program atoms implicit real(a-h,o-z) implicit integer(i-n) c include 'version.h' c-*-fortran-*- character*9 vrsion parameter (vrsion='2.50 ') c---------------------------------------------------------------------- c copyright 1998-2001 Bruce Ravel c copyright 1993-1997 University of Washington c written by Bruce Ravel c e-mail ravel@phys.washington.edu c WWW http://feff.phys.washington.edu/~ravel c please use email for communication with the author c c This program is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 2, or (at your option) c any later version. c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c You should have received a copy of the GNU General Public License c along with GNU Emacs; see the file COPYING. If not, write to c the Free Software Foundation, 675 Massachusettes Ave, c Cambridge, MA 02139, USA. c Everyone is granted permission to copy, modify and redistribute this c and related files provided: c 1. All copies contain this copyright notice. c 2. All modified copies shall carry a prominant notice stating who c made modifications and the date of such modifications. c 3. The name of the modified file be changed. c 4. No charge is made for this software or works derived from it. c This clause shall not be construed as constraining other software c distributed on the same medium as this software, nor is a c distribution fee considered a charge. c---------------------------------------------------------------------- c brief description of the code: c c atoms writes a list of atomic coordinates for any crystal given its c crystallographic information. the list will be sorted by radial c distance from an atom chosen as the central atom. atoms also estimates c the bulk absorption and density of the material and various corrections c to xafs data due to experimental effects. c---------------------------------------------------------------------- c comments blocks that follow: c glossary of variables c descriptions of runtime error codes c sample input file c version history c c the code begins after the first occurance of this string: %%%% c the first executable statement begins after its second occurance c---------------------------------------------------------------------- c >>> glossary of variables c include 'glossary' c=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c this is a list of globaly or commonly used parameters and c variables with brief descriptions of their purposes c () = dimension, [] = set of values, {} = alternate name c c=-=-=-=-=-=-=-=-=-=-=-=-=-= parameters =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c eps: a small number for use in floating point logicals c etok: conversion between ev and invang c iat: maximum number of unique atoms c natx: maximum number of atoms in cluster c ndopx: maximum number of dopants at a site c nfit: maximum number of points for linear regression c ngeomx: maximum number of one bounce flags c ntitx: maximum number of title lines c nvals: maximum number of parameters for linear regression c nwdx: maximum number of words for bwords c nlogx: maximum number of logic flags in array logic c nexafs: maximum number of items calculated from mcmaster data c vrsion: version number c c=-=-=-=-=-=-=-=-=-=-=-=-=-= integers =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c iatom: number of atoms in atom list c ibasis: number of atoms in basis list c ipt: (iat), number of positions of a unique atom in unit cell c iptful: (iat), number of positions of a unique atom in overfull cell c imult: (iat), multiplicity at each site c ispa: [1..230], number of space group in itxc c isyst: [1..8], identifies crystal system c itot: number of atoms found in cluster c job: counts complete runs through code with multiple inputs c ngeom: (ngeomx) one-bounce flags for geom.dat c ns: {also ng}, simple multiplicity at a point c nsites: equal iatom or, if using basis, equals ibasis c ntit: (9), number of title lines c c=-=-=-=-=-=-=-=-=-=-=-=-=-= logicals =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c vaxflg: true for compilation on vms, for open status of files c stdout: true for stdin/stdout operation, false for disk operation c expnd: true to use expanded atoms list, false for normal c logic: (nlogx) array of various run control and diagnostic flags, c see arrays.map c c=-=-=-=-=-=-=-=-=-=-=-=-= characters =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c core: atomic symbol of central atom c cnum: used to write out numbers with messag c dopant: (iat,ndopx) atomic symbols of atoms at site (main+dopants) c edge: k or l3 edge of core atom c messg: string sent to messag c outfil: output file name c spcgrp: space group of crystal C title: (ntitx), user input title lines c c=-=-=-=-=-=-=-=-=-=-=-=-=-=-= reals =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c ampslf: self-absorption amplitude correction c atlis: (natx,8), list of atoms in cluster, fractional, and cartesian c cell: (6), a,b,c,alpha,beta, and gamma of cell c dmax: radius of cluster c fulcel: (iat,192,3), coordinates of atoms in overfull cell c fs: (3,3,24), c gasses: (3) percent by pressure in i0 chamber of argon, krypton, nitrogen c percnt: (iat,ndopx) percent substitution of dopants for replaced atoms c exafs: (10) array of values from mcamster calculation c st: (iat,192,3), fractioanl coords of points after bravais transl. c trmtx: (3,3), transformation matrix between cartesian and cell-axis c ts: (3,24), fractional positions of points before bravais transl. c x: (iat), fractional coordinate of unique atoms c y: (iat), fractional coordinate of unique atoms c z: (iat), fractional coordinate of unique atoms c c=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c >>> runtime error codes c include 'runtime' c---------------------------------------------------------------------- c Error Codes c c All error messages are of 1 or more lines. They begin with three c asterixes (***) followed by a token and end with a period c followed by a dash (.-). If an input file keyword appears in the c message, it should be surrounded by double quotes. c c When an error is caught, it should set an error code. The codes are c 0 no error (and no message) c 1 informational (tokens: Caution Position Ending) c 2 warning (token: Warning) c 3 error (token: Error) c c Informational messages are those that do not indicate a problem, c but do indicate something the user should know about. Currently c used informational messages are for debugging messages, c positional messages, impending early termination of the program, c and non-serious cautions. c Warnings are for things that should not impede the progress of the c program, but which may produce output that is not what the user c intended. Warnings include unknown keywords and exceeded parameters. c Errors are things the preclude the continuation of the program. c---------------------------------------------------------------------- c=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c >>> sample input file: c include 'sample' c c title pbtio3 n&k,10k,a=3.885,c=4.139 c space p 4 m m c a=3.885 c=4.139 c rmax=10 core=ti c atom c ! at.type x y z tag c pb 0.0 0.0 0.0 c ti 0.5 0.5 0.5377 c o 0.5 0.5 0.1118 o1 c o 0.0 0.5 0.6174 o2 c ------------------------------------------------- c=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= c >>> history c include 'history' c 1.0 got it working c 2.0 satisfied copyright criteria in cluster expansion routines c 2.1 added indexing (8/92) c 2.2 added absorption length (9/92) c 2.3 improved handling of spc grp notation, fixed bcc bug, c fixed floating point logic (1/93) c 2.4 handle bases, atom list option, shift (3/93), mcmaster c correction (4/93) c approaching 3 too quickly, switch to hundredths c 2.41 mcmaster correction corrected, i0 and self absorption c corrections, new cluster expansion routine, overfull c unit cell, simple dopant, more error checking on input, c multiple title lines, untab, shift warning and c version number in feff.inp (6/93) c 2.42 modularized in anticipation of dafs applications (6/93) c general housekeeping, tags, improved dopants, core keyword c required, case insensitivity in code, geom.dat + subshell c sorting, self-absorption bug fixed (8/93 and 10/93) c 2.42.a lower case and true robustness, revamped input parsing for c better error checking, handle overlapping atoms better, hex c C, V symmetry groups, corrected tri/hex bug in atinpt, no c mcmaster for Z<13, diagnostic messages from input file (1/94) c corrected bug in dopants, c more housekeeping (2/94) calculate delta mu from core rather c than total mu and reinstate mcmaster for Z<13 (3/94) c silly bug in atinpt that trashed nonorthoganal groups fixed, c also improved error messages (3/94) c 2.42.b fixed mishandling of rhombohedral groups (6/94) c 2.42.c pass parameters as arguments for easier hacking, had to pass c some memory space to certain subroutines, fixed a bug c in subroutine ref that was affecting geout, 72 character c names for output files, pass io number for feff.inp, c l1&l2, move origin into readin (8/94) c 2.42.d contains full fuctionality of 2.43.c except for dafs apps (1/95) c 2.42.e contains full fuctionality of 2.43.d except for dafs apps (2/95) c 2.42.f contains full fuctionality of 2.43.f except for dafs apps c & up parallel development to 2.43 without dafs apps c c 2.43 tabulate chantler's data for interpolation, wrote fcal -- c an engine for using chantler's data, wrote a0.f for reading c chantler and cromer-mann and making a0, write a0 as a five c column file suitable for feffit, no energy corrections (8/94) c 2.43.b new a0 filename, allow neg. q's, fix null atoms handling, c fixed mishandling of trigonal (not rhomb.) groups (9/94) c added warning message for low symmetry cells, added my name c to feff.inp and run time messages(11/94), fix some error c messages (1/95) c 2.43.c full sasaki tables, fixed espilon bug in multip, added p1 c option (1/95) c 2.43.d after UWXAFS 3.0 release -- fixed bug with dmax < min distance c (2/95) c skip subversion e c 2.43.f fixed bug in self-absorption calculation, added krypton to I0, c geom.dat and feff.dat write same number of atoms (4/95) c 2.43.g no file name conflicts, much improved internal documentation c (7/95) c c 2.44. & 2.45. handles different settings of low symmetry crystals, c improve handling of schoenflies notation, better error c messages for mcmaster calculations (8/95), compile time c switch for stdin/stdout (9/95), typo in syschk, in c multip minor bug re. imult for atom with coord=1 c edge energy in feff.inp, allow L1&l2 (10/95) c 2.44 & up parallels 2.45 without dafs apps c 2.45.a fixed bug in f.p. comparisons in indexing, five digits in c feff.inp, geom.dat no longer depends on scratch file (11/95) c 2.45.b central atom gets tag, reflect.dat (12/95) c c 2.46 & up parallels 2.47 without dafs apps and extended atoms list c 2.47 tighten modularity & combine variables into arrays, fix problem c with nofx and polyft by explicitly carrying around misc.f file, c information for fluorescence normalization, move atoms list c parsing to external subroutine to allow expanded atoms list, c rmax card to 5 digits + 0.00001, fixed potential numerical c problem in metric (2/96) made groups module (3/96) angles in c monoclinic settings, c 2.4?.b rework makefile using uninclude perl script and unzipped c modules, added xanes card c 2.4?.c added keywords "feff8" and "correction", added optional c feff8 output (BR Jan 16 1998) c c to do: new crystal, fix monoclinic angles c c 2.50 change structure of source tree, use libraries and include c files in a more sensible manner, (BR Mar 2 1998) (goals c for 2.50pre1: modularize crystl+groups+clustr, remove logic() c c changes in functionality from versions before 2.50 c 1. no longer support more than one job per file c 2. consistent message syntax for post-processing purposes c c goals for 2.50pre2: clean up remaining code, allow spcgrp=ispa, c end keyord wade through code cleaning up c run-time messages c goals for 2.50pre3: begin work on monoclinic c other goals for 2.50: revise document, write crystl user guide, c more output types, see wishlist c---------------------------------------------------------------------- c%%%% c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ c stdout=.true. for reading from standard input and writing to standard c output logical stdout parameter (stdout=.false.) c expnd=.true. for reading expanded atoms list, false for normal atoms list logical expnd parameter (expnd=.false.) c vaxflg=.true. for compilation on a VMS machine, used for opening c files in such a way that VMS version numbers are used logical vaxflg parameter (vaxflg=.false.) c crystl.h contains all information relevant to a unit cell c include 'crystl.h' c-*-fortran-*- c various parameters used by module crystl common /cryint/ iabs, iatom, ibasis, isystm, ispa, iperm, nsites, $ ipt(iat), idop(iat), imult(iat) save /cryint/ parameter(nsysm=4, nshwrn=4) character*2 dopant(iat,ndopx) character*10 spcgrp, tag(iat) character*74 shwarn(nshwrn) character*77 sysmes(nsysm) common /crystr/ shwarn, sysmes, dopant, tag, spcgrp save /crystr/ logical syserr, shift common /crylog/ syserr, shift save /crylog/ dimension trmtx(3,3), st(iat,192,3) dimension cell(6), x(iat), y(iat), z(iat) dimension percnt(iat,ndopx) common /cryflt/ trmtx, st, cell, x, y, z, percnt save /cryflt/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, % = error handling, ! = output needed to c construct cluster, the rest are used internally) c c * iabs: index of absorber in unique coordinate list c * iatom: >=1 if atoms list is used, else =1 c * ibasis: =1 if basis list is used, else =0 c isystm: index of crystal system (1..7)=(mono,orth,,tetr, c cubic,hex,triclinic) c ispa: space group index, 1-230 from IXTC c 0: not recognized, error in input symbol c 1-2: triclinic c 3-15: monoclinic c 16-74: orthorhombic c 75-142: tetragonal c 143-167: trigonal c 168-194: hexagonal c 195-230: cubic c iperm: permutation index for non-standard settings, used in crystl c 1: default value -- no permutation necessary c 1-6: 6 orthorhombic settings (abc, cab, bca, a-cb, ba-c, -cba) c 11-12: 2 monoclinic settings, z-axis unique, y-axis unique c 21-22: 2 tetragonal settings, standard and rotated c ! ipt: (iat) number of positions of unique atom in unit cell (1..192) c imult: (iat) workspace for calculating multiplicities c c % sysmes: 4 line message if space group and axes/angles don't match c % syserr: true if space group and axes/angles don't match c % shwarn: 3 line message if space group may require a shift vector c % shift: true if space group may require a shift vector c c * dopant*2: (iat,ndopx) matrix with all host and dopant atomic symbols c * percnt: (iat,ndopx) matrix with occupancies of hosts and dopants c * tag*10: (iat) character tag for each unique site in cell c * spcgrp*10: space group symbol. On output it is the short c Hermann-Maguin symbol in standard setting. On input c spcgrp can be any short HM, Schoenflies, a number c between 1 and 230, or one of a small set of special c words (fcc, bcc, etc.). Other symbol conventions c (full HM symbol, Shubnikov, 1935 ITXC, etc.) are not c and never will be used. c c * x,y,z: (iat) arrays of fractional coordinates of unique positions c in unit cell c * cell: (6) array of a,b,c,alpha,beta,gamma c c ! trmtx: (3,3) transformation matrix between cell-axis and cartesian c bases, see subroutine trans in clustr c ! st: (iat,192,3) fractional coordinates of all atoms in unit cell, c first arg refers to unique atom list, second c to position in cell, third is xyz. c c fyi: 192 is the largest possible number of equivalent c positions in a cell of any symmetry. see, for example, c cubic f m 3 c. c---------------------------------------------------------------------- c exafs.h contains information relevant to exafs calculations c include 'exafs.h' c-*-fortran-*- common /exaflt/ gasses(3), exafs(nexafs), rmax save /exaflt/ common /exaint/ iedge, iexerr save /exaint/ character*10 core, edge*2 common /exastr/ core, edge save /exastr/ logical lfluo common /exalog/ lfluo save /exalog/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, ! = output, % = error handling) c c * gasses: (3) percent pressure of argon, krypton, nitrogen in i0 chamber c gasses(1) percentage of argon c gasses(2) percentage of krypton c gasses(3) percentage of nitrogen c ! exafs: (13) amu,delmu,spgrav,sigmm,qrtmm,ampslf,sigslf,qrtslf, c sigi0,qrti0,muf,mub,mue c exafs(1): total mu c exafs(2): delta mu c exafs(3): speciffic gravity c exafs(4): mcmaster sigma^2 c exafs(5): mcmaster C4 c exafs(6): self absorption amplitude correction c exafs(7): self absorption sigma^2 c exafs(8): self absorption C4 c exafs(9): i0 corrcetion sigma^2 c exafs(10): i0 correction C4 c * iedge: edge for calulation, 1=K 2=L1 3=L2 4=L3 c * iexerr: exit error code, 0=no prob, 1=info, 2=warning, 3=error c * core*10: tag of absorbing atom c lfluo: true if fluorescence corrections were calculated c---------------------------------------------------------------------- c unit.h contains information over-full unit cell information c include 'unit.h' c-*-fortran-*- common /uninum/ iptful(iat), fullcl(iat,192,3) save /uninum/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c * iptful: (iat) number of positions of unique atom in overfull unit cell c * fullcl: (iat,192,3) fractional coords of all atoms in overfull unit cell c---------------------------------------------------------------------- c see glossary for descriptions of variables, see arrays.map for c description of logic, gasses, exafs parameter(m=8) character*2 elemnt(iat), test, vrsn*9 character*10 inpgrp, noantg(iat) character*72 title(ntitx), outfil, afname, refile character*78 messg character*78 module, string logical logic(nlogx) complex anot(neptx) dimension ngeom(ngeomx) dimension atlis(natx,8), qvect(3) dimension nrefl(3) c reserve some array space for use in modules cluster and output dimension cltmp1(natx), cltmp2(natx), cltmp3(natx,m) logical cltmp4(natx) character*10 optmp1(maxln) dimension optmp2(maxln), optmp3(maxln), optmp4(maxln), $ optmp5(maxln), ioptp6(maxln), ioptp7(maxln) c------------------------------------------------------------------------ c-- dafs stuff c dimension f0(iat,ndopx), usqr(iat) c complex fcore(neptx) c c from block data sasaki c parameter(nelem=92, ndatx=233) c common /fdat/ nfdata(nelem), engrd(nelem,ndatx), c $ fp(nelem,ndatx), fpp(nelem,ndatx) c c this is the crommer-mann common block c common /sk/ aa(1926) c------------------------------------------------------------------------ c------------------------------------------------------------------------ c formats needed at top level: version # (4000), line of '=' (4010), c ... aN,(55-N)x ... 4000 format('ATOMS ',a9,46x,'by Bruce Ravel') 4010 format(75('=')) c%%%% c--------------------------------------------------------------------- c run time messages: lines of '=' and version number c set unit number of feff.inp if (.not.stdout) then ifeff = 2 write(messg,4010) call messag(messg) write(messg,4000)vrsion call messag(messg) write(messg,4010) call messag(messg) else c this clause may trigger a compiler warning regarding there being no c possible path to this spot in the code. this is an unavoidable c result of using F77 and no preprocessor and should pose no problem c during execution of the code. ifeff = 6 endif c--------------------------------------------------------------------- c initialize some top-level variables vrsn = vrsion test = 'ab' logic(1) = .false. module = 'Atoms' c 10 continue c===================================================================== c atoms module 1: initialize, read input file, error checking c===================================================================== c print*,'beginning module 1' call readin(iat, natx, ntitx, ndopx, ngeomx, neptx, nlogx, $ ifeff, ntit, iatom, ibasis, iabs, isystm, $ iperm, ipt, iptful, idop, ngeom, iedge, $ nepts, nsites, nrefl, nnoan, $ vrsn, spcgrp, inpgrp, title, outfil, afname, $ refile, tag, noantg, edge, core, elemnt, dopant, $ x, y, z, cell, rmax, st, fullcl, atlis, $ percnt, gasses, qvect, egr, anot, $ logic, stdout, vaxflg, expnd) if (logic(1)) goto 99 c===================================================================== c atoms module 2: decode space group, determine unit cell contents c===================================================================== string = 'the crystl module' if (logic(20)) call positn(module, string) iunidb = 0 if (logic(21)) icrydb = icrydb + 2**0 call crystl(icrydb, iercry) if ( (.not.stdout).and.syserr ) then call messag(' ') call messag(' *** Warning ') do 20 i=1,nsysm call messag(sysmes(i)) 20 continue call messag('The calculation will be finished, but you '// $ 'might want to edit your') call messag('crystallographic input data and try again.-') call messag(' ') endif c===================================================================== c atoms module 3: perform various calculations using mcmaster tables c===================================================================== if (logic(28)) then string = 'the mcm module' if (logic(7)) then if (logic(20)) call positn(module, string) iexadb = 0 if (logic(22)) iexadb = iexadb + 2**0 if (logic(14)) iexadb = iexadb + 2**1 if (logic(15)) iexadb = iexadb + 2**2 if (logic(16)) iexadb = iexadb + 2**3 call mcm(iexadb) endif if (.not.lfluo) logic(3)=.false. endif c===================================================================== c atoms module 4: construct unit.dat c===================================================================== string = 'the unit module' if (logic(20)) call positn(module, string) iunidb = 0 if (logic(23)) iunidb = iunidb + 2**0 if (logic(8)) iunidb = iunidb + 2**1 if (logic(9)) iunidb = iunidb + 2**2 call unit(iunidb, ntit, title, vaxflg, ieruni) c===================================================================== c atoms module 5: construct structure factor for dafs applications c===================================================================== c if (logic(10).or.logic(11)) then c string = 'the ascat module' c if (logic(20)) call positn(module, string) c call ascat(iat, ntitx, ndopx, neptx, nlogx, c $ nsites, ipt, idop, ntit, nepts, nrefl, nnoan, c $ edge, core, dopant, title, afname, refile, vrsn, c $ tag, noantg, c $ st, usqr, cell, percnt, qvect, egr, fcore, f0, c $ anot, logic, vaxflg) c endif c===================================================================== c atoms module 6: expand cluster around central atom c===================================================================== if (logic(7)) then string = 'the clustr module' if (logic(20)) call positn(module, string) call clustr(iat,natx,ngeomx,nlogx, $ iabs,nsites,iperm,ipt,itot,ngeom, $ cell,trmtx,rmax,st,atlis, $ cltmp1,cltmp2,cltmp3,cltmp4, $ logic) c===================================================================== c atoms module 7: write feff.inp, geom.dat c===================================================================== string = 'the output module' if (logic(20)) call positn(module, string) call output(iat, natx, ntitx, ndopx, ngeomx, maxln, nlogx, $ nexafs, $ ifeff, iabs, itot, ntit, idop, ngeom, imult, $ title, tag, edge, core, dopant, outfil, elemnt, $ vrsn, percnt, exafs, atlis, $ logic, vaxflg, $ optmp1,optmp2,optmp3,optmp4,optmp5,ioptp6,ioptp7) c##################################################################### c--------------------------------------------------------------------- c run time message: output file and line of '=' if ((logic(6)).and.(outfil.ne.'list')) then if (logic(13)) then call messag('geom.dat overwritten.') else call messag('geom.dat written.') endif endif if (.not.stdout) then ii = istrln(outfil) if (logic(12)) then call messag(outfil(:ii)//' overwritten.') else call messag('Output written to '//outfil(:ii)) endif endif else call messag('not writing feff.inp.') endif if (.not.stdout) then write(messg,4010) call messag(messg) endif c--------------------------------------------------------------------- c if (.not.logic(1)) goto 10 99 continue stop c end main program atom end subroutine readin(iat,natx,ntitx,ndopx,ngeomx,neptx,nlogx,ifeff, $ ntit,iatom,ibasis,iabs,isystm,iperm, $ ipt,iptful,idop,ngeom,iedge,nepts,nsites,nrefl,nnoan, $ vrsion,spcgrp,inpgrp,title,outfil,afname,refile, $ tag,noantg,edge,core,elemnt,dopant, $ x,y,z,cell,dmax,st,fullcl,atlis, $ percnt,gasses,qvect,egr,anot, $ logic,stdout,vaxflg,expnd) c===================================================================== c atoms module 1: initialize, read input file, error checking c===================================================================== c this module consists of the following subroutines and functions: c readin atchck atinit atinpt atspec dopfix getatm groups origin c rh2hex schfix settng spcchk systm c===================================================================== implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) c parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=800) c parameter (neptx=2**11) character*2 elemnt(iat) character*2 edge, dopant(iat,ndopx), vrsion*9, test character*10 spcgrp, inpgrp, tag(iat), core, geodat, noantg(iat) character*72 title(ntitx),outfil,afname,outf,refile character*74 messg logical logic(nlogx), stdout, vaxflg, expnd, shift complex anot(neptx) dimension ipt(iat), iptful(iat), idop(iat), $ ngeom(ngeomx), nrefl(3) dimension x(iat), y(iat), z(iat) dimension cell(6), qvect(3), gasses(3) dimension st(iat,192,3), fullcl(iat,192,3), atlis(natx,8) dimension percnt(iat,ndopx) parameter(nshwrn=4) character*74 shwarn(nshwrn) logical shft 4000 format(35('*-'),'*') 4010 format(1x,'* ',a75) 4020 format(1x,' ') 4100 format(1x,'* This feff.inp file generated by ATOMS, version ', $ a9,/,' * ATOMS written by and copyright (c) Bruce Ravel', $ ', 1992-1999',/) c------------------------------------------------------------ c initialize everything and read the input file c then check the consistency of the input values and c determine system from cell constants c call messag(' initializing...') call atinit(iat,natx,ntitx,ndopx,ngeomx,neptx,nlogx, $ title,elemnt,tag,noantg,spcgrp,edge,core, $ dopant,outfil,afname,geodat,refile, $ iatom,ibasis,dmax,ispa,iperm,idop,ngeom,iedge,iabs, $ ipt,iptful,isyst,nepts,nrefl,nnoan, $ x,y,z,cell,st,fullcl,atlis, $ percnt,gasses,qvect,egr,anot, $ logic,stdout) c call messag(' reading atom.inp...') call atinpt(iat,ntitx,ndopx,nlogx, $ title,ntit,iatom,ibasis,iabs,dmax,ispa,iperm, $ idop,iedge,nepts,nrefl,isystm,nnoan, $ elemnt,tag,noantg,edge,core,spcgrp,inpgrp, $ outfil,shwarn,afname,refile,dopant, $ x,y,z,cell,percnt,gasses,qvect,egr, $ logic, stdout, expnd, shift) if (logic(1)) goto 99 c this is a lame work-around for not yet having headers in readin call igtisp(ispa) c call messag(' consistancy checks...') call atchck(iat,ndopx,core,dopant,edge, $ iatom,ibasis,ispa,idop, $ x,y,z,cell,dmax,gasses,qvect) c a few more chores before leaving nsites = iatom if (logic(2)) nsites=ibasis inquire(file=outfil,exist=logic(12)) if (logic(6)) inquire(file=geodat,exist=logic(13)) test = 'ab' outf=outfil call case(test,outf) if (stdout) then write(ifeff,4100)vrsion c call origin(spcgrp, warn, wrning) else if (outf.eq.'list') then inquire(file='atoms.lis',exist=logic(12)) else if (.not.vaxflg) then open(unit=ifeff,file=outfil,status='unknown') else open(unit=ifeff,file=outfil,status='new') endif write(ifeff,4100)vrsion endif endif c --- give warning about space groups that need shift c call origin(spcgrp, warn, wrning) call gtshft(shft,shwarn) if (shft) then if (ifeff.ne.6) then write(messg,4000) c call messag(messg) call messag(' ') call messag(' *** Warning:') endif do 20 i=1,nshwrn if (ifeff.eq.6) then call messag('* '//shwarn(i)) else call messag(shwarn(i)) write(ifeff,4010)shwarn(i) endif 20 continue write(ifeff,4020) if (ifeff.ne.6) then write(messg,4000) c call messag(messg) call messag(' ') endif ierr = 2 endif 99 continue return c end of module readin end subroutine igtisp(isp) c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ c include 'crystl.h' c-*-fortran-*- c various parameters used by module crystl common /cryint/ iabs, iatom, ibasis, isystm, ispa, iperm, nsites, $ ipt(iat), idop(iat), imult(iat) save /cryint/ parameter(nsysm=4, nshwrn=4) character*2 dopant(iat,ndopx) character*10 spcgrp, tag(iat) character*74 shwarn(nshwrn) character*77 sysmes(nsysm) common /crystr/ shwarn, sysmes, dopant, tag, spcgrp save /crystr/ logical syserr, shift common /crylog/ syserr, shift save /crylog/ dimension trmtx(3,3), st(iat,192,3) dimension cell(6), x(iat), y(iat), z(iat) dimension percnt(iat,ndopx) common /cryflt/ trmtx, st, cell, x, y, z, percnt save /cryflt/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, % = error handling, ! = output needed to c construct cluster, the rest are used internally) c c * iabs: index of absorber in unique coordinate list c * iatom: >=1 if atoms list is used, else =1 c * ibasis: =1 if basis list is used, else =0 c isystm: index of crystal system (1..7)=(mono,orth,,tetr, c cubic,hex,triclinic) c ispa: space group index, 1-230 from IXTC c 0: not recognized, error in input symbol c 1-2: triclinic c 3-15: monoclinic c 16-74: orthorhombic c 75-142: tetragonal c 143-167: trigonal c 168-194: hexagonal c 195-230: cubic c iperm: permutation index for non-standard settings, used in crystl c 1: default value -- no permutation necessary c 1-6: 6 orthorhombic settings (abc, cab, bca, a-cb, ba-c, -cba) c 11-12: 2 monoclinic settings, z-axis unique, y-axis unique c 21-22: 2 tetragonal settings, standard and rotated c ! ipt: (iat) number of positions of unique atom in unit cell (1..192) c imult: (iat) workspace for calculating multiplicities c c % sysmes: 4 line message if space group and axes/angles don't match c % syserr: true if space group and axes/angles don't match c % shwarn: 3 line message if space group may require a shift vector c % shift: true if space group may require a shift vector c c * dopant*2: (iat,ndopx) matrix with all host and dopant atomic symbols c * percnt: (iat,ndopx) matrix with occupancies of hosts and dopants c * tag*10: (iat) character tag for each unique site in cell c * spcgrp*10: space group symbol. On output it is the short c Hermann-Maguin symbol in standard setting. On input c spcgrp can be any short HM, Schoenflies, a number c between 1 and 230, or one of a small set of special c words (fcc, bcc, etc.). Other symbol conventions c (full HM symbol, Shubnikov, 1935 ITXC, etc.) are not c and never will be used. c c * x,y,z: (iat) arrays of fractional coordinates of unique positions c in unit cell c * cell: (6) array of a,b,c,alpha,beta,gamma c c ! trmtx: (3,3) transformation matrix between cell-axis and cartesian c bases, see subroutine trans in clustr c ! st: (iat,192,3) fractional coordinates of all atoms in unit cell, c first arg refers to unique atom list, second c to position in cell, third is xyz. c c fyi: 192 is the largest possible number of equivalent c positions in a cell of any symmetry. see, for example, c cubic f m 3 c. c---------------------------------------------------------------------- isp = ispa return end subroutine gtshft(shft,shw) logical shft character*74 shw(4) c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ c include 'crystl.h' c-*-fortran-*- c various parameters used by module crystl common /cryint/ iabs, iatom, ibasis, isystm, ispa, iperm, nsites, $ ipt(iat), idop(iat), imult(iat) save /cryint/ parameter(nsysm=4, nshwrn=4) character*2 dopant(iat,ndopx) character*10 spcgrp, tag(iat) character*74 shwarn(nshwrn) character*77 sysmes(nsysm) common /crystr/ shwarn, sysmes, dopant, tag, spcgrp save /crystr/ logical syserr, shift common /crylog/ syserr, shift save /crylog/ dimension trmtx(3,3), st(iat,192,3) dimension cell(6), x(iat), y(iat), z(iat) dimension percnt(iat,ndopx) common /cryflt/ trmtx, st, cell, x, y, z, percnt save /cryflt/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, % = error handling, ! = output needed to c construct cluster, the rest are used internally) c c * iabs: index of absorber in unique coordinate list c * iatom: >=1 if atoms list is used, else =1 c * ibasis: =1 if basis list is used, else =0 c isystm: index of crystal system (1..7)=(mono,orth,,tetr, c cubic,hex,triclinic) c ispa: space group index, 1-230 from IXTC c 0: not recognized, error in input symbol c 1-2: triclinic c 3-15: monoclinic c 16-74: orthorhombic c 75-142: tetragonal c 143-167: trigonal c 168-194: hexagonal c 195-230: cubic c iperm: permutation index for non-standard settings, used in crystl c 1: default value -- no permutation necessary c 1-6: 6 orthorhombic settings (abc, cab, bca, a-cb, ba-c, -cba) c 11-12: 2 monoclinic settings, z-axis unique, y-axis unique c 21-22: 2 tetragonal settings, standard and rotated c ! ipt: (iat) number of positions of unique atom in unit cell (1..192) c imult: (iat) workspace for calculating multiplicities c c % sysmes: 4 line message if space group and axes/angles don't match c % syserr: true if space group and axes/angles don't match c % shwarn: 3 line message if space group may require a shift vector c % shift: true if space group may require a shift vector c c * dopant*2: (iat,ndopx) matrix with all host and dopant atomic symbols c * percnt: (iat,ndopx) matrix with occupancies of hosts and dopants c * tag*10: (iat) character tag for each unique site in cell c * spcgrp*10: space group symbol. On output it is the short c Hermann-Maguin symbol in standard setting. On input c spcgrp can be any short HM, Schoenflies, a number c between 1 and 230, or one of a small set of special c words (fcc, bcc, etc.). Other symbol conventions c (full HM symbol, Shubnikov, 1935 ITXC, etc.) are not c and never will be used. c c * x,y,z: (iat) arrays of fractional coordinates of unique positions c in unit cell c * cell: (6) array of a,b,c,alpha,beta,gamma c c ! trmtx: (3,3) transformation matrix between cell-axis and cartesian c bases, see subroutine trans in clustr c ! st: (iat,192,3) fractional coordinates of all atoms in unit cell, c first arg refers to unique atom list, second c to position in cell, third is xyz. c c fyi: 192 is the largest possible number of equivalent c positions in a cell of any symmetry. see, for example, c cubic f m 3 c. c---------------------------------------------------------------------- shft = shift shw(1) = shwarn(1) shw(2) = shwarn(2) shw(3) = shwarn(3) shw(4) = shwarn(4) return end subroutine atchck(iat,ndopx,core,dopant,edge, $ iatom,ibasis,ispa,idop, $ x,y,z,cell,dmax,gasses,qvect) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c-------------------------------------------------------------------- c input: c dopant: matrix of element symbols c x,y,z : arrays of unique atom fractional coordinates c cell: array of cell constants c iatom: number of unique atoms c ibasis: number of atoms in basis c dmax: radius of desired cluster c ispa: number between 1 and 230 denoting space group c pargon: percent argon in the i0 chamber c pnitro: percent nitrogen in the i0 chamber c pkrypt: percent krypton in the i0 chamber c-------------------------------------------------------------------- c check the consistancy of all the input parameters. c if any are funny write a run-time error message and c die gracefully. c-------------------------------------------------------------------- c parameter(iat=50,ndopx=4) parameter(epsi=0.001) character*2 el,dopant(iat,ndopx),dp,test,edge character*10 core c character*77 messg dimension x(iat), y(iat), z(iat), cell(6), qvect(3) dimension idop(iat), gasses(3) logical ldie ldie = .false. icent = 0 inull = 0 icore = 0 test = 'ab' iall = iatom if (ibasis.gt.0) iall=ibasis do 100 i=1,iall el = dopant(i,1) call case(test,el) if ((el.eq.'nu').and.(i.ne.1)) inull = inull+1 if (core.eq.el) icore = icore+1 if ((x(i).gt.1.0).or.(x(i).lt.-1.0)) then call messag(' ') call messag('Atom positions must be real numbers '// $ 'between -1 and 1.') ldie=.true. endif if ((y(i).gt.1.0).or.(y(i).lt.-1.0)) then call messag(' ') call messag('Atom positions must be real numbers '// $ 'between -1 and 1.') ldie=.true. endif if ((z(i).gt.1.0).or.(z(i).lt.-1.0)) then call messag(' ') call messag('Atom positions must be real numbers '// $ 'between -1 and 1.') ldie=.true. endif if ((is2z(el).eq.0).and.(el.ne.'nu')) then call messag(' ') call messag(dopant(i,1)//'???') call messag('One of your elements is not in the '// $ 'periodic table.') ldie=.true. endif if (core.eq.'nu') then call messag(' ') call messag('The core atom cannot be a null site.') ldie=.true. endif 100 continue c%%% if (icent.ne.1) then C%%% call messag(' ') c%%% call messag('Feff requires one and only one absorption '// c%%% $ 'site.') c%%% ldie=.true. c%%% endif if (inull.ge.1) then call messag(' ') call messag('Only one empty site is allowed and it '// $ 'must be the first site listed.') ldie=.true. endif c check if core is a dopant do 104 i=1,iat do 102 j=2,idop(i) dp=dopant(i,j) call case(test,dp) if (core.eq.dp) icore=icore+1 102 continue 104 continue if (icore.eq.0) then call messag(' ') call messag('The central atom specified by the keyword '// $ '"core" is not') call messag('in the atom or dopant lists.') ldie=.true. endif C%%% if (icore.ge.2) then C%%% call messag(' ') C%%% call messag('Error reading the core atom.') C%%% ii=istrln(core) C%%% messg = core(:ii)//' appears more than once in the atom list.') C%%% call messag(messg) C%%% ldie=.true. C%%% endif if ((iatom.eq.0).and.(ibasis.eq.0)) then call messag(' ') call messag('You included no atoms in your input file.') ldie=.true. endif if (ispa.eq.0) then call messag(' ') call messag('Your space group does not exist. Check '// $ 'the international tables.') call messag('The ATOMS document explains adapting '// $ 'notation for the keyboard.') ldie=.true. endif do 110 i=1,3 if (cell(i).le.0) then call messag(' ') call messag('Cell constants cannot be negative or zero.') ldie=.true. endif if ((cell(i+3).lt.0).or.(cell(i+3)-180.0.gt.epsi)) then call messag(' ') call messag('Cell angles must be stated between '// $ '0 and 180 degrees.') ldie=.true. endif c%%% if (qvect(i).lt.0) then c%%% call messag(' ') c%%% call messag('Values for the components of the q vector '// c%%% $ 'in dafs must be non-negative.') c%%% ldie=.true. c%%% endif 110 continue if (dmax.le.0) then call messag(' ') call messag('Rmax is a radial distance. It must be '// $ 'positive.') ldie=.true. endif if ( (iatom.gt.1).and.(ibasis.gt.1) ) then call messag(' ') call messag('You may not specify both an atom list and a '// $ 'basis list.') ldie=.true. endif c if ( (gasses(1)+gasses(3)+gasses(2))-1.0.gt.epsi ) then c call messag(' ') c call messag('The sum of the percentages of nitrogen, '// c $ 'argon and krypton in the ') c call messag('I0 chamber cannot exceed 1.0') c ldie=.true. c endif c c if ( (gasses(1).lt.-epsi).or.(gasses(3).lt.-epsi).or. c $ (gasses(3).lt.-epsi) ) then c call messag(' ') c call messag('The percentage of nitrogen, argon or '// c $ 'krypton in the i0 chamber') c call messag('cannot be less than 0.') c ldie=.true. c endif call case(test,edge) if ( .not.((edge.eq.'k').or.(edge.eq.'l3').or.(edge.eq.'l2') $ .or.(edge.eq.'l1')) ) then call messag(' ') call messag('ATOMS only recognizes K and L edges.') ldie=.true. endif if (ldie) goto 666 return 666 continue call messag('ATOMS cannot continue. Please edit atoms.inp '// $ 'and try again.') call messag(' ') stop c end subroutine atchck end subroutine atinit(iat,natx,ntitx,ndopx,ngeomx,neptx,nlogx, $ title,elemnt,tag,noantg,spcgrp,edge,core, $ dopant,outfil,afname,geodat,refile, $ iatom,ibasis,dmax,ispa,iperm,idop,ngeom,iedge,iabs, $ ipt,iptful,isyst,nepts,nrefl,nnoan, $ x,y,z,cell,st,fullcl,atlis, $ percnt,gasses,qvect,egr,anot, $ logic,stdout) c $ lbasis,lindex,lfluor,ldwarf,lmm,lunit,lp1, c $ lself,li0,lgeom,ldafs,lf,lmod,lfeff,lfex,lgex, c $ lcrys, lmcm, lun, la0, lclus, lout, lrefl) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------- c title : user supplied comment line c elemnt : character array of atom types c tag : character array of site tags c spcgrp : chararcter string with hermann-maguin space group designation c edge : absorption edge of core atom, k or l3 c x,y,z : positions of atoms in cell-axis coordinates c cell : lattice constants, a,b,c,alpha,beta & gamma c iatom : number of unique atoms in cell c ibasis : number of atoms in basis c dmax : maximum distance in cluster c ispa : number between 1 and 230, index of s.g. in int'l tables c iperm : index of permutation matrix for non-standard setting c outfil : output file name c refile : reflection amplitudes file name c st: : arrays containing positions in unit cell c isystm : bravais lattice type c dopant : dopant element symbol c percnt : percent of dopant c gasses : percent of argon, krypton, nitrogen in i0 chamber c logic : logic flags, see arrays map c------------------------------------------------------- c initialize everything there is to initialize c------------------------------------------------------- parameter (zero=0.000000000, one=1.000000000) c parameter (iat=50,natx=800,neptx=2**11) c parameter (ntitx=9,ndopx=4,ngeomx=800) character*2 elemnt(iat),edge,dopant(iat,ndopx) character*10 spcgrp,tag(iat),core,geodat,noantg(iat) character*72 title(ntitx),outfil, afname, refile complex anot(neptx) dimension x(iat), y(iat), z(iat), cell(6), qvect(3) dimension st(iat,192,3), $ fullcl(iat,192,3), atlis(natx,8) dimension ipt(iat), iptful(iat), idop(iat), $ ngeom(ngeomx), nrefl(3) dimension percnt(iat,ndopx), gasses(3) logical logic(nlogx), stdout c--------- characters ------------------------------------------------- do 10 i=1,ntitx title(i) = ' ' 10 continue spcgrp = ' ' edge = ' ' core = ' ' outfil = 'feff.inp' call lower(outfil) afname = ' ' geodat = 'geom.dat' call lower(geodat) refile = 'reflect.dat' call lower(refile) c--------- logicals --------------------------------------------------- do 15 i=1,nlogx logic(i) = .false. 15 continue c 7: feff 19: feff8 28: mcm logic(7) = .true. logic(19) = .false. logic(28) = .true. c stdout = .true. c--------- reals ------------------------------------------------------ dmax = 5. do 17 i=1,3 gasses(i) = zero 17 continue egr = zero c--------- integers --------------------------------------------------- ispa = 0 iperm = 1 iatom = 0 ibasis = 0 isyst = 0 iabs = 0 iedge = 0 nepts = 0 nnoan = 0 do 20 i=1,3 nrefl(i) = 0 20 continue c--------- arrays ------------------------------------------------------ do 100 i=1,iat elemnt(i) = ' ' tag(i) = ' ' noantg(i) = ' ' x(i) = zero y(i) = zero z(i) = zero ipt(i) = 0 iptful(i) = 0 idop(i) = 1 do 90 j=1,ndopx dopant(i,j) = ' ' percnt(i,j) = zero 90 continue 100 continue do 110 i=1,3 cell(i) = zero cell(i+3) = 90. qvect(i) = zero 110 continue do 120 i=1,ngeomx ngeom(i) = 0 120 continue c unit transformation for trivial position k=1 do 180 i=1,3 do 170 j=1,iat do 160 k=1,192 st(j,k,i) = zero fullcl(j,k,i) = zero 160 continue 170 continue 180 continue do 200 i=1,natx do 190 j=1,8 atlis(i,j) = zero 190 continue 200 continue do 210 i=1,neptx anot(i) = cmplx(zero,zero) 210 continue return c end subroutine atinit end subroutine atinpt(iat,ntitx,ndopx,nlogx, $ title,ntit,iatom,ibasis,iabs,dmax,ispa,iperm, $ idop,iedge,nepts,nrefl,isystm,nnoan, $ elemnt,tag,noantg,edge,core,spcgrp,inpgrp, $ outfil,shwarn,afname,refile,dopant, $ x,y,z,cell,percnt,gasses,qvect,egr, $ logic, stdout, expnd, shift) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------- c iatom : number of unique atoms in cell c ibasis : number of atoms in basis c ispa : number between 1 and 230, index of s.g. in int'l tables c iperm : index of permutation matrix for non-standard setting c title : user supplied comment line c elemnt : character array of atom types c tag : character array of site tags c spcgrp : chararcter string with hermann-maguin space group designation c edge : absorption edge of core atom, k or l3 c outfil : output file name c refile : reflection amplitude file name c dopant : dopant element symbol c x,y,z : positions of atoms in cell-axis coordinates c cell : lattice constants, a,b,c,alpha,beta & gamma c dmax : maximum distance in cluster c percent : percent of dopant c logic : various flags, see arrays.map c noantg : tags for which anomalous correction is to be neglected c--------------------------------------------------------------------- c this parses the lines of the command file looking for keywords then c reads in the value for that keyword from the next word. the c structure is nearly free format except for the atom list which must c come at the end of the command file, the reason for this is that c "b" and "c" are keywords and atomic symbols thus enforcing some c structure in the command file is the easiest way to distinguish them. c--------------------------------------------------------------------- parameter(ndpmax=10, nwdx=20) c parameter(iat=50, ntitx=9, ndopx=4 ) parameter(zero=0) character*2 elemnt(iat),edge,dopant(iat,ndopx), $ doplis(ndpmax),test character*10 spcgrp,inpgrp,tag(iat),replcd(ndpmax),core,co,tagup character*10 noantg(iat) character*20 words(nwdx) character*72 title(ntitx), titln, outfil, fname, afname, refile character*80 string,toss,messg*78 logical logic(nlogx), stdout, expnd logical inpnul, lcore, lshift, there dimension x(iat), y(iat), z(iat), cell(6), qvect(3) dimension idop(iat), nrefl(3), gasses(3) dimension percnt(iat,ndopx), pclis(ndpmax) parameter(nshwrn=4) character*74 shwarn(nshwrn) logical shift 1410 format(bn,f10.0) 1440 format(a) 1450 format(a,i2) 4000 format(i2) 4010 format(' *** Notice at line ',i3) 4020 format(' *** Warning at line ',i3) c--------------------------------------------------------------------- c initialize some things used only in this routine inpnul = .true. lcore = .false. lshift = .false. icore = 0 ndop = 0 ntit = 0 xshift = zero yshift = zero zshift = zero nnoan = 0 test = 'ab' nline = 0 ierr = 0 iertot = 0 c the value of the variable test must be in the same case as the c keyword names in the long block of elseif's c--------------------------------------------------------------------- c open atom.inp, look for upper and lower case file names for both c atom.inp and atoms.inp if (.not.stdout) then fname = 'atoms.inp' call lower(fname) inquire(file=fname,exist=there) if (.not.there) then call upper(fname) inquire(file=fname,exist=there) endif if (.not.there) then fname = 'atom.inp' call lower(fname) inquire(file=fname,exist=there) if (.not.there) then call upper(fname) inquire(file=fname,exist=there) endif endif if (.not.there) then call messag('Input file for ATOMS is not found. '// $ 'Hasta luego.') stop endif open(unit=1,file=fname,status='old') endif c--------------------------------------------------------------------- c begin reading the input file, words must be cleared each time to c avoid unintentionally labling more than one atom type as the c central atom. 101 continue if (stdout) then read (*,1440,end=191,err=191)string else read (1,1440,end=191,err=191)string endif nline = nline+1 call untab(string) c call uncomm(string) 120 continue nwds = nwdx do 122 iw=1,nwds words(iw)=' ' 122 continue call triml(string) c - denotes end of job if (string(1:1).eq.'-') goto 191 c skip a comment line if ((string(1:1).eq.'!').or.(string(1:1).eq.'*') $ .or.(string(1:1).eq.'%').or.(string(1:1).eq.'#')) goto 101 c skip a blank line if (string.eq.' ') goto 101 c begin reading line i=1 call bwords(string,nwds,words) inpnul = .false. c ******************** input file parsing ************************* c read a word, identify it, assign the value from the following word(s) c increment i and come back. i points to position in string, when i c exceeds nwds go read a new line. 130 continue call case(test,words(i)) c skip a blank line if (words(i).eq.' ') then goto 101 c ignore everything after !,*,% elseif ((words(i)(1:1).eq.'!').or.(words(i)(1:1).eq.'*').or. $ (words(i)(1:1).eq.'%').or.(words(i)(1:1).eq.'#')) then goto 101 elseif (words(i).eq.'end') then goto 191 c title and comment are synonyms elseif ((words(i).eq.'comment').or.(words(i).eq.'title')) then if (ntit.lt.ntitx) then call gettit(words(i), string, titln, ntit, stdout) title(ntit) = titln endif goto 101 c read the next ten characters c into space, continue reading c rest of the line. c this one is perverse and must c be handled specially elseif (words(i).eq.'space') then toss = string call case(test,toss) m = index(toss, 'space') toss = string(m+6:) call triml(toss) string = toss if (string(:1).eq.'=') toss = string(2:) call triml(toss) spcgrp = toss(1:10) call triml(spcgrp) call case(test,spcgrp) string = toss(11:) inpgrp = spcgrp goto 120 c outfile, default=feff.inp elseif (words(i)(1:3).eq.'out') then outfil=words(i+1) i=i+2 c specified edge, default by z elseif ((words(i).eq.'edge').or.(words(i).eq.'hole')) then edge=words(i+1) call case(test,edge) i=i+2 c specified core elseif ((words(i).eq.'core').or.(words(i)(1:4).eq.'cent')) then core=words(i+1) call case(test,core) lcore = .true. i=i+2 c dopants elseif (words(i)(1:3).eq.'dop') then ndop = ndop + 1 if (ndop.gt.ndopx) then write(messg, 4020)nline call messag(messg) call messag(' You have exceeded the '// $ 'maximum number of dopants.') call messag(' ATOMS will ignore this and all '// $ 'further dopants.-') ierr = 2 goto 137 endif doplis(ndop) = words(i+1) call case(test,doplis(ndop)) replcd(ndop) = words(i+2) call case(test,replcd(ndop)) call getrea(words(i), words(i+3), pclis(ndop), $ nline, ierr) 137 continue i=i+4 c argon, fluorescence elseif (words(i)(1:3).eq.'arg') then call getrea(words(i), words(i+1), gasses(1), nline, ierr) logic(3) = .true. i=i+2 c krypton, fluorescence elseif (words(i)(1:3).eq.'kry') then call getrea(words(i), words(i+1), gasses(2), nline, ierr) logic(3) = .true. i=i+2 c nitrogen, fluorescence elseif (words(i)(1:3).eq.'nit') then call getrea(words(i), words(i+1), gasses(3), nline, ierr) logic(3) = .true. i=i+2 c flag for indexing elseif (words(i)(1:3).eq.'ind') then call getlgc(words(i), words(i+1), logic(4), nline, ierr) i=i+2 c geom.dat elseif (words(i)(1:3).eq.'geo') then call getlgc(words(i), words(i+1), logic(6), nline, ierr) i=i+2 c xanes keywords (& not feff8) c elseif (words(i)(1:3).eq.'xan') then c call getlgc(words(i), words(i+1), logic(18), nline, ierr) c logic(19) = .false. c i=i+2 c feff8 keywords (& not xanes) elseif (words(i)(1:5).eq.'feff8') then call getlgc(words(i), words(i+1), logic(19), nline, ierr) logic(18) = .false. i=i+2 c run clustr & output (note order) elseif (words(i)(1:4).eq.'feff') then call getlgc(words(i), words(i+1), logic(7), nline, ierr) i=i+2 c calc and write McM corrs. elseif (words(i)(1:4).eq.'corr') then call getlgc(words(i), words(i+1), logic(28), nline, ierr) i=i+2 c heh, heh, heh! elseif (words(i)(1:3).eq.'dwa') then call getlgc(words(i), words(i+1), logic(5), nline, ierr) i=i+2 c * * * * * * * * * * diagnostic functions * * * * * * * * * * * * c mcmast.dat elseif (words(i)(1:3).eq.'mcm') then call getlgc(words(i), words(i+1), logic(14), nline, ierr) i=i+2 c self.dat elseif (words(i).eq.'self') then call getlgc(words(i), words(i+1), logic(15), nline, ierr) i=i+2 c i0.dat elseif (words(i).eq.'i0') then call getlgc(words(i), words(i+1), logic(16), nline, ierr) i=i+2 c unit.dat elseif (words(i)(1:3).eq.'uni') then call getlgc(words(i), words(i+1), logic(9), nline, ierr) i=i+2 c p1.inp elseif (words(i).eq.'p1') then call getlgc(words(i), words(i+1), logic(8), nline, ierr) i=i+2 c f.dat, diagnostic for f'/" elseif (words(i)(1:4).eq.'fdat') then call getlgc(words(i), words(i+1), logic(17), nline, ierr) i=i+2 c print module messages elseif (words(i)(1:3).eq.'mod') then call getlgc(words(i), words(i+1), logic(20), nline, ierr) i=i+2 c print location messages elseif (words(i).eq.'message') then call getint(words(1),words(i+1), imess, nline, ierr) if ((imess.eq.0).or.(imess.eq.2)) logic(21) = .true. if ((imess.eq.0).or.(imess.eq.3)) logic(22) = .true. if ((imess.eq.0).or.(imess.eq.4)) logic(23) = .true. if ((imess.eq.0).or.(imess.eq.5)) logic(24) = .true. if ((imess.eq.0).or.(imess.eq.6)) logic(25) = .true. if ((imess.eq.0).or.(imess.eq.7)) logic(26) = .true. if (imess.eq.0) logic(20) = .true. i=i+2 c * * * * * * * * end diagnostic functions * * * * * * * * * * * * c rmax, default=5.0 elseif (words(i)(1:3).eq.'rma') then call getrea(words(i), words(i+1), dmax, nline, ierr) i=i+2 c the lattice constants elseif (words(i).eq.'a') then call getrea(words(i), words(i+1), cell(1), nline, ierr) i=i+2 elseif (words(i).eq.'b') then call getrea(words(i), words(i+1), cell(2), nline, ierr) i=i+2 elseif (words(i).eq.'c') then call getrea(words(i), words(i+1), cell(3), nline, ierr) i=i+2 c the latice angles elseif (words(i)(1:3).eq.'alp') then call getrea(words(i), words(i+1), cell(4), nline, ierr) i=i+2 elseif (words(i)(1:3).eq.'bet') then call getrea(words(i), words(i+1), cell(5), nline, ierr) i=i+2 elseif (words(i)(1:3).eq.'gam') then call getrea(words(i), words(i+1), cell(6), nline, ierr) i=i+2 c shift vector elseif (words(i).eq.'shift') then call getrea(words(i), words(i+1), xshift, nline, ierr) call getrea(words(i), words(i+2), yshift, nline, ierr) call getrea(words(i), words(i+3), zshift, nline, ierr) lshift = .true. i=i+4 c ************ DAFS STUFF **************** c q vector for dafs elseif ((words(i)(1:4).eq.'qvec').or.(words(i).eq.'dafs')) then call getrea(words(i), words(i+1), qvect(1), nline, ierr) call getrea(words(i), words(i+2), qvect(2), nline, ierr) call getrea(words(i), words(i+3), qvect(3), nline, ierr) logic(10) = .true. i=i+4 elseif (words(i).eq.'feout') then afname = words(i+1) i=i+2 c reflection amplitudes elseif (words(i)(1:4).eq.'refl') then call getint(words(i), words(i+1), nrefl(1), nline, ierr) call getint(words(i), words(i+2), nrefl(2), nline, ierr) call getint(words(i), words(i+3), nrefl(3), nline, ierr) logic(11) = .true. i=i+4 c reflection amplitude file name elseif (words(i).eq.'refile') then refile = words(i+1) i=i+2 c # of grid points for dafs elseif (words(i)(1:3).eq.'nep') then call getint(words(i), words(i+1), nepts, nline, ierr) i=i+2 c grid spacing for dafs elseif (words(i)(1:3).eq.'egr') then call getrea(words(i), words(i+1), egr, nline, ierr) i=i+2 c neglect anomalous correction elseif (words(i)(1:4).eq.'noan') then nnoan = nnoan+1 noantg(nnoan) = words(i+1) i=i+2 c beneath the word atom is a c 5 col. list of unique atoms c in this order: c sym x y z center? c atom info is read in until eof c or - is found elseif (words(i)(1:3).eq.'ato') then 140 continue if (stdout) then read (*,1440,end=191,err=191)string else read (1,1440,end=191,err=191)string endif nline = nline+1 call untab(string) call triml(string) if (string(1:1).eq.'-') goto 191 if ( (string(1:1).eq.' ').or.(string(1:1).eq.'!').or. $ (string(1:1).eq.'*').or.(string(1:1).eq.'%').or. $ (string(1:1).eq.'#')) $ goto 140 iatom=iatom+1 if (iatom.gt.iat) then ierr = 3 400 format(' *** Error: Your atoms list exceeds ',i3, $ ', the hardwired limit.') write(messg, 400)iat call messag(' ') call messag(messg) call messag(' Reset iat in the source code then ') call messag(' recompile ATOMS to handle a larger '// $ 'atom list.-') goto 191 endif if (expnd) then call messag(' *** Error: No expanded atoms list yet.-') stop else call getatm(nline, ierr, string, elemnt(iatom), $ x(iatom), y(iatom), z(iatom), $ tag(iatom)) if (ierr.eq.2) iatom=iatom-1 endif if (ierr.eq.3) iertot = 1 ierr = 0 goto 140 c handle basis c iatom set to one, one atom c will be expanded as a c point and rest will be added elseif (words(i)(1:3).eq.'bas') then logic(2) = .true. iatom = iatom+1 155 continue if (stdout) then read (*,1440,end=191,err=191)string else read (1,1440,end=191,err=191)string endif nline = nline+1 call untab(string) call triml(string) if (string(1:1).eq.'-') goto 191 if ( (string(1:1).eq.' ').or.(string(1:1).eq.'!').or. $ (string(1:1).eq.'*').or.(string(1:1).eq.'%').or. $ (string(1:1).eq.'#')) $ goto 155 ibasis=ibasis+1 if (ibasis.gt.iat) then ierr = 3 410 format(' *** Error: Your basis list exceeds ',i3, $ ', the hardwired limit.') write(messg, 400)iat call messag(' ') call messag(messg) call messag(' Reset iat in the source code then ') call messag(' recompile ATOMS to handle a larger '// $ 'atom list.-') goto 191 endif if (expnd) then call messag(' *** Error: No expanded atoms list yet.-') stop else call getatm(nline, ierr, string, elemnt(ibasis), $ x(ibasis), y(ibasis), z(ibasis), $ tag(ibasis)) if (ierr.eq.2) iatom=iatom-1 endif if (ierr.eq.3) iertot = 1 ierr = 0 goto 155 else write(messg, 4020)nline call messag(messg) iunk = istrln(words(i)) messg = ' "'//words(i)(:iunk)//'" is an unknown keyword.-' call messag(messg) ierr = 2 i=i+2 endif c if read entire line then read next line else read next word in line if (ierr.eq.3) iertot = 1 ierr = 0 if (i.ge.nwds) goto 101 goto 130 c done reading lines 191 continue if (ierr.eq.3) iertot = 1 if (iertot.ne.0) then call messag(' ') call messag(' *** Ending early due to faulty input file.-') call messag(' ') ierr = 1 stop endif if (inpnul) then logic(1)=.true. goto 300 endif c-------------------------------------------------------------------- c----- do a few things with the keyword values before leaving ------- c-------------------------------------------------------------------- c turn off all messages if program compiled for standard in/output c also disable dafs, geom.dat, unit.dat, p1.dat outputs if (stdout) then logic(6) = .false. logic(8) = .false. logic(9) = .false. logic(10) = .false. logic(11) = .false. logic(14) = .false. logic(15) = .false. logic(16) = .false. logic(17) = .false. logic(20) = .false. logic(21) = .false. logic(22) = .false. logic(23) = .false. logic(24) = .false. logic(25) = .false. logic(26) = .false. endif c iall is the number of atom in the atom or basis list iall = iatom if (logic(2)) iall = ibasis c add shift vector to unique atom coordinates do 250 i=1,iall x(i) = x(i) + xshift y(i) = y(i) + yshift z(i) = z(i) + zshift 250 continue c identify space group from supplied symbol call groups c organize matrices containing site contents call dopfix(iat,ndopx,ndpmax, $ iall,ndop,tag,doplis,replcd,pclis, $ elemnt,dopant,percnt,idop) c try to determine the atomic symbol of the core atom c it need not be specified if the atom list has one site in it... if ((iatom.eq.1).and.(ibasis.le.1).and.(.not.lcore)) then core = elemnt(1) iabs = 1 call case(test,core) lcore = .true. endif c print*,'initial value of core: ', core, ' iabs=', iabs c search through tag list for the specified core... co = core call case(test,co) do 200 i=1,iall tagup=tag(i) call case(test,tagup) if (tagup.eq.co) then icore = icore + 1 core = elemnt(i) iabs = i lcore = .true. endif 200 continue 210 continue c print*,'after searching tag list: ', core, ' iabs=', iabs c if the specified core was not found in the tag list, search the dopants c (use the variable name tagup to avoid defining another variable) if (iabs.eq.0) then do 280 i=1,iall do 270 j=2,idop(i) co = core call case(test,co) tagup=dopant(i,j) call case(test,tagup) if (tagup.eq.co) then iabs = i icore = icore+1 endif 270 continue 280 continue endif c---------------------------------------------------------------------- c choose l3 (=4) or k (=1) edge, the numbers are chosen to suit mucal if (edge.eq.'k') then iedge = 1 elseif (edge.eq.'l1') then iedge = 2 elseif (edge.eq.'l2') then iedge = 3 elseif (edge.eq.'l3') then iedge = 4 elseif (edge.eq.' ') then if (is2z(core).gt.57) then edge = 'l3' iedge = 4 else edge = 'k' iedge = 1 endif endif c check if core has been specified, this is to satisfy backwards c incompatibility concerns if (.not.lcore) then call messag(' ') call messag(' *** Error: while reading atom or basis list') call messag(' In this version of ATOMS, the central '// $ 'atom is specified by the keyword "core"') call messag(' The fifth column of the atom list is '// $ 'reserved for the site tag.') call messag('Please edit the input file and run atoms '// $ 'again.-') call messag(' ') stop endif c check if 0 sites match core if (icore.eq.0) then ii = istrln(co) call messag(' ') call messag(' *** Error: while reading central atom.') call messag(' '//co(:ii)//' matches no sites.-') call messag(' ') stop endif c check if 2 or more sites match core if (icore.ge.2) then ii = istrln(co) call messag(' ') call messag(' *** Error: while reading central atom.') call messag(' '//co(:ii)//' matches more than one site.-') call messag(' ') stop endif c check if outfil or afname will overwrite input file if ((outfil.eq.fname).or.(afname.eq.fname).or. $ (refile.eq.fname)) then call messag(' *** Error: ') call messag(' One of your specified output files names '// $ 'will overwrite the input file.') call messag(' This is not allowed.-') call messag(' ') stop endif 300 continue return c 666 continue c stop c end subroutine atinpt end subroutine dopfix(iat,ndopx,ndpmax, $ iatom,ndop,tag,doplis,replcd,pclis, $ elemnt,dopant,percnt,idop) c----------------------------------------------------------------------- c inputs: c iat: number of unique crystallographic sites c ndop: total number of dopants c tag: array of site tags c doplis: array of all doping atoms c replcd: array of all replaced atoms c pclis: array of doping percentages c elemnt: array of atoms from atom list c output: c dopant: iat x ndopx matrix of doping atoms indexed by site c percnt: iat x ndopx matrix of doping percentages indexed by site c idop: array indicating number of dopants at each site c----------------------------------------------------------------------- implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) c parameter(iat=50, ndopx=4, ndpmax=10) character*2 test character*2 doplis(ndpmax), dopant(iat,ndopx), elemnt(iat) character*10 tag(iat), tagup, replcd(ndpmax), repup dimension pclis(ndpmax), percnt(iat,ndopx) dimension idop(iat) test = 'ab' do 100 i=1,ndop repup = replcd(i) call case(test,repup) do 50 j=1,iatom tagup = tag(j) call case(test,tagup) if (repup.eq.tagup) then idop(j) = idop(j) + 1 dopant(j,idop(j)) = doplis(i) percnt(j,idop(j)) = pclis(i) endif 50 continue 100 continue do 200 i=1,iatom dopant(i,1) = elemnt(i) sumdop = 0 do 150 j=2,idop(i) sumdop = sumdop + percnt(i,j) 150 continue percnt(i,1) = 1. - sumdop 200 continue return c end subroutine dopfix end subroutine getatm(nline, ierr, string, elem, x, y, z, tag) implicit real(a-h,o-z) implicit integer(i-n) c-------------------------------------------------------------- c copyright (c) 1998 Bruce Ravel c-------------------------------------------------------------- c======================================================================== c This routine parses a line containing information about a unique atom c position in a unit cell and returns the information about that site. c======================================================================== parameter(nwdx=20) character*2 elem, test, check*10 character*20 tag*10, words(nwdx) character*78 messg character*(*) string integer nline, ierr test = 'ab' do 10 i=1,nwdx words(i) = ' ' 10 continue nwds = nwdx call bwords(string,nwds,words) if (nwds.lt.4) goto 666 check = words(1) call lower(check) if (check(1:2) .eq. 'nu') goto 20 if (is2z(words(1)).eq.0) goto 666 if (istrln(words(1)).gt.2) goto 666 20 continue c if ( (nwds.lt.4).or.(is2z(words(1)).eq.0).or. c $ (istrln(words(1)).gt.2) ) goto 666 c get element symbol, x, y, z, tag in that order elem = words(1) call case(test,elem) call getrea('atomic position', words(2), x, nline, ierr) call getrea('atomic position', words(3), y, nline, ierr) call getrea('atomic position', words(4), z, nline, ierr) if ((nwds.gt.4) .and. ((words(5).ne.'!').and. $ (words(5).ne.'%').and.(words(5).ne.'*')) ) then tag = words(5) else tag = words(1) call fixsym(tag(1:2)) endif return 666 continue call messag(' ') call messag(' ') 400 format(' *** Warning at line ',i3, ' while reading the atom', $ ' or basis list') write(messg,400)nline call messag(messg) call messag(' ') call messag(' The atom list is a formatted list, and must '// $ 'be at the end of') call messag(' the input file.') call messag(' The first column is a two character '// $ 'elemental symbol.') call messag(' The next three are coordinates in the unit '// $ 'cell.') call messag(' The fifth column is the optional site tag.') call messag(' Atoms should be able to continue, but may '// $ 'not produce') call messag(' the correct output.') call messag(' You should edit atoms.inp and try again.-') call messag(' ') ierr = 2 c end subroutine getatm.f end subroutine crystl(idebug, ierr) c===================================================================== c atoms module 2: decode space group, determine unit cell contents c===================================================================== c this module consists of the following subroutines and functions: c crystl basfil basort equipt genmul ibravl metric multip syschk c and requires c case dbglvl istrln messag positn upper c c most variables are passed in common in crystl.h c idebug: an integer denoting the debug level, this is interpreted c into an array of binary bits which are used as logical flags. c multiple debugging features can be enables by specifying a c sum of bits c 0: disable all debuging function c 1: enable positional run-time messages c ierr: output error code (0=no problem, 1=info, 2=warning, 3=error) c------------------------------------------------------------------------ implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) parameter(zero=0.e0, one=1.e0) c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ c include 'crystl.h' c-*-fortran-*- c various parameters used by module crystl common /cryint/ iabs, iatom, ibasis, isystm, ispa, iperm, nsites, $ ipt(iat), idop(iat), imult(iat) save /cryint/ parameter(nsysm=4, nshwrn=4) character*2 dopant(iat,ndopx) character*10 spcgrp, tag(iat) character*74 shwarn(nshwrn) character*77 sysmes(nsysm) common /crystr/ shwarn, sysmes, dopant, tag, spcgrp save /crystr/ logical syserr, shift common /crylog/ syserr, shift save /crylog/ dimension trmtx(3,3), st(iat,192,3) dimension cell(6), x(iat), y(iat), z(iat) dimension percnt(iat,ndopx) common /cryflt/ trmtx, st, cell, x, y, z, percnt save /cryflt/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, % = error handling, ! = output needed to c construct cluster, the rest are used internally) c c * iabs: index of absorber in unique coordinate list c * iatom: >=1 if atoms list is used, else =1 c * ibasis: =1 if basis list is used, else =0 c isystm: index of crystal system (1..7)=(mono,orth,,tetr, c cubic,hex,triclinic) c ispa: space group index, 1-230 from IXTC c 0: not recognized, error in input symbol c 1-2: triclinic c 3-15: monoclinic c 16-74: orthorhombic c 75-142: tetragonal c 143-167: trigonal c 168-194: hexagonal c 195-230: cubic c iperm: permutation index for non-standard settings, used in crystl c 1: default value -- no permutation necessary c 1-6: 6 orthorhombic settings (abc, cab, bca, a-cb, ba-c, -cba) c 11-12: 2 monoclinic settings, z-axis unique, y-axis unique c 21-22: 2 tetragonal settings, standard and rotated c ! ipt: (iat) number of positions of unique atom in unit cell (1..192) c imult: (iat) workspace for calculating multiplicities c c % sysmes: 4 line message if space group and axes/angles don't match c % syserr: true if space group and axes/angles don't match c % shwarn: 3 line message if space group may require a shift vector c % shift: true if space group may require a shift vector c c * dopant*2: (iat,ndopx) matrix with all host and dopant atomic symbols c * percnt: (iat,ndopx) matrix with occupancies of hosts and dopants c * tag*10: (iat) character tag for each unique site in cell c * spcgrp*10: space group symbol. On output it is the short c Hermann-Maguin symbol in standard setting. On input c spcgrp can be any short HM, Schoenflies, a number c between 1 and 230, or one of a small set of special c words (fcc, bcc, etc.). Other symbol conventions c (full HM symbol, Shubnikov, 1935 ITXC, etc.) are not c and never will be used. c c * x,y,z: (iat) arrays of fractional coordinates of unique positions c in unit cell c * cell: (6) array of a,b,c,alpha,beta,gamma c c ! trmtx: (3,3) transformation matrix between cell-axis and cartesian c bases, see subroutine trans in clustr c ! st: (iat,192,3) fractional coordinates of all atoms in unit cell, c first arg refers to unique atom list, second c to position in cell, third is xyz. c c fyi: 192 is the largest possible number of equivalent c positions in a cell of any symmetry. see, for example, c cubic f m 3 c. c---------------------------------------------------------------------- character*1 csymbr logical lbasis dimension ts(3,24), fs(3,3,24) integer idebug, idbg(0:ndbgx) character*78 module, string lbasis=.false. if (ibasis.gt.0) lbasis=.true. call dbglvl(idebug,idbg) c print*,'idebug=',idebug,' idbg=(',idbg,')' module = 'crystl' ierr = 0 c initialize centrosymmetry flag c isymce=1 marks a centrosymmetric atom, this is determined in c equipt and used elsewhere isymce = 0 ns = 0 c initialize the transformation matrices do 30 i=1,3 do 20 j=1,24 ts(i,j) = zero do 10 k=1,3 fs(i,k,j) = zero 10 continue 20 continue 30 continue fs(1,1,1) = one fs(2,2,1) = one fs(3,3,1) = one c------------------------------------------------------------ c reorganize basis list so absorber is at symmetry point in cell nat = iatom if (lbasis.and.(iabs.ne.1)) then string = 'sorting basis' if (idbg(0).gt.0) call positn(module, string) call basort(iat,ndopx,ibasis,iabs,x,y,z,dopant,tag) nat = ibasis endif c------------------------------------------------------------ c permute atoms to standard setting if (iperm.gt.1) call fperm(iat, nat, iperm, cell, x, y, z) c------------------------------------------------------------ c calculate the transformation matrix string = 'getting matrix' if (idbg(0).gt.0) call positn(module, string) call metric(cell, trmtx) c------------------------------------------------------------ c call the routine that does all the group theory to find c individual atom positions from the symmetry properties of c the space group and the positions of the unique atoms within c the primitive cell string = 'entering equipt' if (idbg(0).gt.0) call positn(module, string) call equipt(isyst, isymce, csymbr, ns, ts, fs, spcgrp) c------------------------------------------------------------ c two independent checks on system of crystal string = 'checking system' if (idbg(0).gt.0) call positn(module, string) syserr = .false. if (isyst.ne.isystm) then call syschk(isyst, isystm, spcgrp, sysmes) syserr = .true. ierr = 1 endif c------------------------------------------------------------ c get number of bravais lattice for use in multip ibravl=ibrav(csymbr) c------------------------------------------------------------ c get igen, the multiplicity of the general position then get c multiplicities of atom positions, c for bases iatom = 1, want to run multip only on first atom in basis string = 'calling genmul' if (idbg(0).gt.0) call positn(module, string) call genmul(ns,isymce,ibravl,igen) string = 'callinp multip' if (idbg(0).gt.0) call positn(module, string) call multip(iatom, ibravl, x, y, z, tag, fs, ts, isymce, $ ns, igen, cell, st, ipt, imult, ierr) c------------------------------------------------------------ c fill in basis at each point if (lbasis) then string = 'filling basis' if (idbg(0).gt.0) call positn(module, string) call basfil(iat, ibasis, x, y, z, ipt, st) endif c------------------------------------------------------------ c permute atoms back to non-standard setting, but not tetragonal if ((iperm.ne.22).and.(iperm.gt.1)) $ call bperm(iat, nat, iperm, cell, ipt, st) return c end of module crystl end subroutine basfil(iat,ibasis,x,y,z,ipt,st) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------- c after the first atom in a basis list has been expanded according c to the group summetries, fill in the remainder of the atoms in c the basis at each point in the unit cell c---------------------------------------------------------------- c input: c iat: parameter set in calling program c ibasis: number of atoms in basis c x,y,z: (iat) fractional coordinates of representative atoms c i/o: c ipt: (iat) multiplicity of each site (all equal for a basis) c st: (iat,192,3) fractional coordinates of all atoms in unit cell c---------------------------------------------------------------- c parameter (iat=50) dimension x(iat), y(iat), z(iat), st(iat,192,3), ipt(iat) do 50 i=2,ibasis do 40 j=1,ipt(1) st(i,j,1) = st(1,j,1) + x(i) st(i,j,2) = st(1,j,2) + y(i) st(i,j,3) = st(1,j,3) + z(i) 40 continue ipt(i) = ipt(1) 50 continue return c end subroutine basfil end subroutine basort(iat,ndopx,ibasis,iabs,x,y,z,dopant,tag) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------------------ c want the absorber at the top of the unique atom list in the c basis calculation. this routine puts the absorber on the point c of translation symmetry and shifts the coordinates of the rest c of the basis accordingly. it also removes a null site from the c list. c------------------------------------------------------------------ c input/output: c iat,ndopx: parameters set in calling program c ibasis: number of sites in basis on input, null site removed c on output c iabs: index of absorber in basis list on input, 1 on output c x,y,z: (iat) on input: fractional coordinates of basis as listed c in input file, on output: fractional coordinates c shifted to put absorber at point of symmetry c dopant*2: (iat,ndopx) list of atomic symbols, reordered on output c so that absorber is the first element of the array c tag*10: (iat) list of site tags, reordered on output so that c absorber is the first element of the array c------------------------------------------------------------------ c parameter (iat=50, ndopx=4) parameter(ibig=10) c this number needs to be bigger than ndopx, 10 should suffice dimension x(iat),y(iat),z(iat) character*2 dopant(iat,ndopx), etoss(ibig), el, test character*10 tag(iat),ttoss test = 'ab' if (iabs.eq.0) goto 999 c on input, first site is the point of symmetry and may be null c iabs may be any other point in the list. want iabs listed first c and the null site at the end for easy removal. c get vector to shift absorber onto basis point for point transform xshift = x(iabs) - x(1) yshift = y(iabs) - y(1) zshift = z(iabs) - z(1) c swap first and absorber and last do 10 i=1,ndopx etoss(i) = dopant(1,i) 10 continue ttoss = tag(1) xtoss = x(1) ytoss = y(1) ztoss = z(1) do 20 i=1,ndopx dopant(1,i) = dopant(iabs,i) 20 continue tag(1) = tag(iabs) x(1) = x(iabs) y(1) = y(iabs) z(1) = z(iabs) do 30 i=1,ndopx dopant(iabs,i) = dopant(ibasis,i) 30 continue tag(iabs) = tag(ibasis) x(iabs) = x(ibasis) y(iabs) = y(ibasis) z(iabs) = z(ibasis) do 40 i=1,ndopx dopant(ibasis,i) = etoss(i) 40 continue tag(ibasis) = ttoss x(ibasis) = xtoss y(ibasis) = ytoss z(ibasis) = ztoss c remove null atom site from list el = dopant(ibasis,1) call case(test,el) if (el.eq.'nu') ibasis = ibasis-1 c shift coordinates do 100 i=1,ibasis x(i) = x(i) - xshift y(i) = y(i) - yshift z(i) = z(i) - zshift 100 continue c reset iabs to reflect the switch just made iabs = 1 999 continue return c end subroutine basort end subroutine bperm(iat, nat, iperm, cell, ipt, st) c permute monoclinic and orthorhombic back to the non-standard setting implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) dimension st(iat,192,3), ipt(iat), cell(6) dimension abc(3), perm(3,3) c if (iperm.eq.22) then c print*,iperm c return c endif do 20 j=1,3 do 10 i=1,3 perm(i,j) = 0 10 continue abc(j) = 0.e0 20 continue c set elements fo permutation matrix c orthorhombic, cab if (iperm.eq.2) then perm(2,1) = 1.e0 perm(3,2) = 1.e0 perm(1,3) = 1.e0 c orthorhombic, bca elseif (iperm.eq.3) then perm(3,1) = 1.e0 perm(1,2) = 1.e0 perm(2,3) = 1.e0 c orthorhombic, a-cb elseif (iperm.eq.4) then perm(1,1) = 1.e0 perm(3,2) = 1.e0 perm(2,3)= -1.e0 c orthorhombic, ba-c elseif (iperm.eq.5) then perm(2,1) = 1.e0 perm(1,2) = 1.e0 perm(3,3) = -1.e0 c orthorhombic, -cba elseif (iperm.eq.6) then perm(3,1) = 1.e0 perm(2,2) = 1.e0 perm(1,3) = -1.e0 c monoclinic, acb(2nd) to abc(1st) elseif (iperm.eq.12) then perm(1,1) = 1.e0 perm(2,3) = 1.e0 perm(3,2) = 1.e0 endif c --- orthorhombic or monoclinic if (iperm.lt.20) then do 40 i=1,3 do 30 j=1,3 abc(i) = abc(i) + cell(j) * abs(perm(i,j)) 30 continue 40 continue do 45 i=1,3 cell(i) = abc(i) 45 continue endif c --- tetragonal c else c abc(1) = cell(1) * sqrt(2.e0) c abc(2) = abc(1) c abc(3) = cell(3) c print*,'iperm=',iperm c print*,'before, after' c print*,cell(1),abc(1) c print*,cell(2),abc(2) c print*,cell(3),abc(3) c print*,'angles:',cell(4),cell(5),cell(6) do 70 i=1,nat do 60 j=1,ipt(i) xx = 0 yy = 0 zz = 0 c permute fractional coordinates xx = st(i,j,1)*perm(1,1) + st(i,j,2)*perm(1,2) + $ st(i,j,3)*perm(1,3) yy = st(i,j,1)*perm(2,1) + st(i,j,2)*perm(2,2) + $ st(i,j,3)*perm(2,3) zz = st(i,j,1)*perm(3,1) + st(i,j,2)*perm(3,2) + $ st(i,j,3)*perm(3,3) c print*,i,st(i,j,1),xx c print*,i,st(i,j,2),yy c print*,i,st(i,j,3),zz st(i,j,1) = xx st(i,j,2) = yy st(i,j,3) = zz 60 continue 70 continue return c end subroutine bperm end subroutine equipt (isystm,isymce,cbravl,ng,tx,fx,spcgrp) implicit real (a-h,o-z) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c interprets the herman-mauguin symbol for space group c modified from a program by h.burzlaff, j.appl.cryst, v.15, c p.464 (1982) c double precision and character variable manipulations: br 8/92 c---------------------------------------------------------------------- c input: c spcgrp*10: hermann-maguin space group notation c output: c isystm: integer denoting bravais lattice, (1..7)=(a,b,r,c,i,f,p) c isymce: centrosymmetry flag, 1=centrosymmetric c cbravl*1: character denoting bravais type, 1st letter in spcgrp c ng: simple multiplicity of lattice type c tx(3,24): fractional coordinates of simply multiple atoms c fx(3,3,24): rotational symmetries c---------------------------------------------------------------------- parameter (eps=.001e0) parameter (one = 1.e0, two = 2.e0, four = 4.e0) parameter (half = one/two, quart = one/four) integer e(3,3), sys, isys(7), nul(3) dimension sh(3), te(3) dimension ss(24,3,3), tx(3,24), ts(24,3), fx(3,3,24) character*10 spcgrp character*1 cspace(10), cbra(7), cbravl, csym(3,4), cbr character*1 cm, cn character*2 test logical blank data (sh(i), i=1,3) /0.25e0, 0.25e0, 0.25e0/ data (nul(i), i=1,3) /0, 0, 0/ data (isys(i),i=1,7) /7, 1, 2, 4, 6, 5, 3/ data (cbra(i),i=1,7) /'p','a','b','c','f','i','r'/ c%%%%% test = 'ab' c --- this stuff was added after running the code through g77 -------- blank = .false. ichar = 0 nbr = 0 c -------------------------------------------------------------------- c the value of test *must* be of the same case as the values of cbra c----------------------------------------------------- c break spcgrp up into its 10 components c cspace contains the (up to) 10 characters in the space group designation do 9001 i=1,10 cspace(i) = ' ' 9001 continue do 9011 i=1,10 read (spcgrp(i:i),4000) cspace(i) call case(test,cspace(i)) 9011 continue 4000 format(a1) c----------------------------------------------------- c initialize some things nsym = -1 ng = 1 ns = 1 do 24 i=1,24 do 22 j=1,3 ts(i,j) = 0.e0 tx(j,i) = 0.e0 do 20 k=1,3 e(j,k) = 0 ss(i,j,k) = 0.e0 fx(j,k,i) = 0.e0 20 continue 22 continue 24 continue ss(1,1,1) = 1.e0 ss(1,2,2) = 1.e0 ss(1,3,3) = 1.e0 do 32 i=1,3 te(i) = 0.e0 do 30 j=1,4 csym(i,j) = ' ' 30 continue 32 continue c----------------------------------------------------- c begin interpreting the space group do 80 i=1,10 c reset blank (flag) and ichar each time a blank is found c then go on to the next character if (cspace(i).eq.' ') then blank = .true. ichar = 0 goto 80 endif c n.b. this could be cleaned up since spcgrp is trimled before this c if bravais lattice type has been found... if (nsym.ge.0) goto 70 c look for bravais lattice type 1..7 = p,a,b,c,f,i,r c cbr for internal use, i/cbravl for external use do 50 j=1,7 cbr = cbra(j) nbr = j if (cspace(i).eq.cbra(j)) goto 60 50 continue 60 continue nsym = 0 cbravl = cspace(i) goto 80 c nsym counts the three symbols in the space group after the lattice type. c ichar counts the characters in that symbol. nsym=[1..3],ichar=[1..4]. c blank=t flags the beginning of a new symbol. 70 continue if (blank) nsym = nsym+1 ichar = ichar+1 csym(nsym,ichar) = cspace(i) blank = .false. if (cspace(i).eq.'/') ns = 0 80 continue c print*,'spcgrp=',spcgrp c print*,'cspace=',cspace c----------------------------------------------------- c determine the bravais system c sys=1...6 ==> (tric,mono,ortho,tetra,hex,cubic) c cubes have triad axes. do 90 i=1,4 if (csym(2,i).ne.'3') goto 90 sys = 6 goto 145 90 continue c hexagonal cells have hexads, trigonal cells have triads c tetragonal cells have tetrads. do 110 i=1,4 if ( (csym(1,i).eq.'3').or.(csym(1,i).eq.'6') ) then sys = 5 goto 145 endif if (csym(1,i).eq.'4') then sys = 4 goto 145 endif 110 continue c choose between triclinic and monoclinic if (nsym.eq.1) then c monoclinic might only have one symbol, but it's not "1" if ( (csym(1,1).eq.'1').or.(csym(1,1).eq.'-') ) then sys = 1 goto 145 endif sys = 2 c fix csym for point groups 2 and m, but not 2/m do 130 i=1,4 csym(2,i) = csym(1,i) 130 continue csym(1,1) = '1' csym(3,1) = '1' endif c%#@%#@ this seems to be wrong for group 2/m c orthorhombic by default unless monoclinic pt. grp. 2 or m sys=3 if ( (csym(1,1).eq.'1').or.(csym(2,1).eq.'1') ) sys = 2 c--------------------------------------------------------------------- c leap ahead to the appropriate section of code for the bravais c type in question c jump to these line numbers: (1000,1100,1200,1300,1400,1500) c for appropriate sys, sys=[1..6] according to lattice type: c (tric,mono,ortho,tetra,hex,cubic) 145 continue if (sys.eq.1) then goto 1000 elseif (sys.eq.2) then goto 1100 elseif (sys.eq.3) then goto 1200 elseif (sys.eq.4) then goto 1300 elseif (sys.eq.5) then goto 1400 elseif (sys.eq.6) then goto 1500 endif c--------------------------------------------------------------------- c triclinic, described by group containing only the identity (p1) c or the identity and a parity operation (p-1) 1000 if (csym(1,1).eq.'-') ns = 0 goto 760 c--------------------------------------------------------------------- c monoclinic, primitive (p) or one-face-centered (c). c point gps: diad (p2,p21,c2),mirror (pm,cm),glide (pc,cc), c combined (p2/m,p21/m,p2/c,p21/c,c2/m,c2/c) 1100 ng = 2 ind = 0 do 180 i=1,3 if (csym(i,1).ne.'1') ind = i 180 continue id = 1 if (csym(ind,1).eq.'2') id = -1 do 190 i=1,3 ss(2,i,i) = ss(1,i,i)*id 190 continue ss(2,ind,ind) = -ss(2,ind,ind) do 220 i=1,3 if ( (csym(i,1).eq.'2').and.(csym(i,2).eq.'1') ) ts(2,i)=0.5 do 210 j=1,4 if (csym(i,j).eq.'a') ts(2,1) = 0.5 if (csym(i,j).eq.'b') ts(2,2) = 0.5 if (csym(i,j).eq.'c') ts(2,3) = 0.5 if (csym(i,j).eq.'n') goto 200 goto 210 200 continue k=i+1 if (k.gt.3) k = k-3 ts(2,k) = 0.5 ts(2,6-k-i) = 0.5 210 continue 220 continue goto 760 c--------------------------------------------------------------------- c --- orthorhombic 1200 continue ng = 4 ic = 0 ind = 1 c if not point group 222... if ( (csym(1,1).ne.'2').and.(csym(2,1).ne.'2').and. $ (csym(3,1).ne.'2') ) then ind = -1 ns = 0 endif do 240 i=1,3 id = 1 c if any diads exist... if (csym(i,1).eq.'2') id = -1 do 230 j=1,3 ss(1+i,j,j) = ss(1,j,j)*id*ind 230 continue ss(1+i,i,i) = -ss(1+i,i,i) 240 continue do 282 i=1,3 c if screw diads exist... if ( (csym(i,1).eq.'2').and.(csym(i,2).eq.'1') ) $ ts(1+i,i) = 0.5 do 280 j=1,4 c if a glide plane...; if b glide plane...; if c glide plane...; c if diagonal glide plane or 1/4 glide plane if (csym(i,j).eq.'a') ts(1+i,1) = 0.5 if (csym(i,j).eq.'b') ts(1+i,2) = 0.5 if (csym(i,j).eq.'c') ts(1+i,3) = 0.5 if ((csym(i,j).eq.'n').or.(csym(i,j).eq.'d')) goto 250 goto 280 250 continue k = i+1 if (k.gt.3) k = k-3 if (csym(i,j).eq.'d') goto 260 c case of not diagonal glide plane ts(1+i,k) = 0.5 ts(1+i,6-k-i) = 0.5 goto 280 c case of 1/4 glide plane 260 ic = 1 c if no centrosymmetry... if (ns.eq.1) goto 270 ts(1+i,k) = 0.25 ts(1+i,6-k-i) = 0.25 goto 280 270 ts(1+i,1) = 0.25 ts(1+i,2) = 0.25 ts(1+i,3) = 0.25 280 continue 282 continue c if (ic.eq.1) goto 760 c if no centrocymmetry... if (ns.eq.1) goto 360 do 290 i=1,3 k = 1+i if (k.gt.3) k = k-3 tc = ts(1+k,i)+ts(1+6-i-k,i) if (tc.eq.1.0) tc = 0.0 ts(1+i,i) = tc 290 continue c---------------------------------------------------------------- c special treatment of c m m a, c m c a, i m m a c ma counts the number of "m's" (ie 2, 1, or 2) if ((cbr.eq.'p').or.(cbr.eq.'f')) goto 760 ma = 0 do 310 i=1,3 do 300 j=1,4 if (csym(i,j).eq.'m') nul(i)=1 300 continue ma = ma+nul(i) 310 continue c if i m m a...do origin shift if ( (cbr.eq.'i').and.(ma.eq.2) ) goto 330 c weed out remaining orthorhombic c and i space groups if ( (ma.eq.0).or.(ma.eq.3).or.(cbr.eq.'i') ) goto 760 c%#%#%#%#%#%#%#%# do 320 i=1,3 c is this a typo?! what is the purpose of the do loop -- this is equally c mysterious in sexie's equipt. will deal with this c when time comes. if (nul(nbr-1).eq.1) goto 760 sh(nbr-1) = 0 320 continue c --- origin shift 330 do 352 i=1,ng do 350 j=1,3 do 340 k=1,3 id = 1 if (j.ne.k) id = 0 ts(i,j) = ts(i,j) + (id-ss(i,j,k))*sh(k) 340 continue if (ts(i,j).gt.1.) ts(i,j) = ts(i,j)-1 if (ts(i,j).lt.1.0) ts(i,j) = ts(i,j)+1 350 continue 352 continue goto 760 c...where to come for no centrocymmetry 360 ic = 0 do 370 i=1,3 c .eq.-1 if ( abs((ss(1+i,1,1)*ss(1+i,2,2)*ss(1+i,3,3)) +1).lt.eps) ic=1 370 continue if (ic.eq.1) goto 410 tc = ts(2,1)+ts(3,2)+ts(4,3) if (abs(tc).lt.eps) goto 760 do 400 i=1,3 k = i+1 if (k.gt.3) k = k-3 if (tc.gt.0.5) goto 380 if (abs(ts(1+i,i)).lt.eps) goto 400 m = i-1 if (m.eq.0) m = m+3 ts(1+m,i) = 0.5 goto 400 380 if (tc.gt.1.0) goto 390 if (abs(ts(1+i,i)).gt.eps) goto 400 l = k+1 if (l.gt.3) l = l-3 ts(1+k,l) = 0.5 ts(1+l,k) = 0.5 goto 400 390 ts(1+i,k) = 0.5 400 continue goto 760 410 do 420 i=1,3 if (abs(ss(1+i,1,1)*ss(1+i,2,2)*ss(1+i,3,3)-1).lt.eps) id=i 420 continue do 450 i=1,3 tc = ts(2,i)+ts(3,i)+ts(4,i) if ( (abs(tc).lt.eps).or.(abs(tc-1.0).lt.eps) ) goto 450 c if mirror and diagonal glide planes exist... if ( ((csym(1,1).eq.'m').and.(csym(2,1).eq.'n')) .or. $ ((csym(2,1).eq.'m').and.(csym(3,1).eq.'n')) .or. $ ((csym(3,1).eq.'m').and.(csym(1,1).eq.'n')) ) goto 440 do 430 j=1,3 if (id.eq.j) goto 430 if (abs(ts(1+j,i)-0.5).lt.eps) goto 430 ts(1+j,i) = 0.5 430 continue goto 450 440 k=i-1 if (k.eq.0) k = k+3 ts(1+k,i) = 0.5 450 continue goto 760 c--------------------------------------------------------------------- c --- tetragonal 1300 ng = 4 if (nsym.eq.3) ng=8 ss(2,1,2) = -1 ss(2,2,1) = 1 ss(2,3,3) = 1 cm = csym(1,1) cn = csym(1,2) do 472 i=1,3 do 470 j=1,3 c if enantiomorphous... if (cm.eq.'-') ss(2,i,j) = -ss(2,i,j) 470 continue 472 continue if (cm.eq.'-') goto 500 c if screw axes of 1/4, 1/2. or 3/4 rotation exist... if (cn.eq.'1') ts(2,3) = 0.25 if (cn.eq.'2') ts(2,3) = 0.5 if (cn.eq.'3') ts(2,3) = 0.75 c if horizontal diagonal glide plane or hdgp & # of symbols=3... if ( (csym(1,3).eq.'n') .or. ((csym(1,4).eq.'n').and.(nsym.eq.3))) $ ts(2,1) = 0.5 c if hdgp & # of symbols=1 (p42/n) or 1/4 screw axis & no cent. & i... if ( ((csym(1,4).eq.'n').and.(nsym.eq.1)) .or. $ ((cn.eq.'1').and.(ns.eq.1).and.(cbr.eq.'i')) ) ts(2,2) = 0.5 c if 1/4 screw axis & no cent. & i... if ( (cn.eq.'1').and.(ns.eq.0).and.(cbr.eq.'i') ) goto 480 c if secondary 1/4 screw axis or no hdgp & vert. diag. glide plane & c third mirror plane... if ( (csym(2,2).eq.'1') .or. $ ((csym(1,4).ne.'n').and.(csym(2,1).eq.'n').and. $ (csym(3,1).eq.'m')) ) goto 490 goto 500 480 continue ts(2,1) = 0.25 ts(2,2) = 0.75 c if point group 4, -4, or 4/m... if (nsym.eq.1) ts(2,1) = 0.75 if (nsym.eq.1) ts(2,2) = 0.25 goto 500 490 continue ts(2,1) = 0.5 ts(2,2) = 0.5 500 continue ss(3,1,1) = -1 ss(3,2,2) = -1 ss(3,3,3) = 1 ts(3,1) = ss(2,1,2)*ts(2,2)+ts(2,1) ts(3,2) = ss(2,2,1)*ts(2,1)+ts(2,2) ts(3,3) = ss(2,3,3)*ts(2,3)+ts(2,3) do 510 i=1,3 if ( (cbr.eq.'i').and.(abs(ts(3,1)-0.5).lt.eps).and. $ (abs(ts(3,2)-0.5).lt.eps).and.(abs(ts(3,3)-0.5).lt.eps) ) $ ts(3,i) = 0.0 510 continue do 524 i=1,3 ts(4,i) = ts(2,i) do 522 j=1,3 ts(4,i) = ts(4,i)+ss(2,i,j)*ts(3,j) do 520 k=1,3 ss(4,i,j) = ss(4,i,j)+ss(2,i,k)*ss(3,k,j) 520 continue 522 continue 524 continue c if point group 4, -4, or 4/m then done... if (nsym.eq.1) goto 760 c if centrosym... if (ns.eq.0) goto 560 cm = csym(2,1) cn = csym(3,1) c if no secondary diad exists... if ( (cm.ne.'2').and.(cn.ne.'2') ) goto 550 c if 2 secondary diads exist... if ( (cm.eq.'2').and.(cn.eq.'2') ) goto 540 c if 2nd symbol 1st char = 2 skip to 530.. if (cm.eq.'2') goto 530 c if c glide plane or diag. glide plane exists... if ( (cm.eq.'c').or.(cm.eq.'n') ) te(3) = 0.5 e(1,1) = -1 e(2,2) = 1 e(3,3) = 1 c skip to 570 if no diag or b glide plaes exist... if ( (cm.ne.'n').and.(cm.ne.'b') ) goto 570 te(1) = 0.5 te(2) = 0.5 goto 570 530 continue e(1,1) = 1 e(2,2) = -1 e(3,3) = -1 c if c or 1/4 glide plane... if (cn.eq.'c') te(3) = 0.5 if (cn.eq.'d') te(3) = 0.25 if (cn.eq.'d') te(2) = 0.5 c if secondary diad is not screw... if (csym(2,2).ne.'1') goto 570 te(1) = 0.5 te(2) = 0.5 goto 570 540 continue e(1,2) = 1 e(2,1) = 1 e(3,3) = -1 c if no secondary screw or i... if ( (csym(2,2).ne.' ').or.(cbr.eq.'i').or.(csym(1,2).eq.' ') ) $ goto 570 c if principle screw axis is 1/4, 1/2, 3/4... if (csym(1,2).eq.'1') te(3) = 0.75 if (csym(1,2).eq.'2') te(3) = 0.5 if (csym(1,2).eq.'3') te(3) = 0.25 goto 570 550 continue cm = csym(2,1) e(1,1) = -1 e(2,2) = 1 e(3,3) = 1 c if parallel diag(n), b, or c mirror planes... if ( (cm.eq.'c').or.(cm.eq.'n') ) te(3) = 0.5 if ( (cm.eq.'n').or.(cm.eq.'b') ) te(1) = 0.5 if ( (cm.eq.'n').or.(cm.eq.'b') ) te(2) = 0.5 goto 570 560 continue e(1,1) = -1 e(2,2) = 1 e(3,3) = 1 c if parallel glide plane... if ( (csym(2,1).eq.'c').or.(csym(2,1).eq.'n') ) te(3) = 0.5 if ( (csym(2,1).eq.'b').or.(csym(2,1).eq.'n') ) te(2) = 0.5 if ( (csym(2,1).eq.'b').or.(csym(2,1).eq.'n') ) te(1) = 0.5 c if parallel glide plane... if ( (csym(1,3).eq.'n').or.(csym(1,4).eq.'n') ) te(1)= te(1)+0.5 570 ne = 4 goto 740 c--------------------------------------------------------------------- c --- hexagonal 1400 continue c print*,'starting hex' ng = 3 cm = csym(1,1) cn = csym(1,2) c if centrosymmetric... if ( (cm.eq.'-').and.(cn.eq.'3') ) ns = 0 c if a hexad exists... if (cm.eq.'6') goto 610 ss(2,1,2) = -1 ss(2,2,1) = 1 ss(2,2,2) = -1 ss(2,3,3) = 1 c if a 1/3, 2/3 screw triad exists... if (cn.eq.'1') ts(2,3) = 1.0/3.0 if (cn.eq.'2') ts(2,3) = 2.0/3.0 ss(3,1,1) = -1 ss(3,2,1) = -1 ss(3,1,2) = 1 ss(3,3,3) = 1 ts(3,3) = 2*ts(2,3) if (ts(3,3).ge.1.0) ts(3,3) = ts(3,3)-1 c if point group -6... if ( (nsym.eq.1).and.(cn.ne.'6') ) goto 760 c if not point group -6m2... if (cn.ne.'6') goto 600 ng = ng+ng do 594 i=1,3 do 592 j=1,3 do 590 k=1,3 ss(3+i,j,k) = ss(i,j,k) ss(3+i,3,3) = -1 590 continue 592 continue 594 continue 600 continue if (nsym.eq.1) goto 760 if ( (csym(2,1).ne.'c').and.(csym(3,1).ne.'c') ) goto 630 ts(4,3) = 0.5 ts(5,3) = 0.5 ts(6,3) = 0.5 goto 630 610 continue ng = ng+ng ss(2,1,1) = 1 ss(2,1,2) = -1 ss(2,2,1) = 1 ss(2,3,3) = 1 c if 1/6..5/6 screw hexad... if (cn.eq.'1') ts(2,3) = 1.0/6.0 if (cn.eq.'2') ts(2,3) = 2.0/6.0 if (cn.eq.'3') ts(2,3) = 3.0/6.0 if (cn.eq.'4') ts(2,3) = 4.0/6.0 if (cn.eq.'5') ts(2,3) = 5.0/6.0 do 626 i=1,4 do 624 j=1,3 ts(2+i,j)=ts(2,j) do 622 k=1,3 ts(2+i,j) = ts(2+i,j)+ss(2,j,k)*ts(1+i,k) if (ts(2+i,j).gt.1.0) ts(2+i,j) = ts(2+i,j)-1.0 do 620 l=1,3 ss(2+i,j,k) = ss(2+i,j,k)+ss(2,j,l)*ss(1+i,l,k) 620 continue 622 continue 624 continue 626 continue if (nsym.eq.1) goto 760 630 continue ng = ng+ng cm = csym(2,1) cn = csym(3,1) c if x,y directions are identity axes... if (cm.eq.'1') goto 650 c if secondary diad exists... if (cm.eq.'2') goto 640 e(1,2) = -1 e(2,1) = -1 e(3,3) = 1 c if c glide plane exists... if (cm.eq.'c') te(3)=0.5 goto 670 640 continue e(1,2) = 1 e(2,1) = 1 e(3,3) = -1 te(3) = 2.0*ts(2,3) c group p 31 1 2 and p 32 1 2 if ( (csym(1,1).eq.'3') .and. $ ((csym(1,2).eq.'1').or.(csym(1,2).eq.'2')) ) te(3) = 0 goto 670 650 continue c if secondary diad exists... if (cn.eq.'2') goto 660 e(1,2) = 1 e(2,1) = 1 e(3,3) = 1 c if c glide plane exists... if (cn.eq.'c') te(3) = 0.5 goto 670 660 continue e(1,2) = -1 e(2,1) = -1 e(3,3) = -1 te(3) = 2.0*ts(2,3) if (te(3).gt.1.0) te(3) = te(3)-1.0 670 continue ne = 6 c if trigonal (3**) or (-3**)... if ( (csym(1,1).eq.'3') .or. $ ((csym(1,2).eq.'3').and.(csym(1,1).eq.'-')) ) ne = 3 goto 740 c--------------------------------------------------------------------- c cubic 1500 ng = 12 if (nsym.eq.3) ng = 24 c if no primary diad or tetrad exists... if ( (csym(1,1).ne.'2').and.(csym(1,1).ne.'4').and. $ (csym(1,1).ne.'-') ) ns = 0 do 692 i=1,3 do 690 j=1,3 ss(1+i,j,j) = 1 if (i.eq.j) goto 690 ss(1+i,j,j) = -1 if (csym(1,1).eq.'n') ts(1+i,j) = half if (csym(1,1).eq.'d') ts(1+i,j) = quart 690 continue 692 continue c if (no a and no 1/4 glide plane and no 1/4 and no 3/4 screw) or c if (face centered)... if ( ((csym(1,1).ne.'a').and.(csym(3,1).ne.'d').and. $ (csym(1,2).ne.'3').and.(csym(1,2).ne.'1')) .or. $ (cbr.eq.'f') ) goto 710 do 700 i=1,3 ts(1+i,i) = half k = i+1 if (k.eq.4) k = 1 ts(1+i,k) = half 700 continue 710 continue do 724 i=1,4 do 722 j=1,3 do 720 k=1,3 l = j+1 if (l.eq.4) l = 1 m = j-1 if (m.eq.0) m = 3 ss(4+i,j,k) = ss(i,l,k) ss(8+i,j,k) = ss(i,m,k) ts(4+i,j) = ts(i,l) ts(8+i,j) = ts(i,m) 720 continue 722 continue 724 continue if (ng.eq.12) goto 760 ne = 12 e(1,2) = 1 e(2,1) = 1 e(3,3) = 1 c if secondary diad exists... if (csym(3,1).eq.'2') e(3,3) = -1 c if c glide plane exists... if (csym(3,1).eq.'c') te(3) = half c if diag glide plane or 2/4 screw diad.. c if 1/4 glide or 1/4 screw or 3/4 screw.. do 730 i=1,3 if ( (csym(3,1).eq.'n').or.(csym(1,2).eq.'2') ) te(i) = half if ( (csym(3,1).eq.'d').or.(csym(1,2).eq.'1').or. $ (csym(1,2).eq.'3') ) te(i) = quart 730 continue c if 1/4 screw or p... if ( (csym(1,2).eq.'1').and.(cbr.eq.'p') ) te(1) = quart * 3 c if (not 1/4 screw or not i) and (not 3/4 screw or not p)... if ( ((csym(1,2).ne.'1').or.(cbr.ne.'i')) .and. $ ((csym(1,2).ne.'3').or.(cbr.ne.'p')) ) goto 740 te(2) = quart * 3 te(3) = quart * 3 c--------------------------------------------------------------------- 740 do 756 i=1,ne do 754 j=1,3 ts(ne+i,j) = te(j) do 752 k=1,3 ts(ne+i,j) = ts(ne+i,j)+e(j,k)*ts(i,k) do 750 l=1,3 ss(ne+i,j,k) = ss(ne+i,j,k)+e(j,l)*ss(i,l,k) 750 continue 752 continue 754 continue 756 continue c--------------------------------------------------------------------- c just about done. put all atoms in central cell, finish up fx, mark c system and centrosymmetry, and make sure ng>=1. 760 continue c++++++++++++++++ c put located atoms back into central cell do 812 i=1,ng do 810 j=1,3 770 if (ts(i,j).ge.1.0) then ts(i,j) = ts(i,j)-1 goto 770 endif 790 if (ts(i,j).lt.0.0) then ts(i,j) = ts(i,j)+1 goto 790 endif 810 continue 812 continue c================ c--------------------------------------------------------------------- c tell the rest of the program what system the lattice is and whether c is has centrosymmetry isystm = isys(sys) if (ns.eq.0) isymce = 1 if (ns.eq.1) isymce = 0 c--------------------------------------------------------------------- c --- swap ss(i,j,k) to fx(k,i,j) do 840 k=1,ng do 830 j=1,3 do 820 i=1,3 fx(i,j,k) = ss(k,j,i) 820 continue tx(j,k) = ts(k,j) 830 continue 840 continue c--------------------------------------------------------------------- c there is always at least one element in a group c (identity transformation) if (ng.eq.0) ng = 1 return c end subroutine equipt end subroutine fperm(iat, nat, iperm, cell, x, y, z) implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) dimension cell(6), x(iat), y(iat), z(iat) dimension abc(3), perm(3,3) do 20 j=1,3 do 10 i=1,3 perm(i,j) = 0 10 continue abc(j) = 0.e0 20 continue c set elements fo permutation matrix c orthorhombic, cab if (iperm.eq.2) then perm(1,2) = 1.e0 perm(2,3) = 1.e0 perm(3,1) = 1.e0 c orthorhombic, bca elseif (iperm.eq.3) then perm(1,3) = 1.e0 perm(2,1) = 1.e0 perm(3,2) = 1.e0 c orthorhombic, a-cb elseif (iperm.eq.4) then perm(1,1) = 1.e0 perm(2,3) = 1.e0 perm(3,2)= -1.e0 c orthorhombic, ba-c elseif (iperm.eq.5) then perm(1,2) = 1.e0 perm(2,1) = 1.e0 perm(3,3) = -1.e0 c orthorhombic, -cba elseif (iperm.eq.6) then perm(1,3) = 1.e0 perm(2,2) = 1.e0 perm(3,1) = -1.e0 c monoclinic, acb(2nd) to abc(1st) elseif (iperm.eq.11) then perm(1,1) = 1.e0 perm(2,3) = 1.e0 perm(3,2) = 1.e0 c tetragonal, rotated --> standard elseif (iperm.eq.22) then perm(1,1) = 1.e0 perm(1,2) = 1.e0 perm(2,1) = -1.e0 perm(2,2) = 1.e0 perm(3,3) = 1.e0 endif c --- orthorhombic or monoclinic if (iperm.lt.20) then do 40 i=1,3 do 30 j=1,3 abc(i) = abc(i) + cell(j) * abs(perm(i,j)) 30 continue 40 continue c --- tetragonal else abc(1) = cell(1) / sqrt(2.e0) abc(2) = abc(1) abc(3) = cell(3) endif c print*,'iperm=',iperm c print*,'before, after' c print*,cell(1),abc(1) c print*,cell(2),abc(2) c print*,cell(3),abc(3) c print*,'angles:',cell(4),cell(5),cell(6) do 45 i=1,3 cell(i) = abc(i) 45 continue do 50 i=1,nat xx = x(i)*perm(1,1) + y(i)*perm(1,2) + z(i)*perm(1,3) yy = x(i)*perm(2,1) + y(i)*perm(2,2) + z(i)*perm(2,3) zz = x(i)*perm(3,1) + y(i)*perm(3,2) + z(i)*perm(3,3) c print*,i,x(i),xx c print*,i,y(i),yy c print*,i,z(i),zz x(i) = xx y(i) = yy z(i) = zz 50 continue return c end subroutine fperm end subroutine genmul(ng,isymce,ibravl,igen) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------------------- c calculates general multiplicity (igen) of unit cell, i.e. the c number of times all of the symmetries of a cell generate a new c point from any arbitrary point c------------------------------------------------------------------- c input: c ng = multiplicity before bravais translations and c centrosymmetry operation c isymce = centrosymmetry flag c ibravl = bravais lattice type, 1..7 = p i r f a b c c output: c igen = general multiplicity, product of simple multiplicity, c mult. of bravais lattice, and mult. of centrosymmetry c------------------------------------------------------------------- c icmf = mult. factor due to centrosymmety c ibrmf = mult. factor due to bravais lattices c igen = total multiplicity c------------------------------------------------------------------- icmf = 1 igen = ng ibrmf = 1 c if centrosymmetric... if (isymce.eq.1) then icmf = 2 igen = ng*icmf endif c 2=i, body center c 3=r, rhombohedral c 4=f, face center if ((ibravl.ge.2).and.(ibravl.le.4)) then ibrmf = ibravl igen = ng*icmf*ibrmf c 5..7=a,b,c, single face center elseif ((ibravl.ge.5).and.(ibravl.le.7)) then ibrmf = 2 igen = ng*icmf*ibrmf endif return c end subroutine genmul end integer function ibrav(csymbr) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit integer(i-n) c------------------------------------------------------------------- c this translates between the integer convention for bravais lattice c type used in equipt and that used elsewhere in the program c c csymbr is the bravais lattice type, ibrav is a number c corresponding to it c------------------------------------------------------------------- character bra(7),csymbr data (bra(i),i=1,7)/'p','i','r','f','a','b','c'/ do 10 i=1,7 if (csymbr.eq.bra(i)) then ibrav = i goto 99 endif 10 continue ibrav = 1 99 return c end integer function ibravl end subroutine metric (cell,trmtx) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------------------ c calculate metric tensor (trmtx) used in transforming from c a cell axis basis to an orthogonal basis c------------------------------------------------------------------ c input: c cell: (6) array containing a,b,c,alpha,beta,gamma c output: c trmtx: (3,3) metric tensor c------------------------------------------------------------------ dimension cell(6),co(3),si(3),trmtx(3,3),cosqr(3) parameter (pi = 3.14159265358979323844e0) parameter (radian = 180.e0/pi) parameter (zero = 0.e0, one = 1.e0) parameter (eps=1.e-6) c------------------------------------------------------------------ c calculate and store sines and cosines of the cell angles do 10 i=1,3 co(i) = cos(cell(i+3)/radian) si(i) = sin(cell(i+3)/radian) cosqr(i) = co(i)**2 10 continue c------------------------------------------------------------------ c calculate various trigonometric quantities for use in the three c dimensional transformation cosxx = (co(1)*co(3) - co(2)) / (si(1)*si(3)) cosyy = (co(1)*co(2) - co(3)) / (si(1)*si(2)) if ((one-cosxx**2).lt.eps) then sinxx = 0.e0 else sinxx = sqrt(one - cosxx**2) endif if ((one-cosyy**2).lt.eps) then sinyy = 0.e0 else sinyy = sqrt(one - cosyy**2) endif c------------------------------------------------------------------ c evaluate the transformation matrix elements trmtx(1,1) = sinyy*si(2) trmtx(1,2) = zero trmtx(1,3) = zero trmtx(2,1) = -((cosyy/(sinyy*si(1)))+(co(1)*cosxx)/(sinxx*si(1))) $ *(sinyy*si(2)) trmtx(2,2) = one trmtx(2,3) = co(1) trmtx(3,1) = -(cosxx*sinyy*si(2))/sinxx trmtx(3,2) = zero trmtx(3,3) = si(1) return c end subroutine metric end subroutine multip (iatom,ibravl,x,y,z,tag,fs,ts,isymce,ns, $ igen,cell,st,ipt,imult,ierr) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c----------------------------------------------------------------- c finds multiplicities of unique positions in primitive cell c----------------------------------------------------------------- c iat = max # of unique atom types c ia = index used below for counting through all atom types in problem c c input: c iat: dimension parameter set in calling program c iatom: # of atom types in problem (iatom<=iat) c ibravl: number denoting bravais lattice type c x,y,z: (iat) fractional coordinates of unique atom positions c tag*10: (iat) tags of each unique site c fs: (3,3,24) rotational symmetries from equipt c ts: (3,24) fractional coords of simply multiple positions from equipt c isymce: flag for centrosymmetry, (1=yes 0=no) c ns: simple multiplicity (ng<=24) c igen: general multiplicity of cell c cell: (6) array containing a,b,c,alpha,beta, and gamma c output: c st(iat,192,3): first index flags atom type c second index flags each occurence of that atom type c there are never more that 192 of an atom type in a cell c third index contains x,y,z (in cell axis basis) and dist. c ipt: (iat) array telling how many of each unique position in cell c ierr: error code, 0 if ok, 2 if decoding problem c------------------------------------------------------------------------ c parameter (iat=50) c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ parameter (zero = 0.e0, one = 1.e0, eps = 0.001e0) parameter (three = 3.e0, third = one/three) parameter (two = 2.e0, half = one/two) parameter (twoth = two/three) dimension x(iat),y(iat),z(iat) dimension tsb(3),xyz(3),xyz1(3),cell(6) dimension brvais(3,9),st(iat,192,3),ts(3,24),fs(3,3,24) dimension ipt(iat), imult(iat) character*10 tag(iat) c---------------------------------------------------------------------- c b1 contains numbers appropriate to calculating translation symmetries c of i, r, f, and abc type cells. i type cells require all positions to c be translated by (1/2,1/2,1/2). r type cells require all positions to c be translated by (2/3,1/3,1/3) and (1/3,2/3,2/3). f type cells require c all positions to be translated by (1/2,1/2,0),(1/2,0,1/2),& (0,1/2,1/2). c abc type cells require (1/2,1/2,0) where the 0 is in the abc position. data ((brvais(i,j),i=1,3),j=1,9)/ $ zero,zero,zero, half,half,half, twoth,third,third, $ half,half,zero, zero,half,half, half,zero,half, $ half,half,zero, third,twoth,twoth, zero,zero,zero/ c the above is more precise but watcom compiler bug barks c data ((brvais(i,j),i=1,3),j=1,9)/ c $ 0.0,0.0,0.0, 0.5,0.5,0.5, 0.6667,0.3333,0.3333, c $ 0.5,0.5,0.0, 0.0,0.5,0.5, 0.5,0.0,0.5, c $ 0.5,0.5,0.0, 0.3333,0.6667,0.6667, 0.0,0.0,0.0/ c---------------------------------------------------------------------- c symmetry associated with bravais lattice types (ie p,i,abc,r,f) nbra=1 if (ibravl.gt.1) nbra=2 if (ibravl.eq.3) nbra=3 if (ibravl.eq.4) nbra=4 c---------------------------------------------------------------------- c loop over all atoms do 110 ia=1,iatom c --- initialize flags and counters and load cell-axis-basis position c --- vector each time through xyz1(1) = x(ia) xyz1(2) = y(ia) xyz1(3) = z(ia) imult(ia) = 0 ipt(ia) = 1 c --- put coordinates in cell in first octant do 10 i=1,3 if ((xyz1(i)+eps).lt.0.e0) xyz1(i) = xyz1(i)+one if (xyz1(i).ge.1.e0) xyz1(i) = xyz1(i) - 1.e0 st(ia,ipt(ia),i) = xyz1(i) 10 continue c --- loop over equivalent positions do 100 j=1,ns c --- loop over bravais lattice points do 90 nb=1,nbra ianti=1 c --- return here to perform centrosymmetry operation 20 continue c --- calculate atom coordinates in the cell axis basis, c perform rotation symmetries do 30 i=1,3 xyz(i) = ianti * (ts(i,j) + fs(1,i,j)*xyz1(1) + $ fs(2,i,j)*xyz1(2) + fs(3,i,j)*xyz1(3)) c --- load appropriate values of bravais translation vector if (nb.eq.1) tsb(i) = brvais(i,1) if (nb.eq.2) tsb(i) = brvais(i,ibravl) if (nb.eq.4) tsb(i) = brvais(i,6) if ((nb.eq.3).and.(ibravl.eq.3)) tsb(i) = brvais(i,8) if ((nb.eq.3).and.(ibravl.eq.4)) tsb(i) = brvais(i,5) c --- translate by the bravais lattice vector xyz(i) = xyz(i)+tsb(i) c --- put position back into first octant if ((xyz(i)+eps).ge.2.0) xyz(i) = xyz(i)-two if ((xyz(i)+eps).ge.1.0) xyz(i) = xyz(i)-one if ((xyz(i)+eps).le.-1.0) xyz(i) = xyz(i)+two if ((xyz(i)+eps).lt.0.0) xyz(i) = xyz(i)+one 30 continue c check if we had that position already in memory c nb: need to recognize that 0 and 1 are the same while considering c floating point precision problems c deincrement istred each time a coordinate is found c if all three are found skip over the storage block do 50 ii=1,ipt(ia) istred=3 do 40 ichk=1,3 posnew = xyz(ichk) posold = st(ia,ii,ichk) if ( ( abs( posnew-posold ).lt.eps) $ .or.(abs( abs(posnew-posold)-1 ).lt.eps) ) $ istred=istred-1 40 continue if (istred.eq.0) goto 60 50 continue c --- increment pointer and store new position ipt(ia) = ipt(ia)+1 do 70 inew=1,3 st(ia,ipt(ia),inew) = xyz(inew) 70 continue 60 continue c --- calculate number imult of coinciding atoms c imult counts how many coincidences, that is the c number of times the symmetry operations reproduced c the same point. dif=0.0 do 80 k=1,3 dif = dif + abs( xyz(k)-xyz1(k) )*cell(k) 80 continue if (abs(dif).lt.eps) then imult(ia) = imult(ia)+1 endif c --- check for centrosymmetry if (isymce.ne.1) goto 90 if (ianti.eq.-1) goto 90 ianti=-1 goto 20 90 continue 100 continue c --- error check, if ok then convert imult to a true multiplicity c and check consistency ierrl = 0 if (imult(ia).eq.0) then call messag(' *** Warning: Multiplicity=0 for atom '// $ tag(ia)//'.-') ierrl = 2 else imult(ia) = igen/imult(ia) if (imult(ia).ne.ipt(ia)) then call messag(' *** Warning: Decoding error for atom '// $ tag(ia)//'.-') ierrl = 2 endif c imult(ia) = igen/imult(ia) endif if (ierrl.ne.0) ierr = ierrl if (ierrl.eq.2) then call messag(' *** Caution: Check your input file to make '// $ 'sure your') call messag('crystallographic information is correct.-') endif c --- go to next atom type 110 continue c do 990 ii=1,iatom c print*, imult(ii) c 990 continue return c end subroutine multip end subroutine syschk(isyst, isystm, spcgrp, sysmes) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c----------------------------------------------------------------- c write a useful error message if the lattice parameters do not c match the space group. c----------------------------------------------------------------- c isyst: system determination from space group, from equipt c isystm: system determination from lattice constants, from systm c spcgrp*10: space group from input file c sysmes*77: (4) message about lattice/space group mismatch c----------------------------------------------------------------- c isystm : 1 = monoclinic 2 = orthorhombic c 3 = 4 = tetragonal c 5 = cubic 6 = hexagonal c 7 = triclinic 8 = c who came up with this notation convention? it sucks! -br c----------------------------------------------------------------- character*10 spcgrp,sg character*12 ctype(8) character*50 prmtrs(8) parameter(nsysm=4) character*77 sysmes(nsysm) data (ctype(i),i=1,8) / 'monoclinic', 'orthorhombic', ' ', $ 'tetragonal', 'cubic', 'hexagonal', $ 'triclinic', ' '/ data prmtrs(1)/'a, b, c unequal; alpha = gamma = 90; beta <> 90'/ data prmtrs(2)/'a, b, c unequal; alpha = beta = gamma = 90'/ data prmtrs(3), prmtrs(8) /' ', ' '/ data prmtrs(4)/'a = b <> c ; alpha = beta = gamma = 90'/ data prmtrs(5)/'a = b = c ; alpha = beta = gamma = 90'/ data prmtrs(6)/'a = b <> c; alpha = beta = 90; gamma = 120'/ data prmtrs(7)/'a, b, c unequal; alpha <> beta <> gamma <> 90'/ ii = istrln(ctype(isystm)) sysmes(1) = 'Your lattice constants and angles are '// $ 'appropriate for a "'//ctype(isystm)(:ii)//'" crystal.' ii = istrln(ctype(isyst)) sg = spcgrp call upper(sg) is = istrln(sg) sysmes(2) = 'Your input space group is "'//ctype(isyst)(:ii)//'".' ip = istrln(prmtrs(isyst)) sysmes(3) = ctype(isyst)(:ii)//' groups require the '// $ 'following parameters:' sysmes(4) = ' '//prmtrs(isyst)(:ip) return c end subroutine syschk end subroutine groups c---------------------------------------------------------------------- c identify space group from supplied symbol and set approriate unit c cell parameters, as needed perform the following: c 1. convert rhombohedral axes to hexagonal c 2. convert schoenflies notation to the standard hermann-maguin symbol c 3. permute non-standard settings to the standard c 4. convert special symbols (fcc, bcc, hcp, hex, diamond, cubic, c salt, nacl, cscl, perovskite, zincblende, zns, graphite) c to corresponding h-m symbols c c some more chores for this: c 1. handle monoclinic cells properly c 2. accept a number between 1 and 230 for spcgrp c c this subroutine calls: c atspec origin rh2hex schfix settng spcchk systm c + string manipulation routines case and messag c---------------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ c include 'crystl.h' c-*-fortran-*- c various parameters used by module crystl common /cryint/ iabs, iatom, ibasis, isystm, ispa, iperm, nsites, $ ipt(iat), idop(iat), imult(iat) save /cryint/ parameter(nsysm=4, nshwrn=4) character*2 dopant(iat,ndopx) character*10 spcgrp, tag(iat) character*74 shwarn(nshwrn) character*77 sysmes(nsysm) common /crystr/ shwarn, sysmes, dopant, tag, spcgrp save /crystr/ logical syserr, shift common /crylog/ syserr, shift save /crylog/ dimension trmtx(3,3), st(iat,192,3) dimension cell(6), x(iat), y(iat), z(iat) dimension percnt(iat,ndopx) common /cryflt/ trmtx, st, cell, x, y, z, percnt save /cryflt/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, % = error handling, ! = output needed to c construct cluster, the rest are used internally) c c * iabs: index of absorber in unique coordinate list c * iatom: >=1 if atoms list is used, else =1 c * ibasis: =1 if basis list is used, else =0 c isystm: index of crystal system (1..7)=(mono,orth,,tetr, c cubic,hex,triclinic) c ispa: space group index, 1-230 from IXTC c 0: not recognized, error in input symbol c 1-2: triclinic c 3-15: monoclinic c 16-74: orthorhombic c 75-142: tetragonal c 143-167: trigonal c 168-194: hexagonal c 195-230: cubic c iperm: permutation index for non-standard settings, used in crystl c 1: default value -- no permutation necessary c 1-6: 6 orthorhombic settings (abc, cab, bca, a-cb, ba-c, -cba) c 11-12: 2 monoclinic settings, z-axis unique, y-axis unique c 21-22: 2 tetragonal settings, standard and rotated c ! ipt: (iat) number of positions of unique atom in unit cell (1..192) c imult: (iat) workspace for calculating multiplicities c c % sysmes: 4 line message if space group and axes/angles don't match c % syserr: true if space group and axes/angles don't match c % shwarn: 3 line message if space group may require a shift vector c % shift: true if space group may require a shift vector c c * dopant*2: (iat,ndopx) matrix with all host and dopant atomic symbols c * percnt: (iat,ndopx) matrix with occupancies of hosts and dopants c * tag*10: (iat) character tag for each unique site in cell c * spcgrp*10: space group symbol. On output it is the short c Hermann-Maguin symbol in standard setting. On input c spcgrp can be any short HM, Schoenflies, a number c between 1 and 230, or one of a small set of special c words (fcc, bcc, etc.). Other symbol conventions c (full HM symbol, Shubnikov, 1935 ITXC, etc.) are not c and never will be used. c c * x,y,z: (iat) arrays of fractional coordinates of unique positions c in unit cell c * cell: (6) array of a,b,c,alpha,beta,gamma c c ! trmtx: (3,3) transformation matrix between cell-axis and cartesian c bases, see subroutine trans in clustr c ! st: (iat,192,3) fractional coordinates of all atoms in unit cell, c first arg refers to unique atom list, second c to position in cell, third is xyz. c c fyi: 192 is the largest possible number of equivalent c positions in a cell of any symmetry. see, for example, c cubic f m 3 c. c---------------------------------------------------------------------- character*2 test logical lrh, ltri, lhex, lalph, lbet, lgam parameter(epsi=1.e-5) test = 'ab' lrh = .false. ltri = .false. lhex = .false. lalph = .false. if ( abs(cell(4)-90.e0).gt.epsi ) lalph = .true. lbet = .false. if ( abs(cell(5)-90.e0).gt.epsi ) lbet = .true. lgam = .false. if ( abs(cell(6)-90.e0).gt.epsi ) lgam = .true. iall = max(iatom, ibasis) call case(test,spcgrp) c equate a, b, and c if b and c are not given. if (cell(2).lt.0.1) cell(2) = cell(1) if (cell(3).lt.0.1) cell(3) = cell(1) c check for special lattice types, ie diamond,fcc,hcp,etc. call atspec(spcgrp,cell) c check the spcgrp against a list of the 230 actual groups and various c alternate settings call spcchk(spcgrp,ispa) if (ispa.eq.0) call settng(spcgrp, iperm, ispa) c flag rhombohedral, trigonal, hexagonal groups if (spcgrp(1:1).eq.'r') lrh = .true. if (spcgrp(3:3).eq.'3') ltri = .true. if ((spcgrp(3:3).eq.'-').and.(spcgrp(4:4).eq.'3')) ltri = .true. if (spcgrp(3:3).eq.'6') lhex = .true. if ((spcgrp(3:3).eq.'-').and.(spcgrp(4:4).eq.'6')) lhex = .true. c check for rhombohedral space groups, convert data if rhombohedral c axes are given. if (lrh.and.lalph) then call rh2hex(iat,iall,cell,x,y,z) goto 100 endif c set angles in hexagonal or trigonal group if ((lhex).or.(lrh).or.(ltri)) then cell(4) = 90.e0 cell(5) = 90.e0 cell(6) = 120.e0 endif 100 continue c obtain the system from the cell parameters for later comparison c with the results of equipt. call systm(cell,isystm) c check to see if space group is one that might need a shift call origin(spcgrp, shift, shwarn) c print*,cell c print*,'atom 1',x(1),y(1),z(1) c print*,'atom 2',x(2),y(2),z(2) return c end subroutine groups end subroutine atspec(spcgrp,cell) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c spcgrp: character string with space group designation c cell: lattice parameters, a,b,c,alpha,beta & gamma c---------------------------------------------------------------------- c interpret words corresponding to very common space groups c set gamma=120 for hcp and graphite c---------------------------------------------------------------------- character*10 spcgrp, test*2 dimension cell(6) c test must be in the same case as the options listed below test = 'ab' call case(test,spcgrp) if ((spcgrp(1:3).eq.'hex').or.(spcgrp(1:3).eq.'hcp')) then spcgrp='p 63/m m c' cell(6)=120 elseif (spcgrp.eq.'fcc') then spcgrp='f m 3 m' elseif (spcgrp.eq.'bcc') then spcgrp='i m 3 m' elseif (spcgrp(1:3).eq.'cub') then spcgrp='p m 3 m' elseif ((spcgrp.eq.'salt').or.(spcgrp.eq.'nacl')) then spcgrp='f m 3 m' elseif ((spcgrp.eq.'cscl').or.(spcgrp(1:3).eq.'ces')) then spcgrp='p m 3 m' elseif (spcgrp(1:5).eq.'perov') then spcgrp='p m 3 m' elseif ((spcgrp(1:5).eq.'zincb').or.(spcgrp.eq.'zns')) then spcgrp='f -4 3 m' elseif (spcgrp(1:3).eq.'dia') then spcgrp='f d 3 m' elseif (spcgrp(1:3).eq.'gra') then spcgrp='p 63 m c' cell(6)=120 endif return c end subroutine atspec end subroutine origin(spcgrp, warn, wrning) c-------------------------------------------------------------- c copyright (c) 1998 Bruce Ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c input: spcgrp: character*10 containing Hermann-Maguin symbol c output: warn: logical, true if need to write message c wrning: (4) of character*74 containing warning message c search a list to see if the chosen space group is among those with c two origins reported in itxc. if it is, give a run-time message c telling the user to check the output and, if it is yucky, to shift c atom coords by a proscribed amount. parameter (norg=22) c norg: # of space groups with two origins reported in itxc character*10 sp(norg), spcgrp, space, test*2 character*23 shift(norg) parameter(nwarn = 4) character*74 wrning(nwarn) logical warn data (sp(i),i=1,norg)/ $ 'p n n n' , 'p b a n', $ 'p m m n' , 'c c c a', $ 'f d d d' , 'p 4/n b m', $ 'p 4/n n c' , 'p 4/n m m', $ 'p 4/n c c' , 'p 4/n b c', $ 'p 42/n n m', 'p 42/n m c', $ 'p 42/n c m', 'i 41/a m d', $ 'i 41/a c d', 'p n 3', $ 'f d 3' , 'p n 3 n', $ 'p n 3 m' , 'f d 3 m', $ 'f d 3 c' , ' '/ data (shift(i),i=1,norg)/ $ ' 0.25 0.25 0.25' , ' 0.25 0.25 0', $ ' 0.25 0.25 0' , ' 0 0.25 0.25', $ '-0.125 -0.125 -0.125', '-0.25 -0.25 0', $ '-0.25 -0.25 -0.25' , '-0.25 0.25 0', $ '-0.25 0.25 0' , '-0.25 0.25 -0.25', $ '-0.25 0.25 -0.25' , '-0.25 0.25 -0.25', $ '-0.25 0.25 -0.25' , ' 0 0.25 -0.125', $ ' 0 0.25 -0.125', '-0.25 -0.25 -0.25', $ '-0.125 -0.125 -0.125', '-0.25 -0.25 -0.25', $ '-0.25 -0.25 -0.25' , '-0.125 -0.125 -0.125', $ '-0.375 -0.375 -0.375', ' '/ test = 'ab' call case(test,spcgrp) warn=.false. ishift=norg do 10 i=1,norg if (spcgrp.eq.sp(i)) then ishift = i space = sp(i) warn=.true. endif 10 continue if (warn) then m1=istrln(space) call upper(space) m2=istrln(shift(ishift)) wrning(1) = ' Space group "'//space(:m1)//'" may be '// $ 'referenced to a different origin.' wrning(2) = ' If the atom list seems incorrect, '// $ 'put this line in your input file' wrning(3) = ' shift '//shift(ishift)(:m2) wrning(4) = ' and run atoms again.-' endif return c end subroutine origin end subroutine rh2hex(iat,iatom,cell,x,y,z) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision(a-h,o-z) c---------------------------------------------------------------------- c converts from a rhombohedral basis to a hexagonal basis c the hexagonal a and c are calculated from the rhombohedral a and c alpha, and the hexagonal gamma is 120. c the new cell constants and angles are calculated from the old c and the unique atom positions are changed as indicated by the itxc c---------------------------------------------------------------------- c input: c iat: dimension of x,y,z c iatom: number of unique positions c input/output: c cell: array containing a,b,c,alpha,beta, and gamma c x,y,z: fractional coordinates of unique positions c---------------------------------------------------------------------- c parameter (iat=50) parameter (one = 1.e0, two = 2.e0, three = 3.e0, one80 = 180.e0) parameter (third=one/three, twoth=two/three) parameter (thirdm=-third, twothm=-twoth) parameter (pi=3.141592653589793238462643) dimension cell(6),x(iat),y(iat),z(iat),convrt(3,3) data ((convrt(i,j),j=1,3),i=1,3) /twoth,thirdm,thirdm, $ third, third,twothm, $ third, third, third/ a = cell(1) alpha = cell(4)*pi/one80 c---------------------------------------------------------------------- c the hexagonal a is the third side of the triangle formed by two of c the rhombohedral cell axes, a, aprime/2, and alpha/2 form a right c triangle aprime = 2 * a * sin(alpha/2) c---------------------------------------------------------------------- c the hexagonal c is the long diagonal of the rhombohedron. the c following is repeated uses of the law of cosines. csqr is the c square of the short face diagonal. bsqr is the square of the long c face diagonal. gsqr is the square of the short body diagonal. cosg c is the cosine of the angle between the long face diagonal and the c opposing axis. this is an ugly mess. bsqr = a**2 * (2 + 2*cos(alpha)) csqr = a**2 * (2 - 2*cos(alpha)) gsqr = csqr + a**2 cosg = (bsqr+a**2-gsqr) / (2*a*sqrt(bsqr)) cprime = sqrt( bsqr + a**2 + 2*a*sqrt(bsqr)*cosg ) c print*,'aprime,cprime: ',aprime,cprime c---------------------------------------------------------------------- c repack cell with new a,b,c,alpha,beta,gamma cell(1) = aprime cell(2) = aprime cell(3) = cprime cell(4) = 90. cell(5) = 90. cell(6) = 120. c---------------------------------------------------------------------- c now fix the unique atom fractional coordinates c convrt is the metric tensor connecting a rhomohedron with its c equivalent heagonal prism do 20 i=1,iatom xnew = x(i)*convrt(1,1)+y(i)*convrt(1,2)+z(i)*convrt(1,3) ynew = x(i)*convrt(2,1)+y(i)*convrt(2,2)+z(i)*convrt(2,3) znew = x(i)*convrt(3,1)+y(i)*convrt(3,2)+z(i)*convrt(3,3) c print 400,'rh2hex: old x,y,z= ',x(i),y(i),z(i) c print 400,'rh2hex: new x,y,z= ',xnew,ynew,znew c400 format(a,3(2x,f8.4)) x(i) = xnew y(i) = ynew z(i) = znew 20 continue 30 continue return c end subroutine rh2hex end subroutine schfix(spcgrp) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision(a-h,o-z) c make sure shoenflies designation has the subscript before the c superscript. this way the user can enter d_3^3 or d^3_3 c and d^3_3 will be converted to d_3^3. c 'v' groups will be changed to 'd' groups character*10 spcgrp, second, third, first*1, test*2 test = 'ab' call case(test,spcgrp) iunder = index(spcgrp,'_') iover = index(spcgrp,'^') first = spcgrp(1:1) c change V groups to more modern D notation if (first.eq.'v') then spcgrp(1:1) = 'd' first = 'd' endif c certain T or O groups if (istrln(spcgrp).eq.3) then if ( (first.eq.'t').and.(iover.eq.2) ) then return elseif ( (first.eq.'o').and.(iover.eq.2) ) then return endif endif c underscore preceeds carot, as it should if ((iunder.lt.iover).and.(iunder.ne.0)) return c else switch underscore part and carot part if (iunder.eq.0) iunder=9 second = spcgrp(2:iunder-1) third = spcgrp(iunder:) if (first.eq.'d') then c --- groups 16-24 if (third.eq.' ') then third = '_2' c --- groups 47-74 elseif (third.eq.'_h') then third = '_2h' endif endif i2 = istrln(second) i3 = istrln(third) spcgrp = first//third(1:i3)//second(1:i2) return c end subroutine schfix end subroutine settng(spcgrp, iperm, ispa) implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) c--------------------------------------------------------------------------- c recognize symbols for alternate settings of monoclinic, orthorhombic, c and tetragonal space groups c c requires subroutines case, messag c c input: c spcgrp: symbol for group as recognized in spcchk c output: c iperm: index of permutation matrix c 1-6: 6 orthorhombic settings (abc, cab, bca, a-cb, ba-c, -cba) c 11-12: 2 monoclinic settings, z-axis unique, y-axis unique c 21-22: 2 tetragonal settings, standard and rotated c ispa: index of space group c--------------------------------------------------------------------------- character*10 spcgrp, oldgrp, altern(6,3:142), test*2 c herman maguinn symbols for alternate settings of monoclinic groups c atoms uses y-axis unique (2nd setting) data (altern(i,3), i=1,2) / 'p 2', 'p 2'/ data (altern(i,4), i=1,2) / 'p 21', 'p 21'/ data (altern(i,5), i=1,2) / 'b 2', 'c 2'/ data (altern(i,6), i=1,2) / 'p m', 'p m'/ data (altern(i,7), i=1,2) / 'p b', 'p c'/ data (altern(i,8), i=1,2) / 'b m', 'c m'/ data (altern(i,9), i=1,2) / 'b b', 'c c'/ data (altern(i,10), i=1,2) / 'p 2/m', 'p 2/m'/ data (altern(i,11), i=1,2) / 'p 21/m', 'p 21/m'/ data (altern(i,12), i=1,2) / 'b 2/m', 'c 2/m'/ data (altern(i,13), i=1,2) / 'p 2/b', 'p 2/c'/ data (altern(i,14), i=1,2) / 'p 21/b', 'p 21/c'/ data (altern(i,15), i=1,2) / 'b 2/b', 'c 2/c'/ c herman maguinn symbols for alternate settings of orthorhombic groups data (altern(i,16), i=1,6) / 'p 2 2 2', 'p 2 2 2', 'p 2 2 2', $ 'p 2 2 2', 'p 2 2 2', 'p 2 2 2'/ data (altern(i,17), i=1,6) / 'p 2 2 21', 'p 21 2 2', 'p 2 21 2', $ 'p 2 21 2', 'p 2 2 21', 'p 21 2 2'/ data (altern(i,18), i=1,6) / 'p 21 21 2', 'p 2 21 21', $ 'p 21 2 21', 'p 21 2 21', 'p 21 21 2', 'p 2 21 21'/ data (altern(i,19), i=1,6) / 'p 21 21 21', 'p 21 21 21', $ 'p 21 21 21', 'p 21 21 21', 'p 21 21 21', 'p 21 21 21'/ data (altern(i,20), i=1,6) / 'c 2 2 21', 'a 21 2 2', 'b 2 21 2', $ 'b 2 21 2', 'c 2 2 21', 'a 21 2 2'/ data (altern(i,21), i=1,6) / 'c 2 2 2', 'a 2 2 2', 'b 2 2 2', $ 'b 2 2 2', 'c 2 2 2', 'a 2 2 2'/ data (altern(i,22), i=1,6) / 'f 2 2 2', 'f 2 2 2', 'f 2 2 2', $ 'f 2 2 2', 'f 2 2 2', 'f 2 2 2'/ data (altern(i,23), i=1,6) / 'i 2 2 2', 'i 2 2 2', 'i 2 2 2', $ 'i 2 2 2', 'i 2 2 2', 'i 2 2 2'/ data (altern(i,24), i=1,6) / 'i 21 21 21', 'i 21 21 21', $ 'i 21 21 21', 'i 21 21 21', 'i 21 21 21', 'i 21 21 21'/ data (altern(i,25), i=1,6) / 'p m m 2', 'p 2 m m', 'p m 2 m', $ 'p m 2 m', 'p m m 2', 'p 2 m m'/ data (altern(i,26), i=1,6) / 'p m c 21', 'p 21 m a', 'p b 21 m', $ 'p m 21 b', 'p c m 21', 'p 21 a m'/ data (altern(i,27), i=1,6) / 'p c c 2', 'p 2 a a', 'p b 2 b', $ 'p b 2 b', 'p c c 2', 'p 2 a a'/ data (altern(i,28), i=1,6) / 'p m a 2', 'p 2 m b', 'p c 2 m', $ 'p m 2 a', 'p b m 2', 'p 2 c m'/ data (altern(i,29), i=1,6) / 'p c a 21', 'p 21 a b', 'p c 21 b', $ 'p b 21 a', 'p b c 21', 'p 21 c a'/ data (altern(i,30), i=1,6) / 'p n c 2', 'p 2 n a', 'p b 2 n', $ 'p n 2 b', 'p c n 2', 'p 2 a n'/ data (altern(i,31), i=1,6) / 'p m n 21', 'p 21 m n', 'p n 21 m', $ 'p m 21 n', 'p n m 21', 'p 2 n m'/ data (altern(i,32), i=1,6) / 'p b a 2', 'p 2 c b', 'p c 2 a', $ 'p c 2 a', 'p b a 2', 'p 2 c b'/ data (altern(i,33), i=1,6) / 'p n a 21', 'p 21 n b', 'p c 21 n', $ 'p n 21 a', 'p b n 21', 'p 2 c n'/ data (altern(i,34), i=1,6) / 'p n n 2', 'p 2 n n', 'p n 2 n', $ 'p n 2 n', 'p n n 2', 'p 2 n n'/ data (altern(i,35), i=1,6) / 'c m m 2', 'a 2 m m', 'b m 2 m', $ 'b m 2 m', 'c m m 2', 'a 2 m m'/ data (altern(i,36), i=1,6) / 'c m c 21', 'a 21 m a', 'b b 21 m', $ 'b m 21 b', 'c c m 21', 'a 21 a m'/ data (altern(i,37), i=1,6) / 'c c c 2', 'a 2 c a', 'b b 2 c', $ 'b b 2 b', 'c c c 2', 'a 2 a a'/ data (altern(i,38), i=1,6) / 'a m m 2', 'b 2 m m', 'c m 2 m', $ 'a m 2 m', 'b m m 2', 'c 2 m m'/ data (altern(i,39), i=1,6) / 'a b m 2', 'b 2 c m', 'c m 2 a', $ 'a c 2 m', 'b m a 2', 'c 2 m b'/ data (altern(i,40), i=1,6) / 'a m a 2', 'b 2 m b', 'c c 2 m', $ 'a m 2 a', 'b b m 2', 'c 2 c m'/ data (altern(i,41), i=1,6) / 'a b a 2', 'b 2 c b', 'c c 2 a', $ 'a c 2 a', 'b b a 2', 'c 2 c b'/ data (altern(i,42), i=1,6) / 'f m m 2', 'f 2 m m', 'f m 2 m', $ 'f m 2 m', 'f m m 2', 'f 2 m m'/ data (altern(i,43), i=1,6) / 'f d d 2', 'f 2 d d', 'f d 2 d', $ 'f d 2 d', 'f d d 2', 'f 2 d d'/ data (altern(i,44), i=1,6) / 'i m m 2', 'i 2 m m', 'i m 2 m', $ 'i m 2 m', 'i m m 2', 'i 2 m m'/ data (altern(i,45), i=1,6) / 'i b a 2', 'i 2 c b', 'i c 2 a', $ 'i c 2 a', 'i b a 2', 'i 2 c b'/ data (altern(i,46), i=1,6) / 'i m a 2', 'i 2 m b', 'i c 2 m', $ 'i m 2 a', 'i b m 2', 'i 2 c m'/ data (altern(i,47), i=1,6) / 'p m m m', 'p m m m', 'p m m m', $ 'p m m m', 'p m m m', 'p m m m'/ data (altern(i,48), i=1,6) / 'p n n n', 'p n n n', 'p n n n', $ 'p n n n', 'p n n n', 'p n n n'/ data (altern(i,49), i=1,6) / 'p c c m', 'p m a a', 'p b m b', $ 'p b m b', 'p c c m', 'p m a a'/ data (altern(i,50), i=1,6) / 'p b a n', 'p n c b', 'p c n a', $ 'p c n a', 'p b a n', 'p n c b'/ data (altern(i,51), i=1,6) / 'p m m a', 'p b m m', 'p m c m', $ 'p m a m', 'p m m b', 'p c m m'/ data (altern(i,52), i=1,6) / 'p n n a', 'p b n n', 'p n c n', $ 'p n a n', 'p n n b', 'p c n n'/ data (altern(i,53), i=1,6) / 'p m n a', 'p b m n', 'p n c m', $ 'p m a n', 'p n m b', 'p c n m'/ data (altern(i,54), i=1,6) / 'p c c a', 'p b a a', 'p b c b', $ 'p b a b', 'p c c b', 'p c a a'/ data (altern(i,55), i=1,6) / 'p b a m', 'p m c b', 'p c m a', $ 'p c m a', 'p b a m', 'p m c b'/ data (altern(i,56), i=1,6) / 'p c c n', 'p n a a', 'p b n b', $ 'p b n b', 'p c c n', 'p n a a'/ data (altern(i,57), i=1,6) / 'p b c m', 'p m c a', 'p b m a', $ 'p c m b', 'p c a m', 'p m a b'/ data (altern(i,58), i=1,6) / 'p n n m', 'p m n n', 'p n m n', $ 'p n m n', 'p n n m', 'p m n n'/ data (altern(i,59), i=1,6) / 'p m m n', 'p n m m', 'p m n m', $ 'p m n m', 'p m m n', 'p n m m'/ data (altern(i,60), i=1,6) / 'p b c n', 'p n c a', 'p b n a', $ 'p c n b', 'p c a n', 'p n a b'/ data (altern(i,61), i=1,6) / 'p b c a', 'p b c a', 'p b c a', $ 'p c a b', 'p c a b', 'p c a b'/ data (altern(i,62), i=1,6) / 'p n m a', 'p b n m', 'p m c n', $ 'p n a m', 'p m n b', 'p c m n'/ data (altern(i,63), i=1,6) / 'c m c m', 'a m m a', 'b b m m', $ 'b m m b', 'c c m m', 'a m a m'/ data (altern(i,64), i=1,6) / 'c m c a', 'a b m a', 'b b c m', $ 'b m a b', 'c c m b', 'a c a m'/ data (altern(i,65), i=1,6) / 'c m m m', 'a m m m', 'b m m m', $ 'b m m m', 'c m m m', 'a m m m'/ data (altern(i,66), i=1,6) / 'c c c m', 'a m a a', 'b b m b', $ 'b b m b', 'c c c m', 'a m a a'/ data (altern(i,67), i=1,6) / 'c m m a', 'a b m m', 'b m c m', $ 'b m a m', 'c m m b', 'a c m m'/ data (altern(i,68), i=1,6) / 'c c c a', 'a b a a', 'b b c b', $ 'b b a b', 'c c c b', 'a c a a'/ data (altern(i,69), i=1,6) / 'f m m m', 'f m m m', 'f m m m', $ 'f m m m', 'f m m m', 'f m m m'/ data (altern(i,70), i=1,6) / 'f d d d', 'f d d d', 'f d d d', $ 'f d d d', 'f d d d', 'f d d d'/ data (altern(i,71), i=1,6) / 'i m m m', 'i m m m', 'i m m m', $ 'i m m m', 'i m m m', 'i m m m'/ data (altern(i,72), i=1,6) / 'i b a m', 'i m c b', 'i c m a', $ 'i c m a', 'i b a m', 'i m c b'/ data (altern(i,73), i=1,6) / 'i b c a', 'i b c a', 'i b c a', $ 'i c a b', 'i c a b', 'i c a b'/ data (altern(i,74), i=1,6) / 'i m m a', 'i b m m', 'i m c m', $ 'i m a m', 'i m m b', 'i c m m'/ c herman maguinn symbols for alternate settings of tetragonal groups data (altern(i,75), i=1,2) / 'p 4', 'c 4'/ data (altern(i,76), i=1,2) / 'p 41', 'c 41'/ data (altern(i,77), i=1,2) / 'p 42', 'c 42'/ data (altern(i,78), i=1,2) / 'p 43', 'c 43'/ data (altern(i,79), i=1,2) / 'i 4', 'f 4'/ data (altern(i,80), i=1,2) / 'i 41', 'f 41'/ data (altern(i,81), i=1,2) / 'p -4', 'c -4'/ data (altern(i,82), i=1,2) / 'i -4', 'f -4'/ data (altern(i,83), i=1,2) / 'p 4/m', 'c 4/m'/ data (altern(i,84), i=1,2) / 'p 42/m', 'c 42/m'/ data (altern(i,85), i=1,2) / 'p 4/n', 'c 4/a'/ data (altern(i,86), i=1,2) / 'p 42/m', 'c 42/a'/ data (altern(i,87), i=1,2) / 'i 4/m', 'f 4/m'/ data (altern(i,88), i=1,2) / 'i 41/a', 'f 41/d'/ data (altern(i,89), i=1,2) / 'p 4 2 2', 'c 4 2 2'/ data (altern(i,90), i=1,2) / 'p 4 2 21', 'c 4 2 21'/ data (altern(i,91), i=1,2) / 'p 41 2 2', 'c 41 2 2'/ data (altern(i,92), i=1,2) / 'p 41 2 21', 'c 41 2 21'/ data (altern(i,93), i=1,2) / 'p 42 2 2', 'c 42 2 2'/ data (altern(i,94), i=1,2) / 'p 42 2 21', 'c 42 2 21'/ data (altern(i,95), i=1,2) / 'p 43 2 2', 'c 43 2 2'/ data (altern(i,96), i=1,2) / 'p 43 2 21', 'c 43 2 21'/ data (altern(i,97), i=1,2) / 'i 4 2 2', 'f 4 2 2'/ data (altern(i,98), i=1,2) / 'i 41 2 2', 'f 41 2 2'/ data (altern(i,99), i=1,2) / 'p 4 m m', 'c 4 m m'/ data (altern(i,100), i=1,2) / 'p 4 b m', 'c 4 m b'/ data (altern(i,101), i=1,2) / 'p 42 c m', 'c 42 m c'/ data (altern(i,102), i=1,2) / 'p 42 n m', 'c 42 m n'/ data (altern(i,103), i=1,2) / 'p 4 c c', 'c 4 c c'/ data (altern(i,104), i=1,2) / 'p 4 n c', 'c 4 c n'/ data (altern(i,105), i=1,2) / 'p 42 m c', 'c 42 c m'/ data (altern(i,106), i=1,2) / 'p 42 b c', 'c 42 c b'/ data (altern(i,107), i=1,2) / 'i 4 m m', 'f 4 m m'/ data (altern(i,108), i=1,2) / 'i 4 c m', 'f 4 m c'/ data (altern(i,109), i=1,2) / 'i 41 m d', 'f 41 d m'/ data (altern(i,110), i=1,2) / 'i 41 c d', 'f 41 d c'/ data (altern(i,111), i=1,2) / 'p -4 2 m', 'c -4 m 2'/ data (altern(i,112), i=1,2) / 'p -4 2 c', 'c -4 c 2'/ data (altern(i,113), i=1,2) / 'p -4 21 m', 'c -4 m 21'/ data (altern(i,114), i=1,2) / 'p -4 21 c', 'c -4 c 21'/ data (altern(i,115), i=1,2) / 'p -4 m 2', 'c -4 2 m'/ data (altern(i,116), i=1,2) / 'p -4 c 2', 'c -4 2 c'/ data (altern(i,117), i=1,2) / 'p -4 b 2', 'c -4 2 b'/ data (altern(i,118), i=1,2) / 'p -4 n 2', 'c -4 2 n'/ data (altern(i,119), i=1,2) / 'i -4 m 2', 'f -4 2 m'/ data (altern(i,120), i=1,2) / 'i -4 c 2', 'f -4 2 c'/ data (altern(i,121), i=1,2) / 'i -4 2 m', 'f -4 m 2'/ data (altern(i,122), i=1,2) / 'i -4 2 d', 'f -4 d 2'/ data (altern(i,123), i=1,2) / 'p 4/m m m', 'c 4/m m m'/ data (altern(i,124), i=1,2) / 'p 4/m c c', 'c 4/m c c'/ data (altern(i,125), i=1,2) / 'p 4/n b m', 'c 4/a m b'/ data (altern(i,126), i=1,2) / 'p 4/n n c', 'c 4/a c n'/ data (altern(i,127), i=1,2) / 'p 4/m b m', 'c 4/m m b'/ data (altern(i,128), i=1,2) / 'p 4/m n c', 'c 4/m c n'/ data (altern(i,129), i=1,2) / 'p 4/n m m', 'c 4/a m m'/ data (altern(i,130), i=1,2) / 'p 4/n c c', 'c 4/a c c'/ data (altern(i,131), i=1,2) / 'p 42/m m c', 'c 42/m c m'/ data (altern(i,132), i=1,2) / 'p 42/m c m', 'c 42/m m c'/ data (altern(i,133), i=1,2) / 'p 42/n b c', 'c 42/a c b'/ data (altern(i,134), i=1,2) / 'p 42/n n m', 'c 42/a m n'/ data (altern(i,135), i=1,2) / 'p 42/m b c', 'c 42/m c b'/ data (altern(i,136), i=1,2) / 'p 42/m n m', 'c 42/m m n'/ data (altern(i,137), i=1,2) / 'p 42/n m c', 'c 42/a c m'/ data (altern(i,138), i=1,2) / 'p 42/n c m', 'c 42/a m c'/ data (altern(i,139), i=1,2) / 'i 4/m m m', 'f 4/m m m'/ data (altern(i,140), i=1,2) / 'i 4/m c m', 'f 4/m m c'/ data (altern(i,141), i=1,2) / 'i 41/a m d', 'f 41/d d m'/ data (altern(i,142), i=1,2) / 'i 41/a c d', 'f 41/d d c'/ test = 'ab' oldgrp = spcgrp call case(test, oldgrp) iperm = 1 c check monoclinic settings do 20 i=3,15 do 10 j=2,1,-1 if (oldgrp.eq.altern(j,i)) then iperm = j+10 ispa = i spcgrp = altern(2,i) call messag('* * WARNING!') call messag('Your crystal is monoclinic. Atoms '// $ 'cannot definitively resolve') call messag('the ambiguities in crystal setting using '// $ 'the standard short symbols.') call messag('Consult The International Tables of '// $ 'X-Ray Crystallography for details on') call messag('permuting monoclinic axes if the output '// $ 'is unsatisfactory.') goto 999 endif 10 continue 20 continue c check orthorhombic settings do 120 i=16,74 do 110 j=1,6 if (oldgrp.eq.altern(j,i)) then iperm = j ispa = i spcgrp = altern(1,i) goto 999 endif 110 continue 120 continue c check tetragonal settings do 220 i=75,142 do 210 j=1,2 if (oldgrp.eq.altern(j,i)) then iperm = j+20 ispa = i spcgrp = altern(1,i) goto 999 endif 210 continue 220 continue 999 continue c print*,'standard space group, input space group' c print*,spcgrp, oldgrp, iperm return c end subroutine setort end subroutine spcchk (spcgrp,ispace) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------- c make sure spcgrp is a valid hermann-mauguin symbol c ispace is the index of the space group as listed below c also check against the schoenflies notation and substitute the c corresponding h-m symbol. c these are listed such that space(i) = schoen(i) for i=1,230 c isn't this cool? c---------------------------------------------------------------- character*10 spcgrp,space(230),schoen(230),test c==================================================================== c hermann-maguin notation c triclinic and monoclinic data (space(i),i=1,15)/ $'p 1','p -1','p 2','p 21','c 2','p m','p c','c m','c c','p 2/m', $'p 21/m','c 2/m','p 2/c','p 21/c','c 2/c'/ c orthorhombic data(space(i),i=16,74)/ $'p 2 2 2','p 2 2 21','p 21 21 2','p 21 21 21','c 2 2 21', $'c 2 2 2','f 2 2 2','i 2 2 2','i 21 21 21','p m m 2','p m c 21', $'p c c 2','p m a 2','p c a 21','p n c 2','p m n 21','p b a 2', $'p n a 21','p n n 2','c m m 2','c m c 21','c c c 2','a m m 2', $'a b m 2','a m a 2','a b a 2','f m m 2','f d d 2','i m m 2', $'i b a 2','i m a 2','p m m m','p n n n','p c c m','p b a n', $'p m m a','p n n a','p m n a','p c c a','p b a m','p c c n', $'p b c m','p n n m','p m m n','p b c n','p b c a','p n m a', $'c m c m','c m c a','c m m m','c c c m','c m m a','c c c a', $'f m m m','f d d d','i m m m','i b a m','i b c a','i m m a'/ c tetragonal data(space(i),i=75,142)/ $'p 4','p 41','p 42','p 43','i 4','i 41','p -4','i -4','p 4/m', $'p 42/m','p 4/n','p 42/n','i 4/m','i 41/a','p 4 2 2','p 4 21 2', $'p 41 2 2','p 41 21 2','p 42 2 2','p 42 21 2','p 43 2 2', $'p 43 21 2','i 4 2 2','i 41 2 2','p 4 m m','p 4 b m','p 42 c m', $'p 42 n m','p 4 c c','p 4 n c','p 42 m c','p 42 b c','i 4 m m', $'i 4 c m','i 41 m d','i 41 c d','p -4 2 m','p -4 2 c','p -4 21 m', $'p -4 21 c','p -4 m 2','p -4 c 2','p -4 b 2','p -4 n 2', $'i -4 m 2','i -4 c 2','i -4 2 m','i -4 2 d','p 4/m m m', $'p 4/m c c','p 4/n b m','p 4/n n c','p 4/m b m','p 4/m n c', $'p 4/n m m','p 4/n c c','p 42/m m c','p 42/m c m','p 42/n b c', $'p 42/n n m','p 42/m b c','p 42/m n m','p 42/n m c','p 42/n c m', $'i 4/m m m','i 4/m c m','i 41/a m d','i 41/a c d'/ c trigonal data(space(i),i=143,167)/ $'p 3','p 31','p 32','r 3','p -3','r -3','p 3 1 2','p 3 2 1', $'p 31 1 2','p 31 2 1','p 32 1 2','p 32 2 1','r 3 2','p 3 m 1', $'p 3 1 m','p 3 c 1','p 3 1 c','r 3 m','r 3 c','p -3 1 m', $'p -3 1 c','p -3 m 1','p -3 c 1','r -3 m','r -3 c'/ c hexagonal data(space(i),i=168,194)/ $'p 6','p 61','p 65','p 62','p 64','p 63','p -6','p 6/m','p 63/m', $'p 6 2 2','p 61 2 2','p 65 2 2','p 62 2 2','p 64 2 2','p 63 2 2', $'p 6 m m','p 6 c c','p 63 c m','p 63 m c','p -6 m 2','p -6 c 2', $'p -6 2 m','p -6 2 c','p 6/m m m','p 6/m c c','p 63/m c m', $'p 63/m m c'/ c cubic data(space(i),i=195,230)/ $'p 2 3','f 2 3','i 2 3','p 21 3','i 21 3','p m 3','p n 3','f m 3', $'f d 3','i m 3','p a 3','i a 3','p 4 3 2','p 42 3 2','f 4 3 2', $'f 41 3 2','i 4 3 2','p 43 3 2','p 41 3 2','i 41 3 2','p -4 3 m', $'f -4 3 m','i -4 3 m','p -4 3 n','f -4 3 c','i -4 3 d','p m 3 m', $'p n 3 n','p m 3 n','p n 3 m','f m 3 m','f m 3 c','f d 3 m', $'f d 3 c','i m 3 m','i a 3 d'/ c==================================================================== c schoenflies notation c triclinic and monoclinic data (schoen(i),i=1,15)/ $'c_1^1','c_i^1','c_2^1','c_2^2','c_2^3','c_s^1','c_s^2','c_s^3', $'c_s^4','c_2h^1','c_2h^2','c_2h^3','c_2h^4','c_2h^5','c_2h^6'/ c orthorhombic data(schoen(i),i=16,74)/ $'d_2^1','d_2^2','d_2^3','d_2^4','d_2^5', $'d_2^6','d_2^7','d_2^8','d_2^9','c_2v^1','c_2v^2', $'c_2v^3','c_2v^4','c_2v^5','c_2v^6','c_2v^7','c_2v^8', $'c_2v^9','c_2v^10','c_2v^11','c_2v^12','c_2v^13','c_2v^14', $'c_2v^15','c_2v^16','c_2v^17','c_2v^18','c_2v^19','c_2v^20', $'c_2v^21','c_2v^22','d_2h^1','d_2h^2','d_2h^3','d_2h^4', $'d_2h^5','d_2h^6','d_2h^7','d_2h^8','d_2h^9','d_2h^10', $'d_2h^11','d_2h^12','d_2h^13','d_2h^14','d_2h^15','d_2h^16', $'d_2h^17','d_2h^18','d_2h^19','d_2h^20','d_2h^21','d_2h^22', $'d_2h^23','d_2h^24','d_2h^25','d_2h^26','d_2h^27','d_2h^28'/ c tetragonal data(schoen(i),i=75,142)/ $'c_4^1','c_4^2','c_4^3','c_4^4','c_4^5','c_4^6','s_4^1','s_4^2', $'c_4h^1','c_4h^2','c_4h^3','c_4h^4','c_4h^5','c_4h^6', $'d_4^1','d_4^2','d_4^3','d_4^4','d_4^5','d_4^6','d_4^7', $'d_4^8','d_4^9','d_4^10','c_4v^1','c_4v^2','c_4v^3', $'c_4v^4','c_4v^5','c_4v^6','c_4v^7','c_4v^8','c_4v^9', $'c_4v^10','c_4v^11','c_4v^12','d_2d^1','d_2d^2','d_2d^3', $'d_2d^4','d_2d^5','d_2d^6','d_2d^7','d_2d^8', $'d_2d^9','d_2d^10','d_2d^11','d_2d^12','d_4h^1', $'d_4h^2','d_4h^3','d_4h^4','d_4h^5','d_4h^6', $'d_4h^7','d_4h^8','d_4h^9','d_4h^10','d_4h^11', $'d_4h^12','d_4h^13','d_4h^14','d_4h^15','d_4h^16', $'d_4h^17','d_4h^18','d_4h^19','d_4h^20'/ c trigonal data(schoen(i),i=143,167)/ $'c_3^1','c_3^2','c_3^3','c_3^4','c_3i^1','c_3i^2', $'d_3^1','d_3^2','d_3^3','d_3^4','d_3^5','d_3^6','d_3^7', $'c_3v^1','c_3v^2','c_3v^3','c_3v^4','c_3v^5','c_3v^6', $'d_3d^1','d_3d^2','d_3d^3','d_3d^4','d_3d^5','d_3d^6'/ c hexagonal data(schoen(i),i=168,194)/ $'c_6^1','c_6^2','c_6^3','c_6^4','c_6^5','c_6^6', $'c_3h^1','c_6h^1','c_6h^2', $'d_6^1','d_6^2','d_6^3','d_6^4','d_6^5','d_6^6', $'c_6v^1','c_6v^2','c_6v^3','c_6v^4','d_3h^1','d_3h^2', $'d_3h^3','d_3h^4','d_6h^1','d_6h^2','d_6h^3','d_6h^4'/ c cubic data(schoen(i),i=195,230)/ $'t^1','t^2','t^3','t^4','t^5','t_h^1','t_h^2','t_h^3', $'t_h^4','t_h^5','t_h^6','t_h^7','o^1','o^2','o^3', $'o^4','o^5','o^6','o^7','o^8','t_d^1', $'t_d^2','t_d^3','t_d^4','t_d^5','t_d^6','o_h^1', $'o_h^2','o_h^3','o_h^4','o_h^5','o_h^6','o_h^7', $'o_h^8','o_h^9','o_h^10'/ c%%% c==================================================================== c the second character of the schoenflies notation must be _ or ^, c these symbols are not used in the hermann-maguin notation. c change hm hexagonal 'c' groups to 'p' c the value of test *must* be in the same case as the data above!! test = 'ab' call case(test,spcgrp) ispace=0 if ((spcgrp(2:2).ne.'_').and.(spcgrp(2:2).ne.'^')) then c hermann-maguin do 10 i=1,230 if ((spcgrp(3:3).eq.'6').and.(spcgrp(1:1).eq.'c')) $ spcgrp(1:1) = 'p' if ((spcgrp(3:3).eq.'-').and.(spcgrp(4:4).eq.'6').and. $ (spcgrp(1:1).eq.'c')) spcgrp(1:1) = 'p' if (spcgrp.eq.space(i)) then ispace=i goto 30 endif 10 continue else c schoenflies call schfix(spcgrp) do 20 i=1,230 if (spcgrp.eq.schoen(i)) then ispace = i spcgrp = space(i) goto 30 endif 20 continue endif 30 continue return c end subroutine spcchk end subroutine systm(cell,isystm) c-------------------------------------------------------------- c copyright (c) 1998 Bruce Ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c determine system from cell constants for comparison c to determination for space group. c isystm : 1 = monoclinic 2 = orthorhombic c 3 = 4 = tetragonal c 5 = cubic 6 = hexagonal c 7 = triclinic 8 = c who came up with this notation convention? why is cubic 5 and not 3? c---------------------------------------------------------------------- parameter (eps=.0001) dimension cell(6) if (abs(cell(6)-120.0).lt.eps) then isystm=6 elseif ( (abs(cell(4)-90).gt.eps) .and. $ (abs(cell(5)-90).lt.eps) .and. $ (abs(cell(6)-90).lt.eps) .and. $ (abs(cell(3)-cell(1)).lt.eps) .and. $ (abs(cell(2)-cell(1)).lt.eps) ) then isystm=6 elseif ( ( (abs(cell(5)-90).gt.eps) .and. $ (abs(cell(6)-90).gt.eps) ) $ .or. (abs(cell(4)-90).gt.eps) $ .or. (abs(cell(6)-90).gt.eps)) then isystm=7 elseif (abs(cell(5)-90).gt.eps) then isystm=1 elseif (abs(cell(3)-cell(1)).lt.eps) then isystm=5 elseif (abs(cell(1)-cell(2)).lt.eps) then isystm=4 else isystm=2 endif return c end subroutine systm end subroutine mcm(idebug) implicit integer(i-n) implicit real(a-h,o-z) c===================================================================== c Atoms Module 3: perform various calculations using mcmaster tables c===================================================================== c this module consists of the following subroutines and functions: c mcm abslen i0 mcmast slfabs c this module also requires: mucal volume positn messag lower dbglvl c polyft case c===================================================================== c input describing the unit cell comes via crystl.h c input controlling exafs function comes via exafs.h c c idebug: an integer denoting the debug level, this is interpreted c into an array of binary bits which are used as logical flags. c multiple debugging features can be enables by specifying a c sum of bits c 0 : disable all debuging function c 1 (+1) : enable positional run-time messages c 2 (+2) : write mcmaster correction diagnostic file c 3 (+4) : write self-absorption correction diagnostic file c 4 (+8) : write i0 correction diagnostic file c------------------------------------------------------------------------ c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ c include 'crystl.h' c-*-fortran-*- c various parameters used by module crystl common /cryint/ iabs, iatom, ibasis, isystm, ispa, iperm, nsites, $ ipt(iat), idop(iat), imult(iat) save /cryint/ parameter(nsysm=4, nshwrn=4) character*2 dopant(iat,ndopx) character*10 spcgrp, tag(iat) character*74 shwarn(nshwrn) character*77 sysmes(nsysm) common /crystr/ shwarn, sysmes, dopant, tag, spcgrp save /crystr/ logical syserr, shift common /crylog/ syserr, shift save /crylog/ dimension trmtx(3,3), st(iat,192,3) dimension cell(6), x(iat), y(iat), z(iat) dimension percnt(iat,ndopx) common /cryflt/ trmtx, st, cell, x, y, z, percnt save /cryflt/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, % = error handling, ! = output needed to c construct cluster, the rest are used internally) c c * iabs: index of absorber in unique coordinate list c * iatom: >=1 if atoms list is used, else =1 c * ibasis: =1 if basis list is used, else =0 c isystm: index of crystal system (1..7)=(mono,orth,,tetr, c cubic,hex,triclinic) c ispa: space group index, 1-230 from IXTC c 0: not recognized, error in input symbol c 1-2: triclinic c 3-15: monoclinic c 16-74: orthorhombic c 75-142: tetragonal c 143-167: trigonal c 168-194: hexagonal c 195-230: cubic c iperm: permutation index for non-standard settings, used in crystl c 1: default value -- no permutation necessary c 1-6: 6 orthorhombic settings (abc, cab, bca, a-cb, ba-c, -cba) c 11-12: 2 monoclinic settings, z-axis unique, y-axis unique c 21-22: 2 tetragonal settings, standard and rotated c ! ipt: (iat) number of positions of unique atom in unit cell (1..192) c imult: (iat) workspace for calculating multiplicities c c % sysmes: 4 line message if space group and axes/angles don't match c % syserr: true if space group and axes/angles don't match c % shwarn: 3 line message if space group may require a shift vector c % shift: true if space group may require a shift vector c c * dopant*2: (iat,ndopx) matrix with all host and dopant atomic symbols c * percnt: (iat,ndopx) matrix with occupancies of hosts and dopants c * tag*10: (iat) character tag for each unique site in cell c * spcgrp*10: space group symbol. On output it is the short c Hermann-Maguin symbol in standard setting. On input c spcgrp can be any short HM, Schoenflies, a number c between 1 and 230, or one of a small set of special c words (fcc, bcc, etc.). Other symbol conventions c (full HM symbol, Shubnikov, 1935 ITXC, etc.) are not c and never will be used. c c * x,y,z: (iat) arrays of fractional coordinates of unique positions c in unit cell c * cell: (6) array of a,b,c,alpha,beta,gamma c c ! trmtx: (3,3) transformation matrix between cell-axis and cartesian c bases, see subroutine trans in clustr c ! st: (iat,192,3) fractional coordinates of all atoms in unit cell, c first arg refers to unique atom list, second c to position in cell, third is xyz. c c fyi: 192 is the largest possible number of equivalent c positions in a cell of any symmetry. see, for example, c cubic f m 3 c. c---------------------------------------------------------------------- c include 'exafs.h' c-*-fortran-*- common /exaflt/ gasses(3), exafs(nexafs), rmax save /exaflt/ common /exaint/ iedge, iexerr save /exaint/ character*10 core, edge*2 common /exastr/ core, edge save /exastr/ logical lfluo common /exalog/ lfluo save /exalog/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, ! = output, % = error handling) c c * gasses: (3) percent pressure of argon, krypton, nitrogen in i0 chamber c gasses(1) percentage of argon c gasses(2) percentage of krypton c gasses(3) percentage of nitrogen c ! exafs: (13) amu,delmu,spgrav,sigmm,qrtmm,ampslf,sigslf,qrtslf, c sigi0,qrti0,muf,mub,mue c exafs(1): total mu c exafs(2): delta mu c exafs(3): speciffic gravity c exafs(4): mcmaster sigma^2 c exafs(5): mcmaster C4 c exafs(6): self absorption amplitude correction c exafs(7): self absorption sigma^2 c exafs(8): self absorption C4 c exafs(9): i0 corrcetion sigma^2 c exafs(10): i0 correction C4 c * iedge: edge for calulation, 1=K 2=L1 3=L2 4=L3 c * iexerr: exit error code, 0=no prob, 1=info, 2=warning, 3=error c * core*10: tag of absorbing atom c lfluo: true if fluorescence corrections were calculated c---------------------------------------------------------------------- parameter(epsi = 1.e-3) integer idebug, idbg(0:ndbgx) logical lmcm, lself, li0 character*78 module, string, messg call dbglvl(idebug,idbg) c print*,'idebug=',idebug,' idbg=(',idbg,')' lmcm = .false. if (idbg(1).gt.0) lmcm = .true. lself = .false. if (idbg(2).gt.0) lself = .true. li0 =.false. if (idbg(3).gt.0) li0 = .true. module = 'mcm' 400 format(' *** Warning: ', a, ' set to a negative number.') 410 format(' *** Warning: ', a, ' set to larger than 1.') c check nitrogen if (gasses(1).lt.0.) then write(messg,400)'argon' call messag(messg) call messag(' The value was reset to 0.-') gasses(1) = 0 iexerr = 2 endif if (gasses(1).gt.1.) then write(messg,410)'argon' call messag(messg) call messag(' The value was reset to 1.-') gasses(1) = 1 iexerr = 2 endif c check argon if (gasses(2).lt.0.) then write(messg,400)'krypton' call messag(messg) call messag(' The value was reset to 0.-') gasses(2) = 0 iexerr = 2 endif if (gasses(2).gt.1.) then write(messg,410)'krypton' call messag(messg) call messag(' The value was reset to 1.-') gasses(2) = 1 iexerr = 2 endif c check krypton if (gasses(3).lt.0.) then write(messg,400)'nitrgen' call messag(messg) call messag(' The value was reset to 0.-') gasses(3) = 0 iexerr = 2 endif if (gasses(3).gt.1.) then write(messg,410)'nitrogen' call messag(messg) call messag(' The value was reset to 1.-') gasses(3) = 1 iexerr = 2 endif c check sum of gasses lfluo = .false. sum = gasses(1) + gasses(2) + gasses(3) if (sum.gt.1.+epsi) then call messag(' *** Warning: the sum off gasses exceeds 1.') call messag(' Turning off fluorescence corrections.-') iexerr = 2 elseif (sum.gt.epsi) then lfluo = .true. endif c------------------------------------------------------------ c calculate absorption and density of the crystal c calculate mcmaster correction for central atom c calculate self absorption correction for fluorescence c calculate i0 correction for fluorescence if ( (iedge.gt.1) .and. (is2z(core).lt.30) ) then call messag(' ') call messag(' *** Warning: McMaster calculations are '// $ 'unreliable for L edges of Z<30.-') call messag(' ') iexerr = 2 endif string = 'computing absorption length' if (idbg(0).gt.0) call positn(module, string) v = volume(cell) call abslen(iat, ndopx, nsites, ipt, iedge, idop, core, dopant, $ percnt, v, amu, delmu, spgrav) string = 'computing McMaster correction' if (idbg(0).gt.0) call positn(module, string) call mcmast(core,iedge,sigmm,qrtmm,lmcm) if (lfluo) then string = 'computing self absorption correction' if (idbg(0).gt.0) call positn(module, string) call slfabs(iat, ndopx, nsites, ipt, iedge, idop, core, $ dopant, percnt, lself, $ ampslf, sigslf, qrtslf, xmuf, xmub) string = 'computing I0 correction' if (idbg(0).gt.0) call positn(module, string) call i0(gasses, core, iedge, li0, sigi0, qrti0) endif exafs(1) = amu exafs(2) = delmu exafs(3) = spgrav exafs(4) = sigmm exafs(5) = qrtmm exafs(6) = ampslf exafs(7) = sigslf exafs(8) = qrtslf exafs(9) = sigi0 exafs(10) = qrti0 exafs(11) = xmuf exafs(12) = xmub exafs(13) = delmu*v return c end of module mcm end subroutine abslen(iat,ndopx, $ iatom,ipt,iedge,idop,core,dopant, $ percnt, v, amu, delmu, spgrav) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c calculate the absorption of the crystal. c recall that barn=10e-24 cm^2/atom and [v]=10e-24 cm^3, thus the c numerical factor cancels exactly. yeah! c also the numerical factor cancels in the specific gravity calculation. c---------------------------------------------------------------------- c input c iat, ndopx: parameters set in calling program c iatom: number of unique atoms c ipt: number of repititions of each unique atom c iedge: desired edge, defaulted by z c idop: (iat) number of species at each site, 1=no dopants, 2+=dopants c core*2: core atom symbol c dopant*2: (iat,ndopx) symbol of doping element c percnt: (iat,ndopx) percnt of dopant, real c v: volume of unit cell, real c output c amu: mu above the edge, real c delmu: delta mu of core, real c spgrav: the specific gravity of the material assuming the density c of the bulk is the same as the density of the cell, real c---------------------------------------------------------------------- c parameter(iat=50,ndopx=4) parameter(factor=1.66053) c atomic mass unit = 1.66053e-24 gram logical lerr character*2 units*1, dopant(iat,ndopx), dp, test character*10 core,cr dimension ipt(iat), idop(iat) dimension energy(9), xsec(10) dimension percnt(iat,ndopx) c---------------------------------------------------------------------- c get edge energy of core atom, w/ units=b mucal returns barns test = 'ab' ener = -1000 units = 'b' lerr = .false. cr = core call case(test, cr) iz = is2z(core) call mucal(ener,core,iz,units,xsec,energy,lerr,ier) ener = energy(iedge) c---------------------------------------------------------------------- c calculate total mu above and below the edge and calculate the density c of the material. mu calculated at +/- estep=50 ev. c outer loop over sites, inner loop over principle and doping atoms estep = 0.05 ier = 0 amu = 0 delmu = 0 camu = 0 cbmu = 0 spgrav = 0 do 20 i=1,iatom do 15 j=1,idop(i) dp = dopant(i,j) call case(test,dp) if (dp.eq.'nu') then goto 15 else iz = is2z(dopant(i,j)) endif call mucal(ener+estep,dopant(i,j),iz,units, $ xsec,energy,lerr,ier) amu = amu + ipt(i)*percnt(i,j)*xsec(4) if (dp.eq.cr) then camu = camu + ipt(i)*percnt(i,j)*xsec(4) call mucal(ener-estep,cr,iz,units,xsec,energy,lerr,ier) cbmu = cbmu + ipt(i)*percnt(i,j)*xsec(4) endif spgrav = spgrav + ipt(i)*percnt(i,j)*xsec(7) 15 continue 20 continue amu = amu / v delmu = (camu - cbmu) / v spgrav = factor*spgrav / v call mucerr(ier) return c end subroutine abslen end subroutine i0(gasses,core,iedge,li0,sigi0,qrti0) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c calculate the i0 corrections for a measurement taken in c in fluorescence. c this correction is needed to compensate for the energy dependence of c the gasses in the i0 chamber. since fluorescent photons are a single c energy, this energy dependence is not divided out when mu is constructed. c it is well approximated by a cubic polynomial regression in ln(E) to c the absorption of the gasses in the i0 chamber c corrections are given as sigma^2 and fourth cumulant. c---------------------------------------------------------------------- c input c pargon: percent by pressure of argon in i0 chamber, real c pnitro: percent by pressure of nitrogen in i0 chamber, real c pnitro: percent by pressure of krypton in i0 chamber, real c core*2: symbol of central atom c iedge: desired edge, defaulted by z, currently k or l3 c li0: undocumented flag to write out i0 diagnostic file, logical c output c sigi0: sigma2 for i0 correction, real c qrti0: sigma4 (quartic term) for i0 correction, real c---------------------------------------------------------------------- c implicit double precision (a-h,o-z) parameter ( iou = 10 ) parameter ( nvals = 50, nfit = 5 ) parameter ( etok=0.26246 82917 ) c nvals: # of points in regression c nfit: max order of polynomial c etok: conversion btwn ev and invang logical lerr,li0 c lerr: used for error checking in mucal c lself: true means to write out the numbers in the self absorption c correction calculation. this is undocumented and will c always be that way. character*2 units*1,core,el character*6 fname dimension xlnxmu(nvals), qsqr(nvals) dimension energy(9), xsec(10), gasses(3) dimension afit(nfit) pargon = gasses(1) pkrypt = gasses(2) pnitro = gasses(3) c---------------------------------------------------------------------- c get edge energy of core atom, e0 = edge energy e0 = -1000 units = 'b' lerr = .false. iz = is2z(core) call mucal(e0,core,iz,units,xsec,energy,lerr,ier) e0 = energy(iedge) c estep: energy step in kev, elimit: end of post-edge region = .5kev estep = .010 elimit = nvals * estep c print*,'elimit = ',elimit c---------------------------------------------------------------------- c get pressure percentage of helium from argon and nitrogen c percentages. then convert percentages to reflect the number of c absorbers. recall that these gases behave like ideal gases at room c temp. and pressure -- nitrogen is diatomic, the other two are c monoatomic, thus the percentages of absorbers is different from the c pressure percentages. phelm = 1 - pargon - pnitro - pkrypt pnorm = phelm + pargon + 2*pnitro + pkrypt phelm = phelm / pnorm pargon = pargon / pnorm pnitro = 2*pnitro / pnorm pkrypt = pkrypt / pnorm c---------------------------------------------------------------------- c calculate total mu above the edge at several energy values c and keep log(mu - preedge extrapolation) v. k^2 (k in inverse angs) ier = 0 do 300 i = 1, nvals ener = i * estep e = e0 + ener el = 'h' iz = is2z(el) call mucal(e,el,iz,units,xsec,energy,lerr,ier) xmuhe = xsec(4) el = 'ar' iz = is2z(el) call mucal(e,el,iz,units,xsec,energy,lerr,ier) xmuar = xsec(4) el = 'n' iz = is2z(el) call mucal(e,el,iz,units,xsec,energy,lerr,ier) xmun = xsec(4) el = 'kr' iz = is2z(el) call mucal(e,el,iz,units,xsec,energy,lerr,ier) xmukr = xsec(4) xmu = phelm*xmuhe + pargon*xmuar + pnitro*xmun + pkrypt*xmukr xlnxmu(i) = log( xmu ) qsqr(i) = etok * ener * 1000.000 300 continue c-------------------------------------------------------------------- c fit log(xmu) v. energy with a quadratic c the linear coef is the i0 sigma2, the quad. coef. is the i0 sigma4 nterms = 3 do 310 i=1,nfit afit(i) = 0.0 310 continue call polyft(qsqr(1),qsqr(nvals),qsqr,xlnxmu,nvals,nterms,afit) sigi0 = - afit(2) / 2.0 qrti0 = afit(3) * 3.0 / 2.0 call mucerr(ier) c undocumented diagnostic file c if you do not already know what this file is for, then you don't want c to use it. if (li0) then fname = 'i0.dat' call lower(fname) open (unit=iou,file=fname,status='unknown') write(iou,*)'afit[2,3]',afit(2),afit(3) write(iou,*)'converted',sigi0,qrti0 do 1000 i=1,nvals ener = i * estep e = e0 + ener val = afit(1) + qsqr(i)*(afit(2) + afit(3)*qsqr(i)) write(iou,400)e,xlnxmu(i),val 400 format(3(2x,f10.6)) 1000 continue close(iou) endif return c end subroutine i0 end subroutine mcmast(core,iedge,sigmm,qrtmm,lmm) c--------------------------------------------------------------------------- c copyright 1993 university of washington matt newville and bruce ravel c--------------------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c calculate the mcmaster correction for the central atom. e and e^2 c correction terms are given as sigma^2 and fourth cumulant. c---------------------------------------------------------------------- c input c core*2: central atom in problem c iedge: desired edge, defaulted by z, currently k or l3 c lmm: undocumented logical keyword, write mcmast.dat, logical c output c sigmm: sigma2 for mcmaster correction, real c qrtmm: sigma4 (quartic term) for mcmaster correction, real c---------------------------------------------------------------------- parameter ( iou = 10 ) parameter ( nvals = 50, npre = 10, nfit = 5 ) parameter ( etok=0.26246 82917 ) c nvals: # of points in postedge regression c npre: # of points in preedge regression c nfit: max order of polynomial c etok: conversion btwn ev and invang logical lerr,lmm c lerr: used for error checking in mucal c lmm : true means to write out the numbers in the mcmaster correction c calculation. this is undocumented and will always be that way. character*2 units*1,core character*10 fname dimension xlnxmu(nvals), qsqr(nvals), xmupre(npre), epre(npre) dimension energy(9), xsec(10), afit(nfit) c---------------------------------------------------------------------- c get edge energy of core atom, e0 = edge energy e0 = -1000 units = 'b' lerr = .false. iz = is2z(core) call mucal(e0,core,iz,units,xsec,energy,lerr,ier) e0 = energy(iedge) c estep: energy step in kev, elimit: end of post-edge region = .5kev estep = .010 c---------------------------------------------------------------------- c calculate total mu below the edge (200ev to 100ev), c undocumented diagnostic file c if you do not already know what this file is for, then you don't want c to use it. if (lmm) then fname = 'mcmast.dat' call lower(fname) open(unit = iou, file=fname, status= 'unknown') write(iou,*) ' iz = ', iz write(iou,*) ' epre(i), xmupre(i) ' endif do 100 i = 1, npre epre(i) = e0 - 0.200 + (i-1) * estep xmu = 0.0 iz = is2z(core) call mucal(epre(i),core,iz,units,xsec,energy,lerr,ier) xmupre(i) = xsec(4) if (lmm) write(iou,*) epre(i), xmupre(i) 100 continue c---------------------------------------------------------------------- c fit pre-edge with a straight line. nterms = 2 do 110 i=1,nfit afit(i) = 0.0 110 continue call polyft(epre(1),epre(npre),epre,xmupre,npre,nterms,afit) bpre = afit(1) slope = afit(2) if (lmm) then write(iou,*) 'slopre, bpre = ', afit(2), afit(1) write(iou,*) ' ' endif c---------------------------------------------------------------------- c calculate total mu above the edge at several energy values c and keep log(mu - preedge extrapolation) v. k^2 (k in inverse angs) ier = 0 if (lmm) write(iou,*) ' qsqr(i), delxmu(i) , xlnxmu(i)' do 300 i = 1, nvals ener = i * estep e = e0 + ener iz = is2z(core) call mucal(e,core,iz,units,xsec,energy,lerr,ier) xmu = xsec(4) delxmu = xmu - (bpre + e*slope) if (delxmu.le.0) delxmu = 0.0001 xlnxmu(i) = log( delxmu ) qsqr(i) = etok * ener * 1000.000 if (lmm) write(iou,*) qsqr(i), delxmu , xlnxmu(i) 300 continue c-------------------------------------------------------------------- c fit log(mu - preedge extrapolation) v. energy with a quadratic c the linear coef is the mcmaster sigma2, the quad. coef. is the c mcmaster sigma4 nterms = 3 do 310 i=1,nfit afit(i) = 0.0 310 continue call polyft(qsqr(1),qsqr(nvals),qsqr,xlnxmu,nvals,nterms,afit) sigmm = - afit(2) / 2.0 qrtmm = afit(3) * 3.0 / 2.0 if (lmm) then write(iou,*) 'qrtmm, sigmm, b = ', qrtmm, sigmm, afit(1) write(iou,*) ' ' write(iou,*) ' fit results:' write(iou,*) ' qsqr , delxmu, log(xmu) ' do 555 i = 1, nvals ener = i * estep qsqr(i) = etok * ener * 1000.000 temp = afit(1) + qsqr(i) * (afit(2) + afit(3)*qsqr(i)) fit = exp( temp ) write(iou,*) qsqr(i), fit, temp 555 continue close(iou) endif call mucerr(ier) return c end subroutine mcmast end subroutine slfabs(iat, ndopx, iatom, ipt, iedge, idop, core, $ dopant, percnt, lself, $ ampslf, sigslf, qrtslf, xmuf, xmub) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c calculate the self absorption corrections for a measurement taken in c in fluorescence. this correction is calculated assuming the crystal c is fully concentrated, i.e. not diluted in any medium. the correction c is needed to compensate for the variable absorption depth due to the c chi(E) wiggles above the edge. it is well approximated by regressing c a cubic polynomial in ln(E) to McMaster data for the full sample. c see Chapter 10 for details c corrections are given as a constant, sigma^2 and fourth cumulant. c---------------------------------------------------------------------- c input c iat, ndopx: parameters set in calling program c iatom: number of unique atoms c ipt: (iat) number of repititions of each unique atom, c array of length iat c iedge: desired edge, defaulted by z, currently k or l3 c core*2: core atom symbol c dopant*2: (iat, ndopx) symbol of doping element c percnt: (iat, ndopx) real, percentage of dopant c lself: undocumented diagnostic file flag, logical c output c ampslf: amplitude factor from self absorption, real c sigslf: sigma2 for self absorption correction, real c qrtslf: sigma4 (quartic term) for self absorption correction, real c muf: absoprtion of whole sample at fluorescent energy c mub: absorption of rest of sample + non-res electrons at E0 c---------------------------------------------------------------------- c parameter (iat=50, ndopx=4) parameter (iou = 10) parameter (nvals = 50, nfit = 5) parameter (etok=0.26246 82917, eps = 0.0001) c nvals: # of points in regression c npre: # of points in preedge regression c nfit: max order of polynomial c etok: conversion btwn ev and invang c eps: small number for floating point logic logical lerr,lself c lerr: used for error checking in mucal c lself: true means to write out the numbers in the self absorption c correction calculation. this is undocumented and will c always be that way. character*2 units*1,dopant(iat,ndopx), dp, test character*8 fname character*10 core dimension xlnxmu(nvals), qsqr(nvals), afit(nfit), xmurat(nvals) dimension ipt(iat), idop(iat) dimension energy(9), xsec(10), percnt(iat,ndopx) c---------------------------------------------------------------------- c get edge energy of core atom, e0 = edge energy test = 'ab' e0 = -1000 units = 'b' lerr = .false. iz = is2z(core) call mucal(e0,core,iz,units,xsec,energy,lerr,ier) e0 = energy(iedge) e0m10 = e0 - 0.01e0 efluor = energy(6) if (iedge.ge.2) efluor = energy(8) c print*,'in slfabs: core,iedge=',core,iedge c estep: energy step in kev, elimit: end of post-edge region = .5kev estep = .010 elimit = nvals * estep c print*,'elimit = ',elimit c---------------------------------------------------------------------- c check to see if post-edge region will run into another c absorption edge in the problem. if it does, stop post-edge c region 10 volts before that edge by resetting estep do 50 i = 1, iatom do 40 j=1,idop(i) iz = is2z(dopant(i,j)) call mucal(e, dopant(i,j), iz,units,xsec,energy,lerr,ier) do 30 k=1,5 if ( (energy(k) - e0).gt.eps ) then echeck = (energy(k) - e0) - .010 elimit = min(elimit, echeck) endif 30 continue 40 continue 50 continue estep = elimit/nvals c---------------------------------------------------------------------- c calculate total absorption at the flourescent energy and 10 volts c below the edge --> xmuf and xmub ier = 0 xmuf = 0 do 150 j=1,iatom do 140 k=1,idop(j) dp = dopant(j,k) call case(test,dp) if (dp.eq.'nu') then goto 140 else iz = is2z(dopant(j,k)) endif call mucal(efluor,dopant(j,k),iz,units,xsec,energy,lerr,ier) xmuf = xmuf + ipt(j)*xsec(4)*percnt(j,k) call mucal(e0m10, dopant(j,k),iz,units,xsec,energy,lerr,ier) xmub = xmub + ipt(j)*xsec(4)*percnt(j,k) 140 continue 150 continue c---------------------------------------------------------------------- c calculate total mu above the edge at several energy values c and keep log(mu - preedge extrapolation) v. k^2 (k in inverse angs) ier = 0 do 300 i = 1, nvals ener = i * estep e = e0 + ener c --- xmu is the absorption of the rest of the sample c --- xmucor is the absorption of the resonant atom xmu = 0.0 xmucor = 0.0 do 250 j = 1, iatom do 240 k=1,idop(j) if (dopant(j,k).eq.'nu') then iz = 1 else iz = is2z(dopant(j,k)) endif call mucal(e, dopant(j,k),iz,units,xsec,energy,lerr,ier) c%%%%%%%%wrong%%%%wrong%%%%wrong%%%%wrong%%%%wrong%%%%wrong%%%%wrong%%%% c%%% the old, bad code. I leave it here in case I need to know how c%%% big a mistake i made before c%%% if (dopant(j,k).eq.core) then c%%% xmucor = xmucor + ipt(j)*xsec(4)*percnt(j,k) c%%% endif c%%% xmu = xmu + ipt(j)*xsec(4)*percnt(j,k) c%%% to test it, uncomment these lines and comment out the next 5 c%%%%%%%%wrong%%%%wrong%%%%wrong%%%%wrong%%%%wrong%%%%wrong%%%%wrong%%%% if (dopant(j,k).eq.core) then xmucor = xmucor + ipt(j)*xsec(4)*percnt(j,k) else xmu = xmu + ipt(j)*xsec(4)*percnt(j,k) endif 240 continue 250 continue c if (i.eq.1) then c print*,'xmu=',xmu/ipt(1) c print*,'xmucor=',xmucor/ipt(1) c endif xmurat(i) = (xmuf + xmu + xmucor) / (xmuf + xmu) c if (xmurat(i).le.0) xmurat(i) = 0.0001 xlnxmu(i) = log( xmurat(i) ) qsqr(i) = etok * ener * 1000.e0 300 continue c-------------------------------------------------------------------- c fit log(xmucore / xmutotal) v. energy with a quadratic c the linear coef is the mcmaster sigma2, the quad. coef. is the c mcmaster sigma4 nterms = 3 do 310 i=1,nfit afit(i) = 0.0 310 continue call polyft(qsqr(1),qsqr(nvals),qsqr,xlnxmu,nvals,nterms,afit) ampslf = exp(afit(1)) sigslf = - afit(2) / 2.0 qrtslf = afit(3) * 3.0 / 2.0 call mucerr(ier) c undocumented diagnostic file c if you do not already know what this file is for, then you don't want c to use it. if (lself) then fname = 'self.dat' call lower(fname) open (unit=iou,file=fname,status='unknown') write(iou,*)'afit(1,2,3)',afit(1),afit(2),afit(3) write(iou,*)'converted',ampslf,sigslf,qrtslf do 1000 i=1,nvals ener = i * estep e = e0 + ener val = exp( afit(1) + qsqr(i)*(afit(2) + afit(3)*qsqr(i)) ) write(iou,400)e,xmurat(i),val 400 format(3(2x,f10.6)) 1000 continue close(iou) endif return c end subroutine slfabs end subroutine mucerr(ier) c generate a warning message from the mucal error code character*2 ending character*22 begin character*78 messg if (ier.eq.0) return begin = ' *** Warning: (mucal) ' ending = '.-' if (ier.eq.1) then messg = begin//'Energy input to mucal is zero'//ending elseif (ier.eq.2) then messg = begin//'Element name does not match Z'//ending elseif ((ier.eq.3).or.(ier.eq.4)) then messg = begin//'No data for Po, At, Fr, Ra, Ac, Pa, '// $ 'Np, or above Pu'//ending elseif (ier.eq.5) then messg = begin//'McMaster only provides l1 data for Z<30'// $ ending elseif (ier.eq.6) then messg = begin//'Energy input to mucal is on an edge'//ending elseif (ier.eq.7) then messg = begin//'No element name of Z supplied'//ending endif call messag(messg) return c end subroutine mucerr end subroutine unit(idebug, ntit, title, vaxflg, ierr) c===================================================================== c atom module 4: construct unit.dat and/or p1.inp c===================================================================== c this module consists of the following subroutines and functions: c unit p1out realcl unitcl writcl c===================================================================== c n.b this module is a skeleton right now -- eventually it will be c used for distortions c===================================================================== c * denotes output c c passed via unit.h: c * iptful: (iat) number of positions of unique atom in overfull unit cell c * fullcl: (iat,192,3) fractional coords of all atoms in overfull unit cell c c idebug: an integer denoting the debug level, this is interpreted c into an array of binary bits which are used as logical flags. c multiple debugging features can be enables by specifying a c sum of bits c 0: disable all debuging function c 1: enable positional run-time messages (2**0) c 2: enable writing p1.inp (2**1) c 3: enable writing unit.inp (2**2) c title*72: (ntitx) array of title lines c vaxflg: set to true for opening files on a vax c ierr: output error code (0=no problem, 1=info, 2=warning, 3=error) c---------------------------------------------------------------------- implicit integer(i-n) implicit real(a-h,o-z) c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ c include 'crystl.h' c-*-fortran-*- c various parameters used by module crystl common /cryint/ iabs, iatom, ibasis, isystm, ispa, iperm, nsites, $ ipt(iat), idop(iat), imult(iat) save /cryint/ parameter(nsysm=4, nshwrn=4) character*2 dopant(iat,ndopx) character*10 spcgrp, tag(iat) character*74 shwarn(nshwrn) character*77 sysmes(nsysm) common /crystr/ shwarn, sysmes, dopant, tag, spcgrp save /crystr/ logical syserr, shift common /crylog/ syserr, shift save /crylog/ dimension trmtx(3,3), st(iat,192,3) dimension cell(6), x(iat), y(iat), z(iat) dimension percnt(iat,ndopx) common /cryflt/ trmtx, st, cell, x, y, z, percnt save /cryflt/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, % = error handling, ! = output needed to c construct cluster, the rest are used internally) c c * iabs: index of absorber in unique coordinate list c * iatom: >=1 if atoms list is used, else =1 c * ibasis: =1 if basis list is used, else =0 c isystm: index of crystal system (1..7)=(mono,orth,,tetr, c cubic,hex,triclinic) c ispa: space group index, 1-230 from IXTC c 0: not recognized, error in input symbol c 1-2: triclinic c 3-15: monoclinic c 16-74: orthorhombic c 75-142: tetragonal c 143-167: trigonal c 168-194: hexagonal c 195-230: cubic c iperm: permutation index for non-standard settings, used in crystl c 1: default value -- no permutation necessary c 1-6: 6 orthorhombic settings (abc, cab, bca, a-cb, ba-c, -cba) c 11-12: 2 monoclinic settings, z-axis unique, y-axis unique c 21-22: 2 tetragonal settings, standard and rotated c ! ipt: (iat) number of positions of unique atom in unit cell (1..192) c imult: (iat) workspace for calculating multiplicities c c % sysmes: 4 line message if space group and axes/angles don't match c % syserr: true if space group and axes/angles don't match c % shwarn: 3 line message if space group may require a shift vector c % shift: true if space group may require a shift vector c c * dopant*2: (iat,ndopx) matrix with all host and dopant atomic symbols c * percnt: (iat,ndopx) matrix with occupancies of hosts and dopants c * tag*10: (iat) character tag for each unique site in cell c * spcgrp*10: space group symbol. On output it is the short c Hermann-Maguin symbol in standard setting. On input c spcgrp can be any short HM, Schoenflies, a number c between 1 and 230, or one of a small set of special c words (fcc, bcc, etc.). Other symbol conventions c (full HM symbol, Shubnikov, 1935 ITXC, etc.) are not c and never will be used. c c * x,y,z: (iat) arrays of fractional coordinates of unique positions c in unit cell c * cell: (6) array of a,b,c,alpha,beta,gamma c c ! trmtx: (3,3) transformation matrix between cell-axis and cartesian c bases, see subroutine trans in clustr c ! st: (iat,192,3) fractional coordinates of all atoms in unit cell, c first arg refers to unique atom list, second c to position in cell, third is xyz. c c fyi: 192 is the largest possible number of equivalent c positions in a cell of any symmetry. see, for example, c cubic f m 3 c. c---------------------------------------------------------------------- c include 'exafs.h' c-*-fortran-*- common /exaflt/ gasses(3), exafs(nexafs), rmax save /exaflt/ common /exaint/ iedge, iexerr save /exaint/ character*10 core, edge*2 common /exastr/ core, edge save /exastr/ logical lfluo common /exalog/ lfluo save /exalog/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: (* = user input, ! = output, % = error handling) c c * gasses: (3) percent pressure of argon, krypton, nitrogen in i0 chamber c gasses(1) percentage of argon c gasses(2) percentage of krypton c gasses(3) percentage of nitrogen c ! exafs: (13) amu,delmu,spgrav,sigmm,qrtmm,ampslf,sigslf,qrtslf, c sigi0,qrti0,muf,mub,mue c exafs(1): total mu c exafs(2): delta mu c exafs(3): speciffic gravity c exafs(4): mcmaster sigma^2 c exafs(5): mcmaster C4 c exafs(6): self absorption amplitude correction c exafs(7): self absorption sigma^2 c exafs(8): self absorption C4 c exafs(9): i0 corrcetion sigma^2 c exafs(10): i0 correction C4 c * iedge: edge for calulation, 1=K 2=L1 3=L2 4=L3 c * iexerr: exit error code, 0=no prob, 1=info, 2=warning, 3=error c * core*10: tag of absorbing atom c lfluo: true if fluorescence corrections were calculated c---------------------------------------------------------------------- c include 'unit.h' c-*-fortran-*- common /uninum/ iptful(iat), fullcl(iat,192,3) save /uninum/ c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c * iptful: (iat) number of positions of unique atom in overfull unit cell c * fullcl: (iat,192,3) fractional coords of all atoms in overfull unit cell c---------------------------------------------------------------------- c include 'version.h' c-*-fortran-*- character*9 vrsion parameter (vrsion='2.50 ') integer idebug, idbg(0:ndbgx) character*72 title(ntitx) character*78 module, string logical vaxflg call dbglvl(idebug,idbg) c print*,'idebug=',idebug,' idbg=(',idbg,')' module = 'unit' ierr = 0 c------------------------------------------------------------ c if space group P1 input file desired, write it out if (idbg(1).gt.0) then string = 'calling p1out' if (idbg(0).gt.0) call positn(module, string) call p1out(iat,ndopx,ntitx,nsites,ntit,iabs,dopant,edge, $ cell,rmax,st,ipt,title,vrsion,vaxflg) endif c------------------------------------------------------------ c if unit cell file desired, calculate overfull cell and write c out unit.dat if (idbg(2).gt.0) then string = 'calling unitcl' if (idbg(0).gt.0) call positn(module, string) call unitcl(iat,nsites,st,ipt,fullcl,iptful) string = 'calling realcl' if (idbg(0).gt.0) call positn(module, string) call realcl(iat,nsites,iptful,cell,fullcl) string = 'calling writcl' if (idbg(0).gt.0) call positn(module, string) call writcl(iat,ndopx,nsites,dopant,tag,iptful,fullcl, $ vrsion, vaxflg) endif return c end of module unit end subroutine p1out(iat,ndopx,ntitx,nsites,ntit,iabs,dopant,edge, $ cell,rmax,st,ipt,title,vrsn,vaxflg) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision(a-h,o-z) parameter(ip1=19) character*2 dopant(iat,ndopx), edge, fname*6, vrsn*9, elmn character*3 ci, cj, tag*15, cabs character*72 title(ntitx) dimension ipt(iat), cell(6), st(iat,192,3) logical there, vaxflg 400 format(a) 405 format(a5,3x,a4) 410 format(3(a5,2x,f9.4,3x)) 420 format('core ',3x,a2,a,a2,6x,'edge ',3x,a2,9x,'rmax ',3x,f7.4) 430 format(2x,a2,3(3x,f8.4),3x,a) 440 format(2x,a2,3(3x,f8.4),3x,a2,i1,'_',i2.2) 450 format(i3) fname = 'p1.inp' call lower(fname) inquire(file=fname, exist=there) ii = istrln(fname) if (there) then call messag(fname(:ii)//' overwritten.') else call messag('Entire unit cell written as an input file to '// $ fname(:ii)) endif if (.not.vaxflg) then open(unit=ip1,file=fname,status='unknown') else open(unit=ip1,file=fname,status='new') endif c write titles write(ip1,400)'! ATOMS '//vrsn//' by Bruce Ravel' do 10 i=1,ntit ii = istrln(title(i)) ii = min(ii,71) write(ip1,400)'title '//title(i)(:ii) 10 continue write(ip1,400)'title unit cell written as space group p 1' c write keywords write(ip1,405)'space', 'p 1' write(ip1,410)'a ', cell(1), 'b ', cell(2), 'c ',cell(3) write(ip1,410)'alpha', cell(4), 'beta ', cell(5), 'gamma',cell(6) c construct tag for core, write more keywords ii=istrln(dopant(iabs,1)) write(cabs,450)iabs call triml(cabs) ia=istrln(cabs) write(ip1,420)dopant(iabs,1)(:ii),cabs(:ia),'_1', edge, rmax write(ip1,400)'atoms' c write atom positions do 30 i=1,nsites do 20 j=1,ipt(i) c construct tag for each atom: Abi_j id = istrln(dopant(i,1)) write(ci,450)i call triml(ci) ii = istrln(ci) write(cj,450)j call triml(cj) ij = istrln(cj) tag = dopant(i,1)(:id)//ci(:ii)//'_'//cj(:ij) elmn = dopant(i,1) call fixsym(elmn) write(ip1,430)elmn,st(i,j,1),st(i,j,2),st(i,j,3),tag 20 continue 30 continue close(ip1) return c end subroutine p1out end subroutine realcl(iat,iatom,iptful,cell,fullcl) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision(a-h,o-z) c--------------------------------------------------------------------- c convert coordinates of atoms in overfull cell from fractional to c angstroms along cell axis basis c do not transform yet! c--------------------------------------------------------------------- c input: c iatom: number of unique atoms c iptful: number of each unique atom in overfull cell c cell: array containing lattice params a,b,c,alpha,beta,gamma c i/o: c fullcl: fractional positions of atoms in overfull cell on input, c cartesian positions on output c--------------------------------------------------------------------- c parameter (iat=50) dimension iptful(iat),cell(6),fullcl(iat,192,3) do 40 i=1,iatom do 30 j=1,iptful(i) c read in position of an atom c and multiply by axis lengths do 10 icoord=1,3 fullcl(i,j,icoord) = fullcl(i,j,icoord) * cell(icoord) 10 continue 30 continue 40 continue return c end subroutine realcl end subroutine unitcl(iat,iatom,st,ipt,fullcl,iptful) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c-------------------------------------------------------------------- c create the overfull unit cell. this is defined as the true unit c cell plus additional atoms on all the walls. thus any atom that c is fully or fractionally within the central cell will have its c coordinates in fullcl. c-------------------------------------------------------------------- c input: c iatom: number of unique atoms c st: fractional coords of each atom in the true unit cell c ipt: number of occurrences of each unique atom in the true cell c output: c fullcl: fractional coords of each atom in the overfull unit cell c iptful: number of occurences of each unique atom in the overfull c cell c-------------------------------------------------------------------- c because 0 is a special position the largest number of atoms on c true unit cell walls is 96 -- doubled is 192, thus ipt and fullcl c can have the same dimensions c-------------------------------------------------------------------- c parameter (iat=50) parameter(eps=0.001) dimension st(iat,192,3),fullcl(iat,192,3) dimension ipt(iat),iptful(iat) c-------------------------------------------------------------------- c copy true cell contents into overfull cell arrays do 30 i=1,iatom do 20 j=1,ipt(i) do 10 k=1,3 fullcl(i,j,k) = st(i,j,k) 10 continue 20 continue iptful(i) = ipt(i) 30 continue c-------------------------------------------------------------------- c search for atoms on a cell edge, wall, or corner. increment iptful c for that atom type and put an atom on the opposite cell edge, wall c or corner. c need to check each position for which wall it is at, i.e. i want c to translate atoms at coordinate 0 to coordinate 1 and those at c coordinate 1 back to 0. ix/y/z =0 when the atom is not near a wall. c ix/y/z =1 when atom is at 0 because i want to add 1 to the coordinate c ix/y/z =-1 when atom is at 1 because i want to sub 1 from the coord. c up to seven new atoms can be generated from a single position for c the overfull cell c ---------- c so 0 means don't translate (not at wall), 1 means translate from 0 c wall to 1 wall, -1 means translate from 1 wall to 0 wall c ---------- do 50 i=1,iatom do 40 j=1,ipt(i) ix = 0 iy = 0 iz = 0 c load ix/y/z for each atom if ( abs(st(i,j,1)) .lt.eps ) ix = 1 if ( abs(st(i,j,1)-1).lt.eps ) ix = -1 if ( abs(st(i,j,2)) .lt.eps ) iy = 1 if ( abs(st(i,j,2)-1).lt.eps ) iy = -1 if ( abs(st(i,j,3)) .lt.eps ) iz = 1 if ( abs(st(i,j,3)-1).lt.eps ) iz = -1 c x at wall if (ix.ne.0) then iptful(i) = iptful(i) + 1 jj = iptful(i) c print*,'unitcl: jj=',jj fullcl(i,jj,1) = st(i,j,1) + ix fullcl(i,jj,2) = st(i,j,2) fullcl(i,jj,3) = st(i,j,3) c x and y at wall if (iy.ne.0) then iptful(i) = iptful(i) + 1 jj = iptful(i) c print*,'unitcl: jj=',jj fullcl(i,jj,1) = st(i,j,1) + ix fullcl(i,jj,2) = st(i,j,2) + iy fullcl(i,jj,3) = st(i,j,3) c x, y and z at wall if (iz.ne.0) then iptful(i) = iptful(i) + 1 jj = iptful(i) c print*,'unitcl: jj=',jj fullcl(i,jj,1) = st(i,j,1) + ix fullcl(i,jj,2) = st(i,j,2) + iy fullcl(i,jj,3) = st(i,j,3) + iz endif endif c x and z at wall if (iz.ne.0) then iptful(i) = iptful(i) + 1 jj = iptful(i) c print*,'unitcl: jj=',jj fullcl(i,jj,1) = st(i,j,1) + ix fullcl(i,jj,2) = st(i,j,2) fullcl(i,jj,3) = st(i,j,3) + iz endif endif c y at wall if (iy.ne.0) then iptful(i) = iptful(i) + 1 jj = iptful(i) c print*,'unitcl: jj=',jj fullcl(i,jj,1) = st(i,j,1) fullcl(i,jj,2) = st(i,j,2) + iy fullcl(i,jj,3) = st(i,j,3) c y and z at wall if (iz.ne.0) then iptful(i) = iptful(i) + 1 jj = iptful(i) c print*,'unitcl: jj=',jj fullcl(i,jj,1) = st(i,j,1) fullcl(i,jj,2) = st(i,j,2) + iy fullcl(i,jj,3) = st(i,j,3) + iz endif endif c z at wall if (iz.ne.0) then iptful(i) = iptful(i) + 1 jj = iptful(i) c print*,'unitcl: jj=',jj fullcl(i,jj,1) = st(i,j,1) fullcl(i,jj,2) = st(i,j,2) fullcl(i,jj,3) = st(i,j,3) + iz endif 40 continue 50 continue return c end subroutine unitcl end subroutine writcl(iat,ndopx, $ iatom,dopant,tag,iptful,fullcl, $ versn,vaxflg) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------- c write out coords of overfull cell to unit.dat c---------------------------------------------------------------- c parameter (iat=50, ndopx=4) parameter(iunit=11) dimension iptful(iat), fullcl(iat,192,3) character*2 dopant(iatom,ndopx),el character*9 versn character*8 fname character*10 tag(iat) logical vaxflg, there 4000 format(1x,i3,3x,a2,2x,a10,3(3x,f6.3)) 4010 format(1x,'! This unit.dat file generated by ATOMS, version ' $ ,a9) 4020 format(1x,'unit cell') fname = 'unit.dat' call lower(fname) inquire(file=fname, exist=there) ii = istrln(fname) if (there) then call messag(fname(:ii)//' overwritten.') else call messag('Unit cell written to '//fname(:ii)) endif if (.not.vaxflg) then open(unit=iunit,file=fname,status='unknown') else open(unit=iunit,file=fname,status='new') endif index = 0 write(iunit,4010)versn write(iunit,4020) do 30 i=1,iatom do 20 j=1,iptful(i) index = index + 1 el = dopant(i,1) call fixsym(el) write(iunit,4000)index, el, tag(i), fullcl(i,j,1), $ fullcl(i,j,2), fullcl(i,j,3) 20 continue 30 continue close(iunit) return c end subroutine writcl end subroutine clustr(iat,natx,ngeomx,nlogx, $ iabs,nsites,iperm,ipt,itot,ngeom, $ cell,trmtx,dmax,st,atlis, $ radii,reftmp,temp,lover, $ logic) c===================================================================== c atom module 6: expand cluster around central atom c===================================================================== c this module consists of the following subroutines and functions: c clustr atheap cellex dist ovrlap subshl tetrot trans c this module calls function ref c===================================================================== c input integers: c iat,natx,ngeomx,nlogx: parameters set in calling program c iabs: index of central atom in arrays dimensioned (iat) c nsites: number of unique positions c ipt: (iat) number of positions of unique atom in unit cell c c output integers: c itot: total number of atoms in cluster c ngeom: (ngeomx) single bounce geometry of each atom in cluster c c input reals: c cell: (6) array of a,b,c,alpha,beta,gamma c trmtx: (3,3) transformation matrix between cell axis and cartesian c coordinates, from subroutine metric c dmax: max cluster size in angstroms c st: (iat,192,3) array of all atomic coordinates in unit cell, c output of module crystl c radii: (natx) workspace c reftmp: (natx) workspace c temp (natx,8) workspace c c output reals: c atlis: (natx, 8) array of all atoms in cluster c 1-3 -> pos. in cell 4 -> dist to origin c 5 -> atom type 6-8 -> cartesian coords c c input logicals c lover: (natx) workspace c logic : array of flags, see arrays.map c--------------------------------------------------------------------- implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) c parameter (iat=50, natx=800, ngeomx=800) parameter(m=8) dimension ipt(iat), ngeom(ngeomx) dimension cell(6), trmtx(3,3) dimension st(iat,192,3), atlis(natx,8) dimension radii(natx),reftmp(natx),temp(natx,m) logical logic(nlogx), lover(natx) 4000 format(a6) c------------------------------------------------------------ c expand the cluster, sort it by radial distance, check for overlap if (logic(25)) call messag(' calling cellex...') call cellex(iat,natx,iabs,nsites,ipt,st,cell,dmax, $ trmtx,itot,atlis) c expand overfull cell, but not right now... c call cellex(iat,natx,iabs,nsites,iptful,fullcl,cell,dmax, c $ trmtx,itot,atlis) c load distances to atoms, (mode=1 in atheap means sort by distance) mode = 1 ifirst = 1 do 50 i=1,itot radii(i) = atlis(i,4) 50 continue if (logic(25)) call messag(' calling atheap...') call atheap(natx,mode,ifirst,itot,atlis,radii,reftmp,temp) c translate all the atoms so that the first entry in atlis is at (0,0,0) xcent = atlis(1,6) ycent = atlis(1,7) zcent = atlis(1,8) do 70 i=1,itot atlis(i,6) = atlis(i,6) - xcent atlis(i,7) = atlis(i,7) - ycent atlis(i,8) = atlis(i,8) - zcent 70 continue c flag down and remove overlapping atoms if (logic(25)) call messag(' calling ovrlap...') call ovrlap(natx,itot,atlis,lover) c sort by subshells if (logic(25)) call messag(' calling subshl...') call subshl(natx,ngeomx,itot,atlis,ngeom,logic(6), $ radii,reftmp,temp) c permute tetragonal crystal back to original setting if (iperm.eq.22) call tetrot(natx, itot, cell, atlis) return c end of module clustr end subroutine atheap(natx,mode,nfirst,nlast,atlis, $ refer,reftmp,temp) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------------------- c heapsort adapted from numerical recipes. sort rows of atlis c comparison to be done with refer, pertinent rows of atlis c first transfered into temp. refer and temp are sorted together. c all the pesky little do loops are for transferring rows c of temp into toss. c c requires function ref c------------------------------------------------------------------- c natx: dimension parameter from calling program c mode: contents of refer, mode=1: sort by radial distance c mode=2: sort by hash of cart. coords. c nfirst: first element of array to sort c nlast: last element to sort c atlis(natx,8): array of (position,distance,atom type,cart. coords) c sorted on output c refer(natx): array of sorting criteria values, sorted on output c reftmp(natx), temp(natx,8): work space c------------------------------------------------------------------- c atlis(natx,8): 1-3 -> pos. in cell 4 -> dist to origin c 5 -> atom type 6,8 -> cartesian coords c------------------------------------------------------------------- parameter (m=8) c parameter (natx=800) dimension atlis(natx,m),toss(m) dimension refer(natx),reftmp(natx),temp(natx,m) c switch atoms to be sorted into temp natom = nlast-nfirst+1 do 40 i=1,natom reftmp(i) = refer(nfirst+i-1) do 20 j=1,m temp(i,j) = atlis(nfirst+i-1,j) 20 continue 40 continue l = natom/2+1 ir = natom 110 continue if (l.gt.1) then l = l-1 do 120 index=1,m toss(index)=temp(l,index) 120 continue rref = reftmp(l) else do 130 index=1,m toss(index) = temp(ir,index) 130 continue rref = reftmp(ir) do 140 index=1,m temp(ir,index)=temp(1,index) 140 continue reftmp(ir)=reftmp(1) ir=ir-1 if(ir.eq.1)then do 150 index=1,m temp(1,index)=toss(index) 150 continue reftmp(1)=rref c sort is finished goto 300 endif endif i=l j=l+l 160 if (j.le.ir) then if (j.lt.ir) then if (reftmp(j).lt.reftmp(j+1)) j=j+1 endif c * * choose sorting mode * * reftos = toss(4) if (mode.eq.1) then reftos = toss(4) elseif (mode.eq.2) then reftos = ref( toss(6), toss(7), toss(8) ) endif if(reftos.lt.reftmp(j))then do 170 index=1,m temp(i,index)=temp(j,index) 170 continue reftmp(i)=reftmp(j) i=j j=j+j else j=ir+1 endif goto 160 endif do 180 index=1,m temp(i,index)=toss(index) 180 continue reftmp(i)=rref goto 110 c switch atoms back into atlis 300 continue do 320 i=1,natom refer(nfirst+i-1) = reftmp(i) do 310 j=1,m atlis(nfirst+i-1,j) = temp(i,j) 310 continue 320 continue return c end subroutine atheap end subroutine cellex(iat,natx, $ iabs,iatom,iptful,fullcl,cell,dmax, $ trmtx,itot,atlis) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------------------------ c c !!!!!! presently passing ipt and st in fractional coords rather than c iptful and fullcl c !!!!!!!!! does not take overfull or cartesian info !!!!!!!!!! c c given an overfull cell in the not-necessarily-orthogonal basis, c expand into a cluster by tacking on adjacent cells. c c check distance of each new atom, if less than dmax, convert to c proper cartesian coordinates and add to atlis c cosum is used to check orthogonality of cell axes c------------------------------------------------------------------------ c input: c iat, natx: dimension parameters from calling program c iabs: index of central atom in arrays dimensioned iat c iatom: number of unique types c iptful: (iat) number of each type in overfull cell c fullcl(iat,192,3): first index marks atom type c second index marks each occurence in overfull c third index marks x,y,z (in cell axis basis) c cell: (6) array of a,b,c,alpha,beta,gamma c dmax: radius of cluster c trmtx: (3,3) transformation matrix cell axis & cartesian bases, from c subroutine metric c output: c itot: number of atoms in cluster c atlis(natx,8): 1-3 -> pos. in cell 4 -> dist to origin c 5 -> atom type 6,8 -> cartesian coords c------------------------------------------------------------------ c parameter (iat=50, natx=800) c natx: max # of atoms to keep c iat : max # of atom types parameter (one=1., epsi=0.0001, zero=0) parameter (pi=3.141592653589793238462643) parameter (big=100000) dimension cell(6) dimension fullcl(iat,192,3), atlis(natx,8), trmtx(3,3) dimension iptful(iat) dimension anewpt(3), centpt(3), d(3) character*6 cnum character*7 creal c character*80 messg 4000 format(f7.4) 4010 format(i6) c------------------------------------------------------------------ c define the central atom, make cosum = sum of cosines of cell angles cosum = zero do 2 i=1,3 c centpt(i) = fullcl(iabs,icnt,i) * cell(i) centpt(i) = fullcl(iabs,1,i) * cell(i) cosum = cosum + abs(cos( cell(i+3)*pi/180 )) 2 continue 5 continue itot=0 c------------------------------------------------------------------------ c determine max number of adjacent cells to fully enclose desired c bubble. this is a safe overkill na = int( dmax/cell(1) + 1 ) nb = int( dmax/cell(2) + 1 ) nc = int( dmax/cell(3) + 1 ) dmin = big c------------------------------------------------------------------------ c loop through all adjacent cells and through all atoms in the overfull c cell. then begin adding atoms to list do 80 ia=-na,na do 70 ib=-nb,nb do 60 ic=-nc,nc do 50 i=1,iatom do 40 j=1,iptful(i) anewpt(1) = (fullcl(i,j,1) + ia)*cell(1) anewpt(2) = (fullcl(i,j,2) + ib)*cell(2) anewpt(3) = (fullcl(i,j,3) + ic)*cell(3) c distance to central atom do 10 icheck=1,3 d(icheck) = anewpt(icheck) - centpt(icheck) 10 continue c too far away dd = dist(d,cell) if (dd.gt.epsi) dmin = min(dmin, dd) if ( dd.gt.dmax ) goto 30 c add to atlis itot = itot + 1 atlis(itot,1) = anewpt(1)/cell(1) atlis(itot,2) = anewpt(2)/cell(2) atlis(itot,3) = anewpt(3)/cell(3) atlis(itot,4) = dd atlis(itot,5) = i * one c calculate cartesian coordinates of atom if (cosum.gt.epsi) call trans(anewpt,trmtx) do 20 k=1,3 atlis(itot,k+5) = anewpt(k) 20 continue c try again with smaller dmax if storage exceeded if (itot.ge.natx) then call messag(' ') call messag('* * * WARNING * * *') write(cnum,4010)natx call messag('You have exceeded '//cnum//' atoms.') call messag('Rmax reduced by 1 Angstrom '// $ 'to accommodate.') dmax = dmax - 1 write(creal,4000)dmax call messag('New rmax = '//creal) call messag(' ') goto 5 endif 30 continue 40 continue 50 continue 60 continue 70 continue 80 continue c if dmax chosen too small, there will be only one atom in the atom list c (the central atom) and the sort routine will barf if (dmin.gt.dmax) then call messag(' ') call messag('* * * WARNING * * *') call messag('Rmax was smaller than the nearest neighbor '// $ 'distance.') call messag('Rmax doubled and cluster expansion run again.') call messag(' ') dmax = 2*dmax goto 5 endif return c end subroutine cellex end function dist(vector,cell) c double precision function dist (vector,cell) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------------------- c calculate distance between (0,0,0) and a position c in the cell axis basis, cosum checks for orthogonal axes c c input: c vector: (3) position in cell axis basis c cell: (6) array of a,b,c,alpha,beta,gamma c output: c dist: distance from origin of the position c------------------------------------------------------------------- parameter (zero=0.e0, epsi=0.0001e0) parameter (pi=3.141592653589793238462643e0) parameter (radian = pi/180.e0) dimension vector(3), cell(6) dist = zero cosum = zero do 10 i=1,3 dist = dist + vector(i)**2 cosum = cosum + abs(cos( cell(i+3)*radian )) 10 continue c correct for non-orthogonal cell axis basis if (cosum.gt.epsi) then dist = dist + 2*vector(1)*vector(2)*cos(cell(6)*radian) $ + 2*vector(1)*vector(3)*cos(cell(5)*radian) $ + 2*vector(2)*vector(3)*cos(cell(4)*radian) endif dist = sqrt(dist) return c end function dist end subroutine ovrlap(natx,itot,atlis,lover) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision(a-h,o-z) c----------------------------------------------------------------- c check if any overlapping atoms have been generated in cluster by c comparing coordinates. c remove overlapping atoms from list c write run-time messages if overlapped atoms found. c this has to be done after the heap sort and before the hash sort c----------------------------------------------------------------- c input: c natx: dimension parameter from calling program c input/output: c itot: number of atoms in cluster, on output: number of c nonredundant atoms c atlis(natx,8): 1-3 -> pos. in cell 4 -> dist to origin c 5 -> atom type 6-8 -> cartesian coords c on output has redundant atoms removed c logical work array: lover(natx) c----------------------------------------------------------------- c parameter (natx=800) parameter(eps=.001) c parameter (iou=21) c eps is used in floating point logicals dimension atlis(natx,8) logical lover(natx),lmessg c character*80 messg, ovrout*10 lmessg = .false. lover(1) = .false. c loop through atoms, get dist x y z, then loop through previous atoms c and compare. mark all but one overlapping atoms do 30 i=2,itot lover(i) = .false. dd = atlis(i,4) xi = atlis(i,6) yi = atlis(i,7) zi = atlis(i,8) do 20 j=1,i-1 if ( abs(atlis(j,4)-dd).le.(eps*10) ) then xdiff = abs(xi-atlis(j,6)) ydiff = abs(yi-atlis(j,7)) zdiff = abs(zi-atlis(j,8)) if ((xdiff.le.eps).and.(ydiff.le.eps).and.(zdiff.le.eps)) $ then lover(i) = .true. lmessg = .true. endif endif 20 continue 30 continue c remove overlapping atoms from the list c every time one atom is removed, bubble the remaining atoms up c write overlapped positions to overlp.err if (lmessg) then C%%% ovrout= 'overlp.err' C%%% call lower(ovrout) C%%% open(unit=iou,file=ovrout,status='unknown') C%%% write(iou,400)' Positions of overlapping atoms in '// C%%% $ 'fractional cell coordinates.' C%%% 400 format(1x,a) i = 1 c do..while.. 40 continue i = i+1 if (lover(i)) then C%%% write (iou,410) atlis(i,1), atlis(i,2), atlis(i,3) C%%% 410 format (3(3x,f8.5)) do 70 j=i+1,itot lover(j-1) = lover(j) do 60 k=1,8 atlis(j-1,k) = atlis(j,k) 60 continue 70 continue i = i-1 itot = itot - 1 endif if (i.lt.itot) goto 40 c write run-time warning if overlapped atoms found call messag(' ') call messag('* * * * WARNING * * * *') call messag('Your input file has generated atoms '// $ 'overlapping in space.') call messag('All redundant atoms have been removed from '// $ 'the atom list.') call messag('Feff.inp has been written and the atom '// $ 'list may be correct') call messag('but the atom labels and McMaster '// $ 'calculations are incorrect.') call messag(' ') call messag('The most likely causes of this are:') call messag(' 1: Specifying a unique crystallographic '// $ 'site more than once. (See') call messag(' section 3.1 of the ATOMS document.)') call messag(' 2: Constructing a basis list that overlaps '// $ 'itself when translated.') call messag(' 3: Specifying incorrect unique '// $ 'crystallographic positions.') C%%% call messag(' ') C%%% ii = istrln(ovrout) C%%% call messag('Positions of atoms found to overlap have '// C%%% $ 'been written') C%%% call messag('to a file called '//ovrout(:ii)) call messag(' ') C%%% close(iou) endif return c end subroutine ovrlap end subroutine subshl(natx,ngeomx,itot,atlis,ngeom,lgeom, $ refer,reftmp,temp) c================================================================== c integers: c natx, ngeomx: dimension parameters from calling program c itot: number of atoms in cluster c c reals: c atlis: (natx, 8) array of all atoms in cluster c 1-3 -> pos. in cell 4 -> dist to origin c 5 -> atom type 6-8 -> cartesian coords c c output: c ngeom: (ngeomx) one bounce flags for geom.dat; integer array c c work space, real arrays: c refer(natx), reftmp(natx), temp(natx,8) c================================================================== c this routine sorts equidistant atoms by a hash value c of the cartesian coordinates. thus atoms at (0,0,5) etc will c be grouped together and different from those at (0,3,-4) etc. c also fills ngeom for use as the one bounce flag in geom.dat c================================================================== implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) c parameter (natx=800, ngeomx=800) parameter (eps=0.001e0, m=8) logical lgeom dimension atlis(natx,8), ngeom(ngeomx) dimension refer(natx), reftmp(natx), temp(natx,m) mode = 2 ifirst = 0 ig = 0 do 10 i=1,itot refer(i) = ref( atlis(i,6), atlis(i,7), atlis(i,8) ) c print*,i,atlis(i,6), atlis(i,7), atlis(i,8), refer(i) 10 continue rlast = atlis(1,4) c step through atom list, when distance changes sort the preceding block c then reset all the markers and continue do 20 i=2,itot if (abs(atlis(i,4)-rlast).gt.eps) then ilast = i-1 if ((ilast-ifirst).gt.2) then call atheap(natx,mode,ifirst,ilast,atlis, $ refer,reftmp,temp) endif ifirst = i rlast = atlis(i,4) endif 20 continue c sort the last group! if ((itot-ifirst).gt.2) call atheap(natx,mode,ifirst,itot,atlis, $ refer,reftmp,temp) c fill ngeom for use in geom.dat if (lgeom) then ifirst = 1 ig = 0 do 50 i=2,itot if (abs(refer(i)-refer(i-1)).gt.eps) then ig = ig + 1 ngeom(ig) = i - ifirst ifirst = i endif 50 continue ig = ig +1 ngeom(ig) = itot-ifirst+1 endif return c end subroutine subshl end subroutine tetrot(natx, itot, cell, atlis) c permute tetragonal cystals back to the non-standard setting c natx: dimension set in celling routine c itot: number of atoms in cluster c cell: (6) array of a,b,c,alpha,beta,gamma c atlis: (natx, 8) array of all atoms in cluster c 1-3 -> pos. in cell 4 -> dist to origin c 5 -> atom type 6-8 -> cartesian coords implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) parameter (root2=1.41421356237309504880e0) dimension atlis(natx,8), cell(6), perm(2,2) perm(1,1) = 1.e0 perm(1,2) = -1.e0 perm(2,1) = 1.e0 perm(2,2) = 1.e0 ab = cell(1) cell(1) = ab * sqrt(2.e0) cell(2) = cell(1) do 70 i=1,itot c permute cartesian coordinates xx = atlis(i,6)*perm(1,1) + atlis(i,7)*perm(1,2) yy = atlis(i,6)*perm(2,1) + atlis(i,7)*perm(2,2) atlis(i,6) = xx / root2 atlis(i,7) = yy / root2 c permute fractional coordinates xx = atlis(i,1)*perm(1,1) + atlis(i,2)*perm(1,2) yy = atlis(i,1)*perm(2,1) + atlis(i,2)*perm(2,2) atlis(i,1) = xx atlis(i,2) = yy 70 continue return c end subroutine tetrot end subroutine trans(vector,trmtx) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------------------- c transform real lengths along cell axes into cartesian coordinates. c trmtx(3,3) is the metric tensor calculated in the subroutine c `metric'. vector(3) is input (cell axis basis) and output c (cartesian) c------------------------------------------------------------------- dimension trmtx(3,3),vector(3),toss(3) do 10 i=1,3 toss(i) = vector(i) vector(i) = 0 10 continue do 30 i=1,3 do 20 j=1,3 vector(i) = vector(i) + trmtx(i,j)*toss(j) 20 continue 30 continue return c end subroutine trans end subroutine output(iat,natx,ntitx,ndopx,ngeomx,maxln,nlogx, $ nexafs, ifeff, $ iabs,itot,ntit,idop,ngeom,imult, $ title,tag,edge,core,dopant,outfil,elemnt, $ vrsion,percnt,exafs,atlis, $ logic,vaxflg, $ tglist,xwrite,ywrite,zwrite,rwrite,index,npot) c===================================================================== c atom module 7: write feff.inp, geom.dat c===================================================================== c this module consists of the following subroutines and functions: c output card feffpr geout c this module calls function ref c===================================================================== implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c organize the results of the cluster expansion in a scratch file c for use in feffpr, then call feffpr. c---------------------------------------------------------------------- c integers: c iat,natx,ntitx,ndopx,ngeomx,maxl,nmlogx c : parameters set in calling program c ifeff: unit number of feff.inp c iabs: index of absorbing atom in arrays dimmensioned iat c itot: number of atoms in cluster c ntit: number of title lines c idop: (iat) number of species at each site, 1=no dopants, 2+=dopants c ngeom: (ngeomx) one bounce flags for geom.dat c c characters c title*72: (ntitx) title lines c tag*10: (iat) site tag for each unique crystallographic site c edge*2: absorbing edge, K, L3 c core*10: tag of absorbing atom c dopant*2: (iat,ndopx) matrix with all host and dopant atomic symbols c outfil*72: output file name c vrsion*5: version number as a character string c c reals: c percnt: (iat,ndopx) occupancies of species and dopants at each site c amu: total absorption above edge in cm^-1 c delmu: change in absorption at edge in cm^-1 c spgrav: specific gravity of crystal c sigmm: McMaster correction sigma^2 c qrtmm: McMaster correction sigma^4 c ampslf: self absorption correction amplitude factor c sigslf: self absorption correction sigma^2 c qrtslf: self absorption correction sigma^4 c sigi0: i0 correction sigma^2 c qrti0: i0 correction sigma^4 c atlis: (natx, 8) array of all atoms in cluster c 1-3 -> pos. in cell 4 -> dist to origin c 5 -> atom type 6-8 -> cartesian coords c c logicals: c logic: array of flags, see arrays.map c vaxflg: set to true if compiled on a Vax c c workspace, all of dimension maxln c tglist (character) c xwrite, ywrite, zwrite, rwrite (real) c index, npot (integer) c---------------------------------------------------------------------- c parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=800) parameter (iuscr=3, iug=4) character*2 edge,dopant(iat,ndopx),dp,test,elemnt(iat) character*9 fname,vrsion*5 character*10 tag(iat),core,tagcen character*72 title(ntitx),outfil,outf dimension atlis(natx,8), idop(iat), percnt(iat,ndopx), $ ngeom(ngeomx), exafs(nexafs), imult(iat) logical logic(nlogx), vaxflg character*10 tglist(maxln) dimension xwrite(maxln), ywrite(maxln), zwrite(maxln), $ rwrite(maxln), index(maxln), npot(maxln) 4000 format(a) 4100 format(1x,a2,3(3x,f8.4),3x,a10,3x,f8.4) 4200 format(1x,'# This atoms.lis file generated by ATOMS, version ', $ a4,/) test = 'ab' c get tag for core atom do 5 i=1,idop(iabs) dp = dopant(iabs,i) call case(test,dp) if (core(1:2).eq.dp) then tagcen = tag(iabs) c tagcen = dopant(iabs,i) c call fixsym(tagcen(1:2)) endif 5 continue c !!!!! don't change the status of this file !!!!! outf=outfil call case(test,outf) c --- write a feff.inp file (and maybe a geom.dat file) ... if (outf.ne.'list') then if (logic(6)) then if (logic(26)) call messag(' calling geout...') call geout(ngeomx, ntitx, natx, $ iug, itot, ntit, ngeom, maxln, $ atlis, vrsion, title, vaxflg) endif if (logic(26)) call messag(' calling feffpr...') call feffpr(iat,natx,ntitx,ndopx,maxln,nexafs,nlogx, $ ifeff,iuscr,itot,ntit,imult, $ edge,core,tag,title,tagcen,exafs,atlis, $ logic, idop,dopant,percnt,elemnt, $ tglist,xwrite,ywrite,zwrite,rwrite,index,npot) close(ifeff) c --- or write a simple list of atoms else if (logic(26)) $ call messag(' opening and writing atoms.lis...') fname = 'atoms.lis' call lower(fname) open (unit=iuscr, file=fname, status='unknown') c make atom list c the list file is six columns: sym x y z tag r do 15 i=1,ntit write(iuscr,4000)title(i) 15 continue write(iuscr,4100) core(1:2), atlis(1,6), atlis(1,7), $ atlis(1,8), tagcen, atlis(1,4) do 20 j=2,itot kat = nint(atlis(j,5)) write(iuscr,4100) dopant(kat,1), atlis(j,6), atlis(j,7), $ atlis(j,8), tag(kat), atlis(j,4) 20 continue write(iuscr,4200)vrsion close(unit=iuscr, status='keep') outfil = fname endif return c end module output end subroutine card(word,feffcd,ii) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c------------------------------------------------------------------ c feff requires the cards to be upper case. this routine assures c that the card will be regardless of the case of this source code c c input: c word: feff card for writing to feff.inp c output: c feffcd: word in all upper case characters c ii: length of word c------------------------------------------------------------------ character*(*) word, feffcd feffcd = word call upper(feffcd) ii = istrln(feffcd) return c end subroutine card end subroutine feffpr(iat,natx,ntitx,ndopx,maxln,nexafs,nlogx, $ ifeff,iunit,itot,ntit,imult, $ edge,core,tag,titl,tagcen,exafs,atlis, $ logic, $ idop,dopant,percnt,elemnt, $ tglist,xwrite,ywrite,zwrite,rwrite,index,npot) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c---------------------------------------------------------------------- c this produces a feff.inp file that will run to completion from a c list of atomic coordinates. the feff.inp file will make resonable c guesses at atom lables, ipots, hole type, and rmax. it will write c all ones for the control card and all zeros for the print card. c it will also write several useful keywords but comment them with an c asterisk. the absorption and the density of the material and the c cluster size will be written as title lines 2 and 3. c---------------------------------------------------------------------- c input: c iunit: scratch file unit number c edge: k, l1, l2, or l3 c exafs: array containing exafs calculations from mcm module c dopant: symbol of doping atom c replcd: symbol of atom replaced by dopant c percnt: occupation of dopant c itot: # of atoms in cluster c---------------------------------------------------------------------- parameter (nw=6, maxty=7, nall=2*maxty) c maxln: max # of atom lines for feff c maxty: max # of unique potentials for feff c parameter (iat=50, ntitx=9, ndopx=4, maxln=400) character*2 edge, dopant(iat,ndopx), cnum, edgeup, elemnt(iat) character*2 at, attype, atlist(0:maxty), test character*10 dwarf(0:nall), core, toss character*10 tglist(maxln), tglast, tag(iat), tagcen character*13 tgword c character*20 words(nw) character*20 feffcd character*23 holewd character*72 titl(ntitx) c character*80 str dimension atlis(natx,8) dimension xwrite(maxln), ywrite(maxln), zwrite(maxln), $ rwrite(maxln) dimension percnt(iat,ndopx), exafs(nexafs) dimension npot(maxln), index(maxln), nz(0:maxty), idop(iat), $ imult(iat), istoi(0:maxty) logical logic(nlogx), ldop, lgcd external s2e data(dwarf(i),i=0,7) /'snow white','dopey','grumpy','bashful', $ 'sleepy','doc','happy','sneezy'/ data(dwarf(i),i=8,nall) /maxty*'ed'/ 4000 format(1x,a) 4002 format(a) 4005 format(i2.2) 4010 format(1x,'* ',a2,' is the central atom.'/,1x,'* ', $'the atom list describes the undoped structure.') 4100 format(1x,14('* -- '),'*') 4200 format(1x,a,2x,f9.5) 4400 format(bn,f10.0) 4500 format(6x,i2,3x,i2,3x,a) 4505 format(6x,i2,3x,i2,4x,a,5x,i2,6x,i2,6x,i2) 4600 format(1x,'* total mu = ',f10.1,' cm^-1, delta mu = ',f10.1, $' cm^-1') 4650 format(1x,'* specific gravity = ',f6.3,', cluster', $' contains ',i4,' atoms.') 4655 format(1x,'* mcmaster corrections: ',f8.5,' ang^2 and ', $e10.3,' ang^4') 4660 format(1x,'* self-abs. corrections: amplitude factor = ', $f6.3) 4662 format(1x,'* ',f8.5,' ang^2 and ', $e10.3,' ang^4') 4670 format(1x,'* i0 corrections: ',f8.5,' ang^2 and ', $e10.3,' ang^4') 4680 format(1x,'* sum of corrections: ',f8.5,' ang^2 and ', $e10.3,' ang^4') 4685 format(1x,'* xanes corrections, [barns/cell]: mu(EF) = ', $ g11.6,/,1x,'* mu_back = ',g11.6, $ ' mu_cen = ',g11.6) 4690 format(1x,'* ',a2,' substituted ',f6.1,'% for ',a10) 4700 format(1x,3(f9.5,3x),i2,3x,a13,3x,f8.5) 4800 format(1x,a,3x,a) 4850 format(1x,a6,' geom.dat file generated with one', $ ' bounce flags.') c---------------------------------------------------------- c initialize things ldop = .false. ipot = 0 test = 'ab' attype = ' ' nwds = nw do 100 i=1,maxty atlist(i) = ' ' istoi(i) = 0 100 continue c---------------------------------------------------------- c read data from scratch file c rewind(iunit) c get the titles c do 105 i=1,ntit c read(iunit,4002,end=140)titl(i) c call triml(titl(i)) c 105 continue c read the line containing the central atom c read(iunit,4000,end=140)str c call bwords(str,nwds,words) tglist(1) = tagcen atlist(0) = core istoi(0) = 0 c atlist(0) = words(1) nz(0) = is2z(core) npot(1) = 0 xwrite(1) = atlis(1,6) ywrite(1) = atlis(1,7) zwrite(1) = atlis(1,8) rwrite(1) = atlis(1,4) c read(words(2),4400)atlis(1,6) c read(words(3),4400)atlis(1,7) c read(words(4),4400)atlis(1,8) c read(words(6),4400)atlis(1,4) c read in all the rest, keep track of ipots by crude criteria c keep track of atom types after the central atom. if an atom type is c repeated do not give it a new ipot. nat = min(itot,maxln) do 130 i=2,nat c nwds=nw c read(iunit,4000,end=140)str c call triml(str) c call bwords(str,nwds,words) kat = nint(atlis(i,5)) at = dopant(kat,1) call case(test,at) xwrite(i) = atlis(i,6) ywrite(i) = atlis(i,7) zwrite(i) = atlis(i,8) rwrite(i) = atlis(i,4) c read(words(2),4400)atlis(i,6) c read(words(3),4400)atlis(i,7) c read(words(4),4400)atlis(i,8) c read(words(6),4400)atlis(i,4) c check the just read atom symbol against the last one. if it is c different then check against the entire list. if it is new then c increment ipot. if it has been seen before then mark jpot with c its previous ipot value and store it in npot(i). c simplest possible assignment of ipots: one unique potential c for every unique atomic species (not crystallographic site!) c at: the present atomic symbol c attype: the last symbol c npot, tglist: lists of ipots and tags for the atom list c nz, atlist: list of z's and symbols for the potentials list c jpot = 0 if (at.ne.attype) then do 110 k=1,ipot toss=atlist(k) call case(test,toss) if (at.eq.toss) then jpot=k goto 120 endif 110 continue ipot = ipot+1 jpot = ipot atlist(ipot) = at nz(ipot) = is2z(at) endif 120 continue attype = at tglist(i) = tag(kat) npot(i) = jpot 130 continue 140 continue c nat=i-1 if (.not.logic(19)) goto 1045 do 1010 ia=0,iat do 1000 ip=1,ipot if (elemnt(ia).eq.atlist(ip)) then istoi(ip) = istoi(ip)+imult(ia) endif 1000 continue 1010 continue minsto=10000 isfact = 1 do 1020 ip=1,ipot minsto = min(minsto, istoi(ip)) 1020 continue c print *, minsto if (minsto.ne.1) then lgcd = .false. do 1040 is=minsto,1,-1 do 1030 ip=1,ipot anum = real(istoi(ip))/real(is) if ((anum - int(anum)) .lt. 0.00001 ) then isfact = is lgcd = .true. else lgcd = .true. goto 1035 endif 1030 continue do 1032 ip=1,ipot istoi(ip) = istoi(ip) / isfact 1032 continue 1035 continue 1040 continue endif 1045 continue c-------------------------------------------------------------------- c interpret the atom indexing if lindex=true c search through the list of atoms. for each atom, compare the tag c to the previous tag (tglast). if it is the same (ie same crys. c site) then check distance. if the distance is different then c increment the index. if distance is the same then use the same c index. if the present tag is different from tglast then search c backwards through all previous atoms to see if that tag (site) c has been used before. if it has, then continue indexing from the c index last used for that site. if it has not been seen before, c then begin indexing from 1. if (logic(4)) then index(1) = 0 tglast = tglist(1) do 148 j=2,nat if (tglist(j).eq.tglast) then jr = int(rwrite(j) * 10000) jrprev = int(rwrite(j-1) * 10000) if (jr.gt.jrprev) then index(j) = index(j-1) + 1 else index(j) = index(j-1) endif else tglast = tglist(j) index(j) = 1 do 143 k=j-2,1,-1 if (tglist(j).eq.tglist(k) ) then index(j) = index(k) + 1 goto 146 endif 143 continue 146 continue endif 148 continue endif c---------------------------------------------------------------- c results of mcmaster module calculations if (logic(28)) then write(ifeff,4100) write(ifeff,4600)exafs(1),exafs(2) write(ifeff,4650)exafs(3),itot write(ifeff,4100) write(ifeff,4655)exafs(4),exafs(5) if (logic(3)) then write(ifeff,4660)exafs(6) write(ifeff,4662)exafs(7),exafs(8) write(ifeff,4670)exafs(9),exafs(10) sumsig = exafs(4) + exafs(7) + exafs(9) sumqrt = exafs(5) + exafs(8) + exafs(10) write(ifeff,4100) write(ifeff,4680)sumsig,sumqrt c write(ifeff,4100) c write(ifeff,4685)exafs(11),exafs(12),exafs(13) endif write(ifeff,4100) endif c---------------------------------------------------------------- c dopant information do 152 i=1,iat do 150 j=2,idop(i) call fixsym(dopant(i,j)) call fixsym(dopant(i,1)) write(ifeff,4690)dopant(i,j),percnt(i,j)*100.,tag(i) ldop = .true. 150 continue 152 continue if (ldop) then call fixsym(core) write(ifeff,4010)core write(ifeff,4100) endif c---------------------------------------------------------------- c titles write(ifeff,4000)' ' call card('title',feffcd,ii) do 155 i=1,ntit ij = istrln(titl(i)) ij = min(ij, 70) write(ifeff,4800)feffcd(:ii),titl(i)(:ij) 155 continue write(ifeff,4000)' ' c -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- c logic(19) is the feff8 flag, control and print take six args c logic(18) is the xanes flag c logic(6) is the nogeom flag c -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- c---------------------------------------------------------------- c hole if (logic(19)) then call card('edge',feffcd,ii) edgeup = edge call upper(edgeup) write(ifeff,4000) feffcd(:ii) // ' ' // edgeup call card('s02',feffcd,ii) write(ifeff,4000) feffcd(:ii) // ' 1.0' else call card('hole',feffcd,ii) call fixsym(atlist(0)) if (edge.eq.'l3') then holewd = ' 4 1.0 '//atlist(0)//' L3 edge' edgen = s2e(atlist(0), 'l3') elseif (edge.eq.'l2') then holewd = ' 3 1.0 '//atlist(0)//' L2 edge' edgen = s2e(atlist(0), 'l2') elseif (edge.eq.'l1') then holewd = ' 2 1.0 '//atlist(0)//' L1 edge' edgen = s2e(atlist(0), 'l1') elseif (edge.eq.'k') then holewd = ' 1 1.0 '//atlist(0)//' K edge' edgen = s2e(atlist(0), 'k') else if (nz(0).gt.57) then holewd = ' 4 1.0 '//atlist(0)//' L3 edge' edgen = s2e(atlist(0), 'l3') else holewd = ' 1 1.0 '//atlist(0)//' K edge' edgen = s2e(atlist(0), 'k') endif endif write(ifeff,4900)feffcd(:ii), holewd, edgen 4900 format (1x, a4, a23, 1x, '(', f7.3, $ ' keV), second number is S0^2') endif c---------------------------------------------------------------- c control, print, rmax cards call card('control',feffcd,ii) write(ifeff,4000)' ' if (logic(19)) then write(ifeff,4000) $ '* pot xsph fms paths genfmt ff2chi' else write(ifeff,4000) '* mphase,mpath,mfeff,mchi' endif if (logic(18)) then write(ifeff,4000)feffcd(:ii)//' 1 0 0 0' elseif (logic(19)) then write(ifeff,4000)feffcd(:ii)// $ ' 1 1 1 1 1 1' else write(ifeff,4000)feffcd(:ii)//' 1 1 1 1' endif call card('print',feffcd,ii) if (logic(6)) then write(ifeff,4000)feffcd(:ii)//' 1 2 0 3' elseif (logic(19)) then write(ifeff,4000)feffcd(:ii)// $ ' 1 0 0 0 0 0' else write(ifeff,4000)feffcd(:ii)//' 1 0 0 3' endif write(ifeff,4000)' ' wrmin = 2.2*rwrite(2) wrmax = rwrite(nat)+0.00001 if (.not.logic(19)) then call card('rmax',feffcd,ii) write(ifeff,4200)feffcd(:ii)//' ',wrmax else call card('scf',feffcd,ii) write(ifeff,4000) '* r_scf [ l_scf n_scf ca ]' write(ifeff,4910)feffcd(:ii)// $ ' ', wrmin, ' 0 15 0.1' 4910 format(1x,a,f7.5,a) endif if (logic(6)) then call card('nogeom',feffcd,ii) write(ifeff,4850)feffcd(:ii) endif write(ifeff,4000)' ' c----------------------------------------------------------------- c various feff cards if (logic(18)) then call card('xanes',feffcd,ii) write(ifeff,4200)feffcd(:ii)//' ',rwrite(nat)+0.00001 call card('vintfix',feffcd,ii) write(ifeff,4000)'*'//feffcd(:ii)//' 10.0' call card('egrid',feffcd,ii) write(ifeff,4000)'*'//feffcd(:ii)//' 1 80' call card('emesh',feffcd,ii) write(ifeff,4000)'*'//feffcd(:ii)//' 1' call card('exchange',feffcd,ii) write(ifeff,4000)feffcd(:ii)//' 2 0 0' elseif (logic(19)) then call card('exchange',feffcd,ii) write(ifeff,4000) '* ixc [ Vr Vi ]' write(ifeff,4000)feffcd(:ii)//' 0 0 0' write(ifeff,4000)' ' call card('exafs',feffcd,ii) write(ifeff,4000)feffcd(:ii) call card('rpath',feffcd,ii) write(ifeff,4200)feffcd(:ii)//' ', 2*wrmin write(ifeff,4000)' ' call card('xanes',feffcd,ii) write(ifeff,4000)'* kmax [ delta_k delta_e ]' write(ifeff,4000) $ '*'//feffcd(:ii)//' 4.0 0.07 0.5' call card('fms',feffcd,ii) write(ifeff,4000)'* r_fms [ l_fms ]' write(ifeff,4207)'*'//feffcd(:ii), wrmin, 0 4207 format(1x,a,4x,2x,f8.5,4x,i2) write(ifeff,4000)'*' call card('rpath',feffcd,ii) write(ifeff,4200)'*'//feffcd(:ii)//' ', 0.1 call card('ldos',feffcd,ii) write(ifeff,4000)'* emin emax resolution' write(ifeff,4000)'*'//feffcd(:ii)//' -20 20 0.1' else call card('criteria',feffcd,ii) write(ifeff,4000)'*'//feffcd(:ii)//' curved plane' call card('debye',feffcd,ii) write(ifeff,4000)'*'//feffcd(:ii)// $ ' temp debye-temp' call card('nleg',feffcd,ii) write(ifeff,4000)'*'//feffcd(:ii)//' 8' endif write(ifeff,4000)' ' c---------------------------------------------------------- c write out the potential list, list is longer for feff8 call card('potentials',feffcd,ii) write(ifeff,4000)feffcd(:ii) if (logic(19)) then write(ifeff,4000) $ '* ipot z [ label l_scmt l_fms '// $ 'stoichiometry ]' else write(ifeff,4000)'* ipot z label' endif do 160 i=0,ipot c istoi = 0 c if (i .ne. 0) istoi = imult(i) if (logic(5)) then if (logic(19)) then llmm = 3 if (nz(i).le.36) llmm = 2 if (nz(i).le.10) llmm = 1 c write(ifeff,4505)i,nz(i),dwarf(i),llmm,llmm write(ifeff,4505)i,nz(i),dwarf(i),-1,-1,istoi(i) else write(ifeff,4500)i,nz(i),dwarf(i) endif else call fixsym(atlist(i)) if (logic(19)) then llmm = 3 if (nz(i).le.36) llmm = 2 if (nz(i).le.10) llmm = 1 write(ifeff,4505)i,nz(i),atlist(i),-1,-1,istoi(i) else write(ifeff,4500)i,nz(i),atlist(i) endif endif 160 continue c---------------------------------------------------------- c write out the atom list write(ifeff,4000)' ' call card('atoms',feffcd,ii) write(ifeff,4000)feffcd(:ii) do 170 i=1,nat if (logic(4)) then itgwd = istrln(tglist(i)) write(cnum,4005)index(i) tgword = tglist(i)(1:itgwd)//'_'//cnum else tgword = tglist(i) endif write(ifeff,4700)xwrite(i),ywrite(i),zwrite(i),npot(i), $ tgword,rwrite(i) 170 continue call card('end',feffcd,ii) write(ifeff,4000)feffcd(:ii) return c end subroutine feffpr end subroutine geout(ngeomx, ntitx, natx, $ iug, itot, ntit, ngeom, maxln, $ atlis, vrsion, title, vaxflg) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c parameter(ngeomx=800) parameter (nwdx=20,maxty=7) parameter (eps=0.0001) dimension atlis(natx,8) character*2 elist(maxty),test,vrsion*5 character*20 fname,feffcd c character*20 words(nwdx) character*72 title(ntitx) dimension ngeom(ngeomx) logical vaxflg 4000 format (a) 4010 format (1x,a) 4020 format (bn,f10.0) 4030 format (1x,70('-')) 4040 format (1x,a,2x,a) 4100 format (1x,i3,3(2x,f10.6),2x,i2,1x,i3) test = 'ab' fname = 'geom.dat' call lower(fname) if (.not.vaxflg) then open (unit=iug,file=fname,status='unknown') else open (unit=iug,file=fname,status='new') endif write(iug,4010)'**this geom.dat file was made by atoms '//vrsion write(iug,4010)'**use this file with the feff.inp file '// $ 'that was created at the same time.' c---------------------------------------------------------- c write the titles call card('title',feffcd,ii) do 105 i=1,ntit write(iug,4040)feffcd(:ii),title(i)(:75-ii) 105 continue write(iug,4030) rlast = -1. icnt = 0 ne = 0 do 10 i=1,maxty elist(i) = ' ' 10 continue do 100 i=1,itot c want geom.dat to be the same length as feff.inp if (itot.gt.maxln) goto 200 igeo = 0 x = atlis(i, 6) y = atlis(i, 7) z = atlis(i, 8) r = ref(x,y,z) if (abs(r-rlast).gt.eps) then ipot = 0 do 50 j=1,ne c if ( (words(1)(1:2).eq.elist(j)).and.(i.ne.1) ) ipot = j if (i.ne.1) ipot = j 50 continue if ( (ipot.eq.0).and.(i.ne.1)) then ne = ne + 1 ipot = ne c elist(ne) = words(1)(1:2) endif icnt = icnt + 1 igeo = ngeom(icnt) rlast = r endif write(iug,4100) (i-1), x, y, z, ipot, igeo 100 continue 200 continue close (iug) return c end subroutine geout end subroutine mucal(en,sym,iz,unit,xsec,energy,erf,ier) c--------------------------------------------------------------------- c mucal.f: generated from mcmaster.dd by dd2f.pl 1.1 c this code and dd2f.pl are copyright (c) 1999 Bruce Ravel c c http://feff.phys.washington.edu/~ravel/atoms/ c c ------------------------------------------------------------------- c All rights reserved. This program is free software; you can c redistribute it and/or modify it under the same terms as Perl c itself. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c Artistic License for more details. c ------------------------------------------------------------------- c c this subroutine has the same semantics as earlier versions of c mucal.f. it was initially tested using the g77 compiler on a c GNU/Linux system with the following flags: -c -Wall -O2 -pedantic c no errors or wranings were reported. Please report any c experiences on other platforms to Bruce Ravel. c c--------------------------------------------------------------------- c This subroutine is based upon the original mucal.f, which was c the work of Dr. Pathikrit Bandyopadhyay and carried this message: c c this is a routine to calculate x-sections using data from c the may 1969 edition of mcmaster. c written by pathikrit bandyopadhyay at the university of c notre dame. c c mucal.f was subsequently modified and maintained by Bruce Ravel c and carried this message: c standardized, stylized and adapted for atoms c by b ravel, september 1992 c c--------------------------------------------------------------------- c c this program has data for all the elements from z=1 to 94 c with the following exceptions: c 84 po \ c 85 at | c 87 fr | c 88 ra > mcmaster does not publish data for these elements. c 89 ac | c 91 pa | c 93 np / c c input: c en: energy at which to calculate the x-section, en<0 means c to skip calculation of absorption c ** symb: name of material c unit: units to be used. 'c' for cm**2/gm, 'b' for barns/atom c ** iz: z number of element c erf: logical print flag (true = print run-time error msgs) c **either or both supplied on input, both returned on output c c output: c xsec(1) = photoelectric x-section c xsec(2) = coherent x-section c xsec(3) = incoherent x-section c xsec(4) = total x-section c xsec(5) = conversion factor c xsec(6) = absorption coefficient c xsec(7) = atomic weight c xsec(8) = density c xsec(9) = l2-edge jump c xsec(10) = l3-edge jump c energy(1) = k-edge energy c energy(2) = l1-edge energy c energy(3) = l2-edge energy c energy(4) = l3-edge energy c energy(5) = m-edge energy c energy(6) = k-alpha1 c energy(7) = k-beta1 c energy(8) = l-alpha1 c energy(9) = l-beta1 c ier = error code c c error codes: c ier=1: energy input is zero c ier=2: name does not match z c ier=3: no documentation for given element (z<94) c ier=4: no documentation for given element (z>94) c ier=5: l-edge calculation may be wrong for z<30 as mcmaster c uses l1 only. c ier=6: energy at the middle of edge c ier=7: no name or z supplied c c****** please correct data errors as they are found. thanx. ****** c c ERROR LOG: c previous: lead k edge, carbon density c 5/95 ak(1,57) corrected c 1/96 l3(28) L3 energy of Ni=855 not 885 c 1/97 den(1) corrected, thanks Boyan c 4/98 ek(39) Y K edge energy fixed to be 17.0384 c c 5/99 database converted to perl and perl used to generate c fortran c -- this error log is no longer updated. please see c perl source c http://feff.phys.washington.edu/~ravel/mcmaster/ c-------------------------------------------------------------------- implicit integer(i-n) implicit real(a-h,o-z) parameter(nelem=94, eps=.001) real ka(nelem),kb(nelem),la(nelem),lb(nelem) real l2(nelem),l3(nelem),lj3(nelem),lj2 logical erf character*1 unit character*2 name(nelem),symb,sym,test dimension ek(nelem),el(nelem),em(nelem),den(nelem), $ atwt(nelem),cf(nelem) dimension ak(0:3,nelem),al(0:3,nelem),am(0:3,nelem), $ an(0:3,nelem) dimension cih(0:3,nelem),coh(0:3,nelem) dimension xsec(10),energy(9) c###the following is the symbol, edge energies, mcmaster c coefficients, flouescent energies, density, conversion c constant, and atomic weight of each supported element c up to plutonium data lj2 / 0.141000e+01 / c data for element #1, Hydrogen, (H) data name(1), ek(1), el(1), em(1) $ /'h ', 1.40000E-02, 0.00000E+00, 0.00000E+00/ data l2(1), l3(1), lj3(1) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(1), kb(1), la(1), lb(1) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(1), cf(1), atwt(1) $ / 8.98800E-05, 1.67400E+00, 1.00800E+00/ data ak(0, 1), ak(1, 1), ak(2, 1), ak(3, 1) $ / 2.44964E+00, -3.34953E+00, -4.71370E-02, 7.09962E-03/ data al(0, 1), al(1, 1), al(2, 1), al(3, 1) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 1), am(1, 1), am(2, 1), am(3, 1) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 1), an(1, 1), an(2, 1), an(3, 1) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 1), coh(1, 1), coh(2, 1), coh(3, 1) $ /-1.19075E-01, -9.37086E-01, -2.00538E-01, 1.06587E-02/ data cih(0, 1), cih(1, 1), cih(2, 1), cih(3, 1) $ /-2.15772E+00, 1.32685E+00, -3.05620E-01, 1.85025E-02/ c data for element #2, Helium, (He) data name(2), ek(2), el(2), em(2) $ /'he', 2.50000E-02, 0.00000E+00, 0.00000E+00/ data l2(2), l3(2), lj3(2) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(2), kb(2), la(2), lb(2) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(2), cf(2), atwt(2) $ / 1.78500E-04, 6.64700E+00, 4.00300E+00/ data ak(0, 2), ak(1, 2), ak(2, 2), ak(3, 2) $ / 6.06488E+00, -3.29055E+00, -1.07256E-01, 1.44465E-02/ data al(0, 2), al(1, 2), al(2, 2), al(3, 2) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 2), am(1, 2), am(2, 2), am(3, 2) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 2), an(1, 2), an(2, 2), an(3, 2) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 2), coh(1, 2), coh(2, 2), coh(3, 2) $ / 1.04768E+00, -8.51805E-02, -4.03527E-01, 2.69398E-02/ data cih(0, 2), cih(1, 2), cih(2, 2), cih(3, 2) $ /-2.56357E+00, 2.02536E+00, -4.48710E-01, 2.79691E-02/ c data for element #3, Lithium, (Li) data name(3), ek(3), el(3), em(3) $ /'li', 5.50000E-02, 0.00000E+00, 0.00000E+00/ data l2(3), l3(3), lj3(3) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(3), kb(3), la(3), lb(3) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(3), cf(3), atwt(3) $ / 5.34000E-01, 1.15200E+01, 6.94000E+00/ data ak(0, 3), ak(1, 3), ak(2, 3), ak(3, 3) $ / 7.75370E+00, -2.81801E+00, -2.41378E-01, 2.62542E-02/ data al(0, 3), al(1, 3), al(2, 3), al(3, 3) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 3), am(1, 3), am(2, 3), am(3, 3) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 3), an(1, 3), an(2, 3), an(3, 3) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 3), coh(1, 3), coh(2, 3), coh(3, 3) $ / 1.34366E+00, 1.81557E-01, -4.23981E-01, 2.66190E-02/ data cih(0, 3), cih(1, 3), cih(2, 3), cih(3, 3) $ /-1.08740E+00, 1.03368E+00, -1.90377E-01, 7.79955E-03/ c data for element #4, Beryllium, (Be) data name(4), ek(4), el(4), em(4) $ /'be', 1.12000E-01, 0.00000E+00, 0.00000E+00/ data l2(4), l3(4), lj3(4) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(4), kb(4), la(4), lb(4) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(4), cf(4), atwt(4) $ / 1.84800E+00, 1.49600E+01, 9.01200E+00/ data ak(0, 4), ak(1, 4), ak(2, 4), ak(3, 4) $ / 9.04511E+00, -2.83487E+00, -2.10021E-01, 2.29526E-02/ data al(0, 4), al(1, 4), al(2, 4), al(3, 4) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 4), am(1, 4), am(2, 4), am(3, 4) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 4), an(1, 4), an(2, 4), an(3, 4) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 4), coh(1, 4), coh(2, 4), coh(3, 4) $ / 2.00860E+00, -4.61920E-02, -3.37018E-01, 1.86939E-02/ data cih(0, 4), cih(1, 4), cih(2, 4), cih(3, 4) $ /-6.90079E-01, 9.46448E-01, -1.71142E-01, 6.51413E-03/ c data for element #5, Boron, (B) data name(5), ek(5), el(5), em(5) $ /'b ', 1.88000E-01, 0.00000E+00, 0.00000E+00/ data l2(5), l3(5), lj3(5) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(5), kb(5), la(5), lb(5) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(5), cf(5), atwt(5) $ / 2.34000E+00, 1.79500E+01, 1.08110E+01/ data ak(0, 5), ak(1, 5), ak(2, 5), ak(3, 5) $ / 9.95057E+00, -2.74174E+00, -2.15138E-01, 2.27845E-02/ data al(0, 5), al(1, 5), al(2, 5), al(3, 5) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 5), am(1, 5), am(2, 5), am(3, 5) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 5), an(1, 5), an(2, 5), an(3, 5) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 5), coh(1, 5), coh(2, 5), coh(3, 5) $ / 2.62862E+00, -2.07916E-01, -2.86283E-01, 1.44966E-02/ data cih(0, 5), cih(1, 5), cih(2, 5), cih(3, 5) $ /-7.91177E-01, 1.21611E+00, -2.39087E-01, 1.17686E-02/ c data for element #6, Carbon, (C) data name(6), ek(6), el(6), em(6) $ /'c ', 2.84000E-01, 0.00000E+00, 0.00000E+00/ data l2(6), l3(6), lj3(6) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(6), kb(6), la(6), lb(6) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(6), cf(6), atwt(6) $ / 2.25000E+00, 1.99400E+01, 1.20100E+01/ data ak(0, 6), ak(1, 6), ak(2, 6), ak(3, 6) $ / 1.06879E+01, -2.71400E+00, -2.00530E-01, 2.07248E-02/ data al(0, 6), al(1, 6), al(2, 6), al(3, 6) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 6), am(1, 6), am(2, 6), am(3, 6) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 6), an(1, 6), an(2, 6), an(3, 6) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 6), coh(1, 6), coh(2, 6), coh(3, 6) $ / 3.10861E+00, -2.60580E-01, -2.71974E-01, 1.35181E-02/ data cih(0, 6), cih(1, 6), cih(2, 6), cih(3, 6) $ /-9.82878E-01, 1.46693E+00, -2.93743E-01, 1.56005E-02/ c data for element #7, Nitrogen, (N) data name(7), ek(7), el(7), em(7) $ /'n ', 4.02000E-01, 0.00000E+00, 0.00000E+00/ data l2(7), l3(7), lj3(7) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(7), kb(7), la(7), lb(7) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(7), cf(7), atwt(7) $ / 1.25000E-03, 2.32600E+01, 1.40080E+01/ data ak(0, 7), ak(1, 7), ak(2, 7), ak(3, 7) $ / 1.12765E+01, -2.65400E+00, -2.00445E-01, 2.00765E-02/ data al(0, 7), al(1, 7), al(2, 7), al(3, 7) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 7), am(1, 7), am(2, 7), am(3, 7) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 7), an(1, 7), an(2, 7), an(3, 7) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 7), coh(1, 7), coh(2, 7), coh(3, 7) $ / 3.47760E+00, -2.15762E-01, -2.88874E-01, 1.15131E-02/ data cih(0, 7), cih(1, 7), cih(2, 7), cih(3, 7) $ /-1.23693E+00, 1.74510E+00, -3.54660E-01, 1.98705E-02/ c data for element #8, Oxygen, (O) data name(8), ek(8), el(8), em(8) $ /'o ', 5.37000E-01, 0.00000E+00, 0.00000E+00/ data l2(8), l3(8), lj3(8) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(8), kb(8), la(8), lb(8) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(8), cf(8), atwt(8) $ / 1.42900E-03, 2.65700E+01, 1.60000E+01/ data ak(0, 8), ak(1, 8), ak(2, 8), ak(3, 8) $ / 1.17130E+01, -2.57229E+00, -2.05893E-01, 1.99244E-02/ data al(0, 8), al(1, 8), al(2, 8), al(3, 8) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 8), am(1, 8), am(2, 8), am(3, 8) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 8), an(1, 8), an(2, 8), an(3, 8) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 8), coh(1, 8), coh(2, 8), coh(3, 8) $ / 3.77239E+00, -1.48539E-01, -3.07124E-01, 1.67303E-02/ data cih(0, 8), cih(1, 8), cih(2, 8), cih(3, 8) $ /-1.73679E+00, 2.17686E+00, -4.49050E-01, 2.64733E-02/ c data for element #9, Fluorine, (F) data name(9), ek(9), el(9), em(9) $ /'f ', 6.86000E-01, 0.00000E+00, 0.00000E+00/ data l2(9), l3(9), lj3(9) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(9), kb(9), la(9), lb(9) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(9), cf(9), atwt(9) $ / 1.10800E+00, 3.15500E+01, 1.90000E+01/ data ak(0, 9), ak(1, 9), ak(2, 9), ak(3, 9) $ / 1.20963E+01, -2.44148E+00, -2.34461E-01, 2.19954E-02/ data al(0, 9), al(1, 9), al(2, 9), al(3, 9) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0, 9), am(1, 9), am(2, 9), am(3, 9) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0, 9), an(1, 9), an(2, 9), an(3, 9) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0, 9), coh(1, 9), coh(2, 9), coh(3, 9) $ / 4.00716E+00, -5.60908E-02, -3.32017E-01, 1.87934E-02/ data cih(0, 9), cih(1, 9), cih(2, 9), cih(3, 9) $ /-1.87570E+00, 2.32016E+00, -4.75412E-01, 2.80680E-02/ c data for element #10, Neon, (Ne) data name(10), ek(10), el(10), em(10) $ /'ne', 8.67000E-01, 0.00000E+00, 0.00000E+00/ data l2(10), l3(10), lj3(10) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(10), kb(10), la(10), lb(10) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(10), cf(10), atwt(10) $ / 9.00000E-04, 3.35100E+01, 2.01830E+01/ data ak(0,10), ak(1,10), ak(2,10), ak(3,10) $ / 1.24485E+01, -2.45819E+00, -2.12591E-01, 1.96489E-02/ data al(0,10), al(1,10), al(2,10), al(3,10) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0,10), am(1,10), am(2,10), am(3,10) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,10), an(1,10), an(2,10), an(3,10) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,10), coh(1,10), coh(2,10), coh(3,10) $ / 4.20151E+00, 4.16247E-02, -3.56754E-01, 2.07585E-02/ data cih(0,10), cih(1,10), cih(2,10), cih(3,10) $ /-1.75510E+00, 2.24226E+00, -4.47640E-01, 2.55801E-02/ c data for element #11, Sodium, (Na) data name(11), ek(11), el(11), em(11) $ /'na', 1.07200E+00, 0.00000E+00, 0.00000E+00/ data l2(11), l3(11), lj3(11) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(11), kb(11), la(11), lb(11) $ / 1.04100E+00, 1.06700E+00, 0.00000E+00, 0.00000E+00/ data den(11), cf(11), atwt(11) $ / 9.70000E-01, 3.81900E+01, 2.29970E+01/ data ak(0,11), ak(1,11), ak(2,11), ak(3,11) $ / 1.26777E+01, -2.24521E+00, -2.74873E-01, 2.50270E-02/ data al(0,11), al(1,11), al(2,11), al(3,11) $ / 1.02355E+01, -2.55905E+00, -1.19524E-01, 0.00000E+00/ data am(0,11), am(1,11), am(2,11), am(3,11) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,11), an(1,11), an(2,11), an(3,11) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,11), coh(1,11), coh(2,11), coh(3,11) $ / 4.26374E+00, 1.34662E-01, -3.70080E-01, 2.14467E-02/ data cih(0,11), cih(1,11), cih(2,11), cih(3,11) $ /-9.67717E-01, 1.61794E+00, -2.87191E-01, 1.31526E-02/ c data for element #12, Magnesium, (Mg) data name(12), ek(12), el(12), em(12) $ /'mg', 1.30500E+00, 6.30000E-02, 0.00000E+00/ data l2(12), l3(12), lj3(12) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(12), kb(12), la(12), lb(12) $ / 1.25400E+00, 1.29700E+00, 0.00000E+00, 0.00000E+00/ data den(12), cf(12), atwt(12) $ / 1.74000E+00, 4.03800E+01, 2.43200E+01/ data ak(0,12), ak(1,12), ak(2,12), ak(3,12) $ / 1.28793E+01, -2.12574E+00, -2.99392E-01, 2.67643E-02/ data al(0,12), al(1,12), al(2,12), al(3,12) $ / 1.05973E+01, -2.89818E+00, 2.34506E-01, 0.00000E+00/ data am(0,12), am(1,12), am(2,12), am(3,12) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,12), an(1,12), an(2,12), an(3,12) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,12), coh(1,12), coh(2,12), coh(3,12) $ / 4.39404E+00, 1.37858E-01, -3.59540E-01, 2.02380E-02/ data cih(0,12), cih(1,12), cih(2,12), cih(3,12) $ /-5.71611E-01, 1.35498E+00, -2.22491E-01, 8.30141E-03/ c data for element #13, Aluminium, (Al) data name(13), ek(13), el(13), em(13) $ /'al', 1.56000E+00, 8.70000E-02, 0.00000E+00/ data l2(13), l3(13), lj3(13) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(13), kb(13), la(13), lb(13) $ / 1.48700E+00, 1.55300E+00, 0.00000E+00, 0.00000E+00/ data den(13), cf(13), atwt(13) $ / 2.72000E+00, 4.47800E+01, 2.69700E+01/ data ak(0,13), ak(1,13), ak(2,13), ak(3,13) $ / 1.31738E+01, -2.18203E+00, -2.58960E-01, 2.22840E-02/ data al(0,13), al(1,13), al(2,13), al(3,13) $ / 1.08711E+01, -2.77860E+00, 1.75853E-01, 0.00000E+00/ data am(0,13), am(1,13), am(2,13), am(3,13) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,13), an(1,13), an(2,13), an(3,13) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,13), coh(1,13), coh(2,13), coh(3,13) $ / 4.15995E+00, 1.40549E-01, -3.52441E-01, 1.93692E-02/ data cih(0,13), cih(1,13), cih(2,13), cih(3,13) $ /-4.39322E-01, 1.30867E+00, -2.11648E-01, 7.54210E-03/ c data for element #14, Silicon, (Si) data name(14), ek(14), el(14), em(14) $ /'si', 1.83900E+00, 1.18000E-01, 0.00000E+00/ data l2(14), l3(14), lj3(14) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(14), kb(14), la(14), lb(14) $ / 1.74000E+00, 1.83200E+00, 0.00000E+00, 0.00000E+00/ data den(14), cf(14), atwt(14) $ / 2.33000E+00, 4.66300E+01, 2.80860E+01/ data ak(0,14), ak(1,14), ak(2,14), ak(3,14) $ / 1.32682E+01, -1.98174E+00, -3.16950E-01, 2.73928E-02/ data al(0,14), al(1,14), al(2,14), al(3,14) $ / 1.12237E+01, -2.73694E+00, 1.27557E-01, 0.00000E+00/ data am(0,14), am(1,14), am(2,14), am(3,14) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,14), an(1,14), an(2,14), an(3,14) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,14), coh(1,14), coh(2,14), coh(3,14) $ / 4.64678E+00, 1.62780E-01, -3.58563E-01, 1.96926E-02/ data cih(0,14), cih(1,14), cih(2,14), cih(3,14) $ /-4.14971E-01, 1.34868E+00, -2.22315E-01, 8.41959E-03/ c data for element #15, Phosphorous, (P) data name(15), ek(15), el(15), em(15) $ /'p ', 2.14900E+00, 1.53000E-01, 0.00000E+00/ data l2(15), l3(15), lj3(15) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(15), kb(15), la(15), lb(15) $ / 2.01500E+00, 2.13600E+00, 0.00000E+00, 0.00000E+00/ data den(15), cf(15), atwt(15) $ / 1.82000E+00, 5.14300E+01, 3.09750E+01/ data ak(0,15), ak(1,15), ak(2,15), ak(3,15) $ / 1.33735E+01, -1.86342E+00, -3.39440E-01, 2.88858E-02/ data al(0,15), al(1,15), al(2,15), al(3,15) $ / 1.15508E+01, -2.92200E+00, 2.54262E-01, 0.00000E+00/ data am(0,15), am(1,15), am(2,15), am(3,15) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,15), an(1,15), an(2,15), an(3,15) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,15), coh(1,15), coh(2,15), coh(3,15) $ / 4.78525E+00, 1.68708E-01, -3.60383E-01, 1.97155E-02/ data cih(0,15), cih(1,15), cih(2,15), cih(3,15) $ /-4.76903E-01, 1.46032E+00, -2.51331E-01, 1.07202E-02/ c data for element #16, Sulfur, (S) data name(16), ek(16), el(16), em(16) $ /'s ', 2.47200E+00, 1.93000E-01, 1.70000E-02/ data l2(16), l3(16), lj3(16) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(16), kb(16), la(16), lb(16) $ / 2.30800E+00, 2.46400E+00, 0.00000E+00, 0.00000E+00/ data den(16), cf(16), atwt(16) $ / 2.00000E+00, 5.32400E+01, 3.20660E+01/ data ak(0,16), ak(1,16), ak(2,16), ak(3,16) $ / 1.37394E+01, -2.04786E+00, -2.73259E-01, 2.29976E-02/ data al(0,16), al(1,16), al(2,16), al(3,16) $ / 1.18181E+01, -2.64618E+00, -9.68049E-02, 0.00000E+00/ data am(0,16), am(1,16), am(2,16), am(3,16) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,16), an(1,16), an(2,16), an(3,16) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,16), coh(1,16), coh(2,16), coh(3,16) $ / 4.92707E+00, 1.65746E-01, -3.59424E-01, 1.95505E-02/ data cih(0,16), cih(1,16), cih(2,16), cih(3,16) $ /-6.56419E-01, 1.65408E+00, -2.98623E-01, 1.42979E-02/ c data for element #17, Chlorine, (Cl) data name(17), ek(17), el(17), em(17) $ /'cl', 2.82200E+00, 2.38000E-01, 1.70000E-02/ data l2(17), l3(17), lj3(17) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(17), kb(17), la(17), lb(17) $ / 2.62200E+00, 2.81500E+00, 0.00000E+00, 0.00000E+00/ data den(17), cf(17), atwt(17) $ / 1.56000E+00, 5.88700E+01, 3.54570E+01/ data ak(0,17), ak(1,17), ak(2,17), ak(3,17) $ / 1.36188E+01, -1.71937E+00, -3.54154E-01, 2.90841E-02/ data al(0,17), al(1,17), al(2,17), al(3,17) $ / 1.20031E+01, -2.41694E+00, -2.40897E-01, 0.00000E+00/ data am(0,17), am(1,17), am(2,17), am(3,17) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,17), an(1,17), an(2,17), an(3,17) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,17), coh(1,17), coh(2,17), coh(3,17) $ / 5.07222E+00, 1.49127E-01, -3.52858E-01, 1.89439E-02/ data cih(0,17), cih(1,17), cih(2,17), cih(3,17) $ /-7.18627E-01, 1.74294E+00, -3.19429E-01, 1.58429E-02/ c data for element #18, Argon, (Ar) data name(18), ek(18), el(18), em(18) $ /'ar', 3.20200E+00, 2.87000E-01, 2.70000E-02/ data l2(18), l3(18), lj3(18) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(18), kb(18), la(18), lb(18) $ / 2.95700E+00, 3.19200E+00, 0.00000E+00, 0.00000E+00/ data den(18), cf(18), atwt(18) $ / 1.78400E-03, 6.63200E+01, 3.99440E+01/ data ak(0,18), ak(1,18), ak(2,18), ak(3,18) $ / 1.39491E+01, -1.82276E+00, -3.28827E-01, 2.74382E-02/ data al(0,18), al(1,18), al(2,18), al(3,18) $ / 1.22960E+01, -2.63279E+00, -7.36600E-02, 0.00000E+00/ data am(0,18), am(1,18), am(2,18), am(3,18) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,18), an(1,18), an(2,18), an(3,18) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,18), coh(1,18), coh(2,18), coh(3,18) $ / 5.21079E+00, 1.35618E-01, -3.47214E-01, 1.84333E-02/ data cih(0,18), cih(1,18), cih(2,18), cih(3,18) $ /-6.82105E-01, 1.74279E+00, -3.17646E-01, 1.56467E-02/ c data for element #19, Potassium, (K) data name(19), ek(19), el(19), em(19) $ /'k ', 3.60700E+00, 3.41000E-01, 3.40000E-02/ data l2(19), l3(19), lj3(19) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(19), kb(19), la(19), lb(19) $ / 3.31300E+00, 3.58900E+00, 0.00000E+00, 0.00000E+00/ data den(19), cf(19), atwt(19) $ / 8.62000E-01, 6.49300E+01, 3.91020E+01/ data ak(0,19), ak(1,19), ak(2,19), ak(3,19) $ / 1.37976E+01, -1.54015E+00, -3.94528E-01, 3.23561E-02/ data al(0,19), al(1,19), al(2,19), al(3,19) $ / 1.24878E+01, -2.53656E+00, -1.04892E-01, 0.00000E+00/ data am(0,19), am(1,19), am(2,19), am(3,19) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,19), an(1,19), an(2,19), an(3,19) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,19), coh(1,19), coh(2,19), coh(3,19) $ / 5.25587E+00, 1.88040E-01, -3.59623E-01, 1.93085E-02/ data cih(0,19), cih(1,19), cih(2,19), cih(3,19) $ /-3.44007E-01, 1.49236E+00, -2.54135E-01, 1.07684E-02/ c data for element #20, Calcium, (Ca) data name(20), ek(20), el(20), em(20) $ /'ca', 4.03800E+00, 4.00000E-01, 4.40000E-02/ data l2(20), l3(20), lj3(20) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(20), kb(20), la(20), lb(20) $ / 3.69100E+00, 4.01200E+00, 0.00000E+00, 0.00000E+00/ data den(20), cf(20), atwt(20) $ / 1.55000E+00, 6.65500E+01, 4.00800E+01/ data ak(0,20), ak(1,20), ak(2,20), ak(3,20) $ / 1.42950E+01, -1.88644E+00, -2.83647E-01, 2.26263E-02/ data al(0,20), al(1,20), al(2,20), al(3,20) $ / 1.27044E+01, -2.55011E+00, -9.43195E-02, 0.00000E+00/ data am(0,20), am(1,20), am(2,20), am(3,20) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,20), an(1,20), an(2,20), an(3,20) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,20), coh(1,20), coh(2,20), coh(3,20) $ / 5.32375E+00, 2.06685E-01, -3.61664E-01, 1.93328E-02/ data cih(0,20), cih(1,20), cih(2,20), cih(3,20) $ /-9.82420E-02, 1.32829E+00, -2.13747E-01, 7.73065E-03/ c data for element #21, Scandium, (Sc) data name(21), ek(21), el(21), em(21) $ /'sc', 4.49300E+00, 4.63000E-01, 5.40000E-02/ data l2(21), l3(21), lj3(21) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(21), kb(21), la(21), lb(21) $ / 4.09000E+00, 4.46000E+00, 0.00000E+00, 0.00000E+00/ data den(21), cf(21), atwt(21) $ / 2.99200E+00, 7.46500E+01, 4.49600E+01/ data ak(0,21), ak(1,21), ak(2,21), ak(3,21) $ / 1.39664E+01, -1.40872E+00, -4.14365E-01, 3.34355E-02/ data al(0,21), al(1,21), al(2,21), al(3,21) $ / 1.28949E+01, -2.40609E+00, -1.77791E-01, 0.00000E+00/ data am(0,21), am(1,21), am(2,21), am(3,21) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,21), an(1,21), an(2,21), an(3,21) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,21), coh(1,21), coh(2,21), coh(3,21) $ / 5.43942E+00, 2.00174E-01, -3.59064E-01, 1.91027E-02/ data cih(0,21), cih(1,21), cih(2,21), cih(3,21) $ /-1.59831E-01, 1.39055E+00, -2.25849E-01, 8.51954E-03/ c data for element #22, Titanium, (Ti) data name(22), ek(22), el(22), em(22) $ /'ti', 4.96500E+00, 5.31000E-01, 5.90000E-02/ data l2(22), l3(22), lj3(22) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(22), kb(22), la(22), lb(22) $ / 4.51000E+00, 4.93100E+00, 0.00000E+00, 0.00000E+00/ data den(22), cf(22), atwt(22) $ / 4.54000E+00, 7.95300E+01, 4.79000E+01/ data ak(0,22), ak(1,22), ak(2,22), ak(3,22) $ / 1.43506E+01, -1.66322E+00, -3.31539E-01, 2.62065E-02/ data al(0,22), al(1,22), al(2,22), al(3,22) $ / 1.31075E+01, -2.53576E+00, -9.57177E-02, 0.00000E+00/ data am(0,22), am(1,22), am(2,22), am(3,22) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,22), an(1,22), an(2,22), an(3,22) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,22), coh(1,22), coh(2,22), coh(3,22) $ / 5.55039E+00, 1.97697E-01, -3.57694E-01, 1.89866E-02/ data cih(0,22), cih(1,22), cih(2,22), cih(3,22) $ /-2.30573E-01, 1.45848E+00, -2.39160E-01, 9.38528E-03/ c data for element #23, Vanadium, (V) data name(23), ek(23), el(23), em(23) $ /'v ', 5.46500E+00, 6.04000E-01, 6.70000E-02/ data l2(23), l3(23), lj3(23) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(23), kb(23), la(23), lb(23) $ / 4.95200E+00, 5.42700E+00, 0.00000E+00, 0.00000E+00/ data den(23), cf(23), atwt(23) $ / 6.11000E+00, 8.45900E+01, 5.09420E+01/ data ak(0,23), ak(1,23), ak(2,23), ak(3,23) $ / 1.47601E+01, -1.88867E+00, -2.71861E-01, 2.15792E-02/ data al(0,23), al(1,23), al(2,23), al(3,23) $ / 1.32514E+01, -2.49765E+00, -1.06383E-01, 0.00000E+00/ data am(0,23), am(1,23), am(2,23), am(3,23) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,23), an(1,23), an(2,23), an(3,23) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,23), coh(1,23), coh(2,23), coh(3,23) $ / 5.65514E+00, 1.99533E-01, -3.57487E-01, 1.89691E-02/ data cih(0,23), cih(1,23), cih(2,23), cih(3,23) $ /-3.08103E-01, 1.52879E+00, -2.52768E-01, 1.02571E-02/ c data for element #24, Chromium, (Cr) data name(24), ek(24), el(24), em(24) $ /'cr', 5.98900E+00, 6.82000E-01, 7.40000E-02/ data l2(24), l3(24), lj3(24) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(24), kb(24), la(24), lb(24) $ / 5.41400E+00, 5.94600E+00, 0.00000E+00, 0.00000E+00/ data den(24), cf(24), atwt(24) $ / 7.19000E+00, 8.63400E+01, 5.19960E+01/ data ak(0,24), ak(1,24), ak(2,24), ak(3,24) $ / 1.48019E+01, -1.82430E+00, -2.79116E-01, 2.17324E-02/ data al(0,24), al(1,24), al(2,24), al(3,24) $ / 1.34236E+01, -2.51532E+00, -1.01999E-01, 0.00000E+00/ data am(0,24), am(1,24), am(2,24), am(3,24) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,24), an(1,24), an(2,24), an(3,24) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,24), coh(1,24), coh(2,24), coh(3,24) $ / 5.77399E+00, 2.03858E-01, -3.59699E-01, 1.92225E-02/ data cih(0,24), cih(1,24), cih(2,24), cih(3,24) $ /-3.87641E-01, 1.59727E+00, -2.66240E-01, 1.11523E-02/ c data for element #25, Manganese, (Mn) data name(25), ek(25), el(25), em(25) $ /'mn', 6.54000E+00, 7.54000E-01, 8.40000E-02/ data l2(25), l3(25), lj3(25) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(25), kb(25), la(25), lb(25) $ / 5.89800E+00, 6.49000E+00, 0.00000E+00, 0.00000E+00/ data den(25), cf(25), atwt(25) $ / 7.42000E+00, 9.12200E+01, 5.49400E+01/ data ak(0,25), ak(1,25), ak(2,25), ak(3,25) $ / 1.48965E+01, -1.79872E+00, -2.83664E-01, 2.22095E-02/ data al(0,25), al(1,25), al(2,25), al(3,25) $ / 1.35761E+01, -2.49761E+00, -1.05493E-01, 0.00000E+00/ data am(0,25), am(1,25), am(2,25), am(3,25) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,25), an(1,25), an(2,25), an(3,25) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,25), coh(1,25), coh(2,25), coh(3,25) $ / 5.84604E+00, 2.13814E-01, -3.59718E-01, 1.91459E-02/ data cih(0,25), cih(1,25), cih(2,25), cih(3,25) $ /-2.47059E-01, 1.49722E+00, -2.38781E-01, 8.93208E-03/ c data for element #26, Iron, (Fe) data name(26), ek(26), el(26), em(26) $ /'fe', 7.11200E+00, 8.42000E-01, 9.40000E-02/ data l2(26), l3(26), lj3(26) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(26), kb(26), la(26), lb(26) $ / 6.40300E+00, 7.05700E+00, 0.00000E+00, 0.00000E+00/ data den(26), cf(26), atwt(26) $ / 7.86000E+00, 9.27400E+01, 5.58500E+01/ data ak(0,26), ak(1,26), ak(2,26), ak(3,26) $ / 1.43456E+01, -1.23491E+00, -4.23491E-01, 3.21661E-02/ data al(0,26), al(1,26), al(2,26), al(3,26) $ / 1.36696E+01, -2.39195E+00, -1.37680E-01, 0.00000E+00/ data am(0,26), am(1,26), am(2,26), am(3,26) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,26), an(1,26), an(2,26), an(3,26) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,26), coh(1,26), coh(2,26), coh(3,26) $ / 5.93292E+00, 2.25038E-01, -3.61748E-01, 1.93024E-02/ data cih(0,26), cih(1,26), cih(2,26), cih(3,26) $ /-3.42379E-01, 1.57245E+00, -2.53198E-01, 9.85822E-03/ c data for element #27, Cobolt, (Co) data name(27), ek(27), el(27), em(27) $ /'co', 7.70900E+00, 9.29000E-01, 1.01000E-01/ data l2(27), l3(27), lj3(27) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(27), kb(27), la(27), lb(27) $ / 6.93000E+00, 7.64900E+00, 0.00000E+00, 0.00000E+00/ data den(27), cf(27), atwt(27) $ / 8.90000E+00, 9.78500E+01, 5.89330E+01/ data ak(0,27), ak(1,27), ak(2,27), ak(3,27) $ / 1.47047E+01, -1.38933E+00, -3.86631E-01, 3.03286E-02/ data al(0,27), al(1,27), al(2,27), al(3,27) $ / 1.38699E+01, -2.50669E+00, -8.69945E-02, 0.00000E+00/ data am(0,27), am(1,27), am(2,27), am(3,27) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,27), an(1,27), an(2,27), an(3,27) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,27), coh(1,27), coh(2,27), coh(3,27) $ / 6.01478E+00, 2.37959E-01, -3.64056E-01, 1.94754E-02/ data cih(0,27), cih(1,27), cih(2,27), cih(3,27) $ /-4.28804E-01, 1.64129E+00, -2.66013E-01, 1.06512E-02/ c data for element #28, Nickel, (Ni) data name(28), ek(28), el(28), em(28) $ /'ni', 8.33300E+00, 1.01200E+00, 1.13000E-01/ data l2(28), l3(28), lj3(28) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(28), kb(28), la(28), lb(28) $ / 7.47700E+00, 8.26400E+00, 0.00000E+00, 0.00000E+00/ data den(28), cf(28), atwt(28) $ / 8.90000E+00, 9.74500E+01, 5.86900E+01/ data ak(0,28), ak(1,28), ak(2,28), ak(3,28) $ / 1.42388E+01, -9.67736E-01, -4.78070E-01, 3.66138E-02/ data al(0,28), al(1,28), al(2,28), al(3,28) $ / 1.39848E+01, -2.48080E+00, -8.88115E-02, 0.00000E+00/ data am(0,28), am(1,28), am(2,28), am(3,28) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,28), an(1,28), an(2,28), an(3,28) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,28), coh(1,28), coh(2,28), coh(3,28) $ / 6.09024E+00, 2.22770E-01, -3.66568E-01, 1.96586E-02/ data cih(0,28), cih(1,28), cih(2,28), cih(3,28) $ /-5.04360E-01, 1.70040E+00, -2.76443E-01, 1.12628E-02/ c data for element #29, Copper, (Cu) data name(29), ek(29), el(29), em(29) $ /'cu', 8.97900E+00, 1.10000E+00, 1.20000E-01/ data l2(29), l3(29), lj3(29) $ / 9.52000E-01, 9.32000E-01, 2.87400E+00/ data ka(29), kb(29), la(29), lb(29) $ / 8.04700E+00, 8.90400E+00, 0.00000E+00, 0.00000E+00/ data den(29), cf(29), atwt(29) $ / 8.94000E+00, 1.05500E+02, 6.35400E+01/ data ak(0,29), ak(1,29), ak(2,29), ak(3,29) $ / 1.45808E+01, -1.18375E+00, -4.13850E-01, 3.12088E-02/ data al(0,29), al(1,29), al(2,29), al(3,29) $ / 1.42439E+01, -2.58677E+00, -6.67398E-02, 0.00000E+00/ data am(0,29), am(1,29), am(2,29), am(3,29) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,29), an(1,29), an(2,29), an(3,29) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,29), coh(1,29), coh(2,29), coh(3,29) $ / 6.17739E+00, 2.73123E-01, -3.72360E-01, 2.01638E-02/ data cih(0,29), cih(1,29), cih(2,29), cih(3,29) $ /-5.70210E-01, 1.75042E+00, -2.84555E-01, 1.16930E-02/ c data for element #30, Zinc, (Zn) data name(30), ek(30), el(30), em(30) $ /'zn', 9.65900E+00, 1.19600E+00, 1.39000E-01/ data l2(30), l3(30), lj3(30) $ / 1.04400E+00, 1.02100E+00, 5.68400E+00/ data ka(30), kb(30), la(30), lb(30) $ / 8.63800E+00, 9.57100E+00, 1.00900E+00, 1.03200E+00/ data den(30), cf(30), atwt(30) $ / 7.14000E+00, 1.08600E+02, 6.53800E+01/ data ak(0,30), ak(1,30), ak(2,30), ak(3,30) $ / 1.44118E+01, -9.33083E-01, -4.77357E-01, 3.62829E-02/ data al(0,30), al(1,30), al(2,30), al(3,30) $ / 1.43221E+01, -2.62384E+00, -2.64926E-02, 0.00000E+00/ data am(0,30), am(1,30), am(2,30), am(3,30) $ / 1.20597E+01, -1.10258E+00, 0.00000E+00, 0.00000E+00/ data an(0,30), an(1,30), an(2,30), an(3,30) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,30), coh(1,30), coh(2,30), coh(3,30) $ / 6.23402E+00, 2.84312E-01, -3.72143E-01, 2.00525E-02/ data cih(0,30), cih(1,30), cih(2,30), cih(3,30) $ /-4.20535E-01, 1.63400E+00, -2.53646E-01, 9.27233E-03/ c data for element #31, Gallium, (Ga) data name(31), ek(31), el(31), em(31) $ /'ga', 1.03670E+01, 1.30200E+00, 1.58000E-01/ data l2(31), l3(31), lj3(31) $ / 1.14200E+00, 1.11500E+00, 5.67100E+00/ data ka(31), kb(31), la(31), lb(31) $ / 9.25100E+00, 1.02630E+01, 1.09600E+00, 1.12200E+00/ data den(31), cf(31), atwt(31) $ / 5.90300E+00, 1.15800E+02, 6.97200E+01/ data ak(0,31), ak(1,31), ak(2,31), ak(3,31) $ / 1.36182E+01, -3.18459E-01, -6.11348E-01, 4.58138E-02/ data al(0,31), al(1,31), al(2,31), al(3,31) $ / 1.44792E+01, -2.54469E+00, -7.57204E-02, 0.00000E+00/ data am(0,31), am(1,31), am(2,31), am(3,31) $ / 1.22646E+01, -2.68965E+00, 0.00000E+00, 0.00000E+00/ data an(0,31), an(1,31), an(2,31), an(3,31) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,31), coh(1,31), coh(2,31), coh(3,31) $ / 6.28298E+00, 2.91334E-01, -3.69391E-01, 1.97029E-02/ data cih(0,31), cih(1,31), cih(2,31), cih(3,31) $ /-3.58218E-01, 1.60050E+00, -2.44908E-01, 8.61898E-03/ c data for element #32, Germanium, (Ge) data name(32), ek(32), el(32), em(32) $ /'ge', 1.11040E+01, 1.41400E+00, 1.81000E-01/ data l2(32), l3(32), lj3(32) $ / 1.24900E+00, 1.21800E+00, 5.70400E+00/ data ka(32), kb(32), la(32), lb(32) $ / 9.88500E+00, 1.09810E+01, 1.18600E+00, 1.21600E+00/ data den(32), cf(32), atwt(32) $ / 5.32300E+00, 1.20500E+02, 7.25900E+01/ data ak(0,32), ak(1,32), ak(2,32), ak(3,32) $ / 1.39288E+01, -4.79613E-01, -5.72897E-01, 4.31277E-02/ data al(0,32), al(1,32), al(2,32), al(3,32) $ / 1.46813E+01, -2.69285E+00, -2.08355E-02, 0.00000E+00/ data am(0,32), am(1,32), am(2,32), am(3,32) $ / 1.24133E+01, -2.53085E+00, 0.00000E+00, 0.00000E+00/ data an(0,32), an(1,32), an(2,32), an(3,32) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,32), coh(1,32), coh(2,32), coh(3,32) $ / 6.33896E+00, 2.91512E-01, -3.65643E-01, 1.92896E-02/ data cih(0,32), cih(1,32), cih(2,32), cih(3,32) $ /-3.34383E-01, 1.60327E+00, -2.45555E-01, 8.71239E-03/ c data for element #33, Arsenic, (As) data name(33), ek(33), el(33), em(33) $ /'as', 1.18680E+01, 1.53000E+00, 2.06000E-01/ data l2(33), l3(33), lj3(33) $ / 1.36000E+00, 1.32500E+00, 4.87500E+00/ data ka(33), kb(33), la(33), lb(33) $ / 1.05430E+01, 1.17250E+01, 1.28200E+00, 1.31700E+00/ data den(33), cf(33), atwt(33) $ / 5.73000E+00, 1.24400E+02, 7.49200E+01/ data ak(0,33), ak(1,33), ak(2,33), ak(3,33) $ / 1.34722E+01, -7.73513E-02, -6.60456E-01, 4.92177E-02/ data al(0,33), al(1,33), al(2,33), al(3,33) $ / 1.46431E+01, -2.48397E+00, -7.96180E-02, 0.00000E+00/ data am(0,33), am(1,33), am(2,33), am(3,33) $ / 1.25392E+01, -2.41380E+00, 0.00000E+00, 0.00000E+00/ data an(0,33), an(1,33), an(2,33), an(3,33) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,33), coh(1,33), coh(2,33), coh(3,33) $ / 6.39750E+00, 2.88866E-01, -3.61747E-01, 1.88788E-02/ data cih(0,33), cih(1,33), cih(2,33), cih(3,33) $ /-3.39189E-01, 1.62535E+00, -2.50783E-01, 9.09103E-03/ c data for element #34, Selenium, (Se) data name(34), ek(34), el(34), em(34) $ /'se', 1.26580E+01, 1.65300E+00, 2.32000E-01/ data l2(34), l3(34), lj3(34) $ / 1.47700E+00, 1.43600E+00, 4.58700E+00/ data ka(34), kb(34), la(34), lb(34) $ / 1.12210E+01, 1.24950E+01, 1.41900E+00, 1.37900E+00/ data den(34), cf(34), atwt(34) $ / 4.79000E+00, 1.31100E+02, 7.89600E+01/ data ak(0,34), ak(1,34), ak(2,34), ak(3,34) $ / 1.30756E+01, 1.83235E-01, -6.94264E-01, 5.02280E-02/ data al(0,34), al(1,34), al(2,34), al(3,34) $ / 1.47048E+01, -2.38853E+00, -1.05877E-01, 0.00000E+00/ data am(0,34), am(1,34), am(2,34), am(3,34) $ / 1.26773E+01, -2.39750E+00, 0.00000E+00, 0.00000E+00/ data an(0,34), an(1,34), an(2,34), an(3,34) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,34), coh(1,34), coh(2,34), coh(3,34) $ / 6.45637E+00, 2.86737E-01, -3.58794E-01, 1.85618E-02/ data cih(0,34), cih(1,34), cih(2,34), cih(3,34) $ /-4.32927E-01, 1.72833E+00, -2.77138E-01, 1.11735E-02/ c data for element #35, Bromine, (Br) data name(35), ek(35), el(35), em(35) $ /'br', 1.34740E+01, 1.78200E+00, 2.57000E-01/ data l2(35), l3(35), lj3(35) $ / 1.59600E+00, 1.55000E+00, 4.55700E+00/ data ka(35), kb(35), la(35), lb(35) $ / 1.19230E+01, 1.32900E+01, 1.48000E+00, 1.52600E+00/ data den(35), cf(35), atwt(35) $ / 3.12000E+00, 1.32700E+02, 7.99200E+01/ data ak(0,35), ak(1,35), ak(2,35), ak(3,35) $ / 1.32273E+01, 1.37130E-01, -6.83203E-01, 4.95424E-02/ data al(0,35), al(1,35), al(2,35), al(3,35) $ / 1.48136E+01, -2.42347E+00, -9.14590E-02, 0.00000E+00/ data am(0,35), am(1,35), am(2,35), am(3,35) $ / 1.27612E+01, -2.37730E+00, 0.00000E+00, 0.00000E+00/ data an(0,35), an(1,35), an(2,35), an(3,35) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,35), coh(1,35), coh(2,35), coh(3,35) $ / 6.51444E+00, 2.86324E-01, -3.57027E-01, 1.83557E-02/ data cih(0,35), cih(1,35), cih(2,35), cih(3,35) $ /-4.48001E-01, 1.76082E+00, -2.85099E-01, 1.17865E-02/ c data for element #36, Krypton, (Kr) data name(36), ek(36), el(36), em(36) $ /'kr', 1.43220E+01, 1.92000E+00, 2.88000E-01/ data l2(36), l3(36), lj3(36) $ / 1.72600E+00, 1.67500E+00, 4.17000E+00/ data ka(36), kb(36), la(36), lb(36) $ / 1.26480E+01, 1.41120E+01, 1.58700E+00, 1.63800E+00/ data den(36), cf(36), atwt(36) $ / 3.74000E-03, 1.39100E+02, 8.38000E+01/ data ak(0,36), ak(1,36), ak(2,36), ak(3,36) $ / 1.35927E+01, -3.05214E-02, -6.51340E-01, 4.77616E-02/ data al(0,36), al(1,36), al(2,36), al(3,36) $ / 1.49190E+01, -2.42418E+00, -8.76447E-02, 0.00000E+00/ data am(0,36), am(1,36), am(2,36), am(3,36) $ / 1.28898E+01, -2.26021E+00, 0.00000E+00, 0.00000E+00/ data an(0,36), an(1,36), an(2,36), an(3,36) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,36), coh(1,36), coh(2,36), coh(3,36) $ / 6.57113E+00, 2.87711E-01, -3.56311E-01, 1.82470E-02/ data cih(0,36), cih(1,36), cih(2,36), cih(3,36) $ /-3.91810E-01, 1.73010E+00, -2.76824E-01, 1.11280E-02/ c data for element #37, Rubidium, (Rb) data name(37), ek(37), el(37), em(37) $ /'rb', 1.52000E+01, 2.06500E+00, 3.22000E-01/ data l2(37), l3(37), lj3(37) $ / 1.86300E+00, 1.80500E+00, 4.22300E+00/ data ka(37), kb(37), la(37), lb(37) $ / 1.33940E+01, 1.49600E+01, 1.69400E+00, 1.75200E+00/ data den(37), cf(37), atwt(37) $ / 1.53200E+00, 1.41900E+02, 8.54800E+01/ data ak(0,37), ak(1,37), ak(2,37), ak(3,37) $ / 1.30204E+01, 3.82736E-01, -7.32427E-01, 5.29874E-02/ data al(0,37), al(1,37), al(2,37), al(3,37) $ / 1.49985E+01, -2.39108E+00, -9.59473E-02, 0.00000E+00/ data am(0,37), am(1,37), am(2,37), am(3,37) $ / 1.30286E+01, -2.38693E+00, 0.00000E+00, 0.00000E+00/ data an(0,37), an(1,37), an(2,37), an(3,37) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,37), coh(1,37), coh(2,37), coh(3,37) $ / 6.59750E+00, 3.02389E-01, -3.56755E-01, 1.81706E-02/ data cih(0,37), cih(1,37), cih(2,37), cih(3,37) $ /-1.28039E-01, 1.53044E+00, -2.27403E-01, 7.39033E-03/ c data for element #38, Strontium, (Sr) data name(38), ek(38), el(38), em(38) $ /'sr', 1.61050E+01, 2.21600E+00, 3.58000E-01/ data l2(38), l3(38), lj3(38) $ / 2.00700E+00, 1.94000E+00, 3.90600E+00/ data ka(38), kb(38), la(38), lb(38) $ / 1.41640E+01, 1.58340E+01, 1.80600E+00, 1.87200E+00/ data den(38), cf(38), atwt(38) $ / 2.54000E+00, 1.45500E+02, 8.76200E+01/ data ak(0,38), ak(1,38), ak(2,38), ak(3,38) $ / 1.35888E+01, 2.20194E-03, -6.38940E-01, 4.60070E-02/ data al(0,38), al(1,38), al(2,38), al(3,38) $ / 1.50114E+01, -2.28169E+00, -1.26485E-01, 0.00000E+00/ data am(0,38), am(1,38), am(2,38), am(3,38) $ / 1.31565E+01, -2.36655E+00, 0.00000E+00, 0.00000E+00/ data an(0,38), an(1,38), an(2,38), an(3,38) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,38), coh(1,38), coh(2,38), coh(3,38) $ / 6.62203E+00, 3.24559E-01, -3.61651E-01, 1.84800E-02/ data cih(0,38), cih(1,38), cih(2,38), cih(3,38) $ / 7.99161E-02, 1.38397E+00, -1.92225E-01, 4.78611E-03/ c data for element #39, Yttrium, (Y) data name(39), ek(39), el(39), em(39) $ /'y ', 1.70384E+01, 2.37300E+00, 3.95000E-01/ data l2(39), l3(39), lj3(39) $ / 2.15600E+00, 2.08000E+00, 4.03600E+00/ data ka(39), kb(39), la(39), lb(39) $ / 1.49570E+01, 1.67360E+01, 1.92200E+00, 1.99600E+00/ data den(39), cf(39), atwt(39) $ / 4.40500E+00, 1.47600E+02, 8.89050E+01/ data ak(0,39), ak(1,39), ak(2,39), ak(3,39) $ / 1.34674E+01, 1.91023E-01, -6.86616E-01, 4.97356E-02/ data al(0,39), al(1,39), al(2,39), al(3,39) $ / 1.51822E+01, -2.38946E+00, -8.81174E-02, 0.00000E+00/ data am(0,39), am(1,39), am(2,39), am(3,39) $ / 1.32775E+01, -2.43174E+00, 0.00000E+00, 0.00000E+00/ data an(0,39), an(1,39), an(2,39), an(3,39) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,39), coh(1,39), coh(2,39), coh(3,39) $ / 6.67096E+00, 3.25070E-01, -3.60613E-01, 1.83326E-02/ data cih(0,39), cih(1,39), cih(2,39), cih(3,39) $ / 6.29057E-02, 1.41577E+00, -1.99713E-01, 5.33312E-03/ c data for element #40, Zirconium, (Zr) data name(40), ek(40), el(40), em(40) $ /'zr', 1.79980E+01, 2.53200E+00, 4.31000E-01/ data l2(40), l3(40), lj3(40) $ / 2.30700E+00, 2.22300E+00, 3.97600E+00/ data ka(40), kb(40), la(40), lb(40) $ / 1.57740E+01, 1.76660E+01, 2.04200E+00, 2.12400E+00/ data den(40), cf(40), atwt(40) $ / 6.53000E+00, 1.51500E+02, 9.12200E+01/ data ak(0,40), ak(1,40), ak(2,40), ak(3,40) $ / 1.27538E+01, 6.97409E-01, -7.89307E-01, 5.64531E-02/ data al(0,40), al(1,40), al(2,40), al(3,40) $ / 1.52906E+01, -2.38703E+00, -9.12292E-02, 0.00000E+00/ data am(0,40), am(1,40), am(2,40), am(3,40) $ / 1.34508E+01, -2.50201E+00, 0.00000E+00, 0.00000E+00/ data an(0,40), an(1,40), an(2,40), an(3,40) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,40), coh(1,40), coh(2,40), coh(3,40) $ / 6.72275E+00, 3.23964E-01, -3.59463E-01, 1.81890E-02/ data cih(0,40), cih(1,40), cih(2,40), cih(3,40) $ / 3.66697E-02, 1.45207E+00, -2.08122E-01, 5.95139E-03/ c data for element #41, Nobium, (Nb) data name(41), ek(41), el(41), em(41) $ /'nb', 1.89860E+01, 2.69800E+00, 4.68000E-01/ data l2(41), l3(41), lj3(41) $ / 2.46500E+00, 2.37100E+00, 3.77400E+00/ data ka(41), kb(41), la(41), lb(41) $ / 1.66140E+01, 1.86210E+01, 2.16600E+00, 2.25700E+00/ data den(41), cf(41), atwt(41) $ / 8.57000E+00, 1.54300E+02, 9.29060E+01/ data ak(0,41), ak(1,41), ak(2,41), ak(3,41) $ / 1.33843E+01, 2.81028E-01, -6.86607E-01, 4.86607E-02/ data al(0,41), al(1,41), al(2,41), al(3,41) $ / 1.52088E+01, -2.20278E+00, -1.36759E-01, 0.00000E+00/ data am(0,41), am(1,41), am(2,41), am(3,41) $ / 1.35434E+01, -2.50135E+00, 0.00000E+00, 0.00000E+00/ data an(0,41), an(1,41), an(2,41), an(3,41) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,41), coh(1,41), coh(2,41), coh(3,41) $ / 6.79013E+00, 3.11282E-01, -3.55233E-01, 1.78231E-02/ data cih(0,41), cih(1,41), cih(2,41), cih(3,41) $ / 2.02289E-04, 1.49347E+00, -2.17419E-01, 6.62245E-03/ c data for element #42, Molybdenum, (Mo) data name(42), ek(42), el(42), em(42) $ /'mo', 1.99990E+01, 2.86600E+00, 5.05000E-01/ data l2(42), l3(42), lj3(42) $ / 2.62500E+00, 2.52000E+00, 3.67500E+00/ data ka(42), kb(42), la(42), lb(42) $ / 1.74780E+01, 1.96070E+01, 2.29300E+00, 2.39500E+00/ data den(42), cf(42), atwt(42) $ / 1.02200E+01, 1.59300E+02, 9.59500E+01/ data ak(0,42), ak(1,42), ak(2,42), ak(3,42) $ / 1.39853E+01, -1.17426E-01, -5.91094E-01, 4.17843E-02/ data al(0,42), al(1,42), al(2,42), al(3,42) $ / 1.53494E+01, -2.26640E+00, -1.16881E-01, 0.00000E+00/ data am(0,42), am(1,42), am(2,42), am(3,42) $ / 1.36568E+01, -2.48480E+00, 0.00000E+00, 0.00000E+00/ data an(0,42), an(1,42), an(2,42), an(3,42) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,42), coh(1,42), coh(2,42), coh(3,42) $ / 6.84600E+00, 3.02790E-01, -3.51131E-01, 1.74403E-02/ data cih(0,42), cih(1,42), cih(2,42), cih(3,42) $ /-5.62860E-02, 1.55778E+00, -2.33341E-01, 7.85506E-03/ c data for element #43, Technetium, (Tc) data name(43), ek(43), el(43), em(43) $ /'tc', 2.10450E+01, 3.04300E+00, 5.44000E-01/ data l2(43), l3(43), lj3(43) $ / 2.79300E+00, 2.67700E+00, 3.59100E+00/ data ka(43), kb(43), la(43), lb(43) $ / 1.84100E+01, 2.05850E+01, 2.42400E+00, 2.53800E+00/ data den(43), cf(43), atwt(43) $ / 1.15000E+01, 1.64400E+02, 9.90000E+01/ data ak(0,43), ak(1,43), ak(2,43), ak(3,43) $ / 1.28214E+01, 7.51993E-01, -7.87006E-01, 5.58668E-02/ data al(0,43), al(1,43), al(2,43), al(3,43) $ / 1.55086E+01, -2.33733E+00, -9.87857E-02, 0.00000E+00/ data am(0,43), am(1,43), am(2,43), am(3,43) $ / 1.37498E+01, -2.44730E+00, 0.00000E+00, 0.00000E+00/ data an(0,43), an(1,43), an(2,43), an(3,43) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,43), coh(1,43), coh(2,43), coh(3,43) $ / 6.87599E+00, 3.26165E-01, -3.58969E-01, 1.80482E-02/ data cih(0,43), cih(1,43), cih(2,43), cih(3,43) $ / 7.57616E-02, 1.44950E+00, -2.04890E-01, 5.64745E-03/ c data for element #44, Ruthenium, (Ru) data name(44), ek(44), el(44), em(44) $ /'ru', 2.21170E+01, 3.22400E+00, 5.85000E-01/ data l2(44), l3(44), lj3(44) $ / 2.96700E+00, 2.83800E+00, 3.43100E+00/ data ka(44), kb(44), la(44), lb(44) $ / 1.92780E+01, 2.16550E+01, 2.55800E+00, 2.68300E+00/ data den(44), cf(44), atwt(44) $ / 1.24100E+01, 1.67800E+02, 1.01070E+02/ data ak(0,44), ak(1,44), ak(2,44), ak(3,44) $ / 1.26658E+01, 8.85020E-01, -8.11144E-01, 5.73759E-02/ data al(0,44), al(1,44), al(2,44), al(3,44) $ / 1.54734E+01, -2.23080E+00, -1.19454E-01, 0.00000E+00/ data am(0,44), am(1,44), am(2,44), am(3,44) $ / 1.38782E+01, -2.48066E+00, 0.00000E+00, 0.00000E+00/ data an(0,44), an(1,44), an(2,44), an(3,44) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,44), coh(1,44), coh(2,44), coh(3,44) $ / 6.93136E+00, 3.34794E-01, -3.63497E-01, 1.84429E-02/ data cih(0,44), cih(1,44), cih(2,44), cih(3,44) $ /-4.24981E-02, 1.54639E+00, -2.26470E-01, 7.18375E-03/ c data for element #45, Rhodium, (Rh) data name(45), ek(45), el(45), em(45) $ /'rh', 2.32200E+01, 3.41200E+00, 6.27000E-01/ data l2(45), l3(45), lj3(45) $ / 3.14600E+00, 3.00300E+00, 3.72100E+00/ data ka(45), kb(45), la(45), lb(45) $ / 2.02140E+01, 2.27210E+01, 2.69600E+00, 2.83400E+00/ data den(45), cf(45), atwt(45) $ / 1.24400E+01, 1.70900E+02, 1.02910E+02/ data ak(0,45), ak(1,45), ak(2,45), ak(3,45) $ / 1.21760E+01, 1.19682E+00, -8.66697E-01, 6.06931E-02/ data al(0,45), al(1,45), al(2,45), al(3,45) $ / 1.55757E+01, -2.24976E+00, -1.13377E-01, 0.00000E+00/ data am(0,45), am(1,45), am(2,45), am(3,45) $ / 1.40312E+01, -2.61303E+00, 0.00000E+00, 0.00000E+00/ data an(0,45), an(1,45), an(2,45), an(3,45) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,45), coh(1,45), coh(2,45), coh(3,45) $ / 6.97547E+00, 3.46394E-01, -3.67794E-01, 1.87885E-02/ data cih(0,45), cih(1,45), cih(2,45), cih(3,45) $ /-1.60399E-01, 1.64861E+00, -2.50238E-01, 8.93818E-03/ c data for element #46, Paladium, (Pd) data name(46), ek(46), el(46), em(46) $ /'pd', 2.43500E+01, 3.60500E+00, 6.70000E-01/ data l2(46), l3(46), lj3(46) $ / 3.33000E+00, 3.17300E+00, 3.40200E+00/ data ka(46), kb(46), la(46), lb(46) $ / 2.11750E+01, 2.38160E+01, 2.83800E+00, 2.99000E+00/ data den(46), cf(46), atwt(46) $ / 1.21600E+01, 1.76700E+02, 1.06400E+02/ data ak(0,46), ak(1,46), ak(2,46), ak(3,46) $ / 1.39389E+01, 1.64528E-01, -6.62117E-01, 4.76289E-02/ data al(0,46), al(1,46), al(2,46), al(3,46) $ / 1.55649E+01, -2.17229E+00, -1.27652E-01, 0.00000E+00/ data am(0,46), am(1,46), am(2,46), am(3,46) $ / 1.41392E+01, -2.57206E+00, 0.00000E+00, 0.00000E+00/ data an(0,46), an(1,46), an(2,46), an(3,46) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,46), coh(1,46), coh(2,46), coh(3,46) $ / 7.03216E+00, 3.49838E-01, -3.70099E-01, 1.89983E-02/ data cih(0,46), cih(1,46), cih(2,46), cih(3,46) $ /-2.67564E-01, 1.73740E+00, -2.69883E-01, 1.03248E-02/ c data for element #47, Silver, (Ag) data name(47), ek(47), el(47), em(47) $ /'ag', 2.55140E+01, 3.80600E+00, 7.17000E-01/ data l2(47), l3(47), lj3(47) $ / 3.52400E+00, 3.35100E+00, 3.22300E+00/ data ka(47), kb(47), la(47), lb(47) $ / 2.21620E+01, 2.49420E+01, 2.98400E+00, 3.15100E+00/ data den(47), cf(47), atwt(47) $ / 1.05000E+01, 1.79100E+02, 1.07880E+02/ data ak(0,47), ak(1,47), ak(2,47), ak(3,47) $ / 1.33926E+01, 4.41380E-01, -6.93711E-01, 4.82085E-02/ data al(0,47), al(1,47), al(2,47), al(3,47) $ / 1.56869E+01, -2.22636E+00, -1.12223E-01, 0.00000E+00/ data am(0,47), am(1,47), am(2,47), am(3,47) $ / 1.41673E+01, -2.48078E+00, 0.00000E+00, 0.00000E+00/ data an(0,47), an(1,47), an(2,47), an(3,47) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,47), coh(1,47), coh(2,47), coh(3,47) $ / 7.06446E+00, 3.63456E-01, -3.73597E-01, 1.92478E-02/ data cih(0,47), cih(1,47), cih(2,47), cih(3,47) $ /-1.66475E-01, 1.65794E+00, -2.48740E-01, 8.66218E-03/ c data for element #48, Cadmium, (Cd) data name(48), ek(48), el(48), em(48) $ /'cd', 2.67110E+01, 4.01800E+00, 7.70000E-01/ data l2(48), l3(48), lj3(48) $ / 3.72700E+00, 3.53700E+00, 3.24900E+00/ data ka(48), kb(48), la(48), lb(48) $ / 2.31720E+01, 2.60930E+01, 3.13300E+00, 3.31600E+00/ data den(48), cf(48), atwt(48) $ / 8.65000E+00, 1.86600E+02, 1.12410E+02/ data ak(0,48), ak(1,48), ak(2,48), ak(3,48) $ / 1.25254E+01, 1.07714E+00, -8.31424E-01, 5.79120E-02/ data al(0,48), al(1,48), al(2,48), al(3,48) $ / 1.59668E+01, -2.38363E+00, -8.01104E-02, 0.00000E+00/ data am(0,48), am(1,48), am(2,48), am(3,48) $ / 1.43497E+01, -2.52756E+00, 0.00000E+00, 0.00000E+00/ data an(0,48), an(1,48), an(2,48), an(3,48) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,48), coh(1,48), coh(2,48), coh(3,48) $ / 7.09856E+00, 3.72199E-01, -3.75345E-01, 1.93481E-02/ data cih(0,48), cih(1,48), cih(2,48), cih(3,48) $ /-5.16701E-02, 1.57426E+00, -2.27646E-01, 7.05650E-03/ c data for element #49, Indium, (In) data name(49), ek(49), el(49), em(49) $ /'in', 2.79400E+01, 4.23800E+00, 8.25000E-01/ data l2(49), l3(49), lj3(49) $ / 3.93800E+00, 3.73000E+00, 3.25500E+00/ data ka(49), kb(49), la(49), lb(49) $ / 2.42070E+01, 2.72740E+01, 3.28700E+00, 3.48700E+00/ data den(49), cf(49), atwt(49) $ / 7.28000E+00, 1.90700E+02, 1.14820E+02/ data ak(0,49), ak(1,49), ak(2,49), ak(3,49) $ / 1.18198E+01, 1.45768E+00, -8.88529E-01, 6.05982E-02/ data al(0,49), al(1,49), al(2,49), al(3,49) $ / 1.62101E+01, -2.51838E+00, -5.40061E-02, 0.00000E+00/ data am(0,49), am(1,49), am(2,49), am(3,49) $ / 1.44115E+01, -2.49401E+00, 0.00000E+00, 0.00000E+00/ data an(0,49), an(1,49), an(2,49), an(3,49) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,49), coh(1,49), coh(2,49), coh(3,49) $ / 7.12708E+00, 3.82082E-01, -3.76855E-01, 1.94151E-02/ data cih(0,49), cih(1,49), cih(2,49), cih(3,49) $ /-8.17283E-03, 1.55865E+00, -2.24492E-01, 6.85776E-03/ c data for element #50, Tin, (Sn) data name(50), ek(50), el(50), em(50) $ /'sn', 2.92000E+01, 4.46500E+00, 8.84000E-01/ data l2(50), l3(50), lj3(50) $ / 4.15600E+00, 3.92900E+00, 3.06000E+00/ data ka(50), kb(50), la(50), lb(50) $ / 2.52700E+01, 2.84830E+01, 3.44400E+00, 3.66200E+00/ data den(50), cf(50), atwt(50) $ / 5.76000E+00, 1.97100E+02, 1.18690E+02/ data ak(0,50), ak(1,50), ak(2,50), ak(3,50) $ / 1.30323E+01, 7.90788E-01, -7.62349E-01, 5.27872E-02/ data al(0,50), al(1,50), al(2,50), al(3,50) $ / 1.58638E+01, -2.19019E+00, -1.13539E-01, 0.00000E+00/ data am(0,50), am(1,50), am(2,50), am(3,50) $ / 1.45572E+01, -2.56792E+00, 0.00000E+00, 0.00000E+00/ data an(0,50), an(1,50), an(2,50), an(3,50) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,50), coh(1,50), coh(2,50), coh(3,50) $ / 7.16085E+00, 3.85512E-01, -3.76481E-01, 1.93305E-02/ data cih(0,50), cih(1,50), cih(2,50), cih(3,50) $ / 1.42151E-02, 1.55754E+00, -2.24736E-01, 6.91395E-03/ c data for element #51, Antimony, (Sb) data name(51), ek(51), el(51), em(51) $ /'sb', 3.04910E+01, 4.69800E+00, 9.44000E-01/ data l2(51), l3(51), lj3(51) $ / 4.38100E+00, 4.13200E+00, 2.93900E+00/ data ka(51), kb(51), la(51), lb(51) $ / 2.63570E+01, 2.97230E+01, 3.60500E+00, 3.84300E+00/ data den(51), cf(51), atwt(51) $ / 6.69100E+00, 2.02200E+02, 1.21760E+02/ data ak(0,51), ak(1,51), ak(2,51), ak(3,51) $ / 9.06990E+00, 3.28791E+00, -1.26203E+00, 8.53470E-02/ data al(0,51), al(1,51), al(2,51), al(3,51) $ / 1.57557E+01, -2.04460E+00, -1.40745E-01, 0.00000E+00/ data am(0,51), am(1,51), am(2,51), am(3,51) $ / 1.46268E+01, -2.55562E+00, 0.00000E+00, 0.00000E+00/ data an(0,51), an(1,51), an(2,51), an(3,51) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,51), coh(1,51), coh(2,51), coh(3,51) $ / 7.19665E+00, 3.85543E-01, -3.75054E-01, 1.91608E-02/ data cih(0,51), cih(1,51), cih(2,51), cih(3,51) $ / 1.56362E-02, 1.57175E+00, -2.28753E-01, 7.26386E-03/ c data for element #52, Tellurium, (Te) data name(52), ek(52), el(52), em(52) $ /'te', 3.18130E+01, 4.93900E+00, 1.00600E+00/ data l2(52), l3(52), lj3(52) $ / 4.61200E+00, 4.34100E+00, 2.97900E+00/ data ka(52), kb(52), la(52), lb(52) $ / 2.74710E+01, 3.09930E+01, 3.76900E+00, 4.02900E+00/ data den(52), cf(52), atwt(52) $ / 6.24000E+00, 2.11900E+02, 1.27600E+02/ data ak(0,52), ak(1,52), ak(2,52), ak(3,52) $ / 1.16656E+01, 1.71052E+00, -9.48281E-01, 6.53213E-02/ data al(0,52), al(1,52), al(2,52), al(3,52) $ / 1.61087E+01, -2.27876E+00, -9.29405E-02, 0.00000E+00/ data am(0,52), am(1,52), am(2,52), am(3,52) $ / 1.47125E+01, -2.54324E+00, 0.00000E+00, 0.00000E+00/ data an(0,52), an(1,52), an(2,52), an(3,52) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,52), coh(1,52), coh(2,52), coh(3,52) $ / 7.23460E+00, 3.82493E-01, -3.72715E-01, 1.89194E-02/ data cih(0,52), cih(1,52), cih(2,52), cih(3,52) $ /-4.07579E-02, 1.64267E+00, -2.47890E-01, 8.80567E-03/ c data for element #53, Iodine, (I) data name(53), ek(53), el(53), em(53) $ /'i ', 3.31690E+01, 5.18800E+00, 1.07200E+00/ data l2(53), l3(53), lj3(53) $ / 4.85200E+00, 4.55700E+00, 2.85600E+00/ data ka(53), kb(53), la(53), lb(53) $ / 2.86100E+01, 3.22920E+01, 3.93700E+00, 4.22000E+00/ data den(53), cf(53), atwt(53) $ / 4.94000E+00, 2.10700E+02, 1.26910E+02/ data ak(0,53), ak(1,53), ak(2,53), ak(3,53) $ / 1.21075E+01, 1.43635E+00, -8.82038E-01, 6.03575E-02/ data al(0,53), al(1,53), al(2,53), al(3,53) $ / 1.64086E+01, -2.48214E+00, -5.07179E-02, 0.00000E+00/ data am(0,53), am(1,53), am(2,53), am(3,53) $ / 1.47496E+01, -2.48179E+00, 0.00000E+00, 0.00000E+00/ data an(0,53), an(1,53), an(2,53), an(3,53) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,53), coh(1,53), coh(2,53), coh(3,53) $ / 7.27415E+00, 3.77223E-01, -3.69728E-01, 1.86280E-02/ data cih(0,53), cih(1,53), cih(2,53), cih(3,53) $ /-4.04420E-02, 1.65596E+00, -2.51067E-01, 9.04874E-03/ c data for element #54, Xenon, (Xe) data name(54), ek(54), el(54), em(54) $ /'xe', 3.45820E+01, 5.45200E+00, 1.14300E+00/ data l2(54), l3(54), lj3(54) $ / 5.10000E+00, 4.78100E+00, 2.87900E+00/ data ka(54), kb(54), la(54), lb(54) $ / 2.98020E+01, 3.36440E+01, 4.11100E+00, 4.42200E+00/ data den(54), cf(54), atwt(54) $ / 5.90000E-03, 2.18000E+02, 1.31300E+02/ data ak(0,54), ak(1,54), ak(2,54), ak(3,54) $ / 1.10857E+01, 2.08357E+00, -1.01209E+00, 6.90310E-02/ data al(0,54), al(1,54), al(2,54), al(3,54) $ / 1.63098E+01, -2.31679E+00, -8.54498E-02, 0.00000E+00/ data am(0,54), am(1,54), am(2,54), am(3,54) $ / 1.47603E+01, -2.45068E+00, 0.00000E+00, 0.00000E+00/ data an(0,54), an(1,54), an(2,54), an(3,54) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,54), coh(1,54), coh(2,54), coh(3,54) $ / 7.31469E+00, 3.70315E-01, -3.66280E-01, 1.83025E-02/ data cih(0,54), cih(1,54), cih(2,54), cih(3,54) $ /-2.82407E-03, 1.64039E+00, -2.47642E-01, 8.82144E-03/ c data for element #55, Cesium, (Cs) data name(55), ek(55), el(55), em(55) $ /'cs', 3.59850E+01, 5.71300E+00, 1.21800E+00/ data l2(55), l3(55), lj3(55) $ / 5.35900E+00, 5.01200E+00, 2.84700E+00/ data ka(55), kb(55), la(55), lb(55) $ / 3.09700E+01, 3.49840E+01, 4.28600E+00, 4.62000E+00/ data den(55), cf(55), atwt(55) $ / 1.87300E+00, 2.20700E+02, 1.32910E+02/ data ak(0,55), ak(1,55), ak(2,55), ak(3,55) $ / 1.13750E+01, 1.94161E+00, -9.83232E-01, 6.71986E-02/ data al(0,55), al(1,55), al(2,55), al(3,55) $ / 1.65418E+01, -2.46363E+00, -5.42849E-02, 0.00000E+00/ data am(0,55), am(1,55), am(2,55), am(3,55) $ / 1.49713E+01, -2.53145E+00, 0.00000E+00, 0.00000E+00/ data an(0,55), an(1,55), an(2,55), an(3,55) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,55), coh(1,55), coh(2,55), coh(3,55) $ / 7.33490E+00, 3.76825E-01, -3.65713E-01, 1.81843E-02/ data cih(0,55), cih(1,55), cih(2,55), cih(3,55) $ / 1.84861E-01, 1.50030E+00, -2.13333E-01, 6.24264E-03/ c data for element #56, Barium, (Ba) data name(56), ek(56), el(56), em(56) $ /'ba', 3.74410E+01, 5.98700E+00, 1.29300E+00/ data l2(56), l3(56), lj3(56) $ / 5.62400E+00, 5.24700E+00, 2.83900E+00/ data ka(56), kb(56), la(56), lb(56) $ / 3.21910E+01, 3.63760E+01, 4.46700E+00, 4.82800E+00/ data den(56), cf(56), atwt(56) $ / 3.50000E+00, 2.28100E+02, 1.37360E+02/ data ak(0,56), ak(1,56), ak(2,56), ak(3,56) $ / 1.02250E+01, 2.67835E+00, -1.12648E+00, 7.62669E-02/ data al(0,56), al(1,56), al(2,56), al(3,56) $ / 1.66217E+01, -2.48972E+00, -4.49623E-02, 0.00000E+00/ data am(0,56), am(1,56), am(2,56), am(3,56) $ / 1.50844E+01, -2.56341E+00, 0.00000E+00, 0.00000E+00/ data an(0,56), an(1,56), an(2,56), an(3,56) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,56), coh(1,56), coh(2,56), coh(3,56) $ / 7.35812E+00, 3.79361E-01, -3.64099E-01, 1.79817E-02/ data cih(0,56), cih(1,56), cih(2,56), cih(3,56) $ / 3.44376E-01, 1.38742E+00, -1.86356E-01, 4.24917E-03/ c data for element #57, Lanthanum, (La) data name(57), ek(57), el(57), em(57) $ /'la', 3.89250E+01, 6.26700E+00, 1.36300E+00/ data l2(57), l3(57), lj3(57) $ / 5.89100E+00, 5.48300E+00, 2.71700E+00/ data ka(57), kb(57), la(57), lb(57) $ / 3.34400E+01, 3.77990E+01, 4.65100E+00, 5.04300E+00/ data den(57), cf(57), atwt(57) $ / 6.15000E+00, 2.30700E+02, 1.38920E+02/ data ak(0,57), ak(1,57), ak(2,57), ak(3,57) $ / 1.09780E+01, 2.23814E+00, -1.03549E+00, 7.02339E-02/ data al(0,57), al(1,57), al(2,57), al(3,57) $ / 1.63134E+01, -2.20156E+00, -9.80569E-02, 0.00000E+00/ data am(0,57), am(1,57), am(2,57), am(3,57) $ / 1.51863E+01, -2.58287E+00, 0.00000E+00, 0.00000E+00/ data an(0,57), an(1,57), an(2,57), an(3,57) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,57), coh(1,57), coh(2,57), coh(3,57) $ / 7.39532E+00, 3.69895E-01, -3.59376E-01, 1.75406E-02/ data cih(0,57), cih(1,57), cih(2,57), cih(3,57) $ / 4.09104E-01, 1.33075E+00, -1.70883E-01, 3.04111E-03/ c data for element #58, Cerium, (Ce) data name(58), ek(58), el(58), em(58) $ /'ce', 4.04440E+01, 6.54900E+00, 1.43400E+00/ data l2(58), l3(58), lj3(58) $ / 6.16500E+00, 5.72400E+00, 2.73700E+00/ data ka(58), kb(58), la(58), lb(58) $ / 3.47170E+01, 3.92550E+01, 4.84000E+00, 5.26200E+00/ data den(58), cf(58), atwt(58) $ / 6.67000E+00, 2.32700E+02, 1.40130E+02/ data ak(0,58), ak(1,58), ak(2,58), ak(3,58) $ / 1.02725E+01, 2.74562E+00, -1.14174E+00, 7.74162E-02/ data al(0,58), al(1,58), al(2,58), al(3,58) $ / 1.65862E+01, -2.36288E+00, -6.54708E-02, 0.00000E+00/ data am(0,58), am(1,58), am(2,58), am(3,58) $ / 1.52693E+01, -2.58174E+00, 0.00000E+00, 0.00000E+00/ data an(0,58), an(1,58), an(2,58), an(3,58) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,58), coh(1,58), coh(2,58), coh(3,58) $ / 7.44255E+00, 3.71328E-01, -3.59642E-01, 1.75852E-02/ data cih(0,58), cih(1,58), cih(2,58), cih(3,58) $ / 4.39881E-01, 1.30925E+00, -1.64548E-01, 2.52641E-03/ c data for element #59, Praesodium, (Pr) data name(59), ek(59), el(59), em(59) $ /'pr', 4.19910E+01, 6.83500E+00, 1.50800E+00/ data l2(59), l3(59), lj3(59) $ / 6.44100E+00, 5.96500E+00, 2.69500E+00/ data ka(59), kb(59), la(59), lb(59) $ / 3.60230E+01, 4.07460E+01, 5.03400E+00, 5.48900E+00/ data den(59), cf(59), atwt(59) $ / 6.76900E+00, 2.34000E+02, 1.40920E+02/ data ak(0,59), ak(1,59), ak(2,59), ak(3,59) $ / 1.10156E+01, 2.22056E+00, -1.02216E+00, 6.90465E-02/ data al(0,59), al(1,59), al(2,59), al(3,59) $ / 1.67118E+01, -2.40326E+00, -6.12619E-02, 0.00000E+00/ data am(0,59), am(1,59), am(2,59), am(3,59) $ / 1.53379E+01, -2.57086E+00, 0.00000E+00, 0.00000E+00/ data an(0,59), an(1,59), an(2,59), an(3,59) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,59), coh(1,59), coh(2,59), coh(3,59) $ / 7.48347E+00, 3.68431E-01, -3.57689E-01, 1.74099E-02/ data cih(0,59), cih(1,59), cih(2,59), cih(3,59) $ / 4.49124E-01, 1.30351E+00, -1.61841E-01, 2.27394E-03/ c data for element #60, Neodymium, (Nd) data name(60), ek(60), el(60), em(60) $ /'nd', 4.35690E+01, 7.12600E+00, 1.57500E+00/ data l2(60), l3(60), lj3(60) $ / 6.72200E+00, 6.20800E+00, 2.66200E+00/ data ka(60), kb(60), la(60), lb(60) $ / 3.73590E+01, 4.22690E+01, 5.23000E+00, 5.72100E+00/ data den(60), cf(60), atwt(60) $ / 6.96000E+00, 2.39600E+02, 1.44270E+02/ data ak(0,60), ak(1,60), ak(2,60), ak(3,60) $ / 1.17632E+01, 1.79481E+00, -9.36661E-01, 6.35332E-02/ data al(0,60), al(1,60), al(2,60), al(3,60) $ / 1.65964E+01, -2.26007E+00, -8.72426E-02, 0.00000E+00/ data am(0,60), am(1,60), am(2,60), am(3,60) $ / 1.54335E+01, -2.59006E+00, 0.00000E+00, 0.00000E+00/ data an(0,60), an(1,60), an(2,60), an(3,60) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,60), coh(1,60), coh(2,60), coh(3,60) $ / 7.52334E+00, 3.66462E-01, -3.56048E-01, 1.72620E-02/ data cih(0,60), cih(1,60), cih(2,60), cih(3,60) $ / 4.37283E-01, 1.31370E+00, -1.62866E-01, 2.29377E-03/ c data for element #61, Promethium, (Pm) data name(61), ek(61), el(61), em(61) $ /'pm', 4.51840E+01, 7.42800E+00, 1.65100E+00/ data l2(61), l3(61), lj3(61) $ / 7.01300E+00, 6.46000E+00, 2.70200E+00/ data ka(61), kb(61), la(61), lb(61) $ / 3.86490E+01, 4.39450E+01, 5.43250E+00, 5.96100E+00/ data den(61), cf(61), atwt(61) $ / 6.78200E+00, 2.44100E+02, 1.47000E+02/ data ak(0,61), ak(1,61), ak(2,61), ak(3,61) $ / 1.13864E+01, 2.05593E+00, -9.88180E-01, 6.69106E-02/ data al(0,61), al(1,61), al(2,61), al(3,61) $ / 1.68337E+01, -2.38810E+00, -6.45041E-02, 0.00000E+00/ data am(0,61), am(1,61), am(2,61), am(3,61) $ / 1.55131E+01, -2.59623E+00, 0.00000E+00, 0.00000E+00/ data an(0,61), an(1,61), an(2,61), an(3,61) $ / 1.55131E+01, -2.59623E+00, 0.00000E+00, 0.00000E+00/ data coh(0,61), coh(1,61), coh(2,61), coh(3,61) $ / 7.56222E+00, 3.65055E-01, -3.54511E-01, 1.71214E-02/ data cih(0,61), cih(1,61), cih(2,61), cih(3,61) $ / 4.05823E-01, 1.33837E+00, -1.67229E-01, 2.55570E-03/ c data for element #62, Samarium, (Sm) data name(62), ek(62), el(62), em(62) $ /'sm', 4.68350E+01, 7.73700E+00, 1.72900E+00/ data l2(62), l3(62), lj3(62) $ / 7.31200E+00, 6.71700E+00, 2.68000E+00/ data ka(62), kb(62), la(62), lb(62) $ / 4.01240E+01, 4.54000E+01, 5.63610E+00, 6.20510E+00/ data den(62), cf(62), atwt(62) $ / 7.53600E+00, 2.49600E+02, 1.50350E+02/ data ak(0,62), ak(1,62), ak(2,62), ak(3,62) $ / 1.19223E+01, 1.79546E+00, -9.42902E-01, 6.44202E-02/ data al(0,62), al(1,62), al(2,62), al(3,62) $ / 1.68725E+01, -2.39051E+00, -6.01080E-02, 0.00000E+00/ data am(0,62), am(1,62), am(2,62), am(3,62) $ / 1.56000E+01, -2.61328E+00, 0.00000E+00, 0.00000E+00/ data an(0,62), an(1,62), an(2,62), an(3,62) $ / 1.56006E+01, -2.61328E+00, 0.00000E+00, 0.00000E+00/ data coh(0,62), coh(1,62), coh(2,62), coh(3,62) $ / 7.60020E+00, 3.64134E-01, -3.53086E-01, 1.69894E-02/ data cih(0,62), cih(1,62), cih(2,62), cih(3,62) $ / 3.55383E-01, 1.37733E+00, -1.74941E-01, 3.06213E-03/ c data for element #63, Europium, (Eu) data name(63), ek(63), el(63), em(63) $ /'eu', 4.85200E+01, 8.05200E+00, 1.80000E+00/ data l2(63), l3(63), lj3(63) $ / 7.61800E+00, 6.97700E+00, 2.72300E+00/ data ka(63), kb(63), la(63), lb(63) $ / 4.15290E+01, 4.70270E+01, 5.84570E+00, 6.45640E+00/ data den(63), cf(63), atwt(63) $ / 5.25900E+00, 2.52400E+02, 1.52000E+02/ data ak(0,63), ak(1,63), ak(2,63), ak(3,63) $ / 1.16168E+01, 1.97533E+00, -9.70901E-01, 6.58459E-02/ data al(0,63), al(1,63), al(2,63), al(3,63) $ / 1.70692E+01, -2.48046E+00, -4.47055E-02, 0.00000E+00/ data am(0,63), am(1,63), am(2,63), am(3,63) $ / 1.57063E+01, -2.63481E+00, 0.00000E+00, 0.00000E+00/ data an(0,63), an(1,63), an(2,63), an(3,63) $ / 1.57063E+01, -2.63481E+00, 0.00000E+00, 0.00000E+00/ data coh(0,63), coh(1,63), coh(2,63), coh(3,63) $ / 7.63711E+00, 3.63957E-01, -3.51900E-01, 1.68783E-02/ data cih(0,63), cih(1,63), cih(2,63), cih(3,63) $ / 2.80316E-01, 1.44016E+00, -1.88641E-01, 4.01226E-03/ c data for element #64, Gadolinium, (Gd) data name(64), ek(64), el(64), em(64) $ /'gd', 5.02400E+01, 8.37600E+00, 1.88200E+00/ data l2(64), l3(64), lj3(64) $ / 7.93100E+00, 7.24300E+00, 2.70100E+00/ data ka(64), kb(64), la(64), lb(64) $ / 4.29830E+01, 4.87180E+01, 6.05720E+00, 6.71320E+00/ data den(64), cf(64), atwt(64) $ / 7.95000E+00, 2.61100E+02, 1.57260E+02/ data ak(0,64), ak(1,64), ak(2,64), ak(3,64) $ / 9.91968E+00, 3.03111E+00, -1.17520E+00, 7.86750E-02/ data al(0,64), al(1,64), al(2,64), al(3,64) $ / 1.71159E+01, -2.47838E+00, -4.37107E-02, 0.00000E+00/ data am(0,64), am(1,64), am(2,64), am(3,64) $ / 1.57159E+01, -2.60843E+00, 0.00000E+00, 0.00000E+00/ data an(0,64), an(1,64), an(2,64), an(3,64) $ / 1.57159E+01, -2.60843E+00, 0.00000E+00, 0.00000E+00/ data coh(0,64), coh(1,64), coh(2,64), coh(3,64) $ / 7.66938E+00, 3.59752E-01, -3.48899E-01, 1.65890E-02/ data cih(0,64), cih(1,64), cih(2,64), cih(3,64) $ / 2.73133E-01, 1.43842E+00, -1.86137E-01, 3.75240E-03/ c data for element #65, Terbium, (Tb) data name(65), ek(65), el(65), em(65) $ /'tb', 5.19960E+01, 8.70800E+00, 1.96700E+00/ data l2(65), l3(65), lj3(65) $ / 8.25200E+00, 7.51500E+00, 2.71300E+00/ data ka(65), kb(65), la(65), lb(65) $ / 4.44700E+01, 5.03910E+01, 6.27280E+00, 6.97800E+00/ data den(65), cf(65), atwt(65) $ / 8.27200E+00, 2.63900E+02, 1.58930E+02/ data ak(0,65), ak(1,65), ak(2,65), ak(3,65) $ / 1.13818E+01, 2.14447E+00, -9.99222E-01, 6.75569E-02/ data al(0,65), al(1,65), al(2,65), al(3,65) $ / 1.71499E+01, -2.45507E+00, -4.71370E-02, 0.00000E+00/ data am(0,65), am(1,65), am(2,65), am(3,65) $ / 1.58412E+01, -2.64040E+00, 0.00000E+00, 0.00000E+00/ data an(0,65), an(1,65), an(2,65), an(3,65) $ / 1.58415E+01, -2.64040E+00, 0.00000E+00, 0.00000E+00/ data coh(0,65), coh(1,65), coh(2,65), coh(3,65) $ / 7.70798E+00, 3.65345E-01, -3.50031E-01, 1.66927E-02/ data cih(0,65), cih(1,65), cih(2,65), cih(3,65) $ / 2.57539E-01, 1.45064E+00, -1.87591E-01, 3.79932E-03/ c data for element #66, Dysprosium, (Dy) data name(66), ek(66), el(66), em(66) $ /'dy', 5.37890E+01, 9.04700E+00, 2.04600E+00/ data l2(66), l3(66), lj3(66) $ / 8.58100E+00, 7.79000E+00, 9.04700E+00/ data ka(66), kb(66), la(66), lb(66) $ / 4.59850E+01, 5.21780E+01, 6.49520E+00, 7.24770E+00/ data den(66), cf(66), atwt(66) $ / 8.53600E+00, 2.69800E+02, 1.62510E+02/ data ak(0,66), ak(1,66), ak(2,66), ak(3,66) $ / 1.14845E+01, 2.10451E+00, -9.89870E-01, 6.69382E-02/ data al(0,66), al(1,66), al(2,66), al(3,66) $ / 1.73446E+01, -2.54821E+00, -3.17606E-02, 0.00000E+00/ data am(0,66), am(1,66), am(2,66), am(3,66) $ / 1.59225E+01, -2.65289E+00, 0.00000E+00, 0.00000E+00/ data an(0,66), an(1,66), an(2,66), an(3,66) $ / 1.59225E+01, -2.65289E+00, 0.00000E+00, 0.00000E+00/ data coh(0,66), coh(1,66), coh(2,66), coh(3,66) $ / 7.74188E+00, 3.67107E-01, -3.49433E-01, 1.66273E-02/ data cih(0,66), cih(1,66), cih(2,66), cih(3,66) $ / 2.42685E-01, 1.46266E+00, -1.89102E-01, 3.85628E-03/ c data for element #67, Holmium, (Ho) data name(67), ek(67), el(67), em(67) $ /'ho', 5.56180E+01, 9.39500E+00, 2.12700E+00/ data l2(67), l3(67), lj3(67) $ / 8.91900E+00, 8.07100E+00, 2.86300E+00/ data ka(67), kb(67), la(67), lb(67) $ / 4.75280E+01, 5.39340E+01, 6.71980E+00, 7.52530E+00/ data den(67), cf(67), atwt(67) $ / 8.80300E+00, 2.73900E+02, 1.64940E+02/ data ak(0,67), ak(1,67), ak(2,67), ak(3,67) $ / 8.75203E+00, 3.71822E+00, -1.29273E+00, 8.55026E-02/ data al(0,67), al(1,67), al(2,67), al(3,67) $ / 1.76583E+01, -2.72523E+00, -8.19409E-04, 0.00000E+00/ data am(0,67), am(1,67), am(2,67), am(3,67) $ / 1.60140E+01, -2.67903E+00, 0.00000E+00, 0.00000E+00/ data an(0,67), an(1,67), an(2,67), an(3,67) $ / 1.60140E+01, -2.67903E+00, 0.00000E+00, 0.00000E+00/ data coh(0,67), coh(1,67), coh(2,67), coh(3,67) $ / 7.77470E+00, 3.69722E-01, -3.49132E-01, 1.65862E-02/ data cih(0,67), cih(1,67), cih(2,67), cih(3,67) $ / 2.28493E-01, 1.47438E+00, -1.90559E-01, 3.90903E-03/ c data for element #68, Erbium, (Er) data name(68), ek(68), el(68), em(68) $ /'er', 5.74860E+01, 9.75200E+00, 2.21200E+00/ data l2(68), l3(68), lj3(68) $ / 9.26500E+00, 8.35800E+00, 2.93300E+00/ data ka(68), kb(68), la(68), lb(68) $ / 4.90990E+01, 5.56900E+01, 6.94870E+00, 7.81090E+00/ data den(68), cf(68), atwt(68) $ / 9.05100E+00, 2.77700E+02, 1.67270E+02/ data ak(0,68), ak(1,68), ak(2,68), ak(3,68) $ / 1.20195E+01, 1.84815E+00, -9.39582E-01, 6.38106E-02/ data al(0,68), al(1,68), al(2,68), al(3,68) $ / 1.77988E+01, -2.74671E+00, -2.87580E-03, 0.00000E+00/ data am(0,68), am(1,68), am(2,68), am(3,68) $ / 1.60672E+01, -2.67580E+00, 0.00000E+00, 0.00000E+00/ data an(0,68), an(1,68), an(2,68), an(3,68) $ / 1.60672E+01, -2.67580E+00, 0.00000E+00, 0.00000E+00/ data coh(0,68), coh(1,68), coh(2,68), coh(3,68) $ / 7.80643E+00, 3.73226E-01, -3.49147E-01, 1.65710E-02/ data cih(0,68), cih(1,68), cih(2,68), cih(3,68) $ / 2.25233E-01, 1.48545E+00, -1.91908E-01, 3.95645E-03/ c data for element #69, Thulium, (Tm) data name(69), ek(69), el(69), em(69) $ /'tm', 5.93900E+01, 1.01160E+01, 2.30700E+00/ data l2(69), l3(69), lj3(69) $ / 9.61800E+00, 8.64800E+00, 2.75800E+00/ data ka(69), kb(69), la(69), lb(69) $ / 5.07300E+01, 5.75760E+01, 7.18100E+00, 8.10300E-03/ data den(69), cf(69), atwt(69) $ / 9.33200E+00, 2.80500E+02, 1.68940E+02/ data ak(0,69), ak(1,69), ak(2,69), ak(3,69) $ / 1.25613E+01, 1.57523E+00, -8.90467E-01, 6.09779E-02/ data al(0,69), al(1,69), al(2,69), al(3,69) $ / 1.74250E+01, -2.51103E+00, -3.29450E-02, 0.00000E+00/ data am(0,69), am(1,69), am(2,69), am(3,69) $ / 1.61269E+01, -2.67886E+00, 0.00000E+00, 0.00000E+00/ data an(0,69), an(1,69), an(2,69), an(3,69) $ / 1.61269E+01, -2.67886E+00, 0.00000E+00, 0.00000E+00/ data coh(0,69), coh(1,69), coh(2,69), coh(3,69) $ / 7.83711E+00, 3.77547E-01, -3.49441E-01, 1.65780E-02/ data cih(0,69), cih(1,69), cih(2,69), cih(3,69) $ / 2.02656E-01, 1.49625E+00, -1.93234E-01, 4.00233E-03/ c data for element #70, Ytterbium, (Yb) data name(70), ek(70), el(70), em(70) $ /'yb', 6.13320E+01, 1.04880E+01, 2.39800E+00/ data l2(70), l3(70), lj3(70) $ / 9.97800E+00, 8.94300E+00, 2.57300E+00/ data ka(70), kb(70), la(70), lb(70) $ / 5.23600E+01, 5.93520E+01, 7.41400E+00, 8.40100E+00/ data den(70), cf(70), atwt(70) $ / 6.97700E+00, 2.87300E+02, 1.73040E+02/ data ak(0,70), ak(1,70), ak(2,70), ak(3,70) $ / 7.42791E+00, 4.28955E+00, -1.35167E+00, 8.66136E-02/ data al(0,70), al(1,70), al(2,70), al(3,70) $ / 1.69795E+01, -2.22577E+00, -7.32557E-02, 0.00000E+00/ data am(0,70), am(1,70), am(2,70), am(3,70) $ / 1.61794E+01, -2.67715E+00, 0.00000E+00, 0.00000E+00/ data an(0,70), an(1,70), an(2,70), an(3,70) $ / 1.39111E+01, -2.40380E+00, 0.00000E+00, 0.00000E+00/ data coh(0,70), coh(1,70), coh(2,70), coh(3,70) $ / 7.86662E+00, 3.82933E-01, -3.50126E-01, 1.66173E-02/ data cih(0,70), cih(1,70), cih(2,70), cih(3,70) $ / 2.02248E-01, 1.48804E+00, -1.89143E-01, 3.62264E-03/ c data for element #71, Lutetium, (Lu) data name(71), ek(71), el(71), em(71) $ /'lu', 6.33140E+01, 1.08700E+01, 2.49200E+00/ data l2(71), l3(71), lj3(71) $ / 1.03490E+01, 9.24400E+00, 2.62000E+00/ data ka(71), kb(71), la(71), lb(71) $ / 5.40630E+01, 6.12820E+01, 7.65400E+00, 8.70800E+00/ data den(71), cf(71), atwt(71) $ / 9.84200E+00, 2.90600E+02, 1.74990E+02/ data ak(0,71), ak(1,71), ak(2,71), ak(3,71) $ / 1.26387E+01, 1.55476E+00, -8.81094E-01, 6.02036E-02/ data al(0,71), al(1,71), al(2,71), al(3,71) $ / 1.72638E+01, -2.37189E+00, -4.95994E-02, 0.00000E+00/ data am(0,71), am(1,71), am(2,71), am(3,71) $ / 1.62289E+01, -2.67128E+00, 0.00000E+00, 0.00000E+00/ data an(0,71), an(1,71), an(2,71), an(3,71) $ / 1.39813E+01, -2.40841E+00, 0.00000E+00, 0.00000E+00/ data coh(0,71), coh(1,71), coh(2,71), coh(3,71) $ / 7.89137E+00, 3.86034E-01, -3.49756E-01, 1.65480E-02/ data cih(0,71), cih(1,71), cih(2,71), cih(3,71) $ / 1.97176E-01, 1.50264E+00, -1.92474E-01, 3.85751E-03/ c data for element #72, Hafnium, (Hf) data name(72), ek(72), el(72), em(72) $ /'hf', 6.53510E+01, 1.12720E+01, 2.60200E+00/ data l2(72), l3(72), lj3(72) $ / 1.07390E+01, 9.56100E+00, 2.41500E+00/ data ka(72), kb(72), la(72), lb(72) $ / 5.57570E+01, 6.32090E+01, 7.89800E+00, 9.02100E+00/ data den(72), cf(72), atwt(72) $ / 1.33000E+01, 2.96400E+02, 1.78500E+02/ data ak(0,72), ak(1,72), ak(2,72), ak(3,72) $ / 7.58160E+00, 4.47037E+00, -1.42808E+00, 9.39044E-02/ data al(0,72), al(1,72), al(2,72), al(3,72) $ / 1.64329E+01, -1.82851E+00, -1.32268E-01, 0.00000E+00/ data am(0,72), am(1,72), am(2,72), am(3,72) $ / 1.62758E+01, -2.66220E+00, 0.00000E+00, 0.00000E+00/ data an(0,72), an(1,72), an(2,72), an(3,72) $ / 1.40548E+01, -2.42829E+00, 0.00000E+00, 0.00000E+00/ data coh(0,72), coh(1,72), coh(2,72), coh(3,72) $ / 7.91803E+00, 3.87021E-01, -3.48881E-01, 1.64406E-02/ data cih(0,72), cih(1,72), cih(2,72), cih(3,72) $ / 1.99469E-01, 1.50233E+00, -1.91385E-01, 3.74011E-03/ c data for element #73, Tantalum, (Ta) data name(73), ek(73), el(73), em(73) $ /'ta', 6.74140E+01, 1.16800E+01, 2.70300E+00/ data l2(73), l3(73), lj3(73) $ / 1.11360E+01, 9.88100E+00, 2.60000E+00/ data ka(73), kb(73), la(73), lb(73) $ / 5.75240E+01, 6.52100E+01, 8.14500E+00, 9.34100E+00/ data den(73), cf(73), atwt(73) $ / 1.66000E+01, 3.00500E+02, 1.80950E+02/ data ak(0,73), ak(1,73), ak(2,73), ak(3,73) $ / 8.65271E+00, 3.73117E+00, -1.26359E+00, 8.23539E-02/ data al(0,73), al(1,73), al(2,73), al(3,73) $ / 1.72411E+01, -2.30313E+00, -5.91006E-02, 0.00000E+00/ data am(0,73), am(1,73), am(2,73), am(3,73) $ / 1.63038E+01, -2.66148E+00, 0.00000E+00, 0.00000E+00/ data an(0,73), an(1,73), an(2,73), an(3,73) $ / 1.41313E+01, -2.47214E+00, 0.00000E+00, 0.00000E+00/ data coh(0,73), coh(1,73), coh(2,73), coh(3,73) $ / 7.94534E+00, 3.87299E-01, -3.47926E-01, 1.63230E-02/ data cih(0,73), cih(1,73), cih(2,73), cih(3,73) $ / 1.96871E-01, 1.50623E+00, -1.91396E-01, 3.70889E-03/ c data for element #74, Tungsten, (W) data name(74), ek(74), el(74), em(74) $ /'w ', 6.95240E+01, 1.20980E+01, 2.81800E+00/ data l2(74), l3(74), lj3(74) $ / 1.15420E+01, 1.02040E+01, 2.61700E+00/ data ka(74), kb(74), la(74), lb(74) $ / 5.93100E+01, 6.72330E+01, 8.39600E+00, 9.67000E+00/ data den(74), cf(74), atwt(74) $ / 1.93000E+01, 3.05400E+02, 1.83920E+02/ data ak(0,74), ak(1,74), ak(2,74), ak(3,74) $ / 7.57541E+00, 4.28874E+00, -1.34998E+00, 8.65200E-02/ data al(0,74), al(1,74), al(2,74), al(3,74) $ / 1.72533E+01, -2.23874E+00, -7.27338E-02, 0.00000E+00/ data am(0,74), am(1,74), am(2,74), am(3,74) $ / 1.62613E+01, -2.60672E+00, 0.00000E+00, 0.00000E+00/ data an(0,74), an(1,74), an(2,74), an(3,74) $ / 1.41536E+01, -2.32580E+00, 0.00000E+00, 0.00000E+00/ data coh(0,74), coh(1,74), coh(2,74), coh(3,74) $ / 7.97266E+00, 3.87704E-01, -3.47155E-01, 1.62372E-02/ data cih(0,74), cih(1,74), cih(2,74), cih(3,74) $ / 1.91015E-01, 1.51240E+00, -1.91220E-01, 3.71450E-03/ c data for element #75, Rhenium, (Re) data name(75), ek(75), el(75), em(75) $ /'re', 0.00000E+00, 0.00000E+00, 0.00000E+00/ data l2(75), l3(75), lj3(75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(75), kb(75), la(75), lb(75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(75), cf(75), atwt(75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ak(0,75), ak(1,75), ak(2,75), ak(3,75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data al(0,75), al(1,75), al(2,75), al(3,75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0,75), am(1,75), am(2,75), am(3,75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,75), an(1,75), an(2,75), an(3,75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,75), coh(1,75), coh(2,75), coh(3,75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data cih(0,75), cih(1,75), cih(2,75), cih(3,75) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ c data for element #76, Osmium, (Os) data name(76), ek(76), el(76), em(76) $ /'os', 7.38720E+01, 1.29640E+01, 3.05000E+00/ data l2(76), l3(76), lj3(76) $ / 1.23840E+01, 1.08710E+01, 2.52900E+00/ data ka(76), kb(76), la(76), lb(76) $ / 6.29910E+01, 7.14040E+01, 8.91000E+00, 1.03540E+01/ data den(76), cf(76), atwt(76) $ / 2.25000E+01, 3.15800E+02, 1.90200E+02/ data ak(0,76), ak(1,76), ak(2,76), ak(3,76) $ / 1.37534E+01, 1.02122E+00, -7.77126E-01, 5.38811E-02/ data al(0,76), al(1,76), al(2,76), al(3,76) $ / 1.73525E+01, -2.28550E+00, -5.88047E-02, 0.00000E+00/ data am(0,76), am(1,76), am(2,76), am(3,76) $ / 1.64233E+01, -2.63163E+00, 0.00000E+00, 0.00000E+00/ data an(0,76), an(1,76), an(2,76), an(3,76) $ / 1.42795E+01, -2.21971E+00, 0.00000E+00, 0.00000E+00/ data coh(0,76), coh(1,76), coh(2,76), coh(3,76) $ / 8.02574E+00, 3.90458E-01, -3.46658E-01, 1.61455E-02/ data cih(0,76), cih(1,76), cih(2,76), cih(3,76) $ / 1.16448E-01, 1.57615E+00, -2.05332E-01, 4.66731E-03/ c data for element #77, Iridium, (Ir) data name(77), ek(77), el(77), em(77) $ /'ir', 7.61120E+01, 1.34240E+01, 3.17200E+00/ data l2(77), l3(77), lj3(77) $ / 1.28240E+01, 1.12150E+01, 2.38700E+00/ data ka(77), kb(77), la(77), lb(77) $ / 6.48860E+01, 7.35490E+01, 9.17300E+00, 1.07060E+01/ data den(77), cf(77), atwt(77) $ / 2.24200E+01, 3.19100E+02, 1.92200E+02/ data ak(0,77), ak(1,77), ak(2,77), ak(3,77) $ / 1.25506E+01, 1.63090E+00, -8.75676E-01, 5.92011E-02/ data al(0,77), al(1,77), al(2,77), al(3,77) $ / 1.65270E+01, -1.76315E+00, -1.35232E-01, 0.00000E+00/ data am(0,77), am(1,77), am(2,77), am(3,77) $ / 1.65144E+01, -2.64832E+00, 0.00000E+00, 0.00000E+00/ data an(0,77), an(1,77), an(2,77), an(3,77) $ / 1.43422E+01, -2.40183E+00, 0.00000E+00, 0.00000E+00/ data coh(0,77), coh(1,77), coh(2,77), coh(3,77) $ / 8.05150E+00, 3.93143E-01, -3.47052E-01, 1.61570E-02/ data cih(0,77), cih(1,77), cih(2,77), cih(3,77) $ / 7.19908E-02, 1.61204E+00, -2.13186E-01, 5.20497E-03/ c data for element #78, Platinum, (Pt) data name(78), ek(78), el(78), em(78) $ /'pt', 7.83950E+01, 1.38920E+01, 3.29700E+00/ data l2(78), l3(78), lj3(78) $ / 1.32730E+01, 1.15640E+01, 2.63200E+00/ data ka(78), kb(78), la(78), lb(78) $ / 6.68200E+01, 7.57360E+01, 9.44100E+00, 1.10690E+01/ data den(78), cf(78), atwt(78) $ / 2.13700E+01, 3.23900E+02, 1.95090E+02/ data ak(0,78), ak(1,78), ak(2,78), ak(3,78) $ / 1.27882E+01, 1.63605E+00, -8.98523E-01, 6.18550E-02/ data al(0,78), al(1,78), al(2,78), al(3,78) $ / 1.73636E+01, -2.21120E+00, -7.30934E-02, 0.00000E+00/ data am(0,78), am(1,78), am(2,78), am(3,78) $ / 1.67024E+01, -2.71631E+00, 0.00000E+00, 0.00000E+00/ data an(0,78), an(1,78), an(2,78), an(3,78) $ / 1.43785E+01, -2.34834E+00, 0.00000E+00, 0.00000E+00/ data coh(0,78), coh(1,78), coh(2,78), coh(3,78) $ / 8.08084E+00, 3.95790E-01, -3.48032E-01, 1.62345E-02/ data cih(0,78), cih(1,78), cih(2,78), cih(3,78) $ / 4.20186E-02, 1.63611E+00, -2.17964E-01, 5.52670E-03/ c data for element #79, Gold, (Au) data name(79), ek(79), el(79), em(79) $ /'au', 8.07230E+01, 1.43530E+01, 3.42500E+00/ data l2(79), l3(79), lj3(79) $ / 1.37330E+01, 1.19180E+01, 2.43900E+00/ data ka(79), kb(79), la(79), lb(79) $ / 6.87790E+01, 7.79680E+01, 9.71100E+00, 1.14390E+01/ data den(79), cf(79), atwt(79) $ / 1.93700E+01, 3.27400E+02, 1.97200E+02/ data ak(0,79), ak(1,79), ak(2,79), ak(3,79) $ / 4.96352E+00, 5.79212E+00, -1.61842E+00, 1.02911E-01/ data al(0,79), al(1,79), al(2,79), al(3,79) $ / 1.74240E+01, -2.23911E+00, -6.63720E-02, 0.00000E+00/ data am(0,79), am(1,79), am(2,79), am(3,79) $ / 1.64734E+01, -2.57834E+00, 0.00000E+00, 0.00000E+00/ data an(0,79), an(1,79), an(2,79), an(3,79) $ / 1.44398E+01, -2.32838E+00, 0.00000E+00, 0.00000E+00/ data coh(0,79), coh(1,79), coh(2,79), coh(3,79) $ / 8.10524E+00, 4.00576E-01, -3.49340E-01, 1.63264E-02/ data cih(0,79), cih(1,79), cih(2,79), cih(3,79) $ / 1.56916E-02, 1.65406E+00, -2.20982E-01, 5.70751E-03/ c data for element #80, Mercury, (Hg) data name(80), ek(80), el(80), em(80) $ /'hg', 8.31030E+01, 1.48460E+01, 3.56200E+00/ data l2(80), l3(80), lj3(80) $ / 1.42090E+01, 1.22840E+01, 2.40000E+00/ data ka(80), kb(80), la(80), lb(80) $ / 7.08210E+01, 8.02580E+01, 9.98700E+00, 1.18230E+01/ data den(80), cf(80), atwt(80) $ / 1.35460E+01, 3.33100E+02, 2.00610E+02/ data ak(0,80), ak(1,80), ak(2,80), ak(3,80) $ / 1.97594E+01, -1.97990E+00, -2.76981E-01, 2.68856E-02/ data al(0,80), al(1,80), al(2,80), al(3,80) $ / 1.71857E+01, -2.08470E+00, -8.53294E-02, 0.00000E+00/ data am(0,80), am(1,80), am(2,80), am(3,80) $ / 1.65903E+01, -2.60670E+00, 0.00000E+00, 0.00000E+00/ data an(0,80), an(1,80), an(2,80), an(3,80) $ / 1.45195E+01, -2.33016E+00, 0.00000E+00, 0.00000E+00/ data coh(0,80), coh(1,80), coh(2,80), coh(3,80) $ / 8.12542E+00, 4.05858E-01, -3.50329E-01, 1.63772E-02/ data cih(0,80), cih(1,80), cih(2,80), cih(3,80) $ / 1.14587E-01, 1.58076E+00, -2.02968E-01, 4.35692E-03/ c data for element #81, Thalium, (Tl) data name(81), ek(81), el(81), em(81) $ /'tl', 8.55280E+01, 1.53440E+01, 3.70000E+00/ data l2(81), l3(81), lj3(81) $ / 1.46980E+01, 1.26570E+01, 2.49800E+00/ data ka(81), kb(81), la(81), lb(81) $ / 7.28600E+01, 8.25580E+01, 1.02660E+01, 1.22100E+01/ data den(81), cf(81), atwt(81) $ / 1.18600E+01, 3.39400E+02, 2.04390E+02/ data ak(0,81), ak(1,81), ak(2,81), ak(3,81) $ / 1.52879E+01, 2.73664E-01, -6.38890E-01, 4.57495E-02/ data al(0,81), al(1,81), al(2,81), al(3,81) $ / 1.77379E+01, -2.37745E+00, -4.33223E-02, 0.00000E+00/ data am(0,81), am(1,81), am(2,81), am(3,81) $ / 1.66564E+01, -2.61593E+00, 0.00000E+00, 0.00000E+00/ data an(0,81), an(1,81), an(2,81), an(3,81) $ / 1.45473E+01, -2.26773E+00, 0.00000E+00, 0.00000E+00/ data coh(0,81), coh(1,81), coh(2,81), coh(3,81) $ / 8.14399E+00, 4.08692E-01, -3.49802E-01, 1.62880E-02/ data cih(0,81), cih(1,81), cih(2,81), cih(3,81) $ / 1.47052E-01, 1.56695E+00, -2.00347E-01, 4.20901E-03/ c data for element #82, Lead, (Pb) data name(82), ek(82), el(82), em(82) $ /'pb', 8.80060E+01, 1.58600E+01, 3.85000E+00/ data l2(82), l3(82), lj3(82) $ / 1.51980E+01, 1.30550E+01, 2.46600E+00/ data ka(82), kb(82), la(82), lb(82) $ / 7.49570E+01, 8.49220E+01, 1.05490E+01, 1.26110E+01/ data den(82), cf(82), atwt(82) $ / 1.13400E+01, 3.44100E+02, 2.07210E+02/ data ak(0,82), ak(1,82), ak(2,82), ak(3,82) $ / 8.63374E+00, 3.69400E+00, -1.21312E+00, 7.74601E-02/ data al(0,82), al(1,82), al(2,82), al(3,82) $ / 1.77963E+01, -2.37691E+00, -4.55883E-02, 0.00000E+00/ data am(0,82), am(1,82), am(2,82), am(3,82) $ / 1.67131E+01, -2.61538E+00, 0.00000E+00, 0.00000E+00/ data an(0,82), an(1,82), an(2,82), an(3,82) $ / 1.45771E+01, -2.25279E+00, 0.00000E+00, 0.00000E+00/ data coh(0,82), coh(1,82), coh(2,82), coh(3,82) $ / 8.15996E+00, 4.18031E-01, -3.52330E-01, 1.64660E-02/ data cih(0,82), cih(1,82), cih(2,82), cih(3,82) $ / 1.82167E-01, 1.54661E+00, -1.95973E-01, 3.90772E-03/ c data for element #83, Bismuth, (Bi) data name(83), ek(83), el(83), em(83) $ /'bi', 9.05270E+01, 1.63850E+01, 3.99900E+00/ data l2(83), l3(83), lj3(83) $ / 1.57080E+01, 1.34180E+01, 2.33800E+00/ data ka(83), kb(83), la(83), lb(83) $ / 7.70970E+01, 8.73350E+01, 1.08360E+01, 1.30210E+01/ data den(83), cf(83), atwt(83) $ / 9.80000E+00, 3.47000E+02, 2.09000E+02/ data ak(0,83), ak(1,83), ak(2,83), ak(3,83) $ / 9.44293E+00, 3.44965E+00, -1.19886E+00, 7.83484E-02/ data al(0,83), al(1,83), al(2,83), al(3,83) $ / 1.75348E+01, -2.23353E+00, -5.96161E-02, 0.00000E+00/ data am(0,83), am(1,83), am(2,83), am(3,83) $ / 1.67078E+01, -2.58648E+00, 0.00000E+00, 0.00000E+00/ data an(0,83), an(1,83), an(2,83), an(3,83) $ / 1.46832E+01, -2.30940E+00, 0.00000E+00, 0.00000E+00/ data coh(0,83), coh(1,83), coh(2,83), coh(3,83) $ / 8.17489E+00, 4.27916E-01, -3.55068E-01, 1.66601E-02/ data cih(0,83), cih(1,83), cih(2,83), cih(3,83) $ / 1.89860E-01, 1.56125E+00, -2.00932E-01, 4.36768E-03/ c data for element #84, Polonium, (Po) data name(84), ek(84), el(84), em(84) $ /'po', 0.00000E+00, 0.00000E+00, 0.00000E+00/ data l2(84), l3(84), lj3(84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(84), kb(84), la(84), lb(84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(84), cf(84), atwt(84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ak(0,84), ak(1,84), ak(2,84), ak(3,84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data al(0,84), al(1,84), al(2,84), al(3,84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0,84), am(1,84), am(2,84), am(3,84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,84), an(1,84), an(2,84), an(3,84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,84), coh(1,84), coh(2,84), coh(3,84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data cih(0,84), cih(1,84), cih(2,84), cih(3,84) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ c data for element #85, Astatine, (At) data name(85), ek(85), el(85), em(85) $ /'at', 0.00000E+00, 0.00000E+00, 0.00000E+00/ data l2(85), l3(85), lj3(85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(85), kb(85), la(85), lb(85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(85), cf(85), atwt(85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ak(0,85), ak(1,85), ak(2,85), ak(3,85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data al(0,85), al(1,85), al(2,85), al(3,85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0,85), am(1,85), am(2,85), am(3,85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,85), an(1,85), an(2,85), an(3,85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,85), coh(1,85), coh(2,85), coh(3,85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data cih(0,85), cih(1,85), cih(2,85), cih(3,85) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ c data for element #86, Radon, (Rn) data name(86), ek(86), el(86), em(86) $ /'rn', 9.84170E+01, 1.80550E+01, 4.47800E+00/ data l2(86), l3(86), lj3(86) $ / 1.73340E+01, 1.46120E+01, 2.34400E+00/ data ka(86), kb(86), la(86), lb(86) $ / 8.38000E+01, 9.48770E+01, 1.17240E+01, 1.43160E+01/ data den(86), cf(86), atwt(86) $ / 9.73000E-03, 3.68600E+02, 2.22000E+02/ data ak(0,86), ak(1,86), ak(2,86), ak(3,86) $ / 1.51782E+01, 3.49020E-01, -6.37638E-01, 4.51377E-02/ data al(0,86), al(1,86), al(2,86), al(3,86) $ / 1.75028E+01, -2.14876E+00, -7.24638E-02, 0.00000E+00/ data am(0,86), am(1,86), am(2,86), am(3,86) $ / 1.69000E+01, -2.60945E+00, 0.00000E+00, 0.00000E+00/ data an(0,86), an(1,86), an(2,86), an(3,86) $ / 1.47243E+01, -2.12905E+00, 0.00000E+00, 0.00000E+00/ data coh(0,86), coh(1,86), coh(2,86), coh(3,86) $ / 8.22553E+00, 4.51478E-01, -3.62056E-01, 1.71556E-02/ data cih(0,86), cih(1,86), cih(2,86), cih(3,86) $ / 1.96619E-01, 1.60080E+00, -2.13800E-01, 5.51717E-03/ c data for element #87, Francium, (Fr) data name(87), ek(87), el(87), em(87) $ /'fr', 0.00000E+00, 0.00000E+00, 0.00000E+00/ data l2(87), l3(87), lj3(87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(87), kb(87), la(87), lb(87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(87), cf(87), atwt(87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ak(0,87), ak(1,87), ak(2,87), ak(3,87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data al(0,87), al(1,87), al(2,87), al(3,87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0,87), am(1,87), am(2,87), am(3,87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,87), an(1,87), an(2,87), an(3,87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,87), coh(1,87), coh(2,87), coh(3,87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data cih(0,87), cih(1,87), cih(2,87), cih(3,87) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ c data for element #89, Actinum, (Ac) data name(89), ek(89), el(89), em(89) $ /'ac', 0.00000E+00, 0.00000E+00, 0.00000E+00/ data l2(89), l3(89), lj3(89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(89), kb(89), la(89), lb(89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(89), cf(89), atwt(89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ak(0,89), ak(1,89), ak(2,89), ak(3,89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data al(0,89), al(1,89), al(2,89), al(3,89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0,89), am(1,89), am(2,89), am(3,89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,89), an(1,89), an(2,89), an(3,89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,89), coh(1,89), coh(2,89), coh(3,89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data cih(0,89), cih(1,89), cih(2,89), cih(3,89) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ c data for element #90, Thorium, (Th) data name(90), ek(90), el(90), em(90) $ /'th', 1.09649E+02, 2.04700E+01, 5.18200E+00/ data l2(90), l3(90), lj3(90) $ / 1.96920E+01, 1.63000E+01, 2.38800E+00/ data ka(90), kb(90), la(90), lb(90) $ / 9.33340E+01, 1.05592E+02, 1.29660E+01, 1.62000E+01/ data den(90), cf(90), atwt(90) $ / 1.17000E+01, 3.85200E+02, 2.32000E+02/ data ak(0,90), ak(1,90), ak(2,90), ak(3,90) $ / 1.34336E+01, 1.34805E+00, -8.13280E-01, 5.55664E-02/ data al(0,90), al(1,90), al(2,90), al(3,90) $ / 1.85481E+01, -2.61281E+00, -7.90574E-03, 0.00000E+00/ data am(0,90), am(1,90), am(2,90), am(3,90) $ / 1.70483E+01, -2.58569E+00, 0.00000E+00, 0.00000E+00/ data an(0,90), an(1,90), an(2,90), an(3,90) $ / 1.47730E+01, -1.91192E+00, 0.00000E+00, 0.00000E+00/ data coh(0,90), coh(1,90), coh(2,90), coh(3,90) $ / 8.27843E+00, 4.79056E-01, -3.67657E-01, 1.74621E-02/ data cih(0,90), cih(1,90), cih(2,90), cih(3,90) $ / 1.70890E-01, 1.65561E+00, -2.29702E-01, 6.92516E-03/ c data for element #91, Protactinium, (Pa) data name(91), ek(91), el(91), em(91) $ /'pa', 0.00000E+00, 0.00000E+00, 0.00000E+00/ data l2(91), l3(91), lj3(91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(91), kb(91), la(91), lb(91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(91), cf(91), atwt(91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ak(0,91), ak(1,91), ak(2,91), ak(3,91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data al(0,91), al(1,91), al(2,91), al(3,91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0,91), am(1,91), am(2,91), am(3,91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,91), an(1,91), an(2,91), an(3,91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,91), coh(1,91), coh(2,91), coh(3,91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data cih(0,91), cih(1,91), cih(2,91), cih(3,91) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ c data for element #92, Uranium, (U) data name(92), ek(92), el(92), em(92) $ /'u ', 1.15603E+02, 2.17560E+01, 5.54900E+00/ data l2(92), l3(92), lj3(92) $ / 2.09470E+01, 1.71670E+01, 2.29200E+00/ data ka(92), kb(92), la(92), lb(92) $ / 9.84280E+01, 1.11289E+02, 1.36130E+01, 1.72180E+01/ data den(92), cf(92), atwt(92) $ / 1.90500E+01, 3.95300E+02, 2.38070E+02/ data ak(0,92), ak(1,92), ak(2,92), ak(3,92) $ / 1.37951E+01, 1.23983E+00, -8.01545E-01, 5.53596E-02/ data al(0,92), al(1,92), al(2,92), al(3,92) $ / 1.75258E+01, -2.07237E+05, -7.23932E-02, 0.00000E+00/ data am(0,92), am(1,92), am(2,92), am(3,92) $ / 1.70353E+01, -2.56903E+00, 0.00000E+00, 0.00000E+00/ data an(0,92), an(1,92), an(2,92), an(3,92) $ / 1.49036E+01, -2.12148E+00, 0.00000E+00, 0.00000E+00/ data coh(0,92), coh(1,92), coh(2,92), coh(3,92) $ / 8.33010E+00, 4.78314E-01, -3.67250E-01, 1.74129E-02/ data cih(0,92), cih(1,92), cih(2,92), cih(3,92) $ / 1.08277E-01, 1.74158E+00, -2.54104E-01, 8.95056E-03/ c data for element #93, Neptunium, (Np) data name(93), ek(93), el(93), em(93) $ /'np', 0.00000E+00, 0.00000E+00, 0.00000E+00/ data l2(93), l3(93), lj3(93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ka(93), kb(93), la(93), lb(93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data den(93), cf(93), atwt(93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00/ data ak(0,93), ak(1,93), ak(2,93), ak(3,93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data al(0,93), al(1,93), al(2,93), al(3,93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data am(0,93), am(1,93), am(2,93), am(3,93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data an(0,93), an(1,93), an(2,93), an(3,93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data coh(0,93), coh(1,93), coh(2,93), coh(3,93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ data cih(0,93), cih(1,93), cih(2,93), cih(3,93) $ / 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ c data for element #94, Plutonium, (Pu) data name(94), ek(94), el(94), em(94) $ /'pu', 1.21760E+02, 2.30950E+01, 5.91400E+00/ data l2(94), l3(94), lj3(94) $ / 2.22630E+01, 1.80530E+01, 2.25100E+00/ data ka(94), kb(94), la(94), lb(94) $ / 1.03653E+02, 1.17146E+02, 1.42790E+01, 1.82780E+01/ data den(94), cf(94), atwt(94) $ / 1.97000E+01, 3.97000E+02, 2.39100E+02/ data ak(0,94), ak(1,94), ak(2,94), ak(3,94) $ / 1.82787E+01, -1.17371E+00, -3.68344E-01, 2.98738E-02/ data al(0,94), al(1,94), al(2,94), al(3,94) $ / 1.75519E+01, -2.02162E+00, -8.22940E-02, 0.00000E+00/ data am(0,94), am(1,94), am(2,94), am(3,94) $ / 1.72953E+01, -2.62164E+00, 0.00000E+00, 0.00000E+00/ data an(0,94), an(1,94), an(2,94), an(3,94) $ / 1.48535E+01, -1.87733E+00, 0.00000E+00, 0.00000E+00/ data coh(0,94), coh(1,94), coh(2,94), coh(3,94) $ / 8.38174E+00, 4.77085E-01, -3.66556E-01, 1.73422E-02/ data cih(0,94), cih(1,94), cih(2,94), cih(3,94) $ / 3.88791E-02, 1.82229E+00, -2.76099E-01, 1.07392E-02/ c----------------------------------------------------------------- c no data for element numbers 84, 85, 87, 88, 89, 91, and 93 c----------------------------------------------------------------- c%%%% test = 'ab' c----------------------------------------------------------------- c begin by error checking name and z c----------------------------------------------------------------- c check for null or undocumented elements symb = sym call case(test,symb) if (symb.eq.'nu') then symb = 'h' iz = 1 endif if ( (iz.eq.84).or.(iz.eq.85).or.(iz.eq.87).or.(iz.eq.88).or. $ (iz.eq.89).or.(iz.eq.91).or.(iz.eq.93) ) then ier = 3 if (erf) call messag('No data for Z=84,85,87-89,91,93') goto 999 elseif ( (symb.eq.'po').or.(symb.eq.'at').or.(symb.eq.'fr').or. $ (symb.eq.'ra').or.(symb.eq.'ac').or.(symb.eq.'pa').or. $ (symb.eq.'np') ) then ier = 3 if (erf) $ call messag('No data for Po, At, Fr, Ra, Ac, Pa, or Np') goto 999 endif c check for missing element if ((symb.eq.' ').and.(iz.eq.0)) then ier = 7 if (erf) call messag('No atomic symbol or Z specified '// $ 'on input') goto 999 endif c search for symbol or z is too big or get symbol from z if (symb.ne.' ') then goto 10 elseif (iz.gt.nelem) then ier = 4 if (erf) call messag('No data for z > 94.') goto 999 else symb = name(iz) goto 20 endif 10 continue c search for z from symbol j = 1 15 continue if ((j.le.nelem).and.(symb.eq.name(j))) then iz = j elseif (j.gt.nelem) then ier = 2 if (erf) call messag('Unknown atomic symbol') goto 999 else j = j+1 goto 15 endif c------------------------------------------------------------- c checking for zero energy input, if en<0 skip over abs. calc. c------------------------------------------------------------- 20 continue if (en.lt.0) goto 160 if (abs(en).lt.eps) then ier = 1 if (erf) call messag('Can not calculate absorption '// $ 'for zero input energy') goto 999 else e = en endif c----------------------------------------------------------------- c check for middle of edge input c----------------------------------------------------------------- if ((e.lt.ek(iz)+eps).and.(e.gt.ek(iz)-eps)) then goto 24 elseif ((e.lt.el(iz)+eps).and.(e.gt.el(iz)-eps)) then goto 24 elseif ((e.lt.em(iz)+eps).and.(e.gt.em(iz)-eps)) then goto 24 else goto 27 endif 24 continue ier = 6 if (erf) call messag('Energy at the middle of edge, '// $ 'using pre-edge fit results may be wrong') c----------------------------------------------------------------- c initialize c----------------------------------------------------------------- 27 continue bsum = 0 sum = 0 chs = 0 csum = 0 cis = 0 cisum = 0 c----------------------------------------------------------------- c select correct range c----------------------------------------------------------------- if (e.ge.ek(iz)) then goto 90 elseif ( (e.lt.ek(iz)).and.(e.ge.el(iz)) ) then goto 30 elseif ( (e.lt.el(iz)).and.(e.ge.em(iz)) ) then goto 50 elseif (e.lt.em(iz)) then goto 70 endif c----------------------------------------------------------------- c start calculation, polynomial exapnsions in log(e) c for photoelectric, coherent, and incoherent x-sections c n is the z number of the atom. c----------------------------------------------------------------- c between k and l edges 30 continue do 40 i=0,3 sum = sum + al(i,iz)*(log(e))**i 40 continue goto 120 c between l and m edges 50 continue do 60 i=0,3 sum = sum + am(i,iz)*(log(e))**i 60 continue goto 110 c below m edge 70 continue do 80 i=0,3 sum = sum + an(i,iz)*(log(e))**i 80 continue goto 120 c above k-edge 90 continue do 100 i=0,3 sum = sum + ak(i,iz)*(log(e))**i 100 continue goto 120 110 if (iz.le.29) then ier = 5 if (erf) call messag('Warning: McMaster uses L1 edge '// $ 'results. May be wrong for Z<30') bax = exp(sum) goto 130 endif 120 continue bax = exp(sum) c---------------------------------------------------------------- c correct for l-edges since mcmaster uses l1-edge c use edge jumps for correct x-sections c---------------------------------------------------------------- if(e.ge.l3(iz).and.e.lt.l2(iz)) bax = bax*lj3(iz) if(e.ge.l2(iz).and.e.lt.el(iz)) bax = bax*lj3(iz)*lj2 c---------------------------------------------------------------- c calculate coherent and incoherent x-sections c---------------------------------------------------------------- 130 continue do 140 i=0,3 chs = chs + coh(i,iz)*(log(e))**i 140 continue bcox = exp(chs) do 150 i=0,3 cis = cis + cih(i,iz)*(log(e))**i 150 continue binx = exp(cis) c sum for total x-section btox = bax+bcox+binx c--------------------------------------------------------------- c calculation done in barns/atom, convert to cm^2/gm if desired c--------------------------------------------------------------- call case(test,unit) if (unit.eq.'c') then xsec(1) = bax/cf(iz) xsec(2) = bcox/cf(iz) xsec(3) = binx/cf(iz) xsec(4) = btox/cf(iz) else xsec(1) = bax xsec(2) = bcox xsec(3) = binx xsec(4) = btox endif xsec(5) = cf(iz) xsec(6) = btox*den(iz)/cf(iz) 160 continue xsec(7) = atwt(iz) xsec(8) = den(iz) if (iz.ge.29) xsec(9) = lj2 xsec(10) = lj3(iz) c---------------------------------------------------------------- c fill the energy array c---------------------------------------------------------------- energy(1) = ek(iz) energy(2) = el(iz) energy(3) = l2(iz) energy(4) = l3(iz) energy(5) = em(iz) energy(6) = ka(iz) energy(7) = kb(iz) energy(8) = la(iz) energy(9) = lb(iz) 999 continue return c end subroutine mucal end c*********************************************************************** subroutine bwords (s, nwords, words) c c breaks string into words. words are seperated by one or more c blanks, or a comma or equal sign and zero or more blanks. c c args i/o description c ---- --- ----------- c s i char*(*) string to be broken up c nwords i/o input: maximum number of words to get c output: number of words found c words(nwords) o char*(*) words(nwords) c contains words found. words(j), where j is c greater then nwords found, are undefined on c output. c c written by: steven zabinsky, september 1984 c c************************** deo soli gloria ************************** c-- no floating point numbers in this routine. implicit integer (a-z) character*(*) s, words(nwords) character blank, comma, equal parameter (blank = ' ', comma = ',', equal = '=') c-- betw .true. if between words c comfnd .true. if between words and a comma or equal has c already been found logical betw, comfnd c-- maximum number of words allowed wordsx = nwords c-- slen is last non-blank character in string slen = istrln (s) c-- all blank string is special case if (slen .eq. 0) then nwords = 0 return endif c-- begc is beginning character of a word begc = 1 nwords = 0 betw = .true. comfnd = .true. do 10 i = 1, slen if (s(i:i) .eq. blank) then if (.not. betw) then nwords = nwords + 1 words (nwords) = s (begc : i-1) betw = .true. comfnd = .false. endif elseif ((s(i:i).eq.comma).or.(s(i:i).eq.equal)) then if (.not. betw) then nwords = nwords + 1 words (nwords) = s(begc : i-1) betw = .true. elseif (comfnd) then nwords = nwords + 1 words (nwords) = blank endif comfnd = .true. else if (betw) then betw = .false. begc = i endif endif if (nwords .ge. wordsx) return 10 continue c if (.not. betw .and. nwords .lt. wordsx) then nwords = nwords + 1 words (nwords) = s (begc :slen) endif return c end subroutine bwords end subroutine smcase (str, contrl) c convert case of string *str*to be the same case c as the first letter of string *contrl* c if contrl(1:1) is not a letter, *str* will be made lower case. character*(*) str, contrl, s1*1, t1*1 s1 = contrl(1:1) t1 = s1 call lower(t1) if (t1.eq.s1) call lower(str) if (t1.ne.s1) call upper(str) return c end subroutine smcase end c---------------------------------------------------------------- subroutine case(test,word) c returns *word* in the same case as *test* c note that this is just the reverse of smcase ! character*(*) test, word call smcase (word, test) return c end subroutine case end double precision function determ(array,nord,nrows) c c calculate determinate of a square matrix c (from bevington "data reduction and error analysis c for the physical sciences" pg 294) c array: matrix to be analyzed c nterms: order of matrix c nrows: first dimension of matrix in calling routine c double precision array(nrows,nrows) determ = 1. do 150 k=1,nord if (array(k,k).ne.0) go to 130 do 100 j=k,nord if (array(k,j).ne.0) go to 110 100 continue determ = 0. go to 160 c 110 do 120 i=k,nord save = array(i,j) array(i,j) = array(i,k) 120 array(i,k) = save determ = -determ c c 130 determ = determ*array(k,k) if (k.ge.nord) go to 150 k1 = k+1 do 140 i=k1,nord do 140 j=k1,nord 140 array(i,j) = array(i,j)-array(i,k)*array(k,j)/array(k,k) 150 continue 160 return c end double precision function determ end subroutine fixsym(sym) c returns a word with the first letter capitalized and the remaining c letters in lower case c this is very useful for writing out atomic symbols character*2 toss, sym*(*) toss = sym call upper(toss(1:1)) call lower(toss(2:2)) ii = istrln(sym) if (ii.gt.2) then call lower(sym(3:ii)) sym = toss(1:1)//toss(2:2)//sym(3:ii) else sym = toss(1:1)//toss(2:2) endif return c end subroutine fixsym end subroutine getint(keywrd,string,ivalue,line,ierr) character*(*) keywrd, string character*72 messg integer ivalue, j, k, line 400 format(bn,i10) 430 format(' *** Error at line ', i3, ' of input file while') read(string,400,iostat=ierr)ivalue if (ierr.ne.0) then j = istrln(string) k = istrln(keywrd) write(messg,430)line call messag(messg) messg = ' reading '//string(:j)// $ ' as an integer for "'// keywrd(:k)//'".-' call messag(messg) ierr = 3 c stop endif return c end subroutine getint end subroutine getlgc(keywrd,string,lvalue,line,ierr) character*(*) keywrd, string character*72 test*2 logical lvalue integer line, ierr test = 'ab' lvalue = .false. call triml(string) call case(test,string) if ( (string(:1).eq.'t') .or. (string(:1).eq.'y') $ .or. (string(:2).eq.'on') ) $ lvalue=.true. return c end subroutine getlog end subroutine getrea(keywrd,string,value,line,ierr) character*(*) keywrd, string character*72 messg integer j, k, id, ie, line real value logical isnum 400 format(bn,f13.0) 410 format(bn,e19.13) 420 format(bn,d19.13) 430 format(' *** Error at line ', i3, ' of input file while') if (isnum(string)) then call lower(string) ie = index(string, 'e') id = index(string, 'd') if ((id.eq.0).and.(ie.eq.0)) then read(string,400)value elseif (ie.ne.0) then read(string,410)value elseif (id.ne.0) then read(string,420)value endif else j = istrln(string) k = istrln(keywrd) write(messg,430)line call messag(messg) messg = ' reading '//string(:j)// $ ' as a real number for "'//keywrd(:k)//'".-' call messag(messg) ierr = 3 c stop endif return c end subroutine getrea end subroutine gettit(keywrd,string,title,ntit,stdout) character*(*) keywrd, string, title character*72 messg, toss integer ntit, i, j logical stdout ntit = ntit + 1 toss = string call case(keywrd,toss) i = index(toss, keywrd) j = istrln(keywrd) title = string(i+j+1:70) call triml(title) if ( (title(:1).eq.'=') .or. (title(:1).eq.',') ) then toss = title(2:) title = toss call triml(title) endif if (.not.stdout) then messg = ' title > '//title call messag(messg) endif return c end subroutine gettit end subroutine interp(x,y,npts,nterms,xin,yout) c c interpolation routine from bevington's book c double precision deltax,delta,a,prod,sum dimension x(*),y(*) dimension delta(10),a(10) c c search for appropriate value of x(1) c 11 do 19 i=1,npts if(xin-x(i)) 13,17,19 13 i1=i-nterms/2 if(i1) 15,15,21 15 i1=1 go to 21 17 yout=y(i) 18 go to 61 19 continue i1=npts-nterms+1 21 i2=i1+nterms-1 if(npts-i2) 23,31,31 23 i2=npts i1=i2-nterms+1 25 if(i1) 26,26,31 26 i1=1 27 nterms=i2-i1+1 c c evaluate deviations delta c 31 denom=x(i1+1)-x(i1) deltax=(xin-x(i1))/denom do 35 i=1,nterms ix=i1+i-1 35 delta(i)=(x(ix)-x(i1))/denom c c accumulate coefficients a c 40 a(1)=y(i1) 41 do 50 k=2,nterms prod=1. sum=0. imax=k-1 ixmax=i1+imax do 49 i=1,imax j=k-i prod=prod*(delta(k)-delta(j)) 49 sum=sum-a(j)/prod 50 a(k)=sum+y(ixmax)/prod c c accumulate sum of expansion c 51 sum=a(1) do 57 j=2,nterms prod=1. imax=j-1 do 56 i=1,imax 56 prod=prod*(deltax-delta(i)) 57 sum=sum+a(j)*prod 60 yout=sum 61 return c end subroutine interp end integer function is2z(sym) c--------------------------------------------------------------------------- c copyright 1993 university of washington matt newville and bruce ravel c--------------------------------------------------------------------------- c returns z number given atomic symbol: default is 0 character*2 symbol(103), sym, sy, test c data (symbol(i),i=1,103) /'h','he','li','be','b','c','n','o', $'f','ne','na','mg','al','si','p','s','cl','ar','k','ca','sc', $'ti','v','cr','mn','fe','co','ni','cu','zn','ga','ge','as','se', $'br','kr','rb','sr','y','zr','nb','mo','tc','ru','rh','pd','ag', $'cd','in','sn','sb','te','i','xe','cs','ba','la','ce','pr','nd', $'pm','sm','eu','gd','tb','dy','ho','er','tm','yb','lu','hf','ta', $'w','re','os','ir','pt','au','hg','tl','pb','bi','po','at','rn', $'fr','ra','ac','th','pa','u','np','pu','am','cm','bk','cf','es', $'fm','md','no','lr'/ c test case of this routine : note that 'ab' must be the same c case as all of the symbols above sy = sym test = 'ab' call case(test,sy) is2z = 0 do 110 i=1,103 if (sy.eq.symbol(i)) then is2z = i goto 120 end if 110 continue 120 return c end integer function is2z end logical function isnum (string) c returns true if string can be a number, else returns false c recognizes e and d exponentials, bit is not foolproof c to be a number, a string must contain: c - only characters in 'de.+-, 1234567890' (case is checked) c - no more than one 'd' or 'e' c - no more than one '.' character*(*) string, str*70, number*20 integer iexp, idec, i, ilen, ier, j, istrln real x external istrln c note: layout of *number* is important: don't change this!! data number /'de.+-, 1234567890'/ c- isnum = .false. iexp = 0 idec = 0 str = string ilen = max(1, istrln (str) ) call smcase(str, number ) do 100 i = 1, ilen j = index(number,str(i:i) ) if (j.le.0) go to 200 if((j.eq.1).or.(j.eq.2)) iexp = iexp + 1 if (j.eq.3) idec = idec + 1 100 continue c every character in the string was found in *number* c so the string probably is a number isnum = .true. c but let's do a few more tests: c number of exponential and decimal markers if (iexp.ge.2) isnum = .false. if (idec.ge.2) isnum = .false. c read with iostat (this may report an error, but not always) read(str,150,iostat=ier) x 150 format (bn,f70.0) if (ier.ne.0) isnum = .false. c all tests done 200 continue return c end logical function isnum end function istrln (string) c c returns index of last non-blank character. c returns zero if string is null or all blank. character*(*) string c-- if null string or blank string, return length zero. istrln = 0 if (string(1:1).eq.char(0)) return if (string.eq.' ') return c c-- find rightmost non-blank, non-null character. ilen = len (string) do 20 i = ilen, 1, -1 if ((string (i:i) .ne. ' ') .and. $ (string (i:i) .ne. char(0))) goto 30 20 continue 30 istrln = i return c end function istrln end subroutine lower (str) c changes a-z to lower case. ascii specific c- for ascii: ichar(upper case 'a') = 65 c- ichar(lower case 'a') = 97 character*(*) str integer iupa, iloa, iupz, idif data iupa, iloa / 65, 97/ idif = iloa - iupa iupz = iupa + 25 jlen = max(1, istrln (str) ) do 10 i = 1, jlen ic = ichar (str(i:i)) if ((ic.ge.iupa).and.(ic.le.iupz)) str(i:i) = char(ic+idif) 10 continue return c end subroutine lower end subroutine messag(messg) c write message to both standard ouput and to unit 2 c unit 2 must be opened already! character*(*) messg write(*,10) messg 10 format(1x,a) return c end subroutine messag end function nofx(x,array,npts) implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) c c function nofx c c purpose c given a value x and an array of values, find the index c corresponding to the array element closest to x c c usage c n = nofx(x,array,npts) c c parameters c x - a given value c array - array of values, assumed to be stored in order of c increasing value c npts - number of elements in array c c subroutines and function subprograms required c none c c written 8/11/81 by j.m. tranquada c dimension array(npts) imin = 1 imax = npts inc = ( imax - imin ) / 2 10 continue it = imin + inc xit = array(it) if ( x .lt. xit ) then imax = it else if ( x .gt. xit ) then imin = it else nofx = it return endif inc = ( imax - imin ) / 2 if ( inc .gt. 0 ) go to 10 xave = ( array(imin) + array(imin+1) ) / 2. if ( x .lt. xave ) then nofx = imin else nofx = imin + 1 endif return c end function nofx end integer function nxtunt(iunit) c this function returns the value of the next unopened unit number equal c to or larger than iunit. it will return neither unit numbers 0, 5, c or 6 nor a negative unit number integer iunit, iun logical open iun = iunit if (iun.le.0) iun = 1 10 continue if ((iun.eq.5).or.(iun.eq.6)) then iun = 7 goto 10 endif inquire (unit=iun, opened=open) if (open) then iun = iun + 1 goto 10 endif nxtunt = iun return c end integer function nxtunt end c======================================================================= subroutine polyft(xfit1,xfit2,xdata,ydata,ndata,nterms,aout) c c get coefficients for polynomial fit : c ydata = aout(1) + aout(2)*xdata + aout(3) *xdata^2 + ... c the fit is done between xdata = xfit1 and xfit2 c c inputs : c xfit1 lower bound of fitting range c xfit2 upper bound of fitting range c xdata array of abscissa values for data c ydata array of ordinate values for data c ndata length of data arrays c nterms number of terms in polynomial c c outputs : c aout coefficients of fitted polynomial to data c c copyright 1992 university of washington : matt newville c c requires function nofx c c see bevington pg 104 for expalanation of these variables c implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) parameter (max= 5, max2m1 = 2*max-1, zero = 0.) dimension xdata(ndata), ydata(ndata), aout(nterms) double precision sumx(max2m1), sumy(max) double precision array(max,max), ain(max), delta, determ external determ c c find points closest to endpoints of fitting range nfit1 = nofx(xfit1,xdata,ndata) nfit2 = nofx(xfit2,xdata,ndata) if (nfit1.gt.nfit2) then ntemp = nfit1 nfit1 = nfit2 nfit2 = ntemp elseif(nfit1.eq.nfit2) then go to 300 end if c c initialize internal arrays nmax = 2 * nterms - 1 do 100 i=1, nmax sumx(i) = zero 100 continue do 110 i = 1, nterms ain(i) = zero sumy(i) = zero do 110 j = 1, nterms array(i,j) = zero 110 continue c c collect sums of data, sum of squares of data, etc. do 200 i = nfit1, nfit2 xi = xdata(i) yi = ydata(i) xterm = 1.0 do 180 n=1, nmax sumx(n) = sumx(n) + xterm xterm = xterm * xi 180 continue yterm = yi do 190 n=1,nterms sumy(n) = sumy(n) + yterm yterm = yterm * xi 190 continue 200 continue c c construct matrices and evaluate coefficients c do 210 j=1,nterms do 210 k=1,nterms array(j,k) = sumx(j + k - 1) 210 continue delta = determ(array,nterms,max) if (delta.ne.zero) then do 260 l=1,nterms do 250 j=1,nterms do 240 k=1,nterms array(j,k) = sumx(j+k-1) 240 continue array(j,l) = sumy(j) 250 continue ain(l) = determ(array,nterms,max)/delta 260 continue end if 300 continue do 400 i = 1, nterms aout(i) = sngl(ain(i)) 400 continue return c end subroutine polyft end function ref(x,y,z) c double precision function ref(x,y,z) c==================================================================== c hash cartesian coordinates, function returns a hash key based on c ordered coordinate absolute values, three digits of precision c (-3,0,4) gives same hash as (4,3,0) etc. but different from (0,5,0) c==================================================================== c input: c x,y,z: cartesian coordinates c output: c hash value fo cartesian coordinates c==================================================================== implicit integer(i-n) implicit real(a-h,o-z) c implicit double precision(a-h,o-z) parameter (bb=7.238e0, cc=12.092e0) parameter (mildix = 10000, icent = 100) c sort coordinates by size sum = abs(x) + abs(y) + abs(z) a = min( abs(x), abs(y), abs(z) ) c = max( abs(x), abs(y), abs(z) ) b = sum - a - c c integer part of real number, nint might get rounded differently for c numbers that are only different due to numerical precision. ia = int(a*mildix) ib = int(b*mildix) ic = int(c*mildix) ia = int(ia/icent) ib = int(ib/icent) ic = int(ic/icent) ref = ia + bb*ib + cc*ic return c end function ref end function s2e(elem,edge) c double precision function s2e(elem,edge) c implicit double precision (a-h,o-z) c this function returns the energy of a given element and edeg c input: c elem: 2 character atomic symbol (case insensitive) c edge: k, l1, l2, l3 (case insensitive) c output: c s2e: energy value parameter (nelem=94) character*(*) elem, edge character*2 ed, el, test dimension ek(nelem), el1(nelem), el2(nelem), el3(nelem) data (ek(i),i=1,60) / $ 0.140000e-01, 0.250000e-01, 0.550000e-01, 0.112000e+00, $ 0.188000e+00, 0.284000e+00, 0.402000e+00, 0.537000e+00, $ 0.686000e+00, 0.867000e+00, 0.107200e+01, 0.130500e+01, $ 0.156000e+01, 0.183900e+01, 0.214900e+01, 0.247200e+01, $ 0.282200e+01, 0.320200e+01, 0.360700e+01, 0.403800e+01, $ 0.449300e+01, 0.496500e+01, 0.546500e+01, 0.598900e+01, $ 0.654000e+01, 0.711200e+01, 0.770900e+01, 0.833300e+01, $ 0.897900e+01, 0.965900e+01, 0.103670e+02, 0.111040e+02, $ 0.118680e+02, 0.126580e+02, 0.134740e+02, 0.143220e+02, $ 0.152000e+02, 0.161050e+02, 0.170800e+02, 0.179980e+02, $ 0.189860e+02, 0.199990e+02, 0.210450e+02, 0.221170e+02, $ 0.232200e+02, 0.243500e+02, 0.255140e+02, 0.267110e+02, $ 0.279400e+02, 0.292000e+02, 0.304910e+02, 0.318130e+02, $ 0.331690e+02, 0.345820e+02, 0.359850e+02, 0.374410e+02, $ 0.389250e+02, 0.404440e+02, 0.419910e+02, 0.435690e+02/ data (ek(i),i=61,nelem) / $ 0.451840e+02, 0.468350e+02, 0.485200e+02, 0.502400e+02, $ 0.519960e+02, 0.537890e+02, 0.556180e+02, 0.574860e+02, $ 0.593900e+02, 0.613320e+02, 0.633140e+02, 0.653510e+02, $ 0.674140e+02, 0.695240e+02, 0.716760e+02, 0.738720e+02, $ 0.761120e+02, 0.783950e+02, 0.807230e+02, 0.831030e+02, $ 0.855280e+02, 0.880060e+02, 0.905270e+02, 0.931050e+02, $ 0.957300e+02, 0.984170e+02, 0.101137e+03, 0.103922e+02, $ 0.106755e+03, 0.109651e+03, 0.112601e+03, 0.115603e+03, $ 0., 0.121760e+03/ data (el1(i),i=1,60) / $ 0.000000e+00, 0.000000e+00, 0.000000e+00, 0.000000e+00, $ 0.000000e+00, 0.000000e+00, 0.000000e+00, 0.000000e+00, $ 0.000000e+00, 0.000000e+00, 0.000000e+00, 0.630000e-01, $ 0.870000e-01, 0.118000e+00, 0.153000e+00, 0.193000e+00, $ 0.238000e+00, 0.287000e+00, 0.341000e+00, 0.400000e+00, $ 0.463000e+00, 0.531000e+00, 0.604000e+00, 0.682000e+00, $ 0.754000e+00, 0.842000e+00, 0.929000e+00, 0.101200e+01, $ 0.110000e+01, 0.119600e+01, 0.130200e+01, 0.141400e+01, $ 0.153000e+01, 0.165300e+01, 0.178200e+01, 0.192000e+01, $ 0.206500e+01, 0.221600e+01, 0.237300e+01, 0.253200e+01, $ 0.269800e+01, 0.286600e+01, 0.304300e+01, 0.322400e+01, $ 0.341200e+01, 0.360500e+01, 0.380600e+01, 0.401800e+01, $ 0.423800e+01, 0.446500e+01, 0.469800e+01, 0.493900e+01, $ 0.518800e+01, 0.545200e+01, 0.571300e+01, 0.598700e+01, $ 0.626700e+01, 0.654900e+01, 0.683500e+01, 0.712600e+01/ data (el1(i),i=61,nelem) / $ 0.742800e+01, 0.773700e+01, 0.805200e+01, 0.837600e+01, $ 0.870800e+01, 0.904700e+01, 0.939500e+01, 0.975200e+01, $ 0.101160e+02, 0.104880e+02, 0.108700e+02, 0.112720e+02, $ 0.116800e+02, 0.120980e+02, 0.125250e+02, 0.129640e+02, $ 0.134240e+02, 0.138920e+02, 0.143530e+02, 0.148460e+02, $ 0.153440e+02, 0.158600e+02, 0.163850e+02, 0.169390e+02, $ 0.174930e+02, 0.180490e+02, 0.186390e+02, 0.192370e+02, $ 0.198400e+02, 0.204700e+02, 0.211050e+02, 0.217560e+02, $ 0., 0.230950e+02/ data (el2(i), i=1,63) / 27*0., $ 0.872000e+00, 0.952000e+00, 0.104400e+01, 0.114200e+01, $ 0.124900e+01, 0.136000e+01, 0.147700e+01, 0.159600e+01, $ 0.172600e+01, 0.186300e+01, 0.200700e+01, 0.215600e+01, $ 0.230700e+01, 0.246500e+01, 0.262500e+01, 0.279300e+01, $ 0.296700e+01, 0.314600e+01, 0.333000e+01, 0.352400e+01, $ 0.372700e+01, 0.393800e+01, 0.415600e+01, 0.438100e+01, $ 0.461200e+01, 0.485200e+01, 0.510000e+01, 0.535900e+01, $ 0.562400e+01, 0.589100e+01, 0.616500e+01, 0.644100e+01, $ 0.672200e+01, 0.701300e+01, 0.731200e+01, 0.761800e+01/ data (el2(i), i=64,nelem) / $ 0.793100e+01, 0.825200e+01, 0.858100e+01, 0.891900e+01, $ 0.926500e+01, 0.961800e+01, 0.997800e+01, 0.103490e+02, $ 0.107390e+02, 0.111360e+02, 0.115420e+02, 0.119570e+02, $ 0.123840e+02, 0.128240e+02, 0.132730e+02, 0.137330e+02, $ 0.142090e+02, 0.146980e+02, 0.151980e+02, 0.157080e+02, $ 0.162440e+02, 0.167850e+02, 0.173370e+02, 0.179070e+02, $ 0.184840e+02, 0.190830e+02, 0.196920e+02, 0.203140e+02, $ 0.209470e+02, 0, 0.222630e+02/ data (el3(i), i=1,63) / 27*0., $ 0.885000e+00, 0.932000e+00, 0.102100e+01, 0.111500e+01, $ 0.121800e+01, 0.132500e+01, 0.143600e+01, 0.155000e+01, $ 0.167500e+01, 0.180500e+01, 0.194000e+01, 0.208000e+01, $ 0.222300e+01, 0.237100e+01, 0.252000e+01, 0.267700e+01, $ 0.283800e+01, 0.300300e+01, 0.317300e+01, 0.335100e+01, $ 0.353700e+01, 0.373000e+01, 0.392900e+01, 0.413200e+01, $ 0.434100e+01, 0.455700e+01, 0.478100e+01, 0.501200e+01, $ 0.524700e+01, 0.548300e+01, 0.572400e+01, 0.596500e+01, $ 0.620800e+01, 0.646000e+01, 0.671700e+01, 0.697700e+01/ data (el3(i), i=64,nelem) / $ 0.724300e+01, 0.751500e+01, 0.779000e+01, 0.807100e+01, $ 0.835800e+01, 0.864800e+01, 0.894300e+01, 0.924400e+01, $ 0.956100e+01, 0.988100e+01, 0.102040e+02, 0.105340e+02, $ 0.108710e+02, 0.112150e+02, 0.115640e+02, 0.119180e+02, $ 0.122840e+02, 0.126570e+02, 0.130550e+02, 0.134180e+02, $ 0.138140e+02, 0.142140e+02, 0.146120e+02, 0.150310e+02, $ 0.154440e+02, 0.158710e+02, 0.163000e+02, 0.167330e+02, $ 0.171670e+02, 0., 0.180530e+02/ ed=edge el=elem i=is2z(el) c check case c ab must be the same case as k,l1,l2,l3 below for this to work! test = 'ab' call case(test,ed) call case(test,el) if ((el.eq.'nu').or.(i.eq.0)) then s2e = 0.e0 goto 99 endif s2e = 0.e0 if (ed.eq.'k') then s2e = ek(i) elseif (ed.eq.'l1') then s2e = el1(i) elseif (ed.eq.'l2') then s2e = el2(i) elseif (ed.eq.'l3') then s2e = el3(i) endif 99 continue return c end function s2e end subroutine triml (string) c removes leading blanks. character*(*) string jlen = istrln(string) c c-- all blank and null strings are special cases. if (jlen .eq. 0) return c-- find first non-blank char do 10 i = 1, jlen if (string (i:i) .ne. ' ') goto 20 10 continue 20 continue c-- if i is greater than jlen, no non-blanks were found. if (i .gt. jlen) return c-- remove the leading blanks. string = string (i:) return c end subroutine triml end subroutine untab (string) c replace tabs with blanks : tab is ascii dependent integer itab , i, ilen parameter (itab = 9) character*(*) string, tab*1 tab = char(itab) ilen = max(1, istrln(string)) 10 continue i = index(string(:ilen), tab ) if (i .ne. 0) then string(i:i) = ' ' go to 10 end if return c end subroutine untab end subroutine upper (str) c changes a-z to upper case. ascii specific c- for ascii: ichar(upper case 'a') = 65 c- ichar(lower case 'a') = 97 character*(*) str integer iupa, iloa, iloz, idif data iupa, iloa / 65, 97/ idif = iloa - iupa iloz = iloa + 25 jlen = max(1, istrln (str) ) do 10 i = 1, jlen ic = ichar (str(i:i)) if ((ic.ge.iloa).and.(ic.le.iloz)) str(i:i) = char(ic-idif) 10 continue return c end subroutine upper end function volume(cell) c double precision function volume(cell) c-------------------------------------------------------------- c copyright 1993 university of washington bruce ravel c-------------------------------------------------------------- implicit real(a-h,o-z) implicit integer(i-n) c implicit double precision (a-h,o-z) c-------------------------------------------------------------- c calculate the volume of any primitive cell c c cell: real array (6) containing a,b,c,alpha,beta,gamma c-------------------------------------------------------------- parameter (pi=3.141592653589793238462643e0) parameter (radian = pi/180.e0) dimension cell(6) cosal = cos( cell(4)*radian ) cosbe = cos( cell(5)*radian ) cosga = cos( cell(6)*radian ) c term = 1 for orthogonal cells term = 1 - cosal**2 - cosbe**2 - cosga**2 + $ 2*cosal*cosbe*cosga volume = cell(1)*cell(2)*cell(3)*sqrt(term) return c end function volume end subroutine z2s(isym,elem) c--------------------------------------------------------------------------- c copyright 1993 university of washington matt newville and bruce ravel c--------------------------------------------------------------------------- c returns atomic symbol from z number: default is ' ' character*2 elem,symbol(103) c data (symbol(i),i=1,103) /'h','he','li','be','b','c','n','o', $'f','ne','na','mg','al','si','p','s','cl','ar','k','ca','sc', $'ti','v','cr','mn','fe','co','ni','cu','zn','ga','ge','as','se', $'br','kr','rb','sr','y','zr','nb','mo','tc','ru','rh','pd','ag', $'cd','in','sn','sb','te','i','xe','cs','ba','la','ce','pr','nd', $'pm','sm','eu','gd','tb','dy','ho','er','tm','yb','lu','hf','ta', $'w','re','os','ir','pt','au','hg','tl','pb','bi','po','at','rn', $'fr','ra','ac','th','pa','u','np','pu','am','cm','bk','cf','es', $'fm','md','no','lr'/ elem = ' ' if ((isym.ge.1).and.(isym.le.103)) elem = symbol(isym) return end subroutine dbglvl(idebug, idbg) c This converts an integer into a binary representation c include 'atparm.h' c-*-fortran-*- c These parameters are the variable size declarations for the program parameter (iat=50, natx=800, ntitx=9, ndopx=4, ngeomx=natx) parameter (neptx=2**11, maxln=natx) parameter (nlogx=28, nexafs=13, ndbgx=10) c - - - - - - - - - - - - - - - - - - - - - - - - c GLOSSARY: c c iat: maximum number of unique atom positions c natx: maximum size of atomic cluster c ntitx: maximum number of title lines c ndopx: maximum number of dopants at any site c ngeomx: maximum number of lines written to geom.dat c neptx: maximum number of energy points in dafs output files c maxln: maximum number of lines written to feff.inp c nlogx: number of logical parameters in logic array c nexafs: number of mcmaster paramters in exafs array c ndbgx: maximum size of debugging code numbers = 2**ndbgx c------------------------------------------------------------------------ integer idebug, idbg(0:ndbgx) integer isave, level do 5 i=0,ndbgx idbg(i) = 0 5 continue if (idebug.ge.1) then isave = idebug do 10 i=ndbgx,0,-1 level = 2**i idbg(i) = idebug/level idebug = mod(idebug,level) 10 continue idebug = isave endif return c end subroutine dbglvl end subroutine positn(module, string) character*78 module, string, messg im = istrln(module) is = istrln(string) messg = ' *** Position in ' // module(:im) // ': ' // $ string(:is) // '.-' call messag(messg) return c end subroutine crypos end