!***************************************************************************************** ! generates meteor spectrum observable from ground and calculates luminous efficiency ! allowed flight speed = 10 to 40 km/s ! allowed flight altitude = 0 to 60 km ! allowed nose radius = 0.01 to 100 m ! specify chemical composition of meteoroid in meteor_spect.inp file lines 1206 - 1219 ! luminous efficiency is given in the last column of amdot.tally file ! ! written by Chul Park, Korea Advanced Institute of Science and Technology (KAIST), March, 2017 program meteor_spect parameter(mnode=1,matoms=56,mdiatoms=12,mtriatoms=6,msp=60) parameter(nw=400000) implicit real*8(a-h,o-z) character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms),spnma(9) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 character*1 dum(120) dimension temp1(11),tempx(11),spgam(msp),waveli(11),iwavel(11), & & absbi(11,11),elmsf(8),spmlf(32),an(10) common/coma/absb(nw) common/comi/nwave common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e common/spect/calpha,slope_ratio,wavmin,wavmax,range common/eqivu/rho_ivu(11),t_ivu(11),h_ivu(11) common/lowdens/ntlow common/lowdens1/templ(11),enthl(11) save ! ! concx's are species concentrations in m-3 ! p means +, e.g. cp = C+ ! ne means electron ! hvy means heavy particles (atoms, diatoms, triatoms, and their ions) ! ! enths=0.5*vinf*vinf*enfac ! enthj=temporary enthalpy value ! enth(idm)=enthalpy at node points dimension concAl(mnode),concAlp(mnode),concAlpp(mnode), & & concAl3p(mnode),concC(mnode), concC2(mnode), & & concCa(mnode),concCap(mnode),concCl(mnode),concC2H(mnode), & & concC3(mnode),concCH(mnode), concCN(mnode),concCO(mnode), & & concCO2(mnode),concCp(mnode), concCpp(mnode),concC3p(mnode), & & concC4p(mnode),concCr(mnode),concCrp(mnode),concCrpp(mnode), & & concFe(mnode),concFeO(mnode),concFep(mnode),concFepp(mnode), & & concFe3p(mnode),concFe4p(mnode),concFe5p(mnode),concH(mnode), & & concH2(mnode), concHp(mnode),concH2O(mnode),concK(mnode), & & concMg(mnode), concMgO(mnode),concMgp(mnode),concMgpp(mnode), & & concMg3p(mnode),concMg4p(mnode),concN(mnode),concNE(mnode), & & concN2(mnode),concN2p(mnode),concNp(mnode),concNpp(mnode), & & concN3p(mnode),concN4p(mnode),concNa(mnode),concNap(mnode), & & concNO(mnode),concNi(mnode),concNip(mnode),concNipp(mnode), & & concNi3p(mnode),concO(mnode),concO2(mnode),concOH(mnode), & & concOp(mnode),concOpp(mnode),concO3p(mnode),concO4p(mnode), & & concS(mnode),concSi(mnode),concSO(mnode),concSiO(mnode), & & concSip(mnode),concSipp(mnode),concSi3p(mnode),concSi4p(mnode), & & concSp(mnode),concSpp(mnode),concS3p(mnode),concS4p(mnode), & & concSiH(mnode),concTi(mnode),concTip(mnode),concTipp(mnode), & & concTi3p(mnode),concTiO(mnode), & & z(mnode), tran(mnode),trot(mnode),tvib(mnode),tele(mnode), & & avg_molwt(mnode),tblack(2),ansp(msp) dimension rhoi(9),tempi(31) data dum1/60*'****'/ ! open(1,file='atom.out') open(2,file='diatom.out') open(3,file='triatom.out') open(4,file='eqtab_air_vis.dat') open(5,file='meteor_spect.inp') open(6,file='meteor_spect.out') open(7,file='atom.dat') open(8,file='diatom.dat') open(9,file='triatom.dat ') open(10,file='amdot.tally') open(11,file='flowfield.out') open(12,file='outer_conv.out') open(13,file='inner_conv.out') open(14,file='spect_air.plt') open(15,file='spect_vap.plt') open(16,file='absb_air.out') open(17,file='absb_vap.out') open(18,file='absb_low.out') open(19,file='thermair.inp') open(20,file='temp_display') open(21,file='short_file') open(22,file='trouble_shooting') data atom_rads/ & & 'Al ','bb ','Al ', & ! 'Al ','bb ' 1 & & 'Al ','bc ','Al ', & ! 'Al ','bf ' 2 & & 'Al ','ff ','Al ', & ! 'Al ','ff ' 3 & & 'C ','bb ','C ', & ! 'C ','bb ', 4 & & 'C ','bc ','C ', & ! 'C ','bf ', 5 & & 'C ','ff ','C ', & ! 'C ','ff ', 6 & & 'Ca ','bb ','Ca ', & ! 'Ca ','bb ' 7 & & 'Ca ','bG ','Ca ', & ! 'Ca ','bf ' 8 & & 'Ca ','ff ','Ca ', & ! 'Ca ','ff ' 9 & & 'Cr ','bb ','Cr ', & ! 'Cr ','bb ' 10-------------------- & & 'Cr ','bG ','Cr ', & ! 'Cr ','bf ' 11 & & 'Cr ','ff ','Cr ', & ! 'cr ','ff ' 12 & & 'Fe ','bb ','Fe ', & ! 'Fe ','bb ' 13 & & 'Fe ','bG ','Fe ', & ! 'Fe ','bf ' 14 & & 'Fe ','ff ','Fe ', & ! 'Fe ','ff ' 15 & & 'H ','bb ','H ', & ! 'H ','bb ', 16 & & 'H ','bG ','H ', & ! 'H ','bf ', 17 & & 'H ','ff ','H ', & ! 'H ','ff ', 18 & & 'Mg ','bb ','Mg ', & ! 'Mg ','bb ', 19 & & 'Mg ','bc ','Mg ', & ! 'Mg ','bf ', 20------------------- & & 'Mg ','ff ','Mg ', & ! 'Mg ','ff ' 21 & & 'Na ','bb ','Na ', & ! 'Na ','bb ' 22 & & 'Na ','bc ','Na ', & ! 'Na ','bf ' 23 & & 'Na ','ff ','Na ', & ! 'Na ','ff ' 24 & & 'N ','bb ','N ', & ! 'N ','bb ', 25 & & 'N ','bc ','N ', & ! 'N ','bf ', 26 & & 'N ','ff ','N ', & ! 'N ','ff ', 27 & & 'Ni ','bb ','Ni ', & ! 'Ni ','bb ' 28 & & 'Ni ','bG ','Ni ', & ! 'Ni ','bf ' 29 & & 'Ni ','ff ','Ni ', & ! 'Ni ','ff ' 30------------------ & & 'O ','bb ','O ', & ! 'O ','bb ', 31 & & 'O ','bc ','O ', & ! 'O ','bf ', 32 & & 'O ','ff ','O ', & ! 'O ','ff ', 33 & & 'S ','bb ','S ', & ! 'S ','bb ' 34 & & 'S ','bG ','S ', & ! 'S ','bf ' 35 & & 'S ','ff ','S ', & ! 'S ','ff ' 36 & & 'Si ','bb ','Si ', & ! 'Si ','bb ', 37 & & 'Si ','bc ','Si ', & ! 'Si ','bf ', 38 & & 'Si ','ff ','Si ', & ! 'Si ','ff ', 39 & & 'Ti ','bb ','Ti ', & ! 'Ti ','bb ' 40------------------ & & 'Ti ','bG ','Ti ', & ! 'Ti ','bf ' 41 & & 'Ti ','ff ','Ti ', & ! 'Ti ','ff ' 42 & & 'Al+ ','bb ','Al+ ', & ! 'Al+ ','bb ' 43 & & 'Al+ ','bc ','Al+ ', & ! 'Al+ ','bf ' 44 & & 'Al+ ','ff ','Al+ ', & ! 'Al+ ','ff ' 45 & & 'C+ ','bb ','C+ ', & ! 'C+ ','bb ' 46 & & 'C+ ','bc ','C+ ', & ! 'C+ ','bf ' 47 & & 'C+ ','ff ','C+ ', & ! 'C+ ','ff ' 48 & & 'Ca+ ','bb ','Ca+ ', & ! 'Ca+ ','bb ' 49 & & 'Ca+ ','bc ','Ca+ ', & ! 'Ca+ ','bf ' 50----------------- & & 'Ca+ ','ff ','Ca+ ', & ! 'Ca+ ','ff ' 51 & & 'Cr+ ','bb ','Cr+ ', & ! 'Cr+ ','bb ' 52 & & 'Cr+ ','bG ','Cr+ ', & ! 'Cr+ ','bf ' 53 & & 'Cr+ ','ff ','Cr+ ', & ! 'Cr+ ','ff ' 54 & & 'Fe+ ','bb ','Fe+ ', & ! 'Fe+ ','bb ' 55 & & 'Fe+ ','bG ','Fe+ ', & ! 'Fe+ ','bf ' 56 & & 'Fe+ ','ff ','Fe+ ', & ! 'Fe+ ','ff ' 57 & & 'Mg+ ','bb ','Mg+ ', & ! 'Mg+ ','bb ' 58 & & 'Mg+ ','bc ','Mg+ ', & ! 'Mg+ ','bf ' 59 & & 'Mg+ ','ff ','Mg+ ', & ! 'Mg+ ','ff ' 60------------- & & 'N+ ','bb ','N+ ', & ! 'N+ ','bb ' 61 & & 'N+ ','bc ','N+ ', & ! 'N+ ','bf ' 62 & & 'N+ ','ff ','N+ ', & ! 'N+ ','ff ' 63 & & 'Na+ ','bb ','Na+ ', & ! 'Na+ ','bb ' 64 & & 'Na+ ','bG ','Na+ ', & ! 'Na+ ','bf ' 65 & & 'Na+ ','ff ','Na+ ', & ! 'Na+ ','ff ' 66 & & 'Ni+ ','bb ','Ni+ ', & ! 'Ni+ ','bb ' 67 & & 'Ni+ ','bG ','Ni+ ', & ! 'Ni+ ','bf ' 68 & & 'Ni+ ','ff ','Ni+ ', & ! 'Ni+ ,'ff ' 69 & & 'O+ ','bb ','O+ ', & ! 'O+ ','bb ' 70------------------- & & 'O+ ','bc ','O+ ', & ! 'O+ ','bf ' 71 & & 'O+ ','ff ','O+ ', & ! 'O+ ','ff ' 72 & & 'S+ ','bG ','S+ ', & ! 'S+ ','bb ' 73 & & 'S+ ','ff ','S+ ', & ! 'S+ ','bf ' 74 & & 'S+ ','ff ','S+ ', & ! 'S+ ','ff ' 75 & & 'Si+ ','bb ','Si+ ', & ! 'Si+ ','bb ' 76 & & 'Si+ ','bc ','Si+ ', & ! 'Si+ ','bf ' 77 & & 'Si+ ','ff ','Si+ ', & ! 'Si+ ','ff ' 78 & & 'Ti+ ','bb ','Ti+ ', & ! 'Ti+ ','bb ' 79 & & 'Ti+ ','bG ','Ti+ ', & ! 'Ti+ ','bf ' 80------------------ & & 'Ti+ ','ff ','Ti+ ', & ! 'Ti+ ','ff ' 81 & & 'Al++','bb ','Al++', & ! 'Al++','bb ' 82 & & 'Al++','bG ','Al++', & ! 'Al++','bf ' 83 & & 'Al++','ff ','Al++', & ! 'Al++','ff ' 84 & & 'C++ ','bb ','C++ ', & ! 'C++ ','bb ' 85 & & 'C++ ','bc ','C++ ', & ! 'C++ ','bf ' 86 & & 'C++ ','ff ','C++ ', & ! 'C++ ','ff ' 87 & & 'Fe++','bb ','Fe++', & ! 'Fe++','bb ' 88 & & 'Fe++','bG ','Fe++', & ! 'Fe++','bf ' 89 & & 'Fe++','ff ','Fe++', & ! 'Fe++','ff ' 90------------------ & & 'Mg++','bb ','Mg++', & ! 'Mg++','bb ' 91 & & 'Mg++','bG ','Mg++', & ! 'Mg++','bf ' 92 & & 'Mg++','ff ','Mg++', & ! 'Mg++','ff ' 93 & & 'N++ ','bb ','N++ ', & ! 'N++ ','bb ' 94 & & 'N++ ','bG ','N++ ', & ! 'N++ ','bf ' 95 & & 'N++ ','ff ','N++ ', & ! 'N++ ','ff ' 96 & & 'Ni++','bb ','Ni++', & ! 'Ni++','bb ' 97 & & 'Ni++','bG ','Ni++', & ! 'Ni++','bf ' 98 & & 'Ni++','ff ','Ni++', & ! 'Nr++','ff ' 99 & & 'O++ ','bb ','O++ ', & ! 'O++ ','bb ' 100--------------- & & 'O++ ','bG ','O++ ', & ! 'O++ ','bf ' 101 & & 'O++ ','ff ','O++ ', & ! 'O++ ','ff ' 102 & & 'S++ ','bb ','S++ ', & ! 'S++ ','bb ' 103 & & 'S++ ','bG ','S++ ', & ! 'S++ ','bf ' 104 & & 'S++ ','ff ','S++ ', & ! 'S++ ','ff ' 105 & & 'Si++','bb ','Si++', & ! 'Si++','bb ' 106 & & 'Si++','bG ','Si++', & ! 'Si++','bf ' 107 & & 'Si++','ff ','Si++', & ! 'Si++','ff ' 108 & & 'Ti++','bb ','Ti++', & ! 'Ti++','bb ' 109 & & 'Ti++','bG ','Ti++', & ! 'Ti++','bf ' 110---------------- & & 'Ti++','ff ','Ti++', & ! 'T+++','ff ' 111 & & 'Al+3','bb ','Al+3', & ! 'Al+3','bb ' 112 & & 'Al+3','bG ','Al+3', & ! 'Al+3','bf ' 113 & & 'Al+3','ff ','Al+3', & ! 'Al+3','ff ' 114 & & 'C+3 ','bb ','C+3 ', & ! 'C+3 ','bb ' 115 & & 'C+3 ','bG ','C+3 ', & ! 'C+3 ','bf ' 116 & & 'C+3 ','ff ','C+3 ', & ! 'C+3 ','ff ' 117 & & 'Fe+3','bb ','Fe+3', & ! 'Fe+3','bb ' 118 & & 'Fe+3','bG ','Fe+3', & ! 'Fe+3','bf ' 119 & & 'Fe+3','ff ','Fe+3', & ! 'Fe+3','ff ' 120------------------ & & 'Mg+3','bb ','Mg+3', & ! 'Mg+3','bb ' 121 & & 'Mg+3','bG ','Mg+3', & ! 'Mg+3','bf ' 122 & & 'Mg+3','ff ','Mg+3', & ! 'Mg+3','ff ' 123 & & 'S+3 ','bb ','S+3 ', & ! 'S+3 ','bb ' 124 & & 'S+3 ','bG ','S+3 ', & ! 'S+3 ','bf ' 125 & & 'S+3 ','ff ','S+3 ', & ! 'S+3 ','ff ' 126 & & 'N+3 ','bb ','N+3 ', & ! 'N+3 ','bb ' 127 & & 'N+3 ','bG ','N+3 ', & ! 'N+3 ','bf ' 128 & & 'N+3 ','ff ','N+3 ', & ! 'N+3 ','ff ' 129 & & 'Ni+3','bb ','Ni+3', & ! 'Ni+3','bb ' 130----------------- & & 'Ni+3','bG ','Ni+3', & ! 'Ni+3','bf ' 131 & & 'Ni+3','ff ','Ni+3', & ! 'Ni+3','ff ' 132 & & 'O+3 ','bb ','O+3 ', & ! 'O+3 ','bb ' 133 & & 'O+3 ','bG ','O+3 ', & ! 'O+3 ','bf ' 134 & & 'O+3 ','ff ','O+3 ', & ! 'O+3 ','ff ' 135 & & 'Si+3','bb ','Si+3', & ! 'Si+3','bb ' 136 & & 'Si+3','bG ','Si+3', & ! 'Si+3','bf ' 137 & & 'Si+3','ff ','Si+3', & ! 'Si+3','ff ' 138 & & 'Ti+3','bb ','Ti+3', & ! 'Ti+3','bb ' 139 & & 'Ti+3','bG ','Ti+3', & ! 'Ti+3','bf ' 140------------------ & & 'Ti+3','ff ','Ti+3', & ! 'T++3','ff ' 141 & & 'C+4 ','bb ','C+4 ', & ! 'C+4 ','bb ' 142 & & 'C+4 ','bG ','C+4 ', & ! 'C+4 ','bf ' 143 & & 'C+4 ','ff ','C+4 ', & ! 'C+4 ','ff ' 144 & & 'Fe+4','bb ','Fe+4', & ! 'Fe+4','bb ' 145 & & 'Fe+4','bG ','Fe+4', & ! 'Fe+4','bf ' 146 & & 'Fe+4','ff ','Fe+4', & ! 'Fe+4','ff ' 147 & & 'Mg+4','bb ','Mg+4', & ! 'Mg+4','bb ' 148 & & 'Mg+4','bG ','Mg+4', & ! 'Mg+4','bf ' 149 & & 'Mg+4','ff ','Mg+4', & ! 'Mg+4','ff ' 150----------------- & & 'N+4 ','bb ','N+4 ', & ! 'N+4 ','bb ' 151 & & 'N+4 ','bG ','N+4 ', & ! 'N+4 ','bf ' 152 & & 'N+4 ','ff ','N+4 ', & ! 'N+4 ','ff ' 153 & & 'O+4 ','bb ','O+4 ', & ! 'O+4 ','bb ' 154 & & 'O+4 ','bG ','O+4 ', & ! 'O+4 ','bf ' 155 & & 'O+4 ','ff ','O+4 ', & ! 'O+4 ','ff ' 156 & & 'Si+4','bb ','Si+4', & ! 'Si+4','bb ' 157 & & 'Si+4','bG ','Si+4', & ! 'Si+4','bf ' 158 & & 'Si+4','ff ','Si+4', & ! 'Si+4','ff ' 159 & & 'Fe+5','bb ','Fe+5', & ! 'Fe+5','bb ' 160---------------- & & 'Fe+5','bG ','Fe+5', & ! 'Fe+5','bf ' 161 & & 'Fe+5','ff ','Fe+5', & ! 'Fe+5','ff ' 162 & & 'H+ ','ff ','H+ ', & ! 'H+ ','ff ' 163 & & ' ','bb ','K ', & ! 'K ','bb ' 164 & & ' ','bf ','K ', & ! 'K ','bf ' 165 & & ' ','ff ','K ', & ! 'K ','ff ' 166 & & ' ',' ',' ', & ! ' ',' ' 167 & & ' ',' ',' '/ ! ' ','bf ' 168 & ! atom list in atom.dat, matoms = 59 ! data atomnm1/ & ! & 'Al ','Al+ ','Al++','Al+3','C ','C+ ','C++ ','C+3 ','C+4 ','Ca ', & ! & 'Ca+ ','Cl ','Cr ','Cr+ ','Fe ','Fe+ ','Fe++','Fe+3','Fe+4','Fe+5', & ! & 'Fe+6','H ','H+ ','K ','Mg ','Mg+ ','Mg++','Mg+3','Mg+4','N ', & ! & 'N+ ','N++ ','N+3 ','N+4 ','Na ','Na+ ','Ni ','Ni+ ','Ni++','Ni+3', & ! & 'O ','O+ ','O++ ','O+3 ','O+4 ','S ','S+ ','S++ ','S+3 ','S+4 ', & ! & 'Si ','Si+ ','Si++','Si+3','Si+4','Ti ','Ti+ ','Ti++','Ti+3'/ ! atom list in source code head = 56 data atomnm1/ & & 'Al ','C ','Ca ','Cr ','Fe ','H ','Mg ','Na ','N ','Ni ', & & 'O ','S ','Si ','Ti ','Al+ ','C+ ','Ca+ ','Cr+ ','Fe+ ','Mg+ ', & & 'N+ ','Na+ ','Ni+ ','O+ ','S+ ','Si+ ','Ti+ ','Al++','C++ ','Fe++', & & 'Mg++','N++ ','Ni++','O++ ','S++ ','Si++','Ti++','Al+3','C+3 ','Fe+3', & & 'Mg+3','S+3 ','N+3 ','Ni+3','O+3 ','Si+3','Ti+3','C+4 ','Fe+4','Mg+4', & & 'N+4 ','O+4 ','Si+4','Fe+5','H+ ',' '/ ! ! species list in eqcal2 = 67 ! & 'Al ','C ','C2 ','Cl ','Cr ','C2H ','Ca ','C3 ','CH ','CN ', & ! & 'CO ','CO2 ','Al+ ','Al++','Al+3','C+ ','Ca+ ','Cr+ ','C++ ','C+3 ', & ! & 'Cr++','Fe ','FeO ','Fe+ ','Fe++','Fe+3','Fe+4','Fe+5','H ','H2 ', & ! & 'N2 ','N2+ ','N+ ','N++ ','N+3 ','N+4 ','Na ','Na+ ','Ni ','Ni+ ', & ! & 'Ni++','Ni+3','NO ','O ','O2 ','OH ','O+ ','O++ ','O+3 ','O+4 ', & ! & 'S ','Si ','SO ','Si+ ','Si++','Si+3','Si+4','S+ ','S++ ','S+3 ', & ! & 'SiH ','SiO ','Ti ','Ti+ ','Ti++','Ti+3','TiO '/ ! ! number of variables in air = 16 ! & 'N ','O ','N2 ','O2 ','NO ','N+ ','O+ ','N++ ','O++ ','N+3 ', & ! & 'O+3 ','N+4 ','O+4 ','NO+ ','N2+ ','O2+ '/ ! ! number of variables in ablation-product = 59 ! & 'S ','H ','C ','O ','Si ','Mg ','Fe ','Ca ','Al ','Na ', & ! & 'Ti ','Cr ','Ni ','O2 ','OH ','CO ','SO ','SiO ','MgO ','FeO ', & ! & 'TiO ','SiO2','S+ ','C+ ','H+ ','O+ ','Si+ ','Mg+ ','Fe+ ','Ca+ ', & ! & 'Al+ ','Na+ ','Ti+ ','Cr+ ','Ni+ ','Al++','C++ ','S++ ','O++ ','Si++', & ! & 'Mg++','Fe++','Ti++','Cr++','Ni++','Al+3','S+3 ','C+3 ','O+3 ','Si+3', & ! & 'Mg+3','Fe+3','Ti+3','Cr+3','Ni+3','Si+4','Fe+4','Ti+4','Ni+4'/ ! ! overlapping species between air and ablation product = 5 ! 'O ','O2 ','O+ ','O++ ','O+3 ' ! net number of variables in program = 16 + 59 - 5 = 70 ! data diatom_bands/ & & 'C2 ','Swan','C2 ', & ! 'C2 ','Swan', 1 & & 'C2 ','Phil','C2 ', & ! 'C2 ','Phil', 2 & & 'C2 ','BR ','C2 ', & ! 'C2 ','BR ', 3 & & 'C2 ','Frey','C2 ', & ! 'C2 ','Frey', 4 & & 'C2 ','FH ','C2 ', & ! 'C2 ','FH ', 5-- & & 'C2 ','Mull','C2 ', & ! 'C2 ','Mull', 6 & & 'C2 ','Dd ','C2 ', & ! 'C2 ','Dd ', 7 & & 'C2 ','nrct','C2 ', & ! 'C2 ','nrct', 8 & & 'C2 ','cont','C2 ', & ! 'C2 ','cont', 9 & & 'CN ','Viol','CN ', & ! 'CN ','Viol', 10-------- & & 'CN ','Red ','CN ', & ! 'CN ','Red ', 11 & & 'CO ','4+ ','CO ', & ! 'CO ','4+ ', 12 CO & & 'CO ','BX ','CO ', & ! 'CO ','BX ', 13 CO & & 'CO ','CX ','CO ', & ! 'CO ','CX ', 14 CO & & 'CO ','EX ','CO ', & ! 'CO ','EX ', 15-- CO & & 'CO ','FX ','CO ', & ! 'CO ','FX ', 16 CO & & 'CO ','GX ','CO ', & ! 'CO ','GX ', 17 CO & & 'CO ','3+ ','CO ', & ! 'CO ','3+ ', 18 CO & & 'CO ','cont','CO ', & ! 'CO ','cont', 19 CO & & 'H2 ','BX ','H2 ', & ! 'H2 ','BX ', 20----------- & & 'H2 ','CX ','H2 ', & ! 'H2 ','CX ', 21 & & 'H2 ','cont','H2 ', & ! 'H2 ','cont', 22 & & 'N2 ','1+ ','N2 ', & ! 'N2 ','1+ ', 23 N2 & & 'N2 ','2+ ','N2 ', & ! 'N2 ','2+ ', 24 N2 & & 'N2 ','W ','N2 ', & ! 'N2 ','W ', 25-- N2 & & 'N2 ','BH1 ','N2 ', & ! 'N2 ','BH1 ', 26 N2 & & 'N2 ','BH2 ','N2 ', & ! 'N2 ','BH2 ', 27 N2 & & 'N2 ','WJ ','N2 ', & ! 'N2 ','WJ ', 28 N2 & & 'N2 ','CY ','N2 ', & ! 'N2 ','CY ', 29 N2 & & 'N2 ','LBH ','N2 ', & ! 'N2 ','LBH ', 30-----------N2 & & 'N2 ','cont','N2 ', & ! 'N2 ','cont', 31 N2 & & 'N2+ ','1- ','N2+ ', & ! 'N2+ ','1- ', 32 N2+ & & 'N2+ ','Mein','N2+ ', & ! 'N2+ ','Mein', 33 N2+ & & 'N2+ ','2- ','N2+ ', & ! 'N2+ ','2- ', 34 N2+ & & 'NO ','Gamm','NO ', & ! 'NO ','Gamm', 35-- NO & & 'NO ','Beta','NO ', & ! 'NO ','Beta', 36 NO & & 'NO ','Delt','NO ', & ! 'NO ','Delt', 37 NO & & 'NO ','Epsi','NO ', & ! 'NO ','Epsi', 38 NO & & 'O2 ','SR ','O2 ', & ! 'O2 ','SR ', 39 O2 & & 'O2 ','cont','O2 ', & ! 'O2 ','cont', 40-----------O2 & & 'CH ','AX ','CH ', & ! 'CH ','AX ', 41 & & 'CH ','BX ','CH ', & ! 'CH ','BX ', 42 & & 'CH ','CX ','CH ', & ! 'CH ','CX ', 43 & & 'OH ','AX ','OH ', & ! 'OH ','AX ', 44 OH & & ' ',' ',' ', & ! ' ',' ', 45-- & & 'SiO ','AX ','SiO ', & ! 'SiO ','AX ', 46 SiO & & 'SiO ','EX ','SiO ', & ! 'SiO ','EX ', 47 SiO & & 'SiO ','cont','SiO ', & ! 'SiO ','cont', 48 SiO & & 'MgO ','BX ','MgO ', & ! 'MgO ','BX ', 49 MgO & & 'MgO ','BA ','MgO ', & ! 'MgO ','BA ', 50-----------MgO & & 'MgO ','AX ','MgO ', & ! 'MgO ','AX ', 51 MgO & & 'MgO ','Ba ','MgO ', & ! 'MgO ','Ba ', 52 MgO & & 'MgO ','da ','MgO ', & ! 'MgO ','da ', 53 MgO & & 'MgO ','Da ','MgO ', & ! 'MgO ','Da ', 54 MgO & & 'FeO ','OR1 ','FeO ', & ! 'FeO ','OR1 ', 55-- FeO & & 'FeO ','OR2 ','FeO ', & ! 'FeO ','OR2 ', 56 FeO & & 'FeO ','cont','FeO ', & ! 'FeO ','IR3 ', 57 FeO & & 'SO ','AX0 ','SO ', & ! 'SO ','AX0 ', 58 SO & & 'SO ','AX1 ','SO ', & ! 'SO ','AX1 ', 59 SO & & 'SO ','AX2 ','SO ', & ! 'SO ','AX2 ', 60-----------SO & & 'TiO ','A-X ','TiO ', & ! 'TiO ','A-X ', 61 TiO & & 'TIO ','B-X ','TiO ', & ! 'TIO ','B-X ', 62 TiO & & 'TIO ','E-X ','TiO ', & ! 'TIO ','C-X ', 63 TiO & & 'TIO ','E-X ','TiO ', & ! 'TIO ','E-X ', 64 TiO & & 'TIO ','f-a ','TiO ', & ! 'TIO ','f-a ', 65-- TiO & & 'TIO ','f-c ','TiO ', & ! 'TIO ','f-c ', 66 TiO & & 'TIO ','f-b ','TiO ', & ! 'TIO ','f-b ', 67 TiO & & 'TiO ','b-a ','TiO ', & ! 'TiO ','b-a ', 68 TiO & & 'TiO ','b-d ','TiO ', & ! 'TiO ','b-d ', 69 TiO & & 'TiO ','c-a ','TiO ', & ! 'TiO ','c-a ', 70----------- & & 'SiH ','AX ','SiH ', & ! 'SiH ','AX ', 71 & & 'SiH ','cont','SiH ', & ! 'SiH ','cont', 72 & & 'MgH ','AX ','MgH ', & ! 'MgH ','AX ', 73 & & 'MgH ','BX ','MgH ', & ! 'MgH ','BX ', 74 & & 'MgH ','CX ','MgH ', & ! 'MgH ','CX ', 75-- & & 'MgH ','cont','MgH ', & ! 'MgH ','cont', 76 & & ' ',' ',' ', & ! ' ',' ', 77 & & ' ',' ',' ', & ! ' ',' ', 78 & & ' ',' ',' ', & ! ' ',' ', 79 & & ' ',' ',' ', & ! ' ',' ', 80----------- & & ' ',' ',' ', & ! ' ',' ', 81 & & ' ',' ',' ', & ! ' ',' ', 82 & & ' ',' ',' ', & ! ' ',' ', 83 & & ' ',' ',' ', & ! ' ',' ', 84 & & ' ',' ',' ', & ! ' ',' ', 85---- & & ' ',' ',' ', & ! ' ',' ', 86 & & ' ',' ',' ', & ! ' ',' ', 87 & & ' ',' ',' ', & ! ' ',' ', 88 & & ' ',' ',' ', & ! ' ',' ', 89 & & ' ',' ',' ', & ! ' ',' ', 90----------- & & ' ',' ',' ', & ! ' ',' ', 91 & & ' ',' ',' ', & ! ' ',' ', 92 & & ' ',' ',' ', & ! ' ',' ', 93 & & ' ',' ',' ', & ! ' ',' ', 94 & & ' ',' ',' ', & ! ' ',' ', 95------ & & ' ',' ',' ', & ! ' ',' ', 96 & & ' ',' ',' ', & ! ' ',' ', 97 & & ' ',' ',' ', & ! ' ',' ', 98 & & ' ',' ',' ', & ! ' ',' ', 99 & & ' ',' ',' '/ ! ' ',' ',100--------------- data diatomnm1/'N2 ','O2 ','NO ','N2+ ','SiO ','MgO ','FeO ', & & 'SO ','OH ','CO ','TiO ',' '/ ! data triatom_bands/ & & 'C3 ','Swin','C3 ', & ! 'C3 ','Swin', 1 & & 'C3 ','VUV ','C3 ', & ! 'C3 ','VUV ', 2 & & 'C3 ','phot','C3 ', & ! 'C3 ','phot', 3 & & ' ','UV ','C2H ', & ! 'C2H ','UV ', 4 & & 'H2O ','VUV ','H2O ', & ! 'H2O ','VUV ', 5 & & 'H2O ','visi','H2O ', & ! 'H2O ','visi', 6 & & 'H2O ','IR ','H2O ', & ! 'H2O ','IR ', 7 & & 'CO2 ','VUV ','CO2 ', & ! 'CO2 ','VUV ', 8 & & 'CO2 ','IR ','CO2 ', & ! 'CO2 ','IR ', 9 & & ' ',' ',' '/ ! ' ',' ', 10 data triatomnm1/6*' '/ data nprt/1/ ! slope ratio of the wavelength-vs- iw curve data slope_ratio/3./ ! ! initialize equilibrium tables call pH_air(0,0.d0,0.d0, rhos,temps) ! call pT_air(0,0.d0,0.d0, rhos,enth_dum,cp) ! call pT_vis_air(0.,0., visc) ! ! read spectroscopic data natoms=56 ! number of atoms in list call atom_read(natoms) ndiatoms=10 ! number of diatoms in list call diatom_read(ndiatoms) ntriatoms=5 ! number of triatoms in list call triatom_read(ntriatoms) ! ! flight conditions read(5,210) (dum(i),i=1,120) 210 format(130a1) write(6,210) (dum(i),i=1,120) read(5,10) nwave,(dum(i),i=1,120) 10 format(i10,120a1) write(6,10) nwave,(dum(i),i=1,120) read(5,10) nair,(dum(i),i=1,120) write(6,10) nair,(dum(i),i=1,120) read(5,10) nabl,(dum(i),i=1,120) write(6,10) nabl,(dum(i),i=1,120) read(5,30) wavmin,(dum(i),i=1,120) write(6,40) wavmin,(dum(i),i=1,120) read(5,30) wavmax,(dum(i),i=1,120) write(6,40) wavmax,(dum(i),i=1,120) read(5,210) (dum(i),i=1,120) write(6,210) (dum(i),i=1,120) read(5,30) rhoinf,(dum(i),i=1,120) 30 format(e10.3,120a1) write(6,40) rhoinf,(dum(i),i=1,120) 40 format(1pe10.3,120a1) read(5,30) vinf,(dum(i),i=1,120) write(6,40) vinf,(dum(i),i=1,120) read(5,30) rnose,(dum(i),i=1,80) write(6,40) rnose,(dum(i),i=1,80) read(5,10) ndm,(dum(i),i=1,80) write(6,10) ndm,(dum(i),i=1,80) read(5,10) nout,(dum(i),i=1,80) write(6,10) nout,(dum(i),i=1,80) read(5,10) nim,(dum(i),i=1,80) write(6,10) nim,(dum(i),i=1,80) read(5,30) facout1,(dum(i),i=1,80) write(6,40) facout1,(dum(i),i=1,80) read(5,30) facin1,(dum(i),i=1,80) write(6,40) facin1,(dum(i),i=1,80) read(5,30) facout2,(dum(i),i=1,80) write(6,40) facout2,(dum(i),i=1,80) read(5,30) facin2,(dum(i),i=1,80) write(6,40) facin2,(dum(i),i=1,80) read(5,30) famdot,(dum(i),i=1,80) write(6,40) famdot,(dum(i),i=1,80) read(5,30) enfac,(dum(i),i=1,80) write(6,40) enfac,(dum(i),i=1,80) read(5,30) elev_ang,(dum(i),i=1,80) write(6,40) elev_ang,(dum(i),i=1,80) read(5,30) hwhh,(dum(i),i=1,80) write(6,40) hwhh,(dum(i),i=1,80) read(5,30) sigma,(dum(i),i=1,80) write(6,40) sigma,(dum(i),i=1,80) read(5,30) spallf,(dum(i),i=1,80) write(6,40) spallf,(dum(i),i=1,80) pres=rhoinf*vinf*vinf write(6,120) pres 120 format(1pe11.4,' Pa. Shock layer pressure') ! ! parameter in wavelength calculation calpha=dlog(slope_ratio)/dlog(dfloat(nwave))+1. ! ! assumed shock layer enthalpy enths=0.5*vinf*vinf*enfac call pH_air(1,pres,enths, rhos,temps) ! !----------------------------------------------------------------air begins concAl(1)=0. concAlp(1)=0. concAlpp(1)=0. concAl3p(1)=0. concC(1)=0. concCa(1)=0. concCap(1)=0. concC2(1)=0. concCl(1)=0. concC2H(1)=0. concC3(1)=0. concCH(1)=0. concCN(1)=0. concCO(1)=0. concCO2(1)=0. concCp(1)=0. concCpp(1)=0. concC3p(1)=0. concC4p(1)=0. concCr(1)=0. concCrp(1)=0. concCrpp(1)=0. concFe(1)=0. concFeO(1)=0. concFep(1)=0. concFepp(1)=0. concFe3p(1)=0. concFe4p(1)=0. concFe5p(1)=0. concH(1)=0. concH2(1)=0. concHp(1)=0. concH2O(1)=0. concK(1)=0. concMg(1)=0. concMgO(1)=0. concMgp(1)=0. concMgpp(1)=0. concMg3p(1)=0. concMg4p(1)=0 concNa(1)=0. concNap(1)=0. concNi(1)=0. concNip(1)=0. concNipp(1)=0. concNi3p(1)=0. concOH(1)=0. concS(1)=0. concSi(1)=0. concSO(1)=0. concSiO(1)=0. concSip(1)=0. concSipp(1)=0. concSi3p(1)=0. concSi4p(1)=0. concSp(1)=0. concSpp(1)=0. concS3p(1)=0. concS4p(1)=0. concSiH(1)=0. concTi(1)=0. concTip(1)=0. concTipp(1)=0. concTi3p(1)=0. concTiO(1)=0. ! ! read in air chemistry data call thrinp(1,5,nprt, nsp,spnm,pres,spallf, tw,delH1) if(spallf.gt.1.0e-6) delH=delH1/spallf if(spallf.le.1.0e-6) delH=delH1 nprint=1000 pkwav=(6000./temps)*6000. ! Planck function peak if((wavmin.lt.1.0).and.(wavmax.lt.1.0)) then wavmin=pkwav/2.5 wavmax=25000. end if write(6,80) wavmin,pkwav,wavmax 80 format(/' wavmin=',f10.2,' pkwav=',f10.2,' wavmax=',f10.2) rangex=100. ! ! make interpolating temperatures t1max=10000./temps t1min=10000./(temps/1.6) ntemp=11 do itemp=1,5 tair(itemp)=t1min+(t1max-t1min)*0.25*(itemp-1) tempx(itemp)=10000./tair(itemp) end do ! ! cycle over temperature do itemp=1,5 tran(1)=tempx(itemp) trot(1)=tran(1) tvib(1)=tran(1) tele(1)=tran(1) call pT_air(1,pres,tempx(itemp), rho,enthj,cp) write(6,20) itemp,pres,tempx(itemp),rho,enthj,cp 20 format(/ & & ' itemp =',i2/ & & ' pres =',1pe12.5,' Pascal'/ & & ' tempx(iemp)=',0pf10.1,' K'/ & & ' rho =',1pe12.5,' kg/m3'/ & & ' enthj =',e12.5,' J/kg'/ & & ' Cp =',e12.5) do i=1,nsp spgam(i)=0.1 end do tmax=1.25d0*tran(1) tmin=0.8d0*tran(1) call thrcal(tmax,tmin,itemp) ! ! calculate absb array if(nair.eq.0) then write(*,*) ' calling eqcal2 for air' write(6,*) ' calling eqcal2 for air' call eqcal2(rho,tran(1),spnm,spgam,nstep,nprt,nprint, eint, & & pres,enthj,zz,avmw,ansp) write(*,*) ' out of eqcal2 for air' write(6,*) ' out of eqcal2 for air' write(6,180) rho,tran(1),pres,enthj,avmw 180 format(' rho=',1pe10.3,' temp=',e10.3,' pres=',e10.3, & & ' enthj=',e10.3,' avmw=',1pe12.5) call interp(nsp,natoms,ndiatoms,ntriatoms,rho, & & tran(1),spnm,spgam,pres,enthj,avmw,ansp, & & concAl(1),concAlp(1),concAlpp(1),concAl3p(1), & & concC(1), concC2(1), & & concCa(1),concCap(1),concCl(1),concC2H(1), & & concC3(1),concCH(1), concCN(1),concCO(1), & & concCO2(1),concCp(1), concCpp(1),concC3p(1), & & concC4p(1),concCr(1),concCrp(1),concCrpp(1), & & concFe(1),concFeO(1),concFep(1),concFepp(1), & & concFe3p(1),concFe4p(1),concFe5p(1),concH(1), & & concH2(1), concHp(1),concH2O(1),concK(1), & & concMg(1), concMgO(1),concMgp(1),concMgpp(1), & & concMg3p(1),concMg4p(1),concN(1),concNE(1), & & concN2(1),concN2p(1),concNp(1),concNpp(1), & & concN3p(1),concN4p(1),concNa(1),concNap(1), & & concNO(1),concNi(1),concNip(1),concNipp(1), & & concNi3p(1),concO(1),concO2(1),concOH(1), & & concOp(1),concOpp(1),concO3p(1),concO4p(1), & & concS(1),concSi(1),concSO(1),concSiO(1), & & concSip(1),concSipp(1),concSi3p(1),concSi4p(1), & & concSp(1),concSpp(1),concS3p(1),concS4p(1), & & concSiH(1),concTi(1),concTip(1),concTipp(1), & & concTi3p(1),concTiO(1)) ! method=1 ! write(*,*) ' calling radipac for air' write(6,*) ' calling radipac for air' call radipac(nprt,natoms,ndiatoms,method,tblack, & & rnose,rangex,nwave,tran,trot,tvib,tele, & & concAl,concAlp,concAlpp,concAl3p, & & concC, concC2, & & concCa,concCap,concCl,concC2H, & & concC3,concCH, concCN,concCO, & & concCO2,concCp, concCpp,concC3p, & & concC4p,concCr,concCrp,concCrpp, & & concFe,concFeO,concFep,concFepp, & & concFe3p,concFe4p,concFe5p,concH, & & concH2, concHp,concH2O,concK, & & concMg, concMgO,concMgp,concMgpp, & & concMg3p,concMg4p,concN,concNE, & & concN2,concN2p,concNp,concNpp, & & concN3p,concN4p,concNa,concNap, & & concNO,concNi,concNip,concNipp, & & concNi3p,concO,concO2,concOH, & & concOp,concOpp,concO3p,concO4p, & & concS,concSi,concSO,concSiO, & & concSip,concSipp,concSi3p,concSi4p, & & concSp,concSpp,concS3p,concS4p, & & concSiH,concTi,concTip,concTipp, & & concTi3p,concTiO, & & avg_molwt) ! ! copy absb into a big array do m=1,nwave absb_air(itemp,m)=absb(m) end do end if end do ! ! write out absorption coefficients if(nair.eq.0) then write(16,*) ' air absorption coefficients' write(16,90) (tair(itemp),itemp=1,5) 90 format(' wavel ',11f10.6) do m=1,nwave write(16,60) wavel(m),(absb_air(itemp,m),itemp=1,5) 60 format(f10.4,1p5e10.3) end do close(16) end if ! ! read absb data from absb_air.out if(nair.eq.1) then read(16,210) (dum(i),i=1,100) read(16,211) (tair(itemp),itemp=1,5) 211 format(10x,5f10.6) do iw=1,nwave read(16,61) wavel(iw),(absb_air(itemp,iw),itemp=1,5) 61 format(f10.3,5e10.3) end do end if ! !--------------------------------------------air ended, freestream begins ! low T, hi_T limits ! inode=1; nprt=0 tlow=1500.; thigh=0.5*temps; nintvl=10; ntlow=11 t1=10000./thigh; t2=10000./tlow tintvl=(t2-t1)/nintvl ! read JANAF coefficients data spnma/'O ','N ','O2 ','N2 ','NO ','O+ ','N+ ','NO+ ','E- '/ call spdinp iprb=1 enth=5.0e8 rho=rhoinf pinf=8.3144*rhoinf*298./0.028854 patm=pinf/1.0133e5 elmsf(1)=0.233; elmsf(2)=0.767 write(6,*) ' ' write(6,*) ' freestream precursor region' ! vary temperature do itemp=1,ntlow txlow(itemp)=t1+tintvl*(itemp-1) tran(1)=10000./txlow(itemp) trot(1)=tran(1) tvib(1)=tran(1) trot(1)=tran(1) call kmeqm(patm,tran(1),enth,iprb,elmsf,spmlf,avmw,rho) patm=patm*(rhoinf/rho) call kmeqm(patm,tran(1),enth,iprb,elmsf,spmlf,avmw,rho) patm=patm*(rhoinf/rho) call kmeqm(patm,trot(1),enthl(itemp),iprb,elmsf,spmlf,avmw,rho) templ(itemp)=trot(1) pr=patm*1.0133e5 antot=pr/(1.3806e-23*tran(1)) write(6,*) ' ' write(6,221) trot(1),pr,enth 221 format(' temperature =',f10.1,' K. pressure=',1pe10.3,' Pa. enthalpy=', & & e10.3,' J/kg') write(6,*) ' isp spnm spmlf sum n(cm-3)' sum=0. do isp=1,9 sum=sum+spmlf(isp) an(isp)=antot*spmlf(isp)/1.0e6 write(6,220) isp,spnma(isp),spmlf(isp),sum,an(isp) 220 format(i5,2x,a4,1p4e12.5) end do ! if(nair.eq.0) then call emis_absb1(itemp,natoms,ndiatoms,ntriatoms, & & nprt,inode,trot(1),rho,an,avg_molwt) do iw=1,nwave absb_low(itemp,iw)=absb(iw) end do end if end do if(nair.eq.0) then write(18,17) 17 format(' freestream air absorption coefficients') write(18,15) (txlow(it),it=1,ntlow) 15 format(' wavel ',11f10.6) do iw=1,nwave write(18,16) wavel(iw),(absb_low(it,iw),it=1,ntlow) 16 format(f10.3,1p11e10.3) end do write(18,62) (dum1(i),i=1,21) do it=1,ntlow write(18,203) it,templ(it),enthl(it) 204 format(i10,1p4e10.3) end do close(18) end if ! ! read absb data from absb_low.out if(nair.eq.1) then read(18,210) (dum(i),i=1,100) read(18,18) (txlow(it),it=1,ntlow) 18 format(10x,11f10.6) do m=1,nwave read(18,19) wavel(m),(absb_low(itemp,m),itemp=1,ntlow) 19 format(f10.3,11e10.3) end do read(18,62) (dum1(i),i=1,21) do it=1,ntlow read(18,203) i,templ(it),enthl(it) end do end if !--------------------------------------------freestream ended, ablation product begins concN(1)=0. concN2(1)=0. concNp(1)=0. concNpp(1)=0. concN3p(1)=0. concN4p(1)=0. concO(1)=0. concO2(1)=0. concOp(1)=0. concOpp(1)=0. concO3p(1)=0. concO4p(1)=0. concNO(1)=0. concN2p(1)=0. concNe(1)=0. ! ! read in ablation product chemical data call thrinp(2,5,nprt, nsp,spnm,pres,spallf, tw,delH) nprint=1000 ! t1max=10000./(temps/2.0) t1min=10000./1500.d0 do itemp=1,11 tcho(itemp)=t1min+(t1max-t1min)*0.1*(itemp-1) tempx(itemp)=10000./tcho(itemp) end do ! ! cycle over temperature zero=0. do itemp=1,11 tran(1)=tempx(itemp) trot(1)=tran(1) tvib(1)=tran(1) tele(1)=tran(1) write(6,20) itemp,pres,tempx(itemp),zero,zero,zero tmax=1.25d0*tran(1) tmin=0.8d0*tran(1) call thrcal(tmax,tmin,itemp) ! ! calculate absb array if(nabl.eq.0) then write(*,*) ' calling eqcal2 for ablation product' write(6,*) ' calling eqcal2 for ablation product' call eqcal2(rho,tran(1),spnm,spgam,nstep,nprt,nprint, eint, & & pres,enthj,zz,avmw,ansp) ! call eqcal3(pres,tran(1),spnm,spgam,nstep,nprt,nprint, eint, & ! & rho,enthj,zz,avmw,ansp) write(*,*) ' out of eqcal2 for ablation product' write(6,*) ' out of eqcal2 for ablation product' write(6,180) rho,tran(1),pres,enthj,avmw write(6,180) rho,tran(1),pres,enthj,avmw ! 180 format(' rho=',1pe10.3,' temp=',e10.3,' pres=',e10.3, & ! & ' enthj=',e10.3,' avmw=',1pe12.5) rho_ivu(itemp)=rho; t_ivu(itemp)=tran(1); h_ivu(itemp)=enthj call interp(nsp,natoms,ndiatoms,ntriatoms,rho, & & tran(1),spnm,spgam,pres,enthj,avmw,ansp, & & concAl(1),concAlp(1),concAlpp(1),concAl3p(1), & & concC(1), concC2(1), & & concCa(1),concCap(1),concCl(1),concC2H(1), & & concC3(1),concCH(1), concCN(1),concCO(1), & & concCO2(1),concCp(1), concCpp(1),concC3p(1), & & concC4p(1),concCr(1),concCrp(1),concCrpp(1), & & concFe(1),concFeO(1),concFep(1),concFepp(1), & & concFe3p(1),concFe4p(1),concFe5p(1),concH(1), & & concH2(1), concHp(1),concH2O(1),concK(1), & & concMg(1), concMgO(1),concMgp(1),concMgpp(1), & & concMg3p(1),concMg4p(1),concN(1),concNE(1), & & concN2(1),concN2p(1),concNp(1),concNpp(1), & & concN3p(1),concN4p(1),concNa(1),concNap(1), & & concNO(1),concNi(1),concNip(1),concNipp(1), & & concNi3p(1),concO(1),concO2(1),concOH(1), & & concOp(1),concOpp(1),concO3p(1),concO4p(1), & & concS(1),concSi(1),concSO(1),concSiO(1), & & concSip(1),concSipp(1),concSi3p(1),concSi4p(1), & & concSp(1),concSpp(1),concS3p(1),concS4p(1), & & concSiH(1),concTi(1),concTip(1),concTipp(1), & & concTi3p(1),concTiO(1)) call radipac(nprt,natoms,ndiatoms,method,tblack, & & rnose,rangex,nwave,tran,trot,tvib,tele, & & concAl,concAlp,concAlpp,concAl3p, & & concC, concC2, & & concCa,concCap,concCl,concC2H, & & concC3,concCH, concCN,concCO, & & concCO2,concCp, concCpp,concC3p, & & concC4p,concCr,concCrp,concCrpp, & & concFe,concFeO,concFep,concFepp, & & concFe3p,concFe4p,concFe5p,concH, & & concH2, concHp,concH2O,concK, & & concMg, concMgO,concMgp,concMgpp, & & concMg3p,concMg4p,concN,concNE, & & concN2,concN2p,concNp,concNpp, & & concN3p,concN4p,concNa,concNap, & & concNO,concNi,concNip,concNipp, & & concNi3p,concO,concO2,concOH, & & concOp,concOpp,concO3p,concO4p, & & concS,concSi,concSO,concSiO, & & concSip,concSipp,concSi3p,concSi4p, & & concSp,concSpp,concS3p,concS4p, & & concSiH,concTi,concTip,concTipp, & & concTi3p,concTiO, & & avg_molwt) ! ! copy absb into a big array do m=1,nwave absb_cho(itemp,m)=absb(m) end do ! reset the last line absb_cho(itemp,nwave)=absb_cho(itemp,nwave-1) end if end do ! ! write out absorption coefficients if(nabl.eq.0) then write(17,*) ' ablation product absorption coefficients' write(17,196) (tcho(itemp),itemp=1,11) 196 format(' tcho ',11f10.6) do m=1,nwave write(17,69) wavel(m),(absb_cho(itemp,m),itemp=1,11) 69 format(f10.3,1p11e10.3) end do write(17,62) (dum1(i),i=1,20) 62 format(40a4) do itemp=1,11 write(17,206) itemp,t_ivu(itemp),h_ivu(itemp),rho_ivu(itemp) 206 format(i10,1p6e10.3) end do close(17) end if ! ! read absb data from absb_vap.out if(nabl.eq.1) then read(17,210) (dum(i),i=1,100) read(17,215) (tcho(itemp),itemp=1,11) 215 format(10x,11f10.6) do m=1,nwave read(17,63) wavel(m),(absb_cho(itemp,m),itemp=1,11) 63 format(f10.3,11e10.3) end do read(17,218) (dum(i),i=1,40) 218 format(100a1) do itemp=1,11 read(17,203) item,t_ivu(itemp),h_ivu(itemp),rho_ivu(itemp) 203 format(i10,5e10.3) end do end if ! ! initialize equilibrium tables call pH_ivu(0,0.d0,0.d0, rhos,temps) ! call pT_ivu(0,0.d0,0.d0, rhos,enths,cpivu) ! ! write(6,190) 190 format(/' it temp enth rho') do itemp=1,11 write(6,200) itemp,t_ivu(itemp),h_ivu(itemp),rho_ivu(itemp) 200 format(i5,1p5e12.5) end do 130 format(30a4) 150 format(10a1,10e10.3) 160 format(10a1,1p10e10.3) 170 continue ! ! flow calc call comet_lbl(nwave,rhoinf,vinf,pres,enths,tw,delH,rnose,spallf, & & ndm,nout,nim,facout1,facin1,facout2,facin2,famdot,elev_ang,hwhh, & & enfac,sigma) close(1); close(2); close(3); close(4); close(5); close(6); close(7) close(8); close(9); close(10); close(11); close(12); close(13) close(14); close(21); close(22) stop end !*********************************************************************** subroutine altrho(iuse,altit,rhoinf) ! converts altitude into density or density into altitude ! input parameters: ! iuse=1: altitude into density, =2: density into altitude ! output parameters: ! altit=altitude, m ! rhoinf=density, kg/m3 implicit real*8(a-h,o-z) dimension hx(25),rhox(25),rhoy(26) save data hx/ & & 0.0000, 10000., 20000., 30000., 40000., 50000., & & 60000., 70000., 80000., 90000., 100000., 110000., & & 120000., 130000., 140000., 150000., 160000., 170000., & & 180000., 190000., 200000., 210000., 220000., 230000., & & 240000./ data rhox/ & & 1.225, 4.135e-1, 8.891e-2, 1.841e-2, 3.996e-3, 1.027e-3, & & 3.097e-4, 8.283e-5, 1.846e-5, 4.114e-6, 9.169e-7, 2.043e-7, & & 5.000e-8, 1.224e-8, 2.995e-9, 7.329e-10,1.793e-10,4.389e-11, & & 1.074e-11,2.628e-12,6.430e-13,1.157e-13,3.850e-14,9.422e-15, & & 2.305e-15/ data itime/0/ ! ! take log of density if(itime.eq.0) then do i=1,25 rhoy(i)=dlog(rhox(i)) end do itime=1 end if ! ! from altitude get density if(iuse.eq.1) then mon=0 call taint(hx,rhox,rhoinf,rhoinf,25,2,ier,mon) rhoinf=dexp(rhoinf) return end if ! ! from density get altitude if(iuse.eq.2) then rholog=dlog(rhoinf) mon=0 call taint(rhoy,hx,rholog,altit,25,2,ier,mon) return end if return end !*********************************************************************** subroutine assign(gamsp,nprt) ! this subroutine and accompanying subroutine conv1 shrink and restore ! species list by ivoking elemental conservation ! assumes the first nelem species are to be removed and put back in ! input: gamsp(i),i=1,nsp: original species list ! nprt=print index ! output: gamsp1(i),i=1,nsp-nelem; shrunken species list parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) dimension gamsp(msp),fac(15),gam_a(15) character*4 elemnm,spnm save ! do isp=nelem+1,nsp gamsp(isp)=1.0e-4 ! 1.0e-4 end do sum=0. do j=1,nelem gamsp(j)=felem(j)/elemwt(j) sum=sum+gamsp(j) end do ! write write(6,*) ' isp spnm im gamsp' do isp=1,nsp write(6,20) isp,spnm(isp),im(isp),gamsp(isp) 20 format(i5,2x,a4,2x,i4,1pe11.4) end do ! ! audit do j=1,nelem gam_a(j)=0. do i=1,nsp gam_a(j)=gam_a(j)+ielem(i,j)*gamsp(i)*spwt(j) end do end do write(6,40) 40 format(' isp elemnm frac') do j=1,nelem write(6,30) j,elemnm(j),gam_a(j) 30 format(i5,2x,a4,1pe11.4) end do return end !********************************************************************************* subroutine atm_absb(mwave,nwave,flux_prec,int_prec,altit,elev_ang,rhoinf, & & flux_grd,int_grd) ! accounts for atmospheric absorption ! input parameters: ! mwave=wavelength index for 1750 A ! nwave=index for max wavelength ! flux_prec=spectral flux at end of precursor region, W/m2 ! int_prec(nw)=normal intensity at end of precursor region, W/(cm2-mic-sr) ! altit=altitude, m ! elev_ang=elevation angle, degrees ! rhoinf=freestream density, kg/m3 ! output parameters: ! int_grd(nw)=normal intensity at ground, W/(cm2-mic-sr) ! flux_grd=radiative flux at ground, W/m2 parameter(nw=400000) implicit real*8(a-h,o-z) real*8 int_prec,int_grd,intw,int_e common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) ! flux_prec(nw)=radiative flux at end of precursor; flux_grd(nw)=radiative flux at ground dimension int_prec(nw),int_grd(nw) dimension wav_tran(155),air_tran(155),altabs(22),absfr(22) data pi/3.14159265/ ! ! wavelengths specifying atmospheric transmission, A data wav_tran/ 100., & & 2994.9, 3020.2, 3045.7, 3071.4, 3097.3, 3123.5, 3149.9, 3176.5, & & 3203.3, 3230.3, 3257.6, 3285.1, 3312.8, 3340.8, 3369.0, 3397.4, & & 3426.1, 3455.1, 3484.2, 3513.6, 3543.3, 3573.2, 3603.4, 3633.8, & & 3664.5, 3695.4, 3726.6, 3758.1, 3789.8, 3821.8, 3854.1, 3886.6, & & 3919.5, 3952.5, 3985.9, 4019.6, 4053.5, 4087.7, 4122.2, 4157.0, & & 4192.1, 4227.5, 4263.2, 4299.2, 4335.5, 4372.1, 4409.0, 4446.3, & & 4483.8, 4521.7, 4559.8, 4598.3, 4637.2, 4676.3, 4715.8, 4755.6, & & 4795.8, 4836.3, 4877.1, 4918.3, 4959.8, 5001.7, 5043.9, 5086.5, & & 5129.4, 5172.7, 5216.4, 5260.4, 5304.9, 5349.6, 5394.8, 5440.4, & & 5486.3, 5532.6, 5579.3, 5626.4, 5673.9, 5721.8, 5770.1, 5818.9, & & 5868.0, 5917.5, 5967.5, 6017.9, 6068.7, 6119.9, 6171.6, 6223.7, & & 6276.3, 6329.2, 6382.7, 6436.6, 6490.9, 6545.7, 6601.0, 6656.7, & & 6712.9, 6769.6, & & 6785., 6927., 7110., 7185., 7298., 7452., 7530., 7648., & & 7687., 7688., 7769., 7875., 7891., 8099., 8125., 8159., & & 8444., 8622., 8989., 9083., 9274., 9371., 9469., 9976., & & 10842., 10843., 10956., 11187., 11304., 11423., 11663., 11724., & & 12096., 12480., 12743., 12810., 13107., 13565., 14143., 14440., & & 14516., 14744., 15292., 15452., 17060., 17602., 18066., 19433., & & 19636., 20686., 21343., 22485., 23199., 25347., 28573., 30101./ ! ! atmospheric transmission, vertical, from infinite height to ground data air_tran/ 0.0000, & & 0.0000, 0.0302, 0.0665, 0.1088, 0.1641, 0.2177, 0.2684, 0.3159, & & 0.3584, 0.3932, 0.4198, 0.4448, 0.4684, 0.4904, 0.5091, 0.5241, & & 0.5387, 0.5530, 0.5668, 0.5802, 0.5932, 0.6059, 0.6181, 0.6294, & & 0.6399, 0.6502, 0.6602, 0.6701, 0.6797, 0.6891, 0.6983, 0.7074, & & 0.7162, 0.7248, 0.7332, 0.7413, 0.7492, 0.7569, 0.7644, 0.7717, & & 0.7788, 0.7857, 0.7924, 0.7990, 0.8053, 0.8115, 0.8174, 0.8232, & & 0.8288, 0.8336, 0.8383, 0.8429, 0.8474, 0.8518, 0.8561, 0.8603, & & 0.8644, 0.8685, 0.8724, 0.8762, 0.8800, 0.8836, 0.8868, 0.8899, & & 0.8930, 0.8961, 0.8990, 0.9019, 0.9048, 0.9076, 0.9103, 0.9130, & & 0.9157, 0.9182, 0.9207, 0.9232, 0.9256, 0.9280, 0.9302, 0.9325, & & 0.9347, 0.9368, 0.9388, 0.9408, 0.9428, 0.9447, 0.9465, 0.9483, & & 0.9500, 0.9517, 0.9533, 0.9548, 0.9563, 0.9578, 0.9591, 0.9605, & & 0.9617, 0.9629, & & 0.9811, 0.9868, 0.9434, 0.7453, 0.8066, 0.9717, 0.9717, 0.6132, & & 0.6132, 0.9717, 0.9764, 0.9764, 0.9575, 0.9528, 0.9764, 0.9802, & & 0.9764, 0.8585, 0.9811, 0.7453, 0.7453, 0.3208, 0.3208, 0.9764, & & 1.0000, 0.9292, 0.9292, 0.2264, 0.9349, 0.3491, 0.3491, 0.7925, & & 0.8585, 0.9811, 0.9811, 0.9623, 0.9198, 0.0000, 0.0000, 0.0991, & & 0.2264, 0.2264, 0.9292, 0.9764, 0.9764, 0.7925, 0.0000, 0.0000, & & 0.1887, 0.9877, 0.9528, 0.9434, 0.8774, 0.0000, 0.0000, 0.1509/ ! ! altitudes specifying density height data altabs/ & & 0., 5000., 10000., 15000., 20000., 25000., & & 30000., 35000., 40000., 45000., 50000., 55000., & & 60000., 65000., 70000., 75000., 80000., 85000., & & 90000., 95000., 100000., 105000./ ! ! fraction of density height data absfr/ & & 0.0000000, 0.4739088, 0.7374038, 0.8790913, 0.9441218, 0.9743732, & & 0.9879313, 0.9941887, 0.9971017, 0.9984768, 0.9991990, 0.9995715, & & 0.9997782, 0.9998896, 0.9999462, 0.9999746, 0.9999880, 0.9999943, & & 0.9999973, 0.9999987, 0.9999994, 0.9999997/ elev_ang1=elev_ang/57.296 ! elevation angle in radian mon1=0; mon2=0 flux_grd=0. do iw=1,nwave if(iw.lt.mwave) int_grd(iw)=0. if(iw.ge.mwave) then int_grd(iw)=int_prec(iw) call taint(wav_tran(1),air_tran(1),wavel(iw),fmult,155,1,ier1,mon1) fmult=dmax1(fmult,1.0d-4) call altrho(2,altit,rhoinf) call taint(altabs,absfr,altit,extinc,22,2,ier2,mon2) fac_angl=1./dsin(elev_ang1) fmul1=(fmult*extinc)**fac_angl int_grd(iw)=int_prec(iw)*fmul1 delw=wavel(iw)-wavel(iw-1) flux_grd=flux_grd+2.0*pi*int_grd(iw)*delw ! rad flux at ground in quasi 1-D end if end do return end !************************************************************************************ subroutine atom_bb(isp,temp, power) ! calculates bound-bound radiation of an atom ! input parameters: ! isp=species number ! atomnm(isp)=species name, A4 ! temp=temperature, K ! output parameters: ! power=emission power, W parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e common/comi/nwave integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom common/coma1/atomwt(matoms),ion_pot(matoms), & & Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms), & & starkg(line_tot,matoms), & & starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms), & & ei_atom(line_tot,matoms),ek_atom(line_tot,matoms), & & wavel_atom(line_tot,matoms),aki_atom(line_tot, & & matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms), & & e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms) & & ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms), & & ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms), & & eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms) common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23, & & matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom, & & matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms), & & ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom, & & matoms),ind_line(line_tot,matoms),iz_atom(matoms), & & neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom, & & matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms), & & ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms), & & nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms), & & n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms), & & n_wavel_cross_atom(matoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,range1 common/scratch/emisr(nw) save data itime/0/ ! write(6,30) atomnm(isp),dens_atom(isp) 30 format(' in atom_bb. species = ', a4,1pe10.3,' cm-3') ! ! power emission power=0. ! neutral partition function partn=0. do i=1,nlev_atom(isp) partn=partn+g_atom(i,isp)*dexp(-1.43877d0*Ecm_atom(i,isp)/temp) end do ! ! ! cycle over lines power=0. do k = 1,nline(isp) ! check if this line is in the desired wavelength range if((wavel_atom(k,isp).lt.wavmin).or. & & (wavel_atom(k,isp).gt.wavmax)) go to 20 ! number density of upper state if(ngk_atom(k,isp).eq.0) neq_factor_k = 1.0 kk=ngk_atom(k,isp) if(ngk_atom(k,isp).ne.0) neq_factor_k=atom_rho(kk,isp)/ & & atom_chi(isp) if(ngi_atom(k,isp).eq.0) neq_factor_i=1.0 kk=ngi_atom(k,isp) if(ngi_atom(k,isp).ne.0) neq_factor_i=atom_rho(kk,isp)/ & & atom_chi(isp) nk=(dens_atom(isp)*gk_atom(k,isp) * dexp(-1.43877d0 & & *ek_atom(k,isp)/temp)/partn) * neq_factor_k ! ! number density of lower state ni=(dens_atom(isp)* gi_atom(k,isp)* dexp(-1.43877d0 & & *ei_atom(k,isp)/temp)/partn) * neq_factor_i ! ! Gaussian width, from richter, in plasma diagnostics, lochte-holtgreven, pp. 1-65. widthg=7.16d-7*wavel_atom(k,isp)*dsqrt(temp/atomwt(isp)) ! classical natural width, also from richter, ibid width1 = 1.18d-4 ! stark width, following griem, plasma spectroscopy gam=starkg(k,isp) expn=starkn(k,isp) ! default formula when gam is not given: from arnold et al, progress in astronautics ! and aeronautics, vol. 69, 1980, pp.52-82. ! if(starkn(k,isp).lt.1.0d-8) gam = & ! & 0.042d0*(wavel_atom(k,isp)**2)/(ion_pot(isp)-ek_atom(k,isp) & ! & )**2 if(starkn(k,isp).lt.1.0d-20) gam = & & 0.042d0*(wavel_atom(k,isp)**2)/(ion_pot(isp)-ek_atom(k,isp) & & )**2 if(starkg(k,isp).lt.1.0d-20) expn=0.33d0 width2=2.0d0*gam*((1.0d-4*temp)**expn)*dens_elec*1.0d-16 ! ! pressure broadening by non-resonant collisions, from traving, in plasma diagnostics, ! lochte-holtgreven, 1968, pp. 66-134. cw3=5.85d-30*dsqrt(2.0d0/atom_avg_molwt)*dens_atom_hvy & & *dsqrt(temp) width3=cw3*wavel_atom(k,isp)**2 ! ! resonance width also from traving, ibid width4=1.03d-25*(1.0d-20*wavel_atom(k,isp)**5) & & *sqrt(real(gk_atom(k,isp))/real(gi_atom(k,isp))) & & *aki_atom(k,isp)*ni ! sum up to get lorenz line width, in A widthl = width1 + width2 + width3 + width4 ! ! voigt line width at half-height, in A widthv=widthl/2.0d0 + dsqrt(widthl**2/4.0d0 +widthg**2) ! ! determine the range multiplication factor range from a semi-empirical formula range=20000.d0*dexp(-ei_atom(k,isp)/16000.d0) + 2000. ! verified ! ! determine the wavelength node m for line center ncentr=nwave*((wavel_atom(k,isp)-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr=(1.0d0/dsqrt(wavmin) - 1.0d0/dsqrt(wavel_atom(k,isp)))/estep + 1 ! determine wavelength interval at line center in angstrom witv=((wavmax-wavmin)/float(nwave)**calpha)*calpha*float(ncentr)**(calpha-1.) ! witv=wavmin**2*estep/((1.0d0-wavmin*estep*ncentr) & ! & *(1.0d0-wavmin*estep*(ncentr-1))) ! witv=1./(1./dsqrt(wavmin)-estep*(ncentr-1))**2 & ! & -1./(1./dsqrt(wavmin)-estep*ncentr)**2 witv=dabs(witv) wd1=1/widthv csprd2=widthl/widthv csprd3=(1.065+0.447*csprd2+0.058*csprd2**2)*widthv*1.0e-4 csprd1=(1.-csprd2)/csprd3 csprd2=csprd2/csprd3 ! ! determine line shape spreading index nspred nspred = 1 + range * widthv/witv nstart = ncentr - nspred if(nstart.lt.1) nstart = 1 nend = ncentr + nspred if(nend.gt.nwave) nend=nwave ! ! set line center wavelength to be a node point, in cm wavctr=wavel_atom(k,isp) ax=(real(gi_atom(k,isp))/real(gk_atom(k,isp)))*(nk/ni) blam=1.1904d-16*ax/((1.0d-8*wavctr)**5*(1.0d0-ax)) ! ! line emissiion power in w/(cm3-sr) e=1.580d-16*aki_atom(k,isp)*nk/wavctr power=power+e ! ! the line shape converts the emitted power e to spectral emission coef, emis, ! w/cm3-micron-sr. mtot=0 do m = nstart,nend csprd3=dabs((wavctr-wavel(m))*wd1) csp2=csprd3**2 csp3=csp2*dsqrt(dsqrt(csprd3)) emisr(m)=e*(csprd1*dexp(-2.772*csp2)+csprd2/(1.+4.*csp2)+0.016* & & csprd2*(1.0-widthl*wd1)*(dexp(-0.4*csp3)-10.0/(10.0+csp3))) if(emisr(m).lt.1.0e-20) then 50 format(a4,' m=',i6,' emisr=',1pe10.3) emisr(m)=1.0e-20 end if mtot=mtot+1 end do call trapez(ans,wavel(nstart),emisr(nstart),mtot,ier) ratio1=ans/10000. do m=nstart,nend emisr(m)=emisr(m)/ratio1 end do do m=nstart,nend emission=emisr(m)*e ratio=1.52*widthv/witv if((m.eq.ncentr).and.(ratio.lt.1.0)) emission=emission*ratio ax = dexp(-1.43877d0*1.0d8/(wavel_atom(k,isp)*temp)) blam=1.1904d-16*ax/((1.0d-8*wavel_atom(k,isp))**5*(1.0d0-ax)) absbx=emission/blam cross=absbx/dens_atom(isp) absby=cross*dens_atom(isp) absb(m)=absb(m)+absby if(absb(m).lt.0.) then write(*,40) atomnm(isp),dens_atom(isp),m,wavel(m), & & ei_atom(k,isp),ek_atom(k,isp),e,emisr(m),ratio,absbx, & & cross,absby,absb(m) 40 format(a4,' dens=',1pe10.3,' m=',i6,' wavel=',0pf10.2, & & ' ei=',f10.2/' ek=',f10.2,' e=',1pe10.3,' emisr=',e10.3, & & ' ratio=',e10.3/' absbx=',e10.3,' cross=',e10.3, & & ' absby=',e10.3,' absb=',e10.3) stop end if end do 20 continue end do itime=itime+1 write(6,66) atomnm(isp),dens_atom(isp),power 66 format(1x,a4,2x,' dens_atom=',1pe10.3,' power=',e10.3) return end !**************************************************************************** subroutine atom_bf_cr(isp,temp, power) ! calculates emission and absorption coefficients for bound-free transitions ! of atoms using cross sections. Peach, Mem. R. astr. Soc (1970) 1-123 ! input parameters: ! isp=species index ! atomnm(matoms)=name of atom ! temp=temperature ! output parameter: ! power=emission power, W/cm3 parameter(matoms=56,mdiatoms=12,mtriatoms=6,nlev_tot_atom=999, & & line_tot=2830,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e common/comi/nwave integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom common/coma1/atomwt(matoms),ion_pot(matoms), & & Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms), & & starkg(line_tot,matoms), & & starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms), & & ei_atom(line_tot,matoms),ek_atom(line_tot,matoms), & & wavel_atom(line_tot,matoms),aki_atom(line_tot, & & matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms), & & e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms) & & ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms), & & ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms), & & eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms) common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23, & & matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom, & & matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms), & & ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom, & & matoms),ind_line(line_tot,matoms),iz_atom(matoms), & & neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom, & & matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms), & & ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms), & & nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms), & & n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms), & & n_wavel_cross_atom(matoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,range1 common/scratch/yy(nw) dimension tlog(17),y(17),wavelx(501),cross(501) save data itime/0/ ! write(6,10) atomnm(isp),dens_atom(isp) 10 format(' In atom_bf_cr. species = ',a4,1pe10.3,' cm-3') ! ! cycle over transition ntemp=n_temp_cross_atom(isp) nwavel=n_wavel_cross_atom(isp) wavelmin = wavel_cross_atom(1,isp) nwavel_c=n_wavel_cross_atom(isp) wavelmax = wavel_cross_atom(nwavel_c,isp) ! ! determine the wavelength node m for line center nstart=nwave*((wavelmin-wavmin)/(wavmax-wavmin))**(1./calpha) ! nstart = (1./dsqrt(wavmin)-1./dsqrt(wavelmin))/estep + 1 nend=nwave*((wavelmax-wavmin)/(wavmax-wavmin))**(1./calpha) ! nend = (1./dsqrt(wavmin)-1./dsqrt(wavelmax))/estep + 1 if(nstart.lt.1) nstart=1 if(nend.gt.nwave) nend=nwave ! ! interpolate absorption cross sections for given electron temperature do it = 1,ntemp tlog(it) = dlog(temp_cross_atom(it,isp)) end do tlogx = dlog(temp) mon = 0 do iwavel = 1, nwavel_c wavelx(iwavel) = wavel_cross_atom(iwavel,isp) do it = 1, ntemp if(cross_atom(iwavel,it,isp).gt.0.) & & y(it) = dlog(cross_atom(iwavel,it,isp)) end do if(temp.lt.temp_cross_atom(ntemp,isp)) & & call taint(tlog,y,tlogx,crossx,ntemp,1,ner,mon) if(temp.ge.temp_cross_atom(ntemp,isp)) & & call taint(tlog,y,tlogx,crossx,ntemp,1,ner,mon) cross(iwavel) = crossx end do ! ! yy(m) is used as emission do m=1,nwave yy(m)=0.0d0 end do ! ! interpolate to find cross section crosx mon = 0 do m = nend,nstrt,-1 crosx=0.; absorption=0. if(wavel(m).gt.wavelmin) then call taint(wavelx,cross,wavel(m),crosx,nwavel_c,1,ner,mon) crosx=dexp(crosx) absorption = crosx * dens_atom(isp) end if ax = dexp(-1.43877d0*1.0d8/(wavel(m)*temp)) blam = 1.1904d-16 * ax/((1.0d-8*wavel(m))**5*(1.0d0 - ax)) emission = absorption * blam yy(m) = yy(m) + emission absb(m) = absb(m) + absorption enddo ! ! emission power call trapez(power,wavel,yy,nwave,ier) power=4.d0*3.1415926d0*1.d-4*power return end !**************************************************************************** subroutine atom_bf_Gaunt(isp,temp, power) ! calculates emission and absorption coefficients for bound-free transitions ! of atoms using Gaunt factors. Based on Griem, Plasma Spectroscopy and ! Peach, Mem. R. astr. Soc (1970) 1-123 ! input parameters: ! isp=species index ! atomnm(matoms)=name of atom ! temp=temperature ! output parameter: ! power=emission power parameter(matoms=56,nlev_tot_atom=999,line_tot=2830,mdiatoms=12, & & mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e common/comi/nwave integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom,sw_limit_m common/coma1/atomwt(matoms),ion_pot(matoms), & & Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms), & & starkg(line_tot,matoms), & & starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms), & & ei_atom(line_tot,matoms),ek_atom(line_tot,matoms), & & wavel_atom(line_tot,matoms),aki_atom(line_tot, & & matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms), & & e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms) & & ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms), & & ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms), & & eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms) common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23, & & matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom, & & matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms), & & ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom, & & matoms),ind_line(line_tot,matoms),iz_atom(matoms), & & neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom, & & matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms), & & ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms), & & nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms), & & n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms), & & n_wavel_cross_atom(matoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,range1 common/scratch/yy(nw) save ! write(6,10) atomnm(isp),dens_atom(isp) 10 format(' In atom_bf. species = ',a4,1pe10.3,' cm-3') ! ! neutral partition function partn=0. do i=1,ntot_gaunt(isp) partn=partn+ig_gaunt(i,isp)*dexp(-1.43877d0*e_gaunt(i,isp)/temp) end do ! ! yy(m) is used to calculated emission do m=1,nwave yy(m)=0.d0 end do ! ! cycle over transition do itran=1,ntot_gaunt(isp) ! ! number density of lower state ! if(ngi_atom(itran,isp).eq.0) neq_factor_i=1.0 neq_factor_i=1.0 ! if(atoms(isp)%line(k)%ngi.eq.0) neq_factor_i = 1.0 kk=ngi_atom(itran,isp) ! if(ngi_atom(itran,isp).ne.0) neq_factor_i=atom_rho(kk,isp)/ & ! & atom_chi(isp) neq_factor_i=1.0 ! ni=(dens_atom(isp)* gi_atom(itran,isp)* dexp(-1.43877d0 & ni=(dens_atom(isp)* IG_GAUNT(itran,isp)* dexp(-1.43877d0 & & *e_gaunt(itran,isp)/temp)/partn) ! > *ei_atom(itran,isp)/temp)/partn) * neq_factor_i ! ! threshold parameters threshold_e = ion_pot(isp) - e_gaunt(itran,isp) threshold_ryd = threshold_e/109679.d0 threshold_wavel = 1.0d8/threshold_e nstart=nwave*((threshold_wavel-wavmin)/(wavmax-wavmin))**(1./calpha) ! nstart=(1./dsqrt(wavmin) - 1./dsqrt(threshold_wavel))/estep + 1 if(nstart.gt.nwave) nstart = nwave ! if out of range, skip calculation if(nstart.lt.1) go to 20 ! ! short wavelength limit, taken to be 10 times the electron thermal energy kT photon_to_kt_ratio = 10. ! max photon energy/kT consider ekt = temp/1.43877d0 sw_limit_e = threshold_e + photon_to_kt_ratio * ekt ! short wavelength limit energy, cm-1 sw_limit_w = 1.0d8/sw_limit_e ! short wavelength limit in Angstrom sw_limit_m = nwave*((sw_limit_w-wavmin)/(wavmax-wavmin))**(1./calpha) ! sw_limit_m = (1./dsqrt(wavmin) - 1./dsqrt(sw_limit_w))/estep + 1 if(sw_limit_m.lt.1) sw_limit_m = 1 ! ! cycle over wavelength do k=nstart-1,1,-1 photon_e=(1.0d0/wavel(k))/109679.d0 - threshold_ryd if(wavel(k).gt.sw_limit_w) then call intpl1(ephot_gaunt(1,isp),gaunt(1,itran,isp), & & photon_e,gauntx,9) if(gauntx.lt.0.1) gauntx=0.1 end if cross_section = (7.908d-18 * (109679.d0*wavel(k)/1.0d8)**3/ & & n_gaunt(itran,isp)**5) * gauntx absorption = ni*cross_section absb(k) = absb(k) + absorption end do 20 continue enddo ! emission power call trapez(power,wavel,yy,nwave,ier) ! power in per st-radian power=4.d0*3.1415926d0*1.0d-4*power return end !*********************************************************************************** subroutine atom_ff(isp,temp, power) ! calculates emission and absorption coefficients for bound-free transitions of ! atoms based on griem, plasma spectroscopy and peach, mem. r. astr. soc(1970) ! 1-123 ! input parameters: ! isp=species index ! atomnm(matoms)=name of atom ! temp=temperature, K ! output parameter: ! power=emission power, W/cm3 ! parameter(matoms=56,nlev_tot_atom=999,line_tot=2830,mdiatoms=12, & & mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e common/comi/nwave integer e_photon,g_atom,gi_atom,gk_atom,g_neq_lev_atom,g_ion common/coma1/atomwt(matoms),ion_pot(matoms), & & Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms), & & starkg(line_tot,matoms), & & starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms), & & ei_atom(line_tot,matoms),ek_atom(line_tot,matoms), & & wavel_atom(line_tot,matoms),aki_atom(line_tot, & & matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms), & & e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms) & & ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms), & & ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms), & & eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms) common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23, & & matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom, & & matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms), & & ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom, & & matoms),ind_line(line_tot,matoms),iz_atom(matoms), & & neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom, & & matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms), & & ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms), & & nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms), & & n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms), & & n_wavel_cross_atom(matoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,range1 dimension x(30),y(30),d_peach(30) ! write(6,10) atomnm(isp),dens_atom(isp) 10 format(' in atom_ff. species = ',a4,1pe10.3,' cm-3') ! ! constant c1 = 1.368d-23 * dens_elec * dens_atom_ion /dsqrt(temp) ! ! generate the temperature variable do it=1,n_temp_ff_atom(isp) x(it)=temp_ff(it,isp) end do ! ! interpolate d of peach for given electron temperature mon = 0 do e_photon = 1,6 do it=1,n_temp_ff_atom(isp) y(it)=gaunt_ff(e_photon,it,isp) end do call taint(x, y, temp, d_peach(e_photon), & & n_temp_ff_atom(isp),2,ner,mon) enddo e_ph_max=ephot_ff(6,isp) ! ! cycle over wavelength mon = 0 do m = nwave,1,-1 photon_e = (1.0d8/wavel(m))/109679.d0 if(photon_e.le.e_ph_max) then call taint(ephot_ff(1,isp),d_peach(1),photon_e,d,6,2,ner,mon) gauntx = 1.0d0 + d end if absorption = c1 * gauntx * (1.0d-8 * wavel(m))**3 ax = dexp(-1.43877d0*1.0d8/(wavel(m)*temp)) blam = 1.1904d-16 * ax/((1.0d-8*wavel(m))**5*(1.0d0 - ax)) emission = blam * absorption emis = emis + emission absb(m) = absb(m) + absorption enddo ! return end !**************************************************************************************** subroutine atom_read(natoms) ! read in monatomic input data from atom.dat ! input parameters: ! natoms=number of atoms ! atomnm1(matoms)= name of atom ! atom_rads(3,168)=list of atomic radiation mechanisms to be calculated ! parameter(matoms=56,nlev_tot_atom=999,line_tot=2830,msp=60,mdiatoms=12, & & mtriatoms=6) implicit real*8(a-h,o-z) real*8 ion_pot character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 character*4 unknown,asterik,minus1 integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom,check common/coma1/atomwt(matoms),ion_pot(matoms), & & Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms), & & starkg(line_tot,matoms), & & starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms), & & ei_atom(line_tot,matoms),ek_atom(line_tot,matoms), & & wavel_atom(line_tot,matoms),aki_atom(line_tot, & & matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms), & & e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms) & & ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms), & & ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms), & & eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms) common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23, & & matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom, & & matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms), & & ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom, & & matoms),ind_line(line_tot,matoms),iz_atom(matoms), & & neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom, & & matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms), & & ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms), & & nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms), & & n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms), & & n_wavel_cross_atom(matoms) character*1 dum(90) data asterik/'****'/,minus1/'-1 '/ ! write(1,900) 900 format(' In atom_read') ! ! start counting chemical species number isp=0 ! read asterik line ! read(7,10) (dum(i),i=1,80) write(1,10) (dum(i),i=1,80) ! ! read chemical species as unknown 10000 continue read(7,20) unknown,(dum(i),i=1,75) 20 format(a4,90a1) write(1,20) unknown,(dum(i),i=1,75) if(unknown.eq.minus1) then write(1,*) ' Data reading finished' return endif ! ! check if this species is required check = 0 do i=1,matoms if(unknown.eq.atomnm1(i)) then do j = 1,167,3 if(unknown.eq.atom_rads(1,j)) then check=1 end if end do end if end do if(check.eq.1) then isp=isp+1 go to 130 endif ! ! This species is not needed and skipped write(1,140) 140 format(' This species is skipped'// & & '************************************************************') 150 read(7,160) unknown 160 format(a4) if(unknown.ne.asterik) go to 150 go to 10000 ! 130 continue ! ! set species name atomnm(isp)=unknown do j=1,5 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) 10 format(130a1) enddo ! ! prepare to read NIST energy levels of neutral species read(7,35) atomwt(isp),(dum(i),i=1,38), & & iz_atom(isp),(dum(i),i=39,75) 35 format(f12.2,38a1,i10,40a1) 30 format(f12.2,40a1) write(1,35) atomwt(isp),(dum(i),i=1,38), & & iz_atom(isp),(dum(i),i=39,75) read(7,30) ion_pot(isp),(dum(i),i=1,40) write(1,30) ion_pot(isp),(dum(i),i=1,40) read(7,40) nlev_atom(isp),(dum(i),i=1,40) 40 format(i10,40a1) write(1,40) nlev_atom(isp),(dum(i),i=1,40) ! do j=1,3 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) enddo ! ! read NIST energy levels of neutral species do ilev=1,nlev_atom(isp) ind_lev_atom(ilev,isp)=ilev ind_lev_atom(ilev,isp) = ilev read(7,50) (dum(i),i=1,30), & & g_atom(ilev,isp),Ecm_atom(ilev,isp),ng_atom(ilev,isp) write(1,50) (dum(i),i=1,30), & & g_atom(ilev,isp),Ecm_atom(ilev,isp),ng_atom(ilev,isp) 50 format(30a1,i3,f13.3,i3) enddo ! ! prepare to read NIST energy levels of ionized species do i1=1,2 read(7,10) (dum(i),i=1,72) write(1,10) (dum(i),i=1,72) enddo read(7,40) nlev_atomic_ion(isp), (dum(i),i=1,40) write(1,40) nlev_atomic_ion(isp), (dum(i),i=1,40) ! do i1=1,2 read(7,10) (dum(i),i=1,72) write(1,10) (dum(i),i=1,72) enddo ! ! read NIST energy levels of ionized species do ilev=1,nlev_atomic_ion(isp) ind_lev_ion(ilev,isp)=ilev ! read(7,50) (dum(i),i=1,30), & & g_ion(ilev,isp),Ecm_ion(ilev,isp) write(1,50) (dum(i),i=1,30), & & g_ion(ilev,isp),Ecm_ion(ilev,isp) enddo ! ! prepare to read nonequilibrium energy levels do i1=1,3 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) enddo read(7,40) neq_lev_atom(isp), (dum(i),i=1,40) write(1,40) neq_lev_atom(isp),(dum(i),i=1,40) do i1=1,3 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) enddo ! ! read nonequilibrium energy levels do ilev=1,neq_lev_atom(isp) read(7,60) (dum(i),i=1,10), & & Ecm_neq_lev_atom(ilev,isp),g_neq_lev_atom(ilev,isp), & & (dum(i),i=11,40) write(1,60) (dum(i),i=1,10), & & Ecm_neq_lev_atom(ilev,isp),g_neq_lev_atom(ilev,isp), & & (dum(i),i=11,40) 60 format(10a1,f12.2,i7,30a1) enddo ! ! prepare to read NIST line table do i1=1,4 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) enddo read(7,40) nline(isp),(dum(i),i=1,40) write(1,40) nline(isp),(dum(i),i=1,40) do i1=1,2 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) enddo ! ! read lines do iline=1,nline(isp) read(7,70) & & ind_line(iline,isp),wavel_atom(iline,isp),aki_atom(iline,isp), & & ei_atom(iline,isp),ek_atom(iline,isp),(dum(i),i=1,43), & & gi_atom(iline,isp),gk_atom(iline,isp) & & ,starkg(iline,isp),starkn(iline,isp),ngi_atom(iline,isp), & & ngk_atom(iline,isp) write(1,70) & & ind_line(iline,isp),wavel_atom(iline,isp),aki_atom(iline,isp), & & ei_atom(iline,isp),ek_atom(iline,isp),(dum(i),i=1,43), & & gi_atom(iline,isp),gk_atom(iline,isp) & & ,starkg(iline,isp),starkn(iline,isp),ngi_atom(iline,isp), & & ngk_atom(iline,isp) enddo 70 format(i4,f10.3,e9.2,2f11.3,43a1,2i4,e10.3,f6.3,2i4) ! ! bound-free continuum ! check whether the data are given in Gaunt factors or cross sections read(7,10) (dum(i),i=1,72) write(1,10) (dum(i),i=1,72) read(7,10) (dum(i),i=1,72) write(1,10) (dum(i),i=1,72) if(dum(27).eq.'G') go to 300 ! data given in Gaunt factors if(dum(27).eq.'c') go to 320 ! data given in cross sections ! ! data given in Gaunt factors 300 continue ! atom_rads(2,isp)='bG ' do i1=1,1 read(7,10) (dum(i),i=1,72) write(1,10) (dum(i),i=1,72) enddo read(7,40) ntot_gaunt(isp),(dum(i),i=1,40) write(1,40) ntot_gaunt(isp), (dum(i),i=1,40) read(7,30) z(isp),(dum(i),i=1,40) write(1,30) z(isp),(dum(i),i=1,40) read(7,30) e_inner(isp), (dum(i),i=1,40) write(1,30) e_inner(isp), (dum(i),i=1,40) read(7,80) (dum(i),i=1,32), (ephot_gaunt(i,isp),i=1,9) write(1,80) (dum(i),i=1,32), (ephot_gaunt(i,isp),i=1,9) 80 format(32a1,9f8.4) read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) ! do itran=1,ntot_gaunt(isp) read(7,90) (dum(i),i=1,12), & & ig_gaunt(itran,isp),e_gaunt(itran,isp),n_gaunt(itran,isp), & & ng_gaunt(itran,isp),(gaunt(i,itran,isp),i=1,9) write(1,90) (dum(i),i=1,12), & & ig_gaunt(itran,isp),e_gaunt(itran,isp),n_gaunt(itran,isp), & & ng_gaunt(itran,isp),(gaunt(i,itran,isp),i=1,9) enddo 90 format(12a1,i3,f10.2,2i3,9f8.4) go to 310 ! ! data given in cross sections 320 continue ! atom_rads(2,isp)='bc ' do i1=1,2 read(7,10) (dum(i),i=1,72) write(1,10) (dum(i),i=1,72) enddo read(7,330) n_temp_cross_atom(isp),(dum(i),i=1,60) 330 format(i10,90a1) write(1,330) n_temp_cross_atom(isp), (dum(i),i=1,60) read(7,330) n_wavel_cross_atom(isp), (dum(i),i=1,60) write(1,330) n_wavel_cross_atom(isp), (dum(i),i=1,60) read(7,10) (dum(i),i=1,79) write(1,10) (dum(i),i=1,79) read(7,340) (dum(i),i=1,11),(temp_cross_atom(it,isp), & & it=1,n_temp_cross_atom(isp)) write(1,340) (dum(i),i=1,11),(temp_cross_atom(it,isp), & & it=1,n_temp_cross_atom(isp)) 340 format(11a1,11f10.1) read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) do iwav=1,n_wavel_cross_atom(isp) read(7,350) wavel_cross_atom(iwav,isp), & & (cross_atom(iwav,it,isp),it=1,n_temp_cross_atom(isp)) 350 format(f10.2,11e10.3) write(1,350) wavel_cross_atom(iwav,isp), & & (cross_atom(iwav,it,isp),it=1,n_temp_cross_atom(isp)) end do 310 continue ! ! prepare to read free-free Gaunt factors do j=1,3 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) enddo read(7,40) n_temp_ff_atom(isp), (dum(i),i=1,30) write(1,40) n_temp_ff_atom(isp) read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) read(7,100) (dum(i),i=1,8),(ephot_ff(i,isp),i=1,6) write(1,100) (dum(i),i=1,8),(ephot_ff(i,isp),i=1,6) 100 format(8a1,6f10.4) read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) ! ! read free-free gaunt factors do it=1,n_temp_ff_atom(isp) read(7,110) temp_ff(it,isp),(gaunt_ff(i,it,isp),i=1,6) write(1,110) temp_ff(it,isp),(gaunt_ff(i,it,isp),i=1,6) enddo 110 format(f8.0,6f10.4) ! ! prepare to read electron-impact excitation rate data do i1=1,5 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) enddo read(7,40) num_exct(isp), (dum(i),i=1,40) write(1,40) num_exct(isp), (dum(i),i=1,40) do j=1,2 read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) enddo ! ! set r0 and rexp to default value of 0 do il=1,21 do iu=1,21 eimp_ro(il,iu,isp)=0. eimp_rexp(il,iu,isp)=0. enddo enddo ! ! read electron-impact excitation rate parameters do i1=1, num_exct(isp) read(7,120) il1,iu1,ro1,rexp1,il2,iu2,ro2,rexp2,il3,iu3,ro3, & & rexp3,il4,iu4,ro4,rexp4 write(1,121) il1,iu1,ro1,rexp1,il2,iu2,ro2,rexp2,il3,iu3,ro3, & & rexp3,il4,iu4,ro4,rexp4 120 format(4(2i3,e8.1,f5.2)) 121 format(4(2i3,es8.1,f5.2)) eimp_ro(il1,iu1,isp)=ro1 eimp_rexp(il1,iu1,isp)=rexp1 eimp_ro(il2,iu2,isp)=ro2 eimp_rexp(il2,iu2,isp)=rexp2 eimp_ro(il3,iu3,isp)=ro1 eimp_rexp(il1,iu1,isp)=rexp3 eimp_ro(il4,iu4,isp)=ro4 eimp_rexp(il4,iu4,isp)=rexp4 enddo read(7,10) (dum(i),i=1,90) write(1,10) (dum(i),i=1,90) ! go to 10000 ! end !************************************************************************************ subroutine audit(gamsp,nprt) ! enlarges species list by ivoking elemental conservation ! input: gamsp1(i),i=1,nsp-nelem, species concentration, mol/kg ! nprt=print index. 0=no print, 1=print ! output: gamsp(i),i=1,nsp parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) dimension gamsp(msp),gamsp1(msp),felx(15) character*4 elemnm,spnm ! do iel=1,nelem felx(iel)=0. do isp=1,nsp felx(iel)=felx(iel)+ielem(isp,iel)*gamsp(isp)*spwt(isp) end do end do ! write(6,10) 10 format(/' element (felx) conservation audit'/ & & ' iel name elemwt felx felem') do iel=1,nelem write(6,20) iel,elemnm(iel),elemwt(iel),felx(iel),felem(iel) 20 format(i5,2x,a4,1p4e11.4) end do write(6,*) ' ' return end !*********************************************************************** subroutine boltzf(wavel,camera) ! makes Boltzmann plot of Mg I lines in wavelengths 4000 to 6500 A ! input parameters: ! wavel(nw)=wavelength ! camera(nw)=intensity obtained in camera, W/(cm2-mic-sr) parameter(nw=400000) implicit real*8(a-h,o-z) real*8 mg2(5,3),mg9(5,1),mg11(5,1),mg14(5,1) dimension wavel(nw),camera(nw),x(4),y(4,1),z(4,1),x1(11),y0(11), & & w(4),resid(4,1),ax(2,2),bx(2,2),sum(1),wavx(4),z0(11), & & ca1(5,1),ca2(5,1),ca3(5,1),ca4(5,1),ca5(5,1) data w/1.,1.,1.,1./ ! ! Mg lines------------------------------------------------------------ ! multplet No. wavelength ek gk Aki data mg2/ & & 2.0, 5183.60, 41197.0, 3.0, 0.561e8, & & 2.0, 5172.68, 41197.0, 3.0, 0.346e8, & & 2.0, 5167.32, 41197.0, 3.0, 0.116e8/ data mg9/ & & 9.0, 5528.40, 53135.0, 5.0, 0.14e8/ data mg11/ & & 11.0, 4702.99, 56308.0, 5.0, 0.16e8/ data mg14/ & & 14.0, 4351.91, 58023.0, 5.0, 0.21e8/ data w/1., 1., 1., 1./ ! ! multiplet 2---------------------------------------------------------- ! find peak m=1 10 m=m+1 if(wavel(m).lt.5168.) go to 10 ! find peak 5183 ! 20 m=m+1 ! if(camera(m).gt.camera(m-1)) go to 20 mpk=m ! find backward valley point mvl1 m=1 11 m=m+1 if(wavel(m).lt.5161.) go to 11 mvl1=m ! find forward valley point mvl2 m=mpk 121 m=m+1 if(wavel(m).lt.5178) go to 121 mvl2=m ! integrate from mvl1 to mvl2 ! mint=mvl2-mvl1+1 ! call simp(area2,wavel(mvl1),camera(mvl1),mint,ier) ! area2=area2-0.5*(camera(mvl1)+camera(mvl2))*(wavel(mvl2-1)-wavel(mvl1+1)) ! background m=1 122 m=m+1 if(wavel(m).lt.5159.) go to 122 background=camera(m) ! area mint=mvl2-mvl1+1 call simp(area2,wavel(mvl1),camera(mvl1),mint,ier) area2=area2-0.5*(camera(mfl1)+camera(mvl2))*(wavel(mvl2)-wavel(mvl1)) ! area2=area2-background*(wavel(mvl2)-wavel(mvl1)) ! area2=(camera(mpk)-background)*(wavel(mvl2)-wavel(mvl1)) ! determine Boltzmann plot point x(1)=mg2(3,2) wavx(1)=mg2(2,2) gtot=mg2(4,2)+mg2(4,3) avaki=(mg2(5,2)*mg2(4,2)+mg2(5,3)*mg2(4,3))/gtot y(1,1)=area2/(gtot*avaki) z(1,1)=dlog(y(1,1)) ! ! multiplet 9------------------------------------------------------------ ! find peak m=1 30 m=m+1 if(wavel(m).lt.5528.) go to 30 mpk=m ! find backward valley point mvl1 m=1 31 m=m+1 if(wavel(m).lt.5523.) go to 31 mvl1=m ! find forward valley point mvl2 m=1 32 m=m+1 if(wavel(m).lt.5533.) go to 32 mvl2=m ! background m=1 33 m=m+1 if(wavel(m).lt.5518.) go to 33 background=camera(m) ! integrate from mvl1 to mvl2 mint=mvl2-mvl1+1 call simp(area9,wavel(mvl1),camera(mvl1),mint,ier) area9=area9-0.5*(camera(mvl1)+camera(mvl2))*(wavel(mvl2-1)-wavel(mvl1+1)) ! area9=(camera(mpk)-background)*(wavel(mvl2)-wavel(mvl1)) ! determine Boltzmann plot point x(2)=mg9(3,1) wavx(2)=mg9(2,1) y(2,1)=area9/(mg9(4,1)*mg9(5,1)) z(2,1)=dlog(y(2,1)) ! ! multiplet 11------------------------------------------------------------- ! find peak m=1 50 m=m+1 if(wavel(m).lt.4702.) go to 50 mpk=m ! find backward valley point mvl1 m=1 51 m=m+1 if(wavel(m).lt.4695.) go to 51 mvl1=m ! find forward valley point mvl2 m=mpk+3 52 m=m+1 ! if(camera(m).lt.camera(m-1)) go to 52 if(wavel(m).lt.4712.) go to 52 mvl2=m ! integrate from mvl1 to mvl2 mint=mvl2-mvl1+1 call simp(area11,wavel(mvl1),camera(mvl1),mint,ier) area11=area11-0.5*(camera(mvl1)+camera(mvl2))*(wavel(mvl2-1)-wavel(mvl1+1)) ! background=camera(mvl1) ! area11=(camera(mpk)-background)*(wavel(mvl2)-wavel(mvl1)) ! determine Boltzmann plot point x(3)=mg11(3,1) wavx(3)=mg11(2,1) y(3,1)=area11/(mg11(4,1)*mg11(5,1)) z(3,1)=dlog(y(3,1)) ! ! multiplet 14--------------------------------------------------------------- ! find peak m=1 70 m=m+1 if(wavel(m).lt.4351.9) go to 70 mpk=m ! find backward valley point mvl1 m=1 71 m=m+1 if(wavel(m).lt.4348.) go to 71 mvl1=m ! find forward valley point nvl2 m=mpk 72 m=m+1 if(wavel(m).lt.4357.) go to 72 ! if(camera(m).lt.camera(m-1)) go to 72 mvl2=m ! integrate from mvl1 to mvl2 mint=mvl2-mvl1+1 call simp(area14,wavel(mvl1),camera(mvl1),mint,ier) area14=area14-0.5*(camera(mvl1)+camera(mvl2))*(wavel(mvl2-1)-wavel(mvl1+1)) ! find background ! m=mpk ! 73 m=m+1 ! if(wavel(m).lt.4357.) go to 73 ! background=camera(m) ! area14=(camera(mpk)-background)*(wavel(mvl2)-wavel(mvl1)) ! determine Boltzmann plot point x(4)=mg14(3,1) wavx(4)=mg14(2,1) y(4,1)=area14/(mg14(4,1)*mg14(5,1)) z(4,1)=dlog(y(4,1)) ! ! plot the results write(6,110) 110 format(/' Boltzmann plot of Mg I lines'/ & & ' E wavel y log(y)') do i=1,4 write(6,100) x(i),wavx(i),y(i,1),z(i,1) end do ! ! least-square line fit n=4; l=1; mm=2 call lsqpol(x,z,w,resid,n,sum,l,ax,bx,mm) ! y = bx(1,1) + bx(2,1)*x write(6,90) bx(1,1),bx(2,1) xlow=40000.; xhigh=60000. 90 format(' bx(1,1)=',1pe10.3,' bx(2,1)=',e10.3/ & & ' best-fit line coordinates'/ & & ' E y log(y)') do i=1,11 x1(i)=xlow+(xhigh-xlow)*0.1*(i-1) y0(i)=bx(1,1)+bx(2,1)*x1(i) z0(i)=dexp(y0(i)) ! y1=dexp(y0(i)) write(6,101) x1(i),y0(i),z0(i) 100 format(f10.0,f10.1p2e11.3) 101 format(f10.0,1p2e11.3) end do ! ! Boltzmann temperature slope=(y0(11)-y0(1))/(x1(11)-x1(1)) temp=-1.43877/slope write(6,120) temp 120 format(' Boltzmann fit temperature =',f10.1) return end !*********************************************************************** subroutine boltzf1(wavel,int) ! makes Boltzmann plot of Fe I lines in wavelengths 4000 to 6500 A ! input parameters: ! wavel(nw)=wavelength ! int(nw)=intensity, any units parameter(nw=400000) implicit real*8(a-h,o-z) dimension wavel(nw),int(nw) dimension fedat(5,27),wavelc(27),ek(27),gk(27),aki(27),y(27), & & logy(27,1),area(27),w(27),x1(25),y0(25),teny0(25),ax(2,2),bx(2,1), & & resid(27,1),sum(1) real*8 int,logy data w/27*1.0/ ! ! Fe lines------------------------------------------------------------ ! No. wavel ek gk Aki data Fedat/ & ! Fedat(5,27) 1.0, 6136.62, 36079.4, 7.0, 1.01e6, & 2.0, 6230.72, 36686.2, 9.0, 9.99e5, & 3.0, 6065.48, 37521.2, 5.0, 1.07e6, & 4.0, 5049.82, 38175.4, 7.0, 1.65e6, & 5.0, 4352.73, 40895.0, 5.0, 3.63e6, & 6.0, 4957.60, 42815.9, 13.0, 4.22e7, & 7.0, 5139.25, 43633.5, 5.0, 8.86e6, & 8.0, 4918.99, 43434.6, 7.0, 1.79e7, & 9.0, 5192.34, 43434.6, 7.0, 1.34e7, & 10.0, 4903.31, 43633.5, 5.0, 6.58e6, & 11.0, 4871.32, 43633.5, 5.0, 2.44e7, & 12.0, 5339.93, 45061.3, 7.0, 6.36e6, & 13.0, 6246.32, 45061.3, 7.0, 3.24e6, & 14.0, 6301.50, 45333.9, 5.0, 6.43e6, & 15.0, 6301.50, 45333.9, 5.0, 6.43e6, & 16.0, 6336.82, 45509.2, 3.0, 7.71e6, & 17.0, 4351.54, 47092.7, 7.0, 9.39e5, & 18.0, 4667.45, 50475.3, 9.0, 6.03e6, & 19.0, 5476.56, 51350.5, 9.0, 8.70e6, & 20.0, 5731.76, 51770.6, 7.0, 1.60e6, & 21.0, 5543.94, 52049.8, 5.0, 3.40e6, & 22.0, 5383.37, 53353.0, 1.0, 7.81e7, & 23.0, 5816.37, 53874.3, 1.0, 4.49e6, & 24.0, 6079.01, 53966.7, 5.0, 2.90e6, & 25.0, 5806.73, 54379.4, 7.0, 2.70e6, & 26.0, 5927.79, 54386.2, 3.0, 5.40e6, & 27.0, 5905.67, 54449.3, 3.0, 1.10e7/ ! cycle over lines do il=1,27 wavelc(il)=fedat(2,il) ek(il)=fedat(3,il) gk(il)=fedat(4,il) aki(il)=fedat(5,il) ! find line center m=1 10 m=m+1 if(wavel(m).lt.wavelc(il)) go to 10 mpk=m ! peak point ! find backward valley point m=mpk-5 20 m=m-1 if(int(m).gt.int(m-2)) go to 20 mvl1=m ! backward valley point if(il.eq.5) then m=1 43 m=m+1 if(wavel(m).lt.4348.) go to 43 mvl1=m end if if(il.eq.6) then m=1 21 m=m+1 if(wavel(m).lt.4933.) go to 21 mvl1=m end if if(il.eq.23) then m=1 35 m=m+1 if(wavel(m).lt.5812.) go to 35 mvl1=m end if if(il.eq.25) then m=1 36 m=m+1 if(wavel(m).lt.5801.) go to 36 mvl1=m end if ! find forward valley point m=mpk+5 30 m=m+1 if(int(m).lt.int(m-2)) go to 30 mvl2=m ! forward valley point if(il.eq.1) then m=mpk+2 31 m=m+1 if(wavel(m).lt.6144.) go to 31 mvl2=m end if if(il.eq.6) then m=mpk 32 m=m+1 if(wavel(m).lt.4976.) go to 32 mvl2=m end if if(il.eq.17) then m=1 33 m=m+1 if(wavel(m).lt.4357.) go to 33 mvl2=m end if if(il.eq.18) then m=1 34 m=m+1 if(wavel(m).lt.4674.) go to 34 mvl2=m end if ! write out the information write(6,40) fedat(1,il),wavel(mvl1),int(mvl1),wavel(mpk),int(mpk), & & wavel(mvl2),int(mvl2) 40 format(/ & & ' line number =', f10.1/ & & ' backward valley point: wavel=', f10.2,' int=',1pe10.3/ & & ' peak point: wavel=',0pf10.2,' int=',1pe10.3/ & & ' forward valley point: wavel=',0pf10.2,' int=',1pe10.3) ! ! area under the curve intvl=mvl2-mvl1+1 call simp(area(il),wavel(mvl1),int(mvl1),intvl,ier) write(6,100) wavelc(il),ier 100 format(' wavelc=',f10.3,' ier=',i2) ! plotting parameter htsmall=int(mvl1) if(int(mvl2).lt.htsmall) htsmall=int(mvl2) defic=0.5*(int(mvl1)+int(mvl2))*(wavel(mvl2)-wavel(mvl1)) if(il.eq.12) defic=0. areax=area(il)-defic if((areax.lt.0.).or.(il.eq.1)) then defic=htsmall*(wavel(mvl2)-wavel(mvl1)) if(il.eq.12) defic=0. areax=area(il)-defic end if if(il.eq.6) then m=1 101 m=m+1 if(wavel(m).lt.4908.) go to 101 htsmall=int(m) defic=htsmall*(wavel(mvl2)-wavel(mvl1)) areax=area(il)-defic end if area(il)=areax y(il)=area(il)/(gk(il)*aki(il)) logy(il,1)=dlog(y(il)) end do ! ! plot the results write(6,50) 50 format(/' Boltzmann plot of Fe I lines'/ & & ' No. E wavel area y log(y)') do il=1,27 write(6,60) il,ek(il),wavelc(il),area(il),y(il),logy(il,1) 60 format(i5,f11.1,f11.2,1p4e11.3) end do ! ! least-square line fit n=27; l=1; mm=2 call lsqpol(ek,logy,w,resid,n,sum,l,ax,bx,mm) ! y = bx(1,1) + bx(2,1)*x write(6,70) bx(1,1),bx(2,1) xlow=30000.; xhigh=55000. 70 format(' bx(1,1)=',1pe10.3,' bx(2,1)=',e10.3/ & & ' best-fit line coordinates'/ & & ' E exp(y) y ') do i=1,21 x1(i)=xlow+(xhigh-xlow)*0.05*(i-1) y0(i)=bx(1,1)+bx(2,1)*x1(i) teny0(i)=dexp(y0(i)) ! y1=dexp(y0(i)) ! write(6,80) x1(i),y0(i),teny0(i) write(6,80) x1(i),teny0(i),y0(i) 80 format(f10.0,1pe11.3,0pf11.4) end do ! ! Boltzmann temperature slope=(y0(11)-y0(1))/(x1(11)-x1(1)) temp=-1.43877/slope write(6,90) temp 90 format(' Boltzmann fit temperature =',f10.1) return end !************************************************************************** subroutine calc(nwave,ndm,tx,rhoinf,vinf,pres,tw,rnose,temps,rhos, & & enths,delta,delH,spallf,nout,nim,facout1,facin1,facout2,facin2,famdot, & & enfac,sigma,iout1,im1) ! calculation of radiative transfer through shock layer and ablation-product layer ! input parameters ! nwave=number of wavelength points ! ndm=number of spatial node points, must be an even number ! tx(ndm)=temperature, K ! rhoinf=freestream density, kg/m3 ! vinf=flight speed-freestream velocity, m/s ! pres=stagnation point pressure, Pascal ! tw=wall temperature, K ! rnose=nose radius, m ! temps=stagnation point gas temperature, K ! rhos=stagnation point density, kg/m3 ! enths=stagnation point enthalpy, J/kg ! delta=shock stand-off distance, m ! delH=ablation energy, J/kg ! nout=allowed number of iteration for air shock layer in one sweep ! nim=allowed number of iteration for ablation-product vapor in one sweep ! facout1=fraction by which an old solution is modified by the new solution ! for air shock layer in the first two sweeps ! facin1=fraction by which an old solution is modified by the new solution ! for ablation product layer in the first two sweeps ! facout2=fraction by which an old solution is modified by the new solution ! for air shock layer in the late two sweeps ! facin2=fraction by which an old solution is modified by the new solution ! for ablation production layer in the later two sweeps ! famdot=fraction by which an old ablation rate is modified by the new ablation ! rate value ! enfac=enthalpy entering shock wave divided by 0.5*vinf*vinf ! sigma=wall emissivity ! output parameters ! iout1=beginning index for air outer layer calc in the 3rd sweep ! im1=beginning index for ablation-product layer calc in the 3rd sweep ! output parameters ! tx(idm) ! enth(idm) parameter (nw=400000) implicit real*8(a-h,o-z) character*4 dum(41) common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11), & & int_cam(nw) dimension tx(802),qpa(802),int_prec(nw),flx(nw),flx_prec(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e,int_old,int_prec,int_s,int_cam,int_abl common/comcalc/beta(802),rhoa(802),rhorat(802),rhovrat(802),y(802), & & enth(802),enth3(802),amdot(0:441) dimension dqdy(802),int_old(10,nw),f(802),fp(802),ax(4,4),rhs(4,2), & & sum(2),axy(3,3),rhsy(3,2),dtdy(802) save ! ndm1=ndm/2 ndm2=ndm1+1 ndm3=ndm1-1 dusdr=vinf/rnose rootpi=sqrt(3.141592) flow_in=rhoinf*vinf enflo_in=rhoinf*vinf*enths ! ! first approximation of beta and rhovrat in the outer layer beta(ndm2)=0. rhoa(ndm2)=rhos do inode=ndm2,ndm beta(inode)=beta(ndm2)+delta*(inode-ndm2)/ndm3 end do tempi=0.8*temps ! 0.8 enthi=0.8*enths ! 0.8 do inode=ndm2,ndm tx(inode)=tempi+(temps-tempi)*(float(inode-ndm2)/float(ndm3)) rhoa(inode)=rhos enth(inode)=enthi+(enths-enthi)*(inode-ndm2)/float(ndm3) rhorat(inode)=1. b1=dsqrt(2.*rhoinf/rhoa(ndm2)) b2=b1-(1.-b1)*beta(ndm2)/(beta(ndm)-beta(ndm2)) b3=0.5*(1.-b1)/(beta(ndm)-beta(ndm2)) b4=b2*(beta(ndm)-beta(ndm2))+b3*(beta(ndm)**2-beta(ndm2)**2) rhovrat(inode)=(b2*(beta(inode)-beta(ndm2))+b3*(beta(inode)**2 & & -beta(ndm2)**2))/b4 end do y(ndm2)=0. do inode=ndm2+1,ndm rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1)) end do enth(ndm)=enths ! ! very first time. assume interface intensity to be black body intensity at wall temperature do iw=1,nw ax1=dexp(-1.43877d0*1.0d8/(wavel(iw)*tw)) do iang=1,10 if(spallf.gt.1.0e-6) then intw(iang,iw)=1.1904d-16*ax1/((1.0d-8*wavel(iw))**5*(1.d0-ax1)) ! W/(cm2-mic-sr) int_e(iang,iw)=intw(iang,iw) end if if(spallf.le.1.0e-6) then intw(iang,iw)=0.; int_e(iang,iw)=0. end if end do end do call slope(ndm1,y(ndm2),tx(ndm2), dtdy(ndm2)) ! ! iteration on outer layer profile iout begins--------------------------- do iout=iout1,iout1+nout-1 call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy, & & int_old, dqdy,qps) ! ! change enthalpy ndm4=0.2*ndm1+ndm1 ndm5=0.4*ndm1+ndm1 ndm6=0.6*ndm1+ndm1 ndm7=0.8*ndm1+ndm1 fenth1=facout1 do idm=ndm-1,ndm4,-1 dely=(y(idm+1)-y(idm)) rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm+1)) dqdy_av=dqdy(idm+1)-dqdy(idm) enth(idm)=fenth1*(enth(idm+1)-(dqdy_av/(rhoinf*vinf))*(1./rhovrat_av)*dely) & & +(1.-fenth1)*enth(idm) end do y1=y(ndm)-y(ndm4); y2=y(ndm)-y(ndm5); y3=y(ndm)-y(ndm6); y4=y(ndm)-y(ndm7) h1=enth(ndm4)-enth(ndm); h2=enth(ndm5)-enth(ndm); h3=enth(ndm6)-enth(ndm) h4=enth(ndm7)-enth(ndm) ax(1,1)=y1; ax(1,2)=y1**2; ax(1,3)=y1**3; ax(1,4)=y1**4; rhs(1,1)=h1 ax(2,1)=y2; ax(2,2)=y2**2; ax(2,3)=y2**3; ax(2,4)=y2**4; rhs(2,1)=h2 ax(3,1)=y3; ax(3,2)=y3**2; ax(3,3)=y3**3; ax(3,4)=y3**4; rhs(3,1)=h3 ax(4,1)=y4; ax(4,2)=y4**2; ax(4,3)=y4**3; ax(4,4)=y4**4; rhs(4,1)=h4 call minv(ax,4,4,rhs,1,determ) a1=rhs(1,1); a2=rhs(2,1); a3=rhs(3,1); a4=rhs(4,1) ! construct enthalpy and temperature fac=facout1 do idm=ndm2,ndm enthx=enths+a1*(y(ndm)-y(idm))+a2*(y(ndm)-y(idm))**2+a3*(y(ndm)-y(idm))**3 & & +a4*(y(ndm)-y(idm))**4 enth(idm)=enthx enth3(idm)=enth(idm) ! enth(idm)=(1.-fac)*enth(idm)+fac*enthx call pH_air(1,pres,enth(idm), rhoa(idm),tx(idm)) end do ! mass and energy out flow rates flow_air=0. enflo_air=0. b1=dsqrt(2.*rhoinf/rhoa(ndm2)) do inode=ndm2+1,ndm rhobyrhos=rhoa(inode)/rhoa(ndm) ubyus=b1+(1.-b1)*(beta(inode)-beta(ndm2))/(beta(ndm)-beta(ndm2)) flow_air=flow_air+rhobyrhos*ubyus*(y(inode)-y(inode-1)) enflo_air=enflo_air+rhobyrhos*ubyus*enth(inode)*(y(inode)-y(inode-1)) end do flow_air=flow_air*2.*rhoa(ndm)*vinf/rnose enflo_air=enflo_air*2.*rhoa(ndm)*vinf/rnose write(6,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air write(*,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air 10 format(/' iout =',i3/ & & ' enth(ndm2) =',1pe10.3,' tx(ndm2) =',e10.3/ & & ' rhoinf*vinf =',1pe10.3,' 0.5*vinf*vinf**3=',e10.3/ & & ' flow_air =',e10.3, ' enflo_air =',e10.3) ! ! rescale beta deltax=beta(ndm)-beta(ndm2) ratio=flow_in/flow_air deltax=deltax*ratio do inode=ndm2,ndm beta(inode)=0.5*(beta(ndm2)+deltax*(inode-ndm2)/ndm3)+ & & 0.5*beta(inode) end do y(ndm2)=0. do inode=ndm2+1,ndm rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1)) end do write(12,80) iout,flow_air 80 format(i6,1pe10.3) end do ! write(*,37) qm(ndm2) 37 format(/' radiative heat flux crossing interface=',1pe10.3) if(spallf.lt.1.0e-6) return ! ! inner layer------------------------------------------------------------------------ ! ! first approximation of temperature txndm2=0.5*(tw+tx(ndm2)) do inode=i,ndm1 tx(inode)=tw+(txndm2-tw)*float(inode-1)/float(ndm3) end do ! ! iterate over ablation rate qm(ndm1)=qm(ndm2) amdot(0)=0.5*qm(ndm2)/delH amdot(1)=0.5*qm(ndm2)/delH do im=im1,im1+nim-1 write(6,*) ' ' write(*,*) ' ' write(6,*) ' im=',im write(*,*) ' im=',im if(im.eq.1) then do inode=1,ndm1 call pT_ivu(1,pres,tx(inode), rhoa(inode),enth(inode),cp) end do end if enthw=enth(1) ! do inode=1,ndm1 rhorat(inode)=rhoa(ndm1)/rhoa(inode) end do rhoe=rhoa(ndm1) rhorw=rhoa(ndm1)/rhoa(1) call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im-1),rhos,rhoe, & & beta,f,fp,betae,fw) do inode=1,ndm1 rhovrat(inode)=(f(inode)/f(1))*amdot(im-1)/(rhoinf*vinf) end do duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoa(ndm1)) y(1)=0. do inode=2,ndm1 rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhoa(ndm1)/rhoav)*(beta(inode)-beta(inode-1)) end do flow=0. aint=0. do inode=2,ndm1 rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) rhorat_av=0.5*(rhorat(inode-1)+rhorat(inode)) enthav=0.5*(enth(inode-1)+enth(inode)) fpav=0.5*(fp(inode-1)+fp(inode)) dely=y(inode)-y(inode-1) flow=flow+2.*rhoe*duedr*rhorat_av*fpav*dely aint=aint+2.*rhoav*duedr*(enthav-enthw)*fpav*dely end do entot=qm(1)-qp(1)+aint ! ! radiation call slope(ndm1,y,tx, dtdy) call flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,int_old, & & dqdy) dqdy(ndm1-1)=0.5*dqdy(ndm1-2) amdot(im)=(1.-famdot)*amdot(im-1)+famdot*(qm(im)-qp(im))/delh nimx=im+1 ! ! change enthalpy ! ! determine 1/4, 1/2, 3/4 points ndm4=0; ndm5=0; ndm6=0 do idm=1,ndm1 if(y(idm).gt.0.25*y(ndm1)) then; ndm4=idm; go to 881; end if end do 881 do idm=1,ndm1 if(y(idm).gt.0.50*y(ndm1)) then; ndm5=idm; go to 882; end if end do 882 do idm=1,ndm1 if(y(idm).gt.0.75*y(ndm1)) then; ndm6=idm; go to 883; end if end do 883 continue fac=im*facin1/10. if(fac.gt.facin1) fac=facin1 do idm=2,ndm6 dely=y(idm)-y(idm-1) rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm-1)) dqdy_av=dqdy(idm)-dqdy(idm-1) enth(idm)=fac*(enth(idm-1)+(dqdy_av/(rhoinf*vinf)) & & *(1./rhovrat_av)*dely) + (1.-fac)*enth(idm) call pH_ivu(1,pres,enth(idm), rhoax,tx(idm)) end do ! y1=y(1); y2=y(ndm4); y3=y(ndm5); y4=y(ndm6) t1=tw; t2=tx(ndm4); t3=tx(ndm5); t4=tx(ndm6) ax(1,1)=1.; ax(1,2)=y1; ax(1,3)=y1**2; ax(1,4)=y1**3; rhs(1,1)=t1 ax(2,1)=1.; ax(2,2)=y2; ax(2,3)=y2**2; ax(2,4)=y2**3; rhs(2,1)=t2 ax(3,1)=1.; ax(3,2)=y3; ax(3,3)=y3**2; ax(3,4)=y3**3; rhs(3,1)=t3 ax(4,1)=1.; ax(4,2)=y4; ax(4,3)=y4**2; ax(4,4)=y4**3; rhs(4,1)=t4 call minv(ax,4,4,rhs,1,determ) ti=rhs(1,1); a1=rhs(2,1); a2=rhs(3,1); a3=rhs(4,1) do idm=1,ndm1 tx(idm)=tw+a1*y(idm)+a2*y(idm)**2+a3*y(idm)**3 end do write(6,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im), & & flow,qm(ndm1),entot,qm(1),aint write(*,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im), & & flow,qm(ndm1),entot,qm(1),aint 20 format( & & ' beta(ndm1)=',1pe10.3,' y(ndm1) =',e10.3/ & & ' tx(ndm2) =',0pf10.1,' tx(ndm1)=',1pe10.3/ & & ' amdot =',1pe10.3,' flow =',e10.3/ & & ' qm(ndm1) =',e10.3, ' entot =',e10.3/ & & ' qm(1) =',e10.3, ' aint =',e10.3 ) write(20,17) im,facin2 write(20,18) (tx(i),i=1,ndm1) write(13,90) im,amdot(im) 90 format(i6,1pe10.3) end do ! ! reevaluate------------------------------------------------------------- ! ! outer layer------------------------------------------------------------ ! ! intensity sent from inner layer to outer layer across interface ! ! iteration on outer layer profile iout begins--------------------------- enth(ndm)=enths flow_in=rhoinf*vinf enflo_in=0.5*rhoinf*vinf**3 qp(ndm2)=qp(ndm1) do iout=iout1+nout,iout1+2*nout-1 do iw=1,nw do iang=1,10 int_old(iang,iw)=int_e(iang,iw) end do end do call slope(ndm1,y(ndm2),tx(ndm2), dtdy(ndm2)) do iw=1,nw do iang=1,10 int_old(iang,nw)=int_e(iang,nw) end do end do call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy, & & int_old, dqdy,qps) ! change enthalpy ndm4=0.2*ndm1+ndm1 ndm5=0.4*ndm1+ndm1 ndm6=0.6*ndm1+ndm1 ndm7=0.8*ndm1+ndm1 fac=facout2 do idm=ndm-1,ndm4,-1 dely=y(idm+1)-y(idm) rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm+1)) dqdy_av=dqdy(idm+1)-dqdy(idm) enth(idm)=fac*(enth(idm+1)-(dqdy_av/(rhoinf*vinf))*(1./rhovrat_av)*dely) & & +(1.-fac)*enth(idm) end do y1=y(ndm)-y(ndm4); y2=y(ndm)-y(ndm5); y3=y(ndm)-y(ndm6); y4=y(ndm)-y(ndm7) h1=enth(ndm4)-enth(ndm); h2=enth(ndm5)-enth(ndm); h3=enth(ndm6)-enth(ndm) h4=enth(ndm7)-enth(ndm) ax(1,1)=y1; ax(1,2)=y1**2; ax(1,3)=y1**3; ax(1,4)=y1**4; rhs(1,1)=h1 ax(2,1)=y2; ax(2,2)=y2**2; ax(2,3)=y2**3; ax(2,4)=y2**4; rhs(2,1)=h2 ax(3,1)=y3; ax(3,2)=y3**2; ax(3,3)=y3**3; ax(3,4)=y3**4; rhs(3,1)=h3 ax(4,1)=y4; ax(4,2)=y4**2; ax(4,3)=y4**3; ax(4,4)=y4**4; rhs(4,1)=h4 call minv(ax,4,4,rhs,1,determ) a1=rhs(1,1); a2=rhs(2,1); a3=rhs(3,1); a4=rhs(4,1) ! construct enthalpy and temperature do idm=ndm2,ndm enthx=enths+a1*(y(ndm)-y(idm))+a2*(y(ndm)-y(idm))**2+a3*(y(ndm)-y(idm))**3 & & +a4*(y(ndm)-y(idm))**4 enth(idm)=enthx enth(idm)=(1.-fenth2)*enth3(idm)+fenth2*enthx enth3(idm)=enth(idm) call pH_air(1,pres,enth(idm), rhoa(idm),tx(idm)) end do ! mass and energy out flow rates flow_air=0. enflo_air=0. b1=dsqrt(2.*rhoinf/rhoa(ndm2)) do inode=ndm2+1,ndm rhobyrhos=rhoa(inode)/rhoa(ndm) ubyus=b1+(1.-b1)*(beta(inode)-beta(ndm2))/(beta(ndm)-beta(ndm2)) flow_air=flow_air+rhobyrhos*ubyus*(y(inode)-y(inode-1)) enflo_air=enflo_air+rhobyrhos*ubyus*enth(inode)*(y(inode)-y(inode-1)) end do flow_air=flow_air*2.*rhoa(ndm)*vinf/rnose enflo_air=enflo_air*2.*rhoa(ndm)*vinf/rnose write(6,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air write(*,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air ! rescale beta deltax=beta(ndm)-beta(ndm2) ratio=flow_in/flow_air deltax=deltax*ratio do inode=ndm2,ndm beta(inode)=0.5*(beta(ndm2)+deltax*(inode-ndm2)/ndm3)+ & & 0.5*beta(inode) end do y(ndm2)=0. do inode=ndm2+1,ndm rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1)) end do write(12,80) iout,flow_air end do ! write(6,*) ' ' write(*,*) ' ' write(6,16) qm(ndm2) write(*,16) qm(ndm2) 16 format(' qm at interface=',1pe11.4,' W/m2') ! ! inner layer again----------------------------------------------------------------- ! ! iterate over ablation rate qm(ndm1)=qm(ndm2) do im=im1+nim,im1+2*nim-1 write(6,*) ' ' write(6,*) ' im=',im write(*,*) ' ' write(*,*) ' im=',im if(im.eq.nim+1) then do inode=1,ndm1 call pT_ivu(1,pres,tx(inode), rhoa(inode),enth(inode),cp) end do end if do inode=1,ndm1 rhorat(inode)=rhoa(ndm1)/rhoa(inode) end do rhoe=rhoa(ndm1) rhorw=rhoa(ndm1)/rhoa(1) ! call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im-1),rhos,rhoe, & & beta,f,fp,betae,fw) do inode=1,ndm1 rhovrat(inode)=(f(inode)/f(1))*amdot(im-1)/(rhoinf*vinf) end do duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoa(ndm1)) y(1)=0. do inode=2,ndm1 rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhoa(ndm1)/rhoav)*(beta(inode)-beta(inode-1)) end do flow=0. aint=0. do inode=2,ndm1 rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) rhorat_av=0.5*(rhorat(inode-1)+rhorat(inode)) enthav=0.5*(enth(inode-1)+enth(inode)) fpav=0.5*(fp(inode-1)+fp(inode)) dely=y(inode)-y(inode-1) flow=flow+2.*rhoe*duedr*rhorat_av*fpav*dely aint=aint+2.*rhoav*duedr*(enthav-enthw)*fpav*dely end do entot=qm(1)-qp(1)+aint ! radiation call slope(ndm1,y,tx, dtdy) call flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,int_old, & & dqdy) dqdy(ndm1-1)=0.5*dqdy(ndm1-2)+dqdy(ndm1) amdot(im)=(1.-famdot)*amdot(im-1)+famdot*(qm(1)-qp(1))/delH call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im),rhos,rhoe, & & beta,f,fp,betae,fw) ! ! change enthalpy ! ! determine 1/4, 1/2, 3/4 points ndm4=0; ndm5=0; ndm6=0 do idm=1,ndm1 if(y(idm).gt.0.25*y(ndm1)) then; ndm4=idm; go to 781; end if end do 781 do idm=1,ndm1 if(y(idm).gt.0.50*y(ndm1)) then; ndm5=idm; go to 782; end if end do 782 do idm=1,ndm1 if(y(idm).gt.0.75*y(ndm1)) then; ndm6=idm; go to 783; end if end do 783 continue fac=facin2 do idm=2,ndm6 dely=y(idm)-y(idm-1) rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm-1)) dqdy_av=dqdy(idm)-dqdy(idm-1) enth(idm)=fac*(enth(idm-1)+(dqdy_av/(rhoinf*vinf)) & & *(1./rhovrat_av)*dely) + (1.-fac)*enth(idm) call pH_ivu(1,pres,enth(idm), rhoax,tx(idm)) end do ! y1=y(1); y2=y(ndm4); y3=y(ndm5); y4=y(ndm6) t1=tw; t2=tx(ndm4); t3=tx(ndm5); t4=tx(ndm6) ax(1,1)=1.; ax(1,2)=y1; ax(1,3)=y1**2; ax(1,4)=y1**3; rhs(1,1)=t1 ax(2,1)=1.; ax(2,2)=y2; ax(2,3)=y2**2; ax(2,4)=y2**3; rhs(2,1)=t2 ax(3,1)=1.; ax(3,2)=y3; ax(3,3)=y3**2; ax(3,4)=y3**3; rhs(3,1)=t3 ax(4,1)=1.; ax(4,2)=y4; ax(4,3)=y4**2; ax(4,4)=y4**3; rhs(4,1)=t4 call minv(ax,4,4,rhs,1,determ) ti=rhs(1,1); a2=rhs(2,1); a3=rhs(3,1); a4=rhs(4,1) do idm=1,ndm1 tx(idm)=ti+a2*y(idm)+a3*y(idm)**2+a4*y(idm)**3 end do write(6,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im), & & flow,qm(ndm1),entot,qm(1),aint write(*,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im), & & flow,qm(ndm1),entot,qm(1),aint write(20,17) im,facin2 17 format(/' tx at end of im=',i3,' facin2=',f8.4) write(20,18) (tx(i),i=1,ndm1) 18 format(10f8.1) write(13,90) im,amdot(im) end do amdot_av=0.5*(amdot(2*nim)+amdot(2*nim-1)) ! return end !************************************************************************** subroutine calc1(nwave,ndm,tx,rhoinf,vinf,pres,tw,rnose,temps,rhos, & & enths,delta,delH,nout,nim,facout1,facin1,facout2,facin2,famdot, & & sigma,hwhh,iout1,im1, amdot_out,delta1,dmix,qps) ! ! input parameters ! nwave=number of wavelength points ! ndm=number of spatial node points, must be an even number ! tx(ndm)=temperature, K ! rhoinf=freestream density, kg/m3 ! vinf=flight speed-freestream velocity, m/s ! pres=stagnation point pressure, Pascal ! tw=wall temperature, K ! rnose=nose radius, m ! temps=stagnation point gas temperature, K ! rhos=stagnation point density, kg/m3 ! enths=stagnation point enthalpy, J/kg ! delta=shock stand-off distance, m ! delH=ablation energy, J/kg ! nout=allowed number of iteration for air shock layer in one sweep ! nim=allowed number of iteration for ablation-product vapor in one sweep ! facout1=fraction by which an old solution is modified by the new solution ! for air shock layer in the first two sweeps ! facin1=fraction by which an old solution is modified by the new solution ! for ablation product layer in the first two sweeps ! facout2=fraction by which an old solution is modified by the new solution ! for air shock layer in the late two sweeps ! facin2=fraction by which an old solution is modified by the new solution ! for ablation production layer in the later two sweeps ! famdot=fraction by which an old ablation rate is modified by the new ablation ! rate value ! sigma=wall emissivity ! hwhh=half-width at half-height of the Gaussian slit function, A ! iout1=beginning index for air outer layer calc (3rd sweep) ! im1=beginning index for ablation-product layer (3rd sweep) ! output parameters ! amdot_out=ablation rate, kg/(m2-s) ! delta1=improved shock stand-off distance, m ! dmix=thickness of mixing region, m ! qps=forward-facing radiative flux at shock wave, W/m2 parameter (nw=400000) implicit real*8(a-h,o-z) character*4 dum(41) common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11), & & int_cam(nw) dimension tx(802),qpa(802) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e,int_old,int_s,int_grd,int_prec,int_cam,int_abl common/comcalc/beta(802),rhoa(802),rhorat(802),rhovrat(802),y(802), & & enth(802),enth3(802),amdot(0:441) dimension & & dqdy(802), int_old(10,nw), & & f(802),fp(802),ax(4,4),rhs(4),sum(2),work(4), & & axy(3,3),rhsy(3,2),dtdy(802),ipvt(4) save ! ndm1=ndm/2 ndm2=ndm1+1 ndm3=ndm1-1 dusdr=vinf/rnose rootpi=sqrt(3.141592) flow_in=rhoinf*vinf enflo_in=rhoinf*vinf*enths ! ! iteration on outer layer profile iout begins--------------------------- do iout=iout1,iout1+nout-1 call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy, & & int_old, dqdy,qps) ! ! change enthalpy ndm4=0.2*ndm1+ndm1 ndm5=0.4*ndm1+ndm1 ndm6=0.6*ndm1+ndm1 ndm7=0.8*ndm1+ndm1 fenth1=facout1 do idm=ndm-1,ndm4,-1 dely=(y(idm+1)-y(idm)) rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm+1)) dqdy_av=dqdy(idm+1)-dqdy(idm) enth(idm)=fenth1*(enth(idm+1)-(dqdy_av/(rhoinf*vinf))*(1./rhovrat_av)*dely) & & +(1.-fenth1)*enth(idm) end do y1=y(ndm)-y(ndm4); y2=y(ndm)-y(ndm5); y3=y(ndm)-y(ndm6); y4=y(ndm)-y(ndm7) h1=enth(ndm4)-enth(ndm); h2=enth(ndm5)-enth(ndm); h3=enth(ndm6)-enth(ndm) h4=enth(ndm7)-enth(ndm) ax(1,1)=y1; ax(1,2)=y1**2; ax(1,3)=y1**3; ax(1,4)=y1**4; rhs(1)=h1 ax(2,1)=y2; ax(2,2)=y2**2; ax(2,3)=y2**3; ax(2,4)=y2**4; rhs(2)=h2 ax(3,1)=y3; ax(3,2)=y3**2; ax(3,3)=y3**3; ax(3,4)=y3**4; rhs(3)=h3 ax(4,1)=y4; ax(4,2)=y4**2; ax(4,3)=y4**3; ax(4,4)=y4**4; rhs(4)=h4 call decomp(4,4,ax,cond,ipvt,work) call solve(4,4,ax,rhs,ipvt) a1=rhs(1); a2=rhs(2); a3=rhs(3); a4=rhs(4) ! construct enthalpy and temperature fac=facout1 do idm=ndm2,ndm ! enths = enths, OK entha=enths+a1*(y(ndm)-y(idm))+a2*(y(ndm)-y(idm))**2+a3*(y(ndm)-y(idm))**3 & & +a4*(y(ndm)-y(idm))**4 enth(idm)=(1.-fac)*enth3(idm)+fac*entha enth3(idm)=enth(idm) call pH_air(1,pres,enth(idm), rhoa(idm),tx(idm)) ! enthx,enth(idm),tx(idm), OK end do ! mass and energy out flow rates flow_air=0. enflo_air=0. b1=dsqrt(2.*rhoinf/rhoa(ndm2)) do inode=ndm2+1,ndm rhobyrhos=rhoa(inode)/rhoa(ndm) ubyus=b1+(1.-b1)*(beta(inode)-beta(ndm2))/(beta(ndm)-beta(ndm2)) flow_air=flow_air+rhobyrhos*ubyus*(y(inode)-y(inode-1)) enflo_air=enflo_air+rhobyrhos*ubyus*enth(inode)*(y(inode)-y(inode-1)) end do flow_air=flow_air*2.*rhoa(ndm)*vinf/rnose enflo_air=enflo_air*2.*rhoa(ndm)*vinf/rnose write(6,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air write(*,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air 10 format(/' iout =',i3/ & & ' enth(ndm2) =',1pe10.3,' tx(ndm2) =',e10.3/ & & ' rhoinf*vinf =',1pe10.3,' 0.5*rhoinf*vinf**3=',e10.3/ & & ' flow_air =',e10.3, ' enflo_air =',e10.3) ! ! rescale beta deltax=beta(ndm)-beta(ndm2) ratio=flow_in/flow_air deltax=deltax*ratio do inode=ndm2,ndm beta(inode)=0.5*(beta(ndm2)+deltax*(inode-ndm2)/ndm3)+0.5*beta(inode) end do y(ndm2)=0. do inode=ndm2+1,ndm rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1)) ! beta(inode),y(inode), OK end do write(12,80) iout,flow_air 80 format(i6,1pe10.3) end do ! write(*,37) qm(ndm2) 37 format(/' wallward radiative heat flux crossing interface=',1pe10.3) ! ! inner layer------------------------------------------------------------ ! enthw=enth(1) ! ! iterate over ablation rate qm(ndm1)=qm(ndm2) ! from wall to edge do im=im1,im1+nim-1 write(6,*) ' ' write(*,*) ' ' write(6,*) ' im=',im write(*,*) ' im=',im if(im.eq.im1) then do inode=1,ndm1 call pT_ivu(1,pres,tx(inode), rhoa(inode),enth(inode),cp) end do end if ! trouble shooting if(im.eq.im1) then write(22,*) '***********************************************************' write(22,*) ' A. im=',im write(22,*) ' A. tx=' write(22,29) (tx(inode),inode=1,ndm1) 29 format(8f10.1) write(22,*) ' A. enth=' write(22,28) (enth(inode),inode=1,ndm1) 28 format(1p8e10.3) end if do inode=1,ndm1 rhorat(inode)=rhoa(ndm1)/rhoa(inode) end do rhoe=rhoa(ndm1) rhorw=rhoa(ndm1)/rhoa(1) call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im-1),rhos,rhoe, & & beta,f,fp,betae,fw) do inode=1,ndm1 rhovrat(inode)=(f(inode)/f(1))*amdot(im-1)/(rhoinf*vinf) end do ! trouble shooting if(im.eq.im1) then write(22,*) ' B. rhovrat=' write(22,27) (rhovrat(inode),inode=1,ndm1) 27 format(8f10.5) end if duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoa(ndm1)) y(1)=0. do inode=2,ndm1 rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhoa(ndm1)/rhoav)*(beta(inode)-beta(inode-1)) ! beta,y, OK end do ! trouble shooting if(im.eq.im1) then write(22,*) ' C. y=' write(22,28) (y(inode),inode=1,ndm1) end if flow=0. aint=0. do inode=2,ndm1 rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) rhorat_av=0.5*(rhorat(inode-1)+rhorat(inode)) enthav=0.5*(enth(inode-1)+enth(inode)) fpav=0.5*(fp(inode-1)+fp(inode)) dely=y(inode)-y(inode-1) flow=flow+2.*rhoe*duedr*rhorat_av*fpav*dely aint=aint+2.*rhoav*duedr*(enthav-enthw)*fpav*dely end do entot=qm(1)-qp(1)+aint ! ! radiation call slope(ndm1,y,tx, dtdy) call flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,int_old, & & dqdy) dqdy(ndm1-1)=0.5*dqdy(ndm1-2) amdot(im)=(1.-famdot)*amdot(im-1)+famdot*(qm(im)-qp(im))/delh nimx=im+1 ! ! change enthalpy ! ! determine 1/4, 1/2, 3/4 points ndm4=0; ndm5=0; ndm6=0 do idm=1,ndm1 if(y(idm).gt.0.25*y(ndm1)) then; ndm4=idm; go to 881; end if end do 881 do idm=1,ndm1 if(y(idm).gt.0.50*y(ndm1)) then; ndm5=idm; go to 882; end if end do 882 do idm=1,ndm1 if(y(idm).gt.0.75*y(ndm1)) then; ndm6=idm; go to 883; end if end do 883 continue fac=facin1 do idm=2,ndm6 dely=y(idm)-y(idm-1) rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm-1)) dqdy_av=dqdy(idm)-dqdy(idm-1) enth(idm)=fac*(enth(idm-1)+(dqdy_av/(rhoinf*vinf)) & & *(1./rhovrat_av)*dely) + (1.-fac)*enth(idm) call pH_ivu(1,pres,enth(idm), rhoax,tx(idm)) ! enth(idm),tx(idm), OK end do ! trouble shooting if(im.eq.im1) then write(22,*) ' D. enth=' write(22,28) (enth(idm),idm=1,ndm6) write(22,*) ' D. tx=' write(22,29) (tx(idm),idm=1,ndm6) end if ! y1=y(1); y2=y(ndm4); y3=y(ndm5); y4=y(ndm6) t1=tw; t2=tx(ndm4); t3=tx(ndm5); t4=tx(ndm6) ax(1,1)=1.; ax(1,2)=y1; ax(1,3)=y1**2; ax(1,4)=y1**3; rhs(1)=t1 ax(2,1)=1.; ax(2,2)=y2; ax(2,3)=y2**2; ax(2,4)=y2**3; rhs(2)=t2 ax(3,1)=1.; ax(3,2)=y3; ax(3,3)=y3**2; ax(3,4)=y3**3; rhs(3)=t3 ax(4,1)=1.; ax(4,2)=y4; ax(4,3)=y4**2; ax(4,4)=y4**3; rhs(4)=t4 call decomp(4,4,ax,cond,ipvt,work) call solve(4,4,ax,rhs,ipvt) ti=rhs(1); a1=rhs(2); a2=rhs(3); a3=rhs(4) do idm=1,ndm1 tx(idm)=tw+a1*y(idm)+a2*y(idm)**2+a3*y(idm)**3 ! tx(idm), OK end do ! trouble shooting if(im.eq.im1) then write(22,*) ' E. tx=' write(22,29) (tx(idm),idm=1,ndm1) end if write(6,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im), & & flow,qm(ndm1),entot,qm(1),aint write(*,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im), & & flow,qm(ndm1),entot,qm(1),aint 20 format( & & ' beta(ndm1)=',1pe10.3,' y(ndm1) =',e10.3/ & & ' tx(ndm2) =',0pf10.1,' tx(ndm1)=',1pe10.3/ & & ' amdot =',1pe10.3,' flow =',e10.3/ & & ' qm(ndm1) =',e10.3, ' entot =',e10.3/ & & ' qm(1) =',e10.3, ' aint =',e10.3 ) write(20,17) im,facin2 17 format(/' tx at end of im=',i3,' facin2=',f8.4) write(20,18) (tx(i),i=1,ndm1) 18 format(10f8.1) write(13,90) im,amdot(im) 90 format(i6,1pe10.3) end do ! ! reevaluate------------------------------------------------------------- ! outer layer------------------------------------------------------------ ! ! iteration on outer layer profile iout begins enth(ndm)=enths flow_in=rhoinf*vinf enflo_in=rhoinf*vinf*enths qp(ndm2)=qp(ndm1) do iout=iout1+nout,iout1+2*nout-1 do iw=1,nw do iang=1,10 int_old(iang,iw)=int_e(iang,iw) end do end do call slope(ndm1,y(ndm2),tx(ndm2), dtdy(ndm2)) do iw=1,nw do iang=1,10 int_old(iang,nw)=int_e(iang,nw) end do end do call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy, & & int_old, dqdy,qps) ! change enthalpy ndm4=0.2*ndm1+ndm1 ndm5=0.4*ndm1+ndm1 ndm6=0.6*ndm1+ndm1 ndm7=0.8*ndm1+ndm1 fac=facout2 do idm=ndm-1,ndm4,-1 dely=y(idm+1)-y(idm) rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm+1)) ! dqdy_av=0.5*(dqdy(idm)+dqdy(idm+1)) dqdy_av=dqdy(idm+1)-dqdy(idm) enth(idm)=fac*(enth(idm+1)-(dqdy_av/(rhoinf*vinf))*(1./rhovrat_av)*dely) & ! enth OK & +(1.-fac)*enth(idm) end do y1=y(ndm)-y(ndm4); y2=y(ndm)-y(ndm5); y3=y(ndm)-y(ndm6); y4=y(ndm)-y(ndm7) h1=enth(ndm4)-enth(ndm); h2=enth(ndm5)-enth(ndm); h3=enth(ndm6)-enth(ndm) h4=enth(ndm7)-enth(ndm) ax(1,1)=y1; ax(1,2)=y1**2; ax(1,3)=y1**3; ax(1,4)=y1**4; rhs(1)=h1 ax(2,1)=y2; ax(2,2)=y2**2; ax(2,3)=y2**3; ax(2,4)=y2**4; rhs(2)=h2 ax(3,1)=y3; ax(3,2)=y3**2; ax(3,3)=y3**3; ax(3,4)=y3**4; rhs(3)=h3 ax(4,1)=y4; ax(4,2)=y4**2; ax(4,3)=y4**3; ax(4,4)=y4**4; rhs(4)=h4 call decomp(4,4,ax,cond,ipvt,work) call solve(4,4,ax,rhs,ipvt) a0=rhs(1); a1=rhs(2); a2=rhs(3); a3=rhs(4) ! construct enthalpy and temperature do idm=ndm2,ndm entha=enthx+a1*(y(ndm)-y(idm))+a2*(y(ndm)-y(idm))**2+a3*(y(ndm)-y(idm))**3 & & +a4*(y(ndm)-y(idm))**4 enth(idm)=(1.-fenth2)*enth3(idm)+fenth2*entha enth3(idm)=enth(idm) call pH_air(1,pres,enth(idm), rhoa(idm),tx(idm)) end do ! mass and energy out flow rates flow_air=0. enflo_air=0. b1=dsqrt(2.*rhoinf/rhoa(ndm2)) do inode=ndm2+1,ndm rhobyrhos=rhoa(inode)/rhoa(ndm) ubyus=b1+(1.-b1)*(beta(inode)-beta(ndm2))/(beta(ndm)-beta(ndm2)) flow_air=flow_air+rhobyrhos*ubyus*(y(inode)-y(inode-1)) enflo_air=enflo_air+rhobyrhos*ubyus*enth(inode)*(y(inode)-y(inode-1)) end do flow_air=flow_air*2.*rhoa(ndm)*vinf/rnose enflo_air=enflo_air*2.*rhoa(ndm)*vinf/rnose write(6,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air write(*,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air ! rescale beta deltax=beta(ndm)-beta(ndm2) ratio=flow_in/flow_air deltax=deltax*ratio do inode=ndm2,ndm beta(inode)=0.5*(beta(ndm2)+deltax*(inode-ndm2)/ndm3)+ & & 0.5*beta(inode) end do y(ndm2)=0. do inode=ndm2+1,ndm rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1)) end do write(12,80) iout,flow_air end do ! shock stand-off distance delta1=y(ndm)-y(ndm2) ! ! radiation from outer layer to inner layer do iw=1,nw do iang=1,10 int_old(iang,iw)=int_e(iang,iw) end do end do call slope(ndm1,y(ndm2),tx(ndm2), dtdy(ndm2)) do iw=1,nw do iang=1,10 int_old(iang,nw)=int_e(iang,nw) end do end do call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy, & & int_old, dqdy,qps) write(6,*) ' ' write(*,*) ' ' write(6,16) qm(ndm2) write(*,16) qm(ndm2) 16 format(' qm at interface=',1pe11.4) ! ! inner layer again------------------------------------------------------------ ! ! iterate over ablation rate qm(ndm1)=qm(ndm2) ! do im=im1+nim,im1+2*nim-1 do im=im1+nim,im1+2*nim+9 write(6,*) ' ' write(6,*) ' im=',im write(*,*) ' ' write(*,*) ' im=',im ! if(im.eq.nim+1) then ! do inode=1,ndm1 ! call pT_ivu(1,pres,tx(inode), rhoa(inode),enth(inode),cp) ! end do ! end if do inode=1,ndm1 rhorat(inode)=rhoa(ndm1)/rhoa(inode) end do rhoe=rhoa(ndm1) rhorw=rhoa(ndm1)/rhoa(1) ! call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im-1),rhos,rhoe, & & beta,f,fp,betae,fw) do inode=1,ndm1 rhovrat(inode)=(f(inode)/f(1))*amdot(im-1)/(rhoinf*vinf) end do duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoa(ndm1)) y(1)=0. do inode=2,ndm1 rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) y(inode)=y(inode-1)+(rhoa(ndm1)/rhoav)*(beta(inode)-beta(inode-1)) end do flow=0. aint=0. do inode=2,ndm1 rhoav=0.5*(rhoa(inode-1)+rhoa(inode)) rhorat_av=0.5*(rhorat(inode-1)+rhorat(inode)) enthav=0.5*(enth(inode-1)+enth(inode)) fpav=0.5*(fp(inode-1)+fp(inode)) dely=y(inode)-y(inode-1) flow=flow+2.*rhoe*duedr*rhorat_av*fpav*dely aint=aint+2.*rhoav*duedr*(enthav-enthw)*fpav*dely end do entot=qm(1)-qp(1)+aint ! radiation call slope(ndm1,y,tx, dtdy) call flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,int_old, & & dqdy) dqdy(ndm1-1)=0.5*dqdy(ndm1-2)+dqdy(ndm1) amdot(im)=(1.-famdot)*amdot(im-1)+famdot*(qm(1)-qp(1))/delH ! ! change enthalpy ! ! determine 1/4, 1/2, 3/4 points ndm4=0; ndm5=0; ndm6=0 do idm=1,ndm1 if(y(idm).gt.0.25*y(ndm1)) then; ndm4=idm; go to 781; end if end do 781 do idm=1,ndm1 if(y(idm).gt.0.50*y(ndm1)) then; ndm5=idm; go to 782; end if end do 782 do idm=1,ndm1 if(y(idm).gt.0.75*y(ndm1)) then; ndm6=idm; go to 783; end if end do 783 continue fac=facin2 do idm=2,ndm6 dely=y(idm)-y(idm-1) rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm-1)) dqdy_av=dqdy(idm)-dqdy(idm-1) enth(idm)=fac*(enth(idm-1)+(dqdy_av/(rhoinf*vinf)) & & *(1./rhovrat_av)*dely) + (1.-fac)*enth(idm) end do ! y1=y(1); y2=y(ndm4); y3=y(ndm5); y4=y(ndm6) t1=tw; t2=tx(ndm4); t3=tx(ndm5); t4=tx(ndm6) ax(1,1)=1.; ax(1,2)=y1; ax(1,3)=y1**2; ax(1,4)=y1**3; rhs(1)=t1 ax(2,1)=1.; ax(2,2)=y2; ax(2,3)=y2**2; ax(2,4)=y2**3; rhs(2)=t2 ax(3,1)=1.; ax(3,2)=y3; ax(3,3)=y3**2; ax(3,4)=y3**3; rhs(3)=t3 ax(4,1)=1.; ax(4,2)=y4; ax(4,3)=y4**2; ax(4,4)=y4**3; rhs(4)=t4 call decomp(4,4,ax,cond,ipvt,work) call solve(4,4,ax,rhs,ipvt) ti=rhs(1); a1=rhs(2); a2=rhs(3); a3=rhs(4) do idm=1,ndm1 tx(idm)=ti+a1*y(idm)+a2*y(idm)**2+a3*y(idm)**3 end do write(6,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im), & & flow,qm(ndm1),entot,qm(1),aint write(*,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im), & & flow,qm(ndm1),entot,qm(1),aint write(20,17) im,facin2 write(20,18) (tx(i),i=1,ndm1) write(13,90) im,amdot(im) end do ! ! re-reevaluate------------------------------------------------------------- ! ! generate forward-cast radiation-------------------------- enth(ndm)=enths flow_in=rhoinf*vinf enflo_in=rhoinf*vinf*enths qpa(ndm2)=qpa(ndm1) ! ! print out flowfield write(11,50) rhoinf,vinf,rnose 50 format(/' rhoinf=',1pe10.3,' vinf=',e10.3,' rnose=',e10.3/ & & ' inode y rho rhov temp qp qm', & & ' dqdy enth') do inode=1,ndm1 write(11,60) inode,y(inode),rhoa(inode),-rhovrat(inode),tx(inode), & & qp(inode),qm(inode),dqdy(inode),enth(inode) 60 format(i5,1p8e11.3) end do ymid=y(ndm1) do inode=ndm2,ndm rhovratz=rhovrat(inode) write(11,60) inode,y(inode)+ymid,rhoa(inode),rhovrat(inode),tx(inode), & & qp(inode),qm(inode),dqdy(inode),enth(inode) end do ! ! fw for viscous flow call pT_vis_air(pres,tx(ndm2), visc) fwv=0.5*(amdot(4*nim)+amdot(4*nim-1))/dsqrt(2.*rhoa(ndm2)*visc*duedr) ! thickness of mixing region dmix dmix=1./(dsqrt(2.*(rhoa(ndm2)/visc)*duedr)) write(6,30) rhoinf,vinf,rnose,amdot(4*nim),fwv, & & ndm,qm(1)-qp(1),delH,delta,dmix,temps,tx(ndm2),tx(ndm1),tw 30 format(/ & & ' rhoinf =',1pe11.4,' kg/m3.'/ & & ' vinf =',e11.4,' m/s.'/ & & ' rnose =',e11.4,' m'/ & & ' amdot =',e11.4,' kg/(m2-s).'/ & & ' fwv =',e11.4/ & & ' ndm =',i5/ & & ' qm(1)-qp(1) =',e11.4,' W/m2'/ & & ' delH =',e11.4,' J/kg.'/ & & ' shock stand-off =',e11.4,' m.'/ & & ' mixing thickness dmix =',e11.4,' m.'/ & & ' post-shock temps =',0pf10.1/ & & ' interface temp tx(ndm2) =',f10.1/ & & ' ablation product layer edge temp tx(ndm1)=',f10.1/ & & ' wall temp tw =',f10.1) write(10,30) rhoinf,vinf,rnose,amdot(4*nim),fwv, & & ndm,qm(1)-qp(1),delH,delta,dmix,temps,tx(ndm2),tx(ndm1),tw amdot_out=amdot(4*nim) ! WRITE(6,*) ' GETTING OUT OF CALC1' return end !*********************************************************************** subroutine calc_1x1x(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 jmin,norm dimension emisj(nw) jmin= real(j) ! J and Lambda refer to the values of lower state involved in transition ! select case (k) go to (10,20,30) k ! case (1) ! R branch, Dj= +1 10 continue rju = jmin rjl = rju - 1.0 s_jj = (rjl+lam_l+1.0)*(rjl-lam_l+1.0) / (rjl+1.0) if(s_jj.lt.0.) s_jj= 1. go to 40 ! case (2) ! Q branch, Dj= 0 20 continue rju = jmin rjl = rju - 0.0 s_jj = lam_l**2*(2.0*rjl+1.0) / (rjl*(rjl+1.0)) if(s_jj.lt.0.) s_jj= 1. go to 40 ! case (3) ! P branch, Dj= -1 30 continue rju = jmin - 1.0 rjl = rju + 1.0 s_jj = (rjl+lam_l)*(rjl-lam_l) / rjl if(s_jj.lt.0.) s_jj= 1. go to 40 ! end select ! 40 continue fpu=bvu*(rju*(rju+1.d0)-0.0**2)-dvu*(rju*(rju+1.d0)-0.0**2)**2 fpl=bvl*(rjl*(rjl+1.d0)-0.0**2)-dvl*(rjl*(rjl+1.d0)-0.0**2)**2 ramda_jj_inv = dev + fpu - fpl wavelx = 1.0d8/ramda_jj_inv norm = 2.d0*rjl + 1. if( (lam_l.eq.2) .and. (rjl.eq.1.) ) norm= 6.d0 if( (lam_l.eq.3) .and. (rjl.eq.1.) ) norm= 13.5d0 if( (lam_l.eq.3) .and. (rjl.eq.2.) ) norm= 7.5d0 popu = dens_diatom(isp)*geu*homo_fac(isp)* & & (2.0d0*rju+1.d0) * dexp(-1.43877d0 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational s hnu = 1.9863d-23 * ramda_jj_inv ! photon energy trans_prob=(64.d0*(3.1415916d0**4)*(0.529167d-8*4.80298d-10)**2 & & *(re1**2)/(3.d0*6.6256d-27))*s_jj*ramda_jj_inv**3/norm e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0) ! emission po ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))*(1./calpha) ! ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1 emisj(j) = e return end !*********************************************************************** subroutine calc_1x1y(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 jmin,norm dimension emisj(nw) jmin= real(j) if( lam_l .gt. lam_u) then ! Delta(Lambda) = -1 ! select case (k) go to (10,20,30) k ! case (1) ! R branch 10 continue rju = jmin + 1.0 rjl = jmin s_jj = (rjl-lam_l+2.0)*(rjl-lam_l+1.0) / (2*(rjl+1.0)) if(s_jj.lt.0.) s_jj= 1. go to 40 ! case (2) ! Q branch 20 continue rju = jmin rjl = jmin s_jj = (rjl-lam_l+1.0)*(rjl+lam_l)*(2.0*rjl+1.0) / & & (2.0*rjl*(rjl+1.0)) if(j.eq.0) s_jj= 0. if(s_jj.lt.0.) s_jj= 1. go to 40 ! case (3) ! P branch 30 continue rju = jmin - 1.0 rjl = jmin s_jj = (rjl-1.0+lam_l)*(rjl+lam_l) / (2.0*rjl) if(j.eq.0) s_jj= 0. if(s_jj.lt.0.) s_jj= 1. go to 40 ! end select end if 40 continue if( lam_u .gt. lam_l) then ! Delta(Lambda) = +1 ! select case (k) go to (50,60,70) k ! case (1) ! R branch 50 continue rju = jmin + 1.0 rjl = jmin s_jj = (rjl+lam_l+2.0)*(rjl+lam_l+1.0) / (2.0*(rjl+1.0)) if(s_jj.lt.0.) s_jj= 1. go to 80 ! case (2) ! Q branch 60 continue rju = jmin rjl = jmin s_jj = (rjl+lam_l+1.0)*(rjl-lam_l)*(2.0*rjl+1.0) & & / (2.0*rjl*(rjl+1.0)) if(s_jj.lt.0.) s_jj= 1. go to 80 ! case (3) ! P branch 70 continue rju = jmin - 1.0 rjl = jmin s_jj = (rjl-lam_l-1.0)*(rjl-lam_l) / (2.0*rjl) if(s_jj.lt.0.) s_jj= 1. go to 80 ! end select end if ! 80 continue fpu = bvu*(rju*(rju+1.d0)-0.0**2) - dvu*(rju*(rju+1.d0)-0.0**2)**2 fpl = bvl*(rjl*(rjl+1.d0)-0.0**2) - dvl*(rjl*(rjl+1.d0)-0.0**2)**2 ramda_jj_inv = dev + fpu - fpl wavelx = 1.0d8/ramda_jj_inv norm = 2.d0*rjl + 1.d0 ! if( ((lam_u.eq.2).and. (lam_l.eq.3)) .and. (rjl.eq.1.) ) norm= 6.0 popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * dexp(-1.43877d0 * (teu/trot & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotationa hnu = 1.9863d-23 * ramda_jj_inv ! photon energ trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8 & & * 4.80298d-10)**2* (re1**2)/(3.d0 * 6.6256d-27)) * s_jj & & * ramda_jj_inv**3/norm e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0) ! emission po ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_2P2P(isp,dev,bvu,bvl,dvu,dvl, geu, & & teu,evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 jmin,norm dimension emisj(nw) jmin= real(j) ! select case (k) go to (10,20,30,40,50,60,70,80,90,100,110,120) k ! case(1) ! R11(f1', f1") 10 continue rju = jmin+1.; rjl = jmin s_jj= (rjl+0.)*(rjl+2.)**2/(rjl+1.)/(2.*rjl+3.) cu1 = 1.0; cl1 = 1.0; cu2 = 0.0; cl2 = 0.0; go to 130 ! case(2) ! R22(f2', f2") 20 continue rju = jmin+1.; rjl = jmin s_jj= rjl**2*(rjl+2.)/(rjl+1.)/(2.*rjl+1.) cu1 = -1.0; cl1 = -1.0; cu2 = 1.0; cl2 = 1.0; go to 130 ! case(3) ! qR12(f1', f2") 30 continue rju = jmin+1.; rjl = jmin s_jj= 1./rjl/(rjl+1.)/(2.*rjl+1.) cu1 = 1.0; cl1 = -1.0; cu2 = 0.0; cl2 = 1.0; go to 130 ! case(4) ! sR21(f2', f1") 40 continue rju = jmin+1.; rjl = jmin s_jj= 0.0 cu1 = -1.0; cl1 = 1.0; cu2 = 1.0; cl2 = 0.0; go to 130 ! case(5) ! Q11(f1', f1") 50 continue rju = jmin; rjl = jmin s_jj= (2.*rjl+3.)/(rjl+1.)/(2.*rjl+1.) cu1 = 1.0; cl1 = 1.0; cu2 = 0.0; cl2 = 0.0; go to 130 ! case(6) ! Q22(f2', f2") 60 continue rju = jmin; rjl = jmin s_jj= (2.*rjl-1.)/rjl/(2.*rjl+1.) cu1 = -1.0; cl1 = -1.0; cu2 = 1.0; cl2 = 1.0; go to 130 ! case(7) ! pQ12(f1', f2") 70 continue rju = jmin; rjl = jmin s_jj= (rjl-1.)*(rjl+1.)/(rjl+0.)/(2.*rjl-1.)/(2.*rjl+1.) cu1 = 1.0; cl1 = -1.0; cu2 = 0.0; cl2 = 1.0; go to 130 ! case(8) ! rQ(f2', f1") 80 continue rju = jmin; rjl = jmin s_jj= rjl*(rjl+2.)/(rjl+1.)/(2.*rjl+1.)/(2.*rjl+3.) cu1 = -1.0; cl1 = 1.0; cu2 = 1.0; cl2 = 0.0; go to 130 ! case(9) ! P11(f1', f1") 90 continue rju = jmin-1.; rjl = jmin s_jj= (rjl-1.)*(rjl+1.)**2/(rjl+0.)/(2.*rjl+1.) cu1 = 1.0; cl1 = 1.0; cu2 = 0.0; cl2 = 0.0; go to 130 ! case(10) ! P22(f2', f2") 100 continue rju = jmin-1.; rjl = jmin s_jj= (rjl+1.)*(rjl-1.)**2/rjl/(2.*rjl-1.) cu1 = -1.0; cl1 = -1.0; cu2 = 1.0; cl2 = 1.0; go to 130 ! case(11) ! oP(f1', f2") 110 continue rju = jmin-1.; rjl = jmin s_jj= 0.0 cu1 = 1.0; cl1 = -1.0; cu2 = 0.0; cl2 = 1.0; go to 130 ! case(12) ! qP(pf2', f1") 120 continue rju = jmin-1.; rjl = jmin s_jj= 1./rjl/(rjl+1.)/(2.*rjl+1.) cu1 = -1.0; cl1 = 1.0; cu2 = 1.0; cl2 = 0.0; go to 130 ! refer to kavacs, pp. 249, 222(v.16) 130 continue sou= 0. sol= 0. fpu=bvu*rju*(rju+1.)-dvu*rju**2*(rju+1.)**2+cu1/2.*sou*(rju+cu2) !cu1= +1, cu2 fpl=bvl*rjl*(rjl+1.)-dvl*rjl**2*(rjl+1.)**2+cl1/2.*sol*(rjl+cl2) !cl1= -1, cl2 ramda_jj_inv = dev + fpu - fpl wavelx = 1.0d8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * dexp(-1.43877d0 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotationa hnu = 1.9863d-23 * ramda_jj_inv ! photon energy trans_prob=(64.d0*(3.1415916d0**4)*(0.529167d-8*4.80298d-10)**2 & & *(re1**2)/(3.d0*6.6256d-27))*s_jj*ramda_jj_inv**3 /(2.*rjl+1.) e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0) ! emission po ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.d0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e return end !*********************************************************************** subroutine calc_2S2P(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,lam_u, & & lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 jmin,norm dimension emisj(nw) real*8 lm sum_fact= 2.d0 ! select case (k) ! refer to pp 261 of herzberg go to (10,20,30,40,50,60,70,80,90,100,110,120) k ! case(1) ! r(f1', f1") 10 continue rju = real(j) + 0.5; rjl = real(j) - 0.5 cu1 = -1.0; cl1 = -1.0; cu2 = 0.0; cl2 = 0.0; go to 130 ! case(2) ! r(f2', f2") 20 continue rju = real(j) + 0.5; rjl = real(j) - 0.5 cu1 = 1.0; cl1 = 1.0; cu2 = 1.0; cl2 = 1.0; go to 130 ! case(3) ! qr(f1', f2") 30 continue rju = real(j) + 0.5; rjl = real(j) - 0.5; cu1 = -1.0 cl1 = 1.0; cu2 = 0.0; cl2 = 1.0; go to 130 ! case(4) ! sr(f2', f1") 40 continue rju = real(j) + 0.5; rjl = real(j) - 0.5 cu1 = 1.0; cl1 = -1.0; cu2 = 1.0; cl2 = 0.0; go to 130 ! case(5) ! q(f1', f1") 50 continue rju = real(j) - 0.5; rjl = real(j) - 0.5 cu1 = -1.0; cl1 = -1.0; cu2 = 0.0; cl2 = 0.0; go to 130 ! case(6) ! q(f2', f2") 60 continue rju = real(j) - 0.5; rjl = real(j) - 0.5 cu1 = 1.0; cl1 = 1.0; cu2 = 1.0; cl2 = 1.0; go to 130 ! case(7) ! pq(f1', f2") 70 continue rju = real(j) - 0.5; rjl = real(j) - 0.5 cu1 = -1.0; cl1 = 1.0; cu2 = 0.0; cl2 = 1.0; go to 130 ! case(8) ! rq(f2', f1") 80 continue rju = real(j) - 0.5; rjl = real(j) - 0.5 cu1 = 1.0; cl1 = -1.0; cu2 = 1.0; cl2 = 0.0; go to 130 ! case(9) ! p(f1', f1") 90 continue rju = real(j) - 0.5; rjl = real(j) + 0.5 cu1 = -1.0; cl1 = -1.0; cu2 = 0.0; cl2 = 0.0; go to 130 ! case(10) ! p(f2', f2") 100 continue rju = real(j) - 0.5; rjl = real(j) + 0.5 cu1 = 1.0; cl1 = 1.0; cu2 = 1.0; cl2 = 1.0; go to 130 ! case(11) ! op(f1', f2") 110 continue rju = real(j) - 0.5; rjl = real(j) + 0.5 cu1 = -1.0; cl1 = 1.0; cu2 = 0.0; cl2 = 1.0; go to 130 ! case(12) ! qp(f2', f1") 120 continue rju = real(j) - 0.5; rjl = real(j) + 0.5 cu1 = 1.0; cl1 = -1.0; cu2 = 1.0; cl2 = 0.0; go to 130 ! end select 130 continue rju = rju + 0.5 rjl = rjl + 0.5 ! refer to kavacs, pp 61, 63, and 127 yu = sou/bvu yl = sol/bvl jx = rju yy = yu if (lam_u .gt. lam_l) then yy = yl jx = rjl end if fpu= bvu*((rju+0.5d0)**2 - lam_u**2 + cu1/2.d0*dsqrt(4.d0 & & *(rju+0.5d0)**2 + (yu*lam_u)**2 - 4.d0*yu*lam_u**2)) & & - dvu*(rju+cu2)**4 fpl= bvl*((rjl+0.5d0)**2 - lam_l**2 + cl1/2.*dsqrt & & (4.d0*(rjl+0.5d0)**2 + (yl*lam_l)**2 - 4.d0*yl*lam_l**2)) & & - dvl*(rjl+cl2)**4 uu = 1.d0/dsqrt(yy**2-yy+(2.d0*jx+1.)**2) if( lam_l .gt. lam_u) then ! 2S-2P ! select case (k) go to (210,220,230,240,250,260,270,280,290,300,310,320) k ! case(1) ! R11(f1', f1") 210 continue s_jj = (2.d0*jx+1.)**2 + (2.d0*jx+1.d0)*uu*(4.d0*jx**2 & & +4.d0*jx-7.d0+2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact go to 330 ! case(2) ! R22(f2', f2") 220 continue s_jj = (2.d0*jx+1.d0)**2 + (2.d0*jx+1.d0)*uu*(4.d0*jx**2 & & +4.d0*jx+1.d0-2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact go to 330 ! case(3) ! qR12(f1', f2") 230 continue s_jj =(2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & -7.d0+2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact go to 330 ! case(4) ! sR21(f2', f1") 240 continue s_jj = (2.d0*jx+1.d0)**2 - (2.d0*jx+1.d0)*uu*(4.d0*jx**2 & & +4.d0*jx+1.d0-2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact go to 330 ! case(5) ! Q11(f1', f1") 250 continue s_jj=(2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)+uu*(8.d0*jx**3 & & +12.d0*jx**2-2.d0*jx-7.d0+2.d0*yy))/(16.d0*jx*(jx+1.d0)) & & /sum_fact go to 330 ! case(6) ! Q22(f2', f2") 260 continue s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)+uu*(8.d0*jx**3 & & +12.d0*jx**2-2.d0*jx+1.d0-2.d0*yy))/(16.d0*jx*(jx+1.d0)) & & /sum_fact go to 330 ! case(7) ! pQ12(f1', f2") 270 continue s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)-uu*(8.d0*jx**3 & & +12.d0*jx**2-2.d0*jx-7.d0+2.d0*yy))/(16.d0*jx*(jx+1.d0)) & & /sum_fact go to 330 ! case(8) ! rQ21(f2', f1") 280 continue s_jj=(2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)-uu*(8.d0*jx**3 & & +12.d0*jx**2-2.d0*jx+1.d0-2.d0*yy))/(16.d0*jx*(jx+1.d0)) & & /sum_fact go to 330 ! case(9) ! P11(f1', f1") 290 continue s_jj = (2.d0*jx+1.d0)**2+(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & +1.d0-2.d0*yy) / (16.d0*jx) /sum_fact go to 330 ! case(10) ! P22(f2', f2") 300 continue s_jj=(2.d0*jx+1.)**2 + (2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & -7.d0+2.d0*yy) / (16.d0*jx) /sum_fact go to 330 ! case(11) ! oP12(f1', f2") 310 continue s_jj = (2.d0*jx+1.d0)**2 - (2.d0*jx+1.d0)*uu*(4.d0*jx**2 & & +4.d0*jx+1.d0-2.d0*yy) / (16.d0*jx) /sum_fact go to 330 ! case(12) ! qP21(f2', f1") 320 continue s_jj = (2.d0*jx+1.d0)**2 - (2.d0*jx+1.d0)*uu*(4.d0*jx**2 & & +4.d0*jx-7.d0+2.d0*yy) / (16.d0*jx) /sum_fact go to 330 ! end select 330 continue end if if( lam_u .gt. lam_l) then ! 2P-2S ! select case (k) go to (410,420,430,440,450,460,470,480,490,500,510,520) k ! case(1) ! R11(f1', f1") 410 continue s_jj = (2.d0*jx+1.d0)**2 + (2.d0*jx+1.)*uu*(4.d0*jx**2+4.d0*jx & & +1.d0-2.d0*yy) / (16.d0*jx) /sum_fact go to 530 ! case(2) ! R22(f2', f2") 420 continue s_jj = (2.d0*jx+1.d0)**2+(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & -7.d0+2.d0*yy) / (16.*jx) /sum_fact go to 530 ! case(3) ! qR12(f1', f2") 430 continue s_jj = (2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & -7.d0+2.*yy) / (16.*jx) /sum_fact go to 530 ! case(4) ! sR21(f2', f1") 440 continue s_jj = (2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & +1.d0-2.d0*yy) / (16.d0*jx) /sum_fact go to 530 ! case(5) ! Q11(f1', f1") 450 continue s_jj=(2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)+uu*(8.d0*jx**3 & & +12.d0*jx**2-2.d0*jx-7.d0+2.d0*yy)) / (16.d0*jx*(jx+1.)) & & /sum_fact go to 530 ! case(6) ! Q22(f2', f2") 460 continue s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)+uu*(8.d0*jx**3 & & +12.d0*jx**2-2.d0*jx+1.d0-2.d0*yy)) / (16.d0*jx*(jx+1.)) & & /sum_fact go to 530 ! case(7) ! pQ12(f1', f2") 470 continue s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)-uu*(8.d0*jx**3 & & +12.d0*jx**2-2.*jx+1.-2.*yy)) / (16.*jx*(jx+1.)) /sum_fact go to 530 ! case(8) ! rQ21(f2', f1") 480 continue s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)-uu*(8.d0*jx**3 & & +12.d0*jx**2-2.d0*jx-7.d0+2.d0*yy)) / (16.d0*jx*(jx+1.d0)) & & /sum_fact go to 530 ! case(9) ! P11(f1', f1") 490 continue s_jj = (2.d0*jx+1.d0)**2+(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & -7.d0+2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact go to 530 ! case(10) ! P22(f2', f2") 500 continue s_jj = (2.d0*jx+1.d0)**2+(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & +1.d0-2.d0*yy) / (16.*(jx+1.)) /sum_fact go to 530 ! case(11) ! oP12(f1', f2") 510 continue s_jj = (2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & +1.d0-2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact go to 530 ! case(12) ! qP21(f2', f1") 520 continue s_jj = (2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx & & -7.d0+2.d0*yy) / (16.d0*(jx+1.)) /sum_fact go to 530 ! end select 530 continue end if ramda_jj_inv = dev + fpu - fpl wavelx = 1.0d8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * dexp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational s hnu = 1.9863d-23 * ramda_jj_inv ! photon energy trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8 & & * 4.80298d-10)**2* (re1**2)/(3.d0 * 6.6256d-27)) * s_jj & & * ramda_jj_inv**3 /(2.d0*jx+1.d0) e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0) ! emission power ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1 emisj(j) = e return end !*********************************************************************** subroutine calc_2S2S(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 jmin,norm dimension emisj(nw) jmin= real(j) ! s_jj's are taken from kovacs's, pp.127. these are exatly same as a.schadee (pp.327) fo ! select case (k) ! refer to pp 261 of herzberg go to (10,20,30,40,50,60,70,80,90,100,110,120) k ! ! case(1) ! R11(f1', f1") 10 continue rju = jmin + 1. rjl = jmin s_jj= (rjl+1.)*(rjl+2.)/(2.*rjl+3.) cu1 = 1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(2) ! R22(f2', f2") 20 continue rju = jmin + 1. rjl = jmin s_jj= (rjl+0.)*(rjl+1.)/(2.*rjl+1.) cu1 = -1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 1.0 go to 130 ! case(3) ! qR(f1', f2") 30 continue rju = jmin + 1. rjl = jmin s_jj= 0. cu1 = 1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(4) ! sR(f2', f1") 40 continue rju = jmin + 1. rjl = jmin s_jj= 0. cu1 = -1.0; cl1 = 1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! case(5) ! Q11(f1', f1") 50 continue rju = jmin + 0. rjl = jmin s_jj= 0. cu1 = 1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(6) ! Q22(f2', f2") 60 continue rju = jmin + 0. rjl = jmin s_jj= 0. cu1 = -1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 1.0 go to 130 ! case(7) ! pQ12(f1', f2") 70 continue rju = jmin + 0. rjl = jmin s_jj= (rjl+0.)/(2.*rjl-1.)/(2.*rjl+1.) cu1 = 1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(8) ! rQ(f2', f1") 80 continue rju = jmin + 0.; rjl = jmin s_jj= (rjl+1.)/(2.*rjl+1.)/(2.*rjl+3.) cu1 = -1.0; cl1 = 1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! case(9) ! P11(f1', f1") 90 continue rju = jmin - 1.; rjl = jmin s_jj= (rjl+0.)*(rjl+1.)/(2.*rjl+1.) cu1 = 1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(10) ! P22(f2', f2") 100 continue rju = jmin - 1.; rjl = jmin s_jj= (rjl+0.)*(rjl-1.)/(2.*rjl-1.) cu1 = -1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 1.0 go to 130 ! case(11) ! oP(f1', f2") 110 continue rju = jmin - 1. rjl = jmin s_jj= 0. cu1 = 1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(12) ! qP(pf2', f1") 120 continue rju = jmin - 1. rjl = jmin s_jj= 0. cu1 = -1.0; cl1 = 1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! end select ! refer to kavacs, pp. 249, 222(v.16) 130 continue fpu=bvu*rju*(rju+1.)-dvu*rju**2*(rju+1.)**2+cu1/2.*sou*(rju+cu2) fpl=bvl*rjl*(rjl+1.)-dvl*rjl**2*(rjl+1.)**2+cl1/2.*sol*(rjl+cl2) ramda_jj_inv = dev + fpu - fpl wavelx = 1.0d8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * dexp(-1.43877d0 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational s hnu = 1.9863d-23 * ramda_jj_inv ! photon energy trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8 & & * 4.80298d-10)**2* (re1**2)/(3.d0 * 6.6256d-27)) * s_jj & & * ramda_jj_inv**3 /(2.d0*rjl+1.) e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0) ! emission po ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_2X2X(isp,dev,bvu,bvl,dvu,dvl, & & geu,teu,evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx, & & emisj,ncentr,lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 jmin,norm dimension emisj(nw) jmin= real(j) ! select case (k) ! refer to pp 261 of Herzberg go to (10,20,30,40,50,60,70,80,90,100,110,120) k ! case(1) ! R11(f1', f1") 10 continue rju = jmin + 1.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(2) ! R22(f2', f2") 20 continue rju = jmin + 1.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = 1.0 cu2 = 1.0 cl2 = 1.0 ! case(3) ! qR12(f1', f2") 30 continue rju = jmin + 1.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(4) ! sR21(f2', f1") 40 continue rju = jmin + 1.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! case(5) ! Q11(f1', f1") 50 continue rju = jmin + 0.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(6) ! Q22(f2', f2") 60 continue rju = jmin + 0.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = 1.0 cu2 = 1.0; cl2 = 1.0 go to 130 ! case(7) ! pQ12(f1', f2") 70 continue rju = jmin + 0.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(8) ! rQ21(f2', f1") 80 continue rju = jmin + 0.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! case(9) ! P11(f1', f1") 90 continue rju = jmin - 0.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(10) ! P22(f2', f2") 100 continue rju = jmin - 0.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = 1.0 cu2 = 1.0; cl2 = 1.0 go to 130 ! case(11) ! oP12(f1', f2") 110 continue rju = jmin - 0.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(12) ! qP21(f2', f1") 120 continue rju = jmin - 0.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! end select ! refer to kavacs, pp 61, 63, and 127, Herzberg 232(v.8) 130 continue yu = sou/bvu yl = sol/bvl fpu= bvu*((rju+0.5d0)**2 - lam_u**2 + cu1/2.d0 & & *dsqrt(4.d0*(rju+0.5d0)**2+(yu*lam_u)**2-4.d0*yu*lam_u**2)) & & -dvu*(rju+cu2)**4 fpl= bvl*((rjl+0.5d0)**2 - lam_l**2 + cl1/2.d0 & & *dsqrt(4.d0*(rjl+0.5d0)**2+(yl*lam_l)**2-4.d0*yl*lam_l**2)) & & -dvl*(rjl+cl2)**4 if(yu .lt. 0) yu= -yu if(yl .lt. 0) yl= -yl uuu=dsqrt(lam_u**2*yu*(yu-4.d0)+4.d0*(rju+0.5d0)**2) & & +cu1*lam_u*(yu-2.d0) uul= dsqrt(lam_l**2*yl*(yl-4.d0) + 4.d0*(rjl+0.5d0)**2) & & + cl1*lam_l*(yl-2.d0) ccu= 0.5d0*(uuu**2 + 4.d0*(rju+0.5d0)**2 - 4.d0*lam_u**2) ccl= 0.5d0*(uul**2 + 4.d0*(rjl+0.5d0)**2 - 4.d0*lam_l**2) if(ccu.eq.0) ccu= 1.d5 if(ccl.eq.0) ccl= 1.d5 jx = rjl ! select case (k) go to (210,220,230,240,250,260,270,280,290,300,310,320) k ! case(1) ! r(f1', f1") 210 continue s_jj = (jx-lam_u+0.5d0)*(jx+lam_u+1.5d0) * (uuu*uul & & + 4.d0*(jx-lam_u+1.5d0)*(jx+lam_u+0.5d0))**2 / & & (4.d0*(jx+1.d0)*ccu*ccl) /2.d0 if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(2) ! r(f2', f2") 220 continue s_jj = (jx-lam_u+0.5d0)*(jx+lam_u+1.5d0) * (uuu*uul & & + 4.d0*(jx-lam_u+1.5d0)*(jx+lam_u+0.5d0))**2 / & & (4.d0*(jx+1.d0)*ccu*ccl) /2.d0 if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(3) ! qr(f1', f2") 230 continue s_jj = (jx-lam_u+0.5d0)*(jx+lam_u+1.5d0) * (uuu*uul & & - 4.d0*(jx-lam_u+1.5d0)*(jx+lam_u+0.5d0))**2 / & & (4.d0*(jx+1.d0)*ccu*ccl) /2.d0 if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(4) ! sr(f2', f1") 240 continue s_jj = (jx-lam_u+0.5d0)*(jx+lam_u+1.5d0) * (uuu*uul & & - 4.d0*(jx-lam_u+1.5d0)*(jx+lam_u+0.5d0))**2 / & & (4.d0*(jx+1.)*ccu*ccl) /2. if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(5) ! q(f1', f1") 250 continue s_jj = (jx+0.5d0) * ((lam_u+0.5d0)*uuu*uul + 4.d0*(lam_u-0.5d0) & & *(jx-lam_u+0.5d0)*(jx+lam_u+0.5d0))**2 / & & (2.*jx*(jx+1.)*ccu*ccl) /2.d0 if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(6) ! q(f2', f2") 260 continue s_jj = (jx+0.5) * ((lam_u+0.5)*uuu*uul + 4.*(lam_u-0.5) & & *(jx-lam_u+0.5)*(jx+lam_u+0.5))**2 / (2.*jx*(jx+1.) & & *ccu*ccl) /2. if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(7) ! pq(f1', f2") 270 continue s_jj = (jx+0.5) * ((lam_u+0.5)*uuu*uul - 4.*(lam_u-0.5) & & *(jx-lam_u+0.5)*(jx+lam_u+0.5))**2 / & & (2.*jx*(jx+1.)*ccu*ccl) /2. if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(8) ! rq(f2', f1") 280 continue s_jj = (jx+0.5d0) * ((lam_u+0.5d0)*uuu*uul - 4.d0*(lam_u-0.5d0) & & *(jx-lam_u+0.5d0)*(jx+lam_u+0.5d0))**2/(2.d0*jx*(jx+1.d0) & & *ccu*ccl)/2.d0 if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(9) ! p(f1', f1") 290 continue s_jj = (jx-lam_u-0.5d0)*(jx+lam_u+0.5d0) * (uuu*uul + & & 4.d0*(jx-lam_u+0.5d0)*(jx+lam_u-0.5d0))**2/(4.d0*jx*ccu*ccl) & & /2.d0 if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(10) ! p(f2', f2") 300 continue s_jj = (jx-lam_u-0.5d0)*(jx+lam_u+0.5d0)*(uuu*uul+4.d0 & & *(jx-lam_u+0.5d0)*(jx+lam_u-0.5d0))**2/(4.d0*jx*ccu*ccl)/2.d0 if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(11) ! op(f1', f2") 310 continue s_jj = (jx-lam_u-0.5d0)*(jx+lam_u+0.5d0)*(uuu*uul-4.d0*(jx-lam_u & & +0.5)*(jx+lam_u-0.5))**2 / (4.*jx*ccu*ccl) /2. if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! case(12) ! qp(f2', f1") 320 continue s_jj = (jx-lam_u-0.5d0)*(jx+lam_u+0.5d0) * (uuu*uul & & - 4.d0*(jx-lam_u+0.5d0)*(jx+lam_u-0.5d0))**2 / & & (4.*jx*ccu*ccl) /2.d0 if(s_jj.lt.0.) s_jj= 0.25 go to 330 ! end select 330 continue ramda_jj_inv = dev + fpu - fpl wavelx = 1.0d8/ramda_jj_inv norm = 2.d0*rjl + 1.d0 ! Note: these values are not correct, approximated ! depend on Y=A/B if( (lam_l.eq.1) .and. (rjl.eq.1.5) ) norm= 3.3333333333333d0 if( (lam_l.eq.2) .and. (rjl.eq.1.5) ) norm= 3.34953d0 if( (lam_l.eq.2) .and. (rjl.eq.2.5) ) norm= 5.2d0 ! for Yu=0.=Yl popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.d0*rju+1.d0) * dexp(-1.43877d0 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of uppe hnu = 1.9863d-23 * ramda_jj_inv ! photon energy in ergs trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8 & & * 4.80298d-10)**2 * (re1**2)/(3.d0 * 6.6256d-27)) * s_jj & & * ramda_jj_inv**3 /norm e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0) ! emission power, w/(cm3 ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_2X2Y(isp,dev,bvu,bvl,dvu,dvl,geu, & & teu,evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 jmin,norm,lm,jx dimension emisj(nw) sum_fact= 1.d0 if((lam_u.eq.0).and.(lam_u.eq.1)) sum_fact= 2.d0 jmin = real(j) ! select case (k) ! refer to pp 261 of Herzberg go to (10,20,30,40,50,60,70,80,90,100,110,120) k ! case(1) ! R11(f1', f1") 10 continue rju = jmin + 1.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(2) ! r(f2', f2") 20 continue rju = jmin + 1.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = 1.0 cu2 = 1.0; cl2 = 1.0 go to 130 ! case(3) ! qr(f1', f2") 30 continue rju = jmin + 1.5 rjl = jmin + 0.5 cu1 = -1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(4) ! sr(f2', f1") 40 continue rju = jmin + 1.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! case(5) ! q(f1', f1") 50 continue rju = jmin + 0.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(6) ! q(f2', f2") 60 continue rju = jmin + 0.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = 1.0 cu2 = 1.0; cl2 = 1.0 go to 130 ! case(7) ! pq(f1', f2") 70 continue rju = jmin + 0.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(8) ! rq(f2', f1") 80 continue rju = jmin + 0.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! case(9) ! p(f1', f1") 90 continue rju = jmin - 0.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = -1.0 cu2 = 0.0; cl2 = 0.0 go to 130 ! case(10) ! p(f2', f2") 100 continue rju = jmin - 0.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = 1.0 cu2 = 1.0; cl2 = 1.0 go to 130 ! case(11) ! op(f1', f2") 110 continue rju = jmin - 0.5; rjl = jmin + 0.5 cu1 = -1.0; cl1 = 1.0 cu2 = 0.0; cl2 = 1.0 go to 130 ! case(12) ! qp(f2', f1") 120 continue rju = jmin - 0.5; rjl = jmin + 0.5 cu1 = 1.0; cl1 = -1.0 cu2 = 1.0; cl2 = 0.0 go to 130 ! end select 130 continue ! ! refer to kavacs, pp 61, 63, and 127 yu = sou/bvu yl = sol/bvl if(yu .lt. 0.) yu= -yu if(yl .lt. 0.) yl= -yl fpu= bvu*((rju+0.5d0)**2 - lam_u**2 + cu1/2.d0*dsqrt(4.d0 & & *(rju+0.5d0)**2 + (yu*lam_u)**2 - 4.d0*yu*lam_u**2)) & & - dvu*(rju+cu2)**4 fpl= bvl*((rjl+0.5d0)**2 - lam_l**2 + cl1/2.*dsqrt(4.d0*(rjl & & +0.5d0)**2 + (yl*lam_l)**2 - 4.d0*yl*lam_l**2)) & & - dvl*(rjl+cl2)**4 uuu= dsqrt(lam_u**2*yu*(yu-4.d0) + 4.d0*(rju+0.5d0)**2) & & + cu1*lam_u*(yu-2.d0) uul= dsqrt(lam_l**2*yl*(yl-4.d0) + 4.d0*(rjl+0.5d0)**2) & & + cl1*lam_l*(yl-2.d0) ccu= 0.5d0*(uuu**2 + 4.d0*(rju+0.5d0)**2 - 4.d0*lam_u**2) ccl= 0.5d0*(uul**2 + 4.d0*(rjl+0.5d0)**2 - 4.d0*lam_l**2) if(ccu.eq.0.) ccu= 1.d5 if(ccl.eq.0.) ccl= 1.d5 jx = rjl lm = real(lam_l) if( lam_l .gt. lam_u) then ! 2P-2D, etc jx = rju lm = lam_u end if if( lam_u .gt. lam_l) then ! 2D-2P, etc ! select case (k) go to (210,220,230,240,250,260,270,280,290,310,320) k ! case(1) ! R11(f1', f1") 210 continue s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*(jx+1.d0)*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(2) ! R22(f2', f2") 220 continue s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*(jx+1.d0)*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(3) ! qR12(f1', f2") 230 continue s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*(jx+1.d0)*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(4) ! sR21(f2', f1") 240 continue s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*(jx+1.)*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(5) ! Q11(f1', f1") 250 continue s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul & & + 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2/(4.d0*jx*(jx+1.) & & *ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(6) ! Q22(f2', f2") 260 continue s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul & & + 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / (4.d0*jx*(jx+1.d0) & & *ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(7) ! pQ12(f1', f2") 270 continue s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul & & - 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / & & (4.d0*jx*(jx+1.d0)*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(8) ! rQ21(f2', f1") 280 continue s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul & & - 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / (4.d0*jx*(jx+1.d0) & & *ccu*ccl) /2. if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(9) ! P11(f1', f1") 290 continue s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(10) ! P22(f2', f2") 300 continue s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(11) ! oP12(f1', f2") 310 continue s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! case(12) ! qP21(f2', f1") 320 continue s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl) /2.d0 if(s_jj .lt. 0.) s_jj= 0.25 go to 330 ! end select 330 continue end if if( lam_l .gt. lam_u) then ! 2P-2D, etc ! select case (k) go to (410,420,430,440,450,460,470,480,490,500,510,520) k ! case(1) ! R11(f1', f1") 410 continue s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(2) ! R22(f2', f2") 420 continue s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(3) ! qR12(f1', f2") 430 continue s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(4) ! sR21(f2', f1") 440 continue s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(5) ! Q11(f1', f1") 450 continue s_jj=(jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul & & +4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / & & (4.d0*jx*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(6) ! Q22(f2', f2") 460 continue s_jj=(jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul+4.d0 & & *(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / & & (4.d0*jx*(jx+1.)*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(7) ! pQ12(f1', f2") 470 continue s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul & & - 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / & & (4.d0*jx*(jx+1.)*ccu*ccl)/2.*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(8) ! rQ21(f2', f1") 480 continue s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul & & - 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / & & (4.d0*jx*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(9) ! P11(f1', f1") 490 continue s_jj = (jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul+4.d0*(jx-lm+0.5) & & *(jx+lm+0.5d0))**2 /(8.d0*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(10) ! P22(f2', f2") 500 continue s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5d0))**2/(8.d0*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(11) ! oP12(f1', f2") 510 continue s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0) & & *(jx+lm+0.5))**2 / (8.d0*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! case(12) ! qP21(f2', f1") 520 continue s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul-4.d0*(jx-lm+0.5) & & *(jx+lm+0.5d0))**2 /(8.d0*(jx+1.d0)*ccu*ccl)/2.*sum_fact if(s_jj .lt. 0.) s_jj= 0.25 go to 530 ! end select 530 continue end if ramda_jj_inv = dev + fpu - fpl wavelx = 1.0d8/ramda_jj_inv norm = 2.d0*rjl+1.d0 if(((lam_u.eq.1).and.(lam_l.eq.0)).and.(jx.eq.1.5)) norm=3.66667d0 if(((lam_u.eq.2).and.(lam_l.eq.1)).and.(jx.eq.1.5)) norm= 3.2d0 if(((lam_u.eq.2).and.(lam_l.eq.1)).and.(jx.eq.2.5)) norm= 5.8d0 if(((lam_u.eq.1).and.(lam_l.eq.2)).and.(jx.eq.1.5)) norm= 2.d0 popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.d0*rju+1.d0) * dexp(-1.43877d0 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational s hnu = 1.9863d-23 * ramda_jj_inv ! photon energy in ergs trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8 & & * 4.80298d-10)**2* (re1**2)/(3.d0 * 6.6256d-27)) * s_jj & & * ramda_jj_inv**3 /norm e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0) ! emission po ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1 emisj(j) = e return end !*********************************************************************** subroutine calc_3P3P(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol,ls_u,ls_l) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) real*8 jmin, norm,jx,lm,lmu,lml jmin= real(j) ! Only for Hund's case Pi(b)-Pi(b) ! select case (k) go to (1,2,3,4,5,6,7,8,9,10, 11,12,13,14,15,16,17,18,19,20, & & 21,22,23,24,25,26,27) k ! case (1) ! P11 1 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0; su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (2) ! Q11 2 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0; su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (3) ! R11 3 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0; su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (4) ! qP21 4 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0; su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (5) ! rQ21 5 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0; su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (6) ! sR21 6 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0; su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (7) ! rP31 7 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (8) ! sQ31 8 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (9) ! tR31 9 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case(10) ! oP12 10 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(11) ! pQ12 11 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(12) ! qR12 12 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(13) ! P22 13 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(14) ! Q22 14 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(15) ! R22 15 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(16) ! qP32 16 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(17) ! rQ32 17 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(18) ! sR32 18 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(19) ! nP13 19 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(20) ! oQ13 20 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(21) ! pR13 21 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(22) ! oP23 22 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(23) ! pQ23 23 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(24) ! qR23 24 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(25) ! P33 25 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(26) ! Q33 26 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(27) ! R33 27 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 28 continue jx = rjl ! for 3sigma of o2 molecule, herzberg pp. 223, Compare with Eq.18 (pp.72) of Kovacs fpu = bvu*(rju+0.)*(rju+1.) + su1*(2.*rju+1.+su2)*bvu + su3*ls_u & & + su4*sqrt( ((2.*rju+1.+su2)*bvu)**2 + su5*ls_u**2 & & + su6*ls_u*bvu ) + su7*sou*(rju+su8) - dvu*(rju*(rju+1.))**2 fpl = bvl*(rjl+0.)*(rjl+1.) + sl1*(2.*rjl+1.+sl2)*bvl + su3*ls_l & & + sl4*sqrt( ((2.*rjl+1.+sl2)*bvl)**2 + sl5*ls_l**2 & & + su6*ls_l*bvl ) + sl7*sol*(rjl+sl8) - dvl*(rjl*(rjl+1.))**2 ! check this table and compare with the table in Tatum, 1966, Canadian Journal of Physics ! select case(k) ! case (1) ! P11 if(k.eq.1) then s_jj = jx*(jx-2.)*(2.*jx+1.)/3./(jx-1.)/(2.*jx-1.) if( jx .eq. 1.) s_jj= 0. end if ! case (2) ! Q11 if(k.eq.2) s_jj = (jx+1.)*(2.*jx+1.)/3./jx**3 ! case (3) ! R11 if(k.eq.3) s_jj = (jx+1.)*(jx-1.)*(2.*jx+3.)/3./jx/(2.*jx+1.) ! case (4) ! qP21 if(k.eq.4) then s_jj = (2.*jx+1.)/3./jx**3/(jx-1.) if( jx .eq. 1.) s_jj= 0. end if ! case (5) ! rQ21 if(k.eq.5) s_jj = (jx+1.)*(jx-1.)/3./jx**3 ! case (6) ! sR21 if(k.eq.6) s_jj = 0.0 ! case (7) ! rP31 if(k.eq.7) s_jj = (jx+1.)*(jx-1.)/3./jx**3/(2.*jx+1.)/(2.*jx-1.) ! case (8) ! sQ31 if(k.eq.8) s_jj = 0.0 ! case (9) ! tR31 if(k.eq.9) s_jj = 0.0 ! case (10) ! oP12 if(k.eq.10) s_jj = 0.0 ! case (11) ! pQ12 if(k.eq.11) s_jj = (jx-1.)*(jx+1.)/3./jx**3 ! case (12) ! qR12 if(k.eq.12) s_jj = (2.*jx+3.)/3./jx/(jx+1.)**3 ! case (13) ! P22 if(k.eq.13) s_jj = (jx+1.)**2*(jx-1.)**2/jx**3/3. ! case (14) ! Q22 if(k.eq.14) s_jj = (2.*jx+1.)*(jx**2+jx-1.)**2/ & & (3.*jx**3*(jx+1.)**3) ! case (15) ! R22 if(k.eq.15) s_jj = jx**2*(jx+2.)**2/(3.*(jx+1.)**3) ! case (16) ! qP32 if(k.eq.16) s_jj = (2.*jx-1.)/(3.*jx**3*(jx+1.)) ! case (17) ! rQ32 if(k.eq.17) s_jj = jx*(jx+2.)/(3.*(jx+1.)**3) ! case (18) ! sR32 if(k.eq.18) s_jj = 0.0 ! case (19) ! nP13 if(k.eq.19) s_jj = 0.0 ! case (20) ! oQ13 if(k.eq.20) s_jj = 0.0 ! case (21) ! pR13 if(k.eq.21) s_jj = jx*(jx+2.)/(jx+1.)**3/(2.*jx+3.)/(2.*jx+1.)/3. ! case (22) ! oP23 if(k.eq.22) s_jj = 0.0 ! case (23) ! pQ23 if(k.eq.23) s_jj = jx*(jx+2.)/3./(jx+1.)**3 ! case (24) ! qR23 if(k.eq.24) s_jj = (2.*jx+1.)/3./(jx+2.)/(jx+1.)**3 ! case (25) ! P33 if(k.eq.25) s_jj = jx*(jx+2.)*(2.*jx-1.)/3./(jx+1.)/(2.*jx+1.) ! case (26) ! Q33 if(k.eq.26) s_jj = jx*(2.*jx+1.)/3./(jx+1.)**3 ! case (27) ! R33 if(k.eq.27) s_jj=(jx+3.)*(jx+1.)*(2.*jx+1.)/3./(jx+2.)/(2.*jx+3.) ! end select ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv norm = 2.*rjl+1. if(rjl.eq.1.) norm= 4. popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational s hnu = 1.9863e-23 * ramda_jj_inv ! photon energy trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8 & & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) & & * s_jj * ramda_jj_inv**3/norm e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! emission power ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_3S3P(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) real*8 jx select case (k) case (1) ! P11 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case (2) ! Q11 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case (3) ! R11 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case (4) ! qP21 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case (5) ! rQ21 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case (6) ! sR21 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case (7) ! rP31 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case (8) ! sQ31 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case (9) ! tR31 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 case(10) ! oP12 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(11) ! pQ12 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(12) ! qR12 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(13) ! P22 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(14) ! Q22 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(15) ! R22 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(16) ! qP32 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(17) ! rQ32 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(18) ! sR32 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 case(19) ! nP13 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 case(20) ! oQ13 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 case(21) ! pR13 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 case(22) ! oP23 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 case(23) ! pQ23 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 case(24) ! qR23 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 case(25) ! P33 rju = real(j) - 0.0; rjl = real(j) + 1.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 case(26) ! Q33 rju = real(j) - 0.0; rjl = real(j) + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 case(27) ! R33 rju = real(j) + 1.0; rjl = real(j) + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 end select yu = sou/bvu yl = sol/bvl yx = yl jx = rjl if (lam_u .gt. lam_l) then yx = yu jx = rju end if ! herzberg pp. 235 zu1 = lam_u**2*yu*(yu-4.) + 4./3. + 4.*rju*(rju+1.) zl1 = lam_l**2*yl*(yl-4.) + 4./3. + 4.*rjl*(rjl+1.) zu2 = (lam_u**2*yu*(yu-1.) - 4./9. - 2.*rju*(rju+1.) ) / (3.*zu1) zl2 = (lam_l**2*yl*(yl-1.) - 4./9. - 2.*rjl*(rjl+1.) ) / (3.*zl1) fpu = bvu*(rju*(rju+1.) + su2*sqrt(zu1) + su3*zu2) + su4*dvu & & *(rju+su5)**4 fpl = bvl*(rjl*(rjl+1.) + su2*sqrt(zl1) + su3*zl2) + su4*dvl & & *(rjl+su5)**4 ! 1u: su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 ! 1l: sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 ! 2u: su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 ! 2l: sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 ! 3u: su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 ! 3l: sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 ! a.schadee pp. 326, compare with kovacs, the last term of +-lam*(y-2) shown at pp.80 is n ! see Budo 1937 also u1 = sqrt(yx*(yx-4.) + 4.*(jx+0.)**2) u3 = sqrt(yx*(yx-4.) + 4.*(jx+1.)**2) if(yx.ge.0) then c1 = jx*(jx+1.)*yx*(yx-4.) + 2.*jx*(2.*jx+1.)*(jx-1.)*(jx+1.) c2 = yx*(yx-4.) + 4.*jx*(jx+1.) c3 = (jx+2.)*(jx-1.)*yx*(yx-4.) + 2.*jx*(2.*jx+1.)*(jx+1.) & & *(jx+2.) else c1 = (jx+2.)*(jx-1.)*yx*(yx-4.) + 2.*jx*(2.*jx+1.)*(jx-1.) & & *(jx+1.) c2 = yx*(yx-4.) + 4.*jx*(jx+1.) c3 = jx*(jx+1.)*yx*(yx-4.) + 2.*jx*(2.*jx+1.)*(jx+1.)*(jx+2.) endif if ( lam_l .gt. lam_u ) then ! 3S-3P select case(k) case (1) ! P11 s_jj = ( (jx**2-1.)*((jx+1.)*u1 - yx + 2.*jx**2)**2 ) / & & (12.*(2.*jx-1.)*c1) case (2) ! Q11 s_jj = ( (jx**2+jx-1.0)*u1 + (yx - 2.0)+ 2.0*jx*(jx**2-1.0) )**2/ & & (12.*jx*c1) case (3) ! R11 s_jj = (jx*(jx+2.)*u1 + (jx+2.)*(yx-2.) + 2.*(jx-1.)*(jx+1.)**2) & & **2 *jx / (12.*(jx+1.)*(2.*jx+3.)*c1) case (4) ! qP21 s_jj = (jx**2-1.)*((jx+1.)*(yx-2.) - u1)**2 / (12.*jx*c1) case (5) ! rQ21 s_jj = (2.*jx+1.)*((jx**2+jx-1.)*(yx-2.) + u1)**2 / & & (12.*jx*(jx+1.)*c1) case (6) ! sR21 s_jj = jx*(jx+2.)*(jx*(yx-2.) + u1)**2 / (12.*(jx+1.)*c1) case (7) ! rP31 s_jj = (jx-1.)**2*(jx+1.)*((jx+1.)*u1 - (yx-2.) - 2.*jx*(jx+1.)) & & **2 / (12.*jx*(2.*jx-1.)*c1) case (8) ! sQ31 s_jj = ((jx**2+jx-1.)*u1 + yx - 2. - 2.*(jx-1.)*(jx+1.)**2 )**2 / & & (12.*(jx+1.)*c1) case (9) ! tR31 s_jj = jx*(jx+2.)*(jx*u1 + yx - 2.*jx**2)**2 / (12.*(2.*jx+3.)*c1) case(10) ! oP12 s_jj = 2.*(jx**2-1.)*yx**2 / (12.*(2.*jx-1.)*c2) case(11) ! pQ12 s_jj = 2.*(jx*(yx-2.) - 2.)**2 / (12.*jx*c2) case(12) ! qR12 s_jj = 2.*jx*((jx+1.)*yx - 2.*(2.*jx+3.))**2 / & & (12.*(jx+1)*(2.*jx+3)*c2) case(13) ! P22 s_jj = 8.*(jx+1.)**3*(jx-1.) / (12.*jx*c2) case(14) ! Q22 s_jj = 8.*(2.*jx+1.)*(jx**2+jx-1.)**2 / (12.*jx*(jx+1.)*c2) case(15) ! R22 s_jj = 8.*jx**3*(jx+2.) / (12.*(jx+1.)*c2) case(16) ! qP32 s_jj = 2.*(jx+1.)*(jx*(yx-4.) + 2.)**2 / (12.*jx*(2.*jx-1.)*c2) case(17) ! rQ32 s_jj = 2.*((jx+1.)*yx - 2.*jx)**2 / (12.*(jx+1.)*c2) case(18) ! sR32 s_jj = 2.*jx*(jx+2.)*yx**2 / (12.*(2.*jx+3.)*c2) case(19) ! nP13 s_jj = (jx**2-1.)*((jx+1.)*u3 + yx - 2. - 2.*jx*(jx+2.))**2 / & & (12.*(2.*jx-1.)*c3) case(20) ! oQ13 s_jj = ((jx**2+jx-1.)*u3 -(yx-2.) - 2.*jx**2*(jx+2.))**2 / & & (12.*jx*c3) case(21) ! pR13 s_jj = jx*(jx+2.)**2*(jx*u3 - (yx-2.) - 2.*jx*(jx+1.))**2 / & & (12.*(jx+1.)*(2.*jx+3.)*c3) case(22) ! oP23 s_jj = (jx**2-1.)*(u3 + (jx+1.)*(jx-2.))**2 / (12.*jx*c3) case(23) ! pQ23 s_jj = (2.*jx+1.)*((jx**2+jx-1.)*(yx-2.) - u3)**2 / & & (12.*jx*(jx+1.)*c3) case(24) ! qR23 s_jj = jx*(jx+2.)*(jx*(yx-2.) - u3)**2 / (12.*(jx+1.)*c3) case(25) ! P33 s_jj = (jx+1.)*((jx**2-1.)*u3 + (jx-1.)*(yx-2.) + 2.*jx**2 & & *(jx+2.))**2 / (12.*jx*(2.*jx-1.)*c3) case(26) ! Q33 s_jj = ((jx**2+jx-1.)*u3 - (yx-2.) + 2.*jx*(jx+1.)*(jx+2.))**2 / & & (12.*(jx+1.)*c3) case(27) ! R33 s_jj = jx*(jx+2.)*(jx*u3 - (yx-2.) + 2.*jx*(jx+2))**2 / & & (12.*(2.*jx+3.)*c3) end select end if if ( lam_u .gt. lam_l ) then ! 3P-3S select case(k) case (1) ! P11 s_jj = (jx*(jx+2.)*u1 + (jx+2.)*(yx-2.) + 2.*(jx-1.)*(jx+1.)**2 ) & & **2 *jx / (12.*(jx+1.)*(2.*jx+3.)*c1) case (2) ! Q11 s_jj = ( (jx**2+jx-1.0)*u1 + (yx - 2.0) + 2.0*jx*(jx**2-1.0) )**2 & & / (12.*jx*c1) case (3) ! R11 s_jj = ( (jx**2-1.)*((jx+1.)*u1 - yx + 2.*jx**2)**2 ) / & & (12.*(2.*jx-1.)*c1) case (4) ! qP21 s_jj = 2.*jx*((jx+1.)*yx - 2.*(2.*jx+3.))**2 / (12.*(jx+1) & & *(2.*jx+3)*c2) case (5) ! rQ21 s_jj = 2.*(jx*(yx-2.) - 2.)**2 / (12.*jx*c2) case (6) ! sR21 s_jj = 2.*(jx**2-1.)*yx**2 / (12.*(2.*jx-1.)*c2) case (7) ! rP31 s_jj = jx*(jx+2.)**2*(jx*u3 - (yx-2.) - 2.*jx*(jx+1.))**2 / & & (12.*(jx+1.)*(2.*jx+3.)*c3) case (8) ! sQ31 s_jj = ((jx**2+jx-1.)*u3 -(yx-2.) - 2.*jx**2*(jx+2.))**2 / & & (12.*jx*c3) case (9) ! tR31 s_jj = (jx**2-1.)*((jx+1.)*u3 + yx - 2. - 2.*jx*(jx+2.))**2 / & & (12.*(2.*jx-1.)*c3) case(10) ! oP12 s_jj = jx*(jx+2.)*(jx*(yx-2.) + u1)**2 / (12.*(jx+1.)*c1) case(11) ! pQ12 s_jj = (2.*jx+1.)*((jx**2+jx-1.)*(yx-2.) + u1)**2 / & & (12.*jx*(jx+1.)*c1) case(12) ! qR12 s_jj = (jx**2-1.)*((jx+1.)*(yx-2.) - u1)**2 / (12.*jx*c1) case(13) ! P22 s_jj = 8.*jx**3*(jx+2.) / (12.*(jx+1.)*c2) case(14) ! Q22 s_jj = 8.*(2.*jx+1.)*(jx**2+jx-1.)**2 / (12.*jx*(jx+1.)*c2) case(15) ! R22 s_jj = 8.*(jx+1.)**3*(jx-1.) / (12.*jx*c2) case(16) ! qP32 s_jj = jx*(jx+2.)*(jx*(yx-2.) - u3)**2 / (12.*(jx+1.)*c3) case(17) ! rQ32 s_jj = (2.*jx+1.)*((jx**2+jx-1.)*(yx-2.) - u3)**2 / & & (12.*jx*(jx+1.)*c3) case(18) ! sR32 s_jj = (jx**2-1.)*(u3 + (jx+1.)*(jx-2.))**2 / (12.*jx*c3) case(19) ! nP13 s_jj = jx*(jx+2.)*(jx*u1 + yx - 2.*jx**2)**2 / (12.*(2.*jx+3.)*c1) case(20) ! oQ13 s_jj = ((jx**2+jx-1.)*u1 + yx - 2. - 2.*(jx-1.)*(jx+1.)**2 )**2 / & & (12.*(jx+1.)*c1) case(21) ! pR13 s_jj = (jx-1.)**2*(jx+1.)*((jx+1.)*u1 - (yx-2.) - 2.*jx*(jx+1.)) & & **2 / (12.*jx*(2.*jx-1.)*c1) case(22) ! oP23 s_jj = 2.*jx*(jx+2.)*yx**2 / (12.*(2.*jx+3.)*c2) case(23) ! pQ23 s_jj = 2.*((jx+1.)*yx - 2.*jx)**2 / (12.*(jx+1.)*c2) case(24) ! qR23 s_jj = 2.*(jx+1.)*(jx*(yx-4.) + 2.)**2 / (12.*jx*(2.*jx-1.)*c2) case(25) ! P33 s_jj = jx*(jx+2.)*(jx*u3 - (yx-2.) + 2.*jx*(jx+2))**2 / & & (12.*(2.*jx+3.)*c3) case(26) ! Q33 s_jj = ((jx**2+jx-1.)*u3 - (yx-2.) + 2.*jx*(jx+1.)*(jx+2.))**2 / & & (12.*(jx+1.)*c3) case(27) ! R33 s_jj = (jx+1.)*((jx**2-1.)*u3 + (jx-1.)*(yx-2.)+ 2.*jx**2*(jx+2.)) & & **2 / (12.*jx*(2.*jx-1.)*c3) end select end if ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational s hnu = 1.9863e-23 * ramda_jj_inv ! photon energy trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8 & & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) & & * s_jj * ramda_jj_inv**3/(2.*jx+1.) e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! emission power ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !********************************************************************* subroutine calc_3S3S(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol,ls_u,ls_l) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) real*8 jmin,jx,lm,lmu,lml jmin= real(j) sum_fact = 6. ! This table was not verified ! ! select case (k) go to (1,2,3,4,5,6,7,8,9,10, 11,12,13,14,15,16,17,18,19,20, & & 21,22,23,24,25,26,27) k ! case (1) ! P11 1 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (2) ! Q11 2 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (3) ! R11 3 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (4) ! qP21 4 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (5) ! rQ21 5 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (6) ! sR21 6 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (7) ! rP31 7 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (8) ! sQ31 8 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case (9) ! tR31 9 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0 sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 go to 28 ! case(10) ! oP12 10 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(11) ! pQ12 11 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(12) ! qR12 12 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 ! case(13) ! P22 13 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(14) ! Q22 14 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(15) ! R22 15 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(16) ! qP32 16 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(17) ! rQ32 17 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(18) ! sR32 18 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0 sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 go to 28 ! case(19) ! nP13 19 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(20) ! oQ13 20 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(21) ! pR13 21 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0 su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(22) ! oP23 22 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(23) ! pQ23 23 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(24) ! qR23 24 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0 su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(25) ! P33 25 continue rju = jmin - 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(26) ! Q33 26 continue rju = jmin - 0.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! case(27) ! R33 27 continue rju = jmin + 1.0; rjl = jmin + 0.0 su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0 su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0 sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 go to 28 ! end select 28 continue jx = rjl ! for 3sigma of o2 molecule, herzberg pp. 223, Compare with Eq.18 (pp.72) of Kovacs fpu = bvu*(rju+0.)*(rju+1.) + su1*(2.*rju+1.+su2)*bvu + su3*ls_u & & + su4*dsqrt( ((2.*rju+1.+su2)*bvu)**2 + su5*ls_u**2 & & + su6*ls_u*bvu ) + su7*sou*(rju+su8) - dvu*(rju*(rju+1.))**2 fpl = bvl*(rjl+0.)*(rjl+1.) + sl1*(2.*rjl+1.+sl2)*bvl + su3*ls_l & & + sl4*sqrt( ((2.*rjl+1.+sl2)*bvl)**2 + sl5*ls_l**2 & & + su6*ls_l*bvl ) + sl7*sol*(rjl+sl8) - dvl*(rjl*(rjl+1.))**2 ! 1u: su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0; su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 ! 1l: sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 ! 2u: su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0; su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 ! 2l: sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0; sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 ! 3u: su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0; su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 ! 3l: sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0; sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 ! check this table and compare with the table in Tatum, 1966, Canadian Journal of Physics ! select case(k) ! case (1) ! P11 if(k.eq.1) & & s_jj = (jx-1.)*(2.*jx+1.)/(2.*jx-1.)/sum_fact ! check this formula ! case (2) ! Q11 if(k.eq.2) & & s_jj = (jx-0.)*(2.*jx+3.)/(2.*jx-1.)/sum_fact ! case (3) ! R11 if(k.eq.3) & & s_jj = (jx-0.)*(2.*jx+3.)/(2.*jx-1.)/sum_fact ! case (4) ! qP21 if(k.eq.4) s_jj = 0.0 ! case (5) ! rQ21 if(k.eq.5) s_jj = 1./jx/sum_fact ! case (6) ! sR21 if(k.eq.6) s_jj = 0.0 ! case (7) ! rP31 if(k.eq.7) s_jj = 1./jx/(2.*jx-1.)/(2.*jx+1.)/sum_fact ! case (8) ! sQ31 if(k.eq.8) s_jj = 0.0 ! case (9) ! tR31 if(k.eq.9) s_jj = 0.0 ! case (10) ! oP12 if(k.eq.10) s_jj = 0.0 ! case (11) ! pQ12 if(k.eq.11) s_jj = 1./jx/sum_fact ! case (12) ! qR12 if(k.eq.12) s_jj = 0.0 ! case (13) ! P22 if(k.eq.13) s_jj = (jx-1.)*(jx+1.)/(jx+0.)/sum_fact ! case (14) ! Q22 if(k.eq.14) s_jj = (jx-0.)*(jx+2.)/(jx+1.)/sum_fact ! case (15) ! R22 if(k.eq.15) s_jj = (jx-0.)*(jx+2.)/(jx+1.)/sum_fact ! case (16) ! qP32 if(k.eq.16) s_jj = 0.0 ! case (17) ! rQ32 if(k.eq.17) s_jj = 1./(jx+1.) ! case (18) ! sR32 if(k.eq. 18) s_jj = 0.0 ! case (19) ! nP13 if(k.eq.19) s_jj = 0.0 ! case (20) ! oQ13 if(k.eq.20) s_jj = 0.0 ! case (21) ! pR13 if(k.eq.21) s_jj = 1./(jx+1.)/(2.*jx+1.)/(2.*jx+3.)/sum_fact ! case (22) ! oP23 if(k.eq.22) s_jj = 0.0 ! case (23) ! pQ23 if(k.eq.23) s_jj = 1./(jx+1.)/sum_fact ! case (24) ! qR23 if(k.eq.24) s_jj = 0.0 ! case (25) ! P33 if(k.eq.2) s_jj = (jx+1.)*(2.*jx-1.)/(2.*jx+1.)/sum_fact ! case (26) ! Q33 if(k.eq.26) s_jj = (jx+2.)*(2.*jx+1.)/(2.*jx+3.)/sum_fact ! case (27) ! R33 if(k.eq.27) s_jj = (jx+2.)*(2.*jx+1.)/(2.*jx+3.)/sum_fact ! end select ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * dexp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational hnu = 1.9863e-23 * ramda_jj_inv ! photon energy trans_prob=(64.0*(3.1415916**4)*(0.529167e-8 * 4.80298e-10)**2 & & * (re1**2)/(3.0 * 6.6256e-27)) * s_jj * ramda_jj_inv**3/ & & (2.*rjl+1.) e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! emission power ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_3X3X(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) real*8 jx,lm,lmu,lml,l21,l22,l41,l42,jmin,norm ! s_sum = 0. ! do m=1, 20 jmin= real(j) ! do k=1, 27 ! When Y=0, Sum-Rule is exactrly satisfied, ! but when Y.ne.0, small errors (less than 0.5) ! select case (k) go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, & & 21,22,23,24,25,26,27) k ! case (1) ! P11 1 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0 go to 28 ! case (2) ! Q11 2 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0 go to 28 ! case (3) ! R11 3 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0 go to 28 ! case (4) ! qP21 4 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0 go to 28 ! case (5) ! rQ21 5 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0 go to 28 ! case (6) ! sR21 6 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0 go to 28 ! case (7) ! rP31 7 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0 go to 28 ! case (8) ! sQ31 8 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0 go to 28 ! case (9) ! tR31 9 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0 go to 28 ! case(10) ! oP12 10 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(11) ! pQ12 11 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(12) ! qR12 12 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(13) ! P22 13 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5= 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(14) ! Q22 14 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(15) ! R22 15 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(16) ! qP32 16 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(17) ! rQ32 17 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(18) ! sR32 18 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0 go to 28 ! case(19) ! nP13 19 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0 go to 28 ! case(20) ! oQ13 20 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0 go to 28 ! case(21) ! pR13 21 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0 go to 28 ! case(22) ! oP23 22 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0 go to 28 ! case(23) ! pQ23 23 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0 go to 28 ! case(24) ! qR23 24 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0 go to 28 ! case(25) ! P33 25 continue rju = jmin - 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0 u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0 go to 28 ! case(26) ! Q33 26 continue rju = jmin - 0.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0 u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0 go to 28 ! case(27) ! R33 27 continue rju = jmin + 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0 u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0 go to 28 ! end select 28 continue yu = sou/bvu; yl = sol/bvl ! yu = 0.; yl= 0. jx = rjl ; lm = real(lam_l) lmu = real(lam_u); lml= real(lam_l) if( yu .lt. 0. ) then yu = -yu; lmu= -real(lam_u) end if if( yl .lt. 0. ) then yl= -yl; lml= -real(lam_l) end if zu1 = lam_u**2*yu*(yu-4.) + 4./3. + 4.*rju*(rju+1.) zu2 = (lam_u**2*yu*(yu-1.) - 4./9. - 2.*rju*(rju+1.)) / (3.*zu1) zl1 = lam_l**2*yl*(yl-4.) + 4./3. + 4.*rjl*(rjl+1.) zl2 = (lam_l**2*yl*(yl-1.) - 4./9. - 2.*rjl*(rjl+1.)) / (3.*zl1) fpu = bvu*(rju*(rju+1.) + su2*sqrt(zu1) + su3*zu2) & & + su4*dvu*(rju+su5)**4 fpl = bvl*(rjl*(rjl+1.) + su2*sqrt(zl1) + su3*zl2) & & + su4*dvl*(rjl+su5)**4 u1u = sqrt(lam_u**2*yu*(yu-4.) + 4.*(rju+u11)**2) & & + u12*lam_u*(yu-2.) u2l = sqrt(lam_l**2*yl*(yl-4.) + 4.*(rjl+l21)**2) & & + l22*lam_l*(yl-2.) u3u = sqrt(lam_u**2*yu*(yu-4.) + 4.*(rju+u31)**2) & & + u32*lam_u*(yu-2.) u4l = sqrt(lam_l**2*yl*(yl-4.) + 4.*(rjl+l41)**2) & & + l42*lam_l*(yl-2.) c1u = lmu**2*yu*(yu-4)*(rju-lmu+1.)*(rju+lmu) + 2.*(2.*rju+1) & & *(rju-lmu)*rju*(rju+lmu) c1l = lml**2*yl*(yl-4)*(rjl-lml+1.)*(rjl+lml) + 2.*(2.*rjl+1) & & *(rjl-lml)*rjl*(rjl+lml) c2u = lmu**2*yu*(yu-4.) + 4.*rju*(rju+1.) c2l = lml**2*yl*(yl-4.) + 4.*rjl*(rjl+1.) c3u = lmu**2*yu*(yu-4)*(rju-lmu)*(rju+lmu+1.) + 2.*(2.*rju+1) & & *(rju-lmu+1.)*(rju+1.)*(rju+lmu+1.) c3l = lml**2*yl*(yl-4)*(rjl-lml)*(rjl+lml+1.) + 2.*(2.*rjl+1) & & *(rjl-lml+1.)*(rjl+1.)*(rjl+lml+1.) if(c1u.eq.0.) c1u=1.e5; if(c1l.eq.0.) c1l=1.e5 if(c2u.eq.0.) c2u=1.e5; if(c2l.eq.0.) c2l=1.e5 if(c3u.eq.0.) c3u=1.e5; if(c3l.eq.0.) c3l=1.e5 ! select case(k) ! case (1) ! p11 if(k.eq.1) then s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+1.)*u3u*u4l+ 8.*(jx-lm-1.)*(jx-lm) & & *(jx+lm-1.)*(jx+lm))**2 /(16.*jx*c1u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (2) ! q11 if(k.eq.2) then s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u*u2l & & + (lm+1.)*(jx-lm)*(jx+lm+1.)*u3u*u4l+ 8.*lm*(jx-lm)**2 & & *(jx+lm)**2)**2 /(16.*jx*(jx+1.)*c1u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. s_sum= s_sum + s_jj end if ! case (3) ! r11 if(k.eq.3) then s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u*u2l & & + (jx-lm)*(jx+lm+2.)*u3u*u4l + 8.*(jx-lm)*(jx-lm+1.) & & *(jx+lm)*(jx+lm+1.))**2 /(16.*(jx+1.)*c1u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (4) ! qp21 if(k.eq.4) then s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u2l - (jx-lm-1.) & & *(jx+lm+1.)*u4l - 2.*lm*(jx-lm)*(jx+lm)*(yu-2.))**2 / & & (2.*jx*c2u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (5) ! rq21 if(k.eq.5) then s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u2l - (lm+1.) & & *(jx-lm)*(jx+lm+1.)*u4l- 2.*lm**2*(jx-lm)*(jx+lm)*(yu-2.)) & & **2 /(2.*jx*(jx+1.)*c2u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (6) ! sr21 if(k.eq.6) then s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u2l - (jx-lm) & & *(jx+lm+2.)*u4l - 2.*lm*(jx-lm)*(jx+lm)*(yu-2.))**2 / & & (2.*(jx+1.)*c2u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (7) ! rp31 if(k.eq.7) then s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+1.)*u3u*u4l- 8.*(jx-lm)*(jx-lm)*(jx+lm) & & *(jx+lm))**2 /(16.*jx*c3u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (8) ! sq31 if(k.eq.8) then s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u*u2l + (lm+1.) & & *(jx-lm)*(jx+lm+1.)*u3u*u4l - 8.*lm*(jx-lm)*(jx-lm+1.)*(jx+lm) & & *(jx+lm+1.))**2 /(16.*jx*(jx+1.)*c3u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (9) ! tr31 if(k.eq.9) then s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u*u2l & & + (jx-lm)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+2.)*(jx+lm) & & *(jx+lm+2.))**2 /(16.*(jx+1.)*c3u*c1l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (10) ! op12 if(k.eq.10) then s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u - (jx-lm-1.) & & *(jx+lm+1.)*u3u - 2.*lm*(jx-lm-1.)*(jx+lm-1.)*(yl-2.))**2 / & & (2.*jx*c1u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (11) ! pq12 if(k.eq.11) then s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u - (lm+1.) & & *(jx-lm)*(jx+lm+1.)*u3u - 2.*lm**2*(jx-lm)*(jx+lm)*(yl-2.)) & & **2 /(2.*jx*(jx+1.)*c1u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (12) ! qr12 if(k.eq.12) then s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u - (jx-lm) & & *(jx+lm+2.)*u3u - 2.*lm*(jx-lm+1.)*(jx+lm+1.)*(yl-2.))**2 / & & (2.*(jx+1.)*c1u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (13) ! p22 if(k.eq.13) then s_jj = 4.*(jx-lm)*(jx+lm)*(0.5*lm**2*(yu-2.)*(yl-2.) & & + (jx-lm-1.)*(jx+lm+1.) + (jx-lm+1.)*(jx+lm-1.))**2 / & & (jx*c2u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (14) ! q22 if(k.eq.14) then s_jj = 4.*(2.*jx+1.)*(0.5*lm**3*(yu-2.)*(yl-2.) + (lm+1.) & & *(jx-lm)*(jx+lm+1.) + (lm-1.)*(jx-lm+1.)*(jx+lm))**2 / & & (jx*(jx+1.)*c2u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (15) ! r22 if(k.eq.15) then s_jj = 4.*(jx-lm+1.)*(jx+lm+1.)*(0.5*lm**2*(yu-2.)*(yl-2.) & & + (jx-lm)*(jx+lm+2.) + (jx-lm+2.)*(jx+lm))**2 /((jx+1.) & & *c2u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (16) ! qp32 if(k.eq.16) then s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u - (jx-lm-1.) & & *(jx+lm+1.)*u3u + 2.*lm*(jx-lm)*(jx+lm)*(yl-2.))**2 / & & (2.*jx*c3u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (17) ! rq32 if(k.eq.17) then s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u - (lm+1.) & & *(jx-lm)*(jx+lm+1.)*u3u + 2.*lm**2*(jx-lm+1.)*(jx+lm+1.) & & *(yl-2.))**2 /(2.*jx*(jx+1.)*c3u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (18) ! sr32 if(k.eq.18) then s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u - (jx-lm) & & *(jx+lm+2.)*u3u + 2.*lm*(jx-lm+2.)*(jx+lm+2.)*(yl-2.))**2 / & & (2.*(jx+1.)*c3u*c2l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (19) ! np13 if(k.eq.19) then s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+1.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm+1.) & & *(jx+lm-1.)*(jx+lm+1.))**2 /(16.*jx*c1u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (20) ! oq13 if(k.eq.20) then s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u*u2l + (lm+1.) & & *(jx-lm)*(jx+lm+1.)*u3u*u4l -8.*lm*(jx-lm)*(jx-lm+1.)*(jx+lm) & & *(jx+lm+1.))**2 /(16.*jx*(jx+1.)*c1u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (21) ! pr13 if(k.eq.21) then s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u*u2l & & + (jx-lm)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm+1.)**2*(jx+lm+1.)**2) & & **2 /(16.*(jx+1.)*c1u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (22) ! op23 if(k.eq.22) then s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u2l - (jx-lm-1.) & & *(jx+lm+1.)*u4l + 2.*lm*(jx-lm+1.)*(jx+lm+1.)*(yu-2.))**2 / & & (2.*jx*c2u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (23) ! pq23 if(k.eq.23) then s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u2l - (lm+1.) & & *(jx-lm)*(jx+lm+1.)*u4l + 2.*lm**2*(jx-lm+1.)*(jx+lm+1.) & & *(yu-2.))**2 /(2.*jx*(jx+1.)*c2u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (24) ! qr23 if(k.eq.24) then s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u2l - (jx-lm) & & *(jx+lm+2.)*u4l + 2.*lm*(jx-lm+1.)*(jx+lm+1.)*(yu-2.))**2 / & & (2.*(jx+1.)*c2u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (25) ! p33 if(k.eq.25) then s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+1.)*u3u*u4l + 8.*(jx-lm)*(jx-lm+1.) & & *(jx+lm)*(jx+lm+1.))**2 /(16.*jx*c3u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (26) ! q33 if(k.eq.26) then s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u*u2l + (lm+1.) & & *(jx-lm)*(jx+lm+1.)*u3u*u4l + 8.*lm*(jx-lm+1.)**2*(jx+lm+1.) & & **2)**2 / (16.*jx*(jx+1.)*c3u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ! case (27) ! r33 if(k.eq.27) then s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u*u2l & & + (jx-lm)*(jx+lm+2.)*u3u*u4l + 8.*(jx-lm+1.)*(jx-lm+2.) & & *(jx+lm+1.)*(jx+lm+2.))**2 /(16.*(jx+1.)*c3u*c3l) /3. if(s_jj .lt. 0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end if ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv norm = 2.*rjl+1. if( (lam_u.eq.1).and.(rjl.eq.1.).and.(yu.eq.0.).and.(yl.eq.0.)) & & norm= 1.66667 if( (lam_u.eq.2).and.(rjl.eq.1.).and.(yu.eq.0.).and.(yl.eq.0.)) & & norm= 7.16715 if( (lam_u.eq.2).and.(rjl.eq.2.).and.(yu.eq.0.).and.(yl.eq.0.)) & & norm= 2.83333 ! C2 Swan if( (lam_u.eq.1).and.(rjl.eq.1.) ) norm= 1.2133831 if( (lam_u.eq.1).and.(rjl.eq.2.) ) norm= 4.5492405 if( (lam_u.eq.1).and.(rjl.eq.3.) ) norm= 7.75791 if( (lam_u.eq.1).and.(rjl.eq.4.) ) norm= 9.3495579 ! N2 2+ if( (lam_u.eq.1).and.(rjl.eq.1.) ) norm= 2.5890816 if( (lam_u.eq.1).and.(rjl.eq.2.) ) norm= 5.2574128 popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational s hnu = 1.9863e-23 * ramda_jj_inv ! photon energy trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8 & & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) * s_jj & & * ramda_jj_inv**3/norm e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! emission power ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_3X3Y(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) real*8 jmin,norm,jx,lm,lmu,lml,l21,l22,u31,u32,l41,l42 sum_fact = 1. if( (lam_u.eq.0).and.(lam_l.eq.1) ) sum_fact= 2. ! s_sum= 0. ! do m=1, 10 jmin = real(j) ! do k= 1, 27 ! when Y= 0 and DL=+1, sum_rule is correct, ! When Y= 0 and Dl=-1, sum_rule has small error (less than 0.5) ! When Y.ne.0, sum_rule has small error (less than 0.5) select case (k) case (1) ! P11 rju = jmin - 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0 case (2) ! Q11 rju = jmin - 0.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0 case (3) ! R11 rju = jmin + 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0 case (4) ! qP21 rju = jmin - 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0 case (5) ! rQ21 rju = jmin - 0.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0 case (6) ! sR21 rju = jmin + 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0 case (7) ! rP31 rju = jmin - 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0 case (8) ! sQ31 rju = jmin - 0.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0 case (9) ! tR31 rju = jmin + 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0 case(10) ! oP12 rju = jmin - 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0 case(11) ! pQ12 rju = jmin - 0.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0 case(12) ! qR12 rju = jmin + 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0 case(13) ! P22 rju = jmin - 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0 case(14) ! Q22 rju = jmin - 0.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0 case(15) ! R22 rju = jmin + 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0 u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0 case(16) ! qP32 rju = jmin - 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0 case(17) ! rQ32 rju = jmin - 0.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0 case(18) ! sR32 rju = jmin + 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 0.0; sl3= 4.0; sl4= -1.0; sl5 = 0.5 u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0 u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0 case(19) ! nP13 rju = jmin - 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0 case(20) ! oQ13 rju = jmin - 0.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0 case(21) ! pR13 rju = jmin + 1.0; rjl = jmin + 0.0 su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0 case(22) ! oP23 rju = jmin - 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0 case(23) ! pQ23 rju = jmin - 0.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0 case(24) ! qR23 rju = jmin + 1.0; rjl = jmin + 0.0 su2= 0.0; su3= 4.0; su4= -1.0; su5 = 0.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0 u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0 case(25) ! P33 rju = jmin - 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0 u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0 case(26) ! Q33 rju = jmin - 0.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0 u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0 case(27) ! R33 rju = jmin + 1.0; rjl = jmin + 0.0 su2= 1.0; su3= -2.0; su4= -1.0; su5 = 1.5 sl2= 1.0; sl3= -2.0; sl4= -1.0; sl5 = 1.5 u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0 u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0 end select yu = sou/bvu yl = sol/bvl jx = rjl lm = real(lam_l) if( lam_l .gt. lam_u) then jx = rju; lm = lam_u end if if( yu .lt. 0. ) then yu = -yu; lmu = -real(lam_u) end if if( yl .lt. 0. ) then yl= -yl; lml = -real(lam_l) end if zu1 = lam_u**2*yu*(yu-4.) + 4./3. + 4.*rju*(rju+1.) zu2 = (lam_u**2*yu*(yu-1.) - 4./9. - 2.*rju*(rju+1.)) / (3.*zu1) zl1 = lam_l**2*yl*(yl-4.) + 4./3. + 4.*rjl*(rjl+1.) zl2 = (lam_l**2*yl*(yl-1.) - 4./9. - 2.*rjl*(rjl+1.)) / (3.*zl1) fpu = bvu*(rju*(rju+1.) + su2*sqrt(zu1) + su3*zu2) & & + su4*dvu*(rju+su5)**4 fpl = bvl*(rjl*(rjl+1.) + su2*sqrt(zl1) + su3*zl2) & & + su4*dvl*(rjl+su5)**4 u1u = sqrt(lam_u**2*yu*(yu-4.) + 4.*(rju+u11)**2) & & + u12*lam_u*(yu-2.) u2l = sqrt(lam_l**2*yl*(yl-4.) + 4.*(rjl+l21)**2) & & + l22*lam_l*(yl-2.) u3u = sqrt(lam_u**2*yu*(yu-4.) + 4.*(rju+u31)**2) & & + u32*lam_u*(yu-2.) u4l = sqrt(lam_l**2*yl*(yl-4.) + 4.*(rjl+l41)**2) & & + l42*lam_l*(yl-2.) lmu = real(lam_u) lml = real(lam_l) if( yu .lt. 0. ) lmu = -real(lam_u) if( yl .lt. 0. ) lml = -real(lam_l) c1u = lmu**2*yu*(yu-4)*(rju-lmu+1.)*(rju+lmu) + 2.*(2.*rju+1) & & *(rju-lmu)*rju*(rju+lmu) c1l = lml**2*yl*(yl-4)*(rjl-lml+1.)*(rjl+lml) + 2.*(2.*rjl+1) & & *(rjl-lml)*rjl*(rjl+lml) c2u = lmu**2*yu*(yu-4.) + 4.*rju*(rju+1.) c2l = lml**2*yl*(yl-4.) + 4.*rjl*(rjl+1.) c3u = lmu**2*yu*(yu-4)*(rju-lmu)*(rju+lmu+1.) + 2.*(2.*rju+1) & & *(rju-lmu+1.)*(rju+1.)*(rju+lmu+1.) c3l = lml**2*yl*(yl-4)*(rjl-lml)*(rjl+lml+1.) + 2.*(2.*rjl+1) & & *(rjl-lml+1.)*(rjl+1.)*(rjl+lml+1.) if(c1u.eq.0.) c1u=1.e5; if(c1l.eq.0.) c1l=1.e5 if(c2u.eq.0.) c2u=1.e5; if(c2l.eq.0.) c2l=1.e5 if(c3u.eq.0.) c3u=1.e5; if(c3l.eq.0.) c3l=1.e5 if(lam_u .gt. lam_l) then select case(k) case (1) ! p11 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.) & & *(jx+lm+1.)*u3u*u4l+ 8.*(jx-lm-2.)*(jx-lm)*(jx+lm)**2 )**2/ & & (32.*jx*c1u*c1l)/3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (2) ! q11 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l+ 8.*(jx-lm-1.)*(jx-lm)*(jx+lm) & & *(jx+lm+1.) )**2 /(32.*jx*(jx+1.)*c1u*c1l) /3. if(s_jj.le.0.) s_jj= 1. ! s_sum= s_sum + s_jj case (3) ! r11 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l+(jx-lm) & & *(jx+lm+3.)*u3u*u4l+ 8.*(jx-lm)**2*(jx+lm)*(jx+lm+2.) )**2 / & & (32.*(jx+1.)*c1u*c1l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (4) ! qp21 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm-2.) & & *(jx+lm+1.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) )**2 / & & (4.*jx*c2u*c1l)/3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (5) ! rq21 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u2l & & - (jx-lm-1.)*(jx+lm+2.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) & & )**2 /(4.*jx*(jx+1.)*c2u*c1l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (6) ! sr21 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm) & & *(jx+lm+3.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) )**2 / & & (4.*(jx+1.)*c2u*c1l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (7) ! rp31 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.) & & *(jx+lm+1.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm)*(jx+lm)*(jx+lm+1.) ) & & **2 /(32.*jx*c3u*c1l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (8) ! sq31 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm)**2*(jx+lm) & & *(jx+lm+2.) )**2 /(32.*jx*(jx+1.)*c3u*c1l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (9) ! tr31 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm) & & *(jx+lm+3.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+1.)*(jx+lm)*(jx+lm+3.) ) & & **2 /(32.*(jx+1.)*c3u*c1l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (10) ! op12 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm-2.) & & *(jx+lm+1.)*u3u - 2.*lm*(jx-lm-2.)*(jx+lm)*(yl-2.) )**2 / & & (4.*jx*c1u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (11) ! pq12 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u & & - (jx-lm-1.)*(jx+lm+2.)*u3u - 2.*lm*(jx-lm-1.)*(jx+lm+1.)*(yl-2.) & & )**2 /(4.*jx*(jx+1.)*c1u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (12) ! qr12 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm) & & *(jx+lm+3.)*u3u - 2.*lm*(jx-lm)*(jx+lm+2.)*(yl-2.) )**2 / & & (4.*(jx+1.)*c1u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (13) ! p22 s_jj = 2.*(jx-lm-1.)*(jx-lm)*( 0.5*lm*(lm+1.)*(yu-2.)*(yl-2.) & & + (jx-lm+1.)*(jx+lm) + (jx-lm-2.)*(jx+lm+1.) )**2 / & & (jx*c2u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (14) ! q22 s_jj = 2.*(jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( 0.5*lm*(lm+1.)*(yu-2.) & & *(yl-2.) + (jx-lm+1.)*(jx+lm) + (jx-lm-1.)*(jx+lm+2.) )**2 / & & (jx*(jx+1.)*c2u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (15) ! r22 s_jj = 2.*(jx+lm+1.)*(jx+lm+2.)*( 0.5*lm*(lm+1.)*(yu-2.)*(yl-2.) & & + (jx-lm+1.)*(jx+lm) + (jx-lm)*(jx+lm+3.) )**2 /((jx+1.) & & *c2u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (16) ! qp32 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm-2.) & & *(jx+lm+1.)*u3u + 2.*lm*(jx-lm-1.)*(jx+lm+1.)*(yl-2.) )**2 / & & (4.*jx*c3u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (17) ! rq32 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u & & - (jx-lm-1.)*(jx+lm+2.)*u3u + 2.*lm*(jx-lm)*(jx+lm+2.)*(yl-2.) & & )**2 /(4.*jx*(jx+1.)*c3u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (18) ! sr32 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm) & & *(jx+lm+3.)*u3u + 2.*lm*(jx-lm+1.)*(jx+lm+3.)*(yl-2.) )**2 / & & (4.*(jx+1.)*c3u*c2l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (19) ! np13 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.) & & *(jx+lm+1.)*u3u*u4l - 8.*(jx-lm-2.)*(jx-lm+1.)*(jx+lm)*(jx+lm+1.) & & )**2 /(32.*jx*c1u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (20) ! oq13 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm+1.) & & *(jx+lm+1.)**2 )**2 /(32.*jx*(jx+1.)*c1u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (21) ! pr13 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm)*(jx+lm+3.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+1.)*(jx+lm+1.) & & *(jx+lm+2.) )**2 /(32.*(jx+1.)*c1u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (22) ! op23 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm-2.) & & *(jx+lm+1.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)*(yu-2.) ) & & **2 /(4.*jx*c2u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (23) ! pq23 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u2l & & - (jx-lm-1.)*(jx+lm+2.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.) & & *(yu-2.) )**2 /(4.*jx*(jx+1.)*c2u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (24) ! qr23 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm) & & *(jx+lm+3.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)*(yu-2.) ) & & **2 /(4.*(jx+1.)*c2u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (25) ! p33 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.) & & *(jx+lm+1.)*u3u*u4l + 8.*(jx-lm-1.)*(jx-lm+1.)*(jx+lm+1.)**2)**2 & & /(32.*jx*c3u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (26) ! q33 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l+8.*(jx-lm)*(jx-lm+1.)*(jx+lm+1.) & & *(jx+lm+2.) )**2 /(32.*jx*(jx+1.)*c3u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj case (27) ! r33 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm) & & *(jx+lm+3.)*u3u*u4l + 8.*(jx-lm+1.)**2*(jx+lm+1.)*(jx+lm+3.) )**2 & & /(32.*(jx+1.)*c3u*c3l) /3. if(s_jj.le.0.) s_jj= 1./9. ! s_sum= s_sum + s_jj end select end if if(lam_l .gt. lam_u) then select case(k) case (1) ! p11 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l+ (jx-lm) & & *(jx+lm+3.)*u3u*u4l + 8.*(jx-lm)**2*(jx+lm)*(jx+lm+2.) )**2 / & & (32.*(jx+1.)*c1u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (2) ! q11 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l + 8.*(jx-lm-1.)*(jx-lm)*(jx+lm) & & *(jx+lm+1.) )**2 /(32.*jx*(jx+1.)*c1u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (3) ! r11 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.) & & *(jx+lm+1.)*u3u*u4l + 8.*(jx-lm-2.)*(jx-lm)*(jx+lm)**2 )**2 / & & (32.*jx*c1u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (4) ! qp21 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm) & & *(jx+lm+3.)*u3u - 2.*lm*(jx-lm)*(jx+lm+2.)*(yl-2.) )**2 / & & (4.*(jx+1.)*c1u*c2l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (5) ! rq21 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u & & - (jx-lm-1.)*(jx+lm+2.)*u3u - 2.*lm*(jx-lm-1.)*(jx+lm+1.)*(yl-2.) & & )**2 /(4.*jx*(jx+1.)*c1u*c2l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (6) ! sr21 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm-2.) & & *(jx+lm+1.)*u3u - 2.*lm*(jx-lm-2.)*(jx+lm)*(yl-2.) )**2 / & & (4.*jx*c1u*c2l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (7) ! rp31 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm)*(jx+lm+3.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+1.)*(jx+lm+1.) & & *(jx+lm+2.) )**2 /(32.*(jx+1.)*c1u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (8) ! sq31 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm+1.) & & *(jx+lm+1.)**2 )**2 /(32.*jx*(jx+1.)*c1u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (9) ! tr31 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l+ (jx-lm-2.) & & *(jx+lm+1.)*u3u*u4l -8.*(jx-lm-2.)*(jx-lm+1.)*(jx+lm)*(jx+lm+1.) & & )**2 /(32.*jx*c1u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (10) ! op12 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm) & & *(jx+lm+3.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) )**2 / & & (4.*(jx+1.)*c2u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (11) ! pq12 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u2l & & - (jx-lm-1.)*(jx+lm+2.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) & & )**2 /(4.*jx*(jx+1.)*c2u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (12) ! qr12 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm-2.) & & *(jx+lm+1.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) )**2 / & & (4.*jx*c2u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (13) ! p22 s_jj = 2.*(jx+lm+1.)*(jx+lm+2.)*( 0.5*lm*(lm+1.)*(yu-2.)*(yl-2.) & & + (jx-lm+1.)*(jx+lm) + (jx-lm)*(jx+lm+3.) )**2 /((jx+1.)*c2u*c2l) & & /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (14) ! q22 s_jj = 2.*(jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( 0.5*lm*(lm+1.)*(yu-2.) & & *(yl-2.) + (jx-lm+1.)*(jx+lm) + (jx-lm-1.)*(jx+lm+2.) )**2 / & & (jx*(jx+1.)*c2u*c2l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (15) ! r22 s_jj = 2.*(jx-lm-1.)*(jx-lm)*( 0.5*lm*(lm+1.)*(yu-2.)*(yl-2.) & & + (jx-lm+1.)*(jx+lm) + (jx-lm-2.)*(jx+lm+1.) )**2 /(jx*c2u*c2l) & & /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (16) ! qp32 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm) & & *(jx+lm+3.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)*(yu-2.) )**2 & & /(4.*(jx+1.)*c2u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (17) ! rq32 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u2l & & - (jx-lm-1.)*(jx+lm+2.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.) & & *(yu-2.) )**2 /(4.*jx*(jx+1.)*c2u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (18) ! sr32 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm-2.) & & *(jx+lm+1.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)*(yu-2.) )**2 & & /(4.*jx*c2u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (19) ! np13 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm)*(jx+lm+3.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+1.)*(jx+lm) & & *(jx+lm+3.) )**2 /(32.*(jx+1.)*c3u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (20) ! oq13 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l -8.*(jx-lm)**2*(jx+lm)*(jx+lm+2.) & & )**2 /(32.*jx*(jx+1.)*c3u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (21) ! pr13 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.) & & *(jx+lm+1.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm)*(jx+lm)*(jx+lm+1.) ) & & **2 /(32.*jx*c3u*c1l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (22) ! op23 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm) & & *(jx+lm+3.)*u3u+ 2.*lm*(jx-lm+1.)*(jx+lm+3.)*(yl-2.) )**2 / & & (4.*(jx+1.)*c3u*c2l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (23) ! pq23 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u & & - (jx-lm-1.)*(jx+lm+2.)*u3u+ 2.*lm*(jx-lm)*(jx+lm+2.)*(yl-2.) ) & & **2 /(4.*jx*(jx+1.)*c3u*c2l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (24) ! qr23 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm-2.) & & *(jx+lm+1.)*u3u + 2.*lm*(jx-lm-1.)*(jx+lm+1.)*(yl-2.) )**2 / & & (4.*jx*c3u*c2l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (25) ! p33 s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm)*(jx+lm+3.)*u3u*u4l + 8.*(jx-lm+1.)**2*(jx+lm+1.) & & *(jx+lm+3.) )**2 /(32.*(jx+1.)*c3u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (26) ! q33 s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l & & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l +8.*(jx-lm)*(jx-lm+1.)*(jx+lm+1.) & & *(jx+lm+2.) )**2 /(32.*jx*(jx+1.)*c3u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. case (27) ! r33 s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.) & & *(jx+lm+1.)*u3u*u4l + 8.*(jx-lm-1.)*(jx-lm+1.)*(jx+lm+1.)**2 )**2 & & /(32.*jx*c3u*c3l) /3.*sum_fact if(s_jj.le.0.) s_jj= 1./9. end select end if ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv norm = 2.*rjl+1. ! in case of N2, rjl=1 --> norm= 2.886 if( (lam_u.eq.1).and.(lam_l.eq.0).and.(rjl.eq.1.).and.(yu.eq.0.) & & .and.(yl.eq.0.) ) norm= 2.6666667 if( (lam_u.eq.2).and.(lam_l.eq.1).and.(rjl.eq.1.).and.(yu.eq.0.) & & .and.(yl.eq.0.) ) norm= 1.50 if( (lam_u.eq.2).and.(lam_l.eq.1).and.(rjl.eq.2.).and.(yu.eq.0.) & & .and.(yl.eq.0.) ) norm= 4.833333 if( (lam_u.eq.0).and.(lam_l.eq.1).and.(rjl.eq.1.).and.(yu.eq.0.) & & .and.(yl.eq.0.) ) norm= 3. ! 1.3632437 if( (lam_u.eq.1).and.(lam_l.eq.2).and.(rjl.eq.1.).and.(yu.eq.0.) & & .and.(yl.eq.0.) ) norm= 7.0e-5 if( (lam_u.eq.1).and.(lam_l.eq.2).and.(rjl.eq.2.).and.(yu.eq.0.) & & .and.(yl.eq.0.) ) norm= 3.270867 if( (lam_u.eq.1).and.(lam_l.eq.2).and.(rjl.eq.3.).and.(yu.eq.0.) & & .and.(yl.eq.0.) ) norm= 7.9253698 if( (lam_u.eq.1).and.(lam_l.eq.2).and.(rjl.eq.4.).and.(yu.eq.0.) & & .and.(yl.eq.0.) ) norm= 9.55393 popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotation hnu = 1.9863e-23 * ramda_jj_inv ! photon ene trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8 & & * 4.80298e-10)**2* (re1**2)/(3.0 * 6.6256e-27)) & & * s_jj * ramda_jj_inv**3/norm e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! emission p ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** ! this subroutine for lambda splitting + spin-orbit splitting ! lambda_upper > 1, if lambda_upper = 0, then sj'j'' should *2. subroutine calc_bb2x2ylam(isp,dev,bvu,bvl,dvu,dvl,geu, & & teu,evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 jx,lm dimension emisj(nw) ! test lambda splitting for ch x2pi-a2delta pl = 0.034d0 ql = 0.0389d0 ! from m. zachwieja (1997) pu = 2.07d-7 ; qu = 4.58d-8 ! from m. zachwieja (1997) ! pu = -3.34e-7 ! qu = 3.29e-7 ! from brazier(can.j.phys,1984,pp1576) geu = 1.0 ! only for lambda splitting ! pl=0.; ql=0.; pu=0.; qu=0. jmin = j - 0 if( (lam_u.eq.1) .and. (lam_l.eq.0) ) jmin = j if( (lam_u.eq.2) .and. (lam_l.eq.1) ) jmin = j + 1 ! s_jj's are taken from kovacs's, pp.127. these are exatly same as a.schadee (pp.327) fo ! but, s_jj of kovacs should be divided by 2. ! select case (k) ! refer to pp 261 of herzberg go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, & & 21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40, & & 41,42,43,44,45,46,47,48) K ! case(1) ! r(f1', f1") d-d 1 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0; cu3 = +1.0; cl3 = +1.0 go to 49 ! case(2) ! r(f1', f1") d-c 2 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0; cu3 = +1.0; cl3 = -1.0 go to 49 ! case(3) ! r(f1', f1") c-c 3 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0; cu3 = -1.0; cl3 = -1.0 go to 49 ! case(4) ! r(f1', f1") c-d 4 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0; cu3 = -1.0; cl3 = +1.0 go to 49 ! case(5) ! r(f2', f2") d-d 5 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0; cu3 = +1.0; cl3 = +1.0 go to 49 ! case(6) ! r(f2', f2") d-c 6 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0; cu3 = +1.0; cl3 = -1.0 go to 49 ! case(7) ! r(f2', f2") c-c 7 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0; cu3 = -1.0; cl3 = -1.0 go to 49 ! case(8) ! r(f2', f2") c-d 8 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0; cu3 = -1.0; cl3 = +1.0 go to 49 ! case(9) ! qr(f1', f2") d-d 9 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0; cu3 = +1.0; cl3 = +1.0 go to 49 ! case(10) ! qr(f1', f2") d-c 10 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0; cu3 = +1.0; cl3 = -1.0 go to 49 ! case(11) ! qr(f1', f2") c-c 11 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0; cu3 = -1.0; cl3 = -1.0 go to 49 ! case(12) ! qr(f1', f2") c-d 12 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(13) ! sr(f2', f1") d-d 13 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(14) ! sr(f2', f1") d-c 14 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(15) ! sr(f2', f1") c-c 15 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(16) ! sr(f2', f1") c-d 16 continue rju = real(jmin) + 1.5; rjl = rju - 1.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(17) ! q(f1', f1") d-d 17 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0 go to 49 ! case(18) ! q(f1', f1") d-c 18 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0 go to 49 ! case(19) ! q(f1', f1") c-c 19 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0 go to 49 ! case(20) ! q(f1', f1") c-d 20 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0 go to 49 ! case(21) ! q(f2', f2") d-d 21 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0 go to 49 ! case(22) ! q(f2', f2") d-c 22 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0 go to 49 ! case(23) ! q(f2', f2") c-c 23 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0 go to 49 ! case(24) ! q(f2', f2") c-d 24 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0 go to 49 ! case(25) ! pq(f1', f2") d-d 25 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(26) ! pq(f1', f2") d-c 26 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(27) ! pq(f1', f2") c-c 27 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(28) ! pq(f1', f2") c-d 28 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(29) ! rq(f2', f1") d-d 29 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(30) ! rq(f2', f1") d-c 30 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(31) ! rq(f2', f1") c-c 31 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(32) ! rq(f2', f1") c-d 32 continue rju = real(jmin) + 0.5; rjl = rju - 0.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(33) ! p(f1', f1") d-d 33 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0 go to 49 ! case(34) ! p(f1', f1") d-c 34 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0 go to 49 ! case(35) ! p(f1', f1") c-c 35 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0 go to 49 ! case(36) ! p(f1', f1") c-d 36 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0 go to 49 ! case(37) ! p(f2', f2") d-d 37 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0 go to 49 ! case(38) ! p(f2', f2") d-c 38 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0 go to 49 ! case(39) ! p(f2', f2") c-c 39 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0 go to 49 ! case(40) ! p(f2', f2") c-d 40 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0 go to 49 ! case(41) ! op(f1', f2") d-d 41 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(42) ! op(f1', f2") d-c 42 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(43) ! op(f1', f2") c-c 43 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(44) ! op(f1', f2") c-d 44 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0 go to 49 ! case(45) ! qp(f2', f1") d- 45 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(46) ! qp(f2', f1") d-c 46 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(47) ! qp(f2', f1") c-c 47 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! case(48) ! qp(f2', f1") c-d 48 continue rju = real(jmin) + 0.5; rjl = rju + 1.0 cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0 go to 49 ! end select 49 continue ! refer to kavacs, pp 61, 63, and 127, mulliken and christy (phys.rev. 1931) yu = sou/bvu yl = sol/bvl xu = dsqrt(4.d0*(rju+0.5d0)**2 + (yu*lam_u)**2 - 4.d0*yu*lam_u**2) xl = dsqrt(4.d0*(rjl+0.5d0)**2 + (yl*lam_l)**2 - 4.d0*yl*lam_l**2) fpu= bvu*((rju+0.5)**2 - lam_u**2 + cu1/2.*xu) - dvu*(rju+cu2)**4 & & + cu3*0.5*(rju+0.5)*((cu1*1.+(2.-yu)/xu)*(0.5*pu+qu) & & + 2.*qu/xu*(rju-0.5)*(rju+1.5)) fpl= bvl*((rjl+0.5)**2 - lam_l**2 + cl1/2.*xl) - dvl*(rjl+cl2)**4 & & + cl3*0.5*(rjl+0.5)*((cl1*1.+(2.-yl)/xl)*(0.5*pl+ql) & & + 2.*ql/xl*(rjl-0.5)*(rjl+1.5)) uuu= dsqrt(lam_u**2*yu*(yu-4.0) + 4.0*(rju+0.5)**2) & & + cu1*lam_u*(yu-2.0) uul= dsqrt(lam_l**2*yl*(yl-4.0) + 4.0*(rjl+0.5)**2) & & + cl1*lam_l*(yl-2.0) ccu= 0.5*(uuu**2 + 4.0*(rju+0.5)**2 - 4.0*lam_u**2) ccl= 0.5*(uul**2 + 4.0*(rjl+0.5)**2 - 4.0*lam_l**2) lm = real(lam_l) jx = rjl if( lam_u .gt. lam_l) then ! select case (k) ! case(1:8) ! rr(f1', f1"), rr22 if((k.ge.1).and.(k.le.8)) & & s_jj = (jx+lm+1.5)*(jx+lm+2.5) * (uuu*uul + 4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (8.*(jx+1.)*ccu*ccl) /2. ! case(9:16) ! qr(f1', f2"), sr21 if((k.ge.9).and.(k.le.16)) & & s_jj = (jx+lm+1.5)*(jx+lm+2.5) * (uuu*uul - 4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (8.*(jx+1.)*ccu*ccl) /2. ! case(17:24) ! qq(f1', f1"), qq22 if((k.gt.17).and.(k.le.24)) & & s_jj = (jx-lm-0.5)*(jx+0.5)*(jx+lm+1.5)*(uuu*uul & & + 4.*(jx-lm+0.5)*(jx+lm+0.5))**2 / & & (4.*jx*(jx+1.)*ccu*ccl) /2. ! case(25:32) ! pq(f1', f2"), rq21 if((k.ge.25).and.(k.le.32)) & & s_jj = (jx-lm-0.5)*(jx+0.5)*(jx+lm+1.5)*(uuu*uul & & - 4.*(jx-lm+0.5)*(jx+lm+0.5))**2 / & & (4.*jx*(jx+1.)*ccu*ccl) /2. ! case(33:40) ! pp(f1', f1"), pp22 if((k.ge.33).and.(k.le.40)) & & s_jj = (jx-lm-1.5)*(jx-lm-0.5) * (uuu*uul + 4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (8.*jx*ccu*ccl) /2. ! case(41:48) ! op(f1', f2"), qp21 if((k.ge.41).and.(k.le.48)) & & s_jj = (jx-lm-1.5)*(jx-lm-0.5) * (uuu*uul - 4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (8.*jx*ccu*ccl) /2. ! end select end if if( lam_u .lt. lam_l) then ! select case (k) ! case(1:8) ! rr(f1', f1"), rr22 if((k.ge.1).and.(k.le.8)) & & s_jj = (jx-lm-1.5)*(jx-lm-0.5) * (uuu*uul + 4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (8.*jx*ccu*ccl) /2. ! case(9:16) ! qr(f1', f2"), sr21 if((k.ge.9).and.(k.le.16)) & & s_jj = (jx-lm-1.5)*(jx-lm-0.5) * (uuu*uul - 4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (8.*jx*ccu*ccl) /2. ! case(17:24) ! qq(f1', f1"), qq22 if((k.ge.17).and.(k.le.24)) & & s_jj = (jx-lm-0.5)*(jx+0.5)*(jx+lm+1.5)*(uuu*uul +4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (4.*jx*(jx+1.)*ccu*ccl) /2. ! case(25:32) ! pq(f1', f2"), rq21 if((k.ge.25).and.(k.le.32)) & & s_jj = (jx-lm-0.5)*(jx+0.5)*(jx+lm+1.5)*(uuu*uul -4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (4.*jx*(jx+1.)*ccu*ccl) /2. ! case(33:40) ! pp(f1', f1"), pp22 if((k.ge.33).and.(k.le.40)) & & s_jj = (jx+lm+1.5)*(jx+lm+2.5) * (uuu*uul + 4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (8.*(jx+1.)*ccu*ccl) /2. ! case(41:48) ! op(f1', f2"), qp21 if((k.ge.41).and.(k.le.48)) & & s_jj = (jx+lm+1.5)*(jx+lm+2.5) * (uuu*uul - 4.*(jx-lm+0.5) & & *(jx+lm+0.5))**2 / (8.*(jx+1.)*ccu*ccl) /2. ! end select end if ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * dexp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot hnu = 1.9863e-23 * ramda_jj_inv trans_prob = (64.0 * (3.1415916**4)*(0.529167e-8*4.80298e-10)**2 & & * (re1**2)/(3.0 * 6.6256e-27)) * s_jj * ramda_jj_inv**3 & & /(2.*rjl+1.) e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_bb5p5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) ! 5Pi-5Pi transition ! Kovacs, Journal of Molecular Spectroscopy, 98, (1983), 41-47, Pi state ! k varies from 1 to 300 ! parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) logical frpi real*8 jx,lm,lmu,lml,l21,l22,l41,l42 ! ! determine kl=low state k value, ku=upper state k value, kj=P,Q,R choice, kso=spin orbit akc=k akd=akc/75.-0.01 kso=int(akd)+1 kold=k-75*(kso-1) ! aka=kold akb=aka/25.-0.01 kj=int(akb)+1 knew=kold-25*(kj-1) ! ak=knew ak1=ak/5.0-0.01 kl=int(ak1)+1 ku=(ak/5.0-real(kl-1))*5.0+0.01 jmin = j ! j refers to the lower state ! ! P-brabch if(kj.eq.1) then rju = real(j) - 1.0 rjl = rju + 1.0 end if if(kj.eq.2) then rju = real(j) rjl = rju - 0.0 end if if(kj.eq.3) then rju = real(j) rjl = rju - 1.0 end if xu=rju*(rju+1) xl=rjl*(rjl+1) yu=sou/bvu yl=sol/bvl tauu=4.*xu/((yu-2.)**2+4.*xu) taul=4.*xl/((yl-2.)**2+4.*xl) dlu=0.1*rju*rju dll=0.1*rjl*rjl if(ku.eq.1) fu=bvu*(xu-3.+2.*sqrt((yu-2.+tauu)**2+4.*xu)+6.*tauu & & -(14./5.)*tauu*(1.-tauu)-tauu**2*(1.-tauu)**2) if(ku.eq.2) fu=bvu*(xu+3.+sqrt((yu-2.+tauu)**2+4.*xu)-3.*tauu & & -(8./5.)*tauu*(1.-tauu)+0.5*tauu**2*(1.-tauu)**2) if(ku.eq.3) fu=bvu*(xu+5.-6.*tauu+tauu**2*(1.-tauu)**2) if(ku.eq.4) fu=bvu*(xu+3.-sqrt((yu-2.+tauu)**2+4.*xu)-3.*tauu & & +(8./5.)*tauu*(1.-tauu)+0.5*tauu**2*(1.-tauu)**2) if(ku.eq.5) fu=bvu*(xu-3.-2.*sqrt((yu-2.+tauu)**2+4.*xu)+6.*tauu & & +(14./5.)*tauu*(1.-tauu)-tauu**2*(1.-tauu)**2) if(kl.eq.1) fl=bvl*(xl-3.+2.*sqrt((yl-2.+taul)**2+4.*xl)+6.*taul & & -(14./5.)*taul*(1.-taul)-taul**2*(1.-taul)**2) if(kl.eq.2) fl=bvl*(xl+3.+sqrt((yl-2.+taul)**2+4.*xl)-3.*taul & & -(8./5.)*taul*(1.-taul)+0.5*taul**2*(1.-taul)**2) if(kl.eq.3) fl=bvl*(xl+5.-6.*taul+taul**2*(1.-taul)**2) if(kl.eq.4) fl=bvl*(xl+3.-sqrt((yl-2.+taul)**2+4.*xl)-3.*taul & & +(8./5.)*taul*(1.-taul)+0.5*taul**2*(1.-taul)**2) if(kl.eq.5) fl=bvl*(xl-3.-2.*sqrt((yl-2.+taul)**2+4.*xl)+6.*taul & & +(14./5.)*taul*(1.-taul)-taul**2*(1.-taul)**2) if(kso.eq.1) then fu=fu+dlu; fl=fl+dll end if if(kso.eq.2) then fu=fu+dlu; fl=fl-dll end if if(kso.eq.3) then fu=fu-dlu; fl=fl+dll end if if(kso.eq.4) then fu=fu-dlu; fl=fl-dll end if fpu = fu; fpl = fl s_jj=0.05 ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational hnu = 1.9863e-23 * ramda_jj_inv ! photon energy ! a = 64* pi**4 * (a0 * e)**2 * s * (delta e)**3 * re**2/(3 * h) trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8 & & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) * s_jj & & * ramda_jj_inv**3/(2.*rjl+1.) e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! emission power ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_bb5p5s(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) ! 5Pi(upper state)-5Sigma(lower state) transition ! Kovacs, Journal of Molecular Spectroscopy, 98, (1983), 41-47, Pi state ! and Kovacs, Rotational Structure in the spectra of diatomic molecules, 1969, for Sig ! k varies from 1 to 300 ! parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) logical frpi real*8 jx,lm,lmu,lml,l21,l22,u31,u32,l41,l42 ! arbitrary values of epsilon and gamma epsil=1.; gamma=1. ! ! determine kl=low state k value, ku=upper state k value, kj=P,Q,R choice, kso=spin orbit akc=k akd=akc/75.-0.01 kso=int(akd)+1 kold=k-75*(kso-1) ! aka=kold akb=aka/25.-0.01 kj=int(akb)+1 knew=kold-25*(kj-1) ! ak=knew ak1=ak/5.0-0.01 kl=int(ak1)+1 ku=(ak/5.0-real(kl-1))*5.0+0.01 jmin = j ! j refers to the lower state ! ! P-brabch if(kj.eq.1) then rju = real(j) - 1.0 rjl = rju + 1.0 end if if(kj.eq.2) then rju = real(j) rjl = rju - 0.0 end if if(kj.eq.3) then rju = real(j) rjl = rju - 1.0 end if xu=rju*(rju+1) xl=rjl*(rjl+1) yu=sou/bvu yl=sol/bvl tauu=4.*xu/((yu-2.)**2+4.*xu) taul=4.*xl/((yl-2.)**2+4.*xl) dlu=0.1*rju*rju dll=0.1*rjl*rjl if(ku.eq.1) fu=bvu*(xu-3.+2.*sqrt((yu-2.+tauu)**2+4.*xu) & & +6.*tauu -(14./5.)*tauu*(1.-tauu)-tauu**2*(1.-tauu)**2) if(ku.eq.2) fu=bvu*(xu+3.+sqrt((yu-2.+tauu)**2+4.*xu) & & -3.*tauu -(8./5.)*tauu*(1.-tauu)+0.5*tauu**2*(1.-tauu)**2) if(ku.eq.3) fu=bvu*(xu+5.-6.*tauu+tauu**2*(1.-tauu)**2) if(ku.eq.4) fu=bvu*(xu+3.-sqrt((yu-2.+tauu)**2+4.*xu)-3.*tauu & & +(8./5.)*tauu*(1.-tauu)+0.5*tauu**2*(1.-tauu)**2) if(ku.eq.5) fu=bvu*(xu-3.-2.*sqrt((yu-2.+tauu)**2+4.*xu)+6.*tauu & & +(14./5.)*tauu*(1.-tauu)-tauu**2*(1.-tauu)**2) if(kl.eq.1) fl=bvl*xl-dvl*xl**2-6.*epsil*rjl/(2.*rjl+3.) & & + 2.*gamma*rjl if(kl.eq.2) fl=bvl*xl-dvl*xl**2+3.*epsil*(rjl+6.)/(2.*rjl+3.) & & +gamma*(rjl-2.) if(kl.eq.3) fl=bvl*xl-dvl*xl**2+3.*epsil*(1.+3./(2.*rjl+3.)-3./ & & (2.*rjl-1.))-3.*gamma if(kl.eq.4) fl=bvu*xl-dvl*xl**2+3.*epsil*(rjl-5.)/(2.*rjl-1.) & & -gamma*(rjl+3.) if(kl.eq.5) fl=bvu*xl-dvl*xl**2-6.*epsil*(rjl+1.)/(2.*rjl-1.) & & -2.*gamma*(rjl+1.) if(kso.eq.1) then fu=fu+dlu fl=fl+dll end if if(kso.eq.2) then fu=fu+dlu fl=fl-dll end if if(kso.eq.3) then fu=fu-dlu fl=fl+dll end if if(kso.eq.4) then fu=fu-dlu fl=fl-dll end if fpu = fu fpl = fl s_jj=0.05 ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational hnu = 1.9863e-23 * ramda_jj_inv ! photon energy ! a = 64* pi**4 * (a0 * e)**2 * s * (delta e)**3 * re**2/(3 * h) trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8 & & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) * s_jj & & * ramda_jj_inv**3/(2.*rjl+1.) e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! emission power ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine calc_bb5s5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu, & & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) ! 5Sigma(upper state)-5Pi(lower state) transition ! Kovacs, Journal of Molecular Spectroscopy, 98, (1983), 41-47, Pi state ! and Kovacs, Rotational Structure in the spectra of diatomic molecules, 1969, for Sigma ! k varies from 1 to 300 ! parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms), & & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) real*8 jx,lm,lmu,lml,l21,l22,u31,u32,l41,l42 logical frpi ! arbitrary values of epsilon and gamma epsil=1.; gamma=1. ! ! determine kl=low state k value, ku=upper state k value, kj=P,Q,R choice, kso=spin orbit akc=k akd=akc/75.-0.01 kso=int(akd)+1 kold=k-75*(kso-1) ! aka=kold akb=aka/25.-0.01 kj=int(akb)+1 knew=kold-25*(kj-1) ! ak=knew ak1=ak/5.0-0.01 kl=int(ak1)+1 ku=(ak/5.0-real(kl-1))*5.0+0.01 jmin = j ! j refers to the lower state ! ! P-brabch if(kj.eq.1) then rju = real(j) - 1.0 rjl = rju + 1.0 end if if(kj.eq.2) then rju = real(j) rjl = rju - 0.0 end if if(kj.eq.3) then rju = real(j) rjl = rju - 1.0 end if xu=rju*(rju+1) xl=rjl*(rjl+1) yu=sou/bvu yl=sol/bvl tauu=4.*xu/((yu-2.)**2+4.*xu) taul=4.*xl/((yl-2.)**2+4.*xl) dlu=0.1*rju*rju dll=0.1*rjl*rjl if(ku.eq.1) fu=bvu*xu-dvu*xu**2-6.*epsil*rju/(2.*rju+3.) & & + 2.*gamma*rju if(ku.eq.2) fu=bvu*xu-dvu*xu**2+3.*epsil*(rju+6.)/(2.*rju+3.) & & +gamma*(rju-2.) if(ku.eq.3) fu=bvu*xu-dvu*xu**2+3.*epsil*(1.+3./(2.*rju+3.)-3./ & & (2.*rju-1.))-3.*gamma if(ku.eq.4) fu=bvu*xu-dvu*xu**2+3.*epsil*(rju-5.)/(2.*rju-1.) & & -gamma*(rju+3.) if(ku.eq.5) fu=bvu*xu-dvu*xu**2-6.*epsil*(rju+1.)/(2.*rju-1.) & & -2.*gamma*(rju+1.) if(kl.eq.1) fl=bvl*(xl-3.+2.*sqrt((yl-2.+taul)**2+4.*xl)+6.*taul & & -(14./5.)*taul*(1.-taul)-taul**2*(1.-taul)**2) if(kl.eq.2) fl=bvl*(xl+3.+sqrt((yl-2.+taul)**2+4.*xl)-3.*taul & & -(8./5.)*taul*(1.-taul)+0.5*taul**2*(1.-taul)**2) if(kl.eq.3) fl=bvl*(xl+5.-6.*taul+taul**2*(1.-taul)**2) if(kl.eq.4) fl=bvl*(xl+3.-sqrt((yl-2.+taul)**2+4.*xl)-3.*taul & & +(8./5.)*taul*(1.-taul)+0.5*taul**2*(1.-taul)**2) if(kl.eq.5) fl=bvl*(xl-3.-2.*sqrt((yl-2.+taul)**2+4.*xl)+6.*taul & & +(14./5.)*taul*(1.-taul)-taul**2*(1.-taul)**2) if(kso.eq.1) then fu=fu+dlu fl=fl+dll end if if(kso.eq.2) then fu=fu+dlu fl=fl-dll end if if(kso.eq.3) then fu=fu-dlu fl=fl+dll end if if(kso.eq.4) then fu=fu-dlu fl=fl-dll end if fpu = fu fpl = fl s_jj=0.05 ramda_jj_inv = dev + fpu - fpl wavelx = 1.0e8/ramda_jj_inv popu = dens_diatom(isp) * geu * homo_fac(isp) * & & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele & & + evu/tvib + fpu/trot))/qtot ! number density of upper rotational hnu = 1.9863e-23 * ramda_jj_inv ! photon energy ! a = 64* pi**4 * (a0 * e)**2 * s * (delta e)**3 * re**2/(3 * h) trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8 & & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) * s_jj & & * ramda_jj_inv**3/(2.*rjl+1.) e = popu * trans_prob * hnu/(4.0 * 3.1415916) ! emission power ! ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1 emisj(j) = e ! return end !*********************************************************************** subroutine chmtx(amtrx, bvtr, iprb) implicit real*8(a-h,o-z) common /spcdat/ eltbl(8,2), sptbl(9,32), fln(8,32), & & tdc(8,32,4), spm(32), & & ne, ns, & & itchm, ioutch, elms(8) ! common /node / spv(32), t, p, & & brm, speth(32), spgfz(32), & & spcsp(32), bzro(8), ethm ! dimension amtrx(16,16), bvtr(16), beta(16,32), & & gfe(32) ! pln=dlog(p) nep1=ne+1 ! ! set beta and gibbs free energy ! do 1 j=1,ns if(spv(j) .le. 0.0) spv(j) = 1.0e-20 gfe(j)=spgfz(j)+pln+dlog(spv(j)) do 1 i=1,ne beta(i,j)=fln(i,j)*spv(j) 1 continue ! ! set element submatrix ! do 2 k=1,ne do 2 i=k,ne amtrx(k,i)=0.0 do 2 j=1,ns amtrx(k,i)=amtrx(k,i)+fln(k,j)*beta(i,j) 2 continue ! ! set molar mass column down thru ne ! do 3 k=1,ne amtrx(k,nep1)=0.0 do 3 j=1,ns amtrx(k,nep1)=amtrx(k,nep1)-beta(k,j) 3 continue ! ! set pressure element ! amtrx(nep1,nep1)=1.0 do 4 j=1,ns amtrx(nep1,nep1)=amtrx(nep1,nep1)-spv(j) 4 continue ! ! reflect amtrx about diagonal except for mass column ! do 5 k=2,ne km1=k-1 do 5 i=1,km1 amtrx(k,i)=amtrx(i,k) 5 continue ! ! reflect negative of mass column to pressure row ! do 8 i=1,ne amtrx(nep1,i)=-amtrx(i,nep1) 8 continue ! !.....if t,p problem, skip temp col & enthalpy row.................... nep2=ne+2 if(iprb.ne.2)go to 9 do 10 i=1,ne amtrx(i,nep2)=0.0 do 11 j=1,ns amtrx(i,nep2)=amtrx(i,nep2)+fln(i,j)*spv(j)*speth(j) 11 continue 10 continue !.....fill the pressure element of temp col............................ amtrx(nep1,nep2)=0.0 do 12 j=1,ns amtrx(nep1,nep2)=amtrx(nep1,nep2)+spv(j)*speth(j) 12 continue !.....fill the enthalpy-temperature element........................ amtrx(nep2,nep2)=0.0 do 13 j=1,ns amtrx(nep2,nep2)=amtrx(nep2,nep2)+spv(j)*(spcsp(j)+speth(j)**2) 13 continue !.....reflect temp col into enthalpy row down thru ne................ do 14 k=1,ne amtrx(nep2,k)=amtrx(k,nep2) 14 continue !.....reflect negative of pressure element to pressure row............ amtrx(nep2,nep1)=-amtrx(nep1,nep2) ! 9 continue ! ! set rhs down thru ne ! do 6 k=1,ne bvtr(k)=brm*bzro(k)+amtrx(k,nep1) do 6 j=1,ns bvtr(k)=bvtr(k)+beta(k,j)*gfe(j) 6 continue ! ! pressure row rhs ! bvtr(nep1)=amtrx(nep1,nep1) do 7 j=1,ns bvtr(nep1)=bvtr(nep1)+spv(j)*gfe(j) 7 continue ! if(iprb.ne.2)go to 99 !.....sset rhs of enthalpy row(enthalpy units=j/kg)................... data gc/8.31434e3/ bvtr(nep2)=ethm*brm/(gc*t) do 15 j=1,ns bvtr(nep2)=bvtr(nep2)+spv(j)*speth(j)*(gfe(j)-1.) 15 continue ! ! 99 return end !************************************************************************* subroutine comet_lbl(nwave,rhoinf,vinf,pres,enths,tw,delH,rnose, & & spallf,ndm,nout,nim,facout1,facin1,facout2,facin2,famdot,elev_ang, & & hwhh,enfac,sigma) ! meteor inviscid line-by-line code ! input parameters ! nwave=number of wavelength points ! rhoinf=freestream density, kg/m3 ! vinf=freestream velocity, m/s ! pres=shock layer pressure, Pa ! enths=enthalpy behind shock wave, J/kg ! tw=wall temperature ! delH=ablation energy, J/kg ! rnose=body radius, m ! ndm=number of node points throughout the shock layer-ablation product layer ! nout=allowed number of iteration over the air shock layer in one sweep ! there are total of 4 sweeps ! nim=allowed number of iteration over the ablation-product layer in one sweep ! there are total of 4 sweeps ! facout1=fraction by which an old solution is modified by the new solution ! for air shock layer in the first two sweeps ! facin1=fraction by which an old solution is modified by the new solution ! for ablation product layer in the first two sweeps ! facout2=fraction by which an old solution is modified by the new solution ! for air shock layer in the late two sweeps ! facin2=fraction by which an old solution is modified by the new solution ! for ablation production layer in the later two sweeps ! famdot=fraction by which an old ablation rate is modified by the new ablation ! rate value ! elev_ang=elevation angle, deg ! hwhh=half-width at half-height in Gaussian slit function, A ! enfac=enthalpy entering shock wave divided by 0.5*vinf*vinf ! sigma=wall emissivity ! parameter(nw=400000) implicit real*8(a-h,o-z) character*4 dum(41) dimension wallt(4),pwall(4),tx(802),int_prec(nw),int_grd(nw), & & wav_sh(1000),edge(1000),shk(1000),prec(1000),grd(1000) common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11), & & int_cam(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) common/compe/compef(14),solid_dens(14),solid_dens_av,wtmolc common/scratch/any(nw) real*8 int_s,intw,int_e,int_prec,int_grd,int_cam,int_abl,mfp,magnit,mass save data wallt/3151.0,3624.2,4268.2,4601.3/ data pwall/5.,6.,7.,8./ data pi/3.14159265/,itime/0/ ! if(itime.eq.0) then ! take the log of absorption coefficients for air do iw=1,nwave do it=1,5 absb_air(it,iw)=dlog(absb_air(it,iw)) end do end do ! take log of absorption coefficients for ablation product do iw=1,nwave do it=1,11 absb_cho(it,iw)=dlog(absb_cho(it,iw)) end do end do ! take the log of absorption coefficients for freestream do iw=1,nwave do it=1,11 absb_low(it,iw)=dlog(absb_low(it,iw)) end do end do end if itime=itime+1 ! ! wall conditions mon=0 ! h0cho=condensed phase formation energy at 298 K, J/kg ! h0chog=gas phase formation energy at 298 K, J/kg ! h0sens=condensed phase sensible energy at tw, J/kg call pT_ivu(1,pres,tw, rhow,enthw,cpw) write(6,70) pres,tw,rhow,enthw,cpw,delH WRITE(*,70) PRES,TW,RHOW,ENTHW,CPW,DELH 70 format(/ & & ' pres=',1pe11.4,' Pa. tw =',0pf10.1,' K'/ & & ' rhow=',1pe11.4,' kg/m3. enthw=',e11.4,' J/kg'/ & & ' cpw =',e11.4 ' J/(kg-K). delH =',e11.4,' J/kg') ! ! asorption coefficient and intensity at wall tx(1)=tw twall=10000./tx(1) do iw=1,nwave ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(1))) do iang=1,10 intw(iang,iw)=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax)) ! W/(cm2-mic-sr) intw(iang,iw)=dmax1(sigma*intw(iang,iw),1.0d-30) intw(iang,iw)=0. end do call intpl1(tcho,absb_cho(1,iw),twall,absbx,11) end do ! ! radiative flux at wall qp(1)=sigma*5.679e-12*tx(1)**4*1.e4 ! W/m2 if(itime.eq.0) write(6,60) qp(1) 60 format(/' black body wall radiative flux=',1pe10.3,' W/m2') ! ! shock conditions enths=0.5*vinf*vinf*enfac ! enthalpy, J/kg call pH_air(1,pres,enths, rhos,temps) write(6,80) pres,enths,rhos,temps 80 format(/ & & ' equilibrium calculation by pH_air using ps and enths'/ & & ' pres =',1pe11.4,' Pa. enths =',e11.4, ' J/kg'/ & & ' rhos =',e11.4, ' kg/m3. temps =',0pf10.1,' K') call pT_air(1,pres,temps, rhos1,enths1,cps) write(6,90) pres,temps, rhos1,enths1,cps 90 format(/ & & ' equilibrium calculation by pT_air using ps and temps'/ & & ' pres =',1pe11.4,' Pa. temps =',0pf10.1,' K'/ & & ' rhos1=',1pe11.4,' kg/m3. enths1=',e11.4, ' J/kg'/ & & ' cps =',e11.4,' J/(kg-K)') ! ! density ratio across shock denrat=rhoinf/rhos ! ratio of shock stand-off distance to nose radius ! from Park, JQSRT 28,29 (1982) del_rat=denrat*(1.0-2.*denrat+5.5*denrat**2) ! shock stand-off distance delta=rnose*del_rat write(6,150) delta 150 format(' shock standoff distance delta=',1pe10.3,' m') ! write(10,30) 30 format(' rhoinf vinf rnose amdot fw ndm', & & ' qm1-qp1 delH dmix Ts Ti Tw eff_lum') read(5,120) (dum(i),i=1,25) 120 format(25a4) write(6,120) (dum(i),i=1,25) read(5,120) (dum(i),i=1,25) write(6,120) (dum(i),i=1,25) ! write(12,160) rhoinf,vinf,rnose 160 format(/' rhoinf=',1pe10.3,' vinf=',e10.3,' rnose=',e10.3/ & & ' iout flow') write(13,170) rhoinf,vinf,rnose 170 format(/' rhoinf=',1pe10.3,' vinf=',e10.3,' rnose=',e10.3/ & & ' im amdot') enths=0.5*vinf*vinf*enfac iout1=1 im1=1 call calc(nwave,ndm,tx,rhoinf,vinf,pres,tw,rnose,temps,rhos, & & enths,delta,delH,spallf,nout,nim,facout1,facin1,facout2,facin2,famdot, & & enfac,sigma,iout1,im1) if(spallf.lt.1.0e-6) go to 220 write(6,*) ' ' iout1=2*nout+1 im1=2*nim+1 call calc1(nwave,ndm,tx,rhoinf,vinf,pres,tw,rnose,temps,rhos, & & enths,delta,delH,nout,nim,facout1,facin1,facout2,facin2,famdot, & & sigma,hwhh,iout1,im1, amdot_out,delta1,dmix,qps) ! shock stand-off distance considerations 220 continue ! mean free path mfp=7.171e-8*1.225/rhoinf ! mean-free-path in meters ! assume relaxation distance to be 7 mfps relax_dist=7.*mfp ! relaxation distance, m ! equiiibrium shock stand-off distance eqinv_delta=delta1-relax_dist-dmix ! m write(6,40) delta,relax_dist,dmix,eqinv_delta 40 format(/ & & ' frozen inviscid shock standoff distance =',1pe12.5,' m'/ & & ' chemical relaxation distance =',e12.5,' m'/ & & ' viscous mixing/cooling distance =',e12.5,' m'/ & & ' equilibrium inviscid shock standoff distance =',e12.5,' m') ! ! calculate precursor region call precurs(mwave,nwave,int_s,qps, rhoinf,vinf,rnose, flux_s,flux_prec,int_prec) ! luminous efficiency calc pwrrad=flux_prec*3.1416*rnose**2 pwrabl=0.5*vinf*vinf*amdot_out*3.1416*rnose**2 if(spallf.gt.1.0e-6) eff_lum=pwrrad/pwrabl if(spallf.le.1.0e-6) eff_lum=0. ! ! calculate atmospheric absorption call atm_absb(mwave,nwave,flux_prec,int_prec,altit,elev_ang,rhoinf, & & flux_grd,int_grd) ! ! radiation intensity in magnitude call magnitf(nwave,rnose,flux_s,flux_prec,flux_grd, & & altit,elev_ang, magnit) ! ! Gaussian slit wav1=3000.; wav2=8000.; nskip=5 call gausst(nwave,hwhh,wav1,wav2,wavel,nskip,int_grd,int_cam) ! ! energy considerations engy_sum2=enths + flux_prec/(rhoinf*vinf) error=engy_sum2/(0.5*vinf*vinf) - 1.0 prec_loss=flux_s-flux_prec ! pwrrad=flux_grd*3.1416*rnose**2 pwrabl=enths*amdot_out*3.1416*rnose**2 eff_lum=pwrrad/pwrabl hloss=0.5*eff_lum*vinf*amdot_out/rhoinf write(*,20) 0.5*vinf*vinf,enths,flux_s,flux_s/(rhoinf*vinf),flux_prec, & & flux_prec/(rhoinf*vinf),prec_loss,prec_loss/(rhoinf*vinf),flux_grd, & & flux_grd/(rhoinf*vinf),eff_lum,hloss,engy_sum2,error,magnit,eff_lum write(6,20) 0.5*vinf*vinf,enths,flux_s,flux_s/(rhoinf*vinf),flux_prec, & & flux_prec/(rhoinf*vinf),prec_loss,prec_loss/(rhoinf*vinf),flux_grd, & & flux_grd/(rhoinf*vinf),eff_lum,hloss,engy_sum2,error,magnit,eff_lum 20 format(/' Energy tally' / & & ' 0.5*vinf*vinf (freestream enthalpy) =',1pe11.4,' J/kg'/ & & ' enths (assumed shock layer enthalpy) =',e11.4,' J/kg'/ & & ' flux_s (radiative power at shock) =',e11.4,' W'/ & & ' flux_s/(rhoinf*vinf) (enthalpy in flux_s) =',e11.4,' J/kg'/ & & ' flux_prec (rad flux at end of precursor region) =',e11.4,' W'/ & & ' flux_prec/(rhoinf*vinf) (enthalpy in flux_prec) =',e11.4,' J/kg'/ & & ' prec_loss (radiation power absorbed in precursor region' / & & ' and recaptured by shock layer) =',e11.4,' W'/ & & ' prec_loss/(rhoinf*vinf) (enthalpy in prec_loss) =',e11.4,' J/kg'/ & & ' flux_grd (radiative flux falling on ground) =',e11.4,' W'/ & & ' flux_grd/(rhoinf*vinf) (enthalpy in flux_grd) =',e11.4,' J/kg'/ & & ' eff_lum (lum efficiency based on qgrd) =',e11.4/ & & ' hloss (enthalpy in eff_lum) =',e11.4,' J/kg'/ & & ' engy_sum2 (enthalpy sum) =',e11.4,' J/kg'/ & & ' error fraction = engy_sum2/(0.5*vinf*vinf) - 1.0) =',e11.4/ & & ' brightness magnitude =',0pf10.3/ & & ' eff_lum(luminous efficiency) =',1pe10.3) ! ! plot absorption coef behind shock (absb(s)), normal intensity ahead of shock(int_s). ! normal intensity at end of precursor region(int_prec), normal intensity at ! ground(int_grd), and intensity caught on spectrographic camera with a Gaussian ! slita(camera) write(14,210) rhoinf,vinf,rnose 210 format(/' rhoinf=',1pe11.4,' vinf=',e11.4,' rnose=',e11.4/ & & ' iw wavel int_s int_prec int_grd camera') do iw=1,nwave write(14,110) iw,wavel(iw),int_s(1,iw),int_prec(iw),int_grd(iw), & & int_cam(iw) end do 110 format(i6,f10.3,1p6e11.4) ! plot absorption coef at edge of ablation product layer(absb(e)), norma lintensity ! at edge(int-e), outward normal intensity at wall(wall(+)), and inward normal ! intensity at wall(wall(-)) write(15,50) rhoinf,vinf,rnose 50 format(/' rhoinf=',1pe11.4,' vinf=',e11.4,' rnose=',e11.4/ & & ' iw wavel int_e wall(+) ') do iw=1,nwave write(15,110) iw,wavel(iw),int_e(1,iw),intw(1,iw) end do close(15) ! ! smoothed signals do iw=1,nwave any(iw)=int_e(1,iw) end do call smooth(nwave,wavel,any, wav_sh,edge) do iw=1,nwave any(iw)=int_s(1,iw) end do call smooth(nwave,wavel,any, wav_sh,shk) call smooth(nwave,wavel,int_prec, wav_sh,prec) call smooth(nwave,wavel,int_grd, wav_sh,grd) write(21,100) 100 format(/' smoothed profiles:'/ & & ' edge=at edge of vapor layer' & & ' shk=in front of shock wave'/ & & ' prec=at end of precursor region'/ & & ' grd=at ground'/ & & ' i wavel edge shk prec grd' ) do iw=1,1000 write(21,10) iw,wav_sh(iw),edge(iw),shk(iw),prec(iw),grd(iw) 10 format(i5,f10.1,1p6e10.3) end do ! ! Borovicka parameters ! volume vol=(4./3.)*pi*rnose**3 ! mass solid_dens_av1=2000. mass=vol*solid_dens_av1 ! shape factor shape_fac=pi*rnose**2/(vol**0.6666667) ! drag cofficient drag_coef=0.5 ! shape-density coefficient shape_dens_coef=drag_coef*shape_fac/(solid_dens_av1**0.6666667) ! heat transfer coef heat_tr_coef=delH*(amdot_out*pi*rnose**2)*2./ & & (shape_fac*vol**0.666667*rhoinf*vinf**3) ! ablation coefficient abl_coef=heat_tr_coef/(2.*drag_coef*delH) write(6,171) vol,mass,shape_fac,drag_coef,shape_dens_coef, & & heat_tr_coef,abl_coef 171 format(/' Borovicka parameters'/ & & ' volume =',1pe11.4,' m3'/ & & ' mass =',e11.4,' kg'/ & & ' shape_factor =',e11.4/ & & ' drag_coef =',e11.4/ & & ' shape-density coef =',e11.4/ & & ' heat transfer coef =',e11.4/ & & ' abl_coef =',e11.4) ! ! write goodbye write(6,*) ' ' write(*,*) ' ' write(6,*) ' goodbye' write(*,*) ' goodbye' return end !*********************************************************************** subroutine compos(elmnm1,elmwt1,elmf1) ! calculates elemental mass fractions from given compositions of meteoroid ! output parameters: ! elmnm1(14)=elemental name ! elmwt1(14)=elemental mass, kg/mol ! elmsf1(14)=elemental mass fraction implicit real*8(a-h,o-z) character*4 dum(51),elmnm(13),elmnm1(13) dimension compmf(14),elmwt(13),compwt(14),elmmf(14),elmf(14), & & elmef(14),elmwt1(13),elmf1(14) character*6 compnm common/compi/compnm(14) common/compe/compef(14),solid_dens(14),solid_dens_av,wtmolc real*8 mg_K,mgo_c_K,mgo_K,mgo_L_K dimension tw(9),tw1(9),twx(9),plogx(9),psum(9),psumlog(9), & & p(9,7),delK(10,7),delHz(4),coeft(4),coefH(4), & & o_K(9),o2_K(9),al2o3_L_K(9),alo_K(9),cao_K(9),cao_L_K(9), & & sio2_c_K(6),sio2_L_K(9),sio2_K(9),sio_K(9), & & fe2o3_c_K(6),fe2o3_L_K(9),feo_L_K(9),feo_K(9), & & mgo_c_K(8),mgo_L_K(9),mgo_K(9), & & h2o_L_K(9),oh_K(9),h2_K(9),h_K(9),fes_c_K(6),fes_L_K(9),fes_K(9), & & c_c_K(9),c3_K(9),sens_SiO2(9),sens_FeO(9),sens_FeS(9),sens_H2O(9), & & sens_MgO(9),sens_C(9) dimension aa(4,4),bb(4,2),cc(4,2) dimension twz(51),ploglog(51),ppb(51),delH_wt(51) ! data compnm/ & ! 1 2 3 4 5 & 'SiO2 ','TiO2 ','Al2O3 ','CrO2 ','Fe2O3 ', & ! 6 7 8 9 10 & 'FeO ','MgO ','CaO ','Na2O ','H2O ', & ! 11 12 13 14 & 'Fe ','Ni ','FeS ','C '/ ! data elmnm/ & ! 1 2 3 4 5 & 'S ', 'H ', 'C ', 'O ', 'Si ', & ! 6 7 8 9 10 & 'Mg ', 'Fe ', 'Ca ', 'Al ', 'Na ', & ! 11 12 13 & 'Ti ', 'Cr ', 'Ni '/ ! data elmwt/ & & 0.032064, 0.001008, 0.012011, 0.016, 0.028086, & & 0.024312, 0.055847, 0.04008, 0.026982, 0.022990, & & 0.047880, 0.051996, 0.058690/ ! data solid_dens/ & & 2.468 , 4.486, 3.97, 2.90, 5.255, & & 6.0, 3.6, 3.35, 2.27, 1.0, & & 7.87, 8.90, 4.70, 2.20/ ! data tw/500.,1000.,1500.,2000.,2500.,3000.,3500.,4000.,4500./ data twx/500.,1000.,1500.,2000.,2500.,3000.,3500.,4000.,4500./ do i=1,14 compef(i)=0. end do ! ! equilibrium constants---------------------------------------------------------- ! ! O2 --> 2 O data o2_K/ 0., 0., 0., 0., 0., 0., 0.,0.,0./ ! SiO2(L) --> SiO + 0.5*O2 data sio2_c_K/85.444,38.137,22.443,14.388,9.463,6.197/ data sio2_L_K/85.617,38.145,22.415,14.388,9.528,6.322,4.056,1.665,-0.186/ data sio2_K/32.142,16.114,10.743,7.796,5.902,4.631,3.717,2.318,1.222/ data sio_K/15.168,9.790,7.926,6.706,5.836,5.240,4.802,3.757,2.934/ ! ! Al2O3 -->2AlO + 0.5*O data al2o3_L_K/158.659,71.114,41.067,27.008,18.433,12.325,7.157,3.365,-0.427/ data alo_K/-2.470,0.800,1.614,1.981,2.186,1.933,1.301,0.832,0.470/ data o_K/-22.936,-9.803,-5.392,-3.175,-1.839,-0.946,-0.307,0.173,0.547/ ! ! CaO --> CaO data cao_L_K/53.971,24.918,15.121,9.720,6.044,3.630,1.930,0.778,-0.310/ data cao_K/ -0.690,1.185,1.817,1.461,0.783,0.359,0.080,-0.116,-0.364/ ! Fe2O3(L) --> 2FeO + 0.5 O2 data fe2o3_c_K/71.972,29.349,15.265,8.185,3.837,-0.511/ data feo_L_K/23.271,10.355,6.033,3.877,2.766,1.661,0.428,-0.673,-1.517/ data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/ ! FeO(L) --> FeO data feo_L_K/23.271,10.355,6.033,3.877,2.544,1.661,0.428,0.673,-1.517/ ! data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/ ! MgO(L) --> MgO data mgo_c_K/57.153,25.749,14.722,8.358,4.582,2.095,0.341,-0.957/ data mgo_L_K/57.153,25.749,14.722,8.358,4.582,2.095,0.491,-0.654,-1.527/ data mgo_K/-2.040,0.894,1.327,0.679,0.305,0.059,-0.115,-0.246,-0.350/ ! H2O(L) --> OH + 0.5 H2 data h2o_L_K/20.534,6.458,1.934, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ data oh_K/ -3.246, -1.222, -0.563, -0.240, -0.050,0.074,0.160, 0.223,0.270/ data h2_K/0.,0.,0.,0.,0.,0.,0.,0.,0./ data h_K/-20.158,-8.644,-4.754,-2.788,-1.599,-0.801,-0.228,0.203,0.539/ ! FeS(c) --> FeS data fes_c_K/10.707,5.102,2.401,1.297,0.577,0.091/ data fes_L_K/10.707,5.102,2.401,1.297,0.577,0.091,-0.867,-1.806,-2.544/ data fes_K/-28.832,-10.510,-5.481,-3.099,-1.791,-0.967,-1.017,-1.256,-1.448/ ! C(c) --> (1/3) C3 data c_c_K/0.,0.,0.,0.,0.,0.,0.,0.,0./ data c3_K/-74.143,-31.400,-17.322,-10.384,-6.285,-3.596,-1.708,-0.317,0.745/ ! ! read in compound mass fractions sum=0. do i=1,14 read(5,10) compmf(i),(dum(j),j=1,10) 10 format(e10.3,20a4) write(6,20) compmf(i),(dum(j),j=1,10) 20 format(f10.7,20a4) sum=sum+compmf(i) end do ! normalize compound mass fractions do i=1,14 compmf(i)=compmf(i)/sum end do ! ! average density sum=0. do i=1,14 sum=sum+compmf(i)/solid_dens(i) end do solid_dens_av=1./sum write(6,60) solid_dens_av 60 format(/' ideal density of meteoroid, solid=',1pe11.4,' g/cm3') ! ! component weight ! kg/mol compwt(1)=elmwt(5)+2.*elmwt(4) ! SiO2 1 compwt(2)=elmwt(11)+2.*elmwt(4) ! TiO2 2 compwt(3)=2.*elmwt(9)+3.*elmwt(4) ! Al2O3 3 compwt(4)=elmwt(12)+2.*elmwt(4) ! CrO2 4 compwt(5)=2.*elmwt(7)+3.*elmwt(4) ! Fe2O3 5 compwt(6)=elmwt(7)+elmwt(4) ! FeO 6 compwt(7)=elmwt(6)+elmwt(4) ! MgO 7 compwt(8)=elmwt(8)+elmwt(4) ! CaO 8 compwt(9)=2.*elmwt(10)+elmwt(4) ! Na2O 9 compwt(10)=2.*elmwt(2)+elmwt(4) ! H2O 10 compwt(11)=elmwt(7) ! Fe 11 compwt(12)=elmwt(13) ! Ni 12 compwt(13)=elmwt(7)+elmwt(1) ! FeS 13 compwt(14)=elmwt(3) ! C 14 ! ! compound mole fractions sum=0. do i=1,14 compef(i)=compmf(i)/compwt(i) sum=sum+compef(i) end do do i=1,14 compef(i)=compef(i)/sum end do ! compound molecular weight wtmolc=0. do i=1,14 wtmolc=wtmolc+compwt(i)*compef(i) end do write(6,30) wtmolc 30 format(/' molecular weight of condensate = ',1pe12.5,' kg/mol'/ & & /' normalized compound mass and mole fractions'/ & & ' i species massf molef') do i=1,14 write(6,40) i,compnm(i),compmf(i),compef(i) 40 format(i5,2x,a4,4x,1p4e12.5) end do ! ! elemental mole fractions elmmf(1)=compef(13) ! S elmmf(2)=2.*compef(10) ! H elmmf(3)=compef(14) ! C elmmf(4)=2.*compef(1)+2.*compef(2)+3.*compef(3) &! & +2.*compef(4)+3.*compef(5)+compef(6)+compef(7) &! & +compef(8)+compef(9)+compef(10) ! O elmmf(5)=compef(1) ! Si elmmf(6)=compef(7) ! Mg elmmf(7)=2.*compef(5)+compef(6)+compef(11)+compef(13) ! Fe elmmf(8)=compef(8) ! Ca elmmf(9)=2.*compef(3) ! Al elmmf(10)=2.*compef(9) ! Na elmmf(11)=compef(2) ! Ti elmmf(12)=compef(4) ! Cr elmmf(13)=compef(12) ! Ni ! ! elemental mass fractions sum=0. do i=1,13 elmf(i)=elmmf(i)*elmwt(i) sum=sum+elmf(i) end do do i=1,13 elmf(i)=elmf(i)/sum end do ! elemental mol fractions sum=0. do i=1,13 sum=sum+elmmf(i) end do do i=1,13 elmmf(i)=elmmf(i)/sum end do write(6,50) 50 format(/' i specie elmwt massfrac molfrac') do i=1,13 write(6,40) i,elmnm(i),elmwt(i),elmf(i),elmmf(i) elmnm1(i)=elmnm(i); elmwt1(i)=elmwt(i); elmf1(i)=elmf(i) end do ! return end !*********************************************************************** subroutine conv(gamsp,gamsp1,nprt) ! this subroutine and accompanying subroutine conv1 shrink and restore ! species list by ivoking elemental conservation ! assumes the first nelem species are to be removed and put back in ! input: gamsp(i),i=1,nsp: original species list ! nprt=print index ! output: gamsp1(i),i=1,nsp-nelem; shrunken species list parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) dimension gamsp(msp),gamsp1(msp) character*4 elemnm,spnm ! do isp=nelem+1,nsp gamsp1(isp-nelem)=gamsp(isp) end do return end !************************************************************************************ subroutine conv1(gamsp1,gamsp,nprt) ! this subroutine and accompanying subroutine conv shrink and restore ! species list by ivoking elemental conservation ! assumes the first nelem species are to be removed and put back in ! input: gamsp1(i),i=1,nsp: shrunken species list ! nprt=print index ! output: gamsp(i),i=1,nsp-nelem; restored species list ! parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) dimension gamsp(msp),gamsp1(msp),amat(15,15),rhs(15),ipvt(15), & & work(15),bmat(15,15) character*4 elemnm,spnm save data itime/0/ itime=itime+1 ! ! first nelem-1 lines do j=1,nelem-1 ! left-hand matrix ! i=column number; j=line number do i=1,nelem amat(j,i)=(spwt(j)/felem(j))*ielem(i,j) & ! amat(j,i) correct & -(spwt(j+1)/felem(j+1))*ielem(i,j+1) end do ! right-hand side vector rhs(j)=0. do i=nelem+1,nsp rhs(j)=rhs(j)-(spwt(j)/felem(j))*ielem(i,j)*gamsp1(i-nelem) & & +(spwt(j+1)/felem(j+1))*ielem(i,j+1)*gamsp1(i-nelem) end do end do ! ! last line. element sum = 1 ! left-hand matrix do i=1,nelem amat(nelem,i)=0. do j=1,nelem amat(nelem,i)=amat(nelem,i)+ielem(i,j)*spwt(j) ! if(itime.eq.2408016) then ! write(6,50) i,j,ielem(i,j),spwt(j),amat(nelem,i) ! 50 format(' i=',i3,' j=',i3,' ielem=',i3,' spwt=',1pe9.2,' amat=',e10.3) ! end if end do end do ! right-hand vector rhs(nelem)=1. do i=nelem+1,nsp do j=1,nelem rhs(nelem)=rhs(nelem)-ielem(i,j)*spwt(j)*gamsp1(i-nelem) end do end do ! ! copy left-hand matrix for later display do ir=1,nelem do ic=1,nelem bmat(ir,ic)=amat(ir,ic) end do end do ! ! solve call decomp(15,nelem,amat,cond,ipvt,work) ! display amat if cond .gt. 1.e8 ! if(cond.gt.1.0e8) then ! write(6,*) ' itime=',itime ! write(6,20) cond ! 20 format(' in conv1. cond=',1pe10.3) ! do ir=1,nelem ! write(6,10) ir,(bmat(ir,ic),ic=1,nelem) ! 10 format(i3,1p15e9.2) ! end do ! if(itime.ge.100) stop ! end if call solve(15,nelem,amat,rhs,ipvt) ! do j=1,nelem gamsp(j)=rhs(j) end do do j=nelem+1,nsp gamsp(j)=gamsp1(j-nelem) end do return end !*********************************************************************** subroutine decomp(ndim,n,a,cond,ipvt,work) implicit real*8(a-h,o-z) integer ndim, n real*8 a(ndim,n), cond, work(n) integer ipvt(n) ! ! decomposes a real matrix by gaussian elimination and estimates ! the condition of the matrix. ! ! use subroutine solve to compute solutions to linear systems. ! ! input... ! ! ndim = declared row dimension of the array containing a. ! ! n = order of the matrix. ! ! a = matrix to be triangularized. ! ! output... ! ! a contains an upper triangular matrix u and a permuted version ! of a lower triangular matrix i-l so that ! (permutation matrix)*a = l*u ! ! cond = an estimate of the condition of a. for the linear system ! a*x = b, changes in a and b may cause changes cond times as ! large in x. if (cond+1.0) equals cond, a is singular to working ! precision. cond is set to 1.0e+32 if exact singularity is detected. ! ! ipvt = the pivot vector ! ipvt(k) = the index of the k-th pivot row ! ipvt(n) = (-1)**(number of interchanges) ! ! work space... ! ! the vector work must be declared and included in the call. its ! input contents are ignored. its output contents are usually ! unimportant. ! ! the determinant of a can be obtained on output by ! det(a) = ipvt(n)*a(1,1)*a(2,2)*...*a(n,n) ! real*8 ek, t, anorm, ynorm, znorm integer nm1, i, j, k, kp1, kb, km1, m ! ipvt(n) = 1 if(n .eq. 1) go to 80 nm1 = n - 1 ! ! compute 1-norm of a ! anorm = 0.0 do 10 j = 1, n t = 0.0 do 5 i = 1, n t = t + abs(a(i,j)) 5 continue if(t .gt. anorm) anorm = t 10 continue ! ! gaussian elimination with partial pivoting ! do 35 k = 1, nm1 kp1 = k + 1 ! ! find pivot ! m = k do 15 i = kp1, n if(abs(a(i,k)) .gt. abs(a(m,k))) m = i 15 continue ipvt(k) = m if(m .ne. k) ipvt(n) = -ipvt(n) t = a(m,k) a(m,k) = a(k,k) a(k,k) = t ! ! skip step if pivot is zero ! if(t .eq. 0.0) go to 35 ! ! compute multipliers ! do 20 i = kp1, n a(i,k) = -a(i,k)/t 20 continue ! ! interchange and eliminate by columns ! do 30 j = kp1, n t = a(m,j) a(m,j) = a(k,j) a(k,j) = t if(t .eq. 0.0) go to 30 do 25 i = kp1, n a(i,j) = a(i,j) + a(i,k)*t 25 continue 30 continue 35 continue ! ! cond = (1-norm of a)*(an estimate of 1-norm of a-inverse) ! estimate obtained by one step of inverse iteration for the small ! singular vector. this involves solving two systems of equations, ! (a-transpose)*y = e and a*z = y where e is a vector of +1 or -1 ! chosen to cause growth in y. ! estimate = (1-norm of z)/(1-norm of y) ! ! solve (a-transpose)*y = e ! do 50 k = 1, n t = 0.0 if(k .eq. 1) go to 45 km1 = k - 1 do 40 i = 1, km1 t = t + a(i,k)*work(i) 40 continue 45 ek = 1.0 if(t .lt. 0.0) ek = -1.0 if(a(k,k) .eq. 0.0) go to 90 work(k) = -(ek + t)/a(k,k) 50 continue do 60 kb = 1, nm1 k = n - kb t = 0.0 kp1 = k + 1 do 55 i = kp1, n t = t + a(i,k)*work(k) 55 continue work(k) = t m = ipvt(k) if(m .eq. k) go to 60 t = work(m) work(m) = work(k) work(k) = t 60 continue ! ynorm = 0.0 do 65 i = 1, n ynorm = ynorm + abs(work(i)) 65 continue ! ! solve a*z = y ! call solve(ndim, n, a, work, ipvt) znorm = 0.0 do 70 i = 1, n znorm = znorm + abs(work(i)) 70 continue ! ! estimate condition ! cond = anorm*znorm/ynorm if(cond .lt. 1.0) cond = 1.0 return ! ! 1-by-1 ! 80 cond = 1.0 if(a(1,1) .ne. 0.0) return ! ! exact singularity ! 90 cond = 1.0e+32 return end !********************************************************************** subroutine der1(neq,t,yy,dydx,istep,nprt) ! steering subroutine for der2 for equilibrium calculation eqcal1 ! inputs: ! neq=number of equations ! t=time ! yy(i)=species concentration, mol/kg ! dydx(i)=rate of change ! istep=time step number ! nprt=print index ! outputs: ! yy(40)=solution ! dydx(40)=slope parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) common/eqcomb/pres,temp,rho,enth,spgam(msp),amdot dimension y(msp),yy(msp),dydx(msp),dydx1(msp),w(msp) character*4 elemnm,spnm ! call conv1(yy,y,0) ! ! suppress negative species concentration do isp=1,nsp if(y(isp).lt.0.) y(isp)=1.0e-8 end do ! ! determine density rho y(nsp1)=0. do isp=1,nsp y(nsp1)=y(nsp1)+y(isp)*ie(isp) end do ! rho1=rho*1.0d-3 do 10 i=1,nsp1 y(i)=y(i)*1.0d-3 ! y(i)=dmax1(y(i)*1.0d-3,1.0d-20) 10 continue call der2(rho1,y,temp,dydx1,w,istep,nprt) do 20 i=1,nsp 20 dydx1(i)=dydx1(i)*1.0d3 call conv(dydx1,dydx,0) return end !*********************************************************************** subroutine der2(rho,g,tk,rate,w,istep,nprt) ! determines rate of production for equilibrium calculation ! for der1 for eqcal1 ! input parameters: ! rho=density, gram/cm3 ! g(i)=species mol concentrations, mol/gram ! tk=temperature, k ! istep=step number ! nprt=print index ! output parameters: ! rate(i),i=1,nsp1: rate of production of species i, mol/(gram-sec) ! w(i),i=1,n10: rate of production by reaction i, mol/(gram-sec) ! ier=error message. 0=no error. 1=error ! parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) dimension rate(msp),g(msp),g1(msp),ckf(msp),ckr(msp),w(msp) character*4 elemnm,spnm data itime/0/ ! ! set rate coefs if(istep.lt.2) then ! ! set variable parameters do k=1,n10 ckf(k)=0.d0 ckr(k)=0.d0 end do t1=1.d0/tk tlog=dlog(tk) ! ! construct forward rate coef ckf(j) and reverse rate coef ckr(j) ! arrays ! ! a+m-->b+c+m type z=10000.d0*t1 do j=n1,n6 akej=aka(1,j)/z+aka(2,j)+aka(3,j)*(-tlog+9.21034d0)+aka(4,j)*z & & + aka(5,j)*z*z ckf(j)=1.0d0 ckr(j)=rho*ckf(j)*dexp(-akej) end do ! ! a+b-->c+d type do j=n7,n10 akej=aka(1,j)/z+aka(2,j)+aka(3,j)*(-tlog+9.21034d0)+aka(4,j)*z & & + aka(5,j)*z*z ckf(j)=1.0d0 ckr(j)=ckf(j)*dexp(-akej) end do ! ! reduce the magnitudes of ckf and ckr do j=1,n10 ckf(j)=ckf(j)/ckr(j) ckr(j)=1.0d0 end do ! endif ! ! sum up individual reactions to compute rates do k=1,nsp rate(k)=0.d0 end do do jr=1,n10 ji1=lid(1,jr) ji2=lid(2,jr) jf1=lid(3,jr) jf2=lid(4,jr) ! type a+m=b+c+m if(jr.le.n6) then w(jr)=ckf(jr)*g(ji1)-ckr(jr)*g(jf1)*g(jf2) rate(ji1)=rate(ji1)-w(jr) rate(jf1)=rate(jf1)+w(jr) rate(jf2)=rate(jf2)+w(jr) endif ! exchange reactions if(jr.ge.n7) then w(jr)=ckf(jr)*g(ji1)*g(ji2)-ckr(jr)*g(jf1)*g(jf2) rate(ji1)=rate(ji1)-w(jr) rate(ji2)=rate(ji2)-w(jr) rate(jf1)=rate(jf1)+w(jr) rate(jf2)=rate(jf2)+w(jr) endif end do ! write(6,60) (w(jr),jr=1,n10) ! 60 format(/' w='/(2x,1p7e11.3)) ! write(6,10) rho,tk,(g(k),k=1,nsp) ! 10 format(' der2. rho,tk=',1p2e10.3,' g='/(1p8e9.2)) ! write(6,20) (rate(k),k=1,nsp) ! 20 format(' rate='/(1p8e9.2)) ! return end !*********************************************************************** subroutine diatom_bb(isp,tran,trot,tvib,tele) ! bound-bound transition in diatoms ! strength of each rotational line is from spradian ! line profile and template procedure are from neqair ! input parameters: ! isp=species index ! diatomnm(mdiatoms)=name of diatom ! tran=translational temperature, K ! trot=rotational temperature, K ! tvib=vibrational temperature, K ! tele=electron-electronic temperature, K ! diatom_bands(3,100)=list of diatom radiation mechanisms to be calculated parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom,minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100),contnm_diatom, & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms),contnm_diatom & & (2,5,mdiatoms),g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e dimension emisj(nw) common/scratch/ y(-nw:nw) ! write(6,15) diatomnm(isp),dens_diatom(isp) 15 format(' In diatom_bb. species = ',a4,1pe10.3,' cm-3') ! ineq=0 ! ! total partition function qtot qtot = 0. do ie = 1,nlev_diatom(isp) ge = g_diatom(ie,isp) te = te_diatom(ie,isp) we = we_diatom(ie,isp) wexe = wexe_diatom(ie,isp) weye = weye_diatom(ie,isp) weze = weze_diatom(ie,isp) be = be_diatom(ie,isp) ae = ae_diatom(ie,isp) de = de_diatom(ie,isp) betae = betae_diatom(ie,isp) do iv = 0, 22 rv = real(iv) bv = be - ae*(rv+0.5) dv = de + betae*(rv+0.5) ev = we*(rv+0.5) - wexe*(rv+0.5)**2 + weye*(rv+0.5)**3 & & + weze*(rv+0.5)**4 if((bv.lt.0.0).or.(ev.lt.0.0)) go to 98 ! partition function. use rigid rotator approximation for each v qtot = qtot + ge * dexp(-1.43877*(te/tele + ev/tvib)) & & * homo_fac(isp) * (trot/(1.43877d0*bv)) end do 98 continue end do ! !----------------------------------------------------------------------------------------- ! cycle over transitions do itr=1,nbb_diatom(isp) ! ! skip if not required ido = 0 do i = 1,195 if((bandnm_diatom(1,itr,isp).eq.diatom_bands(1,i)).and. & & (bandnm_diatom(2,itr,isp).eq.diatom_bands(2,i))) ido = 1 end do if(ido.eq.0) go to 20 ! ! echo status ! write(6,30) diatomnm(isp) ! 30 format(' in diatom_bb. species = ',a4) write(6,10) itr,(bandnm_diatom(k,itr,isp),k=1,2) 10 format(' itr=',i3,1x,2a4) neq_factor_k = 1.0 ie_up = nup_diatom(itr,isp) ie_lo = nlo_diatom(itr,isp) hund = hund_diatom(itr,isp) ! ! vibrational matrix do vu = 0, maxv_up_diatom(itr,isp) do vl = 0,maxv_lo_diatom(itr,isp) maxj =min(jim_v_diatom(vu,ie_up,isp), & & jim_v_diatom(vl,ie_lo,isp)) ! ! determine the band origin parameters geu = g_diatom(nup_diatom(itr,isp),isp) gel = g_diatom(nlo_diatom(itr,isp),isp) teu = te_diatom(nup_diatom(itr,isp),isp) tel = te_diatom(nlo_diatom(itr,isp),isp) weu = we_diatom(nup_diatom(itr,isp),isp) wel = we_diatom(nlo_diatom(itr,isp),isp) wexeu = wexe_diatom(nup_diatom(itr,isp),isp) wexel = wexe_diatom(nlo_diatom(itr,isp),isp) weyeu = weye_diatom(nup_diatom(itr,isp),isp) weyel = weye_diatom(nlo_diatom(itr,isp),isp) wezeu = weze_diatom(nup_diatom(itr,isp),isp) wezel = weze_diatom(nlo_diatom(itr,isp),isp) beu = be_diatom(nup_diatom(itr,isp),isp) bel = be_diatom(nlo_diatom(itr,isp),isp) aeu = ae_diatom(nup_diatom(itr,isp),isp) ael = ae_diatom(nlo_diatom(itr,isp),isp) deu = de_diatom(nup_diatom(itr,isp),isp) del = de_diatom(nlo_diatom(itr,isp),isp) betau = betae_diatom(nup_diatom(itr,isp),isp) betal = betae_diatom(nlo_diatom(itr,isp),isp) ! rvu = real(vu) rvl = real(vl) evu=weu*(rvu+0.5) - wexeu*(rvu+0.5)**2 + weyeu*(rvu+0.5)**3 & & + wezeu*(rvu+0.5)**4 evl=wel*(rvl+0.5) - wexel*(rvl+0.5)**2 + weyel*(rvl+0.5)**3 & & + wezel*(rvl+0.5)**4 dev = teu + evu - (tel + evl) ! band origin energy, cm-1 bvu = beu - aeu*(rvu+0.5) bvl = bel - ael*(rvl+0.5) dvu = deu + betau*(rvu+0.5) dvl = del + betal*(rvl+0.5) if(dev .le. 100.0) go to 999 ! electronic transition moment including franck-condon factor re1 = re1_diatom(vl,vu,itr,isp) ! wavelength of band origin (j = 0), angstrom wavel0 = 1.0d8/dev ! generate voigt profile for band origin ! ! gaussian width, angstrom ! slit function widthg = 7.16d-7*wavel0*dsqrt(tran/diatomwt(isp)) ! ! classical natural width, angstrom width1 = 1.18d-4 ! stark width, angstrom ! approximate default formula, assume energy to ionization to be 100000 cm-1 gam=0.042d0*(wavel0**2)/(100000.d0)**2 expn = 0.33d0 width2 = 2.0d0*gam*(1.d04*tele)**expn*dens_elec*1.d-16 ! pressure broadening by non-resonant collisions, traving cw3 = 5.85d-30*dsqrt(2.d0/diatomwt(isp)) width3 = cw3 * wavel0**2 ! ! lorenz width widthl = width1 + width2 + width3 ! ! voigt line half-width at half-height widthv = widthl/2.d0 + dsqrt(widthl**2/4.d0 + widthg**2) ! range over which the line shape must be drawn, in the units of half-half width range = 10.d0 ! ! determine the wavelength node for line center for band origin ! ncentr=nwave*((wavel_atom(k,isp)-wavmin)/(wavmax-wavmin))**(1./calpha) ncentr0=nwave*((wavel0-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr0 = (1./dsqrt(wavmin) - 1./dsqrt(wavel0))/estep + 1 ! ! determine wavelength interval at line center for band origin in angstrom witv = ((wavmax-wavmin)/float(nwave)**calpha)*calpha*float(ncentr0)**(calpha-1.) ! witv = 1.d0/(1.d0/dsqrt(wavmin) - estep*(ncentr0-1))**2 & ! & - 1.d0/(1.d0/dsqrt(wavmin) - estep*ncentr0)**2 ! witv = dabs(witv) ! ! determine line shape spreading index nspred nspred = 1 + range * widthv/witv if(nspred.ge.1000) nspred= 1000 ! generate voight profile function y wd1=1/widthv csprd2=widthl/widthv csprd3=(1.065+0.447*csprd2+0.058*csprd2**2)*widthv*1.0e-4 csprd1=(1.-csprd2)/csprd3 csprd2=csprd2/csprd3 do m = 1,nspred wavctr=wavel(ncentr0) csprd3=dabs((wavctr-wavel(m))*wd1) csp2=csprd3**2 csp3=csp2*dsqrt(dsqrt(csprd3)) y(m) = csprd1*dexp(-2.772*csp2)+csprd2/(1.+4.*csp2)+0.016* & & csprd2*(1.0-widthl*wd1)*(dexp(-0.4*csp3)-10.0/(10.0+csp3)) ratio=1.52*withv/witv if((m.eq.1).and.(ratio.lt.0.3)) y(0)=y(0)*ratio y(-m) = y(m) end do lam_u = lambda_diatom(nup_diatom(itr,isp),isp) lam_l = lambda_diatom(nlo_diatom(itr,isp),isp) spinu = s_diatom(nup_diatom(itr,isp),isp) spinl = s_diatom(nlo_diatom(itr,isp),isp) sou = spinorb_diatom(nup_diatom(itr,isp),isp) sol = spinorb_diatom(nlo_diatom(itr,isp),isp) ls_u = lam2_diatom(nup_diatom(itr,isp),isp) ls_l = lam2_diatom(nlo_diatom(itr,isp),isp) sisi = 0 ! When 1, all transition should be singlet to singlet transition if(sisi.eq.1) then spinu = 1 spinl = 1 hund= 'aa ' end if !========================================================================= ! 1X(a)-1X(a) transition if( ( ((lam_u.eq.0) .and. (lam_l.eq.0)) .or. & & ((lam_u.eq.1) .and. (lam_l.eq.1)) .or. & & ((lam_u.eq.2) .and. (lam_l.eq.2)) .or. & & ((lam_u.eq.3) .and. (lam_l.eq.3))) .and. & & ((spinu.eq.1) .and. (spinl.eq.1)) .and. & & (hund.eq.'aa ') ) then ! if((vu.eq.0).and.(vl.eq.9)) write(6,*) & & ' 1X-1X: Hund case = aa. ',bandnm_diatom(1,itr,isp), & & bandnm_diatom(2,itr,isp) do j= 1, maxj do k= 1, 3 call calc_1X1X(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax = dexp(-1.43877d0*1.d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 1X(a)-1Y(a) transition if((((lam_u.eq.0).and.(lam_l.eq.1)) .or. & & ((lam_u.eq.1).and.(lam_l.eq.0)) .or. & & ((lam_u.eq.1).and.(lam_l.eq.2)) .or. & & ((lam_u.eq.2).and.(lam_l.eq.1)) .or. & & ((lam_u.eq.2).and.(lam_l.eq.3)) .or. & & ((lam_u.eq.3).and.(lam_l.eq.2))) .and. & & ((spinu.eq.1).and.(spinl.eq.1)).and.(hund.eq.'aa ')) then if((vu.eq.0).and.(vl.eq.9)) write(6,*) & & ' 1X-1Y: Hund case = aa. ',bandnm_diatom(1,itr,isp), & & bandnm_diatom(2,itr,isp) do j= 1, maxj do k = 1, 3 call calc_1X1Y(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if enddo end do end do end if !======================================================================= ! 2S - 2S transition (Hund's b): see Schadee, 1964 if( ((lam_u.eq.0).and.(lam_l.eq.0)).and.((spinu.eq.2).and. & & (spinl.eq.2)).and.(hund.eq.'bb ')) then if((vu.eq.0).and.(vl.eq.9)) write(6,*) & & ' 2S-2S: Hund case = bb. ',bandnm_diatom(1,itr,isp), & & bandnm_diatom(2,itr,isp) do j= 1, maxj do k=1, 12 call calc_2S2S(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj, & & ncentr,lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if enddo enddo end do end if !======================================================================= ! 2P - 2P transition (Hund's b): see Schadee, 1964 if( ((lam_u.eq.1).and.(lam_l.eq.1)).and.((spinu.eq.2).and. & & (spinl.eq.2)).and.(hund.eq.'bbpp ') ) then if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 2P-2P: Hund case = bbpp. ',bandnm_diatom(1,itr,isp), & & bandnm_diatom(2,itr,isp) ! do j= 1, maxj do k= 1, 12 call calc_2P2P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj, & & ncentr,lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if enddo enddo end do end if !======================================================================= ! 2X - 2X transition (intermediate states), See Kovacs if((((lam_u.eq.0).and.(lam_l.eq.0)) .or. & & ((lam_u.eq.1).and.(lam_l.eq.1)) .or. & & ((lam_u.eq.2).and.(lam_l.eq.2))) .and. & & ((spinu.eq.2).and.(spinl.eq.2)).and.(hund .eq. 'intd ')) then if((vu.eq.0).and.(vl.eq.9)) write(6,*) & & ' 2X-2X: Hund case = intd(intermediate) ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) ! do j= 1, maxj do k=1, 12 call calc_2X2X(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj, & & ncentr,lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do enddo end do end if !======================================================================= ! 2S-2P, 2P-2S transitions (intermediate states), See Arnold 1969 if((((lam_u.eq.1).and.(lam_l.eq.0)).or. & & ((lam_u.eq.0).and.(lam_l.eq.1))) .and. & & ((spinu.eq.2).and.(spinl.eq.2)).and.(hund .eq.'insp ')) then if((vu.eq.0).and.(vl.eq.9)) write(6,*) & & ' 2S-2P: Hund case = insp(intermediate) ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) do j= 1, maxj do k= 1, 12 call calc_2S2P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj, & & ncentr,lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if enddo enddo enddo end if !======================================================================= ! 2X - 2Y transition (intermediate states), See Kovacs if((((lam_u.eq.1).and.(lam_l.eq.0)).or. & & ((lam_u.eq.0).and.(lam_l.eq.1)) .or. & & ((lam_u.eq.1).and.(lam_l.eq.2)) .or. & & ((lam_u.eq.2).and.(lam_l.eq.1))) .and. & & ((spinu.eq.2).and.(spinl.eq.2)).and.(hund.eq.'intd ') ) then ! if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & '2X-2Y: Hund.s case = intd (intermediate). ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) do j= 1, maxj do k= 1, 12 call calc_2X2Y(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj, & & ncentr,lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 3S - 3S transition (Hund's case b) if((((lam_u.eq.0).and.(lam_l.eq.0))).and.((spinu.eq.3).and. & & (spinl.eq.3)).and.(hund.eq.'bb ')) then ! if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 3S-3S: Hund case = bb. ',bandnm_diatom(1,itr,isp), & & bandnm_diatom(2,itr,isp) do j= 1, maxj do k= 1, 27 call calc_3S3S(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol,ls_u,ls_l) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 3P - 3P transition (Hund's case b) if((((lam_u.eq.1).and.(lam_l.eq.1))).and.((spinu.eq.3).and. & & (spinl.eq.3)).and.(hund.eq.'bbpp ')) then if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 3P-3P: Hund case = bbpp. ',bandnm_diatom(1,itr,isp), & & bandnm_diatom(2,itr,isp) do j= 1, maxj do k= 1, 27 call calc_3P3P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol,ls_u,ls_l) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 3X - 3X transition (intermediate states) if((((lam_u.eq.0).and.(lam_l.eq.0)).or. & & ((lam_u.eq.1).and.(lam_l.eq.1)) .or. & & ((lam_u.eq.2).and.(lam_l.eq.2))) .and. & & ((spinu.eq.3).and.(spinl.eq.3)).and.(hund.eq.'intd ')) then if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 3X-3X: Hund case = intd(intermediate). ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) ! do j= 1, maxj do k=1, 27 call calc_3X3X(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 3S-3P, 3P-3S transitions if((((lam_u.eq.0).and.(lam_l.eq.1)) .or. & & ((lam_u.eq.1).and.(lam_l.eq.0))) .and. & & ((spinu.eq.3).and.(spinl.eq.3)).and.(hund.eq.'insp ') ) then if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 3S-3P or 3P-3S: Hund case = insp(intermediate). ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) ! do j= 1, maxj do k = 1, 27 call calc_3S3P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 3X - 3Y transition (intermediate states) if((((lam_u.eq.0).and.(lam_l.eq.1)) .or. & & ((lam_u.eq.1).and.(lam_l.eq.0)) .or. & & ((lam_u.eq.1).and.(lam_l.eq.2)) .or. & & ((lam_u.eq.2).and.(lam_l.eq.1))) .and. & & ((spinu.eq.3).and.(spinl.eq.3)).and.(hund.eq.'intd ')) then if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 3X-3Y: Hund case = intd(intermediate). ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) do j= 1, maxj do k=1, 27 call calc_3X3Y(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 5X - 5Y TRANSITION, X = PI, DEL, OR FI if((lam_u.ge.1).and.(lam_l.ge.1) .and. & & (spinu.eq.5).and.(spinl.eq.5)) then if((lam_u.eq.0).and.(lam_l.eq.1)) go to 888 if((lam_u.eq.1).and.(lam_l.eq.0)) go to 888 if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 5X-5X: no Hund case identifiable. ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) do k = 1, 300 do j=1, maxj call calc_bb5p5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do 888 continue endif !======================================================================= ! 5S - 5P TRANSITION if((lam_u.eq.0).and.(lam_l.eq.1) .and. & & (spinu.eq.5).and.(spinl.eq.5)) then if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 5SIGMA - 5PI: no Hund case identifiable. ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) do k = 1, 300 do j=1, maxj call calc_bb5s5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 5P - 5S TRANSITION if((lam_u.eq.1) .and. (lam_l.eq.0) .and. & & (spinu.eq.5).and.(spinl.eq.5)) then if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 5P5S: no Hund case identifiable. ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) do k = 1, 300 do j=1, maxj call calc_bb5p5s(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !======================================================================= ! 7X - 7Y TRANSITION if((spinu.eq.7) .and. (spinl.eq.7) ) then if((vu.eq.0).and.(vl.eq.0)) write(6,*) & & ' 7X-7Y: no Hund case identifiable. ', & & bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp) do k = 1, 300 do j=1, maxj call calc_bb5p5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu, & & tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, & & lam_u,lam_l,sou,sol) do m = -nspred,nspred if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then emission = emisj(j) * y(m) ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele)) blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5* & & (1.d0-ax)) cross=(emission/blam)/dens_diatom(isp) absorption=cross*dens_diatom(isp) absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption end if end do end do end do end if !--------------------------------------------------------- 999 continue ! dev is negative ! Check input data for two states ! end do ! end of cycle over vl (lower v) end do ! end of cycle over vu (upper v) 20 continue end do ! end of cycle over transition ! return end !*********************************************************************** subroutine diatom_bf(isp,temp) ! continuum of diatomic molecules ! input parameters: ! isp=species index ! diatomnm(mdiatoms)=name of diatom ! temp=temperature, K parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom, & & neq_factor_k,ls_u,ls_l character*5 dum(90),hund_diatom,hund character*4 asterik,atomnm2(matoms),bandnm_diatom,contnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo_state,s_diatom,up_state, & & g_atom1,g_atom2,gneq_diatom,check,ncentr(301) integer vu,vl,spinu, spinl,sisi common/comi/nwave common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms),contnm_diatom & & (2,5,mdiatoms),g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e real*8 minwavel,maxwavel common/scratch/y(nw) dimension emisj(nw),tlog(15),wavelx(501),cross(501) ! ! echo status write(6,10) diatomnm(isp),dens_diatom(isp) 10 format(' in diatom_bf. species = ',a4,1pe10.3,' cm-3') ! cycle over transitions do itr=1,ncont_diatom(isp) write(6,40) (contnm_diatom(i,itr,isp),i=1,2) 40 format(' calculate ', 2a4) nwavex = ncont_wavel_diatom(itr,isp) minwavel = wavel_cont_diatom(1,itr,isp) maxwavel = wavel_cont_diatom(nwavex,itr,isp) ! ncentr=nwave*((wavel_atom(k,isp)-wavmin)/(wavmax-wavmin))**(1./calpha) nstrt = nwave*((minwavel-wavmin)/(wavmax-wavmin))**(1./calpha) ! nstrt = (1.0/dsqrt(wavmin) - 1./dsqrt(minwavel))/estep + 1 if(nstrt.lt.1) nstrt = 1 nend = nwave ntemp = ncont_temp_diatom(itr,isp) if(nstrt.lt.1) nstrt = 1 if(nend.gt.nwave) nend = nwave ! ! interpolate absorption cross sections for given electron temperature do it = 1,ntemp tlog(it) = dlog(temp_cont_diatom(it,itr,isp)) end do tlogx = dlog(temp) mon = 0 do iwave = 1, nwavex wavelx(iwave) = wavel_cont_diatom(iwave,itr,isp) do it = 1, ntemp if(cross_diatom(it,iwave,itr,isp).gt.1.e-20) & & y(it) = dlog(cross_diatom(it,iwave,itr,isp)) if(cross_diatom(it,iwave,itr,isp).le.1.e-20) & & y(it) = dlog(1.d-20) end do if(temp.lt.temp_cont_diatom(ntemp,itr,isp)) & & call taint(tlog,y,tlogx,crossx,ntemp,2,ner,mon) if(temp.ge.temp_cont_diatom(ntemp,itr,isp)) & & call taint(tlog,y,tlogx,crossx,ntemp,1,ner,mon) cross(iwave) = crossx end do ! ! interpolate to find cross section crosx mon = 0 do m = nend,nstrt,-1 if((wavel(m).gt.minwavel).and.(wavel(m).lt.maxwavel)) then call taint(wavelx,cross,wavel(m),crosx,nwavex,1,ner,mon) absorption = dexp(crosx) * dens_diatom(isp) ax = dexp(-1.43877*1.0d8/(wavel(m)*temp)) blam = 1.1904d-16 * ax/((1.0d-8*wavel(m))**5*(1.0 - ax)) emission = absorption * blam absb(m) = absb(m) + absorption end if enddo ! end if !20 continue end do return end !***************************************************************************** subroutine diatom_read(ndiatoms) ! read diatomic data from diatom.dat ! input parameters: ! ndiatoms=number of diatomic molecules ! diatomnm1(mdiatoms)=name of diatoms ! diatom_bands(3,100)=diatomic radiation mechanisms to be calculated ! output parameters: ! diatomnm(mdiatoms)=name of diatoms parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) implicit real*8(a-h,o-z) real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom character*1 dum(90) character*5 hund_diatom character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100),contnm_diatom, & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 integer charge_diatom,g_diatom,lo,s_diatom,g_atom1,g_atom2, & & gneq_diatom,check,up_state common/comadiatom/ae_diatom(46,mdiatoms), & & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms), & & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms), & & atomwt2(mdiatoms),be_diatom(46,mdiatoms), & & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms), & & betae_diatom(46,mdiatoms), & & cross_diatom(11,121,21,mdiatoms), & & cross_imp_diatom(11,11,11,mdiatoms), & & de_diatom(46,mdiatoms),diatom_mass(mdiatoms), & & diatomwt(mdiatoms), & & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms), & & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms), & & FC_imp_diatom(0:11,0:11,11,11,mdiatoms), & & e_elec_imp_diatom(11,11,11,mdiatoms), & & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms), & & lam2_diatom(46,mdiatoms), & & n_himp_bb_diatom(11,11,11,mdiatoms), & & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms), & & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms), & & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms), & & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms), & & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms), & & td_himp_bb_diatom(11,11,11,mdiatoms), & & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms), & & wavel_cont_diatom(121,0:21,mdiatoms), & & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms), & & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms) common/comidiatom/charge_diatom(mdiatoms),contnm_diatom & & (2,5,mdiatoms),g_diatom(46,mdiatoms),g_atom1(11,mdiatoms), & & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms), & & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms), & & maxvl_FC_diatom(0:11,0:11,mdiatoms), & & maxvu_FC_diatom(0:11,0:11,mdiatoms), & & maxv_up_diatom(45,mdiatoms), & & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms), & & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms), & & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms), & & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms), & & nup_diatom(45,mdiatoms), & & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms) common/comhund/hund_diatom(35,mdiatoms) ! data asterik/'****'/,minus1/'-1 '/ ! write(2,900) 900 format(' in diatom_read') ! ! start counting chemical species number isp=0 ! read asterik line read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) 10 format(90a1) 10000 continue read(8,20) unknown,(dum(i),i=1,90) write(2,20) unknown,(dum(i),i=1,90) 20 format(a4,90a1) if(unknown.eq.minus1) then write(2,160) (diatomnm(isp),isp=1,ndiatoms) 160 format(' diatomic data finished reading for ',10a4) return end if ! ! check if this species is required check = 0 do i=1,mdiatoms if(unknown.eq.diatomnm1(i)) then do j=1,173 if(unknown.eq.diatom_bands(1,j)) check=1 end do end if end do if(check.eq.1) then isp=isp+1 go to 130 endif ! this species is not needed and skipped write(2,140) 140 format(' this species is skipped') 150 read(8,20) unknown,(dum(i),i=1,70) if(unknown.ne.asterik) go to 150 go to 10000 130 continue ! set species name diatomnm(isp) = trim(adjustl(unknown)) ! ! prepare to read diatomic level data read(8,30) diatom_mass(isp), (dum(i),i=1,50) write(2,30) diatom_mass(isp), (dum(i),i=1,50) 30 format(e11.3,70a1) read(8,30) diatomwt(isp), (dum(i),i=1,50) write(2,30) diatomwt(isp), (dum(i),i=1,50) read(8,30) reduced_mass(isp), (dum(i),i=1,50) write(2,30) reduced_mass(isp), (dum(i),i=1,50) read(8,30) dissoc_eny(isp), (dum(i),i=1,50) write(2,30) dissoc_eny(isp), (dum(i),i=1,50) read(8,30) spin_nuc(isp), (dum(i),i=1,50) write(2,30) spin_nuc(isp), (dum(i),i=1,50) read(8,30) homo_fac(isp), (dum(i),i=1,50) write(2,30) homo_fac(isp), (dum(i),i=1,50) read(8,40) charge_diatom(isp), (dum(i),i=1,50) write(2,40) charge_diatom(isp), (dum(i),i=1,50) read(8,40) nlev_diatom(isp), (dum(i),i=1,50) write(2,40) nlev_diatom(isp), (dum(i),i=1,50) 40 format(i11,70a1) ! do i1=1,3 read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) enddo ! ! read diatomic level data do lev=1,nlev_diatom(isp) read(8,50) (dum(i),i=1,13), & & te_diatom(lev,isp),re_diatom(lev,isp),g_diatom(lev,isp), & & dzero_diatom(lev,isp),we_diatom(lev,isp),wexe_diatom(lev,isp), & & weye_diatom(lev,isp),weze_diatom(lev,isp),be_diatom(lev,isp), & & ae_diatom(lev,isp),de_diatom(lev,isp),betae_diatom(lev,isp), & & spinorb_diatom(lev,isp),lambda_diatom(lev,isp), & & s_diatom(lev,isp),lam2_diatom(lev,isp) write(2,50) (dum(i),i=1,13), & & te_diatom(lev,isp),re_diatom(lev,isp),g_diatom(lev,isp), & & dzero_diatom(lev,isp),we_diatom(lev,isp),wexe_diatom(lev,isp), & & weye_diatom(lev,isp),weze_diatom(lev,isp),be_diatom(lev,isp), & & ae_diatom(lev,isp),de_diatom(lev,isp),betae_diatom(lev,isp), & & spinorb_diatom(lev,isp),lambda_diatom(lev,isp), & & s_diatom(lev,isp),lam2_diatom(lev,isp) 50 format(13a1,f10.2,f8.4,i3,f10.2,f10.3,f9.4,e11.3,e11.3,f9.5, & & e11.3,e11.3,e11.3,e11.3,2i3,e11.3) enddo ! ! prepare to read max rotational quantum numbers do j=1,5 read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) enddo ! read max rotational quantum numbers do ilev=1,nlev_diatom(isp) read(8,60) jlev,(jim_v_diatom(iv,ilev,isp),iv=0,21) write(2,60) jlev,(jim_v_diatom(iv,ilev,isp),iv=0,21) 60 format(i6,23i6) enddo ! ! number of radiative transitions read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) read(8,70) nbb_diatom(isp), (dum(i),i=1,70) write(2,70) nbb_diatom(isp),(dum(i),i=1,70) read(8,70) ncont_diatom(isp),(dum(i),i=1,70) write(2,70) ncont_diatom(isp),(dum(i),i=1,70) 70 format(i10,90a1) read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) ! ! read bound-bound radiation data do iband=1,nbb_diatom(isp) read(8,80) (bandnm_diatom(i,iband,isp),i=1,2),(dum(i),i=1,60) write(2,80) (bandnm_diatom(i,iband,isp),i=1,2),(dum(i),i=1,60) 80 format(2a4,70a1) read(8,90) & & nup_diatom(iband,isp),(dum(i),i= 1,17), & & nlo_diatom(iband,isp),(dum(i),i=18,34), & & hund_diatom(iband,isp),(dum(i),i=35,50) write(2,90) & & nup_diatom(iband,isp),(dum(i),i= 1,17), & & nlo_diatom(iband,isp),(dum(i),i=18,34), & & hund_diatom(iband,isp),(dum(i),i=35,50) 90 format(i5,17a1,i3,17a1,a5,16a1) do i1=1,5 read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) enddo read(8,91) & & maxv_up_diatom(iband,isp),(dum(i),i=1,17), & & maxv_lo_diatom(iband,isp),(dum(i),i=18,40) write(2,91) & & maxv_up_diatom(iband,isp),(dum(i),i=1,17), & & maxv_lo_diatom(iband,isp),(dum(i),i=18,40) 91 format(i5,17a1,i3,50a1) do j=1,3 read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) enddo ! do ivu=0, maxv_up_diatom(iband,isp) read(8,100) (dum(i),i=1,3), & & (re1_diatom(ivl,ivu,iband,isp),ivl=0, & & maxv_lo_diatom(iband,isp)) write(2,110) (dum(i),i=1,3), & & (re1_diatom(ivl,ivu,iband,isp),ivl=0, & & maxv_lo_diatom(iband,isp)) 100 format(3a1,22e8.1) 110 format(3a1,1p22es8.2e1) enddo read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) end do !------------------------------------------------------------------- ! prepare to read molecular continuum data if(ncont_diatom(isp).eq. 0) go to 120 do 125 iband=1,ncont_diatom(isp) ! cycle over continuum starts read(8,80) (contnm_diatom(i,iband,isp),i=1,2),(dum(i),i=1,60) write(2,80) (contnm_diatom(i,iband,isp),i=1,2),(dum(i),i=1,60) do i1=1,2 read(8,10) (dum(i),i=1,79) write(2,10) (dum(i),i=1,79) end do read(8,70) ncont_temp_diatom(iband,isp),(dum(i),i=1,60) write(2,70) ncont_temp_diatom(iband,isp),(dum(i),i=1,60) read(8,70) ncont_wavel_diatom(iband,isp),(dum(i),i=1,60) write(2,70) ncont_wavel_diatom(iband,isp),(dum(i),i=1,60) read(8,10) (dum(i),i=1,79) write(2,10) (dum(i),i=1,79) ! nvuvtemp = ncont_temp_diatom(iband,isp) nvuvwave = ncont_wavel_diatom(iband,isp) ! read(8,200) (dum(i),i=1,11),(temp_cont_diatom(it,iband,isp), & & it=1,nvuvtemp) write(2,200) (dum(i),i=1,11),(temp_cont_diatom(it,iband,isp), & & it=1,nvuvtemp) 200 format(11a1,7f10.1) read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) ! ! read molecular continuum data do iwav=1, nvuvwave read(8,210) wavel_cont_diatom(iwav,iband,isp), & & (cross_diatom(it,iwav,iband,isp),it=1,nvuvtemp) write(2,210) wavel_cont_diatom(iwav,iband,isp), & & (cross_diatom(it,iwav,iband,isp),it=1,nvuvtemp) 210 format(f10.2,7e10.3) enddo read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) 125 continue ! !------------------------------------------------------------------------------------ ! prepare to read collisional excitation parameters 120 continue read(8,270) (dum(i),i=1,12),atomnm1(isp),(dum(i),i=13,14), & & atomnm2(isp),(dum(i),i=15,90) write(2,270) (dum(i),i=1,12),atomnm1(isp),(dum(i),i=13,14), & & atomnm2(isp),(dum(i),i=15,90) 270 format(12a1,a3,2a1,a3,90a1) read(8,170) neq_lev_diatom(isp),(dum(i),i=1,70) write(2,170) neq_lev_diatom(isp),(dum(i),i=1,70) 170 format(i5,90a1) ! if(neq_lev_diatom(isp).eq. 0) go to 180 ! no data, skip ! ! read dissociated atoms parameters read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) read(8,290) atomwt1(isp),(dum(i),i=1,50) write(2,290) atomwt1(isp),(dum(i),i=1,50) 290 format(f10.2,50a1) do i=1,4 read(8,300) Ecm_atom1(i,isp),g_atom1(i,isp),(dum(j),j=1,39) write(2,300) Ecm_atom1(i,isp),g_atom1(i,isp),(dum(j),j=1,39) 300 format(f10.2,i10,40a1) end do read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) read(8,290) atomwt2(isp),(dum(i),i=1,50) write(2,290) atomwt2(isp),(dum(i),i=1,50) do i=1,4 read(8,300) Ecm_atom2(i,isp),g_atom2(i,isp),(dum(j),j=1,39) write(2,300) Ecm_atom2(i,isp),g_atom2(i,isp),(dum(j),j=1,39) end do read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) ! ! read collisional excitation data ! ! collisional bound-free transition data ! read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) do ilev=1,neq_lev_diatom(isp) ! electron-impact bf data read(8,220) (dum(i),i=1,24),gneq_diatom(ilev,isp), & & barrier_diatom(ilev,isp),a_eimp_diatom(ilev,isp), & & an_eimp_diatom(ilev,isp),td_eimp_diatom(ilev,isp) write(2,220) (dum(i),i=1,24),gneq_diatom(ilev,isp), & & barrier_diatom(ilev,isp),a_eimp_diatom(ilev,isp), & & an_eimp_diatom(ilev,isp),td_eimp_diatom(ilev,isp) 220 format(24a1,i3,f9.2,e10.3,f8.4,f10.2) ! heavy-particle-impact bf data do im=1,6 read(8,222) (dum(i),i=1,36),a_himp_diatom(ilev,im,isp), & & n_himp_diatom(ilev,im,isp),td_himp_diatom(ilev,im,isp) 222 format(36a1,e10.3,f8.4,e10.3) write(2,222) (dum(i),i=1,36),a_himp_diatom(ilev,im,isp), & & n_himp_diatom(ilev,im,isp),td_himp_diatom(ilev,im,isp) end do end do read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) 260 continue ! ! prepare to read bound-bound electron-impact transition rate data ! ! specify lower and upper states read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) read(8,90) lo_state,(dum(i),i=1,17),up_state,(dum(i),i=18,40) write(2,90) lo_state,(dum(i),i=1,17),up_state,(dum(i),i=18,40) ! ! read radiative transition probability between lower and upper states read(8,240) & & (prob_diatom(im,lo_state,up_state,isp),im=0,7),(dum(i),i=1,10) write(2,240) & & (prob_diatom(im,lo_state,up_state,isp),im=0,7),(dum(i),i=1,10) 240 format(8e10.3,10a1) ! ! prepare to read Franck-Condon factors read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) read(8,90) & & maxvu_FC_diatom(lo_state,up_state,isp),(dum(i),i=1,17), & & maxvl_FC_diatom(lo_state,up_state,isp),(dum(i),i=18,40) write(2,90) & & maxvu_FC_diatom(lo_state,up_state,isp),(dum(i),i=1,17), & & maxvl_FC_diatom(lo_state,up_state,isp),(dum(i),i=18,40) do i1=1,3 read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) enddo ! max_vu = maxvu_FC_diatom(lo_state,up_state,isp) max_vl = maxvl_FC_diatom(lo_state,up_state,isp) ! ! read franck-condon factors do ivu=0, max_vu read(8,250) i, & & (FC_imp_diatom(ivl,ivu,lo_state,up_state,isp),ivl=0,max_vl) write(2,251) i, & & (FC_imp_diatom(ivl,ivu,lo_state,up_state,isp),ivl=0,max_vl) 250 format(i3,14e8.1) 251 format(i3,1p14e8.1) enddo ! ! read banner for electron-impact excitation data read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) ! ! set meth (method of specifying electron-impact excitation value) ! meth=1 if cross section specified. meth=2 if rate parameter specified if((dum(1).eq.'E').or.(dum(1).eq.'e')) & & meth_imp_diatom(lo_state,up_state,isp)=1 if((dum(1).eq.'R').or.(dum(1).eq.'r')) & & meth_imp_diatom(lo_state,up_state,isp)=2 ! ! meth=1 if(meth_imp_diatom(lo_state,up_state,isp).eq.1) then ! electron energy, ev read(8,225) (dum(i),i=1,21), & & (e_elec_imp_diatom(iev,lo_state,up_state,isp),iev=1,8) write(2,226) (dum(i),i=1,21), & & (e_elec_imp_diatom(iev,lo_state,up_state,isp),iev=1,8) 225 format(21a1,8e10.3) 226 format(21a1,1p8e10.3) ! excitation cross section, cm2 read(8,225) (dum(i),i=1,21), & & (cross_imp_diatom(iev,lo_state,up_state,isp),iev=1,8) write(2,226) (dum(i),i=1,21), & & (cross_imp_diatom(iev,lo_state,up_state,isp),iev=1,8) ! ! default values of electron energy if(e_elec_imp_diatom(1,lo_state,up_state,isp).lt.0.001) then do iev = 1,8 e_elec_imp_diatom(iev,lo_state,up_state,isp) = & & ((te_diatom(up_state,isp)-te_diatom(lo_state,isp))/ & & 8067.5) *1.3**(ilev-1) end do do iev = 1,8 x=e_elec_imp_diatom(iev,lo_state,up_state,isp)/ & & e_elec_imp_diatom(1,lo_state,up_state,isp) if((charge_diatom(isp).eq.0).and. & & (s_diatom(lo_state,isp).eq.s_diatom(up_state,isp))) then cross_diatom(iev,lo_state,up_state,isp)= & & 3.14159 * (0.5292*1.0e-8)**2 * log(x)/x end if ! default values of cross section if((charge_diatom(isp).eq.0).and. & & (s_diatom(lo_state,isp).ne.s_diatom(up_state,isp))) then cross_diatom(iev,lo_state,up_state,isp)=3.14159 & & *(0.5292*1.0e-8)**2*0.65*(x-1.0)/(1.0+(x-1.0)**2) end if if(charge_diatom(isp).eq.1) then cross_diatom(iev,lo_state,up_state,isp)= & & 3.14159*(0.5292*1.0e-8)**2*3.4*(2.+x)/(2.+x**2) end if end do write(2,280) & & (e_elec_imp_diatom(iev,lo_state,up_state,isp),iev=1,8), & & (cross_diatom(iev,lo_state,up_state,isp),iev=1,8) 280 format(' default elect energy:',8f10.4/'default cros section:' & & ,1p8e10.3) end if end if ! ! meth=2 if(meth_imp_diatom(lo_state,up_state,isp).eq.2) then read(8,225) (dum(i),i=1,21), & & (ratep_diatom(iev,lo_state,up_state,isp),iev=1,3) write(2,225) (dum(i),i=1,21), & & (ratep_diatom(iev,lo_state,up_state,isp),iev=1,3) end if ! ! read heavy particle-impact bound-bound transition rate parameters read(8,10) (dum(i),i=1,90) write(2,10) (dum(i),i=1,90) read(8,10) (dum(i),i=1,89) write(2,10) (dum(i),i=1,90) read(8,10) (dum(i),i=1,89) write(2,10) (dum(i),i=1,90) do im=1,6 read(8,310) (dum(i),i=1,15), & & a_himp_bb_diatom(im,lo_state,up_state,isp), & & n_himp_bb_diatom(im,lo_state,up_state,isp), & & td_himp_bb_diatom(im,lo_state,up_state,isp) 310 format(15a1,3e10.3) 311 format(15a1,1p3e10.3) write(2,311) (dum(i),i=1,15), & & a_himp_bb_diatom(im,lo_state,up_state,isp), & & n_himp_bb_diatom(im,lo_state,up_state,isp), & & td_himp_bb_diatom(im,lo_state,up_state,isp) end do ! ! default values of a, n, and td read(8,20) unknown,(dum(i),i=1,70) write(2,20) unknown,(dum(i),i=1,70) if(unknown.eq.asterik) go to 10000 go to 260 ! ! this species has ended 180 continue read(8,20) unknown,(dum(i),i=1,70) write(2,20) unknown,(dum(i),i=1,70) if(unknown.ne.asterik)go to 180 go to 10000 ! end !************************************************************************** subroutine eintf(pft,pfti,tmax,tmin) ! calculates coefficients for expressions for internal energy and ! electronic energy ! inputs: ! pft(5,20,3)=total partition functions at 5 temperatures ! pfti(5,20,3)=internal partition functions at 5 temperatures ! tmax=maximum temperature, K ! tmin=minimum temeprature, K parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) character*4 elemnm,spnm dimension tt(5),tt1(5),xx(5,5),b(5),wkarea(msp),elenf(5),pft & & (5,msp,3),pfti(5,msp,3) ! tdif=0.25d0*(tmax-tmin) do 330 jt=1,5 tt(jt)=tmin+tdif*(jt-1) 330 tt1(jt)=10000.d0/tt(jt) ! ! internal energy (without translational-rotational energy), J/mol do 440 jt=1,5 temp=tt(jt) dtemp=0.002d0*temp do 400 jsp=1,nsp1 akbjt=1.3805d-23*6.025d23*temp**2*dlog(pft(jt,jsp,3)/ & & pft(jt,jsp,1))/(2.0d0*dtemp)-(12.4716d0+8.3148d0*im(jsp))*temp akb(jt,jsp)=dmax1(akbjt,1.0d-10) 400 continue 440 continue ! ! determine 5 coefficients expressing internal energy ! eint=exp[akb(1,j)/z+akb(2,j)+akb(3,j)*ln(z)+akb(4,j)*z+akb(5,j)*z**2] ! where z=10000./temp ! ! set independent variables xx(j,i) ! j=row number, i=column number do 530 jsp=1,nsp1 do 540 j=1,5 b(j)=dlog(akb(j,jsp)) xx(j,1)=1.d0/tt1(j) xx(j,2)=1.0d0 xx(j,3)=dlog(tt1(j)) do 540 i=4,5 540 xx(j,i)=tt1(j)**(i-3) call leqt2f(xx,1,5,5,b,0,wkarea,ier) do 541 j=1,5 541 akb(j,jsp)=b(j) 530 continue !----------------------------------------------------------------------- ! determine 5 coefficients expressing electronic energy, J/kg ! elenf=exp[akd(1,j)/z+akd(2,j)+akd(3,j)*ln(z)+akd(4,j)*z+akd(5,j)*z**2] ! where z=10000./temp ! do 10 isp=1,nsp nlev=nelec(isp) do 30 jt=1,5 te=tt(jt) q=0.d0 els=0.d0 do 20 ilev=1,nlev ! ! atom if(im(isp).eq.0) then expe=dexp(-1.4388d0*atome(ilev,isp)/te) q=q+atomg(ilev,isp)*expe els=els+atome(ilev,isp)*atomg(ilev,isp)*expe endif ! ! molecule if(im(isp).eq.1) then ge=spect(1,ilev,isp) tex=spect(2,ilev,isp) expe=dexp(-1.4388d0*tex/te) q=q+ge*expe els=els+tex*ge*expe endif ! 20 continue elenf(jt)=1.4388d0*1.3806d-23*6.026d23*els/q +1.0D-10 30 continue ! do 40 j=1,5 b(j)=dlog(elenf(j)) xx(j,1)=1.d0/tt1(j) xx(j,2)=1.0d0 xx(j,3)=dlog(tt1(j)) do 40 i=4,5 40 xx(j,i)=tt1(j)**(i-3) call leqt2f(xx,1,5,5,b,0,wkarea,ier) do 50 j=1,5 akd(j,isp)=b(j) 50 continue ! 10 continue ! return end !********************************************************************** subroutine emis_absb(nprt,natomsx,ndiatomsx,ntriatoms,inode, & & tran,trot,tvib,tele, & & concAl,concAlp,concAlpp,concAl3p, & & concC, concC2, & & concCa,concCap,concCl,concC2H, & & concC3,concCH, concCN,concCO, & & concCO2,concCp, concCpp,concC3p, & & concC4p,concCr,concCrp,concCrpp, & & concFe,concFeO,concFep,concFepp, & & concFe3p,concFe4p,concFe5p,concH, & & concH2, concHp,concH2O,concK, & & concMg, concMgO,concMgp,concMgpp, & & concMg3p,concMg4p,concN,concNE, & & concN2,concN2p,concNp,concNpp, & & concN3p,concN4p,concNa,concNap, & & concNO,concNi,concNip,concNipp, & & concNi3p,concO,concO2,concOH, & & concOp,concOpp,concO3p,concO4p, & & concS,concSi,concSO,concSiO, & & concSip,concSipp,concSi3p,concSi4p, & & concSp,concSpp,concS3p,concS4p, & & concSiH,concTi,concTip,concTipp, & & concTi3p,concTiO, & & avg_molwt) ! emission and absorption calculation parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,mnode=1,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 ion_pot,n_himp_bb_diatom,lam2_diatom, & & n_himp_diatom,ix_lev_triatom,iy_lev_triatom,iz_lev_triatom, & & intens integer g_atom,gi_atom,gk_atom,g_diatom,g_atom1,g_atom2, & & gneq_diatom,s_diatom,up,gg_lev_triatom,ge_lev_triatom, & & spin_lev_triatom,g1_lev_triatom,g2_lev_triatom,g3_lev_triatom, & & charge_diatom,g_neq_lev_atom,g_ion common/coma1/atomwt(matoms),ion_pot(matoms), & & Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms), & & starkg(line_tot,matoms), & & starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms), & & ei_atom(line_tot,matoms),ek_atom(line_tot,matoms), & & wavel_atom(line_tot,matoms),aki_atom(line_tot, & & matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms), & & e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms) & & ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms), & & ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms), & & eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms) common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23, & & matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom, & & matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms), & & ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom, & & matoms),ind_line(line_tot,matoms),iz_atom(matoms), & & neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom, & & matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms), & & ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms), & & nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms), & & n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms), & & n_wavel_cross_atom(matoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 character*4 contnm_triatom,contnm_diatom character*5 hund_diatom common/comi/nwave dimension & & avg_molwt(mnode),diatom_avg_molwt(mdiatoms),diatom_dens_atom & & (mdiatoms),diatom_dens_mol(mdiatoms),diatom_dens_hvy(mdiatoms), & & diatom_dens_elec(mdiatoms),didens_atom(mdiatoms),diatom_rho & & (mdiatoms),diatom_chi(mdiatoms), & & diatom_dens_atom1(mdiatoms),diatom_dens_atom2(mdiatoms), & & tridens_atom(mtriatoms), & & tran(mnode),trot(mnode),tvib(mnode),tele(mnode) dimension & & concAl(mnode),concAlp(mnode),concAlpp(mnode),concAl3p(mnode), & & concC(mnode), concC2(mnode), & & concCa(mnode),concCap(mnode),concCl(mnode),concC2H(mnode), & & concC3(mnode),concCH(mnode), concCN(mnode),concCO(mnode), & & concCO2(mnode),concCp(mnode), concCpp(mnode),concC3p(mnode), & & concC4p(mnode),concCr(mnode),concCrp(mnode),concCrpp(mnode), & & concFe(mnode),concFeO(mnode),concFep(mnode),concFepp(mnode), & & concFe3p(mnode),concFe4p(mnode),concFe5p(mnode),concH(mnode), & & concH2(mnode), concHp(mnode),concH2O(mnode),concK(mnode), & & concMg(mnode), concMgO(mnode),concMgp(mnode),concMgpp(mnode), & & concMg3p(mnode),concMg4p(mnode),concN(mnode),concNE(mnode), & & concN2(mnode),concN2p(mnode),concNp(mnode),concNpp(mnode), & & concN3p(mnode),concN4p(mnode),concNa(mnode),concNap(mnode), & & concNO(mnode),concNi(mnode),concNip(mnode),concNipp(mnode), & & concNi3p(mnode),concO(mnode),concO2(mnode),concOH(mnode), & & concOp(mnode),concOpp(mnode),concO3p(mnode),concO4p(mnode), & & concS(mnode),concSi(mnode),concSO(mnode),concSiO(mnode), & & concSip(mnode),concSipp(mnode),concSi3p(mnode),concSi4p(mnode), & & concSp(mnode),concSpp(mnode),concS3p(mnode),concS4p(mnode), & & concSiH(mnode),concTi(mnode),concTip(mnode),concTipp(mnode), & & concTi3p(mnode),concTiO(mnode) save data blank4/' '/ natoms=natomsx ndiatoms=ndiatomsx ntriatoms=0 avg_molwt(1)=15. ! ! atomic species if(natoms.gt.0) then dens_atom_hvy=0. do isp=1,natoms dens_atom(isp)=0. atom_chi(isp) = 1.0 atom_avg_molwt = avg_molwt(inode) dens_elec = 1.0e-6*concNe(inode) if(atomnm(isp).eq.'Al ') then dens_atom(isp) = 1.0e-6*concAl(inode) atom_dens_ion(isp) =1.0e-6*concAlp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Al+ ') then dens_atom(isp) = 1.0e-6*concAlp(inode) atom_dens_ion(isp) =1.0e-8*concAlp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Al++') then dens_atom(isp) = 1.0e-6*concAlpp(inode) atom_dens_ion(isp) =1.0e-6*concAl3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Al+3') then dens_atom(isp) = 1.0e-6*concAl3p(inode) atom_dens_ion(isp) =1.0e-8*concAl3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'C ') then dens_atom(isp) = 1.0e-6*concC(inode) atom_dens_ion(isp) =1.0e-6*concCp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ca ') then dens_atom(isp) = 1.0e-6*concCa(inode) atom_dens_ion(isp) =1.0e-6*concCap(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ca+ ') then dens_atom(isp) = 1.0e-6*concCap(inode) atom_dens_ion(isp) =1.0e-8*concCap(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'C+ ') then dens_atom(isp) = 1.0e-6*concCp(inode) atom_dens_ion(isp) =1.0e-6*concCpp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'C++ ') then dens_atom(isp) = 1.0e-6*concCpp(inode) atom_dens_ion(isp) =1.0e-6*concC3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'C+3 ') then dens_atom(isp) = 1.0e-6*concC3p(inode) atom_dens_ion(isp) =1.0e-7*concC3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'C+4 ') then dens_atom(isp) = 1.0e-6*concC4p(inode) atom_dens_ion(isp) =1.0e-7*concC4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Cl ') then dens_atom(isp) = 1.0e-6*concCl(inode) atom_dens_ion(isp) =1.0e-7*concCl(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Cr ') then dens_atom(isp) = 1.0e-6*concCr(inode) atom_dens_ion(isp) =1.0e-6*concCrp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Cr+ ') then dens_atom(isp) = 1.0e-6*concCrp(inode) atom_dens_ion(isp) =1.0e-6*concCrpp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Cr++') then dens_atom(isp) = 1.0e-6*concCrpp(inode) atom_dens_ion(isp) =1.0e-7*concCrpp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Fe ') then dens_atom(isp) = 1.0e-6*concFe(inode) atom_dens_ion(isp) = 1.0e-6*concFep(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Fe+ ') then dens_atom(isp) = 1.0e-6*concFep(inode) atom_dens_ion(isp) = 1.0e-6*concFepp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Fe++') then dens_atom(isp) = 1.0e-6*concFepp(inode) atom_dens_ion(isp) = 1.0e-6*concFe3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Fe+3') then dens_atom(isp) = 1.0e-6*concFe3p(inode) atom_dens_ion(isp) = 1.0e-6*concFe4p(inode) end if if(atomnm(isp).eq.'Fe+4') then dens_atom(isp) = 1.0e-6*concFe4p(inode) atom_dens_ion(isp) = 1.0e-6*concFe5p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Fe+5') then dens_atom(isp) = 1.0e-6*concFe5p(inode) atom_dens_ion(isp) = 1.0e-7*concFe5p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'H ') then dens_atom(isp) = 1.0e-6*concH(inode) atom_dens_ion(isp) = 1.0e-6*concHp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'H+ ') then dens_atom(isp) = 1.0e-6*concHp(inode) atom_dens_ion(isp) = 1.0e-7*concHp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'K ') then dens_atom(isp) = 1.0e-6*concK(inode) atom_dens_ion(isp) = 1.0e-7*concK(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Mg ') then dens_atom(isp) = 1.0e-6*concMg(inode) atom_dens_ion(isp) = 1.0e-6*concMgp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Mg+ ') then dens_atom(isp) = 1.0e-6*concMgp(inode) atom_dens_ion(isp) = 1.0e-6*concMgpp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Mg++') then dens_atom(isp) = 1.0e-6*concMgpp(inode) atom_dens_ion(isp) = 1.0e-6*concMg3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Mg+3') then dens_atom(isp) = 1.0e-6*concMg3p(inode) atom_dens_ion(isp) = 1.0e-6*concMg4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Mg+4') then dens_atom(isp) = 1.0e-6*concMg4p(inode) atom_dens_ion(isp) = 1.0e-7*concMg4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'N ') then dens_atom(isp) = 1.0e-6*concN(inode) atom_dens_ion(isp) = 1.0e-6*concNp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'N+ ') then dens_atom(isp) = 1.0e-6*concNp(inode) atom_dens_ion(isp) = 1.0e-6*concNpp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'N++ ') then dens_atom(isp) = 1.0e-6*concNpp(inode) atom_dens_ion(isp) = 1.0e-6*concN3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'N+3 ') then dens_atom(isp) = 1.0e-6*concN3p(inode) atom_dens_ion(isp) = 1.0e-7*concN3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'N+4 ') then dens_atom(isp) = 1.0e-6*concN4p(inode) atom_dens_ion(isp) = 1.0e-7*concN4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Na ') then dens_atom(isp) = 1.0e-6*concNa(inode) atom_dens_ion(isp) = 1.0e-6*concNap(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Na+ ') then dens_atom(isp) = 1.0e-6*concNap(inode) atom_dens_ion(isp) = 1.0e-7*concNap(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ni ') then dens_atom(isp) = 1.0e-6*concNi(inode) atom_dens_ion(isp) = 1.0e-6*concNip(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ni+ ') then dens_atom(isp) = 1.0e-6*concNip(inode) atom_dens_ion(isp) = 1.0e-7*concNipp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ni++') then dens_atom(isp) = 1.0e-6*concNipp(inode) atom_dens_ion(isp) = 1.0e-7*concNi3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ni+3') then dens_atom(isp) = 1.0e-6*concNi3p(inode) atom_dens_ion(isp) = 1.0e-7*concNi3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'O ') then dens_atom(isp) = 1.0e-6*concO(inode) atom_dens_ion(isp) = 1.0e-6*concOp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'O+ ') then dens_atom(isp) = 1.0e-6*concOp(inode) atom_dens_ion(isp) = 1.0e-6*concOpp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'O++ ') then dens_atom(isp) = 1.0e-6*concOpp(inode) atom_dens_ion(isp) = 1.0e-6*concO3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'O+3 ') then dens_atom(isp) = 1.0e-6*concO3p(inode) atom_dens_ion(isp) = 1.0e-6*concO4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'O+4 ') then dens_atom(isp) = 1.0e-6*concO4p(inode) atom_dens_ion(isp) = 1.0e-7*concO4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'S ') then dens_atom(isp) = 1.0e-6*concS(inode) atom_dens_ion(isp) = 1.0e-6*concSp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'S+ ') then dens_atom(isp) = 1.0e-6*concSp(inode) atom_dens_ion(isp) = 1.0e-6*concSpp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'S++ ') then dens_atom(isp) = 1.0e-6*concSpp(inode) atom_dens_ion(isp) = 1.0e-6*concS3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'S+3 ') then dens_atom(isp) = 1.0e-6*concS3p(inode) atom_dens_ion(isp) = 1.0e-6*concS4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'S+4 ') then dens_atom(isp) = 1.0e-6*concS4p(inode) atom_dens_ion(isp) = 1.0e-7*concS4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Si ') then dens_atom(isp) = 1.0e-6*concSi(inode) atom_dens_ion(isp) = 1.0e-6*concSip(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Si+ ') then dens_atom(isp) = 1.0e-6*concSip(inode) atom_dens_ion(isp) = 1.0e-6*concSipp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Si++') then dens_atom(isp) = 1.0e-6*concSipp(inode) atom_dens_ion(isp) = 1.0e-6*concSipp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Si+3') then dens_atom(isp) = 1.0e-6*concSi3p(inode) atom_dens_ion(isp) = 1.0e-7*concSi3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Si+4') then dens_atom(isp) = 1.0e-6*concSi4p(inode) atom_dens_ion(isp) = 1.0e-7*concSi4p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ti ') then dens_atom(isp) = 1.0e-6*concTi(inode) atom_dens_ion(isp) = 1.0e-6*concTip(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ti+ ') then dens_atom(isp) = 1.0e-6*concTip(inode) atom_dens_ion(isp) = 1.0e-6*concTipp(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ti++') then dens_atom(isp) = 1.0e-6*concTipp(inode) atom_dens_ion(isp) = 1.0e-6*concTi3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if if(atomnm(isp).eq.'Ti+3') then dens_atom(isp) = 1.0e-6*concTi3p(inode) atom_dens_ion(isp) = 1.0e-7*concTi3p(inode) dens_atom_hvy=dens_atom_hvy+dens_atom(isp) end if ! generate default values of atom_rho(i,isp) do i=1,neq_lev_atom(isp) atom_rho(i,isp)=1.0 end do atom_chi(isp) = 1.0 ! ! bound-bound radiation do i=1,167 ibb=0 if((atomnm(isp).eq.atom_rads(1,i)).and. & & (atom_rads(1,i).eq.atom_rads(3,i)).and. & & (atom_rads(2,i).eq.'bb ')) then ibb = 1 end if if((ibb.eq.1).and.(dens_atom(isp).gt.1.0e12)) then if(atomnm(isp).ne.'H ') then write(6,61) atomnm(isp),dens_atom(isp),tran(1) write(*,61) atomnm(isp),dens_atom(isp),tran(1) 61 format(/' calling atom_bb ',a4,1pe10.3,' temp=',0pf10.1) call atom_bb(isp, tele(inode),power) write(*,62) atomnm(isp) write(6,62) atomnm(isp) 62 format(' out of atom_bb ',a4,1pe10.3) end if if(atomnm(isp).eq.'H ') then write(6,81) atomnm(isp),dens_atom(isp),tran(1) write(*,81) atomnm(isp),dens_atom(isp),tran(1) 81 format(/' calling H_bb ',a4,1pe10.3,' temp=',0pf10.1) call H_bb(isp,tele(inode),power) write(*,82) atomnm(isp) write(6,82) atomnm(isp) 82 format(' out of H_bb ',a4,1pe10.3) end if end if end do ! ! bound-free radiation ibf = 0 do i=1,167 if((atomnm(isp).eq.atom_rads(1,i)).and. & & (atom_rads(1,i).eq.atom_rads(3,i)).and. & & (atom_rads(2,i).eq.'bG ')) ibf=1 if((atomnm(isp).eq.atom_rads(1,i)).and. & & (atom_rads(1,i).eq.atom_rads(3,i)).and. & & (atom_rads(2,i).eq.'bc ')) ibf=2 end do if((ibf.eq.1).and.(dens_atom(isp).gt.1.0e12) ) then write(6,63) atomnm(isp),dens_atom(isp),tran(1) write(*,63) atomnm(isp),dens_atom(isp),tran(1) 63 format(/' calling atom_bf_gaunt ',a4,1pe10.3,' temp=',0pf10.1) ! call atom_bf_Gaunt(isp,tele(inode), power) write(*,76) atomnm(isp) write(6,76) atomnm(isp) 76 format(' out of atom_bf_gaunt ',a4,1pe10.3) end if if((ibf.eq.2).and.(dens_atom(isp).gt.1.0e12)) then write(*,64) atomnm(isp),dens_atom(isp),tele(inode) write(6,64) atomnm(isp),dens_atom(isp),tele(inode) 64 format(/' calling atom_bf_cr ',a4,1pe10.3,' temp=',0pf10.1) ! call atom_bf_cr(isp,tele(inode), power) write(*,75) atomnm(isp) write(6,75) atomnm(isp) 75 format(' out of atom_bf_cr ',a4,1pe10.3) end if ! ! free-free radiation iff = 0 do i=1,167 if((atomnm(isp).eq.atom_rads(1,i)).and.(atom_rads(1,i).eq.atom_rads(3,i)) & & .and.(atom_rads(2,i).eq.'ff')) iff = 1 enddo if((iff.eq.1).and.(dens_atom(isp).gt.1.0e12)) then write(*,65) atomnm(isp),dens_atom(isp),tran(1) write(6,65) atomnm(isp),dens_atom(isp),tran(1) 65 format(/' calling atom_ff ',a4,1pe10.3,' t=',0pf10.1) call atom_ff(isp, tele(inode), power) write(*,66) atomnm(isp) write(6,66) atomnm(isp) 66 format(' out of atom_ff ',a4,1pe10.3) power_tot=power_tot+power end if end do ! over atomic species end if ! atoms ! !-------------------------------------------------------------------------------------- ! diatomic radiation if(ndiatoms.gt.0) then do isp = 1,ndiatoms dens_diatom(isp)=0. diatom_dens_elec(isp) = 1.0e-6*concNe(inode) if(diatomnm(isp).eq.'C2 ') then dens_diatom(isp) = 1.0e-6 * concC2(inode) diatom_dens_atom1(isp) = 1.0e-6 * concC(inode) diatom_dens_atom2(isp) = 1.0e-6 * concC(inode) endif if(diatomnm(isp).eq.'CH ') then dens_diatom(isp) = 1.0e-6 * concCH(inode) diatom_dens_atom1(isp) = 1.0e-6 * concC(inode) diatom_dens_atom2(isp) = 1.0e-6 * concH(inode) endif if(diatomnm(isp).eq.'CN ') then dens_diatom(isp) = 1.0e-6 * concCN(inode) diatom_dens_atom1(isp) = 1.0e-6 * concC(inode) diatom_dens_atom2(isp) = 1.0e-6 * concN(inode) endif if(diatomnm(isp).eq.'CO ') then dens_diatom(isp) = 1.0e-6 * concCO(inode) diatom_dens_atom1(isp) = 1.0e-6 * concC(inode) diatom_dens_atom2(isp) = 1.0e-6 * concO(inode) endif if(diatomnm(isp).eq.'H2 ') then dens_diatom(isp) = 1.0e-6 * concH2(inode) diatom_dens_atom1(isp) = 1.0e-6 * concH(inode) diatom_dens_atom2(isp) = 1.0e-6 * concH(inode) endif if(diatomnm(isp).eq.'N2 ') then dens_diatom(isp) = 1.0e-6 * concN2(inode) diatom_dens_atom1(isp) = 1.0e-6 * concN(inode) diatom_dens_atom2(isp) = 1.0e-6 * concN(inode) endif if(diatomnm(isp).eq.'N2+ ') then dens_diatom(isp) = 1.0e-6 * concN2p(inode) diatom_dens_atom1(isp) = 1.0e-6 * concNp(inode) diatom_dens_atom2(isp) = 1.0e-6 * concN(inode) endif if(diatomnm(isp).eq.'NO ') then dens_diatom(isp) = 1.0e-6 * concNO(inode) diatom_dens_atom1(isp) = 1.0e-6 * concN(inode) diatom_dens_atom2(isp) = 1.0e-6 * concO(inode) endif if(diatomnm(isp).eq.'O2 ') then dens_diatom(isp) = 1.0e-6 * concO2(inode) diatom_dens_atom1(isp) = 1.0e-6 * concO(inode) diatom_dens_atom2(isp) = 1.0e-6 * concO(inode) endif if(diatomnm(isp).eq.'OH ') then dens_diatom(isp) = 1.0e-6 * concOH(inode) diatom_dens_atom1(isp) = 1.0e-6 * concO(inode) diatom_dens_atom2(isp) = 1.0e-6 * concH(inode) endif if(diatomnm(isp).eq.'SiH ') then dens_diatom(isp) = 1.0e-6 * concSiH(inode) diatom_dens_atom1(isp) = 1.0e-6 * concSi(inode) diatom_dens_atom2(isp) = 1.0e-6 * concH(inode) end if if(diatomnm(isp).eq.'SiO ') then dens_diatom(isp) = 1.0e-6 * concSiO(inode) diatom_dens_atom1(isp) = 1.0e-6 * concSi(inode) diatom_dens_atom2(isp) = 1.0e-6 * concO(inode) end if if(diatomnm(isp).eq.'MgO ') then dens_diatom(isp) = 1.0e-6 * concMgO(inode) diatom_dens_atom1(isp) = 1.0e-6 * concMg(inode) diatom_dens_atom2(isp) = 1.0e-6 * concO(inode) end if if(diatomnm(isp).eq.'FeO ') then dens_diatom(isp) = 1.0e-6 * concFeO(inode) diatom_dens_atom1(isp) = 1.0e-6 * concFe(inode) diatom_dens_atom2(isp) = 1.0e-6 * concO(inode) end if if(diatomnm(isp).eq.'SO ') then dens_diatom(isp) = 1.0e-6 * concSO(inode) diatom_dens_atom1(isp) = 1.0e-6 * concS(inode) diatom_dens_atom2(isp) = 1.0e-6 * concO(inode) end if if(diatomnm(isp).eq.'TiO') then dens_diatom(isp) = 1.0e-6 * concTiO(inode) diatom_dens_atom1(isp) = 1.0e-6 * concTi(inode) diatom_dens_atom2(isp) = 1.0e-6 * concO(inode) end if ! ! generate default values of diatom_rho(ie,isp) do i=1,ndiatoms do ie=1,20 diatom_rho(i) = 1.0 end do end do diatom_chi(isp) = 1.0 ! ! bound-bound radiation ibb = 0 do i=1,100 if( (diatomnm(isp).eq.diatom_bands(1,i)).and. & & (diatom_bands(1,i).eq.diatom_bands(3,i)) & & .and. ( (diatom_bands(2,i).ne.'cont') .and. & & (diatom_bands(2,i).ne.'nrct') ) ) then ibb = 1 is=i end if if((ibb.eq.1).and.(dens_diatom(isp).gt.1.0e12)) then write(*,51) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),tran(1) write(6,51) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),tran(1) 51 format(/' calling diatom_bb ',2a4,1pe10.3,' t=',0pf10.1) call diatom_bb(isp,diatomnm,tran(inode), & & trot(inode),tvib(inode),tele(inode),diatom_bands) write(*,73) diatomnm(isp) write(6,73) diatomnm(isp) 73 format(' out of diatom_bb ',a4,1pe10.3) end if ibb=0 end do ! ! bound-free radiation ibf = 0 do i=1,100 if( (diatomnm(isp).eq.diatom_bands(1,i)) .and. & & (diatom_bands(1,i).eq.diatom_bands(3,i)) & & .and.((diatom_bands(2,i).eq.'cont') .or. & & (diatom_bands(2,i).eq.'nrct') ) ) then ibf = 1 is=i end if if((ibf.eq.1).and.(dens_diatom(isp).gt.1.0e12)) then write(*,52) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),tran(1) write(6,52) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),tran(1) 52 format(/' calling diatom_bf ',2a4,1pe10.3,' t=',0pf10.1) call diatom_bf(isp,tele(1)) write(*,72) diatomnm(isp) write(6,72) diatomnm(isp) 72 format(' out of diatom_bf ',a4,1pe10.3) end if ibf=0 end do end do ! over diatomic species end if ! diatoms ! !----------------------------------------------------------------------------------------- ! triatomic radiation if(ntriatoms.gt.0) then do isp=1,ntriatoms if(triatomnm(isp).eq.'C3 ') then dens_triatom(isp) = 1.0e-6 * concC3(inode) end if if(triatomnm(isp).eq.'C2H ') then dens_triatom(isp) = 1.0e-6 * concC2H(inode) end if if(triatomnm(isp).eq.'H2O ') then dens_triatom(isp) = 1.0e-6 * concH2O(inode) end if if(triatomnm(isp).eq.'CO2 ') then dens_triatom(isp) = 1.0e-6 * concCO2(inode) end if ! ! continuum radiation only ibf = 0 do i=1,10 if((triatomnm(isp).eq.triatom_bands(1,i)).and. & & (triatom_bands(1,i).eq.triatom_bands(3,i))) then ibf = 1 is=i end if if((ibf.eq.1).and.(dens_triatom(isp).gt.1.0e12)) then write(*,*) ' calling triatom_bf ',triatomnm(isp),triatom_bands(2,is) write(6,*) ' calling triatom_bf ',triatomnm(isp),triatom_bands(2,is) call triatom_bf(isp,tele(1)) write(6,*) ' out of triatom_bf' write(*,*) ' out of triatom_bf' end if end do ibf=0 end do end if ! return end !*********************************************************************** subroutine emis_absb1(itemp,natomsx,ndiatomsx,ntriatoms, & & nprt,inode,temp,rho,an,avg_molwt) parameter(nw=400000) parameter(matoms=56,mdiatoms=12,mtriatoms=6,mnode=1,msp=60) implicit real*8(a-h,o-z) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm, & & atomnm1,diatomnm,diatomnm1,triatomnm,triatomnm1 character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/comi/nwave dimension an(10),avg_molwt(mnode) ! 1 2 3 4 5 6 7 8 9 ! O N O2 N2 NO O+ N+ NO+ E- natoms=natomsx ndiatoms=ndiatomsx ntriatoms=0 avg_molwt(1)=15. ! atoms dens_atom_hvy=an(1)+an(2)+an(6)+an(7) do isp=1,natoms ibb=0 if(atomnm(isp).eq.'O ') then dens_atom(isp) = an(1) atom_dens_ion(isp) = an(6) ibb=1 end if if(atomnm(isp).eq.'N ') then dens_atom(isp) = an(2) atom_dens_ion(isp) = an(7) ibb=1 end if if(atomnm(isp).eq.'O+ ') then dens_atom(isp) = an(6) atom_dens_ion(isp) = 1.0e-6* an(6) ibb=1 end if if(atomnm(isp).eq.'N+ ') then dens_atom(isp) = an(7) atom_dens_ion(isp) = 1.0e-6* an(7) ibb=1 end if if((ibb.eq.1).and.(dens_atom(isp).gt.1.0e12)) then write(6,61) atomnm(isp),dens_atom(isp),temp write(*,61) atomnm(isp),dens_atom(isp),temp 61 format(/' calling atom_bb ',a4,1pe10.3,' temp=',0pf10.1) call atom_bb(isp, temp,power) write(*,62) atomnm(isp) write(6,62) atomnm(isp) 62 format(' out of atom_bb ',a4,1pe10.3) ! write(*,64) atomnm(isp),dens_atom(isp),temp write(6,64) atomnm(isp),dens_atom(isp),temp 64 format(/' calling atom_bf_cr ',a4,1pe10.3,' temp=',0pf10.1) call atom_bf_cr(isp,temp, power) write(*,75) atomnm(isp) write(6,75) atomnm(isp) 75 format(' out of atom_bf_cr ',a4,1pe10.3) write(*,65) atomnm(isp),dens_atom(isp),temp write(6,65) atomnm(isp),dens_atom(isp),temp 65 format(/' calling atom_ff ',a4,1pe10.3,' temp=',0pf10.1) call atom_ff(isp, temp, power) write(*,66) atomnm(isp) write(6,66) atomnm(isp) 66 format(' out of atom_ff ',a4,1pe10.3) end if ! end do ! ! diatoms ! 1 2 3 4 5 6 7 8 9 ! O N O2 N2 NO O+ N+ NO+ E- do isp=1,ndiatoms ibb=0 if(diatomnm(isp).eq.'O2 ') then dens_diatom(isp)=an(3) ibb=1 end if if(diatomnm(isp).eq.'N2 ') then dens_diatom(isp)=an(4) ibb=1 end if if(diatomnm(isp).eq.'NO ') then dens_atom(isp)=an(5) ibb=1 end if if((ibb.eq.1).and.(dens_diatom(isp).gt.1.0e12)) then write(*,51) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),temp write(6,51) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),temp 51 format(/' calling diatom_bb ',2a4,1pe10.3,' temp=',0pf10.1) ! call diatom_bb(isp,diatomnm,temp,temp,temp,temp,diatom_bands) write(*,73) diatomnm(isp) write(6,73) diatomnm(isp) 73 format(' out of diatom_bb ',a4,1pe10.3) write(*,52) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),temp write(6,52) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),temp 52 format(/' calling diatom_bf ',2a4,1pe10.3,' temp=',0pf10.1) call diatom_bf(isp,temp) write(*,72) diatomnm(isp) write(6,72) diatomnm(isp) 72 format(' out of diatom_bf ',a4,1pe10.3) end if end do return end !********************************************************************** subroutine eqcal2(rhox,tempx,spnmx,spgamx,nstep,nprt,nprint, & & eintx,presx, enthx,zz,avmw,ansp) ! ! calculate equilibrium composition for given density and temperature ! input ! rhox=density, kg/m3 ! tempx=temperature, K ! spnmx(msp)=species name ! spgamx(i)=initial estimate of species concentration, mol/kg ! presx=pressure, pascal ! nstep=max allowed time step in stiff7 integration ! nprt=print index ! nprt=0 no print. 3=print ! nprint=printing interval ! output ! eintx=internal energy per unit volume, J/m3 ! enthx=enthalpy, J/kg ! zz=compressibility ! avmw=average molecular weight,kg/mol ! parameter(msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) common/eqcomb/pres,temp,rho,enth,spgam(msp),amdot common/eqcomd/gamma,delta,elen,aratx,emfp,epsiln dimension y(msp),yy(msp),dy(msp),case(5),spgamx(msp),frac(msp),ansp(msp) character*4 elemnm,spnm,spnmx(msp) save external der1 epsiln=1.0d-9*(rhox/1.0e-5)**0.75 ! epsiln=1.0d-12*(rhox/1.0e-5)**0.75 neq=nsp-nelem temp=tempx rho=rhox do isp=1,nsp dy(isp)=100. spnm(isp)=spnmx(isp) end do call assign(spgam,nprt) ! ! integration t=0. h=1.0d-20 case(1)=0.025d0 case(2)=10. case(3)=1.0d-7 ! case(4)=-1.5d0 case(4)=1.0d0/3.0d0 case(5)=1.0d-7 call conv(spgam,yy,0) istep=1 iprint=0 nprt=2 go to 80 ! 20 continue if(nprt.gt.2) write(6,130) istep,h,tempx,(yy(i),i=1,neq) 130 format(' in eqcal2. istep=',i7,' h=',1pe9.2,' tempx=', & & e10.3,' yy='/(1p7e10.2)) call stiff7(neq,t,yy,dy,der1,h,case,istep,nprt) istep=istep+1 if(istep.lt.20) go to 20 iprint=iprint+1 80 continue call conv1(yy,y,0) sumdy=0. do i=1,neq sumdy=sumdy+dy(i)**2 end do sumdy=dsqrt(sumdy/float(neq)) if((iprint.eq.nprint).and.(nprt.gt.1)) then write(6,30) istep,temp,h,sumdy 30 format(' in eqcal2. istep=',i7,' temp=',1pe10.3,' h=',1pe9.2, & & ' sumdy=',1pe9.2) ! write(6,70) (spnm(i),i=1,nsp1) 70 format(1x,7(2x,a4,4x)) ! write(6,50) (y(i),i=1,nsp1) iprint=0 endif ! converged if h.gt.case(2) if(h.gt.case(2)) then go to 140 end if if((istep.gt.500000).and.(sumdy.lt.epsiln)) then go to 140 end if ddy=0. go to 20 ! ! write out if wanted 50 format(1x,1p7e10.3) if(sumdy.gt.epsiln) then write(6,170) istep,rhox,tempx,sumdy 170 format(' in eqcal2. istep,rhox,tempx,sumdy=',i6,1p3e10.3, & & ' stop') stop end if ! ! converged, post-processing begins 140 continue ! audit elemental mass fractions: compare the mass frac with the original values call audit(spgam,nprt) sumh=0. spgam(nsp1)=0. do 90 jsp=1,nsp spgam(jsp)=y(jsp) spgam(nsp1)=spgam(nsp1)+spgam(jsp)*ie(jsp) 90 sumh=sumh+spgam(jsp) sumgam=sumh+spgam(nsp1) avmw=1./sumgam rhox=presx*avmw/(8.3143*tempx) zz=avmw0/avmw do 160 jsp=1,nsp1 frac(jsp)=spgam(jsp)/sumgam spgamx(isp)=spgam(isp) 160 continue ! ! enthalpy enthx, J/kg enthx=0. z=10000./temp alogz=dlog(z) do jsp=1,nsp1 enthx=enthx+(dexp(akb(1,jsp)/z+akb(2,jsp)+akb(3,jsp)*alogz+ & & akb(4,jsp)*z+akb(5,jsp)*z**2)+(20.78575+8.3148*im(jsp)) & & *temp+h0sp(jsp))*spgam(jsp) end do ! ! write if wanted ! if(nprt.gt.1) then write(6,100) istep,sumdy,presx,tempx,enthx, & & rhox,h,(dy(i),i=1,neq) 100 format(/'in eqcal2. converged. istep=',i8,' sumdy=', & & 1pe10.3,' presx=',1pe10.3/' tempx=',e10.3,' enth=',e10.3, & & ' rhox=',e10.3,' h=',e12.3,' dy='/(1p7e10.3)) write(6,70) (spnm(i),i=1,nsp) write(6,180) (frac(i),i=1,nsp1) 180 format(' frac='/(1p7e10.3)) ! endif ! ! write conditions antot=presx/(1.3806e-23*tempx) write(6,210) rhox,tempx,enthx,antot 210 format(/ & & ' density =',1pe12.5,' kg/m3'/ & & ' temperature =',0pf12.2,' K.'/ & & ' enthalpy =',1pe12.5,' J/kg'/ & & ' ntot =',e12.5,' m-3'/ & & ' species mol/kg mol-frac n(m-3)') do isp=1,nsp1 spnmx(isp)=spnm(isp) spgamx(isp)=spgam(isp) ansp(isp)=antot*frac(isp) write(6,220) spnm(isp),spgamx(isp),frac(isp),ansp(isp) 220 format(1x,a4,2x,1p4e12.5) end do return end !********************************************************************** subroutine eqcal3(px,tempx,spnmx,spgamx,nstep,nprt,nprint, & & eintx, rhox,enthx,zz,avmw,ansp) ! ! calculate equilibrium composition for given density and temperature ! input ! px=pressure, Pascal ! tempx=temperature, K ! spnmx(40)=species name ! spgamx(msp)=initial guess of spcies concentration, mol/kg ! nstep=max allowed time step in stiff7 integration ! nprt=print index ! nprt=0 no print. 3=print ! nprint=printing interval ! output ! spnmx(40)=species name, through common/eqcomi ! eintx=internal energy per unit volume, J/m3 ! rhox=density, kg/m3 ! enthx=enthalpy, J/kg ! zz=compressibility ! avmw=average molecular weight,kg/mol ! spgamx(i)=calculated species concentration, mol/kg ! parameter(msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) common/eqcomb/pres,temp,rho,enth,spgam(msp),amdot common/eqcomd/gamma,delta,elen,aratx,emfp,epsiln dimension y(msp),yy(msp),dy(msp),case(5),spgamx(msp),ansp(msp) character*4 elemnm,spnm,spnmx(msp) save external der1 ! ! first approximation of density ! call eqcal2(rhox,tempx,spnmx,spgamx,nstep,nprt,nprint, & & eintx, px,enthx,zz,avmw,ansp) ! ! do ip=1,2 ! rhox=rhox*px/presx ! call eqcal2(rhox,tempx,spnmx,spgamx,nstep,nprt,nprint, & ! & eintx, px,enthx,zz,avmw,ansp) ! end do ! return end !************************************************************************ subroutine ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot,rhos,rhoe, beta, & & f,fp,betae,fwx) ! vertical velocity function f and tangential velocity function fp for ablation layer ! 5th order polynomial fit ! input parameters: ! ndm=length of spatial node point array ! rhoinf=freestrem density, kg/m3 ! vinf=freestream velocity, m/s ! rhorat(802)=density ratio ! amdot=ablation rate, kg/(m2-s) ! rhos=density behind shock, kg/m3 ! rhoe=density of ablation product at interface, kg/m3 ! beta(ndm)=independent coordinate ! f(802)=normal velocity function ! fp(802)=df/deta, tangential velocity function ! betae=interface value of beta ! output parameters: ! fwx=wall value of f implicit real*8(a-h,o-z) dimension beta(802),f(802),fp(802),rhorat(802) common/fprof2/fw,fpw,fppw,rhorw,rhor1,d0,d2,d3,c1,c2,c3,c4,c5 save external funfw2 ! method=1 ndm1=ndm/2 ndm2=ndm1+1 ndm3=ndm1-1 duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoe) fw=-amdot/(2.*duedr*rhos) if(fw.gt.0.) then write(*,80) amdot,fw write(6,80) amdot,fw 80 format(' in ffp5. amdot=',1pe12.5,' fw=',1pe12.5,' stop') stop end if rhorw=rhorat(1) nmid=ndm1/2 rhor1=rhorat(nmid) if(method.eq.1) then fpw=0.d0 fppw=-0.5*rhorw/fw end if if(method.eq.2) then fpw=dsqrt(rhorw) fppw=0.d0 end if dbeta=-0.01*fw betaef=0. itry=0 ! 10 continue itry=itry+1 betaef=betaef+dbeta ff=funfw2(betaef) ! write(6,40) itry,dbeta,betaef,ff 40 format(' ffp5. itry=',i4,' dbeta=',1pe10.3,' betaef=',e10.3,' ff=',e10.3) if(itry.gt.1) then if(ff*ffold.lt.0.) go to 20 end if if((itry.gt.1).and.(ff.gt.ffold)) go to 70 betaef_old=betaef ffold=ff dbeta=dbeta*1.2 if(itry.ge.100) then write(6,50) betaef 50 format(' ffp5. no sign change after 500 tries and betaef=',1pe10.3) stop end if go to 10 ! 20 continue beta1=betaef_old-(betaef-betaef_old)*0.1 beta2=betaef+(betaef-betaef_old)*0.1 ! write(6,60) beta1,beta2 60 format(' ffp5. beta1,beta2=',1p2e11.4) betaex=0.5*(beta1+beta2) e1=1.0e-6 e2=1.0e-6 call root(funfw2,betae,betaex,beta1,beta2,e1,e2,ier) if(ier.ne.1) then write(6,30) ier 30 format(' ffp5. ier=',i1,' stop') stop end if ! 70 continue do inode=1,ndm1 beta(inode)=float(inode-1)*betae/float(ndm3) f(inode)=c1*(beta(inode)-betae)+c2*(beta(inode)-betae)**2+c3*(beta(inode) & & -betae)**3+c4*(beta(inode)-betae)**4+c5*(beta(inode)-betae)**5 fp(inode)=c1+2.*c2*(beta(inode)-betae)+3.*c3*(beta(inode)-betae)**2 & & +4.*c4*(beta(inode)-betae)**3+5.*c5*(beta(inode)-betae)**4 end do fwx=fw return end !*********************************************************************** function fkmax(k,u,imax1,imax,evib,bv,dv) implicit real*8(a-h,o-z) dimension k(500),u(500) do 260 i=imax1,imax kk1=k(i)*(k(i)+1) e2=evib+bv*kk1-dv*kk1**2 kmax=k(i) if (e2.le.u(i)) goto 270 kmax=k(i) 260 continue ! 270 fkmax=kmax imax1=i+1 return end !************************************************************************************ subroutine flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma, & & int_old,dqdy) ! radiative flux calculation for inner layer ! input parameters: ! nwave=length of wavelength array ! ndm=length of spatial node point array ! im=current number of iteration ! nim=number of allowed iteration of inner layer ! y(ndm)=node coordinates ! beta(ndm)=normalized node coordinates ! tx(ndm)=temperature, K ! dtdy(ndm)=temperature slope, K/m ! sigma=emissivity of wall ! int_old(10,nw)=intensity toward wall, W/(cm2-mic-sr) ! output parameters: ! int_e(10,nw)=outward intensity at edge, through common spectb parameter(nw=400000) implicit real*8(a-h,o-z) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e,int_old,int_new,int_s,int_cam,int_abl common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11), & & int_cam(nw) dimension y(802),beta(802),tx(802),dtdy(802),dqdy(802), & & dqpdy(802),dqmdy(802),dqpdy1(802),dqmdy1(802) ! qp=flux from wall to shock; qm=flux from shock to wall common/scratch/int_new(10,nw) dimension int_old(10,nw) dimension cos1(11),bint(11) save data itime/0/,pi/3.1415926/,ITM/0/ ! ndm1=ndm/2 ndm2=ndm1+1 ndm3=ndm1-1 ! nwave=nw do iang=1,10 ang(iang)=(iang-1)*0.5*pi/10. cos1(iang)=1./dcos(ang(iang)) sin2(iang)=dsin(2.*ang(iang)) end do ang(11)=0.5*pi bint(1)=0.; bint(11)=0. itime=itime+1 ! ! radiative transfer from interface to wall (flux taken to be positive)-------------------- ! do iw=1,nw do iang=1,10 int_old(iang,iw)=0. end do end do qm(ndm1)=qm(ndm2) mon=0 do idm=ndm1-1,1,-1 tinv=10000./tx(idm) qm(idm)=0. do iw=1,nwave mon=0 call taint(tcho,absb_cho(1,iw),tinv,absbx,11,2,ier,mon) ! call intpl1(tcho,absb_cho(1,iw),tinv,absbx,11) absba=dexp(absbx) dely=(y(idm+1)-y(idm))*100. ! cm ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(idm))) blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax)) ! W/(cm2-mic-sr) ! dbdt=1.1904e-16*1.43877*ax/((1.0d-8*wavel(iw))**6*tx(idm)**2*(1.-ax)**2) ! intensity do iang=1,10 tau=absba*dely*cos1(iang) expx=dexp(-tau) int_new(iang,iw)=blam*(1.0-expx)+int_old(iang,iw)*expx bint(iang)=pi*sin2(iang)*int_new(iang,iw) end do call simp(qlam,ang,bint,11,ier) ! memorize intensity to wall if(idm.eq.1) then do iang=1,10 intw(iang,iw)=int_new(iang,iw) end do end if ! flux if(iw.eq.1) delw=wavel(2)-wavel(1) if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1)) if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1) qm(idm)=qm(idm)+qlam*delw*1.0e-4 ! W/cm2 do iang=1,10 int_old(iang,iw)=int_new(iang,iw) end do end do qm(idm)=qm(idm)*1.e4 ! W/m2 end do write(6,60) qm(1) 60 format(/' to-wall radiative flux=',1pe10.3,' W/m2'/) ! ! radiative transfer from wall to edge(interface)----------------------------- ! ! absorption coefficient at wall and intensity from wall twall=10000./tx(1) qp(1)=0. do iw=1,nwave ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(1))) do iang=1,10 intw(iang,iw)=sigma*1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax)) & & + (1.-sigma)*intw(iang,iw) ! W/(cm2-mic-sr) bint(iang)=pi*sin2(iang)*intw(iang,iw) end do call simp(qlam,ang,bint,11,ier) if(iw.eq.1) delw=wavel(2)-wavel(1) if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1)) if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1) qp(1)=qp(1)+qlam*delw*1.0e-4 call intpl1(tcho,absb_cho(1,iw),twall,absbx,11) end do qp(1)=qp(1)*1.0e4 ! W/m2 ! radiative transfer from wall to edge do iw=1,nwave do iang=1,10 int_old(iang,iw)=intw(iang,iw) end do end do do idm=2,ndm1 tinv=10000./tx(idm) qp(idm)=0. do iw=1,nwave mon=0 call taint(tcho,absb_cho(1,iw),tinv,absbx,11,2,ier,mon) ! call intpl1(tcho,absb_cho(1,iw),tinv,absbx,11) absba=dexp(absbx) dely=(y(idm)-y(idm-1))*100. ! cm ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(idm))) blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax)) ! W/(cm2-mic-sr) ! dbdt=1.1904e-16*1.43877*ax/((1.0d-8*wavel(iw))**6*tx(idm)**2*(1.-ax)**2) ! intensity do iang=1,10 tau=absba*dely*cos1(iang) expx=dexp(-tau) int_new(iang,iw)=blam*(1.0-expx)+int_old(iang,iw)*expx bint(iang)=pi*sin2(iang)*int_new(iang,iw) end do call simp(qlam,ang,bint,11,ier) if(iw.eq.nwave) then do iang=1,10 int_new(iang,iw)=int_new(iang,iw-1) end do end if ! flux if(iw.eq.1) delw=wavel(2)-wavel(1) if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1)) if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1) qp(idm)=qp(idm)+qlam*delw*1.0e-4 ! W/cm2 do iang=1,10 int_old(iang,iw)=int_new(iang,iw) end do end do if(idm.eq.ndm1) then do iw=1,nwave do iang=1,10 int_e(iang,iw)=int_new(iang,iw) end do end do end if qp(idm)=qp(idm)*1.e4 ! W/m2 end do ! ! divergence of heat flux ! do inode=1,ndm3 ! at inode + 1/2 point dqpdy1(inode)=(qp(inode+1)-qp(inode))/(y(inode+1)-y(inode)) dqmdy1(inode)=(qm(inode+1)-qm(inode))/(y(inode+1)-y(inode)) end do ! interpolate to obtain the values at inode mon=0 do inode=1,ndm1 if(inode.eq.1) y1=-0.5*(y(2)-y(1)) if(inode.gt.1) y1=y(inode)-0.5*(y(inode+1)-y(inode)) call taint(y,dqpdy1,y1,dqpdy(inode),ndm3,1,ier,mon) end do mon=0 do inode=1,ndm1 if(inode.eq.1) y1=-0.5*(y(2)-y(1)) if(inode.gt.1) y1=y(inode)-0.5*(y(inode+1)-y(inode)) call taint(y,dqmdy1,y1,dqmdy(inode),ndm3,1,ier,mon) end do ! ! impose zero at interface do inode=1,ndm1 rat=(float(inode-1)/float(ndm1-1))**4 dqpdy(inode)=(1.-rat)*dqpdy(inode)+rat*dqmdy(inode) end do ! divergence: dqdy>0 means flow gaining energy do inode=1,ndm1 dqdy(inode)=-dqpdy(inode)+dqmdy(inode) end do ! return end !*********************************************************************************** subroutine flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy, & & int_old, dqdy, qpshock) ! radiative flux calculation for outer layer ! input parameters: ! nwave=length of wavelength array ! ndm=length of spatial node point array ! nout=number of allowed iteration of outer layer calculation ! rhoinf=freestream density, kg/m3 ! rnose=nose radius, m ! vinf=freestream velocity, m/s ! y(ndm)=node coordinates ! beta(ndm)=normalized node coordinates ! tx(ndm)=temperature, K ! dtdy(ndm)=temperature slope, K/m ! int_old(10,nw)=intensity in the last iteration, W/(cm2-mic-sr) ! output parameters: ! qp(ndm)=shockward radiative flux, W/cm2 ! qm(ndm)=wallward radiation flux, W/cm2 ! dqdy(ndm)=divergence of radiative flux, W/m3 ! qpshock=outward radiation flux from shock, W/m2 ! parameter(nw=400000) implicit real*8(a-h,o-z) ! iny_e(10,nw)=intensity of ablation product at edge (interface) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e,int_s,int_sav,int_prec,int_old,int_new, & & int_cam,int_abl common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11), & & int_cam(nw) dimension y(802),beta(802),tx(802),dtdy(802),dqdy(802), & & dqpdy(802),dqmdy(802),dqpdy1(802),dqmdy1(802) ! qp=flux from wall to shock; qm=flux from shock to wall common/scratch/int_new(10,nw),int_sav(nw) ! flx(nw)=radiative flux at shock; flx_prec(nw)=radiative flux at end of precursor dimension int_old(10,nw),flx(nw),flx_prec(nw),flx_grd(nw), & & int_prec(nw),qplam(nw) ! wav_tran(101) and air(tran(101) are atmospheric absorption dimension cos1(11),bint(11) ! dimension wav_tran(154),air_tran(154) save data itime/0/,pi/3.1415926/,cutlo/4000./,cuthi/8000./,iwrite/0/ ! ndm1=ndm/2 ndm2=ndm1+1 ndm3=ndm1-1 do iang=1,10 ang(iang)=(iang-1)*0.5*pi/10. cos1(iang)=1./dcos(ang(iang)) sin2(iang)=dsin(2.*ang(iang)) end do ang(11)=0.5*pi bint(1)=0.; bint(11)=0. itime=itime+1 ! ! radiative transfer from interface to shock -------------------- ! do idm=ndm2+1,ndm if(idm.eq.ndm2+1) then do iw=1,nwave do iang=1,10 if(itime.le.nout) int_old(iang,iw)=intw(iang,iw) if(itime.gt.nout) int_old(iang,iw)=int_e(iang,iw) end do end do end if qps=0. tinv=10000./tx(idm) qp(idm)=0. do iw=1,nwave mon=0 call taint(tair(1),absb_air(1,iw),tinv,absbx,5,2,ier,mon) absba=dexp(absbx) ! cm-1 dely=(y(idm)-y(idm-1))*100. ! cm ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(idm))) blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax)) ! W/(cm2-mic-sr) dbdt=1.1904e-16*1.43877*ax/((1.0d-8*wavel(iw))**6*tx(idm)**2*(1.-ax)**2) do iang=1,10 tau=absba*dely*cos1(iang) if(tau.gt.500.) then int_new(iang,iw)=blam end if if(tau.le.500.) then expx=dexp(-tau) int_new(iang,iw)=blam*(1.0-expx)+int_old(iang,iw)*expx ! W/(cm2-mic-sr) end if bint(iang)=pi*sin2(iang)*int_new(iang,iw) end do call simp(qlam,ang,bint,11,ier) ! qlam W/(cm2-mic) ! memorize spectrum at shock for later use if(idm.eq.ndm) then do iang=1,10 int_s(iang,iw)=int_new(iang,iw) ! W/(cm2-mic-sr) end do end if ! flux if(iw.eq.1) delw=wavel(2)-wavel(1) if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1)) if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1) qp(idm)=qp(idm)+qlam*delw*1.0e-4 ! W/cm2 if((wavel(iw).gt.cutlo).and.(wavel(iw).lt.cuthi)) & & qps=qps+qlam*delw*1.0e-4 ! W/cm2 do iang=1,10 int_old(iang,iw)=int_new(iang,iw) ! W/(cm2-mic-sr) end do qplam(iw)=qp(idm)*1.e4 ! W/m2 end do qp(idm)=qp(idm)*1.e4 ! W/m2 qps=qps*1.e4 ! W/m2 end do qpshock=qp(ndm) ! ! radiative transfer from shock to interface (flux taken to be positive)-------------------- ! do iw=1,nwave do iang=1,10 int_old(iang,iw)=0. end do end do qm(ndm)=0. do idm=ndm-1,ndm2,-1 tinv=10000./tx(idm) qm(idm)=0. do iw=1,nwave mon=0 call taint(tair,absb_air(1,iw),tinv,absbx,5,2,ier,mon) absba=dexp(absbx) dely=(y(idm+1)-y(idm))*100. ! cm ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(idm))) blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax)) ! W/(cm2-mic-sr) ! dbdt=1.1904e-16*1.43877*ax/((1.0d-8*wavel(iw))**6*tx(idm)**2*(1.-ax)**2) ! intensity do iang=1,10 tau=absba*dely*cos1(iang) if(tau.gt.700.) tau=700. expx=dexp(-tau) int_new(iang,iw)=blam*(1.0-expx)+int_old(iang,iw)*expx bint(iang)=pi*sin2(iang)*int_new(iang,iw) end do call simp(qlam,ang,bint,11,ier) if(iw.eq.nwave) then do iang=1,10 int_new(iang,iw)=int_new(iang,iw-1) end do end if ! flux if(iw.eq.1) delw=wavel(2)-wavel(1) if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1)) if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1) qm(idm)=qm(idm)+qlam*delw*1.0e-4 ! W/(cm2-mic) do iang=1,10 int_old(iang,iw)=int_new(iang,iw) end do end do qm(idm)=1.e4*qm(idm) ! W/m2 end do ! ! divergence of heat flux ! do inode=ndm2,ndm-1 ! at inode + 1/2 point dqpdy1(inode)=(qp(inode+1)-qp(inode))/(y(inode+1)-y(inode)) dqmdy1(inode)=(qm(inode+1)-qm(inode))/(y(inode+1)-y(inode)) end do ! interpolate to obtain the values at inode mon=0 do inode=ndm2,ndm-1 if(inode.eq.ndm2) y1=-0.5*(y(ndm2+1)-y(ndm2)) if(inode.gt.ndm2) y1=y(inode)-0.5*(y(inode+1)-y(inode)) call taint(y(ndm2),dqpdy1(ndm2),y1,dqpdy(inode),ndm3,2,ier,mon) end do mon=0 do inode=ndm2,ndm-1 if(inode.eq.ndm2) y1=-0.5*(y(ndm2+1)-y(ndm2)) if(inode.gt.ndm2) y1=y(inode)-0.5*(y(inode+1)-y(inode)) call taint(y(ndm2),dqmdy1(ndm2),y1,dqmdy(inode),ndm3,2,ier,mon) end do ! ! impose zero at interface do inode=ndm2,ndm rat=(float(inode-ndm2)/float(ndm1-1))**4 dqpdy(inode)=rat*dqpdy(inode)+(1.-rat)*dqmdy(inode) end do ! divergence: dqdy>0 means flow gaining energy do inode=ndm2,ndm dqdy(inode)=-dqpdy(inode)+dqmdy(inode) end do ! return end !*********************************************************************** function funfw2(betae) ! function subroutine for determining edge value of beta ! input parameter: ! betae=edge value of beta implicit real*8(a-h,o-z) common/fprof2/fw,fpw,fppw,rhorw,rhor1,d0,d2,d3,c1,c2,c3,c4,c5 dimension a(2,2),b(2),x(2) ! determine curve fit coefficient d2 and d3 to fit the given density ratio function a(1,1)=betae**2 a(1,2)=-betae**3 b(1)=rhorw-1.d0 a(2,1)=0.25d0*betae**2 a(2,2)=-0.125d0*betae**3 b(2)=rhor1-1.d0 call lin2(a,b,x) d0=1.0d0 d2=x(1); d3=x(2) c1=1.0d0 c2=(fw+betae-0.05d0*fppw*betae**2-(7.d0/60.d0)*d2*betae**3+d3*betae**4/40.d0) & & /(0.9d0*betae**2+d2*betae**4/60.d0) c3=-d2/(6.d0*c1) c4=-d3/(16.d0*c1)+d2*c2/24.d0 c5=(2.d0*c2-6.d0*c3*betae+12.d0*c4*betae**2-fppw)/(20.d0*betae**3) funfw2=5.d0*c5*betae**4 -4.d0*c4*betae**3 + 3.d0*c3*betae**2 & & - 2.d0*c2*betae + 1.d0 -fpw ! write(6,40) fw,betae,fppw,c1,c2,c3,c4,c5,funfw2 40 format(' in funfw2'/ & & ' fw=',1pe10.3,' betae=',e10.3,' fppw=',e10.3/ & & ' c1-c5=',5e10.3,' funfw2=',1pe10.3) return end !*********************************************************************** subroutine gausst(nwave,hwhh,wav1,wav2,wavel,nskip,ainp,aout) ! Gaussian slit processing ! input parameters: ! nwave=number of wavelength points ! hwhh=half width in A at half height ! wav1=low wavelength limit of plot, A ! wav2=high wavelength limit of plot, A ! wavel(nw)=wavelengths ! ainp(nw)=original signal ! output parameter ! aout(nw)=slit-processed signal parameter (nw=400000) implicit real*8(a-h,o-z) common/scratch/wavel1(nw),aout1(nw) dimension wavel(nw),ainp(nw),aout(nw) common/scratch/gaussx(-101:101),gaussy(-101:101),fx(-101:101) ! ! generate Gaussian function xhalf=(-dlog(0.5d0)) xstep=hwhh/20. sum=0. do i=0,101 gaussx(i)=xstep*i gaussx(-i)=-gaussx(i) gaussy(i)=dexp(-xhalf*(gaussx(i)/hwhh)**2) gaussy(-i)=gaussy(i) if(i.gt.0) then sum=sum+0.5*(gaussy(i-1)+gaussy(i))*xstep end if end do sum=sum*2. ! write(*,*) ' sum=',sum do i=-101,101 gaussy(i)=gaussy(i)/sum end do do i=-101,101 ! write(6,10) i,gaussx(i),gaussy(i) 10 format(i5,1p2e12.5) end do ! ! iw=1 50 continue iw=iw+1 if(wavel(iw).lt.wav1) go to 50 nw1=iw-101 60 continue iw=iw+1 if(wavel(iw).lt.wav2) go to 60 nw2=iw+101 do iw=1,nwave aout(iw)=0. end do if(nw1.lt.1) nw1=1 if(nw2.gt.nwave) nw2=nwave nw1a=nw1-100; if(nw1a.lt.1) nw1a=1 nw2a=nw2+100; if(nw2a.gt.nwave) nw2a=nwave nscan=nw2a-nw1a ! mon=0 ! Gaus operation every 5th points j=0 do iw=nw1,nw2,nskip sum=0. do iwx=-101,101 wavelx=wavel(iw)+gaussx(iwx) call taint(wavel(nw1a),ainp(nw1a),wavelx,fx(iwx),nscan,1,ier,mon) sum=sum+fx(iwx)*gaussy(iwx)*xstep end do aout(iw)=sum j=j+1 wavel1(j)=wavel(iw) aout1(j)=aout(iw) jmax=j end do ! interpolate between the 5th values mon=0 do iw=nw1,nw2 if(wavel(iw).lt.wavel1(jmax)) & & call taint(wavel1(1),aout1(1),wavel(iw),aout(iw),jmax,1,ier,mon) end do ! ! Boltzmann plot call boltzf(wavel,aout) call boltzf1(wavel,aout) return end !****************************************************************************** subroutine H_bb(isp, temp, power) ! calculates emission and absorption coefficients by atomic lines of H ! input parameters: ! isp=species index ! temp=temperature, K ! output parameter: ! power=emission power, W/cm3 parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e common/comi/nwave integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom common/coma1/atomwt(matoms),ion_pot(matoms), & & Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms), & & starkg(line_tot,matoms), & & starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms), & & ei_atom(line_tot,matoms),ek_atom(line_tot,matoms), & & wavel_atom(line_tot,matoms),aki_atom(line_tot, & & matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms), & & e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms) & & ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms), & & ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms), & & eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms) common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23, & & matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom, & & matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms), & & ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom, & & matoms),ind_line(line_tot,matoms),iz_atom(matoms), & & neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom, & & matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms), & & ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms), & & nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms), & & n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms), & & n_wavel_cross_atom(matoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,range1 common/scratch/emisr(nw) dimension alph(20,6),spro(20,6),dell(20),y(20) integer npro(6) integer isp,wave_num1,i,j,k,ncentr,m,nl,nu,mon,ner,lin,nlim ! ! The following hydrogen line Stark broadening parameters are from Griem, Plasma ! Spectroscopy ! ! number of data points data npro/ & & 17, & ! L-alpha & 16, & ! L-beta & 14, & ! B-alpha & 19, & ! B-beta & 13, & ! B-gamma & 10 / ! B-delta ! ! wavelength deviation coordinates data alph/ & & 0., 0.0001,0.0002,0.0003,0.0004,0.0005,0.0006,0.0008,0.001, & ! L-alpha & 0.0013,0.0016,0.002, 0.0025,0.003, 0.0035,0.004, 0.0045,0., & ! " & 0., 0., & ! " & 0., 0.0002,0.0004,0.0006,0.0008,0.001, 0.0013,0.0016,0.002, & ! L-beta & 0.0025, 0.003, 0.0035,0.004, 0.005, 0.007, 0.01, 0., 0., & ! " & 0., 0., & ! " & 0., 0.005, 0.01, 0.015, 0.02, 0.025, 0.03, 0.04, 0.05, & ! B-alpha & 0.07, 0.09, 0.12, 0.15, 0.2, 0., 0., 0., 0., & ! " & 0., 0., & ! " & 0., 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0.08, & ! B-beta & 0.09, 0.1, 0.12, 0.14, 0.16, 0.18, 0.2, 0.25, 0.3, & ! " & 0.35, 0., & ! " & 0., 0.01, 0.02, 0.04, 0.06, 0.08, 0.1, 0.12, 0.15, & ! B-gamma & 0.2, 0.3, 0.4, 0.5, 0., 0., 0., 0., 0., & ! " & 0., 0., & ! " & 0., 0.02, 0.04, 0.07, 0.1, 0.15, 0.2, 0.3, 0.42, & ! B-delta & 0.6, 0., 0., 0., 0., 0., 0., 0., 0., & ! " & 0., 0. / ! " ! ! intensity coordinates data spro/ & & 2304., 1153., 522., 291., 208., 169., 145., 104., 78.2, & ! L-alpha & 54.2, 39.9, 28.1, 17.9, 11.9, 7.8, 5.2, 3.4, 0., & ! " & 0., 0., & ! " & 98.1, 117.9, 163.6, 177., 176.7, 166.5, 146.3, 122.0, 97., & ! L-beta & 71.5, 52.9, 40.1, 29.9, 19.0, 9.4, 4.0, 0., 0., & ! " & 0., 0., & ! " & 15.7, 14.0, 11.2, 8.63, 6.79, 5.55, 4.63, 3.35, 2.52, & ! B-alpha & 1.55, 1.03, 0.6, 0.375, 0.2, 0., 0., 0., 0., & ! " & 0., 0., & ! " & 3.36, 3.62, 3.91, 4.01, 3.85, 3.53, 3.16, 2.74, 2.34, & ! B-beta & 2., 1.73, 1.31, 0.999, 0.787, 0.622, 0.502, 0.313, 0.218, & ! " & 0.164, 0., & ! " & 3.43, 3.28, 2.99, 2.53, 2.23, 1.94, 1.65, 1.38, 1.06, & ! B-gamma & 0.684, 0.326, 0.182, 0.113, 0., 0., 0., 0., 0., & ! " & 0., 0., & ! " & 1.63, 1.69, 1.71, 1.58, 1.37, 1.04, 0.772, 0.43, 0.229, & ! B-delta & 0.106, 0., 0., 0., 0., 0., 0., 0., 0., & ! " & 0., 0. / ! " ! write(6,10) atomnm(isp),dens_atom(isp) 10 format(' in H_bb. species = ', a4,1pe10.3,' cm-3') ! ! neutral partition function partn=0. do i=1,nlev_atom(isp) partn=partn+g_atom(i,isp)*dexp(-1.43877d0*Ecm_atom(i,isp)/temp) end do ! cycle over lines ! do k = 1,nline(isp) ! ! number density of upper state nk=(dens_atom(isp)*gk_atom(k,isp) * dexp(-1.43877d0 & & *ek_atom(k,isp)/temp)/partn) ! ! number density of lower state ni=(dens_atom(isp)* gi_atom(k,isp)* dexp(-1.43877d0 & & *ei_atom(k,isp)/temp)/partn) ! ! seek line profile data from Griem's table nl = ngi_atom(k,isp) nu = ngk_atom(k,isp) lin=0 if((nl.eq.1).and.(nu.eq.2)) lin=1 if((nl.eq.1).and.(nu.ge.3)) lin=2 if((nl.eq.1).and.(nu.ge.4)) lin=2 if((nl.eq.1).and.(nu.ge.5)) lin=2 if((nl.eq.1).and.(nu.ge.6)) lin=2 if((nl.eq.2).and.(nu.eq.3)) lin=3 if((nl.eq.2).and.(nu.eq.4)) lin=4 if((nl.eq.2).and.(nu.eq.5)) lin=5 if((nl.eq.2).and.(nu.eq.6)) lin=6 if((nl.gt.2).and.(nu.eq.4)) lin=4 if((nl.gt.2).and.(nu.eq.5)) lin=5 if((nl.gt.2).and.(nu.ge.6)) lin=6 nlim=npro(lin) f0=1.253e-9*(dens_elec**0.666667) f1=1./f0 do j=1,npro(lin) y(j)=spro(j,lin) dell(j)=f0*alph(j,lin) enddo ! ! determine the wavelength node m for line center ! determine the wavelength node m for line center ncentr=nwave*((wavel_atom(k,isp)-wavmin)/(wavmax-wavmin))**(1./calpha) ! ncentr=(1.0d0/dsqrt(wavmin) - 1.0d0/dsqrt(wavel_atom(k,isp)))/estep + 1 ! determine wavelength interval at line center in angstrom witv=((wavmax-wavmin)/float(nwave)**calpha)*calpha*float(nwave)**(calpha-1.) ! witv=wavmin**2*estep/((1.0d0-wavmin*estep*ncentr) & ! & *(1.0d0-wavmin*estep*(ncentr-1))) ! witv=1./(1./dsqrt(wavmin)-estep*(ncentr-1))**2 & ! & -1./(1./dsqrt(wavmin)-estep*ncentr)**2 ! witv=dabs(witv) ! ax=(real(gi_atom(k,isp))/real(gk_atom(k,isp)))*(nk/ni) blam=1.1904d-16*ax/((1.0d-8*wavel_atom(k,isp))**5*(1.0d0-ax)) ! line emissiion power in w/(cm3-sr) e=1.580d-16*aki_atom(k,isp)*nk/wavel_atom(k,isp) const=spro(npro(lin),lin)*(dell(nlim)**2.5) mtot=0 mon=0 do m=1,nwave ! del=1.0d0/(1.0d0/wavmin-estep*(ncentr-1))-1.0d0/(1.0d0/ & ! & wavmin-estep*(m-1)) ! determine wavelength interval at line center in angstrom witv=((wavmax-wavmin)/float(nwave)**calpha)*calpha*float(nwave)**(calpha-1.) ! witv=wavmin**2*estep/((1.0d0-wavmin*estep*ncentr) & ! & *(1.0d0-wavmin*estep*(ncentr-1))) ! del=1./(1./dsqrt(wavmin)-estep*(ncentr-1))**2 & ! & -1./(1./dsqrt(wavmin)-estep*ncentr)**2 ! del=dabs(witv) ! ! skip if wavelength is more than 10000 Angstrom away from the center of the line if(del.gt.wavel_atom(k,isp)*0.1) go to 20 ! if(del.gt.1000.) go to 20 ! within Griem's profile limit if(del.lt.dell(nlim)) go to 30 ! ! extrapolate beyond Griem's profile limit prof=const/(del**2.5) go to 40 ! ! Griem's profile by interpolation 30 continue call taint(dell,y,del,prof,nlim,2,ner,mon) ! ! construct profile 40 continue mtot=mtot+1 emisr(m)=prof if(mtot.eq.1) m1=m m2=m 20 continue end do call trapez(ans,wavel(m1),emisr(m1),mtot,ier) ratio=ans*f1 ! do m=nstart,nend do m=m1,m2 emisr(m)=emisr(m)/ratio end do do m=m1,m2 emission=e*emisr(m)*1.0e4*f1 absorption = emission/blam cross=absorption/dens_atom(isp) absb(m) = absb(m) + absorption end do end do ! return end !*********************************************************************** subroutine interp(nsp,natoms,ndiatoms,ntriatoms,& & rho,temp,spnmx,spgam,pres,enth,avmw,ansp, & & concAl,concAlp,concAlpp,concAl3p, & & concC, concC2, & & concCa,concCap,concCl,concC2H, & & concC3,concCH, concCN,concCO, & & concCO2,concCp, concCpp,concC3p, & & concC4p,concCr,concCrp,concCrpp, & & concFe,concFeO,concFep,concFepp, & & concFe3p,concFe4p,concFe5p,concH, & & concH2, concHp,concH2O,concK, & & concMg, concMgO,concMgp,concMgpp, & & concMg3p,concMg4p,concN,concNE, & & concN2,concN2p,concNp,concNpp, & & concN3p,concN4p,concNa,concNap, & & concNO,concNi,concNip,concNipp, & & concNi3p,concO,concO2,concOH, & & concOp,concOpp,concO3p,concO4p, & & concS,concSi,concSO,concSiO, & & concSip,concSipp,concSi3p,concSi4p, & & concSp,concSpp,concS3p,concS4p, & & concSiH,concTi,concTip,concTipp, & & concTi3p,concTiO) ! picks needed radiation mechanisms by matching the species number density ! and given command ! input parameters: ! nsp= number of species ! rho=density, kg/m3 ! temp=temperature, K ! spnm(msp)=species name ! spgam(msp)=species concentration, mol/kg ! pres=pressure, Pascal ! enth=enthalpy, J/kg ! avmw=average molecular weight kg/mol ! atomnm(matoms)=name of atoms ! diatomnm(mdiatoms)=name of diatoms ! triatomnm(mtriatoms)=name of triatoms ! atom_rads(3,168)=list of atomic radiation mechanisms to be calculated ! diatom_bands(3,100)=list of diatomic radiation mechanisms to be calculated ! triatom_bands(3,10)=list of triatomic radiation mechanisms to be calculated ! concAl, etc= concentration of Al, etc, m-3 ! parameter(matoms=56,mdiatoms=12,mtriatoms=6,msp=60) implicit real*8(a-h,o-z) character*4 asterik,atomnm2(matoms),bandnm_diatom,spnmx(msp), & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 dimension spgam(msp),ansp(msp) nsp1=nsp+1 do isp=1,nsp1 if(spnm(isp).eq.'Al ') then concAl=ansp(isp) end if if(spnm(isp).eq.'C ') then concC=ansp(isp) end if if(spnm(isp).eq.'C2 ') then concC2=ansp(isp) end if ! if(spnm(isp).eq.'Cl ') then ! concCl=ansp(isp) ! end if if(spnm(isp).eq.'Cr ') then concCr=ansp(isp) end if if(spnm(isp).eq.'C2H ') then concC2H=ansp(isp) end if if(spnm(isp).eq.'Ca ') then concCa=ansp(isp) end if if(spnm(isp).eq.'C3 ') then concC3=ansp(isp) end if if(spnm(isp).eq.'CH ') then concCH=ansp(isp) end if if(spnm(isp).eq.'CN ') then concCN=ansp(isp) end if if(spnm(isp).eq.'CO ') then concCO=ansp(isp) end if if(spnm(isp).eq.'CO2 ') then concCO2=ansp(isp) end if if(spnm(isp).eq.'Al+ ') then concAlp=ansp(isp) end if if(spnm(isp).eq.'Al++') then concAlpp=ansp(isp) end if if(spnm(isp).eq.'Al+3') then concAl3p=ansp(isp) end if if(spnm(isp).eq.'C+ ') then concCp=ansp(isp) end if if(spnm(isp).eq.'Ca+ ') then concCap=ansp(isp) end if if(spnm(isp).eq.'Cr+ ') then concCrp=ansp(isp) end if if(spnm(isp).eq.'C++ ') then concCpp=ansp(isp) end if if(spnm(isp).eq.'C+3 ') then concC3p=ansp(isp) end if ! if(spnm(isp).eq.'Cr++') then ! concCrpp=ansp(isp) ! end if if(spnm(isp).eq.'Fe ') then concFe=ansp(isp) end if if(spnm(isp).eq.'FeO ') then concFeO=ansp(isp) end if if(spnm(isp).eq.'Fe+ ') then concFep=ansp(isp) end if if(spnm(isp).eq.'Fe++') then concFepp=ansp(isp) end if if(spnm(isp).eq.'Fe+3') then concFe3p=ansp(isp) end if if(spnm(isp).eq.'Fe+4') then concFe4p=ansp(isp) end if if(spnm(isp).eq.'Fe+5') then concFe5p=ansp(isp) end if if(spnm(isp).eq.'H ') then concH=ansp(isp) end if if(spnm(isp).eq.'H2 ') then concH2=ansp(isp) end if if(spnm(isp).eq.'H+ ') then concHp=ansp(isp) end if if(spnm(isp).eq.'H2O ') then concH2O=ansp(isp) end if ! if(spnm(isp).eq.'K ') then ! concK=ansp(isp) ! end if if(spnm(isp).eq.'Mg ') then concMg=ansp(isp) end if if(spnm(isp).eq.'MgO ') then concMgO=ansp(isp) end if if(spnm(isp).eq.'Mg+ ') then concMgp=ansp(isp) end if if(spnm(isp).eq.'Mg++') then concMgpp=ansp(isp) end if if(spnm(isp).eq.'Mg+3') then concMg3p=ansp(isp) end if if(spnm(isp).eq.'Mg+4') then concMg3p=ansp(isp) end if if(spnm(isp).eq.'N ') then concN=ansp(isp) end if if(spnm(isp).eq.'N2 ') then concN2=ansp(isp) end if if(spnm(isp).eq.'N2+ ') then concN2p=ansp(isp) end if if(spnm(isp).eq.'N+ ') then concNp=ansp(isp) end if if(spnm(isp).eq.'N++ ') then concNpp=ansp(isp) end if if(spnm(isp).eq.'N+3 ') then concN3p=ansp(isp) end if if(spnm(isp).eq.'N+4 ') then concN3p=ansp(isp) end if if(spnm(isp).eq.'Na ') then concNa=ansp(isp) end if if(spnm(isp).eq.'Na+ ') then concNap=ansp(isp) end if if(spnm(isp).eq.'Ni ') then concNi=ansp(isp) end if if(spnm(isp).eq.'Ni+ ') then concNip=ansp(isp) end if if(spnm(isp).eq.'Ni++') then concNipp=ansp(isp) end if if(spnm(isp).eq.'Ni+3') then concNi3p=ansp(isp) end if if(spnm(isp).eq.'NO ') then concNO=ansp(isp) end if if(spnm(isp).eq.'O ') then concO=ansp(isp) end if if(spnm(isp).eq.'O2 ') then concO2=ansp(isp) end if if(spnm(isp).eq.'OH ') then concOH=ansp(isp) end if if(spnm(isp).eq.'O+ ') then concOp=ansp(isp) end if if(spnm(isp).eq.'O++ ') then concOpp=ansp(isp) end if if(spnm(isp).eq.'O+3 ') then concO3p=ansp(isp) end if if(spnm(isp).eq.'O+4 ') then concO3p=ansp(isp) end if if(spnm(isp).eq.'S ') then concS=ansp(isp) end if if(spnm(isp).eq.'Si ') then concSi=ansp(isp) end if if(spnm(isp).eq.'SO ') then concSO=ansp(isp) end if if(spnm(isp).eq.'Si+ ') then concSip=ansp(isp) end if if(spnm(isp).eq.'Si++') then concSipp=ansp(isp) end if if(spnm(isp).eq.'Si+3') then concSi3p=ansp(isp) end if if(spnm(isp).eq.'Si+4') then concSi4p=ansp(isp) end if if(spnm(isp).eq.'S+ ') then concSp=ansp(isp) end if if(spnm(isp).eq.'S++ ') then concSpp=ansp(isp) end if if(spnm(isp).eq.'S+3 ') then concS3p=ansp(isp) end if if(spnm(isp).eq.'SiH ') then concSiH=ansp(isp) end if if(spnm(isp).eq.'SiO ') then concSiO=ansp(isp) end if if(spnm(isp).eq.'Ti ') then concTi=ansp(isp) end if if(spnm(isp).eq.'Ti+ ') then concTip=ansp(isp) end if if(spnm(isp).eq.'Ti++') then concTipp=ansp(isp) end if if(spnm(isp).eq.'Ti+3') then concTip3=ansp(isp) end if if(spnm(isp).eq.'TiO ') then concTiO=ansp(isp) end if if(spnm(isp).eq.'E- ') concNE=ansp(isp) end do ! return end !************************************************************************* subroutine intpl1(xtab,ftab,x,f,n) ! three-point interpolation, for equally-spaced xtab values ! linear extrapolation beyond limits ! inputs: ! xtab(n)=tabulated x values ! ftab(n)=tabulated function values ! x=x value where interpolation is wanted ! n=number of data points ! output: ! f=function value at x ! implicit real*8(a-h,o-z) dimension xtab(n), ftab(n) ! a=(x-xtab(1))/(xtab(n)-xtab(1)) ! ! x is within limits if((a.gt.0.).and.(a.lt.1.)) then i=int(float(n-1)*(x-xtab(1))/(xtab(n)-xtab(1)))+1 if(i.eq.1) then p=(x-xtab(2))/(xtab(2)-xtab(1)) f=0.5*p*(p-1.)*ftab(1)+(1.-p*p)*ftab(2)+0.5*p*(p+1.)*ftab(3) endif if(i.gt.1) then p=(x-xtab(i))/(xtab(2)-xtab(1)) f=0.5*p*(p-1.)*ftab(i-1)+(1.-p*p)*ftab(i)+0.5*p*(p+1.) & & *ftab(i+1) endif endif ! x is below lower limit, linear extrapolation if(a.le.0.) then f=ftab(1)+(ftab(2)-ftab(1))*(x-xtab(1))/(xtab(2)-xtab(1)) endif ! x is over upper limit, linear extrapolation if(a.ge.1.) then f=ftab(n)+(ftab(n)-ftab(n-1))*(x-xtab(n))/(xtab(n)-xtab(n-1)) endif ! return end !*********************************************************************** subroutine ivuna_wall(pab, twa,delHa) ! determines wall conditions for Ivuna-Orgueil meteoroid ! input parameter ! pab=pressure, Pa ! outputparameters ! twa=wall temperature, K ! delHa=ablation energy, J/kg implicit real*8(a-h,o-z) ! feo_L_K is for liquid FeO ! fes_c_K is for solid FeS real*8 mg_K,mgo_c_K,mgo_K,mgo_L_K,na2o_L_K,nao_K,na_K,ni_L_K,nig_K dimension tw(9),tw1(9),twx(9),plogx(9),psum(9),psumlog(9), & & p(9,14),delK(10,14),delHz(4),coeft(4),coefH(4), & & o_K(9),o2_K(9),ca_K(9),cao_L_K(9),cao_K(9), & & sio2_c_K(6),sio2_L_K(9),al2o3_c_K(9),al2o_K(9),alo2_K(9), & & alo_K(9),sio2_K(9),sio_K(9),fe2o3_c_K(6),fe2o3_L_K(9), & & feo_L_K(9),feo_K(9),fe_L_K(9),fe_K(9),mg_K(9),mgo_c_K(9), & & mgo_L_K(9),mgo_K(9),na2O_L_K(9),nao_K(9),na_K(9),h2o_L_K(9), & & h2o_K(9),oh_K(9),h2_K(9),h_K(9),fes_c_K(6), & & fes_L_K(9),fes_K(9),ni_L_K(9),nig_K(9),tio2_L_K(9),tiog_K(9), & & c_c_K(9),c3_K(9),s_K(9), & & sens_O(9),sens_O2(9),sens_SiO(9),sens_Si(9),sens_SiO2(9), & & sens_TiO(9),sens_TiO2(9),sens_Ti(9),sens_Fe(9), & & sens_AlO(9),sens_Al2O(9),sens_Al(9),sens_CrO(9), & & sens_FeO(9),sens_CaO(9),sens_Ca(9),sens_FeS(9),sens_S(9), & & sens_H(9),sens_OH(9),sens_H2O(9),sens_MgO(9),sens_Mg(9),sens_NaO(9), & & sens_Na(9),sens_Ni(9),sens_C(9),sens_C3(9) dimension ploglog(51) character*6 compnm ! compef=mol fraction of compounds common/compi/compnm(14) common/compe/compef(14),solid_dens(14),solid_dens_av,wtmolc dimension aa(4,4),bb(4,2),cc(4,2) dimension twz(51),ppb(51),delH_wt(51),pln(51) ! data tw/500.,1000.,1500.,2000.,2500.,3000.,3500.,4000.,4500./ data twx/500.,1000.,1500.,2000.,2500.,3000.,3500.,4000.,4500./ data itime/0/ ! ! equilibrium constants---------------------------------------------------------- ! ! O2 --> 2 O data o2_K/ 0., 0., 0., 0., 0., 0., 0., 0., 0./ ! 1. SiO2(L) --> SiO2(g) data sio2_c_K/85.444,38.137,22.443,14.388,9.463,6.197/ data sio2_L_K/85.617,38.145,22.415,14.388,9.528,6.322,4.056,1.665,-0.186/ ! OK data sio2_K/32.142,16.114,10.743,7.796,5.902,4.631,3.717,2.318,1.222/ data sio_K/15.168,9.790,7.926,6.706,5.836,5.240,4.802,3.757,2.934/ ! ! 2. TiO2 --> TiO + 0.5*O2 data tio2_L_K/84.880,38.329,22.853,15.188,10.576,7.526,5.365,3.214,1.063/ data tiog_K/-0.497,2.173,2.925,3.219,3.269,3.255,3.211,2.615,1.965/ ! OK ! ! 3. Al2O3 -->Al2O + O2 data al2o3_c_K/158.659,71.114,41.067,27.008,18.433,12.325,7.157,3.365,-0.427/ data al2o_K/19.968,12.014,8.868,7.196,6.139,4.633,2.639,1.143,-0.020/ data alo2_K/9.949,5.350,3.593,2.685,2.120,1.346,0.336,-0.421,-1.008/ data alo_K/-2.470,0.800,1.614,1.981,2.186,1.933,1.301,0.832,0.470/ ! ok data o_K/-22.936,-9.803,-5.392,-3.175,-1.839,-0.946,-0.307,0.173,0.547/ ! 5. Fe2O3(L) --> 2FeO + 0.5 O2 data fe2o3_c_K/71.972,29.349,15.265,8.185,3.837,-0.511/ data feo_L_K/23.271,10.355,6.033,3.877,2.766,1.661,0.428,-0.673,-1.517/ ! data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/ ! corrected data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/ ! 6. FeO(L) --> FeO(g) data feo_L_K/23.271,10.355,6.033,3.877,2.544,1.661,0.428,0.673,-1.517/ ! data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/ ! corrected data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/ ! ! 7. MgO(L) --> Mg + 0.5 O2 data mgo_c_K/57.153,25.749,14.722,8.358,4.582,2.095,0.341,-0.957,-0.957/ data mgo_L_K/57.153,25.749,14.722,8.358,4.582,2.095,0.491,-0.654,-1.527/ ! corrected data mgo_K/-2.040,0.894,1.327,0.679,0.305,0.059,-0.115,-0.246,-0.350/ data mg_K/ -9.338,-1.828,0., 0., 0., 0., 0., 0., 0./ ! ! 8. CaO --> Ca + 0.5 O2 data cao_L_K/53.971,24.918,15.121,9.720,6.044,3.630,1.930,0.778,-0.310/ data cao_K/ -0.690,1.185,1.817,1.461,0.783,0.359,0.080,-0.116,-0.364/ ! corrected data ca_K/ -12.090,-3.393,-0.812, 0., 0., 0., 0., 0., 0./ ! ! 9. Na2O --> NaO + Na data Na2O_L_K/36.652,14.634,5.836,1.292,-1.317,-2.981,-4.145,-5.018,-5.697/ data NaO_K /-4.968,-0.920,-0.586,-0.794,-0.920,-1.06,-1.069,-1.118,-1.159/ ! OK data Na_K / 0., 0., 0., 0., 0., 0., 0., 0., 0./ ! 10. H2O(L) --> OH + 0.5H2 data h2o_L_K/20.534,6.458,1.934, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ data oh_K/ -3.246, -1.222, -0.563, -0.240, -0.050,0.074,0.160, 0.223,0.270/ ! OK data h2_K/0.,0.,0.,0.,0.,0.,0.,0.,0./ ! data h_K/-20.158,-8.644,-4.754,-2.788,-1.599,-0.801,-0.228,0.203,0.539/ ! data h2o_K/22.884,10.060,5.724,3.540,2.223,1.344,0.713,0.239,-0.131/ ! ! 11. Fe(L) --> Fe(g) data fe_L_K/ 0., 0., 0., 0., 0., 0., -0.605,-1.236,-1.867/ data fe_K/-35.408,-13.824,-6.816,-3.429,-1.505,-0.260,0., 0., 0./ ! OK ! ! 12. Ni(L) --> Ni(g) data ni_L_K/ 0., 0., 0., 0., 0., 0., -0.609, -1.524,2.286/ data nig_K/-37.000,-14.659,-7.282,-3.717, -1.666,-0.327, 0., 0., 0./ ! OK ! 13. FeS(c) --> Fe + S data fes_c_K/10.707,5.102,2.401,1.297,0.577,0.091/ data fes_L_K/10.707,5.102,2.401,1.297,0.577,0.091,-0.867,-1.806,-2.544/ data fes_K/-28.832,-10.510,-5.481,-3.099,-1.791,-0.967,-1.017,-1.256,-1.448/ ! corrected data s_K/ -21.932,-8.154,-4.286,2.494,-1.356,-0.595,-0.050,0.360,0.680/ ! 14. C(c) --> (1/3) C3 data c_c_K/0.,0.,0.,0.,0.,0.,0.,0.,0./ data c3_K/-74.143,-31.400,-17.322,-10.384,-6.285,-3.596,-1.708,-0.317,0.745/ ! OK ! if(itime.eq.1) go to 1000 ! !------------------------------------------------------------------- ! initialization ! ! generate 1000/T array do it=1,9 tw1(it)=1000./tw(it) end do !------------------------------------------------------------------- ! mol fractions brought from compos ! 1 2 3 4 5 ! & 'SiO2 ','TiO2 ','Al2O3 ','CrO2 ','Fe2O3 ', & ! 6 7 8 9 10 ! & 'FeO ','MgO ','CaO ','Na2O ','H2O ', & ! 11 12 13 14 ! & 'Fe ','Ni ','FeS ','C '/ ! vapor pressure ! ! 1. SiO2(L) --> SiO2(g) do it=1,9 delK(it,1)=sio2_K(it)-sio2_L_K(it) p(it,1)=10.**delK(it,1) end do ! 2. TiO2 --> TiO + 0.5O2 do it=1,9 delK(it,2)=tiog_K(it) - tio2_L_K(it) p(it,2)=10.**delK(it,2) end do ! 3. Al2O3--> Al2O + O2 do it=1,9 delK(it,3)=al2o_K(it)-al2o3_c_K(it) p(it,3)=10.**delK(it,3) end do ! 5. Fe2O3(L) --> 2 FeO + 0.5O2 do it=1,9 if(it.le.6) fe2o3ck=fe2o3_c_K(it) if(it.gt.6) then mon=0 call taint(tw1(1),fe2o3_c_K(1),tw1(it),fe2o3ck,6,1,ier,mon) end if delK(it,5)=feo_K(it) + 0.5*o2_K(it) - fe2o3ck p(it,5)=10.**delK(it,5) end do ! 6. FeO(L) --> FeO(g) do it=1,9 delK(it,6)=feo_K(it) - feo_L_K(it) p(it,6)=10.**delK(it,3) end do ! 7. MgO(c) --> MgO(g) do it=1,9 delK(it,7)=mgo_K(it)-mgo_c_K(it) p(it,7)=10.**delK(it,7) end do ! 8. CaO(c) --> CaO(g) do it=1,9 delK(it,8)=cao_K(it)-cao_L_K(it) p(it,8)=10.**delK(it,9) end do ! 9. Na2O --> NaO + Na do it=1,9 delK(it,9)=NaO_K(it)+Na_K(it)-Na2O_L_K(it) p(it,9)=10.**delK(it,9) end do ! 10. H2O(L) --> OH + 0.5H2 do it=1,9 delK(it,10)=oh_K(it)+0.5*h2_K(it)-h2O_L_K(it) ! delK(it,10)=h2o_K(it)-h2o_L_K(it) p(it,10)=10.**delK(it,10) end do ! 11. Fe(L) --> Fe(g) do it=1,9 delK(it,11)=fe_K(it)-fe_L_K(it) p(it,11)=10.**delK(it,11) end do ! 12. Ti(L) --> Ti do it=1,9 delK(it,12)=nig_K(it)-ni_L_K(it) p(it,11)=10.**delK(it,12) end do ! 13. FeS(L) --> FeS(g) do it=1,9 delK(it,13)=feS_K(it) - fes_L_K(it) ! delK(it,13)=fes_K(it) - fes_L_K(it) p(it,13)=10.**delK(it,6) end do ! 14. C(c) --> C3/3 do it=1,9 delK(it,14)=0.33333*c3_K(it) - c_c_K(it) p(it,14)=10.**delK(it,7) end do ! mol fractions brought from compos ! 1 2 3 4 5 ! & 'SiO2 ','TiO2 ','Al2O3 ','CrO2 ','Fe2O3 ', & ! 6 7 8 9 10 ! & 'FeO ','MgO ','CaO ','Na2O ','H2O ', & ! 11 12 13 14 ! & 'Fe ','Ni ','FeS ','C '/ ! compef_sum=0. do i=1,14 compef_sum=compef_sum+compef(i) end do ! individual partial pressures do it=1,9 p(it,1)=p(it,1)*compef(1) ! SiO2 p(it,2)=p(it,2)*compef(2) ! TiO2 p(it,3)=p(it,3)*compef(3) ! Al2O3 p(it,4)=0. ! CrO2 p(it,5)=p(it,5)*compef(5) ! Fe2O3 p(it,6)=p(it,6)*compef(6) ! FeO p(it,7)=p(it,7)*compef(7) ! MgO p(it,8)=p(it,8)*compef(8) ! CaO p(it,9)=p(it,9)*compef(9) ! Na2O p(it,10)=p(it,10)*compef(10) ! H2O p(it,11)=p(it,11)*compef(11) ! Fe p(it,12)=p(it,12)*compef(12) ! Ni p(it,13)=p(it,13)*compef(13) ! FeS p(it,14)=p(it,14)*compef(14) ! C end do ! ! write vapor pressures write(6,*) ' ' write(6,20) 20 format(47h 1=SiO2->SiO+O, 2=TiO2->TiO+O, 3=Al2O3->2AlO+O , & & 69h 4=CrO2->CrO+O, 5=Fe2O3->2FeO+O, 6=FeO(L)->FeO, 7=MgO(L)->MgO / & & 69h 8=CaO(L)->CaO(g), 9=Na2O->NaO+Na, 10=H2O->OH+H, 11=Fe(L)->Fe(g) & & 47h 12=Ni(L)->Ni(g),13=FeS(L)->FeS 14=C(c)->C3/3 & & /'Partial pressures (atm)'/ & & 69h Tw 1000/Tw SiO2 TiO2 Al2O3 CrO2 Fe2O3 FeO & & 69h MgO CaO Na2O Fe Ni FeS C psum ) do it=1,9 psum(it)=p(it,1)+0.*p(it,2)+p(it,3)+p(it,4)+p(it,5)+p(it,6)+0.*p(it,7) & & +p(it,8)+p(it,9)+p(it,10)+p(it,11)+p(it,12)+p(it,13)+p(it,14) psumlog(it)=dlog10(psum(it)) write(6,10) tw(it),1000./tw(it),(p(it,k),k=1,3),(p(it,k),k=5,14),psum(it) 10 format(f7.0,f8.5,1p20e9.2) end do ! ! write temperature-pressure relationship write(6,120) 120 format(/' p1(atm) Tw') do itx=1,51 twz(itx)=1850.+2000.*0.035*(itx-1) mon=0. call taint(tw,psumlog,twz(itx),pslx,9,2,ier,mon) ppb(itx)=10.**pslx pln(itx)=dlog(ppb(itx)) write(6,110) ppb(itx),twz(itx) 110 format(1pe11.3,0pf10.1) end do ! !--------------------------------------------------------------------- ! ablation energy ! 1 2 3 4 5 ! & 'SiO2 ','TiO2 ','Al2O3 ','CrO2 ','Fe2O3 ', & ! 6 7 8 9 10 ! & 'FeO ','MgO ','CaO ','Na2O ','H2O ', & ! 11 12 13 14 ! & 'Fe ','Ni ','FeS ','C '/ ! ! formation energy, condensate data delHc_SiO2/-908.346/,delHc_TiO2/-893.055/,delHc_Al2O3/-1620.567/, & & delHc_Fe2O3/-819.03/,delHc_FeO/-247.532/,delHc_MgO/-601.241/, & & delHc_CaO/-557.335/,delHc_Na2O/-413.15/,delHc_H2O/-285.830/, & & delHc_Fe/0./,delHc_FeS/-101.67/,delHc_C/0./ ! ! total formation energy of condensate Hc_av = & delHc_SiO2*compef(1) + delHc_TiO2*compef(2) + delHc_Al2O3*compef(3) & & + delHc_Fe2O3*compef(5) + delHc_FeO*compef(6) + delHc_MgO*compef(7) & & + delHc_CaO*compef(8) + delHc_Na2O*compef(9) + delHc_H2O*compef(10) & & + delHc_Fe*compef(11) + delHc_FeS*compef(13) + delHc_C*compef(14) ! kJ/mol Hc_av = Hc_av*1.0e3 ! J/mol ! ! formation energy, ablation product data delHg_Si/446.00/, delHg_SiO/-101.57/, & & delHg_TiO2/-303.28/, delHg_TiO/53.93/,delHg_Ti/470.92/, & & delHg_AlO/67.0/, delHg_Al/327.3/,delHg_FeO/251.05/, & & delHg_MgO/58.16/, delHg_CaO/45.1/, delHg_Na/107.5/, & & delHg_NaO/85.04/, delHg_O/246.79/, delHg_O2/0./,delHg_Fe/413.1/, & & delHg_FeS/370.77/, delHg_CaO/45.1/, delHg_H2O/-241.826/, & & delHg_C/273.3/, delHg_C3/811./, delHg_Na2O/85.48/,delHg_S/274.71/ ! 1 2 3 4 5 ! & 'SiO2 ','TiO2 ','Al2O3 ','CrO2 ','Fe2O3 ', & ! 6 7 8 9 10 ! & 'FeO ','MgO ','CaO ','Na2O ','H2O ', & ! 11 12 13 14 ! & 'Fe ','Ni ','FeS ','C '/ ! ! sensible energies of ablation product ! SiO2 data sens_SiO2/9.655,37.405,67.179,97.614,128.337,159.210, & & 190.168,221.181,252.231/ ! SiO data sens_SiO/6.282,23.472,41.645,60.179,78.897,97.735,116.672, & & 135.710,154.884/ ! Si data sens_Si/4.374,14.903,25.447,36.236,47.326,58.649,70.116, & & 81.651,93.206/ ! TiO data sens_TiO/6.855,25.283,44.324,63.568,83.040,102.932,123.455, & & 144.751,166.861/ ! TiO2 data sens_TiO2/9.606,36.491,64.750,93.417,122.266,151.256,180.438, & & 209.914,239.789/ ! O data sens_O/4.343,14.860,25.296,35.713,46.130,56.574,67.079,77.675, & & 88.386/ ! O2 data sens_O2/6.084,22.703,40.599,59.175,78.328,98.013,118.165,138.705,& & 159.572/ ! Al2O data sens_Al2O/11.067,40.732,71.341,102.227,133.229,164.293,195.405, & & 226.567,357.814/ ! AlO data sens_AlO/6.544,24.362,43.930,65.606,88.743,112.374,135.896, & & 159.094,181.978/ ! Al data sens_Al/4.268,14.712,25.112,35.523,45.921,56.318,66.722,77.150, & & 87.642/ ! CrO data sens_CrO/6.640,24.526,43.103,61.952,80.979,100.179,119.586, & & 139.243,159.188/ ! FeO data sens_FeO/6.556,24.545,43.095,61.963,81.189,100.865,121.034, & & 141.676,162.732/ ! Fe data sens_Fe/5.138,16.874,27.984,39.312,51.274,63.994,77.507, & & 91.872,107.200/ ! MgO data sens_MgO/7.053,31.379,57.820,81.353,103.117,124.081,144.717, & & 165.267,185.871/ ! CaO data sens_CaO/6.859,25.058,44.255,66.293,93.122,123.790,155.679, & & 186.918,216.877/ ! Ca data sens_Ca/4.196,14.589,24.982,35.405,46.054,57.105,70.641,86.448, & & 105.568/ ! NaO data sens_NaO/7.294,26.050,45.189,64.582,84.202,104.040,124.092, & & 144.357,164.833/ ! Na data sens_Na/4.196,14.589,24.982,35.378,45.803,56.343,67.154,78.457, & & 90.469/ ! OH data sens_OH/5.992,20.935,36.839,53.762,71.419,89.584,108.119,126.939,& & 145.991/ ! H2O data sens_H2O/6.925,26.000,48.151,72.790,99.108,126.549,154.768, & & 183.552,212.764/ ! H data sens_H/4.196,14.589,24.982,35.375,45.768,56.161,66.554,76.947, & & 87.370/ ! Ni data sens_Ni/4.815,17.239,29.461,41.266,52.748,64.031,75.225,86.433, & & 97.760/ ! FeS data sens_FeS/7.111,25.568,44.396,63.478,82.887,102.761,123.143, & & 144.017,165.329/ ! S data sens_S/4.689,15.677,26.325,36.917,47.640,58.538,69.634,80.898, & & 92.290/ ! C data sens_C/2.337,9.492,17.317,25.645,34.294,43.178,52.24, & & 61.446,70.772/ ! C3 data sens_C3/7.612,28.477,51.951,76.934,100.885,129.534,156.720, & & 184.339,184.339/ ! ! 1 2 3 4 5 ! & 'SiO2 ','TiO2 ','Al2O3 ','CrO2 ','Fe2O3 ', & ! 6 7 8 9 10 ! & 'FeO ','MgO ','CaO ','Na2O ','H2O ', & ! 11 12 13 14 ! & 'Fe ','Ni ','FeS ','C '/ ! ! vary pressure ! write(6,*) ' ' write(6,*) ' p(atm) Tw delH(J/kg' mon=0 do ip=1,51 mon=0 ! SiO2(L) -> SiO2(g) call taint(tw,sens_SiO2,twz(ip),sensx_SiO2,9,2,ier,mon) ! call taint(tw,sens_O,tww,sensx_O,9.2,ier,mon) ! call taint(tw,sens_O2,tww,sensx_O2,9,2,ier,mon) delHx_SiO2=(delHg_SiO2 + sensx_SiO2-delHc_SiO2)*1000. ! TiO2(L) -> TiO2(g) call taint(tw,sens_TiO2,twz(ip),sensx_TiO2,9.2,ier,mon) delHx_TiO2=(delHg_TiO2+sensx_TiO2-delHc_TiO2)*1000. ! Al2O3(L) -> Al2O(g) + O2 ! call taint(tw,sens_Al,tww,sensx_Al,9,2,ier,mon) call taint(tw,sens_Al2O,twz(ip),sensx_Al2O,9,2,ier,mon) delHx_Al2O3=(delHg_Al2O+sensx_Al2O+0.5*delHg_O2 & & +0.5*sensx_O2*(twz(ip)-298.)- delHc_Al2O3)*1000. ! CrO2 ! call taint(tw,sens_CrO,tww,sensx_CrO,ier,mon) ! end do ! Fe2O3 -> 2FeO + O2 ! call taint(tw,sens_Fe,twz(ip),sensx_Fe,9,2,ier,mon) call taint(tw,sens_FeO,tww,sensx_FeO,9,2,ier,mon) delHx_Fe2O3=(2*delHg_FeO+2.*sensx_FeO+delHg_O2+sensx_O2 & & -delHc_Fe2O3)*1000. ! FeO(c) -> FeO(g) delHx_FeO=(delHg_FeO+sensx_FeO-delHc_FeO)*1000. ! MgO(c) -> MgO(g) ! call taint(tw,sens_Mg,tww,sensx_Mg,9,2,ier,mon) call taint(tw,sens_MgO,twz(ip),sensx_MgO,9,2,ier,mon) delHx_MgO=(delHg_MgO+sensx_MgO-delHc_MgO)*1000. ! CaO(c) -> CaO(g) call taint(tw,sens_CaO,twz(ip),sensx_CaO,9,2,ier,mon) delHx_CaO=(delHg_CaO+sensx_CaO-delHc_CaO)*1000 ! H2O(c) -> H2O(g) ! call taint(tw,sens_H,twz(ip),sensx_H,9,2,ier,mon) call taint(tw,sens_H2O,twz(ip),sensx_H2O,9,2,ier,mon) delHx_H2O=(delHg_H2O+2*sensx_H2O-delHc_H2O)*1000. ! Na2O -> NaO + 0.5O2 call taint(tw,sens_NaO,twz(ip),sensx_NaO,9,2,ier,mon) delHx_Na2O=(delHg_NaO+sensx_NaO-delHc_Na2O)*1000. ! FeS call taint(tw,sens_FeS,twz(ip),sensx_FeS,9,2,ier,mon) delHx_FeS=(delHg_FeS+sensx_FeS-delHc_FeS)*1000. ! Fe call taint(tw,sens_Fe,twz(ip),sensx_Fe,9,2,ier,mon) delHx_Fe=(delHg_Fe+sensx_Fe-delHc_Fe)*1000. ! C call taint(tw,sens_C3,twz(ip),sensx_C3,9,2,ier,mon) delHx_C=(delHg_C3+sensx_C3-delHc_C)*1000. delH_wt(ip) = & & (delHx_SiO2*compef(1) + delHx_TiO2*compef(2) + delHx_Al2O3*compef(3) & & + delHx_Fe2O3*compef(5)+ delHx_FeO*compef(6) + delHx_MgO*compef(7) & & + delHx_CaO*compef(8) + delHx_Na2O*compef(9) + delHx_H2O*compef(10) & & + delHx_Fe*compef(11) + delHx_FeS*compef(13) & & + delHx_C*compef(14))/wtmolc write(6,135) ppb(ip),twz(ip),delH_wt(ip) pln(ip)=dlog(ppb(ip)) 135 format(1pe11.4,0pf11.1,1pe11.4) ! ! 1 2 3 4 5 ! & 'SiO2 ','TiO2 ','Al2O3 ','CrO2 ','Fe2O3 ', & ! 6 7 8 9 10 ! & 'FeO ','MgO ','CaO ','Na2O ','H2O ', & ! 11 12 13 14 ! & 'Fe ','Ni ','FeS ','C '/ ! end do !------------------------------------------------------------- ! run 1000 continue pll=dlog(pab/1.0133e5) mon=0 call taint(pln,twz,pll,twa,51,2,ier,mon) call taint(pln,delH_wt,pll,delHa,51,2,ier,mon) return end !********************************************************************* subroutine jmax(m) ! set up arrays k(i) and u(i) to ! find kmax - the maximum rotational quantum number. ! ! note that kmax values can not be calculated unless ! dissociation energies are input. ! parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) common/eqcome/kmaxvV(msp,25,100),maxv(msp,25),vV(msp,25,100) dimension k(500),u(500) character*4 elemnm,spnm real*8 mu ! rmax=1.0e-7 mu=rmass(m) c3=1.686e-15/mu n=nelec(m) ! do 25 i=1,n 25 maxv(m,i)=0 ! do 2 ie1=1,n ! we=spect(3,ie1,m) wexe=spect(4,ie1,m) weye=spect(5,ie1,m) requil=spect(6,ie1,m)*1.0d-8 dzero=spect(7,ie1,m) be=spect(8,ie1,m) alpha=spect(9,ie1,m) de=spect(10,ie1,m) beta=spect(11,ie1,m) ! imax=0 imax1=1 do 20 i=1,500 k(i)=0 20 u(i)=0. rstep=1.0d-9 dequil=dzero+.5d0*we-.25d0*wexe+.125d0*weye c1=1.2177d+7*we*dsqrt(mu/dequil) r=requil fr2=0.0d0 80 fr1=fr2 85 r=r+rstep if (r.gt.rmax) go to 90 c2=dexp(-c1*(r-requil)) fr2=(r*1.0d+8)**3*c2*(1.0d0-c2) if (fr2.gt.fr1) go to 80 if(dabs(fr2-fr1).le.1.0d-10) goto 90 r=r-rstep rstep=rstep/10. goto 85 ! 90 continue fk=fr2*1.0e-24*c1*dequil/c3 rk=-.5d0+.5d0*dsqrt(1.0d0+4.0d0*fk) k(1)=rk u(1)=dequil*(1.0d0-dexp(-c1*(r-requil)))**2+c3*rk*(rk+1.)/r**2 rstep=1.0d-10 do 120 i=2,500 kjh=0 100 r=r+rstep c2=dexp(-c1*(r-requil)) fr2=(r*1.0e+8)**3*c2*(1.0-c2) fk=fr2*1.0e-24*c1*dequil/c3 rk=-.5d0+.5d0*sqrt(1.0d0+4.0d0*fk) k(i)=rk if(k(i).lt.3) goto 130 delk=k(i-1)-k(i) if(delk.lt.1.5d0.and.delk.gt.0.5d0) goto 110 r=r-rstep if(delk.le.0.5) rstep=rstep*2.0 if(delk.ge.1.5) rstep=rstep/10.0 kjh=kjh+1 if(kjh.lt.100) goto 100 write(6,700) m,i 700 format(' infinite loop in jmax at 700; m=',i3,' i=',i3) stop ! 110 u(i)=dequil*(1.0d0-exp(-c1*(r-requil)))**2+c3*rk*(rk+1.)/r**2 imax=i 120 continue 130 continue ! ! cycle over vibrational levels ! ! the energies of the first 16 levels, or less if evib=>dequil, are ! calculated from we,wexe and weye. the energies of the remaining ! levels are calculated by added on the evib increment from a morse pot. ! nvib=32 140 nvib=nvib/2 if(nvib.gt.0) goto 150 ! write(6,710) m,ie 710 format(' error!! no vibrational levels for m=',i3, & & ' state=',i3) stop 150 evib=0. do 1 jvib=1,nvib v=jvib-1 evib2=evib bv=be-alpha*(v+0.5d0) dv=de+beta*(v+0.5d0) evib=we*(v+.5d0)-wexe*(v+.5d0)**2+weye*(v+.5d0)**3 vv(m,ie1,jvib)=evib delev=evib-evib2 if(evib.le.evib2) goto 140 kmax=fkmax(k,u,imax1,imax,evib,bv,dv) kmaxvv(m,ie1,jvib)=kmax if (evib.ge.dequil/2.) goto 4 if(kmax.le.2) goto 3 1 continue jvib1=nvib+1 goto 5 4 jvib1=jvib+1 5 nvib=2.*dequil/we if(nvib.gt.100) nvib=100 do 6 jvib=jvib1,nvib v=jvib-1 bv=be-alpha*(v+0.5) dv=de+beta*(v+0.5) delev=delev-we**2/(2.*dequil) evib=evib+delev vv(m,ie1,jvib)=evib if(evib.gt.dequil) goto 3 kmax=fkmax(k,u,imax1,imax,evib,bv,dv) kmaxvv(m,ie1,jvib+1)=kmax if(kmax.le.2) goto 3 6 continue jvib=nvib goto 7 3 jvib=jvib-1 7 maxv(m,ie1)=jvib 2 continue iv(m)=1 return end !*********************************************************************** subroutine kmeqm(p1,t1,ethm1,iprb,elmsf1,spmlf1,brm1,rho1) ! !.....iprb(t,p)=1; iprb(h,p)=2......................................... ! subroutine for computing chemical equilibrium in flow fields. the ! method is essentially that given in nasa sp-273 by mcbride and gordon ! ! inputs: ! p1=pressure, atm ! T1=temperature, K ! ethm1=enthalpy, J/kg ! outputs: ! brm1=average molecular weight, g/mol ! rho1=density, kg/m3 implicit real*8(a-h,o-z) common /spcdat/ eltbl(8,2), sptbl(9,32), fln(8,32), & & tdc(8,32,4), spm(32), & & ne, ns, & & itchm, ioutch, elms(8) ! common /node / spv(32), t, p, & & brm, speth(32), spgfz(32), & & spcsp(32), bzro(8), ethm ! dimension amtrx(16,16), bvtr(16), work(16), & & ipvt(16),elmsf1(8),spmlf1(32) data itime/0/ do 70 i=1,32 70 spmlf1(i)=0.1 300 format(1x,80a1) !.....p=pressure in atm !.....t=temperature in k !.....ethm=enthalpy in j/kg p=p1 t=t1 if(iprb.eq.2) ethm=ethm1 !.....set elemental mass fractions to input values do 10 i=1,ne bzro(i)=elmsf1(i)/elms(i) 10 continue !..... normalize initial guess of species mole fractions and calculate brm sum=0. do 50 i=1,ns 50 sum=sum+spmlf1(i) brm=0. do 60 i=1,ns spmlf1(i)=spmlf1(i)/sum brm=brm+spm(i)*spmlf1(i) 60 continue !.....set initial guess for species mole fractions to input values do 40 i=1,ns 40 spv(i)=spmlf1(i) ! ndim = 16 nrnk=ne+1 !.....if h,p problem, increase rank of a matrix by 1........................ if(iprb.eq.2)nrnk=nrnk+1 ! !.....set species thermo functions........................................ call spthf ! ! iteration loop itcmax = 30000 do 20 itc = 1, itcmax ! !.....reset species thermo functions if h,p problem....................... if(iprb.eq.2)call spthf ! ! fill matrix resulting from lagrangian multiplier method call chmtx(amtrx, bvtr, iprb) ! ! solve linear system for species changes call decomp(ndim,nrnk, amtrx, cndno, ipvt, work) call solve(ndim,nrnk, amtrx, bvtr, ipvt) ! ! apply species update corrections ! call spudt(bvtr, lcnv, iprb) ! write(6,201) (spv(i),i=1,10),t,brm 201 format(1x,' SPV='/1p10e10.3/' T,BRM=',3E10.3) if(lcnv .ne. 0) go to 30 20 continue ! ! solution failed to converge ! write(6,100) itcmax, t, p, (spv(ii),ii=1,ns) 100 format(//5x,26heqm. chm. did not converge,3h in, & & i7,12h iterations.,/,5x,37hstate conditions for this case are : & & 7htemp.= ,1pe11.4,18h kelvin ; press.= ,1pe11.4,5h atm. / & & ' spmlfo='/ (1p5e11.3)) stop ! ! solution converged 30 continue ! ! write (6,200) itc 200 format (/' no. of iteration steps : ',i2) ! do 2 i=1,ns 2 spmlf1(i)=spv(i) if(iprb.eq.2) t1=t brm1=brm if(iprb.eq.2) go to 99 ethm1=0. do 1 i=1,ns 1 ethm1=ethm1+spv(i)*speth(i) ethm1=ethm1*8.31434e3*t/brm1 ! 99 continue antot=p1*1.0133e5/(1.3805e-23*t1) awt=1.0e-3*brm1/6.025e23 rho1=antot*awt return end !**************************************************************** subroutine leqt2f(a,m,n,ia,b,idgt,wkarea,ier) ! matrix inversion with accompanying solution of linear equations ! of the form ax=b ! inputs: ! a(n,n)=left-hand-side matrix, first index=row, second index=column ! m=column dimension of b ! n=row dimensions of a and b ! ia=dimensions of a and b ! b(n,m)=right-hand-side vector ! idgt=input option ! wkarea=work area ! outputs: ! b(n,m) contains the solution vector ! ier=errror message implicit real*8(a-h,o-z) dimension ipivot(70),pivot(70),index(70,2) dimension a(ia,ia),b(ia,m),wkarea(1) equivalence (irow,jrow),(icolum,jcolum),(amax,t,swap) ! ! initialization 10 determ=1.0 15 do 20 j=1,n 20 ipivot(j)=0 30 do 550 i=1,n 40 amax=0.0d0 ! ! search for pivot element 45 do 105 j=1,n 50 if(ipivot(j)-1) 60,105,60 60 do 100 k=1,n 70 if(ipivot(k)-1) 80,100,740 80 if(abs(amax)-abs(a(j,k))) 85,100,100 85 irow=j 90 icolum=k 95 amax=a(j,k) 100 continue 105 continue 110 ipivot(icolum)=ipivot(icolum)+1 ! ! interchange rows to put pivot element on diagonal 130 if(irow-icolum) 140,260,140 140 determ=-determ 150 do 200 l=1,n 160 swap=a(irow,l) 170 a(irow,l)=a(icolum,l) 200 a(icolum,l)=swap 205 if(m) 260,260,210 210 do 250 l=1,m 220 swap=b(irow,l) 230 b(irow,l)=b(icolum,l) 250 b(icolum,l)=swap 260 index(i,1)=irow 270 index(i,2)=icolum 310 pivot(i)=a(icolum,icolum) 320 determ=determ*pivot(i) ! ! divide pivot row by pivot element 330 a(icolum,icolum)=1.0 340 do 350 l=1,n 350 a(icolum,l)=a(icolum,l)/pivot(i) 355 if(m) 380,380,360 360 do 370 l=1,m 370 b(icolum,l)=b(icolum,l)/pivot(i) ! ! reduce non-pivot rows 380 do 550 l1=1,n 390 if(l1-icolum) 400,550,400 400 t=a(l1,icolum) 420 a(l1,icolum)=0.0 430 do 450 l=1,n 450 a(l1,l)=a(l1,l)-a(icolum,l)*t 455 if(m)550,550,460 460 do 500 l=1,m 500 b(l1,l)=b(l1,l)-b(icolum,l)*t 550 continue ! ! interchange columns 600 do 710 i=1,n 610 l=n+1-i 620 if(index(l,1)-index(l,2)) 630,710,630 630 jrow=index(l,1) 640 jcolum=index(l,2) 650 do 705 k=1,n 660 swap=a(k,jrow) 670 a(k,jrow)=a(k,jcolum) 700 a(k,jcolum)= swap 705 continue 710 continue 740 return end !*********************************************************************** subroutine lin2(a,r, x) ! solve two simultaneous linear equations ! input parameters: ! a(2,2)=left hand side matrix ! r(2)=right hand side vector ! output parameters: ! x(2)=solution vector implicit real*8(a-h,o-z) dimension a(2,2),r(2),x(2) x(1)=(-r(1)/a(1,2)+r(2)/a(2,2))/(a(2,1)/a(2,2)-a(1,1)/a(1,2)) x(2)=r(1)/a(1,2)-(a(1,1)/a(1,2))*x(1) return end !************************************************************************* subroutine lsqpol(x,y,w,resid,n,sum,l,a,b,m) ! x(n) is the abscissa of data points ! y(n) is the ordinate of data points ! w(n) is the weighting factor ! n is the number of data points ! l is the number of sets ! m is the number of terms in polynomial ! a(m,m) is the working space ! b(m,l) is the coefficient array in ascending degree implicit real*8(a-h,o-z) dimension x(n),y(n,l),resid(n,l),w(n),a(2,2),b(2,1),sum(l), & & c(27,27),ipvt(27),work(27) 10 do 20 i=1,n 20 c(i,1)=1.0 30 do 50 j=2,m 40 do 50 i=1,n 50 c(i,j)=c(i,j-1)*x(i) 60 do 100 i=1,m 70 do 100 j=1,m 80 a(i,j)=0.0 90 do 100 k=1,n 100 a(i,j)=a(i,j)+c(k,i)*c(k,j)*w(k) 105 do 150 j=1,l 110 do 150 i=1,m 120 b(i,j)=0.0 130 do 150 k=1,n 150 b(i,j)=b(i,j)+c(k,i)*y(k,j)*w(k) 170 call decomp(2,2,a,cond,ipvt,work) call solve(2,2,a,b,ipvt) ! call decomp(4,4,ax,cond,ipvt,work) ! call solve(4,4,ax,rhs,ipvt) ! 170 call minv(a,n,n,b,l,determ) 180 do 205 j=1,l 185 sum(j)=0. 192 do 195 k=1,m 195 c(k,1)=b(k,j) 198 continue ! 198 do 205 i=1,n ! 200 resid(i,j)=polye1(x(i),m,c(1,1)) - y(0,j) ! 205 sum(j)=sum(j)+resid(i,j)**2*w(i) 205 continue 210 return end !*********************************************************************** subroutine magnitf(nwave,rnose,flux_s,flux_prec,flux_grd, & & alt,elev_ang, magnit) ! calculates brightness magnitude of the meteor ! input parameters: ! nwave ! rnose ! flux_grd=radiation flux received at ground, W/m2 ! wavel(nw) ! int_prec(nw)=intensity at the end of absorption, W/(m2-sr) ! alt=altitude, m ! parameter(nw=400000) implicit real*8(a-h,o-z) real*8 int_prec,magnit dimension wavel(nw),int_prec(nw) data unit_mag/2.511886/,sun_mag/-26.74/ ! sun's brightness at Earth = 1364.9 qsun=1364.9 ! W/m2 ! meteor's total radiation flux at edge of precursor region qsurf=flux_prec*1.0e-4* 3.1416*rnose**2 *1.0e4 ! W ! distance from meteor to the observer dist=alt ! m ! area of the imaginary half-sphere of radius = dist area=2.*3.1416*dist**2 ! m2 ! brightness q=qsurf/area ! W/m2 ! compare with sun qratio=qsun/q ! unit_mag**x=qratio --> x log(unit_mag) = log(qratio) x = dlog(qratio)/dlog(unit_mag) ! magnitude of the meteor magnit = sun_mag + x ! write write(6,10) magnit 10 format(/' brightness magnitude =',f10.2) return end !*********************************************************************** ! minv 1/29/71 subroutine minv(a,ndim,n,b,m,determ) ! matrix inversion with accompanying solution of linear equations ! of the form ax=b ! input parameters: ! a(ndim,ndim)=left-hand-side matrix, first index=row, second index=column ! ndim=dimension of a and b ! n=actual size of a and b ! b(ndim,2)=right-hand-side vector ! m=1 or 2, depending on the dimension of b ! output parameters: ! b(n,2) contains the solution vector ! determ contains the determinant of a-matrix ! note: the matrix a and vector b must be solidly loaded implicit real*8(a-h,o-z) dimension ipivot(70),pivot(70),index(70,2) dimension a(ndim,ndim),b(ndim,2) equivalence (irow,jrow),(icolum,jcolum),(amax,t,swap) ! ! initialization 10 determ=1.0 15 do 20 j=1,n 20 ipivot(j)=0 30 do 550 i=1,n 40 amax=0.0 ! ! search for pivot element 45 do 105 j=1,n 50 if(ipivot(j)-1) 60,105,60 60 do 100 k=1,n 70 if(ipivot(k)-1) 80,100,740 80 if(abs(amax)-abs(a(j,k))) 85,100,100 85 irow=j 90 icolum=k 95 amax=a(j,k) 100 continue 105 continue 110 ipivot(icolum)=ipivot(icolum)+1 ! ! interchange rows to put pivot element on diagonal 130 if(irow-icolum) 140,260,140 140 determ=-determ 150 do 200 l=1,n 160 swap=a(irow,l) 170 a(irow,l)=a(icolum,l) 200 a(icolum,l)=swap 205 if(m) 260,260,210 210 do 250 l=1,m 220 swap=b(irow,l) 230 b(irow,l)=b(icolum,l) 250 b(icolum,l)=swap 260 index(i,1)=irow 270 index(i,2)=icolum 310 pivot(i)=a(icolum,icolum) 320 determ=determ*pivot(i) ! ! divide pivot row by pivot element 330 a(icolum,icolum)=1.0 340 do 350 l=1,n 350 a(icolum,l)=a(icolum,l)/pivot(i) 355 if(m) 380,380,360 360 do 370 l=1,m 370 b(icolum,l)=b(icolum,l)/pivot(i) ! ! reduce non-pivot rows 380 do 550 l1=1,n 390 if(l1-icolum) 400,550,400 400 t=a(l1,icolum) 420 a(l1,icolum)=0.0 430 do 450 l=1,n 450 a(l1,l)=a(l1,l)-a(icolum,l)*t 455 if(m)550,550,460 460 do 500 l=1,m 500 b(l1,l)=b(l1,l)-b(icolum,l)*t 550 continue ! ! interchange columns 600 do 710 i=1,n 610 l=n+1-i 620 if(index(l,1)-index(l,2)) 630,710,630 630 jrow=index(l,1) 640 jcolum=index(l,2) 650 do 705 k=1,n 660 swap=a(k,jrow) 670 a(k,jrow)=a(k,jcolum) 700 a(k,jcolum)= swap 705 continue 710 continue 740 return end !*********************************************************************** subroutine partfx(m,specie,amass,t,tv,te,nprt,partf,parti) ! evaluates partition function ! input parameters: ! m=species index: ! specie=specie ! amass=atomic or molecular weight, gram/mol ! spect(i,j,m)=spectral constants ! i: 1=degen,2=term,3=we,4=wexe,5=weye,6=re,7=dzero ! 8=be,9=alphae,10=de,11=betae ! j: max number of electronic levels is 12 ! t=heavy particle translational and rotational temperature, k ! tv=vibrational temperature, k ! te=electron temperature, k ! nprt=print index. print if nprt.ge.2 ! calculated parameter: ! factr=sysmmetry factor; 0.5 for homo diatomics, 1.0 otherwise ! output parameter: ! partf=partition function, including translational component ! parti=internal partition function, excluding translational component ! parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) dimension specie(msp) character*4 elemnm,spnm,specie ! ! electron if(m.eq.nsp1) then parti=2.0 partf=1.878e20*sqrt(amass*te)*amass*te return endif ! ! translational component qt=1.878e20*sqrt(amass*t)*amass*t ! ! atom if(im(m).eq.0) then q=0. t1=1./te nlev=nelec(m) do 4 j=1,nlev 4 q=q+atomg(j,m)*dexp(-1.43877*atome(j,m)*t1) endif ! ! diatomic molecule if((im(m).eq.1).and.(ih(m).eq.2)) then q=qevr(m,t,tv,te,nprt)*factr(m) end if ! ! triatomic molecule if((im(m).eq.1).and.(ih(m).eq.3)) then q=pftri(m,t,tv,nprt)*factr(m) end if parti=q partf=q*qt return end !********************************************************************** subroutine pH_air(iuse,presx,enthx, rhox,tempx) ! from ebyrho and rho, determine pres, temp, and enth for air ! input parameters: ! iuse=0, initialization; =1, normal use; ! =2, for fixed pressure(iuse=1 must preceed) ! presx=pressure, Pascal ! enthx=enthalpy, J/kg ! output parameters: ! rhox=density, kg/m3 ! tempx=temperature, K implicit real*8(a-h,o-z) character*4 dum(25) dimension pres(33),enth(29),rho(33,29),temp(33,29), & & rhoz(29),tempz(29) save ! ! read data file if presx.eq.0 if(iuse.eq.0) then read(4,10) (dum(i),i=1,25) read(4,10) (dum(i),i=1,25) 10 format(25a4) do ip=1,33 do ih=1,29 read(4,20) pres(ip),enth(ih),rho(ip,ih),temp(ip,ih) 20 format(10x,4e12.4) rho(ip,ih)=dlog(rho(ip,ih)) temp(ip,ih)=dlog(temp(ip,ih)) end do end do do ip=1,33 pres(ip)=dlog(pres(ip)) end do do ih=1,29 enth(ih)=dlog(enth(ih)) end do return end if ! presy=dlog(presx) enthy=dlog(enthx) if(iuse.eq.1) then mon=0 do ih=1,29 call taint(pres(1),rho(1,ih),presy,rhoz(ih),33,2,ier,mon) call taint(pres(1),temp(1,ih),presy,tempz(ih),33,2,ier,mon) end do end if mon=0 call taint(enth(1),rhoz(1),enthy,rhox,29,2,ier,mon) rhox=exp(rhox) call taint(enth(1),tempz(1),enthy,tempx,29,2,ier,mon) tempx=exp(tempx) return end !*********************************************************************** subroutine pH_ivu(iuse,presx,enthx, rhox,tempx) ! from p and H, determine rho and T for H-chondrite ! input parameters: ! iuse=0, initialization; =1, normal use; ! presx=pressure, Pascal ! enthx=enthalpy, J/kg ! output parameters: ! rhox=density, kg/m3 ! tempx=temperature, K implicit real*8(a-h,o-z) common/eqivu/rho_ivu(11),t_ivu(11),h_ivu(11) dimension temp(11),enth(11),rho(11) save if(iuse.eq.0) then do itemp=1,11 enth(itemp)=dlog(h_ivu(itemp)) rho(itemp)=dlog(rho_ivu(itemp)) end do end if ! enthy=dlog(enthx) mon=0 call taint(enth(1),rho(1),enthy,rhox,11,2,ier,mon) rhox=dexp(rhox) call taint(enth(1),t_ivu(1),enthy,tempx,11,2,ier,mon) return end !*********************************************************************** subroutine precurs(mwave,nwave,int_s,qps, rhoinf,vinf,rnose, & & flux_s,flux_prec,int_prec) ! input parameters: ! nwave ! rhoinf ! vinf ! rnose ! int_s(10,nw)=angle_specific intensity, W/(cm2-mic-sr) ! qps=radiation flux emanating from shock wave, W/m2 ! output parameters ! mwave=wavelength index for 1750 A ! flux_s=radiative flux at shock calculated in this subroutine, W/m2 ! flux_prec=radiative flux at end of precursor region, W/m2 ! int_prec(nw)=normal intensity at the end of precursor region, W/(cm2-mic-sr) ! parameter(nw=400000) implicit real*8(a-h,o-z) dimension ang(11),flux(1091),r(1091),q(1091),h(1091),temp(1091) dimension int_s(10,nw),int_prec(nw) real*8 int_s,int_new,int_old,intw,int_e,int_prec dimension wavprec(171),croslog(171) common /spcdat/ eltbl(8,2), sptbl(9,32), fln(8,32), & & tdc(8,32,4), spm(32), & & ne, ns, & & itchm, ioutch, elms(8) dimension elmsf(8),spmlf(32),ansp(32) common/scratch/int_new(nw),int_old(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) character*4 spnm(9) common/lowdens/ntlow common/lowdens1/templ(11),enthl(11) dimension cos1(11),sin2(11),bint(11) data pi/3.141592/,itime/0/ data spnm/'O ','N ','O2 ','N2 ','NO ','O+ ','N+ ','NO+ ','E- '/ ! ! wavelength of absorption cross section for air at room temperature data wavprec/ & & 50.0, 60.0, 70.0, 80.0, 90.0, 100.0, 110.0, & & 120.0, 130.0, 140.0, 150.0, 160.0, 170.0, 180.0, & & 190.0, 200.0, 210.0, 220.0, 230.0, 240.0, 250.0, & & 260.0, 270.0, 280.0, 290.0, 300.0, 310.0, 320.0, & & 330.0, 340.0, 350.0, 360.0, 370.0, 380.0, 390.0, & & 400.0, 410.0, 420.0, 430.0, 440.0, 450.0, 460.0, & & 470.0, 480.0, 490.0, 500.0, 510.0, 520.0, 530.0, & & 540.0, 550.0, 560.0, 570.0, 580.0, 590.0, 600.0, & & 610.0, 620.0, 630.0, 640.0, 650.0, 660.0, 670.0, & & 680.0, 690.0, 700.0, 710.0, 720.0, 730.0, 740.0, & & 750.0, 760.0, 770.0, 780.0, 790.0, 800.0, 810.0, & & 820.0, 830.0, 840.0, 850.0, 860.0, 870.0, 880.0, & & 890.0, 900.0, 910.0, 920.0, 930.0, 940.0, 950.0, & & 960.0, 970.0, 980.0, 990.0, 1000.0, 1010.0, 1020.0, & & 1030.0, 1040.0, 1050.0, 1060.0, 1070.0, 1080.0, 1090.0, & & 1100.0, 1110.0, 1120.0, 1130.0, 1140.0, 1150.0, 1160.0, & & 1170.0, 1180.0, 1190.0, 1200.0, 1210.0, 1220.0, 1230.0, & & 1240.0, 1250.0, 1260.0, 1270.0, 1280.0, 1290.0, 1300.0, & & 1310.0, 1320.0, 1330.0, 1340.0, 1350.0, 1360.0, 1370.0, & & 1380.0, 1390.0, 1400.0, 1410.0, 1420.0, 1430.0, 1440.0, & & 1450.0, 1460.0, 1470.0, 1480.0, 1490.0, 1500.0, 1510.0, & & 1520.0, 1530.0, 1540.0, 1550.0, 1560.0, 1570.0, 1580.0, & & 1590.0, 1600.0, 1610.0, 1620.0, 1630.0, 1640.0, 1650.0, & & 1660.0, 1670.0, 1680.0, 1690.0, 1700.0, 1710.0, 1720.0, & & 1730.0, 1740.0, 1750.0/ ! ! log10 of absorption cross section of air at room temperature data croslog/ & & -18.5627,-18.4086,-18.2624,-18.1245,-17.9951,-17.8741,-17.7896, & & -17.7059,-17.6228,-17.5400,-17.4572,-17.3989,-17.3424,-17.2877, & & -17.2347,-17.1835,-17.1456,-17.1087,-17.0730,-17.0384,-17.0050, & & -16.9765,-16.9490,-16.9227,-16.8976,-16.8737,-16.8568,-16.8402, & & -16.8239,-16.8079,-16.7922,-16.7764,-16.7609,-16.7457,-16.7308, & & -16.7163,-16.6990,-16.6828,-16.6675,-16.6533,-16.6401,-16.6279, & & -16.6168,-16.6067,-16.5976,-16.5896,-16.5857,-16.5820,-16.5787, & & -16.5757,-16.5730,-16.5736,-16.5745,-16.5758,-16.5774,-16.5793, & & -16.5727,-16.5690,-16.5688,-16.5726,-16.5809,-16.5840,-16.5920, & & -16.6048,-16.6220,-16.6432,-16.6570,-16.6700,-16.6804,-16.7915, & & -16.8218,-16.8498,-16.8740,-16.9150,-16.9546,-16.9921,-17.3619, & & -17.5158,-17.6697,-17.7215,-17.7732,-17.8249,-17.8767,-17.9284, & & -17.9802,-18.0319,-18.0772,-18.1224,-18.1677,-18.2130,-18.2583, & & -18.3035,-18.3488,-18.3941,-18.4394,-18.4846,-18.5661,-18.6476, & & -18.7291,-18.8106,-18.8921,-18.8993,-18.9066,-18.9138,-18.9210, & & -18.9283,-18.9364,-18.9446,-18.9527,-18.9609,-18.9690,-18.9772, & & -18.9853,-18.9935,-19.0016,-19.0098,-19.0234,-19.0369,-19.0505, & & -19.0641,-19.0777,-19.0913,-19.1048,-19.1184,-18.9977,-18.9192, & & -18.7418,-18.5643,-18.3868,-18.2094,-18.0319,-17.9196,-17.8074, & & -17.6951,-17.5828,-17.4705,-17.4597,-17.4488,-17.4379,-17.4271, & & -17.4162,-17.4488,-17.4814,-17.5140,-17.5466,-17.5792,-17.6118, & & -17.6444,-17.6770,-17.7096,-17.7422,-17.8001,-17.8581,-17.9160, & & -17.9740,-18.0319,-18.0953,-18.1587,-18.2220,-18.2854,-18.3488, & & -18.4122,-18.4756,-18.5389,-18.6023,-18.6657,-18.9699,-19.2742, & & -19.5784,-19.8826,-20.1868/ ! WRITE(*,*) ' ' WRITE(*,*) ' IN PRECURS' ! ! write out int_s write(6,*) ' ' write(6,67) qps 67 format(' qps(radiative flux at shock wave) = ',1pe10.3,' W/m2') write(6,*) ' normal intensity entering precursor region' write(6,62) 62 format(' iw wavel int_s cros_sec') iprint=101 mon=0 do iw=1,nwave cros=0. if(wavel(iw).lt.1750) then call taint(wavprec,croslog,wavel(iw),crosl,171,2,ier,mon) cros=10.**crosl ! absorption cross section, cm2 end if iprint=iprint+1 if(iprint.ge.100) then write(6,61) iw,wavel(iw),int_s(1,iw),cros 61 format(i10,f10.2,1p3e11.3) iprint=0 end if end do ! ! number density of freestream aninf=rhoinf*(6.0223e23/0.028855)*1.0e-6 ! cm-3 ! ! freestream pressure pinf=(8.3144/0.028854)*rhoinf*298. ! Pa patm=pinf/1.0133e5 ! atm ! ! freestream enthalpy hinf=3.0053e5 ! J/kg ! ! rnose in cm rnose1=rnose*100. ! ! find iw for 1750 A do iw=1,nwave if(wavel(iw).gt.1750.) go to 10 end do 10 mwave=iw-1 write(6,20) mwave 20 format(' mwave=',i6) ! ! flux contained below 1750 A in int_s(10,iw) do iang=1,11 ang(iang)=(iang-1)*0.5*pi/10. cos1(iang)=1./dcos(ang(iang)) sin2(iang)=dsin(2.*ang(iang)) end do bint(1)=0.; bint(11)=0. ! ! flux below 1750 A in int_s flux0=0. ! flux in int_s below 1750 A, W/m2 do iw=2,mwave delw=wavel(iw)-wavel(iw-1) do iang=1,10 bint(iang)=pi*sin2(iang)*int_s(iang,iw) end do call simp(qlam,ang,bint,11,ier) flux0=flux0+qlam*delw ! flux in int_s below 1750 A, W/m2 end do write(6,50) flux0 50 format(' flux0(flux below 1750 A)=',1pe10.3,' W/m2') ! ! flux below 1750 A in int_s normal assuming solid angle of pi flux1=0. do iw=2,mwave delw=wavel(iw)-wavel(iw-1) flux1=flux1+pi*int_s(1,iw)*delw end do s_ratio=flux0/flux1 write(6,60) flux1,s_ratio 60 format( & & ' flux1(calculated from normal with solid angle of pi)=',1pe11.4/ & & ' flux0/flux1 =',e11.4) ! ! carry out radiative transfer calc until flux drops to 1% of flux0 ! ! number of grids ngrid=1000 ! ! prepare grid in a radial direction in half-space dr1=0.5e17/aninf ! step size, cm dr=0.01*dr1 ! step size, m do igrid=1,ngrid r(igrid)=dr*(igrid-1) end do ! ! outward irradiation ! ! set initial value for int_old and flux flux(1)=0. do iw=1,nwave int_old(iw)=int_s(1,iw) end do ! ! radiative transfer below 1750 A write(6,*) ' ' write(6,*) ' radiative transfer below 1750 A.' write(6,*) ' igrid r(m) flux(w/m2)' igrid=1 r0=0. temp0=298. write(6,44) igrid,r0,flux0 mon=0 do igrid=2,ngrid flux(igrid)=0. do iw=2,mwave delw=wavel(iw)-wavel(iw-1) call taint(wavprec,croslog,wavel(iw),crosl,171,2,ier,mon) cros=10.**crosl ! absorption cross section, cm2 absb=cros*aninf tau=absb*dr1 expx=dexp(-tau) ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*temp0)) blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax)) ! W/(cm2-mic-sr) ! int_new(iw)=blam*(1.0-expx)+int_old(iw)*expx ! W/(cm2-mic-sr) ! ! expanding flow tau1=((2./(100.*rnose))*dsqrt(int_old(iw)/int_s(1,iw)) & & + absba)*dr*100. ! cm-1 exp1=dexp(-tau1) int_new(iw)=absba*blam*(1./tau1-exp1/tau1) + int_old(iw)*exp1 ! flux(igrid)=flux(igrid)+s_ratio*pi*int_new(iw)*delw ! W/m2 int_old(iw)=int_new(iw) end do write(6,44) igrid,r(igrid),flux(igrid) 44 format(i7,f11.5,1pe11.3) ! ! find the end point of nearly-total absorption(5%) below 1750 A flux_rat=flux(igrid)/flux0 if(flux_rat.lt.0.10) go to 30 end do 30 continue ! the r-value is the precursor thickness prec_th=r(igrid) ! precursor region thickness, m write(6,*) ' precursor thickness=',prec_th mgrid=igrid ! precursor edge node ! ! energy source q(1)=0.; q(2)=0. do igrid=3,mgrid-1 q(igrid)=(flux(igrid+1)-flux(igrid-1))/(2.*dr) ! rad source, W/m3 end do q(2)=2.*q(3) - q(4) ! correct first and last values q(1)=q(2) - (q(3)-q(2)) q(mgrid)=2.*q(mgrid-1) - q(mgrid-2) ! ! enthalpy increase due to rad source q h(mgrid)=hinf write(6,*) ' ' write(6,*) ' enthalpy in precursor region raised by absorption' write(6,*) ' igrid r(m) q(J/m3) enth(J/kg)' write(6,40) igrid,r(mgrid),q(mgrid),h(mgrid) do igrid=mgrid-1,1,-1 dh=(q(igrid+1)/(rhoinf*vinf))*dr ! J/kg h(igrid)=h(igrid+1)+dabs(dh) write(6,40) igrid,r(igrid),q(igrid),h(igrid) 40 format(i7,f11.5,1pe11.3,1p3e11.4) end do ! ! radiative transfer of wavelengths above 1750 A ! ! starting flux above 1750 A flux_a=0. do iw=mwave,nwave delw=wavel(iw)-wavel(iw-1) flux_a=flux_a+1.5*pi*int_s(1,iw)*delw end do write(6,80) flux_a 80 format(/' at shock, flux above 1750 A =',1pe11.4,' W/m2') ! ! radiative transfer iprb=2 elmsf(1)=0.233; elmsf(2)=0.767 do iw=mwave,nwave int_new(iw)=int_s(1,iw) int_old(iw)=int_new(iw) end do do iw=mwave,nwave int_old(iw)=int_s(1,iw) end do flux(1)=flux_a write(6,70) 70 format(/' flux in precursor region above 1750 A'/ & & ' igrid r(m) temp flux(W/m2)') zero=0.; ione=1; temp(1)=6000. call kmeqm(patm,temp(1),h(1),iprb,elmsf,spmlf,brm,rho) write(6,71) temp(1),(spmlf(k),k=1,16) 71 format(' first kmeqm finished. temp(1)=',f10.2/ & & ' spmlf='/(1p5e10.3)) patm=patm*rhoinf/rho ! correction call kmeqm(patm,temp(1),h(1),iprb,elmsf,spmlf,brm,rho) write(*,*) ' correction kmeqm finished, temp(1)=',temp(1) write(6,90) ione,zero,temp(1),flux(1) 90 format(i5,f11.5,f11.1,1pe11.4) do igrid=2,mgrid temp(igrid)=h(igrid)/1008.5 ! temporary temperature if(temp(igrid).gt.800.) then call kmeqm(patm,temp(igrid),h(igrid),iprb,elmsf,spmlf,brm,rho) patm=patm*rhoinf/rho ! correction call kmeqm(patm,temp(igrid),h(igrid),iprb,elmsf,spmlf,brm,rho) end if tinv=10000./temp(igrid) flux(igrid)=0. ! expanding flow mon=0 do iw=mwave,nwave delw=wavel(iw)-wavel(iw-1) ! expanding flow if(temp(igrid).le.1500.) then int_new(iw)=int_old(iw) flux(igrid)=flux(igrid-1) int_old(iw)=int_new(iw) end if if(temp(igrid).gt.1500.) then call taint(txlow(1),absb_low(1,iw),tinv,absbx,ntlow,2,ier,mon) absba=dexp(absbx) ! cm-1 delr=(r(igrid)-r(igrid-1))*100. ! cm ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*temp(igrid))) blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax)) ! W/(cm2-mic-sr) tau=absba*delr*100. expx=dexp(-tau) ! int_new(iw)=blam*(1.0-expx)+int_old(iw)*expx ! W/(cm2-mic-sr) ! ! expanding flow tau1=((2./(100.*rnose))*dsqrt(int_old(iw)/int_s(1,iw)) & & + absba)*dr*100. ! cm-1 exp1=dexp(-tau1) int_new(iw)=absba*blam*(1./tau1-exp1/tau1) + int_old(iw)*exp1 ! flux(igrid)=flux(igrid)+2.0*pi*int_new(iw)*delw ! W/m2 int_old(iw)=int_new(iw) end if end do write(6,90) igrid,r(igrid),temp(igrid),flux(igrid) end do do iw=1,nwave if(iw.le.mwave) int_prec(iw)=0. if(iw.gt.mwave) int_prec(iw)=int_new(iw) end do flux_s=flux(1); flux_prec=flux(mgrid) WRITE(*,*) ' GETTING OUT OF PRECURS' return end !****************************************************************** subroutine pT_air(iuse,presx,tempx, rhox,enthx,cp) ! from p and T, determine rho and H for air ! input parameters: ! iuse=0, initialization; =1, normal use; ! =2, for fixed pressure(iuse=1 must preceed) ! presx=pressure, Pascal ! tempx=temperature, K ! output parameters: ! rhox=density, kg/m3 ! enthx=enthalpy, J/kg ! cp=dH/dT, J/(kg-K) implicit real*8(a-h,o-z) character*4 dum(25) dimension pres(29),temp(50),rho(29,50),enth(29,50),enthz(50), & & rhoz(50),tempz(50) save ! ! read data file if presx.eq.0 if(iuse.eq.0) then read(4,10) (dum(i),i=1,25) read(4,10) (dum(i),i=1,25) 10 format(25a4) do ip=1,29 do it=1,50 read(4,20) pres(ip),temp(it),rho(ip,it),enth(ip,it) 20 format(10x,4e12.4) rho(ip,it)=dlog(rho(ip,it)) enth(ip,it)=dlog(enth(ip,it)) end do end do do ip=1,29 pres(ip)=dlog(pres(ip)) end do do it=1,50 temp(it)=dlog(temp(it)) end do return end if ! presy=dlog(presx) tempy=dlog(tempx) if(iuse.eq.1) then mon=0 do it=1,50 call taint(pres(1),rho(1,it),presy,rhoz(it),29,2,ier,mon) call taint(pres(1),enth(1,it),presy,enthz(it),29,2,ier,mon) end do end if mon=0 call taint(temp(1),rhoz(1),tempy,rhox,50,2,ier,mon) rhox=exp(rhox) call taint(temp(1),enthz(1),tempy,enthx,50,2,ier,mon) enthx=exp(enthx) dtemp=0.02*tempx temp1=dlog(tempx+dtemp) call taint(temp(1),enthz(1),temp1,enth1,50,2,ier,mon) enth1=exp(enth1) temp2=dlog(tempx-dtemp) call taint(temp(1),enthz(1),temp2,enth2,50,2,ier,mon) enth2=exp(enth2) cp=(enth1-enth2)/(2.*dtemp) return end !********************************************************************** subroutine pT_ivu(iuse,presx,tempx, rhox,enthx,cp) ! from p and T, determine rho, and enth for ablation product ! input parameters: ! iuse=0, initialization; =1, normal use; ! =2, for fixed pressure(iuse=1 must preceed) ! presx=pressure, Pascal ! tempx=temperature, K ! output parameters: ! rhox=density, kg/m3 ! enthx=enthalpy, J/kg ! cp=dH/dT, J/(kg-K) implicit real*8(a-h,o-z) character*4 dum(25) common/eqivu/rho_ivu(11),t_ivu(11),h_ivu(11) dimension temp(11),rho(11),enth(11) save ! ! read data file if presx.eq.0 if(iuse.eq.0) then do itemp=1,11 temp(itemp)=dlog(t_ivu(itemp)) enth(itemp)=dlog(h_ivu(itemp)) rho(itemp)=dlog(rho_ivu(itemp)) end do end if ! tempy=dlog(tempx) mon=0 call taint(temp(1),rho(1),tempy,rhox,11,2,ier,mon) rhox=dexp(rhox) mon=0 call taint(temp(1),enth(1),tempy,enthx,11,2,ier,mon) enthx=dexp(enthx) dtemp=0.02*tempx temp1=dlog(tempx+dtemp) mon=0 call taint(temp(1),enth(1),temp1,enth1,11,2,ier,mon) enth1=dexp(enth1) temp2=dlog(tempx-dtemp) call taint(temp(1),enth(1),temp2,enth2,11,2,ier,mon) enth2=dexp(enth2) cp=(enth1-enth2)/(2.*dtemp) return end !********************************************************************** subroutine pT_vis_air(presx,tempx, viscx) ! from p and T, determine viscosity for air ! input parameters: ! iuse=0, initialization; =1, normal use; ! =2, for fixed pressure(iuse=1 must preceed) ! presx=pressure, Pascal ! tempx=temperature, K ! output parameters: ! viscx=density, MKS units implicit real*8(a-h,o-z) character*4 dum(25) dimension pres(25),temp(57),visc(25,57),viscz(57),tempz(57) save ! ! read data file if presx.eq.0 if((presx.lt.1.).and.(tempx.lt.1.)) then read(4,10) (dum(i),i=1,25) ! write(*,10) (dum(i),i=1,25) 10 format(25a4) do ip=1,25 do it=1,57 read(4,20) pres(ip),temp(it),visc(ip,it) ! write(*,20) pres(ip),temp(it),visc(ip,it) 20 format(10x,4e12.4) visc(ip,it)=dlog(visc(ip,it)) end do end do do ip=1,25 pres(ip)=dlog(pres(ip)) end do do it=1,57 temp(it)=dlog(temp(it)) end do end if ! presy=dlog(presx) tempy=dlog(tempx) mon=0 do it=1,57 call taint(pres(1),visc(1,it),presy,viscz(it),25,2,ier,mon) end do mon=0 call taint(temp(1),viscz(1),tempy,viscx,57,2,ier,mon) viscx=dexp(viscx) return end !********************************************************************** function pftri(m,t,tv,nprt) ! partition function for triatomic molecule ! inputs: ! m=species index ! t=translational-rotational temperature ! tv=vibrational temperature ! nprt=printing index parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) character*4 elemnm,spnm ! factr(i)=rotational factor (1 for hetero, 0.5 for homo) ! spect(1,1,jsp)=1st vibrational multiplicity ! spect(1,2,jsp)=1st vibrational constant, cm-1 ! spect(2,1,jsp)=2nd vibrational multiplicity ! spect(2,2,jsp)=2nd vibrational constant, cm-1 ! spect(3,1,jsp)=3rd vibrational multiplicty ! spect(3,2,jsp)=3rd vibrational constant, cm-1 ! spect(4,1,jsp)=ground state electronic multiplicity ! spect(5,1,jsp)=1st bond distance, angstrom ! spect(5,2,jsp)=2nd bond distance, angstrom ! spect(6,1,jsp)=bond angle, degrees ! spect(7,1,jsp)=moment of inertia, g3-cm6 ! spect(7,2,jsp)=B, cm-1 g1=spect(1,1,m) ev1=spect(1,2,m) g2=spect(2,1,m) ev2=spect(2,2,m) g3=spect(3,1,m) ev3=spect(3,2,m) ge=spect(4,1,m) angle=spect(6,1,m) ai=spect(7,1,m) B=spect(7,2,m) ! ! vibration qv1=g1/(1.-exp(-1.4388*ev1/tv)) qv2=g2/(1.-exp(-1.4388*ev2/tv)) qv3=g3/(1.-exp(-1.4388*ev3/tv)) qv=qv1*qv2*qv3 ! ! rotation if(angle.gt.179.) qr=t/(1.4388*b) ! if(angle.le.179.) qr=t**1.5*sqrt(ai)/((1.4388*2.7994e-39)**1.5) ! formula requiring ai*1.e100 in the place of ai, for a machine of low ceiling if(angle.le.179.) qr=t**1.5*sqrt(ai/(1.4388*2.7994e1))/ & & (1.4388*2.7994e-10) ! ! total pftri=ge*qv*qr ! write(6,10) m,t,qv,qr,pftri 10 format(' pftri. m,t,qv,qr,pftri=',i2,1p4e10.3) return end !********************************************************************** function qevr(m,t,tv,te,nprt) parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) common/eqcome/kmaxvV(msp,25,100),maxv(msp,25),vV(msp,25,100) character*4 elemnm,spnm ! if(iv(m).gt.0) go to 5 call jmax(m) nst1=nelec(m) do 60 ist1=1,nst1 maxv1=maxv(m,ist1) if(nprt.gt.2) write(6,90) m,ist1 90 format(' m=',i3,' kmax for electronic state ',i2) if(nprt.gt.2) write(6,70) (kmaxvv(m,ist1,maxv2),maxv2=1,maxv1) 70 format(16i5) 60 continue ! 5 q=0. n=nelec(m) do 30 ie1=1,n degen=spect(1,ie1,m) term=spect(2,ie1,m) if(ie1.ne.1) goto 50 term1=term dele1=vv(m,1,1) 50 dele=vv(m,ie1,1) ee=term+dele-term1-dele1 qe=degen*dexp(-1.43877*ee/te) nv=maxv(m,ie1) if(nv.eq.0) goto 30 qvr=0. do 20 i=1,nv v=i-1 ev=vv(m,ie1,i)-dele qv=dexp(-1.43877*ev/tv) bv=spect(8,ie1,m)-spect(9,ie1,m)*(v+.5) dv=spect(10,ie1,m)+spect(11,ie1,m)*(v+.5) nr=kmaxvv(m,ie1,i) qr=0. do 10 ir=1,nr k=ir-1 kk1=k*(k+1) er=bv*kk1-dv*kk1**2 if((er.gt.0.).and.(er.lt.100000)) & & qr=qr+(2*k+1.)*dexp(-1.43877*er/t) 10 continue qvr=qvr+qv*qr 20 continue q=q+qe*qvr 30 continue qevr=q return end !*********************************************************************************** subroutine radipac(nprt,natoms,ndiatoms,method,tblack, & & rnose,rangex,nwavex,tran,trot,tvib,tele, & & concAl,concAlp,concAlpp,concAl3p, & & concC, concC2, & & concCa,concCap,concCl,concC2H, & & concC3,concCH, concCN,concCO, & & concCO2,concCp, concCpp,concC3p, & & concC4p,concCr,concCrp,concCrpp, & & concFe,concFeO,concFep,concFepp, & & concFe3p,concFe4p,concFe5p,concH, & & concH2, concHp,concH2O,concK, & & concMg, concMgO,concMgp,concMgpp, & & concMg3p,concMg4p,concN,concNE, & & concN2,concN2p,concNp,concNpp, & & concN3p,concN4p,concNa,concNap, & & concNO,concNi,concNip,concNipp, & & concNi3p,concO,concO2,concOH, & & concOp,concOpp,concO3p,concO4p, & & concS,concSi,concSO,concSiO, & & concSip,concSipp,concSi3p,concSi4p, & & concSp,concSpp,concS3p,concS4p, & & concSiH,concTi,concTip,concTipp, & & concTi3p,concTiO, & & avg_molwt) ! radiation package main program ! input parameters: ! z(mnode) = geometrical distance, m ! method=1: Uniform slab (nnode = 1). Emission power and normal intensity ! calculated. 1.5 million words typ for spectrum for 0.5 million ! wavelength points. Needs 'depth' in cm, and 'nnode' must be 1. ! tblack(2) = temperature of black body incident on gas. ! for method = 4,5, and 6, (1) is at wall, (2) is at free stream ! atom_rads(3,168) specifies atom radiation calculation ! diatom_bands(3,100) specifies molecular band calculation ! tran(mnnode) = translational temperature, K ! trot(mnode) = rotational temperature, K ! tvib(mnode) = vibrational temperature, K ! tele(mnode) = electron temperature, K ! concC,concC2,concC2H,concC3,concCH,concCN,concCO,concCp,concH,concH2,concHp, ! concN,concN2,concN2p,concNE,concNO,concNp,concO,concO2,concOH,concOp ! = species concentration in m-3 for C, C2, C2H, --- etc ! avg_molwt(mnode) = average molecular weight, g/mol ! parameter (nw=400000) parameter(matoms=56,mdiatoms=12,mtriatoms=6,mnode=1,msp=60) implicit real*8(a-h,o-z) character*4 blank4,count4,blank2,count2 character*4 asterik,atomnm2(matoms),bandnm_diatom, & & minus1,unknown character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/coma/absb(nw) dimension & & concAl(mnode),concAlp(mnode),concAlpp(mnode),concAl3p(mnode), & & concC(mnode), concC2(mnode), & & concCa(mnode),concCap(mnode),concCl(mnode),concC2H(mnode), & & concC3(mnode),concCH(mnode), concCN(mnode),concCO(mnode), & & concCO2(mnode),concCp(mnode), concCpp(mnode),concC3p(mnode), & & concC4p(mnode),concCr(mnode),concCrp(mnode),concCrpp(mnode), & & concFe(mnode),concFeO(mnode),concFep(mnode),concFepp(mnode), & & concFe3p(mnode),concFe4p(mnode),concFe5p(mnode),concH(mnode), & & concH2(mnode), concHp(mnode),concH2O(mnode),concK(mnode), & & concMg(mnode), concMgO(mnode),concMgp(mnode),concMgpp(mnode), & & concMg3p(mnode),concMg4p(mnode),concN(mnode),concNE(mnode), & & concN2(mnode),concN2p(mnode),concNp(mnode),concNpp(mnode), & & concN3p(mnode),concN4p(mnode),concNa(mnode),concNap(mnode), & & concNO(mnode),concNi(mnode),concNip(mnode),concNipp(mnode), & & concNi3p(mnode),concO(mnode),concO2(mnode),concOH(mnode), & & concOp(mnode),concOpp(mnode),concO3p(mnode),concO4p(mnode), & & concS(mnode),concSi(mnode),concSO(mnode),concSiO(mnode), & & concSip(mnode),concSipp(mnode),concSi3p(mnode),concSi4p(mnode), & & concSp(mnode),concSpp(mnode),concS3p(mnode),concS4p(mnode), & & concSiH(mnode),concTi(mnode),concTip(mnode),concTipp(mnode), & & concTi3p(mnode),concTiO(mnode), & & z(mnode),tran(mnode),trot(mnode),tvib(mnode),tele(mnode), & & tblack(2),avg_molwt(mnode) common/heavy_imp/collid_dens(6) common/comi/nwave common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e common/spect/calpha,slope_ratio,wavmin,wavmax,range ! data blank2/' '/,blank4/' '/,itime/0/ write(6,*) ' In radipac' ! ! set common parammeters nwave=nwavex; range=rangex; method=1; avg_molwt(1)=15.; inode = 1 itime=1 ! ! initialize wavelength array. square root-spaced energy intervals ! wavelength in angstroms do m=1,nwave wavel(m)=wavmin+(wavmax-wavmin)*(float(m)/float(nwave))**calpha ! wavel(m)=1.0d0/(1.0d0/dsqrt(wavmin)-estep*(m-1))**2 end do ! ! initiate emission coef, absorption coef, and intensity arrays do m=1,nwave absb(m) = 1.0d-30 ! absorption coef end do ! write(6,*) ' ' ! ! emission and absorption coefs ! write(*,*) ' calling emis_absb' write(6,*) ' calling emis_absb' call emis_absb(nprt,natoms,ndiatoms,ntriatoms, & & inode,tran,trot,tvib,tele, & & concAl,concAlp,concAlpp,concAl3p, & & concC, concC2, & & concCa,concCap,concCl,concC2H, & & concC3,concCH, concCN,concCO, & & concCO2,concCp, concCpp,concC3p, & & concC4p,concCr,concCrp,concCrpp, & & concFe,concFeO,concFep,concFepp, & & concFe3p,concFe4p,concFe5p,concH, & & concH2, concHp,concH2O,concK, & & concMg, concMgO,concMgp,concMgpp, & & concMg3p,concMg4p,concN,concNE, & & concN2,concN2p,concNp,concNpp, & & concN3p,concN4p,concNa,concNap, & & concNO,concNi,concNip,concNipp, & & concNi3p,concO,concO2,concOH, & & concOp,concOpp,concO3p,concO4p, & & concS,concSi,concSO,concSiO, & & concSip,concSipp,concSi3p,concSi4p, & & concSp,concSpp,concS3p,concS4p, & & concSiH,concTi,concTip,concTipp, & & concTi3p,concTiO, & & avg_molwt) itime=itime+1 write(*,*) ' ' write(*,*) ' out of emis_absb' write(6,*) ' ' write(6,*) ' out of emis_absb' ! return end !************************************************************************* subroutine root (fun,r,a,bl,bu,ep,e2,i) !root sorensen, emc. modification made feb. 1963 to modify way root0010 ! second guess at root is made. root0020 ! root0040 ! argument list- root0050 ! fun-function subprogram name. root0060 ! r -argument of subprogram and value of root. root0070 ! a -initial guess at root root0080 ! bl -lower bound on root root0090 ! bu -upper bound on root root0100 ! ep -epsilon test for function - if fun(r) (absolute root0110 ! value) is less than or equal to ep, i=1 and root0120 ! return. root0130 ! e2 -epsilon test on root approximation. if ratio of diff-root0140 ! erence of successive approximations to current root0150 ! approximation is less than e2 in absolute value, root0160 ! i=1 and return. root0170 ! i -error code =1 for normal return root0180 ! root0190 ! root0200 implicit real*8(a-h,o-z) dimension x(3),fx(3) ! dimension x(3),fx(3) root0220 g=a isp=0 ! test for lower bound on root less than upper bound root0250 if (bl-bu) 1,2,2 ! if not, error code i=3. return. root0270 2 i=3 return ! test for guess outside bounds. root0300 1 if (g-bl) 9,7,8 8 if (g-bu) 6,7,9 ! if yes, error code i=2 and return. root0330 9 i=2 return ! if guess=lower bound, compute guess=0.5*(bu+bl) root0360 7 g=(bl+bu)/2.0 6 gl=bl+0.1*(g-bl) gu=bu-0.1*(bu-g) 80 r=g fg=fun(g) if (abs(fg)-ep) 13,13,32 10 if (abs(fx(i1))-ep) 13,13,17 13 i=1 return ! 17 i1=i1 if (fx(i1)) 18,18,19 18 if (fx(i2)) 20,20,21 20 im=1 go to 23 19 if (fx(i2)) 24,24,22 22 im=0 go to 23 21 ip=i2 im=i1 go to 25 24 ip=i1 im=i2 go to 25 ! 23 do 26 ic1=1,20 ! root has not been bracketed. use successive approximations. root0610 t=fx(i2)-fx(i1) if (abs(t)-0.01*ep) 27,27,28 27 if (x(i1)-x(i2)) 14,12,14 12 i=4 return ! 14 x(if)=0.5*(x(i1)+x(i2)) r=x(if) go to 33 ! 28 x(if)=x(i2)-(x(i2)-x(i1))/t*fx(i2) r=x(if) if (x(if)) 63,64,63 63 if (abs((x(if)-x(i2))/x(if))-e2 ) 34,34,65 64 if (abs(x(if)-x(i2))-e2 ) 34,34,65 34 fx(if)=fun(x(if)) i=1 return ! 65 continue 29 if (bl-x(if)) 31,31,32 31 if (x(if)-bu) 33,33,32 33 fx(if)=fun (x(if)) if (abs(fx(if))-ep) 13,13,35 35 if (fx(if)) 36,13,37 36 if (im) 38,38,39 38 ip=i2 im=if if=i1 go to 25 37 if (im) 39,39,40 40 ip=if im=i2 if=i1 go to 25 39 i1=i1+1 i2=i2+1 if=if+1 go to (42,42,43,44),if 42 i2=1 go to 26 43 i1=1 go to 26 44 if=1 26 continue ! 32 isp=isp+1 i1=1 i2=2 if=3 x(i2)=g fx(i2)=fg go to (47,48,49,50,51,69,70),isp 47 x(i1)=gl r=gl fgl=fun(r) fx(i1)=fgl go to 10 48 x(i1)=gu r=gu fgu=fun(r) fx(i1)=fgu go to 10 49 x(i2)=gl fx(i2)=fgl g2=0.5*(g+bl) 71 x(i1)=g2 r=g2 fg2=fun(r) fx(i1)=fg2 go to 10 50 x(i1)=g2 fx(i1)=fg2 go to 17 51 g2=0.5*(g+bu) go to 71 69 x(i1)=gu fx(i1)=fgu x(i2)=g2 fx(i2)=fg2 go to 17 70 i=5 return ! 25 do 52 ic=1,50 ! root has been bracketed. use approximations on each side. root1410 x(if)=x(ip)-(x(ip)-x(im))/(fx(ip)-fx(im))*fx(ip) r=x(if) if (x(if)) 61,62,61 61 if (abs((x(if)-x(ip))/x(if))-e2 ) 134,134,67 67 if (abs((x(if)-x(im))/x(if))-e2 ) 134,134,53 62 if (abs(x(if)-x(ip)) -e2 ) 134,134,68 68 if (abs(x(if)-x(im)) -e2 ) 134,134,53 134 fx(if)=fun(x(if)) i=1 return ! 53 continue 54 if (x(if)-bl) 32,56,56 56 if (x(if)-bu) 55,55,32 55 fx(if)=fun (x(if)) if (abs(fx(if))-ep) 13,13,57 57 if (fx(if)) 58,13,59 58 it=im im=if go to 60 59 it=ip ip=if 60 if=it 52 continue go to 32 end !*********************************************************************** subroutine simp(r,x,y,n,ier) implicit real*8(a-h,o-z) dimension x(n),y(n) r=0.0 if(n.gt.1) go to 1 ier=2 return 1 if(x(1).eq.x(2)) go to 12 nm1=n-1 if(n.eq.2) go to 13 if(x(1).lt.x(2)) go to 3 ! test for x to be monotonically decreasing do 2 i=2,nm1 if(x(i+1).ge.x(i)) go to 12 2 continue go to 5 ! test for x to be monotonically increasing 3 do 4 i=2,nm1 if(x(i+1).le.x(i)) go to 12 4 continue 5 nm2=n-2 if(mod(n,2).eq.0) go to 14 p=0.0 n1=1 6 s1=x(n1+1)-x(n1) s2=x(n1+2)-x(n1+1) s3=x(nm1)-x(nm2) s4=x(n)-x(nm1) r=(2.*s1**2+s1*s2-s2**2)/s1*y(n1)+(2.*s4**2+s3*s4-s3**2)/s4*y(n) n1=n1+1 do 7 i=n1,nm1,2 s1=x(i)-x(i-1) s2=x(i+1)-x(i) 7 r=r+(s1+s2)**3/(s1*s2)*y(i) if(n.lt.5) go to 9 n1=n1+1 do 8 i=n1,nm2,2 s1=x(i-1)-x(i-2) s2=x(i)-x(i-1) s3=x(i+1)-x(i) s4=x(i+2)-x(i+1) 8 r=r+((2.*s2**2+s1*s2-s1**2)/s2+(2.*s3**2+s3*s4-s4**2)/s3)*y(i) 9 r=r/6.+p 10 continue ier=1 return 11 ier=3 return 12 ier=4 return ! trapezoidal rule for n=2 13 r=(x(2)-x(1))*(y(1)+y(2))/2.0 go to 10 ! fit polynomial thru first 3 points and integrate from x(1) to x(2). 14 s1=x(2)-x(1) s2=x(3)-x(1) s3=y(2)-y(1) s4=y(3)-y(1) p=s1/6.*(2.*s3+6.*y(1)+(s2**2*s3-s1**2*s4)/(s2*(s2-s1))) n1=2 go to 6 end !*************************************************************************** subroutine slope(n,xx,yy,dydx) ! derivative subroutine implicit real*8(a-h,o-z) ! input parameters: ! n=number of points ! xx(n)=independent variables ! yy(n)=dependent variables ! output parameters ! dydx(n)=slope at mid point dimension xx(802),yy(802),dydx(802) dydx(1)=(yy(2)-yy(1))/(xx(2)-xx(1)) do i=2,n-1 call slope1(xx(i-1),xx(i),xx(i+1),yy(i-1),yy(i),yy(i+1), dydx(i)) end do dydx(n)=(yy(n)-yy(n-1))/(xx(n)-xx(n-1)) return end !**************************************************************************** subroutine slope1(x1,x2,x3,y1,y2,y3, dydx2) implicit real*8(a-h,o-z) b1=(y3-y1)/(x3-x1); b2=(y2-y1)/(x2-x1) a2=(b1-b2)/(x3-x2); a1=b2-a2*(x3-x1) dydx2=a1+2.*a2*(x2-x1) return end !*********************************************************************** subroutine smooth(nwave,wavel,sigin, wavsig,sigout) ! shortens the signal by averaging ! input parameters: ! nwave=length of wavel and sigin ! wavel(nw)=wavelength, A ! sigin(nw)=input signal ! output parameters: ! wavsig(500)=wavelength for sigout ! sigout(500)=smoothed signal parameter(nw=400000) implicit real*8(a-h,o-z) dimension wavel(nw),sigin(nw),wavsig(1000),sigout(1000) ! navge=float(nwave)/1000. do i=1,999 wavsig(i)=wavel(i*navge) i1=(i-1)*navge+1; i2=i*navge if(i2.gt.nwave) i2=nwave sigout(i)=0. an=0 do j=i1,i2 sigout(i)=sigout(i)+sigin(j) an=an+1.0 end do sigout(i)=sigout(i)/an end do return end !*********************************************************************** subroutine solve(ndim,n,a,b,ipvt) implicit real*8(a-h,o-z) integer ndim, n, ipvt(n) real*8 a(ndim,n), b(n) ! ! solution of linear systems, a*x = b ! do not use if decomp has detected singularity ! ! input... ! ndim = declared row dimension of array containing a ! n = order of matrix ! a = triangularized matrix from subroutine decomp ! b = right hand side vector ! ipvt = pivot vector obtained from decomp ! ! output ! ! b = solution vector, x ! integer kb, km1, nm1, kp1, i, k, m real*8 t ! ! forward elimination ! if(n .eq. 1) go to 50 nm1 = n - 1 do 20 k = 1, nm1 kp1 = k + 1 m = ipvt(k) t = b(m) b(m) = b(k) b(k) = t do 10 i = kp1, n b(i) = b(i) + a(i,k)*t 10 continue 20 continue ! ! back substitution ! 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 b(i) = b(i) + a(i,k)*t 30 continue 40 continue 50 b(1) = b(1)/a(1,1) return end !*********************************************************************** subroutine spdinp ! implicit real*8(a-h,o-z) common /spcdat/ eltbl(8,2), sptbl(9,32), fln(8,32), & & tdc(8,32,4), spm(32), & & ne, ns, & & itchm, ioutch, elms(8) ! common /node / spv(32), t, p, & & brm, speth(32), spgfz(32), & & spcsp(32), bzro(8), ethm ! dimension end(3), tn(9), tf(3), & & tel(2), rnum(9), trmax(3), & & emtbl(3,16) ! ioutch=0 ncd=0 ne=0 ns=0 nsmax = 32 nemax = 8 do 24 j = 1, nsmax do 24 i = 1, nemax fln(i,j)=0.0 24 continue ! 1 continue ncd=ncd+1 !.....read a species data card........................... read(19,100)(tn(i),i=1,9),(tf(j),j=1,3),tt,icd 100 format(9a1,1x,3(e18.5),6x,f5.0,3x,i1) write(6,100) (tn(i),i=1,9),(tf(j),j=1,3),tt,icd !.....determine if this is end of data.................................. data end/1hE,1hN,1hD/ do 2 i=1,3 if(tn(i).ne.end(i))go to 3 2 continue ! ! chemistry card input has ended ! if(ioutch.eq.0) go to 98 write(6,110) 110 format(1h1, 44x, 20hchemistry input data) write(6,120) 120 format(/,1x,22hspecies molecular mass,/) do 30 j = 1, ns write(6,130) (sptbl(ic,j), ic = 1, 5), spm(j) 130 format(3x, 5a1, 6x, f9.5) 30 continue ! write(6,135) 135 format( //, 38x, 40hthermodynamic coefficients - janaf model) write(6,140) 140 format(/, 1x, 15hspecies t,k, 12x, 1ha, 14x, 1hb, 14x, 1hc, & & 14x, 1hd, 14x, 1he, 14x, 1hf, /) do 50 j = 1, ns do 40 itr = 1, 3 write(6,150) (sptbl(ic,j), ic = 1, 5), trmax(itr), & & (tdc(icf,j,itr), icf = 1, 6) 150 format(3x, 5a1, f9.0, 3x, 1p6e15.5) 40 continue write(6,155) 155 format(/) 50 continue ! go to 98 3 continue if(ns.eq.0)go to 4 do 5 i=1,ns isp=i do 6 j=1,9 if(tn(j).ne.sptbl(j,i))go to 5 6 continue go to 7 5 continue !.....new species found................................................. 4 continue ns=ns+1 isp=ns ! !.....decompose species name............................................ n=0 8 continue n=n+1 tel(1)=tn(n) !.....determine if next character is a formula number................... data rnum/1h1,1h2,1h3,1h4,1h5,1h6,1h7,1h8,1h9/ do 9 i=1,9 if(tn(n+1).eq.rnum(i))go to 10 9 continue n=n+1 tel(2)=tn(n) go to 11 10 continue data blank/1h / tel(2)=blank 11 continue if(ne.eq.0)go to 12 !.....test temporary element symbol against element table............... do 13 i=1,ne iel=i do 14 j=1,2 if(tel(j).ne.eltbl(i,j))go to 13 14 continue go to 20 13 continue !.....don't add electron to element list if already there.............. if(tel(1).ne.eltrn.or.tel(2).ne.blank)go to 12 if(ielt.ne.0)go to 20 ielt=ne+1 12 continue ne=ne+1 iel=ne eltbl(ne,1)=tel(1) eltbl(ne,2)=tel(2) ! !.....locate element mass & stow to elms................................ data emtbl/1hE,1h ,5.486e-4, & & 1hH,1h ,1.008, & & 1hB,1h ,4.004, & & 1hC,1h ,12.0112, & & 1hO,1h ,16.0, & & 1hN,1h ,14.008, & & 1hS,1h ,28.06, & & 1hA,1h ,39.948, & & 24*0.0/ do 31 i=1,16 idlc=i do 28 j=1,2 if(tel(j).ne.emtbl(j,i))go to 31 28 continue go to 29 31 continue write(6,107) 107 format(//5x,' species data input has encountered an element not', & & ' present in element table(emtbl).') stop ! 29 elms(ne)=emtbl(3,idlc) ! !.....stow formula number for this element of current species........... 20 continue n=n+1 do 15 i=1,9 if(tn(n).eq.rnum(i))inum=i 15 continue fln(iel,ns)=float(inum) ! !.....is this an ionic species?......................................... data ielt/0/ data pls/1h+/,rmns/1h-/ if(tn(n+1).eq.pls)go to 23 if(tn(n+1).eq.rmns)go to 23 go to 21 23 continue n=n+1 !.....is this 1st ionic species encountered?............................ if(ielt.ne.0)go to 22 !.....add electron to element tables.................................... ne=ne+1 ielt=ne data eltrn/1hE/ eltbl(ne,1)=eltrn eltbl(ne,2)=blank elms(ielt)=emtbl(3,1) ! !.....stow formula number for electron in this species................. 22 continue if(tn(n).eq.pls)fln(ielt,ns)=-1. if(tn(n).eq.rmns)fln(ielt,ns)=1. ! 21 continue if(tn(n+1).eq.blank)go to 16 go to 8 !.....blank in species name indicates end of name, so stow name to sptbl 16 continue do 17 i=1,9 sptbl(i,ns)=tn(i) 17 continue ! !.....stow thermodynamic & transport data............................... ! 7 continue !.....is this card thermo data?......................................... if(tt.ne.0.0)go to 18 !.....stow species mass in spm(i) go to(25,1,1),icd 25 spm(isp)=tf(1) go to 1 ! !.....stow thermo data.................................................. 18 continue !.....determine temperature range index................................. itr=1 if(tt.eq.3000.)itr=2 if(tt.eq.6000.)itr=3 trmax(itr) = tt !.....detemine which half of thermo coefficients........................ ih=0 if(icd.eq.2)ih=3 !.....stow data to tcd.................................................. do 19 i=1,3 idx=i+ih tdc(idx,isp,itr)=tf(i) 19 continue go to 1 98 continue if(ielt.eq.0)go to 99 !.....move electron to bottom of element & form. num. tables............. !.....also set ne down by 1 for gas dynamics............................. do 34 i=1,ne ielt=i if(eltbl(i,1).eq.eltrn.and.eltbl(i,2).eq.blank)go to 35 34 continue go to 99 35 continue tmp1=eltbl(ielt,1) tmp2=eltbl(ielt,2) tmp3=elms(ielt) nem1=ne-1 do 36 i=ielt,nem1 eltbl(i,1)=eltbl(i+1,1) eltbl(i,2)=eltbl(i+1,2) elms(i)=elms(i+1) 36 continue eltbl(ne,1)=tmp1 eltbl(ne,2)=tmp2 elms(ne)=tmp3 do 37 j=1,ns tmp1=fln(ielt,j) do 38 i=ielt,nem1 fln(i,j)=fln(i+1,j) 38 continue fln(ne,j)=tmp1 37 continue ! 99 return end !*********************************************************************** subroutine spthf !.....routine for computing the thermodynamic functions for species.. !.....using the janaf format fitting functions........................ ! !.....nb:- all thermo functions output for this routine are........... !.....normalized: ie, divided r or r*t............................... ! implicit real*8(a-h,o-z) common /spcdat/ eltbl(8,2), sptbl(9,32), fln(8,32), & & tdc(8,32,4), spm(32), & & ne, ns, & & itchm, ioutch, elms(8) ! common /node / spv(32), t, p, & & brm, speth(32), spgfz(32), & & spcsp(32), bzro(8), ethm ! dimension f1(32),f2(32),f3(32),f4(32),f5(32),f6(32) ! data rgc/0.503205/ ! 1 continue ! !.....move appropriate temp. subset of tdc into working arrays fn.. if(t.ge.3000.)go to 2 do 3 j=1,ns f1(j)=tdc(1,j,1) f2(j)=tdc(2,j,1) f3(j)=tdc(3,j,1) f4(j)=tdc(4,j,1) f5(j)=tdc(5,j,1) f6(j)=tdc(6,j,1) 3 continue go to 7 ! 2 continue if(t.ge.6000)go to 4 do 5 j=1,ns f1(j)=tdc(1,j,2) f2(j)=tdc(2,j,2) f3(j)=tdc(3,j,2) f4(j)=tdc(4,j,2) f5(j)=tdc(5,j,2) f6(j)=tdc(6,j,2) 5 continue go to 7 ! 4 continue do 6 j=1,ns f1(j)=tdc(1,j,3) f2(j)=tdc(2,j,3) f3(j)=tdc(3,j,3) f4(j)=tdc(4,j,3) f5(j)=tdc(5,j,3) f6(j)=tdc(6,j,3) 6 continue ! 7 continue ! !.....set temperature functions........................................ data tc1,tc2,tc3,tc4/3.e3,9.e6,3.333333e-4,1.111111e-7/ rt=1./t tf1=t-tc1 tf2=0.5*(t*t-tc2) tf3=-(rt-tc3) tf4=tf1-t*dlog(t*tc3) tf5=tf2-t*tf1 tf6=tf3+0.5*t*(rt*rt-tc4) rgct=rgc*rt ! !.....compute thermo-functions for the species set................... do 8 j=1,ns spcsp(j)=f3(j)+f4(j)*t+f5(j)*rt*rt c1p2=f1(j)+f2(j) speth(j)=c1p2+f3(j)*tf1+f4(j)*tf2+f5(j)*tf3 spgfz(j)=c1p2+f3(j)*tf4+f4(j)*tf5+f5(j)*tf6-f6(j)*t 8 continue ! !.....norminalization by gas constant & temperature................ do 9 j=1,ns spcsp(j)=spcsp(j)*rgc speth(j)=speth(j)*rgct spgfz(j)=spgfz(j)*rgct 9 continue ! ! 99 return end !*********************************************************************** subroutine spudt(svtr,lcnv,iprb) ! routine for updating solution vector, namely, species mole ! fractions and mixture molar mass ! implicit real*8(a-h,o-z) common /spcdat/ eltbl(8,2), sptbl(9,32), fln(8,32), & & tdc(8,32,4), spm(32), & & ne, ns, & & itchm, ioutch, elms(8) ! common /node / spv(32), t, p, & & brm, speth(32), spgfz(32), & & spcsp(32), bzro(8), ethm ! dimension svtr(16), dlns(32), spl(32) ! data tln/9.21034/ nep1=ne+1 nep2=ne+2 pln=dlog(p) ! ! compute changes in the log of the species mole fractions ! do 1 j=1,ns spl(j)=dlog(spv(j)) dlns(j)=-(spgfz(j)+pln+spl(j)) if(iprb.eq.2)dlns(j)=dlns(j)+speth(j)*svtr(nep2) do 1 i=1,ne dlns(j)=dlns(j)+fln(i,j)*svtr(i) 1 continue ! ! select weighting factor ! wf1=dabs(dlns(1)) do 2 j=2,ns wf1 = dmax1(wf1, dabs(dlns(j))) 2 continue wf1=dmax1(wf1,dabs(svtr(nep1))) if(wf1 .lt. 1.0e-25) wf1 = 1.0 wf1=2./wf1 ! wf2=1.0 do 3 j=1,ns if(spl(j).gt.-18.42.and.dlns(j).le.0.)go to 3 if(dlns(j).eq.0.0.or.(spl(j)+tln).lt.1.e-9)go to 3 wf2=dmin1(wf2,dabs(-(spl(j)+tln)/(dlns(j)))) 3 continue wf=dmin1(1.,wf1,wf2) ! ! apply corrections to solution vector ! spcm=0. lcnv=0 ! ! update molecular mass ! dlnm=wf*svtr(nep1) brm=dexp(dlog(brm)+dlnm) ! !.....for the h,p problem, update temperature......................... if(iprb.ne.2)go to 5 tmpln=dlog(t)+wf*svtr(nep2) t=dexp(tmpln) ! 5 continue ! ! update species mole fractions ! do 4 j=1,ns spl(j)=spl(j)+wf*dlns(j) spv(j)=dexp(spl(j)) spcp=spv(j)*dabs(dlns(j)) spcm=dmax1(spcm,spcp) 4 continue ! ! check convergence of mole fractions & molar mass............ ! data tol /1.0e-1/ if(spcm.lt.tol.and.dlnm.lt.tol) lcnv = 1 ! 99 return end !************************************************************************** subroutine stiff7(n,t,y,r,der,h,case,istep,nprt) ! stiff equation integrator ! input specifications ! n=order of differential equation ! t=independent variable ! y(n)=dependent variable ! der=name of the subroutine specifying derivative. ! must be stated in external in the calling program. ! the subroutine must be in the form ! subroutine der(t,y,dy) ! where t is the independent variable ! y(n) is the dependent variable ! dy(n) is the dy/dt array ! h=initial step size of t ! case(5): ! case(1)=maximum allowed fractional change in dependent variables ! 0.04 recommended ! case(2)=maximum allowed stepsize in t ! case(3)=minimum value of dependent variable for which the ! automatic fractional differentiation is done. ! case(4)=stability parameter. 0.33333 is most accurate ! -1.5 is most stable. 0.33333 recommended ! case(5)=delta y for absolute differentiation when y is less than ! case(3) ! istep=number of steps ! nprt=print index. ! output specifications ! t=updated independent variable ! y(n)=updated dependent variables ! r(n)=increment ! parameter(msp=60) implicit real*8(a-h,o-z) dimension case(5),y(msp),dy(msp),ysi(msp),dysi(msp),r(msp) dimension pw(msp,msp),pwsq(msp,msp),qmat(msp,msp),rmat(msp,msp), & & ip(msp) external der data itime/0/ ymin=case(3) dely=case(5) eps=case(1) c1=case(4)-1.d0 c2=.5e0-case(4) call der(n,t,y,dy,istep,nprt) ! save initial y in ysi, initial dy in dysi do 10 ic=1,n ysi(ic)=y(ic) 10 dysi(ic)=dy(ic) ! calculate jacobian matrix, store in pw do 40 ic=1,n delyj=.005d0*ysi(ic) if(abs(ysi(ic)).lt.ymin) delyj=dely yd=.5e0/delyj y(ic)=ysi(ic)+delyj call der(n,t,y,dy,istep,nprt) do 20 ir=1,n 20 r(ir)=dy(ir) y(ic)=ysi(ic)-delyj call der(n,t,y,dy,istep,nprt) do 30 ir=1,n pw(ir,ic)=(r(ir)-dy(ir))*yd 30 continue 40 y(ic)=ysi(ic) ! calculate square of jacobian, store in pwsq do 55 ic=1,n do 55 ir=1,n s=0.e0 do 50 is=1,n 50 s=s+pw(ir,is)*pw(is,ic) 55 pwsq(ir,ic)=s jmat=1 ! ! set up left hand side matrix in qmat 60 continue c3=h*c1 c4=h*h*c2 c5=-h*c2 do 70 ic=1,n do 71 ir=1,n qmat(ir,ic)=c3*pw(ir,ic)+c4*pwsq(ir,ic) if(ir.eq.ic) qmat(ir,ic)=qmat(ir,ic)+1.d0 71 continue 70 continue ! ip(n) = 1 do 86 k = 1,n if(k.eq.n) go to 85 kp1 = k+1 m = k do 81 i = kp1,n if(abs(qmat(i,k)).gt.abs(qmat(m,k))) m = i 81 continue ip(k) = m if(m.ne.k) ip(n) = -ip(n) t1 = qmat(m,k) qmat(m,k) = qmat(k,k) qmat(k,k) = t1 if(t1.eq.0.e0) go to 85 do 82 i = kp1,n 82 qmat(i,k) = -qmat(i,k)/t1 do 84 j = kp1,n t1 = qmat(m,j) qmat(m,j) = qmat(k,j) qmat(k,j) = t1 if(t1.eq.0.e0) go to 84 do 83 i = kp1,n 83 qmat(i,j) = qmat(i,j) + qmat(i,k)*t1 84 continue 85 if(qmat(k,k).eq.0.e0) ip(n) = 0 86 continue qmatmax=0. do ir=1,n do ic=1,n qmatmax=dmax1(qmatmax,dabs(qmat(ir,ic))) end do end do ! if(ip(n).ne.0) go to 110 write(6,88) h 88 format(/' h=',1pe10.3) do ir=1,n do ic=1,n ! write(6,87) ir,ic,qmat(ir,ic) 87 format(' ir,ic=',2i3,' qmat=',1pe10.3) end do end do stop ! go to 170 110 continue ! ! calculate right hand side vector r do 120 ic=1,n do 120 ir=1,n rmat(ir,ic)=c5*pw(ir,ic) if(ir.eq.ic) rmat(ir,ic)=rmat(ir,ic)+1.e0 120 continue do 135 ir=1,n s=0.e0 do 130 ic=1,n 130 s=s+h*rmat(ir,ic)*dysi(ic) 135 r(ir)=s if(n.eq.1) go to 139 nm1 = n-1 do 137 k = 1,nm1 kp1 = k+1 m = ip(k) t1 = r(m) r(m) = r(k) r(k) = t1 do 137 i = kp1,n 137 r(i) = r(i) + qmat(i,k)*t1 do 138 kb = 1,nm1 km1 = n-kb k = km1+1 r(k) = r(k)/qmat(k,k) t1 = -r(k) do 138 i = 1,km1 138 r(i) = r(i) + qmat(i,k)*t1 139 r(1) = r(1)/qmat(1,1) ! r contains delta y vector ! change step size maximum of 50 times before accepting step jmat=jmat+1 if(jmat.ge.20) go to 150 ! find max, abs (delta y)/y am=0.e0 do ir=2,n am=dmax1(am,abs(r(ir))/(abs(y(ir))+1.0d-80) ) end do ! ! step size test, reset if necessary ! if(am.eq.0.e0) go to 150 ! no change in h necessary if((am.le.eps).and.(am.ge.0.1*eps)) then go to 150 end if ! h too large if(am.gt.eps) then h=.5e0*h go to 60 end if ! h too small if(am.lt.0.08e0*eps) then h=1.9e0*h go to 60 end if ! if(h.gt.case(2)) then ! go to 150 ! endif ! go to 60 ! ! increase dependent and independent variables. 150 continue do ir=1,n y(ir)=ysi(ir)+r(ir) end do t=t+h 170 continue return end !*********************************************************************** subroutine taint(xtab,ftab,x,fx,n,k,ner, mon) ! interpolation subroutine for unequally-spaced x-values ! input parameters: ! xtab(n)=independent variables in the given table ! ftab(n)=dependent variables in the given table ! x=independent variable for which interpolation is wanted ! n=number of points in table ! k=order of interpolation. 1=linear (two points), 2=quadratic(three points),etc ! mon=must be set initially to zero. the subroutine sets to 1. If set to 1, ! the subroutine skips reading xtab. Maximum of 9 allowed ! output parameters ! fx=dependetn variable obtained by interpolation ! ner=error message. 1=successful interpolation. ne.1=error (ner=2: too few ! number of given table values. ner=3: xtab values are not monotonic) ! implicit real*8(a-h,o-z) dimension xtab(n),ftab(n),t(10),c(10) !ps0400 taint subroutine- in fortran ii. if (n - k) 1,1,2 1 ner=2 return 2 if (k-9) 3,3,1 3 if ( mon) 4,4,5 5 if ( mon-2) 6,7,4 4 j=0 nm1=n-1 do 8 i=1,nm1 if (xtab(i)-xtab(i+1)) 9,11,10 11 ner=3 return 9 j=j-1 go to 8 10 j=j+1 8 continue mon=1 if (j) 12,6,6 12 mon=2 7 do 13 i=1,n if (x-xtab(i)) 14,14,13 14 j=i go to 18 13 continue go to 15 6 do 16 i=1,n if (x-xtab(i)) 16,17,17 17 j=i go to 18 16 continue 15 j=n 18 j=j-(k+1)/2 if (j) 19,19,20 19 j=1 20 m=j+k if (m-n) 21,21,22 22 j=j-1 go to 20 21 kp1=k+1 jsave=j 26 do 23 l=1,kp1 c(l)=x-xtab(j) t(l)=ftab(j) 23 j=j+1 do 24 j=1,k i=j+1 25 t(i)=(c(j)*t(i)-c(i)*t(j))/(c(j)-c(i)) i=i+1 if (i-kp1) 25,25 ,24 24 continue fx=t(kp1) ner=1 return end !*************************************************************************** subroutine thrcal(tmax,tmin,itemp) ! thermodynamic calculation ! input: nprt=print index. ! tmax=maximum temperature ! tmin=minimum temperature ! itemp=temperature index parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) dimension tt(5),tt1(5),xx(5,5),b(5),wkarea(msp),pft & & (5,msp,3),pfti(5,msp,3) character*4 elemnm,spnm ! nprt=0 if(itemp.eq.1) nprt=1 ! ! prepare for equilibrium constant calculation if(n6.ge.1) then do 310 jr=1,n6 ji1=lid(1,jr) jf1=lid(3,jr) jf2=lid(4,jr) hr(jr)=(h0sp(ji1)-h0sp(jf1)-h0sp(jf2)) 310 continue endif if(n10.ge.n7) then do 320 jr=n7,n10 ji1=lid(1,jr) ji2=lid(2,jr) jf1=lid(3,jr) jf2=lid(4,jr) hr(jr)=(h0sp(ji1)+h0sp(ji2)-h0sp(jf1)-h0sp(jf2)) 320 continue endif ! ! partition functions tdif=0.25d0*(tmax-tmin) do 330 jt=1,5 tt(jt)=tmin+tdif*(jt-1) tt1(jt)=10000.d0/tt(jt) 330 continue do 340 jsp=1,nsp1 do 340 jt=1,5 dtemp=0.002d0*tt(jt) do 341 i=1,3 temp=tt(jt)+dtemp*(i-2) spwt1=spwt(jsp)*1.0d3 call partfx(jsp,spnm(jsp),spwt1,temp,temp,temp,nprt,partf, & & parti) pfti(jt,jsp,i)=parti pft(jt,jsp,i)=partf/6.025d23 341 continue if(nprt.gt.2) write(6,960) jsp,tt(jt),(pft(jt,jsp,i),i=1,3) 960 format(' jsp=',i2,' temp=',f7.0,' pft=',3e10.3) 340 continue call eintf(pft,pfti,tmax,tmin) ! ! calculate equilibrium constants do 350 jr=1,n6 ji1=lid(1,jr) jf1=lid(3,jr) jf2=lid(4,jr) if(nprt.gt.2) write(6,1000) ji1,jf1,jf2 1000 format(' ji1,jf1,jf2 =',4i5) do 350 jt=1,5 akax=(pft(jt,jf1,2)/pft(jt,ji1,2))*pft(jt,jf2,2) aka(jt,jr)=dlog(akax)+hr(jr)/(6.025d23*1.3805d-23*tt(jt)) 350 continue do 360 jr=n7,n10 ji1=lid(1,jr) ji2=lid(2,jr) jf1=lid(3,jr) jf2=lid(4,jr) if(nprt.gt.2) write(6,1100) ji1,ji2,jf1,jf2 1100 format(' ji1,ji2,jf1,jf2=',4i5) do 360 jt=1,5 akax=(pft(jt,jf1,2)/pft(jt,ji1,2))*(pft(jt,jf2,2)/ & & pft(jt,ji2,2)) aka(jt,jr)=dlog(akax)+hr(jr)/(6.025d23*1.3805d-23*tt(jt)) 360 continue if(nprt.gt.2) write(6,970) 970 format(' aka made') ! ! determine 5 coefficients expressing equilibrium constant ! ke=dexp(aka(1,jr)/z+aka(2,jr)+aka(3,jr)*ln(z)+aka(4,jr)*z ! +aka(5,jr)*z*z), where z=10000/temp ! ! set independent variables xx(j,i) and rhs b(j) ! j=row number, i=column number. do 560 jr=1,n10 do 370 j=1,5 b(j)=aka(j,jr) xx(j,1)=1.0d0/tt1(j) xx(j,2)=1.0d0 xx(j,3)=dlog(tt1(j)) do 370 i=4,5 370 xx(j,i)=tt1(j)**(i-3) call leqt2f(xx,1,5,5,aka(1,jr),0,wkarea,ier) 560 continue ! ! write out if(nprt.gt.0) then write(6,380) 380 format(/' list of reactions'/' initl species final species', & & ' reaction equilibrium constant coefficient rate const', & & ' t-pwr',' activn'/29x,'energy',13x,'5-term expansion',13x, & & 'cm3/mol',13x,'temp' /29x,'kjoul/mol' ) do 390 jr=1,n10 if(jr.eq.1) write(6,400) 400 format(' heavy particle impact dissociation') if(jr.eq.n3) write(6,410) 410 format(' electron impact dissociations') if(jr.eq.n5) write(6,420) 420 format(' electron impact ionizations') if(jr.eq.n7) write(6,440) 440 format(' exchange reactions') if(jr.eq.n9) write(6,450) 450 format(' associative ionization reactions') l1=lid(1,jr) l2=lid(2,jr) l3=lid(3,jr) l4=lid(4,jr) if(jr.le.n6) then write(6,470) jr,spnm(l1),spnm(l3),spnm(l4), & & hr(jr)*1.0e-3,(aka(i,jr),i=1,5),(crat(i,jr),i=1,3) 470 format(1x,i2,4x,a4,5x,1h=,a4,1h+,a4,f9.2,1x,5f8.3, & & 1x,1pe10.3,0pf9.3,f9.0) if(jr.le.n2) then do 490 jsp=1,nsp write(6,500) spnm(jsp),crat1(jsp,jr),crat(2,jr), & & crat(3,jr) 500 format(65x,4hm = ,a4,4x,1pe10.3,0pf9.3,f9.0) 490 continue endif endif if(jr.gt.n6) then write(6,480) jr,spnm(l1),spnm(l2),spnm(l3),spnm(l4), & & hr(jr)*1.0e-3,(aka(i,jr),i=1,5),(crat(i,jr),i=1,3) 480 format(1x,i2,4x,a4,1h+,a4,1h=,a4,1h+,a4, & & f9.2,1x,5f8.3,1x,1pe10.3,0pf9.3,f9.0) endif 390 continue endif return end !*********************************************************************** subroutine thrinp(ncase,nair,nprt, nspx,spnmx, pres,spallf, tw,delH) ! thermodynamic input subroutine ! input parameters: ! ncase=1: air; =2: ablation product ! nair=unit containing equilibrium air data ! nprt=0 no print ! =1 chemical rate formulas only printed ! =2 inputs and chemical rate formulas printed ! =3 further details printed ! nspx ! spnmxx ! pres=pressure, in Pa ! output parameters: ! nspx=number of species ! spnmx(msp)=species name ! tw=wall temperature ! delH=ablation energy. J/kg parameter(msp=60) implicit real*8(a-h,o-z) common/eqcoma/elemwt(15), & & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp), & & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp), & & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp), & & akb(5,msp),akd(5,msp),avmw0 common/eqcomb/elemnm(12) common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc, & & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp), & & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp) common/node/spv(msp),t,p,brm,speth(msp),spgfz(msp),spcsp(msp), & & bzro(9),ethm,h298(msp) dimension dum(40) character*4 elemnm,dum,spnm,spnmx(msp) ! ! read in elemental and species indices ! definition: ! nelem=total number of elements ! nsp=total number of species ! elemnm(i)=element name(a4) ! elemwt(i)=molecular weight of element ! felem(i)=mass fraction of element ! nded(i)=species to be deduced from others read(5,11) (dum(i),i=1,31) 11 format(40a4) write(6,11) (dum(i),i=1,31) read(5,10) (dum(i),i=1,19),nelem,nsp 10 format(19a4/8i10) if(nprt.gt.0) write(6,10) (dum(i),i=1,19),nelem,nsp ! ! for air if(ncase.eq.1) then read(5,80) (dum(i),i=1,19) if(nprt.gt.0) write(6,80) (dum(i),i=1,19) sumel=0. do 20 jelem=1,nelem read(5,30) elemnm(jelem),elemwt(jelem),felem(jelem) 30 format(a4,6x,f10.6,e10.3,2i5) if(nprt.gt.0) write(6,30) elemnm(jelem),elemwt(jelem), & & felem(jelem) sumel=sumel+felem(jelem) 20 continue do 21 jelem=1,nelem 21 felem(jelem)=felem(jelem)/sumel end if ! ! for ablation product if(ncase.eq.2) then call compos(elemnm,elemwt,felem) ! call ivuna_wall(pres, tw,delH) if(spallf.gt.1.0e-6) peff=pres/spallf if(spallf.le.1.0e-6) peff=pres call ivuna_wall(peff, tw,delH1) if(spallf.gt.1.0e-6) delH=delH1/spallf if(spallf.le.1.0e-6) delH=delH1 end if ! read in species data ! definition: ! spnm(i)=species name(a4) ! spwt(i)=species molecular weight ! cpsp(i)=cp of species (j/mol) ! h0sp(i)=formation energy, j/mol ! ie(i)=electric charge; 0=neutral,1=positive,-1=negative ! im(i)=molecule index; 0=atom, 1=molecle ! ih(i)=number of atoms in the species ! nelec(i)=number of electronic states ! ielem(jsp,i)=number of elements i in species jsp iveq=0 do 50 jsp=1,nsp read(5,61) (dum(k),k=1,19) 61 format(21a4) if(nprt.gt.0) write(6,61) (dum(i),i=1,19) read(5,60) spnm(jsp),spwt(jsp),cpsp(jsp),h0sp(jsp),ie(jsp), & & im(jsp),ih(jsp),nelec(jsp),(ielem(jsp,i),i=1,nelem) 60 format(a4,6x,f10.6,e10.3,e10.3,4i5,15i2) write(6,120) spnm(jsp),spwt(jsp),cpsp(jsp),h0sp(jsp),ie(jsp), & & im(jsp),ih(jsp),nelec(jsp),(ielem(jsp,i),i=1,nelem) 120 format(a4,6x,f10.7,1pe10.3,e10.3,4i5,15i2) ! ! spectral data ! atom ! definition: ! atomg(ilev,jsp)=g of state ilev of species jsp ! atome(ilev,jsp)=e of state ilev of species jsp, cm-1 if(im(jsp).eq.0) then nlev=nelec(jsp) read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) 80 format(19a4) do 70 ilev=1,nlev read(5,90) atomg(ilev,jsp),atome(ilev,jsp) 90 format(8e10.3) if(nprt.gt.1) write(6,110) atomg(ilev,jsp),atome(ilev,jsp) 110 format(f10.0,f10.2) 70 continue endif ! ! diatomic molecule ! definition: ! rmass(i)=reduced mass ! factr(i)=rotational factor (1 for hetero, 0.5 for homo) ! spect(i,j,jsp), i=1-11 =spectral constants for species jsp, ! for jth electronic state if((im(jsp).eq.1).and.(ih(jsp).eq.2)) then read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) read(5,90) rmass(jsp),factr(jsp) if(nprt.gt.1) write(6,90) rmass(jsp),factr(jsp) read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) nlev=nelec(jsp) do 160 j=1,nlev read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) read(5,130) (spect(i,j,jsp),i=1,7) 130 format(f10.0,f10.2,f10.4,f10.5,f10.7,f10.5,f10.0) if(nprt.gt.1) write(6,130) (spect(i,j,jsp),i=1,7) read(5,140) (spect(i,j,jsp),i=8,11) 140 format(10x,f10.3,f10.6,e10.3,e10.3) if(nprt.gt.1) write(6,150) (spect(i,j,jsp),i=8,11) 150 format(10x,f10.3,f10.6,1pe10.3,e10.3) 160 continue ! endif ! ! triatomic molecule ! definition: ! factr(i)=rotational factor (1 for hetero, 0.5 for homo) ! spect(1,1,jsp)=1st vibrational multiplicity ! spect(1,2,jsp)=1st vibrational constant, cm-1 ! spect(2,1,jsp)=2nd vibrational multiplicity ! spect(2,2,jsp)=2nd vibrational constant, cm-1 ! spect(3,1,jsp)=3rd vibrational multiplicty ! spect(3,2,jsp)=3rd vibrational constant, cm-1 ! spect(4,1,jsp)=ground state electronic multiplicity ! spect(5,1,jsp)=1st bond distance, angstrom ! spect(5,2,jsp)=2nd bond distance, angstrom ! spect(6,1,jsp)=bond angle, degrees ! spect(7,1,jsp)=moment of inertia, g3-cm6 ! spect(7,2,jsp)=b, cm-1 ! assumes single electronic state, harmonic oscillator, rigid rotator ! if((im(jsp).eq.1).and.(ih(jsp).eq.3)) then read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) read(5,90) rmass(jsp),factr(jsp) if(nprt.gt.1) write(6,90) rmass(jsp),factr(jsp) read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) read(5,80) (dum(i),i=1,19) if(nprt.gt.1) write(6,80) (dum(i),i=1,19) read(5,730) & & spect(1,1,jsp),spect(1,2,jsp),spect(2,1,jsp),spect(2,2,jsp), & & spect(3,1,jsp),spect(3,2,jsp),spect(4,1,jsp), & & spect(5,1,jsp),spect(5,2,jsp),spect(6,1,jsp),spect(6,2,jsp), & & spect(7,1,jsp),spect(7,2,jsp) 730 format(f10.1,f10.2,f10.1,f10.2,f10.1,f10.2,f10.1/ & & 2f10.3,2f10.2,2e10.3) if(nprt.gt.1) write(6,740) & & spect(1,1,jsp),spect(1,2,jsp),spect(2,1,jsp),spect(2,2,jsp), & & spect(3,1,jsp),spect(3,2,jsp),spect(4,1,jsp), & & spect(5,1,jsp),spect(5,2,jsp),spect(6,1,jsp),spect(6,2,jsp), & & spect(7,1,jsp),spect(7,2,jsp) 740 format(f10.1,f10.2,f10.1,f10.2,f10.1,f10.2,f10.1/ & & 2f10.3,2f10.2,1p2e10.3) endif ! 310 continue 50 continue ! reading of heavy-particle species ended ! electron ! definition: nsp1=nsp+1 nsp2=nsp+2 nsp3=nsp-nelem jsp=nsp1 read(5,61) (dum(i),i=1,19) if(nprt.gt.1) write(6,61) (dum(i),i=1,19) read(5,60) spnm(jsp),spwt(jsp),cpsp(jsp), & & h0sp(jsp),ie(jsp),im(jsp),nelec(jsp),(ielem(jsp,i),i=1, & & nelem) if(nprt.gt.1) write(6,120) spnm(jsp),spwt(jsp), & & cpsp(jsp),h0sp(jsp),ie(jsp),im(jsp),nelec(jsp),(ielem(jsp,i), & & i=1,nelem) ! ! read in reaction data ! definition: ! nhdiss=number of dissoc reactions by heavy-particle impact ! nediss=number of dissoc reactions by electron impact ! neimp=number of ionization reactions by electron impact ! nexch=number of exchange reactions ! nassoc=number of associative ionization reactions read(5,170) (dum(i),i=1,19),nhdiss,nediss,neimp,nexch, & & nassoc 170 format(19a4/8i10) if(nprt.gt.1) write(6,170) (dum(i),i=1,19),nhdiss,nediss,neimp, & & nexch,nassoc n1=1 n2=nhdiss n3=n2+1 n4=n2+nediss n5=n4+1 n6=n4+neimp n7=n6+1 n8=n6+nexch n9=n8+1 n10=n8+nassoc ! heavy particle-impact dissociation if(nhdiss.gt.0) then do 230 jr=n1,n2 read(5,180) dum(1),dum(2),dum(3),dum(4),dum(5) 180 format(10x,a4,8x,a4,10x,a4,8x,a4,8x,a4) if(nprt.gt.1) write(6,180) dum(1),dum(2),dum(3),dum(4),dum(5) do 190 i=1,5 lid(i,jr)=0 do 190 jsp=1,nsp if(dum(i).eq.spnm(jsp)) lid(i,jr)=jsp 190 continue read(5,200) crat(2,jr),crat(3,jr) 200 format(10x,f10.3,f10.0) if(nprt.gt.1) write(6,200) crat(2,jr),crat(3,jr) do 260 ithird=1,nsp read(5,210) dum(6),crat1(ithird,jr) 210 format(a4,6x,e10.3) if(nprt.gt.1) write(6,210) dum(6),crat1(ithird,jr) 260 continue 230 continue endif ! electron-impact dissociation + electron-impact ionization if(n6.ge.n3) then do 240 jr=n3,n6 read(5,180) dum(1),dum(2),dum(3),dum(4),dum(5) if(nprt.gt.1) write(6,180) dum(1),dum(2),dum(3),dum(4),dum(5) do 220 i=1,5 lid(i,jr)=0 do 220 jsp=1,nsp1 if(dum(i).eq.spnm(jsp)) lid(i,jr)=jsp 220 continue read(5,510) crat(1,jr),crat(2,jr),crat(3,jr) 510 format(e10.3,f10.3,f10.0) if(nprt.gt.1) write(6,510) crat(1,jr),crat(2,jr),crat(3,jr) 240 continue endif ! exchange + associative ionization if(n10.ge.n7) then do 290 jr=n7,n10 read(5,180) dum(1),dum(2),dum(3),dum(4) if(nprt.gt.1) write(6,180) dum(1),dum(2),dum(3),dum(4) do 280 i=1,4 lid(i,jr)=0 do 280 jsp=1,nsp2 if(dum(i).eq.spnm(jsp)) lid(i,jr)=jsp 280 continue read(5,510) crat(1,jr),crat(2,jr),crat(3,jr) if(nprt.gt.1) write(6,510) crat(1,jr),crat(2,jr),crat(3,jr) 290 continue endif ! ! write lid array, if wanted do 900 jr=n1,n10 if(nprt.gt.2) write(6,910) (lid(i,jr),i=1,5) 910 format(5i5) 900 continue ! ! calculate enthalpy (minus formation energy) at 298 K in J/mol do isp=1,nsp1 h298(isp)=h0sp(isp) enddo ! ! average molecular weight at low temperature avmw0=0.05459068 do iel=1,nelem nded(iel)=iel end do do isp=1,nsp1 spnmx(isp)=spnm(isp) end do nspx=nsp return end !*********************************************************************** subroutine trapez(ans,x,y,n,ier) ! integrates with trapezoidal rule implicit real*8(a-h,o-z) dimension x(n),y(n) sum=0. do i=2,n sum=sum+(x(i)-x(i-1))*0.5*(y(i-1)+y(i)) enddo ans=sum return end !*********************************************************************** subroutine triatom_bf(isp,temp) ! triatomic continuum parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) parameter (nw=400000) implicit real*8(a-h,o-z) character*1 dum(140),id_lev_triatom(8,15,mtriatoms) character*4 contnm_triatom,unknown,asterik,minus1 character*4 atomnm2(matoms),bandnm_diatom, & & contnm_diatom(2,21,mdiatoms) character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 character*8 sym_lev_triatom(10,15,mtriatoms) integer check,gg_lev_triatom,ge_lev_triatom,spin_lev_triatom, & & g1_lev_triatom,g2_lev_triatom,g3_lev_triatom real*8 ix_lev_triatom,iy_lev_triatom,iz_lev_triatom common/comi/nwave common/comtriatom/a0_lev_triatom(15,mtriatoms), & & ang_lev_triatom(15,mtriatoms), & & b0_lev_triatom(15,mtriatoms),c0_lev_triatom(15,mtriatoms), & & cross_cont_triatom(302,10,5,mtriatoms), & & ix_lev_triatom(15,mtriatoms),iy_lev_triatom(15,mtriatoms), & & iz_lev_triatom(15,mtriatoms),r1_lev_triatom(15,mtriatoms), & & r2_lev_triatom(15,mtriatoms),te_lev_triatom(15,mtriatoms), & & temp_cont_triatom(10,15,mtriatoms), & & tv_lev_triatom(15,mtriatoms),triatom_dis_eny(10), & & triatom_ion_eny(10),triatom_mass(10),triatomwt(10), & & wavel_cont_triatom(302,5,mtriatoms), & & we_lev_triatom(15,15,mtriatoms),wexe_lev_triatom(15,15,mtriatoms) & & ,we1_lev_triatom(15,mtriatoms),we2_lev_triatom(15,mtriatoms), & & we3_lev_triatom(15,mtriatoms),wexe1_lev_triatom(15,mtriatoms), & & wexe2_lev_triatom(15,mtriatoms),wexe3_lev_triatom(15,mtriatoms) common/comitriatom/contnm_triatom(2,5,mtriatoms), & & g_lev_triatom(5,15,mtriatoms),g1_lev_triatom(15,mtriatoms), & & g2_lev_triatom(15,mtriatoms),g3_lev_triatom(15,mtriatoms), & & gg_lev_triatom(15,mtriatoms),ge_lev_triatom(15,mtriatoms), & & ind_lev_triatom(15,mtriatoms),lam_lev_triatom(15,mtriatoms), & & nlev_triatom(10),ntemp_cont_triatom(5,mtriatoms), & & num_cont_triatom(mtriatoms),nwave_cont_triatom(15,mtriatoms), & & spin_lev_triatom(15,mtriatoms) common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec, & & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms), & & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms), & & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms) & & ,rho_diatom(10,mdiatoms) common/spect/calpha,slope_ratio,wavmin,wavmax,rangex common/coma/absb(nw) common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw), & & intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11) real*8 intw,int_e,minwavel,maxwavel dimension tlog(15),y(15),wavelx(151),cross(151) ! WRITE(*,*) ' IN TRIATOM_BB. ',TRIATOMNM(ISP) write(6,15) triatomnm(isp),dens_triatom(isp) 15 format(' In triatom_bb. species = ',a4,1pe10.3,' cm-3') ! ! cycle over continua k=0 do icont=1,num_cont_triatom(isp) k=k+1 if(contnm_triatom(2,icont,isp).eq.triatom_bands(2,k)) then nwavex = nwave_cont_triatom(icont,isp) minwavel = wavel_cont_triatom(1,icont,isp) maxwavel = wavel_cont_triatom(nwavex,icont,isp) nstrt = nwave*((minwavel-wavmin)/(wavmax-wavmin))**(1./calpha)+2 ! nstrt = (1.0/wavmin**2 - 1.0/minwavel**2)/estep + 2 nend = nwave*((maxwavel-wavmin)/(wavmax-wavmin))**(1./calpha) ! nend = (1.0/wavmin**2 - 1.0/maxwavel**2)/estep ntemp = ntemp_cont_triatom(icont,isp) if(nstrt.lt.1) nstrt = 1 if(nend.gt.nwave) nend = nwave ! ! interpolate absorption cross sections for given electron temperature do it = 1,ntemp tlog(it) = dlog(temp_cont_triatom(it,icont,isp)) end do tlogx = dlog(temp) mon = 0 do iwave = 1, nwavex wavelx(iwave) = wavel_cont_triatom(iwave,icont,isp) do it = 1,ntemp y(it) = dlog(cross_cont_triatom(iwave,it,icont,isp)+1.0e-22) end do call taint(tlog,y,tlogx,crossx,ntemp,2,ner,mon) cross(iwave) = crossx end do ! ! interpolate to find cross section crosx mon = 0 do m = nstrt,nend call taint(wavelx,cross,wavel(m),crosx,nwavex,1,ner,mon) absorption = dexp(crosx) * dens_triatom(isp) ax = dexp(-1.43877*1.0e8/(wavel(m)*temp)) blam = 1.1904e-16 * ax/((1.0e-8*wavel(m))**5*(1.0 - ax)) emission = absorption * blam absb(m) = absb(m) + absorption end do end if end do ! return end !*********************************************************************** subroutine triatom_read(ntriatom1) ! reads triatom data ! input parameters: ! triatom_bands(3,10)=list of triatomic radiation mechanisms to be calculated ! triatomnm(mtriatoms)=triatom name ! output parameters: ! ntriatom1=number of triatoms ! triatomnm1(mtriatoms)=name of triatoms parameter(matoms=56,nlev_tot_atom=999, & & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60) implicit real*8(a-h,o-z) character*1 dum(140),id_lev_triatom(8,15,mtriatoms) character*4 contnm_triatom,unknown,asterik,minus1 character*4 atomnm2(matoms),bandnm_diatom, & & contnm_diatom(2,21,mdiatoms) character*4 atom_rads(3,168),diatom_bands(3,100), & & triatom_bands(3,10),spnm(msp),aster,dum1(60), & & atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms), & & diatomnm1(mdiatoms),triatomnm(mtriatoms), & & triatomnm1(mtriatoms) common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, & & diatomnm,diatomnm1,triatomnm,triatomnm1 character*8 sym_lev_triatom(10,15,mtriatoms) integer check,gg_lev_triatom,ge_lev_triatom,spin_lev_triatom, & & g1_lev_triatom,g2_lev_triatom,g3_lev_triatom real*8 ix_lev_triatom,iy_lev_triatom,iz_lev_triatom common/comtriatom/a0_lev_triatom(15,mtriatoms), & & ang_lev_triatom(15,mtriatoms), & & b0_lev_triatom(15,mtriatoms),c0_lev_triatom(15,mtriatoms), & & cross_cont_triatom(302,10,5,mtriatoms), & & ix_lev_triatom(15,mtriatoms),iy_lev_triatom(15,mtriatoms), & & iz_lev_triatom(15,mtriatoms),r1_lev_triatom(15,mtriatoms), & & r2_lev_triatom(15,mtriatoms),te_lev_triatom(15,mtriatoms), & & temp_cont_triatom(10,15,mtriatoms), & & tv_lev_triatom(15,mtriatoms),triatom_dis_eny(10), & & triatom_ion_eny(10),triatom_mass(10),triatomwt(10), & & wavel_cont_triatom(302,5,mtriatoms), & & we_lev_triatom(15,15,mtriatoms),wexe_lev_triatom(15,15,mtriatoms) & & ,we1_lev_triatom(15,mtriatoms),we2_lev_triatom(15,mtriatoms), & & we3_lev_triatom(15,mtriatoms),wexe1_lev_triatom(15,mtriatoms), & & wexe2_lev_triatom(15,mtriatoms),wexe3_lev_triatom(15,mtriatoms) common/comitriatom/contnm_triatom(2,5,mtriatoms), & & g_lev_triatom(5,15,mtriatoms),g1_lev_triatom(15,mtriatoms), & & g2_lev_triatom(15,mtriatoms),g3_lev_triatom(15,mtriatoms), & & gg_lev_triatom(15,mtriatoms),ge_lev_triatom(15,mtriatoms), & & ind_lev_triatom(15,mtriatoms),lam_lev_triatom(15,mtriatoms), & & nlev_triatom(10),ntemp_cont_triatom(5,mtriatoms), & & num_cont_triatom(mtriatoms),nwave_cont_triatom(15,mtriatoms), & & spin_lev_triatom(15,mtriatoms) data asterik/'****'/,minus1/'-1 '/ ! ntriatoms=0 isp=0 ! read asterik line read(9,10) (dum(i),i=1,120) write(3,10) (dum(i),i=1,120) 10 format(130a1) 10000 continue read(9,20) unknown,(dum(i),i=1,120) write(3,20) unknown,(dum(i),i=1,120) 20 format(a4,130a1) if(unknown.eq.minus1) then write(3,160) (triatomnm(i),i=1,ntriatoms) 160 format(' triatomic data finished reading for ',10a4) return end if ! ! check if this species is required check = 0 do i=1,mtriatoms if(unknown.eq.triatomnm1(i)) check=1 end do if(check.eq.1) then isp=isp+1 go to 130 endif ! this species is not needed and skipped write(3,140) 140 format(' this species is skipped') 150 read(9,20) unknown,(dum(i),i=1,70) write(3,20) unknown,(dum(i),i=1,70) if(unknown.ne.asterik) go to 150 go to 10000 130 continue ! set species name triatomnm(isp) = unknown ! ! prepare to read triatomic level data read(9,30) triatom_mass(isp), (dum(i),i=1,50) write(3,30) triatom_mass(isp), (dum(i),i=1,50) 30 format(e11.4,70a1) read(9,30) triatomwt(isp), (dum(i),i=1,50) write(3,30) triatomwt(isp), (dum(i),i=1,50) read(9,10) (dum(i),i=1,70) write(3,10) (dum(i),i=1,70) read(9,30) triatom_dis_eny(isp), (dum(i),i=1,50) write(3,30) triatom_dis_eny(isp), (dum(i),i=1,50) read(9,30) triatom_ion_eny(isp), (dum(i),i=1,50) write(3,30) triatom_ion_eny(isp), (dum(i),i=1,50) read(9,40) nlev_triatom(isp), (dum(i),i=1,50) write(3,40) nlev_triatom(isp), (dum(i),i=1,50) 40 format(i11,70a1) ! do j=1,4 read(9,10) (dum(i),i=1,90) write(3,10) (dum(i),i=1,90) enddo ! ! read triatomic level data do lev=1,nlev_triatom(isp) read(9,50) ind_lev_triatom(lev,isp), & & (id_lev_triatom(j,lev,isp),j=1,8), & & gg_lev_triatom(lev,isp), & & tv_lev_triatom(lev,isp),te_lev_triatom(lev,isp), & & a0_lev_triatom(lev,isp),b0_lev_triatom(lev,isp), & & c0_lev_triatom(lev,isp),ix_lev_triatom(lev,isp), & & iy_lev_triatom(lev,isp),iz_lev_triatom(lev,isp) 50 format(i3,1x,8a1,i3,8f10.2) write(3,50) ind_lev_triatom(lev,isp), & & (id_lev_triatom(j,lev,isp),j=1,8), & & gg_lev_triatom(lev,isp), & & tv_lev_triatom(lev,isp),te_lev_triatom(lev,isp), & & a0_lev_triatom(lev,isp),b0_lev_triatom(lev,isp), & & c0_lev_triatom(lev,isp),ix_lev_triatom(lev,isp), & & iy_lev_triatom(lev,isp),iz_lev_triatom(lev,isp) read(9,51) lam_lev_triatom(lev,isp), & & spin_lev_triatom(lev,isp),r1_lev_triatom(lev,isp), & & r2_lev_triatom(lev,isp),ang_lev_triatom(lev,isp), & & we1_lev_triatom(lev,isp),wexe1_lev_triatom(lev,isp), & & g1_lev_triatom(lev,isp), & & we2_lev_triatom(lev,isp),wexe2_lev_triatom(lev,isp), & & g2_lev_triatom(lev,isp), & & we3_lev_triatom(lev,isp),wexe3_lev_triatom(lev,isp), & & g3_lev_triatom(lev,isp) 51 format(i7,i5,f9.4,f8.4,f7.1,f8.2,f8.3,i3,f9.2,f8.2,i3, & & f8.2,f8.2,i3) write(3,51) lam_lev_triatom(lev,isp), & & spin_lev_triatom(lev,isp),r1_lev_triatom(lev,isp), & & r2_lev_triatom(lev,isp),ang_lev_triatom(lev,isp), & & we1_lev_triatom(lev,isp),wexe1_lev_triatom(lev,isp), & & g1_lev_triatom(lev,isp), & & we2_lev_triatom(lev,isp),wexe2_lev_triatom(lev,isp), & & g2_lev_triatom(lev,isp), & & we3_lev_triatom(lev,isp),wexe3_lev_triatom(lev,isp), & & g3_lev_triatom(lev,isp) end do ! ! number of radiative transitions read(9,10) (dum(i),i=1,90) write(3,10) (dum(i),i=1,90) read(9,70) num_cont_triatom(isp), (dum(i),i=1,70) write(3,70) num_cont_triatom(isp), (dum(i),i=1,70) 70 format(i10,90a1) read(9,10) (dum(i),i=1,90) write(3,10) (dum(i),i=1,90) ! ! prepare to read triatomic continuum data if(num_cont_triatom(isp).eq.0) go to 120 ! do icont=1,num_cont_triatom(isp) read(9,75) (contnm_triatom(i,icont,isp),i=1,2),(dum(i),i=1,60) write(3,75) (contnm_triatom(i,icont,isp),i=1,2),(dum(i),i=1,60) 75 format(2a4,70a1) do j=1,2 read(9,10) (dum(i),i=1,79) write(3,10) (dum(i),i=1,79) enddo read(9,70) ntemp_cont_triatom(icont,isp),(dum(i),i=1,60) write(3,70) ntemp_cont_triatom(icont,isp),(dum(i),i=1,60) read(9,70) nwave_cont_triatom(icont,isp),(dum(i),i=1,60) write(3,70)nwave_cont_triatom(icont,isp),(dum(i),i=1,60) read(9,10) (dum(i),i=1,79) write(3,10) (dum(i),i=1,79) ! read(9,200) (dum(i),i=1,11),(temp_cont_triatom(it,icont,isp), & & it=1,ntemp_cont_triatom(icont,isp)) write(3,200) (dum(i),i=1,11),(temp_cont_triatom(it,icont,isp), & & it=1,ntemp_cont_triatom(icont,isp)) 200 format(11a1,11f10.1) read(9,10) (dum(i),i=1,90) write(3,10) (dum(i),i=1,90) ! ! read molecular vuv continuum data do iwav=1, nwave_cont_triatom(icont,isp) read(9,210) wavel_cont_triatom(iwav,icont,isp), & & (cross_cont_triatom(iwav,it,icont,isp),it=1, & & ntemp_cont_triatom(icont,isp)) write(3,210) wavel_cont_triatom(iwav,icont,isp), & & (cross_cont_triatom(iwav,it,icont,isp),it=1, & & ntemp_cont_triatom(icont,isp)) 210 format(f10.2,11e10.3) enddo read(9,10) (dum(i),i=1,90) write(3,10) (dum(i),i=1,90) end do 120 continue ! ! this species has ended 180 continue go to 10000 ! end