1 | C CE PROGRAMM EXTRAIT UN SOUS FICHIER DU CONTENU DE LA BANQUE |
---|
2 | C DANS UN DOMAINE SPECTRAL DONNE |
---|
3 | C IL PERMET DE LISTER,DE COPIER SUR DISQUE OU BANDE |
---|
4 | C UNE ZONE COMPRISE ENTRE NU1 ET NU2 POUR UNE OU PLUSIEURS |
---|
5 | C MOLECULES,UNE OU PLUSIEURS VARIETES ISOTOPIQUES |
---|
6 | C NU1,NU2 LIMITES INF ET SUP DU DOMAINE SPECTRAL ETUDIE |
---|
7 | C LISTE='OUI' SORTIE SUR PAPIER DE 1 OU PLUSIEURS MOLECULES |
---|
8 | C 1 OU PLUSIEURS VARIETES ISOTOPIQUES |
---|
9 | C ='NON' (PAR DEFAUT) |
---|
10 | C UNITE='BINAIRE' SORTIE SUR DISQUE OU BANDE MAGNETIQUE EN BINAIRE |
---|
11 | C UNITE='FORMATE' SORTIE SUR DISQUE OU BANDE MAGNETIQUE EN FORMATE |
---|
12 | C PAR DEFAUT PAS DE SORTIE SUR FICHIER |
---|
13 | C MOLE= SUITE DES MOLECULES DEMANDEES EXEMPLE MOLE='H2O' OU 'CO2' |
---|
14 | C ISOT= SUITE DES ISOTOPES DEMANDES EXEMPLE ISOT=161,162,666... |
---|
15 | C IUNI UNITE LOGIQUE CORRESPONDANT AU FICHIER SPECTRAL |
---|
16 | C JUNI UNITE LOGIQUE DU SOUS-FICHIER SPECTRAL DEMANDE |
---|
17 | C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -* |
---|
18 | C |
---|
19 | C MODIF : 06.05.1991 PASSAGE DE 40 A 75 MOLECULES DANS LES COMMON |
---|
20 | C LAST MODIF : 11.03.1997 passage en double precision de v(2) par |
---|
21 | C un facteur de corr=1.d50 |
---|
22 | C |
---|
23 | C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -* |
---|
24 | subroutine extr(p,qq,*) |
---|
25 | C |
---|
26 | character*132 fnt |
---|
27 | character*112 fml |
---|
28 | character*80 fmc,fb |
---|
29 | character*35 mkod |
---|
30 | character*44 fmt |
---|
31 | character*9 trs1,trs2 |
---|
32 | character*7 form,bin,unite |
---|
33 | character*6 fff |
---|
34 | character*4 mole,ctlg,code,blanc,mcode |
---|
35 | character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre,liste, |
---|
36 | & oui,iopt,modif,trans,ver,sla |
---|
37 | character*2 ikod,icod,icod3,icod4,icod5,icod6 |
---|
38 | character*1 moins,slash,bl,mcod(4) |
---|
39 | logical*1 p(1),qq(1) |
---|
40 | integer ia(9),in,vers |
---|
41 | C |
---|
42 | C GEISA90 : 16 -> 29 |
---|
43 | C |
---|
44 | real nu1,nu2 |
---|
45 | CBB 11.03 element correctif de v(2) |
---|
46 | real*8 aa2,cor |
---|
47 | CBB fin |
---|
48 | real aa(4),v(29) |
---|
49 | C |
---|
50 | common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste |
---|
51 | common/p2/ mole(75),isot(100),nbi(75),nbt(75),iopt,ctlg,trans, |
---|
52 | & trs1,trs2 |
---|
53 | common/p3/ imole,iran,ival,pgm,ianl,iext,itrs,ilst,icop,info,icre |
---|
54 | common/p4/ nmol,knmol,ksot,kksot,ntab,nhist,kp,lre,form,bin,modif |
---|
55 | common/p5/ code(75),nn(150),nq(150),ikod(18),icod(18),jdeb(75) |
---|
56 | common/ffff/ fml,fmc,fmt,fnt,fff |
---|
57 | common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui |
---|
58 | C |
---|
59 | equivalence (a,aa(1),v(1)),(v(5),ia(1)),(v(15),izot),(v(16),imol) |
---|
60 | equivalence (v(14),in),(mcode,mcod(1)),(mkod,ikod(1)),(v(17),ver) |
---|
61 | C |
---|
62 | data moins,slash/'-','/'/,bl/' '/,sla/' /'/,cor/1.d50/ |
---|
63 | C |
---|
64 | C P(1 A 1000) EST MIS A .FALSE. SI L'ISOTOPE N'EST PAS DEMANDE |
---|
65 | C ET A .TRUE. SI L'ISOTOPE EST DEMANDE |
---|
66 | C |
---|
67 | C |
---|
68 | C IMPRESSION,PERFORATION OU ECRITURE SUR FICHIER DES RESULTATS |
---|
69 | C |
---|
70 | call pgeisa(nu1,nu2,*900) |
---|
71 | C |
---|
72 | C IMPRESSION DU TITRE |
---|
73 | C |
---|
74 | write(isor,3000) vers,pgm,pgm,nu1,nu2 |
---|
75 | 3000 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *', |
---|
76 | &31x,'consultation of GEISA',i2.2,' contents ',33x, |
---|
77 | &'* geisa geisa *'/' *',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/ |
---|
78 | &' * geisa geisa *',20x,'spectral interval (cm-1) ', |
---|
79 | &' nu1=',f10.3,3x,'nu2=',f10.3, |
---|
80 | &20x,'* geisa geisa *'/1x,17('*'),98x,17('*')) |
---|
81 | write(isor,3500) |
---|
82 | 3500 format( 44x,'extraction of the following '/ |
---|
83 | &44x,' molecules and isotopes '/) |
---|
84 | do 35 i=1,nmol |
---|
85 | if(.not.qq(i)) go to 35 |
---|
86 | sla(1:1)=bl |
---|
87 | sla(2:2)=bl |
---|
88 | if(i.eq.34) sla(1:1)='l' |
---|
89 | if(i.eq.37) sla(1:1)='h' |
---|
90 | if(i.eq.42) sla(1:1)='o' |
---|
91 | if(i.eq.42) sla(2:2)='2' |
---|
92 | kk=jdeb(i) |
---|
93 | ki=kk+1 |
---|
94 | kf=kk+nn(kk) |
---|
95 | jj=0 |
---|
96 | do 33 j=ki,kf |
---|
97 | if(.not.p(nn(j)))go to 33 |
---|
98 | jj=jj+1 |
---|
99 | ia(jj)=nn(j) |
---|
100 | 33 continue |
---|
101 | C |
---|
102 | C IMPRESSION DES MOLECULES ET ISOTOPES DEMANDES |
---|
103 | C |
---|
104 | j1=jj-1 |
---|
105 | fmt(13:14)=icod(jj) |
---|
106 | if(jj.ne.1) |
---|
107 | &write(isor,fmt)code(i),sla ,(ia(j),moins,j=1,j1),ia(jj),slash |
---|
108 | if(jj.eq.1) write(isor,fmt) code(i),sla ,ia(jj),slash |
---|
109 | sla(1:1)=bl |
---|
110 | sla(2:2)=bl |
---|
111 | 35 continue |
---|
112 | if(liste.ne.oui) go to 50 |
---|
113 | write(isor,3600) |
---|
114 | 3600 format(/1x,128('-')) |
---|
115 | write(isor,5000) |
---|
116 | 5000 format(' | (a) | (b) | (c) | (d) |',16x,'(e)',17x, |
---|
117 | &'|(f)|(g)| h|(i)|',13x,'molecules',13x,'|') |
---|
118 | write(isor,4000) |
---|
119 | 4000 format(1x,128('-')) |
---|
120 | 50 continue |
---|
121 | rewind juni |
---|
122 | nbre = 0 |
---|
123 | icod3=icod(3) |
---|
124 | icod4=icod(4) |
---|
125 | icod5=icod(5) |
---|
126 | icod6=icod(6) |
---|
127 | 100 continue |
---|
128 | call lgeisa(v,*200) |
---|
129 | if(.not.qq(imol).or..not.p(izot)) go to 100 |
---|
130 | nbre=nbre+1 |
---|
131 | fml(15:16)=icod4 |
---|
132 | fmc(6:7) =icod4 |
---|
133 | if(a.ge.1000.) go to 53 |
---|
134 | fml(15:16)=icod6 |
---|
135 | fmc(6:7) =icod6 |
---|
136 | go to 55 |
---|
137 | 53 continue |
---|
138 | if(a.ge.10000.) go to 55 |
---|
139 | fml(15:16)=icod5 |
---|
140 | fmc(6:7) =icod5 |
---|
141 | 55 continue |
---|
142 | if(liste.ne.oui) go to 56 |
---|
143 | mcode=code(imol) |
---|
144 | C |
---|
145 | C NE PAS DEPASSER LES 34 CARACTERES DE MKOD |
---|
146 | C |
---|
147 | jmol=min0(30,imol) |
---|
148 | do 551 j=1,4 |
---|
149 | mkod(jmol+j-1:jmol+j-1)=mcod(j) |
---|
150 | 551 continue |
---|
151 | CBB correction de v(2) |
---|
152 | aa2=aa(2)*(1/cor) |
---|
153 | CBB fin |
---|
154 | mkod(jmol+4:jmol+4)=bl |
---|
155 | mkod(jmol+5:jmol+5)=bl |
---|
156 | if(imol.eq.34) mkod(jmol+4:jmol+4)='l' |
---|
157 | if(imol.eq.37) mkod(jmol+4:jmol+4)='h' |
---|
158 | if(imol.eq.42) mkod(jmol+4:jmol+4)='0' |
---|
159 | if(imol.eq.42) mkod(jmol+5:jmol+5)='2' |
---|
160 | write(isor,fml ) aa(1),aa2,aa(3),aa(4),ia,in,izot, |
---|
161 | &imol,ver,mkod,nbre |
---|
162 | do 552 j=1,4 |
---|
163 | mkod(jmol+j-1:jmol+j-1)=bl |
---|
164 | 552 continue |
---|
165 | mkod(jmol+4:jmol+4)=bl |
---|
166 | mkod(jmol+5:jmol+5)=bl |
---|
167 | 56 continue |
---|
168 | CBB correction de v(2) |
---|
169 | aa2=aa(2)*(1/cor) |
---|
170 | CBB fin |
---|
171 | if(mode) 100,120,105 |
---|
172 | 105 continue |
---|
173 | C |
---|
174 | C ECRITURE SUR FICHIER (FORMATE) |
---|
175 | C |
---|
176 | write(juni,fmc ) aa(1),aa2,aa(3),aa(4),ia,in,izot,imol, |
---|
177 | &(v(j),j=17,24) |
---|
178 | go to 100 |
---|
179 | 120 continue |
---|
180 | C |
---|
181 | C * ECRITURE SUR FICHIER (NON FORMATE) |
---|
182 | C |
---|
183 | write(juni) aa(1),aa2,aa(3),aa(4),ia,in,izot,imol, |
---|
184 | &(v(j),j=17,24) |
---|
185 | go to 100 |
---|
186 | 200 continue |
---|
187 | if(nbre.eq.0) write(isor,7400) |
---|
188 | 7400 format(1x,'|',37x,'dans l''intervalle demande il n''y a aucune par |
---|
189 | &eille raie',34x,'|') |
---|
190 | if(liste.eq.oui) write(isor,4200) |
---|
191 | 4200 format(1x,127('-')//,40x,'(a) wavenumber (cm-1)'/ |
---|
192 | &40x,'(b) intensity (cm molec-1 at 296 k)'/ |
---|
193 | &40x,'(c) collision halfwidth (cm-1 atm-1)'/ |
---|
194 | &40x,'(d) energy of the lower level of the transition (cm-1)'/ |
---|
195 | &40x,'(e) identification of the transition'/ |
---|
196 | &40x,'(f) coefficient for temperature dependence of halfwidth'/ |
---|
197 | &40x,'(g) identification of the isotope'/ |
---|
198 | &40x,'(h) identification of the molecule'/ |
---|
199 | &40x,'(i) geisa internal code for data identification'/) |
---|
200 | if(nbre.eq.0) go to 900 |
---|
201 | if(mode.ge.0) rewind juni |
---|
202 | if(mode.eq.0) write(isor,7501) juni |
---|
203 | 7501 format(/' end of output on binary file ',i3) |
---|
204 | if(mode.eq.1) write(isor,7601) juni |
---|
205 | 7601 format(/' end of output on coded file',i3) |
---|
206 | if(nbre.ne.0) write(isor,7502) nbre |
---|
207 | 7502 format(/1x,'total number of transitions : ',i7) |
---|
208 | 900 continue |
---|
209 | return 1 |
---|
210 | end |
---|