1 | C SORTIE DE CERTAINS RENSEIGNEMENTS SUR LA |
---|
2 | C SPECTROSCOPIC DATA BANK |
---|
3 | C |
---|
4 | C SANS AUCUN PARAMETRE SORTIE DES FREQUENCES MOLECULES ET DU CODAGE |
---|
5 | C DE LA VERSION LA PLUS RECENTE |
---|
6 | C LISTE='CTLG' IMPRESSION DU CATALOGUE DE LA BANQUE(ENTRE NU1-NU2) |
---|
7 | C SI NU1 ET NU2 OMIS TOUT LE CATALOGUE |
---|
8 | C LISTE='OPT' LISTE DES OPTIONS DISPONIBLES |
---|
9 | C |
---|
10 | C ANAL='OUI' SORTIE DES FREQUENCES MOLECULES-ISOTOPES (SANS LECTURE |
---|
11 | C DE LA BANQUE) |
---|
12 | C |
---|
13 | C TRANS='OUI' SORTIE DES TRANSITIONS (SANS LECTURE DE LA BANQUE) |
---|
14 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * |
---|
15 | C |
---|
16 | C LAST MODIF : 06.05.1991 PASSAGE DE 40 MOLECULES A 75 DANS LES COMMON |
---|
17 | C LAST MODIF : 04.12.1996 PASSAGE DE 42 MOLECULES A 75 DANS LES COMMON |
---|
18 | C |
---|
19 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * |
---|
20 | subroutine infor(pp,ia) |
---|
21 | C |
---|
22 | logical*1 pp(1) |
---|
23 | character*44 fmt |
---|
24 | character*9 trs1,trs2 |
---|
25 | character*7 form,bin |
---|
26 | character*4 code,ctlg,mole,blanc,coli6 |
---|
27 | character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre, |
---|
28 | & oui,iopt,liste,iasr,remp,supp,ajou,modif,trans |
---|
29 | character*2 icod,ikod |
---|
30 | character*1 moins,slash,bl,ch5,ch6 |
---|
31 | integer ia(1),vers,nbtr(75) |
---|
32 | real nu1,nu2,vnu(4) |
---|
33 | C |
---|
34 | common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste |
---|
35 | common/p2/ mole(75),isot(100),nbi(75),nbt(75),iopt,ctlg,trans, |
---|
36 | & trs1,trs2 |
---|
37 | common/p3/ imole,iran,ival,pgm,ianl,iext,itrs,ilst,icop,info,icre |
---|
38 | common/p4/ nmol,knmol,ksot,kksot,ntab,nhist,kp,lre,form,bin,modif |
---|
39 | common/p5/ code(75),nn(150),nq(150),ikod(18),icod(18),jdeb(75) |
---|
40 | common/p6/ iasr,remp,supp,ajou,imp8,imp9,in40,in41,in42,in43,n97 |
---|
41 | common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui |
---|
42 | C |
---|
43 | data vnu/0. ,22656.465,0. ,0. / |
---|
44 | data moins,slash,bl/'-','/',' '/ |
---|
45 | C DATA NBTR91 |
---|
46 | C & / 49296, 60948,168881, 24125, 13205, 40514, 2254, 7385, 23659, |
---|
47 | C & 55468, 6784, 4635,143021, 8676, 107, 371, 398, 237, |
---|
48 | C & 6020, 4171, 2702, 8944, 6457, 1258, 203, 824, 2575, |
---|
49 | C & 9019, 2577, 1405, 2027, 15565, 117, 6687, 5444, 4058, |
---|
50 | C & 3388, 18242, 11520, 3390, 35*0/ |
---|
51 | data nbtr |
---|
52 | & / 50217, 62816,281607, 26771, 13515, 66883, 6292, 94738, 38853, |
---|
53 | & 100680, 11152, 4635,171504, 41786, 107, 533, 576, 237, |
---|
54 | & 7230, 24922, 2702, 14981, 11524, 1668, 12978, 824, 2575, |
---|
55 | & 9019, 2577, 1405, 2027, 15565, 117, 9355,100781, 20788, |
---|
56 | & 3388, 54866, 11520, 3390, 26963, 32199, 33*0/ |
---|
57 | data fmt/'(27x,a4,a1,a1,i10,7x,a1, (i3,a1), x,i6)'/ |
---|
58 | ivers=0 |
---|
59 | jvers=0 |
---|
60 | if(liste.eq.iopt) go to 50 |
---|
61 | if(liste.eq.ctlg) go to 40 |
---|
62 | C |
---|
63 | C IMPRESSIONS DES FREQUENCES MOLECULES DE LA BANQUE VERSION VERS |
---|
64 | C |
---|
65 | write(isor,3000) vers,pgm,pgm |
---|
66 | 3000 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *', |
---|
67 | &36x,'spectroscopic data bank GEISA',i2.2,31x, |
---|
68 | &'* geisa geisa *'/' *',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/ |
---|
69 | &' * geisa geisa *',98x,'* geisa geisa *'/, |
---|
70 | &1x,17('*'),98x,17('*')) |
---|
71 | liste=iopt |
---|
72 | write(isor,3010) |
---|
73 | 3010 format (/27x,'molecules code ',7x,'isotopes', |
---|
74 | &25x,'number of transitions'/ |
---|
75 | &27x,'--------- ---- ',7x,8('-'),25x,'------ -- -----------'/) |
---|
76 | kt=0 |
---|
77 | do 35 i=1,nmol |
---|
78 | nbtri=nbtr(ivers+i) |
---|
79 | kt=kt+nbtri |
---|
80 | kk=jdeb(i) |
---|
81 | ki=kk+1 |
---|
82 | kf=kk+nn(kk) |
---|
83 | jj=0 |
---|
84 | do 33 j=ki,kf |
---|
85 | if(.not.pp(nn(j)))go to 33 |
---|
86 | jj=jj+1 |
---|
87 | ia(jj)=nn(j) |
---|
88 | 33 continue |
---|
89 | j1=jj-1 |
---|
90 | fmt(26:27)=icod(jj) |
---|
91 | icoli6=42-4*jj+1 |
---|
92 | write(coli6,'(i4.4)')icoli6 |
---|
93 | fmt(37:38)=coli6(3:4) |
---|
94 | C |
---|
95 | C AJOUT DU 5EME et (6eme) CARACTERE DES MOLECULES CH3CL,HCOOH, CLONO2 |
---|
96 | ch5=bl |
---|
97 | ch6=bl |
---|
98 | if(i.eq.34) ch5='l' |
---|
99 | if(i.eq.37) ch5='h' |
---|
100 | if(i.eq.42) ch5='o' |
---|
101 | if(i.eq.42) ch6='2' |
---|
102 | C************RAJOUT DE ,nbtri A LA FIN DE CHAQUE TEST************ |
---|
103 | if(jj.ne.1) |
---|
104 | &write(isor,fmt)code(i),ch5,ch6,i,slash,(ia(j),moins,j=1,j1), |
---|
105 | &ia(jj),slash,nbtri |
---|
106 | if(jj.eq.1) write(isor,fmt) code(i),ch5,ch6,i,slash,ia(jj),slash |
---|
107 | &,nbtri |
---|
108 | 35 continue |
---|
109 | write(isor,3030) kt,kt,vnu(jvers+1),vnu(jvers+2) |
---|
110 | 3030 format(94x,'------'/86x,'total=',i8//27x,'the bank contains ', |
---|
111 | &i8,' lines in the spectral range', |
---|
112 | &2x,'nu1=',f10.4,' and nu2=',f10.4) |
---|
113 | if(liste.eq.oui) write(isor,4000) |
---|
114 | 4000 format(//40x,'(a) wavenumber (cm-1)'/ |
---|
115 | &40x,'(b) intensity (cm molec-1 at 296 k)'/ |
---|
116 | &40x,'(c) collision halfwidth (cm-1 atm-1)'/ |
---|
117 | &40x,'(d) energy of the lower level of the transition (cm-1)'/ |
---|
118 | &40x,'(e) identification of the transition'/ |
---|
119 | &40x,'(f) coefficient for temperature dependence of halfwidth'/ |
---|
120 | &40x,'(g) identification of the isotope'/ |
---|
121 | &40x,'(h) identification of the molecule'/ |
---|
122 | &40x,'(i) geisa internal code for data identification'/) |
---|
123 | go to 100 |
---|
124 | 40 continue |
---|
125 | C |
---|
126 | C LISTE CATALOGUE |
---|
127 | call pgeisa(0.,99999.) |
---|
128 | read (iuni,rec=1) |
---|
129 | &aa1,aa2,anu,n203,nbraie,nbmol,iecr,ifin,ll1,ll2,ll3,ll4 |
---|
130 | c vers=ll3 |
---|
131 | write(isor,3000) vers,pgm,pgm |
---|
132 | ipp=ifin-1 |
---|
133 | if(nu1.eq.-1.) nu1=aa1 |
---|
134 | if(nu2.eq.-1.) nu2=aa2 |
---|
135 | write(isor,4100) nbraie,aa1,aa2,ipp,anu,n203,vers,nu1,nu2 |
---|
136 | 4100 format(//1x,'the bank contains',i8,' raies comprises entre nu1 |
---|
137 | &=',f12.3,' et nu2=',f10.3//' le nombre de records reellement occup |
---|
138 | &ees est de : ',i4,' records'// ' les transitions figurent dans la |
---|
139 | & banque par groupes de ',f4.0,' cm-1 dans un format chaine' |
---|
140 | &//' chaque record comprend au maximum ',i4,' raies'// |
---|
141 | &/1x, 'liste du catalogue d |
---|
142 | &e GEISA',i2.2,3x,'pour les blocks tels que : ',f10.3,' < nu < ', |
---|
143 | &f10.3/1x,29('*')//1x,23x,'block lu',22x,5x,3x,'block precedent', |
---|
144 | & 3x,5x,4x,'block suivant',4x/24x,8('*'),30x,15('*'),12x,13('*') |
---|
145 | &//' numero nombre de raies premiere raie derniere raie nume |
---|
146 | &ro derniere raie numero premiere raie ligne total/grou |
---|
147 | &pe'/1x, '------ |
---|
148 | & ------ -- ----- -------- ---- -------- ---- ------ ------ |
---|
149 | &-- ---- ------ -------- ---- ----- ------------') |
---|
150 | write(isor,4101) nbmol |
---|
151 | 4101 format(' cette banque contient : ',i2,' molecules'/) |
---|
152 | kk=0 |
---|
153 | kkk=0 |
---|
154 | iecr1=int(aa2/anu) + 2 - int(aa1/anu) |
---|
155 | i=0 |
---|
156 | iadr=int(nu1/anu) + 2 - int(aa1/anu) |
---|
157 | 45 continue |
---|
158 | i=i+1 |
---|
159 | ilec=iadr |
---|
160 | read (iuni,rec=ilec) iadr,jadr,k,a1,a2,a3,v1 |
---|
161 | C |
---|
162 | C GEISA90 : 16 -> 29 |
---|
163 | C |
---|
164 | k=k/29 |
---|
165 | write(isor,4200) ilec,k,v1,a3,jadr,a2,iadr,a1,i |
---|
166 | 4200 format(1x,i5,8x,i3,8x,f12.6,3x,f12.6,6x,i5,3x,f12.6,6x,i5,3x,f12.6 |
---|
167 | &,6x,i4) |
---|
168 | kk=kk+k |
---|
169 | kkk=kkk+k |
---|
170 | if(iadr.gt.iecr1) go to 49 |
---|
171 | write(isor,4201) kk |
---|
172 | 4201 format(116x,3x,i9) |
---|
173 | kk=0 |
---|
174 | 49 continue |
---|
175 | if(nu2.gt.a1) go to 45 |
---|
176 | write(isor,4201) kk |
---|
177 | write(isor,4202) kkk |
---|
178 | 4202 format(1x,115x,6x,'------'/1x,113x,'total : ',i6) |
---|
179 | return |
---|
180 | 50 continue |
---|
181 | C |
---|
182 | C LISTE DES OPTIONS |
---|
183 | write(isor,3000) vers,pgm,pgm |
---|
184 | write(isor,5000) |
---|
185 | 5000 format(//51x,'list of available options in GEISA software ', |
---|
186 | &//26x,82('*')) |
---|
187 | write(isor,5005) |
---|
188 | 5005 format(26x,'* &geisa pgm=''anl'',nu1,nu2,dnu,mole,anal / ' |
---|
189 | &,34x,'*'/ |
---|
190 | &26x,'* &geisa pgm=''anl'',nu1,nu2,dnu,mole,isot,histo,nbclas / |
---|
191 | & ',18x,'*'/26x,'*',80x,'*') |
---|
192 | write(isor,5010) |
---|
193 | 5010 format(26x,'* &geisa pgm=''cop'',nu1,nu2 /',53x,'*' |
---|
194 | &/26x,'*',80x,'*') |
---|
195 | write(isor,5015) |
---|
196 | 5015 format(26x,'* &geisa pgm=''cre'',format,juni /',49x, |
---|
197 | &'*'/26x,'*',80x,'*') |
---|
198 | write(isor,5020) |
---|
199 | 5020 format(26x,'* &geisa pgm=''ext'',nu1,nu2,mole,isot,liste,format,ju |
---|
200 | &ni / ',21x,'*'/26x,'*',80x,'*') |
---|
201 | write(isor,5025) |
---|
202 | 5025 format(26x,'* &geisa pgm=''inf'' /',61x,'*') |
---|
203 | write(isor,5026) |
---|
204 | 5026 format(26x,'* &geisa pgm=''inf'',liste=''opt'' / ',44x,'*') |
---|
205 | write(isor,5030) |
---|
206 | 5030 format(26x,'* &geisa pgm=''lst'',nu1,nu2,mole,isot,liste,format,ju |
---|
207 | &ni,iuni / ',15x,'*'/26x,'*',80x,'*') |
---|
208 | write(isor,5035) |
---|
209 | 5035 format(26x,'* &geisa pgm=''trs'',nu1,nu2,mole,iuni /',43x,'*') |
---|
210 | write(isor,5050) |
---|
211 | 5050 format(26x,82('*')) |
---|
212 | liste=' ' |
---|
213 | 100 continue |
---|
214 | return |
---|
215 | end |
---|