# Andriy Zhugayevych azh@ukr.net # Molecular Modeling package # created 2.01.2010 modified - see version below # ################################################################################ #root: MolMod #hfl: MolMod #toc: _Overview MolMod:=module() option package; global kcalmol2eV, kJmol2eV, hartree2eV, GPaAo32eV, icm2eV, ifs2eV, K2eV, # Energy conversion constants bohr2A, e2iA, h2ime, h2imu, mdyniA2eViA2, D2eA, # Other conversion constants UserConfigurationFolder, TemporaryFilesFolder, CurrentDataFolder, # System vaiables FG_simplify, # FiniteGroups package variable MolSearchTable, MolSearchIndex; # Database tables export ModuleLoad, Setup, PrintSpherPolynom, DecodeMethod, DecodeBS, DecodeKgrid, BestProgram, TypeMethod, DecodeFormula, EncodeFormula, DecodeTranslation, DecodeTranslation1, EncodeTranslation, EncodeTranslation1, DecodeState, DecodeFilename, NormalizeCharges, LabelAtoms, SaveTempData, # Auxiliary routines AtomicNumber, ElementSymbol, ElementName, AtomicType, pg2Z, AtomMass, tb_rcov, tb_rion, tb_rvdw, GetASD, # Atomic data tb_solvents, # Molecular data len, angle, dihedral, len2, angle2, dihedral2, Get4th, GetInternals, Int2Cart, Cart2Int, ODR, ReduceLattice2D, ReduceLattice3D, CVP, CVP2, CVPfcc, Atoms2Cell, SuperCell, FoldCells, ConnectAtoms, RemoveAtoms, MolGraph, ChemDistance, Centroid, CooPolyhedra, CooPolyhedron, ClassifyAtoms, atype_mm3, atype_opls, GetTopology, Clusterize, ContactDistance, FragmentMolecule, FragmentPlot, ChangeDihedral, AliphaticDihedrals, Alkane, SortAlkane, OrientBy2Vectors, CanonicOrientation, Superimpose, GuessPermutation, MatchMol, JoinMol, AttachPoints, SymmetrizeCell, SymmetrizeAtoms, UnfoldBySymmetry, SelectAtoms, # Geometry HasTopology, ReadXYZ, WriteXYZ, ReadPDB, WritePDB, ReadGRO, ReadAtomsCube, CombineXYZ, xyz2MV, ReadCIF, WriteCIF, ReadPOSCAR, WritePOSCAR, cryst2M, M2cryst, ReshapeCell, DecodeAxes, DecodeAxes2, cif2xyz, xyz2cif, ReadPAR, WritePAR, IndexPRM, ReadPRM, WritePRM, MergePRM, # Molecular file tools AOangular, AOl, AOt, AOr, AOxyz, AOnormalize, GTOint1, GTOint2, GTOint3, GTOint4, GTOint42, GTOoverlap, GTOoverlap2, GTOreduce, GTOadd, GTOexpand1, GTOexpand3, GTOexpand, Hybrid, shell2LtN, LtN2shell, UnfoldBS, FoldBS, ReadBS, RotationM4AO, TransformMO, WriteMGF, CompressMGF, LocalizeMO, MatchOrbitals, # Wave-function VibrationalModes, MatchVibrations, VibronicCouplings, TransSp, CoarsegrainSp, fTransSp, GenerateES, SingleQMode, SingleQModeFit, MultimerH, MultimerH7, ChemBalance, EnergyBalance, DetermineBandGap, # Quantum chemistry pqrlabel, SPindex, SPDindex, printAO, plotE, plot3Dgrid, plotMol, acolor_azh, acolor_azh2, asize_azh, simplifySVG, CompressEigenvectors, DomainMO, printMO, # Output WriteAtom, WriteMethod, WriteBS, WriteEBS, WriteInput, WriteScript, Run, CleanUp, SubmitJob, DownloadJob, AFMorder, showkgrids, # External programs input WhatProgram, IsNormalTermination, ReadAtoms, ReadOutput, ReadExcStates, ReadVibrations, ReadNBO, LoadMO, CorrectSymmetryOrientation, OptimCurve, GetTiming, ReadDump, WriteDump, ReadAUX, CompressAUX, ReadRawMatrixElement, ReadDOS, getv, getvlbl, # External programs output MaterialsData, MaterialsTable, MaterialsIndex, IdentifyMolecule, MolFingerprint, MolSearchInit, EOSfit, # Materials ReadFockM; # Undocumented procedures local version, requiredsetupversion, tmpfld, eu, eunit, gu, gunit, # Units and their names datalookup, datainifile, bmfld, # Database fwidth, digits, xyzdigits, pdbdigits, qdigits, # Formatting output xprm, xgbs, xinp, xout, xevl, xevla, xevlb, xevc, xevca, xevcb, xrho, xrhoa, xrhob, xs1e, xh1e, # File extensions basisset, time,time9, mem,mem9, tvsymbol,tvsymbol9, tvzero,tvzero9, # default settings tin_xinp, tin_xinp2, tin_exe, tin_path, tin_bin, tin_fld, tin_pbs, tin_res, # TINKER variables lam_xinp, lam_xinp2, lam_exe, lam_path, lam_fld, lam_pbs, lam_res, lam_xdump, # LAMMPS variables mop_xinp, mop_exe, mop_path, mop_res, mop_fld, mop_pbs, mop_aoorder, mop_aoindex, # MOPAC variables fly_xinp, fly_exe, fly_path, fly_readdump, fly_dirscf, # Firefly variables gau_xinp, gau_exe, gau_path, gau_res, gau_fld, gau_pbs, gau_readdump, # Gaussian variables vas_xinp, vas_path, vas_fld, vas_pbs, vas_scfmet, vas_LREAL, vas_NCORE, # VASP variables Zmax, AtomicTypeL, AtomicTypeM, # Atomic data knownsolvents, solventindices, # Molecular data Ls2Ld, Ld2Ls, lmax, mmax, pqr, ROI, R2TL, trig2monom, monomfactor, # Spherical harmonics SingleQMode4Fit, # Quantum chemistry knownbasissets, knownDFT, knownpostHF, knowncomposite, knownabinitio, knownsemiemp, knownmolmech, knownprefixes, knownsuffixes, # Known methods tb_bss, # additional basis sets mid2, # indexing AOs i,s,v,V,L; # auxiliary variables ModuleLoad:=proc() local l,u,t,R,ps,ips,V,T,p,m,i,j,ls,x,o,o2,p1,p2,e,v,f, g,L; version:=20231205; requiredsetupversion:=20220715; # BasicTools and FiniteGroups packages are required, SSH is optional if not(member('BasicTools',packages())) then try with(BasicTools) catch: error "Cannot find the required BasicTools package: %1",lastexception end end; if ( BasicTools[Setup]('version')<20181211) then WARNING("Update BasicTools package to version from 11.12.2018 at least") end; if ( SSH[Setup]('version')<20190120) then WARNING("Update SSH package to version from 20.01.2019 at least") end; if (FiniteGroups[Setup]('version')<20221209) then WARNING("Update FiniteGroups package to version from 9.12.2022 at least") end; FG_simplify:=simplify;#x->x; FiniteGroups[setfloorfast](); # Temporary files folder if type(TemporaryFilesFolder,string) then tmpfld:=TemporaryFilesFolder else v:=getenv("TEMP"); if type(v,string) then tmpfld:=SimplifyPath(cat(v,"/")) else tmpfld:="" end end; # Constants unprotect('kcalmol2eV,kJmol2eV,hartree2eV,GPaAo32eV,icm2eV,K2eV,bohr2A,e2iA,h2ime,mdyniA2eViA2,D2eA'); kcalmol2eV:=simplify(Unit('kcal/eV'))/BasicTools[GetConstantSU]('N[A]',value); kJmol2eV:=simplify(Unit('kJ/eV'))/BasicTools[GetConstantSU]('N[A]',value); hartree2eV:=simplify(Unit('hartree/eV')); GPaAo32eV:=simplify(Unit('GPa*Ao^3/eV')); icm2eV:=evalf(2*Pi*BasicTools[GetConstantSU]('hbar',value)*BasicTools[GetConstantSU]('c',value)*Unit('erg/eV')); ifs2eV:=evalf(2*Pi*BasicTools[GetConstantSU]('hbar',value)*Unit('erg/eV')*1e15); # this means period or cyclic frequency not angular frequency K2eV:=op(1,simplify(GetConstantSU('k')/Unit('eV'))); bohr2A:=simplify(Unit('bohr/Ao')); e2iA:=BasicTools[GetConstantSU]('e',value,esu)^2/op(1,simplify(Unit('eV')))*1e8; h2ime:=GetConstantSU('hbar',value)^2/GetConstantSU('m[e]',value)*simplify(Unit('erg*cm^2/eV/Ao^2')); h2imu:=GetConstantSU('hbar',value)^2/GetConstantSU('m[u]',value)*simplify(Unit('erg*cm^2/eV/Ao^2')); mdyniA2eViA2:=simplify(1e-11*Unit('erg/eV')); D2eA:=simplify(Unit('debye/esu/Ao')/BasicTools[GetConstantSU]('e',value,esu),'esu'); protect('kcalmol2eV,kJmol2eV,hartree2eV,GPaAo32eV,icm2eV,K2eV,bohr2A,e2iA,h2ime,mdyniA2eViA2,D2eA'); # Atomic data Zmax:=nops(ElementSymbol); AtomicTypeL:="pgLBbvcC"; AtomicTypeL:=table([seq(AtomicTypeL[i]=i,i=1..length(AtomicTypeL))]); AtomicTypeM:=[ seq([1,g,"s","1s" , 1,g , 0,"HeII"],g=1..2), seq([2,g,"s","2s2p" , 4,g , 2,"He" ],g=1..2), seq([2,g,"p","2s2p" , 4,g+2, 2,"He" ],g=1..6), seq([3,g,"s","3s3p" , 4,g , 10,"Ne" ],g=1..2), seq([3,g,"p","3s3p" , 4,g+2, 10,"Ne" ],g=1..6), seq([4,g,"s","3d4s4p" , 9,g , 18,"Ar" ],g=1..2), seq([4,g,"d","3d4s4p" , 9,g+2, 18,"Ar" ],g=1..10), seq([4,g,"p","4s4p" , 4,g+2, 28,"ZnII"],g=1..6), seq([5,g,"s","4d5s5p" , 9,g , 36,"Kr" ],g=1..2), seq([5,g,"d","4d5s5p" , 9,g+2, 36,"Kr" ],g=1..10), seq([5,g,"p","5s5p" , 4,g+2, 46,"CdII"],g=1..6), seq([6,g,"s","4f5d6s6p",16,g , 54,"Xe" ],g=1..2), seq([6,g,"f","4f5d6s6p",16,g+2, 54,"Xe" ],g=1..14), seq([6,g,"d","5d6s6p" , 9,g+2, 68,"YbII"],g=1..10), seq([6,g,"p","6s6p" , 4,g+2, 78,"HgII"],g=1..6), seq([7,g,"s","5f6d7s7p",16,g , 86,"Rn" ],g=1..2), seq([7,g,"f","5f6d7s7p",16,g+2, 86,"Rn" ],g=1..14), seq([7,g,"d","6d7s7p" , 9,g+2,100,"NoII"],g=1..10), seq([7,g,"p","7s7p" , 4,g+2,110,"CnII"],g=1..6)]; AtomicTypeM:=Matrix(nops(AtomicTypeM),nops(AtomicTypeM[1]),(Z,i)->AtomicTypeM[Z][i]); # Molecular data knownsolvents:=Sort(convert(map2(op,1,{indices(tb_solvents)}),list),v->tb_solvents[v,"e0"]); solventindices:=sort(convert(map2(op,2,{indices(tb_solvents)}),list)); # Recognized shells Ld2Ls:=table([seq(L="SPDFGH"[L+1],L=0..5),-1="SP"]); Ls2Ld:=table([seq(Ld2Ls[v]=v,v=indices(Ld2Ls,nolist)),"L"=-1]); # Spherical monomials indexing lmax:=4; mmax:=table(): for l from 0 to lmax do mmax[l]:=(l+1)*(l+2)/2 end: pqr:=table([ # Jmol ordering (0,0)=[0,0,0], (0,1)=[0,0,0], (1,1)=[1,0,0], (1,2)=[0,1,0], (1,3)=[0,0,1], (2,1)=[2,0,0], (2,2)=[0,2,0], (2,3)=[0,0,2], (2,4)=[1,1,0], (2,5)=[1,0,1], (2,6)=[0,1,1], (3,1)=[3,0,0], (3,2)=[0,3,0], (3,3)=[0,0,3], (3,4)=[1,2,0], (3,5)=[2,1,0], (3,6)=[2,0,1], (3,7)=[1,0,2], (3,8)=[0,1,2], (3,9)=[0,2,1], (3,10)=[1,1,1], (4,1)=[4,0,0], (4,2)=[0,4,0], (4,3)=[0,0,4], (4,4)=[1,3,0], (4,5)=[3,1,0], (4,6)=[3,0,1], (4,7)=[1,0,3], (4,8)=[0,1,3], (4,9)=[0,3,1], (4,10)=[2,2,0], (4,11)=[2,0,2], (4,12)=[0,2,2], (4,13)=[1,1,2], (4,14)=[1,2,1], (4,15)=[2,1,1], NULL]); # Spherical monomials matrix elements unassign('u,t'); ROI:=table([(0,0)=1]); for p1 from 0 to lmax-1 do ROI[p1+1,0]:=simplify(diff(ROI[p1,0],u)-2*u*ROI[p1,0]+p1*(1+t)*ROI[p1-1,0])/2 end: for p1 from 0 to lmax do for p2 from 0 to lmax-1 do ROI[p1,p2+1]:=simplify(-diff(ROI[p1,p2],u)+2*u*ROI[p1,p2]+p2*(1+1/t)*ROI[p1,p2-1])/2 end end: for e in indices(ROI) do ROI[op(e)]:=unapply(ROI[op(e)],u,t) end: # Spherical monomials rotations unassign('R,x'); R2TL:=table(); for l from 0 to lmax do ps:=[seq(pqr[l,m],m=1..mmax[l])]; ips:=table([seq(pqr[l,m]=m,m=1..mmax[l])]); V:=Vector(mmax[l],m->sqrt(mul(mul(p2+1/2,p2=0..p1-1),p1=ps[m]))); T:=Matrix(mmax[l]); for p in ps do i:=ips[p]; ls:=coeffs2(mul(add(R[o2,o]*x[o2],o2=1..3)^p[o],o=1..3),[x[1],x[2],x[3]]); for v in ls do j:=ips[v[..3]]; T[j,i]:=v[-1]*V[j]/V[i] end end; R2TL[l]:=unapply(T,'R') end; # Transformation matrix between trig and monomial basis trig2monom:=table([ 1=Matrix(3,{(3,1)=1,(1,2)=1,(2,3)=1}), 2=Matrix(6,5,{(1,1)=-1/2,(1,4)=sqrt(3)/2,(2,1)=-1/2,(2,4)=-sqrt(3)/2,(3,1)=1,(4,5)=1,(5,2)=1,(6,3)=1}), #previously (4,5)=-1 3=map(v->signum(v)*sqrt(abs(v)),Matrix(10,7,{(1,2)=-3/8,(1,6)=5/8,(2,3)=-3/8,(2,7)=-5/8,(3,1)=1,(4,2)=-3/40,(4,6)=-9/8,(5,3)=-3/40,(5,7)=9/8,(6,1)=-9/20,(6,4)=3/4,(7,2)=6/5,(8,3)=6/5,(9,1)=-9/20,(9,4)=-3/4,(10,5)=1})), 4=map(v->signum(v)*sqrt(abs(v)),Matrix(15,9,{(1,1)=9/64,(1,4)=-5/16,(1,8)=35/64,(2,1)=9/64,(2,4)=5/16,(2,8)=35/64,(3,1)=1,(4,5)=-5/28,(4,9)=-5/4,(5,5)=-5/28,(5,9)=5/4,(6,2)=-45/56,(6,6)=5/8,(7,2)=10/7,(8,3)=10/7,(9,3)=-45/56,(9,7)=-5/8,(10,1)=27/560,(10,8)=-27/16,(11,1)=-27/35,(11,4)=27/28,(12,1)=-27/35,(12,4)=-27/28,(13,5)=9/7,(14,2)=-9/56,(14,6)=-9/8,(15,3)=-9/56,(15,7)=9/8})), NULL]); # Known methods knownbasissets:=["a","c","dg","h","l","p","s","nc","us","paw"]; knownDFT:=["HF","LDA","LDA-U","GGA","GGA-U","PBE","PBE0","B3LYP","CAM-B3LYP","HSE06","LC-WPBE","WB97X","WB97XD","M062X","APF","APFD","PW6B95","PW6B95D3","SCAN","R2SCAN","VDW-DF2"]; knownpostHF:=["MP2","MP3","MP4","MP4-SDQ","CIS","CID","CISD","QCISD","CI2","CI3","CI4","CCD","CCSD","CCSD-T","B2PLYP"]; knowncomposite:=["G2","G3","G4","CBS-QB3","W1BD"]; knownabinitio:=[op(knownDFT),op(knownpostHF),op(knowncomposite)]; knownsemiemp:=["PM7","PM6","PM6-DH+","PM6-DH2","AM1","PM3","MNDO","PDDG","ZINDO"]; knownmolmech:=["MM","MM3","MM3-","EIM","COMB","COMB3","OPLS","EEP"]; knownprefixes:=["R","U"]; knownsuffixes:=["D3","D4","MBD"]; # Additional basis sets tb_bss:=table([ # Polarization orbitals for LANL2DZ basis set, EMSL LANL2DZdp ECP Polarization, C E Check et al, J Phys Chem A 105, 8111 (2001) ( 1,"l2p","l2")=[[0,[[0.0498,1]]],[1,[[0.356,1]]]], ( 6,"l2p","l2")=[[1,[[0.0311,1]]],[2,[[0.587,1]]]], ( 7,"l2p","l2")=[[1,[[0.0533,1]]],[2,[[0.736,1]]]], ( 8,"l2p","l2")=[[1,[[0.0673,1]]],[2,[[0.961,1]]]], ( 9,"l2p","l2")=[[1,[[0.0737,1]]],[2,[[1.577,1]]]], (14,"l2p","l2")=[[1,[[0.0237,1]]],[2,[[0.296,1]]]], (15,"l2p","l2")=[[1,[[0.0298,1]]],[2,[[0.364,1]]]], (16,"l2p","l2")=[[1,[[0.0347,1]]],[2,[[0.496,1]]]], (17,"l2p","l2")=[[1,[[0.0467,1]]],[2,[[0.648,1]]]], (32,"l2p","l2")=[[1,[[0.0209,1]]],[2,[[0.246,1]]]], (33,"l2p","l2")=[[1,[[0.0263,1]]],[2,[[0.286,1]]]], (34,"l2p","l2")=[[1,[[0.0328,1]]],[2,[[0.363,1]]]], (35,"l2p","l2")=[[1,[[0.0376,1]]],[2,[[0.434,1]]]], (50,"l2p","l2")=[[1,[[0.0174,1]]],[2,[[0.186,1]]]], (51,"l2p","l2")=[[1,[[0.0220,1]]],[2,[[0.207,1]]]], (52,"l2p","l2")=[[1,[[0.0274,1]]],[2,[[0.250,1]]]], (53,"l2p","l2")=[[1,[[0.0308,1]]],[2,[[0.294,1]]]], (82,"l2p","l2")=[[1,[[0.0168,1]]],[2,[[0.179,1]]]], (83,"l2p","l2")=[[1,[[0.0204,1]]],[2,[[0.192,1]]]], NULL]); # Default settings f:=cat(UserConfigurationFolder,"MolMod_Setup.ini"); if FileTools[Exists](f) then read f else WARNING("MolMod_Setup.ini is not found in UserConfigurationFolder=%1",UserConfigurationFolder) end; NULL end: #hfl: Setup #toc: _Setup #MolMod[Setup] Setup:=proc({quick::boolean:=false,database::boolean:=false,thisdatalookup::list(string):=[],setupversion::integer:=requiredsetupversion,printout::boolean:=false}) local sq,scan,files,folders,f,maxlen,lsid,e,id,s,listdir,tbid,fld,fmt,l,syss,sys,exts,datfld,bmfld2,ext,p,sysfld,lsf,ls,fn,n,i; if (setupversion<>requiredsetupversion) then WARNING("Setup versions do not match: submitted version %1, required version %2. Update MolMod_Setup.ini",setupversion,requiredsetupversion) end; sq:=ProcessSetupArgs([_rest], ['eunit','gunit','datalookup','datainifile','bmfld','tvsymbol','tvzero','fwidth','digits','xyzdigits','pdbdigits','qdigits', 'xprm','xgbs','xout','xevl','xevla','xevlb','xevc','xevca','xevcb','xrho','xrhoa','xrhob','xs1e','xh1e', 'time','mem', 'tin_xinp','tin_xinp2','tin_exe','tin_path','tin_bin','tin_fld','tin_pbs','tin_res', 'lam_xinp','lam_xinp2','lam_exe','lam_path','lam_fld','lam_pbs','lam_res','lam_xdump', 'mop_xinp','mop_exe','mop_path','mop_res','mop_fld','mop_pbs','mop_aoorder', 'fly_xinp','fly_exe','fly_path','fly_readdump','fly_dirscf', 'gau_xinp','gau_exe','gau_path','gau_res','gau_fld','gau_pbs','gau_readdump', 'vas_xinp','vas_path','vas_fld','vas_pbs','vas_scfmet','vas_LREAL','vas_NCORE'], ['version','Zmax','knownsolvents','solventindices','lmax','pqr','ROI','trig2monom', 'knownbasissets','knownDFT','knownpostHF','knowncomposite','knownabinitio','knownsemiemp','knownmolmech','knownprefixes','knownsuffixes']); if quick then return sq end; eu:=simplify(Unit(parse(eunit)/'eV')); gu:=simplify(Unit(parse(gunit)/'eV/Ao')); xinp:=table(["tin"=tin_xinp,"lam"=lam_xinp,"mop"=mop_xinp,"fly"=fly_xinp,"gau"=gau_xinp,"vas"=vas_xinp]); if (member("tin_bin=",map(v->convert(v,string)[1..8],[_rest])) and not(tin_bin="" or FileTools[Exists](tin_bin))) then WARNING("%1 does not exist. Provide the correct path to tinker/bin folder",tin_bin) end; if (member("lam_exe=",map(v->convert(v,string)[1..8],[_rest])) and not(lam_exe="" or FileTools[Exists](lam_exe))) then WARNING("%1 does not exist. Provide the correct path to LAMMPS executable",lam_exe) end; if (member("mop_exe=",map(v->convert(v,string)[1..8],[_rest])) and not(mop_exe="" or FileTools[Exists](mop_exe))) then WARNING("%1 does not exist. Provide the correct path to MOPAC2012.exe file",mop_exe) end; if (member("fly_exe=",map(v->convert(v,string)[1..8],[_rest])) and not(fly_exe="" or FileTools[Exists](fly_exe))) then WARNING("%1 does not exist. Provide the correct path to firefly.exe file",fly_exe) end; tvsymbol9:=tvsymbol; tvzero9:=tvzero; time9:=time; mem9:=mem; mop_aoindex:=table(): for i from 1 to nops(mop_aoorder) do mop_aoindex[mop_aoorder[i]]:=i end; if printout then printf("Energy conversion constants: kcalmol2eV, kJmol2eV, hartree2eV, GPaAo32eV, icm2eV, ifs2eV, K2eV\n"); printf("Other conversion constants: bohr2A, e2iA, h2ime, h2imu, mdyniA2eViA2, D2eA\n"); printf("Internal constants: Zmax=%d, lmax=%d\n",Zmax,lmax); printf("Internal variables: Ls2Ld, Ld2Ls, mmax, pqr, ROI, trig2monom\n"); printf("Internal parameters: tvsymbol=%s, tvzero=%a\n",tvsymbol9,tvzero9); printf("digits=%d, xyzdigits=%d, pdbdigits=%d, qdigits=%d\n",digits,xyzdigits,pdbdigits,qdigits); printf("Temporary files folder: %s\n",tmpfld); printf("Ordering of d-orbitals: %{c,}s\n",Vector(6,m->(Trim(pqrlabel(pqr[2,m]))))) end; # Initialize database if database then unprotect('MaterialsTable,MaterialsIndex'); scan:=proc(folder) local f,ls,e,d,s; f:=SimplifyPath(cat(folder,"/",datainifile)); if not(FileTools[Exists](f)) then WARNING("Materials Database: Data initialization file does not exist: %1",f); return end; ls:=remove(s->s="",ReadLines(f)); e:=StringTools[Split](ls[1],";"); d:=op(sscanf(e[1],"%d")); if not(type(d,nonnegint)) then WARNING("Materials Database: Wrong depth in %1",folder); return end; if (d>0) then if (nops(e)<3 or nops(e)>6) then WARNING("Materials Database: Wrong format in %1",folder); return end; if not(member(e[2],["n","n_p","p_n"])) then WARNING("Materials Database: Wrong id-format in %1",folder); return end; e:=[op(e),""$(6-nops(e))]; folders:=[op(folders),[SimplifyPath(folder),d,e[2],StringTools[Split](e[3],","),e[4],e[5],StringTools[Split](e[6],",")]] end; for s in ls[2..] do f:=SimplifyPath(cat(folder,"/",s)); if FileTools[Exists](f) then if FileTools[IsDirectory](f) then scan(f) else files:=[op(files),f] end else WARNING("Materials Database: Entry does not exist: %1 in %2",f,folder) end end; NULL end; files,folders:=[],[]; for f in `if`(thisdatalookup=[],datalookup,thisdatalookup) do scan(f) end; if printout then printf("%s\nInitializing Materials Database:\n",cat("-"$44)); maxlen:=max(seq(length(v[1]),v=folders)); printf(" %-*s depth fmt exts special folders excluded\n",maxlen-3,"Folders:"); seq(printf("%-*s %d %-4s %{c,}s %s %s %{c,}s\n",maxlen,op(..3,v),Vector(v[4]),v[5],v[6],Vector(v[7])),v=Sort(folders,[1])); printf(" Files:\n"); seq(printf("%s\n",v),v=sort(files)) end; MaterialsTable:=table(); lsid:=[]; for f in files do read f; lsid:=[op(lsid),seq(lhs(e),e=_data4MaterialsData)]; for e in _data4MaterialsData do id,s:=op(e); if assigned('MaterialsTable[id]') then WARNING("Materials Database: Skipping duplicating record %1 from %2",id,f) else MaterialsTable[id]:=s end end end; listdir:=v->sort(remove(f->f[1]="_",FileTools[ListDirectory](v,'returnonly'=cat("*.",ext)))); tbid:=table(); for e in folders do fld,fmt:=e[1],e[3]; syss:=[Tree2Seq(FoldersTree(fld,e[2]-1))]; l:=length(syss[1]); syss:=remove(member,remove(s->s[1]="_",[seq(s[l+2..],s=syss)]),e[7]); exts,datfld,bmfld2:= e[4], `if`(e[5]="","",cat(e[5],"/")), `if`(e[6]="","",cat(e[6],"/")); for sys in syss do for ext in exts do p:=StringTools[SubstituteAll](sys,"/","_"); sysfld:=SimplifyPath(cat(fld,"/",sys,"/")); lsf:=listdir(sysfld); if (datfld<>"" and FileTools[Exists](cat(sysfld,datfld))) then lsf:=[op(map2(cat,datfld,listdir(cat(sysfld,datfld)))),op(lsf)] end; if (bmfld2<>"" and FileTools[Exists](cat(sysfld,bmfld2))) then ls:=sort(select(f->FileTools[IsDirectory](cat(sysfld,bmfld2,f)) and f[1]<>"_",FileTools[ListDirectory](cat(sysfld,bmfld2)))); lsf:=[op(lsf),seq(op(map2(cat,cat(bmfld2,v,"/"),listdir(cat(sysfld,bmfld2,v)))),v=ls)] end; for f in lsf do fn:=cat(sysfld,f); if (ext="xyz" and SearchText("_md",f)>0 and FileTools[Size](fn)>100000) then next end; n:=StringTools[Substitute](StringTools[Substitute](StringTools[Substitute](f[..-2-length(ext)],datfld,""),bmfld2,""),"/","_"); id:=`if`(p="" or fmt="n",n,`if`(fmt="n_p",cat(n,"_",p),`if`(fmt="p_n",cat(p,"_",n),""))); for i from 2 to infinity while assigned('MaterialsTable[id]') do if (not(FileTools[Exists](MaterialsTable[id])) or ExpandPath(MaterialsTable[id],"n")=ExpandPath(fn,"n")) then id:=cat(id,"_",ext) else if (SearchText(bmfld2,fn)=0) then WARNING("Materials Database: Record %1 already exists for %2",id,fn) end; l:=length(convert(i,string)); id:=`if`(length(id)>4+l and id[-4-l..-1-l]="_rec", cat(id[..-5-l],"_rec",i), cat(id,"_rec2")) end end; MaterialsTable[id]:=fn; tbid[id]:=NULL end end end end: lsid:=[op(lsid),op(sort([indices(tbid,'nolist')]))]; MaterialsIndex:=Classify2(lsid,s->StringTools[Split](s,"_")[1]); protect('MaterialsTable,MaterialsIndex'); if printout then printf("%d entries in MaterialsTable, %d entries in MaterialsIndex\n",nops([indices(MaterialsTable,'nolist')]),nops([indices(MaterialsIndex,'nolist')])) end; end if; # Output sq end: #cat: Auxiliary routines #hfl: PrintSpherPolynom PrintSpherPolynom:=proc() local l,m; for l from 0 to lmax do for m from 1 to mmax[l] do printf("%1d %2d %s\n",l,m,pqrlabel(pqr[l,m])) end end: NULL end: #hfl: DecodeMethod DecodeMethod:=proc(s0::string,altnames::list(string=string):=[],$) local tb,s,i,method,bss,ls,suffix,prefix,typ; tb:=table(altnames); s:=StringTools[Split](s0,"_")[1]; for i from 1 to length(s) do if StringTools[IsLower](s[i]) then break end end; method,bss:=s[..i-1],s[i..]; if (method[..3]="CAS") then return ["",method,bss] end; ls:=StringTools[Split](method,"-"); if (nops(ls)>1 and member(ls[-1],knownsuffixes)) then method,suffix:=StringTools[Join](ls[..-2],"-"),cat("-",ls[-1]) else suffix:="" end; if assigned('tb[method]') then prefix,method:="",tb[method] elif (member(method[1],knownprefixes) and assigned('tb[method[2..]]')) then prefix,method:=method[1],tb[method[2..]] else prefix:=0 end; typ:=`if`(member(method,knownmolmech),1,`if`(member(method,knownsemiemp),2,`if`(member(method,knownabinitio),3,0))); if (typ=0) then if (prefix=0 and member(method[1],knownprefixes)) then prefix,method:=method[1],method[2..]; typ:=`if`(member(method,knownmolmech),1,`if`(member(method,knownsemiemp),2,`if`(member(method,knownabinitio),3,0))) end; if (typ=0) then error("Uknown method in %1",s) end else prefix:="" end; if (typ=1 and prefix<>"") then error("No prefix is allowed for molecular mechanics methods in %1",s) end; [prefix,cat(method,suffix),bss] end: #hfl: DecodeMethod DecodeBS:=proc(s::string,$) local i,family,size,suffix,kgrid; for i from 1 to length(s) while StringTools[IsLower](s[i]) do end; family,suffix:=s[..i-1],s[i..]; if not(member(family,knownbasissets)) then error("Uknown basis set family in %1",s) end; for i from 1 to length(suffix) while StringTools[IsDigit](suffix[i]) do end; size,suffix:=suffix[..i-1],suffix[i..]; i:=SearchText("G",suffix); if (i>0) then suffix,kgrid:=suffix[..i-1],suffix[i..] else kgrid:="" end; size:=parse(size,'statement'); if not(type(size,posint)) then error("Cannot find basis set size in %1",s) end; [family,size,suffix,kgrid] end: #hfl: DecodeMethod DecodeKgrid:=proc(kgrid::string,Atoms::list(list):=[],Cell::{Matrix,list}:=[],{minlen::numeric:=20,maxdev::numeric:=1e-6},$) local s,c,l,ns,n,Tvs,M,nt,lens,tmap,allequal,i,v; if (kgrid="") then return [] end; if not(member(kgrid[1],["G"])) then error("Unrecognized k-grid type in %1",kgrid) end; s:=kgrid[2..]; for c in s do if not(StringTools[IsDigit](c)) then error("Nondigit symbols in %1",kgrid) end end; l:=length(s); if (l=0 or l=5 or l>6) then error("Two little or too many k-points in %1",kgrid) end; ns:=map(parse,[StringTools[LengthSplit](s,`if`(l>3,2,1))]); for n in ns do if (n=0) then error("Zeroes are not allowed in kgrid: %1",kgrid) end end; if type(Cell,Matrix) then M:=Cell elif (Cell=[]) then if (Atoms=[]) then return [kgrid[1],op(ns)] end; Tvs:=select(v[1]=tvsymbol9,Atoms); if (Tvs=[]) then return [] end; M:=Atoms2Cell(Tvs)[2] else M:=cryst2M(Cell) end; nt:=Dim2(M)[2]; lens:=[seq(evalf(sqrt(add(v^2,v=M[..,i]))),i=1..nt)]; tmap:=[seq(`if`(lens[i]>minlen-maxdev and abs(lens[i]-round(lens[i]))maxdev) then allequal:=false; break end end; if (nops(ns)>nt) then error("Number of translations vectors, nt=%1, is smaller than length of kgrid=%2",nt,kgrid) end; if (nops(ns)"" and member(suf,knownsuffixes)) then met:=met[..-2-length(suf)] end; if member(met,["G2","G3","G4","CBS-QB3","W1BD"]) then "gau" elif member(met,knownabinitio) then bs:=DecodeBS(bss); if (bs[2]<100) then "gau" else "vas" end elif member(met,knownmolmech) then "lam" elif member(met,knownsemiemp) then "mop" else "" end end: #hfl: DecodeMethod TypeMethod:=proc(method::string,t::string,$) local pre,met,bss,suf; pre,met,bss:=op(DecodeMethod(method)); suf:=StringTools[Split](met,"-")[-1]; if (suf<>"" and member(suf,knownsuffixes)) then met:=met[..-2-length(suf)] else suf:="" end; if (t="abinitio") then member(met,knownabinitio) elif (t="semiemp") then member(met,knownsemiemp) elif (t="molmech") then member(met,knownmolmech) elif (t="DFT-D") then member(suf,knownsuffixes) elif (t="DFT") then member(met,knownDFT) elif (t="postHF") then member(met,knownpostHF) elif (t="composite") then member(met,knowncomposite) elif (t="lam") then evalb(BestProgram(method)="lam") elif (t="mop") then evalb(BestProgram(method)="mop") elif (t="gau") then evalb(BestProgram(method)="gau") elif (t="vas") then evalb(BestProgram(method)="vas") else error("Unrecognized method type: %1",t) end end: #hfl: DecodeFormula DecodeFormula:=(s::string)->map(v->[v[1],`if`(v[2]="",1,parse(v[2]))],map(u->[StringTools[SelectRemove](not(StringTools[IsDigit]),u)],[StringTools[CaseSplit](StringTools[Split](s,"_")[1])])): #hfl: DecodeFormula EncodeFormula:=proc(ls0::{list(string),list(list)},sortf::procedure:=sort,$) local ls,tb,id; if (ls0=[]) then return "" end; if type(ls0,list([string,integer])) then ls:=ls0 else ls:=remove(`=`,`if`(type(ls0,list(string)),ls0,map2(op,1,ls0)),tvsymbol9); tb:=Classify2(ls,v->v); id:=sortf([indices(tb,nolist)]); ls:=[seq([v,nops(tb[v])],v=id)] end; cat(seq(cat(v[1],`if`(v[2]=1,"",v[2])),v=ls)) end: #hfl: DecodeTranslation DecodeTranslation:=(s::string)->map(DecodeTranslation1,StringTools[Split](s,"+")): DecodeTranslation1:=proc(s::string,$) local f,L,m,v,i,j,k,c; f:=proc(c,n) if (c="a") then i:=i+n elif (c="b") then j:=j+n elif (c="c") then k:=k+n elif (c="i") then i:=i-n elif (c="j") then j:=j-n elif (c="k") then k:=k-n else error("Unrecognized symbol '%1' in '%2'",c,s) end end; L:=[StringTools[Group](StringTools[IsDigit],s)]; if not(StringTools[IsDigit](L[1])) then error("Unrecognized prefix in '%1'",s) end; m:=op(sscanf(L[1],"%d")); i,j,k:=0,0,0; L:=L[2..]; if (L<>[]) then L:=map(v->`if`(nops(v)=2,[v[1],op(sscanf(v[2],"%d"))],[v[1],1]),[ListTools[LengthSplit](L,2)]); for v in L do for c in v[1][..-2] do f(c,1) end; f(v[1][-1],v[2]) end end; [m,i,j,k] end: #hfl: DecodeTranslation EncodeTranslation:=proc(mts::{[posint,integer,integer,integer],list([posint,integer,integer,integer])},n::nonnegint:=2,$) if type(mts,listlist) then StringTools[Join](map(EncodeTranslation1,mts,n),"+") else EncodeTranslation1(mts,n) end end: EncodeTranslation1:=proc(mt::[posint,integer,integer,integer],n::nonnegint:=2,$) local f; f:=proc(s,t) local c,r; c:=`if`(t>0,s[1],s[2]); r:=abs(t); `if`(r>n,cat(c,r),cat(c$r)) end; cat("",mt[1],f("ai",mt[2]),f("bj",mt[3]),f("ck",mt[4])) end: #hfl: DecodeState DecodeState:=proc(s0::string,Q0::integer:=0,M0::posint:=1,$) local s,i,nP,nN,Q,M,X,ds; s:=s0; if (s[1]="O") then Q,s:=Q0,s[2..] else for i from 1 to length(s) while (s[i]="P") do end; nP,s:=i-1,s[i..]; for i from 1 to length(s) while (s[i]="N") do end; nN,s:=i-1,s[i..]; if (nP*nN>0) then error("Both P and N are present in state %1",s0) end; Q:=Q0+nP-nN end; X:=0; if (s="" or StringTools[IsDigit](s[1])) then M:=`if`(type(Q-Q0,odd),`if`(M0=1,2,M0-1),M0); ds:=-1 elif (s="R") then M,X,s:=1,1,"" else M:=SearchText(s[1],"SDTQQXX"); if (M=0) then error("Unrecognized spin in state %1",s0) end; ds:=`if`(M>2,-1,0); if (M>3 and type(Q-Q0+M0,odd)) then M:=M+1 end; s:=s[2..] end; if (s<>"") then if StringTools[IsDigit](s) then X:=parse(s)+ds else error("Unrecognized excitation in state %1",s0) end end; if (X<0) then error("Negative excitation in state %1",s0) end; Q,M,X end: #hfl: DecodeFilename DecodeFilename:=proc( f0::string, out::string:="", markers::list(string):=["dat/main.dat","dat","bm","em","bin"], { root::string:=RootDataFolder, defext::string:="xyz", nofile::boolean:=false, ref::string:="dat/", reftag::string:="_old", mainref::string:="dat/main.dat", nowarning::boolean:=false, printout::{boolean,posint}:=false },$) local rfld,fpath,fn,ext,f,fld,fp,path,scores,i,v,sfld,sys,bm,ffn,id, cods,conf,method,pos,mprefix,met,bs,program,cods1,cods2,slv,solvent,solveps,state,tag,css,conf0, r,refs,A0,desc0,refconf,refconfdif,nm0,Q0,M0,X0,SG0,CO0,nt0,na0,formula0,Z0,A,desc,nt,na,formula,Z,nm,Q,M,SG,CO,X,k,o,pd,ps,tb,ls; # decode folders rfld:=SimplifyPath(root); if (rfld<>"" and rfld[-1]<>"/") then rfld:=cat(rfld,"/") end; fpath,fn,ext:=ExpandPath(SimplifyPath(f0),"p,n,x"); ext:=TrimLeft(ext,["."]); if (ext="") then ext:=defext end; if (fpath[..length(rfld)]=rfld) then fpath:=fpath[length(rfld)+1..] end; f:=cat(rfld,fpath,fn,`if`(ext="","",cat(".",ext))); if not(nofile or nowarning or FileTools[Exists](f)) then WARNING("File does not exist: %1",f) end; fld:=cat(rfld,fpath); fp:=cat(fld,fn); path:=remove(`=`,Split(TrimRight(fpath,["/"]),"/"),""); scores:=[seq(add(`if`(FileTools[Exists](StringTools[Join]([rfld,op(..i,path),v],"/")),1,0),v=markers),i=0..nops(path))]; v:=max(scores); for i from nops(path) by -1 to 0 while (scores[i+1]]],cat(sys," atom") else A,desc:=[],"" end; # get reference data from main.dat nm0:=0; Q0,M0,X0,SG0,CO0:=`if`(FileTools[Exists](cat(sfld,mainref)), ReadRecord(cat(sfld,mainref),"Q::integer,M::posint:=1,X::nonnegint:=-1,SG::string,CO::list",'input'="file"), op([0,1,0,"",[]])); if not(conf[..5]="molec" or conf[..7]="cluster") then SG0,CO0:="",[] end; # ignore SG and CO from main.dat for nonmolecular configurations # get reference data from geometry file if (ref<>"" and ref[-1]<>"/") then if FileTools[Exists](cat(sfld,r)) then r:=ref else r:=""; if not(nowarning) then WARNING("Provided reference file does not exist: %1",ref) end end else refs:=ListTools[MakeUnique]([ cat(ref,conf,`if`(state="","","_"),state,".",ext), cat(ref,conf,".",ext), cat(ref,StringTools[Split](conf,"_")[1],".",ext), cat(ref,StringTools[Split](conf,"-")[1],".",ext), cat(ref,TrimRight(StringTools[Split](conf,"-")[1],StringTools[Explode]("1234567890")),".",ext), ""]); for r in refs do if FileTools[Exists](cat(sfld,r)) then break end end end; if (ExpandPath(r,"x")=".xyz") then A0,desc0:=ReadXYZ(cat(sfld,r),'output'=2); if (A<>[] and map2(op,1,A)<>map2(op,1,A0)) then WARNING("Ignored inconsistent reference geometry: %1<>%2",r,ffn); r,A0,desc0,refconf,refconfdif:="",[],"","","" else refconf:=ExpandPath(r,"n"); if (conf[..length(refconf)]=refconf) then refconfdif:=conf[length(refconf)+1..] else refconf,refconfdif:="","" end end else A0,desc0,refconf,refconfdif:=[],"","","" end; if (r<>"") then Q0,M0,X0,SG0,nm0,v:=ReadRecord(`if`(A0=[],cat(sfld,r),desc0), sprintf("Q::integer:=%d,M::posint:=%d,X::nonnegint:=%d,SG::string:=%s,nm::nonnegint:=%d,CO::list",Q0,M0,X0,SG0,nm0),'input'=`if`(A0=[],"file","string")); if (v<>[]) then CO0:=copy(v) end end; # process reference data nt0:=add(`if`(v[1]=tvsymbol9,1,0),v=A0); na0:=nops(A0)-nt0; formula0:=EncodeFormula(A0); Z0:=`if`(conf="atom",AtomicNumber(sys),add(AtomicNumber(v[1]),v=A0)); Q,M,X:=`if`(conf="atom",DecodeState(state,0,Z0+1),DecodeState(state,Q0,M0)); if (X0>=0) then X:=X0 end; # process geometry if (A=[]) then nt,na,nm,formula,SG,CO:=nt0,na0,nm0,formula0,SG0,CO0 else nt:=add(`if`(v[1]=tvsymbol9,1,0),v=A); na:=nops(A)-nt; formula:=EncodeFormula(A); Z:=add(AtomicNumber(v[1]),v=A); if (conf<>"atom" and type(Z+Q0+M0,even)) then Q,M,X:=DecodeState(state,Q0,M0+1) end; Q,M,X,SG,nm,v:=ReadRecord(desc,sprintf("Q::integer:=%d,M::posint:=%d,X::nonnegint:=%d,SG::string:=%s,nm::nonnegint:=%d,CO::list",Q,M,X,SG0,nm0),'input'="string"); CO:=`if`(v=[],CO0,v) end; if (SG="") then SG:=piecewise(nt=0,"1",nt=1,"q1",nt=2,"p1",nt=3,"P1","") end; k,o,solveps:=ReadRecord(desc,"key::string,opts::list,solveps::numeric:=1",'input'="string"); # output if (printout<>false) then pd:=(s,v,v0)->`if`(v=v0,"",sprintf(", %s=%d",s,v)); ps:=(s,v)->`if`(v="","",sprintf(", %s=%s",s,v)); printf("%s: %s, na=%d%s%s%s%s%s%s%s%s\n", id,formula,na,pd("nt",nt,0),pd("Q0",Q0,0),pd("Q",Q,Q0),pd("M0",M0,1),pd("M",M,M0),pd("X",X,0), ps("SG",SG),`if`(CO=[],"",cat(", CO=",StringTools[DeleteSpace](sprintf("%a",CO))))); if (printout=true) then if FileTools[Exists](f) then printf(" file=%s\n",f) end; if (desc<>"") then printf(" desc=%s\n",desc) end; if (r<>"") then printf(" ref=%s, desc0=%s\n",r,desc0) end end end; tb:=[ # important ***** "A"=A, "A0"=A0, "bm"=bm, "bs"=bs, "c"=conf, "c0"=conf0, "CO"=CO, "cods1"=cods1, "cods2"=cods2, "css"=css, "desc"=desc, "desc0"=desc0, "ext"=ext, "f"=f, "ffn"=ffn, "fld"=fld, "fn"=fn, "formula"=formula, "fp"=fp, "id"=id, "k"=k, "M"=M, "M0"=M0, "m"=method, "met"=met, "mprefix"=mprefix, "na"=na, "nm"=nm, "nt"=nt, "o"=o, "p"=program, "Q"=Q, "Q0"=Q0, "ref"=r, "refconf"=refconf, "rfld"=rfld, "S"=state, "SG"=SG, "sfld"=sfld, "slv"=slv, "solvent"=solvent, "solveps"=solveps, "sys"=sys, "tag"=tag, "X"=X, NULL]; if (out="") then tb else tb:=table(tb); ls:=StringTools[Split](out,","); for v in ls do if not(assigned('tb[v]')) then error("Unrecognized data tag: %1",v) end end; seq(tb[v],v=ls) end end: #hfl: NormalizeCharges NormalizeCharges:=proc(lsq::list(numeric),digits::posint,Q::numeric:=0,AT::list:=[$1..nops(lsq)],{printout::boolean:=false,warning::boolean:=false},$) local N,q,Q2,s,n,G,T,n2,dq,t,v,lsi,i; N:=nops(lsq); q:=Vector(N,lsq); Q2:=add(v,v=q); if (abs(Q2-Q)>0.5*10^(-digits)) then s:=sprintf("Charges are changed by %+.*f to match the total charge mismatch dQ=%+.*f",digits+1+round(log10(N)),(Q-Q2)/N,digits,Q-Q2); if warning then WARNING(s) elif printout then printf("%s\n",s) end end; q:=map(u->Round(u+(Q-Q2)/N,digits),q); Q2:=add(v,v=q); if (Q2-Q<>0) then n:=round(abs(Q-Q2)*10^digits); if (n>N) then error("Algorithm error: n=%1>N=%2",n,N) end; s:=sprintf("Round-off extra charge dQ=%+.*f is distributed among %d atoms",digits,Q-Q2,n); if warning then WARNING(s) elif printout then printf("%s\n",s) end; if (nops(AT)<>N) then error("Inconsistent lsq and AT: %1 and %2",lsq,AT) end; G:=Classify2([seq([AT[i],i],i=1..N)],[1]); T:=Sort([indices(G,'nolist')],t->-nops(G[t])); n2,dq:=0,signum(Q-Q2)*10^(-digits); for t in T while (n2n) then next else for v in G[t] do q[v[2]]:=q[v[2]]+dq end; n2:=n2+nops(G[t]) end end; if (n2<>n) then lsi:=[seq(i,i=1..N,ceil(N/abs(n-n2)))]; WARNING("Algorithm error: n2=%1<>n=%2 -- will distribute extra charge between atoms %3",n2,n,lsi); for i in lsi do q[i]:=q[i]+signum(n-n2)*dq end end; Q2:=add(v,v=q); if (Q2-Q<>0) then error("Algorithm error: Q2-Q=%1",Q2-Q) end end; [seq(v,v=q)] end: #hfl: LabelAtoms LabelAtoms:=proc(A::list,$) local enumerate,lsk; enumerate:=v->`if`(nops(v)=1,[[v[1],""]],[seq([v[i],i],i=1..nops(v))]); lsk:=map2(op,2,Sort(map(op@enumerate,[entries(Classify2([$1..nops(A)],i->A[i][1]),nolist)]),[1])); [seq([op(A[i]),cat(A[i][1],lsk[i])],i=1..nops(A))] end: #hfl: SaveTempData SaveTempData:=proc(tag::string,dat::list,fn::string:=TempDataFile,{s::string:=sys,c::string:=conf,m::string:=method,overwrite::boolean:=false},$) local s1,ls,s2,s3,fld,bakfn,bakfn0,lsf,n, f; s1:=sprintf("%s,%s,%s,%s:",s,c,m,tag); ls:=[ListTools[LengthSplit](dat,2)]; s2:=Trim(sprintf("%s %s",s1,StringTools[Join](map(sprintf@op,ls),", "))); if not(FileTools[Exists](fn)) then WriteLines(fn,["\# Temporary data collector",""]) end; s3:=ReadValue(fn,s1,'startofline'); if (s3=NULL or s3[..length(s1)]<>s1) then WriteLines(fn,[s2],'append'); UnloadTextFile(fn) else s3:=Trim(s3); if (s3<>s2) then if overwrite then ls:=map(Trim,ReadLines(fn)); ls:=Substitute(ls,s3,s2); fld:=ExpandPath(fn,"ap"); bakfn:=cat(fn,".bak"); bakfn0:=ExpandPath(bakfn,"nx"); lsf:=FileTools[ListDirectory](fld,'returnonly'=cat(bakfn0,"*")); n:=max(0,seq(parse(f[length(bakfn0)+1..]),f=lsf))+1; FileTools[Rename](fn,cat(bakfn,n)); WriteLines(fn,ls); UnloadTextFile(fn) else WARNING("Data exist and differ. Compare old vs new:"); printf("%s\n%s\n",s3,s2) end end end; s2 end: ################################################################################ #cat: Atomic data #hfl: AtomicNumber AtomicNumber:=proc(element,{notag::boolean:=false},$) local i,s; if (type(element,posint) and element<=Zmax) then element elif type(element,string) then if notag then s:=element else for i from 2 to length(element) while StringTools[IsLower](element[i]) do end; s:=element[1..i-1] end; try op(1,[ScientificConstants[GetElement](convert(s,symbol),name)]) catch: 0 end else error("Unrecognized element, %1",element) end end: #hfl: AtomicNumber ElementSymbol:=[seq(sprintf("%s",Trim(convert(rhs(op(2,[ScientificConstants[GetElement](v,symbol)])),string))),v=1..112)]: #hfl: AtomicNumber ElementName:=[seq(sprintf("%s",convert(rhs(op(2,[ScientificConstants[GetElement](v,name)])),string)),v=1..nops(ElementSymbol))]: #hfl: AtomicType AtomicType:=proc(element,output::string,$) local Z,lsi,c,i; Z:=AtomicNumber(element); if (Z<1 or Z>Zmax) then error("Unrecognized element, %1",element) end; lsi:=[seq(AtomicTypeL[c],c=output)]; for i in lsi do if not(type(i,integer)) then error("Unrecognized label %1 in %2",i,output) end end; seq(AtomicTypeM[Z,i],i=lsi) end: #hfl: AtomicType pg2Z:=proc(p::posint,g::posint,$) if (g>8) then error "Group number cannot exceed 8, but received %1",g end; if (p=1) then if (g>2) then error "Group number for 1st period cannot exceed 2, but received %1",g else g end elif (p=2) then g+2 elif (p=3) then g+10 elif (p=4) then g+`if`(g>2,28,18) elif (p=5) then g+`if`(g>2,46,36) elif (p=6) then g+`if`(g>2,78,54) else "Unrecognized period, %1",p end end: #hfl: AtomMass AtomMass:=proc(element,isotope::integer:=-1,{minabundance::numeric:=0.24},$) local Z,v,ls,iso; if (element="D") then return AtomMass("H",2) end; Z:=AtomicNumber(element); if (isotope<0) then rhs(rhs([ScientificConstants[GetElement](Z,'atomicweight')][2])[1]) elif (isotope>0) then v:=rhs([ScientificConstants[GetElement]([Z,isotope],'atomicmass')][2]); rhs(v[1])*Unit(rhs(v[3])/'amu') else ls:=[ScientificConstants[GetIsotopes](':-element'=Z,'abundance','output=atomicnumbers')]; iso:=ls[op(MaxIdx(ls,v->rhs(rhs([ScientificConstants[GetElement](v,'abundance')][2])[1])))]; v:=rhs(rhs([ScientificConstants[GetElement](iso,'abundance')][2])[1]); if (v0) then error("Error in connecting to ASD: %1, %2",op(ans)) end; dat1:=ImportMatrix(cat(f,".csv"),'source'='csv',datatype=string); nd1,nc1:=Dim2(dat1); nd1:=nd1-1; lbls:=dat1[1,..]; if not(nc1>=5 and lbls[1]="Configuration" and lbls[2]="Term" and lbls[3]="J" and lbls[4]="Level (eV)") then WARNING("Unrecognized data: %1 x %2 %3",nd1,nc1,convert(lbls,list)) end; dat1:=map(s->`if`(s="",s,Trim(s[3..-2])),dat1[2..,..]); dat:=table(): for i from 1 to nd1 do T:=dat1[i,2]; if (T="" or T="Limit") then M,L:=99,"?" else ML:=Split(T," ")[-1]; try M:=parse(ML[1]); if not(type(M,posint)) then M:=99 end catch: M:=99 end; L:=ML[2]; if (SearchText(T[-1],"SPDFGHIJKLMN")>0) then T:=cat(T," ") end end; try Js:=[parse(dat1[i,3])]; if Js=[] then Js:=[99/2] end catch: Js:=[99/2] end; E:=dat1[i,4]; if (E[1]="[") then E:=E[2..] end; if (E="") then E:=undefined else E:=sscanf(E,"%f"); if (E=[]) then E:=undefined else E:=E[1] end end; for J in Js do if not(type(J,rational)) then J:=99/2 end; dat[i*100+2*J]:=[E,M,L,2*J,T,dat1[i,1],dat1[i,5]] end end; dat:=convert(dat,list): nd:=nops(dat); if pout then dat2:=dat[..min(maxlines,nd)]; dat3:=select(v->v[5]="Limit",dat); dat3:=dat3[..min(iquo(maxlines,2),nops(dat3))]; maxlen5,maxlen6:=seq(max(map(length,map2(op,j,[op(dat2),op(dat3)]))),j=5..6); printf(" E(eV)%*sM L 2J %*s conf\n",digits-1,"",maxlen5,"term"); seq(printf("%*.*f%3d%3s%3d %*s %-*s %s\n",3+digits,digits,op(..4,v),maxlen5,v[5],maxlen6,v[6],v[7]),v=dat2); printf("%s\n",cat("."$44)); seq(printf("%*.*f%3d%3s%3d %*s %-*s %s\n",3+digits,digits,op(..4,v),maxlen5,v[5],maxlen6,v[6],v[7]),v=dat3) end; dat end: ################################################################################ #cat: Molecular data #hfl: MolecularData tb_solvents:=table(): # 1st two epsilons are taken from Gaussian http://gaussian.com/scrf/?tabid=7 # 2nd two epsilons and ETN are taken from Table A-1 [Reichardt11], here refractive index is taken at Na D-line 589nm # pi* is taken from Table 7-4 [Reichard11] and [Laurence94] V:= ["solv","file" ,"formula" ,"name_G" , "e0_G" , "ei_G" , "e0" , "ei" ,"ETN","pi*" ]: L:=[ ["pcm" ,"" ,"" ,"" , 1 , 1 , 1 , 1 ,0 , 0 ], ["vac" ,"" ,"" ,"" , 1 , 1 , 1 , 1 ,-.111,-1.23 ], ["hpt" ,"heptane" ,"C7H16" ,"heptane" , 1.9113, 1.925989, 1.92, 1.3876^2, .012,-0.06 ], ["ben" ,"benzene" ,"C6H6" ,"benzene" , 2.2706, 2.253301, 2.27, 1.5011^2, .111, 0.55 ], ["tol" ,"toluene" ,"C6H5CH3" ,"toluene" , 2.3741, 2.238315, 2.38, 1.4969^2, .099, 0.49 ], ["tce" ,"ethyleneCl3" ,"C2HCl3" ,"trichloroethene" , 3.422 , 2.182415, 3.42, 1.4773^2, .160, 0.48 ], ["clf" ,"chloroform" ,"CHCl3" ,"chloroform" , 4.7113, 2.090627, 4.89, 1.4459^2, .259, 0.69 ], ["clb" ,"benzeneCl" ,"C6H5Cl" ,"chlorobenzene" , 5.6968, 2.322881, 5.62, 1.5248^2, .188, 0.68 ], ["thf" ,"THF" ,"C4H8O" ,"tetrahydrofuran" , 7.4257, 1.974025, 7.58, 1.4072^2, .207, 0.55 ], ["dcm" ,"DCM" ,"CH2Cl2" ,"dichloromethane" , 8.93 , 2.028346, 8.93, 1.4242^2, .309, 0.73 ], ["dclb","benzeneCl2" ,"C6H4Cl2" ,"o-dichlorobenzene", 9.9949, 2.407152, 9.93, 1.5515^2, .225, 0.77 ], ["eth" ,"ethanol" ,"C2H5OH" ,"ethanol" , 24.852 , 1.852593, 24.55, 1.3614^2, .654, 0.54 ], ["acn" ,"acetonitrile" ,"CH3CN" ,"acetonitrile" , 35.688 , 1.806874, 35.94, 1.3441^2, .460, 0.66 ], ["dmso","DMSO" ,"SO(CH3)2","dimethylsulfoxide", 46.826 , 2.007889, 46.45, 1.4793^2, .444, 1 ], ["wat" ,"water" ,"H2O" ,"water" , 78.3553, 1.777849, 78.36, 1.3330^2,1 , 1.09 ], NULL]: for v in L do for i from 2 to nops(v) do tb_solvents[v[1],V[i]]:=v[i] end end: ################################################################################ #cat: Geometry #hfl: len len:=proc(p1,p2:=0,$) if (p2=0) then if hastype(p1,float) then evalf(sqrt(add(v^2,v=p1))) else simplify(abs(sqrt(add(v^2,v=p1))),symbolic) end else len(p1-p2) end end: #hfl: len angle:=proc(p1,p2,p3:=0,{radians::boolean:=false},$) local e,s; if (p3=0) then e:=add(p1[i]*p2[i],i=1..Dim2(p1))/len(p1)/len(p2); if (hastype(p1,float) or hastype(p2,float)) then if (evalf(1-abs(e))>1e-8) then evalf(arccos(e)*`if`(radians,1,180/Pi)) elif (e=1) then 0. elif (e=-1) then evalf(`if`(radians,Pi,180)) else s:=signum(evalf(e)); e:=evalf(2*arcsin(0.5*len(p1/len(p1)-s*p2/len(p2)))); if (s<0) then e:=Pi-e end; evalf(e*`if`(radians,1,180/Pi)) end else simplify(arccos(e)*`if`(radians,1,180/Pi),symbolic) end else angle(p1-p2,p3-p2,_options) end end: #hfl: len dihedral:=proc(p1,p2,p3,p4:=0,{radians::boolean:=false,ref::realcons:=0},$) local e; if (p4=0) then e:=LinearAlgebra[CrossProduct](p2,p3); e:=arctan(len(p2)*p1.e,LinearAlgebra[CrossProduct](p1,p2).e)*`if`(radians,1,180/Pi); if (hastype(p1,float) or hastype(p2,float) or hastype(p3,float)) then e:=evalf(e); if (eevalhf(P[i+1,o]-P[i,o]),datatype=float); evalhf(arccos(-add(B[1,o]*B[2,o],o=1..3)/sqrt(add(B[1,o]^2,o=1..3)*add(B[2,o]^2,o=1..3)))*`if`(radians,1,180/Pi)) end: #hfl: len dihedral2:=proc(P,{radians::boolean:=false,ref::realcons:=0},$) local B,p,q,e,o; B:=Matrix(3,(i,o)->evalhf(P[i+1,o]-P[i,o]),datatype=float); p:=Vector(3,datatype=float); p[1]:=evalhf(B[1,2]*B[2,3]-B[1,3]*B[2,2]); p[2]:=evalhf(B[1,3]*B[2,1]-B[1,1]*B[2,3]); p[3]:=evalhf(B[1,1]*B[2,2]-B[1,2]*B[2,1]); q:=Vector(3,datatype=float); q[1]:=evalhf(B[2,2]*B[3,3]-B[2,3]*B[3,2]); q[2]:=evalhf(B[2,3]*B[3,1]-B[2,1]*B[3,3]); q[3]:=evalhf(B[2,1]*B[3,2]-B[2,2]*B[3,1]); e:=evalhf(arctan(sqrt(add(B[2,o]^2,o=1..3))*add(B[1,o]*q[o],o=1..3),add(p[o]*q[o],o=1..3))*`if`(radians,1,180/Pi)); if (e, r:=0, p2::Vector(3):=p3-<1,0,0>, theta:=180, p1::Vector(3):=p2+<0,1,0>, phi:=0, {radians::boolean:=false,convention::string:="MOPAC"},$)::Vector(3); local t,p,ex,ey,ez,p4; if radians then t,p:=theta,-phi else t,p:=theta*Pi/180,-phi*Pi/180 end; ez:=LinearAlgebra[Normalize](p2-p3,2): ey:=LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](ez,p1-p2),2): ex:=LinearAlgebra[CrossProduct](ey,ez): p4:=p3+r*sin(t)*cos(p)*ex+r*sin(t)*sin(p)*ey+r*cos(t)*ez; `if`(hastype(p4,float),evalf(p4),p4) end: #hfl: Get4th GetInternals:=proc(p4::Vector(3),p3::Vector(3),p2::Vector(3),p1::Vector(3),{radians::boolean:=false,convention::string:="MOPAC"},$) local v1,v2,v3; v1,v2,v3:=p2-p1,p3-p2,p4-p3; len(v3),angle(v3,-v2,':-radians'=radians),dihedral(v1,v2,v3,':-radians'=radians) end: #hfl: Int2Cart Int2Cart:=proc(Atoms::list,$) local n,Atoms2,i; n:=nops(Atoms); Atoms2:=Vector(n): Atoms2[1]:=`if`(nops(Atoms[1])>1 and type(Atoms[1][2],Vector), Atoms[1], [Atoms[1][1],Get4th()]); if (n>1) then Atoms2[2]:=`if`(type(Atoms[2][2],Vector), Atoms[2], [Atoms[2][1],Get4th(Atoms2[Atoms[2][2][1]][2],Atoms[2][2][2])]); if (n>2) then Atoms2[3]:=`if`(type(Atoms[3][2],Vector), Atoms[3], [Atoms[3][1],Get4th(Atoms2[Atoms[3][2][1]][2],Atoms[3][2][2],Atoms2[Atoms[3][2][3]][2],Atoms[3][2][4])]); for i from 4 to nops(Atoms) do Atoms2[i]:=`if`(type(Atoms[i][2],Vector), Atoms[i], [Atoms[i][1],Get4th(Atoms2[Atoms[i][2][1]][2],Atoms[i][2][2],Atoms2[Atoms[i][2][3]][2],Atoms[i][2][4],Atoms2[Atoms[i][2][5]][2],Atoms[i][2][6])]) end; end end; convert(Atoms2,list) end: #hfl: Int2Cart Cart2Int:=proc(Atoms::list,lsijk::list:=[seq([i-1,i-2,i-3],i=1..nops(Atoms))],$) local n,tb,Atoms2,i,j; n:=nops(Atoms); tb:=`if`(nops(lsijk)=n,table([seq(i=lsijk[i],i=1..n)]),table(lsijk)); Atoms2:=Vector(n): Atoms2[1]:=`if`(assigned('tb[1]'), [Atoms[1][1],[]], Atoms[1]); if (n>1) then Atoms2[2]:=`if`(assigned('tb[2]'), [Atoms[2][1],[1,len(Atoms[2][2]-Atoms[1][2])]], Atoms[2]); if (n>2) then Atoms2[3]:=`if`(assigned('tb[3]'), [Atoms[3][1],[tb[3][1],len(Atoms[3][2]-Atoms[tb[3][1]][2]),tb[3][2],angle(Atoms[3][2]-Atoms[tb[3][1]][2],Atoms[tb[3][2]][2]-Atoms[tb[3][1]][2])]], Atoms[3]); for i from 4 to nops(Atoms) do Atoms2[i]:=`if`(assigned('tb[i]'), [Atoms[i][1],ListTools[Interleave](tb[i],[GetInternals(Atoms[i][2],seq(Atoms[j][2],j=tb[i]))])], Atoms[i]) end; end end; convert(Atoms2,list) end: #hfl: ODR ODR:=proc(Atoms::list,code::{"line","plane"},$) local P,n,R,ls,ev,evc,i,v,u; P:=`if`(type(Atoms[1],list),map2(op,2,Atoms),Atoms); n:=Dim2(P[1]); if not(nops([n])=1 and type(n,posint)) then error("Unrecognized coordinates, %1",P[1]) end; R:=add(v,v=P)/nops(P); ls:=[seq(v-R,v=P)]; ev,evc:=LinearAlgebra[Eigenvectors](Matrix(n,(i,j)->add(v[i]*v[j],v=ls),datatype=float,shape=symmetric)); for i from 1 to n do if (ev[i]<0) then if (ev[i]>-10^(2-Digits)) then ev[i]:=0 else error("Negative eigenvalue, %1",ev[i]) end end end; if (code="line") then sqrt((add(add(u^2,u=v),v=ls)-ev[n])/nops(P)),evc[..,n],R else sqrt(ev[1]/nops(P)),evc[..,1],R end end: #hfl: ReduceLattice ReduceLattice2D:=proc(V10::Vector,V20::Vector,s10::numeric:=0,s20::numeric:=0,$) #s10<=s20 local s1,s2,V1,V2; if (s10=0) then s1,s2:=add(v^2,v=V10),add(v^2,v=V20); if (s1>s2) then s1,V1,V2:=s2,V20,V10 else V1,V2:=V10,V20 end else V1,V2,s1,s2:=V10,V20,s10,s20 end; V2:=V2-round((V1.V2)/s1)*V1; s2:=add(v^2,v=V2); if (s1>s2) then ReduceLattice2D(V2,V1,s2,s1) else V1,V2 end end: #hfl: ReduceLattice ReduceLattice3D:=proc(M::{Matrix,[Vector,Vector,Vector]},tol::numeric:=1.001,{keeporientation::boolean:=false},$) local V1,V2,V3,ls1,s1,s2,s3,V,s,i,ls2,i1,i2,j; V1,V2,V3:=`if`(type(M,Matrix),seq(M[..,i],i=1..3),op(M)); if keeporientation then ls1:=[V1,V2,V3] end; do s1,s2,s3:=add(v^2,v=V1),add(v^2,v=V2),add(v^2,v=V3); if (2*abs(V1.V2)>min(s1,s2)*tol) then V1,V2:=ReduceLattice2D(V1,V2); next end; if (2*abs(V2.V3)>min(s2,s3)*tol) then V2,V3:=ReduceLattice2D(V2,V3); next end; if (2*abs(V3.V1)>min(s3,s1)*tol) then V3,V1:=ReduceLattice2D(V3,V1); next end; break end; if ((V1.V2)*(V2.V3)*(V3.V1)<0) then V:=V1-signum(V1.V2)*V2-signum(V1.V3)*V3; s:=add(v^2,v=V); if (sv[1]=i1 or v[2]=i2,s) end; V:=ls2[map2(op,2,Sort(V,[1]))] else V:=[V1,V2,V3][SortIdx([s1,s2,s3],'nolist')] end; `if`(type(M,Matrix),Matrix(op(M),(j,i)->V[i][j]),V) end: #hfl: CVP CVP:=proc( p::Vector, M::Matrix, Mi::Matrix:=M^(-1), corner2::Vector:=Vector(op(1,p),1), corner1::Vector:=Vector(op(1,p),1)-corner2, output::nonnegint:=0, $) local d,n,S,r,n2,r2; d:=op(1,p); n:=map(floor,Mi.p); S:=combinat[cartprod]([seq([seq(n[i]+v,v=corner1[i]..corner2[i])],i=1..d)]); r:=add(v^2,v=p-M.n); while not(S['finished']) do n2:=Vector(S['nextvalue']()); r2:=add(v^2,v=p-M.n2); if (r2abs(v))); n[o]:=n[o]+signum(p[o]-n[o]) end; if (output=1) then len(p-n) elif (output=2) then n else len(p-n),n end end: #hfl: Atoms2Cell Atoms2Cell:=proc( Atoms::list, opt4ReshapeCell::list:=[], { offset::{posint,list({numeric,undefined})}:=[], transform::boolean:=false, augment::boolean:=transform, rescale::boolean:=augment, scale::numeric:=0, dim::nonnegint:=0, e3::Vector(3):=<0,0,1>, output::string:="am" },$) local f,dt,T,A,n,x0,dx0,s,i0,p0,e1,e2,e3a,o1,s1,s2,nt,tflags,j,M,TT,R,Mi,c,v,o; if hastype(Atoms,float) then f:=evalf; dt:=datatype=float else f:=simplify; dt:=NULL end; T,A:=selectremove(v->v[1]=tvsymbol9,Atoms); n:=nops(T); if (dim>0 and n<>dim) then error("Expected %1 translation vectors, detected %2",dim,n) end; if (n=0 and not(augment)) then return Atoms,undefined end; x0,dx0,s:=[undefined$3],[undefined$3],1; if type(offset,posint) then i0:=offset; p0:=A[i0][2] else x0:=offset[..min(3,nops(offset))]; x0:=[op(x0),undefined$(3-nops(x0))]; i0:=0; p0:=<0,0,0> end; if (offset<>[] or transform or augment) then if (n=0) then e1,e2,e3a:=<1,0,0>,<0,1,0>,<0,0,1>; if (rescale and A<>[]) then s:=`if`(scale>0,scale,max(1,ceil(4*sqrt(max(seq(((v[2]-p0).e1)^2+((v[2]-p0).e2)^2+((v[2]-p0).e3a)^2,v=A)))))); dx0:=[-1/2,-1/2,-1/2] end; T:=[["",s*e1],["",s*e2],["",s*e3a]] elif (n=1) then e1:=T[1][2]; o1:=op(MaxIdx(e1,v->abs(v))); s1:=signum(e1[o1]); s2:=`if`(o1=2,-1,1); e2:=s2*LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](e3,e1),2); if (evalf(add(v^2,v=e2))<10^(2-Digits)) then e2:=LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](<<0,0,1>|<1,0,0>|<0,1,0>>.e3,T[1][2]),2) end; e3a:=s1*s2*LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](e1,e2),2); if (rescale and A<>[]) then s:=`if`(scale>0,scale,max(1,ceil(4*sqrt(max(seq(((v[2]-p0).e2)^2+((v[2]-p0).e3a)^2,v=A)))))); dx0:=subsop(o1=undefined,[-1/2,-1/2,-1/2]) end; T:=[op(T),["",s*e2],["",s*e3a]]; if (o1=2) then T:=T[[2,1,3]] elif (o1=3) then T:=T[[2,3,1]] end elif (n=2) then e3a:=LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](T[1][2],T[2][2]),2); if (rescale and A<>[]) then s:=`if`(scale>0,scale,max(1,ceil(4*max(seq(abs((v[2]-p0).e3a),v=A))))); dx0:=[undefined$2,-1/2] end; T:=[op(T),["",s*e3a]] elif (n>3) then error("Cannot augment %1 translation vectors",n) end end; nt:=nops(T); tflags:=[seq(`if`(j>nt,0,`if`(T[j][1]=tvsymbol9,1,2)),j=1..3)]; M:=Matrix(3,nt,(o,i)->f(T[i][2][o]),dt); if (nt=3 and opt4ReshapeCell<>[]) then M,TT,R:=ReshapeCell(M,op(opt4ReshapeCell)); if not(transform) then A:=[seq([v[1],f(R.v[2]),op(3..,v)],v=A)] end; tflags:=map(abs@round,convert(TT.Vector(tflags),list)) else TT,R:=Matrix(LinearAlgebra[IdentityMatrix](3))$2 end; if (offset<>[] or transform) then Mi:=M^(-1); A:=[seq([v[1],f(Mi.v[2]),op(3..,v)],v=A)]; if (i0>0) then x0:=[seq(v-1/2,v=A[i0][2])] end; x0:=[seq(`if`(x0[o]=undefined,dx0[o],`if`(dx0[o]=undefined,x0[o],x0[o]+dx0[o])),o=1..3)]; if (x0<>[undefined$3]) then A:=[seq([v[1],Vector(3,o->`if`(x0[o]=undefined,v[2][o],Reduce2P(v[2][o],1,x0[o])),dt),op(3..,v)],v=A)]; if not(transform) then A:=[seq([v[1],f(M.v[2]),op(3..,v)],v=A)] end end end; seq(`if`(c="a",A,`if`(c="m",`if`(augment,M,M[..,..n]),`if`(c="t",TT,`if`(c="r",R,`if`(c="f",tflags,NULL))))),c=output) end: #hfl: SuperCell SuperCell:=proc( Atoms::list, scell::{numeric,list(posint),list(numeric..numeric)}, MorCell::{Matrix,list}:=<<1,0,0>|<0,1,0>|<0,0,1>>, { scaletv::boolean:=type(scell,list(posint)), to01::boolean:=false, sortf::procedure:=(i->`if`(i<0,i+1000000,i)), connectivity::boolean:=false },$) local inrange,cartesians,A,M,Mt,na,nt,a,v,sc,sc0,k,T; inrange:=v->`if`(nt=1,evalb(op(1,sc[1])<=v and v|<0,1,0>|<0,0,1>> end; na:=nops(A); nt:=op(1,M)[2]; a:=Vector(nt,k->len(M[..,k])); if type(scell,numeric) then v:=`if`(nt=1,1,`if`(nt=2,1/sin(angle(M[..,1],M[..,2])),a[1]*a[2]*a[3]/LinearAlgebra[Determinant](M))); sc:=[seq(-v*scell/a[k]..1+v*scell/a[k],k=1..nt)] elif type(scell,list(posint)) then sc:=[seq(0..v,v=scell)] else sc:=scell end; if (nt<>nops(sc)) then error("Number of translation vectors %1<>%2 size of super cell list",nt,nops(sc)) end; sc0:=[seq(Sort([seq(i,i=floor(op(1,v))..ceil(op(2,v))-1)],sortf),v=sc)]; for k from 1 to nt do A:=[seq(seq([v[1],v[2]+i*Mt[..,k],op(3..,v)],v=A),i=sc0[k])] end; if type(map(op,sc),list(integer)) then if connectivity then A:=[seq(seq([op(..3,v),map(`+`,v[4],na*(k-1)),op(5..,v)],v=A[na*(k-1)+1..na*k]),k=1..nops(A)/na)] end else if cartesians then T:=`if`(nt=1,LinearAlgebra[Transpose](M[..,1])/a[1]^2,`if`(nt=2,Matrix(2,(i,j)->M[..,i].M[..,j])^(-1).Matrix(2,3,(i,o)->M[o,i]),M^(-1))); A:=select(v->inrange(T.v[2]),A) else A:=select(v->inrange(v[2]),A) end; if connectivity then error("Connectivity is not supported for noninteger cell range") end end; `if`(cartesians, [op(A),seq([tvsymbol,`if`(scaletv,max(sc0[k])-min(sc0[k])+1,1)*M[..,k]],k=1..nt)], A ) end: #hfl: SuperCell FoldCells:=proc( Atoms::list, scell::list(posint), layers::list:=[1,1], refatom::nonnegint:=0, refpoint::Vector:=<0,0,0>, maxdev::numeric:=0.2, { cminMSD::numeric:=0.9, output::{"standard","compact","full"}:="standard", printout::boolean:=false, digits::posint:=4, terse::boolean:=false },$) local nt,m,Tvs,minMSD,A,M,T,k,na,L,n,nu,mu,i0,UC,MSD,Rep,l,j,i,ls,p,devs,r,shift,v,u,w; # translations nt,m:=nops(scell),mul(v,v=scell); Tvs,A:=selectremove(v->v[1]=tvsymbol9,Atoms); if (nops(Tvs)<>nt) then error("Number of translation vectors %1 is incompatible with super cell %2",nops(Tvs),scell) end; minMSD:=evalf(cminMSD*(min(seq(len(v[2]),v=Tvs))-2*maxdev)/m*sqrt(m-1)); if (minMSD1) then WARNING("Cannot detect out-of-box atoms, minMSD=%1na) then error("Layers do not sum up to UC") end; i0:=[0,op(..-2,i0)]; # main UC,MSD,Rep:=Vector(na),Vector(na,datatype=float),Vector(na); for l from 1 to L do for j from 1 to n[l] do # old code: for i from 1 to na do i:=j+i0[l]; ls:=[seq(seq(evalf(A[j+i0[l]*nu+n[l]*(u-1)+na*nu*(w-1)][2]-T[u+nu*(w-1)]),u=1..nu),w=1..mu)]; # old code: ls:=[seq(A[i+na*(r-1)][2]-T[r],r=1..m)]; if (output="full") then Rep[i]:=Matrix(ls,datatype=float) end; p:=add(v,v=ls)/m; devs:=map(len,ls,p); MSD[i]:=sqrt(add(v^2,v=devs)/m); if (MSD[i]>minMSD) then ls:=map2(op,2,Atoms2Cell([seq(["",v],v=ls),op(Tvs)],'offset'=op(MinIdx(devs)),'transform'=false,'augment'=true,'rescale'=false)[1]); if (output="full") then Rep[i]:=Matrix(ls,datatype=float) end; p:=add(v,v=ls)/m; devs:=map(len,ls,p); MSD[i]:=sqrt(add(v^2,v=devs)/m) end; for r from 1 to m do if (not(terse) and devs[r]>maxdev) then WARNING("Deviation for atom %1 replica %2 is %3>maxdev=%4",i,r,devs[r],maxdev) end end; UC[i]:=p end end; # final if printout then printf(" %-*s\n%*.*f\n",digits+3,Vector(na,i->A[i][1]),digits+3,digits,MSD) end; if (refatom>0) then shift:=refpoint-UC[refatom]; if printout then printf("shift=(%{c,}.*f)\n",digits,shift) end; for i from 1 to na do UC[i]:=UC[i]+shift end end; [seq([A[i][1],UC[i],`if`(output="standard",MSD[i],`if`(output="full",Rep[i],NULL))],i=1..na),seq([tvsymbol9,M[..,k]],k=1..nt)] end: #hfl: ConnectAtoms ConnectAtoms:=proc( Atoms0::list, BLdef::{string,procedure}:="CCDC", rcov::table:=table(), c::numeric:=1.3, { supercell::{list(numeric..numeric),numeric}:=[(-1..1)$3], output::string:="i" },$) local Tvs,Atoms,nt,n,A,ls,tb,a1,a2,tb1,P,d2,maxbond,Atoms2,n2a,P2a,d2a,i,j,o; Tvs,Atoms:=selectremove(v->v[1]=tvsymbol9,Atoms0); nt,n:=nops(Tvs),nops(Atoms); A:=[seq(v[1],v=Atoms)]; ls:={op(A)}; tb:=table(): if type(BLdef,procedure) then for a1 in ls do for a2 in ls do tb[a1,a2]:=(c*BLdef(a1,a2))^2 end end else tb1:=table(): if (BLdef<>"") then for a1 in ls do tb1[a1]:=tb_rcov[a1,BLdef] end end; for a1 in indices(rcov,'nolist') do tb1[a1]:=rcov[a1] end; for a1 in ls do if not(type(tb1[a1],numeric)) then error("Nonnumeric covalent radius for element %1: %2",a1,tb1[a1]) end end; for a1 in ls do for a2 in ls do tb[a1,a2]:=(c*(tb1[a1]+tb1[a2]))^2 end end end; P:=Matrix(3,n,(o,i)->Atoms[i][2][o],datatype=float); d2:=Matrix(n,(i,j)->add((P[o,i]-P[o,j])^2,o=1..3),shape=symmetric,datatype=float); if (nt>0) then maxbond:=sqrt(max(entries(tb))); Atoms2:=SuperCell([seq([i,Atoms[i][2]],i=1..n),op(Tvs)],`if`(type(supercell,list),supercell[..nt],`if`(supercell>0,supercell,maxbond)))[..-1-nt]; n2a:=nops(Atoms2)-n; P2a:=Matrix(3,n2a,(o,i)->Atoms2[n+i][2][o],datatype=float); d2a:=Matrix(n,n2a,(i,j)->add((P[o,i]-P2a[o,j])^2,o=1..3),datatype=float); for i from 1 to n do for j from 1 to n2a do if (d2a[i,j]tb[A[i],A[j]],NULL,j),j=1..n)],i=1..n)], `if`(s="n",sort([seq([seq(`if`(i=j or d2[i,j]>tb[A[i],A[j]],NULL,A[j]),j=1..n)],i=1..n)]), `if`(s="2",d2, `if`(s="d",LinearAlgebra[Map](sqrt,d2), `if`(s="m",Matrix(n,(i,j)->`if`(i=j or d2[i,j]>tb[A[i],A[j]],0,1),shape=symmetric,datatype=integer), `if`(s="g",GraphTheory[Graph](Matrix(n,(i,j)->`if`(i=j or d2[i,j]>tb[A[i],A[j]],0,1),shape=symmetric,datatype=integer)), NULL)))))),s=output) end: #hfl: RemoveAtoms RemoveAtoms:=proc(A::list,lsi0::list(integer),$) local na,lsi,i2i,i,j; if HasTopology(A) then na:=nops(A); lsi:=sort(lsi0); i2i:=Vector(na,i->i); for i in lsi do i2i[i]:=NULL; for j from i+1 to na do i2i[j]:=i2i[j]-1 end end; subsop(seq(i=NULL,i=lsi),map(v->subsop(4=map(i->i2i[i],v[4]),v),A)) else subsop(seq(i=NULL,i=lsi0),A) end end: #hfl: MolGraph MolGraph:=proc(A::list,Co::list:=[],{printout::boolean:=false},$) local na,C,L,nl,l2k,k2i,i,k,l; na:=nops(A); C:=`if`(nops(Co)=na and type(Co,list(list(posint))),Co,`if`(HasTopology(A),map2(op,4,A),ConnectAtoms(A,op(Co)))); L:=sort(convert({seq(v[1],v=A)},list)); nl:=nops(L); l2k:=table([seq(L[k]=k,k=1..nl)]); k2i:=k->na+1+k*(k-1)/2; if printout then printf("%{c,}s\n",Vector(nl,k->sprintf("%s=%d",L[k],k2i(k)))) end; [seq([ op(C[i]), k2i(l2k[A[i][1]]) ],i=1..na), seq( op([[ seq(`if`(A[i][1]=L[k],i,NULL),i=1..na) ,seq(k2i(k)+l,l=1..k-1) ], seq([k2i(k)],l=1..k-1)]) ,k=1..nl)] end: #hfl: ChemDistance ChemDistance:=proc(lsi::list(posint),lsj::list(posint),MG::Graph,$) local i,j; MinVal([seq(seq([GraphTheory[Distance](MG,i,j),i,j],i=lsi),j=lsj)],[1]) end: #hfl: Centroid Centroid:=proc( A0::list, Tvs::list:=[], i0::integer:=1, f::procedure:=(P->add(v,v=P)/nops(P)), $) local A,nt,na,P,B,M,V,i,v; A:=[op(A0),op(Tvs)]; nt:=add(`if`(v[1]=tvsymbol9,1,0),v=A); na:=nops(A)-nt; if (nt=0) then P:=map2(op,2,A) else B,M:=Atoms2Cell(A,'transform','augment'=false); V:=[seq(map(round,B[i][2][..nt]-B[i0][2][..nt]),i=1..na)]; P:=[seq(A[i][2]-M.V[i],i=1..na)] end; f(P) end: #hfl: CooPolyhedra CooPolyhedra:=proc( Atoms::list, Cell::list, maxminratio::numeric:=1.3, c::numeric:=1.3, { nmin::posint:=3, nmax::posint:=6, reduceratio::numeric:=0.9, supercell::posint:=1, printout::boolean:=false, labels::boolean:=false, printxyz::string:="", overwrite::boolean:=false },$) local l,M,Mi,Atoms2,ls,ds,dmax,cps,ss,k,v,u,i,j; l:=`if`(labels,4,1); M:=cryst2M(Cell); Mi:=M^(-1); Atoms2:=UnfoldBySymmetry(Atoms,Cell[7]); ls:=[seq(Sort(select(w->w[3][op(..2,w),evalf(len(w[2])),op(3..,w)],[seq(seq(seq(seq(subsop(2=M.(+u[2]-v[2]),u),i=-supercell..supercell),j=-supercell..supercell),k=-supercell..supercell),u=Atoms2)])),[3])[2..],v=Atoms)]; ds:=[seq(sort(map2(op,3,v)),v=ls)]; dmax:=[seq(maxminratio*`if`(v=[],0,`if`(nops(v)>nmax,reduceratio*v[nmin],v[min(nmin,nops(v))])),v=ds)]; cps:=[seq([op(..2,Atoms[i]),select(v->v[3]sprintf("%-2s(%{c,}5.3f) -%{c,}s",cp[l],cp[2],Vector(map(v->sprintf(" %-2s(%5.3f)",v[l],v[3]),cp[3]))),cps); if printout then seq(printf("%s\n%24s%{c,}.0f\n",ss[k],"",Vector(sort([seq(seq(angle(cps[k][3][i][2],cps[k][3][j][2]),j=1..i-1),i=1..nops(cps[k][3]))]))),k=1..nops(cps)) end; if (printxyz<>"") then for k from 1 to nops(cps) do v:=cps[k]; WriteXYZ(cat(printxyz,k,".xyz"),[[v[1],<0,0,0>,v[4]],seq([u[1],u[2],u[4]],u=v[3])],ss[k],format3=" `%s",':-overwrite'=overwrite) end end; cps end: #hfl: CooPolyhedra CooPolyhedron:=proc( AorAC::list, i0::{posint,list(posint),Vector}, cutoff::{"cov","vdw",numeric}:="cov", { stretch::numeric:=1.3, maxminratio::numeric:=`if`(cutoff="cov",1.3,2), reduceratio::numeric:=0.9, nmin::posint:=3, nmax::posint:=`if`(cutoff="cov",6,`if`(cutoff="vdw",14,999)), voidradius::numeric:=`if`(cutoff="cov",0.5,1), supercell::posint:=1, printout::boolean:=false},$) local A,Tvs,p,s,r,dmax,ls,ds,cp,v,u,i,j; A:=`if`(nops(AorAC)=2 and type(AorAC[1],list(list)), cif2xyz(op(AorAC),'optUnfoldBySymmetry'=['fd1st']), AorAC); Tvs,A:=selectremove(v->v[1]=tvsymbol9,A); for v in Tvs do A:=[op(A),seq(seq(subsop(2=u[2]+i*v[2],u),u=A),i=[seq(`if`(j=0,NULL,j),j=-supercell..supercell)])] end; if type(i0,posint) then p:=A[i0][2] elif type(i0,list(posint)) then p:=add(A[i][2],i=i0)/nops(i0) else p:=i0 end; s:=`if`(type(i0,posint),A[i0][1],""); if type(cutoff,numeric) then cp:=[s,p,Sort(select(w->w[3]stretch*(r+tb_rcov[v]) else dmax:=v->stretch*(r+tb_rvdw[v]) end; ls:=Sort(select(w->w[3]"") then ls:=ls[2..] end; ds:=map2(op,3,ls); dmax:=maxminratio*`if`(ds=[],0,`if`(nops(ds)>nmax,reduceratio*ds[nmin],ds[min(nmin,nops(ds))])); cp:=[s,p,select(v->v[3]`if`(s="",s,cat("(",s,")")); embrace:=s->`if`(s="",s,cat("[",s,"]")); if (atype=1) then T:= [seq(cat(A[i][1], EncodeFormula( [seq( A[j][1], j=V[i])] )), i=1..n)] elif (atype=2) then T:= [seq(cat(A[i][1], EncodeFormula( [seq(cat(A[j][1], enclose(EncodeFormula( [seq( A[k][1], k=remove(`=`,V[j],i))] ))), j=V[i])] )), i=1..n)] elif (atype=3) then T:= [seq(cat(A[i][1], EncodeFormula( [seq(cat(A[j][1], enclose(EncodeFormula( [seq(cat(A[k][1], embrace(EncodeFormula( [seq( A[l][1], l=remove(`=`,V[k],j))] ))), k=remove(`=`,V[j],i))] ))), j=V[i])] )), i=1..n)] else error("Maximum supported order is 3, but received %1",atype) end else undef:=atype("",0,[],[],0); Va:=Vector(n,i->A[i][1]); Vc:=map(nops,V); Vn:=Vector(n,i->[seq(Va[j],j=V[i])]); Vo:=Vector(n,datatype=integer); CB:=CycleBasis2(GraphTheory[Graph](V)); for lsi in CB do for i in lsi do Vo[i]:=nops(lsi) end end; T:=Vector(n,i->undef); for iter from 1 to niter do T:=Vector(n,i->atype(Va[i],Vc[i],Vn[i],[seq(T[j],j=V[i])],Vo[i])) end; lsi:=[seq(`if`(T[i]=undef,i,NULL),i=1..n)]; if (lsi=[]) then T:=convert(T,list) else print(lsi); print(convert(T,list)); error("There are undetermined atom types") end end; if (reindex or printout) then t2i:=Classify2([$1..n],i->T[i]); lst:=sort([indices(t2i,'nolist')]); if (sortby="sortbyindex" or sortby="" and type(atype,posint)) then lst:=Sort(lst,t->t2i[t][1]) end; if reindex then t2t:=table([seq(lst[i]=i,i=1..nops(lst))]); T:=map(t->t2t[t],T) end; if printout then t2s:=table([seq(t=`if`(type(t,string),t,sprintf("%a",t)),t=lst)]); if type(atype,procedure) then T1:=ClassifyAtoms(A,1,V,':-reindex'=false); maxlen:=max(seq(length(t2s[t]),t=lst)); t2s:=table([seq(t=sprintf("%*s %s",maxlen,t2s[t],T1[t2i[t][1]]),t=lst)]) end; if reindex then t2s:=table([seq(lst[i]=sprintf("%*d %s",floor(log10(nops(lst)))+1,i,t2s[lst[i]]),i=1..nops(lst))]) end; maxlen:=max(seq(length(t2s[t]),t=lst)); seq(printf("%-*s %{c,}d\n",maxlen,t2s[t],Vector(t2i[t])),t=lst) end end; T,`if`(labels,lst,NULL) end: #hfl: ClassifyAtoms atype_mm3:=proc(a::string,c::nonnegint,n::list(string),t::list) if (a="H" ) then if (n=["C"] or n=["Si"]) then 5 elif (n=["O"]) then 21 elif (n=["N"]) then `if`(t=[39],48,23) elif (n=["S"]) then 44 else 0 end elif (a="C" ) then if (c=4) then 1 elif (c=3) then if member(7,t) then 3 else 2 end elif (c=2) then 4 else 0 end elif (a="N" ) then if (c=3) then if member(7,t) then 46 else 8 end elif (c=2) then 37 elif (c=4) then 39 else 0 end elif (a="O" ) then if (c=2) then 6 elif (c=1) then 7 else 0 end elif (a="S" ) then if (c=2) then if (t[1]=2 or t[1]=37) then 42 else 15 end elif (c=3) then if member(7,t) then 17 else 0 end elif (c=4) then 18 else 0 end elif (a="P" and c=3) then 25 elif (a="F" and c=1) then 11 elif (a="Cl" and c=1) then 12 elif (a="Br" and c=1) then 13 elif (a="I" ) then if (c=1) then 14 elif (c=0) then 165 else 0 end elif (a="Si" and c=4) then 19 else 0 end end: #hfl: ClassifyAtoms atype_opls:=proc(a::string,c::nonnegint,n::list(string),t::list,o::nonnegint) local r; r:=evalb(o=5 or o=6); if (a="H" ) then if (n=["C"]) then `if`(t=[90],91,`if`(t=[86],89,`if`(t=[80],85,0))) elif (n=["N"]) then 45 elif (n=["O"]) then 7 elif (n=["S"]) then 146 else 0 end elif (a="C" ) then if (c=4) then 80 elif (c=3) then if member("O",n) then 3 else `if`(r,90,86) end elif (c=2) then 203 else 0 end elif (a="N" ) then if (c=3) then `if`(r,262,193) elif (c=2) then 36 elif (c=1) then 36 elif (c=4) then 229 else 0 end elif (a="O" ) then if (c=2) then `if`(r,507,5) elif (c=1) then 4 else 0 end elif (a="S" ) then if (c=2) then `if`(r,574,24) else 0 end elif (a="F" ) then 1 elif (a="Cl") then 45 elif (a="Br") then 663 elif (a="I" ) then 673 elif (a="Si") then 866 elif (a="P" ) then 336 else 0 end end: #hfl: GetTopology GetTopology:=proc( Atoms::list, AT0::{list,procedure}, prm0::{table,string}, fff::string:="", { connectivity::list:=[], reindex::boolean:=false, maxdihedral::numeric:=999, maximproper::numeric:=90, strictimproper::boolean:=false, bincosdihedral::numeric:=0.5, mincosimproper::numeric:=0.99, Kbond::numeric:=333.3, Kangle::numeric:=77.7, Kdihedral::numeric:=7.777, Kimproper::numeric:=22.2, entangled::boolean:=false, i2monly::boolean:=false, printout::boolean:=false, maxlength::posint:=120 },$) local cano,cani,A,na,Co,i2m,M,mols,m,AT,atypes,nt,generateff,prm,id,AC,e,bos,ans,dis,ims,boi,ani,dii,imi,bos2,ans2,dis2,ims2,i,j,k,l,u,v,V,tb,b; cano:=proc(v::list,$) if (nops(v)=2) then if (v[1]v[1]=tvsymbol9,Atoms); na:=nops(A); Co:=`if`(nops(connectivity)=na and type(connectivity,list(list(posint))),connectivity,ConnectAtoms(Atoms,op(connectivity))); # identify molecules i2m:=Vector(na,datatype=integer); if entangled then M:=Matrix(na,shape=symmetric,datatype=integer); for i from 1 to na do for j in Co[i] do M[i,j]:=1 end end; mols:=GraphTheory[ConnectedComponents](GraphTheory[Graph](M)); for m from 1 to nops(mols) do for i in mols[m] do i2m[i]:=m end end else m,j:=1,0; for i from 1 to na do i2m[i]:=m; j:=max(j,op(Co[i])); if (j=i or Co[i]=[]) then m:=m+1 end end end; if i2monly then return convert(i2m,list) end; # get types and parameters AT:=`if`(type(AT0,list),AT0,ClassifyAtoms(A,AT0,Co)); atypes:=sort(ListTools[MakeUnique](AT)); nt:=nops(atypes); generateff:=false; if reindex then id:=table([seq(atypes[i]=i,i=1..nops(atypes))]); AT:=map(i->id[i],AT); prm,id:=ReadPRM(prm0,fff,atypes,'getindex',':-reindex'=true,':-printout'=printout) elif type(prm0,table) then prm:=copy(prm0); v:=nops([indices(prm)]); if (v=0) then generateff:=true; prm:=table([seq(i=i,i=atypes)]) elif (v=nt) then if (sort([indices(prm,'nolist')])=atypes) then generateff:=true else error("indices(prm)=%1<>atypes=%2",sort([indices(prm,'nolist')]),atypes) end else id:=IndexPRM(prm,':-printout'=printout) end else prm,id:=ReadPRM(prm0,fff,atypes,'getindex',':-printout'=printout) end; for i from 1 to na do prm["e",AT[i]]:=A[i][1] end; AC:=map(v->prm[v],AT); # process elementwise and pairwise entries if generateff then for i from 1 to na do prm["n",AT[i]]:=nops(Co[i]) end; for i in atypes do e:=prm["e",i]; prm["m",i]:=AtomMass(e); prm["l",i]:=e; prm["q",i]:=0; prm["t",i]:=e; prm["p",i,i]:=["lj",0.1111,2*tb_rvdw[e]] end else v:=`minus`({op(id[2])},{op(AT)}); if (v<>{}) then WARNING("Unused types: %1",v) end; v:=`minus`({op(AT)},{op(id[2])}); if (v<>{}) then error("Undefined types: %1",v) end end; for i from 1 to na do if (nops(Co[i])<>prm["n",AT[i]]) then WARNING("Wrong coordination for atom %1",i) end end; # process bonded interactions bos:=[seq(seq(`if`(i>j,NULL,[i,j]),j=Co[i]),i=1..na)]; ans:=[seq(seq([v[1],i,v[2]],v=combinat[choose](Co[i],2)),i=1..na)]; dis:=[seq(seq(`if`(l=b[1],NULL,seq(`if`(k=b[2],NULL,[k,b[1],b[2],l]),k=Co[b[1]])),l=Co[b[2]]),b=bos)]; ims:=[seq(seq(op([[i,v[1],v[2],v[3]],[i,v[1],v[3],v[2]],[i,v[2],v[3],v[1]]]),v=combinat[choose](Co[i],3)),i=1..na)]; if generateff then tb:=Classify2(bos,v->map(u->AC[u],v)); for v in indices(tb,'nolist') do prm["b",op(cano(v))]:=["harmonic",Kbond,Statistics[Mean](map(v->len(seq(u[2],u=A[v])),tb[v]))] end; tb:=Classify2(ans,v->map(u->AC[u],v)); for v in indices(tb,'nolist') do prm["a",op(cano(v))]:=["harmonic",Kangle,Statistics[Mean](map(v->angle(seq(u[2],u=A[v])),tb[v]))] end; tb:=Classify2(dis,v->map(u->AC[u],v)); for v in indices(tb,'nolist') do V:=map(v->cos(dihedral(seq(u[2],u=A[v]),'radians')),tb[v]); V:=map(Statistics[Mean],[ListTools[Categorize]((u,v)->abs(u-v)<=bincosdihedral,V)]); if (nops(V)=1) then if (V[1]1-bincosdihedral/2) then prm["d",op(cano(v))]:=["opls",0,Kdihedral,0,0] else prm["d",op(cano(v))]:=["opls",-4*V[1],-1,0,0] end elif (nops(V)=2) then if (V[1]1-bincosdihedral/2) then prm["d",op(cano(v))]:=["opls",0,Kdihedral,0,0] elif (V[1]1-bincosdihedral/2) then prm["d",op(cano(v))]:=["opls",12*V[2]^2-3,0,-1,0] else prm["d",op(cano(v))]:=["opls",0,0,0,0] end else prm["d",op(cano(v))]:=["opls",0,0,0,0] end end; tb:=Classify2(ims,v->map(u->AC[u],v)); for v in indices(tb,'nolist') do V:=map(v->cos(dihedral(seq(u[2],u=A[v]),'radians')),tb[v]); if (Statistics[Mean](V)>mincosimproper) then prm["i",op(cani(v))]:=["harmonic",Kimproper,0] end end; id:=IndexPRM(prm,':-printout'=printout) end; boi,ani,dii,imi:=seq(table([seq(v[i]=i,i=1..nops(v))]),v=id[4..7]); bos:=map(v->[boi[cano([seq(AC[i],i=v)])],op(v)],bos); ans:=map(v->[ani[cano([seq(AC[i],i=v)])],op(v)],ans); ims:=map(v->[imi[cani([seq(AC[i],i=v)])],op(v)],ims); if not(strictimproper) then ims:=[op(ims),op(map(v->[imi[cani([seq(AC[i],i=v)])],op(v)],dis))] end; dis:=map(v->[dii[cano([seq(AC[i],i=v)])],op(v)],dis); #ims:=select(v->type(v[1],integer),ims); #if generateff then # bos2,ans2,dis2,ims2:=[],[],[],[] #else bos,bos2:=selectremove(v->type(v[1],posint),bos); ans,ans2:=selectremove(v->type(v[1],posint),ans); dis,dis2:=selectremove(v->type(v[1],posint) and abs(dihedral(seq(A[i][2],i=v[2..]),'ref'=-180))type(v[1],posint) and abs(dihedral(seq(A[i][2],i=v[2..]),'ref'=-180))[]),Vector(n,g->[]); for i from 1 to nops(Atoms) do ls:=[seq([g,add(v^2,v=Atoms[i][2]-P[g])],g=1..n)]; if (dmax>0) then ls:=remove(v->v[2]>d2max,ls); if (ls=[]) then G0:=[op(G0),i]; next end end; g,d2:=op(MinVal(ls,[2])); G[g]:=[op(G[g]),i]; dist[g]:=[op(dist[g]),d2] end; if (G0<>[]) then WARNING("There are %1 unclusterized atoms",nops(G0)) end; G:=[seq(G[g],g=1..n)]; R:=[seq(`if`(G[g]=[],0,sqrt(max(dist[g]))),g=1..n)] else if (add(nops(groups[g]),g=1..n)<>nops(Atoms)) then error("Wrong groups provided, %1",groups) end; G:=groups; R:=[seq(sqrt(max(seq(add(v^2,v=Atoms[i][2]-P[g]),i=G[g]))),g=1..n)] end; if printout then for g from 1 to n do printf("%6.1f - %*d\n",R[g],ceil(log10(nops(Atoms))),Vector(G[g])) end; if (G0<>[]) then printf("Unclusterized: %{c,}d\n",Vector(G0)) end end; if empty then [seq([P[g],R[g],G[g]],g=1..n)] else [seq(`if`(G[g]=[],NULL,[P[g],R[g],G[g]]),g=1..n)] end end: #hfl: ContactDistance ContactDistance:=proc( Atoms1::list, Atoms2::list, Clusters1::list:=`if`(cutoff>0,Clusterize(Atoms1),[]), Clusters2::list:=`if`(cutoff>0,Clusterize(Atoms2),[]), { cutoff::numeric:=0, all::boolean:=false },$) option hfloat; local ls,i,j,u,v,R; if (Clusters1=[] or Clusters2=[] or cutoff<=0) then ls:=[seq(seq([add(v^2,v=Atoms1[i][2]-Atoms2[j][2]),i,j],i=1..nops(Atoms1)),j=1..nops(Atoms2))] else R:=cutoff+max(seq(v[2],v=Clusters1))+max(seq(v[2],v=Clusters2)); ls:=select(u->evalb(u[1]0) then ls:=select(u->evalb(u[1][sqrt(v[1]),v[2],v[3]],Sort(ls,[1])) else i:=op(MinIdx(ls,[1])); [sqrt(ls[i][1]),ls[i][2],ls[i][3]] end end: #hfl: FragmentMolecule FragmentMolecule:=proc( A::list, Co::list:=[], output::string:="f", { breakbonds::list([posint,posint]):=[], istree::procedure:=defistree, extracycles::list(set):=[], sortf::procedure:=(v->v[1][1]), coof::procedure:=undefined, perm::list:=[], passivator::string:="D", printout::boolean:=false },$) local na,C,C2,b,F,sf,P,iP,fP,n,p,p1,p2,B,lsA,na1,na2,lsi,i2j,A1,i,j,v,u,q; na:=nops(A); C:=`if`(nops(Co)=na and type(Co,list(list(posint))),Co,`if`(HasTopology(A),map2(op,4,A),ConnectAtoms(A,op(Co)))); if (breakbonds=[]) then C2:=copy(C) else C2:=Vector(na,i->C[i]); for b in breakbonds do C2[b[1]]:=Substitute(C2[b[1]],b[2]); C2[b[2]]:=Substitute(C2[b[2]],b[1]) end; C2:=convert(C2,list) end; F:=CyclesAndTrees(GraphTheory[Graph](C2),istree,extracycles); sf:=`if`(coof=undefined,sortf,((v,A)->add(coof(u[2]),u=A[v[1]])/nops(v[1]))); P:=SortIdx(F,v->sf(v,A),nolist); iP:=table([seq(P[p]=p,p=1..nops(P))]); fP:=v->[sort(v[1]),op(Sort(map(u->subsop(3=iP[u[3]],u),v[2..]),[3]))]; F:=[seq(fP(v),v=F[P])]; if (perm<>[]) then iP:=table([seq(`if`(type(perm[p],posint),perm[p]=p,seq(q=p,q=perm[p])),p=1..nops(perm))]); F:=[seq(`if`(type(v,posint),fP(F[v]),fP([[seq(op(F[p][1]),p=v)],seq(seq(`if`(member(u[3],v),NULL,u),u=F[p][2..]),p=v)])),v=perm)] end; n:=nops(F); if (breakbonds<>[]) then F:=Vector(nops(F),p->F[p]); for b in breakbonds do for p from 1 to n do if member(b[1],F[p][1]) then p1:=p end; if member(b[2],F[p][1]) then p2:=p end end; F[p1]:=[op(F[p1]),[b[1],b[2],p2]]; F[p2]:=[op(F[p2]),[b[2],b[1],p1]] end; F:=convert(F,list) end; B:=Sort([seq(seq(`if`(u[1]min(v[2])*n+max(v[2])); if (SearchPos(output,"h")>0) then lsA:=table(); for p from 1 to n do na1,na2:=nops(F[p][1]),nops(F[p])-1; lsi:=[op(F[p][1]),seq(v[2],v=F[p][2..])]; i2j:=table([seq(lsi[j]=j,j=1..nops(lsi))]); A1:=[ seq([op(..2,A[i]),0,map(i->i2j[i],C[i])],i=lsi[..na1]), seq([passivator,A[lsi[na1+j]][2],0,[i2j[F[p][1+j][1]]]],j=1..na2) ]; A1:=[op(..na1,A1),seq(subsop(2=A1[v[4][1]][2]+LinearAlgebra[Normalize](v[2]-A1[v[4][1]][2],2)*(tb_rcov[A1[v[4][1]][1]]+tb_rcov[passivator]),v),v=A1[-na2..])]; lsA[p]:=A1 end; lsA:=convert(lsA,list) end; if printout then seq(printf("%2d: %s %s%{s}s\n",p,EncodeFormula(A[F[p][1]]),convert2range(F[p][1],asstring),Vector(map(v->sprintf(", [%d,%d,%d]",op(v)),F[p][2..]))),p=1..nops(F)) end; seq( `if`(s="f",F, `if`(s="b",B, `if`(s="c",map(v->add(A[i][2],i=v[1])/nops(v[1]),F), `if`(s="h",lsA, NULL)))),s=output) end: #hfl: FragmentMolecule FragmentPlot:=proc(A::list,F::list,opt4text::list:=['color'="LimeGreen",'font'=[Helvetica,14]]) local i,v,u,o; display([seq(plotMol(A[v[1]]),v=F), seq(plots[textplot3d]([seq(add(u[2][o],u=A[F[i][1]])/nops(F[i][1]),o=1..3),sprintf("%d",i)],op(opt4text)),i=1..nops(F))], axes=none,scaling=constrained,_rest) end: #hfl: ChangeDihedral ChangeDihedral:=proc( Atoms::list, lsi::[posint,posint,posint,posint], val::numeric, Co0::list:=`if`(nops(Atoms[1])>3,map2(op,4,Atoms),ConnectAtoms(Atoms,op(opt4CA))), { opt4CA::list:=[], frags::[list(posint),list(posint)]:=[[],[]] },$) local Co,j1,i1,i2,j2,i,frag1,frag,frag2,v,p,R,Atoms2; j1,i1,i2,j2:=op(lsi); if (frags=[[],[]]) then Co:=map(convert,Co0,set); Co:=subsop(i1=`minus`(Co[i1],{i2}),i2=`minus`(Co[i2],{i1}),Co); frag1:={i1}; do frag:=`union`(frag1,seq(Co[i],i=frag1)); if (nops(frag)=nops(frag1)) then break else frag1:=frag end end; frag2:={i2}; do frag:=`union`(frag2,seq(Co[i],i=frag2)); if (nops(frag)=nops(frag2)) then break else frag2:=frag end end; if not(`intersect`(frag1,frag2)={}) then v:=frag1,frag2; Co:=map(convert,Co0,set); Co:=subsop(j1=`minus`(Co[j1],{j2}),j2=`minus`(Co[j2],{j1}),Co); frag1:={j1}; do frag:=`union`(frag1,seq(Co[i],i=frag1)); if (nops(frag)=nops(frag1)) then break else frag1:=frag end end; frag2:={j2}; do frag:=`union`(frag2,seq(Co[i],i=frag2)); if (nops(frag)=nops(frag2)) then break else frag2:=frag end end; if not(`intersect`(frag1,frag2)={}) then error("Dihedral %3 is locked (frag1=%1, frag2=%2) and improper is locked (frag1=%1, frag2=%2)",frag1,frag2,lsi) end end else frag1,frag2:=op(frags) end; p:=Atoms[i2][2]; R:=RotationM(Pi/180*(val-dihedral(seq(Atoms[i][2],i=lsi))),p-Atoms[i1][2]); Atoms2:=Vector(nops(Atoms),i->Atoms[i]); for i in frag2 do Atoms2[i][2]:=R.(Atoms2[i][2]-p)+p end; convert(Atoms2,list) end: #hfl: AliphaticDihedrals AliphaticDihedrals:=proc( A::list, T::list:=["CC2H2"], { atoms14::list:=["C"], printout::boolean:=false, printxyz::string:="", overwrite::boolean:=false},$) local Co,AT,ATL,lst,topo,ds,ls,lsi; Co:=ConnectAtoms(A); AT,ATL:=ClassifyAtoms(A,1,Co,'labels'); lst:=map2(SearchPos,ATL,T); topo:=GetTopology(A,AT,table([seq(v=v,v=AT)]),'connectivity'=Co); ds:=select(v-> member(AT[v[2]],lst) and member(AT[v[3]],lst) and member(A[v[1]][1],atoms14) and member(A[v[4]][1],atoms14),map(v->v[2..],topo[5])); ls:=ListTools[FindRepetitions](ds,1,(u,v)->u[2]=v[2] and u[3]=v[3]); if (ls<>[]) then WARNING("Multiply defined dihedrals: %1",ls) end; lsi:=sort(convert({seq(op(v),v=ds)},list)); if (printxyz<>"" and lsi<>[]) then WriteXYZ(printxyz,A[lsi],':-overwrite'=overwrite) end; ds end: #hfl: Alkane Alkane:=proc(n::posint,{CC::numeric:=1.527,CCC::numeric:=113.46,CH::numeric:=1.099,HCH::numeric:=105.98,CCH:=111.55},$) local a,b,c,d,a2,b2,k; a,b:=evalf(CC*sin(CCC*Pi/360)),evalf(CC/2*cos(CCC*Pi/360)); c,d:=evalf(CH*sin(HCH*Pi/360)),evalf(b+CH*cos(HCH*Pi/360)); a2,b2:=evalf(CH*sin((CCH-CCC/2)*Pi/180)),evalf(CH*cos((CCH-CCC/2)*Pi/180)-b); [seq(op([ ["C",,2,[`if`(k=1,3*n+2,3*k-5),3*k-1,3*k,3*k+1]], ["H",,1,[3*k-2]], ["H",,1,[3*k-2]] ]),k=1..n), ["H",,1,[3*n-2]], ["H",,1,[1]] ] end: #hfl: Alkane SortAlkane:=proc(A::list,i00::integer,convention::{"line","loop","zigzag"}:="loop",Co::list:=[],{printout::boolean:=false},$) local na,nc,C,i,i0,i1,i2,i3,i4,P,lsi,ls1,ls2,d,v; na:=nops(A); nc:=(na-2)/3; if not(type(nc,posint)) then error("Wrong alkane length: %1",na) end; C:=`if`(Co=[],`if`(HasTopology(A),map2(op,4,A),ConnectAtoms(A)),Co); i1:=`if`(i00>0,i00,na+i00+1); if (i1<1 or i1>na or nops(C[i1])<>1) then error("Wrong alkane root: %1",i1) end; i4:=op(C[i1]); P:=Vector(na,datatype=integer); P[-1]:=i1; for i from 1 to nc-1 do i0,i1:=i1,i4; lsi:=remove(`=`,C[i1],i0); ls1,ls2:=selectremove(i->A[i][1]="C",lsi); if (nops(ls1)=1) then i4:=op(ls1) else error("No carbon at atom %1",i1) end; if (nops(ls2)=2) then i2,i3:=op(ls2) else error("No hydrogens at atom %1",i1) end; d:=dihedral(seq(v[2],v=A[[i1,i2,i3,i4]]),'ref'=-180); if (d>0) then i2,i3:=i3,i2 end; if printout then printf("%2d: %2d %2d %2d %2d %2d\n",i,i0,i1,i2,i3,i4) end; P[3*i-2]:=i1; P[3*i-1]:=i2; P[3*i]:=i3 end; P[-5]:=i4; ls2:=Sort(map(i->[i,dihedral(seq(v[2],v=A[[i0,i1,i4,i]]),'ref'=0)],remove(`=`,C[i4],i1)),[2]); if (nops(ls2)=3) then P[-4],P[-2],P[-3]:=seq(v[1],v=ls2) else error("No hydrogens at atom %1",i4) end; P:=convert(P,list); if (convention="line") then P:=[P[-1],op(..-2,P)] elif (convention="zigzag") then P:=[op(..-3,P),P[-1],P[-2]] end; P end: #hfl: OrientBy2Vectors OrientBy2Vectors:=proc(p1::Vector(3),p2::Vector(3),p3::{1,2,3,-1,-2,-3}:=3,{output::posint:=2,radians::boolean:=false}) local ord,ls,T,v,alpha,axis; ord:=piecewise(p3=1,[2,3,1],p3=2,[3,1,2],p3=3,[1,2,3],p3=-1,[3,2,1],p3=-2,[1,3,2],p3=-3,[2,1,3],'undefined'); ls:=LinearAlgebra[GramSchmidt]([p1,p2,signum(p3)*LinearAlgebra[CrossProduct](p1,p2)],'normalized','conjugate'=false); T:=LinearAlgebra[Transpose](Matrix([seq(ls[i],i=ord)])); v,alpha,axis:=RotationParam(T,_rest); if not(radians) then alpha:=evalf(180/Pi*alpha) end; if (output=1) then T elif (output=2) then alpha,axis else alpha,axis,T end end: #hfl: CanonicOrientation CanonicOrientation:=proc( A0::list, PBC::{0,1,2,3}:=add(`if`(v[1]=tvsymbol9,1,0),v=A0), axes::{12,13,23,21,31,32}:=`if`(PBC=0,31,`if`(PBC=1,13,12)), octant::[{-1,0,1},{-1,0,1},{-1,0,1}]:=`if`(PBC=0,[1,1,1],`if`(PBC=1,[0,1,1],`if`(PBC=2,[0,0,1],[0,0,0]))), { include::list(string):=[], exclude::list(string):=[], usesubset::list(posint):=`if`(include=[],`if`(exclude=[],[$1..nops(A0)],[seq(`if`(member(A0[i][1],include),NULL,i),i=1..nops(A0))]),[seq(`if`(member(A0[i][1],include),i,NULL),i=1..nops(A0))]), ca::{list({integer,list(integer)}),list(string),Vector(3)}:=`if`(PBC=0,[$1..nops(usesubset)],<0,0,0>), ce::boolean:=false, cf::{procedure,"centroid"}:="centroid", pa::{list({integer,list(integer)}),list(string),Vector(3)}:=`if`(PBC=0,[$1..nops(usesubset)],[tvsymbol9]), pe::boolean:=false, pf::{procedure,"centroid","relcentroid","plane","line","outermost"}:=`if`(PBC=0,"plane",x->x[1]), pd::{-1,0,1}:=`if`(PBC>0 or member(pf,["centroid","relcentroid","outermost"]) or type(pa,{Vector,[integer],[integer,integer]}),1,0), sa::{list({integer,list(integer)}),list(string),Vector(3)}:=`if`(PBC>1,[tvsymbol9],[$1..nops(usesubset)]), se::boolean:=false, sf::{procedure,"centroid","relcentroid","plane","line","outermost"}:=`if`(PBC>1,x->x[2],`if`(PBC=1,"plane","line")), sd::{-1,0,1}:=`if`(PBC>1 or member(sf,["centroid","relcentroid","outermost"]) or type(sa,{Vector,[integer],[integer,integer]}),1,0), oa::{list({integer,list(integer)}),list(string),Vector(3)}:=[], oe::boolean:=false, of::{procedure,"centroid","relcentroid","plane","line","outermost"}:=`if`(type(oa,{[integer],[integer,integer],[integer,integer,integer]}),"centroid","outermost"), zero::numeric:=1e-4, det::{-1,0,1}:=0, extraT::{Matrix,string}:="", output::{"A","TR"}:="A", nowarning::boolean:=false, printout::boolean:=false },$) local A,vecs,vec,prn,isTv,cv,pv,sv,ov,R,e,e2,o,p,T,uda,A2,i,j,k,v,u,w; # subroutine vecs vecs:=proc(a,e) local ls,isTv; if type(a,Vector) then return true,[a] end; ls:=`if`(type(a,list(string)), [seq(`if`(e xor member(A[i][1],a),i,NULL),i=1..nops(A))], `if`(e,sort(convert(`minus`({$1..nops(A)},convert(a,set)),list)),a) ); if (ls=[]) then error("Empty list of points obtained from a=%1 with e=%2",a,e) end; isTv:=evalb(add(`if`(type(i,integer) and A[i][1]=tvsymbol9,1,0),i=ls)=nops(ls)); isTv,[seq(`if`(type(i,integer),`if`(isTv xor A[i][1]=tvsymbol9,NULL,A[i][2]),A[i[1]][2]+add(i[j]*A[j][2],j=1-nops(i)..-1)),i=ls)] end; # subroutine vec vec:=proc(v,f) if (v=[]) then error("Empty list of points") elif type(v,Vector) then v elif (f="centroid" or nops(v)=1) then add(u,u=v)/nops(v) elif (f="relcentroid" or nops(v)=2) then add(u,u=v[2..])/(nops(v)-1)-v[1] elif (f="plane" or f="line") then [ODR(v,f)][2] elif (f="outermost") then MaxVal(v,u->add(w^2,w=u)) end end; # subroutine prn prn:=proc(f,a) local s; s:=sprintf(" set by %s(%s)",`if`(type(f,string),f,"proc"),`if`(type(a,list(integer)),sprintf("%{c,}d",Vector(a)),`if`(type(a,list(string)),sprintf("%{c,}s",Vector(a)),sprintf("%a",a)))); `if`(length(s)>50,cat(s[..47],"..."),s) end; # body A:=A0[usesubset]; isTv,cv:=vecs(ca,ce); R:=evalf(`if`(type(cf,procedure),cf(cv),vec(cv,cf))); if printout then printf("Center point=(%{c,}+.3f)%s\n",R,prn(cf,ca)) end; e[1],e[2],e[3]:=<1,0,0>,<0,1,0>,<0,0,1>; if (nops(A)>1) then # primary axis isTv,pv:=vecs(pa,pe); if not(isTv) then pv:=[seq(u-R,u=pv)] end; e[1]:=LinearAlgebra[Normalize](evalf(`if`(type(pf,procedure),pf(pv),vec(pv,pf))),2)*`if`(pd=-1,-1,1); e[2]:=LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](`if`(abs(<0,0,1>.e[1])<0.9,<0,0,1>,<0,1,0>),e[1]),2); e[3]:=LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](e[1],e[2]),2); if printout then printf("Primary axis=(%{c,}+.3f)%s\n",e[1],prn(pf,pa)) end; if (nops(A)>2) then # secondary axis isTv,sv:=vecs(sa,se); if not(isTv) then sv:=[seq(u-R,u=sv)] end; sv:=[seq(,u=sv)]; e2:=evalf(`if`(type(sf,procedure),sf(sv),vec(sv,sf))); e[2]:=LinearAlgebra[Normalize](e2[1]*e[2]+e2[2]*e[3],2)*`if`(sd=-1,-1,1); e[3]:=LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](e[1],e[2]),2); if printout then printf("Second axis=(%{c,}+.3f)%s\n",e[2],prn(sf,sa)) end end end; # correct sign of e[3] if member(axes,[13,32,21]) then e[3]:=-e[3] end; # octant condition T:=Matrix(3,datatype=float); j:=DecodeAxes(axes); if (oa=[]) then for k from 1 to 3 do T[j[k],..]:=e[k] end; if printout then printf("Translation vectors are oriented as [%{c,}d]\n",Vector(j)) end else o:=octant; isTv,ov:=vecs(oa,oe); if isTv then error("Translation vectors are not allowed for cv") end; ov:=[seq(u-R,u=ov)]; p:=evalf(`if`(type(of,procedure),of(ov),vec(ov,of))); if printout then printf("Octant point=(%{c,}+.3f)%s\n",p,prn(of,oa)) end; for k from 1 to 3 do v:=p.e[k]; if (abs(v)0 or k=2 and sd<>0) then WARNING("Octant condition cannot be satisfied for axis %1",j[k]) else e[k]:=-e[k] end end end; T[j[k],..]:=e[k] end end; # determine undirected axes uda:={1,2,3}; if (pd<>0) then uda:=uda minus {j[1]} end; if (sd<>0) then uda:=uda minus {j[2]} end; for k from 1 to 3 do if (o[k]<>0) then uda:=uda minus {k} end end; # use determinant if (det=0 and nops(uda)>0 and LinearAlgebra[Determinant](T)<0) then T[uda[1],..]:=-T[uda[1],..] elif (det<>0 and det<>round(LinearAlgebra[Determinant](T))) then if (nops(uda)>0) then T[uda[1],..]:=-T[uda[1],..] else WARNING("Determinant condition cannot be satisfied") end end; # extra transformation if (extraT<>"") then if type(extraT,Matrix) then T:=evalf(extraT.T) elif assigned('FiniteGroups[TransformationTable][extraT]') then T:=evalf(FiniteGroups[TransformationTable][extraT]^(-1).T) else error("Unrecognized extraT: %1",extraT) end end; # transform A2:=[seq([v[1],T.`if`(v[1]=tvsymbol9,v[2],v[2]-R),op(3..,v)],v=A0)]; # determine essential undirected axes if (nops(uda)>1) then for k in uda do if (max(seq(evalf(abs(v[2][k])),v=A2))1) then WARNING("More than one undirected axes: %1",uda) end end; if (output="TR") then T,R else A2 end end: #hfl: Superimpose Superimpose:=proc( Atoms1::list, Atoms20::list, perm2::list(posint):=[$1..nops(Atoms20)], {massweighted::boolean:=false, isotopes::list:=[0$nops(Atoms1)], weights::{"mass",Vector}:=Vector(nops(Atoms1),1), det::{-1,0,1}:=0, axis::{undefined,Vector(3)}:=undefined, cellonly::boolean:=false, translateonly::boolean:=false, unorderedtvs::boolean:=false, raiseerror::boolean:=false, output::string:="a", printout::boolean:=false },$) local Atoms2,ispoints,n,P1,P2,nt,na,w,W,R,A1,A2,M1,M2,V,r1,r2,P,R0,RMS,RMS0,rm,rp,e,alpha,M,o,o1,o2,o3,ev,evc,s,q,dev,lsi,Atoms,v,i,c; Atoms2:=Atoms20[perm2]; ispoints:=not(evalb(type(Atoms1[1],list))); n:=nops(Atoms1); if not(n=nops(Atoms2)) then error("Molecules differ by size, %1<>%2",n,nops(Atoms2)) end; if not(ispoints) and not(foldl(`and`,seq(evalb(Atoms1[i][1]=Atoms2[i][1]),i=1..n))) then if raiseerror then error("Molecules differ by composition or are misordered") else WARNING("Molecules differ by composition or are misordered") end end; P1,P2:=evalf(`if`(ispoints,Atoms1,map2(op,2,Atoms1))),evalf(`if`(ispoints,Atoms2,map2(op,2,Atoms2))); nt:=add(`if`(v[1]=tvsymbol9,1,0),v=Atoms1); na:=n-nt; w:=Vector(n,i->`if`(i>na,0,`if`(massweighted,AtomMass(Atoms1[i][1],isotopes[i]),weights[i])),datatype=float); W:=add(v,v=w); R:=Matrix(3,(i,j)->`if`(i=j,1,0)); if (nt>0) then A1,M1:=Atoms2Cell(Atoms1,'transform','augment'=false); A2,M2:=Atoms2Cell(Atoms2,'transform','augment'=false); V:=[seq(map(round,A1[i][2][..nt]-A2[i][2][..nt]),i=1..na)]; P2:=[seq(P2[i]+M2.V[i],i=1..na),op(-nt..,P2)]; if (cellonly or na=0) then r1,r2:=<0,0,0>,<0,0,0> else r1,r2:=add(w[i]*P1[i],i=1..na)/W,add(w[i]*P2[i],i=1..na)/W end; if (translateonly) then P:=[seq(v-r2+r1,v=P2[..na]),seq(v,v=P2[-nt..])] elif (nt=1) then R0:=RotationMp2q(P2[-1],P1[-1]); if cellonly then P,R:=map(v->R0.v,P2),R0 else P,R:=Superimpose(P1[..na],map(v->R0.v,P2[..na]),':-det'=det,':-axis'=P1[-1],':-output'="ar"); P,R:=[op(P),R0.P2[-1]],R.R0 end else if unorderedtvs then R:=SuperimposeM(M1,M2,"r"); if (det<>0) then if (round(LinearAlgebra[Determinant](R))<>det) then WARNING("Cannot satisfy determinant condition for Tvs with SuperimposeM, will align TVs sequentally"); R:=LinearAlgebra[Transpose](RotationM2zx(P1[-nt],P1[-nt+1],12)).RotationM2zx(P2[-nt],P2[-nt+1],12,det) end end else if (det=0) then R :=LinearAlgebra[Transpose](RotationM2zx(P1[-nt],P1[-nt+1],12)).RotationM2zx(P2[-nt],P2[-nt+1],12,+1); R0:=LinearAlgebra[Transpose](RotationM2zx(P1[-nt],P1[-nt+1],12)).RotationM2zx(P2[-nt],P2[-nt+1],12,-1); RMS :=evalf(add(w[i]*add(v^2,v=R .(P2[i]-r2)+r1-P1[i]),i=1..na)/W); RMS0:=evalf(add(w[i]*add(v^2,v=R0.(P2[i]-r2)+r1-P1[i]),i=1..na)/W); if (RMS>RMS0) then R:=R0 end else R:=LinearAlgebra[Transpose](RotationM2zx(P1[-nt],P1[-nt+1],12)).RotationM2zx(P2[-nt],P2[-nt+1],12,det) end end; P:=[seq(R.(v-r2)+r1,v=P2[..na]),seq(R.v,v=P2[-nt..])] end else r1,r2:=add(w[i]*P1[i],i=1..n)/W,add(w[i]*P2[i],i=1..n)/W; if translateonly then P:=[seq(v-r2+r1,v=P2)] else rm:=Matrix(n,3,(i,o)->P2[i][o]-r2[o]-P1[i][o]+r1[o],datatype=float); rp:=Matrix(n,3,(i,o)->P2[i][o]-r2[o]+P1[i][o]-r1[o],datatype=float); if type(axis,Vector) then e:=LinearAlgebra[Normalize](axis,2); alpha:=arctan( 2*add(w[i]*(e[1]*(rm[i,2]*rp[i,3]-rm[i,3]*rp[i,2])+e[2]*(rm[i,3]*rp[i,1]-rm[i,1]*rp[i,3])+e[3]*(rm[i,1]*rp[i,2]-rm[i,2]*rp[i,1])),i=1..n), add(w[i]*(rp[i,1]^2+rp[i,2]^2+rp[i,3]^2-(e[1]*rp[i,1]+e[2]*rp[i,2]+e[3]*rp[i,3])^2-rm[i,1]^2-rm[i,2]^2-rm[i,3]^2+(e[1]*rm[i,1]+e[2]*rm[i,2]+e[3]*rm[i,3])^2),i=1..n)); R:=RotationM(alpha,e) else M:=Matrix(4,datatype=float,shape=symmetric); M[1,1]:=add(w[i]*(rm[i,1]^2+rm[i,2]^2+rm[i,3]^2),i=1..n); for o1 from 1 to 3 do o2,o3:=(o1 mod 3)+1,((o1+1) mod 3)+1; M[1+o1,1+o1]:=add(w[i]*(rm[i,o1]^2+rp[i,o2]^2+rp[i,o3]^2),i=1..n); M[1,1+o1]:=add(w[i]*(rp[i,o2]*rm[i,o3]-rm[i,o2]*rp[i,o3]),i=1..n); M[1+o2,1+o3]:=add(w[i]*(rm[i,o2]*rm[i,o3]-rp[i,o2]*rp[i,o3]),i=1..n) end; ev,evc:=LinearAlgebra[Eigenvectors](M); s:=`if`(det=1 or det=0 and ev[1]<=add(M[o,o],o=1..4)/2-ev[4],1,-1); q:=evc[..,s]; R:=s*<< q[1]^2+q[2]^2-q[3]^2-q[4]^2, 2*(q[2]*q[3]+q[1]*q[4]), 2*(q[2]*q[4]-q[1]*q[3]) >| < 2*(q[2]*q[3]-q[1]*q[4]), q[1]^2-q[2]^2+q[3]^2-q[4]^2, 2*(q[3]*q[4]+q[1]*q[2]) >| < 2*(q[2]*q[4]+q[1]*q[3]), 2*(q[3]*q[4]-q[1]*q[2]), q[1]^2-q[2]^2-q[3]^2+q[4]^2 >> end; P:=[seq(R.(v-r2)+r1,v=P2)] end end; dev:=[seq(sqrt(add(v^2,v=P1[i]-P[i])),i=1..n)]; RMS:=sqrt(add(w[i]*dev[i]^2,i=1..n)/W); if printout then printf("Initial weighted RMS = %.3g\n",sqrt(add(w[i]*add(v^2,v=P1[i]-P2[i]),i=1..n)/W)); printf("Optimized weighted RMS = %.3g\n",sqrt(add(w[i]*add(v^2,v=P1[i]-P [i]),i=1..n)/W)); printf("Initial center of mass difference = <%{c,}.3g>\n",add(w[i]*(P1[i]-P2[i]),i=1..n)); printf("MustBeZero center of mass difference = <%{c,}.0e>\n",add(w[i]*(P1[i]-P [i]),i=1..n)); printf("Initial orbital moment difference = <%{c,}.3g>\n",add(w[i]*LinearAlgebra[CrossProduct](P1[i],P2[i]),i=1..n)); printf("MustBeZero orbital moment difference = <%{c,}.0e>\n",add(w[i]*LinearAlgebra[CrossProduct](P1[i],P [i]),i=1..n)); printf("Displacement 1 = <%{c,}.3g>\n",r1); printf("Displacement 2 = <%{c,}.3g>\n",r2); printf("Rotation det = %d, angle = %.3g, axis = <%{c,}.3g>\n",RotationParam(R,'degrees')); lsi:=SortIdx(dev,'nolist'); printf("Largest deviations:%{c,}s%s\n",Vector(min(5,n),i->sprintf(" %d=%.2g",lsi[-i],dev[lsi[-i]])),`if`(n>5,",...","")) end; V:=map(v->R.(v-r2)+r1,Vector(nops(Atoms20),i->`if`(ispoints,Atoms20[i],Atoms20[i][2]))); for i from 1 to n do V[perm2[i]]:=P[i] end; Atoms:=`if`(ispoints,[seq(v,v=V)],[seq([Atoms20[i][1],V[i]],i=1..nops(Atoms20))]); seq(`if`(c="a",Atoms,`if`(c="d",RMS,`if`(c="D",RMS*sqrt(W),`if`(c="e",max(dev),`if`(c="f",dev, `if`(c="r",R,`if`(c="1",r1,`if`(c="2",r2,`if`(c="v",ev,`if`(c="m",M,`if`(c="w",w,`if`(c="W",W,NULL)))))))))))),c=output) end: #hfl: MatchMol GuessPermutation:=proc(A1::list,A2::list,maxdev::numeric:=999,{astable::boolean:=false,checkidentity::boolean:=false},$) local na1,na2,es,ne,gs1,gs2,P,Vd,maxd2,m,ijd2,e,i,j,d2; na1,na2:=nops(A1),nops(A2); if (checkidentity and (na1<>na2)) then error("Different number of atoms: %1<>%2",na1,na2) end; es:=convert({seq(v[1],v=A1),seq(v[1],v=A2)},list); ne:=nops(es); gs1:=[seq([seq(`if`(A1[i][1]=e,i,NULL),i=1..na1)],e=es)]; gs2:=[seq([seq(`if`(A2[i][1]=e,i,NULL),i=1..na2)],e=es)]; if (checkidentity and not(foldl(`and`,seq(nops(gs1[m])=nops(gs2[m]),m=1..ne)))) then error("Molecules have different compositions: %1<>%2",seq(cat(seq(cat(es[m]," ",nops(v[m])," "),m=1..ne)),v=[gs1,gs2])) end; P,Vd:=Vector(na1,datatype=integer),Vector(na1,datatype=float); maxd2:=evalf(maxdev^2); for m from 1 to ne do ijd2:=IdentifyPairs(gs1[m],gs2[m],(i,j)->add(evalf(v^2),v=A1[i][2]-A2[j][2]),"v"); for e in ijd2 do i,j,d2:=op(e); if (d2>maxd2) then break else P[i],Vd[i]:=j,sqrt(d2) end end end; if astable then [seq(`if`(P[i]=0,NULL,i=P[i]),i=1..na1)],[seq(`if`(P[i]=0,NULL,i=Vd[i]),i=1..na1)] else convert(P,list),convert(Vd,list) end end: #hfl: MatchMol MatchMol:=proc( Atoms1::list, Atoms2::list, method::{"","topo","geo","refp"}:="", MSDmax::realcons:=`if`(method="geo",10.^(2-Digits),999), { emax::numeric:=`if`(method="geo",1,999), dmax::numeric:=0.3, refp::list:=[], asis::boolean:=false, det::{-1,0,1}:=1, scan::{0,1,2,3,12,13,23,123}:=123, opt4CA1::list:=[], opt4CA2::list:=opt4CA1, opt4CO1::list:=[], opt4CO2::list:=opt4CO1, output::string:="b", printout::boolean:=false, xyzfile::string:=cat(tmpfld,"_tmp.xyz"), digits::posint:=3 },$) local prn,na,b,P1,d1,C1,C2,fp1,fp2,Vd,Atoms2a,d,A1,A0,R,ls1,ls2,ls3,R11,R22,R33,A2a,Pa,Vda,da,P,A2,e,p1,p2,c; prn:=proc(Vd) local V,d; V:=sort(Vd); d:=evalf(sqrt(add(v^2,v=Vd)/na)); if (na>6) then printf("MSD=%.*g, distances=[%{c,}.*g,...,%{c,}.*g]\n",digits,d,digits,Vector(V[..3]),digits,Vector(V[-3..])) else printf("MSD=%.*g, distances=[%{c,}.*g]\n",digits,d,digits,Vector(V)) end end; na:=nops(Atoms1); # refp if (method="refp") then b:=true; A2a:=Superimpose(Atoms1[map(lhs,refp)],Atoms2,map(rhs,refp),':-det'=det,':-printout'=printout); P,Vd:=GuessPermutation(Atoms1,A2a,'checkidentity'); d,Vd,Atoms2a:=Superimpose(Atoms1,Atoms2[P],':-det'=det,':-output'="dfa"); if printout then prn(Vd); WriteXYZ(xyzfile,[op(Atoms1),op(Atoms2a)],'overwrite') end else # topo b,P1,d1:=false,[$1..na],infinity; if (method="" or method="topo") then C1:=ConnectAtoms(Atoms1,op(opt4CA1)); fp1:=MolFingerprint(Atoms1,C1); C2:=ConnectAtoms(Atoms2,op(opt4CA2)); fp2:=MolFingerprint(Atoms1,C1); if (fp1=fp2) then b:=GraphTheory[IsIsomorphic](GraphTheory[Graph](MolGraph(Atoms1,C1)),GraphTheory[Graph](MolGraph(Atoms2,C2)),'P1'); if b then P1:=convert(table(P1),list)[..na]; d1,Vd,Atoms2a:=Superimpose(Atoms1,Atoms2[P1],':-det'=det,':-output'="dfa"); if printout then prn(Vd); WriteXYZ(xyzfile,[op(Atoms1),op(Atoms2a)],'overwrite') end; else if printout then printf("Molecular graphs are nonisomorphic\n") end end else if printout then printf("Molecular fingerprints are different:\n1=%s\n2=%s\n",fp1,fp2) end end end; # geo if (method="" or method="geo") then if asis then Atoms2a:=Atoms2; d:=undefined else if printout then printf("Canonic Orientation:\n") end; A1:=CanonicOrientation(Atoms1,op(opt4CO1)); A0:=CanonicOrientation(Atoms2,op(opt4CO2)); R:=Matrix(3,datatype=float): ls1:=`if`(member(scan,[1,12,13,123]),[1,-1],[1]); ls2:=`if`(member(scan,[2,12,23,123]),[1,-1],[1]); ls3:=`if`(member(scan,[3,13,23,123]),[1,-1],[1]); d:=1e22; for R11 in ls1 do R[1,1]:=R11; for R22 in ls2 do R[2,2]:=R22; for R33 in ls3 do R[3,3]:=R33; A2a:=[seq([v[1],R.v[2]],v=A0)]; Pa,Vda:=GuessPermutation(A1,A2a,'checkidentity'); da:=sqrt(add(v^2,v=Vda)/na); if (dadmax,NULL,i),i=1..na)]; if printout then printf("%d atoms out of %d are used for superimposing\n",nops(ls1),na) end; if (nops(ls1)<3 and na>nops(ls1)) then WARNING("Number of close atoms is less than 3. Increase dmax=%1",dmax); Atoms2a:=Superimpose(Atoms1,Atoms2[P],':-det'=det) else d,R,p1,p2:=Superimpose(Atoms1[ls1],Atoms2[P][ls1],':-output'="dr12"); Atoms2a:=[seq([v[1],R.(v[2]-p2)+p1],v=Atoms2)] end end; P,Vd:=GuessPermutation(Atoms1,Atoms2a,'checkidentity'); d,Vd,Atoms2a:=Superimpose(Atoms1,Atoms2[P],':-det'=det,':-output'="dfa"); if printout then prn(Vd); WriteXYZ(xyzfile,[op(Atoms1),op(Atoms2a)],'overwrite') end; if (method="" and b) then if (dnops(joints)+1) then error("Inconsistent numbers of molecules and joints") end; if (nm<>nops(dets)) then error("Inconsistent numbers of molecules and dets") end; tbrcov:=table(rcov); topo:=HasTopology(molecules[1]); i0s:=Vector(nm,datatype=integer); for m from 2 to nm do i0s[m]:=i0s[m-1]+nops(molecules[m-1]) end; As:=Vector(nm,m->map(v->[v[1],dets[m]*v[2],op(3..,v),[]],Vector(nops(molecules[m]),i->molecules[m][i]))); for m2 from 2 to nm do J:=joints[m2-1]; m1:=`if`(J[1]>0,J[1],m2+J[1]); if (m1>=m2 or m1<1) then error("Molecule %1 can be attached only to previous molecules, not to %2",m2,m1) end; A1:=As[m1]; i1,j1,k1:=op(J[2]); A2:=As[m2]; i2,j2,k2:=op(J[3]); T1:=OrientBy2Vectors(A1[k1][2]-A1[i1][2],A1[i1][2]-A1[j1][2],':-output'=1); T2:=OrientBy2Vectors(A2[i2][2]-A2[k2][2],`if`(nops(A2)<3 or angle(A2[i2][2]-A2[k2][2],A2[j2][2]-A2[i2][2])<1,LinearAlgebra[RandomVector](3),A2[j2][2]-A2[i2][2]),':-output'=1); R:=T1^(-1).evalf(RotationM(Pi*(J[4]/180-1),<1,0,0>)).T2; b:=`if`(nops(J)>4,J[5],add(`if`(assigned('tbrcov[v]'),tbrcov[v],tb_rcov[v]),v=[A1[i1][1],A2[i2][1]])); p1:=A1[i1][2]+b*LinearAlgebra[Normalize](A1[k1][2]-A1[i1][2],2); p2:=A2[i2][2]; A1[i1]:=subsop(-1=[op(A1[i1][-1]),4*m2+2],A1[i1]); A1[j1]:=subsop(-1=[op(A1[j1][-1]),4*m2+1],A1[j1]); A1[k1]:=subsop(-1=[op(A1[k1][-1]),0 ],A1[k1]); A2[i2]:=subsop(-1=[op(A2[i2][-1]),4*m2+3],A2[i2]); A2[j2]:=subsop(-1=[op(A2[j2][-1]),4*m2+4],A2[j2]); A2[k2]:=subsop(-1=[op(A2[k2][-1]),0 ],A2[k2]); if topo then di:=i0s[m2]-i0s[m1]; A1[i1]:=subsop(4=Substitute(A1[i1][4],k1,i2+di),A1[i1]); A2[i2]:=subsop(4=Substitute(A2[i2][4],k2,i1-di),A2[i2]) end; As[m2]:=map(v->subsop(2=R.(v[2]-p2)+p1,v),As[m2]) end; if topo then for m from 2 to nm do As[m]:=map(v->subsop(4=map(`+`,v[4],i0s[m]),v),As[m]) end end; A:=[seq(seq(u,u=v),v=As)]; lsi:=[seq(`if`(member(0,A[i][-1]),i,NULL),i=1..nops(A))]; A:=RemoveAtoms(A,lsi); J:=Matrix(nm-1,4,datatype=integer); for i from 1 to nops(A) do for v in A[i][-1] do J[iquo(v-5,4),irem(v-1,4)+1]:=i end end; J:=convert(J,listlist); if printout then printf("Joints:%s\n",StringTools[DeleteSpace](sprintf("%a",J))) end; seq(`if`(c="a",map(v->v[..-2],A),`if`(c="j",J,NULL)),c=output) end: #hfl: AttachPoints AttachPoints:=proc(points::list(Vector(3)),b::realcons,n::nonnegint,{a34::realcons:=0},$) local p,es,m,e1,e2,e3,ls,x; if (nops(points)<2) then error("At least two points are required") end; p:=points[1]; es:=map(v->LinearAlgebra[Normalize](v-p,2),points[2..]); m:=nops(es); e1:=LinearAlgebra[Normalize](-add(v,v=es),2); e3:=`if`(m=1,`if`(e1[1]=0 and e1[2]=0,<0,1,0>,<0,0,1>),ODR(points,"plane")[2]); e2:=LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](e3,e1),2); e3:=LinearAlgebra[CrossProduct](e1,e2); if (n=0) then ls:=[] elif (n=1) then ls:=[e1] elif (n=2 and m=1) then ls:=[e1+sqrt(3)*e3,e1-sqrt(3)*e3] elif (n=2 and m=2) then x:=`if`(a34=0,2,tan(Pi/360*a34)^2); ls:=[e1+sqrt(x)*e3,e1-sqrt(x)*e3] elif (n=3 and m=1) then ls:=[e1+sqrt(8)*e2,e1-sqrt(2)*e2+sqrt(6)*e3,e1-sqrt(2)*e2-sqrt(6)*e3] else error("Unsupported combination: n=%1, m=%2",n,m) end; map(v->simplify(p+b*LinearAlgebra[Normalize](v,2)),ls) end: #hfl: SymmetrizeCell SymmetrizeCell:=proc(Atoms::list,Cell::list,axes::{12,21,13,31,23,32}:=12,symdev::[numeric,numeric,numeric]:=[1e-4,1e-3,1e-4],{base::integer:=0,printout::boolean:=false},$) local A,C,SG,n,r,i1,i2,i3,a,d,ls,i,j,k,l,o,base1; A:=Vector(nops(Atoms),l->Vector(Atoms[l][2],datatype=anything)); C:=Vector(Cell); SG:=`if`(nops(Cell)>6,Cell[7],""); n:=`if`(SG="",0,FiniteGroups[SpaceGroupNumber][FiniteGroups[SymmetryGroup](SG,'output'="n")]); if not(type(n,integer)) then n:=-FiniteGroups[LayerGroupNumber][FiniteGroups[SymmetryGroup](SG,'output'="n")]; if not(type(n,integer)) then WARNING("Unrecognized symmetry group in Cell=%1",Cell); return Atoms,Cell end end; r:=evalb(length(SG)>1 and SG[-2..]=":R"); i1,i2,i3:=op(DecodeAxes(axes)); if (n<>0) then # lengths if (n>=195 or r) then a:=(C[1]+C[2]+C[3])/3; d:=max(seq(abs(v-a),v=C[1..3]))/a; if (d>symdev[1]) then WARNING("a=b=c deviation is %1",d) end; C[1],C[2],C[3]:=a,a,a elif (n>=75 or n<=-49) then a:=(C[i1]+C[i2])/2; d:=abs(C[i1]-a)/a; if (d>symdev[1]) then WARNING("a=b deviation is %1",d) end; C[i1],C[i2]:=a,a end; # angles if r then a:=(C[4]+C[5]+C[6])/3; d:=max(seq(abs(v-a),v=C[4..6]))/a; if (d>symdev[2]) then WARNING("Deviation from rhombohedral angles is %1",d) end; C[4],C[5],C[6]:=a,a,a elif (n>=143 and n<195 or n<=-65) then d:=max(abs(C[3+i1]-90),abs(C[3+i2]-90),abs(C[3+i3]-120)); if (d>symdev[2]) then WARNING("Deviation from hexagonal angles (unique axis Z) is %1",d) end; C[3+i1],C[3+i2],C[3+i3]:=90,90,120 elif (n>=16 or n<=-8) then d:=max(seq(abs(v-90),v=C[4..6])); if (d>symdev[2]) then WARNING("Deviation from right angles is %1",d) end; C[4],C[5],C[6]:=90,90,90 elif (n>=3) then ls:=map(v->abs(v-90),C[4..6]); i:=op(MaxIdx(ls)); j,k:=op(`minus`({1,2,3},{i})); d:=max(ls[j],ls[k]); if (d>symdev[2]) then WARNING("Deviation from monoclinic angles (unique axis %1) is %2","XYZ"[i],d) end; C[3+j],C[3+k]:=90,90 end; else # lengths a:=(C[1]+C[2]+C[3])/3; if foldl(`and`,seq(abs(C[i]-a)=0) then base1:=piecewise(base>0,base,n=0,8,abs(n)=1,1,n<11 and n>-15,2,n<75,4,8); for l from 1 to nops(Atoms) do for o from 1 to 3 do if (abs(A[l][o]-round(base1*A[l][o])/base1) end end else for k from 1 to 3 do i,j:=(k mod 3)+1,(k+1 mod 3)+1; if (C[i]=C[j]) then for l from 1 to nops(Atoms) do a:=(A[l][i]+A[l][j])/2; if (abs(A[l][i]-a)0,scale,`if`(type(G[1],Matrix),1,5)); offset1:=[seq(`if`(nops(offset)v[1]=tvsymbol9,Atoms0); # begin Symmetrize cell if (Tvs<>[]) then Atoms,M:=Atoms2Cell(Atoms0,':-offset'=offset,'transform'); sTv:=[seq(signum(MaxVal(M[..,i],v->abs(v))),i=1..Dim2(M)[2])]; for i from 1 to nops(Tvs) do if (sTv[i]<0) then WARNING("Translation vector %1 is negative: %2 (M[..,%1]=%3)",i,Tvs[i],M[..,i]) end end; if (originalcell or nops(Tvs)=1) then elif (nops(Tvs)=2 or nops(Tvs)=3) then Cell:=M2cryst(M[DecodeAxes2(axesaxes)],cellsymmetry,tvzero); if (axesaxes<>1212) then if (type(Cell[-1],integer) and axesaxes<>Cell[-1]) then WARNING("axesaxes=%1 from M2cryst is overwritten by user-provided axesaxes=%2",Cell[-1],axesaxes); Cell:=subsop(-1=axesaxes,Cell) else Cell:=[op(Cell),axesaxes] end end; Cell2:=SymmetrizeCell([],Cell,cellaxes,symdev)[2]; M2:=cryst2M([op(Cell2),op(cryst2Mpars)]); det2:=signum(LinearAlgebra[Determinant](M2)); # Rotate M back to original settings R2a:=Superimpose([seq(M[..,i],i=1..Dim2(M)[2])],[seq(M2[..,i],i=1..Dim2(M)[2])],':-output'="r",'det'=det2); det2a,angle2a,axis2a:=RotationParam(R2a); angle2a:=evalf(angle2a/Pi); if (det2a<>det2) then error("det2a<>det2") end; if (angle2a<0.03 and det2=1) then M:=copy(M2) else angle2,axis2:=round(angle2a*12)/12,map(round,LinearAlgebra[Normalize](axis2a)*12)/12; R2:=det2*RotationM(Pi*angle2,axis2); dR2:=LinearAlgebra[Norm](evalf(R2-R2a),Frobenius); if (dR2>1e-4) then R2:=R2a; WARNING("Cannot rationalize R2a: dR2=%1, angle2a=%2, axis2a=%3",dR2,angle2a,convert(axis2a,list)) end; M:=evalf(R2.M2) end; # end Rotate M for i from 1 to Dim2(M)[2] do if (sTv[i]*MaxVal(M[..,i],v->abs(v))<0) then M[..,i]:=-M[..,i] end end; Tvs:=[seq([tvsymbol9,M[..,i]],i=1..nops(Tvs))] end # end Symmetrize cell else M:=scale1*<<1,0,0>|<0,1,0>|<0,0,1>> end; n,na:=nops(G),nops(Atoms); if type(axes,Matrix) then R:=axes else R:=Matrix(3,datatype=float); P:=[seq(parse(v),v=convert(axes,string))]; for o from 1 to 3 do R[P[o],o]:=1 end end; Ri:=R^(-1); lsA:=Vector(n); AL:=map2(op,1,Atoms); mmi:=`if`(type(monomers,list),monomers,[ListTools[LengthSplit]([$1..na],`if`(monomers<0,-monomers*na/n,monomers))]); if (mmi=[]) then lsA[1]:=[seq([v[1],evalf(FiniteGroups[FG_app](G[1],R.v[2],offset1,true))],v=Atoms)] else mmp1:=[seq(evalf(FiniteGroups[FG_apl](G[1],[seq(R.v[2],v=Atoms[u])],offset1,true)),u=mmi)]; ls:=ListTools[FlattenOnce](mmp1); lsA[1]:=[seq([AL[i],ls[i]],i=1..na)] end; if (PorA=[]) then useP,lsP:=false,Vector(n); lsP[1]:=[$1..na] elif type(PorA,listlist(posint)) then useP,lsP:=true,PorA; if not(nops(lsP)=n and nops(lsP[1])=na) then error("Wrong permutation list: %1",PorA) end else useP:=true; if (nops(PorA)<>nops(Atoms0)) then error("Wrong number of atoms in permutation-generating set: %1",PorA) end; lsP:=SymmetrizeAtoms(PorA,G,R,':-output'="p") end; if printout then maxlen:=9; for k from 2 to n do maxlen:=max(maxlen,length(FiniteGroups[PrintSymmetryElement](G[k],printkind))) end; printf(" \# %-*s%*s distances\n",maxlen-1,"symmetry",3+digits,"MSD") end; kdd:=table(): for k from 2 to n do if printout then s:=sprintf("%3d %-*s",k,maxlen,FiniteGroups[PrintSymmetryElement](G[k],printkind)) end; if (mmi=[]) then A:=[seq([v[1],evalf(FiniteGroups[FG_app](G[k],v[2],offset1,true))],v=lsA[1])] else ls:=evalf([seq(op(FiniteGroups[FG_apl](G[k],v,offset1,true)),v=mmp1)]); A:=[seq([AL[i],ls[i]],i=1..na)] end; if useP then P:=lsP[k]; Vd:=[seq(evalf(len(lsA[1][i][2]-A[P[i]][2])),i=1..na)] else P,Vd:=GuessPermutation(lsA[1],A,'checkidentity'); lsP[k]:=P end; dev,MSD:=max(Vd),sqrt(add(v^2,v=Vd)); if (scale1*dev>maxdev) then kdd[k]:=[k,dev,MSD] end; if printout then s:=sprintf("%s%*.*f %s",s,3+digits,digits,MSD,`if`(scale1*dev>maxdev,"*"," ")); lsi:=SortIdx(-Vd,'nolist'); for j from 1 to na while ((j=1 or scale1*Vd[lsi[j]]>dmax) and length(s)linewidth) then printf("%s...\n",s[..linewidth-4]) else printf("%s\n",s) end else if (not(nowarning) and scale1*dev>maxdev) then WARNING("No symmetry for element %1",k) end end; lsA[k]:=A[P] end; kdd:=convert(kdd,list); if printout then WriteXYZ(xyzfile,map(v->[v[1],M.v[2]],[seq(op(lsA[k]),k=1..n)]),'overwrite') end; orbs:=Sort(convert({seq(sort(convert({seq(lsP[k][i],k=1..n)},list)),i=1..na)},list),[1]); no:=nops(orbs); A:=[seq(subsop(2=evalf(Ri.add(lsA[k][i][2],k=1..n)/n),Atoms[i]),i=1..na)]; if (ref=[]) then FD:=A[map2(op,1,orbs)] else if (nops(ref)<>no) then error("Inconsistent ref and orbs: nops(ref)=%1<>nops(orbs)=%2",nops(ref),no) end; Md:=Matrix(no,na,(l,i)->add(v^2,v=M.(ref[l][2]-A[i][2]))); ls:=Sort(IdentifyPairs([$1..no],[$1..na],(l,i)->Md[l,i],'nolist'),[1]); for v in ls do if (v[3]>maxdev^2) then WARNING("No reference for FD atom ref[%1]=%2. The nearest A[%3]=%4 is %5 apart", v[1],sprintf("[%s,<%.3f>]",op(ref[v[1]])),v[2],sprintf("[%s,<%.3f>]",op(A[v[2]])),sprintf("%.6f",sqrt(v[3]))) end end; FD:=A[map2(op,2,ls)] end; gen:=Vector(na,datatype=integer); for orb in orbs do i:=orb[1]; for j in orb do for k from 1 to n do if (lsP[k][j]=i) then gen[j]:=k; break end end end end; gen:=convert(gen,list); A1:=[seq(subsop(2=lsA[gen[i]][i][2],Atoms[i]),i=1..na)]; if (Tvs<>[]) then # if (nops(Tvs)=1) then A:=map(v->[v[1],],A) elif (nops(Tvs)=2) then A:=map(v->[v[1],],A) end; A:=[seq([A[i][1],M.Vector(3,o->A[i][2][o]+round(Atoms[i][2][o]-A[i][2][o]),datatype=float),op(3..,Atoms[i])],i=1..na),op(Tvs)]; FD:=[seq(A[v[1]],v=orbs),op(Tvs)] end; seq(`if`(c="a",A,`if`(c="d",FD,`if`(c="g",gen,`if`(c="1",A1,`if`(c="b",evalb(kdd=[]),`if`(c="o",orbs,`if`(c="p",[seq(P,P=lsP)],`if`(c="f",kdd,NULL)))))))),c=output) end: #hfl: UnfoldBySymmetry UnfoldBySymmetry:=proc( Atoms::list, Cell::{string,list}, maxdev::numeric:=1.1e-4, offset::list({numeric,undefined}):=[], { fd1st::boolean:=false, primitive::boolean:=false },$) local SG,G,T,Ti,TMi,Atoms2,x0,iszero,Tvs,A,M,ls,i,j,k,v,u; if primitive then SG:=`if`(type(Cell,string),Cell,Cell[7]); if not(type(SG,string)) then error("Unrecognized space group in the provided Cell=%1",Cell) end; G,T:=FiniteGroups[SymmetryGroup](SG,':-primitive'=true,'output'="GT"); Ti:=FiniteGroups[FG_inv](T); TMi:=`if`(type(Ti,list),Ti[1],Ti); Atoms2:=[seq([v[1],TMi.v[2]],v=Atoms)]; UnfoldBySymmetry(Atoms2,G,maxdev,offset,':-fd1st'=fd1st),`if`(type(Cell,string),NULL,cryst2M(Cell).`if`(type(T,list),T[1],T)) else x0:=[op(offset),undefined$(3-nops(offset))]; if (type(Cell,list) and type(Cell[1],indexable)) then G:=Cell else SG:=`if`(type(Cell,string),Cell,Cell[7]); G,k:=FiniteGroups[SymmetryGroup](SG,'output'="Gk"); x0:=piecewise(k[8]=0,[undefined$3],k[8]=1,[x0[1],-1/2,-1/2],k[8]=2,[x0[1],x0[2],-1/2],x0) end; iszero:=`if`(type(G[1],Matrix), x->abs(x)abs(Reduce2P(x,1,-1/2))v[1]=tvsymbol9,Atoms); if (nops(Tvs)>0) then A,M:=Atoms2Cell(Atoms,'transform') end; if fd1st then ls:=[seq([seq(subsop(2=v,u),v=FiniteGroups[FG_orbit](G,u[2],"p",iszero))],u=A)]; A:=[seq(seq(`if`(j>nops(ls[i]),NULL,ls[i][j]),i=1..nops(A)),j=1..max(seq(nops(v),v=ls)))] else A:=[seq(seq(subsop(2=v,u),v=FiniteGroups[FG_orbit](G,u[2],"p",iszero)),u=A)] end; A:=[seq(subsop(2=Vector(3,o->`if`(x0[o]=undefined,v[2][o],Reduce2P(v[2][o],1,x0[o]))),v),v=A)]; if (nops(Tvs)>0) then [seq(subsop(2=M.v[2],v),v=A),op(Tvs)],M else A end end end: #hfl: SelectAtoms SelectAtoms:=proc(Atoms0::list,selfun::{"d"},params::{[numeric,list({posint,Vector})]},{printout::boolean:=false},$) local Tvs,Atoms,R,p0; Tvs,Atoms:=selectremove(v->v[1]=tvsymbol9,Atoms0); if (selfun="d") then R:=params[1]; p0:=add(`if`(type(v,posint),Atoms[v][2],v),v=params[2])/nops(params[2]); if (Tvs<>[]) then Atoms:=remove(v->v[1]=tvsymbol9,SuperCell(Atoms0,R)) end; Atoms:=select(v->len(v[2],p0)<=R,Atoms) end; Atoms end: ################################################################################ #cat: Molecular file tools #hfl: HasTopology HasTopology:=proc(A::list,$) evalb(nops(A)>0 and nops(A[1])>3 and type(A[1][4],list(integer))) end: #hfl: ReadXYZ ReadXYZ:=proc(S::{string,list}, format::string:="%s %f %f %f", pos::list:=[1,2,3,4], { output::posint:=1, all::boolean:=false, nocomment::boolean:=false, printout::boolean:=false },$) local opts,ncom,getN,L,T,M,k,N,m,l,A,v,com,maxpos,i,n,rest; opts:=':-output'=output,':-nocomment'=nocomment,':-printout'=printout; ncom:=`if`(nocomment,0,1); if type(S,string) then getN:=proc(s) local v,N; v:=sscanf(s,"%d"); if (v=[]) then 0 else N:=v[1]; if (Trim(s)=sprintf("%d",N)) then N else 0 end end end; L:=ReadLines(`if`(FileTools[Exists](S),S,cat(S,".xyz"))); if (L=[]) then return [] end; if all then T,M:=table(),0; for k from 1 to nops(L) do N:=getN(L[k]); if (N>0) then M:=M+1; T[M]:=[N,k+1]; k:=k+ncom+N end end; if (M=0) then return [] end; for m from 1 to M-1 do T[m]:=[op(T[m]),T[m+1][2]] end; T[M]:=[op(T[M]),nops(L)]; T:=[seq([ReadXYZ([T[m][1],op(T[m][2]..T[m][3],L)],format,pos,opts)],m=1..M)]; seq(map2(op,l,T),l=1..nops(T[1])) else N:=getN(L[1]); if (N=0) then error("First line must begin with number of atoms but received %1",L[1]) end; ReadXYZ([N,op(2..,L)],format,pos,opts) end else if (format="tin" ) then ReadXYZ(S,"%d %s %f %f %f",[2,3,4,5],opts) elif (format="atypes") then ReadXYZ(S,"%s %f %f %f `%d",[1,2,3,4,5],opts) elif (format="topology") then L:=[ReadXYZ(S,"%s %f %f %f `%d [%d,%d,%d,%d,%d,%d]",[$1..11],opts)]; A:=map(v->[v[1],v[2],`if`(nops(v)>2,op([v[3],[op(4..,v)]]),NULL)],L[1]); A,op(2..,L) else N:=S[1]; com:=`if`(nocomment,"",S[2]); maxpos:=max(op(..4,pos)); A:=Vector(N); for i from 1 to N do try L:=sscanf(S[1+ncom+i],format) catch: break end; n:=nops(L); if (nL[pos[1+k]],datatype=float),seq(`if`(k>n,NULL,L[k]),k=pos[5..])] end; if (i-1<>N) then WARNING("Expected %1 atoms but found only %2 atoms",N,i-1) end; rest:=Trim(StringTools[Join](S[1+ncom+`if`(i-1=N,N,i)+1..],"\n"),["\n"]); if printout then printf("%s //%d%s\n",com,N,`if`(rest="","",cat(" //",length(rest)))) end; op(1..min(3,output),[convert(A,list),com,rest]) end end end: #hfl: ReadXYZ WriteXYZ:=proc(filename::string, Atoms::list, comment::string:="", {firstline::string:="", after::string:="", normalmode::{Matrix,Vector,0}:=0, format1::string:=" %-4s", format2::string:=cat(" %",digits+6,".",digits,"f"), digits::nonnegint:=xyzdigits, format3::string:="", compact::{boolean,nonnegint}:=false, append::boolean:=false, overwrite::boolean:=false},$) local A,na,fd,format,Atom,s,i,M; if type(Atoms[1][1],list) then # list of list of atoms WriteXYZ(filename,Atoms[1],comment,':-firstline'=firstline,':-format1'= format1,':-format2'= format2,':-digits'=digits,':-compact'=compact,':-overwrite'=overwrite); for A in Atoms[2..] do WriteXYZ(filename,A,':-format1'= format1,':-format2'=format2,':-digits'=digits,':-compact'=compact,':-append'=true,':-overwrite'=overwrite) end elif type(Atoms[1][2],list) then # list of list of atoms with comments WriteXYZ(filename,Atoms[1][2],cat(Atoms[1][1],comment),':-firstline'=firstline,':-format1'= format1,':-format2'= format2,':-digits'=digits,':-compact'=compact,':-overwrite'=overwrite); for A in Atoms[2..] do WriteXYZ(filename,A[2],A[1],':-format1'= format1,':-format2'=format2,':-digits'=digits,':-compact'=compact,':-append'=true,':-overwrite'=overwrite) end else # single list of atoms na:=nops(Atoms); if (filename<>"") then if (FileTools[Exists](filename) and not(overwrite or append)) then error "File exists, %1",filename end; fd:=fopen(filename,`if`(append,'APPEND','WRITE'),'TEXT') else fd:=fopen('terminal','WRITE') end; fprintf(fd,"%d %s\n%s\n",na,firstline,comment); if (normalmode=0) then format:=`if`(compact=false,cat(format1,format2,"%s\n"),cat("%s %.",`if`(compact=true,digits,compact),"f%s\n")); if (format3="" and nops(Atoms[1])>3 and type(Atoms[1][3],integer) and type(Atoms[1][4],list(posint))) then for Atom in Atoms do try s:=sprintf(" `%-4d [%{c,}d]",Atom[3],Vector(Atom[4])) catch: s:="" end; fprintf(fd,format,Atom[1],Vector(Atom[2]),s) end else for Atom in Atoms do try s:=sprintf(format3,op(3..,Atom)) catch: s:="" end; fprintf(fd,format,Atom[1],Vector(Atom[2]),s) end end else format:=`if`(compact=false,cat(format1,format2,format2,"\n"),cat("%s %.",`if`(compact=true,digits,compact),"f %.",`if`(compact=true,digits,compact),"f\n")); if type(normalmode,Vector) then if (Dim2(normalmode)<>3*na) then fclose(fd); error("Length(normalmode)<>3*nops(Atoms)") else M:=ArrayTools[Reshape](normalmode,[3,na]) end; else if ([Dim2(normalmode)]<>[3,na]) then fclose(fd); error("Dimensions(normalmode)<> 3 by nops(Atoms)") else M:=normalmode end end; for i from 1 to na do fprintf(fd,format,Atoms[i][1],Vector(Atoms[i][2]),M[..,i]) end end; if (after<>"") then fprintf(fd,after) end; if (filename<>"") then fclose(fd) end end # endif end: #hfl: ReadPDB ReadPDB:=proc( filename::string, output::string:="Atoms,Cell", { poscoo::posint:=31, printout::{boolean,nonnegint,[nonnegint,nonnegint]}:=false },$) local fd,Atoms,title,compnd,remark,i,s,id,atom,element,coo,Cell,com,ls,v,r; if not(printout=false) then PrintFile(filename,`if`(type(printout,posint),printout,`if`(type(printout,list),op(printout),NULL))) end; fd:=fopen(filename,READ,TEXT); Atoms,title,compnd,remark:=table(),"","",[]: for i from 1 to infinity while not(feof(fd)) do s:=readline(fd); id:=s[..6]; if (id="ATOM " or id="HETATM") then atom:=Trim(s[13..16]); element:=StringTools[Remove](StringTools[IsDigit],atom); if StringTools[IsUpper](element[2]) then element:=`if`(id="ATOM ",element[1],StringTools[Capitalize](element)) end; try coo:=sscanf(s[poscoo..],"%f%f%f")[1..3] catch: coo:=[seq(sscanf(s[v],"%f")[1],r=[31..38,39..46,47..54])] end; Atoms[i]:=[element,Vector(3,o->coo[o],datatype=float),`if`(id="ATOM ",[atom,Trim(s[18..20]),op(sscanf(s[23..26],"%d"))],NULL)] elif (id="CRYST1") then Cell:=[op(sscanf(s[7..55],"%f%f%f%f%f%f")),Trim(s[56..])] elif (id="TITLE ") then title:=Trim(s[7..]) elif (id="COMPND") then compnd:=Trim(s[7..]) elif (id="REMARK") then remark:=[op(remark),s[7..]] end end; fclose(fd); com:=StringTools[Join](remove(`=`,[title,compnd,op(remark)],""),"; "); remark:=StringTools[Join](remark,"\n"); Atoms:=convert(Atoms,list); ls:=StringTools[Split](output,","); if (ls=[""]) then ls:="" end; seq(`if`(s="Atoms",Atoms,`if`(s="Cell" and type(Cell,list),Cell,`if`(s="comment",com,`if`(s="REMARK",remark,`if`(s="TITLE",title,`if`(s="COMPND",compnd,NULL)))))),s=ls) end: #hfl: ReadPDB WritePDB:=proc(filename::string, Atoms::list, Cell::{undefined,[numeric,numeric,numeric,numeric,numeric,numeric,string]}:=undefined, con::list(list(posint)):=ConnectAtoms(Atoms,op(opt4CA)), {TITLE::string:="", COMPND::string:="", REMARK::string:="", opt4CA::list:=[], digits::nonnegint:=pdbdigits, extraspace::boolean:=false, before::string:="", after::string:="", overwrite::boolean:=false},$) local fd,e,i,m,j,ls; if (filename<>"") then if (FileTools[Exists](filename) and not(overwrite)) then error "File exists, %1",filename end; fd:=fopen(filename,WRITE,TEXT) else fd:=fopen('terminal',WRITE) end; if (before<>"") then writeline(fd,before) end; if (TITLE<>"" ) then writeline(fd,cat("TITLE ",TITLE)) end; if (COMPND<>"") then writeline(fd,cat("COMPND ",COMPND)) end; if (REMARK<>"") then writeline(fd,cat("REMARK ",REMARK)) end; if (Cell<>undefined) then fprintf(fd,cat("CRYST1",cat("%9.",digits,"f")$3,"%7.2f"$3," %s\n"),op(Cell)) end; for i from 1 to nops(Atoms) do fprintf(fd,cat("HETATM%5d %-4s %{s}8.*f\n"), i, cat(`if`(extraspace," ",""),Atoms[i][1]), digits, Atoms[i][2] ) end: if (con<>[]) then for i from 1 to nops(Atoms) do for e in remove(`=`,[ListTools[LengthSplit](select(`>`,con[i],i),4)],[]) do fprintf(fd,"CONECT %4d %4d\n",i,Vector(e)) end end end; if (after<>"") then writeline(fd,after) end; if (filename<>"") then fclose(fd) end end: #hfl: ReadGRO ReadGRO:=proc(filename::string,output::string:="a",notelements::list(string):=["Na","Nb","Si"],{printout::boolean:=false},$) local ls,desc,na,rest,box,sbox,Tvs,full,ff,A,c,v; ls:=ReadLines(`if`(FileTools[Exists](filename),filename,cat(filename,".gro"))); desc:=Trim(ls[1]); na:=parse(ls[2]); rest:=ls[na+3..]; ls:=ls[3..2+na]; box:=`if`(rest=[],[],10*sscanf(rest[1],"%f%f%f%f%f%f%f%f%f")); sbox:=`if`(box=[],"",sprintf("box=[%{c,}s]",Vector(map2(sprintf,"%a",map(ReduceFloat,box))))); if printout then printf("%s //%d //%d //%s\n",desc,na,nops(rest),sbox) end; Tvs:=`if`(nops(box)=3,[seq(["Tv",Vector(3,o->`if`(o=i,box[i],0))],i=1..3)],[]); full:=map(sscanf,ls,"%5d%5s%5s%5d%f%f%f%f%f%f"); ff:=proc(s) local e; e:=`if`(StringTools[IsLower](s[2]),`if`(AtomicNumber(s[..2],notag)>0,s[1..2],s[1]),s[1]); `if`(member(e,notelements),e[1],e) end; A:=[seq([ff(v[3]),10*Vector(v[5..7]),v[3]],v=full),op(Tvs)]; seq(`if`(c="a",A,`if`(c="b",box,`if`(c="B",sbox,`if`(c="d",desc,`if`(c="f",full,`if`(c="r",rest,'undefined')))))),c=output) end: #hfl: ReadAtomsCube ReadAtomsCube:=proc(filename::string,$) local N,ls,Atoms,i,e; N:=-ReadValue(filename,'shift'=2,'format'="%d"); ls:=ReadLines(filename,'shift'=6,'nlines'=N); Atoms:=table(): for i from 1 to N do e:=sscanf(ls[i],"%d%f%{3}fc"); Atoms[i]:=[ElementSymbol[e[1]],e[3]] end; convert(Atoms,list) end: #hfl: CombineXYZ CombineXYZ:=proc(filename::string,mask::string,{num::posint:=infinity,comment::string:="",overwrite::boolean:=false,append::boolean:=false,delete::boolean:=false}) local fd,i,Atoms; if FileTools[Exists](filename) then if overwrite then FileTools[Remove](filename) else if not(append) then error "File exists, %1",filename end end end; for i from 1 to num while FileTools[Exists](sprintf(mask,i)) do Atoms:=ReadXYZ(sprintf(mask,i),_rest); WriteXYZ(filename,Atoms,`if`(i=1,comment,NULL),':-append'=true,'after'="\n"); if delete then FileTools[Remove](sprintf(mask,i)) end end: fclose(filename) end: #hfl: xyz2MV xyz2MV:=proc(s::string,{x::string:="x",y::string:="y",z::string:="z",sep::string:=","},$) local M,V,ls,i,e; M,V:=Matrix(3),Vector(3); ls:=StringTools[Split](s,sep); for i from 1 to 3 do e:=ls[i]; V[i] :=eval(parse(StringTools[Substitute](StringTools[Substitute](StringTools[Substitute](e,x,"0"),y,"0"),z,"0"))); M[i,1]:=eval(parse(StringTools[Substitute](StringTools[Substitute](StringTools[Substitute](e,x,"1"),y,"0"),z,"0"))-V[i]); M[i,2]:=eval(parse(StringTools[Substitute](StringTools[Substitute](StringTools[Substitute](e,x,"0"),y,"1"),z,"0"))-V[i]); M[i,3]:=eval(parse(StringTools[Substitute](StringTools[Substitute](StringTools[Substitute](e,x,"0"),y,"0"),z,"1"))-V[i]) end; M,V end: #hfl: ReadCIF ReadCIF:=proc( filename::string, rec::nonnegint:=1, output::string:="A,C", addkeys::list:=[], {key_cell::[string,string,string,string,string,string]:=["_cell_length_a","_cell_length_b","_cell_length_c","_cell_angle_alpha","_cell_angle_beta","_cell_angle_gamma"], key_gen::string:="_symmetry_equiv_pos_as_xyz", key_atomname::{string,list(string)}:=["_atom_site_type_symbol","_atom_site_label"], key_coo::[string,string,string]:=["_atom_site_fract_x","_atom_site_fract_y","_atom_site_fract_z"], key_occ::string:="_atom_site_occupancy", atomname::procedure:=(s->StringTools[Select](StringTools[IsAlpha],s)), printout::boolean:=false, verbose::boolean:=false },$) local rl,split,readpar,key,fd,com,i,j,t,s,dat,tb,value,values2,ls,keys,values,n,e,p2k,pars,p2v,par,out,V,key1,na,U,ls2; # procedures rl:=proc() local s,i; s:=readline(fd); if (s=0 or s=NULL) then "end","" else i:=SearchText("#",s); if (i>0) then s,com:=s[..i-1],cat(com,Trim(s[i+1..]),"\n") end; s:=Trim(s); if (s="") then rl() elif (s[1..5]="data_") then "data",s[6..] elif (s[1..5]="loop_") then "loop","" elif (s[1]="_") then "key",s elif (s[1]=";") then "par","" else "",s end end end: split:=proc(s) local ls; ls:=StringTools[Split](s,"'"); op(remove(`=`,[seq(`if`(type(i,odd),op(StringTools[Split](ls[i])),ls[i]),i=1..nops(ls))],"")) end: readpar:=proc() local v,t,s; v:=""; t,s:=rl(); while (t<>"par") do v:=cat(v,"\n",s); t,s:=rl() end; v[2..] end: # read file fd:=fopen(`if`(FileTools[Exists](filename),filename,cat(filename,".cif")),READ,TEXT); com:="": for i from 1 to max(1,rec) do t:=""; while (t<>"data") do t,s:=rl(); if (t="end") then fclose(fd); error("Record #%1 is not found",max(1,rec)) end end end; dat:=[]: while (t="data") do tb:=table(["#data_label"=s]); t,s:=rl(); while (t="key" or t="loop") do if (t="key") then i:=searchtext(" ",s); if (i>0) then key,value:=s[1..i-1],Trim(s[i+1..],[" ","'"]) else key,value:=s,"" end; if (value="") then t,s:=rl(); if (t="") then value:=Trim(s,["'"]) elif (t="par") then value:=readpar() else next end end; ls:=[[key,value]]; t,s:=rl() else keys:=[]: t,s:=rl(); while (t="key") do i:=searchtext(" ",s); if (i>0) then fclose(fd); error("Expected key only, received %1: %2",t,s) end; keys:=[op(keys),s]; t,s:=rl() end; n:=nops(keys); values,values2:=[],[]: while (t="" or t="par") do values:=[op(values),`if`(t="",split(s),readpar())]; values2:=[op(values2),`if`(t="",op(StringTools[Split](s)),values[-1])]; t,s:=rl() end; if (irem(nops(values),n)>0) then values:=copy(values2); WARNING("Patching values for keys=%1",keys); if (irem(nops(values2),n)>0) then fclose(fd); error("Incompatible keys and values: %1, %2",keys,values) end end; ls:=[seq([keys[i],[seq(values[i+n*(j-1)],j=1..nops(values)/n)]],i=1..n)] end; for e in ls do key:=e[1]; if assigned('tb[key]') then for i from 2 to infinity while assigned('tb[cat(key,"#",i)]') do end; WARNING("Duplicating key %1 renamed to %2#%3",key,key,i); key:=cat(key,"#",i) end; tb[key]:=e[2] end end; if (rec=0) then dat:=[op(dat),copy(tb)] else break end end; fclose(fd); # end read if (printout and com<>"") then printf(com) end; if (rec=0) then if printout then for tb in dat do printf("data_%s\n",tb["#data_label"]) end end; return dat end; # scalar values p2k:=table([ "SG"=["_symmetry_space_group_name_H-M","_space_group_name_H-M_alt"], "Z"=["_cell_formula_units_Z"], "T"=["_diffrn_ambient_temperature","_cell_measurement_temperature"], "P"=["_diffrn_ambient_pressure","_cell_measurement_pressure"], "formula"=["_chemical_formula_sum"], "CCDC"=["_database_code_depnum_ccdc_archive"], "DOI"=["_journal_paper_doi","_citation_doi"], op(addkeys)]); pars:=[indices(p2k,'nolist')]; p2v:=table(); for par in pars do if type(p2k[par],string) then p2k[par]:=[p2k[par]] end; value:=""; for key in p2k[par] do if assigned('tb[key]') then value:=tb[key]; break end end; p2v[par]:=value end; p2v["SG"]:=Trim(StringTools[DeleteSpace](p2v["SG"]),"'"); p2v["Z"]:=`if`(p2v["Z"]=undefined,0,op(sscanf(p2v["Z"],"%d"))); p2v["T"]:=`if`(p2v["T"]=undefined,0,op(sscanf(p2v["T"],"%f"))); p2v["formula"]:=Trim(StringTools[DeleteSpace](p2v["formula"]),"'"); p2v["CCDC"]:=Trim(StringTools[DeleteSpace](p2v["CCDC"]),"'"); if (p2v["CCDC"][..4]="CCDC") then p2v["CCDC"]:=p2v["CCDC"][5..] end; p2v["DOI"]:=Trim(StringTools[DeleteSpace](`if`(type(p2v["DOI"],list),p2v["DOI"][1],p2v["DOI"])),"'"); # end scalar if printout then printf("data_%s: %s\n",tb["#data_label"],cat(p2v["SG"], `if`(p2v["formula"]="",NULL,cat(", ",p2v["formula"])), `if`(p2v["T"]=0,NULL,cat(", T=",p2v["T"],"K")), `if`(p2v["P"]="",NULL,cat(", P=",p2v["P"],"kPa")), `if`(assigned('tb["_publ_author_name"]') and assigned('tb["_journal_year"]'),cat(", ",tb["_publ_author_name"][1]," ",tb["_journal_year"]),NULL))); if verbose then ls:=sort([indices(tb,'nolist')]); for key in ls do if type(tb[key],list) then printf("%s (%d)\n",key,nops(tb[key])) else printf("%s\n",key) end end end end; # output ls:=StringTools[Split](output,","); if (ls=[""]) then ls:="" end; out:=NULL; for s in ls do if (s="data") then out:=out,op(op(tb)) elif (s="Cell" or s="C") then out:=out,[seq(op(sscanf(tb[key],"%f")),key=key_cell),p2v["SG"]] elif (s="gen") then if assigned(tb[key_gen]) then V:=Vector(nops(tb[key_gen])): for i from 1 to nops(tb[key_gen]) do e:=tb[key_gen][i]; try V[i]:=[xyz2MV(e)] catch: WARNING("Cannot decode gen[%1]=%2",i,e); V[i]:=e end end; out:=out,convert(V,list) else out:=out,[] end elif (s="Atoms" or s="A") then key1:=""; for key in `if`(type(key_atomname,string),[key_atomname],key_atomname) do if assigned('tb[key]') then key1:=key; break end end; if (key1="") then error("key_atomname=%1 is not found",key_atomname) end; na:=nops(tb[key1]); V:=Vector(na): for i from 1 to na do V[i]:=[atomname(tb[key1][i]),Vector([seq(op(sscanf(tb[key][i],"%f")),key=key_coo)])] end; if assigned('tb[key_occ]') then U:=Vector(map(parse,tb[key_occ])); ls2:=[seq(`if`(U[i]=1,NULL,[op(V[i]),U[i]]),i=1..na)]; if (ls2<>[]) then WARNING("Partial occupancies: %1",ls2) end end; out:=out,convert(V,list) elif (s="comment") then out:=out,`if`(com="","",com[..-2]) elif assigned('p2v[s]') then out:=out,p2v[s] elif assigned('tb[s]') then out:=out,tb[s] else error("Key %1 is not found",s) end end; out end: #hfl: ReadCIF WriteCIF:=proc(filename::string, A0::list, Cell0::{list,Matrix}:=["P1"], Z::nonnegint:=0, com::string:="", data::table:=table([]), { opt4Atoms2Cell::list:=[], tvzero::numeric:=tvzero9, symmetrize::boolean:=false, symdev::[numeric,numeric,numeric]:=[1e-4,1e-3,1e-4], pos::nonnegint:=33, digits::nonnegint:=xyzdigits, label::string:="nolabel", DOI::string:="", T::numeric:=-1, P::numeric:=-1, format_cell::string:="", format_angle::string:=format_cell, gen::list:=[], key_sgname::string:="_symmetry_space_group_name_H-M", key_atomname::string:="_atom_site_type_symbol", format_atomname::string:=" %-4s", format_coo::procedure:=((x,d)->BasicTools[FormatFloat](x,d,'maxorder'=0,'width'=d+3)), key_other::list(string):=[], format_other::string:="", after::string:="", append::boolean:=false, overwrite::boolean:=false },$) local Cell,A,M,tflags,Po,Pj,v,SG,S,q,gen2,g,x,y,z,abc,V,i,abg,hasWyckoff,fmt,coo,rest,key; if type(Cell0,[string]) then A,M,tflags:=Atoms2Cell(A0,op(opt4Atoms2Cell),'transform','output'="amf"); Cell:=M2cryst(M,Cell0[1],tvzero); if type(Cell[-1],posint) then Po,Pj:=DecodeAxes2(Cell[-1]); A:=map(v->[v[1],v[2][Po],op(3..,v)],A) end else A:=A0; Cell:=`if`(type(Cell0,list),piecewise(nops(Cell0)>6,Cell0,nops(Cell0)=6,[op(Cell0),"P1"],M2cryst(op(Cell0))),M2cryst(Cell0,999999)) end; if symmetrize then A,Cell:=SymmetrizeCell(A,Cell,symdev) end; SG:=Cell[7]; if (SG="") then SG:="P1"; WARNING("SG is set to P1 for Cell=%1",Cell) end; # prepare text to write S:=table(["dat"=cat("data_",label)]); if (com<>"") then S["com"]:=cat("# ",com) end; if (DOI<>"") then S["DOI"]:=sprintf("%-*s %s",pos-2,"_journal_paper_doi",DOI) end; if (T>=0) then S["T"] :=sprintf("%-*s %a",pos-2,"_diffrn_ambient_temperature",T) end; if (P>=0) then S["P"] :=sprintf("%-*s %a",pos-2,"_diffrn_ambient_pressure",P) end; if (Z>0) then S["Z"] :=sprintf("%-*s %d",pos-2,"_cell_formula_units_Z",Z) end; # symmetry q:=`if`(SearchText(" ",SG)>0,"'",""); S["SG"]:=sprintf("%-*s %s%s%s",pos-2,key_sgname,q,SG,q); gen2:=`if`(gen=[],[],["loop_","_symmetry_equiv_pos_as_xyz",seq(`if`(type(g,string),sprintf("'%s'",Trim(g,["'"])),sprintf("%{c,}a",g[1].+g[2])),g=gen)]); # cell abc:=["a","b","c"]; V:=[seq(`if`(format_cell="",sprintf("%a",ReduceFloat2(Round(v,digits))),sprintf(format_cell,v)),v=Cell[1..3])]; V:=AlignPoints(["123",op(V)])[2..]; for i from 1 to 3 do S[abc[i]]:=TrimRight(sprintf("%-*s %s",pos-3,cat("_cell_length_",abc[i]),V[i])) end; abg:=["alpha","beta ","gamma"]; V:=[seq(`if`(format_angle="",sprintf("%a",ReduceFloat2(Round(v,max(0,digits-1)))),sprintf(format_angle,v)),v=Cell[4..6])]; V:=AlignPoints(["123",op(V)])[2..]; for i from 1 to 3 do S[abg[i]]:=TrimRight(sprintf("%-*s %s",pos-2,cat("_cell_angle_",abg[i]),V[i])) end; # coordinates hasWyckoff:=foldl(`and`,seq(nops(v)>2 and type(v[3],string) and StringTools[IsDigit](v[3][1]) and StringTools[IsLower](v[3][-1]),v=A)); fmt:=cat(format_atomname,"%s",`if`(hasWyckoff," %-3s",""),format_other); coo:=["loop_", key_atomname, seq(cat("_atom_site_fract_",v),v="xyz"), `if`(hasWyckoff,"_atom_site_Wyckoff_symbol",NULL), op(key_other), seq(sprintf(fmt,v[1],map(format_coo,Vector(v[2]),digits),op(3..,v)),v=A)]; # write to file rest:=[seq(sprintf("%-*s %s",pos-2,key,data[key]),key=indices(data,'nolist'))]; WriteLines(filename,[seq(`if`(assigned('S[v]'),S[v],NULL),v=["com","dat","DOI","T","P","a","b","c","alpha","beta ","gamma","Z","SG"]), op(gen2),op(coo),op(rest),`if`(after="",NULL,after)],':-overwrite'=overwrite,':-append'=append) end: #hfl: ReadPOSCAR ReadPOSCAR:=proc( filename0::string, i2a0::list(string):=[], tmap0::list({1,2,3}):=[], { output::string:="a", printout::boolean:=false },$) local filename,ls,com,scalecell,M,i,i2a,i2n,nions,AL,na,cart,Atoms,tmap,c; filename:=`if`(FileTools[Exists](filename0),filename0,cat(filename0,".POSCAR")); ls:=ReadLines(filename,'nlines'=8); com:=ls[1]; scalecell:=sscanf(ls[2],"%f")[1]; M:=Matrix(3,datatype=float); for i from 1 to 3 do M[..,i]:=scalecell*op(sscanf(ls[2+i],"%{3}fc")) end; if StringTools[IsDigit](Trim(ls[6])[1]) then ls:=["",op(6..7,ls)] else ls:=ls[6..8] end; i2a:=`if`(i2a0=[],remove(`=`,StringTools[Split](ls[1]," "),""),i2a0); i2n:=map(s->sscanf(s,"%d")[1],remove(`=`,StringTools[Split](ls[2]," "),"")); nions:=nops(i2n); if (nops(i2a)<>nions) then i2a:=[seq(ElementSymbol[i],i=1..nions)]; WARNING("No i2a provided in %1, will use %2 sequence",filename,i2a) end; AL:=[seq(i2a[i]$i2n[i],i=1..nions),tvsymbol9$3]; na:=nops(AL)-3; if printout then printf("%s // %d = %s\n",com,na,EncodeFormula(AL[..-4])) end; cart:=member(Trim(ls[3])[1],["C","c","K","k"]); ls:=ReadLines(filename,'shift'=8,'nlines'=na); Atoms:=[seq(sscanf(ls[i],"%{3}fc")[1],i=1..na)]; if not(cart) then Atoms:=map(v->M.v,Atoms) end; if (tmap0=[]) then tmap:=ReadRecord(com,"tmap::list:=[$1..3]",'input'="string") else tmap:=tmap0 end; Atoms:=[seq([AL[i],Atoms[i]],i=1..na),seq([tvsymbol9,M[..,i]],i=tmap)]; seq(`if`(c="a",Atoms,`if`(c="c",com,NULL)),c=output) end: #hfl: ReadPOSCAR WritePOSCAR:=proc( filename::string, Atoms::list, Cell::{list,Matrix}:=[], comment::string:="", tmap0::list({1,2,3}):=[1,1], { cart::{2,1,0,-1}:=0, freezeTv::list([nonnegint,nonnegint,nonnegint]):=[], opt4ReshapeCell::list:=[], digits::nonnegint:=xyzdigits, scalecell::numeric:=1, printi2a::boolean:=false, overwrite::boolean:=false },$) local printfreeze,freeze,A,M,tflags,Tvs,fM,cart1,Mi,tmap,i2a,i2n,i,fd,v,L,o; printfreeze:=L->`if`(freeze,cat(seq(`if`(v=0," F"," T"),v=L)),""); freeze:=foldl(`and`,seq(evalb(nops(v)>2 and type(v[-1],[nonnegint,nonnegint,nonnegint])),v=Atoms)); if (Cell=[]) then A,M,tflags:=Atoms2Cell(Atoms,opt4ReshapeCell,'augment',output="amf"); Tvs:=select(v->v[1]=tvsymbol9,Atoms); fM:=[seq(v[-1],v=Tvs),[0,0,0]$3][..3] else A:=Atoms; M:=`if`(type(Cell,Matrix),Cell,cryst2M(Cell)); fM:=`if`(freezeTv=[],[[1,1,1]$3],freezeTv); tflags:=[1,1,1] end; if (cart=1 and Cell<>[]) then cart1:=true; A:=map(v->subsop(2=M.v[2],v),A) elif (cart=-1 and Cell=[]) then cart1:=false; Mi:=M^(-1); A:=map(v->subsop(2=Mi.v[2],v),A) elif (cart=2) then cart1:=true else cart1:=evalb(Cell=[]) end; tmap:=`if`(tmap0=[1,1],[seq(`if`(tflags[o]=2,NULL,o),o=1..3)],tmap0); i2a,i2n:=[A[1][1]],[1]; for i from 2 to nops(A) do if (A[i][1]<>i2a[-1]) then i2a,i2n:=[op(i2a),A[i][1]],[op(i2n),i] end end; i2n:=[seq(i2n[i]-i2n[i-1],i=2..nops(i2n)),i-i2n[-1]]; if (nops(i2a)<>nops(convert(i2a,set))) then WARNING("Unsorted list of atoms: %1",map2(op,1,A)) end; if (filename<>"") then if (FileTools[Exists](filename) and not(overwrite)) then error("File exists, %1",filename) end; fd:=fopen(filename,'WRITE','TEXT') else fd:=fopen('terminal','WRITE') end; fprintf(fd,"%s\n",StringTools[Join]([`if`(comment="",NULL,comment),`if`(printi2a,sprintf("i2a=[%{c,}s]",Vector(i2a)),NULL),`if`(tmap=[1,2,3],NULL,sprintf("tmap=[%{c,}d]",Vector(tmap)))],", ")); fprintf(fd,"%.*f\n",digits,scalecell); for i from 1 to 3 do fprintf(fd,"%*.*f%s\n",fwidth,digits,M[..,i]/scalecell,printfreeze(fM[i])) end; fprintf(fd,"%s\n",Vector(i2a)); fprintf(fd,"%d\n",Vector(i2n)); if freeze then writeline(fd,"Selective dynamics") end; writeline(fd,`if`(cart1,"Cartesian","Direct")); for v in A do fprintf(fd,"%*.*f%s\n",fwidth,digits,v[2],printfreeze(v[-1])) end; if (filename<>"") then fclose(fd) end; NULL end: #hfl: cryst2M cryst2M:=proc(cryst0::list,$) local cryst,SG,axes,cod,n,m,nt,d,v,a,b,c,A,B,C,x,M,MM,axes1,axes2,Po,Pj; cryst,SG,axes,cod:=cryst0,"undefined",0,undefined; n:=nops(cryst); if (n>3 and type(cryst[-3],string)) then m,SG,axes,cod:=n-3,cryst[-3],max(cryst[-2],cryst[-1]),min(cryst[-2],cryst[-1]) elif (n>2 and type(cryst[-2],string)) then m,SG:=n-2,cryst[-2]; if (cryst[-1]<1212) then cod:=cryst[-1] else axes:=cryst[-1] end elif (n>1 and type(cryst[-1],string)) then m,SG:=n-1,cryst[-1] else m:=n end; if (m=1) then nt:=1 elif (m=3) then nt:=2 elif (m=6) then nt:=3 else error("Unrecognized definition of crystal: %1",cryst) end; if hastype(cryst,float) then cryst:=[seq(evalf(v),v=cryst[..m]),op(m+1..,cryst)] end; if (SG="" or SG="undefined") then d:=nt elif StringTools[IsAlpha](SG[1]) then d:=3 else v:=sscanf(SG,"%d"); d:=`if`(v=[],nt,op(v)) end; if (d).<<1,x,x>||>*a/sqrt(1+2*x^2)) elif (cod=0) then MM:=Matrix(3,{(1,1)=evalf(a^2),(2,2)=evalf(b^2),(3,3)=evalf(c^2),(1,2)=evalf(a*b*cos(C)),(2,3)=evalf(b*c*cos(A)),(3,1)=evalf(c*a*cos(B))},shape=symmetric,datatype=float); M:=MatrixFunction2(MM,v->sqrt(v)) else M:=simplify(< | | >) end elif (nt=2) then a,b:=op(cryst[1..2]); C:=Pi/180*cryst[3]; M:=simplify(< | >) elif (nt=1) then M:=<> end; if ((nt=2 or nt=3) and type(axes,posint)) then Po,Pj:=DecodeAxes2(axes); M:=M[SortIdx(Po[..nt],'nolist'),SortIdx(Pj[..nt],'nolist')] end; if (d>nt) then M:=Matrix(d,nt,M) end; `if`(hastype(M,float),Matrix(M,datatype=float),M) end: #hfl: cryst2M M2cryst:=proc(M0::Matrix,SG0::string:="undefined",tvzero::numeric:=tvzero9,$) local M,nt,d,SG,axes,W,Pj,o,o1,o2,lso,a,b,c; M:=copy(M0); d,nt:=op(1,M); if (nt<1 or nt>3) then error("Unrecognized nt, %1",nt) end; SG:=`if`(SG0="undefined",`if`(d=3,["q1","p1","P1"][nt],sprintf("%d",d)),SG0); axes:=NULL; if not(tvzero<0 or nt=1 or d=1) then W:=[seq(add(`if`(evalf(abs(M[o,i]))>tvzero,7,0),o=1..d)+i,i=1..nt)]; if foldl(`and`,seq(type(v,integer),v=W)) then Pj:=SortIdx(W,'nolist'); M:=M[..,Pj]; o1:=op(MaxIdx(M[..,1],v->abs(v))); lso:=subsop(o1=NULL,[$1..d]); o2:=lso[op(MaxIdx(M[lso,2],v->abs(v)))]; axes:=((o1*10+o2)*10+Pj[1])*10+Pj[2]; if axes=1212 then axes:=NULL end end end; if (nt=3) then a,b,c:=seq(M[..,i],i=1..3); [ len(a), len(b), len(c), angle(b,c), angle(c,a), angle(a,b), SG, axes ] elif (nt=2) then a,b:=seq(M[..,i],i=1..2); [ len(a), len(b), angle(a,b), SG, axes ] else [ len(M[..,1]), SG, axes] end end: #hfl: cryst2M ReshapeCell:=proc(M0::Matrix,{ orient::boolean:=false, tvzero::numeric:=tvzero9, cellcode::{integer,undefined}:=undefined, reduce::boolean:=false, base::integer:=2520},$) local f,dt,M,T,oriented,j,cryst,axes,M2,R; if hastype(M0,float) then f:=evalf; dt:=datatype=float else f:=simplify; dt:=NULL end; M:=Matrix(f(M0),dt); T:=Matrix(LinearAlgebra[IdentityMatrix](3)); oriented:=false; if orient then for j from 1 to 3 do if (M[2,j]=0 and M[3,j]=0) then ColumnOperation(M,[1,j],'inplace'); RowOperation (T,[1,j],'inplace'); oriented:=true; break end end; if oriented then oriented:=false; for j from 2 to 3 do if (M[3,j]=0) then ColumnOperation(M,[2,j],'inplace'); RowOperation (T,[2,j],'inplace'); oriented:=true; break end end end; for j from 1 to 3 do if (evalf(M[j,j])<0) then ColumnOperation(M,j,-1,'inplace'); RowOperation (T,j,-1,'inplace') end end end; if (orient and not(oriented) or not(cellcode=undefined)) then cryst:=M2cryst(M,tvzero); axes:=DecodeAxes2(`if`(nops(cryst)=8 and cryst[8]>1212,cryst[8],1212))[2]; T:=copy(T[..,axes]); if (cellcode>=1212) then axes:=DecodeAxes2(cellcode)[2]; T[..,axes]:=copy(T) end; M:=cryst2M([op(..6,cryst),"",cellcode]) end; if reduce then M2:=ReduceLattice3D(M,'keeporientation'); T:=map(v->round(base*v)/base,simplify(M2^(-1).M.T)); M:=M2 end; if hastype(M0,float) then M:=map(Round,M,Digits-2) end; M2:=f(M.T); R:=`if`(evalf(LinearAlgebra[Norm](M2-M0,'Frobenius'))>10^(2-Digits),f(M2.M0^(-1)),Matrix(LinearAlgebra[IdentityMatrix](3))); M,T,R end: #hfl: cryst2M DecodeAxes:=proc(axes::{12,13,23,21,31,32},$) local i,j; i:=iquo(axes,10,j); [i,j,6-i-j] end: #hfl: cryst2M DecodeAxes2:=proc(axesaxes::posint,$) local axes1,axes2; axes1:=iquo(axesaxes,100,axes2); if not(member(axes1,{12,13,23,21,31,32}) and member(axes2,{12,13,23,21,31,32})) then error("Unrecognized axes code: %1",axesaxes) end; DecodeAxes(axes1),DecodeAxes(axes2) end: #hfl: cif2xyz cif2xyz:=proc( Atoms::list, Cell::list, G0::list:=[], {primitive::boolean:=false, optUnfoldBySymmetry::list:=[]}, $) local A,M,G; if (primitive and nops(Cell)=7) then A,M:=UnfoldBySymmetry(Atoms,Cell,op(optUnfoldBySymmetry),':-primitive'=true) else M:=cryst2M(Cell); G:=`if`(G0=[],FiniteGroups[SymmetryGroup](`if`(nops(Cell)>6 and type(Cell[7],string),Cell[7],"P1")),G0); A:=UnfoldBySymmetry(Atoms,G,op(optUnfoldBySymmetry)) end; [seq([v[1],M.v[2]],v=A),seq([tvsymbol9,M[..,i]],i=1..3)] end: #hfl: cif2xyz xyz2cif:=proc(Atoms::list,symmetry::{string,list},offset::list:=[undefined$3],{primitive::boolean:=false,opt4Atoms2Cell::list:=[],optSymmetrizeAtoms::list:=[]},$) local SG,A,M,G,T,FD,Cell,v; SG:=`if`(type(symmetry,string),symmetry,""); A,M:=Atoms2Cell(Atoms,'dim'=3,'transform',op(opt4Atoms2Cell)); if (primitive and SG<>"") then G,T:=FiniteGroups[SymmetryGroup](SG,':-primitive'=true,'output'="GT"); if type(T,list) then T:=T[1] end; M:=M.T^(-1); FD:=SymmetrizeAtoms(A,G,op(optSymmetrizeAtoms),'output'="d"); FD:=map(v->subsop(2=T.v[2],v),FD); FD:=map(v->subsop(2=Vector(3,o->`if`(offset[o]=undefined,v[2][o],Reduce2P(v[2][o],1,offset[o]))),v),FD) else FD:=SymmetrizeAtoms(A,symmetry,op(optSymmetrizeAtoms),'output'="d") end; Cell:=M2cryst(M,SG); FD,Cell end: #hfl: ReadPAR ReadPAR:=proc(par::string,output::string:="",$) local ls,model,e,elements,tb,com,s,i,v,vars,Z,M,out, a,b,c,A,B,C,x,y,z,x1,x2,x3,y1,y2,y3,z1,z2,z3, HH,OH,HOH,PP,CC,CH; ls:=StringTools[Split](par,";"); model:=Trim(ls[1]); if (model="H2" ) then e:=["Dh" , ["2b",<0,0,z>]] elif (model="HF" ) then e:=["Ch", ["1a",<0,0,0>], ["1a",<0,0,z>]] elif (model="H2O" ) then e:=["C2v", ["1a",<0,0,0>], ["2g",<0,y,z>]] elif (model="P4" ) then e:=["Td" , ["4e",]] elif (model="CH4" ) then e:=["Td" , ["1a",<0,0,0>], ["4e",]] elif (model="C2H4" ) then e:=["D2h", ["2i",], ["4y",]] elif (model="C6H6" ) then e:=["D6h", ["6j",], ["6j",]] elif (model="CH2" ) then e:=[[a,"qmcmzy"], ["2e",<1/4,y,0>], ["4k",<1/4,y2,z2>]] #Pmam elif (model="helix3") then e:=[[c,"q3112"], ["3a",]] elif (model="helix4") then e:=[[c,"q4122"], ["4a",]] elif (model="gra" ) then e:=[[a,a,120,"p6/mmm"], ["2c",<2/3,1/3,0>]] elif (model="ars" ) then e:=[[a,a,120,"p-3m1" ], ["2d",<2/3,1/3,z>]] elif (model="pho" ) then e:=[[a,b, 90,"pbmn" ], ["4h",]] elif (model="boat2D") then e:=[[a,b, 90,"pmmn" ], ["4f",]] elif (model="Br" ) then e:=[[a,b,c,90,90, 90,"Cmca" ], ["8f",<0,y,z>]] elif (model="cpyr" ) then e:=[[a,a,c,90,90, 90,"I-42d" ], ["4a",<0,0,0>], ["4b",<1/2,1/2,0>], ["8d",]] elif (model="bct2" ) then e:=[[a,a,c,90,90, 90,"P4/mmm" ], ["1a",<0,0,0>], ["1d",<1/2,1/2,1/2>]] elif (model="rut" ) then e:=[[a,a,c,90,90, 90,"P42/mnm"], ["2a",<0,0,0>], ["4f",]] elif (model="bct" ) then e:=[[a,a,c,90,90, 90,"I4/mmm" ], ["2a",<0,0,0>]] elif (model="tin" ) then e:=[[a,a,c,90,90, 90,"I41/amd"], ["4a",<0,3/4,1/8>]] elif (model="ana" ) then e:=[[a,a,c,90,90, 90,"I41/amd"], ["4a",<0,3/4,1/8>], ["8e",<0,3/4,z>]] elif (model="LiFeO2") then e:=[[a,a,c,90,90, 90,"I41/amd"], ["4b",<0,3/4,5/8>], ["4a",<0,3/4,1/8>], ["8e",<0,3/4,z>]] elif (model="Se" ) then e:=[[a,a,c,90,90,120,"P3121" ], ["3a",]] elif (model="GeTe" ) then e:=[[a,a,c,90,90,120,"R3m" ], ["3a",<0,0,0>], ["3a",<0,0,z>]] elif (model="TiSe2" ) then e:=[[a,a,c,90,90,120,"P-3m1" ], ["1a",<0,0,0>], ["2d",<1/3,2/3,z>]] elif (model="sr" ) then e:=[[a,a,c,90,90,120,"R-3m" ], ["3a",<0,0,0>]] elif (model="As" ) then e:=[[a,a,c,90,90,120,"R-3m" ], ["6c",<0,0,z>]] elif (model="chh" ) then e:=[[a,a,c,90,90,120,"R-3m" ], ["3a",<0,0,0>], ["6c",<0,0,z>]] elif (model="NaFeO2") then e:=[[a,a,c,90,90,120,"R-3m" ], ["3a",<0,0,0>], ["3b",<0,0,1/2>], ["6c",<0,0,z>]] elif (model="wur" ) then e:=[[a,a,c,90,90,120,"P63mc" ], ["2b",<1/3,2/3,0>], ["2b",<1/3,2/3,z>]] elif (model="WC" ) then e:=[[a,a,c,90,90,120,"P-6m2" ], ["1a",<0,0,0>], ["1d",<1/3,2/3,1/2>]] elif (model="ch" ) then e:=[[a,a,c,90,90,120,"P63/mmc"], ["2a",<0,0,0>], ["2c",<1/3,2/3,1/4>]] elif (model="hcp" ) then e:=[[a,a,c,90,90,120,"P63/mmc"], ["2c",<1/3,2/3,1/4>]] elif (model="hdia" ) then e:=[[a,a,c,90,90,120,"P63/mmc"], ["4f",<1/3,2/3,z>]] elif (model="MgB2" ) then e:=[[a,a,c,90,90,120,"P6/mmm" ], ["1a",<0,0,0>], ["2d",<1/3,2/3,1/2>]] elif (model="pyr" ) then e:=[[a,a,a,90,90, 90,"Pa-3" ], ["4a",<0,0,0>], ["8c",]] elif (model="bixb" ) then e:=[[a,a,a,90,90, 90,"Ia-3" ], ["8b",<1/4,1/4,1/4>],["24d",], ["48e",]] elif (model="Cu2O" ) then e:=[[a,a,a,90,90, 90,"Pn-3m" ], ["4b",<0,0,0>], ["2a",<1/4,1/4,1/4>]] elif (model="zbl" ) then e:=[[a,a,a,90,90, 90,"F-43m" ], ["4a",<0,0,0>], ["4c",<1/4,1/4,1/4>]] elif (model="sc" ) then e:=[[a,a,a,90,90, 90,"Pm-3m" ], ["1a",<0,0,0>]] elif (model="CsCl" ) then e:=[[a,a,a,90,90, 90,"Pm-3m" ], ["1a",<0,0,0>], ["1b",<1/2,1/2,1/2>]] elif (model="per" ) then e:=[[a,a,a,90,90, 90,"Pm-3m" ], ["1a",<0,0,0>], ["1b",<1/2,1/2,1/2>], ["3c",<1/2,1/2,0>]] elif (model="fcc" ) then e:=[[a,a,a,90,90, 90,"Fm-3m" ], ["4a",<0,0,0>]] elif (model="NaCl" ) then e:=[[a,a,a,90,90, 90,"Fm-3m" ], ["4a",<0,0,0>], ["4b",<1/2,1/2,1/2>]] elif (model="CaF2" ) then e:=[[a,a,a,90,90, 90,"Fm-3m" ], ["4a",<0,0,0>], ["8c",<1/4,1/4,1/4>]] elif (model="dia" ) then e:=[[a,a,a,90,90, 90,"Fd-3m" ], ["8a",<1/8,1/8,1/8>]] elif (model="spin" ) then e:=[[a,a,a,90,90, 90,"Fd-3m" ], ["8a",<1/8,1/8,1/8>],["16d",<1/2,1/2,1/2>], ["32e",]] elif (model="bcc" ) then e:=[[a,a,a,90,90, 90,"Im-3m" ], ["2a",<0,0,0>]] else error("Unrecognized structural type %1 in %2",model,par) end; if (nops(ls)=1) then return e elif (nops(ls)<3) then error("Insufficient data for %1",par) end; elements:=map(Trim,StringTools[Split](ls[2],",")); tb:=table([ "model"=model, "elements"=elements ]); com:=""; for s in ls[3..] do i:=SearchText("=",s); if (i=0) then com:=`if`(com="",Trim(s),cat(com,"; ",Trim(s))) else v:=Trim(s[..i-1]); tb[v]:=`if`(member(v,["name","doi","ref","method"]),Trim(s[i+1..]),parse(s[i+1..])) end end; tb["com"]:=com; if (nops(e)-1<>nops(elements)) then error("Wrong number of elements (%1) in %2",nops(elements),par) end; vars:=indets(e); for v in vars do if not(type(tb[convert(v,string)],numeric)) then error("Missing parameter %1 in %2",v,s0) end end; e:=eval(e,{seq(v=tb[convert(v,string)],v=vars)}); tb["Cell"]:=e[1]; tb["Atoms"]:=[seq([elements[i],e[1+i][2],e[1+i][1]],i=1..nops(elements))]; ls:=[seq(op(sscanf(v[1],"%d")),v=e[2..])]; tb["na"]:=add(v,v=ls); Z:=`if`(type(e[1],string),1,igcd(op(ls))); ls:=ls/Z; tb["Z"]:=Z; tb["formula"]:=cat(seq(cat(elements[i],`if`(ls[i]=1,"",ls[i])),i=1..nops(ls))); if type(tb["Cell"],string) then tb["M"],tb["nt"],tb["V1"]:=undefined,0,0 else M:=cryst2M(tb["Cell"]); tb["M"]:=M; tb["nt"]:=Dim2(M)[2]; tb["V1"]:=`if`(tb["nt"]=1,len(M[..,1]),`if`(tb["nt"]=2,len(LinearAlgebra[CrossProduct](M[..,1],M[..,2])),LinearAlgebra[Determinant](M)))/tb["na"] end; if (output="") then op(tb) else ls:=StringTools[Split](output,","); out:=NULL; for s in ls do if assigned('tb[s]') then out:=out,tb[s] else error("Unrecognized index %1 in %2",s,op(tb)) end end; out end end: #hfl: ReadPAR WritePAR:=proc(model::string,Atoms::list,Cell::{undefined,[numeric$6,string]}:=undefined,$) end: #hfl: ReadPRM IndexPRM:=proc(prm::table,{printout::boolean:=false,maxlines::posint:=16},$) local ls,types,classes,ls1,pairs,bonds,angles,dihedrals,impropers,v,u,t; ls:=[indices(prm)]; types,ls:=selectremove(v->nops(v)=1,ls); types:=sort(map(op,types)); classes:=sort(convert({seq(prm[t],t=types)},list)); ls1,ls:=selectremove(v->nops(v)=2,ls); pairs,ls:=selectremove(v->v[1]="p",ls); pairs:=SortM(map(v->v[2..],pairs),[1,2]); for v in pairs do if (v[1]>v[2]) then WARNING("Unordered pair %1",v) end end; bonds,ls:=selectremove(v->v[1]="b",ls); bonds:=SortM(map(v->v[2..],bonds),[1,2]); for v in bonds do if (v[1]>v[2]) then WARNING("Unordered bond %1",v) end end; angles,ls:=selectremove(v->v[1]="a",ls); angles:=SortM(map(v->v[2..],angles),[2,1,3]); for v in angles do if (v[1]>v[3]) then WARNING("Unordered angle %1",v) end end; dihedrals,ls:=selectremove(v->v[1]="d",ls); dihedrals:=SortM(map(v->v[2..],dihedrals),[2,3,1,4]); for v in dihedrals do if (v[2]>v[3]) then WARNING("Unordered dihedral %1",v) end end; impropers,ls:=selectremove(v->v[1]="i",ls); impropers:=SortM(map(v->v[2..],impropers),[1,2,3,4]); for v in impropers do if (v[2]>v[3]) then WARNING("Unordered improper %1",v) end end; if (ls<>[]) then error("Unrecognized table entries: %1",ls) end; if printout then printf("%d atom classes\n%d atom types\n%d atomic data entries\n",nops(classes),nops(types),nops(ls1)); printf("type class label nnn mass charge text\n"); for v in types[..min(maxlines,nops(types))] do printf("%3d%5d %-4s%3d%8.3f %*.*f %s\n",v,prm[v],seq(prm[u,v],u="lnm"),3+qdigits,qdigits,prm["q",v],prm["t",v]) end; if (nops(types)>maxlines) then printf("... %d more types ...\n",nops(types)-maxlines) end; printf("%d pair coefficients\n%d bond coefficients\n%d angle coefficients\n%d dihedral coefficients\n%d improper coefficients\n",nops(pairs),nops(bonds),nops(angles),nops(dihedrals),nops(impropers)) end; [classes,types,pairs,bonds,angles,dihedrals,impropers] end: #hfl: ReadPRM ReadPRM:=proc( filename::string, format::{"","OPLS","mass"}:="", lst::list(posint):=[], { getindex::boolean:=false, reindex::boolean:=false, cmap::list(posint):=[], vdwbyclass::boolean:=false, improperorder::[nonnegint,nonnegint,nonnegint,nonnegint]:=[3,1,2,4], printout::boolean:=false, maxlines::posint:=16 },$) local ls,tid,lsc,cid,prm,style,badi,s,v,u,e,i,j,k,id,types,classes,pairs,nbadi,o,t; if (lst=[] and reindex) then error("Inconsistent parameters: subset=[] and reindex=true") end; ls:=ReadLines(`if`(FileTools[Exists](filename),filename,cat(filename,xprm))); if (ls[1][..1]="#" and printout) then printf("%s\n",ls[1]) end; tid:=table([seq( lst[i]=i,i=1..nops(lst ))]); cid:=table([seq(cmap[i]=i,i=1..nops(cmap))]); lsc:=Sort([indices(cid,'nolist')],k->cid[k]); prm:=table(); if (format="mass") then for s in ls do if (s[..5]="mass ") then e:=sscanf(s[6..],"%d%f # %d%s%d%f"); if (nops(e)<>6) then error("Unrecognized type description: %1",s) end; prm["m",e[1]]:=e[2]; prm[e[1]]:=e[3]; prm["e",e[1]]:=e[4]; prm["l",e[1]]:=e[4]; prm["n",e[1]]:=e[5]; prm["q",e[1]]:=e[6]; prm["t",e[1]]:=StringTools[Join](remove(`=`,StringTools[Split](s," "),"")[9..]," ") end end; if printout then types:=sort(map(op,select(v->nops(v)=1,[indices(prm)]))); classes:=sort(convert({seq(prm[t],t=types)},list)); id:=[classes,types,[]$5] end elif (format="") then style,badi:=table(),table(); for s in ls do if (s[..5]="mass ") then e:=sscanf(s[6..],"%d%f # %d%s%d%f"); if (nops(e)<>6) then error("Unrecognized type description: %1",s) end; prm["m",e[1]]:=e[2]; prm[e[1]]:=e[3]; prm["e",e[1]]:=e[4]; prm["l",e[1]]:=e[4]; prm["n",e[1]]:=e[5]; prm["q",e[1]]:=e[6]; prm["t",e[1]]:=StringTools[Join](remove(`=`,StringTools[Split](s," "),"")[9..]," ") elif (s[..11]="pair_coeff ") then e:=sscanf(s[12..],"%d%d%f%f"); if (nops(e)<>4) then WARNING("Unrecognized pair coeff: %1",s); next end; prm["p",op(1..2,e)]:=["opls",op(3..4,e)] elif (s[..11]="bond_coeff ") then e:=sscanf(s[12..],"%d%f%f # %d%d"); if (nops(e)<>5) then WARNING("Unrecognized bond coeff: %1",s); next end; prm["b",op(4..5,e)]:=[style["b"],op(2..3,e)]; badi[1,e[1]]:=e[4..5] elif (s[..12]="angle_coeff ") then e:=sscanf(s[13..],"%d%f%f # %d%d%d"); if (nops(e)<>6) then WARNING("Unrecognized angle coeff: %1",s); next end; prm["a",op(4..6,e)]:=[style["a"],op(2..3,e)]; badi[2,e[1]]:=e[4..6] elif (s[..15]="dihedral_coeff ") then e:=sscanf(s[16..],"%d%f%f%f%f # %d%d%d%d"); if (nops(e)<>9) then WARNING("Unrecognized dihedral coeff: %1",s); next end; prm["d",op(6..9,e)]:=[style["d"],op(2..5,e)]; badi[3,e[1]]:=e[6..9] elif (s[..15]="improper_coeff ") then e:=sscanf(s[16..],"%d%f%f # %d%d%d%d"); if (nops(e)<>7) then WARNING("Unrecognized improper coeff: %1",s); next end; prm["i",op(4..7,e)]:=[style["i"],op(2..3,e)]; badi[4,e[1]]:=e[4..7] end; i:=SearchText(" #",s); if (i>0) then s:=s[..i-1] end; if (s[..11]="pair_style ") then if (Trim(s[12..])[..2]="lj") then style["p"]:="lj" else error("Unrecognized pair style: %1",s) end elif (s[..11]="bond_style ") then style["b"]:=Trim(s[12..]) elif (s[..12]="angle_style ") then style["a"]:=Trim(s[13..]) elif (s[..15]="dihedral_style ") then style["d"]:=Trim(s[16..]) elif (s[..15]="improper_style ") then style["i"]:=Trim(s[16..]) end end; ls:=[indices(prm)]; types:=sort(map(op,select(v->nops(v)=1,ls))); classes:=sort(convert({seq(prm[t],t=types)},list)); pairs:=SortM(map(v->v[2..],select(v->v[1]="p",ls)),[1,2]); nbadi:=[seq(max(map2(op,2,select(v->v[1]=k,[indices(badi)]))),k=1..4)]; id:=[classes,types,pairs,seq([seq(badi[k,i],i=1..nbadi[k])],k=1..4)] elif (format="OPLS") then for s in ls do i:=SearchText(" #",s); if (i>0) then s:=s[..i-1] end; if (s[..5]="atom ") then v:=StringTools[Split](s[6..],""""); if (nops(v)<>3) then error("Missing type description: %1",s) end; e:=sscanf(v[1],"%d%d%s"); if (nops(e)<>3) then WARNING("Unrecognized atom: %1",s); next end; i,k:=e[1],e[2]; if (lst<>[]) then if not(member(i,lst)) then next else if not(member(k,lsc)) then lsc:=[op(lsc),k]; cid[k]:=nops(lsc) end end end; if reindex then i,k:=tid[i],cid[k] end; prm[i]:=k; prm["l",i]:=e[3]; prm["t",i]:=v[2]; e:=sscanf(v[3],"%d%f%d"); if (nops(e)<>3) then WARNING("Unrecognized atom: %1",s); next end; prm["e",i]:=`if`(e[1]=0,prm["l",i],ElementSymbol[e[1]]); prm["m",i]:=e[2]; prm["n",i]:=e[3] elif (s[..7]="charge ") then e:=sscanf(s[8..],"%d%f"); if (nops(e)<>2) then WARNING("Unrecognized charge: %1",s); next end; if (lst<>[] and not(member(e[1],lst))) then next end; i:=`if`(reindex,tid[e[1]],e[1]); prm["q",i]:=e[2] elif (s[..4]="vdw ") then e:=sscanf(s[5..],"%d%f%f"); if (nops(e)<>3) then WARNING("Unrecognized vdw: %1",s); next end; if vdwbyclass then k:=`if`(reindex,cid[e[1]],e[1]); for i in select(j->prm[j]=k,map(op,select(v->nops(v)=1,[indices(prm)]))) do prm["p",i,i]:=["lj",e[3],e[2]] end else if (lst<>[] and not(member(e[1],lst))) then next end; i:=`if`(reindex,tid[e[1]],e[1]); prm["p",i,i]:=["lj",e[3],e[2]] end elif (s[..5]="bond ") then e:=sscanf(s[6..],"%d%d%f%f"); if (nops(e)<>4) then WARNING("Unrecognized bond: %1",s); next end; if (lsc<>[] and not(member(e[1],lsc) and member(e[2],lsc))) then next end; k:=sort(`if`(reindex,[cid[e[1]],cid[e[2]]],e[..2])); prm["b",op(k)]:=["harmonic",op(3..4,e)] elif (s[..6]="angle ") then e:=sscanf(s[7..],"%d%d%d%f%f"); if (nops(e)<>5) then WARNING("Unrecognized angle: %1",s); next end; if (lsc<>[] and not(member(e[1],lsc) and member(e[2],lsc) and member(e[3],lsc))) then next end; k:=`if`(reindex,[cid[e[1]],cid[e[2]],cid[e[3]]],e[..3]); if (k[3]0); for i in [7,10,13,16] while (i<=nops(e)) do if (type(e[i],odd) and e[i-1]=0 or type(e[i],even) and e[i-1]=180) then v[e[i]]:=e[i-2] elif (type(e[i],even) and e[i-1]=0) then v[e[i]]:=-e[i-2] else error("Invalid angles in dihedral: %1",s) end end; if (lsc<>[] and not(member(e[1],lsc) and member(e[2],lsc) and member(e[3],lsc) and member(e[4],lsc))) then next end; k:=`if`(reindex,[cid[e[1]],cid[e[2]],cid[e[3]],cid[e[4]]],e[..4]); if (k[3][] and not(member(e[1],lsc) and member(e[2],lsc) and member(e[3],lsc) and member(e[4],lsc))) then next end; k:=`if`(reindex,[cid[e[1]],cid[e[2]],cid[e[3]],cid[e[4]]],e[..4])[improperorder]; k:=[k[1],min(k[2],k[3]),max(k[2],k[3]),k[4]]; prm["i",op(k)]:=["harmonic",e[5],0] end end; if reindex then for i from 1 to nops(lst) do if (i<>tid[lst[i]]) then j:=tid[lst[i]]; prm[i]:=prm[j]; for v in ["e","l","m","n","q","t"] do prm[v,i]:=prm[v,j] end; prm["p",i,i]:=prm["p",j,j] end end end; if (getindex or printout) then id:=IndexPRM(prm) end end; if printout then types:=id[2]; printf("%d atom classes\n%d atom types\n",nops(id[1]),nops(types)); printf("type class label nnn mass charge text\n"); for v in types[..min(maxlines,nops(types))] do printf("%3d%5d %-4s%3d%8.3f %*.*f %s\n",v,prm[v],seq(prm[u,v],u="lnm"),3+qdigits,qdigits,prm["q",v],prm["t",v]) end; if (nops(types)>maxlines) then printf("... %d more types ...\n",nops(types)-maxlines) end; printf("%d pair coefficients\n%d bond coefficients\n%d angle coefficients\n%d dihedral coefficients\n%d improper coefficients\n",seq(nops(id[k]),k=3..7)) end; op(prm),`if`(getindex,id,NULL) end: #hfl: ReadPRM WritePRM:=proc(filename::string,prm::table,id0::list:=[],format::{""}:="",comment::string:="", {LJ::{[numeric,numeric],[numeric,numeric,numeric,numeric]}:=[1,10],coulomb::{[numeric,numeric],[numeric,numeric,numeric,numeric]}:=[1,10],overwrite::boolean:=false},$) local id,com; if (not(overwrite) and FileTools[Exists](filename)) then error("File exists: %1",filename) end; id:=`if`(id0=[],IndexPRM(prm),id); com:=StringTools[Split](comment,"\n"); if (format="") then WriteLines(filename,[ `if`(comment="",NULL,op(map(v->cat("# ",v),com))), "",sprintf("special_bonds lj %a %a %a coul %a %a %a",op(`if`(nops(LJ)=4,LJ[..3],[0,0,LJ[1]])),op(`if`(nops(coulomb)=4,coulomb[..3],[0,0,coulomb[1]]))), "",seq(sprintf("mass %2d %7.3f \# %2d %-2s %2d %*.*f %s",i,prm["m",i],prm[i],prm["e",i],prm["n",i],3+qdigits,qdigits,prm["q",i],prm["t",i]),i=id[2]), "",sprintf("pair_style lj/cut/coul/cut %a %a",LJ[-1],coulomb[-1]), "",seq(sprintf("pair_coeff %2d %2d %8.4f %8.4f",op(i),op(2..3,prm["p",op(i)])),i=id[3]), "","bond_style harmonic", "",seq(sprintf("bond_coeff %4d %7.1f %7.3f \# %2d %2d",i,op(2..3,prm["b",op(id[4][i])]),op(id[4][i])),i=1..nops(id[4])), "","angle_style harmonic", "",seq(sprintf("angle_coeff %4d %6.1f %7.2f \# %2d %2d %2d",i,op(2..3,prm["a",op(id[5][i])]),op(id[5][i])),i=1..nops(id[5])), "","dihedral_style opls", "",seq(sprintf("dihedral_coeff %4d %7.3f %7.3f %7.3f %7.3f \# %2d %2d %2d %2d",i,op(2..5,prm["d",op(id[6][i])]),op(id[6][i])),i=1..nops(id[6])), "","improper_style harmonic", "",seq(sprintf("improper_coeff %4d %7.1f %4.0f \# %2d %2d %2d %2d",i,op(2..3,prm["i",op(id[7][i])]),op(id[7][i])),i=1..nops(id[7])), NULL],':-overwrite'=overwrite) end end: #hfl: ReadPRM MergePRM:=proc(prm1::table,prm2::table,{printout::boolean:=false},$) local cano,cani,prm,types,ls,types2,t,c2c,pairs,f,v,u; cano:=proc(v::list,$) if (nops(v)=2) then if (v[1]nops(v)=1,[indices(prm)]); types:=sort(map(op,types)); types2:=sort(map(op,select(v->nops(v)=1,[indices(prm2)]))); if (types<>types2) then error("Different types: %1<>%2",types,types2) end; for t in types do prm["q",t]:=prm2["q",t]; if (prm2["t",t]<>"") then prm["t",t]:=cat(prm["t",t]," ",prm2["t",t]) end end; c2c:=table([seq(prm[t]=prm2[t],t=types)]); if printout then printf("Class map: %{c,}s\n",Vector([seq(sprintf("%d=%d",prm[t],prm2[t]),t=types)])) end; pairs,ls:=selectremove(v->v[1]="p",remove(v->nops(v)=2,ls)); f:=true; for v in sort(pairs) do if assigned('prm2[op(v)]') then prm[op(v)]:=prm2[op(v)] else if printout then if f then printf("Undefined parameters:\n"); f:=false end; printf("[%s,%{c,}d]\n",v[1],Vector(v[2..])) end end end; for v in sort(ls) do u:=[v[1],op(`if`(v[1]="i",cani,cano)([seq(c2c[i],i=v[2..])]))]; if assigned('prm2[op(u)]') then prm[op(v)]:=prm2[op(u)] else if printout then if f then printf("Undefined parameters:\n"); f:=false end; printf("[%s,%{c,}d]=[%s,%{c,}d]\n",v[1],Vector(v[2..]),u[1],Vector(u[2..])) end end end; op(prm) end: ################################################################################ #cat: Wave-function #hfl: AO #AO monomfactor:=proc(pqr) option remember; sqrt(GAMMA(pqr[1]+pqr[2]+pqr[3]+3/2)/(2*GAMMA(pqr[1]+1/2)*GAMMA(pqr[2]+1/2)*GAMMA(pqr[3]+1/2))) end: #hfl: AO AOangular:=proc(s::{[integer,integer],[integer,integer,nonnegint],[name,name,name],string},x,y,z,$) local c; if type(s,string) then if (s="S") then AOangular("",x,y,z) elif (s="X2") then Yxyz(2,"E" ,x,y,z)[1] elif (s="Z2") then Yxyz(2,"E" ,x,y,z)[2] elif (s="X3") then Yxyz(3,"F1",x,y,z)[1] elif (s="Y3") then Yxyz(3,"F1",x,y,z)[2] elif (s="Z3") then Yxyz(3,"F1",x,y,z)[3] elif (s="XY2") then Yxyz(3,"F2",x,y,z)[1] elif (s="YZ2") then Yxyz(3,"F2",x,y,z)[2] elif (s="ZX2") then Yxyz(3,"F2",x,y,z)[3] elif (s="S4") then Yxyz(4,"A1",x,y,z)[1] elif (s="X2Z2") then Yxyz(4,"E" ,x,y,z)[1] elif (s="Z4") then Yxyz(4,"E" ,x,y,z)[2] elif (s="YZY2") then Yxyz(4,"F1",x,y,z)[1] elif (s="ZXZ2") then Yxyz(4,"F1",x,y,z)[2] elif (s="XYX2") then Yxyz(4,"F1",x,y,z)[3] elif (s="YZX2") then Yxyz(4,"F2",x,y,z)[1] elif (s="ZXY2") then Yxyz(4,"F2",x,y,z)[2] elif (s="XYZ2") then Yxyz(4,"F2",x,y,z)[3] else AOangular([seq(StringTools[CountCharacterOccurrences](s,c),c="XYZ")],x,y,z) end elif (nops(s)=3) then if type(s[1],negint) then Yxyz(-s[1],s[2],x,y,z) else monomfactor(s)*x^s[1]*y^s[2]*z^s[3] end elif (s[1]<0) then Yxyz(-s[1],iidI(s[2]),x,y,z) else AOangular(pqr[op(s)],x,y,z) end end: #hfl: AO AOl:=proc(s::{[integer,integer],[integer,integer,nonnegint],[name,name,name],string},$) local c; if type(s,string) then if (s="S") then 0 elif member(s,["X2","Z2"]) then 2 elif member(s,["X3","Y3","Z3","XY2","YZ2","ZX2"]) then 3 elif member(s,["S4","X2Z2","Z4","YZY2","ZXZ2","XYX2","YZX2","ZXY2","XYZ2"]) then 4 else add(StringTools[CountCharacterOccurrences](s,c),c="XYZ") end elif (nops(s)=3) then if type(s[1],negint) then -s[1] else s[1]+s[2]+s[3] end else abs(s[1]) end end: #hfl: AO AOt:=proc(s::{[integer,integer],[integer,integer,nonnegint],[name,name,name],string},$) `if`(type(s,string), `if`(member(s,["X2","Z2","X3","Y3","Z3","XY2","YZ2","ZX2","S4","X2Z2","Z4","YZY2","ZXZ2","XYX2","YZX2","ZXY2","XYZ2"]),"c","m"), `if`(type(s[1],negint),"t","m")) end: #hfl: AO AOr:=proc(AO::list,r,$) local ac; AO[4]*r^AOl(AO[2])*`if`(type(AO[3][1],list),add(ac[2]*exp(-ac[1]*r^2),ac=AO[3]),r^(AO[3][1]-1)*exp(-AO[3][2]*r)) end: #hfl: AO AOxyz:=proc(AO::list,x0,y0,z0,$) local x,y,z,r2,ac; if type(AO[1],Vector) then x,y,z:=x0-AO[1][1],y0-AO[1][2],z0-AO[1][3] else x,y,z:=x0,y0,z0 end; r2:=x^2+y^2+z^2; AO[4]*AOangular(AO[2],x,y,z)*`if`(type(AO[3][1],list),add(ac[2]*exp(-ac[1]*r2),ac=AO[3]),sqrt(r2)^(AO[3][1]-1)*exp(-AO[3][2]*sqrt(r2))) end: #hfl: AO AOnormalize:=proc(AO::list,{function::boolean:=false},$) local l,C,v,v1,v2; l:=AOl(AO[2]); C:=`if`(type(AO[3][1],list),sqrt(2/GAMMA(l+3/2)/add(add(v1[2]*v2[2]/(v1[1]+v2[1])^(l+3/2),v1=AO[3]),v2=AO[3])),(2*AO[3][2])^(AO[3][1]+l+1/2)/sqrt((2*(AO[3][1]+l))!)); C:=`if`(hastype(C,float),evalf(C),simplify(C)); if function then if type(AO[3],listlist) then subsop(3=map(v->[v[1],C*v[2]],AO[3]),4=AO[4]/C,AO) else error("Cannot renormalize function for STO: %1",AO) end else subsop(4=C,AO) end end: #hfl: GTOint GTOint1:=(a::positive,n::nonnegint)->`if`(type(n,even),evalf(GAMMA((n+1)/2)/sqrt(a^(n+1))),0): #hfl: GTOint GTOint2:=proc( ac1::list, ac2::list, p::nonnegint, q::nonnegint, r::nonnegint,$) local v1,v2; `if`(type(p,even) and type(q,even) and type(r,even),evalf(GAMMA((p+1)/2)*GAMMA((q+1)/2)*GAMMA((r+1)/2)*add(add(v1[2]*v2[2]/(v1[1]+v2[1])^((p+q+r+3)/2),v1=ac1),v2=ac2)), 0) end: #hfl: GTOint GTOint3:=proc(e,$) local xyz; xyz:=remove(member,indets(e,name),{Pi}); if (nops(xyz)<>3) then error("Unrecognized indeterminates %1 in %2",xyz,e) end; `if`(type(e,`+`), map(int,map(simplify,expand(e)),[seq(v=-infinity..infinity,v=xyz)]), int(e,[seq(v=-infinity..infinity,v=xyz)])) end: #hfl: GTOint GTOint4:=proc(p1::integer,p2::integer,a1,a2,x12,$) option remember; if (p1>p2) then if (p2<0) then 0 else ( 2*a2*x12*GTOint4(p1-1,p2,a1,a2,x12)+p2*GTOint4(p1-1,p2-1,a1,a2,x12)+(p1-1)*GTOint4(p1-2,p2,a1,a2,x12))/(2*(a1+a2)) end else if (p1<0) then 0 elif (p2=0) then exp(-a1*a2/(a1+a2)*x12^2)/sqrt(a1+a2) else (-2*a1*x12*GTOint4(p1,p2-1,a1,a2,x12)+p1*GTOint4(p1-1,p2-1,a1,a2,x12)+(p2-1)*GTOint4(p1,p2-2,a1,a2,x12))/(2*(a1+a2)) end end end: GTOint42:=proc(p1::integer,p2::integer,a1,a2,x12,$) option remember; local ia; ia:=1/(a1+a2); exp(-a1*a2*ia*x12^2)*(a1/a2)^((p2-p1)/2)*ia^((p1+p2+1)/2)*ROI[p1,p2](-sqrt(a1*a2*ia)*x12,a1/a2) end: #hfl: GTOint GTOoverlap:=proc(GTO1::list,GTO2::list,{noprefactor::boolean:=false},$) local ff,X12,pqr1,pqr2,u,v,i,x,y,z,ls1,ls2; ff:=`if`(hastype(GTO1,float) or hastype(GTO2,float),evalf,simplify); X12:=[seq(GTO2[1][i]-GTO1[1][i],i=1..3)]; pqr1,pqr2:=GTO1[2],GTO2[2]; if (type(pqr1,[nonnegint,nonnegint,nonnegint]) and type(pqr2,[nonnegint,nonnegint,nonnegint])) then ff(`if`(noprefactor,1,monomfactor(pqr1)*monomfactor(pqr2))*Pi^(3/2)*GTO1[4]*GTO2[4]*add(add(u[2]*v[2]*mul(GTOint4(pqr1[i],pqr2[i],u[1],v[1],X12[i]),i=1..3),u=GTO1[3]),v=GTO2[3])) else ls1:=coeffs2(AOangular(pqr1,x,y,z),[x,y,z]); ls2:=coeffs2(AOangular(pqr2,x,y,z),[x,y,z]); ff(add(add(u[4]*v[4]*GTOoverlap(subsop(2=u[..3],GTO1),subsop(2=v[..3],GTO2),':-noprefactor'=true),u=ls1),v=ls2)) end end: GTOoverlap2:=proc(GTO1::list,GTO2::list,{noprefactor::boolean:=false},$) local ff,X12,sep,pqr1,pqr2,l1,l2,u,v,i,x,y,z,ls1,ls2; ff:=`if`(hastype(GTO1,float) or hastype(GTO2,float),evalf,simplify); X12:=[seq(GTO1[1][i]-GTO2[1][i],i=1..3)]; sep:=add(v^2,v=X12); pqr1,pqr2:=GTO1[2],GTO2[2]; if (type(pqr1,[nonnegint,nonnegint,nonnegint]) and type(pqr2,[nonnegint,nonnegint,nonnegint])) then l1,l2:=add(v,v=pqr1),add(v,v=pqr2); ff(`if`(noprefactor,1,monomfactor(pqr1)*monomfactor(pqr2)) *Pi^(3/2)*GTO1[4]*GTO2[4]*add(add( u[2]*v[2]*exp(-u[1]*v[1]/(u[1]+v[1])*sep)*(u[1]/v[1])^((l2-l1)/2)*(u[1]+v[1])^(-(l1+l2+3)/2) *mul(ROI[pqr1[i],pqr2[i]](sqrt(u[1]*v[1]/(u[1]+v[1]))*X12[i],u[1]/v[1]),i=1..3), u=GTO1[3]),v=GTO2[3])) else ls1:=coeffs2(AOangular(pqr1,x,y,z),[x,y,z]); ls2:=coeffs2(AOangular(pqr2,x,y,z),[x,y,z]); ff(add(add(u[4]*v[4]*GTOoverlap(subsop(2=u[..3],GTO1),subsop(2=v[..3],GTO2),':-noprefactor'=true),u=ls1),v=ls2)) end end: #hfl: GTOreduce GTOreduce:=proc(psi::listlist,maxdev::numeric:=10^(2-Digits),maxdev2::numeric:=maxdev,$) local ls,psi2,i,X0,pqr,c,acs,ls2,v,u; ls:=[ListTools[Categorize]((GTO1,GTO2)->GTO1[2]=GTO2[2] and add(v^2,v=GTO1[1]-GTO2[1])1) then psi2:=Vector(nops(ls)); for i from 1 to nops(ls) do if (nops(ls[i])>1) then c:=ls[i][1][4]; acs:=[seq(seq([u[1],u[2]*v[4]/c],u=v[3]),v=ls[i])]; ls2:=[ListTools[Categorize]((ac1,ac2)->abs(ac1[1]-ac2[1])1) then acs:=map(v->[add(u[1],u=v)/nops(v),add(u[2],u=v)],ls2) end; psi2[i]:=[ add(v[1],v=ls[i])/nops(ls[i]), ls[i][1][2], Rort(acs,[1]), c] else psi2[i]:=ls[i][1] end end; [seq(v,v=psi2)] else psi end end: #hfl: GTOreduce GTOadd:=proc(psi1::listlist,psi2::listlist,maxdev::numeric:=10^(2-Digits),maxdev2::numeric:=maxdev,$) local psi,i,n,GTO2,exist,c,acs,ls2,v,u; psi:=table(): for i from 1 to nops(psi1) do psi[i]:=psi1[i] end; n:=nops(psi1); for GTO2 in psi2 do exist:=false; for i from 1 to n do if (psi[i][2]=GTO2[2] and add(v^2,v=psi[i][1]-GTO2[1])abs(ac1[1]-ac2[1])1) then acs:=map(v->[add(u[1],u=v)/nops(v),add(u[2],u=v)],ls2) end; psi[i]:=subsop(3=Rort(acs,[1]),psi[i]) else n:=n+1; psi[n]:=GTO2 end end; convert(psi,list) end: #hfl: GTOexpand GTOexpand1:=proc(xpa1::list,xpa2::list,$) local x1,p1,a1,x2,p2,a2,x0,dx; x1,p1,a1,x2,p2,a2:=op(xpa1),op(xpa2); x0:=(a1*x1+a2*x2)/(a1+a2); x0,PolynomialTools[CoefficientList]((dx+x0-x1)^p1*(dx+x0-x2)^p2,dx),a1+a2,exp(-a1*a2/(a1+a2)*(x1-x2)^2) end: #hfl: GTOexpand GTOexpand3:=proc(xpa1::list,xpa2::list,$) local X1,pqr1,a1,X2,pqr2,a2,X0,C,c,a,o,p,q,r,v; X1,pqr1,a1,X2,pqr2,a2:=op(xpa1),op(xpa2); X0,C,c:=Vector(3),Vector(3),Vector(3); for o from 1 to 3 do X0[o],C[o],a,c[o]:=GTOexpand1([X1[o],pqr1[o],a1],[X2[o],pqr2[o],a2]) end; X0, remove(v->v[4]=0,[seq(seq(seq([p-1,q-1,r-1,C[1][p]*C[2][q]*C[3][r]],r=1..nops(C[3])),q=1..nops(C[2])),p=1..nops(C[1]))]), a, simplify(mul(v,v=c)) end: #hfl: GTOexpand GTOexpand:=proc(GTO1::list,GTO2::list,{noprefactor::boolean:=false,donotreduce::boolean:=false},$) local ff,pqr1,pqr2,C0,GTO,ac1,ac2,X0,pqrc,a,c,psi,ls1,ls2,v,u; ff:=`if`(hastype(GTO1,float) or hastype(GTO2,float),evalf,simplify); pqr1,pqr2:=GTO1[2],GTO2[2]; if (type(pqr1,[nonnegint,nonnegint,nonnegint]) and type(pqr2,[nonnegint,nonnegint,nonnegint])) then C0:=ff(GTO1[4]*GTO2[4]*`if`(noprefactor,1,monomfactor(GTO1[2])*monomfactor(GTO2[2]))); GTO:=table(); for ac1 in GTO1[3] do for ac2 in GTO2[3] do X0,pqrc,a,c:=GTOexpand3([GTO1[1],pqr1,ac1[1]],[GTO2[1],pqr2,ac2[1]]); c:=c*C0*ac1[2]*ac2[2]; for v in pqrc do GTO[ac1[1],ac2[1],v[..3]]:=[X0,v[..3],[[a,v[4]]],ff(c/monomfactor(v[..3]))] end end end; psi:=convert(GTO,list) else ls1:=coeffs2(AOangular(pqr1,x,y,z),[x,y,z]); ls2:=coeffs2(AOangular(pqr2,x,y,z),[x,y,z]); psi:=[seq(seq(op(GTOexpand(subsop(2=u[..3],4=ff(GTO1[4]*u[4]),GTO1),subsop(2=v[..3],4=ff(GTO2[4]*v[4]),GTO2),':-noprefactor'=true,':-donotreduce'=true)),u=ls1),v=ls2)] end; `if`(donotreduce,psi,GTOreduce(psi)) end: #hfl: Hybrid Hybrid:=proc(triple::list,{inplane::boolean:=false,weightsonly::boolean:=false},$) local v,i,j, e,cosa,s,eta,c0,c,T; if type(triple,[Vector$3]) then e:=map(LinearAlgebra[Normalize],triple,2,'conjugate'=false); cosa:=[seq(e[i mod 3 +1].e[(i+1) mod 3 +1],i=1..3)] elif type(triple,[numeric$3]) then if (evalb(add(v,v=triple)>360)=true) then error "Sum of the angles %1>360 degrees",add(v,v=triple) end; e[1]:=<1,0,0>; e[2]:=evalf(); e[3]:=evalf(); e[3][3]:=sqrt(max(0.,1-e[3][1]^2-e[3][2]^2)); cosa:=[seq(evalf(cos(v*Pi/180)),v=triple)] else e[1]:=<1,0,0>; e[2]:=simplify(); e[3]:=simplify(); e[3][3]:=simplify(sqrt(1-e[3][1]^2-e[3][2]^2)); cosa:=[seq(simplify(cos(v)),v=triple)] end; for i from 1 to 3 do if (evalb(evalf(cosa[i])>=0)=true) then WARNING("The number %1 angle %2<=90 degrees",i,evalf(180/Pi*arccos(cosa[i]))) end end; s:=sqrt(-mul(cosa[i],i=1..3)); eta:=[seq(arctan(-cosa[i]/s),i=1..3)]; c0:=sqrt(1-add(cos(eta[i])^2,i=1..3)); T:=Array(0..3,0..3): T[0,0]:=c0: if (inplane or evalb(c0=0)=true) then if not(inplane) then WARNING("Inplane triple") end; T[0,1..3]:=LinearAlgebra[Normalize](LinearAlgebra[CrossProduct](e[1],e[2]),2) else for i from 1 to 3 do c[i]:=-cos(eta[i])*sin(eta[i])/c0 end; for j from 1 to 3 do T[0,j]:=add(c[i]*e[i][j],i=1..3) end end: for i from 1 to 3 do T[i,0]:=cos(eta[i]); for j from 1 to 3 do T[i,j]:=sin(eta[i])*e[i][j] end end: T:=convert(T,Matrix); if weightsonly then [seq(T[i,1]^2,i=2..4)] else T end end: #hfl: BS shell2LtN:=proc(s::string,Ltrig::integer:=-1,$) local L,t,N; L,t:=StringTools[SelectRemove](StringTools[IsUpper],s); L:=Ls2Ld[L]; if not(type(L,integer)) then error("Unrecognized orbital quantum number of the shell: %1",s) end; if (t="") then if (Ltrig<0) then return [L,"",0] else t:=`if`(Lsqrt((2*a)^(l+3/2)*2/GAMMA(l+3/2))), labelformat::string:="%s", {program::{"","gau"}:="",printout::boolean:=false}, $) local e,tb,k,L,t,n,center,ac,label,lsL,s,ac2,o,p,m,Ltrig,BS2,N; if printout then printf("%d shells of types %{c,}s\n",nops(BS),Vector(sort(convert({seq(e[2],e=BS)},list)))) end; if (NorL=0) then tb:=table(); k:=0; for e in BS do L,t,n:=op(shell2LtN(e[2])); if (t="") then error("No shell functional type in %1",e[2]) end; center,ac:=e[1],e[3]; label:=sprintf(labelformat,`if`(type(e[-1],string),e[-1],"")); lsL:=`if`(L=-1,[0,1],[L]); for s from 1 to nops(lsL) do L:=lsL[s]; ac2:=map(v->[v[1],evalf(prefactor(v[1],L)*v[1+s])],ac); if (t="m") then for o from 1 to (L+1)*(L+2)/2 do k:=k+1; p:=pqr[L,o]; tb[k]:=[ center, p, ac2, 1, cat(label,`if`(L=0,"S",cat("X"$p[1],"Y"$p[2],"Z"$p[3])))] end elif (t="t") then for o from 1 to 2*L+1 do k:=k+1; m:=iidI(o); tb[k]:=[ center, [-L,m,0], ac2, 1, cat(label,Ld2Ls[L],`if`(m=0," ",`if`(m>0,"+","-")),abs(m))] end elif (t="c") then error("Cubic angular functions are not implemented") else error("Unrcognized functional form of the shell: %1",t) end end end; convert(tb,list) elif (NorL<0) then Ltrig:=-NorL; if printout then printf("Basis set is overwritten with Ltrig=%d\n",Ltrig) end; BS2:=map(e->subsop(2=LtN2shell(op(..2,shell2LtN(Ld2Ls[shell2LtN(e[2],Ltrig)[1]],Ltrig))),e),BS); UnfoldBS(BS2,prefactor,labelformat,':-program'=program,':-printout'=printout) else N:=NorL; BS2:=[]; for Ltrig from 2 to lmax+1 do BS2:=UnfoldBS(BS,-Ltrig,prefactor,labelformat,':-program'=program); if (nops(BS2)>=N) then break end end; if (nops(BS2)<>N) then error("No basis set of size %1",N) end; if printout then printf("Ltrig=%d is used to match basis set size %d\n",Ltrig,N) end; BS2 end end: #hfl: BS FoldBS:=proc(BS::list,prefactor::procedure:=((a,l)->sqrt((2*a)^(l+3/2)*2/GAMMA(l+3/2))),$) local ff,FBS,lsk,k,u,v; ff:=proc(BF::list,$) local a,t,L,ac,lbl,v,i; a:=BF[2]; t:=AOt(a); if (t="c") then error("Cubic functions are not implemented") end; if (type(a,string) and member(a,"S","X","XX","XXX","XXXX") or a[2]=0 and (nops(a)=2 or a[3]=0)) then L:=AOl(a); ac:=map(v->[v[1],evalf(v[2]/prefactor(v[1],L))],BF[3]); v,lbl:=convert(BF[1],string),BF[5]; i:=SearchText(v,lbl); if (i>0) then lbl:=cat(lbl[..i-1],v) end; [BF[1],LtN2shell(L,t),ac,BF[4],lbl] else NULL end end; FBS:=map(ff,BS); lsk:=[seq(`if`(FBS[k-1][2]="Sm" and FBS[k][2]="Pm" and abs(FBS[k-1][3][1][1]-FBS[k][3][1][1])<1e-4,k,NULL),k=2..nops(FBS))]; subsop(seq(k-1=NULL,k=lsk),seq(k=subsop(2="SPm",3=zip((u,v)->[op(u),v[2]],FBS[k-1][3],FBS[k][3]),FBS[k]),k=lsk),FBS) end: #hfl: BS ReadBS:=proc(filename::string,A::list,Ltrig::integer:=-1,prefactor::procedure:=((a,l)->sqrt((2*a)^(l+3/2)/Pi/GAMMA(l+1/2))),$) local TBS,el,ls,BS,i,s,n,L,t,tb,j,k,a,c,c2,v; TBS:=table(); for el in {seq(v[1],v=A)} do ls:=ReadLines(filename,StringTools[UpperCase](ElementName[AtomicNumber(el)])); BS:=table(): i:=1; while (i<=nops(ls)) do s,n:=op(sscanf(ls[i],"%s %d")); L:=Ls2Ld[s]; t:=`if`(Ltrig<0,"",`if`(Lj) then error "j and k are different, %1,%2",j,k end; tb[j]:=[a,evalf(c*prefactor(a,0)),evalf(c2*prefactor(a,1))] end else for j from 1 to n do k,a,c:=op(sscanf(ls[i+j],"%d %f %f")); if (k<>j) then error "j and k are different, %1,%2",j,k end; tb[j]:=[a,evalf(c*prefactor(a,L))] end end; BS[i]:=[cat(Ld2Ls[L],t),convert(tb,list)]; i:=i+n+1 end; TBS[el]:=convert(BS,list) end; [seq(seq([i,op(v),1,cat(A[i][1],i)],v=TBS[A[i][1]]),i=1..nops(A))] end: #hfl: RotationM4AO RotationM4AO:=proc(R0::{Matrix,[realcons,realcons,realcons,realcons]},L::nonnegint,t::{"m","t","c"},$) option remember; local R,abc,d,dt,sf,M,m,T,s3; if type(R0,Matrix) then R:=R0; d:=round(LinearAlgebra[Determinant](R)); abc:=RotationParamEulerY(d*R) else abc,d:=R0[..3],R0[4]; R:=d*RotationMEulerY(op(abc)) end; if hastype(R,float) then dt:=datatype=float; sf:=evalf; s3:=1/sqrt(3.) else dt:=NULL; sf:=simplify; s3:=1/sqrt(3) end; if (t="t") then M:=LinearAlgebra[DiagonalMatrix]([1,seq(`if`(type(m,odd),<<-1,I>|<1,I>>,<<1,-I>|<1,I>>)/sqrt(2),m=1..L)]); T:=Matrix(map(sf@evalc@Re@sf,d^L*M.Matrix(2*L+1,(i,j)->sf(WignerD(L,iidI(i),iidI(j),op(abc)))).LinearAlgebra[HermitianTranspose](M)),dt) elif (t="m") then if (L>lmax) then error("l>lmax (l=%1)",L) end; T:=Matrix(map(sf,R2TL[L](R)),dt) elif (t="c") then if (L=2) then # [ y*z, z*x, x*y, (x^2-y^2)/2, (z^2-(x^2+y^2)/2)/sqrt(3) ] T:=Matrix(< < R[2,2]*R[3,3]+R[2,3]*R[3,2] | R[2,1]*R[3,3]+R[2,3]*R[3,1] | R[2,2]*R[3,1]+R[2,1]*R[3,2] | R[2,1]*R[3,1]-R[2,2]*R[3,2] | (2*R[2,3]*R[3,3]-R[2,1]*R[3,1]-R[2,2]*R[3,2])*s3 >, < R[1,2]*R[3,3]+R[1,3]*R[3,2] | R[1,1]*R[3,3]+R[1,3]*R[3,1] | R[1,1]*R[3,2]+R[1,2]*R[3,1] | R[1,1]*R[3,1]-R[1,2]*R[3,2] | (2*R[1,3]*R[3,3]-R[1,2]*R[3,2]-R[1,1]*R[3,1])*s3 >, < R[1,3]*R[2,2]+R[1,2]*R[2,3] | R[1,1]*R[2,3]+R[2,1]*R[1,3] | R[1,1]*R[2,2]+R[1,2]*R[2,1] | R[1,1]*R[2,1]-R[1,2]*R[2,2] | (2*R[1,3]*R[2,3]-R[1,1]*R[2,1]-R[1,2]*R[2,2])*s3 >, < R[1,2]*R[1,3]-R[2,2]*R[2,3] | R[1,1]*R[1,3]-R[2,1]*R[2,3] | R[1,1]*R[1,2]-R[2,2]*R[2,1] | (R[1,1]^2+R[2,2]^2-R[1,2]^2-R[2,1]^2)/2 | (R[2,2]^2-R[1,1]^2+R[2,1]^2-R[1,2]^2+2*R[1,3]^2-2*R[2,3]^2)/2*s3 >, < (2*R[3,3]*R[3,2]-R[2,2]*R[2,3]-R[1,2]*R[1,3])*s3 | (2*R[3,3]*R[3,1]-R[1,1]*R[1,3]-R[2,1]*R[2,3])*s3 | (2*R[3,1]*R[3,2]-R[1,1]*R[1,2]-R[2,2]*R[2,1])*s3 | (R[2,2]^2-R[1,1]^2+R[1,2]^2-R[2,1]^2+2*R[3,1]^2-2*R[3,2]^2)/2*s3 | (R[1,1]^2+R[2,2]^2+R[1,2]^2+R[2,1]^2)/6+(2*R[3,3]^2-R[1,3]^2-R[3,1]^2-R[2,3]^2-R[3,2]^2)/3 > >,dt) end else end; T end: #hfl: RotationM4AO TransformMO:=proc(R,evc0::{Matrix,Vector},BS::list,S0::{Matrix,undefined}:=undefined,$) local dt,sf,evc,bs,K,k,B,Lt,v,TT,L,t,k2,S,TTiT; if (hastype(evc0,float) or hastype(R,float)) then dt:=datatype=float; sf:=evalf else dt:=NULL; sf:=simlify end; evc:=copy(evc0); bs:=map2(op,2,BS); K:=[seq(`if`(nops(bs[k])=2 and bs[k][2]=0 or nops(bs[k])=3 and bs[k][2..3]=[0,0],k,NULL),k=1..nops(bs))]: B:=map(k->[k,AOl(bs[k]),AOt(bs[k])],K); Lt:={seq(v[2..3],v=B)}; TT:=table([seq(op(v)=sf(RotationM4AO(R,op(v))),v=Lt)]); for v in B do k,L,t:=op(v); k2:=k-1+Dim2(TT[L,t])[1]; if type(evc,Matrix) then evc[k..k2,..]:=sf(TT[L,t].evc[k..k2,..]) else evc[k..k2]:=sf(TT[L,t].evc[k..k2]) end end; if type(S0,Matrix) then S:=Matrix(S0,dt); TTiT:=table([seq(op(v)=`if`(v[2]="m" and v[1]>1,sf(LinearAlgebra[Transpose](TT[op(v)])^(-1)),TT[op(v)]),v=Lt)]); for v in B do k,L,t:=op(v); k2:=k-1+Dim2(TT[L,t])[1]; S[k..k2,..]:=sf(TTiT[L,t].S[k..k2,..]) end; for v in B do k,L,t:=op(v); k2:=k-1+Dim2(TT[L,t])[1]; S[..,k..k2]:=sf(S[..,k..k2].LinearAlgebra[Transpose](TTiT[L,t])) end; evc,Matrix(S,dt,shape=symmetric,attributes=[positive_definite]) else evc end end: #hfl: WriteMGF WriteMGF:=proc( filename::string, Atoms::list, FBS::list, evl0::{Vector,list(Vector)}, evc0::{Matrix,list(Matrix)}, labelsorhomo0::{Vector,list(Vector),nonnegint,list(nonnegint)}:=`if`(type(evl0,list),[0$nops(evl0)],0), { Ltrig::integer:=-1, obin::posint:=5, width::posint:=10, pos::posint:=22, symlabelpos::posint:=14, jmol::boolean:=false, before::list(string):=[], after::list({string,list}):=[], overwrite::boolean:=false },$) local evl,evc,labelsorhomo,nl,N,BS,K,T,i,k,incomplete,FBS2,v,n,j,fd,s,ac,prefix,l,no,labels,o1,o2; evl:=`if`(type(evl0,list),evl0,[evl0]); evc:=`if`(type(evc0,list),evc0,[evc0]); labelsorhomo:=`if`(type(labelsorhomo0,list),labelsorhomo0,[labelsorhomo0]); nl:=nops(evl); if (nops(evc)<>nl) then error("Incompatible lists of eigenvalues and eigenvectors") end; if (nops(labelsorhomo)<>nl) then error("Incompatible lists of eigenvalues and labels") end; N:=Dim2(evc[1])[1]; BS:=UnfoldBS(FBS,`if`(Ltrig<0,NULL,-Ltrig),"."); if (nops(BS)<>N) then error("Wrongly unfolded basis set: expected N=%1, unfolded N=%2",N,nops(BS)) end; # Convert basis set if jmol then K:=Vector(N,k->k,datatype=integer); T:=table(); i,k:=0,0; incomplete:=false; FBS2:=map(v->subsop(2=`if`(member(v[2][-1],["m","t","c"]),v[2][..-2],v[2]),v),FBS); FBS2:=[seq(`if`(v[2]="SPD",op([subsop(2="SP",3=map(ac->ac[[1,2,3]],v[3]),v),subsop(2="D",3=map(ac->ac[[1,4]],v[3]),v)]),v),v=FBS2)]; FBS2:=[seq(`if`(v[2]="SP",op([subsop(2="S",3=map(ac->ac[[1,2]],v[3]),v),subsop(2="P",3=map(ac->ac[[1,3]],v[3]),v)]),v),v=FBS2)]; for v in FBS2 do if (v[2]="S" ) then i:=i+1; k:=k+1; T[i]:=LinearAlgebra[IdentityMatrix](1) elif (v[2]="P" ) then i:=i+1; if (BS[k+1][2][1]=-1) then k:=k+3; T[i]:=trig2monom[1] else k:=k+3; T[i]:=LinearAlgebra[IdentityMatrix](3) end elif (v[2]="D" ) then i:=i+1; if (BS[k+1][2][1]=-2) then k:=k+5; T[i]:=trig2monom[2] else k:=k+6; T[i]:=LinearAlgebra[IdentityMatrix](6) end elif (v[2]="F" ) then i:=i+1; if (BS[k+1][2][1]=-3) then k:=k+7; T[i]:=trig2monom[3] else k:=k+10; T[i]:=LinearAlgebra[IdentityMatrix](10) end elif (v[2]="G" ) then n:=`if`(BS[k+1][2][1]=-4, 9,15); for j from 1 to n do K[k+j]:=0 end; k:=k+n; incomplete:=true elif (v[2]="H" ) then n:=`if`(BS[k+1][2][1]=-5,11,21); for j from 1 to n do K[k+j]:=0 end; k:=k+n; incomplete:=true else error("Unrecognized shell: %1",v) end end; if incomplete then WARNING("Some higher orbitals have been removed") end; K:=[seq(`if`(K[k]=0,NULL,k),k=1..N)]; T:=Matrix(evalf(LinearAlgebra[DiagonalMatrix](convert(T,list))),datatype=float); FBS2:=map(v->subsop(2=cat(v[2],"m"),v),remove(v->member(v[2],["G","H"]),FBS2)); return WriteMGF(filename,Atoms,FBS2,evl,map(v->T.v[K],evc),labelsorhomo,':-obin'=obin,':-width'=width,':-pos'=pos,':-symlabelpos'=symlabelpos,':-before'=before,':-after'=after,':-overwrite'=overwrite) end; # Begin writing if (not(overwrite) and FileTools[Exists](filename)) then error("File exists: %1",filename) end; fd:=fopen(filename,WRITE,TEXT); for s in before do fprintf(fd,"%s\n",s) end; writeline(fd," Entering Gaussian System\n"); # Coordinates writeline(fd," Standard orientation:\n\n\n"); writeline(fd,cat(" ","-"$55)); for i from 1 to nops(Atoms) do fprintf(fd,"%6d%4d%5d %12.6f\n",i,AtomicNumber(Atoms[i][1]),0,Atoms[i][2]) end; writeline(fd,cat(" ","-"$55,"\n")); # Basis set writeline(fd," AO basis set (Overlap normalization):"); for k from 1 to nops(FBS) do v:=FBS[k]; fprintf(fd," Atom %2s%-5d Shell %5d %-2s%4d\n", Atoms[v[1]][1], v[1], k, `if`(member(v[2][-1],["m","t","c"]),v[2][..-2],v[2]), nops(v[3])); for ac in v[3] do fprintf(fd," %18.10e\n",Vector(ac)) end end: # Molecular orbitals prefix:=Vector(N,k->sprintf("%5d %-*s %-*s%",k,symlabelpos-7,cat(Atoms[BS[k][1]][1],BS[k][1])[..symlabelpos-7],pos-symlabelpos-1,BS[k][-1])); for l from 1 to nl do writeline(fd,""); no:=Dim2(evl[l]); labels:=map(s->StringTools[Center](s,width)[..width],`if`(type(labelsorhomo[l],Vector),labelsorhomo[l],Vector(no,o->`if`(o>labelsorhomo[l],"V","O")))); fprintf(fd," %s Molecular Orbital Coefficients:\n",`if`(nl=1,"",["Alpha","Beta"][l])); for o1 from 1 by obin to no do o2:=min(no,o1+obin-1); fprintf(fd,"%*s%{s}*d\n",pos-4,"",width,Vector([$o1..o2])); fprintf(fd,"%*s%{s}*s\n",pos,"",width,labels[o1..o2]); fprintf(fd,"%*s%{s}s\n",pos-1,"Eigenvalues -- ",map(v->sprintf("%*.5f",width,v)[..width],evl[l][o1..o2])); for k from 1 to N do fprintf(fd,"%s%{s}*.5f\n",prefix[k],width,evc[l][k,o1..o2]) end end end; for s in after do fprintf(fd,"%s\n",s) end; fclose(fd); NULL end: #hfl: CompressMGF CompressMGF:=proc( filename0::string, left::nonnegint:=2, { nobackup::boolean:=false, forcebackup::boolean:=false, pos::posint:=21 },$) local filename,fn,ls,v,inp,u,i1,i2,i3,i1a,i1b,nr,nb,nc,V,N,k,i0; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,".mgf")); fn:=ExpandPath(filename,"pn"); ls:=ReadLines(filename); # NTO v:=SearchFilePos(filename,"Natural Transition Orbital Coefficients:",'noerror'); if (v<>[]) then inp:=ReadOutput(filename,"in"); i2:=v[1]; if (ls[i2+1]="...") then WARNING("File is already compressed: %1",filename); return end; i3:=SearchFilePos(filename,"Gross orbital populations:",'skiplines'=i2)[1]; v:=SearchFilePos(filename,"Input orientation:",'noerror'); i1:=`if`(v=[],nops(ls)+1,v[1]); FileTools[Rename](filename,cat(fn,".bak"),'force'=forcebackup); WriteLines(filename,`if`(i1>i2,[op(..i2,ls),"...",op(i3..,ls)],[op(..i1-1,ls),cat(" Input",`if`(searchtext("nosymm",inp)>0,""," ")," orientation:"),op(i1+1..i2,ls),"...",op(i3..,ls)])) else # NO v:=SearchFilePos(filename,"Natural Orbital Coefficients:",'noerror'); if (v<>[]) then i1:=v[1]; u:=SearchFilePos(filename,"Density Matrix",'skiplines'=i1,'noerror'); if (u=[]) then i2:=SearchFilePos(filename,"Condensed to atoms",'skiplines'=i1)[1]; if (ls[i2-1]="...") then WARNING("File is already compressed: %1",filename); return end; s:=NULL; i3:=i2 else i2:=u[1]; s:=ls[i2]; if (ls[i2+1]="...") then WARNING("File is already compressed: %1",filename); return end; i3:=SearchFilePos(filename,"Gross orbital populations:",'skiplines'=i2)[1] end; i1a:=SearchFilePos(filename,"Eigenvalues",'skiplines'=i1)[1]; i1b:=SearchFilePos(filename,"Eigenvalues",'skiplines'=i1a)[1]; nr:=i1b-i1a; nb:=iquo(i2-i1-1,nr); nc:=Dim2(sscanf(ls[i1a][pos..],"%{;h}fr")[1]); V:=sscanf(cat(seq(ls[i1a+nr*k][pos..],k=0..nb-1)),"%{;h}fr")[1]; N:=Dim2(V); for k from 1 to N while (V[k]>1) do end; if (k>N) then error("Cannot find unit occupation crossing in %1",filename) end; i0:=i1a+nr*iquo(k,nc); FileTools[Rename](filename,cat(fn,".bak"),'force'=forcebackup); WriteLines(filename,[ op(..i1,ls), `if`(left=0,NULL,op(max(i1a,i0-(left-1)*nr)-1..min(i0+left*nr,i1a+nr*nb)-2,ls)), s,"...", op(i3..,ls)]) else WARNING("Cannot determine type of orbitals in %1",fn); return end if end if; if nobackup then FileTools[Remove](cat(fn,".bak")) end; NULL end: #hfl: LocalizeMO LocalizeMO:=proc( mo::Matrix, pro::{list,Matrix}, typ::{"in","out","inU","inV","outU","outV","on"}, nof::numeric, evorH::{Matrix,Vector,0}, moSorS::Matrix:=LinearAlgebra[IdentityMatrix](Dim2(mo)[1]), purifymo::name:=undefined, { minocc::numeric:=.01, donotdiagonalize::boolean:=false, nprint::posint:=8, digits::posint:=3, printout::boolean:=false },$) local prn,HT,N,n,N2,n2,S,moS,H,lsk,M,occ1,T1,n1,U,Vt,o1,ls,lso,lmo1,lmoS1,no,S1,e2,T2,lmo2,lmoS2,occ2,M2,o,v; prn:=proc(n::nonnegint,J0::indexable,O::indexable,E::{indexable,0}:=0,$) local w,o,J,V; w,o:=digits+2,max(5,n-nprint+1); J:=Vector(n,o->J0[o],datatype=integer); V:=Vector(n,o->FormatFloat(O[o],digits,'maxorder'=0,'width'=w)); if (o=5) then printf("%*d\n%s\n",w,J,V) else printf("%*d %*s %*d\n%s %*s %s\n",w,J[..3],w,"...",w,J[o..],V[..3],w,"...",V[o..]) end; if (E<>0) then if (o=5) then printf("%*.1f\n",w,E) else printf("%*.1f %*s %*.1f\n",w,E[..3],w,"...",w,E[o..]) end end end; if member(typ,["in","inV","outU"]) then WARNING("typ=%1 can produce wrong results",typ) end; HT:=`if`(has(mo,I),LinearAlgebra[HermitianTranspose],LinearAlgebra[Transpose]); N,n:=Dim2(mo); if type(pro,list) then n2:=0 else N2,n2:=Dim2(pro); if (N2<>N) then error("Inconsistent basis size in mo(%1) and pro(%2)",N,N2) end end; if ([Dim2(moSorS)]=[N,N]) then S,moS:=moSorS,HT(mo).moSorS elif ([Dim2(moSorS)]=[n,N]) then S,moS:=undefined,moSorS else error("Inconsistent size of mo(%1,%2) and moSorS(%3,%4)",Dim2(mo),Dim2(moSorS)) end; H:=`if`(type(evorH,Vector),LinearAlgebra[DiagonalMatrix](evorH),evorH); lsk:=`if`(typ[..2]="in",pro,`if`(typ[..3]="out",remove(member,[$1..N],pro),undefined)); #1. Calculate T1 and occ2 by SVD or GEVP if ((n2=0 or n2=N) and (typ="in" or typ="out")) then if type(S,undefined) then error("Unrecognized overlap matrix Dim2=%1",Dim2(moSorS)) end; if (n2=0) then # projecting list of AO indices with overlap M:=HT(mo[lsk,..]).S[lsk,lsk].mo[lsk,..] else # projecting matrix M:=pro.mo; M:=HT(M).S.M end; occ1,T1:=LinearAlgebra[Eigenvectors](Matrix(M,shape=hermitian),Matrix(moS.mo,shape=hermitian,attributes=[positive_definite])); if (typ="in") then occ1,T1:=occ1[[seq(n..1,-1)]],T1[..,[seq(n..1,-1)]] else occ1:=map(v->1-v,occ1) end; n1:=n elif (n2=0 and member(typ,["inU","inV","outU","outV"]) or n2>0 and typ="on") then if (n2=0) then # projecting list of AO indices without overlap M:=moS[..,lsk].mo[lsk,..] else # projecting MOs M:=moS.pro end; U,Vt,occ1:=LinearAlgebra[SingularValues](M,'thin','output'=[':-U',':-Vt',':-S']); if (typ[-1]="U") then T1:=U elif (typ[-1]="V") then T1:=HT(Vt) else T1:=U.Vt end; if (typ[..3]="out") then occ1,T1:=map(v->1-v,occ1[[seq(n..1,-1)]]),T1[..,[seq(n..1,-1)]] end; n1:=`if`(n2=0,n,min(n,n2)) else error("Unrecognized combination of pro(n2=%1) and typ=%2 parameters",n2,typ) end; #2. Determine no for o1 from 1 to n1 while (occ1[o1]>minocc) do end; o1:=min(o1,n1); if type(nof,integer) then no:=nof else for no from 0 to n1-1 while (occ1[no+1]>nof) do end end; if printout then prn(o1,[$1..o1],occ1,`if`(H=0,0,Vector(o1,o->HT(T1[..,o]).H.T1[..,o]))),printf("no=%d%*s\n",no,(digits+3)*min(no,nprint+4)-5-floor(log10(max(1,min(no,nprint+4)))),"***") end; if (no=0) then return NULL end; T1:=T1[..,..no]; #2a. Purify mo and exit if not(purifymo=undefined or no=n) then ls:=Rort([seq([o,T1[o,..].HT(T1[o,..])],o=1..n)],[2]); lso:=sort(map2(op,1,ls[..no])); if printout then printf("Will rerun with purified mo %s:\n",convert2range(lso,'asstring')),prn(n,map2(op,1,ls),map2(op,2,ls)) end; assign(purifymo,ls); return LocalizeMO(mo[..,lso],pro,typ,no,`if`(H=0,0,H[lso,lso]),`if`(type(S,Matrix),S,moS[lso,..]),':-minocc'=minocc,':-donotdiagonalize'=donotdiagonalize,':-nprint'=nprint,':-digits'=digits,':-printout'=printout) end; #2b. Calculate lmo1,lmoS1 and check if T1 is unitary lmo1,lmoS1:=mo.T1,HT(T1).moS; S1:=HT(T1).T1; if (LinearAlgebra[Norm](S1-1,'Frobenius')>10^(2-Digits)) then WARNING("T1 is not unitary, |S1-1|=%1",LinearAlgebra[Norm](S1-1,'Frobenius')) end; #3. Calculate T2 by diagonalizing H if (H=0) then lmo2,lmoS2,e2:=lmo1,lmoS1,Vector(no,datatype=float) elif (donotdiagonalize) then lmo2,lmoS2,e2:=lmo1,lmoS1,Vector(no,o->HT(T1[..,o]).H.T1[..,o],datatype=float) else e2,T2:=LinearAlgebra[Eigenvectors](Matrix(HT(T1).H.T1,shape=hermitian)); lmo2,lmoS2,T1:=lmo1.T2,HT(T2).lmoS1,T1.T2 end; #4. Calculate occ2 if (n2=N) then M2:=pro.lmo2; occ2:=Vector(no,o->HT(M2[..,o]).S.M2[..,o]) elif (n2=0) then if (typ="in" or typ="out") then occ2:=Vector(no,o->HT(lmo2[lsk,o]).S[lsk,lsk].lmo2[lsk,o]) else occ2:=Vector(no,o->lmoS2[o,lsk].lmo2[lsk,o]) end else # n2>0 occ2:=Vector(no,o->LinearAlgebra[Norm](lmoS2[o,..].pro,2)) end; if (typ[..3]="out") then occ2:=map(v->1-v,occ2) end; if printout then prn(no,[$1..no],occ2,`if`(H=0,0,e2)) end; lmo2,lmoS2,e2,occ2,occ1,T1 end: #hfl: MatchOrbitals MatchOrbitals:=proc(A1::list,ev1::Vector,evc1::Matrix,sym1::{Vector,list},S1::Matrix, A2::list,ev2::Vector,evc2::Matrix,sym2::{Vector,list},S2::Matrix, de::numeric, minO::numeric:=0, lso::list:=[], lsi::list:=[], k2i::list:=[], {maxrot::numeric:=0.1, maxdS::numeric:=1e-8, printout::{boolean,posint}:=false },$) local pri,noprint,na1,na2,N1,N2,no10,no20,s1,s2,lso1,lso2,no1,no2,lsi1,lsi2,na,A2a,R,d,K1,K2,k2i1,k2i2,i2p1,i2p2,N,dS,S,O12,val,ls,no,lso1a,lso2a,maxo1,maxo2,lso1b,lso2b,no1b,no2b,P2a,ev2a,evc2a,sym2a,O12a,C2a,L, v,o,o1,o2,i,k; if type(printout,boolean) then pri,noprint:=printout,3 else pri,noprint:=true,printout end; na1,na2:=nops(A1),nops(A2); N1,no10,N2,no20:=Dim2(evc1),Dim2(evc2); s1:=`if`(type(sym1,list) and sym1=[],Vector(no1,o->""),sym1); s2:=`if`(type(sym2,list) and sym2=[],Vector(no2,o->""),sym2); # Process lso if (lso=[]) then lso1,lso2:=[$1..no10],[$1..no20] else lso1,lso2:=`if`(type(lso,[list,list]),op(lso),lso$2); if (max(lso1)>no10) then error("Too large indexes in lso1: %1",lso1) end; if (max(lso2)>no20) then error("Too large indexes in lso2: %1",lso2) end end; no1,no2:=nops(lso1),nops(lso2); if pri then printf("Orbitals: no1/20=%d/%d, no1/2=%d/%d\n",no10,no20,no1,no2) end; # Process geometry if (lsi=[]) then lsi1,lsi2:=[$1..na1],[$1..na2] else lsi1,lsi2:=`if`(type(lsi,[list,list]),op(lsi),lsi$2); if (max(lsi1)>na1) then error("Too large indexes in lsi1: %1",lsi1) end; if (max(lsi2)>na2) then error("Too large indexes in lsi2: %1",lsi2) end end; na:=nops(lsi1); if (nops(lsi2)<>na) then error("Different sizes of lsi1,2: %1 vs %2",lsi1,lsi2) end; R,d:=Superimpose(A1[lsi1],A2[lsi2],output="rd",'det'=1); if pri then printf("Atoms: na1/2=%d/%d, na=%d, dev=%.1g, det=%d, angle=%.3f, axis=<%{c,}.2f>\n",na1,na2,na,d,RotationParam(R)) end; if (LinearAlgebra[Norm](R-1,'Frobenius')>maxrot) then error("Rotations are not supported, R=%1",R) end; A2a:=map(v->subsop(2=R.v[2],v),A2); # Process basis if (k2i=[]) then K1,K2:=[$1..N1],[$1..N2] else k2i1,k2i2:=`if`(type(k2i,[list,list]),op(k2i),k2i$2); if not(type(k2i1,list(integer))) then k2i1:=map2(op,1,k2i1) end; #convert basis set to k2i i2p1:=[seq(SearchPos(lsi1,i),i=1..na1)]; #sort according to atoms positions K1:=map2(op,1,Sort(remove(v->v[2]=0,[seq([k,i2p1[k2i1[k]]],k=1..nops(k2i1))]),[2])); #convert to K if not(type(k2i2,list(integer))) then k2i2:=map2(op,1,k2i2) end; i2p2:=[seq(SearchPos(lsi2,i),i=1..na2)]; K2:=map2(op,1,Sort(remove(v->v[2]=0,[seq([k,i2p2[k2i2[k]]],k=1..nops(k2i2))]),[2])) end; N:=nops(K1); if (nops(K2)<>N) then error("Different sizes of K1,2: %1 vs %2",K1,K2) end; printf("Basis: N1/2=%d/%d, N=%d\n",N1,N2,N); # Determine overlap matrix dS:=LinearAlgebra[Norm](S1[K1,K1]-S2[K2,K2],'Frobenius'); if (dS<=maxdS) then S:=S1[K1,K1]; if pri then printf("S=S1.K: |S2-S|=%.2g\n",dS) end else S:=Matrix(MatrixFunction2(S1,x->sqrt(x)),datatype=float)[..,K1].Matrix(MatrixFunction2(S2,x->sqrt(x)),datatype=float)[K2,..]; if pri then printf("S=sqrt(S1).K.sqrt(S2): |S1-S|=%.2g, |S2-S|=%.2g\n",LinearAlgebra[Norm](S1[..,K1]-S[..,K2],'Frobenius'),LinearAlgebra[Norm](S2[K2,..]-S[K1,..],'Frobenius')) end end; # Match orbitals O12:=LinearAlgebra[Transpose](evc1[..,lso1]).S.evc2[..,lso2]; #PrintMatrix(O12[..min(24,no1),..min(24,no2)],"%.2f",'head'=[map(convert,lso1a,string),map(convert,lso2a,string)]): val:=Matrix(no1,no2,(o1,o2)->`if`(s1[lso1[o1]]=s2[lso2[o2]],0,1000)+((ev1[lso1[o1]]-ev2[lso2[o2]])/de)^2-O12[o1,o2]^2,datatype=float); ls:=IdentifyPairs([$1..no1],[$1..no2],(o1,o2)->val[o1,o2],'nolist'); ls:=Sort(select(v->abs(O12[v[1],v[2]])>=minO,ls),[1]); no:=nops(ls); lso1a:=lso1[map2(op,1,ls)]; lso2a:=lso2[map2(op,2,ls)]; # Reorder ev2,evc2 and process unpaired orbitals maxo1,maxo2:=max(lso1a),max(lso2a); lso1b:=remove(member,remove(`>`,lso1,maxo1),lso1a); lso2b:=remove(member,remove(`>`,lso2,maxo2),lso2a); no1b,no2b:=nops(lso1b),nops(lso2b); if pri then printf("Permuted orbitals: %{c,}s\n",Vector([seq(`if`(lso1a[o]=lso2a[o],NULL,sprintf("%d=%d",lso1a[o],lso2a[o])),o=1..no)])); if (no1b>0) then printf("Unmatched orbitals 1 (%d):%{c,}s\n",no1b,map(o->sprintf(" %d@%.2f",o,ev1[o]),Vector(lso1b[..min(9,no1b)]))) end; if (no2b>0) then printf("Unmatched orbitals 2 (%d):%{c,}s\n",no2b,map(o->sprintf(" %d@%.2f",o,ev2[o]),Vector(lso2b[..min(9,no2b)]))) end end; P2a:=Vector([$1..no20]); for o from 1 to no do P2a[lso1a[o]]:=lso2a[o] end; #permute matched orbitals for o from 1 to no2b do P2a[maxo1+o]:=lso2b[o] end; #they are followed by unmatched orbitals from evc2 for o from maxo1+no2b+1 to no20 do P2a[o]:=o-no1b end; #shift other indexes by unmatched orbitals from evc1 P2a:=convert(P2a,list); ev2a,evc2a,sym2a:=ev2[P2a],evc2[..,P2a],`if`(sym2=[],[],sym2[P2a]); for o in lso1a do evc2a[..,o]:=evc2a[..,o]*signum(evc1[..,o].S.evc2a[..,o]) end; for o in lso1b do evc2a[..,o]:=Vector(N2); evc2a[K2,o]:=evc1[K1,o]; ev2a[o]:=ev1[o] end; O12a:=LinearAlgebra[Transpose](evc1[..,lso1a]).S.evc2a[..,lso1a]; #PrintMatrix(O12a[..min(24,no),..min(24,no)],"%.2f",'head'=[map(convert,lso1a,string),map(convert,lso2a,string)]): C2a:=Vector(no20,9); for o from 1 to no do C2a[lso1a[o]]:=O12a[o,o] end; for o in lso1b do C2a[o]:=7 end; for o from 1 to no2b do C2a[maxo1+o]:=8 end; L:=[seq([O12a[o,o],ev2[lso2a[o]]-ev1[lso1a[o]],lso1a[o],ev1[lso1a[o]],lso2a[o],ev2[lso2a[o]]],o=1..no)]; if pri then ls:=map(v->sprintf(" %.2f@%+.2f (%d@%.2f/%d@%.2f)",op(v)),Sort(L,[1])[..min(noprint,no)]); if (noprint>3) then printf("Smallest overlaps:\n"); PrintColumns(ls,3) else printf("Smallest overlaps:%{c,}s\n",Vector(ls)) end; printf("Final norm: %.3f\n",LinearAlgebra[Norm](O12a-1,'Frobenius')) end; A2a,ev2a,evc2a,sym2a,C2a,P2a,O12a,O12,S,L,R end: ################################################################################ #cat: Quantum chemistry #hfl: VibrationalModes VibrationalModes:=proc( Atoms::list, frcc::Matrix, output::string:="nem", { isotopes::list:=[0$nops(Atoms)], massnormalized::boolean:=false, vibrationsonly::boolean:=false, axes::list:=[1,2,3], dir::Vector:=<1,1,1>, trmodes::{"ignore","explicit","smallest","lowest","residue"}:="explicit", nzero::nonnegint:=6, zero::numeric:=.001, printout::boolean:=false, minT::numeric:=.01, minR::numeric:=.1, nprint::posint:=3, digits::posint:=3 },$) local n,m,mtot,P,J,Jv,O,N,M,k,o,K,ev,evc,E,i,ni,VT,ls,err,VR,T1,evc1,K1,ev1,E1,ev2,evc2,ls2,T,v,modes,j,out; n:=nops(Atoms); m:=`if`(type(isotopes[1],integer),[seq(AtomMass(Atoms[k][1],isotopes[k]),k=1..n)],isotopes); mtot:=add(m[k],k=1..n); # Inertia matrix P:=add(m[k]*Atoms[k][2],k=1..n)/mtot; J:=Matrix(3,(o1,o2)->add(m[k]*(Atoms[k][2][o1]-P[o1])*(Atoms[k][2][o2]-P[o2]),k=1..n),datatype=float,shape=symmetric); J:=Matrix(Trace(J)-J,datatype=float,shape=symmetric); Jv,O:=LinearAlgebra[Eigenvectors](J); O:=O[..,axes]; if (O[..,1].dir<0) then O[..,1]:=-O[..,1] end; if (O[..,2].dir<0) then O[..,2]:=-O[..,2] end; if (LinearAlgebra[Determinant](O)<0) then O[..,3]:=-O[..,3] end; if printout then printf("Inertia matrix eigenvalues (u*Ao^2): %.3f\n",Jv) end; # Spectral analysis N:=3*n; M:=Vector(N,datatype=float); for k from 1 to n do for o from 1 to 3 do M[3*k-3+o]:=m[k] end end; K:=Matrix(N,(i,j)->frcc[i,j]/`if`(massnormalized,1,sqrt(M[i]*M[j])),shape=symmetric,datatype=float); ev,evc:=LinearAlgebra[Eigenvectors](K); E:=Vector(N,i->signum(ev[i])*sqrt(h2imu*abs(ev[i])),datatype=float); for i from 1 to N while (E[i]<-zero) do end; ni:=i-1; if (ni>0 and printout) then printf("There are %d imaginary frequencies (zero=%a)",ni,zero) end; for i from ni+1 to N while (E[i]<=zero) do end; if (i-1-ni<>nzero) then WARNING("The number of zero modes %1<>%2 (zero=%3)",i-1-ni,nzero,zero) end; VT:=Vector(N,i->abs(add(sqrt(M[j])*evc[j,i],j=1..N)),datatype=float); ls:=SortIdx(VT,'nolist'); err:=add(`if`(abs(E[i])>zero,1,0),i=ls[-min(3,nops(ls))..]); if (err>0) then WARNING("There are %1 nonzero T-modes",err) end; VR:=Vector(N,i->abs(add(sqrt(M[3*k])*add(Atoms[k][2][mod1(j+1,3)]*evc[3*k-3+mod1(j+2,3),i]-Atoms[k][2][mod1(j+2,3)]*evc[3*k-3+mod1(j+1,3),i],j=1..3),k=1..n)),datatype=float); ls:=SortIdx(VR,'nolist'); err:=add(`if`(abs(E[i])>zero,1,0),i=ls[-min(max(0,nzero-3),nops(ls))..]); if (err>0) then WARNING("There are %1 nonzero R-modes",err) end; # Translations and rotations if (trmodes<>"ignore") then T1:=Matrix(N,6,datatype=float); for o from 1 to 3 do for k from 1 to n do T1[3*k-2..3*k,o]:=O[..,o]; T1[3*k-2..3*k,o+3]:=LinearAlgebra[CrossProduct](O[..,o],Atoms[k][2]-P) end end; for o from 1 to 3 do T1[..,o]:=T1[..,o]/sqrt(mtot); T1[..,o+3]:=T1[..,o+3]/sqrt(Jv[o]) end; evc1:=Matrix(N,6,(i,j)->T1[i,j]*sqrt(M[i]),datatype=float); K1:=Matrix(LinearAlgebra[Transpose](evc1).K.evc1,shape=symmetric,datatype=float); ev1:=LinearAlgebra[Eigenvalues](K1); E1:=Vector(6,i->signum(ev1[i])*sqrt(h2imu*abs(ev1[i])),datatype=float); err:=add(`if`(abs(v)>zero,1,0),v=E1); if (err>0) then WARNING("There are %1 nonzero TR-modes (zero=%2)",err,zero) end; if printout then printf("TR eigenvalues (meV): %{c,}.3f\n",1000*E1); printf("TR nondiagonality: %.2g\n",LinearAlgebra[Norm](ev1-sort(LinearAlgebra[Diagonal](K1)),'infinity')/LinearAlgebra[Norm](ev1,'infinity')) end; if (trmodes="explicit") then if not(nzero=6 or nzero=3) then WARNING("nzero=%1 but trmodes=explicit",nzero) end; evc:=Matrix(LinearAlgebra[IdentityMatrix](N),datatype=float); evc[..,..nzero]:=evc1[..,..nzero]; evc,v:=LinearAlgebra[QRDecomposition](evc); evc[..,..nzero]:=evc1[..,..nzero]; ev2,evc2:=LinearAlgebra[Eigenvectors](Matrix((LinearAlgebra[Transpose](evc).K.evc)[nzero+1..,nzero+1..],shape=symmetric,datatype=float)); evc[..,nzero+1..]:=evc[..,nzero+1..].evc2; ev:=Vector(N,i->`if`(i<=nzero,K1[i,i],ev2[i-nzero]),datatype=float); if printout then printf("Rovibrational terms (meV): %.2g\n",sqrt(h2imu*LinearAlgebra[Norm](Transpose(evc1).K.evc[..,nzero+1..],'Frobenius'))) end elif (trmodes="smallest") then ls:=SortIdx(E,v->abs(v),'nolist')[..nzero]; ni:=min(op(ls))-1; if (ni>0) then ev[..nzero],ev[nzero+1..nzero+ni]:=ev[ni+1..ni+nzero],ev[..ni]; evc[..,..nzero],evc[..,nzero+1..nzero+ni]:=evc[..,ni+1..ni+nzero],evc[..,..ni] end elif (trmodes="lowest" and ni>0) then error("There are %1 imaginary frequencies (zero=%2, Eim=%3), cannot use trmodes=lowest)",ni,zero,convert(E[..ni],list)) elif (trmodes="residue") then ls :=SortIdx(VT,v->-v,'nolist')[..3]; ls2:=SortIdx(VR,v->-v,'nolist')[..nzero]; for i from 1 to nzero do if member(ls2[i],ls) then ls2:=subsop(i=NULL) end end; ls:=[op(ls),op(1..nzero-3,ls2)]; ls2:=[seq(`if`(member(i,ls),NULL,i),i=1..N)]; ev[..nzero],ev[nzero+1..]:=ev[ls],ev[ls2]; evc[..,..nzero],evc[..,nzero+1..]:=evc[..,ls],evc[..,ls2] end; end if; # Prepare output E:=Vector(N,i->signum(ev[i])*sqrt(h2imu*abs(ev[i])),datatype=float); T:=Matrix(N,(i,j)->evc[i,j]/sqrt(M[i]),datatype=float); v:=Vector(N,j->1/LinearAlgebra[Norm](T[..,j],2),datatype=float); modes:=Matrix(N,(i,j)->v[j]*T[i,j],datatype=float); VT:=Vector(N,i->abs(add(sqrt(M[j])*evc[j,i],j=1..N)),datatype=float); VR:=Vector(N,i->abs(add(sqrt(M[3*k])*add(Atoms[k][2][mod1(j+1,3)]*evc[3*k-3+mod1(j+2,3),i]-Atoms[k][2][mod1(j+2,3)]*evc[3*k-3+mod1(j+1,3),i],j=1..3),k=1..n)),datatype=float); # Printing if printout then i,j:=SortIdx(VT[..6],'nolist')[-3],SortIdx(VR[..6],'nolist')[-3]; printf("Ratio of highest T/R-residue of vibrational mode to lowest T/R-residue of T/R-mode: %.2g / %.2g\n",max(VT[nzero+1..])/VT[i],max(VR[nzero+1..])/VR[j]); printf("There are %d vibrations up to %.0f meV, %d zero modes, %d imaginary frequencies\n",N-nzero,1000*E[-1],nzero,ni); printf(" # vib# E(meV) T-res R-res\n"); for i from 1 to N while (i<=nzero or E[i]minT or VR[i]>minR) do end; for j from 1 to min(N,i-1+nprint) do printf("%3d%4s%s%*.*f%*.*f\n",j,`if`(j>nzero,sprintf("%d",j-nzero),""),FormatFloat(1000*E[j],0,digits,'width'=10),6+digits,digits,VT[j],6+digits,digits-1,VR[j]) end end; i:=`if`(vibrationsonly,nzero+1,1); out:=NULL; for v in output do if (v="e") then out:=out,E[i..] elif (v="i") then out:=out,ni elif (v="j") then out:=out,J elif (v="k") then out:=out,K elif (v="l") then out:=out,K1 elif (v="m") then out:=out,modes[..,i..] elif (v="M") then out:=out,M elif (v="n") then out:=out,N-i+1 elif (v="o") then out:=out,O elif (v="p") then out:=out,P elif (v="t") then out:=out,T[..,i..] elif (v="v") then out:=out,ev elif (v="w") then out:=out,evc elif (v="X") then out:=out,sqrt(h2imu)*Matrix(N,N-i+1,(k,j)->T[k,i-1+j]/`if`(E[i-1+j]=0,10^(1-Digits),sqrt(abs(E[i-1+j]))),datatype=float) elif (v="z") then out:=out,nzero elif (v="1") then out:=out,VT elif (v="2") then out:=out,VR else error("Unrecognized output code %1",v) end end; out end: #hfl: MatchVibrations MatchVibrations:=proc(A1::list,E1::Vector,T1::Matrix,sym1::{Vector,list}, A2::list,E2::Vector,T2::Matrix,sym2::{Vector,list}, M::Vector,dE::numeric,PP::list(list(posint)):=[],{maxnorm::numeric:=1,printout::boolean:=false},$) local n1,N1,n2,N2,s1,s2,R,d,A2a,v,T2in1,Tt,val,ls,P,P2,lsm,lslsm,E2a,T2a,ff,ls2,i,j,m; n1,N1,n2,N2:=Dim2(T1),Dim2(T2); s1:=`if`(type(sym1,list) and sym1=[],Vector(N1,m->""),sym1); s2:=`if`(type(sym2,list) and sym2=[],Vector(N2,m->""),sym2); if printout then printf("na1/2=%d/%d, n1/2=%d/%d, N1/2=%d/%d\n",nops(A1),nops(A2),n1,n2,N1,N2) end; R,d:=Superimpose(A1,A2,output="rd"); if printout then printf("Atoms: dev=%.1g, det=%d, angle=%.3f, axis=<%{c,}.2f>\n",d,RotationParam(R)) end; A2a:=map(v->subsop(2=R.v[2],v),A2); T2in1:=LinearAlgebra[DiagonalMatrix]([R$nops(A1)]).T2; Tt:=LinearAlgebra[Transpose](T1).LinearAlgebra[DiagonalMatrix](M).T2in1; val:=Matrix(N1,N2,(i,j)->1000*`if`(s1[i]=s2[j],0,1)+((E1[i]-E2[j])/dE)^2-Tt[i,j]^2,datatype=float); ls:=IdentifyPairs([$1..N1],[$1..N2],(i,j)->val[i,j],'nolist'); P:=SortIdx(map2(op,1,Sort(ls,[2])),'nolist'); if (PP<>[]) then P2:=Vector(N1,m->m,datatype=integer); for lsm in PP do P2[sort(lsm)]:=Vector(lsm) end; P:=P[convert(P2,list)] end; lslsm:=Sort(map(sort,GraphTheory[StronglyConnectedComponents](GraphTheory[Graph]({seq(`if`(m=P[m],NULL,[m,P[m]]),m=1..N1)}))),[1]); if (printout and lslsm<>[]) then printf("Permutations: %{s}s\n",Vector(map(lsm->sprintf("[%{c,}d]",Vector(P[lsm])),lslsm))) end; E2a,T2a:=E2[P],T2in1[..,P]; for i from 1 to N2 do T2a[..,i]:=T2a[..,i]*signum(add(M[j]*T2a[j,i]*T1[j,i],j=1..n2)) end; Tt:=LinearAlgebra[Transpose](T1).LinearAlgebra[DiagonalMatrix](M).T2a; if printout then printf("Final norm: %.3f\n",LinearAlgebra[Norm](Tt-1,'Frobenius')); ff:=proc(lsm) local M; M:=Matrix(nops(lsm)+1,datatype=integer); M[2..,1]:=Vector(lsm); M[1,2..]:=Vector(P[lsm]); M[2..,2..]:=map(round,100*Tt[lsm$2]); M end; ls2:=[seq(`if`(LinearAlgebra[Norm](Tt[lsm$2]-1,'Frobenius')>maxnorm,ff(lsm),NULL),lsm=lslsm)]; if (ls2<>[]) then print(op(ls2)) end end; A2a,E2a,T2a,R,P,ls,Tt end: #hfl: VibronicCouplings VibronicCouplings:=proc( Atoms::list, Atoms2::list, frcc::Matrix, output::string:="nesm", { vibrationsonly::boolean:=false, printout::boolean:=false, nprint2::posint:=3, digits::posint:=3 }) local Atoms2a,N,E,modes,T,M,nzero,x,i,j,g2,g,S,Stot,Epol,ls,out,v; if printout then printf("---------- Orientation ----------\n") end; Atoms2a:=Superimpose(Atoms,Atoms2,'massweighted',':-printout'=printout); N,E,modes,T,M,nzero:=VibrationalModes(Atoms,frcc,"nemtMz",_rest,':-printout'=printout,':-digits'=digits); x:=Vector(N,datatype=float); for i from 1 to N/3 do for j from 1 to 3 do x[3*(i-1)+j]:=Atoms[i][2][j]-Atoms2a[i][2][j] end end; g2:=Vector[row](N,j->M[j]*x[j],datatype=float).T; g:=Vector(N,i->g2[i] *sqrt(abs(E[i])/(2*h2imu)),datatype=float); S:=Vector(N,i->g2[i]^2* abs(E[i])/(2*h2imu) ,datatype=float); if printout then printf("Couplings to TR modes: total %.2g, max %.2g\n",add(v,v=S[..nzero]),max(S[..nzero])); Stot,Epol:=add(v,v=S),add(E[i]*S[i],i=1..N); printf("Stot=%.2f, Epol=%.3f eV, bandwidth=%.3f eV (%.3f at 300K), effomega=%.0f meV\n",Stot,Epol,sqrt(add(E[i]^2*S[i],i=1..N)),sqrt(add(E[i]^2*S[i]*coth(E[i]/(2*300*K2eV)),i=1..N)),1000*Epol/Stot); printf("---------- Strongest couplings ----------\n"); printf(" # vib# E(meV) S\n"); ls:=SortIdx(S,u->-u,'nolist'); for i in ls[..nprint2] do printf("%3d%4s%s%*.*f\n",i,`if`(i>nzero,sprintf("%d",i-nzero),""),FormatFloat(1000*E[i],0,digits,'width'=10),6+digits,digits,S[i]) end end; i:=`if`(vibrationsonly,nzero+1,1); out:=NULL; for v in output do if (v="e") then out:=out,E[i..] elif (v="g") then out:=out,g[i..] elif (v="m") then out:=out,modes[..,i..] elif (v="M") then out:=out,M elif (v="n") then out:=out,N-i+1 elif (v="s") then out:=out,S[i..] elif (v="t") then out:=out,T[..,i..] elif (v="z") then out:=out,nzero else error("Unrecognized output code %1",v) end end; out end: #hfl: TransSp TransSp:=proc( VE::Vector, VS::Vector, TorVn::{numeric,Vector}, vmin::numeric, { absbin::numeric:=infinity, relbin::numeric:=0.5, sorted::boolean:=false, avew::numeric:=0.5, wdigits::posint:=30, maxnconf::posint:=1000000, maxerror::numeric:=0.1, maxerror2::numeric:=maxerror/10, sort::boolean:=false, Edigits::nonnegint:=3, Sdigits::nonnegint:=2, printout::boolean:=false },$) local digits,N,E,f,Vvo,Vvmax,i,s,m,n1,n2,ls1,ls2,n,v,ls,T,binE,N0,tb,E1,j,k,S,Ea,Sw,e,o2,o1,v1,v2,vmax,o,Vomax,E0,vmin2,err,lsijsv,tbv,spp,ct,ijsv,ijs,ijs1,nijsv,m1,lstr,sprng,ij,io; digits:=Digits; Digits:=wdigits; if type(TorVn,Vector) then N:=op(1,VE); E:=VE; f:=(m,n,s)->`if`(m<=n,evalf(s^(n-m)*m!/n!*orthopoly[L](m,n-m,s)^2*exp(-s)),f(n,m,s)); Vvo,Vvmax:=Vector(N),Vector(N,datatype=float); for i from 1 to N do s,m:=VS[i],TorVn[i]; n1,n2:=max(0,round(m+s-2*sqrt(m*s)-1/2)),round(m+s+2*sqrt(m*s)-1/2); ls1:=[]; for n from n1-1 by -1 to 0 do v:=f(m,n,s); if (v-v[1]); Vvmax[i]:=ls[1][1]; Vvo[i]:=[seq([v[1]/Vvmax[i],v[2]],v=ls)] end else T:=TorVn; binE:=`if`(absbin=infinity,T*relbin,absbin); N0:=op(1,VE); ls:=`if`(sorted,[$1..N0],SortIdx(VE,'nolist')); tb:=table(): i:=1; while (i<=N0) do E1:=VE[ls[i]]; for j from i+1 to N0 while (VE[ls[j]]-E1add(VS[i],i=ls[k]),datatype=float); Ea:=Vector(N,k->add(VS[i]*VE[i],i=ls[k])/S[k],datatype=float); Sw:=Vector(N0,i->VS[i]/(1-exp(-VE[i]/T)),datatype=float); E:=Vector(N,k->Ea[k]+avew*T*ln(add(Sw[i],i=ls[k])/add(Sw[i]*exp((Ea[k]-VE[i])/T),i=ls[k])),datatype=float); if printout then printf("---------- Coarse graining (bin=%.2g) ----------\n N Stot Smax Epol\n",binE); printf("before: %4d%8.*f%8.*f%8.*f\n",N0,Sdigits,add(v,v=VS),Sdigits,max(seq(v,v=VS)),Edigits,add(VE[i]*VS[i],i=1..N0)); printf(" after: %4d%8.*f%8.*f%8.*f\n",N ,Sdigits,add(v,v=S ),Sdigits,max(seq(v,v=S )),Edigits,add( E[i]* S[i],i=1..N )) end; f:=(o,e,S)->evalf(exp(ln(BesselI(o,S/sinh(e)))+e*o-S*coth(e))); Vvo,Vvmax:=Vector(N),Vector(N,datatype=float); for i from 1 to N do s,e:=S[i],E[i]/2/T; o2:=round(s); o1:=o2-1; v1,v2:=f(o1,e,s),f(o2,e,s); vmax:=max(v1,v2); ls1:=[]; for o from o1-1 by -1 to -infinity do v:=f(o,e,s); if (v-v[1]); Vvmax[i]:=vmax end end; Vomax:=Vector(N,i->Vvo[i][1][2],datatype=integer); E0:=add(E[i]*Vomax[i],i=1..N); vmax:=mul(v,v=Vvmax); Digits:=digits; vmin2:=min(.999,vmin/vmax); for i from 1 to N do Vvo[i]:=remove(v->v[1]maxerror2) then WARNING("Error in integrals=%1>maxerror2=%2",err,maxerror2) end; lsijsv:=[[[],vmax]]; tbv:=table([[]=vmax]); spp:=table([0=vmax]); if printout then printf("---------- Spectral progression ----------\n m spp nconf time\n 0%9.4f 1\n",spp[0]) end; for m from 1 to infinity do spp[m]:=0; ct:=:-time(); tb:=table(); for ijsv in lsijsv do ijs,v:=op(ijsv); for i from `if`(ijs=[],0,ijs[-1][1])+1 to N do for j from 2 to nops(Vvo[i]) do v1:=v*Vvo[i][j][1]; if (v1maxnconf) then WARNING("Maximum number of configurations (%1) is exceeded",maxnconf); break end end; err:=1-add(spp[m1],m1=0..m); if printout then printf("---------- Finally ----------\nTotal number of configurations is %d\n",nops([indices(tbv)])) end; if (err>maxerror) then WARNING("Incomplete spectral progression error=%1>maxerror=%2",err,maxerror) end; ct:=:-time(); lstr:=[seq([tbv[ijs],[seq([ij[1],Vvo[ij[1]][ij[2]][2]],ij=ijs)]],ijs=indices(tbv,'nolist'))]; if sort then lstr:=Sort(lstr,v->-v[1]) end; lstr:=[seq([E0+add(E[io[1]]*(io[2]-Vomax[io[1]]),io=v[2]),v[1],v[2]],v=lstr)]; sprng:=min(seq(v[1],v=lstr))..max(seq(v[1],v=lstr)); if printout then printf("Spectral range is %.*f..%.*f, computation time %.0f\n",Edigits,op(1,sprng),Edigits,op(2,sprng),:-time()-ct) end; Vomax,lstr,sprng,vmax,err end: #hfl: TransSp CoarsegrainSp:=proc(sp::{Vector,list},binE::numeric,{printout::boolean:=false},$) local w,minE,maxE,binrng,A1,A2,v,i; if (type(sp,Vector) or nops(sp[1])=1) then w:=1/Dim2(sp); CoarsegrainSp([seq([v,w],v=sp)],binE,':-printout'=printout) else minE,maxE:=min(seq(v[1],v=sp)),max(seq(v[1],v=sp)); binrng:=round(minE/binE)..round(maxE/binE); A1,A2:=Array(binrng,datatype=float),Array(binrng,datatype=float): for v in sp do i:=round(v[1]/binE); A1[i]:=A1[i]+v[2]*v[1]; A2[i]:=A2[i]+v[2] end; v:=[[minE,0],seq(`if`(A2[i]=0,NULL,[A1[i]/A2[i],A2[i]]),i=binrng),[maxE,0]]; if printout then printf("Coarse grained from %d to %d\n",nops(sp),nops(v)) end; v end end: #hfl: TransSp fTransSp:=proc(E::numeric,VE::Vector,VS::Vector,TorVn::{numeric,Vector},sigma::numeric,{digits::posint:=5},$) local N,VT,t; N:=op(1,VE); if type(TorVn,Vector) then evalf(Int(exp(add(VS[i]*(cos(VE[i]*t)-1),i=1..N)-0.5*sigma^2*t^2)*cos(t*E-add(VS[i]*sin(VE[i]*t),i=1..N))*mul(orthopoly[L](TorVn[i],2*VS[i]*(1-cos(VE[i]*t))),i=1..N),t=0..evalf(sqrt(2*ln(10^digits/sigma))/sigma),':-digits'=digits,'method'=_d01akc)/Pi) else VT:=Vector(N,i->VS[i]*`if`(T=0,1,coth(VE[i]/(2*TorVn))),datatype=float); evalf(Int(exp(add(VT[i]*(cos(VE[i]*t)-1),i=1..N)-0.5*sigma^2*t^2)*cos(t*E-add(VS[i]*sin(VE[i]*t),i=1..N)),t=0..evalf(sqrt(2*ln(10^digits/sigma))/sigma),':-digits'=digits,'method'=_d01akc)/Pi) end end: #hfl: TransSp GenerateES:=proc( ES0::list([numeric,numeric]):=[], N0::nonnegint:=0, Edist::anything:=undefined, Sdist::anything:=undefined, Emax::numeric:=0, S0::numeric:=0, lambda0::numeric:=0, { output::{"list","vectors"}:="vectors", printout::boolean:=false, plotout::boolean:=false, colors::[string,string]:=["Red","Blue"], eunit::string:=" (eV)" },$) local VE,VS,x,ES,N,i,V,U,l; if (N0>0) then VE:=Statistics[Sample](Statistics[RandomVariable](Edist),N0); if (Emax>0) then VE:=(Emax/max(VE))*VE end; VS:=Statistics[Sample](Statistics[RandomVariable](Sdist),N0); if (S0>0) then VS:=(S0/add(v,v=VS))*VS end; if (lambda0>0) then x:=(lambda0/(VE.VS))^(1/3); VE,VS:=x*VE,x*VS end else VE,VS:=[],[] end; ES:=Sort([seq([VE[i],VS[i]],i=1..N0),op(ES0)],[1]); N:=nops(ES); if printout then printf("N=%d, E=%.2g..%.2g, S=%.2g, Smax=%.2g, lambda=%.2g\n",N,ES[1][1],ES[-1][1],add(v[2],v=ES),max(map2(op,2,ES)),add(v[1]*v[2],v=ES)) end; if plotout then VE,VS:=seq(Vector(N,i->ES[i][l]),l=1..2); V:=Vector(N): for i from 1 to N do V[i]:=`if`(i=1,0,V[i-1])+VE[i]*VS[i] end: U:=Vector(N): for i from 1 to N do U[i]:=`if`(i=1,0,U[i-1])+VS[i] end: print(plots[dualaxisplot]( plot([[[0,0],seq([VE[i],V[i]],i=1..N)]$2],'style'=["point","line"],'color'=colors[1],'axis'[2]=['color'=colors[1]],'labels'=[cat("Mode frequency",eunit),cat("Relaxation energy progression",eunit)]), plot([[[0,0],seq([VE[i],U[i]],i=1..N)]$2],'style'=["point","line"],'color'=colors[2],'axis'[2]=['color'=colors[2]],'labels'=[cat("Mode frequency",eunit),"Huang-Rhys factor progression"]), 'labeldirections'=["horizontal","vertical"],'axes'="boxed")) end; if (output="list") then ES else seq(Vector(N,i->ES[i][l],`if`(hastype(ES,float),datatype=float,NULL)),l=1..2) end end: #hfl: SingleQMode SingleQMode:=(E,s,EQ,SQ)->add(SQ^v/v!*exp(-(E-EQ*v)^2/(2*s^2)-SQ),v=0..Digits+3.6*SQ)/sqrt(2*Pi*s^2): SingleQMode4Fit:=(E,s,EQ,SQ,digits)->add(SQ^v/v!*exp(-(E-EQ*v)^2/(2*s^2)-SQ),v=0..digits+3.6*SQ): #hfl: SingleQMode SingleQModeFit:=proc( ls0::list([numeric,numeric]), EQ0::numeric, SQ0::numeric, cy::numeric, cL::numeric, cR::numeric:=cL, { crop::numeric..numeric:=0..0, porder::posint:=2, sratio::numeric:=0.99, sestimate::numeric:=0, Acor::numeric:=1, Ecor::numeric:=0, scor::numeric:=1, maxvar:=2, maxdev::numeric:=1, EQSQfixed::boolean:=false, digits::posint:=Digits, NLPopt::list:=[] },$) local ls,E1,E2,i0,scale,i1,i2,sol1,Emax,fmax,s1,s0,A0,EC0,sol2,r,EC,A,s,EQ,SQ,sol,OS,E; if (maxvar<=1) then error("Expected maxvar>1, received %1",maxvar) end; if (maxdev<=0 or maxdev>1) then error("Expected 0evalb(v[1]>=E1 and v[2]<=E2),ls0) end; ls:=Sort(ls,[1]); i0:=op(MaxIdx(ls,[2])); scale:=1/ls[i0][2]; ls:=[seq([v[1],v[2]*scale],v=ls)]; for i1 from i0 by -1 to 1 while (ls[i1][2]>=cL) do end; for i2 from i0 to nops(ls) while (ls[i2][2]>=cR) do end; ls:=ls[i1+1..i2-1]; sol1:=FindExtremum(ls,porder,cy); Emax,fmax,s1:=sol1[1],sol1[3],sqrt(-sol1[3]/sol1[5]); if (evalf(sqrt(SQ0)*EQ0/s1)>sratio) then if (sestimate>0) then s0:=sestimate else error("Estimated sqrt(SQ0)*EQ0/s1 = %1>%2 = sratio. Provide sestimate",evalf(sqrt(SQ0)*EQ0/s1),sratio) end else s0:=scor*sqrt(s1^2-SQ0*EQ0^2) end; A0:=Acor*fmax*s1/s0; EC0:=Ecor+Emax-EQ0*SQ0^2/(SQ0+0.5); sol2:=NLPSolve2(3,V->evalf(add((v[2]-V[1]*SingleQMode4Fit(v[1]-V[2],V[3],EQ0,SQ0,digits))^2,v=ls)),[], [< A0/maxvar, EC0-SQ0*EQ0*(maxvar-1), s0/maxvar >,< A0*maxvar, EC0+SQ0*EQ0*(maxvar-1), s0*maxvar >], initialpoint=, op(NLPopt)); if EQSQfixed then r,A,EC,s,EQ,SQ:= sqrt(sol2[1]/nops(ls)), seq(v,v=sol2[2]), EQ0,SQ0 else sol:=NLPSolve2(5,V->evalf(add((v[2]-V[1]*SingleQMode4Fit(v[1]-V[2],V[3],V[4],V[5],digits))^2,v=ls)),[], [< A0/maxvar, EC0-SQ0*EQ0*(maxvar-1), s0/maxvar, EQ0/maxvar, 0 >,< A0*maxvar, EC0+SQ0*EQ0*(maxvar-1), s0*maxvar, EQ0*maxvar, SQ0*maxvar >], initialpoint=, op(NLPopt)); if (sol[1]>sol2[1]) then WARNING("Full optimization is worse than partial: %1>%2",sol[1],sol2[1]) end; r,A,EC,s,EQ,SQ:= sqrt(sol[1]/nops(ls)), seq(v,v=sol[2]) end; if (maxdev<>1) then if (abs(A/A0-1) >maxdev) then WARNING("A: estimated %1, optimized %2",A0 ,A ) end; if (abs(EC-EC0)/SQ0/EQ0>maxdev) then WARNING("EC: estimated %1, optimized %2",EC0,EC) end; if (abs(s/s0-1) >maxdev) then WARNING("s: estimated %1, optimized %2",s0 ,s ) end; if (abs(EQ/EQ0-1) >maxdev) then WARNING("EQ: estimated %1, optimized %2",EQ0,EQ) end; if (abs(SQ/SQ0-1) >maxdev) then WARNING("SQ: estimated %1, optimized %2",SQ0,SQ) end end; OS:=evalf(A*sqrt(2*Pi)*s/scale); [ r, [ OS, EC+SQ*EQ, sqrt(s^2+SQ*EQ^2), EQ, SQ ], [OS,EC,s,EQ,SQ], [Emax,fmax/scale,s1], unapply(A/scale*SingleQMode4Fit(E-EC,s,EQ,SQ,digits),E), ls[1][1]..ls[-1][1] ] end: #hfl: MultimerH MultimerH:=proc(ev::Vector,evr::Matrix,evcs::list(Matrix),{exact::boolean:=false,printout::boolean:=false},$) local N,n,X,v,k,o,m,N1,n1,H,S,isqrtS,Ho,W,lsk,mo,dW,dev,extra; N,n:=Dim2(evr)[1],add(Dim2(v)[2],v=evcs); X:=Matrix(N,n,datatype=float); k,o:=0,0; for m from 1 to nops(evcs) do N1,n1:=Dim2(evcs[m]); X[..,o+1..o+n1]:=evr[..,k+1..k+N1].evcs[m]; k,o:=k+N1,o+n1 end; H:=Matrix(LinearAlgebra[Transpose](X).LinearAlgebra[DiagonalMatrix](ev).X,shape=symmetric); S:=Matrix(LinearAlgebra[Transpose](X).X,shape=symmetric,attributes=[positive_definite]); isqrtS:=MatrixFunction2(S,x->1/sqrt(x)); Ho:=Matrix(isqrtS.H.isqrtS,shape=symmetric); W:=Vector(N,k->add(X[k,o]^2,o=1..n),datatype=float); lsk:=SortIdx(W,w->-w,'nolist'); mo:=sort(lsk[..n]); if (mo[n]-mo[1]+1<>n) then WARNING("Noncontiguous range: %1",mo) end; if printout then dW:=map2(`-`,1,W[mo]); dev:=LinearAlgebra[Eigenvalues](Ho)-ev[mo]; printf("BS=%d, N=%d, n=%d, nm=%d, max(dW)=%.1f, max(dE)=%.0f\n",Dim2(evr)[2],N,n,nops(evcs),100*max(dW),1000*max(map(abs,dev))); printf("MO\# %{s}5d\ndW%% %{s}5.1f\ndEm %{s}+5.0f\n",Vector(mo),100*dW,1000*dev); if (N>n) then if (mo[n]-mo[1]+1<>n) then extra:=sort(convert(`minus`({$mo[1]..mo[n]},{op(mo)}),list)); printf("Extra MOs:\n"); printf("MO\# %{s}5d\nW%% %{s}5.1f\nE %{s}+5.0f\n",Vector(extra),100*W[extra],ev[extra]) end; printf("Lower W%%: %s\n" ,Vector(min(3,N-n),k->sprintf("%.2f[%d]",W[lsk[n+k]],lsk[n+k]))); printf("Lower E: %5.0f\n",Vector(min(3,mo[1]-1),k->1000*(ev[mo[1]]-ev[mo[1]-k]))); printf("Higher E: %5.0f\n",Vector(min(3,N-mo[n]),k->1000*(ev[mo[n]+k]-ev[mo[n]]))) end; v:=LinearAlgebra[Trace](Ho)/n; printf("Ho relative to mean energy %.3f:\n",v); PrintMatrix(1000*(Ho-v),"%.0f") end; if exact then MultimerH(ev[mo],evr[mo,..],evcs,':-printout'=printout) else Ho,H,S,X,W,mo end end: #hfl: MultimerH MultimerH7:=proc(lsf::list(string),o1::{integer,list(integer)},no::{integer,list(integer)}:=1, { HOMO::list(nonnegint):=[], EFermi::{numeric,numeric..numeric}:=-10..0, extevl:=".evl", extevc:=".evc", exts1e:=".s1e", printout::boolean:=false },$) local nm,Vev,Vevc,VS,VN,VNo,useS,ext,f,m,VNa,E1,E2,o,j1,j2,Egap,mj2i,i,j,B,F0,S0,Vo1,Vno,setH,H,S,Ho,Sev,Sevc,Ssqrti; nm:=nops(lsf)-1; # Read data Vev,Vevc,VS,VN,VNo:=Vector(nm+1),Vector(nm+1),Vector(nm+1),Vector(nm+1,datatype=integer),Vector(nm+1,datatype=integer): useS:=false; for f in lsf do if FileTools[Exists](cat(f,exts1e)) then useS:=true; break end end; for ext in [extevl,extevc,`if`(useS,exts1e,NULL)] do for f in lsf do if not(FileTools[Exists](cat(f,ext))) then error("File does not exist: %1%2",f,ext) end end end; for m from 1 to nm+1 do Vev [m]:=ReadBIN(cat(lsf[m],extevl)); Vevc[m]:=ReadBIN(cat(lsf[m],extevc)); VN[m],VNo[m]:=Dim2(Vevc[m]); VS[m]:=`if`(useS,ReadBIN(cat(lsf[m],exts1e)),LinearAlgebra[IdentityMatrix](VN[m],datatype=float,shape=symmetric)) end; if (add(VN[m],m=1..nm)<>VN[-1]) then error("Inconsistent basis set sizes: %1",convert(VN,list)) end; # Determine HOMO if (HOMO=[]) then VNa:=Vector(nm,datatype=integer); if type(EFermi,numeric) then E1,E2:=EFermi$2 else E1,E2:=op(EFermi) end; for m from 1 to nm do for o from 1 to VNo[m] while (Vev[m][o]Vev[m][o+1]-Vev[m][o]) end; if printout then printf("Detected gaps: %{c,}.2f\n",Vector(nm,m->Vev[m][VNa[m]+1]-Vev[m][VNa[m]])) end else if (nops(HOMO)<>nm) then error("nops(HOMO)=%1<>%2=nm",nops(HOMO),nm) end; VNa:=Vector(HOMO,datatype=integer); for m from 1 to nm do if (VNa[m]>VNo[m]) then error("Wrong HOMO provided: VNa[%1]=%2>%3=VNo[%1]",m,VNa[m],VNo[m]) end end end; for m from 1 to nm do if (VNo[m]-VNa[m]>0) then Egap:=Vev[m][VNa[m]+1]-Vev[m][VNa[m]]; if (VNa[m]>1 and Egap1 and Egapnm) then error("nops(o1)=%1<>%2=nm",nops(o1),nm) end; Vo1:=Vector(o1,datatype=integer); else Vo1:=Vector(nm,m->o1,datatype=integer) end; if (type(no)=list) then if (nops(no)<>nm) then error("nops(no)=%1<>%2=nm",nops(no),nm) end; Vno:=Vector(no,datatype=integer); else Vno:=Vector(nm,m->no,datatype=integer) end; setH:=table(): for m from 1 to nm do j1:=VNa[m]+Vo1[m]; j2:=j1+`if`(Vo1[m]>0,1,-1)*(Vno[m]-1); if (j1>j2) then j1,j2:=j2,j1 end; if (j1<1 or j2>VNo[m]) then error("Insufficient number of orbitals, %1, for molecule %2",VNo[m],m) end; if printout then printf("Spectral separation for m=%d: %.2f %.2f\n",m,`if`(j1=1,undefined,Vev[m][j1]-Vev[m][j1-1]),`if`(j2=VNo[m],undefined,Vev[m][j2+1]-Vev[m][j2])) end; setH[m]:=mj2i[m,j1]..mj2i[m,j2] end; setH:=convert(setH,list); # Final H:=Matrix(F0[setH$2],shape=symmetric); S:=Matrix(S0[setH$2],shape=symmetric,attributes=[positive_definite]); if useS then Sev,Sevc:=LinearAlgebra[Eigenvectors](S); Ssqrti:=Matrix(Sevc.LinearAlgebra[DiagonalMatrix](map(v->1/sqrt(v),Sev)).LinearAlgebra[Transpose](Sevc),shape=symmetric); Ho:=Matrix(Ssqrti.H.Ssqrti,shape=symmetric) else Ho:=H end; Ho,H,S end: #hfl: ChemBalance ChemBalance:=proc(compounds::list,{extoutput::boolean:=false,printout::boolean:=false},$) local ls,nc,elements,eqs,x,sol,v,u,n,e,l; if (compounds=[]) then return [] end; ls:=`if`(type(compounds[1],string),map(DecodeFormula,compounds),map(DecodeFormula@EncodeFormula,compounds)); nc:=nops(ls); elements:=sort(convert({seq(seq(v[1],v=u),u=ls)},list)); eqs:={seq(add(add(`if`(v[1]=e,v[2],0),v=ls[l])*x[l],l=1..nc),e=elements)}; sol:=isolve(eqs,n); if (sol=NULL) then error("No solution of chemical equation: %1",eqs) else sol:=subs(n=1,sol) end; x:=[seq(subs(op(sol),x[l]),l=1..nc)]; for v in x do if (indets(v)<>{}) then error("Underdetermined chemical equation: %1, %2",eqs,sol) end end; n:=igcd(op(x)); if (n=0) then n:=1 end; if printout then printf("%{s}s\n",Vector(nc,l->sprintf("%+d*%s",x[l],EncodeFormula(ls[l])))) end; x/n,`if`(extoutput,ls,NULL) end: #hfl: ChemBalance EnergyBalance:=proc(compounds::list,product::integer:=0,per::string:="",{convex::boolean:=false,decomp::boolean:=false,printout::boolean:=false},$) local larger,v,lsA,lsE,x,ls,E,formula,n,l; larger:=proc(f1,f2) local ans,v,u; ans:=true; for v in f2 while ans do ans:=false; for u in f1 do if (u[1]=v[1]) then ans:=evalb(u[2]>=v[2]); break end end end; ans end; if (compounds=[]) then return 0 end; v:=compounds[1]; if type(v,string) then lsA:=map(ReadAtoms,compounds,1); lsE:=map(ReadOutput,compounds,"E") elif (type(v,list) and nops(v)>1) then lsA:=map2(op,1,compounds); lsE:=map2(op,2,compounds) else error("Unrecognized list of compounds: %1",compounds) end; x,ls:=ChemBalance(lsA,'extoutput',':-printout'=printout); E:=add(x[l]*lsE[l],l=1..nops(x)); if (product=0) then n:=1 else formula:=ls[product]; if (x[product]=0) then return undefined end; if (convex and not(foldl(`and`,true,seq(evalb(x[product]*v<=0),v=subsop(product=NULL,x))))) then return undefined end; if (convex and decomp and not(foldl(`and`,true,seq(larger(formula,v),v=subsop(product=NULL,ls))))) then return undefined end; if (per="") then n:=1 elif (per="atom") then n:=add(v[2],v=formula) else n:=add(`if`(v[1]=per,v[2],0),v=formula); if (n=0) then error("No element %1 in compounds[%2]=%3 out of %4",per,product,formula,compounds) end end; n:=n*x[product] end; E/n end: #hfl: DetermineBandGap DetermineBandGap:=proc(kps::Matrix,evs::Matrix,occ::Matrix,{digits::posint:=3,printout::boolean:=false},$) local no,nk,maxocc,HOMOs,LUMOs,k,o,ok,HOMO,LUMO,EFermi; no,nk:=Dim2(evs); maxocc:=round(max(occ[1,..])); HOMOs,LUMOs:=table(),table(); for k from 1 to nk do for o from 1 to no while (occ[o,k]*2>maxocc) do end; if (o>1) then HOMOs[k]:=[o-1,k] end; if (o<=no) then LUMOs[k]:=[o,k] end end; HOMOs:=convert(HOMOs,list); LUMOs:=convert(LUMOs,list); ok:=MaxVal(HOMOs,ok->evs[op(ok)]); HOMO:=[op(ok),kps[..,ok[2]],evs[op(ok)],occ[op(ok)]]; ok:=MinVal(LUMOs,ok->evs[op(ok)]); LUMO:=[op(ok),kps[..,ok[2]],evs[op(ok)],occ[op(ok)]]; EFermi:=(HOMO[4]*(LUMO[5]-maxocc/2)+LUMO[4]*(maxocc/2-HOMO[5]))/(LUMO[5]-HOMO[5]); if printout then printf("HOMO at o=%d, k%d=<%{c,}.*f>, E=%.*f, occ=%.*f\n",HOMO[1],HOMO[2],digits,HOMO[3],digits,HOMO[4],digits,HOMO[5]); printf("LUMO at o=%d, k%d=<%{c,}.*f>, E=%.*f, occ=%.*f\n",LUMO[1],LUMO[2],digits,LUMO[3],digits,LUMO[4],digits,LUMO[5]); printf("EFermi=%.*f, Egap=%.*f\n",digits,EFermi,digits,LUMO[4]-HOMO[4]) end; HOMO,LUMO end: ################################################################################ #cat: Output #hfl: pqrlabel pqrlabel:=pqr->sprintf("%-*s",lmax,`if`(pqr=[0,0,0],"S",cat("X"$pqr[1],"Y"$pqr[2],"Z"$pqr[3]))): #hfl: printAO SPindex:=proc(c::indexable,$) local i; if (c[1]=0) then infinity else i:=round((c[2]^2+c[3]^2+c[4]^2)/c[1]^2); if (i<6) then min(i,3) else infinity end end end: #hfl: printAO SPDindex:=proc(c::indexable,$) local v,i,s,p,d,k,m,n; v:=add(c[i]^2,i=1..9); s,p,d:=c[1]^2/v,add(c[i]^2,i=2..4)/v,add(c[i]^2,i=5..9)/v; MinVal([seq(seq(seq(`if`(n+m+k=0,NULL,[n,m,k,(n/(n+m+k)-s)^2+(m/(n+m+k)-p)^2+(k/(n+m+k)-d)^2]),n=0..1),m=0..3),k=0..5)],[4]) end; #hfl: printAO printAO:=proc(c::indexable,format::string:="%s_%s",{uppercase::boolean:=false},$) local n,s,m,l; n:=Dim2(c); if uppercase then s:=["S","P","D"] else s:=["s","p","d"] end; if (n=1) then s[1] elif (n=4) then m:=SPindex(c); if (m=0) then s[1] else sprintf(format, `if`(m=infinity,s[2],cat(s[1],s[2],`if`(m=1,NULL,m))), PrintVector3d(c[2..4])) end elif (n=9) then m:=SPDindex(c)[..3]; if (m[3]=0) then printAO(c[..4],format,':-uppercase'=uppercase) else cat(seq(`if`(m[l]=0,NULL,`if`(m[l]=1,s[l],cat(s[l],m[l]))),l=1..3)) end else error("Unrecognized orbitals: %1",c) end end: #hfl: plotE plotE:=proc( MO0::{Vector,list}, x::numeric:=1, dx::numeric:=.1, viewbox::name:=undefined, { multiplicity::{boolean,"auto"}:="auto", gap::numeric:=.15, color:="Black", lineopts::list:=[], textopts::list:=[], textalign::string:="RL", sep::list(numeric):=[.05,-.05], vsep::numeric:=0.04, vscale::numeric:=0, fontsize::[numeric,numeric]:=[.05,0], topbottom::[numeric,numeric]:=[0,.03], show::boolean:=false}) local nt,TA,TO,colors,MO,n,i,x1,lsx,Vy,ls1,ls2,maxlen,m,E,txt,j,dx1,x2,ls,j1,j2,vb; nt:=min(nops(sep),length(textalign)); TA:=[seq(`if`(textalign[j]="L",ALIGNLEFT,ALIGNRIGHT),j=1..nt)]; TO:=`if`(textopts<>[] and type(textopts,list(list)),textopts,[textopts$nt]); if (nops(TO)MO0[i])); n:=op(1,MO); if (n=0) then return `if`(show,plots[display]([plot([])],_rest),[]) end; for i from 1 to n do if type(MO[i],list) then if (multiplicity="auto") then if not(nops(MO[i])>1 and member(MO[i][1],[1,2,3,4,5]) and type(MO[i][2],numeric)) then MO[i]:=[1,op(MO[i])] end elif (multiplicity=false) then MO[i]:=[1,op(MO[i])] end else MO[i]:=[1,MO[i]] end end; x1:=x-dx; lsx:=map(y->x+signum(y)*dx+y*dx,sep); Vy:=Optimization[QPSolve]( [Vector(n,i->-MO[i][2]), LinearAlgebra[IdentityMatrix](n)], [Matrix(n-1,n,(i,j)->piecewise(j=i,1,j=i+1,-1,0)), Vector(n-1,-`if`(vscale=0,MO[-1][2]-MO[1][2],vscale)*vsep)], initialpoint=Vector(n,i->MO[i][2]) )[2]; ls1,ls2,maxlen:=table(),table(),Vector(nt+1,datatype=integer); for i from 1 to n do m,E,txt:=MO[i][1],MO[i][2],MO[i][3..]; for j from 1 to min(nt,nops(txt)) do if (length(txt)>maxlen[j]) then maxlen[j]:=length(txt) end end; dx1:=dx*2/(m-gap); x2:=x1+(1-gap)*dx1; ls1[i]:=[seq(CURVES([[x1+dx1*j,E],[x2+dx1*j,E]]),j=0..m-1)]; ls2[i]:=[seq(TEXT([lsx[j],Vy[i]],txt[j],TA[j]),j=1..min(nt,nops(txt)))] end: nt:=max(seq(nops(ls2[i]),i=1..n)); ls:=[ [seq(op(ls1[i]),i=1..n),COLOUR('RGB',op(ColorTools[ToRGB24](colors[1])/255))], seq([seq(`if`(nops(ls2[i])`,sep[..nt],0); j2:=`if`(ls2=[],-1,op(MaxIdx(ls2))); vb:=[x-dx*(1-sep[j1]+maxlen[j1]*fontsize[1])..x+dx*(1+sep[j2]+maxlen[j2]*fontsize[2]), MO[1][2]-topbottom[2]*(MO[-1][2]-MO[1][2])..MO[-1][2]+topbottom[1]*(MO[-1][2]-MO[1][2])]; if not(viewbox=undefined) then assign(viewbox,vb) end; `if`(show, plots[display]([plots[display](PLOT(op(ls[1])),op(lineopts)),seq(plots[display](PLOT(op(ls[1+j])),op(TO[j])),j=1..nt)], 'view'=vb,'thickness'=3,'axis'[1]=[':-color'="White"],'axes'='frame',_rest), ls) end: #hfl: plot3Dgrid plot3Dgrid:=proc( grid::Matrix, ix::{1,2,3}, iy::{1,2,3}, sxy::[numeric,numeric]:=[0.4$2], colors::[string,string,string]:=["Black","Blue","Red"], symbolsizes::[posint,posint,posint]:=[6,10,10] ) local n,i,o,V,A,S,iz,sx,sy,v2xy,tb,lsz,pl1,pl2,pl0,vz; n:=Dim2(grid)[1]; V:=[seq(sort(convert({seq(grid[i,o],i=1..n)},list)),o=1..3)]; A:=[seq(max(-V[o][1],V[o][-1]),o=1..3)]; S:=[seq(min(`if`(nops(V[o])=1,1,(V[o][-1]-V[o][1])/(nops(V[o])-1)),seq(V[o][i]-V[o][i-1],i=2..nops(V[o]))),o=1..3)]; iz:=6-ix-iy; sx,sy:=sxy[1]*S[ix]/A[iz],sxy[2]*S[iy]/A[iz]; v2xy:=v->[v[ix]+v[iz]*sx,v[iy]+v[iz]*sy]; tb:=Classify2([seq(grid[i],i=1..n)],[iz]); lsz:=Sort([indices(tb,nolist)]); pl1:=`if`(nops(lsz)>1,plots[pointplot](map(v2xy,tb[lsz[1]]),'color'=colors[2],'symbolsize'=symbolsizes[2]),NULL); pl2:=plots[pointplot](map(v2xy,tb[lsz[-1]]),'color'=colors[3],'symbolsize'=symbolsizes[3]); pl0:=`if`(nops(lsz)>2,plots[pointplot](map(v2xy,[seq(op(tb[vz]),vz=lsz[2..-2])]),'color'=colors[1],'symbolsize'=symbolsizes[1]),NULL); display([pl0,pl1,pl2],view=[V[ix][1]-S[ix]*sxy[1]..V[ix][-1]+S[ix]*sxy[1],V[iy][1]-S[iy]*sxy[2]..V[iy][-1]+S[iy]*sxy[2]], 'tickmarks'=['spacing'(S[ix]),'spacing'(S[iy])],'gridlines','axes'='boxed',_rest) end: #hfl: plotMol plotMol:=proc( Atoms::list, Cell::{list,Matrix}:=[], { hidecell::boolean:=false, hidehydrogens::boolean:=false, asis::boolean:=false, acolor::procedure:=acolor_azh, asize::procedure:=asize_azh, asymbol::string:=solidsphere, colsat::numeric:=.2, grayval::numeric:=.9, opt4CA::{list,"no"}:=[] }) local A,M,d,n,na,ls,B,B2,A2,box3,i,j,v; A,M:=Atoms2Cell(Atoms); if (Cell<>[]) then M:=`if`(type(Cell,Matrix),Cell,cryst2M(Cell)) end; d:=`if`(A=[] and type(M,Matrix),op(1,M)[1],op(1,A[1][2])); if type(M,Matrix) then n:=op(1,M)[2]; if (d<>op(1,M)[1]) then error("Incompatible dimensions of A and M: %1<>%2",d,op(1,M)[1]) end else n:=0 end; A:=`if`(hidehydrogens,remove(v->v[1]="H",A),A); if (Cell<>[] and not(asis)) then A:=[seq([v[1],M.v[2]],v=A)] end; na:=nops(A); ls:=`if`(opt4CA="no",[[]$na],ConnectAtoms(A,op(opt4CA))); B:=[seq(seq([op(A[i]),op(A[j])],j=select(`>`,ls[i],i)),i=1..na)]; B2:=[seq(`if`(v[1]=v[3], [v[1],v[2],v[4]], op([ [v[1],v[2],(v[2]+v[4])/2], [v[3],v[4],(v[2]+v[4])/2] ])),v=B)]; A2:=A[[seq(`if`(ls[i]=[],i,NULL),i=1..na)]]; box3:=[ [[0,0,0],[1,0,0],[0,colsat,1]], [[0,0,0],[0,1,0],[1/3,colsat,1]], [[0,0,0],[0,0,1],[2/3,colsat,1]], [[1,1,1],[0,1,1],[0,0,grayval]], [[1,1,1],[1,0,1],[0,0,grayval]], [[1,1,1],[1,1,0],[0,0,grayval]], [[1,0,0],[1,1,0],[0,0,grayval]], [[1,0,0],[1,0,1],[0,0,grayval]], [[0,1,0],[1,1,0],[0,0,grayval]], [[0,1,0],[0,1,1],[0,0,grayval]], [[0,0,1],[0,1,1],[0,0,grayval]], [[0,0,1],[1,0,1],[0,0,grayval]]]; `if`(not(hidecell) and n>0 and d=3,seq(plottools[line](convert(M.Vector(v[1][..n]),list),convert(M.Vector(v[2][..n]),list),'color'=COLOR(HSV,op(v[3]))),v=box3[[[1],[1,2,7,9],..][n]]),NULL), seq(plottools[line](convert(v[2],list),convert(v[3],list),'color'=acolor(v[1]),'thickness'=piecewise(na>500,1,na>100,2,na>20,3,4),_rest),v=B2), seq(plottools[point](convert(v[2],list),'color'=acolor(v[1]),'symbolsize'=asize(v[1]),'symbol'=asymbol,_rest),v=A2) end: #hfl: plotMol acolor_azh:=proc(Z::{posint,string},$) local p,g,L; p,g,L:=AtomicType(Z,"pgL"); if (L="s") then if (p=1) then COLOR(HSV,0,0,`if`(g=1,.9,.7)) else COLOR(HSV,piecewise(g=1,8/9,7/9),1,`if`(p=2,1,.75)) end elif (L="p") then if (g=2) then COLOR(HSV,0,0,`if`(p=2,0,0.2)) elif (g=6) then COLOR(HSV,0,0,.7) else COLOR(HSV,piecewise(g=1,1/2,g=3,2/3,g=4,0,g=5,1/3),1,`if`(p=2,1,.75)) end elif (L="d") then COLOR(HSV,.13,1,.9) else COLOR(HSV,0,0,1/2) end end: #hfl: plotMol asize_azh:=proc(s::string,$) if (s="H") then 20 else 40 end end: #hfl: simplifySVG simplifySVG:=proc( filename::string, newtitle::string:="", margin::numeric:=3, textsubs::list(string=string):=[], addcolors::list(string=list):=[], { overwritecolors::boolean:=false, tag::string:="_new", ignorefont::boolean:=false, ignorefontsize::boolean:=false, ignorefontwidth::boolean:=false, font::string:="sans-serif", fontsize::posint:=20, linewidth::numeric:=2, fontwidth::numeric:=0, fontWpt2px::numeric:=0.8, fontHpt2px::numeric:=1, xydigits::nonnegint:=1, lwdigits::nonnegint:=1, maxnp::posint:=100, printout::boolean:=false },$) local fn,colors,readatt,writeatt,lbls4L,lbls4P,lbls4T,xml,ff,title,f,Lines,Polygons,Text,X2Y,i,classes,x1,x2,y,y1,y2,w,h,v; #initialize readatt:=proc(s,l,t) local v; if member(l,["fill","stroke"]) then v:=sscanf(s,"rgb(%d,%d,%d)"); `if`(v=[],piecewise(s="red",[255,0,0],s="green",[0,255,0],s="blue",[0,0,255],undefined),`if`(v=[0,0,0],undefined,v)) elif (l="stroke-width") then v:=parse(s); `if`(t="text" and (ignorefontwidth or abs(v-fontwidth)<1.5*10^(-lwdigits)) or abs(v-linewidth)<1.5*10^(-lwdigits),undefined,v) elif (l="font-family") then `if`(ignorefont or s=font,undefined,s) elif (l="font-size") then v:=parse(s); `if`(ignorefontsize or abs(v-fontsize)<1,undefined,v) else v:=piecewise(l="class",s, l="points",sscanf(s,cat("%f"$maxnp)), parse(s)) end end; writeatt:=(v,l,t)->`if`(v=undefined,"",piecewise( l="class",sprintf(" %s=\"%s\"",l,v), member(l,["x","y","x1","y1","x2","y2"]), sprintf(" %s='%.*f'",l,xydigits,v), l="points", sprintf(" %s='%.*f'",l,xydigits,Vector(v)), member(l,["fill","stroke"]), sprintf(" %s='rgb(%d,%d,%d)'",l,op(v)), l="stroke-width", sprintf(" %s='%.*f'",l,lwdigits,v), l="font-family", sprintf(" %s='%s'",l,v), l="font-size", sprintf(" %s='%d'",l,round(v)), "")); lbls4L:=["x1","y1","x2","y2","opacity","stroke","stroke-width","class"]; lbls4P:=["points","fill","stroke","stroke-width","class"]; lbls4T:=["x","y","font-family","font-weight","font-size","fill","stroke","stroke-width","class"]; colors:=table(`if`(overwritecolors,addcolors,["R"=[0,0,0],"H"=[191,191,191],"N"=[0,0,255],"O"=[255,0,0],"F"=[0,255,0],"P"=[255,99,0],"S"=[255,229,22],"Cl"=[0,255,0],op(addcolors)])); #read and process SVG data fn:=`if`(FileTools[Exists](filename) and not(FileTools[IsDirectory](filename)),filename,cat(filename,".svg")); xml:=ReadXML(fn,'reload')[3]; if printout then printf("file=%s\n",fn) end; ff:=(x,f)->(f(x[1]),`if`(nops(x)=1,NULL,seq(ff(y,f),y=x[2..]))); if (newtitle="") then title:=[ff(xml,x->`if`(x[1]="title",x[3],NULL))]; title:=`if`(title=[],"",title[1]) else title:=newtitle end: if printout then printf("title=%s\n",title) end; f:=proc(att::list,lbls::list,tag::string) local tb,ls,l; tb:=table(att); ls:=`minus`({indices(tb,'nolist')},{op(lbls)}); if (nops(ls)>0) then WARNING("Unprocessed attributes %1 in %2",ls,att) end; [seq(`if`(assigned(tb[l]),readatt(tb[l],l,tag),undefined),l=lbls),_rest] end; Lines :=[ff(xml,x->`if`(x[1]="line" ,f(x[2],lbls4L,"line" ),NULL))]; if printout then printf("%d lines\n" ,nops(Lines) ) end; Polygons:=[ff(xml,x->`if`(x[1]="polygon",f(x[2],lbls4P,"polygon" ),NULL))]; if printout then printf("%d polygons\n",nops(Polygons)) end; Text :=[ff(xml,x->`if`(x[1]="text" and nops(x)>2,f(x[2],lbls4T,"text",x[3]),NULL))]; if printout then printf("%d texts\n" ,nops(Text) ) end; if (textsubs<>[]) then X2Y:=table(textsubs); Text:=map(v->`if`(assigned('X2Y[v[-1]]'),subsop(-1=X2Y[v[-1]],v),v),Text) end; #apply classes if (op(colors)=[]) then classes:=[] else i:=SearchPos(lbls4T,"class"); Text:=map(v->`if`(assigned(colors[v[-1]]),subsop(SearchPos(lbls4T,"fill")=undefined,SearchPos(lbls4T,"stroke")=undefined,i=v[-1],v),v),Text); classes:=sort(remove(`=`,convert({seq(v[i],v=Text)},list),undefined)); if printout then printf("classes=[%{c,}s]\n",Vector(classes)) end end; #determine viewBox and shift coordinates x1:=round(min(seq(v[1],v=Lines),seq(v[3],v=Lines),seq(seq(v[1][i],i=1..nops(v[1]),2),v=Polygons),seq(v[1],v=Text))-margin); x2:=round(max(seq(v[1],v=Lines),seq(v[3],v=Lines),seq(seq(v[1][i],i=1..nops(v[1]),2),v=Polygons),seq(v[1]+length(v[-1])*fontsize*fontWpt2px,v=Text))+margin); y1:=round(min(seq(v[2],v=Lines),seq(v[4],v=Lines),seq(seq(v[1][i],i=2..nops(v[1]),2),v=Polygons),seq(v[2]-fontsize*fontHpt2px,v=Text))-margin); y2:=round(max(seq(v[2],v=Lines),seq(v[4],v=Lines),seq(seq(v[1][i],i=2..nops(v[1]),2),v=Polygons),seq(v[2],v=Text))+margin); w,h:=x2-x1,y2-y1; if printout then printf("x=%d..%d (w=%d), y=%d..%d (h=%d)\n",x1,x2,w,y1,y2,h) end; Lines:=map(v->[v[1]-x1,v[2]-y1,v[3]-x1,v[4]-y1,op(5..,v)],Lines); Polygons:=map(v->[[seq(v[1][i]-`if`(type(i,odd),x1,y1),i=1..nops(v[1]))],op(2..,v)],Polygons); Text:=map(v->[v[1]-x1,v[2]-y1,op(3..,v)],Text); #write SVG file WriteLines(cat(ExpandPath(fn,"pn"),tag,ExpandPath(fn,"x")),[ "", "", sprintf("",w,h,w,h), `if`(classes=[],NULL,op([ "" ])), sprintf("%s",title), `if`(Lines=[],NULL,op([ sprintf("",linewidth), seq(sprintf("",Vector(nops(lbls4L),i->writeatt(v[i],lbls4L[i],"line"))),v=Lines), ""])), `if`(Polygons=[],NULL,op([ sprintf("",linewidth), seq(sprintf("",Vector(nops(lbls4P),i->writeatt(v[i],lbls4P[i],"polygon"))),v=Polygons), ""])), `if`(Text=[],NULL,op([ sprintf("",fontsize,fontwidth), seq(sprintf("%s",Vector(nops(lbls4T),i->writeatt(v[i],lbls4T[i],"text")),v[-1]),v=Text), ""])), ""],overwrite) end: #hfl: CompressEigenvectors CompressEigenvectors:=proc(evc::{Matrix,Vector},threshold::numeric,k2il0::list([posint,posint]):=[],i2k0::list:=[],$) local no,evc2,o,cmin,nb,k2il,i2k,il2k,i,k,l,tb,na,c,v,cn; if type(evc,Vector) then no:=op(1,evc); evc2:=Vector(no); for o from 1 to no do cmin:=threshold*max(seq(abs(v[2]),v=evc[o])); evc2[o]:=Sort(select(v->abs(v[2])>cmin,evc[o]),v->-abs(v[2])) end else nb,no:=op(1,evc); evc2:=Vector(no); for o from 1 to no do cmin:=threshold*LinearAlgebra[Norm](evc[..,o],infinity); evc2[o]:=Sort([seq(`if`(abs(evc[k,o])>cmin,[k,evc[k,o]],NULL),k=1..nb)],v->-abs(v[2])) end end; if (k2il0=[] and i2k0=[]) then evc2 else if (k2il0=[]) then i2k:=i2k0; k2il:=table(); for i from 1 to nops(i2k) do for l from 1 to nops(i2k[i]) do k2il[i2k[i][l]]:=[i,l] end end; k2il:=convert(k2il,list) elif (i2k0=[]) then k2il:=k2il0; il2k:=table(); for k from 1 to nops(k2il) do il2k[op(k2il[k])]:=k end; i2k:=table(); for i from 1 to infinity while assigned('il2k[i,1]') do tb:=table(); for l from 1 to infinity while assigned('il2k[i,l]') do tb[l]:=il2k[i,l] end; i2k[i]:=convert(tb,list) end; i2k:=convert(i2k,list) else k2il:=k2il0; i2k:=i2k0 end; na,nb:=nops(i2k),nops(k2il); for o from 1 to no do tb:=Classify2(evc2[o],v->k2il[v[1]][1]); for i in indices(tb,'nolist') do c:=Vector(nops(i2k[i]),datatype=float); for v in tb[i] do c[k2il[v[1]][2]]:=v[2] end; cn:=LinearAlgebra[Norm](c,2); cn:=cn*signum(`if`(abs(c[1])<0.4*cn,MaxVal(c,v->abs(v)),c[1])); tb[i]:=[i,cn,convert(c/cn,list)] end; evc2[o]:=Sort(convert(tb,list),v->-abs(v[2])) end; evc2 end end: #hfl: CompressEigenvectors DomainMO:=proc(V::Vector,BS::listlist,threshold::numeric,{fullout::boolean:=false},$) local N,na,W,k,w,i,lsi; N:=nops(BS); if (Dim2(V)<>N) then error("Inconsistent basis size in V(%1) and BS(%2)",Dim2(V),N) end; na:=max(map2(op,1,BS)); W:=Vector(na,datatype=float); for k from 1 to N do W[BS[k][1]]:=W[BS[k][1]]+V[k]^2 end; w:=max(W)*threshold; lsi:=Sort([seq(`if`(W[i]-W[i]); `if`(fullout,map(i->[i,W[i]],lsi),lsi) end: #hfl: printMO printMO:=proc( ev::Vector, A::list, homo0::nonnegint, QMS::[integer,integer,integer]:=[0,0,1], evc::Matrix:=<<0>>, BS::list(list):=[], sym::list(string):=[], fmt::string:=cat("%4d %s%4d:%*.*f %s %{c,}s"), nnee::[nonnegint,nonnegint,numeric,numeric]:=[9,9,-99,99], ozero::integer:=-1, {nocore::boolean:=false, smallcore::boolean:=false, valencegap::numeric:=10, coregap::numeric:=5, donotprint::boolean:=false, digits::posint:=2, ninline::nonnegint:=5, after::string:="", threshold::numeric:=0.5, mo2s::procedure:=(v->""), width::posint:=80 },$) local nstar,no,Q,M,spinsign,elems,Zs,nvo,nve,nce,ov,homo,lumo,Egap,vgap,Vgap,gaps,bands,evcc,maxlen1,maxlen2,b,o1,o2,o2o,o,v,u,s; nstar:=StringTools[CountCharacterOccurrences](fmt,"*"); if (nstar>2) then error("Too many stars in fmt: %1",fmt) end; no:=Dim2(ev); if (A=[]) then nvo,ov,homo:=0,0,homo0 else Q,M,spinsign:=op(QMS); elems:=`if`(type(A[1],string),A,map2(op,1,A)); Zs:=map(AtomicNumber,elems); nvo,nve,nce:=add(AtomicType(v,"bvc"),v=elems); ov:=1+`if`(smallcore, (nce-add(piecewise(v>54,46,v>36,28,0),v=Zs))/2, `if`(nocore, 0, nce/2 )); nve:=nve-Q; if (M=0) then M:=irem(nve,2)+1 else if type(nve+M,even) then error("Inconsistent Q and M: %1,%2",Q,M) end end; homo:=ov-1+(nve+spinsign*(M-1))/2; if (homo0<>0) then if (homo0<>homo) then error("Inconsistent homo0 and derived homo: %1,%2",homo0,homo) end end end; if (homo=0) then homo,lumo,ov,Egap,Vgap,bands:=no,no,1,0,0,[1] else lumo:=homo+1; Egap:=ev[lumo]-ev[homo]; if not(donotprint) then printf("nvo=%d, HOMO=%d, LUMO=%d, Egap=%.*f%s\n",nvo,homo,lumo,digits,Egap,after); if (ninline>0) then printf("ev= %.*f ... %.*f *gap* %.*f ... %.*f\n",digits,ev[1],digits,ev[max(1,homo-ninline+1)..homo],digits,ev[lumo..min(lumo+ninline-1,no)],digits,ev[-1]) end end; vgap:=`if`(valencegap>0,valencegap,Egap); if (ov=0) then for ov from homo by -1 to 2 while (ev[ov]-ev[ov-1]v[2]>coregap,Rort(gaps,[2])); bands:=`if`(ov=1,[1],[1,op(sort(map2(op,1,gaps))),ov]) end; if not(donotprint) then if (Dim2(evc)[1]>1) then evcc:=CompressEigenvectors(evc,threshold) else evcc:=[] end; maxlen1,maxlen2:=1+trunc(log10(ov)),digits+3+trunc(log10(-ev[1])); for b from 1 to nops(bands)-1 do o1,o2:=bands[b],bands[b+1]-1; printf("%*d%1s(%*d..%*d) %*.*f..%*.*f %*.*f (%*.*f) %*.*f %s\n", maxlen1,o2-o1+1,`if`(o1=ov,"*",""),maxlen1,o1,maxlen1,o2, maxlen2,digits,ev[o1],maxlen2,digits,ev[o2], maxlen2,digits,Mean(ev[o1..o2]),digits+3,digits,`if`(o1=o2,0,StandardDeviation(ev[o1..o2])), maxlen2,digits,ev[o2+1]-ev[o2],`if`(evcc=[],"",BS[evcc[o1][1][1]][-1])) end; if (evcc<>[]) then o2o:=`if`(ozero=-1,o->o-ov+1,`if`(ozero=-2,o->`if`(o>homo,o-lumo+1,homo-o+1),o->o)); for o1 from max(ov,homo-nnee[1]+1) to homo-1 while (ev[o1]nnee[4]) do end; for o from ov to o2 do v:=[seq(sprintf(" %s %s",FormatFloat(u[2]^2,2),BS[u[1]][-1]),u=evcc[o])]; if (v[1][2]<>".") then v:=subsop(1=v[1][2..],v) end; s:=sprintf(fmt,o2o(o),mo2s(v),o,op([digits+5,digits][..nstar]),ev[o],`if`(sym=[],"",sprintf(" %-3s",sym[o])),Vector(v)); printf("%s\n",`if`(length(s)>width,cat(s[..width-3],"..."),s)); if (o=ov and o1>ov+2) then printf("%s\n",cat("."$18)); o:=o1-1 end; if (o=homo and o2>o) then printf("%s\n",cat("-"$width)) end end end end; [nvo,no,homo,lumo,ov,ev[ov],ev[homo],Egap,Vgap,bands] end: ################################################################################ #cat: External programs input #hfl: WriteAtom WriteAtom:=proc(program::{"mop","fly","gau"},Atom::list,$) local optflags,coo; coo:=convert(Atom[2],list); if (program="mop") then optflags:=`if`(nops(Atom)=3 and type(Atom[3],list(integer)),Atom[3],[1,1,1]); if (nops(coo)=3) then sprintf("%-2s %*.*f %d %*.*f %d %*.*f %d",Atom[1],seq(op([fwidth,digits,coo[i],optflags[i]]),i=1..3)) elif (nops(coo)=0) then sprintf("%-2s",Atom[1]) elif (nops(coo)=2) then sprintf("%-2s %*.*f %d",Atom[1],fwidth,digits,coo[2],optflags[1]) elif (nops(coo)=4) then sprintf("%-2s %*.*f %d %*.*f %d %*d %*d %d %d 0",Atom[1],seq(op([fwidth,digits-`if`(i=1,0,1),coo[2*i],optflags[i]]),i=1..2),fwidth-digits,0,digits+1,0,coo[1],coo[3]) elif (nops(coo)=6) then sprintf("%-2s %*.*f %d %*.*f %d %*.*f %d %d %d %d",Atom[1],seq(op([fwidth,digits-`if`(i=1,0,1),coo[2*i],optflags[i]]),i=1..3),seq(coo[2*i-1],i=1..3)) else error("Unrecognized coordinates %1",Atom) end elif (program="fly") then if (nops(coo)=3) then sprintf("%-2s %3d %*.*f",Atom[1],AtomicNumber(Atom[1]),fwidth,digits,Atom[2]) elif (nops(coo)=0) then sprintf("%-2s",Atom[1]) elif (nops(coo)=2) then sprintf("%-2s %d %*.*f",Atom[1],coo[1],fwidth,digits,coo[2]) elif (nops(coo)=4) then sprintf("%-2s %d %*.*f %d %*.*f",Atom[1],seq(op([coo[2*i-1],fwidth,digits,coo[2*i]]),i=1..2)) elif (nops(coo)=6) then sprintf("%-2s %d %*.*f %d %*.*f %d %*.*f",Atom[1],seq(op([coo[2*i-1],fwidth,digits,coo[2*i]]),i=1..3)) else error("Unrecognized coordinates %1",Atom) end elif (program="gau") then if (nops(coo)=3) then sprintf("%-2s %*.*f",Atom[1],fwidth,digits,Atom[2]) elif (nops(coo)=0) then sprintf("%-2s",Atom[1]) elif (nops(coo)=2) then sprintf("%-2s %4d %*.*f",Atom[1],coo[1],fwidth,digits,coo[2]) elif (nops(coo)=4) then sprintf("%-2s %4d %*.*f %4d %*.*f",Atom[1],seq(op([coo[2*i-1],fwidth,digits,coo[2*i]]),i=1..2)) elif (nops(coo)=6) then sprintf("%-2s %4d %*.*f %4d %*.*f %4d %*.*f",Atom[1],seq(op([coo[2*i-1],fwidth,digits,coo[2*i]]),i=1..3)) else error("Unrecognized coordinates %1",Atom) end end end: #hfl: WriteMethod WriteMethod:=proc(program::{"lam","tin","mop","fly","gau","vas"},method::string,$) local s; s:=StringTools[UpperCase](method); if (program="fly") then if (s="" or s="HF") then "" elif (s="MP2") then "MPLEVL=2" else cat("DFTTYP=",`if`(s="PBE","PBE96",s)) end elif (program="gau") then if (s="LDA") then "SVWN" elif (s="PBE") then "PBEPBE" elif (s="PBE0") then "PBE1PBE" elif (s="HSE06") then "HSEh1PBE" elif (s[..3]="CAS") then cat(s[..3],"(",Substitute(s[4..],"-",","),")") else s end else s end end: #hfl: WriteMethod WriteBS:=proc(program::{"fly","gau","vas"},bss::string,path::string:="",$) local fam,size,v,known,s,p; try fam,size,v:=op(1..3,DecodeBS(bss)); known:=true catch: known:=false end; s:=""; if (program="fly") then if known then if (fam="p") then if (size=2) then s:="31" elif (size=3) then s:="311" else error("Unsupported basis set size in %1",bss) end; s:=cat("GBASIS=N",s," NGAUSS=6"); if (v="") then s:=s elif (v="pd" or v="p") then s:=cat(s," NDFUNC=1") elif (v="pdp") then s:=cat(s," NDFUNC=1 NPFUNC=1") elif (v="apd" or v="ap") then s:=cat(s," NDFUNC=1 DIFFSP=.T.") elif (v="apdp") then s:=cat(s," NDFUNC=1 NPFUNC=1 DIFFSP=.T.") elif (v="aapdp") then s:=cat(s," NDFUNC=1 NPFUNC=1 DIFFSP=.T. DIFFS=.T.") else error("Unrecognized suffix in %1",bss) end elif (fam="h") then if (size=1) then s:="GBASIS=MINI" elif (size=2) then s:="GBASIS=MIDI" else error("Unsupported basis set size in %1",bss) end end end; if (s="") then if (bss[..7]="GBASIS=") then s:=bss elif FileTools[Exists](cat(path,bss)) then s:=cat("EXTFIL=.T. GBASIS=",bss) else for p in fly_path do if FileTools[Exists](cat(p,bss)) then s:=cat("EXTFIL=.T. GBASIS=",p,bss); break end end end end; if (s="") then error("Unrecognized basis set: %1",bss) else s:=cat(" $BASIS ",s," $END") end elif (program="gau") then if known then if (SearchText("x",v)>0) then s:="gen" else if (fam="a") then if (size=2) then s:="S" elif (size=3) then s:="TZ" elif (size=4) then s:="QZ" else error("Unsupported basis set size in %1",bss) end; s:=cat("Def2",s,"V"); if (v="") then s:=s elif (v="p") then s:=cat(s,"P") elif (v="pp") then s:=cat(s,"PP") else error("Unrecognized suffix in %1",bss) end elif (fam="c") then if (size=2) then s:="D" elif (size=3) then s:="T" elif (size=4) then s:="Q" elif (size=5) then s:="5" else error("Unsupported basis set size in %1",bss) end; s:=cat("cc-pV",s,"Z"); if (v="") then s:=s elif (v="a") then s:=cat("aug-",s) else error("Unrecognized suffix in %1",bss) end elif (fam="dg") then if (bss="dg2") then s:="DGDZVP" elif (bss="dg2p") then s:="DGDZVP2" elif (bss="dg3") then s:="DGTZVP" else error("Unrecognized basis of DG family: %1",bss) end elif (fam="l") then if (bss="l2") then s:="LANL2DZ" elif (bss="l2p") then s:="LANL2DZ ExtraBasis" else error("Unrecognized basis of LANL family: %1",bss) end elif (fam="p") then if (size=2) then s:="6-31" elif (size=3) then s:="6-311" else error("Unsupported basis set size in %1",bss) end; if (v="") then s:=cat(s,"G") elif (v="p" or v="pd") then s:=cat(s,"G*") elif (v="pp" or v="pdp") then s:=cat(s,"G**") elif (v="pa" or v="pda") then s:=cat(s,"+G*") elif (v="ppa" or v="pdpa") then s:=cat(s,"+G**") elif (v="ppaa" or v="pdpaa") then s:=cat(s,"++G**") elif (v="p2dp") then s:=cat(s,"G(2d,p)") elif (v="p2dpa") then s:=cat(s,"+G(2d,p)") elif (v="p3df2pa") then s:=cat(s,"+G(3df,2p)") else error("Unrecognized suffix in %1",bss) end elif (fam="s") then if (size=2) then s:="CEP-31" elif (size=3) then s:="CEP-121" else error("Unsupported basis set size in %1",bss) end; if (v="") then s:=cat(s,"G") elif (v="p" or v="pd") then s:=cat(s,"G*") elif (v="pp") then s:=cat(s,"G ExtraBasis") else error("Unrecognized suffix in %1",bss) end elif (fam="h") then if (size=1) then s:="STO-3G" else error("Unsupported basis set size in %1",bss) end else error("Unsupported basis set: %1",bss) end end else s:=bss end elif (program="vas") then if known then s:=cat(fam,"_%s/%s",`if`(v="",v,cat("_",v)),"/POTCAR") elif FileTools[Exists](cat(path,bss)) then s:=bss else error("Unrecognized basis set: %1",bss) end end; s end: #hfl: WriteMethod WriteEBS:=proc(program::{"fly","gau"},Z::posint,BS::listlist,{digits::posint:=6},$) local s,GTO,CGF; if (program="gau") then s:=sprintf("%-2s 0",ElementSymbol[Z]); for GTO in BS do s:=sprintf("%s\n%-2s%3d 1.0",s,["S","P","D"][1+GTO[1]],nops(GTO[2])); for CGF in GTO[2] do s:=sprintf("%s\n%*.*f%*.*f",s,8+digits,digits,CGF[1],8+digits,digits,CGF[2]) end end; s:=cat(s,"\n****") end; s end: #hfl: WriteInput WriteInput:=proc( filename::string, program::{"lam","tin","mop","fly","gau","vas"}, method::string, runtype::string, Atoms::list, Cell::{undefined,Matrix,[numeric,numeric,numeric,numeric,numeric,numeric],[numeric,numeric,numeric,numeric,numeric,numeric,string]}:=undefined, Q::integer:=0, mult::posint:=`if`(type(Q,even),1,2), keylinepart1::string:="", output::list(string):=[], keylinepart2::string:="", { keylineonly::boolean:=false, keysep::string:=`if`(member(program,["tin","mop","gau"])," ","\n"), title::string:="", efile::string:="", before::list(string):=[], after::list({string,list}):=[], geomonly::boolean:=false, permonly::boolean:=false, i2aonly::boolean:=false, reuseinput::boolean:=false, append::boolean:=false, printout::{boolean,nonnegint,[nonnegint,nonnegint]}:=false, #Calculation parameter-specific keys: t::numeric:=0, T::numeric:=0, T2::numeric:=T, K::numeric:=T, P::numeric:=0, P2::numeric:=P, fix::{string,list}:=`if`(runtype="md","NVE",""), solvent::{string,numeric}:="", solvmodel::string:="", solveps::numeric:=0, #Atom and topology-specific keys: SORT::boolean:=evalb(program="vas"), connectivity::list:=[], atypes::list:=[], reindex::boolean:=false, charges::list:=[], #Geometry-specific keys: symmetry::{string,list,integer}:=`if`(member(runtype,["mo","no","nbo"]),"no",""), coo::{"","xyz","mop","fly"}:="", nt::nonnegint:=`if`(Cell=undefined,add(`if`(v[1]=tvsymbol9,1,0),v=Atoms),3), offset::[{numeric,[numeric,numeric]},{numeric,[numeric,numeric]},{numeric,[numeric,numeric]}]:=[0$3], vacuumlayer::numeric:=10, augmentcell::boolean:=evalb(member(program,["lam","tin","vas"]) and nt<3), orientcell::boolean:=evalb(augmentcell or member(program,["lam","tin"])), reducecell::boolean:=false, tvzero::numeric:=tvzero9, scalecell::numeric:=1, opt::string:="", optmet::{string,integer}:=`if`(program="tin","newton",`if`(program="vas",2,"")), opttol::numeric:=`if`(program="vas",tol,0), opttol2::numeric:=0, optlim::nonnegint:=`if`(program="lam",10000,0), optlim2::nonnegint:=`if`(program="lam",100000,0), opttol4::numeric:=opttol, optlim4::nonnegint:=optlim, optmet4::{string,integer}:=optmet, printstep4::numeric:=`if`(member(optmet4,["quickmin","fire"]),100,printstep), #Electronic structure-specific keys: excstate::nonnegint:=0, scf::string:="", scfmet::{string,integer}:=`if`(program="vas",vas_scfmet,""), scftol::numeric:=`if`(program="vas",tol,0), scflim::nonnegint:=0, scfalt::list([posint,posint]):=[], scfalta::list([posint,posint]):=[], scfaltb::list([posint,posint]):=[], occ::list:=[0], kgrid::{nonnegint,list}:=`if`(member("dos",output),100,30), Ueff::list(string=numeric):=["V"=3.1,"Cr"=3.5,"Mn"=3.9,"Fe"=4.0,"Co"=3.4,"Ni"=6.0,"Cu"=4.0,"Mo"=3.5,"Ag"=1.5], # [Jain11] BSSE::{"","counterpoise"}:="", #Other generic keys: tol::integer:=0, timestepinfs::numeric:=`if`(program="tin" or program="lam",`if`(runtype="em",10,1),0.1), printstep::numeric:=`if`(runtype="em",1,100), latsum::string:="", latsumtol::numeric:=1e-4, qeqtol::numeric:=0, Pcontrol::{"","iso","aniso","tri",list}:="", fixframe::nonnegint:=0, nbin::nonnegint:=`if`(member("bin",output),1000,0), tbin::nonnegint:=`if`(nbin=0,0,round(1000*t/timestepinfs/nbin)), nxyz::nonnegint:=`if`(member("xyz",output), 100,0), txyz::nonnegint:=`if`(nxyz=0,0,round(1000*t/timestepinfs/nxyz)), Tdamptime::nonnegint:=100, Pdamptime::nonnegint:=1000, seed::posint:=iquo(rand(),1111), mem::nonnegint:=mem9, time::numeric:=time9, # nsnapshots::posint:=100, tsnapshots::numeric:=ReduceFloat2(parse(sprintf("%.1g",t/nsnapshots),'statement')), # LAMMPS-specific keys: BOUNDARY::string:="", dumpcoo::string:="", LJ::{[numeric,numeric],[numeric,numeric,numeric,numeric]}:=[1,10], coulomb::{[numeric,numeric],[numeric,numeric,numeric,numeric]}:=[1,10], NEIGHBOR::[numeric,string]:=[0,""], THERMO_STYLE::string:=`if`(runtype="em","custom step pe fnorm fmax vol",""), #TINKER-specific keys: pisystem::{listlist(posint),undefined}:=undefined, #MOPAC-specific keys: AUX_MOS::integer:=99999, AUX_PRECISION::nonnegint:=4, AUX_COMP::boolean:=evalb(program="mop" and SearchText("MOZYME",keyline)>0), #Gaussian-specific keys: INTEGRAL::string:="", # for Gaussian 9 set to ultrafine NBO::boolean:=false, noRaman::boolean:=false, TDnstates::posint:=`if`(runtype[..3]="exc",30,4), #VASP-specific keys: freezeTv::list([nonnegint,nonnegint,nonnegint]):=[], ICHARG::{integer,undefined}:=undefined, IDIPOL::nonnegint:=0, LDIPOL::boolean:=false, LMONO::boolean:=evalb(nt<>3 and Q<>0), LORBIT::integer:=vas_LORBIT, LREAL::{"F","O","A",posint}:=vas_LREAL, MAGMOM::list:=[], AFM::{boolean,list}:=false, NCORE::integer:=vas_NCORE, POTCARtags::{list(string),list(string=string)}:=["","_sv","_pv"] },$) local keyline,scftyp,met,bss,ffn,fn,fd,i,j,o,o2,v,u,e,s,n,ls, freezeTv2,Tvs,A,na,M,Mi,tflags,box,tilt,boundary, elems,iperm,perm, fff,ffformat,AT,i2m,bonds,angles,dihedrals,impropers,prm,id,i2a,a2i, lsq,tbq,Q2,params,tunit,ccP,Tdamptime2,Pdamptime2,Tline,Pline,Pline2,pcontrol,minimize,minimize2, t7,printstep7,nbin7,tbin7,nxyz7,txyz7,fix7,T7,T27,P7,P27,iter,vars,T1,P1, optmet2,C,Co,atype,pisys,keyline2,flag,fld, composite,empcor,excspin,excstate1,excstate2,mgftype,sopt,sscf,sscrf,spop,Atoms2, kgrid2,title2,ecut,pff,atom,tbUeff,LDAUU,pfn,tags,path,tag,Atom,lsZ,lsZ2,Z,Vmm,tbmm,tmap,lsn; keyline:=cat(keylinepart1,`if`(keylinepart1="" or keylinepart2="" or keylinepart2[1]=keysep,"",keysep),keylinepart2); if (method="") then scftyp,met,bss:="","",""; WARNING("Method is not provided") else scftyp,met,bss:=op(DecodeMethod(method)) end; ffn,fn:=ExpandPath(filename,"pn,n"); if FileTools[Exists](cat(ffn,xout)) then WARNING("Output exists: %1",cat(ffn,xout)) end; # Unit cell and simulation box freezeTv2:=freezeTv; if (Cell=undefined) then Tvs,A:=selectremove(v->v[1]=tvsymbol9,Atoms); M:=Matrix(3,(o,j)->`if`(o=j,1,0),datatype=float); for j from 1 to nops(Tvs) do M[..,j]:=Tvs[j][2] end; if (Tvs<>[] and type(Tvs[1][-1],[nonnegint,nonnegint,nonnegint])) then freezeTv2:=[seq(v[-1],v=Tvs),[0,0,0]$3][..3] end else M:=`if`(type(Cell,Matrix),Cell*scalecell,cryst2M(Cell)); A:=[seq([v[1],M.v[2]],v=Atoms)]; Tvs:=[seq([tvsymbol9,M[..,j]],j=1..Dim2(M)[2])] end; na:=nops(A); if (augmentcell or orientcell) then A,M,tflags:=Atoms2Cell([op(A),op(Tvs)],['orient'=orientcell,':-tvzero'=tvzero,'reduce'=reducecell],'augment','rescale'=false,':-output'="amf"); Tvs:=[seq([tvsymbol9,M[..,j]],j=1..Dim2(M)[2])] else tflags:=[1$nt,0$(3-nt)]; if not(Cell=undefined) then A:=Atoms end end; try box:=[seq(`if`(type(offset[o],list), offset[o], `if`(tflags[o]=1, [offset[o],Tvs[o][2][o]+offset[o]], [round(min(seq(v[2][o],v=A))-vacuumlayer-offset[o]),round(max(seq(v[2][o],v=A))+vacuumlayer+offset[o])] )),o=1..3)] catch: box:=[[undefined$2]$3] end; for j from 1 to 3 do if (tflags[j]=2) then if (add((M[o,j]-`if`(o=j,1,0))^2,o=1..3)<10^(2-Digits)) then M[j,j]:=box[j][2]-box[j][1] else error("Noncanonic augmentation for j=%1 in M=%2",j,M) end end end; if geomonly then return [A,M,Tvs,tflags,box] end; # Sort atoms by elements elems:=ListTools[MakeUnique](map2(op,1,A)); if SORT then iperm:=[seq(seq(`if`(A[i][1]=e,i,NULL),i=1..na),e=elems)]; A:=A[iperm]; perm:=SortIdx(iperm,'nolist'); if permonly then return perm end end; # Fragmentation if (BSSE<>"") then i2m:=`if`(atypes=[],GetTopology(A,[],"",':-connectivity'=connectivity,'i2monly'),atypes) end; ##### # lam if (program="lam") then # geometry (bounding box) tilt:=evalf([Tvs[2][2][1],Tvs[3][2][1],Tvs[3][2][2]]); if (add(v^2,v=tilt)<10^(2-Digits)) then tilt:=0 else if (round(Tvs[1][2][1]*10^xyzdigits)+2*round(tilt[1]*10^xyzdigits)=-1) then Tvs[1][2][1]:=(round(Tvs[1][2][1]*10^xyzdigits)+1)/10^xyzdigits; WARNING("Last digit in translation vector of hexagonal lattice is corrected to get the right tilt") end end; box:=[seq(`if`(type(offset[o],list), offset[o], `if`(tflags[o]=1, [offset[o],Tvs[o][2][o]+offset[o]], [round(min(seq(v[2][o],v=A))-vacuumlayer-offset[o]),round(max(seq(v[2][o],v=A))+vacuumlayer+offset[o])] )),o=1..3)]; boundary:=map(v->"ps"[v],tflags); # force field file if (efile<>"") then if FileTools[Exists](efile) then fff:=efile else error("External force field file does not exist: %1",efile) end elif member(met,["OPLS"]) then if (reuseinput and FileTools[Exists](cat(ffn,xprm))) then fff:=cat(ffn,xprm) else fff,ffformat:="","OPLS"; for v in tin_path do if FileTools[Exists](cat(v,"oplsaa.prm")) then fff:=cat(v,"oplsaa.prm"); break end end; if (fff="") then error("No OPLS force field file") end end else fff:=cat("ffield.",StringTools[LowerCase](met)); if not(foldl(`or`,false,seq(FileTools[Exists](cat(v,fff)),v=lam_path))) then WARNING("Force field file %1 does not exist",fff) end end; if printout then printf("Using force field file %s\n",fff) end; # topology if member(met,["OPLS"]) then if (type(atypes,list(integer)) and nops(atypes)=na) then AT:=atypes; AT,i2m,bonds,angles,dihedrals,impropers,prm,id:=op(GetTopology(Atoms,AT,fff,`if`(type(ffformat,string),ffformat,NULL),':-connectivity'=connectivity,':-reindex'=reindex,':-printout'=printout)); elif (nops(atypes)=8 and type(atypes[1],list(integer))) then AT,i2m,bonds,angles,dihedrals,impropers,prm,id:=op(atypes) else error("Invalid atypes: %1",atypes) end; if not(reuseinput and FileTools[Exists](cat(ffn,xprm))) then if (reindex or efile="") then WritePRM(cat(ffn,xprm),prm,':-LJ'=LJ,':-coulomb'=coulomb,'overwrite') else FileTools[Copy](efile,cat(ffn,xprm),'force') end end; i2a:=[seq(prm["e",i],i=id[2])] elif member(met,["EEP"]) then if not(reuseinput) then FileTools[Copy](fff,cat(ffn,xprm),'force') end; prm:=ReadPRM(ffn,"mass"); ls:=sort(map(op,select(v->nops(v)=1,[indices(prm)]))); for i from 1 to nops(ls) do if (ls[i]<>i) then error("Atom types for EEP must be integers from 1 to number of elements, but received %1",ls) end end; i2a:=[seq(prm["e",i],i=ls)]; a2i:=table(); for i from 1 to nops(i2a) do a2i[i2a[i]]:=i end; AT:=map(v->a2i[v[1]],A) else i2a:=ListTools[MakeUnique](map2(op,1,A)); a2i:=table(); for i from 1 to nops(i2a) do a2i[i2a[i]]:=i end; AT:=map(v->a2i[v[1]],A) end; if i2aonly then return i2a end; # charges if member(met,["OPLS","EEP"]) then lsq:=charges; if (lsq=[]) then lsq:=NormalizeCharges([seq(prm["q",i],i=AT)],qdigits,Q,AT,'warning') end elif member(met,["COMB","COMB3"]) then tbq:=table(charges); lsq:=map(v->tbq[v[1]],A) else lsq:=[] end; # inp if not(reuseinput and FileTools[Exists](cat(ffn,lam_xinp2))) then fd:=fopen(cat(filename,lam_xinp2),WRITE,TEXT); writeline(fd); for o from 1 to 3 do fprintf(fd,"%.*f %.*f %slo %shi\n",xyzdigits,box[o][1],xyzdigits,box[o][2],"xyz"[o]$2) end; if (tilt<>0) then fprintf(fd,"%.*f %.*f %.*f xy xz yz\n",xyzdigits,tilt[1],xyzdigits,tilt[2],xyzdigits,tilt[3]) end; if member(met,["OPLS"]) then fprintf(fd,"\n%d atoms\n%d bonds\n%d angles\n%d dihedrals\n%d impropers\n",na,nops(bonds),nops(angles),nops(dihedrals),nops(impropers)); fprintf(fd,"\n%d atom types\n%d bond types\n%d angle types\n%d dihedral types\n%d improper types\n",nops(id[2]),seq(nops(v),v=id[4..7])); fprintf(fd,"\nAtoms\n\n"); for j from 1 to na do fprintf(fd,"%6d%6d%4d%*.*f%*.*f\n",j,i2m[j],AT[j],5+qdigits,qdigits,lsq[j],8+xyzdigits,xyzdigits,A[j][2]) end; if (bonds<>[]) then fprintf(fd,"\nBonds\n\n") ,seq(fprintf(fd,"%d %d %d %d\n", i,op(bonds[i])) ,i=1..nops(bonds)) end; if (angles<>[]) then fprintf(fd,"\nAngles\n\n") ,seq(fprintf(fd,"%d %d %d %d %d\n", i,op(angles[i])) ,i=1..nops(angles)) end; if (dihedrals<>[]) then fprintf(fd,"\nDihedrals\n\n"),seq(fprintf(fd,"%d %d %d %d %d %d\n",i,op(dihedrals[i])),i=1..nops(dihedrals)) end; if (impropers<>[]) then fprintf(fd,"\nImpropers\n\n"),seq(fprintf(fd,"%d %d %d %d %d %d\n",i,op(impropers[i])),i=1..nops(impropers)) end else fprintf(fd,"\n%d atom types\n%d atoms\nAtoms\n\n",nops(i2a),na); if member(met,["COMB","COMB3","EEP"]) then for j from 1 to na do fprintf(fd,"%6d%4d%*.*f%*.*f\n",j,AT[j],5+qdigits,qdigits,lsq[j],8+xyzdigits,xyzdigits,A[j][2]) end else for j from 1 to na do fprintf(fd,"%6d%4d%*.*f\n",j,AT[j],8+xyzdigits,xyzdigits,A[j][2]) end end end; fclose(fd) end; if printout then PrintFile(cat(filename,lam_xinp2),20) end; # main if member(met,["OPLS","EEP"]) then params:=cat("include ",fn,xprm) else params:=cat( seq(sprintf("mass %4d%8.3f\n",i,AtomMass(i2a[i])),i=1..nops(i2a)), sprintf("pair_style %s %s\n", StringTools[LowerCase](met), `if`(met="COMB3","polar_off","")), sprintf("pair_coeff * * %s %s %s", `if`(met="EIM",Vector(i2a),""), fff, Vector(i2a))) end; tunit:=`if`(member(met,["OPLS"]),1,1000); # femtoseconds ccP:=`if`(member(met,["OPLS"]),10000/1.01325 ,10000); # from GPa Tdamptime2,Pdamptime2:=Tdamptime/tunit,Pdamptime/tunit; Tline:=sprintf("%a %a %a",ReduceFloat(T),ReduceFloat(T2),ReduceFloat(Tdamptime2)); v:=[seq(`if`(boundary[o]="p","xyz"[o],NULL),o=1..3)]; pcontrol:=`if`(Pcontrol="",`if`(tilt=0,`if`(nops(v)=3,"aniso",v),`if`(nops(v)=3,"tri",[op(v),seq(seq(cat(v[o],v[o2]),o2=o+1..nops(v)),o=1..nops(v))])),Pcontrol); v:=sprintf("%a %a %a",ReduceFloat(ccP*P),ReduceFloat(ccP*P2),ReduceFloat(Pdamptime2)); Pline:=`if`(type(pcontrol,string),cat(pcontrol," ",v),cat(seq(cat(u," ",v," "),u=pcontrol),"couple none")); v:=sprintf("%a",ReduceFloat(ccP*P)); Pline2:=`if`(type(pcontrol,string),cat(pcontrol," ",v),cat(seq(cat(u," ",v," "),u=pcontrol),"couple none")); minimize :=sprintf("minimize %.1e %.1e %d %d",opttol2,`if`(type(opttol ,integer),10^(opttol -3),opttol ),optlim ,optlim2); minimize2:=sprintf("minimize %.1e %.1e %d %d",opttol2,`if`(type(opttol4,integer),10^(opttol4-3),opttol4),optlim4,optlim2); if (optmet <>"") then minimize :=sprintf("thermo %d\nmin_style %s\n%s",printstep ,optmet ,minimize ) end; if (optmet4<>"") then minimize2:=sprintf("thermo %d\nmin_style %s\n%s",printstep4,optmet4,minimize2) end; ls:=[op(before), cat("units ",`if`(member(met,["OPLS"]),"real","metal")), cat("atom_style ",`if`(member(met,["OPLS"]),"full",`if`(member(met,["COMB","COMB3","EEP"]),"charge","atomic"))), cat("boundary ",`if`(BOUNDARY="",sprintf("%s %s %s",op(boundary)),BOUNDARY)), cat("read_data ",fn,lam_xinp2), params, `if`(latsum="",NULL,sprintf("kspace_style %s %.2g",latsum,latsumtol)), `if`(NEIGHBOR[2]="",NULL,sprintf("neighbor %a %s",op(NEIGHBOR))), `if`(THERMO_STYLE="",NULL,sprintf("thermo_style %s",THERMO_STYLE)), sprintf("thermo %d",printstep), `if`(timestepinfs=1,NULL,sprintf("timestep %s",FormatFloat(timestepinfs/`if`(member(met,["OPLS"]),1,1000),0,maxorder=6))), `if`(fixframe=0,NULL,sprintf("fix momentum all momentum %d linear 1 1 1 angular",fixframe)), `if`(member(met,["COMB","COMB3"]),cat("fix qeq all qeq/comb 1 ",FormatFloat(`if`(type(qeqtol,integer),10^(qeqtol-3),qeqtol),1,'maxorder'=15,'showzero'),`if`(member("qeq",output),cat(" file ",fn,".qeq"),NULL)),NULL), `if`(keyline="",NULL,keyline), `if`(runtype="sp","run 1",NULL), `if`(runtype="em",`if`(type(fix,[posint,posint]), sprintf("variable i loop %d\nlabel loop_i\n reset_timestep 0\n fix box all box/relax %s vmax 0.001\n %s\n unfix box\n %s\n if '$(step)<%d' then 'jump SELF break_i'\n next i\n jump SELF loop_i\nlabel break_i",fix[1],Pline2,minimize,minimize2,fix[2]), `if`(fix="cell" or nt=0, minimize, sprintf("fix box all box/relax %s vmax 0.001\n%s",Pline2,minimize))),NULL), `if`(runtype="md",cat( `if`(tbin>0 or member("bin",output),sprintf("dump mdbin all custom %d %s.bin x%s y%s z%s\ndump_modify mdbin sort id\n",`if`(tbin>0,tbin,round(9000*t/timestepinfs)),fn,dumpcoo$3),NULL), `if`(txyz>0 or member("xyz",output),sprintf("dump mdxyz all xyz %d %s.xyz\ndump_modify mdxyz element %s\n" ,`if`(txyz>0,txyz,round(9000*t/timestepinfs)),fn,Vector(i2a)),NULL), sprintf("velocity all create %a %d dist gaussian mom yes rot yes\n",ReduceFloat(K),seed), `if`(fix="NVE",sprintf("fix ensemble all nve\n"), `if`(fix="NVT",sprintf("fix ensemble all nvt temp %s\n",Tline), `if`(fix="NPT",sprintf("fix ensemble all npt temp %s %s\n",Tline,Pline), `if`(fix="NPH",sprintf("fix ensemble all nph %s\n",Pline),NULL)))), sprintf("run %d",round(1000*t/timestepinfs))),NULL), NULL]; t7,printstep7,tbin7,txyz7,fix7,T7,T27,P7,P27:=t,printstep,tbin,txyz,fix,T,T2,P,P2; iter:=0; for s in after do if type(s,string) then ls:=[op(ls),s] else iter:=iter+1; ls:=[op(ls),sprintf("write_dump all custom %s%s%d element x%s y%s z%s%s modify sort id element %s",fn,lam_xdump,iter,dumpcoo$3,`if`(charges=[],""," q"),Vector(i2a))]; T1,P1:=T27,P27; ProcessSetupArgs(s,['t7','printstep7','nbin7','tbin7','nxyz7','txyz7','fix7','T7','T27','P7','P27'],"7"); vars:={seq(convert(lhs(u),string),u=select(type,s,equation))}; if member("printstep" ,vars) then ls:=[op(ls),sprintf("thermo %d",printstep)] end; if member("nbin",vars) then ls:=[op(ls),sprintf("dump_modify mdbin every %d",`if`(nbin7>0,round(1000*t7/timestepinfs/nbin7),round(9000*t7/timestepinfs)))] end; if member("nxyz",vars) then ls:=[op(ls),sprintf("dump_modify mdxyz every %d",`if`(nxyz7>0,round(1000*t7/timestepinfs/nxyz7),round(9000*t7/timestepinfs)))] end; if member("tbin",vars) then ls:=[op(ls),sprintf("dump_modify mdbin every %d",`if`(tbin7>0,tbin7,round(9000*t7/timestepinfs)))] end; if member("txyz",vars) then ls:=[op(ls),sprintf("dump_modify mdxyz every %d",`if`(txyz7>0,txyz7,round(9000*t7/timestepinfs)))] end; if member("fix" ,vars) then ls:=[op(ls),"unfix ensemble"] end; if member("T",vars) then T1:=T7 end; if member("P",vars) then P1:=P7 end; Tline:=sprintf("%a %a %a",ReduceFloat(T1),ReduceFloat(T27),ReduceFloat(Tdamptime2)); v:=sprintf("%a %a %a",ReduceFloat(ccP*P1),ReduceFloat(ccP*P27),ReduceFloat(Pdamptime2)); Pline:=`if`(type(pcontrol,string),cat(pcontrol," ",v),cat(seq(cat(u," ",v," "),u=pcontrol),"couple none")); ls:=[op(ls), `if`(fix="NVE",sprintf("fix ensemble all nve"), `if`(fix="NVT",sprintf("fix ensemble all nvt temp %s",Tline), `if`(fix="NPT",sprintf("fix ensemble all npt temp %s %s",Tline,Pline), `if`(fix="NPH",sprintf("fix ensemble all nph %s",Pline),NULL)))), sprintf("run %d",round(1000*t7/timestepinfs))] end end; WriteLines(cat(filename,lam_xinp),[op(ls), sprintf("write_dump all custom %s%s element x%s y%s z%s %sx %sy %sz %smodify sort id element %s",fn,lam_xdump,dumpcoo$3,`if`(runtype="md","v","f")$3,`if`(charges=[],"","q "),Vector(i2a)), "print 'Final volume = $(vol)'", "print 'Final potential energy = $(pe)'", "print 'Final gradient norm = $(fnorm)'", `if`(runtype="md","print 'Final total energy = $(etotal)'",NULL), "print 'Execution terminated normally'"],'overwrite') # tin elif (program="tin") then if (runtype="em" and FileTools[Exists](cat(ffn,".xyz"))) then WARNING("xyz-file exists (optimized geometry will be written to *.xyz_2): %1",cat(ffn,xout)) end; if (runtype="em" and not(member(optmet,["newton","minimize","xtalmin"]))) then error("optmet must be on of [newton,minimize,xtalmin] but received %1",optmet) end; optmet2:=optmet; met:=WriteMethod("tin",met); if not(reuseinput and FileTools[Exists](cat(ffn,tin_xinp2))) then if (nt>0) then C:=`if`(type(Cell,list),Cell,M2cryst(Matrix(3,(o,i)->Tvs[i][2][o],datatype=float)))[..6]; if not(fix="cell") then optmet2:="xtalmin" end end; Co:=`if`(nops(connectivity)=na and type(connectivity,list(list(posint))),connectivity,ConnectAtoms(A,op(connectivity))); if (type(atypes,list(integer)) and nops(atypes)=na) then AT:=atypes else if (atypes<>[] and type(atypes[1],procedure)) then atype:=atypes[1] elif (met="MM3" or met="MM3-") then atype:=atype_mm3 else error("Neither atomic types nor atype procedure are provided") end; AT:=ClassifyAtoms(A,atype,Co,`if`(nops(atypes)>1,op(2..,atypes),NULL)) end; WriteLines(cat(filename,tin_xinp2),[sprintf("%d %s",na,`if`(title="","notitle",title)),seq(sprintf("%5d %-2s %10.6f %4d %5d",i,op(A[i]),AT[i],Vector(Co[i])),i=1..na)],'overwrite') end; if not(reuseinput and FileTools[Exists](cat(ffn,".key"))) then prm:=piecewise(met="MM",fn,met="MM3-","mm3",StringTools[LowerCase](met)); flag:=false; for fld in tin_path do if FileTools[Exists](cat(fld,prm,xprm)) then flag:=true; break end end; if not(flag) then error("prm-file does not exists: %1",prm) end; if (met="MM3") then pisys:=`if`(pisystem=undefined,[[seq(`if`(member(AT[i],[2,37,42]),i,NULL),i=1..nops(AT))]],pissystem); pisys:=`if`(pisys=[[]],[],[seq(cat("pisystem ",StringTools[SubstituteAll](StringTools[WrapText](sprintf("%d",Vector(v)),110)," \n","\npisystem ")),v=pisys)]) else pisys:=[] end; WriteLines(cat(filename,".key"),[ cat("parameters ",fld,prm), op(pisys), `if`(nt=0,NULL,sprintf("a-axis %.*f\nb-axis %.*f\nc-axis %.*f\nalpha %.*f\nbeta %.*f\ngamma %.*f",seq(op([xyzdigits,v]),v=C))), NULL],'overwrite') end; if not(printout=false) then for e in [tin_xinp2,".key"] do PrintFile(cat(filename,e),`if`(printout=true,NULL,`if`(type(printout,posint),printout,op(printout)))) end end; if (keyline="") then if (runtype="sp") then keyline2:="E" elif (runtype="em") then keyline2:=cat(`if`(optmet2="newton","A A ",NULL),sprintf("%.1e",`if`(type(opttol,integer),10^(opttol-2),opttol/kcalmol2eV))) elif (runtype="md") then keyline2:=sprintf("%d %a %s %d%s%s", round(1000*t/timestepinfs), timestepinfs, FormatFloat(txyz*timestepinfs/1000,3), piecewise(fix="NVE",1,fix="NVT",2,fix="NPH",3,fix="NPT",4,9), `if`(fix="NVT" or fix="NPT",sprintf(" %a",T),""), `if`(fix="NPH" or fix="NPT",sprintf(" %a",P),"") ) else error("Provide keyline") end else keyline2:=keyline end; WriteLines(cat(filename,tin_xinp),[sprintf("%s %s%s %s",piecewise(runtype="sp","analyze",runtype="em",optmet2,runtype="md","dynamic",runtype),fn,tin_xinp2,keyline2)],'overwrite'); if (runtype="em" and FileTools[Exists](cat(filename,".xyz_2"))) then fremove(cat(filename,".xyz_2")) end #mop elif (program="mop") then fd:=fopen(cat(filename,xinp[program]),`if`(append,APPEND,WRITE),TEXT); if (append and filepos(fd)>1) then writeline(fd,"") end; try if keylineonly then writeline(fd,keyline) else writeline(fd,cat(" ", `if`(time>0,sprintf("T=%aD ",time),NULL), `if`(member("mgf",output),"GRAPHF ",NULL), `if`(member("bin",output) or member("aux",output),sprintf("AUX(MOS=%d,PRECISION=%d%s) ",AUX_MOS,AUX_PRECISION,`if`(AUX_COMP,",COMP","")),NULL), `if`(Q=0,NULL,sprintf("CHARGE=%d ",Q)), `if`(mult=1,NULL,sprintf("MS=%.1f ",(mult-1)/2)), WriteMethod("mop",met)," ", `if`(runtype="sp","1SCF ",""), `if`(runtype="md",sprintf("DRC KINETIC=%f T-PRIORITY=1 CYCLES=%d GNORM=0.0 ", 3/2*K*K2eV/kcalmol2eV, round(1000*t)),""), piecewise(scftyp="R","RHF ",scftyp="U" or mult>1 and member(met,["PM7","PM6"]),"UHF ",""), piecewise(opttol=1,"GNORM=10 ",opttol=-1,"GNORM=0.1 ",opttol=-2,"GNORM=0.01 ",opttol>0,sprintf("GNORM=%.1e ",opttol/kcalmol2eV),opttol<0,"GNORM=0 ",""), `if`(optlim>0,sprintf("CYCLES=%d ",optlim),""), piecewise(scftol>0,sprintf("SCFCRT=1.D-%d ",scftol),scftol=-1,"RELSCF=0.1 ",scftol=-2,"RELSCF=0.01 ",""), `if`(scflim>0,sprintf("ITRY=%d ",scflim),""), `if`(symmetry="","","SYMMETRY "), `if`(solvent="",NULL,sprintf("eps=%a ",`if`(assigned('tb_solvents[solvent,"e0"]'),tb_solvents[solvent,"e0"],solvent))), `if`(member("Fr",elems),"VDWM(FR=2.00) ",`if`(member("At",elems),"VDWM(AT=2.00) ",NULL)), keyline)) end; writeline(fd,title,""); for Atom in Atoms do writeline(fd,WriteAtom(program,Atom)) end; if (symmetry<>"") then writeline(fd,""); if type(symmetry,string) then fprintf(fd,symmetry) else for e in symmetry do fprintf(fd,"%d %d %{c,}d\n",e[1],e[2],convert(e[3..-1],Vector)) end end end; if (nops(after)>0) then writeline(fd,""); for s in after do writeline(fd,s) end end; finally fclose(fd) end # fly elif (program="fly") then fd:=fopen(cat(filename,xinp[program]),`if`(append,APPEND,WRITE),TEXT); if (append and filepos(fd)>1) then writeline(fd,"") end; try s:=cat( `if`(time>0,sprintf("TIMLIM=%d ",ceil(time*24*60)),""), `if`(mem>0,sprintf("MWORDS=%d ",mem),"")); if (s<>"") then writeline(fd,cat(" $SYSTEM ",s,"$END")) end; fprintf(fd," $CONTRL%s ICHARG=%d MULT=%d SCFTYP=%s $END\n", piecewise(coo="",`if`(nops(convert(Atoms[1][2],list))=3,""," COORD=ZMT"),coo="xyz"," COORD=CART",coo="mop"," COORD=ZMT",""), Q,mult, `if`(scftyp="",`if`(mult=1,"RHF","UHF"),`if`(scftyp="R" and mult>1,"ROHF",cat(scftyp,"HF")))); s:=cat( `if`(runtype="","",sprintf("RUNTYP=%s ",piecewise(runtype="sp","ENERGY",runtype="em","OPTIMIZE",""))), WriteMethod("fly",met)," ", `if`(scflim>0,sprintf("MAXIT=%d ",scflim),"")); if (s<>"") then writeline(fd,cat(" $CONTRL ",s,"$END")) end; s:=cat( `if`(fly_dirscf=1,"DIRSCF=.T. ",""), `if`(fly_dirscf=0,"DIRSCF=.F. ",""), `if`(scftol>0,sprintf("NCONV=%d ",scftol),"")); if (s<>"") then writeline(fd,cat(" $SCF ",s,"$END")) end; s:=cat( `if`(opttol>0,sprintf("OPTTOL=%.1e ",3*opttol/hartree2eV*bohr2A),""), `if`(optlim>0,sprintf("NSTEP=%d ",optlim),"")); if (s<>"") then writeline(fd,cat(" $STATPT ",s,"$END")) end; writeline(fd,WriteBS("fly",bss)); if (keyline<>"") then writeline(fd,keyline) end; fprintf(fd," $DATA\n%s\n%s\n",title,`if`(symmetry="","C1",symmetry)); if (symmetry<>"" and symmetry<>"C1") then writeline(fd,"") end; for Atom in Atoms do writeline(fd,WriteAtom(program,Atom)) end; writeline(fd," $END"); if (nops(after)>0) then writeline(fd,""); for s in after do writeline(fd,s) end end; finally fclose(fd) end # gau elif (program="gau") then if not(member(runtype,["","chk","wave","sp","em","freq","mo","no","nbo","mgf","mgfmo","mgfno","esp"]) or member(runtype[..3],["exc","nto"])) then error("Unrecognized gau runtype: %1",runtype) end; composite:=member(met,knowncomposite); if (length(met)>3 and met[-3..]="-D3") then met,empcor:=met[..-4],"GD3BJ" else empcor:="" end; if (runtype[..3]="exc") then if (runtype[..4]="excS") then excspin,excstate1:= 0,runtype[5..] elif (runtype[..4]="excT") then excspin,excstate1:= 1,runtype[5..] else excspin,excstate1:=-1,runtype[4..] end; if (excstate1="") then excstate1:=`if`(excstate>0,excstate,1) else excstate1:=parse(excstate1) end; if not(type(excstate1,posint)) then error("Unrecognized runtype: %1",runtype) end else excspin,excstate1:=-1,excstate end; if (runtype[..3]="nto") then if (runtype[..4]="ntoS") then excspin,excstate2:= 0,runtype[5..] elif (runtype[..4]="ntoT") then excspin,excstate2:= 1,runtype[5..] else excspin,excstate2:=-1,runtype[4..] end; excstate2:=parse(excstate2); if not(type(excstate2,posint)) then error("Unrecognized runtype: %1",runtype) end; excstate1:=`if`(excstate>0,excstate,1) else excstate2:=0 end; if (runtype[..3]="mgf") then mgftype:=runtype[4..]; if (mgftype="") then mgftype:=`if`(mult>1,"no","mo") end elif (runtype[..3]="nto") then mgftype:="nto" else mgftype:="" end; lsZ:=sort(convert(map(AtomicNumber,remove(`=`,{seq(v[1],v=Atoms)},tvsymbol9)),list)); fd:=fopen(cat(filename,xinp[program]),`if`(append,APPEND,WRITE),TEXT); if (append and filepos(fd)>1) then writeline(fd,"") end; try for s in before do writeline(fd,s) end; if (mem>0) then writeline(fd,cat("%mem=",mem,"MW")) end; if (member("bin",output) or member("rwf",output) or member(runtype,["mo","no","nbo"])) then writeline(fd,cat("%rwf=",fn,".rwf")) end; if (member("chk",output) or member(runtype,["chk","freq","wave"]) and not(composite)) then writeline(fd,cat("%chk=",fn,".chk")) end; sopt:=StringTools[Join]([ `if`(opt="",NULL,opt), piecewise(opttol=-2,"vtight",opttol=-1,"tight",NULL), `if`(optlim>0,sprintf("maxcycles=%d",optlim),NULL), `if`(coo="xyz","cartesian",NULL), `if`(member(fix,["","NVE","NVT"]),NULL,`if`(type(fix,string) and SearchText("atoms",fix)=0,"ModRedundant","ReadOpt")) ],","); sscf:=StringTools[Join]([ `if`(scf="",NULL,scf), `if`(scftol>0,sprintf("conver=%d",scftol),NULL), `if`(scflim>0,sprintf("maxcycles=%d",scflim),NULL) ],","); sscrf:=StringTools[Join]([ `if`(solvent="" or solvmodel="",NULL,solvmodel), `if`(member(solvent,["","pcm","vac"]),NULL,cat("solvent=",`if`(assigned('tb_solvents[solvent,"name_G"]'),tb_solvents[solvent,"name_G"],solvent))), `if`(solvent="pcm","read",NULL) ],","); spop:=StringTools[Join]([ `if`(mgftype="",NULL,"full"), `if`(mgftype="" or mgftype="mo",NULL,mgftype), `if`(runtype="no","no",NULL), `if`((NBO or runtype="nbo") and not(composite),"NBO",NULL), `if`(runtype="nbo","SaveNBOs",NULL), `if`(runtype="esp","CM5",NULL) ],","); if keylineonly then writeline(fd,keyline) else writeline(fd,cat( `if`(member("P",output),"#P",`if`(member("N",output),"#N",`if`(member("T",output) or member(runtype,["chk","wave","mgf","mgfmo","mgfno"]),"#T", `if`(member(runtype,["sp","mo"]) and nt>0,"#P","#"))) ), # #-key " ",`if`(scftyp="R" and mult>1,"RO",scftyp), WriteMethod("gau",met), `if`(composite and not(runtype="em" or runtype="freq"),"(sp)",NULL), #method " ",WriteBS("gau",bss), `if`(bss[1]="p" and lsZ[-1]>36," ExtraBasis",NULL), #basis `if`(empcor="",NULL,cat(" EmpiricalDispersion(",empcor,")")), #empirical dispersion `if`(INTEGRAL="",NULL,cat(" int(",INTEGRAL,")")), #int `if`(runtype="em" or sopt<>"",`if`(sopt=""," opt",cat(" opt(",sopt,")")),NULL), #opt `if`(opttol>0,sprintf(" iop(1/7=%d)",floor(1e6*opttol/hartree2eV*bohr2A)),NULL), #user-provided opttol `if`(sscf="",NULL,cat(" scf(",sscf,")")), #scf `if`(scfalt=[] and scfalta=[] and scfaltb=[],NULL," guess(alter)"), #scf initial guess `if`(sscrf="",NULL,cat(" scrf(",sscrf,")")), #scrf `if`(runtype="freq" and not(composite),cat(" freq(SaveNM",`if`(noRaman or met[..4]="CCSD" or met[..3]="LC-",")",",Raman)")),NULL), #freq `if`(excstate1>0,cat(sprintf(" TD(nstates=%d",excstate2+TDnstates), #TD `if`(excspin=0,",singlets",`if`(excspin=1,",triplets",NULL)), `if`(excstate1>1,sprintf(",root=%d",excstate1),NULL), ")"),NULL), `if`(spop="",NULL,cat(" pop(",spop,") density",`if`(excstate2>0,sprintf("(transition=%d)",excstate2),NULL))), #pop density `if`(member(runtype,["mo","no","nbo"]) or mgftype<>""," gfprint",NULL), #gfprint `if`(runtype="esp"," prop(FitCharge)",NULL), #prop `if`(symmetry="no" or StringTools[LowerCase](symmetry)="nosymm"," nosymm",NULL), #nosymm `if`(BSSE="counterpoise",sprintf(" counterpoise=%d",max(i2m)),NULL), #counterpoise `if`(keyline="",NULL," "),keyline)) end; writeline(fd,""); writeline(fd,`if`(Trim(title)="",NULL,title),""); fprintf(fd,"%d %d\n",Q,mult); if (BSSE="") then Atoms2:=Atoms else Atoms2:=[seq([`if`(Atoms[i][1]=tvsymbol9,Atoms[i][1],sprintf("%s(Fragment=%d)",Atoms[i][1],i2m[i])),Atoms[i][2]],i=1..nops(Atoms))] end; for Atom in Atoms2 do writeline(fd,WriteAtom(program,Atom)) end; if not(member(fix,["","NVE","NVT"])) then writeline(fd,""); if type(fix,string) then fprintf(fd,fix) else fprintf(fd,"notatoms=%{c,}s\n",Vector([seq(`if`(type(e,posint),sprintf("%d",e),sprintf("%d-%d",op(e))),e=convert2range(fix))])) end end; if (SearchText("x",bss)>0) then ls:=StringTools[Split](bss,"x"); ls:=map2(WriteBS,"gau",ls); lsZ2:=[selectremove(`<`,lsZ,19)]; for i from 1 to nops(ls) do if (lsZ2[i]<>[]) then fprintf(fd,"\n%s 0\n%s\n****",Vector(map(v->ElementSymbol[v],lsZ2[i])),ls[i]) end end; fprintf(fd,"\n") elif (bss="l2p") then writeline(fd,""); for Z in lsZ do writeline(fd,WriteEBS("gau",Z,tb_bss[Z,"l2p","l2"])) end elif (bss[1]="p" and lsZ[-1]>36) then s:=WriteBS("gau",bss); i:=SearchText("+",s); if (i=0) then i:=SearchText("G",s) end; if (i=0) then error("Unrecognized p-class bss: %1",bss) end; fprintf(fd,"\n%s 0\n3-21%s\n****\n",Vector([seq(`if`(Z>36,ElementSymbol[Z],NULL),Z=lsZ)]),s[i..]) end; if (solvent="pcm") then fprintf(fd,"\nEps=%a\n",solveps) end; if not(scfalt=[] and scfalta=[] and scfaltb=[]) then writeline(fd,""); if (scfalt<>[]) then if (mult<>1) then error("Multiplicity=%1 is inconsistent with scfalt=%2",mult,scfalt) end; for v in scfalt do fprintf(fd,"%d %d\n",op(v)) end else if (mult=1) then error("Multiplicity=%1 is inconsistent with scfalta,scfaltb=%2,%3",mult,scfalta,scfaltb) end; for v in scfalta do fprintf(fd,"%d %d\n",op(v)) end; writeline(fd,""); for v in scfaltb do fprintf(fd,"%d %d\n",op(v)) end end end; if (nops(after)>0) then writeline(fd,""); for s in after do writeline(fd,s) end end; writeline(fd,""); finally fclose(fd) end # vas elif (program="vas") then if (runtype="em" and not(type(optmet,integer))) then error("optmet must be integer but received %1",optmet) end; fld:=cat(filename,vas_xinp); v:=StringTools[Split](met,"-"); if (nops(v)>1 and member(v[-1],["D3","D4","MBD"])) then met,empcor:=met[..-length(v[-1])-2],v[-1] else empcor:="" end; sscf:=piecewise( met="PBE0" ,"LHFCALC=T", met="HSE06" ,"LHFCALC=T; HFSCREEN=0.2", met="HF" ,"LHFCALC=T; AEXX=1; ALDAC=0; AGGAC=0", met="B3LYP" ,"LHFCALC=T; GGA=B3; AEXX=0.2; AGGAX=0.72; AGGAC=0.81; ALDAC=0.19", met="SCAN" ,"METAGGA=SCAN; LASPH=T", met="R2SCAN" ,"METAGGA=R2SCAN; LASPH=T", met="VDW-DF2","GGA=ML; LUSE_VDW=T; Zab_vdW=-1.8867; AGGAC=0", met="LDA-U" or met="GGA-U",cat("LDAU=T; LMAXMIX=4; LDAUU=",LDAUU), met="LDA" or met="GGA" or met="PBE",NULL, undefined); if (sscf=undefined) then error("Unrecognized VASP method: %1",met) end; if (empcor<>"") then sscf:=cat(sscf,`if`(sscf=NULL,"","; "),"IVDW=",piecewise(empcor="D3",12,empcor="D4",13,empcor="MBD",202,undefined)) end; if (met="R2SCAN" and empcor="D3") then sscf:=cat(sscf,"\nVDW_S8=0.78981345; VDW_A1=0.49484001; VDW_A2=5.73083694") end; #[Ehlert21] # POSCAR tmap:=[seq(`if`(tflags[o]=2,NULL,o),o=1..3)]; i2a,lsn:=[A[1][1]],[1]; for i from 2 to nops(A) do if (A[i][1]<>i2a[-1]) then i2a,lsn:=[op(i2a),A[i][1]],[op(lsn),i] end end; lsn:=[seq(lsn[i]-lsn[i-1],i=2..nops(lsn)),i-lsn[-1]]; if (nops(i2a)<>nops(convert(i2a,set))) then error("Unsorted list of atoms: %1",map2(op,1,A)) end; if i2aonly then return i2a end; if not(FileTools[Exists](fld)) then mkdir(fld) end; if not(reuseinput and FileTools[Exists](cat(fld,"/POSCAR"))) then WritePOSCAR(cat(fld,"/POSCAR"),A,M,tmap,'cart'=`if`(type(Cell,undefined),2,-1),':-freezeTv'=freezeTv2,':-scalecell'=scalecell,':-digits'=digits,'printi2a','overwrite') end; # POTCAR if (bss="" and not(FileTools[Exists](cat(fld,"/POTCAR")))) then error("Provide basis set or get POTCAR") end; ecut:=DecodeBS(bss)[2]; if not(reuseinput and FileTools[Exists](cat(fld,"/POTCAR"))) then pff:=WriteBS("vas",bss); s:=""; tags:=`if`(type(POTCARtags[1],string),POTCARtags,table(POTCARtags)); for atom in i2a do flag:=false; for tag in `if`(type(tags,list),tags,[tags[atom]]) do pfn:=sprintf(pff,piecewise(member(met,["GGA","GGA-U","PBE0","HSE06","HF","B3LYP","VDW-DF2","SCAN","R2SCAN"]),"PBE",met="LDA-U","LDA",met),cat(atom,tag)); for path in vas_path do if FileTools[Exists](cat(path,pfn)) then flag:=true; break end end; if (flag=true) then break end end; if not(flag) then error("POTCAR file does not exist: %1, tags=%2",pfn,POTCARtags) end; assign('s',cat(s,FileTools[Text][ReadFile](cat(path,pfn)))) end; WriteLines(cat(fld,"/POTCAR"),[s],'overwrite') end; # KPOINTS if not(reuseinput and FileTools[Exists](cat(fld,"/KPOINTS"))) then kgrid2:=DecodeKgrid(DecodeBS(bss)[4],A,M); kgrid2:=`if`(kgrid2=[],kgrid,kgrid2); if (kgrid2=0) then WriteLines(cat(fld,"/KPOINTS"),["","1","rec","0 0 0 1"],'overwrite') elif type(kgrid2,posint) then WriteLines(cat(fld,"/KPOINTS"),["","0","A",sprintf("%d",kgrid2)],'overwrite') else WriteLines(cat(fld,"/KPOINTS"),["","0",kgrid2[1],sprintf("%d %d %d",op(2..4,kgrid2)),`if`(nops(kgrid2)>4,sprintf("%d %d %d",op(5..7,kgrid2)),NULL)],'overwrite') end end; # INCAR title2:=`if`(perm=[$1..na],"",sprintf("perm=[%{c,}d]",Vector(perm))); if (title<>"") then title2:=`if`(title2="",title,cat(title,", ",title2)) end; if (met="LDA-U" or met="GGA-U") then tbUeff:=table(Ueff); LDAUU:=cat(seq(`if`(assigned('tbUeff[v]'),sprintf(" %a",tbUeff[v])," 0"),v=i2a)) end; if (AFM<>false) then Vmm:=AFMorder(A,M,`if`(type(AFM,list),op(AFM),NULL)) end; if (MAGMOM<>[]) then if type(MAGMOM,list(numeric)) then Vmm:=MAGMOM else Vmm:=Vector(na); tbmm:=table(MAGMOM); for i from 1 to na do if assigned('tbmm[i]') then Vmm[i]:=tbmm[i] elif assigned('tbmm[A[i][1]]') then Vmm[i]:=tbmm[A[i][1]] end end; Vmm:=[seq(v,v=Vmm)] end end; WriteLines(cat(fld,"/INCAR"),[ `if`(title2="",NULL,cat("SYSTEM= ",title2)), `if`(NCORE>0,sprintf("NCORE=%d",NCORE),`if`(NCORE<0,sprintf("NPAR=%d",-NCORE),NULL)), cat("LREAL=",`if`(type(LREAL,string),LREAL,`if`(nops(A)>LREAL,"A","F"))), `if`(type(ICHARG,integer),sprintf("ICHARG=%d",ICHARG),NULL), cat("LWAVE=",`if`(member("bin",output),"T","F")), `if`(tol=0,NULL,cat("PREC=",["Low","Normal","Accurate"$2][2-tol])), `if`(type(symmetry,integer),sprintf("ISYM=%d",symmetry),NULL), sprintf("ENCUT=%d",ecut), `if`(scftyp="U","ISPIN=2",NULL), `if`(occ=[],NULL,sprintf("ISMEAR=%d%s",occ[1],`if`(nops(occ)>1,cat("; SIGMA=",FormatFloat(occ[2],3,'showzero')),""))), sscf, `if`(scfmet="",NULL,sprintf(`if`(type(scfmet,string),"ALGO=%s","IALGO=%d"),scfmet)), `if`(scflim=0,NULL,cat("NELM=",scflim)), `if`(scftol>0,sprintf("EDIFF=%g" ,scftol),`if`(type(scftol,negint),sprintf("EDIFF=1E-%d" ,4-scftol),NULL)), `if`(opttol>0,sprintf("EDIFFG=-%g",opttol),`if`(type(opttol,negint),sprintf("EDIFFG=1E-%d",3-opttol),NULL)), `if`(runtype="em",cat("IBRION=",optmet,"; ISIF=",piecewise(fix="volume",4,fix="cell",2,3),"; NSW=",`if`(optlim=0,100,optlim)),NULL), `if`(type(Vmm,list),cat("MAGMOM= ",StringTools[Join](map(v->`if`(type(v,list),sprintf("%d*%a",v[2],v[1]),sprintf("%a",v)),convert2repeat(Vmm)))),NULL), `if`(LORBIT>=0,sprintf("LORBIT=%d",LORBIT),NULL), keyline],'overwrite'); if (met="VDW-DF2") then flag:=false; for path in vas_path do if FileTools[Exists](cat(path,"vdw_kernel.bindat")) then flag:=true; break end end; if flag then FileTools[Copy](cat(path,"vdw_kernel.bindat"),cat(fld,"/vdw_kernel.bindat"),'force') else WARNING("No vdw_kernel.bindat, expect slow-down of calculations") end end; if not(printout=false) then for v in ["/INCAR","/KPOINTS","/POSCAR"] do PrintFile(cat(fld,v),`if`(printout=true,NULL,`if`(type(printout,posint),printout,op(printout)))) end end end; if (not(printout=false) and program<>"vas") then PrintFile(cat(filename,xinp[program]),`if`(printout=true,NULL,`if`(type(printout,posint),printout,op(printout)))) end; if (program="vas") then i2a else NULL end end: #hfl: WriteScript WriteScript:=proc( scriptname::string, program::{"lam","tin","mop","fly","gau"}, lsinp::list(string), folder::string:="", output::list:=[], { OS::{"Windows"}:="Windows", modify::procedure:=(exe->`if`(member(program,["tin","fly"]),cat("call ",exe),exe)), overwrite::boolean:=false, append::boolean:=false, cleanup::boolean:=false, printout::{boolean,nonnegint,[nonnegint,nonnegint]}:=false },$) local fld,ls,i,input,s,fn,e; fld:={seq(ExpandPath(s,"p"),s=lsinp)}; if (nops(fld)=1) then fld:=`if`(folder="",op(fld),cat(folder,"/",op(fld))) else error("All input files must be from the same folder, but received %1",lsinp) end; ls:=table(): for i in lsinp do input:=ExpandPath(i,"n"); if (program="lam") then ls[i]:=cat(modify(lam_exe)," ",input,lam_xinp) elif (program="tin") then ls[i]:=cat(modify(tin_exe)," ",input,tin_xinp) elif (program="mop") then ls[i]:=cat(modify(mop_exe)," ",input,mop_xinp) elif (program="fly") then ls[i]:=cat(modify(fly_exe)," ",input,fly_xinp, seq(cat("\n",fly_readdump," ",input,"_scratch/DICTNRY ",input,".",e," ",e),e=output), `if`(cleanup,cat("\nrd ",input,"_scratch /s/q"),NULL)) elif (program="gau") then ls[i]:=cat(modify(gau_exe)," ",input,gau_xinp) end end; ls:=[seq(ls[i],i=lsinp)]; if (scriptname="") then for s in ls do writeline(s) end; ls else fn:=SimplifyPath(cat(fld,"/",ExpandPath(scriptname,"n"),".bat")); WriteLines(fn,ls,':-overwrite'=overwrite,':-append'=append); if not(printout=false) then PrintFile(fn,`if`(type(printout,posint),printout,`if`(type(printout,list),op(printout),NULL))) end; fn end; end: #hfl: Run Run:=proc( filename::string, { program::{"lam","tin","mop","fly","gau"}:=ExpandPath(filename,"x")[2..], OS::{"Windows"}:="Windows", cleanup::boolean:=false, test::boolean:=false, printout::boolean:=false },$) local fld,fn,s,ans; fld,fn:=ExpandPath(filename,"p,nx"); s:=piecewise(program="lam",lam_exe,program="tin",tin_exe,program="mop",mop_exe,program="fly",fly_exe,program="gau",gau_exe,undefined); s:=cat(s," ",fn); if (fld<>"") then s:=cat("""cd ",fld,"&&",s,"""") end; s:=cat("cmd /c ",s); if (test or not(printout=false)) then printf("%s\n",s) end; if not(test) then ans:=ssystem(s); if (ans[1]<>0) then error("%1 --- error: %2",s,ans) else if cleanup then CleanUp(filename) end; ans[2] end end end; #hfl: CleanUp CleanUp:=proc(filename::string,keep::list(string):=[],delete::set(string):={},$) local fld,fn,e,program,isfld,f,del; fld,fn,e:=ExpandPath(filename,"p,n,x"); program:=e[2..]; if (program="vas" and not(FileTools[Exists](cat(filename,".in")))) then FileTools[Rename](cat(filename,"/INCAR"),cat(filename,".in")) end; if member(program,{"lam","tin","mop","fly","gau","vas"}) then isfld:=FileTools[Exists](filename) and FileTools[IsDirectory](filename); if isfld then if (keep=[]) then try for f in FileTools[ListDirectory](filename) do FileTools[Remove](cat(filename,"/",f)) end; FileTools[RemoveDirectory](filename,'forceremove'); catch: WARNING("Cannot remove folder %1",filename) end else WARNING("No clean up is performed because 'keep' must be empty on folder removal (%1)",filename) end else del:=piecewise(program="tin",{".dyn"},program="mop",{".arc",".res"},program="gau",{".rwf",".chk"},{}); if not(member("input",keep)) then del:=`union`(del,piecewise(program="lam",{lam_xinp,lam_xinp2},program="tin",{tin_xinp,tin_xinp2,".key"},program="mop",{mop_xinp},program="fly",{fly_xinp},program="gau",{gau_xinp},{})) end; del:=`minus`(del,{seq(cat(".",e),e=keep)}); del:=`union`(del,{seq(cat(".",e),e=delete)}); for e in del do if FileTools[Exists](cat(fld,fn,e)) then FileTools[Remove](cat(fld,fn,e)) end end end else WARNING("No clean up is performed because of unrecognized filename extension in %1",filename) end; NULL end; #hfl: SubmitJob SubmitJob:=proc( filename::string, ppn::nonnegint:=0, { nodes::{string,nonnegint}:=0, mem::numeric:=0, extramem::nonnegint:=1, disk::numeric:=0, program::{"lam","tin","mop","gau","vas"}:=ExpandPath(filename,"x")[2..], pbsscript::string:="", runscript::string:="", workfld::string:="", usefld::boolean:=false, prefix::string:="", separator::string:="_", nochkprefix::boolean:=false, inputisthere::boolean:=false, uploadonly::boolean:=false, overwrite::boolean:=false, test::boolean:=false, printout::{boolean,nonnegint,[nonnegint,nonnegint]}:=false }) local fld,fn,ext,remfn,pbs,isfld,remfld,outcheck,ls,ins,i,e; fld,fn,ext:=ExpandPath(filename,"p,n,x"); remfn:=`if`(prefix="",fn,cat(prefix,separator,fn)); pbs:= `if`(pbsscript="",piecewise(program="lam",lam_pbs,program="tin",tin_pbs,program="mop",mop_pbs,program="gau",gau_pbs,program="vas",vas_pbs,undefined),pbsscript); if not(inputisthere) then if not(FileTools[Exists](filename)) then error("Input file does not exists: %1",filename) end; isfld:=FileTools[IsDirectory](filename); if (test or not(printout=false or printout=0)) then if not(isfld) then PrintFile(filename,`if`(type(printout,posint),printout,`if`(type(printout,list),op(printout),NULL))) end end; remfld:=`if`(workfld="",piecewise(program="lam",lam_fld,program="tin",tin_fld,program="mop",mop_fld,program="gau",gau_fld,program="vas",vas_fld,undefined),workfld); outcheck:=cat(remfld,remfn,`if`(usefld or isfld,`if`(program="vas","/OUTCAR",""),xout)); if (not(overwrite or test) and SSH[FileExists](outcheck)) then error("Output file exists: %1",outcheck) end; if (usefld or isfld) then remfld:=cat(remfld,remfn,"/") end; if (program="tin") then convert2unix(filename); ls:=ReadLines(cat(fld,fn,".key")); WriteLines(cat(fld,fn,".key"),[seq(`if`(s[..11]="parameters ",cat("parameters ",tin_res,ExpandPath(Trim(s[12..]),"nx")),s),s=ls)],':-overwrite'=true) elif (program="gau") then if (ppn=0) then error("For Gaussian ppn must be provided explicitly") end; ls:=ReadLines(filename); ls:=remove(v->StringTools[LowerCase](TrimLeft(v)[..13])="%nprocshared=" or StringTools[LowerCase](TrimLeft(v)[..5])="%mem=",ls); ins:=[`if`(ppn>1,cat("%nprocshared=",ppn),NULL),`if`(mem>0,cat("%mem=",round(mem),"GB"),NULL)]; for i from 1 to nops(ls) do if (StringTools[LowerCase](Trim(ls[i]))="--link1--") then ls:=[op(..i,ls),op(ins),op(i+1..,ls)] end end; ls:=[op(ins),op(ls)]; if not(nochkprefix) then for i from 1 to nops(ls) do if (ls[i][..4]="%rwf" or ls[i][..4]="%chk") then ls:=subsop(i=cat(ls[i][..4],"=",remfn,".",ls[i][2..4]),ls) end end end; WriteLines(filename,ls,':-overwrite'=true) elif (program="vas") then convert2unix(cat(filename,"/INCAR")) end; if not(test) then if (usefld or isfld) then SSH[run](cat("mkdir -p ",remfld)) end; if (program="vas") then SSH[put](StringTools[Join](FileTools[ListDirectory](filename)),remfld,'lcd'=filename) else SSH[runftp]([cat("put ",filename," ",remfld,remfn,ext)]); for e in piecewise(program="lam",[lam_xinp2,`if`(FileTools[Exists](cat(fld,fn,".prm")),".prm",NULL)],program="tin",[tin_xinp2,".key"],[]) do SSH[runftp]([cat("put ",fld,fn,e," ",remfld,remfn,e)]) end end end end; if not(uploadonly) then if (runscript="") then SSH[qsub](pbs,remfn,':-nodes'=nodes,':-ppn'=ppn,`if`(mem>0,':-mem'=mem+extramem,NULL),`if`(disk>0,':-disk'=disk,NULL),':-test'=test,':-printout'=`if`(printout=false,false,true),_rest) else if not(test) then SSH[run](cat(runscript," ",remfn,ext," &")) end end end end: #hfl: SubmitJob DownloadJob:=proc( filename::string, output::list({string,posint}):=[], { program::{"lam","tin","mop","gau","vas"}:=ExpandPath(filename,"x")[2..], workfld::string:="", overwrite::boolean:=false, outishere::boolean:=false, otherfiles::boolean:=false, keep::{boolean,list(string)}:=false, cleanup::{boolean,list(string)}:=false, copyfailed::boolean:=false, unix2dos::boolean:=false, prefix::string:="", separator::string:="_", printout::boolean:=false },$) local fld,fn,ext,remfn,remfld,usefld,e,del,get,rwf,cod,ls1,ls2; fld,fn,ext:=ExpandPath(filename,"p,n,x"); remfn:=`if`(prefix="",fn,cat(prefix,separator,fn)); remfld:=`if`(workfld="",piecewise(program="lam",lam_fld,program="tin",tin_fld,program="mop",mop_fld,program="gau",gau_fld,program="vas",vas_fld,undefined),workfld); # Download output file if not(outishere or otherfiles) then usefld:=evalb(SSH[FileStatus](cat(remfld,remfn))=1); if (program="vas") then if SSH[FileExists](cat(remfld,remfn,"/OUTCAR")) then SSH[run](cat("cp -f ",remfld,remfn,"/OUTCAR ",remfld,remfn,"/",remfn,xout)) else error("%1%2/OUTCAR does not exist",remfld,remfn) end end; SSH[sget](cat(remfld,remfn,`if`(usefld,cat("/",remfn),""),xout),'lcd'=fld,':-overwrite'=overwrite,':-unix2dos'='unix2dos'); # if binary file is converted then it will be corrupted if (prefix<>"") then FileTools[Rename](cat(fld,remfn,xout),cat(fld,fn,xout)) end; if printout then printf("Done %s%s\n",remfn,xout) end else if (program="vas") then FileTools[Copy](cat(fld,fn,"/OUTCAR"),cat(fld,fn,xout)) elif not(FileTools[Exists](cat(fld,fn,xout))) then FileTools[Copy](cat(fld,fn,"/",fn,xout),cat(fld,fn,xout)) end end; if IsNormalTermination(cat(fld,fn,xout)) then # Remote postprocessing if (program="gau" and output<>[]) then if SSH[FileExists](cat(remfld,remfn,".rwf")) then rwf:=cat(remfld,remfn,".rwf") elif SSH[FileExists](cat(remfld,remfn,".chk")) then rwf:=cat(remfld,remfn,".chk") else rwf="" end; for cod in output do if not(SSH[FileExists](cat(remfld,remfn,".",cod))) then if (rwf="") then error("No rwf or chk file for %s",remfn) else SSH[run](cat(gau_readdump," ",rwf," ",remfld,remfn,".",cod," ",cod)) end end end; if outishere then printf("Download gaussian binary files: %{c,}s\n",Vector(output)) end end; # Download other files and do remote cleanup if (not(outishere) or otherfiles) then if member("fld",output) then if usefld then SSH[sget](cat(remfld,remfn),'lcd'=fld); if (prefix<>"") then FileTools[Rename](cat(fld,remfn),cat(fld,fn)) end else error("There is no folder to download") end end; if (program="vas") then SSH[sget](cat(remfld,remfn,"/INCAR"),'lcd'=fld,':-overwrite'=true,':-unix2dos'='unix2dos'); FileTools[Rename](cat(fld,"INCAR"),cat(fld,fn,".vas.in"),'force'=overwrite); for e in [["bin","WAVECAR"],["chg","CHGCAR"],["dos","DOSCAR"],["pot","LOCPOT"],["dyn","DYNMAT"],["evl","EIGENVAL"],["xml","vasprun.xml"]] do if member(e[1],output) then if SSH[FileExists](cat(remfld,remfn,"/",e[2])) then SSH[sget](cat(remfld,remfn,"/",e[2]),'lcd'=fld,':-overwrite'=true,`if`(e[1]="bin",NULL,':-unix2dos'='unix2dos')); FileTools[Rename](cat(fld,e[2]),cat(fld,fn,".",e[1]),'force'=overwrite); if printout then printf("Done %s.%s\n",fn,e[1]) end else error("%1%2/%3 does not exist",remfld,remfn,e[2]) end end end else get:=`union`(`minus`({op(output)},{"fld"}),piecewise(program="lam",{seq(cat(lam_xdump,v),v=["",1,2,3]),"xyz","bin","qeq"},program="tin",{"xyz"},program="mop",{"aux","xyz","mgf"},{})); del:=`union`({ext,xout},piecewise(program="lam",{lam_xinp2,"prm","stdout"},program="tin",{tin_xinp2,"key"},program="mop",{"arc","den","res","stdout"},program="gau",{"rwf","chk"},{})); get:= map(v->`if`(v="" or v[1]=".",v,cat(".",v)),get); del:=`if`(keep=true,{},`minus`(map(v->`if`(v="" or v[1]=".",v,cat(".",v)),del),`if`(keep=false,{},{seq(cat(".",v),v=keep)}))); for e in get do if SSH[FileExists](cat(remfld,remfn,e)) then SSH[sget](cat(remfld,remfn,e),'lcd'=fld,':-overwrite'=overwrite,`if`(member(e,[".xyz",".qeq",".aux",".mgf",seq(cat(lam_xdump,v),v=["",1,2,3])]),':-unix2dos'='unix2dos',NULL)); SSH[run](cat("rm ",remfld,remfn,e)); if (prefix<>"") then FileTools[Rename](cat(fld,remfn,e),cat(fld,fn,e)) end; if printout then printf("Done %s%s\n",fn,e) end end end; for e in del do if SSH[FileExists](cat(remfld,remfn,e)) then SSH[run](cat("rm ",remfld,remfn,e)) end end end; if (usefld and keep<>true) then SSH[run](cat("rm ",remfld,remfn,"/*")); SSH[run](cat("rmdir ",remfld,remfn)) end else if (program="vas") then FileTools[Copy](cat(fld,fn,"/INCAR"),cat(fld,fn,".vas.in"),'force'=overwrite); if unix2dos then convert2dos(cat(fld,fn,".vas.in")) end; for e in [["bin","WAVECAR"],["chg","CHGCAR"],["dos","DOSCAR"],["pot","LOCPOT"],["dyn","DYNMAT"],["evl","EIGENVAL"],["xml","vasprun.xml"]] do if member(e[1],output) then FileTools[Copy](cat(fld,fn,"/",e[2]),cat(fld,fn,".",e[1]),'force'=overwrite); if (e[1]<>"bin" and unix2dos) then convert2dos(cat(fld,fn,".",e[1])) end end end elif (program="mop" and FileTools[Exists](cat(fld,fn,".aux" )) and unix2dos) then convert2dos(cat(fld,fn,".aux" )) end end; # Local cleanup and additional processing if (program="vas" and FileTools[Exists](cat(fld,fn,".evl"))) then if FileTools[Exists](cat(fld,fn,".vas/POSCAR")) then ls1:=ReadLines(cat(fld,fn,".vas/POSCAR"))[..7]; ls2:=ReadLines(cat(fld,fn,".evl")); WriteLines(cat(fld,fn,".evl"),["","\#POSCAR",op(ls1),"\#EIGENVAL",op(ls2)],':-overwrite'=true) else WARNING("No POSCAR to add to evl-file: %1",cat(fld,fn,".vas/POSCAR")) end end; if not(cleanup=false) then CleanUp(filename,`if`(cleanup=true,[],cleanup)) end; if printout then printf("Ready, %s\n",remfn) end; true else WARNING("Abnormal termination in %1, input and output are left on remote machine%2",fn,`if`(copyfailed,", output is copied to local folder","")); if copyfailed then CleanUp(filename,["input"]) else fremove(cat(fld,fn,xout)) end; false end end: #hfl: AFMorder AFMorder:=proc(Atoms::list,M::Matrix,ismagnetic::procedure:=(s->member(AtomicType(s,"L"),["d","f"])),cnn::numeric:=1.1,$) local fill,na,lsi,P,np,MD,VD,Vnn,Vmm,i,j,j1,j2,j3,V; fill:=proc(i::integer,v::integer,$) local j; if (Vmm[i]=0) then Vmm[i]:=v; for j in Vnn[i] do fill(j,-v) end end end; na:=nops(Atoms); lsi:=[seq(`if`(ismagnetic(Atoms[i][1]),i,NULL),i=1..na)]; P:=map2(op,2,Atoms[lsi]); np:=nops(P); MD:=Matrix(np,(i,j)->min(seq(seq(seq(`if`(i=j and j1=0 and j2=0 and j3=0,NULL,evalf(len(M.(P[j]+-P[i])))),j1=-1..1),j2=-1..1),j3=-1..1)),datatype=float); VD:=Vector(np,i->min(MD[i,..]),datatype=float); Vnn:=Vector(np,i->[seq(`if`(MD[i,j]<=cnn*VD[i],j,NULL),j=1..np)]); Vmm:=Vector(np,datatype=integer); for i from 1 to np do fill(i,(-1)^(1+i)) end; for i from 1 to np do for j in Vnn[i] do if (Vmm[i]=Vmm[j]) then error("Frustrated system: %1",[seq([i,Atoms[lsi[i]][1],Vmm[i]],i=1..np)]) end end end; V:=Vector(na,datatype=integer); for i from 1 to np do V[lsi[i]]:=Vmm[i] end; convert(V,list) end: #hfl: showkgrids showkgrids:=proc(Cell::{Matrix,list},dkmin::numeric,dkmax::numeric,addgrids::list([posint,posint,posint]):=[],sortindex::integer:=-1,{digits::posint:=3,printnot::boolean:=false},$) local b,dks,dk2g,dk0f,gs,g2g,g,dk,dk1,dk2,v,o,n; b:=M2cryst(evalf(2*Pi*LinearAlgebra[Transpose](`if`(type(Cell,Matrix),Cell,cryst2M(Cell))^(-1))),-1); dks:=sort(convert({dkmin,dkmax,seq(seq(Round(b[o]/(n+1/2),digits),n=max(1,ceil(b[o]/dkmax-1/2))..max(1,floor(b[o]/dkmin-1/2))),o=1..3)},list)); dk2g:=proc(dk0,b) local g,dk; g:=[seq(max(1,round(b[o]/dk0)),o=1..3)]; dk:=[seq(b[o]/g[o],o=1..3)]; [dk,g,mul(v,v=g),max(dk)/min(dk)] end; dk0f:=proc(dk1,dk2) local n,dk; for n from -1 to digits+3 do dk:=Round((dk1+dk2)/2,n); if (dk>=dk1 and dk<=dk2) then break end end; round(dk*10^digits)/10^digits end; gs:=[seq([dk0f(dks[i-1],dks[i]),dks[i-1],dks[i],dks[i]-dks[i-1],op(dk2g((dks[i-1]+dks[i])/2,b))],i=2..nops(dks))]; g2g:=proc(g,b) local dk,dk1,dk2; dk:=[seq(b[o]/g[o],o=1..3)]; dk1,dk2:=min(dk),max(dk); [dk0f(dk1,dk2),dk1,dk2,dk2-dk1,dk,g,mul(v,v=g),dk2/dk1] end; for g in addgrids do if (SearchPos(map2(op,6,gs),g)=0) then dk:=[seq(b[o]/g[o],o=1..3)]; dk1,dk2:=min(dk),max(dk); gs:=[op(gs),[dk0f(dk1,dk2),dk1,dk2,-10^(-digits-1),dk,g,mul(v,v=g),dk2/dk1]] end end; gs:=Sort(gs,[sortindex]); if not(printnot) then printf(" dk0 dkmin-dkmax w dk1 dk2 dk3 n1 n2 n3 ntot max/min\n"); seq(printf("%-*s (%*.0f-%*.0f)%*.0f %s%5d%3d%3d%6d%6.2f%s\n", digits+2,FormatFloat(v[1],1), digits,v[2]*10^digits,digits,v[3]*10^digits, digits+1,v[4]*10^digits, Vector(3,o->sprintf("%.3f",v[5][o])[2..]), op(v[6]), v[7], v[8], `if`(member(v[6],addgrids),"*","") ),v=gs) end; gs end: ################################################################################ #cat: External programs output #hfl: WhatProgram WhatProgram:=proc(filename0::string,{noerror::boolean:=false},$) local filename,s; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); s:=cat(op(ReadLines(filename,'nlines'=6))); if (SearchText("Gaussian",s)>0) then "gau" elif (SearchText("LAMMPS" ,s)>0) then "lam" elif (SearchText(" vasp." ,s)>0) then "vas" elif (SearchText("MOPAC20" ,s)>0) then "mop" elif (SearchText("FHI-aims",s)>0) then "fhi" elif (SearchText("TINKER" ,s)>0) then "tin" elif (SearchText("Firefly" ,s)>0) then "fly" else if type(SearchFilePos(filename,"*** PROGRAM SYSTEM MOLPRO ***",':-noerror'=true),[posint,posint]) then "mpr" else if noerror then "" else error("Unrecognized program for %1",filename) end end end end: #hfl: WhatProgram IsNormalTermination:=proc(filename0::string,{program::{"lam","tin","mop","fly","gau","mpr","fhi","vas"}:=WhatProgram(filename0)},$) local filename,v; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); if (program="lam") then v:=SearchFilePos(filename,"Execution terminated normally",'noerror'); if (v=NULL) then v:=SearchFilePos(filename,"Total wall time:",'noerror') end elif (program="tin") then v:=`if`(nops(ReadLines(filename))>20,[1,1],[]) elif (program="mop") then v:=SearchFilePos(filename,"== MOPAC DONE ==",'noerror') elif (program="fly") then v:=SearchFilePos(filename,"EXECUTION OF FIREFLY TERMINATED NORMALLY",'noerror') elif (program="gau") then v:=SearchFilePos(filename,"Normal termination of Gaussian",'noerror') elif (program="mpr") then v:=SearchFilePos(filename,"Molpro calculation terminated",'noerror') elif (program="fhi") then v:=SearchFilePos(filename,"Leaving FHI-aims",'noerror') elif (program="vas") then v:=SearchFilePos(filename,"General timing and accounting informations for this job:",'noerror') else return 'undefined' end; if (v=[]) then false else true end end: #hfl: ReadAtoms ReadAtoms:=proc( filename0::{string,integer}, number::{integer,"input","ending"}:=-1, i2a0::list(string):=[], tmap0::list(posint):=[9], linenumber::symbol:=undefined, { program::{"lam","tin","mop","fly","gau","fhi","vas"}:=WhatProgram(filename0), cartesians::boolean:=false, full1st::boolean:=false, offset::list:=[0,0,0], opt4ReadLines::list:=[], printout::boolean:=false },$) local filename,Atoms,ls,i,i0,Cell,na,BC,M,o,rec,tb,e,L,p,internals,optflags,c,s,j,i2a,tmap,perm,lsn,atoms,Tvs,sep,T2,v,u,l; filename:=`if`(type(filename0,integer) or FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,piecewise(program="lam",lam_xdump,program="tin",".xyz",xout))); Atoms:=table(): if (type(filename,string) and ExpandPath(filename,"nx")="PUNCH") then ls:=ReadLines(filename,"COORDINATES",number,s->evalb(s[1..3]="---"),'shift'=3); for i from 1 to nops(ls) do e:=sscanf(ls[i],"%s%f%{3}fc"); Atoms[i]:=[StringTools[Capitalize](e[1]),e[3]] end else if (program="lam") then na:=ReadValue(filename,"ITEM: NUMBER OF ATOMS",'shift'=1,'format'="%d"); ls:=ReadLines(filename,"ITEM: BOX BOUNDS ",'shift'=0,'nlines'=4); BC:=remove(`=`,StringTools[Split](ls[1][17..]),""); ls:=map(sscanf,ls[2..],"%f%f%f"); M:=Matrix(3,datatype=float); for o from 1 to 3 do M[o,o]:=ls[o][2]-ls[o][1] end; if (nops(BC)=3) then elif (nops(BC)=6 and BC[..3]=["xy","xz","yz"]) then M[1,2],M[1,3],M[2,3]:=seq(ls[o][3],o=1..3); M[1,1]:=M[1,1]-abs(M[1,2])-abs(M[1,3]); M[2,2]:=M[2,2]-abs(M[2,3]) else error("Unrecognized BC: %1",BC) end; ls:=ReadLines(filename,"ITEM: ATOMS ",'shift'=0,'nlines'=na+1): rec:=remove(`=`,StringTools[Split](ls[1][12..]),""); if not(nops(rec)>=4 and (rec[..4]=["element","x","y","z"] or rec[..4]=["element","xu","yu","zu"])) then error("Unsupported format of dump file: %1",rec) end; Atoms:=[seq(sscanf(ls[1+i],"%s%{3}fc"),i=1..na)]; Atoms:=[op(Atoms),seq(`if`(BC[o-4]="pp",[tvsymbol9,M[..,o]],NULL),o=1..3)] elif (program="tin") then ls:=ReadLines(filename); na:=op(sscanf(ls[1],"%d")); Cell:=sscanf(ls[2],"%f%f%f%f%f%f"); i0:=`if`(nops(Cell)=6,2,1); if (nops(ls)[`if`(assigned('tb[v[1]]'),tb[v[1]],v[1]),v[2]],Atoms) elif (program="mop") then ls:=ReadLines(filename,"CURRENT VALUE OF HEAT OF FORMATION",s->evalb(Trim(s)=""),'shift'=4); if (ls=[]) then ls:=ReadLines(filename,"CURRENT VALUE OF GEOMETRY",s->evalb(Trim(s)=""),'shift'=5) end; if (ls<>[]) then for i from 1 to nops(ls) do e:=sscanf(ls[i],"%s%f%d%f%d%f%d"); Atoms[i]:=[StringTools[Capitalize](e[1]),Vector([e[2],e[4],e[6]],datatype=float)] end else if cartesians then ls:=ReadLines(filename,"CARTESIAN COORDINATES",`if`(number="input",1,`if`(number="ending",-1,number)),'shift'=2); for i from 1 to nops(ls) do e:=sscanf(ls[i],"%d%s%{3}fc"); if (nops(e)=3) then Atoms[i]:=[StringTools[Capitalize](e[2]),e[3]] else break end end else ls:=ReadLines(filename," ATOM CHEMICAL",1..18,`if`(number="input",1,`if`(number="ending",-1,number)),'shift'=2); if (ls=[]) then ls:=ReadLines(filename," ATOM CHEMICAL",1..18,`if`(number="input",1,`if`(number="ending",-1,number)),'shift'=2) end; internals:=evalb(length(ls[1])>9); ls:=ls[2..]; for i from 1 to nops(ls) do e:=sscanf(ls[i],"%d%s%f%[ *]%f%[ *]%f%[ *]%d%d%d"); if (nops(e)<>8 and nops(e)<>11) then i:=i+1; break end; optflags:=[seq(piecewise(c="",0,c="*",1,9),c=map(Trim,[e[4],e[6],e[8]]))]; Atoms[i]:=[StringTools[Capitalize](e[2]),`if`(nops(e)=8, , [e[9],e[3],e[10],e[5],e[11],e[7]] ), `if`(optflags=[1,1,1],NULL,optflags)] end; if (internals and not(full1st) and i>1 and nops(Atoms[1])=3 and Atoms[1][3]=[0,0,0] and Atoms[1][2][1]=0. and Atoms[1][2][2]=0. and Atoms[1][2][3]=0.) then Atoms[1]:=[Atoms[1][1],[]] end; if (internals and i>2 and nops(Atoms[2])=3 and Atoms[2][3][2..3]=[0,0] and Atoms[2][2][2]=0. and Atoms[2][2][3]=0.) then Atoms[2]:=[Atoms[2][1],[1,Atoms[2][2][1]],`if`(Atoms[2][3]=[1,0,0],NULL,[0])] end; if (internals and i>3 and nops(Atoms[3])=3 and nops(Atoms[3][2])=6 and Atoms[3][2][5]=0 and Atoms[3][2][6]=0. and Atoms[3][3][3]=0) then Atoms[3]:=[Atoms[3][1],Atoms[3][2][1..4],`if`(Atoms[3][3]=[1,1,0],NULL,Atoms[3][3][1..2])] end end end elif (program="fly") then ls:=ReadLines(filename,"COORDINATES OF ALL ATOMS ARE (ANGS)",number,'shift'=3); if (ls=[]) then c:=bohr2A; ls:=ReadLines(filename,"ATOM ATOMIC COORDINATES (BOHR)",'shift'=2) else c:=1 end; for i from 1 to nops(ls) do e:=sscanf(ls[i],"%s%f%{3}fc"); Atoms[i]:=[StringTools[Capitalize](e[1]),c*e[3]] end elif (program="gau") then if (number="input") then ls:=ReadLines(filename," Symbolic Z-Matrix:",s->evalb(s=" "),'shift'=1); if ls=[] then ls:=ReadLines(filename," Symbolic Z-matrix:",s->evalb(s=" "),'shift'=2) end; for i from 1 to nops(ls) do Atoms[i]:=sscanf(ls[i],"%s%{3}fc") end elif (number="ending") then ls:=ReadLines(filename); for i from nops(ls) by -1 to 1 do if (ls[i]<>"" and ls[i][-1]="@") then sep:=`if`(length(ls[i])<3,ls[i-1][-1],ls[i][-2]); if member(sep,["\\","|"]) then ls:=ls[..i]; break end end end; if (i<3) then error("Cannot locate ending") end; L:=length(ls[-2]); for i from -2 by -1 to -infinity while (length(ls[i])=L or SearchText(sep,ls[i])>0) do end; s:=StringTools[Join](map(s->s[2..],ls[i..]),""); L:=length(s); i:=SearchText(cat(sep,sep,sep),s); for v from -2 to 2 while (i=0 or L-i<10) do i:=SearchText(cat(sep,sep,v,","),s) end; if (i=0) then error("Cannot locate starting separator for coordinates in %1",s) end; s:=s[i+3..]; i:=SearchText(cat(sep,sep),s); if (i=0) then error("Cannot locate trailing separator for coordinates in %1",s) end; ls:=map(StringTools[Split],StringTools[Split](s[..i-1],sep)[2..],","); Atoms:=[seq([`if`(v[1]="TV",tvsymbol9,v[1]),Vector(map(op@sscanf,v[-3..-1],"%f"),datatype=float)],v=ls)]; else ls:=`if`(opt4ReadLines=[],ReadLines(filename,"Center Atomic Atomic Coordinates (Angstroms",number,s->evalb(s[1..4]=" ---"),'shift'=3),ReadLines(filename,op(opt4ReadLines))); for i from 1 to nops(ls) do e:=sscanf(ls[i],"%d%d%d%{3}fc"); if (e[2]=0) then next else Atoms[i]:=[`if`(e[2]=-2,tvsymbol9,ElementSymbol[e[2]]),e[4]] end end end elif (program="fhi") then s:=`if`(number=-1,"Final atomic structure:","Updated atomic structure:"); ls:=ReadLines(filename,s,number,'shift'=6); for i from 1 to nops(ls) do e:=sscanf(ls[i]," atom %{3}fc%s"); Atoms[i]:=[StringTools[Capitalize](e[2]),e[1]] end; ls:=ReadLines(filename,s,number,'shift'=2,'nlines'=3); for j from 1 to nops(ls) do e:=sscanf(ls[j]," lattice_vector %{3}fc"); Atoms[i-1+j]:=[tvsymbol9,e[1]] end elif (program="vas") then s:=ReadValue(filename," POSCAR = "); if (i2a0=[]) then v:=ReadBody(s," i2a=[","]",'noerror'); if (v="") then error("Provide i2a") end; i2a:=StringTools[Split](v,",") else i2a:=i2a0 end; tmap:=`if`(tmap0=[9],ReadRecord(s,"tmap::list:=[$1..3]",'input'="string"),tmap0); s:=ReadValue(filename,"ions per type ="); lsn:=map(op@sscanf,remove(`=`,StringTools[Split](s," "),""),"%d"); if (nops(lsn)<>nops(i2a)) then error("Inconsistent lsn=%1 and i2a=%2",lsn,i2a) end; atoms:=[seq(i2a[l]$lsn[l],l=1..nops(i2a))]; ls:=ReadLines(filename," POTCAR:",'shift'=0,'nlines'=nops(i2a)); if printout then for s in ls do printf("%s\n",s) end end; for i from 1 to nops(i2a) do if (searchtext(i2a[i],ls[i])=0) then WARNING("Checking i2a: no %1 is found in %2",i2a[i],ls[i]) end end; i0:=SearchFilePos(filename,"VOLUME and BASIS-vectors are now",number,op(opt4ReadLines))[1]; if not(linenumber=undefined) then assign(linenumber,i0) end; ls:=ReadLines(filename,'shift'=i0+4,'nlines'=3); Tvs:=map(op@sscanf,ls,"%{3}fc"); ls:=ReadLines(filename,"POSITION TOTAL-FORCE (eV/Angst)",s->evalb(s[..3]=" --"),'skiplines'=i0,'shift'=2); if (nops(ls)<>add(v,v=lsn)) then error("nops(Atoms)=%1<>%2=add(v,v=lsn), lsn=%3",nops(ls),add(v,v=lsn),lsn) end; Atoms:=map(op@sscanf,ls,"%{3}fc"); na:=nops(Atoms); if (type(filename,string) and FileTools[Exists](cat(ExpandPath(filename,"pn"),".vas.in"))) then s:=ReadValue(cat(ExpandPath(filename,"pn"),".vas.in"),"SYSTEM",1..7); perm:=`if`(s=NULL,[],ReadRecord(s,"perm::list",'input'="string")); if (perm=[]) then perm:=[$1..na] elif (nops(perm)<>na) then error("Wrong perm: %1") end else perm:=[$1..na] end; T2:=[seq(`if`(member(o,tmap),NULL,[Tvs[o],1/add(v^2,v=Tvs[o]),offset[o]]),o=1..3)]; Atoms:=[seq([atoms[i],`if`(T2=[],Atoms[i],Atoms[i]-add(floor(u[2]*Atoms[i].u[1]-u[3])*u[1],u=T2))],i=perm),seq([tvsymbol9,Tvs[o]],o=tmap)] end end; convert(Atoms,list) end: #hfl: ReadOutput ReadOutput:=proc( filename0::string, key::{string,"in","A","na","charge","mult","SG","ESS","E","F","ZPE","G","H","BS","DBS","N","No","Nk","KPOINTS","kgrid","Ne","Na","Nb","EFermi","evl","evla","evlb","Sz","S2","dS2","d","Q","q","md","EM","EM1","EM2","nopt"}, key2::{"","raw","Mul","NBO","ESP","CM5","Hir"}:="", number::integer:=`if`(member(key,["N","No","Nk","KPOINTS","kgrid","Ne","Na","Nb","BS"]),1,-1), { program::{"lam","tin","mop","fly","gau","mpr","fhi","vas"}:=WhatProgram(filename0), simplesearch::boolean:=false },$) local k,v,v1,v2,filename,units,ls,n,n1,n2,evl,res,tags,m,s,tb,i,i0,fn,e,p,s2,E2,GetKeyword,scftype,dfttype,mplevel,citype,dentype,L,N,ac,fmt,A,V,M,no,nk,kps,evs,occ,o,ls2; if (key="A") then return ReadAtoms(filename0,number,':-program'=program) end; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); if (SearchText(",",key)>0) then seq(ReadOutput(filename,s,key2),s=StringTools[Split](key,",")) elif (key[..4]="evl(" or key[..5]="evla(" or key[..5]="evlb(") then k:=key[..`if`(key[4]="(",3,4)]; ls:=sscanf(key,cat(k,"(%d:%d)")); if (nops(ls)=2) then n1,n2:=op(ls) elif (nops(ls)=1) then n1,n2:=op(ls),op(ls) else error("Unrecognized key: %1",key) end; if (n1<0 or n2<0) then error("Unrecognized key: %1",key) end; evl:=ReadOutput(filename,k,number); if type(evl,list) then if (n1>1 or n2>1) then error("Only HOMO and LUMO can be requested in evl(n1:n2) for k-space calculations but key=%1",key) end; v1,v2:=DetermineBandGap(op(evl)); [`if`(n1=1,v1[4],NULL),`if`(n2=1,v2[4],NULL)] else n:=ReadOutput(filename,`if`(k="evlb","Nb","Na"),number); [seq(evl[o],o=max(1,n-n1+1)..min(n+n2,Dim2(evl)))] end else res:=NULL; # lam if (program="lam") then units:=ReadValue(filename,"units ",1..6,'format'="%s"); if (key="na") then res:=ReadValue(filename," reading atoms ..." ,1..20,number,'shift'=1,'format'="%d") elif (key="E") then res:=ReadValue(filename,"Final potential energy =",1..24,number,'format'="%f")*`if`(units="real",kcalmol2eV,1) elif (key="F") then res:=ReadValue(filename,"Final total energy =" ,1..20,number,'format'="%f")*`if`(units="real",kcalmol2eV,1) elif (key="G") then res:=ReadValue(filename,"Final gradient norm =" ,1..21,number,'format'="%f")*`if`(units="real",kcalmol2eV,1) elif (key="md") then tb,i0:=table(),0; for k from 1 to infinity do ls:=ReadLines(filename,"Step ",1..9,k,'shift'=0); if (ls=[]) then break end; tags:=remove(`=`,StringTools[Split](ls[1]," "),""); if (k=1) then tb[1]:=tags elif (tb[1]<>tags) then WARNING("Inconsistent tags: %1 vs %2",tb[1],tags) end; m:=nops(tags); s:=cat("%f"$m); for i from 2 to nops(ls) do v:=sscanf(ls[i],s); if (nops(v)=m) then tb[i0+i]:=v else break end end; i0:=i0+nops(ls) end; res:=convert(tb,list) else error("Unrecognized lam key: %1",key) end # tin elif (program="tin") then if (key="E") then res:=ReadValue(filename,"Total Potential Energy :",number,'format'="%f")*kcalmol2eV; if not(type(res,numeric)) then res:=ReadValue(filename,"Final Function Value :",number,'format'="%f")*kcalmol2eV end else error("Unrecognized tin key: %1",key) end # mop elif (program="mop") then if (key="in") then res:=Trim(op(ReadLines(filename," ***",1..4,6,'nlines'=1))) elif (key="E") then res:=ReadValue(filename,"FINAL HEAT OF FORMATION",number,'format'=" = %f")*kcalmol2eV elif (key="E_old") then res:=ReadValue(filename,"TOTAL ENERGY",number,'format'=" = %f") elif (key="G") then res:=ReadValue(filename,"GRADIENT NORM =",number,'format'="%f")*kcalmol2eV elif (key="N") then ls:=ReadLines(filename,"EIGENVALUES",number); if (ls<>[]) then res:=nops([seq(op(sscanf(s,cat("%f"$8))),s=ls)]) else fn:=cat(ExpandPath(filename,"pn"),".aux"); if FileTools[Exists](fn) then res:=ReadValue(fn," AO_ATOMINDEX[",'format'="%d"); WARNING("N is read from aux-file %1",fn) else error("Cannot find N in %1 and aux-file %2 does not exists",filename,fn) end end elif (key="Ne") then res:=ReadValue(filename,"NO. OF ALPHA ELECTRONS",number,'format'=" = %d"); if (res=NULL) then res:=2*ReadValue(filename,"NO. OF FILLED LEVELS",number,'format'=" = %d"); e:=ReadValue(filename,"NO. OF OPEN LEVELS",number,'format'=" = %d"); if (e=NULL) then elif (e=1) then res:=res+1 else res:=undefined end else res:=res+ReadValue(filename,"NO. OF BETA ELECTRONS",number,'format'=" = %d") end elif (key="Na") then res:=ReadValue(filename,"NO. OF ALPHA ELECTRONS",number,'format'=" = %d"); if (res=NULL) then res:=ReadValue(filename,"NO. OF FILLED LEVELS",number,'format'=" = %d") end elif (key="Nb") then res:=ReadValue(filename,"NO. OF BETA ELECTRONS",number,'format'=" = %d"); if (res=NULL) then res:=ReadValue(filename,"NO. OF FILLED LEVELS",number,'format'=" = %d") end elif (key="evl") then res:=op(sscanf(StringTools[Join](ReadLines(filename,"EIGENVALUES")," "),"%{;h}fc")) elif (key="S2") then res:=ReadValue(filename,"(S**2) =",number,'format'="%f") elif (key="d" ) then res:=Vector([ReadValue(filename,"DIPOLE X Y Z TOTAL",number,'shift'=3,'format'=" SUM %f %f %f")],datatype=float)*D2eA; v:=ReadValue(filename," CHARGE ON SYSTEM =",number,'format'="%d"); if type(v,integer) then A:=ReadAtoms(filename); res:=res+v*add(AtomMass(A[i][1])*A[i][2],i=1..nops(A))/add(AtomMass(A[i][1]),i=1..nops(A)) end elif (key="q" ) then ls:=ReadLines(filename,"NET ATOMIC CHARGES",number,s->evalb(s="" or s[1..2]<>" "),'shift'=3); res:=table(): for i from 1 to nops(ls) do e:=sscanf(ls[i],"%d%s%f"); if (nops(e)=3) then res[i]:=e[3] else break end end; res:=convert(res,list) else error("Unrecognized mop key: %1",key) end # fly elif (program="fly") then if (key="in") then ls:=ReadLines(filename," INPUT CARD>",'shift'=0); ls:=[seq(`if`(s[..12]=" INPUT CARD>",Trim(s[13..]),NULL),s=ls)]; ls:=select(s->evalb(s[1]="$"),ls); for i from 1 to nops(ls) while not (ls[i][..5]="$DATA") do end; res:=StringTools[Join](map(Trim,ls[..i-1]),"\n") elif (key="E") then GetKeyword:=proc(key) local key2,s,i; key2:=key; s:=ReadValue(filename,key2,'startofline'); if not(type(s,string) and s[..12]=" INPUT CARD>") then key2:=StringTools[LowerCase](key); s:=ReadValue(filename,key2,'startofline') end; if (type(s,string) and s[..12]=" INPUT CARD>") then i:=searchtext(key2,s); s:=s[i+length(key2)..]; StringTools[UpperCase](Trim(op(sscanf(TrimLeft(s),"=%s")))) else piecewise(key="RUNTYP","ENERGY",key="SCFTYP","RHF",key="MPLEVL","0","") end end; scftype:=GetKeyword("SCFTYP"); scftype:=piecewise(scftype="RHF","R",scftype="UHF","U",scftype="ROHF","RO",'undefined'); dfttype:=GetKeyword("DFTTYP"); mplevel:=GetKeyword("MPLEVL"); citype:=GetKeyword("CITYP"); if (mplevel="4") then res:=hartree2eV*ReadValue(filename,"E(MP4-SDQ) =",'format'="%f") else dentype:=`if`(dfttype<>"",cat(scftype,"-",`if`(dfttype="LSDA","SLATER",dfttype)), `if`(mplevel<>"0",cat("MP",mplevel), `if`(citype<>"","CI",cat(scftype,"HF")))); i0:=SearchFilePos(filename,cat(" properties for the ",dentype," density"),number)[1]; res:=hartree2eV*ReadValue(filename," TOTAL ENERGY =",'format'="%f",'skiplines'=i0) end elif (key="G" ) then res:=ReadValue(filename," RMS GRADIENT",number,'format'=" = %f")*hartree2eV/bohr2A elif (key="N" ) then res:=ReadValue(filename," TOTAL NUMBER OF BASIS FUNCTIONS",number,'format'=" = %d") elif (key="Ne") then res:=ReadValue(filename," NUMBER OF ELECTRONS",number,'format'=" = %d") elif (key="Na") then res:=ReadValue(filename," NUMBER OF OCCUPIED ORBITALS (ALPHA)",number,'format'=" = %d") elif (key="Nb") then res:=ReadValue(filename," NUMBER OF OCCUPIED ORBITALS (BETA )",number,'format'=" = %d") elif (key="S2") then res:=ReadValue(filename," S-SQUARED",number,'format'=" = %f") elif (key="d" ) then res:=Vector([ReadValue(filename," DX DY DZ /D/ (DEBYE)",number,'shift'=1,'format'="%f%f%f")],datatype=float)*D2eA elif (key="q") then ls:=ReadLines(filename," TOTAL MULLIKEN AND LOWDIN ATOMIC POPULATIONS",number,'shift'=2); res:=table(): for i from 1 to nops(ls) do e:=sscanf(ls[i][17..],"%f"); if (nops(e)=1) then res[i]:=e[1] else break end end; res:=convert(res,list) else error("Unrecognized fly key: %1",key) end # gau elif (program="gau") then if (key="in") then res:=Trim(StringTools[Join](map(s->`if`(s[1]=" ",s[2..],s),ReadLines(filename," #",1..2,s->s[..4]=" ---",'shift'=0)),"")) elif (key="na") then res:=ReadValue(filename," NAtoms=",number,'format'="%d") elif (key="charge") then res:=ReadValue(filename," Charge =",1,'format'="%d") elif (key="mult") then res:=ReadValue(filename," Multiplicity =",1,'format'="%d") elif (key="SG") then res:=ReadValue(filename," Full point group ",number,'format'="%s") elif (key="ESS") then res:=ReadValue(filename," The electronic state ",number); if (res=NULL) then res:="" else res:=StringTools[Split](res)[-1]; if (res<>"" and res[-1]=".") then res:=res[..-2] end end elif (key="E") then s,res:=ReadValue(filename,"SCF Done: E(",number,'format'="%s = %f"); if not(simplesearch) then m:=StringTools[Split](ReadOutput(filename,"in")," ")[2]; if member(m,["G2","G3","G4","CBS-QB3","W1BD"]) then res:=ReadValue(filename,"(0 K)=",'format'="%f")-ReadValue(filename,"E(ZPE)=",'format'="%f") elif member(m,["G2(sp)","G3(sp)","G4(sp)","CBS-QB3(sp)","W1BD(sp)"]) then s2:=piecewise(m="CBS-QB3(sp)"," E(CBS-QB3)=",m="W1BD(sp)"," W1BD Electronic Energy",m[1]="G",cat(" G",m[2]," Energy="),undefined); res:=ReadValue(filename,s2,'format'="%f") elif (s="RHF)" or s="UHF)") then # post-HF if (m="HF") then s2:=NULL elif (m="MP2") then s2:=ReadValue(filename," EUMP2 =" ,number) elif (m="CCSD-T") then s2:=ReadValue(filename," CCSD(T)=",number) elif member(m,["CCD","CCSD","QCISD"]) then if (number=-1) then s2:=ReadValue(filename," E(CORR)=",-1) else error("For CI and CC methods only last energy can be read, but number=%1",number) end elif member(m,["CIS","CID","CISD"]) then if (number=-1) then s2:=ReadValue(filename," E(CI)=" ,-1) else error("For CI and CC methods only last energy can be read, but number=%1",number) end elif (m="MP3") then s2:=ReadValue(filename," EUMP3=",number) elif (m="MP4-SDQ") then s2:=ReadValue(filename," UMP4(SDQ)=",number) elif (m="MP4") then s2:=ReadValue(filename," UMP4=",number) else error("Unsupported post-HF method in %1: %2",filename,m) end; if type(s2,string) then res:=op(sscanf(StringTools[Substitute](s2,"D","E"),"%f")) end else # DFT try DecodeMethod(cat(StringTools[UpperCase](s[..-2]),"p2"),["S-VWN"="LDA","PBE-PBE"="PBE","PBE1PBE"="PBE","HSEH1PBE"="HSE06"]) catch: WARNING("Unable to decode method in %1",s[1..-2]) end end; E2:=ReadValue(filename," Counterpoise: corrected energy =",number,'format'="%f"); if type(E2,numeric) then res:=E2 end; try E2:=ReadValue(filename," Total Energy, E(TD-HF/TD-",number,'format'="%s = %f")[2]; if type(E2,numeric) then res:=E2 end catch: end; end; res:=res*hartree2eV elif (key="ZPE") then res:=ReadValue(filename,"Zero-point vibrational energy",number,'format'="%f")*kJmol2eV/1000; if not(simplesearch) then m:=StringTools[Split](ReadOutput(filename,"in")," ")[2]; if member(m,["G2","G3","G4","CBS-QB3","W1BD"]) then res:=ReadValue(filename,"E(ZPE)=",'format'="%f")*hartree2eV end end elif (key="G") then ls:=ReadLines(filename,"Forces (Hartrees/Bohr)",-1,s->evalb(Trim(s)[1]="-"),'shift'=3); if (ls<>[]) then res:=Matrix([seq(sscanf(v,"%d %d %f %f %f")[3..5],v=ls)],datatype=float)*hartree2eV/bohr2A else ls:=ReadLines(filename," Variable Old X -DE/DX ",number,s->evalb(Trim(s[..6])=""),'shift'=2); if (ls=[]) then error("No forces in %1",filename) end; res:=LinearAlgebra[Transpose](ArrayTools[Reshape](Vector(nops(ls),i->sscanf(ls[i],"%s %f %f")[3],datatype=float)*hartree2eV/bohr2A,3,nops(ls)/3)) end elif (key="BS" or key="DBS") then ls:=ReadLines(filename,`if`(key="BS","AO basis set","Density basis set"),number,'nlines'=10^9); if (ls=[]) then res:=[] else res:=table(); k:=1; while (ls[k][..6]=" Atom ") do v:=sscanf(ls[k]," Atom %s Shell %d%s%d bf %d - %d %{3}fc"); i:=parse(StringTools[Select](StringTools[IsDigit],v[1])); L:=v[3]; N:=v[6]-v[5]+1; s:=LtN2shell(L,N); fmt:=cat("%f"$(length(L)+1)); ac:=[seq(sscanf(StringTools[SubstituteAll](s,"D","e"),fmt),s=ls[k+1..k+v[4]])]; res[k]:=[i,s,ac,1,v[1]]; k:=k+v[4]+1 end; res:=convert(res,list) end elif (key="N" ) then res:=op(sscanf(op(ReadLines(filename," basis functions,",number,'shift'=0,'nlines'=1)),"%d")) elif (key="Na") then res:=op(sscanf(op(ReadLines(filename," alpha electrons",number,'shift'=0,'nlines'=1)),"%d")) elif (key="Nb") then res:=ReadValue(filename,"alpha electrons",number,'format'="%d") elif (key="evl" or key="evla") then i0:=SearchFilePos(filename,"SCF Done",number)[1]; res:=hartree2eV*op(sscanf(StringTools[SubstituteAll](StringTools[Join](map(s->s[28..],ReadLines(filename,"Alpha occ. eigenvalues",s->s[..2]=" ",'shift'=0,'skiplines'=i0))," "),"-"," -"),"%{;h}fc")) elif (key="evlb") then i0:=SearchFilePos(filename,"SCF Done",number)[1]; res:=hartree2eV*op(sscanf(StringTools[SubstituteAll](StringTools[Join](map(s->s[28..],ReadLines(filename,"Beta occ. eigenvalues",s->s[..3]=" ",'shift'=0,'skiplines'=i0))," "),"-"," -"),"%{;h}fc")) elif (key="sym") then i0:=SearchFilePos(filename,"SCF Done",number)[1]; ls:=ReadLines(filename,"Orbital symmetries:",s->s[..5]<>" " and s[..7]<>" Alpha " and s[..6]<>" Beta ",'shift'=1,'skiplines'=i0); if (ls<>[] and ls[1][2..15]="Alpha Orbitals") then for i from 2 to nops(ls) do if (ls[i][2..15]="Beta Orbitals") then break end end; if (i>nops(ls)) then error("No beta orbitals in %1",ls) end; res:=[map(Trim,map(op@StringTools[Split],map(s->s[18..],ls[2..i-1])," "),[" ","(",")"]), map(Trim,map(op@StringTools[Split],map(s->s[18..],ls[i+1.. ])," "),[" ","(",")"])] else res:=map(Trim,map(op@StringTools[Split],map(s->s[18..],ls)," "),[" ","(",")"]) end elif (key="Sz") then res:=ReadValue(filename,"=",number,'format'="%f"); if (res=NULL) then res:=0 end elif (key="S2") then i0:=SearchFilePos(filename,"SCF Done",number)[1]; res:=ReadValue(filename,"=",'skiplines'=i0,'format'="%f") elif (key="dS2") then i0:=SearchFilePos(filename,"SCF Done",number)[1]; res:=ReadValue(filename,"=",'skiplines'=i0,'format'="%f"); if (res<>NULL) then v:=ReadValue(filename,"=",'skiplines'=i0,'format'="%f"); if (v<>NULL) then res:=res-v*(v+1) end end elif (key="d") then res:=Vector([ReadValue(filename,"Dipole moment (field-independent basis, Debye):",number,'shift'=1,'format'=" X=%f Y=%f Z=%f")],datatype=float)*D2eA elif (key="Q") then ls:=ReadLines(filename,"Traceless Quadrupole moment (field-independent basis, Debye-Ang):",number,'nlines'=2); ls:=[op(sscanf(ls[1]," XX=%f YY=%f ZZ=%f")),op(sscanf(ls[2]," XY=%f XZ=%f YZ=%f"))]; res:=Matrix(3,shape=symmetric,datatype=float); res[1,1]:=ls[1]*D2eA*3; res[2,2]:=ls[2]*D2eA*3; res[3,3]:=ls[3]*D2eA*3; res[1,2]:=ls[4]*D2eA*3; res[1,3]:=ls[5]*D2eA*3; res[2,3]:=ls[6]*D2eA*3 elif (key="q") then if (key2="" or key2="Mul") then i,p:=2,12; for s in [" Mulliken atomic charges:"," Mulliken charges:","Mulliken charges and spin densities:"] while (SearchFilePos(filename,s,number,'noerror')=[]) do end elif (key2="NBO") then i,p,s:=6,14," Summary of Natural Population Analysis:" elif (key2="ESP") then i,p,s:=3,12," Charges from ESP fit, RMS=" elif (key2="CM5") then i,p,s:=2,67," Hirshfeld charges, spin densities, dipoles, and CM5 charges" elif (key2="Hir") then i,p,s:=2,12," Hirshfeld charges, spin densities, dipoles, and CM5 charges" else error("For key=q, key2 must be one of [""=Mul(liken),NBO,ESP,CM5,Hir(shfeld)], but received %1",key2) end; ls:=ReadLines(filename,s,`if`(key2="NBO",1,number),s->evalb(s="" or s[..2]<>" " or s[..8]=" "),'shift'=i); if (ls<>[] and member(key2,["CM5","Hir"])) then ls:=ls[..-2] end; res:=table(): for i from 1 to nops(ls) do e:=sscanf(ls[i][p..],"%f"); if (nops(e)=1) then res[i]:=e[1] else break end end; res:=convert(res,list) elif (key="nopt") then res:=ReadValue(filename," Step number ",1..13,-1,'format'="%d") else error("Unrecognized gau key: %1",key) end # mpr elif (program="mpr") then if (key="in") then res:=Trim(StringTools[Join](map(s->`if`(s[1]=" ",s[2..],s),ReadLines(filename," ***",1..4,s->s[..10]=" geometry=",'shift'=0)),"\n")) elif (key="E") then res:=ReadValue(filename," energy= ",number,'format'="%f")*hartree2eV else error("Unrecognized mpr key: %1",key) end # fhi elif (program="fhi") then if (key="in") then res:="Too many lines" elif (key="E") then res:=ReadValue(filename,`if`(number=-1,"Final zero-broadening corrected energy (caution - metals only) :","Total energy corrected :"),number,'format'="%f") else error("Unrecognized fhi key: %1",key) end # vas elif (program="vas") then if (key="in") then res:=StringTools[SubstituteAll](StringTools[Join](map(Trim,ReadLines(filename," INCAR:",1,s->evalb(s="" or s[..8]=" POTCAR:"))),"; ")," = ","=") elif (key="na") then res:=ReadValue(filename," NIONS =",number,'format'="%d") elif (key="SG") then res:=ReadValue(filename,"The static configuration has the point symmetry",number,'format'="%s"); if (type(res,string) and res<>"" and res[-1]=".") then res:=res[..-2] end elif (key="ESS") then res:="" elif (key="E") then res:=ReadValue(filename,"energy(sigma->0) =",number,'format'="%f"); if (res=NULL) then res:=ReadValue(filename,"energy without entropy=",number,'format'="%f") end elif (key="F") then res:=ReadValue(filename,"free energy TOTEN =" ,number,'format'="%f") elif (key="G") then ls:=ReadLines(filename," TOTAL-FORCE (eV/Angst)",number,s->s[2..4]="---",'shift'=2); n:=nops(ls); M:=Matrix(n,3,datatype=float); for i from 1 to n do M[i,..]:=op(sscanf(ls[i],"%{6}fc"))[4..6] end; res:=M elif (key="H") then ls:=ReadLines(filename," SECOND DERIVATIVES (NOT SYMMETRIZED)",number,s->Trim(s)="",'shift'=3); n:=nops(ls); M:=Matrix(n,datatype=float); for i from 1 to n do M[i,..]:=-op(sscanf(ls[i][6..],"%{*}fr",n)) end; res:=`if`(key2="raw",M,Matrix(n,(i,j)->(M[i,j]+M[j,i])/2,shape=symmetric,datatype=float)) elif (key="N") then res:=ReadValue(filename," NPLWV =",number,'format'="%d") elif (key="No") then res:=ReadValue(filename," NBANDS=",number,'format'="%d") elif (key="Nk") then res:=ReadValue(filename," NKPTS =",number,'format'="%d") elif (key="KPOINTS") then res:=[ReadValue(filename," generate k-points for:",number,'format'="%d%d%d")] elif (key="kgrid") then res:=map(op@sscanf,ReadLines(filename,"Following reciprocal coordinates:",number,s->evalb(Trim(s)=""),'shift'=2),"%{4}fc") elif (key="Ne") then res:=ReduceFloat2(ReadValue(filename," NELECT =",number,'format'="%f")) elif (key="Na" or key="Nb") then res:=ReduceFloat2(ReadValue(filename," NELECT =",number,'format'="%f")); v:=ReduceFloat2(ReadValue(filename," NUPDOWN=",number,'format'="%f")); res:=`if`(key="Na",res-v,res+v)/2 elif (key="EFermi") then res:=ReadValue(filename," E-fermi :",number,'format'="%f") elif (key="evl") then no,nk:=ReadOutput(filename,"No,Nk"); ls:=remove(s->Trim(s)="",ReadLines(filename,"k-point 1 :",number,s->evalb(s[..3]="---"),'shift'=0)); if (nops(ls)<>(no+2)*nk) then error("nops(ls)=%1<>(no+2)*nk=%2",nops(ls),(no+2)*nk) end; ls:=[ListTools[LengthSplit](ls,no+2)]; kps:=Matrix(3 ,nk,datatype=float); evs:=Matrix(no,nk,datatype=float); occ:=Matrix(no,nk,datatype=float); for k from 1 to nk do kps[..,k]:=op(sscanf(ls[k][1][18..],"%{3}fc")); ls2:=map(sscanf,ls[k][3..],"%d%f%f"); for o from 1 to no do evs[o,k]:=ls2[o][2]; occ[o,k]:=ls2[o][3] end end; res:=[kps,evs,occ] elif (key="EM") then ls:=ReadLines(filename," TOTAL ELASTIC MODULI (kBar)",number,'shift'=3,'nlines'=6); res:=Matrix(6,shape=symmetric,datatype=float); for i from 1 to 6 do res[i,..]:=op(sscanf(ls[i][5..],"%{6}fr"))/10 end # conversion kbar to GPa elif (key="EM1") then ls:=ReadLines(filename," SYMMETRIZED ELASTIC MODULI (kBar)",number,'shift'=3,'nlines'=6); res:=Matrix(6,shape=symmetric,datatype=float); for i from 1 to 6 do res[i,..]:=op(sscanf(ls[i][5..],"%{6}fr"))/10 end elif (key="EM2") then ls:=ReadLines(filename," ELASTIC MODULI IONIC CONTR (kBar)",number,'shift'=3,'nlines'=6); if (ls=[]) then ls:=ReadLines(filename," ELASTIC MODULI CONTR FROM IONIC RELAXATION (kBar)",number,'shift'=3,'nlines'=6) end; res:=Matrix(6,shape=symmetric,datatype=float); for i from 1 to 6 do res[i,..]:=op(sscanf(ls[i][5..],"%{6}fr"))/10 end elif (key="nopt") then res:=ReadValue(filename,"--- Iteration ",-1,'format'="%d") elif member(key,["ZPE"]) then res:=undefined else error("Unrecognized vas key: %1",key) end end; `if`(res=NULL,undefined,res) end end: #hfl: ReadExcStates ReadExcStates:=proc(filename0::string, { program::{"gau"}:=WhatProgram(filename0), T::Matrix(3,3):=<<1,0,0>|<0,1,0>|<0,0,1>>, number::integer:=-1, printout::{boolean,posint}:=false, width::posint:=80 },$) local filename,tb,i0,i,ls1,ls2,ls3,j,v,s; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); tb:=table(): if (program="gau") then ls1:=ReadLines(filename,"Ground to excited state transition electric dipole moments (Au):",number,s->evalb(s[..2]<>" "),'shift'=2,'line'='i0'); if (ls1=[]) then return [] end; ls1:=map(s->T.sscanf(s,"%d %{3}fr")[2]*bohr2A,ls1); i0:=SearchFilePos(filename,"Excitation energies and oscillator strengths:",'skiplines'=i0)[1]; for i from 1 to infinity do ls2:=[ReadValue(filename,sprintf("Excited State %3d:",i),'skiplines'=i0,'line'='i0','format'="%s %f eV %f nm f=%f =%f")]; if (ls2=[]) then break end; ls3:=Vector(ReadLines(filename,s->evalb(s=" " or s[..2]<>" "),'shift'=i0,'nlines'=infinity)); for j from 1 to op(1,ls3) do v:=sscanf(ls3[j],"%d -> %d%f"); if (nops(v)=3) then ls3[j]:=v else v:=sscanf(ls3[j],"%d <- %d%f"); if (nops(v)=3) then ls3[j]:=[v[2],v[1],v[3]] else v:=sscanf(ls3[j],"%d%s -> %d%s%f"); if (nops(v)=5) then ls3[j]:=[v[1],v[3],v[5],cat(v[2],v[4])] else v:=sscanf(ls3[j],"%d%s <- %d%s%f"); if (nops(v)=5) then ls3[j]:=[v[3],v[1],v[5],cat(v[4],v[2])] else error("Unrecognized CI transition: %1",ls3[j]) end end end end end; tb[i]:=[ls2[2],ls2[4],ls1[i],ls2[1],ls2[5],convert(ls3,list)] end end; tb:=convert(tb,list); if not(printout=false) then printf(" \# E(eV) osc.str. trans.el.dipole(eA) symmetry CI expansion weights\n"); for i from 1 to min(`if`(type(printout,posint),printout,999),nops(tb)) do s:=StringTools[Join](map(v->sprintf("%d->%d%6.2f%s",op(v),""),tb[i][-1]),", "); if (length(s)>width) then s:=cat(s[..width-3],"...") end; printf("%2d%7.2f%7.3f <%5.2f> %-12s%4.2f %s\n",i,op(1..5,tb[i]),s) end end; tb end: #hfl: ReadVibrations ReadVibrations:=proc( filename0::string, output::string:="nem", i2a0::list(string):=[], { opt4ReadAtoms::list:=[], printout::boolean:=false, printunit::{"eV","meV","icm"}:="meV" },$) local filename,program,printcc,s,v,i2a,A,a2m,Tvs,na,N,M,i,o,nc,cw,j0,ls,na2,nr,N2,V,j,i2,k,L,E,rm,fc,modes,patch,IR,Raman,T,lsz,lsi,Upp,out; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); program:=WhatProgram(filename); printcc:=piecewise(printunit="eV",1,printunit="meV",1000,printunit="icm",1/icm2eV,undefined); if (program="gau") then A:=ReadAtoms(filename,op(opt4ReadAtoms)) elif (program="vas") then s:=ReadValue(filename," POSCAR = "); if (i2a0=[]) then v:=ReadBody(s," i2a=[","]",'noerror'); if (v="") then error("Provide i2a") end; i2a:=StringTools[Split](v,",") else i2a:=i2a0 end; A:=ReadAtoms(filename,1,i2a,op(opt4ReadAtoms)) else error("%1 is not supported",program) end; Tvs,A:=selectremove(v->v[1]=tvsymbol9,A); na:=nops(A); N:=3*na; M:=Vector(N,datatype=float); if (program="gau") then for i from 1 to na do for o from 1 to 3 do M[3*i-3+o]:=AtomMass(A[i][1]) end end; N:=N-`if`(na=2,5,6); nc,cw,j0:=3,23,12; ls:=ReadLines(filename," and normal coordinates:",s->evalb(Trim(s)="")); na2:=op(sscanf(ls[-1],"%d")); if not(type(na2,posint)) then error("Unrecognized last line: %1",ls[-1]) end; if (na2<>na) then WARNING("na has been reset from %1 to %2",na,na2); na:=na2; A,M:=A[..na],M[..3*na] end; for nr from na2+3 to nops(ls) while (ls[nr][..9]<>" ") do end; nr:=nr-1; if not(type(nops(ls)/nr,posint)) then seq(printf("%s\n",ls[i]),i=[1,2,3,-3,-2,-1]); error("Unrecognized record: nops(ls)=%1, nr=%2",nops(ls),nr) end; ls:=[ListTools[LengthSplit](ls,nr)]; N2:=sscanf(ls[-1][1],cat("%d"$nc))[-1]; if (N2<>N) then WARNING("N has been reset from %1 to %2",N,N2); N:=N2; M:=M[..3*na] end; V:=Matrix(N,nr); for i from 1 to N do for j from 1 to nr do i2:=iquo(i-1,nc,'k')+1; V[i,j]:=ls[i2][j][j0+cw*k+1..j0+cw*(k+1)] end end; L:=Vector(N,i->Trim(V[i,2][5..])); E:=Vector(N,i->op(sscanf(V[i,3][5..],"%f"))*icm2eV,datatype=float); rm:=Vector(N,i->op(sscanf(V[i,4][5..],"%f")),datatype=float); fc:=Vector(N,i->op(sscanf(V[i,5][5..],"%f")),datatype=float); T:=Matrix(3*na,N,datatype=float); for i from 1 to N do for j from 1 to na do v:=op(sscanf(V[i][nr-na+j],"%{3}fc")); for o from 1 to 3 do T[3*j-3+o,i]:=v[o] end end end; for i from 1 to N do T[..,i]:=T[..,i]/sqrt(add(M[j]*T[j,i]^2,j=1..3*na)) end; modes:=Matrix(3*na,N,(i,j)->T[i,j]*sqrt(M[i]),datatype=float); patch:=proc(v) if (v=[]) then if (k<2) then k:=k+1; WARNING("Overflow %1",k) end; [9999999] else v end end; k:=0; IR:=`if`(ls[1][6][..9]=" IR Inten",Vector(N,i->op(patch(sscanf(V[i,6][5..],"%f"))),datatype=float),Vector(N)); k:=0; Raman:=`if`(ls[1][7][..12]=" Raman Activ",Vector(N,i->op(patch(sscanf(V[i,7][5..],"%f"))),datatype=float),Vector(N)) elif (program="vas") then rm:=undefined; a2m:=table([seq(i2a[i]=ReadValue(filename," POMASS =",i,format="%f"),i=1..nops(i2a))]); for i from 1 to na do for o from 1 to 3 do M[3*i-3+o]:=a2m[A[i][1]] end end; ls:=ReadLines(filename,"Eigenvectors and eigenvalues of the dynamical matrix",'shift'=3,'nlines'=N*(na+3)); ls:=[ListTools[LengthSplit](ls,na+3)]; E:=Vector(N,i->op(sscanf(ls[-i][2][64..],"%f"))/1000,datatype=float); for i from 1 to N do if (ls[-i][2][6..8]="f ") then elif (ls[-i][2][6..8]="f/i") then E[i]:=-E[i] else error("Unrecognized line: %1",ls[-i][2]) end end; modes:=Matrix(N,datatype=float); for i from 1 to N do for j from 1 to na do v:=op(sscanf(ls[-i][3+j][36..],"%{3}fc")); for o from 1 to 3 do modes[3*j-3+o,i]:=v[o] end end end; T:=Matrix(3*na,N,(i,j)->modes[i,j]/sqrt(M[i]),datatype=float); Raman,IR:=Vector(N),Vector(N) else error("%1 is not supported",program) end; lsz:=`if`(program="gau",[0,0,0],sort(SortIdx([seq(sqrt(add(StandardDeviation([seq(T[3*k-3+i,j],k=1..na)])^2,i=1..3)),j=1..N)],'nolist')[1..3])); lsi:=select(i->E[i]<0 and not(member(i,lsz)),[$1..N]); if printout then printf("%{c,}.2f .. %{c,}.0f %s\nTranslations: %d,%d,%d%s\nNormalization: %.8f,%.8f\n",printcc*E[..min(9,N)],printcc*E[-min(3,N)..],printunit,op(lsz), `if`(lsi=[],"",sprintf(" Imaginary: %{c,}d",Vector(lsi))), LinearAlgebra[Norm](modes.LinearAlgebra[Transpose](modes)-1,'Frobenius'), LinearAlgebra[Norm](LinearAlgebra[Transpose](modes).modes-1,'Frobenius')) end; Upp:=modes.DiagonalMatrix(map(v->signum(v)*v^2/h2imu,E)).Transpose(modes); Upp:=Matrix(N,(i,j)->sqrt(M[i]*M[j])*Upp[i,j],datatype=float,shape=symmetric); out:=NULL; for v in output do if (v="a") then out:=out,A elif (v="e") then out:=out,E elif (v="f") then out:=out,fc elif (v="h") then out:=out,Upp elif (v="i") then out:=out,lsi elif (v="l") then out:=out,L elif (v="m") then out:=out,modes elif (v="M") then out:=out,M elif (v="n") then out:=out,N elif (v="r") then out:=out,Raman elif (v="t") then out:=out,T elif (v="T") then out:=out,Tvs elif (v="u") then out:=out,rm elif (v="v") then out:=out,IR elif (v="z") then out:=out,lsz else error("Unrecognized output code %1",v) end end; out end: #hfl: ReadNBO ReadNBO:=proc(filename0::string,spin::{"","a","b"}:="",{printout::boolean:=false},$) local filename,Na,Nb,Ne,number,ls,s2v,tb,n,ls2,ls1,tag,t,P,p,v; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); Na,Nb:=ReadOutput(filename,"Na,Nb"); Ne:=piecewise(spin="a",Na,spin="b",Nb,Na+Nb); number:=`if`(spin="",1,`if`(spin="a",2,3)); #NAO ls:=remove(s->Trim(s)="",ReadLines(filename,"NAO Atom No lang Type(AO) Occupancy",number,'shift'=2)); s2v:=proc(s) local v; v:=[op(sscanf(s[..28],"%d%s%d%s%s")),op(sscanf(s[30..31],"%d")),s[32],op(sscanf(s[34..],"%f%f"))]; if (nops(v)=9) then subsop(-1=hartree2eV*v[-1],v) elif (nops(v)=8) then [op(v),0] else error("Incomplete data in %1",s) end end; ls:=map(s2v,ls); tb:=table([seq(op(v[[3,4,6]])=v,v=ls)]); if printout then printf("%d NAOs, spin=%s, Ne=%d, Ne-sumocc=%.6f\n",nops([indices(tb)]),spin,Ne,Ne-add(v[8],v=entries(tb,nolist))) end; #NBO ls:=select(s->s[7]=".",ReadLines(filename,"Natural Bond Orbitals (Summary):",number,s->evalb(s[9]="-"),'shift'=5)); ls:=map(s->sscanf(cat(s[..11],s[40..61],s[13..32],"-X 0"),"%d.%s%f%f%d)%s%d -%s%d")[[1,2,5,7,9,3,4]],ls); # id,typ,#,i,j,occ,e ls:=map(v->subsop(6=`if`(v[6]<0.5,v[6],round(v[6])-v[6]),7=v[7]*hartree2eV,v),ls); n:=nops(ls); ls2:=remove(s->s[45..46]="0." or s[45..46]="1.",ReadLines(filename,"(Occupancy) Bond orbital/ Coefficients/ Hybrids",number,'shift'=2)); ls1:=select(s->s[7]=".",ls2): ls2:=[ListTools[Split](s->s[7]=".",ls2)][2..]: if not(nops(ls1)=n and nops(ls2)=n) then error("Inconsistent lists: %1=%2=%3",n,nops(ls1),nops(ls2)) end; ls2:=Vector(n,p->Join([ls1[p],op(ls2[p])],"\n")); tag:=" Reordering of NBOs for storage:"; t:=length(tag); P:=ReadLines(filename,tag,number,s->s[..t]<>tag,'shift'=0); if (P=[]) then P:=[$1..n] else P:=sscanf(cat(seq(v[t+1..],v=P)),"%{*}dr",n)[1]; P:=SortIdx(P,'nolist') end; s2v:=proc(s0) local f,s,w,p; f:=proc(s) local v,p; v:=sscanf(s,"s(%f%%)p%f(%f%%)d%f(%f%%)f%f(%f%%)g%f(%f%%)h%f(%f%%)"); seq(v[2*p+1]/100,p=0..(nops(v)-1)/2) end; s:=StringTools[SubstituteAll](s0,"\n ",""); s:=StringTools[SubstituteAll](s," s(","\ns("); w:=map(Trim,Split(s,"\n")); if (nops(w)=5) then [seq([op(sscanf(w[p][10..],"%f")),f(w[p+1])],p=[2,4])] elif (nops(w)=2) then [[1.,f(w[2])]] else error("Unrecognized record: %1",s0) end end; ls:=[seq([op(ls[p]),s2v(ls2[p]),P[p]],p=1..n)]; for v in ls do tb[[v[4],`if`(v[5]=0,NULL,v[5])],v[2],v[3]]:=[v[1],op(6..,v)] end; op(tb) end: #hfl: LoadMO LoadMO:=proc( fn::string, out::string:="", { spin::{"","a","b"}:="", outtag::string:="", symtag::string:=outtag, binfn::string:="", bintag::string:="", binpath::string:="", nooverlaps::boolean:=false, printout::boolean:=false },$) local fld,fn0,fout,fsym,fbin,A,SG,FBS,Q,M,Na,Nb,sym,inputline,nt,na,homo,A2,ev,evc,N,no,evr,S,BS,Sev,Sevc,sqrtS,isqrtS,evco,H,Ho,v; fld,fn0:=ExpandPath(fn,"p,n"); fout:=cat(fn,outtag); fsym:=cat(fn,symtag); fbin:=`if`(binfn="",cat(fld,binpath,fn0,bintag),binfn); if printout then printf("fout=%s\nfbin=%s\n",fout,fbin) end; if not(fexists(fout)) then fout:=cat(fout,xout); if not(fexists(fout)) then error("No out-file: %1",fout) end end; A,SG,FBS,Q,M,Na,Nb,sym,inputline:=ReadOutput(fout,"A,SG,BS,charge,mult,Na,Nb,sym,in"); nt:=add(`if`(v[1]=tvsymbol9,1,0),v=A); na:=nops(A)-nt; homo:=`if`(spin="a",Na,`if`(spin="b",Nb,Na)); if printout then printf("inputline=%s\nnt=%d, na=%d, SG=%s, Q=%d, M=%d, spin=%s, homo=%d, |FBS|=%d\n",inputline,nt,na,SG,Q,M,spin,homo,nops(FBS)) end; #if (M<>1 and spin="") then error("Choose spin a or b") end; if (symtag<>outtag) then if not(fexists(fsym)) then fsym:=cat(fsym,xout); if not(fexists(fsym)) then error("No sym-file: %1",fsym) end end; if (sym<>[]) then WARNING("Symmetry will be overwritten from other file") end; sym,SG,A2:=ReadOutput(fsym,"sym,SG,A"); if (sym=[]) then if printout then printf("No MO-symmetries information in %s\n",fsym) end else sym:=CorrectSymmetryOrientation(A,A2,sym,SG); if (spin="a" and sym<>[]) then sym:=sym[1] elif (spin="b" and sym<>[]) then sym:=sym[2] end; if printout then printf("MO-symmetries with SG=%s is from file %s\n",SG,fsym) end end end; if not(fexists(cat(fbin,".evl",spin))) then error("No evl-file: %1.evl%2",fbin,spin) end; if not(fexists(cat(fbin,".evc",spin))) then error("No evc-file: %1.evc%2",fbin,spin) end; ev,evc:=seq(ReadBIN(cat(fbin,e,spin)),e=[".evl",".evc"]); N,no:=Dim2(evc); S:=`if`(fexists(cat(fbin,".s1e")),Matrix(ReadBIN(cat(fbin,".s1e")),datatype=float,shape=symmetric,attributes=[positive_definite]),undefined); if type(S,Matrix) then if ([Dim2(S)]<>[N,N]) then error("Inconsistent size of evc(%1,%2) and S(%3,%4)",Dim2(evc),Dim2(S)) end end; evr:=`if`(fexists(cat(fbin,".evr",spin)),ReadBIN(cat(fbin,".evr",spin)),`if`(type(S,undefined),undefined,LinearAlgebra[Transpose](evc).S)); if type(evr,Matrix) then if ([Dim2(evr)]<>[no,N]) then error("Inconsistent size of evc(%1,%2) and evr(%3,%4)",Dim2(evc),Dim2(evr)) end end; if (not(nooverlaps) and type(S,undefined) and type(evr,undefined)) then error("nos1e=false but no s1e- or evr-file: %1.s1e/evr",fbin) end; if printout then printf("N=%d, no=%d%s%s%s\n",N,no, `if`(type(S,Matrix),", S exists",`if`(type(evr,Matrix),", evr exists","")), `if`(type(evr,Matrix),sprintf(", |evr.evc-1|=%.0g",LinearAlgebra[Norm](evr.evc-1,Frobenius)),""), `if`(nooverlaps,", no overlaps","")) end; if (FBS=[]) then WARNING("No basis") else BS:=UnfoldBS(FBS,':-printout'=printout); if (nops(BS)<>N) then error("Wrongly unfolded basis") end end; Sev,Sevc,sqrtS,isqrtS,evco,H,Ho:=undefined$7; if (SearchText("O",out)>0) then Sev,Sevc:=LinearAlgebra[Eigenvectors](S); sqrtS:=Matrix(Sevc.LinearAlgebra[DiagonalMatrix](map(sqrt,Sev)).LinearAlgebra[Transpose](Sevc),shape=symmetric); isqrtS:=Matrix(Sevc.LinearAlgebra[DiagonalMatrix](map(x->1/sqrt(x),Sev)).LinearAlgebra[Transpose](Sevc),shape=symmetric); evco:=sqrtS.evc; if printout then printf("Overlap eigenvalues: %s .. %s\n",FormatFloat(Sev[1],2),FormatFloat(Sev[-1],2)) end end; if (SearchText("H",out)>0) then H:=Matrix(S.evc.LinearAlgebra[DiagonalMatrix](ev).LinearAlgebra[Transpose](evc).S,shape=symmetric); Ho:=`if`(type(evco,Matrix),Matrix(evco.LinearAlgebra[DiagonalMatrix](ev).LinearAlgebra[Transpose](evco),shape=symmetric),undefined) end; ["A"=A,"BS"=BS,"FBS"=FBS,"ev"=ev,"evc"=evc,"evco"=evco,"evr"=evr,"fout"=fout,"fsym"=fsym,"fbin"=fbin,"H"=H,"Ho"=Ho,"homo"=homo,"isqrtS"=isqrtS, "M"=M,"N"=N,"na"=na,"no"=no,"nt"=nt,"Q"=Q,"S"=S,"Sev"=Sev,"SG"=SG,"spin"=spin,"sqrtS"=sqrtS,"sym"=sym] end: #hfl: LoadMO CorrectSymmetryOrientation:=proc(A::list,A2::list,sym::{list,Vector},SG::string,$) # tested for D2H local R,axesperm,patchsym; R:=Superimpose(A,A2,output="r"); axesperm:=convert(map(round@abs,Transpose(R).<1,2,3>),list); patchsym:=proc(sym::string,P::list,$) if (length(sym)>1 and sym[1]="B" and StringTools[IsDigit](sym[2])) then cat(sym[1],4-axesperm[4-parse(sym[2])],sym[3..]) else sym end end; if member(SG,["D2H","D6H"]) then `if`(type(sym,list(string)) or type(sym,Vector),map(patchsym,sym),map2(map,patchsym,sym)) else sym end end: #hfl: OptimCurve OptimCurve:=proc(filename0::string,{program::{"lam","tin","mop","fly","gau","vas"}:=WhatProgram(filename0),cut::{infinity,nonnegint}:=infinity},$) local filename,id0,id,ls,lsp,fmt,tb,i0,i,j,E,Gmax,GRMS,s,isTD,isMP2,fpos,fn2,fd2,tb1,tb2,l,t,F,jmax; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); if (program="lam") then id0:=["PotEng","Fnorm","Fmax","Volume","Press"]; ls:=ReadLines(filename,"Step ",1..5,'shift'=0); id:=remove(`=`,StringTools[Split](ls[1]),""); lsp:=map2(SearchPos,id,id0)+[1$nops(id0)]; fmt:=cat("%f"$max(lsp)); [seq(zip(`*`,[1,1,1,1,1e-4],sscanf(cat("0 ",s),fmt)[lsp]),s=ls[2..-2])] elif (program="tin") then ls:=ReadLines(filename," TN Iter ",1..9,'shift'=3); [seq(zip(`*`,[kcalmol2eV,kcalmol2eV,0,1],sscanf(s,"%d%f%f%f%f")[[2,3,1,5]]),s=ls)] elif (program="mop") then ls:=ReadLines(filename," CYCLE: 1 TIME:",1..19,s->s[..3]=" --",'shift'=0); ls:=select(s->evalb(s[1..7]=" CYCLE:" or s[1..22]=" RESTART FILE WRITTEN,"),ls); ls:=map(s->sscanf(s[48..-1],"GRAD.: %f HEAT: %f"),ls); [seq([kcalmol2eV*v[2],kcalmol2eV*v[1]],v=ls)] elif (program="fly") then tb:=table(): i0:=0; for i from 0 to infinity do try j,E:=ReadValue(filename," NSERCH=",'format'="%d ENERGY= %f",'skiplines'=i0,'line'='i0') catch: break end; if not(j=i) then error("Inconsistent numbering at NSERCH=%1",j) end; try Gmax,GRMS:=ReadValue(filename," MAXIMUM GRADIENT =",'format'="%f RMS GRADIENT = %f",'skiplines'=i0) catch: break end; tb[i]:=[ hartree2eV*E, hartree2eV/bohr2A*GRMS, hartree2eV/bohr2A*Gmax ] end; convert(tb,list) elif (program="gau") then if (cut<>infinity and IsNormalTermination(filename)) then error("No cut is allowed for normally terminated run, %1",filename) end; tb:=table(); i0:=0; s:=ReadValue(filename," #"); isTD:=evalb(max(searchtext(" td ",s),searchtext(" td(",s))>0); isMP2:=evalb(max(searchtext(" mp2 ",s),searchtext(" mp2(",s))>0); for i from 1 to `if`(cut>0,cut,infinity) do try E:=`if`(isTD, ReadValue(filename," Total Energy, E(TD-HF/TD-",'format'="%s = %f",'skiplines'=i0)[2], `if`(isMP2, op(sscanf(StringTools[Substitute](ReadValue(filename," EUMP2 =",'skiplines'=i0),"D","E"),"%f")), ReadValue(filename," SCF Done: E(",'format'="%s = %f",'skiplines'=i0)[2])) catch: E:=0; break end; i0:=SearchFilePos(filename," Item Value Threshold Converged?",'skiplines'=i0,'noerror'); if (i0=[]) then break else i0:=i0[1]; ls:=[seq(ReadValue(filename,s,'format'="%f",'skiplines'=i0),s=["Maximum Force","RMS Force","Maximum Displacement","RMS Displacement"])]; ls:=map(v->`if`(type(v,numeric),v,undefined),ls); tb[i]:=[ hartree2eV*E, hartree2eV/bohr2A*ls[2], hartree2eV/bohr2A*ls[1], bohr2A*ls[4], bohr2A*ls[3] ] end end; if (cut=infinity) then convert(tb,list) elif (cut=0) then OptimCurve(filename,':-cut'=op(MinIdx(tb,[1]))) else i0:=SearchFilePos(filename,"GradGradGrad",'skiplines'=i0,'noerror'); if (i0=[]) then error("No Grad..Grad string to cut %1",filename) else i0:=i0[1] end; fn2:=cat(ExpandPath(filename,"pn"),"_new.out"); WriteLines(fn2,ReadLines(filename,'nlines'=i0),'overwrite'); FileTools[Remove](filename); FileTools[Rename](fn2,filename); convert(tb,list) end elif (program="vas") then tb1:=table(); i0:=0; for l from 1 to infinity do try i0:=SearchFilePos(filename," FREE ENERGIE OF THE ION-ELECTRON SYSTEM (eV)",'skiplines'=i0)[1]; F:=ReadValue(filename," free energy TOTEN =" ,'format'="%f",'skiplines'=i0); E:=ReadValue(filename," energy without entropy=",'format'="%f",'skiplines'=i0); tb1[l]:=[F,E] catch: break end end; tb2:=table(); i0:=0; for l from 1 to infinity do try i,j:=ReadValue(filename,"--- Iteration",'format'="%d(%d",'skiplines'=i0,'line'='i0'); i0:=SearchFilePos(filename," LOOP: cpu time",'skiplines'=i0)[1]; t:=ReadValue(filename,"real time",'format'="%f",'skiplines'=i0); if not(type(t,numeric)) then t:=infinity end; F:=ReadValue(filename," free energy TOTEN =" ,'format'="%f",'skiplines'=i0); E:=ReadValue(filename," energy without entropy =",'format'="%f",'skiplines'=i0); tb2[i,j]:=[F,E,t] catch: break end end; tb:=table(); for i from 1 to infinity while assigned('tb2[i,1]') do for j from 1 to infinity while assigned('tb2[i,j]') do end; jmax:=j-1; tb[i]:=[op(`if`(assigned('tb1[i]'),tb1[i],[0,0])),[seq(tb2[i,j],j=1..jmax)]] end; convert(tb,list) end end: #hfl: GetTiming GetTiming:=proc(filename0::string,{printnot::boolean:=false},$) local filename,program,e,t,s1,dt1,s2,dt2,s,i,t2,formats; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); program:=WhatProgram(filename); if (program="gau" or IsNormalTermination(filename)) then t,t2:=0,0; if (program="lam") then e:=[ReadValue(filename,"Total wall time:",'format'="%d:%d:%d")]; t:=(e[1]*60+e[2])*60+e[3] elif (program="tin") then if not(printnot) then printf("TINKER does not provide timing information\n") end elif (program="mop") then t:=ReadValue(filename," TOTAL JOB TIME: ",'format'="%f"); if not(type(t,numeric)) then t:=ReadValue(filename," TOTAL CPU TIME: ",'format'="%f"); if not(type(t,numeric)) then t:=undefined end end elif (program="fly") then formats:=["%H:%M:%S %d-%b-%Y","%H:%M:%S LT %d-%b-%Y"]; s1:=ReadValue(filename," EXECUTION OF FIREFLY BEGUN "); dt1:=undefined; for s in formats do try dt1:=StringTools[ParseTime](s,Trim(s1)); break catch: end end; s2:=ReadValue(filename," EXECUTION OF FIREFLY TERMINATED NORMALLY "); dt2:=undefined; for s in formats do try dt2:=StringTools[ParseTime](s,Trim(s2)); break catch: end end; t:=(((dt2:-yearDay*24+dt2:-hour)*60+dt2:-minute)*60+dt2:-second)-(((dt1:-yearDay*24+dt1:-hour)*60+dt1:-minute)*60+dt1:-second) elif (program="gau") then e:=[ReadValue(filename,"Job cpu time:",'format'="%d days %d hours %d minutes %f seconds")]; if (e=[]) then printf("Execution is not ended or terminated abnormally\n"); return undefined end; t2:=((e[1]*24+e[2])*60+e[3])*60+e[4]; e:=[ReadValue(filename,"Elapsed time:",'format'="%d days %d hours %d minutes %f seconds")]; t:=`if`(e=[],t2,((e[1]*24+e[2])*60+e[3])*60+e[4]) elif (program="vas") then t2:=ReadValue(filename," Total CPU time used (sec): ",'format'="%f"); t :=ReadValue(filename," Elapsed time (sec): ",'format'="%f") end; if not(printnot) then printf("Runtime is %s, cpu time is %s\n",FormatTime2(t),FormatTime2(t2)) end; t,t2 else printf("Execution is not ended or terminated abnormally\n"); undefined end end: #hfl: ReadDump ReadDump:=proc( filename::string, program::{"lam","mop"}, cod::string, save2file::string:=ExpandPath(filename,"pn"), { ibytes::{0,2,4,8}:=0, fbytes::{0,4,8}:=0, cmin::numeric:=0.002, overwrite::boolean:=false, printout::boolean:=false},$) local fd,fr,readpreamble,preamblelen,na,tilt,BC,box,nc,d,nr,extradata,XYZ,r,na2,i0,c,n,o,nb,ls,n2,rho,n1,homo,ls1,ls2,no,Vni,Vlsi,Vnl,i2k,k,i,k2il,l,Vcn,Vnn,evc,lsk,lsc,m; if (program="lam") then # see tools/binary2txt.cpp fr:=(t,n)->FileTools[Binary][Read](fd,t,n,'byteorder'='native'); readpreamble:=proc() local magicwordlen,magicword,endian,revision,timestep,na,tilt,BC,box,d,unitslen,units,timeflag,time,columnslen,columns,nc; magicwordlen:=-fr(integer[8],1)[1]; if (magicwordlen>0) then magicword:=convert(fr(integer[1],magicwordlen),'bytes'); endian,revision:=op(fr(integer[4],2)); if (endian<>1) then WARNING("endian=%1",endian) end; timestep:=fr(integer[8],1)[1] end; na:=fr(integer[8],1)[1]; tilt:=fr(integer[4],1)[1]; #=triclinic BC:=Matrix(3,2,fr(integer[4],6),datatype=integer); #boundary(0=p,1=f,2=s,3=m) box:=Matrix(3,2,fr(float[8],6),datatype=float); #xlo,hhi,ylo,yhi,zlo,zhi if (tilt<>0) then tilt:=fr(float[8],3) end; #xy,xz,yz d:=fr(integer[4],1)[1]; if (d<>3) then fclose(fd); error("Unrecognized dimension: %1",d) end; #=size_one if (magicwordlen>0 and revision>1) then unitslen:=fr(integer[4],1)[1]; if (unitslen>0) then units:=convert(fr(integer[1],unitslen),'bytes') end; timeflag:=fr(integer[1],1)[1]; if (timeflag>0) then time:=fr(float[8],1)[1] end; columnslen:=fr(integer[4],1)[1]; columns:=convert(fr(integer[1],columnslen),bytes) end; nc:=fr(integer[4],1)[1]; #number of chunks na,tilt,BC,box,nc end proc; #readpreamble if (cod="md") then fd:=fopen(filename,READ,BINARY); na,tilt,BC,box,nc:=readpreamble(fd); preamblelen:=FileTools[Position](fd); d:=3; nr:=iquo(FileTools[Size](fd),preamblelen+nc*(4+8*d*na),'extradata'); # old code nr:=floor(FileTools[Size](filename)/4/(6*na+25+6*tilt)); if (extradata>0) then WARNING("%1 bytes of extradata",extradata) end; XYZ:=Array(1..nr,1..na+3,1..3,datatype=float); filepos(fd,0); for r from 1 to nr do na2,tilt,BC,box,nc:=readpreamble(fd); if (na2<>na) then fclose(fd); error("na2=%1<>na=%2",na2,na) end; i0:=0; for c from 1 to nc do n:=fr(integer[4],1)[1]; # chunk size XYZ[r,i0+1..i0+n/d,1..3]:=Matrix(n/d,3,FileTools[Binary][Read](fd,float[8],n,'byteorder'='native'),datatype=float); i0:=i0+n/d end; if (i0<>na) then fclose(fd); error("i0=%1<>na=%2",i0,na) end; for o from 1 to 3 do XYZ[r,o-4,o]:=box[o,2]-box[o,1] end; if (tilt<>0) then XYZ[r,-2,1]:=tilt[1]; XYZ[r,-1,1]:=tilt[2]; XYZ[r,-1,2]:=tilt[3]; XYZ[r,-3,1]:=XYZ[r,-3,1]-abs(tilt[1])-abs(tilt[2]); XYZ[r,-2,2]:=XYZ[r,-2,2]-abs(tilt[3]) end end; nr:=r-1; fclose(fd); if (save2file="") then XYZ else WriteBIN(cat(save2file,".md"),XYZ[1..nr,..,..],':-overwrite'=overwrite) end else error("Acceptable codes for LAMMPS are [md] but received %1",cod) end elif (program="mop") then if (cod="rho") then n,nb,na:=op(FileTools[Binary][Read](filename,integer[4],3,'byteorder'='native')); if (n<>8*nb*(nb+1)/2+4+4) then fclose(filename); error("n<>8*nb*(nb+1)/2+4+4 in %1",filename) end; ls:=FileTools[Binary][Read](filename,float[8],nb*(nb+1)/2,'byteorder'='native'); n2:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native')); if (n2<>n) then fclose(filename); error("n2<>n in %1",filename) end; rho:=Matrix(nb,(i,j)->ls[i*(i-1)/2+j],shape=symmetric,storage=triangular[lower],datatype=float); if (FileTools[Binary][CountBytes](filename)=0) then fclose(filename); if (save2file="") then rho else WriteBIN(cat(save2file,".rho"),rho,`if`(fbytes=0,NULL,'code'=[2,fbytes,0,1]),':-overwrite'=overwrite) end else n1:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native')); if (n1<>n-8) then fclose(filename); error("n1<>n-8 in %1",filename) end; ls:=FileTools[Binary][Read](filename,float[8],nb*(nb+1)/2,'byteorder'='native'); n2:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native')); if (n2<>n1) then fclose(filename); error("n2<>n1 in %1",filename) end; fclose(filename); if (save2file="") then [rho,Matrix(nb,(i,j)->ls[i*(i-1)/2+j],shape=symmetric,storage=triangular[lower],datatype=float)] else WriteBIN(cat(save2file,".rhoa"),rho,`if`(fbytes=0,NULL,'code'=[2,fbytes,0,1]),':-overwrite'=overwrite); WriteBIN(cat(save2file,".rhob"),Matrix(nb,(i,j)->ls[i*(i-1)/2+j],shape=symmetric,storage=triangular[lower],datatype=float),`if`(fbytes=0,NULL,'code'=[2,fbytes,0,1]),':-overwrite'=overwrite) end end elif (cod="evc") then homo:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; ls1:=FileTools[Binary][Read](filename,integer[4],homo,'byteorder'='native'); n2:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; if (n2<>homo) then fclose(filename); error("n2<>homo in %1",filename) end; n:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; ls2:=FileTools[Binary][Read](filename,integer[4],n,'byteorder'='native'); n2:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; if (n2<>n) then fclose(filename); error("n2<>n in %1",filename) end; no:=homo+n; Vni:=Vector([op(ls1),op(ls2)],datatype=integer); Vlsi:=Vector(no,o->FileTools[Binary][Read](filename,integer[4],Vni[o]+2,'byteorder'='native')[2..-2]); na:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; Vnl:=Vector(FileTools[Binary][Read](filename,integer[4],na,'byteorder'='native'),datatype=integer); n2:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; if (n2<>na) then fclose(filename); error("n2<>na in %1",filename) end; i2k:=Vector(na); k:=0; for i from 1 to na do i2k[i]:=[$k+1..k+Vnl[i]]; k:=k+Vnl[i] end; nb:=k; i2k:=convert(i2k,list); k2il:=table(): for i from 1 to nops(i2k) do for l from 1 to nops(i2k[i]) do k2il[i2k[i][l]]:=[i,l] end end; k2il:=convert(k2il,list); n1:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; if (n1<>na) then fclose(filename); error("n1<>na in %1",filename) end; Vcn:=Vector(FileTools[Binary][Read](filename,integer[4],na,'byteorder'='native'),datatype=integer); n2:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; if (n2<>n1) then fclose(filename); error("n2<>n1 in %1",filename) end; n:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/4; if (n<>9*na) then fclose(filename); error("n<>9*na in %1",filename) end; Vnn:=Vector(na,i->remove(`=`,FileTools[Binary][Read](filename,integer[4],9,'byteorder'='native'),0)); # trailing integer[4] is skipped to read float[8] continuously evc:=Vector(no); for o from 1 to no do lsk:=[seq(op(i2k[i]),i=Vlsi[o])]; lsc:=FileTools[Binary][Read](filename,float[8],nops(lsk)+1,'byteorder'='native')[2..]; evc[o]:=Sort(select(v->abs(v[2])>=cmin,[seq([lsk[m],lsc[m]],m=1..nops(lsk))]),v->-abs(v[2])) end; n2:=op(FileTools[Binary][Read](filename,integer[4],1,'byteorder'='native'))/8; if (FileTools[Binary][CountBytes](filename)<>0) then fclose(filename); error("%1 bytes are left unread in %2",FileTools[Binary][CountBytes](filename),filename) end; fclose(filename); if (save2file="") then evc,k2il,i2k,convert(Vnn,list) else WriteBIN(cat(save2file,".evc"),evc,[integer[4],float[4]],':-overwrite'=overwrite) end else error("Acceptable codes for MOPAC are [rho,evc] but received %1",cod) end end end: #hfl: ReadDump WriteDump:=proc(filename::string,program::{"mop"},cod::string,data::list,$) local rho,na,nb,n,i,j; if (program="mop") then if (cod="rho") then if not(type(data,{[Matrix,posint],[Matrix,Matrix,posint]})) then error("Unrecognized data, must be [rho,na] or [rhoa,rhob,na]") end; rho,na:=data[1],data[-1]; nb:=[op(1,rho)][1]; n:=8*nb*(nb+1)/2+4+4; FileTools[Binary][Write](filename,integer[4],[n,nb,na],'byteorder'='native'); FileTools[Binary][Write](filename,float[8],[seq(seq(rho[i,j],j=1..i),i=1..nb)],'byteorder'='native'); FileTools[Binary][Write](filename,integer[4],[n],'byteorder'='native'); if (nops(data)=3) then rho:=data[2]; FileTools[Binary][Write](filename,integer[4],[n-8],'byteorder'='native'); FileTools[Binary][Write](filename,float[8],[seq(seq(rho[i,j],j=1..i),i=1..nb)],'byteorder'='native'); FileTools[Binary][Write](filename,integer[4],[n-8],'byteorder'='native') end; fclose(filename) else error("Acceptable codes for MOPAC are [rho] but received %1",cod) end end end: #hfl: ReadAUX ReadAUX:=proc( filename0::string, key::string, dim::{integer,"sym"}:=1, fmt::{"f","d","s"}:="f",$) local filename,s,mozyme,evl,no,occ,ne,lso,o,homo,lumo,somo,evc,i0,n,n1,n2,u,v,na,k2i,i2k,k2il,k,l,aosym,elem,zeta,pqn,bss,m,L; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,".aux")); if (key="evl" or key="evc") then s:=ReadValue(filename," KEYWORDS=""",1..11); mozyme:=evalb(SearchText("MOZYME",s)>0); evl:=ReadAUX(filename,`if`(mozyme,"LMO_ENERGY_LEVELS","EIGENVALUES")); no:=op(1,evl); try occ:=ReadAUX(filename,"MOLECULAR_ORBITAL_OCCUPANCIES") catch: fclose(filename); WARNING("Fail to read MO occupancies, will calculate from number of electrons"); ne:=ReadAUX(filename,"NUM_ELECTRONS","d"); occ:=Vector(no,o->`if`(2*o<=ne,2,`if`(2*o=ne+1,1,0)),datatype=float) end; if mozyme then lso:=SortIdx([seq(evl[o],o=1..no)],'nolist'); evl:=evl[lso]; occ:=occ[lso] else lso:=[$1..no] end; for o from 1 to no while (occ[o]=2) do end; homo:=`if`(o>1 and o<=no,o-1,undefined); for o from no by -1 to 1 while (occ[o]=0) do end; lumo:=`if`(o>=1 and o" \# Compressed LMO vectors \#") do end; readline(filename),readline(filename); for o from 1 to no do n:=op(fscanf(filename," LMO_INDICES[%d]=")); u:=op(fscanf(filename,cat("%{",n,"}dc"))); n2:=op(fscanf(filename," LMO_COEFFICIENTS[%d]=")); if (n<>n2) then fclose(filename); error("Incompatible LMO_INDICES and LMO_COEFFICIENTS") end; v:=op(fscanf(filename,cat("%{",n,"}fc"))); evc[o]:=[seq([u[k],v[k]],k=1..n)] end; fclose(filename); evc:=evc[lso] else evc:=LinearAlgebra[Transpose](ReadAUX(filename,"EIGENVECTORS",no)) end; evl,evc,homo,lumo,somo end elif (key="bss") then elem:=ReadAUX(filename,"ATOM_EL","s"); na:=op(1,elem); aosym:=ReadAUX(filename,"ATOM_SYMTYPE","s"); k2i:=ReadAUX(filename,"AO_ATOMINDEX","d"); n:=op(1,k2i); i2k:=Vector(na,i->[]); k2il:=Vector(n); for k from 1 to n do i2k[k2i[k]]:=[op(i2k[k2i[k]]),k] end; for i from 1 to na do i2k[i]:=Sort(i2k[i],k->mop_aoindex[aosym[k]]); for l from 1 to nops(i2k[i]) do k2il[i2k[i][l]]:=[i,l] end end; zeta:=ReadAUX(filename,"AO_ZETA"); pqn:=ReadAUX(filename,"ATOM_PQN","d"); [seq([elem[k2i[k]],op(k2il[k]),aosym[k],pqn[k],zeta[k]],k=1..op(1,k2i))],[seq(v,v=i2k)] elif (key="BS") then bss,i2k:=ReadAUX(filename,"bss"); map(v->[v[2],v[4],[v[5],v[6]],1,cat(v[1],v[2],v[4])],bss) elif (key="Atoms") then elem:=ReadAUX(filename,"ATOM_EL","s"); v:=LinearAlgebra[Transpose](ReadAUX(filename,"ATOM_X_OPT:ANGSTROMS",3)); [seq([elem[i],v[..,i]],i=1..op(1,elem))] else if not(fmt="f" or fmt="d" or fmt="s") then error "Format must be one of [f,d,s] but received %1",fmt end; L:=length(key)+1; do s:=readline(filename); if (s[2..L]=key or s=0) then break end end; if (s=0) then error("No key: %1",key) end; s:=TrimRight(s[L+1..]); if (s[1]="=") then v:=op(sscanf(`if`(fmt="f",StringTools[Substitute](s,"D","E"),s),cat("=%",fmt))) else n:=op(sscanf(s,"[%d]=")); s:=s[searchtext("=",s)+1..-1]; if (s<>"") then v:=op(sscanf( StringTools[SubstituteAll](s,"D","E"), cat("%{",n,"}",fmt,"c") )) elif (dim=1) then v:=op(fscanf(filename,cat("%{",n,"}",fmt,"c"))) elif (dim=-1) then v:=op(fscanf(filename,cat("%{",n,"}",fmt,"r"))) elif (dim=0) then m:=sqrt(n); v:=op(fscanf(filename,cat("%{",m,",",m,"}",fmt,"m"))); elif (dim="sym") then readline(filename); m:=(sqrt(8*n+1)-1)/2; v:=op(fscanf(filename,cat("%{",m,",",m,";lx(symmetric)}",fmt,"m"))) elif (dim>1) then n1,n2:=n/dim,dim; v:=op(fscanf(filename,cat("%{",n1,",",n2,"}",fmt,"m"))) else n1,n2:=-dim,-n/dim; v:=op(fscanf(filename,cat("%{",n1,",",n2,"}",fmt,"m"))) end end; fclose(filename); v end end: #hfl: CompressAUX CompressAUX:=proc( filename0::string, tosave::list(string):=["evc"], { datatype:=float[4], nobackup::boolean:=false, forcebackup::boolean:=false, forcebin::boolean:=false },$) local filename,fn,lsspin,spin,V,M,ls,i,j; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,".aux")); fn:=ExpandPath(filename,"pn"); if (nops(`minus`(convert(tosave,set),{"evl","evc","s1e","h1e","rho"}))>0) then error("Allowed entries of tosave list are [evl,evc,s1e,h1e,rho] but received %1",tosave) end; # save if not(nobackup) then FileTools[Copy](filename,cat(fn,".bak"),'force'=forcebackup) end; lsspin:=`if`(SearchFilePos(filename,"ALPHA_EIGENVECTORS",'noerror')=NULL, [""], ["ALPHA_","BETA_"]); if member("evl",tosave) then for spin in lsspin do V:=ReadAUX(filename,cat(spin,"EIGENVALUES")); if (datatype<>float) then V:=Vector(V,':-datatype'=datatype) end; WriteBIN(cat(fn,".evl",StringTools[LowerCase](spin[1])),V,'overwrite'=forcebin) end end; if member("evc",tosave) then try for spin in lsspin do M:=ReadAUX(filename,cat(spin,"EIGENVECTORS")); if (datatype<>float) then M:=Matrix(M,':-datatype'=datatype) end; WriteBIN(cat(fn,".evc",StringTools[LowerCase](spin[1])),M,'overwrite'=forcebin) end catch: WARNING("No evc") end end; if member("s1e",tosave) then try M:=ReadAUX(filename,cat(spin,"OVERLAP_MATRIX")); if (datatype<>float) then M:=Matrix(M,':-datatype'=datatype,shape=symmetric) end; WriteBIN(cat(fn,".s1e"),M,'overwrite'=forcebin) catch: WARNING("No s1e") end end; if member("h1e",tosave) then try for spin in lsspin do M:=ReadAUX(filename,cat(spin,"FOCK_MATRIX")); if (datatype<>float) then M:=Matrix(M,':-datatype'=datatype,shape=symmetric) end; WriteBIN(cat(fn,".h1e",StringTools[LowerCase](spin[1])),M,'overwrite'=forcebin) end catch: WARNING("No h1e") end end; if member("rho",tosave) then try for spin in lsspin do M:=ReadAUX(filename,cat(`if`(spin="","TOTAL_",spin),"DENSITY_MATRIX")); if (datatype<>float) then M:=Matrix(M,':-datatype'=datatype,shape=symmetric) end; WriteBIN(cat(fn,".rho",StringTools[LowerCase](spin[1])),M,'overwrite'=forcebin) end catch: WARNING("No rho") end end; # compress ls:=ReadLines(filename); for i from 1 to infinity while (i<=nops(ls)) do if (ls[i][..37]=" # Geometry optimization #") then for j from i+3 to nops(ls) do if (ls[j][1..37]=" ####################################") then ls:=[op(ls[1..i+2]),op(ls[j..-1])]; break end end elif (ls[i][..16]=" OVERLAP_MATRIX[" ) then for j from i+2 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..22]=" TOTAL_DENSITY_MATRIX[") then for j from i+2 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..22]=" ALPHA_DENSITY_MATRIX[") then for j from i+2 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..21]=" BETA_DENSITY_MATRIX[" ) then for j from i+2 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..13]=" FOCK_MATRIX[" ) then for j from i+2 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..19]=" ALPHA_FOCK_MATRIX[" ) then for j from i+2 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..18]=" BETA_FOCK_MATRIX[" ) then for j from i+2 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..14]=" EIGENVECTORS[" ) then for j from i+1 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..20]=" ALPHA_EIGENVECTORS[" ) then for j from i+1 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] elif (ls[i][..19]=" BETA_EIGENVECTORS[" ) then for j from i+1 to nops(ls) while (ls[j][..2]=" ") do end; ls:=[op(..i-1,ls),op(j..,ls)] end end; WriteLines(filename,ls,'overwrite'); NULL end: #hfl: ReadRawMatrixElement ReadRawMatrixElement:=proc(f::string,bifl::[posint,posint,posint,posint]:=[1,4,8,64],{printout::boolean:=false},$) local rf,mf,bo,isize,fsize,lsize,p,rec, LabFil,IVers,NLab,GVers,Title,na,N,NBsUse,Q,M,ne,Len12L,Len4L,IOpCl,ICGU,Z,IAtTyp,AtmChg,V,A,IBfAtm,IBfTyp,AtmWgt,NFC,NFV,ITran,IDum,ls,i, lbl,NTot,NPerRec,NRec,p2,rd,R; # rf reads simple records rf:=proc(t::string,n::{nonnegint,list(nonnegint)}:=[],size::nonnegint:=esize,{pos::nonnegint:=0},$) local p0,res,v; p0:=`if`(pos=0,p,pos); if (t="L") then res:=ReadBIN(f,'code'=[1,1,1,bo],'datapos'=p0,'dimensions'=[lsize],'nodescription'); res:=Trim(cat(seq(StringTools[Char](v),v=res))); p0:=p0+lsize elif (t="i") then res:=convert(ReadBIN(f,'code'=[1,isize,1,bo],'datapos'=p0,'dimensions'=[n],'nodescription'),list); p0:=p0+isize*n elif (t="V") then res:=ReadBIN(f,'code'=[2,fsize,1,bo],'datapos'=p0,'dimensions'=[n],'nodescription'); p0:=p0+fsize*n elif (t="M") then res:=ReadBIN(f,'code'=[2,fsize,2,bo],'datapos'=p0,'dimensions'=n,'nodescription'); p0:=p0+fsize*mul(v,v=n) else res:=ReadBIN(f,'code'=[1,size,1,bo],'datapos'=p0,'dimensions'=n,'nodescription'); p0:=p0+size*mul(v,v=n) end; if (pos=0) then p:=p0 end; res end: # mf reads matrix element records mf:=proc(rd::list,{move::boolean:=false},$) local NI,NR,NTot,NPerRec,N1,N2,N3,N4,N5,ISym,NRec,lbl,p2,n,NLast,dt,ds,dp,opts,R,id,U,V,r; NI,NR,NTot,NPerRec,N1,N2,N3,N4,N5,ISym,NRec,lbl,p2:=op(rd); n:=NRec*NPerRec; NLast:=NTot-(NRec-1)*NPerRec; if (NI=1 and NR=0 or NI=0 and NR=1) then dt:=`if`(NI=1,1,2); ds:=`if`(NI=1,isize,fsize); dp:=n*ds; opts:=`if`(lbl="OVERLAP",optrtable=[attributes=[positive_definite]],NULL); if (N1>0 and N2=0) then R:=ReadBIN(f,'code'=[dt,ds,1 ,bo],'datapos'=p2,'dimensions'=[N1],'nodescription',opts) elif (N1>0 and N2>0 and N3=0) then R:=ReadBIN(f,'code'=[dt,ds,2 ,bo],'datapos'=p2,'dimensions'=[N1,N2],'nodescription',opts) elif (N1+N2=0 and N3=0) then R:=ReadBIN(f,'code'=[dt,ds,3 ,bo],'datapos'=p2,'dimensions'=[N2],'nodescription',opts) elif (N1>0 and N2>0 and N3>0 and N4=0) then R:=ReadBIN(f,'code'=[dt,ds,43,bo],'datapos'=p2,'dimensions'=[N1,N2,N3],'nodescription',opts) elif (N1+N2=0 and N3>0 and N4=0) then R:=ReadBIN(f,'code'=[dt,ds,53,bo],'datapos'=p2,'dimensions'=[N2,N3],'nodescription',opts) elif (N1+N2=0 and N3>0 and N4>0) then R:=ReadBIN(f,'code'=[dt,ds,54,bo],'datapos'=p2,'dimensions'=[N2,N3,N4],'nodescription',opts) elif (N1=N2 and N2=N3 and N3+N4=0) then R:=ReadBIN(f,'code'=[dt,ds,3 ,bo],'datapos'=p2,'dimensions'=[N4*(N4+1)/2],'nodescription',opts) else R:=ReadBIN(f,'code'=[dt,ds,1 ,bo],'datapos'=p2,'dimensions'=[NTot],'nodescription',opts); WARNING("Read as vector: %1",rd) end elif (NI=1 and NR=1 and lbl="GAUSSIAN SCALARS") then dp:=isize*n+fsize*n; id:=ReadBIN(f,'code'=[1,isize,1,bo],'datapos'=p2,'dimensions'=[NTot],'nodescription'); U :=ReadBIN(f,'code'=[1,isize,1,bo],'datapos'=p2+isize*NTot,'dimensions'=[NTot],'nodescription'); V :=ReadBIN(f,'code'=[2,fsize,1,bo],'datapos'=p2+isize*n,'dimensions'=[NTot],'nodescription'); R:=[seq(id[i]=`if`(U[i]=1,round(V[i]),V[i]),i=1..NTot)] elif (NI>1 and NR=1) then dp:=isize*NI*n+fsize*n; id,V:=table(),table(); for r from 1 to NRec do id[r]:=ReadBIN(f,'code'=[1,isize,2,bo],'datapos'=p2+isize*NI*NPerRec*(r-1)+fsize*NPerRec*(r-1),'dimensions'=[`if`(r=NRec,NLast,NPerRec),NI],'nodescription'); V [r]:=ReadBIN(f,'code'=[2,fsize,1,bo],'datapos'=p2+isize*NI*NPerRec*r +fsize*NPerRec*(r-1),'dimensions'=[`if`(r=NRec,NLast,NPerRec)],'nodescription') end; R:=[seq(seq(seq(v,v=id[r][i,..])=V[r][i],i=1..Dim2(V[r])),r=1..NRec)]; unassign('id,V') else error("Unrecognized record: %1",rd) end; if move then p:=p2+dp end; R end: # read NLab records bo,isize,fsize,lsize:=op(bifl); p:=0; rec:=table(); LabFil:=rf("L"); rec["LabFil"]:=LabFil; IVers,NLab:=op(rf("i",2)); rec["IVers"]:=IVers; rec["NLab"]:=NLab; GVers:=rf("L"); rec["GVers"]:=GVers; if printout then printf("LabFil=%s\nIVers=%d, NLab=%d\nGVers=%s\n",LabFil,IVers,NLab,GVers) end; Title:=rf("L"); rec["Title"]:=Title; na,N,NBsUse,Q,M,ne,Len12L,Len4L,IOpCl,ICGU:=op(rf("i",10)); rec["NAtoms"]:=na; rec["NBasis"]:=N; rec["NBsUse"]:=NBsUse; rec["ICharg"]:=Q; rec["Multip"]:=M; rec["NE"]:=ne; rec["Len12L"]:=Len12L; rec["Len4L"]:=Len4L; rec["IOpCl"]:=IOpCl; rec["ICGU"]:=ICGU; if printout then printf("Title=%s\nNAtoms=%d, NBasis=%d, NBsUse=%d, ICharg=%d, Multip=%d, NE=%d\nLen12L=%d, Len4L=%d, IOpCl=%d, ICGU=%d\n",Title,na,N,NBsUse,Q,M,ne,Len12L,Len4L,IOpCl,ICGU) end; Z:=rf("i",na); rec["IAn"]:=Z; IAtTyp:=rf("i",na); rec["IAtTyp"]:=IAtTyp; AtmChg:=rf("V",na); rec["AtmChg"]:=AtmChg; V:=Transpose(rf("M",[na,3])): rec["C"]:=V; A:=[seq([ElementSymbol[Z[i]],bohr2A*V[..,i]],i=1..na)]; rec["A"]:=A; if printout then end; IBfAtm,IBfTyp:=rf("i",N),rf("i",N); rec["IBfAtm"]:=IBfAtm; rec["IBfTyp"]:=IBfTyp; AtmWgt:=rf("V",na); rec["AtmWgt"]:=AtmWgt; if printout then printf("Records 3-8: IAn, IAtTyp, AtmChg, C, IBfAtm, IBfTyp, AtmWgt\n") end; NFC,NFV,ITran,IDum:=op(rf("i",4)); rec["NFC"]:=NFC; rec["NFV"]:=NFV; rec["ITran"]:=ITran; rec["IDum"]:=IDum; if printout then printf("NFC=%d, NFV=%d, ITran=%d, IDum=%d\n",NFC,NFV,ITran,IDum) end; ls:=rf("i",NLab-10); if printout then printf("Size of other records:%{c,}s\n",Vector(nops(ls),i->sprintf(" %d=%d",10+i,ls[i]))) end; for i from 1 to nops(ls) do rec[10+i]:=rf("i",ls[i]) end; if not(type(p/fsize,integer)) then rf("i",1) end; rec["pos"]:=p; if printout then printf("Matrix element records starts at pos=%d\n",p) end; # read matrix element records if printout then printf("NI NR NTot NPerRec N1 N2 N3 N4 N5 ISym NRec label\n") end; do lbl:=rf("L"); if (lbl="END") then break end; V:=rf("i",10); NTot,NPerRec:=op(3..4,V); NRec:=ceil(NTot/NPerRec); p2:=p; rd:=[op(V),NRec,lbl,p2]; R:=mf(rd,'move'); if printout then printf("%2d%3d%9d%5d%5d%5d%5d%5d%5d%5d%5d %s\n",op(rd)) end; rec[lbl]:=[op(rd),R] end; op(rec) end: #hfl: ReadDOS ReadDOS:=proc(filename0::string,sitemap0::list:=[],labels0::list:=[],{primitive::boolean:=false,printout::boolean:=false},$) local filename,ls,Emax,Emin,nb,E0,S,na,sitemap,ns,labels,Atoms,Cell,i,s,v,tb,DOS,DOS1,DOS2,b,V,l,k,lsk,ne,dne; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,".dos")); ls:=ReadLines(filename); if printout then printf("%s\n%s\n%s\n%s\n%s\n%s\n%s\n",filename,seq(ls[i],i=1..6)) end; ls:=ls[6..]; Emax,Emin,nb,E0,S:=op(sscanf(ls[1],"%f%f%d%f%f")); na:=nops(ls)/(nb+1)-1; if not(type(na,integer)) then error("Wrong number of lines in %1",filename) end; if printout then printf("na=%d\n",na) end; if (na=0) then if (sitemap0<>[]) then WARNING("sitemap0<>[] while na=0 implying DOS rather than PDOS") end; ns,sitemap,labels:=0,[],[] else if type(sitemap0,list(list(posint))) then sitemap:=`if`(sitemap0=[],[[i]$i=1..na],sitemap0); ns:=nops(sitemap); if (labels0=[]) then labels:=[seq(convert(s,string),s=1..ns)] elif type(labels0,list(string)) then labels:=labels0 else Atoms:=`if`(nops(labels0)=2 and type(labels0[1][1],list),labels0[1],labels0); labels:=[seq(Atoms[v[1]][1],v=sitemap)]; if (ListTools[FindRepetitions](labels)<>[]) then labels:=map(v->cat(v[2][2],v[1]),Sort(map(op@ListTools[Enumerate],[entries(Classify2(ListTools[Enumerate](labels),[2]),'nolist')]),v->v[2][1])) end end; if (nops(labels)<>ns) then error("labels=%1 are inconsistent with sitemap=%2",labels,sitemap) end elif (nops(sitemap0)=2 and type(sitemap0[1][1],list)) then Atoms,Cell:=op(sitemap0); ns:=nops(Atoms); sitemap:=Vector(ns); i:=0; for s from 1 to ns do v:=nops(UnfoldBySymmetry(Atoms[s..s],Cell[7],':-primitive'=primitive)); sitemap[s]:=[$(i+1..i+v)]; i:=i+v end; sitemap:=convert(sitemap,list); labels:=[seq(Atoms[s][1],s=1..ns)]; if (ListTools[FindRepetitions](labels)<>[]) then labels:=map(v->cat(v[2][2],v[1]),Sort(map(op@ListTools[Enumerate],[entries(Classify2(ListTools[Enumerate](labels),[2]),'nolist')]),v->v[2][1])) end else Atoms:=sitemap0; tb:=Classify2([$1..nops(Atoms)],i->Atoms[i][1]); labels:=sort([indices(tb,'nolist')]); sitemap:=[seq(tb[v],v=labels)]; ns:=nops(sitemap) end end; if printout then printf("sitemap=%a\nlabels=%a\nFermi energy=%.3f (reset to zero)\n",sitemap,labels,E0) end; if (max(sitemap)>na) then error("Sitemap is incompatible with DOSCAR: sitemap=%1, na=%2",sitemap,na) end; if type(sitemap0,name) then assign(sitemap0,sitemap) end; if (nops(sscanf(ls[2],"%f%f%f%f%f"))=5) then DOS1,DOS2:=Array(1..nb,0..ns,0..3,datatype=float),Array(1..nb,0..ns,0..3,datatype=float); for b from 1 to nb do V:=op(sscanf(ls[1+b],"%{5}fr")); DOS1[b,0,0],DOS1[b,0,1],DOS1[b,0,2]:=V[1]-E0,V[2],V[4]; DOS2[b,0,0],DOS2[b,0,1],DOS2[b,0,2]:=V[1]-E0,V[3],V[5] end; if (na>0) then V:=Array(1..nb,1..na,1..18,datatype=float); for i from 1 to na do for b from 1 to nb do V[b,i,..]:=sscanf(ls[(nb+1)*i+1+b],"%f%{18}fr")[2] end end; for l from 0 to 2 do lsk:=`if`(l=0,[1],`if`(l=1,[3,5,7],[9,11,13,15,17])); for s from 1 to ns do for b from 1 to nb do DOS1[b,s,l]:=add(add(V[b,i,k],k=lsk),i=sitemap[s])/nops(sitemap[s]) end end end; for b from 1 to nb do DOS1[b,0,3]:=DOS1[b,0,1]-add(add(DOS1[b,s,l],l=0..2)*nops(sitemap[s]),s=1..ns) end; if printout then printf("Unresolved alpha states: %.0f out of %.0f\n",add(DOS1[b,0,3],b=1..nb)/add(DOS1[b,0,1],b=1..nb)*DOS1[nb,0,2],DOS1[nb,0,2]) end; for l from 0 to 2 do lsk:=`if`(l=0,[2],`if`(l=1,[4,6,8],[10,12,14,16,18])); for s from 1 to ns do for b from 1 to nb do DOS2[b,s,l]:=add(add(V[b,i,k],k=lsk),i=sitemap[s])/nops(sitemap[s]) end end end; for b from 1 to nb do DOS2[b,0,3]:=DOS2[b,0,1]-add(add(DOS2[b,s,l],l=0..2)*nops(sitemap[s]),s=1..ns) end; if printout then printf("Unresolved beta states: %.0f out of %.0f\n",add(DOS2[b,0,3],b=1..nb)/add(DOS2[b,0,1],b=1..nb)*DOS2[nb,0,2],DOS2[nb,0,2]) end end; for b from 1 to nb while (DOS1[b,0,0]<0) do end; v:=DOS[min(b,nb),0,2]; ne:=round(v); dne:=v-ne; for b from 1 to nb while (DOS2[b,0,0]<0) do end; v:=DOS[min(b,nb),0,2]; ne:=[ne,round(v)]; dne:=[dne,v-ne[2]]; if printout then printf("ne=[%d,%d], dne=[%.2g,%.2g]\n",op(ne),op(dne)) end; [DOS1,DOS2],labels,sitemap,na,ne else DOS:=Array(1..nb,0..ns,0..3,datatype=float); for b from 1 to nb do DOS[b,0,0..2]:=op(sscanf(ls[1+b],"%{3}fr")); DOS[b,0,0]:=DOS[b,0,0]-E0 end; if (na>0) then V:=Array(1..nb,1..na,1..9,datatype=float); for i from 1 to na do for b from 1 to nb do V[b,i,..]:=sscanf(ls[(nb+1)*i+1+b],"%f%{9}fr")[2] end end; for l from 0 to 2 do lsk:=`if`(l=0,1..1,`if`(l=1,2..4,5..9)); for s from 1 to ns do for b from 1 to nb do DOS[b,s,l]:=add(add(V[b,i,k],k=lsk),i=sitemap[s])/nops(sitemap[s]) end end end; for b from 1 to nb do DOS[b,0,3]:=DOS[b,0,1]-add(add(DOS[b,s,l],l=0..2)*nops(sitemap[s]),s=1..ns) end; if printout then printf("Unresolved states: %.0f out of %.0f\n",add(DOS[b,0,3],b=1..nb)/add(DOS[b,0,1],b=1..nb)*DOS[nb,0,2],DOS[nb,0,2]) end end; for b from 1 to nb while (DOS[b,0,0]<0) do end; v:=DOS[min(b,nb),0,2]; ne:=round(v); dne:=v-ne; if printout then printf("ne=%d, dne=%.2g\n",ne,dne) end; DOS,labels,sitemap,na,ne end end: #hfl: getv getv:=proc( c::string, m::string, k::string, { sys::string:="", ref::string:="", ref2::string:=`if`(ref="","_O",ref), fld::string:=`if`(sys="",CurrentDataFolder,cat(CurrentDataFolder,sys,"/")), bmf::string:=cat(fld,bmfld), tag::string:="", xout2::string:=xout, printout::boolean:=false },$) local r,v,f,E1,E2; r:=':-sys'=sys,':-ref'=ref,':-ref2'=ref2,':-fld'=fld,':-bmf'=bmf,':-tag'=tag,':-xout2'=xout2,':-printout'=printout; v:=undefined; if (k="") then v:=undefined elif (k="fout") then v:=cat(fld,c,"_",m,tag,xout2); if not(fexists(v)) then v:=cat(bmf,c,"/",m,tag,xout2); if not(fexists(v)) then if printout then printf("No out-file for c=%s, m=%s, tag=%s in fld=%s or bmf=%s\n",c,m,tag,fld,bmf) end; v:=undefined end end elif (k="fxyz") then v:=cat(fld,c,"_",m,tag,".xyz"); if not(fexists(v)) then v:=cat(bmf,c,"/",m,tag,".xyz"); if not(fexists(v)) then v:=undefined end end elif (k="fcif") then v:=cat(fld,c,"_",m,tag,".cif"); if not(fexists(v)) then v:=cat(bmf,c,"/",m,tag,".cif"); if not(fexists(v)) then v:=undefined end end elif (k="A") then f:=getv(c,m,"fxyz",':-fld'=fld,':-bmf'=bmf); if (f=undefined) then f:=getv(c,m,"fcif",':-fld'=fld,':-bmf'=bmf); if (f=undefined) then f:=getv(c,m,"fout",':-fld'=fld,':-bmf'=bmf); if (f=undefined) then v:=undefined else v:=ReadAtoms(f) end else v:=ReadCIF(f,[1]) end else v:=ReadXYZ(f) end elif member(k,["in","A","na","charge","mult","SG","ESS","E","F","G","H","BS","DBS","N","No","Nk","KPOINTS","kgrid","Ne","Na","Nb","EFermi","evl","evla","evlb","Sz","S2","dS2","d","Q","q","md","EM","EM1","EM2","nopt"]) then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,k) end elif (k[..4]="evl(" and k[-1]=")") then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,k) end elif (k="Ainput" ) then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadAtoms(f,"input" ) end elif (k="Aending") then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadAtoms(f,"ending") end elif (k="HOMO" ) then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,"evl(1)")[1] end elif (k="HOMO2") then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,"evl(2)")[1] end elif (k="dHOMO") then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,"evl(2)"); v:=v[2]-v[1] end elif (k="dIP" ) then v:=getv(c,m,"PVE",r)+getv(c,m,"HOMO",r) elif (k="dAIP" ) then v:=getv(c,m,"PAE",r)+getv(c,m,"HOMO",r) elif (k="PAE" ) then v:=getv(cat(c,"_P"),m,"E",r)-getv(cat(c,ref),m,"E",r) elif (k="AIP" ) then v:=getv(c,m,"PAE",r) elif (k="PVE" ) then v:=getv(c,cat(m,"_P"),"E",r)-getv(c,m,"E",r) elif (k="IP" ) then v:=getv(c,m,"PVE",r) elif (k="PVe" ) then v:=getv(cat(c,"_P"),m,"E",r)-getv(cat(c,"_P"),cat(m,ref2),"E",r) elif (k="PRE" ) then v:=getv(cat(c,ref),cat(m,"_P"),"E",r)-getv(cat(c,"_P"),m,"E",r) elif (k="PRe" ) then v:=getv(cat(c,"_P"),cat(m,ref2),"E",r)-getv(cat(c,ref),m,"E",r) elif (k="PRs" ) then v:=(getv(c,m,"PRe",r)+getv(c,m,"PRE",r))/2 elif (k="PRa" ) then v:= getv(c,m,"PRe",r)-getv(c,m,"PRE",r) elif (k="PREo" ) then v:=getv(cat(c,"_P"),cat(m,"_O"),"HOMO",r)-getv(c,m,"HOMO",r)-getv(c,m,"PRe",r) elif (k="LUMO" ) then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,"evl(1)")[2] end elif (k="LUMO2") then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,"evl(2)")[4] end elif (k="dLUMO") then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,"evl(2)"); v:=v[4]-v[3] end elif (k="dEA" ) then v:=-getv(c,m,"NVE",r)+getv(c,m,"LUMO",r) elif (k="dAEA" ) then v:=-getv(c,m,"NAE",r)+getv(c,m,"LUMO",r) elif (k="NAE" ) then v:=getv(cat(c,"_N"),m,"E",r)-getv(cat(c,ref),m,"E",r) elif (k="AEA" ) then v:=-getv(c,m,"NAE",r) elif (k="NVE" ) then v:=getv(c,cat(m,"_N"),"E",r)-getv(c,m,"E",r) elif (k="EA" ) then v:=-getv(c,m,"NVE",r) elif (k="NVe" ) then v:=getv(cat(c,"_N"),m,"E",r)-getv(cat(c,"_N"),cat(m,ref2),"E",r) elif (k="NRE" ) then v:=getv(cat(c,ref),cat(m,"_N"),"E",r)-getv(cat(c,"_N"),m,"E",r) elif (k="NRe" ) then v:=getv(cat(c,"_N"),cat(m,ref2),"E",r)-getv(cat(c,ref),m,"E",r) elif (k="NRs" ) then v:=(getv(c,m,"NRe",r)+getv(c,m,"NRE",r))/2 elif (k="NRa" ) then v:=getv(c,m,"NRe",r)-getv(c,m,"NRE",r) elif (k="NREo" ) then v:=getv(c,m,"LUMO",r)-getv(cat(c,"_N"),cat(m,"_O"),"LUMO",r)-getv(c,m,"NRe",r) elif (k="TAE" ) then v:=getv(cat(c,"_T"),m,"E",r)-getv(cat(c,ref),m,"E",r) elif (k="TVE" or k="sgap" ) then v:=getv(c,cat(m,"_T"),"E",r)-getv(c,m,"E",r) elif (k="TVe" or k="phoe" ) then v:=getv(cat(c,"_T"),m,"E",r)-getv(cat(c,"_T"),cat(m,ref2),"E",r) elif (k="TRE" ) then v:=getv(cat(c,ref),cat(m,"_T"),"E",r)-getv(cat(c,"_T"),m,"E",r) elif (k="TRe" ) then v:=getv(cat(c,"_T"),cat(m,ref2),"E",r)-getv(cat(c,ref),m,"E",r) elif (k="TRs" ) then v:=(getv(c,m,"TRe",r)+getv(c,m,"TRE",r))/2 elif (k="TRa" ) then v:=getv(c,m,"TRe",r)-getv(c,m,"TRE",r) elif (k="RTE" ) then f:=getv(c,cat(m,"_exc"),"fout",r); if (f<>undefined) then v:=ReadOutput(f,"E")+ReadExcStates(f)[1][1] end elif (k="RTe" ) then f:=getv(cat(c,"_R"),cat(m,"_exc"),"fout",r); if (f<>undefined) then v:=ReadOutput(f,"E")+ReadExcStates(f)[1][1] end elif (k="RAE" ) then v:=getv(c,m,"RTE",r)-getv(c,cat(m,"_exc"),"E",r) elif (k="RVE" or k="ogap" or k="abse" ) then f:=getv(c,cat(m,"_exc"),"fout",r); if (f<>undefined) then v:=ReadExcStates(f)[1][1] end elif (k="RVe" or k="emie" ) then f:=getv(cat(c,"_R"),cat(m,"_exc"),"fout",r); if (f<>undefined) then v:=ReadExcStates(f)[1][1] end elif (k="RRE" ) then v:=getv(c,m,"RTE",r)-getv(c,m,"RTe",r) elif (k="RRe" ) then v:=getv(cat(c,"_R"),cat(m,"_exc"),"E",r)-getv(c,cat(m,"_exc"),"E",r) elif (k="RRs" ) then v:=(getv(c,m,"RVE",r)-getv(c,m,"RVe",r))/2 elif (k="RRa" ) then v:=getv(c,m,"RRe",r)-getv(c,m,"RRE",r) elif (k="gap" ) then v:=getv(c,m,"LUMO",r)-getv(c,m,"HOMO",r) elif (k="cgap" ) then v:=getv(c,cat(m,"_P"),"E",r)+getv(c,cat(m,"_N"),"E",r)-2*getv(c,m,"E",r) elif (k="chi" ) then v:=(getv(c,cat(m,"_P"),"E",r)-getv(c,cat(m,"_N"),"E",r))/2 elif (k="absf" ) then f:=getv(c,cat(m,"_exc"),"fout",r); if (f<>undefined) then v:=ReadExcStates(f)[1][2] end elif (k="absd" ) then f:=getv(c,cat(m,"_exc"),"fout",r); if (f<>undefined) then v:=ReadExcStates(f)[1][3] end elif (k="emif" ) then f:=getv(cat(c,"_R"),cat(m,"_exc"),"fout",r); if (f<>undefined) then v:=ReadExcStates(f)[1][2] end elif (k="emid" ) then f:=getv(cat(c,"_R"),cat(m,"_exc"),"fout",r); if (f<>undefined) then v:=ReadExcStates(f)[1][3] end elif (k="ZPE" ) then f:=getv(c,cat(m,"_freq"),"fout",r); if (f<>undefined) then v:=ReadOutput(f,"ZPE") end elif (k[1]="q" and member(k[2..],["Mul","NBO","ESP","CM5","Hir"])) then f:=getv(c,m,"fout",r); if (f<>undefined) then v:=ReadOutput(f,"q",k[2..]) end else error("Unrecognized key: %1",k) end; if (v=Float(undefined)) then v:=undefined end; v end: #hfl: getv getvlbl:=table([ "in"="Input line", "A"="Atoms", "Ainput"="Atoms (input)", "Aending"="Atoms (ending)", "na"="Number of atoms", "SG"="Symmetry", "ESS"="Electronic state symmetry", "E"="Total energy", "F"="Free energy", "G"="Gradient", "H"="Hessian", "BS"="Basis set", "DBS"="Density fitting basis set", "N"="Basis set size", "No"="Number of orbitals per k-point", "Nk"="Number of k-points", "KPOINTS"="Number of k-points along each of three directions", "kgrid"="List of k-points", "Ne"="Number of electrons", "Na"="Number of spin-up electrons", "Nb"="Number of spin-down electrons", "EFermi"="Fermi level", "evl"="Eigenvalues", "evla"="Spin-up eigenvalues", "evlb"="Spin-down eigenvalues", "Sz"="Spin z-component", "S2"="Squared spin", "dS2"="Spin contamination", "d"="Electric dipole", "Q"="Electric quadrupole", "q"="Atomic charges", "md"="MD data", "EM"="Elastic moduli", "EM1"="Elastic moduli rigid-cell contribution", "EM2"="Elastic moduli ionic-relaxation contribution", "HOMO"="HOMO energy", "HOMO2"="HOMO-1 energy", "dHOMO"="HOMO gap", "dIP"="IP+HOMO", "dAIP"="Adiabatic IP + HOMO", "PAE"="Relaxed cation energy", "AIP"="Adiabatic ionization potential", "PVE"="Vertical cation energy", "IP"="Ionization potential", "PVe"="Hole detachment energy", "PRE"="Hole polaron relaxation energy", "PRe"="Hole removal relaxation energy", "PRs"="Hole symmetrized relaxation energy", "PRa"="Hole PES asymmetry energy", "PREo"="Hole polaron relaxation energy by HOMO", "LUMO"="LUMO energy", "LUMO2"="LUMO-1 energy", "dLUMO"="LUMO gap", "dEA"="EA+LUMO", "dAEA"="Adiabatic EA + LUMO", "NAE"="Relaxed anion energy", "AEA"="Adiabatic electron affinity", "NVE"="Vertical anion energy", "EA"="Electron affinity", "NVe"="Electron detachment energy", "NRE"="Electron polaron relaxation energy", "NRe"="Electron removal relaxation energy", "NRs"="Electron symmetrized relaxation energy", "NRa"="Electron PES asymmetry energy", "NREo"="Electron polaron relaxation energy by LUMO", "TAE"="Relaxed triplet energy", "TVE"="Triplet excitation energy", "TVe"="Triplet emission energy", "TRE"="Triplet polaron relaxation energy", "TRe"="Triplet deexcitation relaxation energy", "TRs"="Triplet symmetrized relaxation energy", "TRa"="Triplet PES asymmetry energy", "RAE"="Relaxed S1 energy", "RVE"="S1 excitation energy", "RVe"="S1 emission energy", "RRE"="S1 polaron relaxation energy", "RRe"="S1 deexcitation relaxation energy", "RRs"="Half Stokes shift", "RRa"="S0-S1 PES asymmetry energy", "absf"="S1 oscilator strength", "absd"="S1 transition dipole", "emif"="Relaxed S1 oscilator strength", "emid"="Relaxed S1 transition dipole", "gap"="HOMO-LUMO gap", "cgap"="Charge gap", "chi"="Electronegativity", "qMul"="Mulliken charges", "qNBO"="NBO charges", "qESP"="ESP charges", "qCM5"="CM5 charges", "qHir"="Hirshfeld charges", # aliases "abse"="Absorption edge", "emie"="Fluorescence energy", "phoe"="Phosphorescence energy", "ogap"="Optical gap", "sgap"="Spin gap", NULL]): #cat: Database #hfl: MaterialsData MaterialsData:=proc( id::string, output::string:="i", { exact::boolean:=false, any::boolean:=false, sep::string:="_", printout::boolean:=false, maxprint::posint:=5 },$) local id0,lsid0,lsid,tags,id1,f,A,desc,SG,FD,C,rec; if exact then if assigned('MaterialsTable[id]') then id1:=id else error("No data for id=%1",id) end else id0:=StringTools[Split](id,"_")[1]; lsid0:=MaterialsIndex[id0]; if not(type(lsid0,list)) then error("Unrecognized id: %1",id) end; lsid:=select(s->(s=id or s[..length(id)+length(sep)]=cat(id,sep)),lsid0); if printout then tags:=map(s->s[length(id)+1..],lsid[..min(maxprint,nops(lsid))]); printf("Requested id=%s, tags=[%{c,}s]\n",id,Vector(`if`(nops(lsid)>maxprint,[op(tags),sprintf(".. %d more",nops(lsid)-maxprint)],tags))) end; if (lsid=[]) then error("For id=%1 there is no matching entries in %2",id,lsid0) elif (nops(lsid)=1 or any) then id1:=lsid[1] else return lsid end end; f:=MaterialsTable[id1]; if printout then printf("Selected id=%s, data=%s\n",id1,f) end; if (f[-4..]=".cif" or f[-4..]=".xyz") then if not(FileTools[Exists](f)) then error("File %1 indexed in MaterialsTable by id=%2 does not exist",f,id1) end; if StringTools[RegMatch]("a|c|d|s",output) then if (f[-4..]=".xyz") then A,desc:=ReadXYZ(f,':-output'=2,':-printout'=printout); SG:=ReadRecord(desc,"SG::string",'input'="string"); if StringTools[RegMatch]("c|d",output) then FD,C:=xyz2cif(A,SG) end else FD,C:=ReadCIF(f,':-printout'=printout); SG:=C[7]; if StringTools[RegMatch]("a",output) then A:=cif2xyz(FD,C) end end end; seq( `if`(s="f",f, `if`(s="i",id1, `if`(s="a",A, `if`(s="c",C, `if`(s="d",FD, `if`(s="s",SG, `if`(s="r",[], `if`(s="p",ExpandPath(f,"p"), NULL)))))))),s=output) else rec:=ReadPAR(f); if StringTools[RegMatch]("a|c|d|s",output) then FD,C:=rec["Atoms"],rec["Cell"]; SG:=`if`(type(Cell,list),Cell[-1],Cell); A:=cif2xyz(FD,C) end; seq( `if`(s="f","", `if`(s="i",id1, `if`(s="a",A, `if`(s="c",C, `if`(s="d",FD, `if`(s="s",SG, `if`(s="r",rec, `if`(s="p","", NULL)))))))),s=output) end if end: #hfl: MaterialsData MaterialsTable:=table(): #hfl: MaterialsData MaterialsIndex:=table(): #hfl: IdentifyMolecule IdentifyMolecule:=proc( A::list, Co::list:=[], fpf::procedure:=MolFingerprint, { notds::boolean:=false, threshold::numeric:=.99, maxRMS::numeric:=99, det::{-1,0,1}:=0, printout::boolean:=false },$) local C,ntds,fp,sys,A0,C0,td,tds,G0,G,b,P,d,A1,P2,d2,G2,v; C:=`if`(nops(Co)=nops(A) and type(Co,list(list(posint))),Co,`if`(HasTopology(A),map2(op,4,A),ConnectAtoms(A,op(Co)))); ntds:=add(`if`(v[1]="D",1,0),v=A); fp:=fpf(`if`(notds,A,[seq(`if`(v[1]="D",subsop(1="H",v),v),v=A)])); if printout then printf("fp=%s\n",fp) end; sys:=MolSearchIndex[fp]; if not(type(sys,string)) then if printout then printf("Unrecognized fingerprint\n") end; return [] end; if printout then printf("sys=%s\n",sys) end; A0,C0,tds:=op(MolSearchTable[sys][[3,4,7]]); if (nops(tds)cat("{",L[k],"}"),AT)) end: #hfl: IdentifyMolecule MolSearchInit:=proc( prefix::string, tags::list(string):=[""], datalookup::list(string):=[], fpf::procedure:=MolFingerprint, { alkanes::nonnegint:=0, printout::boolean:=false},$) global MolSearchTable,MolSearchIndex; local syss,sys,tag,id,p,A,SG,Co,formula,tds,fp,n,fps; if (datalookup=[]) then if ([indices(MaterialsIndex,nolist)]=[]) then MolMod:-Setup('database') end else MolMod:-Setup('database','thisdatalookup'=datalookup) end; syss:=[indices(MaterialsIndex,'nolist')]; if printout then printf("%d records in MaterialsIndex\nList of no-file systems (if any):\n",nops(syss)) end; MolSearchTable:=table(); for sys in syss do for tag in [op(tags),"doesnotexist"] while not(assigned('MaterialsTable[cat(sys,prefix,tag)]')) do end; if (tag="doesnotexist") then if printout then MaterialsData(sys,':-printout'=printout) end else MolSearchTable[sys]:=cat(sys,prefix,tag) end end; syss:=[indices(MolSearchTable,nolist)]; if printout then printf("%d records in MolSearchTable\n",nops(syss)) end; MolSearchIndex:=table(); for sys in syss do id:=MolSearchTable[sys]; p,A,SG:=MaterialsData(id,"pas",'exact'); if HasTopology(A) then Co:=map2(op,4,A) else Co:=ConnectAtoms(A) end; formula:=EncodeFormula(A); p:=p[..SearchText(sys,p)+length(sys)]; try tds:=ReadRecord(cat(p,"dat/main.dat"),"tds::list",input="file") catch: tds:=[] end; fp:=fpf(A,Co); MolSearchTable[sys]:=[fp,id,A,Co,formula,SG,tds]; if assigned('MolSearchIndex[fp]') then WARNING("%1 is skipped because its fingerprint %2 is reserved for %3",sys,fp,MolSearchIndex[fp]) else MolSearchIndex[fp]:=sys end end; for n from 1 to alkanes do sys:=cat("polyethylene",n); id:=cat(sys,"_molec"); SG:=`if`(type(n,odd),"mm2y","2/m"); A:=Alkane(n); Co:=map2(op,4,A); formula:=EncodeFormula(A); tds:=[[1,4,nops(A)]]; fp:=fpf(A,Co); MolSearchTable[sys]:=[fp,id,A,Co,formula,SG,tds]; if assigned('MolSearchIndex[fp]') then WARNING("%1 is skipped because its fingerprint %2 is reserved for %3",sys,fp,MolSearchIndex[fp]) else MolSearchIndex[fp]:=sys end end; fps:=[indices(MolSearchIndex,'nolist')]; if printout then printf("%d records in MolSearchIndex\n",nops(fps)) end; nops(syss),nops(fps) end: #hfl: EOSfit EOSfit:=proc( VE::list, method::{posint,"Murnaghan"}:=4, { vrange::{range,numeric}:=0.01, extrarange::numeric:=1, vtext::{numeric,undefined}:=undefined, etext::{numeric,undefined}:=undefined, lunit::string:="Ao", eunit::string:="eV", punit::string:="GPa", tmpfile::string:=cat(tmpfld,"_tmp"), murn::string:="C:/Sci/murn.bat", digits::[nonnegint,nonnegint,nonnegint,nonnegint]:=[3,4,1,2], #V0,E0,K0,K0' printout::boolean:=false, plotout::{boolean,list}:=false, addplot::list:=[] },$) local ccP,n,V1,V2,E2,Vrng,Vmin,Emin,Vscale,Escale,xy,f,x0,V0,E,V,ans,v,K0,K0p,E0,r,dE,P,K,PK,i,p,stdE,VEplot,PKplot; ccP:=simplify(Unit(convert(eunit,name)/convert(lunit,name)^3/convert(punit,name))); n:=nops(VE); if (n<3) then error("At least 3 points are required but received %1",VE) end; V1,V2,E2:=min(map2(op,1,VE)),max(map2(op,1,VE)),max(map2(op,2,VE)); Vrng:=`if`(type(vrange,range),vrange,V1-vrange*(V2-V1)..V2+vrange*(V2-V1)); if type(method,posint) then if (n[(v[1]-Vmin)/Vscale,(v[2]-Emin)/Escale],VE); f:=LinearFit2(xy,method,"f"); x0:=fsolve(D(f),(V1-Vmin)/Vscale..(V2-Vmin)/Vscale); if not(type(x0,numeric)) then WARNING("Extrapolating outside the provided set of points"); x0:=fsolve(D(f),(max(0,V1-extrarange*(V2-V1))-Vmin)/Vscale..(V2+extrarange*(V2-V1)-Vmin)/Vscale); if not(type(x0,numeric)) then error("No extremum: %1",x0) end end; V0:=Vmin+Vscale*x0; E:=unapply(Emin+Escale*f((V-Vmin)/Vscale),V); E0:=E(V0); K0:=V0*(D@@2)(E)(V0); K0p:=-1-V0^2/K0*(D@@3)(E)(V0) elif (method="Murnaghan") then if (n<4) then error("Not enough points (%1) for method=%2",n,method) end; WriteLines(cat(tmpfile,".dat"),["2","1","1 2 2",sprintf("%d",n),seq(sprintf("%.8f %.8f",v[1]^(1/3),v[2]),v=VE)],'overwrite'); ans:=ssystem(sprintf("%s %s.dat %s.txt",murn,tmpfile$2)); if (ans[1]=0) then v,V0,K0,K0p,E0:=ReadValue(cat(tmpfile,".txt"),"alat=",'shift'=1,'format'="%f%f%f%f%f"); K0:=K0*simplify(Unit('Mbar/eV*bohr^3')); E:=unapply(`if`(K0p=1,E0+K0*(V-V0-V0*ln(V/V0)),E0+K0*V0*((V/V0)^(1-K0p)/(K0p*(K0p-1))+V/V0/K0p-1/(K0p-1))),V) else error("Failed murn.bat run: murn=%1, ans=%2",murn,ans) end end; r:=[seq(v[2]-E(v[1]),v=VE)]; dE:=sqrt(add(v^2,v=r)/n); for i from 1 to n do if (abs(r[i])>2*dE) then WARNING("Point %1 is out by %2*dE",i,FormatFloat(r[i]/dE,1)) end end; if printout then printf("%s fit over %d points: V0=%.*f %s^3, E0=%.*f %s, K0=%.*f %s, K0'=%.*f, stdE=%s m%s\n",`if`(type(method,string),method, sprintf("%d-order polynomial",method)),n,digits[1],V0,lunit,digits[2],E0,eunit,digits[3],K0*ccP,punit,digits[4],K0p,FormatFloat(1000*dE,2,'showzero'),eunit) end; stdE:=`if`(dE>10^(-digits[2]),sprintf("stdE=%s m%s\n",FormatFloat(1000*dE,2,'showzero'),eunit),""); VEplot:=[ plots[textplot]([`if`(type(vtext,numeric),vtext,V0),`if`(type(etext,numeric),etext,E2), sprintf("V0=%.*f\nE0=%.*f\n%sK0=%.*f %s\nK0'=%.*f",digits[1],V0,digits[2],E0,stdE,digits[3],K0*ccP,punit,digits[4],K0p)],'align'={"below"}), plot(E,Vrng,'labels'=[sprintf("Volume (%s^3)",lunit),sprintf("Energy (%s)",eunit)]), plot(VE,'style'="point")]; P:=-diff(E(V),V); K:=-V*diff(P,V); PK:=Vector(n-2); for i from 1 to n-2 do p:=-diff(CurveFitting[PolynomialInterpolation](VE[i..i+2],V),V); PK[i]:=eval([p,-V*diff(p,V)],V=VE[i+1][1]) end; PK:=convert(PK,list); PKplot:=[ plot([ccP*P,ccP*K,V=Vrng],'labels'=[sprintf("Pressure (%s)",punit),sprintf("Bulk modulus (%s)",punit)]), plot(ccP*PK,'style'="point",'symbolsize'=16)]; if (plotout=true or type(plotout,list)) then print(plots[display]([op(VEplot),op(addplot)],'axes'="boxed",`if`(type(plotout,list),op(plotout),NULL))); print(plot([seq([i,r[i]],i=1..n)],'style'="point",'symbolsize'=20,`if`(type(plotout,list),op(plotout),NULL))); print(plots[display](PKplot,'axes'="boxed",`if`(type(plotout,list),op(plotout),NULL))) end; op(1,E),dE,[V0,E0,K0*ccP,K0p],VEplot,PKplot end: # Read superpaginated MOPAC Fock matrix. Here modes are those printed by VASP ReadFockM:=proc(filename0::string, { pos::posint:=12, width::posint:=11, num::posint:=6, number::integer:=-1 },$) local filename,program,fd,fpos,N,BSL,iBSL,jBSL,s,F,j0,j,i; filename:=`if`(FileTools[Exists](filename0) and not(FileTools[IsDirectory](filename0)),filename0,cat(filename0,xout)); program:=WhatProgram(filename); if (program<>"mop") then error("ReadFockM is for MOPAC only, but this output was generated by %1",program) end; fd:=fopen(filename,READ,TEXT); fpos:=SearchFilePos(fd," FOCK MATRIX ",1..13,number); N,BSL,iBSL:=0,table(),table(): do s:=readline(fd); if (s="" or s[1..3]=" --" or s[1..3]=" ") then next elif (s=0 or s[2..pos-1]=BSL[num+1] or nops(sscanf(s[2..pos-1],"%s %s %d"))<>3) then break end; N:=N+1; BSL[N]:=s[2..pos-1]; iBSL[s[2..pos-1]]:=N; jBSL[cat(s[2..6],s[pos-3..pos-1])]:=N end; F:=Matrix(N,shape=symmetric,datatype=float); filepos(fd,fpos); do s:=readline(fd); if (s="" or s[1..3]=" --") then next elif (s[1..3]=" ") then j0:=jBSL[s[pos+width-8..pos+width-1]]-1; for j from 2 to min(num,N-j0) do if (jBSL[s[pos+width*j-8..pos+width*j-1]]<>j0+j) then error "Wrong orbital in line %1",s end end else i:=iBSL[s[2..pos-1]]; for j from 1 to min(num,i-j0) do F[i,j0+j]:=op(sscanf(s[pos+width*(j-1)..pos+width*j-1],"%f")) end; if (i=N and j0+j=N+1) then break end end end; fclose(fd); Vector(N,i->BSL[i]),F end: ######################################################################## ModuleLoad() end module: