c c ***************************************************************** c * * c * driver to program KINALC version 1.7 * c * a CHEMKIN based program for kinetic analysis * c * * c ***************************************************************** c c further info is in the comment lines of subroutine KINALC c program driver c implicit double precision (a-h, o-z), integer (i-n) parameter ( leni =500000, lenr =2000000, lenc = 1000, 1 lensym = 500) dimension iw(leni), rw(lenr) character cw(lenc)*(lensym) character*10 fdflt character*80 fname character*11 ckiii,upcas logical isckiii c c lin = Unit number for control file input c lkb = Unit number for standard input (e.g. keyboard) c lscr = Unit number for standard output (e.g. screen) c lout = Unit number for text output c linc = Unit number for CHEMKIN linking file input c lnul = Unit number for discarded error messages c ldata = Unit number for unformatted data input c lfdata = Unit number for formatted data input c c leni = Length of integer work array c lenr = Length of real work array c lenc = Length of character work array c lensym = Length of a character string in character work array c c iw = Integer work array c rw = Real work array c cw = Character work array c data lin/4/, lkb/5/, lscr/6/, lout/7/, linc/8/, lnul/9/ data ldata/10/, lfdata/11/ c write(lscr,200) 200 format(///// 1 5x,'KINALC: Kinetic analysis of reaction mechanisms'// 2 5x,'A postprocessor program to CHEMKIN based', 3 1x,'simulation packages'// 4 5x,'Input and output data files for KINALC'/ 5 5x,'Hit ENTER for defaults'/) c fdflt= 'control' write(lscr,201) fdflt 201 format(/1x,'Input of keywords [',a10,'] :') read (lkb ,100) fname if (fname.eq.' ') fname= fdflt open (unit = lin, status= 'old', form= 'formatted', 1 file= fname, iostat= mes, err= 10) c c selection of CHEMKIN-II or CHEMKIN-III mode of operation c read(lin,211) ckiii ckiii=upcas(ckiii,11) c isckiii=.false. if (ckiii.eq.'CHEMKIN-III') then isckiii=.true. write(lscr,202) 202 format(/1x,'KINALC expects CHEMKIN-III format data files') else write(lscr,203) 203 format(/1x,'KINALC expects CHEMKIN-II format data files') endif c fdflt= 'results' write(lscr,204) fdflt 204 format(/1x,'Output of results [',a10,'] :') read (lkb ,100) fname if (fname.eq.' ') fname= fdflt open (unit = lout, status= 'unknown', form= 'formatted', 1 file= fname, iostat= mes, err= 10) c if (isckiii) then fdflt= 'chem.asc' write(lscr,205) fdflt 205 format(/1x,'Input of the CHEMKIN-III mechanism file [', 1 a10,'] :') read (lkb ,100) fname if (fname.eq.' ') fname= fdflt open (unit = linc, status= 'old', form= 'formatted', 1 file= fname, iostat= mes, err= 10) else fdflt= 'chem.bin' write(lscr,206) fdflt 206 format(/1x,'Input of the CHEMKIN-II mechanism file [', 1 a10,'] :') read (lkb ,100) fname if (fname.eq.' ') fname= fdflt open (unit = linc, status= 'old', form= 'unformatted', 1 file= fname, iostat= mes, err= 10) endif c fdflt= 'save.bin' write(lscr,207) fdflt 207 format(/1x,'Input of concentrations (and sensitivities) '/ 1 1x,'from an unformatted save file [',a10,'] :') read (lkb ,100) fname if (fname.eq.' ') fname= fdflt open (unit = ldata, status= 'unknown', form= 'unformatted', 1 file= fname, iostat= mes, err= 10) c fdflt= 'None' write(lscr,208) fdflt 208 format(/1x,'Input of concentrations (and sensitivities) '/ 1 1x,'from a formatted save file [',a10,'] :') read (lkb ,100) fname if (fname.eq.' ') fname= fdflt open (unit = lfdata, status= 'unknown', form= 'formatted', 1 file= fname, iostat= mes, err= 10) c c UNIX c open (unit = lnul, status='old', file='/dev/null') c c DOS / WINDOWS c c open (unit = lnul, status='old', file='NUL') c c pass control to kinalc c call kinalc (lin,lout,linc,lnul,ldata,lfdata, 1 leni, iw, lenr, rw, lenc, cw,isckiii) c close (lin) close (lout) close (linc) close (ldata) close (lfdata) stop 10 write (lscr,210) mes,fname stop c 100 format(80a) c 210 format( 1 ' Error No',i4,' at opening file ',a10// 2 ' --- PROGRAM TERMINATED ---') 211 format(a11) c end c c ***************************************************************** c * * c * KINALC * c * * c * CHEMKIN based program for kinetic analysis * c * * c ***************************************************************** c c The latest version of this program is always available from c the World Wide Web: c http://www.chem.leeds.ac.uk/Combustion/Combustion.html c or c http://garfield.chem.elte.hu/Combustion/Combustion.html c c c---------------------------------------------------------------------- c c This program has to be linked to the c cklib.f subroutine library of the CHEMKIN-II package c or to the c chemkin.lib and chemkin_public.lib subroutine libraries of the c CHEMKIN-III package (use kinalc4ckIII.mak). c c Linking with cklib.f works with all FORTRAN compilers and c on all platforms (tested platforms: Linux, AIX, SGI, SUN, DEC, Win32) c c Using CHEMKIN-III on platform Win32, KINALC has to be compiled with c Compaq (Digital) Visual Fortran version 6.0. c c---------------------------------------------------------------------- c c c Version 1.7 (2/15/2002) c c Changes from version 1.6 (2/15/2002) c 1 KINALC can now postprocess results also from the following c CHEMKIN-III simulation programs: c SENKIN, PREMIX, OPPDIF, SHOCK, EQUIL c It cannot postprocess yet results from c CHEMKIN-III programs: AURORA, SPIN, c and the surface kinetics results of EQUIL c c Changes from version 1.5 (12/15/2001) c 1 Fixed bug in the PCAS calculation. c 2 Improved printout of the results of eigenanalysis c in options PCAS and PCAF. c c Changes from version 1.4 (6/1/2001) c 1 Avoid division by zero in subroutine QSSAS. c 2 Modified printout in subroutine ATOMFLOW c 3 Numerical zero was changed from 1.E-50 to 1.E-30 c 4 Elimination of not used items from the argumentum lists of c all subroutines c 5 Modification of SENKIN normalization in READC c 6 Modified handling of strings in ROPAB c 7 Checking the values given by AT_TEMP when reading data c from SENKIN, PREMIX, SHOCK, OPPDIF and RUN1DL output c c Changes from version 1.3 (11/1/98) c 1 Normalization of sensitivity coefficients calculated by SENKIN c instead of seminormalization. Changing subroutine READC. c c Changes from version 1.2 (11/1/96) c 1 Calculation of RALI is corrected, c application of a normalized form c 2 Flame velocity sensitivities are now printed out c using option SENS (PREMIX only) c 3 New option HSEN: handling of heat of formation sensitivities, c calculated by the HSEN option of PREMIX c Also: printout of heat of formation flame velocity sensitivities c 4 New option UNC_ANAL: Uncertainty analysis based on local sensitivities c 5 New option CSP: Computational Singular Perturbation analysis c 6 New option ILDM: Intrinsic low-dimensional manifolds c 7 New option THEDY: Calculation of mean thermodynamic properties c 8 New option OPPDIF Reading data from diffusion flame code OPPDIF c c Changes from version 1.1 (12/8/95) c Two bugs have been fixed that made the program c unuseable on DEC computers c 1 COMMON CKSTRT has been deleted in the beginning of c subroutine kinalc.f c 2 Calling subroutines iorder and rorder with zero length c vectors has been prevented in subroutine control c c Changes from version 1.0 (7/12/95) c 1 The structure of COMMON CKSTRT in the CHEMKIN package was c changed on 1/26/94 (from CKINTERP v.3.3 and CKLIB v.4.5). c To keep the compatibility, a version sensitive handling c of CKSTRT has been introduced to KINALC. c c Version 1.0 was launched on 1st July, 1995 c c---------------------------------------------------------------------- c c This subroutine performs various analyses on reaction mechanisms c c Available options: c c (1) Principal component analysis of sensitivity matrix S c (2) Heat of formation sensitivities of species c (3) Uncertainty analysis c (4) Sensitivity of the concentration of single species c (5) Sensitivity of the concentration of a group of species c (6) Identification of rate limiting steps c (7) Importance of reactions (deduced from normed rate contributions) c (8) Principal component analysis of matrix F c (9) Rate-of-production analysis - detailed information c (10) Rate-of-production analysis - brief information c (11) Fluxes of elements c (12) Kinetic connections among species c (13) Lifetimes of species c (14) Instantaneous QSSA error for single species c (15) Instantaneous QSSA error for groups of species c (16) Computational singular perturbation analysis c (17) Intrinsic low dimensional manifolds c (18) Mean thermodynamic properties c (19) Explanation of the results c c The program can be used in conjunction with the following c CHEMKIN based simulation packages: c c (1) Application programs of the CHEMKIN-II package: c SENKIN, PREMIX, OPPDIF, PSR, SHOCK, EQLIB c c (2) Application programs of the CHEMKIN-III package: c SENKIN, PREMIX, OPPDIF, SHOCK, EQUIL c c (3) The RUN1DL package c c This program was developed using CHEMKIN-II version 3.9 c and was tested with several other versions. c The CHEMKIN-III extensions were developed using c CHEMKIN 3.6 (Windows platform) c c c*********************************************************************** c c Please feel free to distribute this program c under the following conditions: c c - Distribution of modified versions is not allowed c - All bugs found have to be reported to c the author: c c Tamas Turanyi c c Department of Physical Chemistry c Eotvos University (ELTE) c H-1518 Budapest, P.O.Box 32, Hungary c Phone : (36-1) 209-0555 x1109 c Fax : (36-1) 209-0602 c E-mail : turanyi@garfield.chem.elte.hu c turanyi@chemres.hu c tamast@chem.leeds.ac.uk c WWW : http://garfield.chem.elte.hu/ c c----------------------------------------------------------------------- c c The CHEMKIN-III interface was written by c c Istvan Gy. Zsely c c Department of Physical Chemistry c Eotvos University (ELTE) c E-mail : zsigy@vuk.chem.elte.hu c WWW : http://garfield.chem.elte.hu/ c c----------------------------------------------------------------------- c c The CSP block was written by: c c Christos Frouzakis c c Institute of Energy c Swiss Federal Institute of Technology c ETH-Zentrum c CH-8092 Zurich, Switzerland c Phone : (41-1) 632-7947 c Fax : (41-1) 632-1100 c E-mail : frouzakis@lvv.iet.mavt.ethz.ch c c c*********************************************************************** c c The program is planned to be developed further and c we are looking forward to receiving suggestions for: c - other methods for the analysis of complex reaction mechanisms c - other CHEMKIN based simulation packages for writing interfaces to c c c The author is very grateful for the helpful suggestions to c c Christos Frouzakis (Zurich) c Robert Hynes (Sydney) c Valerie Dupont (Leeds) c Patricia Patterson (Leeds) c Anders Broe Bendtsen (Lyngby, Denmark) c Jianning Zhu (Sydney) c Zsely, Istvan Gyula (Budapest) c c======================================================================= c c DESCRIPTION OF INPUT AND OUTPUT FILES c c======================================================================= c c C O N T R O L c c c c Keywords accepted in the control file c c c Mode of operation: c c CHEMKIN-III The program assumes that the link and the save files are c in CHEMKIN-III format c This keyword MUST be in the first line! c Without it KINALC expects CHEMKIN-II format files. c c CHEMKIN-II The program assumes that the link and the save files are c in CHEMKIN-III format (default). c c c Origin of concentrations (and possibly sensitivities): c c SENKIN Source: the unformatted save file of SENKIN c Further info: TIME c c PREMIX Source: the unformatted save file of PREMIX c Further info: HEIGHT c c OPPDIF Source: the unformatted save file of OPPDIF c Further info: HEIGHT c c PSR Source: the unformatted save file of PSR c CHEMKIN-II mode only c Further info: None c c SHOCK Source: the unformatted save file of SHOCK c Further info: TIME c c EQLIB Source: the unformatted save file of EQLIB c CHEMKIN-II mode only c Further info: None c c EQUIL Source: the unformatted save file of EQUIL c CHEMKIN-III mode only c Further info: None c c RUN1DL Source: the formatted continuation file of RUN1DL, format A. c CHEMKIN-II mode only c Further info: HEIGHT c c Notes: c c SENKIN, PREMIX, OPPDIF, PSR, SHOCK, and EQLIB c are application programs of the CHEMKIN-II package c c CHEMKIN-II: A FORTRAN Chemical Kinetics Package for c the Analysis of Gas-phase Chemical Kinetics c R.J. Kee, F.M. Rupley, J.A. Miller c (C) Sandia National Laboratories c Livermore c California 94551 c USA c c c SENKIN, PREMIX, OPPDIF, SHOCK, and EQUIL c are application programs of the CHEMKIN-III collection: c c CHEMKIN Collection, Release 3.6 c R. J. Kee, F. M. Rupley, J. A. Miller, M. E. Coltrin, c J. F. Grcar, E. Meeks, H. K. Moffat, A. E. Lutz, c G. Dixon-Lewis, M. D. Smooke, J. Warnatz, G. H. Evans, c R. S. Larson, R. E. Mitchell, L. R. Petzold, c W. C. Reynolds, M. Caracotsios, W. E. Stewart, P. Glarborg, c C. Wang, and O. Adigun, c Reaction Design, Inc., San Diego, CA (2000). c www.reactiondesign.com c c c c RUN-1DL: The Universal Laminar Flame and Flamelet Code c (C) Professor Bernd Rogg c e-mail: RUN-1DL@lstm.ruhr-uni-bochum.de c Lehrstuhl fur Stromungsmechanik c Institut fur Thermo- und Fluiddynamik c Ruhr-Universitat Bochum c D-44780 Bochum c Germany c c c c TIME The mechanism is investigated at the concentrations c (and possibly sensitivities) c belonging to the time point(s) given by parameter TIME c Usage: TIME c Unit: seconds c Use a single value in each line! c Can be used multiple times, the order is arbitrary. c c HEIGHT The mechanism is investigated at the concentrations c (and possibly sensitivities) c belonging to the height(s) given by parameter HEIGHT c Usage: HEIGHT c Unit: cm c Use a single value in each line! c Can be used multiple times, the order is arbitrary. c c AT_TEMP The mechanism is investigated at the concentrations c (and possibly sensitivities) belonging to the temperature c values given by parameter AT_TEMP c Usage: AT_TEMP c Unit: K c Use a single value in each line! c Can be used multiple times, the order is arbitrary. c c c Methods for the analysis of mechanisms: c c> PCAS Principal component analysis of matrix S c where S(i,j)= {d ln c(i) / d ln k(j) }, c c is the vector of concentrations, and c k is the vector of rate coefficients c Species listed after PCAS are considered in the objective c function of principal component analysis c Usage: PCAS ... c Can be used multiple times c Default: all species c c TPCAS A reaction is considered to have a large influence on species c listed after PCAS if it is present in a reaction group having an c eigenvalue greater than TAS and characterized by an eigenvector c element greater than TES. Thresholds TAS and TES are c defined by TPCAS. c Usage: TPCAS c Can be used multiple times c Default values: TAS= 0.0001 and TES= 0.2 c c> HSENS List of species that heat of formation have a c high influence on the calculated concentration c of species listed after HSEN c Temperature can also be given in the list. c Usage: HSENS ... c Can be used multiple times c Default: If no species or temperature is given then c flame velocity sensitivities are printed out only c (if applicable) c c c> UNC_ANAL Uncertainty analysis based on local sensitivities c List of reactions which cause a high uncertainty to the c calculated concentration of species listed after UNC_ANAL c Temperature can also be given in the list. c Usage: UNC_ANAL ... c Can be used multiple times c Default: If no species or temperature is given then c flame velocity uncertainties are printed out only c (if applicable) c c UNC Defining the uncertainty factors of reactions c The reaction uncertainty factor is defined as the c logarithm of the ratio of the best estimation and of c the extreme possible value: c f = log_10 (k_max / k) or f = log_10 (k / k_min) c For details see e.g.: c Baulch D.L. et al., Combust.Flame 98,59-79(1994) c Can be used multiple times c Usage: UNC c or c UNC REACTION#n c or c UNC ALL c Notes: c - The reaction string must be EXACTLY IDENTICAL to c the reaction strings listed in the 'Your requests' c section of results when UNC_ANAL has been used. c - In 'REACTION#n' number n is the number of the reaction c the uncertainty information refers to. c (This is an alternative to the previous command.) c - UNC ALL defines the uncertainty of all reactions not c defined individually by the UNC or c UNC REACTION#n commands. c Default value: U= 0.5 for all reactions c c c> SENS List of reactions having a high influence on the concentration c of single species listed after SENS c Temperature can also be given in the list. c Usage: SENS ... c Can be used multiple times c Default: If no species or temperature is given then c flame velocity sensitivities are printed out only c (if applicable) c c c> SENG List of reactions having a high influence on the concentration c of group of species listed after SENG c Temperature can also be given in the list. c Usage: SENG ... c Can be used multiple times c Default: all species and temperature c c c> RALI The rate limiting steps of the production of species defined c in the list are searched for. A reaction is considered c rate limiting if its dS/dt value is much higher than the c corresponding values of other reactions c Usage: KRALI ... c Can be used multiple times c Default: none. At least one species has to be specified. c c c> RIMP Importance of reactions is assessed on the basis of c b(j)= SUM_i ((k(j)/cwdot(i))(d cwdot(i) / d k(j)))^2 values, c where cwdot is the vector of production rates and c k is the vector of rate coefficients c c TREAC A reaction is considered important if b(j) is greater then TREAC c Default value: TREAC= 1. c c c> PCAF Principal component analysis of matrix F c where F(i,j)= { (k(j)/cwdot(i))(d cwdot(i) / d k(j)) } c TPCAF A reaction is considered important, if it is present in a reaction c group having an eigenvalue greater than TAF and characterized by c an eigenvector element greater than TEF. c Thresholds TAF and TEF are defined by TPCAF. c Usage: TPCAF c Can be used multiple times c Default values: TAS= 0.0001 and TES= 0.2 c c c> ROPAD Rate-of-production analysis; a detailed list of reaction c contributions to the production rates of species is given c c TDLIM A reaction is not listed if its rate is TDLIM times less c than the largest contribution to the production rate of a species c Usage: TDLIM c Default value: tdlim= 100. c c c> ROPAB Rate-of-production analysis; a brief summary of reaction c contributions to the production rates of species is given c c TBLIMS Creation of the brief form is controlled by three values, c defined by TBLIMS. For the definition of the three thresholds c see the comments in subroutine ROPAB. c Usage: TBLIMS c Default values: tblim1=3, tblim2=10, tblim3=100. c c TROPA Effective in case of both ROPAD and ROPAB; A reaction is considered c important if it has a higher contribution than TROPA % c to the production rate of a species. c Default value: TROPA= 5. c c c> ATOMFLOW Fluxes of elemens from species to species are investigated c The name(s) of elements are listed after the keyword. c Usage: ATOMFLOW ... c Can be used multiple times c Default: all elements c c c> CONNECT Let a group of species, important for the modeller, be given c after this keyword. Option CONNECT provides the list of species c having a close connection to the group of species on the c basis of the investigation of c b(j)= SUM_i ( d ln cwdot(i) / d ln c(j) )^2 values. c Usage: CONNECT ... c Can be used multiple times c Default: none. At least one species has to be specified. c c c> LIFETIME Lifetimes of species are calculated c c c> QSSAS If the concentration of non-QSSA species is calculated exactly, c application of the quasi-steady-state approximation (QSSA) c causes an error in the calculation of the concentration of QSSA c species. This error, called the instantaneous QSSA error, can be c calculated by QSSAS for single QSSA species. c c c> QSSAG If there is not one but several QSSA species, their errors c interact. This error, calculated here, is called group c instantaneous QSSA error. c The list of QSSA species has to be given after QSSAG c Usage: QSSAG ... c Can be used multiple times. c Default: none. At least one species has to be specified. c c> CSP Computational Singular Perturbation analysis c Usage: CSP c where "tlcsp" is the limiting time scale c Default value: tlcsp= 1.E-05 c c> ILDM Intrinsic low-dimensional manifolds c Usage: ILDM c where "tlildm" is the limiting time scale c Default value: tlildm= 1.E-05 c c c> THEDY Mean thermodynamic data c c c> COMMENTS The printed results are commented and explained. c A must for first time users ! c c c> END The control file may be closed by an END statement. c Any subsequent commands are ignored. c c c Further rules: c c - the order of keywords is arbitrary (except for CHEMKIN-III and END) c - characters after an '!' sign are not interpreted c - lower case letters are accepted c c An example for a control file: c c CHEMKIN-II c SENKIN c !PREMIX c !OPPDIF c !PSR c !SHOCK c !EQLIB c !EQUIL c !RUN1DL c TIME 0.001 c TIME 0.1 c TIME 1.E-7 c AT_TEMP 900 c !HEIGHT 0.3 c PCAS H2O c PCAS CO CO2 c TPCAS 0.0001 0.2 c HSEN H2O CO CO2 c UNC_ANAL H2O CO2 c UNC H2+O2=>2OH 1.0 c UNC H+O2=>HO+O 0.1 c UNC REACTION#14 0.15 c UNC ALL 0.5 c SENS H2O CO CO2 c SENS CH4 T c SENG H2O CO CO2 c SENG CH4 T c RALI CO2 c RIMP c TREAC 1. ! This is the default c PCAF c TPCAF 0.0001 0.2 c ROPAD c TDLIM 100. c ROPAB c TBLIMS 3. 10. 100. c TROPA 5. c ATOMFLOW C H c CONNECT H2O CO c CONNECT CO2 CH4 c LIFETIME c QSSAS c QSSAG H OH HO2 c CSP 1.E-5 c ILDM 0.0001 c THEDY c COMMENTS c END c c==================================================================== c c K E Y B O A R D c c Keyboard input, used for defining the I/O file names c c==================================================================== c c S C R E E N c c Screen output. It is used c when the I/O file names are asked for c c==================================================================== c c R E S U L T S c c Text output. All results appear here. c c==================================================================== c c M E C H A N I S M c c The 'mechanism file' contains the complete description of the c reaction mechanism. Its format depends on the mode of operation. c c CHEMKIN-II mode: c chem.bin Input file of KINALC, the output of ckinterp.f c c CHEMKIN-III mode: c chem.asc Input file of KINALC, the output of chem.exe c c==================================================================== c c c Usage of work arrays: c c Integer: c c LENGTH DESCRIPTION c c - c | leniwk work area of CHEMKIN c + c | npcas kpcas c + c | nhsens khsens c + c | nunc kunc c + c | nsens ksens c + c | nseng kseng c + c | ncore kcore c + c | nqssag kqssag c + c | nrali krali c + c | natom katom c + c | ii*nhtt importance of reactions (1/0) based on RIMP c + c | ii*nhtt importance of reactions (1/0) based on PCAF c + c | ii*nhtt importance of reactions (1/0) based on ROPA c + c | ii*nhtt reserved area c + c | work area of subroutines c - c c Real: c c - c | lenrwk work area of CHEMKIN c + c | temp temperature(s) [K] c | p pressure [dynes/cm2] c | c(1..kk) concentrations [mole/cm**3] c + c | s(1..kk+1,1..ii) normalized sensitivities c | for temperature and concentrations (optional) c + c | hs(1..kk+1,1..kk) heat-of-formation sensitivities (optional) c + c | fls(1..ii) normalized flame velocity sensitivities c + c | flhs(1..kk) normalized heat-of-formation flame velocity sensitivities c + c | work area of subroutines c - c c In case of PCAS: c c - c | lenrwk work area of CHEMKIN c + c | c | repeated nt times: c | c | s(1..kk+1,1..ii) normalized sensitivities c | for temperature and concentrations c | c + c | work area of subroutines c - c c c c Character: c c - c | lencwk work area of CHEMKIN c + c | work area of subroutines c - c subroutine kinalc (lin,lout,linc,lnul,ldata,lfdata, 1 leni, iw, lenr, rw, lenc, cw,isckiii) implicit double precision (a-h, o-z), integer (i-n) parameter (nmode=19,maxhot=100,maxtemp=100,maxs=100,maxf=100) parameter (maxgrid=300,maxfon=50,maxii=1000,lenistr=40) parameter (maxrch= 2*maxii+1) dimension iw(leni), rw(lenr) character*(*) cw(lenc) character datum*16, times*8, vers*16 character*(lenistr) istr,rname(maxrch) dimension hot(maxhot), temp(maxtemp), ths(2,maxs), thf(2,maxf) dimension x(maxgrid), hots(maxhot), unc(maxii), rval(1) logical lmode(nmode),comments,lrest,dend,kerr,isckiii logical lsens,lhsens,lsfld,lhsfld data lmode /nmode*.FALSE./ c c logical variables: c c lmode(i) .true. method i is used for mechanism investigation c comments .true. the output is commented c lsens .true. reading of sensitivity data is requested c lhsens .true. reading of H sensitivity data is requested c lsfld .true. flame sensitivity data available c lhsfld .true. H flame sensitivity data available c if (isckiii) then write (lout, 299) else write (lout, 200) endif 200 format(/ 1 ' KINALC: Analysis of Reaction Mechanisms'/ 2 ' Version 1.7 (15th February, 2002)'/ 3 ' CHEMKIN-II mode') 299 format(/ 1 ' KINALC: Analysis of Reaction Mechanisms'/ 2 ' Version 1.7 (15th February, 2002)'/ 3 ' CHEMKIN-III mode') c c--------------------------------------------------------------------- c c determine mechanism size c if (isckiii) then call cklen (linc, lout, leniwk, lenrwk, lencwk,iflag) else call cklen (linc, lout, leniwk, lenrwk, lencwk) endif c c Note for CHEMKIN-II users: c CKLIB versions later than 1/19/95 require the following callings: c call cklen (linc, lout, leniwk, lenrwk, lencwk, iflag) c call ckinit (leniwk, lenrwk, lencwk, linc, lout, iw, rw, cw, iflag) c If you have such a version of CKLIB, please modify the callings c above and below accordingly. c if (leniwk.le.leni.and.lenrwk.le.lenr.and.lencwk.le.lenc) then if (isckiii) then call ckinit (leniwk,lenrwk,lencwk,linc,lout,iw,rw,cw,iflag) else call ckinit (leniwk,lenrwk,lencwk,linc,lout,iw,rw,cw) endif call ckindx (iw, rw, mm, kk, ii, nfit) kk1= kk + 1 kk2= kk + 2 else write (lout,203) leni, leniwk, lenr, lenrwk, lenc, lencwk write (lout,204) return endif c c check for minimal integer space c lit= leniwk +9*kk1 +mm lrt= lenrwk +ii +maxgrid*kk1 lct= lencwk +1 if (lit.gt.leni) then write (lout,203) leni, lit, lenr, lrt, lenc, lct write (lout,204) return endif c--------------------------------------------------------------------- c c reading the version number of the interpreter c that created the chem.bin (cklink) file c rewind(linc) if (isckiii) then read(linc,7000) vers 7000 format(a16) else read(linc) vers endif call ckxnum(vers,1,lout,nval,rval,kerr) rvers= rval(1) if (rvers.lt.3.2999) then call strt1(IcNS,NcKF) else call strt2(IcNS,NcKF) endif c c-------------------------------------------------------------------- c irpcas= leniwk +1 irhsen= irpcas +kk1 irunc= irhsen +kk1 irsens= irunc +kk1 irseng= irsens +kk1 ircore= irseng +kk1 irqssg= ircore +kk1 irrali= irqssg +kk1 iratom= irrali +kk1 irspec= iratom +mm ipcck= 1 ipkname= ipcck +mm iptemp= ipcck +mm +kk c c consider temperature as a species c cw(iptemp)= 'T' c c-------------------------------------------------------------------- c c reaction strings c if (ii.gt.maxii) then write(lout,210) ii,ii,maxii 210 format(/' Number of reactions: ',i5, 1 /' maxii should be >= than',i5, 2 /' (currently maxii=',i5,')'/ 3 /' Please increase maxii in subroutine KINALC!'/ 4 /' ---- PROGRAM TERMINATED ---'//) return endif do 2 i=1,ii call cksymr(i,lout,iw,rw,cw,lt,istr,kerr) if (kerr) then write(lout,211) lt,lenistr 211 format(/' CKSYMR error in subroutine KINALC'/ 1 /' lenistr should be >= than',i5, 2 /' (currently lenistr=',i5,')'/ 3 /' Please increase lenistr in subroutine KINALC!'/ 4 /' ---- PROGRAM TERMINATED ---'//) return endif rname(i)= istr 2 continue c rname(ii+1)= 'ALL' c do 3 i=1,ii call cki2ch(i,istr,ilen,kerr) rname(ii+1+i)= 'REACTION#'//istr(:ilen) 3 continue c call control 1 (lin,lout,lnul,mm,kk,kk1,ii,maxrch,maxhot,maxtemp,maxs,maxf, 2 nmode,lmode,indata,npcas,nhsens,nunc,nsens,nseng,ncore,nqssag, 3 nrali,natom,nhot,ntemp,nths,nthf,hot,temp,ths,thf, 4 treac,tropa,tdlim,tblim1,tblim2,tblim3,tlcsp,tlildm, 5 iw(irpcas),iw(irhsen),iw(irunc),iw(irsens),iw(irseng), 6 iw(ircore),iw(irqssg),iw(irrali),iw(iratom),iw(irspec), 7 cw(ipcck),cw(ipkname),rname,unc,isckiii) comments= .FALSE. nhtt= nhot+ntemp c c check for minimal space again c lit= leniwk+npcas+nhsens+nunc+nsens+nseng+ncore+nqssag+nrali+ 1 natom+4*nhtt*ii litot= lit lrtot= lrt lctot= lct if (lit.gt.leni) then write (lout,203) leni, lit, lenr, lrt, lenc, lct write (lout,204) return endif c c rearrangement of integer workspace c ippcas= leniwk +1 iphsen= ippcas +npcas ipunc= iphsen +nhsens ipsens= ipunc +nunc ipseng= ipsens +nsens ipcore= ipseng +nseng ipqssg= ipcore +ncore iprali= ipqssg +nqssag ipatom= iprali +nrali ipimp1= ipatom +natom ipimp2= ipimp1 +ii*nhtt ipimp3= ipimp2 +ii*nhtt ipimp4= ipimp3 +ii*nhtt ires= lit c do 10 i=1,nhsens 10 iw(iphsen+i-1)= iw(irhsen+i-1) do 11 i=1,nunc 11 iw(ipunc+i-1)= iw(irunc+i-1) do 12 i=1,nsens 12 iw(ipsens+i-1)= iw(irsens+i-1) do 13 i=1,nseng 13 iw(ipseng+i-1)= iw(irseng+i-1) do 14 i=1,ncore iw(ipcore+i-1)= iw(ircore+i-1) 14 continue do 15 i=1,nqssag iw(ipqssg+i-1)= iw(irqssg+i-1) 15 continue do 16 i=1,nrali iw(iprali+i-1)= iw(irrali+i-1) 16 continue do 17 i=1,natom iw(ipatom+i-1)= iw(iratom+i-1) 17 continue do 18 i=ipimp1,ires 18 iw(i)= 0 c c-------------------------------------------------------------------- c nrev= 0 do 4 i=1,ii 4 if(iw(IcNS+i-1).gt.0) nrev= nrev+1 nirrev= ii-nrev write(lout,201) kk,nirrev 201 format(/ 1 ' The mechanism contains',i4,' species'/ 2 ' ' ,i6,' irreversible reactions') if (nrev.gt.0) then write(lout,202) nrev stop endif 202 format( 1 ' and' ,i6,' reversible reactions.'// 2 ' Your mechanism contains reversible reactions'/ 3 ' and therefore KINALC would give senseless results'/ 4 ' for some options.'// 5 ' Please transform the reversible reactions'/ 6 ' to pairs of irreversible reactions by program MECHMOD'/ 7 ' (available from the Web sites'/ 8 ' http://www.chem.leeds.ac.uk/Combustion/Combustion.html OR'/ 9 ' http://garfield.chem.elte.hu/Combustion/Combustion.html).'/ a ' You have to produce a new mechanism file and redo'/ b ' the simulations with this new mechanism file.'/ c ' (The concentrations calculated must remain practically'/ d ' identical so if you do not use sensitivities'/ e ' you may use the original save file.)'// f ' ----- PROGRAM TERMINATED -----'///) c c-------------------------------------------------------------------- c c PCAS if (lmode(1)) then c nt= nhtt iikknt= kk1*nt*ii iii= ii*ii c lit= ires +ii*maxfon +ii lrt1= lenrwk +nt*kk1*(ii+1) +2*kk1 +ii lrt2= lenrwk +iikknt +iii +3*ii lrt= max(lrt1,lrt2) lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c HSENS if (lmode(2)) then c lit= ires +kk lrt= lenrwk +2 +kk1*ii +kk1*kk +3*kk +ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c UNC_ANAL if (lmode(3)) then c lit= ires +ii lrt= lenrwk +2 +kk +kk1*ii +kk1*kk +5*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c SENS if (lmode(4)) then c lit= ires +ii lrt= lenrwk +2 +kk +ii*kk1 +kk1*kk +4*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c SENG if (lmode(5)) then c lit= ires +ii lrt= lenrwk +2 +kk +ii*kk1 +3*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c RALI if (lmode(6)) then c lit= ires +kk1*ii +ii lrt= lenrwk +2 +4*kk +kk1*ii +kk*kk +3*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c RIMP if (lmode(7)) then c lit= ires +ii*kk +ii lrt= lenrwk +2 +2*kk + 4*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c PCAF if (lmode(8)) then c lit= ires +kk*ii +ii +ii*maxfon lrt= lenrwk +2 +2*kk +3*ii +ii*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c ROPAD if (lmode(9)) then c lit= ires +ii lrt= lenrwk +2 +2*kk +4*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c ROPAB if (lmode(10)) then c lit= ires +ii lrt= lenrwk +2 +2*kk +4*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c ATOMFLOW if (lmode(11)) then c lit= ires +mm*kk +kk*ii lrt= lenrwk +2 +kk +kk*kk +2*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c CONNECT if (lmode(12)) then c lit= ires +3*kk lrt= lenrwk +2 +6*kk +kk*kk lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c LIFETIME if (lmode(13)) then c lit= ires +kk lrt= lenrwk +2 +4*kk lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c QSSAS if (lmode(14)) then c lit= ires +kk lrt= lenrwk +2 +6*kk lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c QSSAG if (lmode(15)) then c lit= ires+ nqssag lrt= lenrwk +2 +4*kk +nqssag +nqssag*nqssag lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c CSP if (lmode(16)) then c lit= ires +2*kk + kk*ii lrt= lenrwk +2 +10*kk +5*ii +4*kk*kk +2*kk*ii lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c ILDM if (lmode(17)) then c lit= ires+ kk lrt= lenrwk +2 +7*kk +3*kk*kk lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c THEDY if (lmode(18)) then c lit= ires lrt= lenrwk +2 +3*kk lct= lencwk +1 litot= max(lit,litot) lrtot= max(lrt,lrtot) lctot= max(lct,lctot) endif c c check for sufficient space c write (lout,203) leni, litot, lenr, lrtot, lenc, lctot 203 format(//, ' Working Space Requirements', 1 /, ' Provided Required ', 2 /, ' Integer ', 2I15, 3 /, ' Real ', 2I15, 4 /, ' Character', 2I15, /) c if (lrtot.gt.lenr .or. litot.gt.leni .or. lctot.gt.lenc) then write (lout,204) 204 format (' Stop, not enough work space provided.') return endif c c common pointers c ipick= 1 iprck= 1 ipcck= 1 ipkname= ipcck+mm c dend= .false. c c--------------------------------------------------------------------- c c PCAS: PCA of matrix S c if (lmode(1)) then lsens= .true. lhsens= .false. ls= kk1*ii ical= 1 do 19 it=1,nhtt ips= iprck +lenrwk +ls*(it-1) ipct= ips +ls*it ipct2= ipct +kk2 ips2= ipct2 +kk2 ipsc= ips2 +ls ipsfl= ipsc +kk1*maxgrid iphsfl= ipsfl +ii iphs= iphsfl +kk if (isckiii) then call readc3 (lout,ldata,lfdata,leniwk,lenrwk,kk,ii, 1 indata,it,nsys,imolf,iw(ipick),rw(iprck),rw(ipct), 2 rw(ips),rw(iphs),rw(ipct2),rw(ips2),rw(ipsfl), 3 rw(iphsfl),rw(ipsc),cw(ipkname),lsens,lhsens,dend, 4 maxhot,nhot,hot,maxtemp,ntemp,temp,maxgrid,x, 5 timmin,timmax,temmin,temmax,lsfld,lhsfld,hots,flvelo) else call readc (lout,ldata,lfdata,leniwk,lenrwk,kk,ii, 1 indata,it,nsys,imolf,iw(ipick),rw(iprck),rw(ipct), 2 rw(ips),rw(iphs),rw(ipct2),rw(ips2),rw(ipsfl), 3 rw(iphsfl),rw(ipsc),cw(ipkname),lsens,lhsens,dend, 4 maxhot,nhot,hot,maxtemp,ntemp,temp,maxgrid,x, 5 timmin,timmax,temmin,temmax,lsfld,lhsfld,hots,flvelo) endif if ( .not.lsens ) then lmode(3)= .false. lmode(4)= .false. lmode(5)= .false. lmode(6)= .false. write(lout,214) goto 49 endif if (dend) goto 20 19 continue c 20 nt= it-1 iikknt= kk1*nt*ii iii= ii*ii c ipip= ires +ipick ipifon= ipip +ii c ips= iprck +lenrwk ipsTs= ips +iikknt ipb= ipsTs +iii ipbb= ipb +ii ipe= ipbb +ii c call pcas(lout,kk1,ii,iikknt,nt,npcas,maxs,nths,ths, 1 iw(ipip),maxfon,iw(ipifon),iw(ippcas),rw(ips),rw(ipsTs), 2 rw(ipb),rw(ipbb),rw(ipe),cw(ipkname),rname,lmode(14)) c 49 continue do 22 i=1,nhtt 22 hot(i)= hots(i) endif c dend= .false. lrest= .false. do 50 i=2,18 if(lmode(i)) lrest= .true. 50 continue if (.not.lrest) goto 999 c c c--------------loop-------------------------------------------------- c npoint= 0 ical= 2 lsens= .false. if (lmode(3).or.lmode(4).or.lmode(5).or.lmode(6)) lsens= .true. lhsens= .false. if (lmode(2)) lhsens= .true. do 1 it=1,nhtt c comments= .false. if (it.eq.1) comments= lmode(19) c ipct= iprck +lenrwk ips= ipct +kk2 iphs= ips +kk1*ii ipsfl= iphs +kk1*kk iphsfl= ipsfl +ii ipct2= iphsfl +kk1 ips2 = ipct2 +kk2 ipsc= ips2 +kk1*ii if (isckiii) then call readc3 (lout,ldata,lfdata,leniwk,lenrwk,kk,ii, 1 indata,it,nsys,imolf,iw(ipick),rw(iprck),rw(ipct), 2 rw(ips),rw(iphs),rw(ipct2),rw(ips2),rw(ipsfl), 3 rw(iphsfl),rw(ipsc),cw(ipkname),lsens,lhsens,dend, 4 maxhot,nhot,hot,maxtemp,ntemp,temp,maxgrid,x, 5 timmin,timmax,temmin,temmax,lsfld,lhsfld,hots,flvelo) else call readc (lout,ldata,lfdata,leniwk,lenrwk,kk,ii, 1 indata,it,nsys,imolf,iw(ipick),rw(iprck),rw(ipct), 2 rw(ips),rw(iphs),rw(ipct2),rw(ips2),rw(ipsfl), 3 rw(iphsfl),rw(ipsc),cw(ipkname),lsens,lhsens,dend, 4 maxhot,nhot,hot,maxtemp,ntemp,temp,maxgrid,x, 5 timmin,timmax,temmin,temmax,lsfld,lhsfld,hots,flvelo) endif c if (dend) goto 1 if ( (lmode(3).or.lmode(4).or.lmode(5).or.lmode(6)) 1 .and. (it.eq.1) .and. (.not.lsens) ) then lmode(3)= .false. lmode(4)= .false. lmode(5)= .false. lmode(6)= .false. write(lout,214) endif 214 format(/ 1 ' The data file does not contain sensitivity information'/ 2 ' Requests for PCAS, UNC_ANAL, SENS, SENG or RALI', 3 ' have been neglected.'//) c if ( lmode(2) .and. (it.eq.1) .and. (.not.lhsens) ) then lmode(2)= .false. write(lout,215) endif 215 format(/ 1 ' The data file does not contain', 2 ' heat-of-formation sensitivity information'/ 2 ' Request for HSENS has been neglected.'//) npoint= npoint+1 c c-------------------------------------------------------------------- c c HSEN: heat-of-formation sensitivity of a species c if (lmode(2)) then c ipip= ires +1 iphs= iprck +lenrwk +2 +kk +kk1*ii iphsfl= iphs +kk1*kk +ii ipa= iphsfl +kk1*kk ipb= ipa +ii ipd= ipb +ii c call hsens(lout,kk,nhsens,iw(iphsen),iw(ipip),rw(iphs), 1 rw(iphsfl),rw(ipa),rw(ipb),rw(ipd),cw(ipkname), 2 flvelo,lhsfld,comments) c endif c c c c-------------------------------------------------------------------- c c UNCAN: uncertainty analysis c if (lmode(3)) then c ipip= ires +1 ipt= iprck +lenrwk +1 ipc= ipt +1 ips= iprck +lenrwk +2 +kk ipsfl= ips +ii*kk1 +kk*kk1 ipa= ipsfl +ii ipb= ipa +ii ipd= ipb +ii c call uncan(lout,kk,ii,nunc,iw(ipunc),iw(ipip),rw(ipt),rw(ipc), 1 rw(ips),rw(ipsfl),unc,rw(ipa),rw(ipb),rw(ipd),cw(ipkname), 2 rname,flvelo,lsfld,comments) c endif c c c c-------------------------------------------------------------------- c c SENS: sensitivity of a species c if (lmode(4)) then c ipip= ires +1 ips= iprck +lenrwk +2 +kk ipsfl= ips +ii*kk1 +kk*kk1 ipa= ipsfl +kk1*ii ipb= ipa +ii ipd= ipb +ii c call sens(lout,kk,ii,nsens,iw(ipsens),iw(ipip),rw(ips),rw(ipsfl), 2 rw(ipa),rw(ipb),rw(ipd),cw(ipkname),rname,lsfld,flvelo,comments) c endif c c c-------------------------------------------------------------------- c c SENG: sensitivity of a species c if (lmode(5)) then c ipip= ires +1 ips= iprck +lenrwk +2 +kk ipa= ips +kk1*ii ipb= ipa +ii ipd= ipb +ii c call seng(lout,kk,ii,nseng,iw(ipseng),iw(ipip),rw(ips), 1 rw(ipa),rw(ipb),rw(ipd),cw(ipkname),rname,comments) c endif c c-------------------------------------------------------------------- c c RALI: determination of rate limiting steps c if (lmode(6)) then ipick= 1 ipnuki= ires +ipick ipip= ipnuki +kk*ii iprck= 1 ipt= iprck +lenrwk +1 ipc= ipt +1 ips= ipc +kk ipwdot=ips +kk1*ii ipcv= ipwdot +kk ipwdotv= ipcv +kk ipe= ipwdotv +kk ipsdot= ipe +kk*kk ipq= ipsdot +ii ipb= ipq +ii call rali(lout,kk,ii,leniwk,lenrwk,iw(ipick),rw(iprck), 1 rw(ipt),rw(ipc),rw(ips),rw(ipwdot),rw(ipcv), 2 rw(ipwdotv),rw(ipe),rw(ipsdot),rw(ipq),rw(ipb),nrali, 3 iw(iprali),iw(ipnuki),iw(ipip),cw(ipkname),rname, 4 comments,rvers) c endif c c------------------------------------------------------------------- c c RIMP: important reactions c if (lmode(7)) then c ipnuki= ires +1 ipip= ipnuki +kk*ii ipt= iprck +lenrwk +1 ipc= ipt +1 ipwdot= ipc +kk ipq= ipwdot +kk ipa= ipq +ii ipb= ipa +ii ipd= ipb +ii c call rimp(lout,kk,ii,nhtt,npoint,leniwk,lenrwk, 1 iw(ipick),rw(iprck),iw(ipimp2),iw(ipnuki),iw(ipip), 2 treac,rw(ipt),rw(ipc),rw(ipwdot),rw(ipq),rw(ipa),rw(ipb), 3 rw(ipd),rname,comments) c endif c c-------------------------------------------------------------------- c c PCAF: PCA of matrix F c if (lmode(8)) then c ipnuki= ipick +ires ipip= ipnuki +kk*ii ipifon= ipip +ii ipt= iprck +lenrwk +1 ipc= ipt +1 ipwdot= ipc +kk ipq= ipwdot +kk ipb= ipq +ii ipfTf= ipb +ii ipe= ipfTf +ii*ii c call pcaf(lout,kk,ii,nhtt,npoint,leniwk,lenrwk, 1 iw(ipick),rw(iprck),iw(ipimp3),iw(ipnuki),iw(ipip), 2 maxfon,iw(ipifon),maxf,nthf,thf,rw(ipt),rw(ipc),rw(ipwdot), 3 rw(ipq),rw(ipb),rw(ipfTf),rw(ipe),rname,comments) c endif c c-------------------------------------------------------------------- c c ROPAD: rate-of-production analysis - detailed information c if (lmode(9)) then c ipip= ires +1 ipt= iprck +lenrwk +1 ipc= ipt +1 ipwdot= ipc +kk ipq= ipwdot+kk ipcik= ipq +ii ipb= ipcik +ii ipd= ipb +ii c call ropad(lout,ii,kk,nhtt,npoint,leniwk,lenrwk, 1 iw(ipick),rw(iprck),iw(ipimp1),iw(ipip),tropa,tdlim, 2 rw(ipt),rw(ipc),rw(ipwdot),rw(ipq),rw(ipcik),rw(ipb),rw(ipd), 3 cw(ipkname),rname,comments) c endif c c c-------------------------------------------------------------------- c c ROPAB: rate-of production analysis - brief information c if (lmode(10)) then c ipip= ires +1 ipt= iprck +lenrwk +1 ipc= ipt +1 ipwdot= ipc +kk ipq= ipwdot+kk ipcik= ipq +ii ipb= ipcik +ii ipd= ipb +ii c call ropab(lout,ii,kk,nhtt,npoint,leniwk,lenrwk, 1 iw(ipick),rw(iprck),iw(ipimp1),iw(ipip), 2 tropa,tblim1,tblim2,tblim3, 3 rw(ipt),rw(ipc),rw(ipwdot),rw(ipq),rw(ipcik),rw(ipb),rw(ipd), 4 cw(ipkname),comments) c endif c c-------------------------------------------------------------------- c c ATOMFLOW: fluxes of atoms c if (lmode(11)) then ipncf= ipick +ires ipnuki= ipncf +mm*kk ipt= iprck +lenrwk +1 ipc= ipt +1 ipaf= ipc +kk ipq= ipaf +kk*kk ipcont= ipq +ii c call atomflow (lout,mm,kk,ii,leniwk,lenrwk,lencwk,iw(ipick), 1 rw(iprck),cw(ipcck),natom,iw(ipatom),iw(ipncf),iw(ipnuki), 2 rw(ipt),rw(ipc),rw(ipaf),rw(ipq),rw(ipcont),rname,comments) c endif c c-------------------------------------------------------------------- c c CONNECT: connections among species c if (lmode(12)) then ipifn= ipick +ires ipiny= ipifn +kk ipip= ipiny +kk ipt= iprck +lenrwk +1 ipc= ipt +1 ipwdot= ipc +kk ipcv= ipwdot +kk ipwdotv= ipcv +kk ipe= ipwdotv +kk ipb= ipe +kk*kk ipbb= ipb +kk c call connect (lout,kk,leniwk,lenrwk,iw(ipick),rw(iprck), 1 rw(ipt),rw(ipc),rw(ipwdot),rw(ipcv),rw(ipwdotv),rw(ipe), 2 rw(ipb),rw(ipbb),ncore,iw(ipcore),iw(ipifn),iw(ipiny),iw(ipip), 3 cw(ipkname),comments) c endif c c-------------------------------------------------------------------- c c LIFETIME: lifetimes of species c if (lmode(13)) then ipip = ipick +ires ipt= iprck +lenrwk +1 ipc= ipt +1 ipcdot= ipc +kk iptau= ipcdot +kk ipb= iptau +kk c call lifetime(lout,kk,leniwk,lenrwk,iw(ipick),rw(iprck), 1 rw(ipt),rw(ipc),rw(ipcdot),rw(iptau),rw(ipb), 2 iw(ipip),cw(ipkname),comments,indata) c endif c c-------------------------------------------------------------------- c c QSSAS: instantaneous QSSA error of single species c if (lmode(14)) then ipip= ipick +ires ipt= iprck +lenrwk +1 ipc= ipt +1 ipcdot= ipc +kk iptau= ipcdot +kk ipwdot= iptau +kk ipeqssa= ipwdot +kk ipb= ipeqssa+kk c call qssas (lout,kk,leniwk,lenrwk,iw(ipick),rw(iprck),rw(ipt), 1 rw(ipc),rw(ipcdot),rw(iptau),rw(ipwdot),rw(ipeqssa),rw(ipb), 2 iw(ipip),cw(ipkname),comments,indata) c endif c c-------------------------------------------------------------------- c c QSSAG: instantaneous QSSA error for qroups of species c if (lmode(15)) then c ipip= ipick +ires ipt= iprck +lenrwk +1 ipc= ipt +1 ipwdot= ipc +kk ipcv= ipwdot +kk ipwdotv= ipcv +kk ipe= ipwdotv +kk ipb= ipe +kk c call qssag (lout,kk,leniwk,lenrwk,iw(ipick),rw(iprck),nqssag, 1 iw(ipqssg),rw(ipt),rw(ipc),rw(ipwdot),rw(ipcv),rw(ipwdotv), 2 rw(ipe),rw(ipb),iw(ipip),cw(ipkname),comments,indata) c endif c c------------------------------------------------------------------ c CSP: Computational Singular Perturbation analysis c if (lmode(16)) then c ipt= iprck +lenrwk+1 ipc= ipt +1 ipcv= ipc +kk ipwd= ipcv +kk ipwdv= ipwd +kk ipf= ipwdv +kk ipwi= ipf +kk ipwr= ipwi +kk ipPr= ipwr +kk ipCpr= ipPr +kk ipr= ipCpr +kk ipeval= ipr +ii ipe= ipeval +kk ipevcr= ipe +kk*kk ipevcl= ipevcr +kk*kk ipQp= ipevcl +kk*kk ipaub= ipQp +kk*kk ipPI= ipaub +kk*ii ipb= ipPI +kk*ii ipbb= ipb +ii ipd= ipbb +ii c ipip= ipick +ires ipisp1= ipip +kk ipisp2= ipisp1 +kk ipnuki= ipisp2 +kk c call csp(lout,kk,ii,leniwk,lenrwk, 1 iw(ipick),rw(iprck),tlcsp, 2 rw(ipt),rw(ipc),rw(ipcv),rw(ipwd),rw(ipwdv),rw(ipf), 3 rw(ipwi),rw(ipwr),rw(ipPr),rw(ipCpr),rw(ipr), 3 rw(ipeval),rw(ipe),rw(ipevcr),rw(ipevcl), 4 rw(ipQp),rw(ipaub),rw(ipPI),rw(ipb),rw(ipbb),rw(ipd), 5 iw(ipip),iw(ipisp1),iw(ipisp2),iw(ipnuki), 4 cw(ipkname),rname,comments) c endif c c c------------------------------------------------------------------ c ILDM: Intrinsic Low Dimensional Manifolds c if (lmode(17)) then c ipp= iprck +lenrwk ipt= ipp +1 ipc= ipt +1 ipxs= ipc +kk ipxsv= ipxs +kk ipwd= ipxsv +kk ipwdv= ipwd +kk ipf= ipwdv +kk ipeval= ipf +kk ipe= ipeval +kk ipevcr= ipe +kk*kk ipevcl= ipevcr +kk*kk c ipmqv= ipick +ires c call ildm(lout,kk,mm,leniwk,lenrwk, 1 iw(ipick),rw(iprck),tlildm,rw(ipp),rw(ipt),rw(ipc), 2 rw(ipxs),rw(ipxsv),rw(ipwd),rw(ipwdv),rw(ipf), 3 iw(ipmqv),rw(ipeval),rw(ipe),rw(ipevcr),rw(ipevcl), 4 cw(ipkname),comments) c c endif c c------------------------------------------------------------------ c THEDYM: calculation of mean thermodynamic properties c if (lmode(18)) then c ipp= iprck +lenrwk ipt= ipp +1 ipc= ipt +1 ipx= ipc +kk ipy= ipx +kk c call thedy(lout,kk,leniwk,lenrwk,iw(ipick),rw(iprck), 1 rw(ipp),rw(ipt),rw(ipc),rw(ipx),rw(ipy)) c endif c 1 continue c------------------end of loop--------------------------------------- 999 continue if (dend) then c c premature end of data file c if (indata.eq.1 .or. indata.eq.4) then write(lout,303) timmin,timmax,temmin,temmax 303 format(/// 1 ' ************************************************************'// 2 ' The requested other time or temperature points are outside'/ 3 ' the scope of the data file: '/ 4 ' time: ',1pe15.3,' s - ',1pe15.3,' s'/ 5 ' temperature: ',0pf15.3,' K - ',0pf15.3, ' K') endif c if (indata.eq.2 .or. indata.eq.6) then write(lout,304) timmin,timmax,temmin,temmax 304 format(/// 1 ' ************************************************************'// 2 ' The requested other height or temperature points are outside'/ 3 ' the scope of the data file: '/ 4 ' height: ',f15.3,' cm - ',f15.3,' cm'/ 5 ' temperature: ',f15.3,' K - ',f15.3,' K'////) endif endif c-------------------------------------------------------------------- c c Summary c comments= lmode(14) ipick= 1 iprck= 1 ipcck= 1 c c if(lmode(9).or.lmode(10)) then c c important reactions at all times based on c rate-of-production analysis c mode= 1 call summ(lout,ii,nhtt,npoint,iw(ipimp1),mode,rname,comments) endif c if(lmode(7)) then c c important reactions at all times based on overall F c mode= 2 call summ(lout,ii,nhtt,npoint,iw(ipimp2),mode,rname,comments) endif c if(lmode(8)) then c c important reactions at all times based on PCA of F c mode= 3 call summ(lout,ii,nhtt,npoint,iw(ipimp3),mode,rname,comments) endif c if(comments) write(lout,205) if(comments) write(lout,206) c c mclock: getting CPU time on an SGI c c itime= mclock() c c etime : getting CPU time on a DEC ALPHA c Don't use on SGI or SUN! c c itime= etime() c min= itime/6000 timem= dfloat(itime-6000*min)/100. if (min.gt.0) then write(lout,207) min,timem else write(lout,208) timem endif call rtime(datum,times) write(lout,209) datum,times c c formats c 100 format(3i5) 205 format(//// * ' ************************************************************'// * ' General comments'// * ' KINALC can be used for finding a subset of a large reaction'/ * ' mechanism that well describes the concentration changes of'/ * ' the important species. These important species are defined'/ * ' by the modeller. The reduced mechanism has to contain the'/ * ' important species and also some other species, called'/ * ' necessary species, and all the important reactions of these'/ * ' two categories of species.'// * ' A possible algorithm for this type of mechanism reduction:'/ * ' Using the CONNECT option of KINALC find out which species'/ * ' are most losely connected to the important species.'/ * ' Using the KILL option of MECHMOD, find all the redundant'/ * ' species in the mechanism via a series of simulations.'/ * ' Elimination of the redundant species does not change'/ * ' significantly the calculated concentrations of important'/ * ' species. The next step is the study of this partly reduced'/ * ' model, which contains important and necessary species only,') 206 format( * ' by KINALC. Options RIMP, ROPA, PCAF, or PCAS can be used for'/ * ' finding the important reactions.'/// * ' The reduction of the mechanism can be continued on the basis'/ * ' of the quasi-steady-state approximation. The QSSA species'/ * ' can be identified using options QSSAS and QSSAG.'/ * ' A more detailed time scale analysis can be based on options '/ * ' CSP and ILDM.'/// * ' Another branch of application of KINALC'/ * ' is finding out which rate parameters have to be known more'/ * ' accurately for better modelling or which parameters can be'/ * ' determined from some kinetic experiments. This information'/ * ' can be obtained using options PCAS, SENS and SENG.'/ * ' UNC_ANAL calculates the uncertainty of results based on'/ * ' the uncertainty of reactions and local sensitivities.'/// * ' The interaction of reactions and species can be understood'/ * ' using options RALI, ATOMFLOW, LIFETIME and '/ * ' also from the results of almost all the other options.'///) 207 format(//' Elapsed CPU time: ',i5,' minutes and ' 1 ,f10.2,' seconds') 208 format(//' Elapsed CPU time: ',f10.2,' seconds') 209 format(///' Date : ',a16,//' Time : ',a8//) c return end c c======================================================================= c c c--------------------------------------------------------------- c mode 1: PCA of S c subroutine pcas(lout,kk1,ii,iikknt,nt,npcas,maxs, 1 nths,ths,ip,maxfon,ifon,kpcas,s,sTs,b,bb,e,kname,rname,comments) c implicit double precision (a-h, o-z), integer (i-n) parameter (lenistr=40) dimension ip(ii),ifon(ii,maxfon),kpcas(npcas) dimension ths(2,maxs) dimension s(iikknt),sTs(ii,ii),b(ii),bb(ii),e(ii) character*(*) kname(kk1), rname(ii) character*(lenistr) istr logical comments c c setting printing thresholds c c tevapr eigenvalue printing threshold c tevepr eigenvector printing threshold c tevapr= 1.D-1 tevepr= 0.2 do 12 is=1,nths if (ths(1,is).lt.tevapr) tevapr=ths(1,is) if (ths(2,is).lt.tevepr) tevepr=ths(2,is) 12 continue tevapr= tevapr/10000 tevepr= tevepr/10 c do 1 i=1,ii do 1 j=1,i sTs(i,j)= 0. do 1 it=1,nt do 1 k=1,kk1 c c if k refers to an obj. func. species => ikp=1 otherwise ikp=0 c ikp= 0 km= k-1 if (km.eq.0) km=kk1 do 2 kp=1,npcas 2 if (km.eq.kpcas(kp)) ikp=1 if (ikp.eq.0) goto 1 c c kit= (it-1)*kk1+k ikit= (it-1)*kk1*ii+(i-1)*kk1+k jkit= (it-1)*kk1*ii+(j-1)*kk1+k sTs(i,j)= sTs(i,j) + s(ikit)*s(jkit) 1 continue c c evaluation of eigenvectors and eigenvalues by c the SDIAG2 routine c call sdiag2(ii,ii,sTs,b,e) c nev: maximal number of non-zero eigenvectors nev= min(ii,npcas*nt) c c the principal components c write(lout,200) (kname(kpcas(k)),k=1,npcas) do 4 i=1,nev if(b(i).lt.tevapr) goto 4 write(lout,201) i,b(i) call order (ii,ip,sTs(1,i),bb,e) do 3 j=1,ii if(dabs(bb(j)).lt.tevepr) goto 3 write(lout,202) j,bb(j),ip(j),rname(ip(j)) 3 continue 4 continue c do 11 is=1,nths tas= ths(1,is) tes= ths(2,is) do 5 i=1,ii 5 ip(i)= 0 do 6 i=1,ii do 6 j=1,maxfon 6 ifon(i,j)= 0 c do 8 i=1,nev if(b(i).lt.tas) goto 9 do 7 j=1,ii if(dabs(sTs(j,i)).lt.tes) goto 7 ip(j)= ip(j) + 1 if (ip(j).gt.maxfon) goto 7 ifon(j,ip(j)) = i 7 continue 8 continue 9 write(lout,203) tas,tes do 10 i=1,ii c istr= rname(i) if(ip(i).eq.0) then write(lout,205) i,istr(:20) else write(lout,205) i,istr(:20),(ifon(i,j),j=1,ip(i)) endif 10 continue c 11 continue c if(comments) write(lout,206) if(comments) write(lout,207) c return c c formats c 100 format (1a1) 200 format (//' === PCAS ==================================='/// 1 5x,'Principal component analysis of the concentration ', 2 'sensitivity matrix :'//' The following species are considered', 3 ' in the objective function: '/900(1x,4a16/)) 201 format(//3x,'No',i4,' eigenvalue :',1pe15.5/9x,' eigenvector :'/) 202 format(5x,i5,1pe15.5,i5,2x,a40) 203 format(///' Summary of the PCA results :'// 1 /2x,' Threshold value for eigenvalues : ',1pe15.5, 2 /2x,' Threshold value for eigenvectors :' ,0pf12.5/) 205 format(1x,i5,1x,a20,3x,20i3,5(/30x,20i3)) 206 format (/ 1 ' The numbers after the reactions show which reaction groups'/ 2 ' (revealed by the eigenvalue-eigenvector analysis)'/ 3 ' the reaction is a member of.'/// 4 ' The principal component analysis of the', 5 ' concentration sensitivity matrix'/ 6 ' can be used for three purposes:'// 7 ' - Interpretation of the sensitivity results'/ 8 ' If the important species are used', 9 ' in the objective function,'/ a ' the PCA will reveal which parameters', b ' or parameter combinations'/ c ' have to be known more accurately for a better description'/ d ' of the concentration of the important species.') 207 format (/ 1 ' - Aid for parameter estimation'/ 2 ' The measured concentrations have to appear in the', 3 ' objective function and'/ 4 ' the PCA tells you which parameters', 5 ' or parameter combinations'/ 6 ' can be determined from an experiment. This method can'/ 7 ' be used for experimental design varying the experimental'/ 8 ' conditions in computer experiments.'// 9 ' - Mechanism reduction'/ a ' If all species appear in the objective function, the PCA'/ b ' results can be used for mechanism reduction. You may want'/ c ' to get rid of the redundant species first using', d ' option CONNECT.'/ e ' For more info see the comments at option CONNECT.'// f ' For the description and applications of the PCA'/ g ' see the following article:'/ h ' Vajda et al., Int.J.Chem.Kinet.,17,55-81(1985)') c end c c---------------------------------------------------------------------- c mode 2 : heat-of-formation sensitivities c subroutine hsens(lout,kk,nhsens,khsens,ip,hs,hsfl,a,b,d,kname, 1 flvelo,lhsfld,comments) c implicit double precision (a-h, o-z), integer (i-n) parameter (lenistr=40) dimension ip(kk) dimension hs(kk+1,kk),a(kk),b(kk),d(kk) dimension khsens(nhsens),hsfl(kk) character*(*) kname(kk) logical comments,lhsfld c write(lout,200) c c printing the flame velocity sensitivities in decreasing order c if (lhsfld) then write(lout,202) flvelo write(lout,205) call order(kk,ip,hsfl,b,d) do 5 i=1,kk if (dabs(b(i)).lt.1.D-3*dabs(b(1)) ) goto 6 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,207) goto 6 endif write(lout,203) i,b(i),kname(ip(i)) 5 continue 6 continue endif c if(nhsens.le.0) return do 1 k=1,nhsens if (khsens(k).eq.kk+1) then write(lout,206) do 2 i=1,kk a(i)= hs(1,i) 2 continue else write(lout,201) kname(khsens(k)) do 3 i=1,kk a(i)= hs(khsens(k)+1,i) 3 continue endif c call order(kk,ip,a,b,d) do 4 i=1,kk if (dabs(b(i)).lt.1.D-3*dabs(b(1)) ) goto 1 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,207) goto 1 endif write(lout,203) i,b(i),kname(ip(i)) 4 continue 1 continue c if (comments) write(lout,204) c c formats c 200 format (//' === HSEN ==================================='/// 1 5x,'Heat of formation sensitivities'/) 201 format(//' Heat-of-formation sensitivities ', 1 'of the concentration of ',a16/ 2 ' (normalized values)'//) 202 format(//' Velocity of the flame is ',f7.2,' cm/s'/) 203 format(5x,i5,1pe11.3,3x,a16) 204 format (/ 1 ' Here the sensitivities of the concentrations of '/ 2 ' species on the heat of formation '/ 3 ' of species are listed.'/ 3 ' In fact, rows of the normalized heat of formation', 4 ' sensitivity matrix'/ 5 ' are printed out in descending order.'/ 6 ' Listing is ceased after 3 orders of magnitude'//) 205 format(//' Heat-of-formation sensitivities ', 1 'of the flame velocity', 2 ' (normalized values)'//) 206 format(//' Heat-of-formation sensitivities ', 1 ' of the calculated temperature', 2 ' (normalized values)'//) 207 format(//5x,' All sensitivities are zero '/) return end c c---------------------------------------------------------------------- c mode 3 : Uncertainty analysis c subroutine uncan(lout,kk,ii,nunc,kunc,ip,T,c,s,sfl,unc,a,b,d, 1 kname,rname,flvelo,lsfld,comments) implicit double precision (a-h, o-z), integer (i-n) dimension c(kk),s(kk+1,ii),sfl(ii) dimension kunc(nunc),unc(ii) dimension ip(ii),a(ii),b(ii),d(ii) character*(*) kname(kk), rname(ii) logical comments, lsfld c write(lout,200) c c Method 1: Warnatz type uncertainty indices c write(lout,201) c if (lsfld) then c c printing the flame velocity uncertainties in decreasing order c write(lout,221) do 5 i=1,ii a(i)= dabs(sfl(i)*unc(i)) 5 continue call order(ii,ip,a,b,d) do 6 i=1,ii if (dabs(b(i)).lt.1.D-3*dabs(b(1)) ) goto 7 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,207) goto 7 endif write(lout,220) i,b(i),ip(i),rname(ip(i)) 6 continue 7 continue endif c c c if(nunc.le.0) return do 1 k=1,nunc if (kunc(k).eq.kk+1) then write(lout,202) do 2 i=1,ii a(i)= dabs(s(1,i)*unc(i)) 2 continue else write(lout,203) kname(kunc(k)) do 3 i=1,ii a(i)= dabs(s(kunc(k)+1,i)*unc(i)) 3 continue endif c call order(ii,ip,a,b,d) do 4 i=1,ii if (dabs(b(i)).lt.1.D-3*dabs(b(1)) ) goto 1 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,207) goto 1 endif write(lout,205) i,b(i),ip(i),rname(ip(i)) 4 continue 1 continue c if (comments) write(lout,206) c c============================================================== c c Method 2: Calculation of variances c write(lout,211) c c conversion of reaction uncertainties 'f' to variances c c f= log10 (k_max / k0) = 1/2.303* ln(k_max / k0) c c ==> ln(k_max / k0) = f*2.303 c where k0 is the best estimation of the rate coefficient and c k_max is the extreme still acceptable value c c Assume that c ln(k) is a stochiastic variable with symmetrical pdf c ln(k0) is the expected value of k c ln(k_max) is a 3*sigma statistical limit c (Prof. D.L. Baulch, private communication) c c then c c 3* sigma(ln(k))= ln(k_max)-ln(k0)=ln(k_max/k0)=f*2.303 c sigma(ln(k) = f*2.303/3. c sigma**2(ln(k))= (f*2.303/3.)**2 c do 11 i=1,ii 11 unc(i)= (unc(i)*2.3025851/3.)**2 c c now unc(i) is the square of variance of the natural logarithm of k c c c printing the flame velocity uncertainties in decreasing order c if (lsfld) then write(lout,221) var2= 0. do 15 i=1,ii semis= sfl(i)*flvelo a(i)= semis**2*unc(i) var2= var2 + a(i) 15 continue write(lout,218) flvelo,dsqrt(var2),var2 c c var2 is the square of variance of the solution c a(i) is the contribution of reaction i to var2 c write(lout,214) call order(ii,ip,a,b,d) do 16 i=1,ii if (dabs(b(i)).lt.1.D-3*var2 ) goto 16 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,207) goto 16 endif write(lout,215) i,b(i),b(i)/var2*100.,ip(i),rname(ip(i)) 16 continue endif c c temperature and concentration uncertainties c do 10 k=1,nunc if (kunc(k).eq.kk+1) then var2= 0. do 12 i=1,ii semis= s(1,i)*T a(i)= semis**2*unc(i) var2= var2 + a(i) 12 continue write(lout,212) T,dsqrt(var2),var2 else var2= 0. do 13 i=1,ii semis= s(kunc(k)+1,i)*c(kunc(k)) a(i)= semis**2*unc(i) var2= var2 + a(i) 13 continue write(lout,213) kname(kunc(k)),c(kunc(k)),dsqrt(var2),var2 endif c c var2 is the square of variance of the solution c a(i) is the contribution of reaction i to var2 c write(lout,214) call order(ii,ip,a,b,d) do 14 i=1,ii if (dabs(b(i)).lt.1.D-3*var2 ) goto 10 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,207) goto 10 endif write(lout,215) i,b(i),b(i)/var2*100.,ip(i),rname(ip(i)) 14 continue 10 continue c if (comments) write(lout,216) if (comments) write(lout,217) c c c formats c 200 format (//' === UNCAN =================================='/// 1 5x,'Uncertainty analysis based on local sensitivities'/) 201 format (//5x,'(i) Warnatz type uncertainty indices'//) 202 format(//5x,' Uncertainty indices of reactions'/ 1 5x,' with respect to the calculated temperature '/) 203 format(//5x,' Uncertainty indices of reactions'/ 1 5x,' with respect to the concentration of ',a16/) 205 format(5x,i5,1pe15.5,i5,3x,a40) 206 format (// 1 ' Warnatz has recommended the application of a '/ 2 ' combined sensitivity/uncertainty index, which'/ 3 ' is defined as the product of the normed sensitivity'/ 3 ' and the logarithm of an uncertainty factor k_max/k'// 4 ' For more info see p.560 in:'/ 5 ' Warnatz J.'/ 6 ' Proc. 24th Symposium on Combustion, pp.553-579(1992)'/) 207 format(//5x,' All uncertainties are zero '/) c 211 format (//5x,' ------------------------------------------------'/ 1 5x,' (ii) Calculation of the variance of the solution') 212 format(// 1 ' TEMPERATURE : ',0pf10.3,' K'/ 2 ' Variance of the temperature : ',0pf10.3,' K'/ 3 ' Square of variance (sigma**2) : ',1pe10.3) 213 format(// 1 ' ',a16/ 1 ' Concentration : ',1pe10.3,' mole/cm3'/ 2 ' Variance of the concentration : ',1pe10.3,' mole/cm3'/ 3 ' Square of variance (sigma**2) : ',1pe10.3) 214 format(/5x,' Contribution of reactions to the sigma**2 :'/) 215 format(5x,i5,1pe15.5,2x,0pf5.2,' % ',i5,3x,a40) 216 format (// 1 ' According to the rules of spread of errors,'/ 2 ' variance of a model output can be calculated'/ 3 ' from the variance of model input using the equation'/ 3 ' sigma**2 (Y_j)= SUM_i (dY_j/dX_i)**2 * sigma**2 (X_i)'/ 4 ' if the covariances are neglected and a linearized'/ 5 ' approach is used. In our case, sigma**2 (X) is the'/ 6 ' variance of the logarithm of rate parameters '/ 7 ' due to experimental uncertainty, (dY/dX)**2 is the '/ 8 ' square of seminormalized sensitivity coefficients'/ 8 ' d v/ d ln k, d T/ d ln k, and d c/ d ln k and '/ 9 ' sigma**2 (Y) is the square of the variance of the') 217 format( 1 ' model output v, T, and c. This allows a rough estimation'/ 2 ' of the uncertainties of the calculated results and an'/ 2 ' analysis of the contribution of parameter uncertainties'/ 2 ' to the uncertainties of model output.'/ 3 ' For more information see:'/ 4 ' Atherton R.W., Schainker R.B., Ducot E.R.'/ 5 ' AIChE Journal, 21, 441(1975)'///) 218 format(// 1 ' Flame velocity : ',0pf10.3,' cm/s'/ 2 ' Variance of flame velocity : ',0pf10.3,' cm/s'/ 3 ' Square of variance (sigma**2) : ',1pe10.3) 220 format(5x,i5,1pe15.5,i5,3x,a40) 221 format(//5x,' Flame velocity uncertainties:'/) return end c c---------------------------------------------------------------------- c mode 4 : sensitivity of single species c subroutine sens(lout,kk,ii,nsens,ksens,ip,s,sfl,a,b,d,kname, 1 rname,lsfld,flvelo,comments) c implicit double precision (a-h, o-z), integer (i-n) dimension ip(ii),ksens(nsens) dimension s(kk+1,ii),sfl(ii),a(ii),b(ii),d(ii) character*(*) kname(kk), rname(ii) logical comments, lsfld c write(lout,200) c c printing the flame velocity sensitivities in decreasing order c if (lsfld) then write(lout,202) flvelo write(lout,205) call order(ii,ip,sfl,b,d) do 5 i=1,ii if (dabs(b(i)).lt.1.D-3*dabs(b(1)) ) goto 6 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,207) goto 6 endif write(lout,203) i,b(i),ip(i),rname(ip(i)) 5 continue 6 continue endif c c c if(nsens.le.0) return do 1 k=1,nsens if (ksens(k).eq.kk+1) then write(lout,206) do 2 i=1,ii a(i)= s(1,i) 2 continue else write(lout,201) kname(ksens(k)) do 3 i=1,ii a(i)= s(ksens(k)+1,i) 3 continue endif c call order(ii,ip,a,b,d) do 4 i=1,ii if (dabs(b(i)).lt.1.D-3*dabs(b(1)) ) goto 1 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,207) goto 1 endif write(lout,203) i,b(i),ip(i),rname(ip(i)) 4 continue 1 continue c if (comments) write(lout,204) c c formats c 200 format (//' === SENS ==================================='/// 1 5x,'Sensitivity of species concentrations on rate coefficients'/) 201 format(//5x,' Sensitivity of the concentration of ',a16/) 202 format(//' Velocity of the flame is ',f7.2,' cm/s'/) 203 format(5x,i5,1pe15.5,i5,3x,a40) 204 format (/ 1 ' Here the sensitivities of the concentrations of '/ 2 ' species (one-by-one) on the rate parameters '/ 3 ' of reactions are listed.'/ 3 ' In fact, rows of the normalized sensitivity matrix'/ 4 ' are printed out in descending order.'/ 5 ' Listing is ceased after 3 orders of magnitude'// 6 ' This information can be used to scan which parameters'/ 7 ' have to be known better for a more precise calculation'/ 8 ' of the concentration of a particular species.'// 9 ' Several applications of sensitivities are enumerated'/ a ' in the following review article:'/ b ' T. Turanyi, J.Mat.Chem.,5,203-248(1990) ') 205 format(//' Flame velocity sensitivities', 1 ' with respect to rate coefficients:'/ 2 ' (normalized values)'//) 206 format(//5x,' Sensitivity of the calculated temperature '/ 1 5x,' on rate coefficients'/) 207 format(//5x,' All sensitivities are zero '/) return end c c---------------------------------------------------------------------- c mode 5 : sensitivity of group of species c subroutine seng(lout,kk,ii,nseng,kseng,ip,s,a,b,d,kname,rname, 1 comments) c implicit double precision (a-h, o-z), integer (i-n) dimension ip(ii),kseng(nseng) dimension s(kk+1,ii),a(ii),b(ii),d(ii) character*(*) kname(kk), rname(ii) logical comments write(lout,200) (kname(kseng(k)),k=1,nseng) write(lout,204) c c bringing T to the 1st place c do 2 k=1,nseng if (kseng(k).eq.kk+1) then kseng(k)= 1 else kseng(k)= kseng(k)+1 endif 2 continue c do 1 i=1,ii a(i)= 0. do 1 k=1,nseng 1 a(i)= a(i) + s(kseng(k),i)*s(kseng(k),i) call order(ii,ip,a,b,d) do 3 i=1,ii if (dabs(b(i)) .lt. 1.D-3*dabs(b(1)) ) goto 4 if( dabs(b(i)).lt.1.D-50 .and. i.eq.1) then write(lout,205) goto 4 endif write(lout,202) i,b(i),ip(i),rname(ip(i)) 3 continue 4 continue c if (comments) write(lout,203) c c formats c 200 format (//' === SENG ==================================='///5x, 1 ' Overall sensitivity study for the following species: '// 2 100(2x,4a16/)) 202 format(5x,i5,1pe15.5,i5,3x,a40) 203 format(// 1 ' The overall concentration sensitivities measure the '/ 2 ' effectiveness of parameter changes on the concentration '/ 3 ' of a group of species. This information can be used '/ 4 ' to understand which parameters have to be known better '/ 5 ' for a more precise calculation of the concentration of '/ 6 ' a group of species.'/ 7 ' Listing is ceased after 3 orders of magnitude.'// 8 ' Overall sensitivities were introduced in'/ 9 ' Vajda et al, Int.J.Chem.Kinet.,17,55-81(1985)'/ a ' An alternative source is the following review '/ b ' on sensitivity analysis:'/ c ' T. Turanyi, J.Mat.Chem.,5,203-248(1990) ') 204 format(//9x,'No',3x,'overall sens. # reaction'/) 205 format(//5x,' All overall sensitivities are zero '/) return end c c------------------------------------------------------------------ c mode 6 search for rate limiting steps c subroutine rali(lout,kk,ii,leniwk,lenrwk,ickwrk,rckwrk, 1 t,c,s,wdot,cv,wdotv,e,sdot,q,b,nrali,krali,nuki,ip, 2 kname,rname,comments,rvers) implicit double precision (a-h, o-z), integer (i-n) dimension s(kk+1,ii),c(kk),cv(kk),wdot(kk),wdotv(kk),e(kk,kk) dimension rckwrk(lenrwk),sdot(ii),q(ii),b(ii) dimension ickwrk(leniwk),krali(nrali),nuki(kk,ii),ip(ii) character*(*) kname(kk),rname(ii) logical comments c if (rvers.lt.3.2999) then call strt1(IcNS,NcKF) else call strt2(IcNS,NcKF) endif c c numerical calculation of the Jacobian c rtol= 1.0001 atol= 1.E-30 c call ckwc (t,c,ickwrk,rckwrk,wdot) do 1 j=1,kk do 2 i=1,kk 2 cv(i)= c(i) cv(j)= c(j)*rtol+atol call ckwc (t,cv,ickwrk,rckwrk,wdotv) do 3 i=1,kk 3 e(i,j)= (wdot(i)-wdotv(i))/(c(j)-cv(j)) 1 continue c write(lout,200) c call cknu(kk,ickwrk,rckwrk,nuki) call ckqc(t,c,ickwrk,rckwrk,q) c do 4 ir=1,nrali i= krali(ir) write(lout,201) kname(i) do 5 j=1,ii sdot(j)= 0. if (rckwrk(NcKF+j-1).lt.1.d-30) goto 5 do 6 k=1,kk if (dabs(e(i,k)).lt.1.D-50) goto 6 sdot(j)= sdot(j) + e(i,k)*s(k+1,j)/rckwrk(NcKF+j-1)*c(k) 6 continue sdot(j)= sdot(j) + dble(nuki(i,j))*q(j)/rckwrk(NcKF+j-1) 5 continue c c normalization of dS/dt c do 8 j=1,ii if (wdot(i).lt.1.d-30) goto 8 sdot(j)= sdot(j)*rckwrk(NcKF+j-1)/wdot(i) 8 continue c call order(ii,ip,sdot,b,q) do 7 j=1,10 write(lout,202) j,b(j),ip(j),rname(ip(j)) 7 continue 4 continue c if (comments) write(lout,204) c 200 format (//' === RALI =================================='/// 1 5x,'Search for rate limiting steps'//) 201 format(//5x, 1 'Rate limiting steps of the production rate of species ',a16/ 2 5x,' (list of the top 10 reactions) '/) 202 format(5x,i5,1pe15.5,i5,3x,a40) 204 format(// 1 ' The usual way for the identification of rate limiting steps'/ 2 ' was finding an appropriate analytical expression for'/ 3 ' production rates. This method is not applicable in the case'/ 4 ' of large reaction mechanisms. It has been shown (see Turanyi,'/ 5 ' J.Math.Chem,5,203-248(1990), p.239) that identification of',/ 6 ' rate limiting steps on the basis of the time'/ 7 ' derivative of the concentration sensitivity matrix'/ 8 ' is in agreement with the classical definition and'/ 9 ' yet can be applied to mechanisms of any size.'//) return end c c--------------------------------------------------------------- c mode 7: Importance of reactions based on overall F elements c subroutine rimp(lout,kk,ii,nt,it,leniwk,lenrwk,ickwrk, 1 rckwrk,imp,nuki,ip,treac,t,c,wdot,q,a,b,d,rname,comments) c c implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),nuki(kk,ii),imp(ii,nt),ip(ii) dimension rckwrk(lenrwk),c(kk),wdot(kk),q(ii),a(ii),b(ii),d(ii) character*(*) rname(ii) logical comments c c generation of nuki,q, and wdot c c nuki net stoichiometric matrix c q rates of reactions (mole/(cm3**3*sec)) c wdot molar production rates c call cknu(kk,ickwrk,rckwrk,nuki) call ckqc(t,c,ickwrk,rckwrk,q) call ckwc(t,c,ickwrk,rckwrk,wdot) c do 1 i=1,ii a(i)= 0. do 1 k=1,kk if (dabs(wdot(k)).lt.1.d-100) goto 1 fki= dble(nuki(k,i))*q(i)/wdot(k) a(i)= a(i) +fki*fki 1 continue c call order(ii,ip,a,b,d) c write(lout,200) do 3 i=1,ii if( b(i) .lt. treac*0.001 ) goto 3 write(lout,202) i,b(i),ip(i),rname(ip(i)) 3 continue c do 4 i=1,ii imp(i,it)= 0 if(a(i).gt.treac) imp(i,it)= 1 4 continue c if (comments) write(lout,203) c 200 format (//' === RIMP ==================================='/// 1 5x,' Importance of reactions: '//) 202 format(5x,i5,1pe15.5,i5,2x,a40) 203 format(// 1 ' Assessment of the importance of reactions based on '/ 2 ' overall rate sensitivities. See eq. (22) in '/ 3 ' Turanyi et al, Int.J.Chem.Kinet.,21,83-99(1989)'//) c return end c c--------------------------------------------------------------- c mode 8: PCA of F c subroutine pcaf(lout,kk,ii,nt,it,leniwk,lenrwk, 1 ickwrk,rckwrk,imp,nuki,ip,maxfon,ifon,maxf, 2 nthf,thf,t,c,wdot,q,b,fTf,e,rname,comments) c implicit double precision (a-h, o-z), integer (i-n) parameter (lenistr=40) dimension ickwrk(leniwk),nuki(kk,ii),imp(ii,nt),ip(ii) dimension rckwrk(lenrwk),c(kk),wdot(kk),q(ii),b(ii) dimension fTf(ii,ii), ifon(ii,maxfon), e(ii), thf(2,maxf) character*(*) rname(ii) character*(lenistr) istr logical comments c c setting printing thresholds c c c tevapr eigenvalue printing threshold c tevepr eigenvector printing threshold c tevapr= 1.D-1 tevepr= 0.2 c do 16 is=1,nthf if (thf(1,is).lt.tevapr) tevapr=thf(1,is) if (thf(2,is).lt.tevepr) tevepr=thf(2,is) 16 continue tevapr= tevapr/10000 tevepr= tevepr/10 c c generation of nuki,q, and wdot c c nuki net stoichiometric matrix c q rates of reactions (mole/(cm3**3*sec)) c wdot molar production rates c call cknu(kk,ickwrk,rckwrk,nuki) call ckqc(t,c,ickwrk,rckwrk,q) call ckwc(t,c,ickwrk,rckwrk,wdot) c do 1 i=1,ii do 1 j=1,i fTf(i,j)= 0. do 1 k=1,kk if (dabs(wdot(k)).lt.1.d-100) goto 1 fki= dble(nuki(k,i))*q(i)/wdot(k) fkj= dble(nuki(k,j))*q(j)/wdot(k) fTf(i,j)= fTf(i,j) + fki*fkj 1 continue c c evaluation of eigenvectors and eigenvalues by c the SDIAG2 routine c call sdiag2(ii,ii,fTf,q,e) c note : rank of fTf matrix.le.nsr nsr= min0(ii,kk) c c the principal components c write(lout,200) do 5 i=1,nsr if(q(i).lt.tevapr) goto 5 write(lout,201) i,q(i) call order (ii,ip,fTf(1,i),b,e) do 4 j=1,ii if(dabs(b(j)).lt.tevepr) goto 4 write(lout,202) j,b(j),ip(j),rname(ip(j)) 4 continue 5 continue c c choosing the thresholds for mechanism reduction c write(lout,210) 15 continue do 14 is=1,nthf taf= thf(1,is) tef= thf(2,is) do 7 i=1,ii imp(i,it)= 0 do 7 j=1,maxfon 7 ifon(i,j)= 0 c do 10 i=1,nsr if(q(i).lt.taf) goto 11 do 9 j=1,ii if(dabs(fTf(j,i)).lt.tef) goto 9 imp(j,it) = imp(j,it) + 1 if (imp(j,it).gt.maxfon) goto 9 ifon(j,imp(j,it)) = i 9 continue 10 continue 11 write(lout,205) taf,tef do 12 i=1,ii c istr= rname(i) if(imp(i,it).eq.0) then write(lout,206) i,istr(:20) else write(lout,206) i,istr(:20),(ifon(i,j),j=1,imp(i,it)) endif 12 continue c 14 continue c if (comments) write(lout,209) c c formats c 100 format (1a1) 101 format (f20.0) 200 format (//' === PCAF ==================================='///5x, 1 'Principal component analysis of the rate sensitivity matrix:' 2 //) 201 format(//3x,'No',i4,' eigenvalue :',1pe15.5/9x,' eigenvector :'/) 202 format(5x,i5,1pe15.5,i5,2x,a40) 203 format (//' You may change the threshold value for ' 1 ,'eigenvalues. '/' The old value is:',1pe15.3/ 2 ' Type new value: ') 204 format (//' You may change the threshold value for ' 1 ,'eigenvectors. '/' The old value is:',f10.3/ 2 ' Type new value: ') 205 format(/' --------------------------------------------------'/ 1 /2x,' Threshold value for eigenvalues : ',1pe15.3, 2 /2x,' Threshold value for eigenvectors :',0pf12.3// 3 /6x,' reactions',16x,'reaction groups') 206 format(1x,i5,1x,a20,3x,20i3,5(/30x,20i3)) 207 format (//' Another cut ? y / n') 209 format(// 1 ' The numbers after the reactions show', 2 ' which reaction groups'/ 3 ' (revealed by the eigenvalue-eigenvector analysis)'/ 4 ' the reaction is a member of. The indicated'/ 5 ' reaction groups are characterized by high eigenvalues'/ 6 ' (i.e. higher than the threshold for eigenvalues).'/ 7 ' Only reactions, having high weight in a reaction group'/ 8 ' (i.e. higher than the threshold for eigenvector '/ 9 ' elements) are indicated.'// a ' Assessment of the importance of reactions based on '/ b ' the principal component analysis of matrix F'/ c ' see Turanyi et al., Int.J.Chem.Kinet.,21,83-99(1989)'//) 210 format(//2x,' Relation of reaction groups to reactions'//) c return end c c---------------------------------------------------------------------- c mode 9 : ROPA detailed c c Rate-of-production analysis c subroutine ropad(lout,ii,kk,nt,it,leniwk,lenrwk, 1 ickwrk,rckwrk,imp,ip,tropa,tdlim,t,c,wdot,q,cik,b,d, 2 kname,rname,comments) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),imp(ii,nt),ip(ii) dimension rckwrk(lenrwk),c(kk),wdot(kk),q(ii),cik(ii),b(ii),d(ii) character*(*) kname(kk),rname(ii) logical comments c call ckqc(t,c,ickwrk,rckwrk,q) call ckwc (t,c,ickwrk,rckwrk,wdot) c write(lout,200) do 1 k=1,kk c c cik: contributions of the reactions to the molar production c rate of the k-th species (vector of ii elements) c call ckcont(k,q,ickwrk,rckwrk,cik) c cikp= 0. cikc= 0. c do 2 i=1,ii if (cik(i).gt.0.) then cikp=cikp+cik(i) else cikc=cikc+cik(i) endif 2 continue write(lout,201) kname(k),wdot(k) call order(ii,ip,cik,b,d) do 3 i=1,ii if(dabs(b(i)).gt.tropa/100.*dabs(b(1)) ) imp(ip(i),it)=1 if( dabs(b(i))*tdlim .lt. dabs(b(1)) ) goto 1 if (dabs(b(1)).lt.1.d-50) then write(lout,204) goto 1 endif if (b(i).gt.0.) then pp= 100.*b(i)/cikp write(lout,202) i,b(i),pp,'%P',ip(i),rname(ip(i)) else pp= 100.*b(i)/cikc write(lout,202) i,b(i),pp,'%C',ip(i),rname(ip(i)) endif 3 continue 1 continue if (comments) write(lout,205) tdlim,tropa c 200 format (//' === ROPAD =================================='/// 1 5x,'Rate-of-production analysis - detailed printout '//) 201 format (/1x,a16,' Rate : ',1pe12.3/ 1 5x,' No Contribution # reaction '/) 202 format(5x,i5,1pe15.5,0pf7.1,1x,a2,i5,2x,a40) 204 format(5x,' --- No significant contribution ---') 205 format(// * ' Contribution of reaction steps to the'/ * ' rate of production of species.'/ * ' The least still listed contribution is greater than'/ * ' 1/TDLIM of the most significant contribution.'/ * ' A reaction is considered significant if its contribution'/ * ' to the production rate of a species is higher than TROPA %'/ * ' of the highest contribution (absolute values).'/ * ' TDLIM and TROPA can be redefined in the control file.'/ * ' Currently TDLIM=',f7.1,' and TROPA=',f7.1,'%.'/ * ' %P indicates the share of reaction', * ' among the production steps'/ * ' %C indicates the share of reaction', * ' among the consumption steps') c return end c---------------------------------------------------------------------- c mode 10: ROPA brief c c Rate-of-production analysis c c The rate-of-production information is provided in c an abbreviated form: c c - The numbers of producing reactions are before the c slash (/), the numbers of consuming reactions are c after the slash. c - Both the producing and consuming reactions are in c descending order of magnitude. c - Reactions, having contribution less than 1/3 but c greater than 1/10 than that of the greatest c consuming/producing reactions, are given in parentheses. c - Reactions, having contribution less than 1/10 than c that of the greatest consuming/producing reactions, c are omitted. c - All the consuming reactions are omitted, if the c contribution of the greatest consuming reaction is less c than 1/100 than that of the greatest producing reaction. c All the producing reactions are omitted, if the c contribution of the greatest producing reaction is less c than 1/100 than that of the greatest consuming reaction. c c These limits (tblim1= 3., tblim2= 10., tblim3= 100.) c can be redefined in the CONTROL data file. c subroutine ropab(lout,ii,kk,nt,it,leniwk,lenrwk, 1 ickwrk,rckwrk,imp,ip,tropa,tblim1,tblim2,tblim3,t,c,wdot,q, 2 cik,b,d,kname,comments) implicit double precision (a-h, o-z), integer (i-n) parameter (lenstr=10) dimension ickwrk(leniwk),imp(ii,nt),ip(ii) dimension rckwrk(lenrwk),c(kk),wdot(kk),q(ii),cik(ii),b(ii),d(ii) dimension itv1(100),itv2(100),ifv1(100),ifv2(100) character*(*) kname(kk) character*(lenstr) str character*80 line logical kerr,comments c write(lout,200) c call ckqc(t,c,ickwrk,rckwrk,q) call ckwc(t,c,ickwrk,rckwrk,wdot) c do 1 k=1,kk c c cik: contributions of the reactions to the molar production c rate of the k-th species (vector of ii elements) c call ckcont(k,q,ickwrk,rckwrk,cik) c call order (ii,ip,cik,b,d) if (dabs(b(1)).lt.1.d-50) then line= ' '//kname(k)//'--- No significant reaction ---' write(lout,202) line goto 1 endif do 2 i=1,ii 2 if(dabs(cik(i)).gt.tropa/100.*dabs(b(1)) ) imp(i,it)=1 c irp= 0 irm= 0 if1= 0 if2= 0 it1= 0 it2= 0 if (b(1)) 10, 20, 20 10 irm= 1 do 11 j=2,ii 11 if (b(j).gt.0.) goto 12 goto 30 12 fmax= b(1) tmax= b(j) if (tmax*tblim3.gt.-fmax) irp=1 goto 30 c 20 irp=1 do 21 j=2,ii 21 if (b(j).lt.0.) goto 22 goto 30 22 tmax= b(1) fmax= b(j) if (-fmax*tblim3.gt.tmax) irm=1 c 30 do 52 j=1,min(20,ii) if (dabs(b(j)).lt.1.d-50) b(j)= 0. if (b(j)) 31, 52, 40 31 if (b(j)*tblim1.lt.fmax) then if1= if1+1 ifv1(if1)= ip(j) elseif (b(j)*tblim2.lt.fmax) then if2= if2+1 ifv2(if2)= ip(j) endif goto 52 40 if (b(j)*tblim1.gt.tmax) then it1= it1+1 itv1(it1)= ip(j) elseif (b(j)*tblim2.gt.tmax) then it2= it2+1 itv2(it2)= ip(j) endif 52 continue c if (irm.eq.0) then if1=0 if2=0 endif if (irp.eq.0) then it1=0 it2=0 endif c c generation of the string c line= ' ' // kname(k) c do 60 j=1,it1 call cki2ch(itv1(j),str,ls,kerr) if (kerr) then write(lout,201) ls,lenstr return endif ilen = max(12,ipplen(line) +1) line(ilen+1:ilen+ls)= str(1:ls) 60 continue c if (it2.gt.0) then ilen = ipplen(line) +1 line = line(:ilen) // '(' do 61 j=1,it2 call cki2ch(itv2(j),str,ls,kerr) if (kerr) then write(lout,201) ls,lenstr return endif ilen = ipplen(line) +1 line= line(:ilen) // str(:ls) 61 continue ilen = ipplen(line) +1 line = line(:ilen) // ')' endif c ilen = max(12,ipplen(line)) line = line(:ilen) // ' / ' c do 62 j=1,if1 call cki2ch(ifv1(j),str,ls,kerr) if (kerr) then write(lout,201) ls,lenstr return endif ilen = ipplen(line) +1 line(ilen+1:ilen+ls)= str(1:ls) 62 continue c if (if2.gt.0) then ilen = ipplen(line) line = line(:ilen) // ' (' do 63 j=1,if2 call cki2ch(ifv2(j),str,ls,kerr) if (kerr) then write(lout,201) ls,lenstr return endif ilen = ipplen(line) +1 line(ilen+1:ilen+ls)= str(1:ls) 63 continue ilen = ipplen(line) line = line(:ilen) // ') ' endif c write(lout,202) line c 50 continue 1 continue c if(comments) write(lout,203) if(comments) write(lout,204) tblim1,tblim2,tblim3,tropa return c 200 format (//' === ROPAB =================================='/// 1 5x,'Rate-of-production analysis - brief printout '//) 201 format(/' CKI2CH error in subroutine ROPAB '/ 1 ' required length: ',i5/ 2 ' current length: ',i5/ 3 ' quit from the subroutine '//) 202 format(a80) 203 format(/// *' Contribution of reaction steps to the', *' rate of production of species.'/ *' The rate-of-production information is provided in', *' an abbreviated form:'// *'- The numbers of producing reactions are before the'/ *' slash (/), the numbers of consuming reactions are'/ *' after the slash.'/ *'- Both the producing and consuming reactions are in'/ *' descending order of magnitude.'/ *'- Reactions, having contribution less than 1/TBLIM1 but'/ *' greater than 1/TBLIM2 than that of the greatest '/ *' consuming/producing reactions, are given in parentheses.'/ *'- Reactions, having contribution less than 1/TBLIM2 than '/ *' that of the greatest consuming/producing reactions,'/ *' are omitted.') 204 format( *'- All the consuming reactions are omitted, if the '/ *' contribution of the greatest consuming reaction is less'/ *' than 1/TBLIM3 than that of the greatest producing reaction.'/ *' All the producing reactions are omitted, if the '/ *' contribution of the greatest producing reaction is less'/ *' than 1/TBLIM3 than that of the greatest consuming reaction.'// *' A reaction is considered significant if its contribution'/ *' to the production rate of a species is higher than TROPA %'/ *' of the highest contribution (absolute values).'/ *' These limits (TBLIM1=',f5.1,', TBLIM2= ',f5.1,', TBLIM3= ' * ,f5.1,', and TROPA= ',f5.1,')'/ *' can be redefined in the control file.'///) c end c------------------------------------------------------------------------ c mode 11: fluxes of elements c subroutine atomflow (lout,mm,kk,ii,leniwk,lenrwk,lencwk, 1 ickwrk,rckwrk,cckwrk,natom,katom,ncf,nuki,t,c,af,q,cont,rname, 2 comments) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),katom(natom),ncf(mm,kk),nuki(kk,ii) dimension rckwrk(lenrwk),c(kk),af(kk,kk),q(ii),cont(ii) character*(*) cckwrk(lencwk),rname(ii) character ch*5, line*80, istr*80 logical comments, kerr write(lout,200) 200 format (//' === ATOMFLOW ==============================='//5x, 1 ' Fluxes of elements from species to species'//) c c q(i) rate of reaction i c af(k1,k2) element flux from species k1 to species k2 c call ckqc(t,c,ickwrk,rckwrk,q) call ckncf(mm,ickwrk,rckwrk,ncf) c do 1 im=1,natom m= katom(im) c c reading the stoichiometric matrix c call cknu(kk,ickwrk,rckwrk,nuki) c c conversion of species stoichiometries c to element stoichiometries c do 2 i=1,ii do 2 k1=1,kk nuki(k1,i)=nuki(k1,i)*ncf(m,k1) do 2 k2=1,kk af(k1,k2)= 0. 2 continue c do 3 i=1,ii c c calculation of the sum of atoms on the left hand side c nnu= 0 do 4 k=1,kk if (nuki(k,i).lt.0) then nnu= nnu+nuki(k,i) endif 4 continue c c calculation of net element fluxes c do 5 k1=1,kk if (nuki(k1,i).ge.0) goto 5 do 6 k2=1,kk if (nuki(k2,i).le.0) goto 6 rnnu= nnu rnuk1= nuki(k1,i) rnuk2= nuki(k2,i) af(k1,k2)= af(k1,k2)+rnuk1/rnnu*rnuk2*q(i) 6 continue 5 continue 3 continue c c printing the fluxes in decreasing order c write(lout,201) cckwrk(m)(:2) 201 format(//' Net fluxes of element ',a2,22x,'absolute',25x,'rel.'/) nprint= (kk*kk-kk)/2 do 8 kp=1,nprint amax= -1. do 7 k1=1,kk do 7 k2=1,kk if (af(k1,k2).ge.amax) then amax= af(k1,k2) k1max= k1 k2max= k2 endif 7 continue af(k1max,k2max)= -af(k1max,k2max) if (kp.eq.1) then if (amax.lt.1.D-30) then write(lout,205) 205 format(' No significant flux') goto 8 else amax1= amax endif endif if (amax.lt.1.D-30) goto 8 write(lout,202) 1 kp,cckwrk(mm+k1max),cckwrk(mm+k2max),amax,amax/amax1 202 format(i6,2x,a16,' => ',a16,1pe12.3,' mole/(cm3 sec) ',5x,0pf7.4) c c calculation of the contributions c do 20 i=1,ii cont(i)= 0. if (nuki(k1max,i).ge.0) goto 20 if (nuki(k2max,i).le.0) goto 20 c nnu= 0 do 21 k=1,kk if (nuki(k,i).lt.0) then nnu= nnu+nuki(k,i) endif 21 continue c rnnu= nnu rnuk1= nuki(k1max,i) rnuk2= nuki(k2max,i) cont(i)= rnuk1/rnnu*rnuk2*q(i)/amax*100. 20 continue c line= ' ' do 22 ip=1,3 cmax= -1. do 23 ip1=1,ii if (cont(ip1).ge.cmax) then cmax= cont(ip1) ipmax= ip1 endif 23 continue cont(ipmax)= -1. if (cmax.lt.0.01) goto 25 istr= rname(ipmax) if (cmax.gt.99.995) then ch= '100.0' lch= 5 else call r2ch(cmax,ch,lch,kerr) if (kerr) goto 8 endif ila= ilasch(line)+2 ilr= ilasch(istr) line= line(:ila)//istr(:ilr)//' '//ch(:lch)//'% ' if (ilasch(line).gt.70) goto 25 22 continue 25 write(lout,206) line 206 format(/6x,a74//) c c 8 continue c c calculation of corrected element fluxes c do 9 k1=1,kk do 9 k2=1,k1 9 af(k1,k2)= af(k1,k2)-af(k2,k1) do 10 k1=1,kk do 10 k2=1,k1 10 af(k2,k1)= - af(k1,k2) c c printing the fluxes in decreasing order c write(lout,203) cckwrk(m)(:2) 203 format(//' Corrected fluxes of element ',a2, 1 16x,'absolute',25x,'rel.'/) nprint= (kk*kk-kk)/2 do 11 kp=1,nprint amax= -1. do 12 k1=1,kk do 12 k2=1,kk if (af(k1,k2).ge.amax) then amax= af(k1,k2) k1max= k1 k2max= k2 endif 12 continue af(k1max,k2max)= -af(k1max,k2max) if (kp.eq.1) then if (amax.lt.1.D-30) then write(lout,205) goto 11 else amax1= amax endif endif if (amax.lt.1.D-50) goto 11 write(lout,202) 1 kp,cckwrk(mm+k2max),cckwrk(mm+k1max),amax,amax/amax1 11 continue 1 continue c c comments c if (comments) write(lout,204) if (comments) write(lout,207) c 204 format(//5x, 1 'Example for the calculation of net element fluxes:'//5x, 2 ' CH3 + C3H7 => C4H8 + H2 rate= r1'/5x, 3 'H atom stoichiometry: 3 7 8 2'/5x, 4 'sum of H atoms on the left hand side: 10 '/5x, 5 'H element fluxes in this reaction step:'//5x, 6 'CH3 => C3H7 0'/5x, 7 'CH3 => C4H8 3/10*8*r1 = 2.4*r1'/5x, 8 'CH3 => H2 3/10*2*r1 = 0.6*r1'/5x, 9 'C3H7 => CH3 0'/5x, a 'C3H7 => C4H8 7/10*8*r1 = 5.6*r1'/5x, b 'C3H7 => H2 7/10*2*r1 = 1.4*r1'//5x, c 'The calculated net fluxes are sum of fluxes calculated'/5x, d 'in each reaction step'///5x, e 'Example for the calculation of corrected fluxes:'//5x, f 'A => B net flux= R'/5x, g 'B => A net flux= r (r B corrected flux= R-r') 207 format(//5x, 1 'For a nice application of element', 2 ' fluxes see the following paper:' 3 /5x,'Revel J, Boettner JC, Cathonnet M, Bachman JS'/5x, 4 'Derivation of a global chemical kinetic mechanism '/5x, 5 'for methane ignition and combustion'/5x, 6 'J.Chim.Phys., 91,365-382(1994)'//) c return end c c------------------------------------------------------------------------ c mode 12: interaction of species c subroutine connect (lout,kk,leniwk,lenrwk,ickwrk,rckwrk, 1 t,c,wdot,cv,wdotv,e,b,bb,ncore,kcore,ifn,iny,ip,kname, 2 comments) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),kcore(ncore),ifn(kk),iny(kk),ip(kk) dimension rckwrk(lenrwk),c(kk),wdot(kk),cv(kk),wdotv(kk) dimension e(kk,kk),b(kk),bb(kk) character*(*) kname(kk) character*1 cm(2) logical comments c cm(1)=' ' cm(2)='*' c do 1 i=1,kk 1 ifn(i)= 0 do 2 i=1,ncore ifn(kcore(i))= 1 iny(i)= kcore(i) 2 continue nfound= ncore c c numerical calculation of the Jacobian c rtol= 1.0001 atol= 1.E-30 c call ckwc (t,c,ickwrk,rckwrk,wdot) do 3 j=1,kk do 4 i=1,kk 4 cv(i)= c(i) cv(j)= c(j)*rtol+atol call ckwc (t,cv,ickwrk,rckwrk,wdotv) do 5 i=1,kk 5 e(i,j)= (wdot(i)-wdotv(i))/(c(j)-cv(j)) 3 continue c write(lout,200) c c-----loop begins --------------------------------------------------- c do 100 icy=1,(kk-ncore) if (icy.eq.1) then write(lout,201)(kname(iny(i)),i=1,nfound) else write(lout,202) icy endif c sumb= 0. do 12 j=1,kk b(j)=0. do 6 i=1,nfound k= iny(i) if(dabs(wdot(k)).lt.1.d-100) goto 6 b(j)= b(j)+(e(k,j)*c(j)/wdot(k))**2 6 continue sumb= sumb +b(j) 12 continue c if (sumb.lt.1.d-50) then write(lout,203) goto 99 endif c call order(kk,ip,b,bb,cv) write(lout,204) (kname(iny(i)),i=1,nfound) write(lout,205) do 7 i=1,kk if (bb(i).lt.1.d-30) goto 7 bb(i)= dlog10(bb(i)) write(lout,206) i,kname(ip(i)),cm(ifn(ip(i))+1),bb(i) 7 continue c do 8 i=1,kk if(ifn(ip(i)).eq.0 ) then ifn(ip(i))=1 nfound= nfound+1 iny(nfound)= ip(i) goto 100 endif 8 continue c 100 continue c c-------------------------------------------------------------------- c 99 write(lout,207) if (comments) write(lout,208) c c 200 format 1 (//' === CONNECT ==================================='//5x, 2 ' Investigation of the connection of species'//) 201 format(' You are interested in how closely are the species'/ 1 ' connected kinetically to the core species below: '// 2 50(1x,4a16/)) 202 format(/// 1 ' Now let us add the highest ranked non-group member species'/ 2 ' to the group. (Calculation No',I3,') ') 203 format(/'No significant connection was found') 204 format(/' Effect of the perturbation', 1 ' of the concentration of each species'/ 2 ' on the rate of the following group of species (log units) :'// 3 50(1x,4a16/)) 205 format(/) 206 format(1x,i3,3x,a16,2x,a1,3x,f6.2) 207 format(///' No more species'//) 208 format(// 1 ' The above numbers, calculated from the normalized'/ 2 ' Jacobian, indicate the effectiveness of small changes'/ 3 ' in the concentration of each species on the production'/ 4 ' rates of the listed group of species. These numbers show'/ 5 ' the strengths of kinetic connections of each species'/ 6 ' to a group of species. The most closely connected species is'/ 7 ' then added to the group and these numbers are recalculated.'/ 8 ' In many cases after several such steps a large gap'/ 9 ' appears in the list of species connections. The species'/ a ' below the gap are not necessary species in a mechanism'/ b ' that describes the kinetic behaviour of the species,'/ c ' defined in the first step.'// d ' Literature: T. Turanyi, New.J.Chem., 14,795-803(1990)'//) c return end c c----------------------------------------------------------------------- c mode 13: lifetimes of species c subroutine lifetime(lout,kk,leniwk,lenrwk, 1 ickwrk,rckwrk,t,c,cdot,tau,b,ip,kname,comments,indata) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk), rckwrk(lenrwk) dimension c(kk),cdot(kk),tau(kk),b(kk),ip(kk) character*(*) kname(kk) logical comments c call ckctc (t,c,ickwrk,rckwrk,cdot,tau) call order(kk,ip,tau,b,cdot) write(lout,200) do 1 k=1,kk if (b(k).lt.1.d-100) goto 1 if (b(k).gt.1.d+200) then write(lout,201) k,kname(ip(k)) else write(lout,202) k,kname(ip(k)),b(k) endif 1 continue c if (comments) write(lout,203) if (comments .and. indata.eq.3) write(lout,204) if (comments .and. indata.eq.2) write(lout,205) if (comments .and. indata.eq.6) write(lout,205) if (comments .and. indata.eq.8) write(lout,204) c 200 format (//' === LIFETIME ==============================='//5x, 1 ' Chemical lifetime of species: (sec) '//) 201 format(2x,i3,'. ',a16, 1 ' --- No consuming reaction, infinite lifetime ---') 202 format(2x,i3,'. ',a16,1pe15.3) 203 format(//5x, 1 'Various interpretations of the lifetime of species and'/5x, 2 'their relation to the QSSA have been discussed', 3 ' in the following article:'/ 3 5x,'T.Turanyi, A.S. Tomlin, M.J. Pilling, '/ 4 5x,'J.Phys.Chem.,97,163-172(1993) /p.167/') 204 format(// 1 5x,'The above lifetimes are chemical lifetimes only.'/ 2 5x,'Lifetimes corrected with the residence time of the'/ 3 5x,'PSR reactor will be calculated in a later version of'/ 4 5x,'this program.'//) 205 format(// 1 5x,'The above lifetimes are chemical lifetimes only.'/ 2 5x,'Lifetimes corrected with diffusion of species'/ 3 5x,'will be calculated in a later version of'/ 4 5x,'this program.'//) return end c c------------------------------------------------------------------ c mode 14 QSSAS c subroutine qssas (lout,kk,leniwk,lenrwk,ickwrk,rckwrk, 1 t,c,cdot,tau,wdot,eqssa,b,ip,kname,comments,indata) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),ip(kk),wdot(kk),eqssa(kk) dimension c(kk),cdot(kk),tau(kk),b(kk),rckwrk(lenrwk) character*(*) kname(kk) logical comments c write(lout,200) call ckctc (t,c,ickwrk,rckwrk,cdot,tau) call ckwc (t,c,ickwrk,rckwrk,wdot) c eps= 1.0d-30 do 1 k=1,kk 1 eqssa(k)= - wdot(k)*tau(k)*100./(c(k)+eps) call order(kk,ip,eqssa,b,cdot) do 2 k=1,kk if (dabs(b(k)).lt.1.d-200) goto 2 if (tau(ip(k)).gt.1.d+200) then write(lout,201) k,kname(ip(k)) else write(lout,202) k,kname(ip(k)),b(k),b(k)*c(ip(k))/100. endif 2 continue c if (comments) write(lout,203) if (comments .and. indata.eq.3) write(lout,204) if (comments .and. indata.eq.2) write(lout,205) if (comments .and. indata.eq.6) write(lout,205) if (comments .and. indata.eq.8) write(lout,204) c 200 format (//' === QSSAS =================================='//5x, 1 ' Instantaneous QSSA error of single species : '// 2 ' relative error absolute error'//) 201 format(2x,i3,'. ',a16, 1 ' --- No consuming reaction, not a QSSA species ---') 202 format(2x,i3,'. ',a16,1pe12.3,' % ',1pe15.3,' mole/cm**3') 203 format(//5x, 1 'This section calculates the QSSA error of each species,'/5x, 2 'if a single species is handled as a QSSA species'/5x, 3 'during the calculation. For more details see:'/5x, 3 'T.Turanyi, A.S. Tomlin, M.J. Pilling, '/5x, 4 'J.Phys.Chem.,97,163-172(1993), equation (8)') 204 format(// 1 5x,'In case of PSR calculations the calculated QSSA'/ 2 5x,'errors seem to be too high. The reason is that the effect'/ 3 5x,'of mixing is not taken into account. An improved error'/ 4 5x,'calculation is expected to appear in a later version'/ 5 5x,'of KINALC.'//) 205 format(// 1 5x,'In case of flame calculations the calculated QSSA'/ 2 5x,'errors seem to be too high. The reason is that the effect'/ 3 5x,'of diffusion is not taken into account. An improved error'/ 4 5x,'calculation is expected to appear in a later version'/ 5 5x,'of KINALC.'//) c return end c c------------------------------------------------------------------ c mode 15 QSSAG c subroutine qssag (lout,kk,leniwk,lenrwk,ickwrk,rckwrk, 1 nqssag,kqssag,t,c,wdot,cv,wdotv,e,b,ip,kname,comments,indata) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),kqssag(nqssag),ip(nqssag) dimension rckwrk(lenrwk),c(kk),wdot(kk),cv(kk),wdotv(kk) dimension e(nqssag,nqssag),b(nqssag) character*(*) kname(kk) logical comments c write(lout,200) c c numerical generation of the J(22) minor matrix c rtol= 1.0001 atol= 1.E-30 c call ckwc (t,c,ickwrk,rckwrk,wdot) do 1 j=1,nqssag do 2 i=1,kk 2 cv(i)= c(i) cv(kqssag(j))= c(kqssag(j))*rtol+atol call ckwc (t,cv,ickwrk,rckwrk,wdotv) do 3 i=1,nqssag 3 e(i,j)= (wdot(kqssag(i))-wdotv(kqssag(i)))/ 1 (c(kqssag(j))- cv(kqssag(j))) 1 continue c do 4 i=1,nqssag 4 b(i)= wdot(kqssag(i)) call dec(nqssag,e,ip,ier) if (ier.ne.0) then write (lout,201) ier return endif call sol(nqssag,e,ip,b) do 5 k=1,nqssag if (dabs(b(k)).lt.1.d-200 .or. 1 dabs(b(k)).gt.1.d+200) then write(lout,202) k,kname(kqssag(k)) else erel= b(k)/c(kqssag(k))*100. write(lout,203) k,kname(kqssag(k)),erel,b(k) endif 5 continue c if (comments) write(lout,204) if (comments .and. indata.eq.3) write(lout,205) if (comments .and. indata.eq.2) write(lout,206) if (comments .and. indata.eq.6) write(lout,206) if (comments .and. indata.eq.8) write(lout,205) c 200 format (//' === QSSAG =================================='//5x, 1 ' Instantaneous QSSA error of a group of species : '// 2 ' relative error absolute error'//) 201 format(' DEC error No',i5,' in subroutine QSSAG '/ 2 ' Please try more realistic QSSA species', 3 ' based on QSSAS analysis'/ 4 ' --- quit from the subroutine --- '//) 202 format(2x,i3,'. ',a16, 1 ' --- Not a QSSA species ---') 203 format(2x,i3,'. ',a16,1pe12.3,' % ',1pe15.3,' mole/cm**3') 204 format(//5x, 1 'If the quasi-stationarity is assumed for a single species'/5x, 2 'in a simulation, its error can be assessed by option QSSAS.'/5x, 3 'However, in practical calculations QSSA is used for several'/5x, 4 'species simultaneously and the QSSA error of species'/5x, 5 'interact. The instantaneous QSSA error for a group of'/5x, 6 'species can be calculated using option QSSAG.'/5x, 7 'Select the QSSA species on the basis of QSSAS !'/5x, 8 'For more details see:'/5x, 3 'T.Turanyi, A.S. Tomlin, M.J. Pilling, '/5x, 4 'J.Phys.Chem.,97,163-172(1993), equation (7)') 205 format(// 1 5x,'In case of PSR calculations the calculated QSSA'/ 2 5x,'errors seem to be too high. The reason is that the effect'/ 3 5x,'of mixing is not taken into account. An improved error'/ 4 5x,'calculation is expected to appear in a later version'/ 5 5x,'of KINALC.'//) 206 format(// 1 5x,'In case of flame calculations the calculated QSSA'/ 2 5x,'errors seem to be too high. The reason is that the effect'/ 3 5x,'of diffusion is not taken into account. An improved error'/ 4 5x,'calculation is expected to appear in a later version'/ 5 5x,'of KINALC.'//) return end c c------------------------------------------------------------------ c mode 16 CSP Computational Singular Perturbation analysis c c The CSP block was written by: c c Christos Frouzakis c c Institute of Energy c Swiss Federal Institute of Technology c ETH-Zentrum c CH-8092 Zurich, Switzerland c Phone : (41-1) 632-7947 c Fax : (41-1) 632-1100 c E-mail : frouzakis@lvv.iet.mavt.ethz.ch c subroutine csp (lout,kk,ii,leniwk,lenrwk, 1 ickwrk,rckwrk,tlcsp,t,c,cv,wdot,wdotv,f, 2 wi,wr,Pr,Cpr,r,evals,e,evecr,evecl,Qp, 3 aub,PI,b,bb,d,ip,ispec1,ispec2,nuki, 4 kname,rname,comments) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),rckwrk(lenrwk) dimension c(kk),cv(kk),wdot(kk),wdotv(kk) dimension f(kk),wi(kk),wr(kk),Pr(kk),Cpr(kk) dimension r(ii),evals(kk),e(kk,kk),evecr(kk,kk),evecl(kk,kk) dimension Qp(kk,kk),aub(kk,ii),PI(kk,ii) dimension b(ii),bb(ii),d(ii),ip(ii) dimension ispec1(kk),ispec2(kk),nuki(kk,ii),iclass(6) character*(*) kname(kk),rname(ii) logical comments c write(lout,200) if (comments) write(lout,201) evfast= -1. / tlcsp fsline= 1. c c________________________________________________________ c c 1.0 BASIS VECTORS c________________________________________________________ c c 1.1 Compute the Jacobian (assuming homogeneous kinetics) c rtol= 1.00001 atol= 1.0d-30 c call ckwc (T,c,ickwrk,rckwrk,wdot) do 1 j=1,kk do 2 i=1,kk 2 cv(i)= c(i) cv(j)= c(j)*rtol+atol call ckwc (t,cv,ickwrk,rckwrk,wdotv) do 3 i=1,kk 3 e(i,j)= (wdot(i)-wdotv(i))/(c(j)-cv(j)) 1 continue c c................................................................ c 1.2 Compute, analyze and order the eigenvalues and c right- and left- eigenvectors c................................................................ c call eigen(e,evals,evecr,evecl,iclass,kk,wr,wi,ier) c if (ier.ne.0) then write(lout,210) return endif c write (lout,211) (iclass(i),i=2,6) if (comments) write (lout,202) c c.............................................. c mode amplitudes c.............................................. c do 4 i=1,kk f(i)=0.0d0 do 4 j=1,kk 4 f(i)=f(i)+evecl(i,j)*wdot(j) c c................................................................ c 1.3.a Find the number of exhausted modes by ensuring c the time-scale separation is larger than tsep c................................................................ c c M = 0 c tsep = 1.0d-3 c do 5 i=1,KK-MM c ratio= dabs(evals(i+1)/evals(i)) c if (ratio.le.tsep) then c M = i c else c goto 20 c endif c 5 continue c c................................................................ c 1.3.b Alternativelly, find the number of exhausted modes M c wrt some user specified thresholds of the contributions c of the modes in species concentrations: c a(i)*f(i)*tau(M+1) < Dy_i = atol + rtol*y_i c c NOTE: it can be proved that there should be at least MM c evalues equal to zero with corresponding left evectors c equal to the element composition vectors. So, these c MM modes are always dormant and correspond to c the element conservation laws. However, since c the Jacobian and the eigensolver are not exact, c the MM evalues can differ from 0. c c................................................................ c c M = 0 c atol=0.0 c rtol=1.0e-2 c c do 6 i=1,KK c tscale = 1/dabs(evals(i+1)) c icheck = 0 c do 7 j=1,kk c dc = atol + rtol*c(j) c cont = dabs(evecr(j,i)*f(i)*tscale) c7 if(cont .le. dc) icheck=icheck+1 c if (icheck.eq.KK) then c M = i c else c goto 20 c endif c6 continue c c................................................................ c 1.3.c Alternativelly, find the number of exhausted modes M c by comparing the contribution of each mode to the c total (which, by definition, is equal to wdot(i)): c If, for j=1, ..., M c a(i,j)*f(j) < atol + rtol*wdot(i), i=1,...,N, c then, c the M modes are exhausted c c................................................................ c c20 M = 0 c ND= 0 c atol=0.0 c rtol=1.0e-3 c c do 8 j=1,KK-MM c nexst=0 c do 9 i=1,KK c con = dabs(atol + rtol*wdot(i)) c dc = dabs(evecr(i,j)*f(j)) c9 if (dc .le. con) nexst=nexst+1 c if (nexst .eq. kk) then c M = i c else c goto 10 c endif c8 continue c c10 do 11 j=M+1,KK-MM c ndorm=0 c do 12 i=1,KK c con = dabs(atol + rtol**2.0*wdot(i)) c dc = dabs(evecr(i,j)*f(j)) c12 if (dc .le. con) ndorm=ndorm+1 c if (ndorm .eq. kk) ND = ND + 1 c11 continue c c write(lout,212) M, ND+MM, kk - M - ND c c212 format(5x,'(',i4,',',i4,',',i4,')', c & ' exhausted/dormant/active modes',/) c c________________________________________________________ c c 2.0 CSP ANALYSIS c________________________________________________________ c c........................................................ c 2.1 Radical pointer c c Row i of matrix Qp contains only the diagonal c elements of the projection matrix a_i*b^i c (corresponding to mode i), so that c Qp(i,j) = evecr(j,i)*evecl(i,j) c As a result, checking for the element closest to c unity should be done along the ROWS. c c........................................................ c do 21 i=1,kk ispec1(i)=0 21 ispec2(i)=0 c c diagonal elements of the projection matrices c stored in the rows of Qp c do 22 i=1,kk do 22 j=1,kk 22 Qp(i,j)=evecr(j,i)*evecl(i,j) write(lout,203) if (comments) write(lout,204) c c Projection to a SINGLE fast direction: c QSSA species pointed to by the largest c element in each row c do 58 IJ=1,KK c if (ij.lt.kk) fsline= (evals(IJ)-evfast)*(evals(IJ+1)-evfast) if (fsline.le.0.) write(lout,220) write(lout,214) IJ,evals(IJ) c do 51 j=1,KK 51 Pr(j) = Qp(IJ,j) c call order(KK, ispec1,Pr,b,d) c c Cumulative projection to the WHOLE fast subspace c (i.e. up to the current number M of modes): c sum of the diagonal elements of the c M fast modes = sum of the rows of Qp c c QSS species pointed to by the elements c of the pointer closer to one. c c Note: M = 1, projection to single fast dir. and c cumulative projection are the same c M = KK, cumulative projection for each species = 1 c do 25 j=1,kk Cpr(j)=0.0D0 do 26 i=1, IJ 26 Cpr(j) = Cpr(j) + Qp(i,j) Cpr(j) = 1.0 - Cpr(j) 25 continue c call order (KK,ispec2,Cpr,b,d) c write(lout,215) & (kname(ispec1(ik)),Pr(ispec1(ik)), & kname(ispec2(KK-ik+1)),1.0d0-Cpr(ispec2(KK-ik+1)), & ik=1,KK) c 58 continue c c c.................................................. c 2.2 PARTICIPATION INDEX c.................................................. c c 2.2.a B(n,r) = b_n . s_r c write(lout,205) if (comments) write(lout,206) call cknu (kk, ickwrk, rckwrk, nuki) do 29 i=1,kk do 28 j=1,II xx=0.0D0 do 27 k=1,kk xx=xx+evecl(i,k)*nuki(k,j) 27 continue aub(i,j)=xx 28 continue 29 continue c c 2.2.b index computation, ordering and result printout c c Note: only absolute numbers make sense, since c if evecr is an eigenvector, -evecr is c also an eigenvector c call ckqc(T, c, ickwrk, rckwrk, r) c do 30 i=1,kk c if (i.lt.kk) fsline= (evals(I)-evfast)*(evals(I+1)-evfast) if (fsline.le.0.) write(lout,220) do 31 j=1,II 31 PI(i,j)=aub(i,j)*r(j) sumPI=0.0D0 do 32 j=1,II 32 sumPI=sumPI+dabs(PI(i,j)) if (sumPI .gt. 0.0) then do 33 j=1,II 33 PI(i,j)=PI(i,j)/sumPI write(lout,216) i,evals(i),f(i) else write(lout,216) i,evals(i),f(i) write(lout,*) ' No participating reactions!' endif c c do 34 j=1,II 34 bb(j)=PI(i,j) call order(ii,ip,bb,b,d) c do 35 j=1,II if(dabs(b(j)).gt.0.005) & write(lout,217) dabs(b(j))*100,ip(j),rname(ip(j)) 35 continue 30 continue c c c.................................................... c 2.3 IMPORTANCE INDEX c.................................................... c write(lout,207) if (comments) write(lout,208) c c 2.3.a Projection matrices c c Projection matrix on the i-th fast component c (matrix product of the corresponding eigenvectors) c Qp(i) = Right_evector(i) X Left_evector(i) c c Fast subspace projection matrix (M=number of fast modes): c Qp(M) = Sum( Qp(i), i=1, M) c Slow subspace projection matrix (I=identity matrix): c Qp = I - Qp(M) c do 50 IJ = 1, KK write(lout,218) IJ do 36 i=1, KK do 36 j=1, KK Qp(i,j) = 0.0d0 do 37 k = 1, IJ 37 Qp(i,j) = Qp(i,j) - evecr(i,k)*evecl(k,j) 36 if (i.eq.j) Qp(i,j) = 1.0d0 + Qp(i,j) c c 2.3.b Effective stoichiometric matrix c AUB(n,r) = Qp(n,r) * s_r c do 38 i=1,kk do 39 j=1,II aub(i,j)=0.0D0 do 39 k=1,kk 39 aub(i,j)=aub(i,j)+Qp(i,k)*nuki(k,j) 38 continue c c 2.3.c Importance Index computation c ordering and result printout c do 40 i=1, KK write(lout,219) kname(i) do 41 j=1,II 41 PI(i,j)=aub(i,j)*r(j) sumPI=0.0D0 do 42 j=1,II 42 sumPI=sumPI+dabs(PI(i,j)) if (sumPI .gt. 0.0) then do 43 j=1,II 43 PI(i,j)=PI(i,j)/sumPI else write(lout,*) ' No participating reactions!' endif c do 44 j=1,II 44 bb(j)=PI(i,j) call order(ii,ip,bb,b,d) c do 45 j=1,II if(dabs(b(j)).gt.0.005) & write(lout,217) abs(b(j))*100,ip(j),rname(ip(j)) 45 continue 40 continue c 50 continue c if(comments) write(lout,209) return c 200 format (//' === CSP ========================================'//5x, & ' Computational Singular Perturbation (CSP) analysis'//) 201 format( & ' CSP employs the eigenvectors of the local Jacobian matrix'/ & ' to transform the right hand side of the ODEs of a spatially'/ & ' homogeneous reacting system to a sum of MODES (linear '/ & ' combinations of the original elementary reaction rates).'/ & ' The eigenvalues of the local Jacobian are used to rank'/ & ' the modes as FAST (those with large and negative '/ & ' eigenvalues), SLOW/ACTIVE (with smaller but still negative'/ & ' eigenvalues), DORMANT (eigenvalues close or equal to zero)'/ & ' or EXPLOSIVE (positive eigenvalues).') 202 format( & ' NOTE: Since zero eigenvalues point to element conservation', & ' laws,'/' there should be AT LEAST as many zero eigenvalues', & ' as elements.'//' Numerical computation, however, can give', & ' different results,'/' and results corresponding to small', & '-eigenvalue CSP modes'/' CANNOT be trusted.' ) 203 format(//' ---- Radical pointer ---- '//) 204 format( & ' For each mode assumed to be fast, the species with the '/ & ' higher single-mode projection is a candidate for a QSSA'/ & ' species. '/ & ' The cumulative projection (i.e. the projection to the fast'/ & ' subspace of up to the current number of mode) is also '/ & ' printed. The closer this comes to 1, the stronger the' / & ' candidacy of the equal number of species as a QSSA species.' & //) 205 format(//' ---- PARTICIPATION INDEX ----'//) 206 format( & ' The Participation Index identifies the elementary'/ & ' reactions that have the largest contribution in the'/ & ' value of each mode. The elementary reactions with the'/ & ' largest participation index FOR AN ACTIVE MODE are rate'/ & ' controlling for the same mode.'/ & ' Reactions with small participation index (at all points'/ & ' wher the analysis is performed) can be neglected from '/ & ' the reaction system.') 207 format(//' ---- IMPORTANCE INDEX ----'//) 208 format( & ' The Importance Index shows the relative importance of the'/ & ' elementary reaction to the evolution of the species'/ & ' concentration. So, elementary reactions with the largest'/ & ' importance indices FOR A SPECIES, are rate-determining.'/ & ' Ordering of the reactions may change when more species '/ & ' are assumed to be fast (i.e. at QSS).' ) 209 format( &//' Some CSP articles :'// &' Lam S.H., Goussis D.A.'/ &' Understanding complex chemical kinetics'/ &' with computational singular perturbation'/ &' 22nd Symp. Combust., 1988,931-941'// &' Goussis D.A., Lam S.H.'/ &' A study of homogeneous methanol oxidation kinetics using CSP'/ &' 24th Symposium on Combustion, 1992, pp.113-120'// &' Trevino C., Mendez F.R.'/ &' Reduced kinetic mechanism for methane ignition'/ &' 24th Symposium on Combustion, 1992, pp.121-127'// &' Lam S.H.'/ &' Using CSP to understand complex chemical kinetics'/ &' Combust.Sci.Technol., 89, 375-404(1993)'// &' Lam S.H., Goussis D.A.'/ &' The CSP method for simplifying kinetics'/ &' Int. J. Chem. Kin., 26, 461-486(1994)'//) 210 format(' CSP error: eigenvectors cannot be computed'/ 1 ' exit from the CSP module '//) 211 format(/ ' Summary of eigenvalues : '// & ' real unstable (ev>=0) : ',i4/ & ' complex stable (Re(ev)<0) : ',i4/ & ' complex unstable (Re(ev)>=0) : ',i4/ & ' real stable (ev<0) : ',i4/ & ' zero (ev<1.E-10) : ',i4//) 214 format(/ ' * Mode', i4,10x,'(Eigenvalue: ',1pe12.5,')'// & 13x,'--Single mode--',10x,'--Cumulative--') 215 format(5x,a10,1x,'(',f6.3,' )',5x,a10,1x,'(',f6.3,' )') 216 format(/' Mode ',i4,5x,' Eigenvalue: ',1pe12.5, 1 5x,'( Amplitude: ',1pe12.5,')'// 2 15x,' Contributing reactions: '/) 217 format(10x,f8.2,' % ',i5,3x,a40) 218 format(/,'*** For',i4,' species assumed at QSS:' ) 219 format(1x,a10) 220 format(// 1 ' ^^^^^^^^^^^^^^^^ FAST TIMESCALES ^^^^^^^^^^^^^^^^^^^^^'/ 2 ' ______________________________________________________'/ 3 ' '/ 3 ' vvvvvvvvvvvvvvvv SLOW TIMESCALES vvvvvvvvvvvvvvvvvvvvv'/) c end c c------------------------------------------------------------------ c mode 17 ILDM Intrinsic Low Dimensional Manifold analysis c subroutine ildm(lout,kk,mm,leniwk,lenrwk, 1 ickwrk,rckwrk,tlildm,p,t,c,xs,xsv,wdot,wdotv,f, 2 mqv,evals,e,evecr,evecl,kname,comments) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),rckwrk(lenrwk),c(kk) dimension xs(kk),xsv(kk),wdot(kk),wdotv(kk),f(kk),mqv(kk) dimension evals(kk),e(kk,kk),evecr(kk,kk),evecl(kk,kk) dimension iclass(6) character*(*) kname(kk) character*45 mintxt(8) logical comments c write(lout,200) c c-------------------------------------------------------------- c c conversion from T,p,c => h,p,Y/rho c c p: pressure in dynes/cm**2 c call ckcty(c,ickwrk,rckwrk,xs) call ckrhoc(p,t,c,ickwrk,rckwrk,rho) call ckhbms(t,xs,ickwrk,rckwrk,hbms) call ckcpbs(t,xs,ickwrk,rckwrk,cpbms) c c conversion to SI units c xhbms= hbms/1.D+4 xcpbms= cpbms/1.D+4 c write(lout,201) xhbms,xcpbms,xhbms/xcpbms,rho c c--------------------------------------------------------------- c c xs specific mole fractions - calculation and printout c do 9 i=1,kk 9 xs(i)= c(i)/rho write(lout,202) write(lout,203) (kname(k),xs(k),k=1,kk) write(lout,204) c c--------------------------------------------------------------- c c calculation of QTf c c c Compute the Jacobian c rtol= 1.001 atol= 1.0e-30 call wxs (kk,xs,wdot,f,evals,T,p,rho, 1 lenick,lenrck,ickwrk,rckwrk) do 1 j=1,kk do 2 i=1,kk 2 xsv(i)= xs(i) xsv(j)= xs(j)*rtol+atol call wxs (kk,xsv,wdotv,f,evals,T,p,rho, 1 lenick,lenrck,ickwrk,rckwrk) do 3 i=1,kk 3 e(i,j)= (wdot(i)-wdotv(i))/(xs(j)-xsv(j)) 1 continue c c Compute the eigenvalues and c right- and left- eigenvectors c call eigen(e,evals,evecr,evecl,iclass,kk,xsv,wdotv,ier) c here xsv and wdotv are work arrays c if (ier.ne.0) then write(lout,205) return endif c do 4 i=1,kk f(i)=0.0d0 do 4 j=1,kk f(i)=f(i)+evecl(i,j)*wdot(j) 4 continue c c c do 5 i=1,kk c write(lout,206) i, evals(i), f(i) c206 format(//' i= ', i5, ' eigenvalue = ',1pe15.5, c 1 ' ampl. = ',1pe10.3//) c write(lout,207) (evecl(i,j),j=1,kk) c207 format(5x,1pe12.5) c 5 continue c c----------------------------------------------------------------- c c sorting the modes c c the i-th mode is fast if ev(i) < xlimit xlimit= -1./tlildm c c the i-th mode is a conservation relation if |ev(i)| < zlimit zlimit= 1.D+00 c c the i-th mode is relaxed if |Qf| < flimit flimit= 1.D+00 c c mqv(i) c 1 conservation relation c 2 conservation relation, OFF the manifold ???? c 3 fast mode, relaxed c 4 fast mode, OFF the manifold c 5 slow mode, relaxed c 6 slow mode, OFF the manifold c 7 repulsive mode, on the manifold c 8 repulsive mode, OFF the manifold c mintxt(1)= 'conservation relation ' mintxt(2)= 'conservation relation, OFF the manifold ???' mintxt(3)= 'fast mode, relaxed ' mintxt(4)= 'fast mode, OFF the manifold ' mintxt(5)= 'slow mode, relaxed ' mintxt(6)= 'slow mode, OFF the manifold ' mintxt(7)= 'repulsive mode, on the manifold' mintxt(8)= 'repulsive mode, OFF the manifold' c nfz= 0 nzero= 0 nbigneg= 0 do 6 i=1,kk afo= dabs(f(i)) foi= f(i) aev= dabs(evals(i)) ev= evals(i) c c scaled amplitude c if(aev.lt.zlimit) then amp2= 0. else amp2= 10000*foi/aev endif afo= dabs(amp2) c if (afo.lt.flimit) nfz=nfz+1 if (aev.lt.zlimit) nzero=nzero+1 if ( ev.lt.xlimit) nbigneg=nbigneg+1 c if ( ev.lt.xlimit .and. afo.lt.flimit) mqv(i)= 3 if ( ev.lt.xlimit .and. afo.ge.flimit) mqv(i)= 4 if ( ev.ge.xlimit .and. afo.lt.flimit) mqv(i)= 5 if ( ev.ge.xlimit .and. afo.ge.flimit) mqv(i)= 6 if (aev.lt.zlimit .and. afo.lt.flimit) mqv(i)= 1 if (aev.lt.zlimit .and. afo.ge.flimit) mqv(i)= 2 if ( ev.ge.zlimit .and. afo.lt.flimit) mqv(i)= 7 if ( ev.ge.zlimit .and. afo.ge.flimit) mqv(i)= 8 write(lout,208) i,ev,amp2,mintxt(mqv(i)) 6 continue write(lout,209) nfz,flimit, 1 nzero,zlimit,mm,nbigneg,xlimit,kk-nfz if (comments) write(lout,210) if (comments) write(lout,211) c c--------------------------------------------------------- c c ndimm=0 c do 7 i=1,kk c if (dabs(f(i)).lt.flimit) goto 40 c ndimm=ndimm+1 c do 8 j=1,kk c vplane(ndimm,j)= evecl(i,j) c 8 continue c write(lout,210) ndimm c210 format(/' Direction #',i3) c write(lout,211) (kname(j),vplane(ndimm,j),j=1,kk) c211 format(5x,a16,1pe10.2,5x,a16,1pe10.2) c 7 continue c c---------------------------------------------------------- c c Compute projection matrix e c see: Maas, Pope, 25th symposium, 1349-1356(1994) c p.1355 c do 10 i=1,kk do 10 j=1,kk e(i,j)= 0. do 10 k=1,nbigneg e(i,j)= e(i,j)+evecr(i,k)*evecl(k,j) 10 continue c do 11 i=1,kk do 11 j=1,kk CrDel= 0. if (i.eq.j) CrDel= 1. e(i,j)= CrDel - e(i,j) 11 continue c write(lout,212) do 12 i=1,kk write(lout,214) kname(i), tlildm write(lout,215) (kname(j),e(j,i),j=1,kk) 12 continue c if (comments) write(lout,220) c c c return c c formats c 200 format (//' === ILDM ======================================'//5x, 1 'Intrinsic Low Dimensional Manifold analysis'//) 201 format( 1 ' enthalpy H = ',1pe12.3,' J/kg Cp =',1pe10.3,' J/(kg*K)'/ 2 ' H/Cp',9x,'=',0pf7.1,6x,' K',6x,'rho =',1pe10.3,' gm/cm3') 202 format(/' Specific mole fractions (Y/rho): '//) 203 format(5x,a16,1pe16.5,5x,a16,1pe16.5) 204 format(//) 205 format(' ILDM error: eigenvectors cannot be computed'/ 1 ' exit from the ILDM module '//) 208 format(' ',i5,' eigenvalue= ',1pe10.2, 1 ' amplitude = ',0pf10.2,2x,a45) 209 format(//' Summary:'// 1 ' No of trajectories on the manifold :',i3/ 2 ' (if FLIMIT=',1pe12.3,')'/ 3 ' No of conserved quantities :',i3/ 4 ' (if ZLIMIT=',1pe12.3,')'/ 4 ' (number of elements=',i2,')'/ 5 ' No of fast time scales :',i3/ 6 ' (if XLIMIT=',1pe12.3,')'// 7 ' => dimension of the manifold :',i3//) 210 format( 1 ' Dimension of the concentration space of kinetic systems is'/ 2 ' equal to the number of species. However, solution trajectories' 3/' tend to move on low dimensional shells for two reasons:'/ 4 ' - element conservation relations decrease the real dimension'/ 5 ' of the system.'/ 6 ' - as a consequence of the existence of very fast time scales'/ 7 ' trajectories quickly move to slow manifolds.') 211 format( 1 ' In the above tables "amplitude" shows a kind of distance of'/ 2 ' the trajectory from the nearest point on the manifold and'/ 3 ' "dimension of the manifold" is the dimension of the shell'/ 4 ' trajectory is on in the space of concentrations.'/ 5 ' Both numbers are rough approximations and'/ 6 ' for quick information only.'//) 212 format(// 1 ' PROJECTION MATRIX: a chemical interpretation'/) 214 format(// 1 ' Adding one unit of ',a16/ 2 ' changes in ',1pe10.3,' s the concentration of the'/ 3 ' SPECIES by UNITS'/) 215 format(1x,a16,f6.2) 220 format(// 1 ' Articles on Intrinsic Low Dimensional Manifolds'// 2 ' Maas U., Pope S.B.'/ 3 ' Simplifying chemical kinetics:'/ 4 ' intrinsic low-dimensional manifolds in composition space'/ 5 ' Combust.Flame, 88, 239-264(1992)'// 6 ' Maas U., Pope S.B.'/ 7 ' Implementation of simplified chemical kinetics'/ 8 ' based on intrinsic low-dimensional manifolds'/ 9 ' Proc. 24th Symp. (Int.) Combust., pp. 103-112(1992)'// 1 ' Maas U., Pope S.B.'/ 2 ' Laminar flame calculations using simplified chemical kinetics'/ 3 ' based on intrinsic low-dimensional manifolds'/ 4 ' Proc. 25th Symp. (Int.) Combust., pp. 1349-1356(1994)'// 5 ' Schmidt D., Maas U., Segatz J., Riedel U. Warnatz J.'/ 6 ' Simulation of laminar methane-air flames using'/ 7 ' automatically simplified chemical kinetics'/ 8 ' Comb.Sci.Tech., in press'//) end c c rate calculation for subroutine ILDM c subroutine wxs (kk,xs,wdot,cwdot,y,T,p,rho, 1 lenick,lenrck,ickwrk,rckwrk) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(lenick),rckwrk(lenrck) dimension xs(kk),wdot(kk),y(kk),cwdot(kk) c call ckwt(ickwrk,rckwrk,y) do 1 k=1,kk y(k)= xs(k)*y(k) 1 continue call ckwyp(p,t,y,ickwrk,rckwrk,cwdot) do 2 k=1,kk wdot(k)= cwdot(k)/rho 2 continue return end c c------------------------------------------------------------------ c mode 18 THEDY calculation of mean thermodynamic properties c subroutine thedy(lout,kk,leniwk,lenrwk,ickwrk,rckwrk, 1 p,t,c,x,y) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),rckwrk(lenrwk),c(kk) dimension x(kk),y(kk) c c p: pressure in dynes/cm**2 c call ckmmwc(c,ickwrk,rckwrk,wtm) call ckrhoc(p,t,c,ickwrk,rckwrk,rho) write(lout,200) wtm,rho 200 format (//' === THEDYM ================================='//5x, 1 'Mean thermodynamic properties : '// 2 ' mean molecular weight : ',f9.3, ' gm/mole'/ 3 ' density : ',1pe9.3,' gm/cm3 '//) c c calculation of mole and mass fractions c call ckctx(c,ickwrk,rckwrk,x) call ckcty(c,ickwrk,rckwrk,y) c c mean thermodynamic properties in molar units c c hbml H mean enthalpy (ergs/mole) c ubml U mean internal energy (ergs/mole) c sbml S mean entropy (ergs/(mole*K)) c gbml G mean Gibbs free energy (ergs/mole) c abml A mean Helmholtz free energy (ergs/mole) c cpbml Cp mean specific heat at constant pressure (ergs/(mole*K)) c cvbml Cv mean specific heat at constant volume (ergs/(mole*K)) c call ckhbml(t,x,ickwrk,rckwrk,hbml) call ckubml(t,x,ickwrk,rckwrk,ubml) call cksbml(p,t,x,ickwrk,rckwrk,sbml) call ckgbml(p,t,x,ickwrk,rckwrk,gbml) call ckabml(p,t,x,ickwrk,rckwrk,abml) call ckcpbl(t,x,ickwrk,rckwrk,cpbml) call ckcvbl(t,x,ickwrk,rckwrk,cvbml) c c conversion to SI units c xhbml= hbml/1.D+7 xubml= ubml/1.D+7 xsbml= sbml/1.D+7 xgbml= gbml/1.D+7 xabml= abml/1.D+7 xcpbml= cpbml/1.D+7 xcvbml= cvbml/1.D+7 c write(lout,201) hbml,xhbml,ubml,xubml,sbml,xsbml,gbml,xgbml, 1 abml,xabml,cpbml,xcpbml,cvbml,xcvbml 201 format( 1 ' enthalpy H =',1pe10.3, 1 ' ergs/mole = ',1pe10.3,' J/mole'/ 2 ' internal energy U =',1pe10.3, 2 ' ergs/mole = ',1pe10.3,' J/mole'/ 3 ' entropy S =',1pe10.3, 3 ' ergs/(mole*K) = ',1pe10.3,' J/(mole*K)'/ 4 ' Gibbs free energy G =',1pe10.3, 4 ' ergs/mole = ',1pe10.3,' J/mole'/ 5 ' Helmholtz free energy A =',1pe10.3, 5 ' ergs/mole = ',1pe10.3,' J/mole'/ 6 ' specific heat at constant p Cp =',1pe10.3, 6 ' ergs/(mole*K) = ',1pe10.3,' J/(mole*K)'/ 7 ' specific heat at constant V Cv =',1pe10.3, 7 ' ergs/(mole*K) = ',1pe10.3,' J/(mole*K)'//) c c mean thermodynamic properties in mass units c c hbml H mean enthalpy (ergs/gm) c ubml U mean internal energy (ergs/gm) c sbml S mean entropy (ergs/(gm*K)) c gbml G mean Gibbs free energy (ergs/gm) c abms A mean Helmholtz free energy (ergs/gm) c cpbms Cp mean specific heat at constant pressure (ergs/(gm*K)) c cvbml Cv mean specific heat at constant volume (ergs/(gm*K)) c call ckhbms(t,y,ickwrk,rckwrk,hbms) call ckubms(t,y,ickwrk,rckwrk,ubms) call cksbms(p,t,y,ickwrk,rckwrk,sbms) call ckgbms(p,t,y,ickwrk,rckwrk,gbms) call ckabms(p,t,y,ickwrk,rckwrk,abms) call ckcpbs(t,y,ickwrk,rckwrk,cpbms) call ckcvbs(t,y,ickwrk,rckwrk,cvbms) c c conversion to SI units c xhbms= hbms/1.D+4 xubms= ubms/1.D+4 xsbms= sbms/1.D+4 xgbms= gbms/1.D+4 xabms= abms/1.D+4 xcpbms= cpbms/1.D+4 xcvbms= cvbms/1.D+4 c write(lout,202) hbms,xhbms,ubms,xubms,sbms,xsbms,gbms,xgbms, 1 abms,xabms,cpbms,xcpbms,cvbms,xcvbms 202 format( 1 ' enthalpy H =',1pe10.3, 1 ' ergs/gm = ',1pe10.3,' J/kg'/ 2 ' internal energy U =',1pe10.3, 2 ' ergs/gm = ',1pe10.3,' J/kg'/ 3 ' entropy S =',1pe10.3, 3 ' ergs/(gm*K) = ',1pe10.3,' J/(kg*K)'/ 4 ' Gibbs free energy G =',1pe10.3, 4 ' ergs/gm = ',1pe10.3,' J/kg'/ 5 ' Helmholtz free energy A =',1pe10.3, 5 ' ergs/gm = ',1pe10.3,' J/kg'/ 6 ' specific heat at constant p Cp =',1pe10.3, 6 ' ergs/(gm*K) = ',1pe10.3,' J/(kg*K)'/ 7 ' specific heat at constant V Cv =',1pe10.3, 7 ' ergs/(gm*K) = ',1pe10.3,' J/(kg*K)') c return end c c-------------------------------------------------------------------- c subroutine summ(lout,ii,nhtt,nt,imp,mode,rname,comments) implicit double precision (a-h,o-z), integer (i-n) dimension imp(ii,nhtt) parameter (lenistr=40) character istr*(lenistr),line(80)*1 character*(*) rname(ii) logical comments c write(lout,200) if (mode.eq.1) write(lout,201) if (mode.eq.2) write(lout,202) if (mode.eq.3) write(lout,203) if (nt.gt.40) write(lout,204) nt c do 1 l=1,80 1 line(l)= ' ' do 2 it=1,nt 2 if (it.gt.9) line(it+38)= char(it/10+48) write(lout,212) (line(l),l=1,80) line(37)= 'S' do 3 it=1,nt 3 line(it+38)= char(it-it/10*10+48) write(lout,212) (line(l),l=1,80) write(lout,213) c do 7 i=1,ii do 4 l=1,80 4 line(l)= ' ' c im= i/1000 ic= i/100-im*10 id= i/10-im*100-ic*10 is= i-im*1000-ic*100-id*10 c if (i.gt.999) line(2)= char(im+48) if (i.gt. 99) line(3)= char(ic+48) if (i.gt. 9) line(4)= char(id+48) line(5)= char(is+48) c istr= rname(i) do 8 l=1,28 8 line(l+7)= istr(l:l) c isum= 0 do 5 it=1,nt 5 isum= isum + imp(i,it) if(isum.gt.0) line(37)= '*' do 6 it=1,nt 6 if(imp(i,it).gt.0) line(38+it)= '*' write(lout,212) (line(l),l=1,80) 7 continue c if (comments) then write(lout,205) if (mode.eq.1) write(lout,221) if (mode.eq.2) write(lout,222) if (mode.eq.3) write(lout,223) else write(lout,214) endif c 200 format (//' === SUMMARY ================================') 201 format(//5x,' Important reactions at each reaction time', 1 ' based on the ROPA analysis'// 2 28x,'reaction times') 202 format(//5x,' Important reactions at each reaction time', 1 ' based on the RIMP analysis'// 2 28x,'reaction times') 203 format(//5x,' Important reactions at each reaction time', 1 ' based on the PCAF analysis'// 2 28x,'reaction times') 204 format(/1x,'Sorry, this subroutine can plot only up to', 1 ' 40 reaction times and'/ 2 ' you have ',i5,' times.') 205 format(// 1 ' Reactions, denoted by * below a reaction time number are'/ 2 ' important at this reaction time. Reactions, denoted by *'/ 3 ' below letter S are important at least at one reaction time.') 207 format(//5x,' Important reactions at each reaction time', 1 ' based on the CSP analysis'// 2 28x,'reaction times') 212 format(80a1) 213 format() 214 format(////) 221 format(// 1 ' Rate-of-production analysis has been used since'/ 2 ' the early days of chemical kinetics. The consequence is'/ 3 ' that it is not easy to find a citation which clearly defines'/ 4 ' the rules. As a possible source see the following article:'/ 5 ' J. Warnatz, Ber.Bunsenges.Phys.Chem.,87,1008-1022(1983),', 6 ' eq.(11)') 222 format(// 1 ' A correct application of the classic rate-of-production'/ 2 ' analysis requires the usage of different limits for each'/ 3 ' species when the significance of reaction contributions to'/ 4 ' the production rates of species are investigated.'/ 5 ' Application of a uniform limit (like TROPA% in ROPA)'/ 6 ' may lead to erroneous conclusions in some cases.'/ 3 ' Matrix F (also known as the "rate sensitivity matrix") is a'/ 8 ' matrix of normed reaction contributions. Here, each'/ 9 ' contribution is normed by the corresponding production rate.'/ 1 ' An importance value for each reaction is calculated as a'/ 2 ' sum of squares of these normed contributions (also referred'/ 3 ' to as overall rate sensitivity values). In most cases,'/ 4 ' reactions having a low importance value at each reaction time'/ 5 ' can be eliminated without any consequence.'/ 6 ' For further information, see: Turanyi T.,Vajda S.,Berces T.:'/ 7 ' Int.J.Chem.Kinet.,21,83-99(1989)'//) 223 format(// 1 ' The principal component analysis of matrix F sorts the'/ 2 ' reactions into reaction groups based on the information of'/ 3 ' normed contributions. You can select the important groups'/ 4 ' by choosing an appropriate threshold for eigenvalues and'/ 5 ' you can define the important reactions in the groups by'/ 6 ' choosing the threshold for eigenvectors. Therefore,'/ 7 ' via a suitable selection of these two thresholds'/ 8 ' a reduced mechanism can be obtained.'/ 9 ' For further information, see: Turanyi T.,Vajda S.,Berces T.:'/ 1 ' Int.J.Chem.Kinet.,21,83-99(1989)'// 2 ' This method has been previously applied for'/ 3 ' mechanism reduction as discussed in, e.g.:'/ 4 ' T. Turanyi, New J. Chem.,14,795-803(1990)'/ 5 ' L. Gyorgyi, R.J. Field, J.Phys.Chem.,95,6594-6602(1991)'/ 6 ' A.S. Tomlin et al., Combust.Flame,91,107-130(1992)'/ 7 ' P. Ibison, J.Phys.Chem.,96,6321-6325(1992)'/ 8 ' T. Turanyi et al., J.Phys.Chem.,97,1931-1941(1993)'//) c return end c c-------------------------------------------------------------------- c subroutine control 1 (lin,lout,lnul,mm,kk,kk1,ii,maxrch,maxhot,maxtemp,maxs,maxf, 2 nmode,lmode,indata,npcas,nhsens,nunc,nsens,nseng,ncore,nqssag, 3 nrali,natom,nhot,ntemp,nths,nthf,hot,temp,ths,thf, 4 treac,tropa,tdlim,tblim1,tblim2,tblim3,tlcsp,tlildm, 5 kpcas,khsens,kunc,ksens,kseng,kcore,kqssag,krali,katom,kspec, 6 ename,kname,rname,unc,isckiii) implicit double precision (a-h, o-z), integer (i-n) parameter (nc1=26,nc2=11,maxh=100,maxt=100) c c 1 PCAS c 2 HSENS c 3 UNC_ANAL c 4 SENS c 5 SENG c 6 RALI c 7 RIMP c 8 PCAF c 9 ROPAD c 10 ROPAB c 11 ATOMFLOW c 12 CONNECT c 13 LIFETIME c 14 QSSAS c 15 QSSAG c 16 CSP c 17 ILDM c 18 THEDY c 19 COMMENTS c c nc1= number of group 1 commands (see array kray1) c nc2= number of group 2 commands (see array kray2) c dimension kpcas(kk1),khsens(kk1),kunc(kk1),ksens(kk1),kseng(kk1) dimension kcore(kk1),kqssag(kk1),krali(kk1),katom(mm),kspec(kk1) dimension time(maxt), height(maxh), hot(maxhot), temp(maxtemp) dimension ths(2,maxs), thf(2,maxf), rval(3), unc(ii) dimension nray(nc1) character*(*) ename(mm),kname(kk1) character*(*) rname(maxrch) character*80 line, upcas, ipar character*8 kray1(nc1), kray2(nc2) logical lmode(nmode), kerr, nv(nc2), isckiii data nv /nc2*.FALSE./ c c------------------------------------------- c c Commands, defining methods of mechanism investigation c kray1( 1)= 'RIMP' kray1( 2)= 'PCAF' kray1( 3)= 'ROPAD' kray1( 4)= 'ROPAB' kray1( 5)= 'LIFETIME' kray1( 6)= 'QSSAS' kray1( 7)= 'THEDY' IND1= 7 c c Special commands c kray1(IND1+ 1)= 'COMMENTS' kray1(IND1+ 2)= 'END' IND2= IND1+ 2 c c Commands, which define the source of data c kray1(IND2+ 1)= 'SENKIN' kray1(IND2+ 2)= 'PREMIX' kray1(IND2+ 3)= 'PSR' kray1(IND2+ 4)= 'SHOCK' kray1(IND2+ 5)= 'EQLIB' kray1(IND2+ 6)= 'RUN1DL' kray1(IND2+ 7)= 'OPPDIF' kray1(IND2+ 8)= 'AURORA' kray1(IND2+ 9)= 'EQUIL' IND3= IND2+ 9 c c Commands with list of species c kray1(IND3+ 1)= 'PCAS' kray1(IND3+ 2)= 'SENS' kray1(IND3+ 3)= 'SENG' kray1(IND3+ 4)= 'CONNECT' kray1(IND3+ 5)= 'QSSAG' kray1(IND3+ 6)= 'RALI' kray1(IND3+ 7)= 'HSEN' kray1(IND3+ 8)= 'UNC_ANAL' IND4= IND3+ 8 c c Command for providing list of elements c kray1(IND4+ 1)= 'ATOMFLOW' IND5= IND4+ 1 c c Command for providing list of reactions c kray1(IND5+ 1)= 'UNC' IND6= IND5+ 1 c c Commands for defining thresholds c kray2( 1)= 'CSP' kray2( 2)= 'ILDM' kray2( 3)= 'TPCAS' kray2( 4)= 'TPCAF' kray2( 5)= 'TREAC' kray2( 6)= 'TROPA' kray2( 7)= 'TDLIM' kray2( 8)= 'TBLIMS' c c Commands for defining points in time or distance c kray2( 9)= 'TIME' kray2(10)= 'HEIGHT' kray2(11)= 'AT_TEMP' c npcas= 0 nhsens= 0 nunc = 0 nsens= 0 nseng= 0 natom= 0 ncore= 0 nqssag= 0 nrali= 0 indata= 0 ntim= 0 nhei= 0 nhot= 0 ntemp= 0 nths= 0 nthf= 0 c uncall= 0.5 do 400 i=1,ii unc(i)= -1. 400 continue write(lout,303) 303 format(//5x,'The control file: '/) c c===================================================== c 100 continue line = ' ' read (lin,'(a)',end=99) line write(lout,'(a)') line ilen = ipplen(line) c c blank lines and comment lines c if (ilen .eq. 0) go to 100 line= upcas(line,ilen) c c group 1 commands c call ckcray(line(:ilen),nc1,kray1,lnul,nc1,nray,nf,kerr) if (nf.eq.0) goto 50 if (nf.gt.1) then write(lout,201) 201 format(1x,'*** Please use only one command in each line.', 1 1x,'This line has been ignored. ***') goto 100 endif icid= nray(1) c c END c if(icid.eq.IND2) goto 99 if(icid.eq.IND6) goto 112 if(icid.gt.IND3) goto 111 if(icid.gt.IND2) goto 110 c if(icid.eq.1) lmode( 7)= .TRUE. if(icid.eq.2) lmode( 8)= .TRUE. if(icid.eq.3) lmode( 9)= .TRUE. if(icid.eq.4) lmode(10)= .TRUE. if(icid.eq.5) lmode(13)= .TRUE. if(icid.eq.6) lmode(14)= .TRUE. if(icid.eq.7) lmode(18)= .TRUE. if(icid.eq.8) lmode(19)= .TRUE. goto 100 c 110 continue c c commands that define the type of input c if (indata.ne.0) then write(lout,210) 210 format(1x,'*** You have defined the source of input data.', 1 1x,'This line has been ignored. ***') else indata= icid-IND2 endif goto 100 c c commands with list of species c 111 continue if (icid.gt.IND4) goto 31 call ckcray(line(:ilen),kk1,kname,lnul,kk1,kspec,nspec,kerr) c goto (17,18,19,20,21,22,23,24) (icid-IND3) c c PCAS 17 continue lmode( 1)= .true. do 117 i=1,nspec 117 kpcas(npcas+i)= kspec(i) npcas= npcas + nspec goto 100 c c SENS 18 continue lmode( 4)= .true. do 118 i=1,nspec 118 ksens(nsens+i)= kspec(i) nsens= nsens + nspec goto 100 c c SENG 19 continue lmode( 5)= .true. do 119 i=1,nspec 119 kseng(nseng+i)= kspec(i) nseng= nseng + nspec goto 100 c c CONNECT 20 continue lmode(12)= .true. do 120 i=1,nspec 120 kcore(ncore+i)= kspec(i) ncore= ncore + nspec goto 100 c c QSSAG 21 continue lmode(15)= .true. do 121 i=1,nspec 121 kqssag(nqssag+i)= kspec(i) nqssag= nqssag + nspec goto 100 c c RALI 22 continue lmode( 6)= .true. do 122 i=1,nspec 122 krali(nrali+i)= kspec(i) nrali= nrali + nspec goto 100 c c HSENS 23 continue lmode( 2)= .true. do 123 i=1,nspec 123 khsens(nhsens+i)= kspec(i) nhsens= nhsens + nspec goto 100 c c UNC_ANAL 24 continue lmode( 3)= .true. do 124 i=1,nspec 124 kunc(nunc+i)= kspec(i) nunc= nunc + nspec goto 100 c c ATOMFLOW (with list of elements) c 31 continue lmode(11)= .true. call ckcray(line(:ilen),mm,ename,lnul,mm,kspec,nspec,kerr) do 125 i=1,nspec 125 katom(natom+i)= kspec(i) natom= natom + nspec goto 100 c c UNC c 112 continue ii2= 2*ii+1 call ckcray(line(:ilen),ii2,rname,lnul,nc1,nray,nf,kerr) c if (nf.lt.1) then write(lout,361) 361 format(1x,'*** No valid reaction string was found.', 1 1x,'This line has been ignored. ***') goto 100 endif c if (nf.gt.1) then write(lout,362) goto 100 endif 362 format(1x,'*** More then one reaction string was found.', 1 1x,'This line has been ignored. ***') c call cknpar(line(:ilen),1,lnul,ipar,istart,kerr) call ckxnum(ipar,1,lnul,nval,rval,kerr) if (rval(1).le.0.) then write(lout,366) 366 format( 1 ' *** Sorry, the uncertainty of the reaction must be >= 0.'/ 2 ' This line has been ignored. ***') goto 100 endif if (nray(1).eq.(ii+1)) uncall= rval(1) if (nray(1).le.ii) unc(nray(1))= rval(1) if (nray(1).gt.(ii+1)) unc(nray(1)-ii-1)= rval(1) goto 100 c c-------------------------------------------------------------------- c No group 1 command in the line 50 continue c c max. three expected values c nexp= 3 call cksnum(line(:ilen),nexp,lnul,kray2,nc2,knum,nval,rval,kerr) c if (kerr) then c c not a group 2 command either c write(lout,203) 203 format(1x,' *** Sorry, I could not understand this line *** ') goto 100 endif c if (nval.le.0) then write(lout,202) 202 format(' *** You must define value(s) with this command ***'/ 1 ' *** This line has been ignored ***') goto 100 endif c c group 2 commands c goto (1,2,3,4,5,6,7,8,9,10,11) knum c c CSP c 1 continue lmode(16)= .true. if (nval.gt.1) write(lout,204) if (nval.lt.1) goto 100 tlcsp= rval(1) nv(1)= .TRUE. if(tlcsp.le.0.) then write(lout,379) 379 format(' The limiting timescale must be positive'/ 1 ' This value has been ignored.'/) nv(1)= .FALSE. endif goto 100 c c ILDM c 2 continue lmode(17)= .true. if (nval.gt.1) write(lout,204) if (nval.lt.1) goto 100 tlildm= rval(1) nv(2)= .TRUE. if(tlildm.le.0.) then write(lout,379) nv(2)= .FALSE. endif goto 100 c c TPCAS c 3 continue if(nval.ne.2) then write(lout,205) 205 format(' *** I expect two values after this command ***'/ 1 ' *** this line has been ignored ***') goto 100 endif if(nths.ge.maxs) then write(lout,206) maxs 206 format(' *** Sorry, I cannot handle more then ',i3, 1 ' TPCAS commands ***'/ 2 ' *** this line has been ignored ***') goto 100 endif nths= nths+1 ths(1,nths)= rval(1) ths(2,nths)= rval(2) goto 100 c c TPCAF c 4 continue if(nval.ne.2) then write(lout,205) goto 100 endif if(nthf.ge.maxf) then write(lout,207) maxf 207 format(' *** Sorry, I cannot handle more then ',i3, 1 ' TPCAF commands ***'/ 2 ' *** this line has been ignored ***') goto 100 endif nthf= nthf+1 thf(1,nthf)= rval(1) thf(2,nthf)= rval(2) goto 100 c c TREAC c 5 continue if (nval.gt.1) write(lout,204) 204 format(' *** The first value is considered only ***') treac= rval(1) nv(5)= .TRUE. goto 100 c c TROPA c 6 continue if (nval.gt.1) write(lout,204) tropa= rval(1) nv(6)= .TRUE. goto 100 c c TDLIM c 7 continue if (nval.gt.1) write(lout,204) tdlim= rval(1) nv(7)= .TRUE. goto 100 c c TBLIMS c 8 continue if (nval.ne.3) then write(lout,211) 211 format(' *** I expect 3 values after this command ***'/ 2 ' *** this line has been ignored ***') goto 100 endif tblim1= rval(1) tblim2= rval(2) tblim3= rval(3) nv(8)= .TRUE. goto 100 c c TIME c 9 continue if (ntim.ge.maxt) then write(lout,350) maxt 350 format(' You have tried to use more than ',i4,' TIME data'/ 1 ' Are you sure? If yes, please modify parameters maxt'/ 2 ' and maxhot. This TIME card has been ignored.') else if (nval.gt.1) write(lout,204) ntim=ntim+1 time(ntim)= rval(1) endif goto 100 c c HEIGHT c 10 continue if (nhei.ge.maxh) then write(lout,351) maxh 351 format(' You have tried to use more than ',i4,' HEIGHT data'/ 1 ' Are you sure? If yes, please modify parameters maxh'/ 2 ' and maxhot. This HEIGHT card has been ignored.') else if (nval.gt.1) write(lout,204) nhei=nhei+1 height(nhei)= rval(1) endif goto 100 c c AT_TEMP c 11 continue if (ntemp.ge.maxtemp) then write(lout,340) maxtemp 340 format(' You have tried to use more than ',i4,' AT_TEMP data'/ 1 ' Are you sure? If yes, please modify parameters maxtemp'/ 2 ' and maxhot. This AT_TEMP card has been ignored.') else if (nval.gt.1) write(lout,204) ntemp=ntemp+1 temp(ntemp)= rval(1) endif goto 100 c---------------------------------------------------------- c c Check the assorted source of data and CHEMKIN version c 99 continue if (isckiii) then if (indata.eq.3) then write(lout,990) 990 format(/' PSR is not a CHEMKIN-III program.') stop endif if (indata.eq.5) then write(lout,991) 991 format(/' EQLIB is not a CHEMKIN-III program.') stop endif if (indata.eq.6) then write(lout,992) 992 format(/' RUN1DL is not a CHEMKIN-III program.') stop endif else if (indata.eq.8) then write(lout,993) 993 format(/' AURORA is not a CHEMKIN-II program.') stop endif if (indata.eq.9) then write(lout,994) 994 format(/' EQUIL is not a CHEMKIN-II program.') stop endif endif c---------------------------------------------------------- c c Echo of accepted control commands c write (lout,250) 250 format(////5x,' Your requests: '//) c c The source of data: c if(indata.gt.0) then write (lout,309) 309 format(' The source of concentrations', 1 ' (and possibly sensitivities) is ') c else write(lout,310) 310 format(' You did not specify any source of data.'/ 1 ' --- PROGRAM TERMINATED ---') stop endif c c if(indata.eq.1) write(lout,311) 311 format(' the unformatted save file of SENKIN.') if(indata.eq.2) write(lout,312) 312 format(' the unformatted save file of PREMIX.') if(indata.eq.3) write(lout,313) 313 format(' the unformatted save file of PSR.') if(indata.eq.4) write(lout,314) 314 format(' the unformatted save file of SHOCK.') if(indata.eq.5) write(lout,315) 315 format(' the unformatted save file of EQLIB.') if(indata.eq.6) write(lout,316) 316 format(' the formatted continuation file of RUN1DL, format A.') if(indata.eq.7) write(lout,317) 317 format(' the unformatted save file of OPPDIF.') if(indata.eq.8) write(lout,318) 318 format(' the unformatted save file of AURORA.') if(indata.eq.9) write(lout,319) 319 format(' the unformatted save file of EQUIL.') c if (ntim.gt.0) call rorder(ntim,time) if (nhei.gt.0) call rorder(nhei,height) c if(indata.eq.1 .or. indata.eq.4) then if((ntim+ntemp).eq.0) then write(lout,320) 320 format(' No TIME or AT_TEMP information was given'/ 1 ' --- PROGRAM TERMINATED ---') stop else write(lout,321) 321 format(//' Analysis of the mechanism ', 1 'at the following reaction times (s) :'//) write(lout,322) (i,time(i),i=1,ntim) if (ntim.eq.0) write(lout,360) 360 format(' None'/) 322 format(100(5(i3,1x,1pe12.4)/)) nhot= ntim do 352 i=1,nhot 352 hot(i)= time(i) endif else if(ntim.ne.0) then write(lout,326) 326 format(/' The TIME information provided has been ignored') endif endif c if(indata.eq.2 .or. indata.eq.6 .or. indata.eq.7) then if((nhei+ntemp).eq.0) then write(lout,323) 323 format(' No HEIGHT or AT_TEMP information was given', 1 ' to the flame code data.'// 2 ' --- PROGRAM TERMINATED ---') stop else write(lout,324) 324 format(// 1 ' Analysis of the mechanism at the following distances (cm) :'//) write(lout,322) (i,height(i),i=1,nhei) if (nhei.eq.0) write(lout,360) nhot= nhei do 353 i=1,nhot 353 hot(i)= height(i) endif else if(nhei.ne.0) then write(lout,327) 327 format(/ 1 ' The HEIGHT information provided has been ignored') endif endif c if(ntemp.gt.0) then c c the AT_TEMP info is not applicable for PSR, AURORA, EQLIB and EQUIL c if(indata.eq.3 .or. indata.eq.5 .or. 1 indata.eq.8.or.indata.eq.9) then write(lout,354) 354 format(/ 1 ' The AT_TEMP information provided has been ignored') ntemp= 0 else write(lout,341) 341 format(// 1 ' Analysis of the mechanism at the following ', 2 'temperatures (K) :'//) write(lout,343) (i,temp(i),i=1,ntemp) 343 format(100(5(i3,1x,f9.3)/)) endif endif c if(indata.eq.3 .or. indata.eq.5 .or. 1 indata.eq.8 .or. indata.eq.9) nhot= 1 c c PCAS c if (lmode(1)) then write(lout,251) 251 format(/' Principal component analysis of the concentration ', 1 'sensitivity matrix') if (nths.eq.0) then nths= 1 ths(1,1)= 0.0001 ths(2,1)= 0.2 write(lout,252) ths(1,1),ths(2,1) 252 format(' Default threshold for eigenvalues :',1pe10.3/ 1 ' Default threshold for eigenvectors :',0pf10.3) else if (nths.le.1) then write(lout,253) ths(1,1),ths(2,1) 253 format(' Threshold for eigenvalues :',1pe10.3/ 1 ' Threshold for eigenvectors :',1pe10.3) else write(lout,254) 254 format(' Significant reactions will be listed considering', 1 ' the thresholds below') do 25 is=1,nths 25 write(lout,255) is,ths(1,is),ths(2,is) 255 format(1x,i3,' eigenvalues :',1pe10.3, 1 ' eigenvectors :',0pf10.3) endif endif c if (npcas.eq.0) then write(lout,256) 256 format( 1 ' You did not specify the group of species to be considered'/ 2 ' in the objective function of PCA. As default, all species'/ 3 ' are considered.') npcas= kk do 52 k=1,kk 52 kpcas(k)= k write(lout,260) (kname(kpcas(k)),k=1,npcas) else call iorder(npcas,kpcas) write(lout,257) (kname(kpcas(k)),k=1,npcas) 257 format(' Species considered in the objective function: '/ 1 50(2x,4a16/)) endif endif c c HSENS c if (lmode(2)) then if (indata.eq.2) then write(lout,363) 363 format(/' List the species to which the concentration'/ 1 ' of each species listed below has a high '/ 2 ' heat-of-formation sensitivity towards.') if (nhsens.eq.0) then write(lout,374) 374 format( 1 ' You did not specify species or temperature therefore') if (indata.eq.2) then write(lout,375) 375 format 1 (' flame velocity sensitivities will be printed only.') else write(lout,376) 376 format(' this command will have no any effect.') endif else call iorder(nhsens,khsens) write(lout,260) (kname(khsens(k)),k=1,nhsens) 260 format(2x,4a16/) endif else write(lout,378) 378 format(/ 1 ' You have used command HSEN, but this option can be used'/ 2 ' with program PREMIX only'/ 3 ' HSEN has been disabled'//) lmode(2)= .false. endif endif c c UNC_ANAL c if (lmode(3)) then write(lout,269) 269 format 1 (/' Uncertainty analysis of the species concentrations', 2 ' below,'/' based on local concentration sensitivities') if (nunc.eq.0) then write(lout,374) if (indata.eq.2) then write(lout,377) 377 format 1 (' flame velocity uncertainties will be printed only.') else write(lout,376) endif else call iorder(nhsens,khsens) write(lout,260) (kname(kunc(k)),k=1,nunc) endif c write(lout,364) 364 format(//' Uncertainty of reactions:'//) do 365 i=1,ii if (unc(i).le.0) unc(i)=uncall write(lout,368) i,rname(i),unc(i) 368 format(5x,i5,2x,a40,f6.3) 365 continue endif c c SENS c if (lmode(4)) then write(lout,258) 258 format(/' List the reactions to which the concentration'/ 1 ' of each species listed below has a high sensitivity'/ 2 ' towards.') if (nsens.eq.0) then write(lout,374) if (indata.eq.2) then write(lout,375) else write(lout,376) endif else call iorder(nsens,ksens) write(lout,260) (kname(ksens(k)),k=1,nsens) endif endif c c SENG c if (lmode(5)) then write(lout,261) 261 format(/' List the reactions to which the concentration'/ 1 ' of the group of species listed below has'/ 2 ' a high sensitivity towards.') if (nseng.eq.0) then write(lout,262) 262 format( 1 ' You did not define species and therefore, as default,'/ 2 ' all species are considered.'/) nseng= kk do 54 k=1,kk 54 kseng(k)= k endif call iorder(nseng,kseng) write(lout,260) (kname(kseng(k)),k=1,nseng) endif c c RALI c if (lmode(6)) then write(lout,264) 264 format(/' Search for rate limiting steps '/ 1 ' of the production rates of the following species:') if (nrali.eq.0) then write(lout,265) 265 format( 1 ' You did not specify the group of species to be considered'/ 2 ' in the rate limiting steps study.', 3 ' This option has been disabled!'/ 4 ' **********************************************************'/) lmode(6)= .FALSE. else call iorder(nrali,krali) write(lout,260) (kname(krali(k)),k=1,nrali) endif endif c c RIMP c if (lmode(7)) then write(lout,267) 267 format(/' Assessment of the importance of reactions ') if (nv(5)) then write(lout,268) treac 268 format(' Threshold value for importance :',1pe10.3) else treac= 1. write(lout,367) treac 367 format(' Default threshold for importance :',1pe10.3) endif endif c c PCAF c if (lmode(8)) then write(lout,270) 270 format(/' Principal component analysis of matrix F ') if (nthf.eq.0) then nthf= 1 thf(1,1)= 0.0001 thf(2,1)= 0.2 write(lout,252) thf(1,1),thf(2,1) else if (nthf.le.1) then write(lout,253) thf(1,1),thf(2,1) else write(lout,271) 271 format(' Reduced mechanisms will be prepared considering', 1 ' the thresholds below') do 26 is=1,nthf 26 write(lout,255) is,thf(1,is),thf(2,is) write(lout,272) 272 format(' Note, that only the last reduction will appear', 1 ' in the summary page') endif endif endif c c ROPAD c if (lmode(9)) then write(lout,275) 275 format(/' Rate-of-production analysis - detailed printout ') if (nv(6)) then write(lout,268) tropa else tropa= 5. write(lout,269) tropa endif if (nv(7)) then write(lout,278) tdlim 278 format(' Control number for printing of detailed ROPA :',1pe10.3) else tdlim= 100. write(lout,279) tdlim 279 format(' Default control number for printing of detailed ROPA :', 1 1pe10.3) endif endif c c ROPAB c if (lmode(10)) then write(lout,280) 280 format(/' Rate-of-production analysis - brief printout ') if (nv(6)) then write(lout,268) tropa else tropa= 5. write(lout,269) tropa endif if (nv(8)) then write(lout,283) tblim1,tblim2,tblim3 283 format(' Control numbers for printing of brief ROPA :'/ 1 3f7.1,' , respectively.') else tblim1= 3. tblim2= 10. tblim3= 100. write(lout,288) tblim1,tblim2,tblim3 288 format(' Default control numbers for printing of brief ROPA :'/ 1 ,3f7.1,' ,respectively.') endif endif c c ATOMFLOW c if (lmode(11)) then if (natom.eq.0) then write(lout,356) 356 format(/ 1 ' You want me to calculate fluxes of elements but'/ 2 ' did not specify element names. As default, '/ 3 ' fluxes for each element will be calculated:') natom= mm do 357 m=1,mm 357 katom(m)= m write(lout,305) (ename(katom(m)),m=1,natom) 305 format(1x,20a3) else call iorder(natom,katom) write(lout,304) (ename(katom(m)),m=1,natom) 304 format(/' Fluxes will be calculated for elements ',20a3) endif endif c c CONNECT c if (lmode(12)) then write(lout,289) 289 format(/' Kinetic connections of each species '/ 1 ' to the following group of species is assessed:') if (kcore(ncore).eq.(kk+1)) then write(lout,291) 291 format(' (Sorry, you cannot use T as a species here)') ncore= ncore-1 endif if (ncore.eq.0) then write(lout,290) 290 format( 1 ' You did not specify the group of species.'/ 2 ' This option has been disabled !'/ 3 ' **************************************************'/) lmode(12)= .FALSE. else call iorder(ncore,kcore) write(lout,260) (kname(kcore(k)),k=1,ncore) endif endif c c LIFETIME c if (lmode(13)) then write(lout,292) 292 format(/' Lifetime of species ') endif c c QSSAS c if (lmode(14)) then write(lout,293) 293 format(/' Calculation of the error of single QSSA species ') endif c c QSSAG c if (lmode(15)) then write(lout,294) 294 format(/' Calculation of the error of the', 1 ' following group of QSSA species ') if (kqssag(nqssag).eq.(kk+1)) then write(lout,291) nqssag= nqssag-1 endif if (nqssag.eq.0) then write(lout,295) 295 format( 1 ' You did not specify the group of species to be considered'/ 2 ' as QSSA species. This option is disabled!'/ 3 ' *********************************************************'/) lmode(13)= .FALSE. else call iorder(nqssag,kqssag) write(lout,260) (kname(kqssag(k)),k=1,nqssag) endif endif c c CSP c if (lmode(16)) then write(lout,370) 370 format(/' Computational Singular Perturbation analysis') if (nv(1)) then write(lout,380) tlcsp 380 format(' The limiting time scale is ',1pe10.3,' s') else tlcsp= 1.E-5 write(lout,381) tlcsp 381 format(' The default limiting time scale is ',1pe10.3,' s'/) endif endif c c c ILDM c if (lmode(17)) then write(lout,371) 371 format(/' Intrinsic Low Dimensional Manifolds' ) if (nv(2)) then write(lout,380) tlildm else tlildm= 1.E-5 write(lout,381) tlildm endif endif c c c THEDY c if (lmode(18)) then write(lout,373) 373 format(/' Thermodynamic properties ' ) endif c c c COMMENTS c if (lmode(19)) then write(lout,298) 298 format(/' The results will be commented ', 1 '(at the first reaction time only)' ) endif c write(lout,302) 302 format(///) return end c-------------------------------------------------------------------- c subroutine iorder(n,iv) implicit double precision (a-h, o-z), integer (i-n) dimension iv(n) c c input iv(n) integer vector with elements in arbitrary order c output iv(n) integer vector with increasing elements c do 1 i=1,n do 1 j=i,n if (iv(i).gt.iv(j)) then is= iv(j) iv(j)= iv(i) iv(i)= is endif 1 continue return end C c-------------------------------------------------------------------- c subroutine rorder(n,rv) implicit double precision (a-h, o-z), integer (i-n) dimension rv(n) c c input rv(n) real vector with elements in arbitrary order c output rv(n) real vector with increasing elements c do 1 i=1,n do 1 j=i,n if (rv(i).gt.rv(j)) then rs= rv(j) rv(j)= rv(i) rv(i)= rs endif 1 continue return end C C----------------------------------------------------------------------C C c INTEGER FUNCTION IPPLEN (LINE) C C BEGIN PROLOGUE C C FUNCTION IPPLEN (LINE) C Returns the effective length of a character string, i.e., C the index of the last character before an exclamation mark (!) C indicating a comment. C C INPUT C LINE - A character string. C C OUTPUT C IPPLEN - The effective length of the character string. C C END PROLOGUE C C*****double precision c IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N) C*****END double precision C*****single precision C IMPLICIT REAL (A-H,O-Z), INTEGER (I-N) C*****END single precision C c CHARACTER LINE*(*) C c IN = IFIRCH(LINE) c IF (IN.EQ.0 .OR. LINE(IN:IN).EQ.'!') THEN c IPPLEN = 0 c ELSE c IN = INDEX(LINE,'!') c IF (IN .EQ. 0) THEN c IPPLEN = ILASCH(LINE) c ELSE c IPPLEN = ILASCH(LINE(:IN-1)) c ENDIF c ENDIF c RETURN c END C CHARACTER*(*) FUNCTION UPCAS(ISTR, ILEN) CHARACTER ISTR*(*), LCASE(26)*1, UCASE(26)*1 DATA LCASE /'a','b','c','d','e','f','g','h','i','j','k','l','m', 1 'n','o','p','q','r','s','t','u','v','w','x','y','z'/, 2 UCASE /'A','B','C','D','E','F','G','H','I','J','K','L','M', 3 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ C UPCAS = ' ' UPCAS = ISTR(:ILEN) JJ = MIN (LEN(UPCAS), LEN(ISTR), ILEN) DO 10 J = 1, JJ DO 10 N = 1,26 IF (ISTR(J:J) .EQ. LCASE(N)) UPCAS(J:J) = UCASE(N) 10 CONTINUE RETURN END c c-------------------------------------------------------------------- c c subroutine for reading CHEMKIN-II files c subroutine readc(lout,ldata,lfdata,leniwk,lenrwk, 1 kk,ii,indata,it,nsys,imolf,ickwrk,rckwrk, 2 ctp,s,hs,ctp2,s2,sfl,hsfl,sc,kname,lsens,lhsens, 3 dend,maxhot,nhot,hot,maxtemp,ntemp,temp,maxgrid,x, 4 timmin,timmax,temmin,temmax,lsfld,lhsfld,hots,flvelo) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),rckwrk(lenrwk) dimension ctp (kk+2),s (kk+1,ii), hs (kk+1,kk) dimension ctp2(kk+2),s2(kk+1,ii) dimension hot(maxhot),temp(maxtemp),x(maxgrid),sfl(ii) dimension hsfl(kk),sc(kk+1,maxgrid),hots(maxhot) character*(*) kname(kk) character ititl*76 logical lsens,lhsens,lsend,lhsend,lsfld,lhsfld,dend CHARACTER*16 ICHR, ISOLUT, ISENSI, IHSENS DATA ISOLUT/'SOLUTION '/, ISENSI/'SENSITIVITY '/, 1 IHSENS/'HSENSITIVITY '/ if (dend) return c c indata source of data (1-6) c it serial number of calling c lsens= .true. reading of sensitivities is required c lhsens= .true. reading of H sensitivities is required c lsend= .true. the data file contains sensitivity info c lhsend= .true. the data file contains H sensitivity info c lsfld= .true. the data file contains flame sensitivity info c lhsfld= .true. the data file contains H flame sensitivity info c ctp(1) pressure [dynes/cm**2] c ctp(2) temperature [K] c ctp(3..kk+2) molar concentrations [mole/cm**3] c s normalized concentration sensitivities c if (it.gt.(nhot+ntemp)) goto 999 kk1= kk+1 kk2= kk+2 do 50 k=1,kk2 ctp (k)= 0. ctp2(k)= 0. 50 continue do 51 k=1,kk1 do 51 i=1,ii s (k,i)= 0. s2(k,i)= 0. 51 continue c lsend= .false. lhsend= .false. lsfld= .false. lhsfld= .false. c call ckrp(ickwrk,rckwrk,ru,ruc,pa) c c indata source of data c 1 SENKIN c 2 PREMIX c 3 PSR c 4 SHOCK c 5 EQLIB c 6 RUN1DL c 7 OPPDIF c 8 not used in CHEMKIN-II mode c 9 not used in CHEMKIN-II mode c goto (1,2,3,4,5,6,7,8,9) indata c c------------------------------------------------------------------- 1 continue c c SENKIN c c Structure of data: c c lsend sensitivity coefficients are written (true/false) c nsys number of variables c nsys=kk+1 for cases A-C c nsys=kk for cases D-E c kkd number of species c iid number of reactions c c repeated nstep times: c time time (sec) c p pressure (dynes/cm2) c temp temperature (K) c y(1..kk) species mass fractions c s(1..nsys,1..ii) sensitivity coefficients c if (it.eq.1) then c c START of 1st calling c rewind ldata read(ldata,end=90) lsend read(ldata) nsys,kkd,iid c if (kkd.ne.kk) goto 91 if (iid.ne.ii) goto 92 c ioff= kk-nsys+1 read(ldata,end=102) time,(ctp(k),k=1,kk2) if(lsend) then read(ldata) ((s(k+ioff,i),k=1,nsys),i=1,ii) endif timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. if (time .lt.timmin) timmin= time if (time .gt.timmax) timmax= time if (ctp(2).lt.temmin) temmin= ctp(2) if (ctp(2).gt.temmax) temmax= ctp(2) c 100 continue read(ldata,end=102) time2,(ctp2(k),k=1,kk2) if(lsend) then read(ldata) ((s(k+ioff,i),k=1,nsys),i=1,ii) endif c if (time2 .lt.timmin) timmin= time2 if (time2 .gt.timmax) timmax= time2 if (ctp2(2).lt.temmin) temmin= ctp2(2) if (ctp2(2).gt.temmax) temmax= ctp2(2) c c conversion of AT_TEMP points to TIME points c if(ntemp.eq.0) goto 100 if(maxhot.lt.(nhot+ntemp)) goto 93 do 101 itt= 1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 101 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 101 endif c tval= (ctp(2)-temp(itt))*(ctp2(2)-temp(itt)) if (tval .le. 0.) then if(dabs(ctp2(2)-ctp(2)).lt.1.d-30) then f1= 1. f2= 0. else f1= (ctp2(2) -temp(itt))/(ctp2(2)-ctp(2)) f2= (temp(itt)-ctp(2)) /(ctp2(2)-ctp(2)) endif nhot= nhot+1 hot(nhot)= f1*time + f2*time2 endif 101 continue c time= time2 ctp(2)= ctp2(2) goto 100 c c finished going through the datafile once c 102 continue ntemp= 0 call rorder(nhot,hot) do 114 i=1,nhot 114 hots(i)= hot(i) endif c c END of 1st calling c rewind ldata read(ldata,end=90) lsend read(ldata) nsys,kkd,iid do 103 i=1,ii s (1,i)= 0. 103 s2(1,i)= 0. ioff= kk-nsys+1 c c reading the first data c read(ldata,end=999) time,(ctp(k),k=1,kk2) if(lsend) then read(ldata) ((s(k+ioff,i),k=1,nsys),i=1,ii) endif c c reading further data c 104 continue read(ldata,end=999) time2,(ctp2(k),k=1,kk2) if(lsend) then read(ldata) ((s2(k+ioff,i),k=1,nsys),i=1,ii) endif c do 107 itt=1,nhot tval= (time-hot(itt))*(time2-hot(itt)) if ( tval.le. 0.0 ) then f1= (time2-hot(itt))/(time2-time) f2= (hot(itt)-time) /(time2-time) hort= hot(itt) do 105 k=1,kk2 105 ctp(k)= f1*ctp(k) + f2*ctp2(k) if (lsens) then do 106 i=1,ii do 106 k=1,kk1 106 s(k,i)= f1*s(k,i) + f2*s2(k,i) endif hot(itt)= -1.D+50 goto 110 endif 107 continue c c the requested data has not been found yet c time= time2 do 108 k=1,kk2 108 ctp(k)= ctp2(k) if (lsens) then do 109 k=1,kk1 do 109 i=1,ii 109 s(k,i)= s2(k,i) endif goto 104 c c success! c 110 continue c write(lout,2005) hort,ctp(2),ctp(1)/pa c c normalizing the sensitivities c do 111 k=1,kk1 do 111 i=1,ii call ckraex(i,rckwrk,ra) if (dabs(ctp(k+1)) .gt. 1.d-30) s(k,i)= s(k,i)*ra/ctp(k+1) 111 continue c do 112 k=1,kk 112 ctp2(k)= ctp(k+2) write(lout,2008) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mass fractions to molar concentrations (mole/cm**3) c call ckytcp(ctp(1),ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) goto 99 c c------------------------------------------------------------------- 2 continue c c PREMIX c c Structure of data: c c ICKLNK 'CKLINK ' (character*16) c c IMCLNK 'MCLINK ' (character*16) c c ISOLUT 'SOLUTION ' (character*16) c c ncomp number of variables= kk+2 c jj number of grid points c p pressure (dynes/cm2) c flrt mass flow rate (g /(cm2 sec)) c x(1..jj) grid point locations (cm) c s(1..ncomp,1..jj) temperature, mass fractions, mass flow rate c c ISENSI 'SENSITIVITY ' (character*16) c c repeated ii times: c i No of reaction c fosc(1..ncomp,1..jj) normalized first order sensitivity coefficients c of temperature, mass fractions, and mass flow rate c with respect to rate parameters c c IHSENS 'HSENSITIVITY ' (character*16) c c repeated kk times: c k No of species c sn(1..ncomp,1..jj) normalized first order sensitivity coefficients c of temperature, mass fractions, and mass flow rate c with respect to species heats of formation c if (it.eq.1) then c c START for the 1st calling only c rewind ldata 200 continue read(ldata,end=90) ichr if (ichr.ne.ISOLUT) goto 200 read(ldata,end=90) ncomp,jj,p,flrt kkd= ncomp-2 if (kkd .ne.kk) goto 91 if (maxgrid.lt.jj) goto 95 c c reading the grid point locations and the temperatures c read(ldata) (x(j),j=1,jj) read(ldata) ((sc(i,j),i=1,kk1),flrth,j=1,jj) c c calculation of mass density c call ckrhoy(p,sc(1,1),sc(2,1),ickwrk,rckwrk,rho) flvelo= flrt/rho c c finding the exterme values c timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. timmin= x(1) timmax= x(jj) do 201 j=1,jj if (sc(1,j).lt.temmin) temmin= sc(1,j) if (sc(1,j).gt.temmax) temmax= sc(1,j) 201 continue c c conversion AT_TEMP points to HEIGHT points c if (ntemp.eq.0) goto 203 if (maxhot.lt. (nhot+ntemp) ) goto 94 do 202 j=1,(jj-1) t1= sc(1,j) t2= sc(1,j+1) do 202 itt=1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 202 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 202 endif c tval= ( t1-temp(itt) )*( t2-temp(itt) ) if ( tval.le.0. ) then if( dabs(t2-t1) .lt. 1.D-30) then f1= 1. f2= 0. else f1= ( t2-temp(itt) ) / (t2-t1) f2= ( temp(itt)-t1 ) / (t2-t1) endif nhot= nhot+1 hot(nhot)= f1*x(j) + f2*x(j+1) c endif 202 continue ntemp= 0 call rorder(nhot,hot) do 220 i=1,nhot 220 hots(i)= hot(i) c c any sensitivities? c if (.not.(lsens.or.lhsens)) goto 208 203 continue read(ldata,end=208,err=208) ichr if ( ichr.eq.ISENSI) goto 204 if ( ichr.eq.IHSENS) goto 221 goto 203 c c flame velocity sensitivities c 204 continue if(.not.lsens) goto 203 do 205 i=1,ii read(ldata,end=208) is,((sc(k,j),k=1,kk1),x(j),j=1,jj) sfl(i)= x(1) 205 continue lsfld= .true. goto 203 c c H flame velocity sensitivities c 221 continue do 222 i=1,kk read(ldata,end=208) is,((sc(k,j),k=1,kk1),x(j),j=1,jj) hsfl(i)= x(1) 222 continue lhsfld= .true. goto 203 endif c c END for the 1st calling only c c====================================================================== 208 continue write(lout,2014) rewind ldata 209 continue read(ldata,end=90) ichr if (ichr.ne.ISOLUT) goto 209 read(ldata,end=90) ncomp,jj,p,flrt c c reading the grid point locations c read(ldata) (x(j),j=1,jj) do 210 j=1,(jj-1) tval= (x(j)-hot(it))*(x(j+1)-hot(it)) if ( tval.le. 0.0 ) goto 211 210 continue goto 999 c c a point was found c 211 continue jp= j f1= (x(jp+1)-hot(it))/(x(jp+1)-x(jp)) f2= (hot(it) -x(jp))/(x(jp+1)-x(jp)) hort= hot(it) c read(ldata) ((sc(i,j),i=1,kk1),flrt,j=1,jj) ctp(1)= p do 212 k=1,kk1 ctp(k+1)= f1*sc(k,jp) + f2*sc(k,jp+1) 212 continue c c any sensitivities? c if (.not.(lsens.or.lhsens)) goto 218 213 continue read(ldata,end=218,err=218) ichr if ( ichr.eq.ISENSI) goto 214 if ( ichr.eq.IHSENS) goto 224 goto 213 c c reading sensitivities c 214 continue if(.not.lsens) goto 213 do 216 iv=1,ii read(ldata,end=218) is,((sc(i,j),i=1,kk1),x(j),j=1,jj) do 215 k=1,kk1 s(k,is)= f1*sc(k,jp) + f2*sc(k,jp+1) 215 continue 216 continue lsend= .true. goto 213 c c reading heat-of-formation sensitivities c 223 continue read(ldata,end=218,err=218) ichr if ( ichr.eq.IHSENS) goto 224 goto 223 c c reading H sensitivities c 224 continue if(.not.lhsens) goto 218 do 226 iv=1,kk read(ldata,end=218) is,((sc(i,j),i=1,kk1),x(j),j=1,jj) do 225 k=1,kk1 hs(k,is)= f1*sc(k,jp) + f2*sc(k,jp+1) 225 continue 226 continue lhsend= .true. c c success! c 218 continue hot(it)= -1.D+50 c write(lout,2006) hort,ctp(2),ctp(1)/pa do 219 k=1,kk 219 ctp2(k)= ctp(k+2) write(lout,2008) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mass fractions to molar concentrations (mole/cm**3) c call ckytcp(p,ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) goto 99 c c------------------------------------------------------------------- 3 continue c c PSR c c Structure of data: c c ch1 'SOLUTION' (character*16) c nn number of variables= KK+1 c equiv equivalence ratio c p pressure (dynes/cm2) c tau residence time (sec) c flrt mass flow rate (g/sec) c v volume (cm3) c q heat loss (cal/sec) c tin inlet temperature (K) c xin(1..kk) inlet species mole fractions c t outlet temperature (K) c y(1..kk) outlet species mass fractions c ch2 'SENSITIVITY' (character*16) c c repeated ii times: c i No. of reaction c fosct normalized first order temperature sensitivity c coefficient: d ln T/d ln k_i = (k_i/T)*(d T/d k_i) c fosc(1..kk) normalized first order concentration sensitivies c c ch3 'RATE OF PRODUCTION' (character*18) c c repeated kk times: c k No. of species c cik(1..ii) contribution of reaction i c to the production of species k (moles/(sec cm3)) c c The above data can be repeated NPROBLEM times c c************************************************************************* c FOR SIMPLICITY ONLY THE FIRST RECORD IN THE SAVE FILE WILL BE PROCESSED c************************************************************************* c write(lout,*) 'PSR indult' rewind ldata 300 continue read(ldata,end=90) ichr if(ichr.ne.ISOLUT) goto 300 read(ldata) nn kkd= nn-1 if(kkd.ne.kk) goto 91 read(ldata) equiv, p, tau, flrt, v, q read(ldata) ctp(2), (ctp2(k), k=1,kk) read(ldata) ctp(2), (ctp2(k), k=1,kk) c ctp(1)= p c write(lout,2300) ctp(2),ctp(1)/pa,equiv,tau,flrt,v,q 2300 format(// 1 ' ***************************************', 2 '****************************************'// 3 5x,' --------------------- PSR ----------------------'// 4 5x,' temperature = ',0pf7.2, 5 ' K pressure = ',0pf7.3,' atm'// 6 5x,' equivalence ratio = ',1pe12.5/ 7 5x,' residence time (sec) = ',1pe12.5/ 8 5x,' mass flow rate (g/sec) = ',1pe12.5/ 9 5x,' volume (cm3) = ',1pe12.5/ a 5x,' heat loss (cal/sec) = ',1pe12.5///) c write(lout,2008) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mass fractions to molar concentrations (mole/cm**3) c call ckytcp(p,ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) c if (lsens) then read(ldata,end=99) ichr if (ichr.ne.ISENSI) goto 99 do 301 i=1,ii read(ldata,end=99) in,(s(k,i),k=1,kk+1) 301 continue lsend= .true. endif c goto 99 c c------------------------------------------------------------------- 4 continue c c SHOCK c c ch1 'SOLUTION' (character*16) c ititl title of the problem (character*76) c c iprb 1 incident shock problem with boundary layer correction c 2 incident shock problem without boundary layer correction c 3 reflected shock problem c c imolf 0 the unit of x is molar concentrations c 1 the unit of x is mole fractions c c repeated nstep times: c tt1 time (sec) c t temperature (K) c pa pressure (atm) c rho density (g/cm3) c wtm mean molecular weight (Dalton) c area cross-sectional area (cm2) c v velocity (cm/s) c tl laboratory time (sec) c x(1..kk) species concentrations (molar concentrations OR mole fractions) c if (it.eq.1) then c c START of 1st calling c rewind ldata 411 continue read(ldata,end=90) ichr if(ichr.ne.ISOLUT) goto 411 read(ldata,end=90) ititl,iprb,imolf write(lout,2400) ititl 2400 format(//1x,a76//) if (iprb.eq.1) write(lout,2401) if (iprb.eq.2) write(lout,2402) if (iprb.eq.3) write(lout,2403) 2401 format(/' incident shock problem with', 1 ' boundary layer correction') 2402 format(/' incident shock problem without', 1 ' boundary layer correction') 2403 format(/' reflected shock problem') c read(ldata) time,ctp(2),p,rho,wtm,area,v,tl,(ctp(k),k=3,kk+2) c timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. if (time .lt.timmin) timmin= time if (time .gt.timmax) timmax= time if (ctp(2).lt.temmin) temmin= ctp(2) if (ctp(2).gt.temmax) temmax= ctp(2) c 400 continue read(ldata,end=403) time2,ctp2(2),p2,rho2,wtm2,area2,v2,tl2, 1 (ctp2(k),k=3,kk+2) c if (time2 .lt.timmin) timmin= time2 if (time2 .gt.timmax) timmax= time2 if (ctp2(2).lt.temmin) temmin= ctp2(2) if (ctp2(2).gt.temmax) temmax= ctp2(2) c c conversion of AT_TEMP points to TIME points c if(ntemp.eq.0) goto 402 if(maxhot.lt.(nhot+ntemp)) goto 93 do 401 itt= 1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 401 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 401 endif c tval= (ctp(2)-temp(itt))*(ctp2(2)-temp(itt)) if (tval .le. 0.) then if(dabs(ctp2(2)-ctp(2)).lt.1.d-30) then f1= 1. f2= 0. else f1= (ctp2(2) -temp(itt))/(ctp2(2)-ctp(2)) f2= (temp(itt)-ctp(2)) /(ctp2(2)-ctp(2)) endif nhot= nhot+1 hot(nhot)= f1*time + f2*time2 endif 401 continue c 402 continue time= time2 ctp(2)= ctp2(2) goto 400 c c finished going through the datafile once c 403 continue ntemp= 0 call rorder(nhot,hot) do 410 i=1,nhot 410 hots(i)= hot(i) endif c c END of 1st calling c rewind ldata 412 continue read(ldata,end=90) ichr if(ichr.ne.ISOLUT) goto 412 read(ldata,end=90) ititl,iprb,imolf read(ldata) time,ctp(2),p,rho,wtm,area,v,tl,(ctp(k),k=3,kk+2) 404 continue read(ldata,end=999) time2,ctp2(2),p2,rho2,wtm2,area2,v2,tl2, 1 (ctp2(k),k=3,kk+2) c do 406 itt=1,nhot tval= (time-hot(itt))*(time2-hot(itt)) if ( tval.le. 0.0 ) then hort= hot(itt) f1= (time2-hot(itt))/(time2-time) f2= (hot(itt)-time) /(time2-time) p= f1*p + f2*p2 rho= f1*rho + f2*rho2 wtm= f1*wtm + f2*wtm2 area= f1*area + f2*area2 v= f1*v + f2*v2 tl= f1*tl + f2*tl2 ctp(1)= p do 405 k=2,kk+2 ctp(k)= f1*ctp(k) + f2*ctp2(k) 405 continue hot(itt)= -1.D+50 goto 408 endif 406 continue c c the requested data has not been found yet c time= time2 p= p2 rho= rho2 wtm= wtm2 area= area2 v= v2 tl= tl2 ctp(1)= p do 407 k=2,kk+2 ctp(k)= ctp2(k) 407 continue goto 404 c c success! c 408 continue write(lout,2005) hort,ctp(2),ctp(1) write(lout,2405) rho,wtm,area,v,tl 2405 format(// 1 ' rho =',1pe12.5,' g/cm3'/ 2 ' wtm =',1pe12.5,' Dalton'/ 3 ' area =',1pe12.5,' cm2'/ 4 ' v =',1pe12.5,' cm/s'/ 5 ' t_lab =',1pe12.5,' sec'//) if (imolf.eq.1) then do 409 k=1,kk+2 409 ctp2(k)= ctp(k) write(lout,2007) write(lout,2010) (kname(k),ctp2(k+2),k=1,kk) c c changing mole fractions to molar concentrations (mole/cm**3) c call ckxtcp(p,ctp(2),ctp2(3),ickwrk,rckwrk,ctp(3)) endif c write(lout,2009) write(lout,2010) (kname(k),ctp(k+2),k=1,kk) goto 99 c c------------------------------------------------------------------- 5 continue c c EQLIB c c two records: one for the initial state and c one for the equilibrium state c c t temperature (K) c p pressure (atm) c U U (erg/g) c H H (erg/g) c S S ( erg/(g K) ) c V V (cm3/g) c C C (cm/sec) c x(1..kk) species concentrations (mole fractions) c rewind ldata 501 continue read(ldata,end=90) ichr if(ichr.ne.ISOLUT) goto 501 read(ldata,end=90) isrfch c surface reactions are not supported yet if (isrfch.eq.1) goto 97 read(ldata,end=90) ctp(2),pp,U,H,Se,V,C,(ctp2(k),k=1,kk), 1 ctp(2),pp,U,H,Se,V,C,(ctp2(k),k=1,kk) c c changing dynes/cm**2 to atm c ctp(1)= pp*pa write(lout,2500) ctp(2),pp,U,H,Se,V,C 2500 format(// 1 ' ***************************************', 2 '****************************************'// 3 5x,' --------------- EQUILIBRIUM STATE --------------'// 4 5x,' temperature = ' ,f7.2, 5 ' K pressure = ',f7.3,' atm'// 6 5x,' U= ', 1pe12.5,' erg/g '/ 7 5x,' H= ', 1pe12.5,' erg/g '/ 8 5x,' S= ', 1pe12.5,' erg/gK '/ 9 5x,' V= ', 1pe12.5,' cm3/g '/ a 5x,' C= ', 1pe12.5,' cm/sec '//) write(lout,2007) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mole fractions to molar concentrations (mole/cm**3) c call ckxtcp(ctp(1),ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) c goto 99 c c------------------------------------------------------------------- 6 continue c c RUN1DL - FORMAT A c c Structure of the formatted data file: c c line content format: c 1 title a80 c 2 pressure [Pa] , ifltype 7x,e12.5,17x,i1 c c ifltype= 1 strained flame c 2 unstrained freely propogating flame c 3 tubular flame c 4 unstrained burner stabilized flame c 5 spherical flame (old) c 6 spherical flame (new) c c 3 dummy a80 c 4 NSPEC,NL 7x,i3,15x,i3 c 4-NL symbols of chemical species 6(2x,a8) c 4+NL+ 1 dummy a80 c 4+NL+ 2 DUEDX,NG,IS,NZERO,TZERO,TIME,DT c (2x,e13.6,3(2x,i4),3(2x,e13.6)) c DUEDX info for strained flames c NG number of grid points c IS number of dependent variables c NZERO number of grid point where c the freely propogating flame is fixed c TZERO fixed temperature at NZERO c TIME time variable c DT time step c 4+NL+ 3 dummy a80 c 4+NL+ 4 dummy (internal info) a80 c 4+NL+ 5 dummy a80 c 4+NL+ 6- NG blocks of data: c c x,Y(1..kk-1),T,Z(1..IS-(kk+1)) (5(2x,e13.6)) c x distance [m] c Y mass fractions c T temperature [K} c Z other stored data c (e.g. for unstrained flames: c Z(1)= mass flux= rho*v [g/(cm**2 s)] c Z(2)= pressure [Pa} ) c c c no sensitivity data c c------------------------------------------------------------------ c c START of 1st calling c if (it.eq.1) then rewind lfdata read(lfdata,2650,end=90) ititl 2650 format(a76) write(lout,2600) ititl 2600 format(//1x,a76//) read(lfdata,2651) ppa,ifltype c c conversion of Pa to dynes/cm**2 c p= ppa * 10. 2651 format(7x,e12.5,17x,i1) read(lfdata,2650) ititl read(lfdata,2652) nspec,nl 2652 format(7x,i3,35x,i3) if (nspec.ne.kk) goto 91 do 600 i=1,(nl+1) read(lfdata,2650) ititl 600 continue read(lfdata,2653) x1,jj,is,n1,x2,x3,x4 2653 format(2x,e13.6,3(2x,i4),3(2x,e13.6)) if (maxgrid.lt.jj) goto 95 do 601 i=1,3 read(lfdata,2650) ititl 601 continue c c reading the grid point locations and temperatures c do 603 j=1,jj read(lfdata,2654) x(j),(sc(i,j),i=2,kk),sc(1,j), 1 (sfl(i),i=1,is-kk) if (j.eq.1 .and. ifltype.eq.2) flrt= sfl(1) 2654 format(5(2x,e13.6)) c c conversion of height from m to cm c x(j)= x(j)*100. c c calculation of the mass fraction of the last species c sc(kk1,j)= 1. do 602 i=2,kk sc(kk1,j)=sc(kk1,j)-sc(i,j) 602 continue 603 continue c c calculation of mass density c if (ifltype.eq.2) then call ckrhoy(p,sc(1,1),sc(2,1),ickwrk,rckwrk,rho) write(lout,2601) flrt/rho 2601 format(//' Velocity of the flame is ',f7.2,' cm/s') endif c c finding the exterme values c timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. timmin= x(1) timmax= x(jj) do 604 j=1,jj if (sc(1,j).lt.temmin) temmin= sc(1,j) if (sc(1,j).gt.temmax) temmax= sc(1,j) 604 continue c c conversion AT_TEMP points to HEIGHT points c if (ntemp.eq.0) goto 606 if (maxhot.lt. (nhot+ntemp) ) goto 94 do 605 j=1,(jj-1) t1= sc(1,j) t2= sc(1,j+1) do 605 itt=1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 605 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 605 endif c tval= ( t1-temp(itt) )*( t2-temp(itt) ) if ( tval.le.0. ) then if( dabs(t2-t1) .lt. 1.D-30) then f1= 1. f2= 0. else f1= ( t2-temp(itt) ) / (t2-t1) f2= ( temp(itt)-t1 ) / (t2-t1) endif nhot= nhot+1 hot(nhot)= f1*x(j) + f2*x(j+1) c endif 605 continue ntemp= 0 call rorder(nhot,hot) do 615 i=1,nhot 615 hots(i)= hot(i) endif c c END of 1st calling c 606 continue rewind lfdata read(lfdata,2650) ititl read(lfdata,2651) ppa,ifltype c c conversion of Pa to dynes/cm**2 c p= ppa * 10. read(lfdata,2650) ititl read(lfdata,2652) nspec,nl do 607 i=1,(nl+1) read(lfdata,2650) ititl 607 continue read(lfdata,2653) x1,jj,is,n1,x2,x3,x4 do 608 i=1,3 read(lfdata,2650) ititl 608 continue c c reading the grid point locations and temperatures c do 610 j=1,jj read(lfdata,2654) x(j),(sc(i,j),i=2,kk),sc(1,j), 1 (sfl(i),i=1,is-kk) c c conversion of height from m to cm c x(j)= x(j)*100. c c calculation of the mass fraction of the last species c sc(kk1,j)= 1. do 609 i=2,kk sc(kk1,j)=sc(kk1,j)-sc(i,j) 609 continue 610 continue c c search for points c do 611 j=1,(jj-1) tval= (x(j)-hot(it))*(x(j+1)-hot(it)) if ( tval.le. 0.0 ) goto 612 611 continue goto 999 c c a point was found c 612 continue jp= j f1= (x(jp+1)-hot(it))/(x(jp+1)-x(jp)) f2= (hot(it) -x(jp))/(x(jp+1)-x(jp)) hort= hot(it) do 613 k=1,kk1 ctp(k)= f1*sc(k,jp) + f2*sc(k,jp+1) 613 continue c write(lout,2006) hort,ctp(2),ctp(1)/pa c do 614 k=1,kk 614 ctp2(k)= ctp(k+2) write(lout,2008) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mass fractions to molar concentrations (mole/cm**3) c call ckytcp(p,ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) goto 99 c c------------------------------------------------------------------- 7 continue c c OPPDIF c c Structure of data: c c ICKLNK 'CKLINK ' (character*16) c c IMCLNK 'MCLINK ' (character*16) c c ISOLUT 'SOLUTION ' (character*16) c c ncomp number of variables= kk+4 c jj number of grid points c p pressure (dynes/cm2) c vfuel mass flow rate of the fuel (g /(cm2 sec)) c voxid mass flow rate of the oxidizer (g /(cm2 sec)) c x(1..jj) grid point locations (cm) c sc(1..ncomp,1..jj) temperature, G, F, H, mass fractions c c ISENSI 'SENSITIVITY ' (character*16) c c repeated ii times: c i No of reaction c sn(1..ncomp,1..jj) normalized first order sensitivity coefficients c of temperature, G, F, H, and mass fractions c with respect to rate parameters c c----------------------------------------------------------------------- c if (it.eq.1) then c c START of 1st calling c rewind ldata 700 continue read(ldata,end=90) ichr if (ichr.ne.ISOLUT) goto 700 read(ldata,end=90) ncomp,jj,p read(ldata,end=90) vfuel,voxid kkd = ncomp-4 if (kkd .ne.kk) goto 91 if (maxgrid.lt.jj) goto 95 c c reading the grid point locations and the temperatures c read(ldata) (x(j),j=1,jj) read(ldata) (sc(1,j),rG,rF,rH,(sc(i,j),i=2,kk+1),j=1,jj) c c finding the exterme values c timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. timmin= x(1) timmax= x(jj) do 701 j=1,jj if (sc(1,j).lt.temmin) temmin= sc(1,j) if (sc(1,j).gt.temmax) temmax= sc(1,j) 701 continue c c conversion AT_TEMP points to HEIGHT points c if (ntemp.eq.0) goto 708 if (maxhot.lt. (nhot+ntemp) ) goto 94 do 702 j=1,(jj-1) t1= sc(1,j) t2= sc(1,j+1) do 702 itt=1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 702 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 702 endif c tval= ( t1-temp(itt) )*( t2-temp(itt) ) if ( tval.le.0. ) then if( dabs(t2-t1) .lt. 1.D-30) then f1= 1. f2= 0. else f1= ( t2-temp(itt) ) / (t2-t1) f2= ( temp(itt)-t1 ) / (t2-t1) endif nhot= nhot+1 hot(nhot)= f1*x(j) + f2*x(j+1) c endif 702 continue ntemp= 0 call rorder(nhot,hot) do 720 i=1,nhot 720 hots(i)= hot(i) endif c c END of 1st calling c c====================================================================== 708 continue write(lout,2014) rewind ldata 709 continue read(ldata,end=90) ichr if (ichr.ne.ISOLUT) goto 709 read(ldata,end=90) ncomp,jj,p read(ldata,end=90) vfuel,voxid c c reading the grid point locations c read(ldata) (x(j),j=1,jj) do 710 j=1,(jj-1) tval= (x(j)-hot(it))*(x(j+1)-hot(it)) if ( tval.le. 0.0 ) goto 711 710 continue goto 999 c c a point was found c 711 continue jp= j f1= (x(jp+1)-hot(it))/(x(jp+1)-x(jp)) f2= (hot(it) -x(jp))/(x(jp+1)-x(jp)) hort= hot(it) c read(ldata) (sc(1,j),rG,rF,rH,(sc(i,j),i=2,kk+1),j=1,jj) ctp(1)= p do 712 k=1,kk1 ctp(k+1)= f1*sc(k,jp) + f2*sc(k,jp+1) 712 continue c if(.not.lsens) goto 718 c c reading sensitivity data c 713 continue read(ldata,end=718,err=718) ichr if ( ichr.eq.ISENSI) goto 714 goto 713 714 continue do 716 iv=1,ii read(ldata,end=718) is, 1 (sc(1,j),rG,rF,rH,(sc(i,j),i=2,kk+1),j=1,jj) do 715 k=1,kk1 s(k,is)= f1*sc(k,jp) + f2*sc(k,jp+1) 715 continue 716 continue lsend= .true. c c success! c 718 continue hot(it)= -1.D+50 c write(lout,2006) hort,ctp(2),ctp(1)/pa do 719 k=1,kk 719 ctp2(k)= ctp(k+2) write(lout,2008) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mass fractions to molar concentrations (mole/cm**3) c call ckytcp(p,ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) goto 99 c c------------------------------------------------------------------- 8 continue c c AURORA write(lout,800) 800 format(' AURORA is not a CHEMKIN-II program.'/ 1 ' --- PROGRAM TERMINATED ---'/) stop c c------------------------------------------------------------------- 9 continue c c EQLIB write(lout,900) 900 format(' EQLIB is not a CHEMKIN-II program.'/ 1 ' --- PROGRAM TERMINATED ---'/) stop c c------------------------------------------------------------------- c c fatal error messages c 90 continue write(lout,2090) 2090 format(' The file you indicated as the source of'/ 1 ' unformatted data does not exist or is empty.'/ 2 '----- PROGRAM TERMINATED -----') stop 91 continue write(lout,2091) kkd,kk 2091 format(//5x,'Number of species in data file does not agree with'/ 1 5x,'the number of species in the link file'// 2 5x,'Number of species in the data file: ',i3/ 3 5x,'Number of species in the link file: ',i3// 4 5x,' --- PROGRAM TERMINATED ---') stop 92 continue write(lout,2092) iid,ii 2092 format( 1 //5x,'Number of reactions in data file does not agree with'/ 2 5x,'the number of reactions in the link file'// 3 5x,'Number of reactions in the data file: ',i3/ 4 5x,'Number of reactions in the link file: ',i3// 5 5x,' --- PROGRAM TERMINATED ---') stop 93 continue write(lout,2093) maxhot, (nhot+ntemp) 2093 format(//5x,'The current value of parameter maxhot in'/ 1 5x,'subroutine KINALC is',i4// 2 5x,'This value has to be higher than the sum'/ 3 5x,'of the number of TIME and AT_TEMP points:',i4// 4 5x,' --- PROGRAM TERMINATED ---') stop 94 continue write(lout,2094) maxhot, (nhot+ntemp) 2094 format(//5x,'The current value of parameter maxhot in'/ 1 5x,'subroutine KINALC is',i4// 2 5x,'This value has to be higher than the sum'/ 3 5x,'of the number of HEIGHT and AT_TEMP points:',i4// 4 5x,' --- PROGRAM TERMINATED ---') stop 95 continue write(lout,2095) maxgrid, jj 2095 format(//5x,'The current value of parameter maxgrid in'/ 1 5x,'subroutine KINALC is',i4// 2 5x,'This value has to be higher than the number of'/ 3 5x,'grid points in the PREMIX save file:',i4// 4 5x,' --- PROGRAM TERMINATED ---') stop 97 continue write(lout,2097) 2097 format(//5x,'This version of KINALC can not read'/ 1 5x,'the surface EQUIL save file.',// 2 5x,' --- PROGRAM TERMINATED ---') stop c c-------------------------------------------------------------------- c c no such point c 999 continue dend= .true. return c c-------------------------------------------------------------------- c c successful return c 99 continue write(lout,2009) write(lout,2010) (kname(k),ctp(k+2),k=1,kk) call ckwc (ctp(2),ctp(3),ickwrk,rckwrk,ctp2) write(lout,2011) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c lsens= .false. lhsens= .false. if (lsend) lsens= .TRUE. if (lhsend) lhsens= .TRUE. c return c--------------------------------------------------------------------- c c common formats c 2000 format(/ 1 ' The data file does not contain sensitivity information'/ 2 ' Requests for PCAS, SENS, SENG or RALI are neglected.'//) 2001 format(' The requested TIME is less then the first entry'/ 1 ' in the data file. The first time will be used.') 2002 format(' The requested HEIGHT is less then the first entry'/ 1 ' in the data file. The first height will be used.') 2003 format( 1 ' ***************************************', 2 '****************************************'/// 3 'The requested TIME is higher then the last entry'/ 4 'in the data file. The last time will be used.') 2004 format( 'The requested HEIGHT is higher then the last entry'/ 1 'in the data file. The last height will be used.') 2005 format(// 1 ' ***************************************', 2 '****************************************'// 3 5x,' ------------ TIME = ',1pg12.5,' s ------------'// 4 5x,' temperature = ',0pf7.2, 5 ' K pressure = ',0pf7.3,' atm'/) 2006 format(// 1 ' ***************************************', 2 '****************************************'// 3 5x,' ------------ HEIGHT = ',1pg12.5,' cm ----------'// 4 5x,' temperature = ',0pf7.2, 5 ' K pressure = ',0pf7.3,' atm'/) 2007 format(' Mole fractions : '//) 2008 format(' Mass fractions : '//) 2009 format(/' Concentrations (mole/cm**3) : '//) 2010 format(5x,a16,1pe16.5,5x,a16,1pe16.5) 2011 format(/' Molar production rates (mole/(cm**3 * sec)) :'//) 2012 format(/' Temperature value of ',f7.2,' K given by AT_TEMP is', 1 ' lower'/' than the minimal simulated temperature of ', 2 f7.2,' K.') 2013 format(/' Temperature value of ',f7.2,' K given by AT_TEMP is', 1 ' higher'/' than the maximal simulated temperature of ', 2 f7.2,' K.') 2014 format(//) end c-------------------------------------------------------------------- c c subroutine for reading CHEMKIN-III save files c subroutine readc3(lout,ldata,lfdata,leniwk,lenrwk, 1 kk,ii,indata,it,nsys,imolf,ickwrk,rckwrk, 2 ctp,s,hs,ctp2,s2,sfl,hsfl,sc,kname,lsens,lhsens, 3 dend,maxhot,nhot,hot,maxtemp,ntemp,temp,maxgrid,x, 4 timmin,timmax,temmin,temmax,lsfld,lhsfld,hots,flvelo) implicit double precision (a-h, o-z), integer (i-n) dimension ickwrk(leniwk),rckwrk(lenrwk) dimension ctp (kk+2),s (kk+1,ii), hs (kk+1,kk) dimension ctp2(kk+2),s2(kk+1,ii) dimension hot(maxhot),temp(maxtemp),x(maxgrid),sfl(ii) dimension hsfl(kk),sc(kk+1,maxgrid),hots(maxhot) character*(*) kname(kk) character ititl*76 logical lsens,lhsens,lsend,lhsend,lsfld,lhsfld,dend CHARACTER*16 ICHR, ISOLUT, ISENSI, IHSENS DATA ISOLUT/'SOLUTION '/, ISENSI/'SENSITIVITY '/, 1 IHSENS/'HSENSITIVITY '/ if (dend) return c c indata source of data (1-6) c it serial number of calling c lsens= .true. reading of sensitivities is required c lhsens= .true. reading of H sensitivities is required c lsend= .true. the data file contains sensitivity info c lhsend= .true. the data file contains H sensitivity info c lsfld= .true. the data file contains flame sensitivity info c lhsfld= .true. the data file contains H flame sensitivity info c ctp(1) pressure [dynes/cm**2] c ctp(2) temperature [K] c ctp(3..kk+2) molar concentrations [mole/cm**3] c s normalized concentration sensitivities c if (it.gt.(nhot+ntemp)) goto 999 kk1= kk+1 kk2= kk+2 do 50 k=1,kk2 ctp (k)= 0. ctp2(k)= 0. 50 continue do 51 k=1,kk1 do 51 i=1,ii s (k,i)= 0. s2(k,i)= 0. 51 continue c lsend= .false. lhsend= .false. lsfld= .false. lhsfld= .false. c call ckrp(ickwrk,rckwrk,ru,ruc,pa) c c indata source of data c 1 SENKIN c 2 PREMIX c 3 not used in CHEMKIN-III mode c 4 SHOCK c 5 not used in CHEMKIN-III mode c 6 not used in CHEMKIN-III mode c 7 OPPDIF c 8 AURORA c 9 EQUIL c goto (1,2,3,4,5,6,7,8,9) indata c c------------------------------------------------------------------- 1 continue c c SENKIN c c Structure of data: c c lsend sensitivity coefficients are written (true/false) c nsys number of variables c nsys=kk+1 for cases A-C c nsys=kk for cases D-E c kkd number of species c iid number of reactions c c repeated nstep times: c time time (sec) c p pressure (dynes/cm2) c temp temperature (K) c y(1..kk) species mass fractions c s(1..nsys,1..ii) sensitivity coefficients c if (it.eq.1) then c c START of 1st calling c rewind ldata 199 continue read(ldata,end=90) ichr if (ichr.ne.'SENKIN SOLUTION') goto 199 read(ldata,end=90) lsend read(ldata) nsys,kkd,iid c if (kkd.ne.kk) goto 91 if (iid.ne.ii) goto 92 c ioff= kk-nsys+1 read(ldata,end=102) time,(ctp(k),k=1,kk2) if(lsend) then read(ldata) ((s(k+ioff,i),k=1,nsys),i=1,ii) endif timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. if (time .lt.timmin) timmin= time if (time .gt.timmax) timmax= time if (ctp(2).lt.temmin) temmin= ctp(2) if (ctp(2).gt.temmax) temmax= ctp(2) c 100 continue read(ldata,end=102) time2,(ctp2(k),k=1,kk2) if(lsend) then read(ldata) ((s(k+ioff,i),k=1,nsys),i=1,ii) endif c if (time2 .lt.timmin) timmin= time2 if (time2 .gt.timmax) timmax= time2 if (ctp2(2).lt.temmin) temmin= ctp2(2) if (ctp2(2).gt.temmax) temmax= ctp2(2) c c conversion of AT_TEMP points to TIME points c if(ntemp.eq.0) goto 100 if(maxhot.lt.(nhot+ntemp)) goto 93 do 101 itt= 1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 101 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 101 endif c tval= (ctp(2)-temp(itt))*(ctp2(2)-temp(itt)) if (tval .le. 0.) then if(dabs(ctp2(2)-ctp(2)).lt.1.d-30) then f1= 1. f2= 0. else f1= (ctp2(2) -temp(itt))/(ctp2(2)-ctp(2)) f2= (temp(itt)-ctp(2)) /(ctp2(2)-ctp(2)) endif nhot= nhot+1 hot(nhot)= f1*time + f2*time2 endif 101 continue c time= time2 ctp(2)= ctp2(2) goto 100 c c finished going through the datafile once c 102 continue ntemp= 0 call rorder(nhot,hot) do 114 i=1,nhot 114 hots(i)= hot(i) endif c c END of 1st calling c rewind ldata 198 continue read(ldata,end=90) ichr if (ichr.ne.'SENKIN SOLUTION') goto 198 read(ldata,end=90) lsend read(ldata) nsys,kkd,iid do 103 i=1,ii s (1,i)= 0. 103 s2(1,i)= 0. ioff= kk-nsys+1 c c reading the first data c read(ldata,end=999) time,(ctp(k),k=1,kk2) if(lsend) then read(ldata) ((s(k+ioff,i),k=1,nsys),i=1,ii) endif c c reading further data c 104 continue read(ldata,end=999) time2,(ctp2(k),k=1,kk2) if(lsend) then read(ldata) ((s2(k+ioff,i),k=1,nsys),i=1,ii) endif c do 107 itt=1,nhot tval= (time-hot(itt))*(time2-hot(itt)) if ( tval.le. 0.0 ) then f1= (time2-hot(itt))/(time2-time) f2= (hot(itt)-time) /(time2-time) hort= hot(itt) do 105 k=1,kk2 105 ctp(k)= f1*ctp(k) + f2*ctp2(k) if (lsens) then do 106 i=1,ii do 106 k=1,kk1 106 s(k,i)= f1*s(k,i) + f2*s2(k,i) endif hot(itt)= -1.D+50 goto 110 endif 107 continue c c the requested data has not been found yet c time= time2 do 108 k=1,kk2 108 ctp(k)= ctp2(k) if (lsens) then do 109 k=1,kk1 do 109 i=1,ii 109 s(k,i)= s2(k,i) endif goto 104 c c success! c 110 continue c write(lout,2005) hort,ctp(2),ctp(1)/pa c c normalizing the sensitivities c do 111 k=1,kk1 do 111 i=1,ii call ckraex(i,rckwrk,ra) if (dabs(ctp(k+1)) .gt. 1.d-30) s(k,i)= s(k,i)*ra/ctp(k+1) 111 continue c do 112 k=1,kk 112 ctp2(k)= ctp(k+2) write(lout,2008) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mass fractions to molar concentrations (mole/cm**3) c call ckytcp(ctp(1),ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) goto 99 c c------------------------------------------------------------------- 2 continue c c PREMIX c c Structure of data: c c ICKLNK 'CKLINK ' (character*16) c c IMCLNK 'MCLINK ' (character*16) c c ISOLUT 'SOLUTION ' (character*16) c c ncomp number of variables= kk+2 c jj number of grid points c p pressure (dynes/cm2) c flrt mass flow rate (g /(cm2 sec)) c x(1..jj) grid point locations (cm) c s(1..ncomp,1..jj) temperature, mass fractions, mass flow rate c c ISENSI 'SENSITIVITY ' (character*16) c c repeated ii times: c i No of reaction c fosc(1..ncomp,1..jj) normalized first order sensitivity coefficients c of temperature, mass fractions, and mass flow rate c with respect to rate parameters c c IHSENS 'HSENSITIVITY ' (character*16) c c repeated kk times: c k No of species c sn(1..ncomp,1..jj) normalized first order sensitivity coefficients c of temperature, mass fractions, and mass flow rate c with respect to species heats of formation c if (it.eq.1) then c c START for the 1st calling only c rewind ldata 200 continue read(ldata,end=90) ichr if (ichr.ne.ISOLUT) goto 200 read(ldata,end=90) ncomp,jj,p,flrt kkd= ncomp-2 if (kkd .ne.kk) goto 91 if (maxgrid.lt.jj) goto 95 c c reading the grid point locations and the temperatures c read(ldata) (x(j),j=1,jj) read(ldata) ((sc(i,j),i=1,kk1),flrth,j=1,jj) c c calculation of mass density c call ckrhoy(p,sc(1,1),sc(2,1),ickwrk,rckwrk,rho) flvelo= flrt/rho c c finding the exterme values c timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. timmin= x(1) timmax= x(jj) do 201 j=1,jj if (sc(1,j).lt.temmin) temmin= sc(1,j) if (sc(1,j).gt.temmax) temmax= sc(1,j) 201 continue c c conversion AT_TEMP points to HEIGHT points c if (ntemp.eq.0) goto 203 if (maxhot.lt. (nhot+ntemp) ) goto 94 do 202 j=1,(jj-1) t1= sc(1,j) t2= sc(1,j+1) do 202 itt=1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 202 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 202 endif c tval= ( t1-temp(itt) )*( t2-temp(itt) ) if ( tval.le.0. ) then if( dabs(t2-t1) .lt. 1.D-30) then f1= 1. f2= 0. else f1= ( t2-temp(itt) ) / (t2-t1) f2= ( temp(itt)-t1 ) / (t2-t1) endif nhot= nhot+1 hot(nhot)= f1*x(j) + f2*x(j+1) c endif 202 continue ntemp= 0 call rorder(nhot,hot) do 220 i=1,nhot 220 hots(i)= hot(i) c c any sensitivities? c if (.not.(lsens.or.lhsens)) goto 208 203 continue read(ldata,end=208,err=208) ichr if ( ichr.eq.ISENSI) goto 204 if ( ichr.eq.IHSENS) goto 221 goto 203 c c flame velocity sensitivities c 204 continue if(.not.lsens) goto 203 do 205 i=1,ii read(ldata,end=208) is,((sc(k,j),k=1,kk1),x(j),j=1,jj) sfl(i)= x(1) 205 continue lsfld= .true. goto 203 c c H flame velocity sensitivities c 221 continue do 222 i=1,kk read(ldata,end=208) is,((sc(k,j),k=1,kk1),x(j),j=1,jj) hsfl(i)= x(1) 222 continue lhsfld= .true. goto 203 endif c c END for the 1st calling only c c====================================================================== 208 continue write(lout,2014) rewind ldata 209 continue read(ldata,end=90) ichr if (ichr.ne.ISOLUT) goto 209 read(ldata,end=90) ncomp,jj,p,flrt c c reading the grid point locations c read(ldata) (x(j),j=1,jj) do 210 j=1,(jj-1) tval= (x(j)-hot(it))*(x(j+1)-hot(it)) if ( tval.le. 0.0 ) goto 211 210 continue goto 999 c c a point was found c 211 continue jp= j f1= (x(jp+1)-hot(it))/(x(jp+1)-x(jp)) f2= (hot(it) -x(jp))/(x(jp+1)-x(jp)) hort= hot(it) c read(ldata) ((sc(i,j),i=1,kk1),flrt,j=1,jj) ctp(1)= p do 212 k=1,kk1 ctp(k+1)= f1*sc(k,jp) + f2*sc(k,jp+1) 212 continue c c any sensitivities? c if (.not.(lsens.or.lhsens)) goto 218 213 continue read(ldata,end=218,err=218) ichr if ( ichr.eq.ISENSI) goto 214 if ( ichr.eq.IHSENS) goto 224 goto 213 c c reading sensitivities c 214 continue if(.not.lsens) goto 213 do 216 iv=1,ii read(ldata,end=218) is,((sc(i,j),i=1,kk1),x(j),j=1,jj) do 215 k=1,kk1 s(k,is)= f1*sc(k,jp) + f2*sc(k,jp+1) 215 continue 216 continue lsend= .true. goto 213 c c reading heat-of-formation sensitivities c 223 continue read(ldata,end=218,err=218) ichr if ( ichr.eq.IHSENS) goto 224 goto 223 c c reading H sensitivities c 224 continue if(.not.lhsens) goto 218 do 226 iv=1,kk read(ldata,end=218) is,((sc(i,j),i=1,kk1),x(j),j=1,jj) do 225 k=1,kk1 hs(k,is)= f1*sc(k,jp) + f2*sc(k,jp+1) 225 continue 226 continue lhsend= .true. c c success! c 218 continue hot(it)= -1.D+50 c write(lout,2006) hort,ctp(2),ctp(1)/pa do 219 k=1,kk 219 ctp2(k)= ctp(k+2) write(lout,2008) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mass fractions to molar concentrations (mole/cm**3) c call ckytcp(p,ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) goto 99 c c------------------------------------------------------------------- 3 continue c c PSR write(lout,300) 300 format(' PSR is not a CHEMKIN-III program.'/ 1 ' --- PROGRAM TERMINATED ---'/) stop c c------------------------------------------------------------------- 4 continue c c SHOCK c c ch1 'SOLUTION' (character*16) c ititl title of the problem (character*76) c c iprb 1 incident shock problem with boundary layer correction c 2 incident shock problem without boundary layer correction c 3 reflected shock problem c c imolf 0 the unit of x is molar concentrations c 1 the unit of x is mole fractions c c repeated nstep times: c tt1 time (sec) c t temperature (K) c pa pressure (atm) c rho density (g/cm3) c wtm mean molecular weight (Dalton) c area cross-sectional area (cm2) c v velocity (cm/s) c tl laboratory time (sec) c x(1..kk) species concentrations (molar concentrations OR mole fractions) c if (it.eq.1) then c c START of 1st calling c rewind ldata 411 continue read(ldata,end=90) ichr if(ichr.ne.ISOLUT) goto 411 read(ldata,end=90) ititl,iprb,imolf write(lout,2400) ititl 2400 format(//1x,a76//) if (iprb.eq.1) write(lout,2401) if (iprb.eq.2) write(lout,2402) if (iprb.eq.3) write(lout,2403) 2401 format(/' incident shock problem with', 1 ' boundary layer correction') 2402 format(/' incident shock problem without', 1 ' boundary layer correction') 2403 format(/' reflected shock problem') c read(ldata) time,ctp(2),p,rho,wtm,area,v,tl,(ctp(k),k=3,kk+2) c timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. if (time .lt.timmin) timmin= time if (time .gt.timmax) timmax= time if (ctp(2).lt.temmin) temmin= ctp(2) if (ctp(2).gt.temmax) temmax= ctp(2) c 400 continue read(ldata,end=403) time2,ctp2(2),p2,rho2,wtm2,area2,v2,tl2, 1 (ctp2(k),k=3,kk+2) c if (time2 .lt.timmin) timmin= time2 if (time2 .gt.timmax) timmax= time2 if (ctp2(2).lt.temmin) temmin= ctp2(2) if (ctp2(2).gt.temmax) temmax= ctp2(2) c c conversion of AT_TEMP points to TIME points c if(ntemp.eq.0) goto 402 if(maxhot.lt.(nhot+ntemp)) goto 93 do 401 itt= 1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 401 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 401 endif c tval= (ctp(2)-temp(itt))*(ctp2(2)-temp(itt)) if (tval .le. 0.) then if(dabs(ctp2(2)-ctp(2)).lt.1.d-30) then f1= 1. f2= 0. else f1= (ctp2(2) -temp(itt))/(ctp2(2)-ctp(2)) f2= (temp(itt)-ctp(2)) /(ctp2(2)-ctp(2)) endif nhot= nhot+1 hot(nhot)= f1*time + f2*time2 endif 401 continue c 402 continue time= time2 ctp(2)= ctp2(2) goto 400 c c finished going through the datafile once c 403 continue ntemp= 0 call rorder(nhot,hot) do 410 i=1,nhot 410 hots(i)= hot(i) endif c c END of 1st calling c rewind ldata 412 continue read(ldata,end=90) ichr if(ichr.ne.ISOLUT) goto 412 read(ldata,end=90) ititl,iprb,imolf read(ldata) time,ctp(2),p,rho,wtm,area,v,tl,(ctp(k),k=3,kk+2) 404 continue read(ldata,end=999) time2,ctp2(2),p2,rho2,wtm2,area2,v2,tl2, 1 (ctp2(k),k=3,kk+2) c do 406 itt=1,nhot tval= (time-hot(itt))*(time2-hot(itt)) if ( tval.le. 0.0 ) then hort= hot(itt) f1= (time2-hot(itt))/(time2-time) f2= (hot(itt)-time) /(time2-time) p= f1*p + f2*p2 rho= f1*rho + f2*rho2 wtm= f1*wtm + f2*wtm2 area= f1*area + f2*area2 v= f1*v + f2*v2 tl= f1*tl + f2*tl2 ctp(1)= p do 405 k=2,kk+2 ctp(k)= f1*ctp(k) + f2*ctp2(k) 405 continue hot(itt)= -1.D+50 goto 408 endif 406 continue c c the requested data has not been found yet c time= time2 p= p2 rho= rho2 wtm= wtm2 area= area2 v= v2 tl= tl2 ctp(1)= p do 407 k=2,kk+2 ctp(k)= ctp2(k) 407 continue goto 404 c c success! c 408 continue write(lout,2005) hort,ctp(2),ctp(1) write(lout,2405) rho,wtm,area,v,tl 2405 format(// 1 ' rho =',1pe12.5,' g/cm3'/ 2 ' wtm =',1pe12.5,' Dalton'/ 3 ' area =',1pe12.5,' cm2'/ 4 ' v =',1pe12.5,' cm/s'/ 5 ' t_lab =',1pe12.5,' sec'//) if (imolf.eq.1) then do 409 k=1,kk+2 409 ctp2(k)= ctp(k) write(lout,2007) write(lout,2010) (kname(k),ctp2(k+2),k=1,kk) c c changing mole fractions to molar concentrations (mole/cm**3) c call ckxtcp(p,ctp(2),ctp2(3),ickwrk,rckwrk,ctp(3)) endif c write(lout,2009) write(lout,2010) (kname(k),ctp(k+2),k=1,kk) goto 99 c c------------------------------------------------------------------- 5 continue c c EQLIB write(lout,500) 500 format(' EQLIB is not a CHEMKIN-III program.'/ 1 ' --- PROGRAM TERMINATED ---'/) stop c c------------------------------------------------------------------- 6 continue c c RUN1DL write(lout,600) 600 format(' RUN1DL is not a CHEMKIN-III program.'/ 1 ' --- PROGRAM TERMINATED ---'/) stop c c------------------------------------------------------------------- 7 continue c c OPPDIF c c Structure of data: c c ICKLNK 'CKLINK ' (character*16) c c IMCLNK 'MCLINK ' (character*16) c c ISOLUT 'SOLUTION ' (character*16) c c ncomp number of variables= kk+4 c jj number of grid points c p pressure (dynes/cm2) c vfuel mass flow rate of the fuel (g /(cm2 sec)) c voxid mass flow rate of the oxidizer (g /(cm2 sec)) c x(1..jj) grid point locations (cm) c sc(1..ncomp,1..jj) temperature, G, F, H, mass fractions c c ISENSI 'SENSITIVITY ' (character*16) c c repeated ii times: c i No of reaction c sn(1..ncomp,1..jj) normalized first order sensitivity coefficients c of temperature, G, F, H, and mass fractions c with respect to rate parameters c c----------------------------------------------------------------------- c if (it.eq.1) then c c START of 1st calling c rewind ldata 700 continue read(ldata,end=90) ichr if (ichr.ne.ISOLUT) goto 700 read(ldata,end=90) ncomp,jj,p,afuel,aoxid,vfuel,voxid,iccord kkd = ncomp-4 if (kkd .ne.kk) goto 91 if (maxgrid.lt.jj) goto 95 c c reading the grid point locations and the temperatures c read(ldata) (x(j),j=1,jj) read(ldata) (sc(1,j),rG,rF,rH,(sc(i,j),i=2,kk+1),j=1,jj) c c finding the exterme values c timmin= 1.D+50 timmax= -1.D+50 temmin= 10000. temmax= -10000. timmin= x(1) timmax= x(jj) do 701 j=1,jj if (sc(1,j).lt.temmin) temmin= sc(1,j) if (sc(1,j).gt.temmax) temmax= sc(1,j) 701 continue c c conversion AT_TEMP points to HEIGHT points c if (ntemp.eq.0) goto 708 if (maxhot.lt. (nhot+ntemp) ) goto 94 do 702 j=1,(jj-1) t1= sc(1,j) t2= sc(1,j+1) do 702 itt=1,ntemp c if (temp(itt).lt.temmin) then write(lout,2012) temp(itt), temmin goto 702 endif if (temp(itt).gt.temmax) then write(lout,2013) temp(itt), temmax goto 702 endif c tval= ( t1-temp(itt) )*( t2-temp(itt) ) if ( tval.le.0. ) then if( dabs(t2-t1) .lt. 1.D-30) then f1= 1. f2= 0. else f1= ( t2-temp(itt) ) / (t2-t1) f2= ( temp(itt)-t1 ) / (t2-t1) endif nhot= nhot+1 hot(nhot)= f1*x(j) + f2*x(j+1) c endif 702 continue ntemp= 0 call rorder(nhot,hot) do 720 i=1,nhot 720 hots(i)= hot(i) endif c c END of 1st calling c c====================================================================== 708 continue write(lout,2014) rewind ldata 709 continue read(ldata,end=90) ichr if (ichr.ne.ISOLUT) goto 709 read(ldata,end=90) ncomp,jj,p,afuel,aoxid,vfuel,voxid,iccord c c reading the grid point locations c read(ldata) (x(j),j=1,jj) do 710 j=1,(jj-1) tval= (x(j)-hot(it))*(x(j+1)-hot(it)) if ( tval.le. 0.0 ) goto 711 710 continue goto 999 c c a point was found c 711 continue jp= j f1= (x(jp+1)-hot(it))/(x(jp+1)-x(jp)) f2= (hot(it) -x(jp))/(x(jp+1)-x(jp)) hort= hot(it) c read(ldata) (sc(1,j),rG,rF,rH,(sc(i,j),i=2,kk+1),j=1,jj) ctp(1)= p do 712 k=1,kk1 ctp(k+1)= f1*sc(k,jp) + f2*sc(k,jp+1) 712 continue c if(.not.lsens) goto 718 c c reading sensitivity data c 713 continue read(ldata,end=718,err=718) ichr if ( ichr.eq.ISENSI) goto 714 goto 713 714 continue do 716 iv=1,ii read(ldata,end=718) is, 1 (sc(1,j),rG,rF,rH,(sc(i,j),i=2,kk+1),j=1,jj) do 715 k=1,kk1 s(k,is)= f1*sc(k,jp) + f2*sc(k,jp+1) 715 continue 716 continue lsend= .true. c c success! c 718 continue hot(it)= -1.D+50 c write(lout,2006) hort,ctp(2),ctp(1)/pa do 719 k=1,kk 719 ctp2(k)= ctp(k+2) write(lout,2008) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mass fractions to molar concentrations (mole/cm**3) c call ckytcp(p,ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) goto 99 c c------------------------------------------------------------------- 8 continue c c AURORA c c Structure of data: c write(lout,800) 800 format(//5x,'Sorry, this version of KINALC cannot'/ 1 5x,'read an AURORA save file.',// 2 5x,' --- PROGRAM TERMINATED ---') stop c c c------------------------------------------------------------------- 9 continue c c EQUIL c c isrfch - integer flag indicating whether or not a surface c chemkin input file was used in the calculation c 1= surface chemistry used, 0= no surface chemistry c c no surface chemisty record can be read in this version c c two records: one for the initial state and c one for the equilibrium state c c t temperature (K) c p pressure (atm) c U U (erg/g) c H H (erg/g) c S S ( erg/(g K) ) c V V (cm3/g) c C C (cm/sec) c x(1..kk) species concentrations (mole fractions) c rewind ldata 901 continue read(ldata,end=90) ichr if(ichr.ne.ISOLUT) goto 901 read(ldata,end=90) isrfch if (isrfch.eq.1) goto 96 read(ldata,end=90) ctp(2),pp,U,H,Se,V,C,(ctp2(k),k=1,kk), 1 ctp(2),pp,U,H,Se,V,C,(ctp2(k),k=1,kk) c c changing dynes/cm**2 to atm c ctp(1)= pp*pa write(lout,2500) ctp(2),pp,U,H,Se,V,C 2500 format(// 1 ' ***************************************', 2 '****************************************'// 3 5x,' --------------- EQUILIBRIUM STATE --------------'// 4 5x,' temperature = ' ,f7.2, 5 ' K pressure = ',f7.3,' atm'// 6 5x,' U= ', 1pe12.5,' erg/g '/ 7 5x,' H= ', 1pe12.5,' erg/g '/ 8 5x,' S= ', 1pe12.5,' erg/gK '/ 9 5x,' V= ', 1pe12.5,' cm3/g '/ a 5x,' C= ', 1pe12.5,' cm/sec '//) write(lout,2007) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c c changing mole fractions to molar concentrations (mole/cm**3) c call ckxtcp(ctp(1),ctp(2),ctp2,ickwrk,rckwrk,ctp(3)) c goto 99 c c------------------------------------------------------------------- c c fatal error messages c 90 continue write(lout,2090) 2090 format(' The file you indicated as the source of'/ 1 ' unformatted data does not exist or is empty.'/ 2 '----- PROGRAM TERMINATED -----') stop 91 continue write(lout,2091) kkd,kk 2091 format(//5x,'Number of species in data file does not agree with'/ 1 5x,'the number of species in the link file'// 2 5x,'Number of species in the data file: ',i3/ 3 5x,'Number of species in the link file: ',i3// 4 5x,' --- PROGRAM TERMINATED ---') stop 92 continue write(lout,2092) iid,ii 2092 format( 1 //5x,'Number of reactions in data file does not agree with'/ 2 5x,'the number of reactions in the link file'// 3 5x,'Number of reactions in the data file: ',i3/ 4 5x,'Number of reactions in the link file: ',i3// 5 5x,' --- PROGRAM TERMINATED ---') stop 93 continue write(lout,2093) maxhot, (nhot+ntemp) 2093 format(//5x,'The current value of parameter maxhot in'/ 1 5x,'subroutine KINALC is',i4// 2 5x,'This value has to be higher than the sum'/ 3 5x,'of the number of TIME and AT_TEMP points:',i4// 4 5x,' --- PROGRAM TERMINATED ---') stop 94 continue write(lout,2094) maxhot, (nhot+ntemp) 2094 format(//5x,'The current value of parameter maxhot in'/ 1 5x,'subroutine KINALC is',i4// 2 5x,'This value has to be higher than the sum'/ 3 5x,'of the number of HEIGHT and AT_TEMP points:',i4// 4 5x,' --- PROGRAM TERMINATED ---') stop 95 continue write(lout,2095) maxgrid, jj 2095 format(//5x,'The current value of parameter maxgrid in'/ 1 5x,'subroutine KINALC is',i4// 2 5x,'This value has to be higher than the number of'/ 3 5x,'grid points in the PREMIX save file:',i4// 4 5x,' --- PROGRAM TERMINATED ---') stop 96 continue write(lout,2096) 2096 format(//5x,'The current version of KINALC can not read'/ 1 5x,'the surface EQUIL save file.',// 2 5x,' --- PROGRAM TERMINATED ---') stop c c-------------------------------------------------------------------- c c no such point c 999 continue dend= .true. return c c-------------------------------------------------------------------- c c successful return c 99 continue write(lout,2009) write(lout,2010) (kname(k),ctp(k+2),k=1,kk) call ckwc (ctp(2),ctp(3),ickwrk,rckwrk,ctp2) write(lout,2011) write(lout,2010) (kname(k),ctp2(k),k=1,kk) c lsens= .false. lhsens= .false. if (lsend) lsens= .TRUE. if (lhsend) lhsens= .TRUE. c return c--------------------------------------------------------------------- c c common formats c 2000 format(/ 1 ' The data file does not contain sensitivity information'/ 2 ' Requests for PCAS, SENS, SENG or RALI are neglected.'//) 2001 format(' The requested TIME is less then the first entry'/ 1 ' in the data file. The first time will be used.') 2002 format(' The requested HEIGHT is less then the first entry'/ 1 ' in the data file. The first height will be used.') 2003 format( 1 ' ***************************************', 2 '****************************************'/// 3 'The requested TIME is higher then the last entry'/ 4 'in the data file. The last time will be used.') 2004 format( 'The requested HEIGHT is higher then the last entry'/ 1 'in the data file. The last height will be used.') 2005 format(// 1 ' ***************************************', 2 '****************************************'// 3 5x,' ------------ TIME = ',1pg12.5,' s ------------'// 4 5x,' temperature = ',0pf7.2, 5 ' K pressure = ',0pf7.3,' atm'/) 2006 format(// 1 ' ***************************************', 2 '****************************************'// 3 5x,' ------------ HEIGHT = ',1pg12.5,' cm ----------'// 4 5x,' temperature = ',0pf7.2, 5 ' K pressure = ',0pf7.3,' atm'/) 2007 format(' Mole fractions : '//) 2008 format(' Mass fractions : '//) 2009 format(/' Concentrations (mole/cm**3) : '//) 2010 format(5x,a16,1pe16.5,5x,a16,1pe16.5) 2011 format(/' Molar production rates (mole/(cm**3 * sec)) :'//) 2012 format(/' Temperature value of ',f7.2,' K given by AT_TEMP is', 1 ' lower'/' than the minimal simulated temperature of ', 2 f7.2,' K.') 2013 format(/' Temperature value of ',f7.2,' K given by AT_TEMP is', 1 ' higher'/' than the maximal simulated temperature of ', 2 f7.2,' K.') 2014 format(//) end c c-------------------------------------------------------------------- c c *** KINALC ***************************************************** c * * c * ORDER puts into order the elements of a vector * c * according to their absolute value * c * * c **************************************************************** c c a - IN: vector of n elements (remains unchanged) c b - OUT: ordered vector c n - IN: dimension of vectors c ip - OUT: integer vector of n elements a(ip(i)) = b(i) c e - working area c c ---------------------------------------------------------------- c subroutine order (n,ip,a,b,e) implicit double precision (a-h, o-z), integer (i-n) dimension ip(n),a(n),b(n),e(n) do 1 i=1,n 1 e(i) = dsign(1.d+00,a(i)) c c rh must be greater then the greatest element of a rh = 1.d+300 do 2 i=1,n c c rm must be smaller then the smallest element of a c rm = 1.d-300 rm = 0. do 3 j=1,n if(dabs(a(j)).ge.rm.and.dabs(a(j)).le.rh) goto 4 goto 3 4 if(i.eq.1) goto 5 do 6 k=2,i if(j.eq.ip(k-1)) goto 3 6 continue 5 rm=dabs(a(j)) im=j 3 continue b(i)=rm * e(im) rh=rm ip(i) = im 2 continue return end c c c *** KINALC ***************************************************** c * * c * RTIME reads date and time * c * * c **************************************************************** c c This subroutine is machine and compiler dependent. c subroutine rtime(cd,ct) implicit integer (i-n) character ct*8,cd*16 character chtd*24 c c Code for SGI's IRIS 5.2 and DEC ALPHA c call fdate (chtd) c c Code for IBM's AIX 4.1 c call fdate_(chtd) c ct= chtd(12:19) cd= chtd(1:10)//','//chtd(20:24) c return end c c c *** KINALC ***************************************************** c * * c * SDIAG2 computes eigenvectors and eigenvalues of a * c * symmetric matrix * c * * c **************************************************************** c c Method of QR transformations. c If the Euclidean norm of the rows varies STRONGLY most accurate c results may be obtained by permuting rows and columns to give c an arrangement with increasing norms of rows. c c Origin : Leibniz-Rechnenzentrum , Munich 1965 c c ---------------------------------------------------------------- c c x - IN: matrix to be diagonalized , its lower triangle has c to be given as ((x(i,j),j=1,i), i=1,n) c - OUT: matrix of eigenvectors c m - IN: leading dimension of matrix x c n - IN: dimension of matrix x c d - OUT: vector of eigenvalues c c ---------------------------------------------------------------- c subroutine sdiag2 (m,n,x,d,e) implicit double precision (a-h, o-z), integer (i-n) dimension d(n),x(m,n),e(n) c c eps= minimum of all x such that 1+x is greater than 1 on the c computer eps= 1.0d-15 c c tol= inf / eps where inf = minimum of all positive x c representable within the computer c tol= 1.0d-300/1.0d-15 if (n.eq.1) goto 400 c c Householder's reduction c simulation of loop do 150 i=n,2,(-1) c do 150 ni=2,n ii= n+2-ni c c loop for recursive address calculation c do 150 i=ii,ii l= i-2 h= 0.0d0 g= x(i,i-1) if(l) 140,140,20 20 do 30 k=1,l 30 h= h+x(i,k)*x(i,k) s= h+g*g if (s.ge.tol) goto 50 h= 0.0d0 goto 140 50 if (h) 140,140,60 60 l= l+1 f= g g= dsqrt(s) if (f) 75,75,70 70 g= -g 75 h= s-f*g x(i,i-1)=f-g f= 0.0d0 do 110 j=1,l x(j,i)= x(i,j)/h s= 0.0d0 do 80 k=1,j 80 s= s+x(j,k)*x(i,k) j1= j+1 if (j1.gt.l) goto 100 do 90 k=j1,l 90 s= s+x(k,j)*x(i,k) 100 e(j)= s/h 110 f= f+s*x(j,i) f= f/(h+h) do 120 j=1,l 120 e(j)= e(j)-f*x(i,j) do 130 j=1,l f= x(i,j) s= e(j) do 130 k=1,j 130 x(j,k)= x(j,k)-f*e(k)-x(i,k)*s 140 d(i)= h 150 e(i-1)= g c c accumulation of transformation matrices c d(1)= x(1,1) x(1,1)= 1.0d0 do 220 i=2,n l= i-1 if (d(i)) 200,200,170 170 do 190 j=1,l s= 0.0d0 do 180 k=1,l 180 s= s+x(i,k)*x(k,j) do 190 k=1,l 190 x(k,j)= x(k,j)-s*x(k,i) 200 d(i)= x(i,i) x(i,i)= 1.0d0 do 220 j=1,l x(i,j)= 0.0d0 220 x(j,i)= 0.0d0 c c diagonalization of the tridiagonal matrix c b= 0.0d0 f= 0.0d0 e(n)= 0.0d0 do 340 l=1,n h= eps*(dabs(d(l))+dabs(e(l))) if (h.gt.b) b=h c c test for splitting c do 240 j=l,n if (dabs(e(j)).le.b) goto 250 240 continue c c test for convergence c 250 if (j.eq.l) goto 340 c c shift from upper 2*2 minor c 260 p= (d(l+1)-d(l))*0.5d0/e(l) r= dsqrt(p*p+1.0d0) p= p+dsign(r,p) h= d(l)-e(l)/p do 300 i=l,n 300 d(i)= d(i)-h f= f+h c c QR transformation c p= d(j) c= 1.0d0 s= 0.0d0 c c simulation of loop do 330 i=j-1,l,(-1) c j1= j-1 do 330 ni=l,j1 ii= l+j1-ni c c loop for recursive address calculation c do 330 i=ii,ii i1= i+1 g= c*e(i) h= c*p c c protection against underflow of exponents c if (dabs(p).lt.dabs(e(i))) goto 310 c= e(i)/p r= dsqrt(c*c+1.0d0) e(i1)= s*p*r s= c/r c= 1.0d0/r goto 320 310 c= p/e(i) r= dsqrt(c*c+1.0d0) e(i1)= s*e(i)*r s= 1.0d0/r c= c/r 320 p= c*d(i)-s*g d(i1)= h+s*(c*g+s*d(i)) do 330 k=1,n h= x(k,i1) x(k,i1)= x(k,i)*s+h*c 330 x(k,i)= x(k,i)*c-h*s e(l)= s*p d(l)= c*p if (dabs(e(l)).gt.b) goto 260 c c convergence c 340 d(l)= d(l)+f c c ordering of eigenvalues c ni= n-1 do 380 i=1,ni k= i p= d(i) j1= i+1 do 360 j= j1,n c if (d(j).le.p) goto 360 k= j p= d(j) 360 continue if (k.eq.i) goto 380 d(k)= d(i) d(i)= p do 370 j=1,n p= x(j,i) x(j,i)= x(j,k) 370 x(j,k)= p 380 continue return c c special treatment of case n= 1 c 400 d(1)= x(1,1) x(1,1)=1.0d0 return end cc c *** KINALC ***************************************************** c * * c * DEC performes the Gaussian decomposition of matrix A * c * * c **************************************************************** c c see C.B. Moler , Algorithm 423 , CACM 15 (1972) c subroutine dec(n,a,ip,ier) implicit double precision (a-h, o-z), integer (i-n) dimension ip(1), a(n,1) ier=0 ip(n)=1 if(n.eq.1) goto 70 nm1=n-1 do 60 k=1,nm1 kp1=k+1 m=k do 10 i=kp1,n 10 if(dabs(a(i,k)).gt.dabs(a(m,k))) m=i ip(k)=m t=a(m,k) if(m.eq.k) goto 20 ip(n)=-ip(n) a(m,k)=a(k,k) a(k,k)=t 20 if (t.eq.0.d00) goto 80 t=1.d00/t do 30 i=kp1,n 30 a(i,k)=-a(i,k)*t do 50 j=kp1,n t=a(m,j) a(m,j)=a(k,j) a(k,j)=t if(t.eq.0.d00) goto 50 do 40 i=kp1,n 40 a(i,j)=a(i,j)+a(i,k)*t 50 continue 60 continue 70 k=n if (a(n,n).eq.0.d00) goto 80 return 80 ier=k ip(n)=0 return end c c *** KINALC ***************************************************** c * * c * SOL computes the solution of the linear system A*X=B * c * * c **************************************************************** c c see C.B. Moler , Algorithm 423 , CACM 15 (1972) c subroutine sol(n,a,ip,b) implicit double precision (a-h, o-z), integer (i-n) dimension ip(1), a(n,1),b(1) if (n.eq.1) goto 50 nm1=n-1 do 20 k=1,nm1 kp1=k+1 m=ip(k) t=b(m) b(m)=b(k) b(k)=t do 10 i=kp1,n 10 b(i)=b(i)+a(i,k)*t 20 continue do 40 kb=1,nm1 km1=n-kb k=km1+1 b(k)=b(k)/a(k,k) t=-b(k) do 30 i=1,km1 30 b(i)=b(i)+a(i,k)*t 40 continue 50 b(1)=b(1)/a(1,1) return end c c *** KINALC ****************************************************** c * * c * RMTXKI writes large real matrices * c * * c ***************************************************************** c c r - matrix to write c nd - leading dimension of r c n - number of rows of matrix r c m - number of columns of matrix r c subroutine rmtxki(lout,n,m,nd,r) implicit real*8(a-h,o-z) implicit integer*4(i-n) dimension r(nd,m) nm=m/5+1 nl=m do 1 k=1,nm nk=min0 (nl,5) nn = (k-1)*5 + nk ni = (k-1)*5 + 1 write(lout,10) (i,i=ni,nn) do 2 i=1,n 2 write (lout,11) i,(r(i,j),j=ni,nn) nl=nl-5 if(nl.eq.0) return 1 continue 10 format(///,6x,10(11x,i3)/) 11 format(/2x,i3,2x,5(1pe14.4)) return end c c-------------------------------------------------------------------- c subroutine r2ch(r,ch,lch,kerr) implicit double precision (a-h, o-z), integer (i-n) character*5 ch, chi logical kerr c c conversion of real numbers (0<=r<99.995) to a c max. 5-character string of 'nn.nn' format c if (r.gt.99.995) then kerr=.true. return endif ir= r*100. call cki2ch (ir, chi, l, kerr) if (kerr) return if (l.eq.1) ch='0.0'//chi(:l) if (l.eq.2) ch='0.' //chi(:l) if (l.gt.2) ch=chi(:(l-2))//'.'//chi( (l-1) : l ) if (ch(3:).eq.'00') ch=ch(:2) if (ch(4:).eq.'0' ) ch=ch(:3) lch= ilasch(ch) return end c c c-------------------------------------------------------------------- c subroutine rg(nm,n,a,wr,wi,matz,z,iv1,fv1,ierr) c integer n,nm,is1,is2,ierr,matz double precision a(nm,n),wr(n),wi(n),z(nm,n),fv1(n) integer iv1(n) c c this subroutine calls the recommended sequence of c subroutines from the eigensystem subroutine package (eispack) c to find the eigenvalues and eigenvectors (if desired) c of a real general matrix. c c on input c c nm must be set to the row dimension of the two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix a. c c a contains the real general matrix. c c matz is an integer variable set equal to zero if c only eigenvalues are desired. otherwise it is set to c any non-zero integer for both eigenvalues and eigenvectors. c c on output c c wr and wi contain the real and imaginary parts, c respectively, of the eigenvalues. complex conjugate c pairs of eigenvalues appear consecutively with the c eigenvalue having the positive imaginary part first. c c z contains the real and imaginary parts of the eigenvectors c if matz is not zero. if the j-th eigenvalue is real, the c j-th column of z contains its eigenvector. if the j-th c eigenvalue is complex with positive imaginary part, the c j-th and (j+1)-th columns of z contain the real and c imaginary parts of its eigenvector. the conjugate of this c vector is the eigenvector for the conjugate eigenvalue. c c ierr is an integer output variable set equal to an error c completion code described in the documentation for hqr c and hqr2. the normal completion code is zero. c c iv1 and fv1 are temporary storage arrays. c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated august 1983. c c ------------------------------------------------------------------ c if (n .le. nm) go to 10 ierr = 10 * n go to 50 c 10 call balanc(nm,n,a,is1,is2,fv1) call elmhes(nm,n,is1,is2,a,iv1) if (matz .ne. 0) go to 20 c .......... find eigenvalues only .......... call hqr(nm,n,is1,is2,a,wr,wi,ierr) go to 50 c .......... find both eigenvalues and eigenvectors .......... 20 call eltran(nm,n,is1,is2,a,iv1,z) call hqr2(nm,n,is1,is2,a,wr,wi,z,ierr) if (ierr .ne. 0) go to 50 call balbak(nm,n,is1,is2,fv1,n,z) 50 return end subroutine balanc(nm,n,a,low,igh,scale) c integer i,j,k,l,m,n,jj,nm,igh,low,iexc double precision a(nm,n),scale(n) double precision c,f,g,r,s,b2,radix logical noconv c c this subroutine is a translation of the algol procedure balance, c num. math. 13, 293-304(1969) by parlett and reinsch. c handbook for auto. comp., vol.ii-linear algebra, 315-326(1971). c c this subroutine balances a real matrix and isolates c eigenvalues whenever possible. c c on input c c nm must be set to the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix. c c a contains the input matrix to be balanced. c c on output c c a contains the balanced matrix. c c low and igh are two integers such that a(i,j) c is equal to zero if c (1) i is greater than j and c (2) j=1,...,low-1 or i=igh+1,...,n. c c scale contains information determining the c permutations and scaling factors used. c c suppose that the principal submatrix in rows low through igh c has been balanced, that p(j) denotes the index interchanged c with j during the permutation step, and that the elements c of the diagonal matrix used are denoted by d(i,j). then c scale(j) = p(j), for j = 1,...,low-1 c = d(j,j), j = low,...,igh c = p(j) j = igh+1,...,n. c the order in which the interchanges are made is n to igh+1, c then 1 to low-1. c c note that 1 is returned for igh if igh is zero formally. c c the algol procedure exc contained in balance appears in c balanc in line. (note that the algol roles of identifiers c k,l have been reversed.) c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated august 1983. c c ------------------------------------------------------------------ c radix = 16.0d0 c b2 = radix * radix k = 1 l = n go to 100 c .......... in-line procedure for row and c column exchange .......... 20 scale(m) = j if (j .eq. m) go to 50 c do 30 i = 1, l f = a(i,j) a(i,j) = a(i,m) a(i,m) = f 30 continue c do 40 i = k, n f = a(j,i) a(j,i) = a(m,i) a(m,i) = f 40 continue c 50 go to (80,130), iexc c .......... search for rows isolating an eigenvalue c and push them down .......... 80 if (l .eq. 1) go to 280 l = l - 1 c .......... for j=l step -1 until 1 do -- .......... 100 do 120 jj = 1, l j = l + 1 - jj c do 110 i = 1, l if (i .eq. j) go to 110 if (a(j,i) .ne. 0.0d0) go to 120 110 continue c m = l iexc = 1 go to 20 120 continue c go to 140 c .......... search for columns isolating an eigenvalue c and push them left .......... 130 k = k + 1 c 140 do 170 j = k, l c do 150 i = k, l if (i .eq. j) go to 150 if (a(i,j) .ne. 0.0d0) go to 170 150 continue c m = k iexc = 2 go to 20 170 continue c .......... now balance the submatrix in rows k to l .......... do 180 i = k, l 180 scale(i) = 1.0d0 c .......... iterative loop for norm reduction .......... 190 noconv = .false. c do 270 i = k, l c = 0.0d0 r = 0.0d0 c do 200 j = k, l if (j .eq. i) go to 200 c = c + dabs(a(j,i)) r = r + dabs(a(i,j)) 200 continue c .......... guard against zero c or r due to underflow .......... if (c .eq. 0.0d0 .or. r .eq. 0.0d0) go to 270 g = r / radix f = 1.0d0 s = c + r 210 if (c .ge. g) go to 220 f = f * radix c = c * b2 go to 210 220 g = r * radix 230 if (c .lt. g) go to 240 f = f / radix c = c / b2 go to 230 c .......... now balance .......... 240 if ((c + r) / f .ge. 0.95d0 * s) go to 270 g = 1.0d0 / f scale(i) = scale(i) * f noconv = .true. c do 250 j = k, n 250 a(i,j) = a(i,j) * g c do 260 j = 1, l 260 a(j,i) = a(j,i) * f c 270 continue c if (noconv) go to 190 c 280 low = k igh = l return end subroutine balbak(nm,n,low,igh,scale,m,z) c integer i,j,k,m,n,ii,nm,igh,low double precision scale(n),z(nm,m) double precision s c c this subroutine is a translation of the algol procedure balbak, c num. math. 13, 293-304(1969) by parlett and reinsch. c handbook for auto. comp., vol.ii-linear algebra, 315-326(1971). c c this subroutine forms the eigenvectors of a real general c matrix by back transforming those of the corresponding c balanced matrix determined by balanc. c c on input c c nm must be set to the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix. c c low and igh are integers determined by balanc. c c scale contains information determining the permutations c and scaling factors used by balanc. c c m is the number of columns of z to be back transformed. c c z contains the real and imaginary parts of the eigen- c vectors to be back transformed in its first m columns. c c on output c c z contains the real and imaginary parts of the c transformed eigenvectors in its first m columns. c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated august 1983. c c ------------------------------------------------------------------ c if (m .eq. 0) go to 200 if (igh .eq. low) go to 120 c do 110 i = low, igh s = scale(i) c .......... left hand eigenvectors are back transformed c if the foregoing statement is replaced by c s=1.0d0/scale(i). .......... do 100 j = 1, m 100 z(i,j) = z(i,j) * s c 110 continue c ......... for i=low-1 step -1 until 1, c igh+1 step 1 until n do -- .......... 120 do 140 ii = 1, n i = ii if (i .ge. low .and. i .le. igh) go to 140 if (i .lt. low) i = low - ii k = scale(i) if (k .eq. i) go to 140 c do 130 j = 1, m s = z(i,j) z(i,j) = z(k,j) z(k,j) = s 130 continue c 140 continue c 200 return end subroutine elmhes(nm,n,low,igh,a,int) c integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1 double precision a(nm,n) double precision x,y integer int(igh) c c this subroutine is a translation of the algol procedure elmhes, c num. math. 12, 349-368(1968) by martin and wilkinson. c handbook for auto. comp., vol.ii-linear algebra, 339-358(1971). c c given a real general matrix, this subroutine c reduces a submatrix situated in rows and columns c low through igh to upper hessenberg form by c stabilized elementary similarity transformations. c c on input c c nm must be set to the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix. c c low and igh are integers determined by the balancing c subroutine balanc. if balanc has not been used, c set low=1, igh=n. c c a contains the input matrix. c c on output c c a contains the hessenberg matrix. the multipliers c which were used in the reduction are stored in the c remaining triangle under the hessenberg matrix. c c int contains information on the rows and columns c interchanged in the reduction. c only elements low through igh are used. c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated august 1983. c c ------------------------------------------------------------------ c la = igh - 1 kp1 = low + 1 if (la .lt. kp1) go to 200 c do 180 m = kp1, la mm1 = m - 1 x = 0.0d0 i = m c do 100 j = m, igh if (dabs(a(j,mm1)) .le. dabs(x)) go to 100 x = a(j,mm1) i = j 100 continue c int(m) = i if (i .eq. m) go to 130 c .......... interchange rows and columns of a .......... do 110 j = mm1, n y = a(i,j) a(i,j) = a(m,j) a(m,j) = y 110 continue c do 120 j = 1, igh y = a(j,i) a(j,i) = a(j,m) a(j,m) = y 120 continue c .......... end interchange .......... 130 if (x .eq. 0.0d0) go to 180 mp1 = m + 1 c do 160 i = mp1, igh y = a(i,mm1) if (y .eq. 0.0d0) go to 160 y = y / x a(i,mm1) = y c do 140 j = m, n 140 a(i,j) = a(i,j) - y * a(m,j) c do 150 j = 1, igh 150 a(j,m) = a(j,m) + y * a(j,i) c 160 continue c 180 continue c 200 return end subroutine eltran(nm,n,low,igh,a,int,z) c integer i,j,n,kl,mm,mp,nm,igh,low,mp1 double precision a(nm,igh),z(nm,n) integer int(igh) c c this subroutine is a translation of the algol procedure elmtrans, c num. math. 16, 181-204(1970) by peters and wilkinson. c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). c c this subroutine accumulates the stabilized elementary c similarity transformations used in the reduction of a c real general matrix to upper hessenberg form by elmhes. c c on input c c nm must be set to the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix. c c low and igh are integers determined by the balancing c subroutine balanc. if balanc has not been used, c set low=1, igh=n. c c a contains the multipliers which were used in the c reduction by elmhes in its lower triangle c below the subdiagonal. c c int contains information on the rows and columns c interchanged in the reduction by elmhes. c only elements low through igh are used. c c on output c c z contains the transformation matrix produced in the c reduction by elmhes. c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated august 1983. c c ------------------------------------------------------------------ c c .......... initialize z to identity matrix .......... do 80 j = 1, n c do 60 i = 1, n 60 z(i,j) = 0.0d0 c z(j,j) = 1.0d0 80 continue c kl = igh - low - 1 if (kl .lt. 1) go to 200 c .......... for mp=igh-1 step -1 until low+1 do -- .......... do 140 mm = 1, kl mp = igh - mm mp1 = mp + 1 c do 100 i = mp1, igh 100 z(i,mp) = a(i,mp-1) c i = int(mp) if (i .eq. mp) go to 140 c do 130 j = mp, igh z(mp,j) = z(i,j) z(i,j) = 0.0d0 130 continue c z(i,mp) = 1.0d0 140 continue c 200 return end subroutine hqr(nm,n,low,igh,h,wr,wi,ierr) C RESTORED CORRECT INDICES OF LOOPS (200,210,230,240). (9/29/89 BSG) c integer i,j,k,l,m,n,en,ll,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr double precision h(nm,n),wr(n),wi(n) double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2 logical notlas c c this subroutine is a translation of the algol procedure hqr, c num. math. 14, 219-231(1970) by martin, peters, and wilkinson. c handbook for auto. comp., vol.ii-linear algebra, 359-371(1971). c c this subroutine finds the eigenvalues of a real c upper hessenberg matrix by the qr method. c c on input c c nm must be set to the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix. c c low and igh are integers determined by the balancing c subroutine balanc. if balanc has not been used, c set low=1, igh=n. c c h contains the upper hessenberg matrix. information about c the transformations used in the reduction to hessenberg c form by elmhes or orthes, if performed, is stored c in the remaining triangle under the hessenberg matrix. c c on output c c h has been destroyed. therefore, it must be saved c before calling hqr if subsequent calculation and c back transformation of eigenvectors is to be performed. c c wr and wi contain the real and imaginary parts, c respectively, of the eigenvalues. the eigenvalues c are unordered except that complex conjugate pairs c of values appear consecutively with the eigenvalue c having the positive imaginary part first. if an c error exit is made, the eigenvalues should be correct c for indices ierr+1,...,n. c c ierr is set to c zero for normal return, c j if the limit of 30*n iterations is exhausted c while the j-th eigenvalue is being sought. c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated september 1989. c c ------------------------------------------------------------------ c ierr = 0 norm = 0.0d0 k = 1 c .......... store roots isolated by balanc c and compute matrix norm .......... do 50 i = 1, n c do 40 j = k, n 40 norm = norm + dabs(h(i,j)) c k = i if (i .ge. low .and. i .le. igh) go to 50 wr(i) = h(i,i) wi(i) = 0.0d0 50 continue c en = igh t = 0.0d0 itn = 30*n c .......... search for next eigenvalues .......... 60 if (en .lt. low) go to 1001 its = 0 na = en - 1 enm2 = na - 1 c .......... look for single small sub-diagonal element c for l=en step -1 until low do -- .......... 70 do 80 ll = low, en l = en + low - ll if (l .eq. low) go to 100 s = dabs(h(l-1,l-1)) + dabs(h(l,l)) if (s .eq. 0.0d0) s = norm tst1 = s tst2 = tst1 + dabs(h(l,l-1)) if (tst2 .eq. tst1) go to 100 80 continue c .......... form shift .......... 100 x = h(en,en) if (l .eq. en) go to 270 y = h(na,na) w = h(en,na) * h(na,en) if (l .eq. na) go to 280 if (itn .eq. 0) go to 1000 if (its .ne. 10 .and. its .ne. 20) go to 130 c .......... form exceptional shift .......... t = t + x c do 120 i = low, en 120 h(i,i) = h(i,i) - x c s = dabs(h(en,na)) + dabs(h(na,enm2)) x = 0.75d0 * s y = x w = -0.4375d0 * s * s 130 its = its + 1 itn = itn - 1 c .......... look for two consecutive small c sub-diagonal elements. c for m=en-2 step -1 until l do -- .......... do 140 mm = l, enm2 m = enm2 + l - mm zz = h(m,m) r = x - zz s = y - zz p = (r * s - w) / h(m+1,m) + h(m,m+1) q = h(m+1,m+1) - zz - r - s r = h(m+2,m+1) s = dabs(p) + dabs(q) + dabs(r) p = p / s q = q / s r = r / s if (m .eq. l) go to 150 tst1 = dabs(p)*(dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1))) tst2 = tst1 + dabs(h(m,m-1))*(dabs(q) + dabs(r)) if (tst2 .eq. tst1) go to 150 140 continue c 150 mp2 = m + 2 c do 160 i = mp2, en h(i,i-2) = 0.0d0 if (i .eq. mp2) go to 160 h(i,i-3) = 0.0d0 160 continue c .......... double qr step involving rows l to en and c columns m to en .......... do 260 k = m, na notlas = k .ne. na if (k .eq. m) go to 170 p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if (notlas) r = h(k+2,k-1) x = dabs(p) + dabs(q) + dabs(r) if (x .eq. 0.0d0) go to 260 p = p / x q = q / x r = r / x 170 s = dsign(dsqrt(p*p+q*q+r*r),p) if (k .eq. m) go to 180 h(k,k-1) = -s * x go to 190 180 if (l .ne. m) h(k,k-1) = -h(k,k-1) 190 p = p + s x = p / s y = q / s zz = r / s q = q / p r = r / p if (notlas) go to 225 c .......... row modification .......... do 200 j = k, EN p = h(k,j) + q * h(k+1,j) h(k,j) = h(k,j) - p * x h(k+1,j) = h(k+1,j) - p * y 200 continue c j = min0(en,k+3) c .......... column modification .......... do 210 i = L, j p = x * h(i,k) + y * h(i,k+1) h(i,k) = h(i,k) - p h(i,k+1) = h(i,k+1) - p * q 210 continue go to 255 225 continue c .......... row modification .......... do 230 j = k, EN p = h(k,j) + q * h(k+1,j) + r * h(k+2,j) h(k,j) = h(k,j) - p * x h(k+1,j) = h(k+1,j) - p * y h(k+2,j) = h(k+2,j) - p * zz 230 continue c j = min0(en,k+3) c .......... column modification .......... do 240 i = L, j p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2) h(i,k) = h(i,k) - p h(i,k+1) = h(i,k+1) - p * q h(i,k+2) = h(i,k+2) - p * r 240 continue 255 continue c 260 continue c go to 70 c .......... one root found .......... 270 wr(en) = x + t wi(en) = 0.0d0 en = na go to 60 c .......... two roots found .......... 280 p = (y - x) / 2.0d0 q = p * p + w zz = dsqrt(dabs(q)) x = x + t if (q .lt. 0.0d0) go to 320 c .......... real pair .......... zz = p + dsign(zz,p) wr(na) = x + zz wr(en) = wr(na) if (zz .ne. 0.0d0) wr(en) = x - w / zz wi(na) = 0.0d0 wi(en) = 0.0d0 go to 330 c .......... complex pair .......... 320 wr(na) = x + p wr(en) = x + p wi(na) = zz wi(en) = -zz 330 en = enm2 go to 60 c .......... set error -- all eigenvalues have not c converged after 30*n iterations .......... 1000 ierr = en 1001 return end subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr) c integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn, x igh,itn,its,low,mp2,enm2,ierr double precision h(nm,n),wr(n),wi(n),z(nm,n) double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2 logical notlas c c this subroutine is a translation of the algol procedure hqr2, c num. math. 16, 181-204(1970) by peters and wilkinson. c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). c c this subroutine finds the eigenvalues and eigenvectors c of a real upper hessenberg matrix by the qr method. the c eigenvectors of a real general matrix can also be found c if elmhes and eltran or orthes and ortran have c been used to reduce this general matrix to hessenberg form c and to accumulate the similarity transformations. c c on input c c nm must be set to the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix. c c low and igh are integers determined by the balancing c subroutine balanc. if balanc has not been used, c set low=1, igh=n. c c h contains the upper hessenberg matrix. c c z contains the transformation matrix produced by eltran c after the reduction by elmhes, or by ortran after the c reduction by orthes, if performed. if the eigenvectors c of the hessenberg matrix are desired, z must contain the c identity matrix. c c on output c c h has been destroyed. c c wr and wi contain the real and imaginary parts, c respectively, of the eigenvalues. the eigenvalues c are unordered except that complex conjugate pairs c of values appear consecutively with the eigenvalue c having the positive imaginary part first. if an c error exit is made, the eigenvalues should be correct c for indices ierr+1,...,n. c c z contains the real and imaginary parts of the eigenvectors. c if the i-th eigenvalue is real, the i-th column of z c contains its eigenvector. if the i-th eigenvalue is complex c with positive imaginary part, the i-th and (i+1)-th c columns of z contain the real and imaginary parts of its c eigenvector. the eigenvectors are unnormalized. if an c error exit is made, none of the eigenvectors has been found. c c ierr is set to c zero for normal return, c j if the limit of 30*n iterations is exhausted c while the j-th eigenvalue is being sought. c c calls cdiv for complex division. c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated august 1983. c c ------------------------------------------------------------------ c ierr = 0 norm = 0.0d0 k = 1 c .......... store roots isolated by balanc c and compute matrix norm .......... do 50 i = 1, n c do 40 j = k, n 40 norm = norm + dabs(h(i,j)) c k = i if (i .ge. low .and. i .le. igh) go to 50 wr(i) = h(i,i) wi(i) = 0.0d0 50 continue c en = igh t = 0.0d0 itn = 30*n c .......... search for next eigenvalues .......... 60 if (en .lt. low) go to 340 its = 0 na = en - 1 enm2 = na - 1 c .......... look for single small sub-diagonal element c for l=en step -1 until low do -- .......... 70 do 80 ll = low, en l = en + low - ll if (l .eq. low) go to 100 s = dabs(h(l-1,l-1)) + dabs(h(l,l)) if (s .eq. 0.0d0) s = norm tst1 = s tst2 = tst1 + dabs(h(l,l-1)) if (tst2 .eq. tst1) go to 100 80 continue c .......... form shift .......... 100 x = h(en,en) if (l .eq. en) go to 270 y = h(na,na) w = h(en,na) * h(na,en) if (l .eq. na) go to 280 if (itn .eq. 0) go to 1000 if (its .ne. 10 .and. its .ne. 20) go to 130 c .......... form exceptional shift .......... t = t + x c do 120 i = low, en 120 h(i,i) = h(i,i) - x c s = dabs(h(en,na)) + dabs(h(na,enm2)) x = 0.75d0 * s y = x w = -0.4375d0 * s * s 130 its = its + 1 itn = itn - 1 c .......... look for two consecutive small c sub-diagonal elements. c for m=en-2 step -1 until l do -- .......... do 140 mm = l, enm2 m = enm2 + l - mm zz = h(m,m) r = x - zz s = y - zz p = (r * s - w) / h(m+1,m) + h(m,m+1) q = h(m+1,m+1) - zz - r - s r = h(m+2,m+1) s = dabs(p) + dabs(q) + dabs(r) p = p / s q = q / s r = r / s if (m .eq. l) go to 150 tst1 = dabs(p)*(dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1))) tst2 = tst1 + dabs(h(m,m-1))*(dabs(q) + dabs(r)) if (tst2 .eq. tst1) go to 150 140 continue c 150 mp2 = m + 2 c do 160 i = mp2, en h(i,i-2) = 0.0d0 if (i .eq. mp2) go to 160 h(i,i-3) = 0.0d0 160 continue c .......... double qr step involving rows l to en and c columns m to en .......... do 260 k = m, na notlas = k .ne. na if (k .eq. m) go to 170 p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if (notlas) r = h(k+2,k-1) x = dabs(p) + dabs(q) + dabs(r) if (x .eq. 0.0d0) go to 260 p = p / x q = q / x r = r / x 170 s = dsign(dsqrt(p*p+q*q+r*r),p) if (k .eq. m) go to 180 h(k,k-1) = -s * x go to 190 180 if (l .ne. m) h(k,k-1) = -h(k,k-1) 190 p = p + s x = p / s y = q / s zz = r / s q = q / p r = r / p if (notlas) go to 225 c .......... row modification .......... do 200 j = k, n p = h(k,j) + q * h(k+1,j) h(k,j) = h(k,j) - p * x h(k+1,j) = h(k+1,j) - p * y 200 continue c j = min0(en,k+3) c .......... column modification .......... do 210 i = 1, j p = x * h(i,k) + y * h(i,k+1) h(i,k) = h(i,k) - p h(i,k+1) = h(i,k+1) - p * q 210 continue c .......... accumulate transformations .......... do 220 i = low, igh p = x * z(i,k) + y * z(i,k+1) z(i,k) = z(i,k) - p z(i,k+1) = z(i,k+1) - p * q 220 continue go to 255 225 continue c .......... row modification .......... do 230 j = k, n p = h(k,j) + q * h(k+1,j) + r * h(k+2,j) h(k,j) = h(k,j) - p * x h(k+1,j) = h(k+1,j) - p * y h(k+2,j) = h(k+2,j) - p * zz 230 continue c j = min0(en,k+3) c .......... column modification .......... do 240 i = 1, j p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2) h(i,k) = h(i,k) - p h(i,k+1) = h(i,k+1) - p * q h(i,k+2) = h(i,k+2) - p * r 240 continue c .......... accumulate transformations .......... do 250 i = low, igh p = x * z(i,k) + y * z(i,k+1) + zz * z(i,k+2) z(i,k) = z(i,k) - p z(i,k+1) = z(i,k+1) - p * q z(i,k+2) = z(i,k+2) - p * r 250 continue 255 continue c 260 continue c go to 70 c .......... one root found .......... 270 h(en,en) = x + t wr(en) = h(en,en) wi(en) = 0.0d0 en = na go to 60 c .......... two roots found .......... 280 p = (y - x) / 2.0d0 q = p * p + w zz = dsqrt(dabs(q)) h(en,en) = x + t x = h(en,en) h(na,na) = y + t if (q .lt. 0.0d0) go to 320 c .......... real pair .......... zz = p + dsign(zz,p) wr(na) = x + zz wr(en) = wr(na) if (zz .ne. 0.0d0) wr(en) = x - w / zz wi(na) = 0.0d0 wi(en) = 0.0d0 x = h(en,na) s = dabs(x) + dabs(zz) p = x / s q = zz / s r = dsqrt(p*p+q*q) p = p / r q = q / r c .......... row modification .......... do 290 j = na, n zz = h(na,j) h(na,j) = q * zz + p * h(en,j) h(en,j) = q * h(en,j) - p * zz 290 continue c .......... column modification .......... do 300 i = 1, en zz = h(i,na) h(i,na) = q * zz + p * h(i,en) h(i,en) = q * h(i,en) - p * zz 300 continue c .......... accumulate transformations .......... do 310 i = low, igh zz = z(i,na) z(i,na) = q * zz + p * z(i,en) z(i,en) = q * z(i,en) - p * zz 310 continue c go to 330 c .......... complex pair .......... 320 wr(na) = x + p wr(en) = x + p wi(na) = zz wi(en) = -zz 330 en = enm2 go to 60 c .......... all roots found. backsubstitute to find c vectors of upper triangular form .......... 340 if (norm .eq. 0.0d0) go to 1001 c .......... for en=n step -1 until 1 do -- .......... do 800 nn = 1, n en = n + 1 - nn p = wr(en) q = wi(en) na = en - 1 if (q) 710, 600, 800 c .......... real vector .......... 600 m = en h(en,en) = 1.0d0 if (na .eq. 0) go to 800 c .......... for i=en-1 step -1 until 1 do -- .......... do 700 ii = 1, na i = en - ii w = h(i,i) - p r = 0.0d0 c do 610 j = m, en 610 r = r + h(i,j) * h(j,en) c if (wi(i) .ge. 0.0d0) go to 630 zz = w s = r go to 700 630 m = i if (wi(i) .ne. 0.0d0) go to 640 t = w if (t .ne. 0.0d0) go to 635 tst1 = norm t = tst1 632 t = 0.01d0 * t tst2 = norm + t if (tst2 .gt. tst1) go to 632 635 h(i,en) = -r / t go to 680 c .......... solve real equations .......... 640 x = h(i,i+1) y = h(i+1,i) q = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) t = (x * s - zz * r) / q h(i,en) = t if (dabs(x) .le. dabs(zz)) go to 650 h(i+1,en) = (-r - w * t) / x go to 680 650 h(i+1,en) = (-s - y * t) / zz c c .......... overflow control .......... 680 t = dabs(h(i,en)) if (t .eq. 0.0d0) go to 700 tst1 = t tst2 = tst1 + 1.0d0/tst1 if (tst2 .gt. tst1) go to 700 do 690 j = i, en h(j,en) = h(j,en)/t 690 continue c 700 continue c .......... end real vector .......... go to 800 c .......... complex vector .......... 710 m = na c .......... last vector component chosen imaginary so that c eigenvector matrix is triangular .......... if (dabs(h(en,na)) .le. dabs(h(na,en))) go to 720 h(na,na) = q / h(en,na) h(na,en) = -(h(en,en) - p) / h(en,na) go to 730 720 call cdiv(0.0d0,-h(na,en),h(na,na)-p,q,h(na,na),h(na,en)) 730 h(en,na) = 0.0d0 h(en,en) = 1.0d0 enm2 = na - 1 if (enm2 .eq. 0) go to 800 c .......... for i=en-2 step -1 until 1 do -- .......... do 795 ii = 1, enm2 i = na - ii w = h(i,i) - p ra = 0.0d0 sa = 0.0d0 c do 760 j = m, en ra = ra + h(i,j) * h(j,na) sa = sa + h(i,j) * h(j,en) 760 continue c if (wi(i) .ge. 0.0d0) go to 770 zz = w r = ra s = sa go to 795 770 m = i if (wi(i) .ne. 0.0d0) go to 780 call cdiv(-ra,-sa,w,q,h(i,na),h(i,en)) go to 790 c .......... solve complex equations .......... 780 x = h(i,i+1) y = h(i+1,i) vr = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - q * q vi = (wr(i) - p) * 2.0d0 * q if (vr .ne. 0.0d0 .or. vi .ne. 0.0d0) go to 784 tst1 = norm * (dabs(w) + dabs(q) + dabs(x) x + dabs(y) + dabs(zz)) vr = tst1 783 vr = 0.01d0 * vr tst2 = tst1 + vr if (tst2 .gt. tst1) go to 783 784 call cdiv(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi, x h(i,na),h(i,en)) if (dabs(x) .le. dabs(zz) + dabs(q)) go to 785 h(i+1,na) = (-ra - w * h(i,na) + q * h(i,en)) / x h(i+1,en) = (-sa - w * h(i,en) - q * h(i,na)) / x go to 790 785 call cdiv(-r-y*h(i,na),-s-y*h(i,en),zz,q, x h(i+1,na),h(i+1,en)) c c .......... overflow control .......... 790 t = dmax1(dabs(h(i,na)), dabs(h(i,en))) if (t .eq. 0.0d0) go to 795 tst1 = t tst2 = tst1 + 1.0d0/tst1 if (tst2 .gt. tst1) go to 795 do 792 j = i, en h(j,na) = h(j,na)/t h(j,en) = h(j,en)/t 792 continue c 795 continue c .......... end complex vector .......... 800 continue c .......... end back substitution. c vectors of isolated roots .......... do 840 i = 1, n if (i .ge. low .and. i .le. igh) go to 840 c do 820 j = i, n 820 z(i,j) = h(i,j) c 840 continue c .......... multiply by transformation matrix to give c vectors of original full matrix. c for j=n step -1 until low do -- .......... do 880 jj = low, n j = n + low - jj m = min0(j,igh) c do 880 i = low, igh zz = 0.0d0 c do 860 k = low, m 860 zz = zz + z(i,k) * h(k,j) c z(i,j) = zz 880 continue c go to 1001 c .......... set error -- all eigenvalues have not c converged after 30*n iterations .......... 1000 ierr = en 1001 return end subroutine cdiv(ar,ai,br,bi,cr,ci) double precision ar,ai,br,bi,cr,ci c c complex division, (cr,ci) = (ar,ai)/(br,bi) c double precision s,ars,ais,brs,bis s = dabs(br) + dabs(bi) ars = ar/s ais = ai/s brs = br/s bis = bi/s s = brs**2 + bis**2 cr = (ars*brs + ais*bis)/s ci = (ais*brs - ars*bis)/s return end c c c-------------------------------------------------------------------- c subroutine dgesl(a,lda,n,ipvt,b,job) integer lda,n,ipvt(1),job double precision a(lda,1),b(1) c c dgesl solves the double precision system c a * x = b or trans(a) * x = b c using the factors computed by dgeco or dgefa. c c on entry c c a double precision(lda, n) c the output from dgeco or dgefa. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c ipvt integer(n) c the pivot vector from dgeco or dgefa. c c b double precision(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve trans(a)*x = b where c trans(a) is the transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if dgeco has set rcond .gt. 0.0 c or dgefa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call dgeco(a,lda,n,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call dgesl(a,lda,n,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,ddot c c internal variables c double precision ddot,t integer k,kb,l,nm1 c nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/a(k,k) t = -b(k) call daxpy(k-1,t,a(1,k),1,b(1),1) 40 continue go to 100 50 continue c c job = nonzero, solve trans(a) * x = b c first solve trans(u)*y = b c do 60 k = 1, n t = ddot(k-1,a(1,k),1,b(1),1) b(k) = (b(k) - t)/a(k,k) 60 continue c c now solve trans(l)*x = y c if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end c c c-------------------------------------------------------------------- c subroutine dgefa(a,lda,n,ipvt,info) integer lda,n,ipvt(1),info double precision a(lda,1) c c dgefa factors a double precision matrix by gaussian elimination. c c dgefa is usually called by dgeco, but it can be called c directly with a saving in time if rcond is not needed. c (time for dgeco) = (1 + 9/n)*(time for dgefa) . c c on entry c c a double precision(lda, n) c the matrix to be factored. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c on return c c a an upper triangular matrix and the multipliers c which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that dgesl or dgedi will divide by zero c if called. use rcond in dgeco for a reliable c indication of singularity. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,dscal,idamax c c internal variables c double precision t integer idamax,j,k,kp1,l,nm1 c c c gaussian elimination with partial pivoting c info = 0 nm1 = n - 1 if (nm1 .lt. 1) go to 70 do 60 k = 1, nm1 kp1 = k + 1 c c find l = pivot index c l = idamax(n-k+1,a(k,k),1) + k - 1 ipvt(k) = l c c zero pivot implies this column already triangularized c if (a(l,k) .eq. 0.0d0) go to 40 c c interchange if necessary c if (l .eq. k) go to 10 t = a(l,k) a(l,k) = a(k,k) a(k,k) = t 10 continue c c compute multipliers c t = -1.0d0/a(k,k) call dscal(n-k,t,a(k+1,k),1) c c row elimination with column indexing c do 30 j = kp1, n t = a(l,j) if (l .eq. k) go to 20 a(l,j) = a(k,j) a(k,j) = t 20 continue call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) 30 continue go to 50 40 continue info = k 50 continue 60 continue 70 continue ipvt(n) = n if (a(n,n) .eq. 0.0d0) info = n return end c c c-------------------------------------------------------------------- c c from math.f c subroutine dscal(n,da,dx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to one. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c double precision da,dx(1) integer i,incx,m,mp1,n,nincx c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dx(i) = da*dx(i) 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da*dx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da*dx(i) dx(i + 1) = da*dx(i + 1) dx(i + 2) = da*dx(i + 2) dx(i + 3) = da*dx(i + 3) dx(i + 4) = da*dx(i + 4) 50 continue return end c c c-------------------------------------------------------------------- c c from math.f c subroutine daxpy(n,da,dx,incx,dy,incy) c c constant times a vector plus a vector. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c double precision dx(1),dy(1),da integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (da .eq. 0.0d0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dy(i) + da*dx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i + 1) = dy(i + 1) + da*dx(i + 1) dy(i + 2) = dy(i + 2) + da*dx(i + 2) dy(i + 3) = dy(i + 3) + da*dx(i + 3) 50 continue return end c c c-------------------------------------------------------------------- c c from math.f c double precision function ddot(n,dx,incx,dy,incy) c c forms the dot product of two vectors. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c double precision dx(1),dy(1),dtemp integer i,incx,incy,ix,iy,m,mp1,n c ddot = 0.0d0 dtemp = 0.0d0 if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dtemp = dtemp + dx(ix)*dy(iy) ix = ix + incx iy = iy + incy 10 continue ddot = dtemp return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dtemp + dx(i)*dy(i) 30 continue if( n .lt. 5 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,5 dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) 50 continue 60 ddot = dtemp return end c c-------------------------------------------------------------------- c c from math.f c integer function idamax(n,dx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c double precision dx(1),dmax integer i,incx,ix,n c idamax = 0 if( n.lt.1 .or. incx.le.0 ) return idamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 dmax = dabs(dx(1)) ix = ix + incx do 10 i = 2,n if(dabs(dx(ix)).le.dmax) go to 5 idamax = i dmax = dabs(dx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 dmax = dabs(dx(1)) do 30 i = 2,n if(dabs(dx(i)).le.dmax) go to 30 idamax = i dmax = dabs(dx(i)) 30 continue return end c c c---------------------------------------------------------------------- c SUBROUTINE EIGEN(a,evals,evecr,evecl,iclass,ndim,wr,wi,ier) c c******************************************************* c THIS SUBROUTINE CALCULATES THE EIGENVALUES AND * c EIGENVECTORS OF THE LINEARIZATION OF THE MAP * c AROUND A POINT. IT ALSO DETERMINES THEIR NATURE, * c AND ORDERS THE REAL POSITIVE EIGENVALUES IN * c ORDER OF INCREASING MAGNITUDE. * c * c******************************************************* c c-------------------------------------------------------- c NOTE working space: c array1: passes jacobian to eigensolver routine, c vectr1: holds the scaled lengths of vectors c vectr2: used during the sorting of eigenvalue c imaginary parts c ivctr1: the ordering of the eigenvalues. c-------------------------------------------------------- c parameter (nmax= 100) implicit double precision (a-h, o-z) dimension wr(ndim),wi(ndim) dimension a(ndim,ndim),evals(ndim) dimension evecr(ndim,ndim),evecl(ndim,ndim) dimension z(nmax,nmax) dimension iclass(6) dimension wmod(nmax) c c working arrays c real*8 vectr1(nmax),vectr2(nmax) real*8 array1(nmax,nmax) integer*4 ivctr1(nmax) c c..... c EIGENVALUES and EIGENVECTORS using GR. c..... do 10 i=1,ndim do 10 j=1,ndim 10 array1(i,j)=a(i,j) c call rg(nmax,ndim,array1,wr,wi,1,z,ivctr1,vectr1,ier) c if (ier.ne.0) then write(*,910) ier go to 700 endif c do 15 i = 1,ndim wmod(i) = DSQRT( wr(i)*wr(i) + wi(i)*wi(i) ) 15 continue c..... c ICLASS will contain the numbers of various types of eigenvalues. c..... do 111 i=1,6 111 iclass (i)=0 c c***** sort the EVs ********* **************************************** c The elements of ICLASS are counting eigenvalues that are: c 1 -- (not used) c 2 -- Real, Non-negative (unstable or neutral). c 3 -- Complex, Negative real part (stable). c 4 -- Complex, Non-negative real part (unstable or neutral). c 5 -- Real, Negative (stable). c 6 -- zero (i.e. abs(evalue(i)) < zer_tol = 1.0d-10 ) c..... c zer_tol = 1.0d-10 do 112 i=1,ndim if (wi(i) .ne. 0.0d0) then if (wr(i) .ge. 0.00d0) then iclass(4)=iclass(4)+1 else iclass(3)=iclass(3)+1 endif else if (dabs(wr(i)) .le. zer_tol) then iclass(6)=iclass(6)+1 elseif (wr(i) .gt. zer_tol) then iclass(2)=iclass(2)+1 else iclass(5)=iclass(5)+1 endif endif 112 continue c c..... c sort the eigenvalues in order of ascending real part c (the real and complex eigenvalues), then reorder the c corresponding eigenvectors. c..... c call sort( ndim,wr,ivctr1 ) do 115 i = 1,ndim evals(i) = wr( ivctr1(i) ) vectr2(i) = wi( ivctr1(i) ) 115 continue do 116 i = 1,ndim wi(i) = vectr2(i) 116 continue c i = 1 do while ( i.le.ndim ) if ( wi(i).ne.0 ) then c..... c extract the real and complex parts of the first c eigenvector for two real eigenvectors and then skip c its complex conjugate eigenvector (which after sorting c should be right next to it). c..... do 122 j = 1,ndim evecr(j,i) = z(j, ivctr1(i)) c c !!! check the next statement c evecr(j,i+1) = z(j+1, ivctr1(i)) 122 continue i = i + 1 else do 125 j = 1,ndim evecr(j,i) = z(j, ivctr1(i)) 125 continue endif i = i + 1 end do c..... c normalize real right eigenvectors to unity length c..... do 61 i=1,ndim vectr1(i)=0.0D0 if(DABS(wi(i)).gt.0.0d0) then else do 62 j=1,ndim vectr1(i)=vectr1(i) + evecr(j,i)*evecr(j,i) 62 continue vectr1(i)=DSQRT(vectr1(i)) do 63 j=1,ndim 63 evecr(j,i)=evecr(j,i)/vectr1(i) endif 61 continue c..... c compute the left eigenvectors by inverting the right c..... c do 150 i=1,ndim do 150 j=1,ndim 150 array1(i,j)=evecr(i,j) c do 200 i=1,ndim do 210 j=1,ndim 210 evecl(I,J) = 0.0D0 200 evecl(I,I) = 1.0D0 call dgefa(array1,nmax,ndim,ivctr1,info) if(info .ne. 0) then write(6, 37) info stop endiF do 220 i=1,ndim 220 call dgesl(array1,nmax,ndim,ivctr1,evecl(1,i),0) c 700 continue return c..... c error messages c..... c 37 FORMAT('Singular matrix in subroutine DGEFA, row ', I3) 910 format('ERROR FROM EIGENSOLVER ROUTINE RG, IERR=',i2,/, & 'No eigenvectors found') c end c c---------------------------------------------------- C From Leonard J. Moss of SLAC: C Here's a hybrid QuickSort I wrote a number of years ago. It's C based on suggestions in Knuth, Volume 3, and performs much better C than a pure QuickSort on short or partially ordered input arrays. SUBROUTINE SORT(N,DATA,INDEX) C=================================================================== C C SORTRX -- SORT, Real input, indeX output C C C Input: N INTEGER C DATA REAL C C Output: INDEX INTEGER (DIMENSION N) C C This routine performs an in-memory sort of the first N elements of C array DATA, returning into array INDEX the indices of elements of C DATA arranged in ascending order. Thus, C C DATA(INDEX(1)) will be the smallest number in array DATA; C DATA(INDEX(N)) will be the largest number in DATA. C C The original data is not physically rearranged. The original order C of equal input values is not necessarily preserved. C C=================================================================== C C SORTRX uses a hybrid QuickSort algorithm, based on several C suggestions in Knuth, Volume 3, Section 5.2.2. In particular, the C "pivot key" [my term] for dividing each subsequence is chosen to be C the median of the first, last, and middle values of the subsequence; C and the QuickSort is cut off when a subsequence has 9 or fewer C elements, and a straight insertion sort of the entire array is done C at the end. The result is comparable to a pure insertion sort for C very short arrays, and very fast for very large arrays (of order 12 C micro-sec/element on the 3081K for arrays of 10K elements). It is C also not subject to the poor performance of the pure QuickSort on C partially ordered data. C C Created: 15 Jul 1986 Len Moss C C=================================================================== INTEGER N,INDEX(N) double precision DATA(N) INTEGER LSTK(31),RSTK(31),ISTK INTEGER L,R,I,J,P,INDEXP,INDEXT double precision DATAP C QuickSort Cutoff C C Quit QuickSort-ing when a subsequence contains M or fewer C elements and finish off at end with straight insertion sort. C According to Knuth, V.3, the optimum value of M is around 9. INTEGER M PARAMETER (M=9) C=================================================================== C C Make initial guess for INDEX DO 50 I=1,N INDEX(I)=I 50 CONTINUE C If array is short, skip QuickSort and go directly to C the straight insertion sort. IF (N.LE.M) GOTO 900 C=================================================================== C C QuickSort C C The "Qn:"s correspond roughly to steps in Algorithm Q, C Knuth, V.3, PP.116-117, modified to select the median C of the first, last, and middle elements as the "pivot C key" (in Knuth's notation, "K"). Also modified to leave C data in place and produce an INDEX array. To simplify C comments, let DATA[I]=DATA(INDEX(I)). C Q1: Initialize ISTK=0 L=1 R=N 200 CONTINUE C Q2: Sort the subsequence DATA[L]..DATA[R]. C C At this point, DATA[l] <= DATA[m] <= DATA[r] for all l < L, C r > R, and L <= m <= R. (First time through, there is no C DATA for l < L or r > R.) I=L J=R C Q2.5: Select pivot key C C Let the pivot, P, be the midpoint of this subsequence, C P=(L+R)/2; then rearrange INDEX(L), INDEX(P), and INDEX(R) C so the corresponding DATA values are in increasing order. C The pivot key, DATAP, is then DATA[P]. P=(L+R)/2 INDEXP=INDEX(P) DATAP=DATA(INDEXP) IF (DATA(INDEX(L)) .GT. DATAP) THEN INDEX(P)=INDEX(L) INDEX(L)=INDEXP INDEXP=INDEX(P) DATAP=DATA(INDEXP) ENDIF IF (DATAP .GT. DATA(INDEX(R))) THEN IF (DATA(INDEX(L)) .GT. DATA(INDEX(R))) THEN INDEX(P)=INDEX(L) INDEX(L)=INDEX(R) ELSE INDEX(P)=INDEX(R) ENDIF INDEX(R)=INDEXP INDEXP=INDEX(P) DATAP=DATA(INDEXP) ENDIF C Now we swap values between the right and left sides and/or C move DATAP until all smaller values are on the left and all C larger values are on the right. Neither the left or right C side will be internally ordered yet; however, DATAP will be C in its final position. 300 CONTINUE C Q3: Search for datum on left >= DATAP C C At this point, DATA[L] <= DATAP. We can therefore start scanning C up from L, looking for a value >= DATAP (this scan is guaranteed C to terminate since we initially placed DATAP near the middle of C the subsequence). I=I+1 IF (DATA(INDEX(I)).LT.DATAP) GOTO 300 400 CONTINUE C Q4: Search for datum on right <= DATAP C C At this point, DATA[R] >= DATAP. We can therefore start scanning C down from R, looking for a value <= DATAP (this scan is guaranteed C to terminate since we initially placed DATAP near the middle of C the subsequence). J=J-1 IF (DATA(INDEX(J)).GT.DATAP) GOTO 400 C Q5: Have the two scans collided? IF (I.LT.J) THEN C Q6: No, interchange DATA[I] <--> DATA[J] and continue INDEXT=INDEX(I) INDEX(I)=INDEX(J) INDEX(J)=INDEXT GOTO 300 ELSE C Q7: Yes, select next subsequence to sort C C At this point, I >= J and DATA[l] <= DATA[I] == DATAP <= DATA[r], C for all L <= l < I and J < r <= R. If both subsequences are C more than M elements long, push the longer one on the stack and C go back to QuickSort the shorter; if only one is more than M C elements long, go back and QuickSort it; otherwise, pop a C subsequence off the stack and QuickSort it. IF (R-J .GE. I-L .AND. I-L .GT. M) THEN ISTK=ISTK+1 LSTK(ISTK)=J+1 RSTK(ISTK)=R R=I-1 ELSE IF (I-L .GT. R-J .AND. R-J .GT. M) THEN ISTK=ISTK+1 LSTK(ISTK)=L RSTK(ISTK)=I-1 L=J+1 ELSE IF (R-J .GT. M) THEN L=J+1 ELSE IF (I-L .GT. M) THEN R=I-1 ELSE C Q8: Pop the stack, or terminate QuickSort if empty IF (ISTK.LT.1) GOTO 900 L=LSTK(ISTK) R=RSTK(ISTK) ISTK=ISTK-1 ENDIF GOTO 200 ENDIF 900 CONTINUE C=================================================================== C C Q9: Straight Insertion sort DO 950 I=2,N IF (DATA(INDEX(I-1)) .GT. DATA(INDEX(I))) THEN INDEXP=INDEX(I) DATAP=DATA(INDEXP) P=I-1 920 CONTINUE INDEX(P+1) = INDEX(P) P=P-1 IF (P.GT.0) THEN IF (DATA(INDEX(P)).GT.DATAP) GOTO 920 ENDIF INDEX(P+1) = INDEXP ENDIF 950 CONTINUE C=================================================================== C C All done END c-------------------------------------------------------------------- c subroutine strt1(IcNSx,NcKFx) implicit double precision (a-h, o-z), integer (i-n) c c Common data before 1/26/94 (CKINTERP v.3.3 and CKLIB v.4.5) c COMMON /CKSTRT/ NMM , NKK , NII , MXSP, MXTB, MXTP, NCP , NCP1, 1 NCP2, NCP2T,NPAR, NLAR, NFAR, NLAN, NFAL, NREV, 2 NTHB, NRLT, NWL, IcMM, IcKK, IcNC, IcPH, IcCH, 3 IcNT, IcNU, IcNK, IcNS, IcNR, IcLT, IcRL, IcRV, 4 IcWL, IcFL, IcFO, IcKF, IcTB, IcKN, IcKT, NcAW, 5 NcWT, NcTT, NcAA, NcCO, NcRV, NcLT, NcRL, NcFL, 6 NcKT, NcWL, NcRU, NcRC, NcPA, NcKF, NcKR, NcK1, 7 NcK2, NcK3, NcK4, NcI1, NcI2, NcI3, NcI4 c IcNSx= IcNS NcKFx= NcKF c return end c c-------------------------------------------------------------------- c subroutine strt2(IcNSx,NcKFx) c c Common data after 1/26/94 (CKINTERP v.3.3 and CKLIB v.4.5) c COMMON /CKSTRT/ NMM , NKK , NII , MXSP, MXTB, MXTP, NCP , NCP1, 1 NCP2, NCP2T,NPAR, NLAR, NFAR, NLAN, NFAL, NREV, 2 NTHB, NRLT, NWL, NRNU, NORD, MXORD,IcMM, IcKK, 3 IcNC, IcPH, IcCH, IcNT, IcNU, IcNK, IcNS, IcNR, 4 IcLT, IcRL, IcRV, IcWL, IcFL, IcFO, IcKF, IcTB, 5 IcKN, IcKT, IcRNU,IcORD,IcKOR,NcAW, NcWT, NcTT, 6 NcAA, NcCO, NcRV, NcLT, NcRL, NcFL, NcKT, NcWL, 7 NcRU, NcRC, NcPA, NcKF, NcKR, NcRNU,NcKOR,NcK1, 8 NcK2, NcK3, NcK4, NcI1, NcI2, NcI3, NcI4 c IcNSx= IcNS NcKFx= NcKF c return end c c============================================================================= c c On the programming style of KINALC c c c The easiest way to tell a Real Programmer from the crowd is by the c programming language he (or she) uses. Real Programmers use FORTRAN. c c * Real Programmers do List Processing in FORTRAN. c c * Real Programmers do String Manipulation in FORTRAN. c c * Real Programmers do Artificial Intelligence programs in FORTRAN. c c ... c Computer science academicians have gotten into the "structured pro- c gramming" rut over the past several years. They claim that programs are c more easily understood if the programmer uses some special language con- c structs and techniques. Some quick observations on Real Programmers and c Structured Programming: c c * Real Programmers aren't afraid to use GOTOs. c c * Real Programmers can write five page long DO loops without getting c confused. c c * Real Programmers don't need comments: the code is obvious. c c * Since FORTRAN doesn't have a structured IF, REPEAT ... UNTIL, or CASE c statement, Real Programmers don't have to worry about not using them. c Besides, they can be simulated when necessary using assigned GOTOs. c c ... c Data structures have also gotten a lot of press lately. Abstract Data c Types, Structures, Pointers, Lists, and Strings have become popular in cer- c tain circles. As all Real Programmers know, c the only useful data structure is the array. Strings, lists, structures, c sets -- these are all special cases of arrays and and can be treated that c way just as easily without messing up your programing language with all c sorts of complications. The worst thing about fancy data types is that you c have to declare them, and Real Programming Languages, as we all know, c have implicit typing based on the first letter of the (six character) c variable name. c c c c Excerpts from: "Real Programmers Don't Use PASCAL", Ed Post, 1982 c c c 1 2 3 4 5 6 7 c23456789012345678901234567890123456789012345678901234567890123456789012