| 1 | C CE PROGRAMME EXTRAIT UN SOUS-FICHIER DE LA BANQUE POUR UN |
|---|
| 2 | C ENSEMBLE DE TRANSITIONS DE ROTATION-VIBRATION ASSOCIEES A UNE |
|---|
| 3 | C TRANSITION VIBRATIONNELLE DONNEE D'UNE VARIETE ISOTOPIQUE |
|---|
| 4 | C |
|---|
| 5 | C NU1,NU2: LIMITES INF ET SUP DU DOMAINE SPECTRAL ETUDIE |
|---|
| 6 | C MOLE = MOLECULE DEMANDEE |
|---|
| 7 | C ISOT = ISOTOPE DEMANDE EXEMPLE ISOT=161 OU 162 ... |
|---|
| 8 | C LISTE = 'OUI' SORTIE SUR PAPIER DES TRANSIIONS DEMANDEES |
|---|
| 9 | C = 'NON' (PAR DEFAUT) |
|---|
| 10 | C UNITE = 'BINAIRE' SORTIE SUR DISQUE OU BANDE MAGNETIQUE EN BINAIRE |
|---|
| 11 | C = 'FORMATE' SORTIE SUR DISQUE OU BANDE MAGNETIQUE EN FORMATE |
|---|
| 12 | C PAR DEFAUT PAS DE SORTIE SUR FICHIER |
|---|
| 13 | C TRS1 : VIBRATION DE DEPART DE LA TRANSITION |
|---|
| 14 | C TRS2 : VIBRATION D ARRIVEE DE LA TRANSITION |
|---|
| 15 | C JUNI : UNITE LOGIQUE DU SOUS-FICHIER SPECTRAL DEMANDE |
|---|
| 16 | C |
|---|
| 17 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * |
|---|
| 18 | C |
|---|
| 19 | C MODIF : 06.05.1991 PASSAGE DE 40 MOLECULES A 75 DANS LES COMMON |
|---|
| 20 | C LAST MODIF : 11.03.1997 PASSAGE DE v(2) en double precision par cor |
|---|
| 21 | C |
|---|
| 22 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * |
|---|
| 23 | subroutine list(p,qq,*) |
|---|
| 24 | C |
|---|
| 25 | logical*1 qq(1) |
|---|
| 26 | character*132 fnt |
|---|
| 27 | character*112 fml,fnl |
|---|
| 28 | character*80 fmc |
|---|
| 29 | character*36 trx,ib |
|---|
| 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,icodem |
|---|
| 35 | character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre,liste, |
|---|
| 36 | & iopt,modif,oui,trans,iref |
|---|
| 37 | character*2 ikod,icod,icod3,icod4,icod5,icod6 |
|---|
| 38 | character*1 bl,cs,ch5,ch6,p(300000) |
|---|
| 39 | integer*2 ia5,x20,vir,a4 |
|---|
| 40 | integer ia(9),vers,in |
|---|
| 41 | C |
|---|
| 42 | C GEISA90 : 16 -> 29 |
|---|
| 43 | C |
|---|
| 44 | real nu1,nu2 |
|---|
| 45 | real*8 aa2,cor,qi2,qj2 |
|---|
| 46 | real aa(4),v(29) |
|---|
| 47 | C |
|---|
| 48 | common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste |
|---|
| 49 | common/p2/ mole(75),isot(100),nbi(75),nbt(75),iopt,ctlg,trans, |
|---|
| 50 | & trs1,trs2 |
|---|
| 51 | common/p3/ imole,iran,ival,pgm,ianl,iext,itrs,ilst,icop,info,icre |
|---|
| 52 | common/p4/ nmol,knmol,ksot,kksot,ntab,nhist,kp,lre,form,bin,modif |
|---|
| 53 | common/p5/ code(75),nn(150),nq(150),ikod(18),icod(18),jdeb(75) |
|---|
| 54 | common/ffff/ fml,fmc,fmt,fnt,fff |
|---|
| 55 | common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui |
|---|
| 56 | C |
|---|
| 57 | equivalence (a,aa(1),v(1)),(v(5),ia(1),ib),(v(14),in),(v(15),izot) |
|---|
| 58 | &,(v(16),imol),(v(17),iver) |
|---|
| 59 | equivalence (ia(5),ia5) |
|---|
| 60 | data fnl/'( 19x,1h|,f10. 6 ,1h|,1pd10.3,1h|,0pf5.3,1h|,f10.3,1h|,9 |
|---|
| 61 | &a4,1h|,f3.2,1h|,i4,1h|,i3,1h|,a4,a1,a1,1h|,a3,1h|,i6)'/ |
|---|
| 62 | data bl,cs/' ','s'/,coeff/2.479426e+19/,cor/1.d50/ |
|---|
| 63 | data trx/' '/ |
|---|
| 64 | C |
|---|
| 65 | C RECHERCHE DE LA MOLECULE |
|---|
| 66 | C |
|---|
| 67 | i1=0 |
|---|
| 68 | i2=0 |
|---|
| 69 | call pgeisa(nu1,nu2,*900) |
|---|
| 70 | ixot=ival |
|---|
| 71 | C |
|---|
| 72 | C RECHERCHE DES VALEURS @ BLANC DANS LES TRS1,2 |
|---|
| 73 | C |
|---|
| 74 | do 10 i=1,9 |
|---|
| 75 | if(trs1(i:i).eq.bl) go to 5 |
|---|
| 76 | i1=i1+1 |
|---|
| 77 | 5 if(trs2(i:i).eq.bl) go to 10 |
|---|
| 78 | i2=i2+1 |
|---|
| 79 | 10 continue |
|---|
| 80 | c print *,'i1=',i1,'i2=',i2 |
|---|
| 81 | if(imole.eq.11) i1=i1+1 |
|---|
| 82 | ii=i1+i2 |
|---|
| 83 | c if(mod(ii,2).eq.0.and.ii.ne.0.or.imole.eq.11) go to 11 |
|---|
| 84 | c write(isor,1010) trs1,trs2 |
|---|
| 85 | c1010 format(///' *lst* erreur sur la transition vibrationnelle demande |
|---|
| 86 | c &e : ',a9,5x,a9) |
|---|
| 87 | 11 continue |
|---|
| 88 | C |
|---|
| 89 | C DETERMINATION DE LA NATURE DE LA TRANSITION |
|---|
| 90 | C I=0 ROTATION PURE |
|---|
| 91 | C I=1 VIBRATION ROTATION |
|---|
| 92 | C |
|---|
| 93 | i=0 |
|---|
| 94 | imax=i1 |
|---|
| 95 | if(i2.ge.i1) imax=i2 |
|---|
| 96 | c print *,'imax=',imax |
|---|
| 97 | do 12 j=1,imax |
|---|
| 98 | if(trs1(j:j).eq.trs2(j:j)) go to 12 |
|---|
| 99 | i=1 |
|---|
| 100 | 12 continue |
|---|
| 101 | c print *,'i=',i |
|---|
| 102 | C |
|---|
| 103 | C PREPARATION DU TITRE |
|---|
| 104 | C |
|---|
| 105 | kk=1 |
|---|
| 106 | do 14 j=1,imole |
|---|
| 107 | kn=nq(kk) |
|---|
| 108 | kk=kk+kn+1 |
|---|
| 109 | 14 continue |
|---|
| 110 | ki=kk-kn |
|---|
| 111 | kf=kk-1 |
|---|
| 112 | p(50)=cs |
|---|
| 113 | if(kn.eq.1) p(50)=bl |
|---|
| 114 | write(isor,1020) vers,pgm,pgm,nu1,nu2 |
|---|
| 115 | 1020 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *', |
|---|
| 116 | &31x,'consultation of GEISA',i2.2,' contents ',33x, |
|---|
| 117 | &'* geisa geisa *'/' *',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/ |
|---|
| 118 | &' * geisa geisa *',20x,'spectral interval (cm-1) ', |
|---|
| 119 | &' nu1=',f10.3,3x,'nu2=',f10.3, |
|---|
| 120 | &21x,'* geisa geisa *'/1x,17('*'),98x,17('*')) |
|---|
| 121 | ch5=bl |
|---|
| 122 | ch6=bl |
|---|
| 123 | if(imole.eq.34) ch5='l' |
|---|
| 124 | if(imole.eq.37) ch5='h' |
|---|
| 125 | if(imole.eq.42) ch5='o' |
|---|
| 126 | if(imole.eq.42) ch6='2' |
|---|
| 127 | C |
|---|
| 128 | C |
|---|
| 129 | C TITRE VIBRATION ROTATION |
|---|
| 130 | C |
|---|
| 131 | c print *,'i1=',i1,'i2=',i2 |
|---|
| 132 | do 21 j=1,i1 |
|---|
| 133 | 21 trx(j:j)=trs1(j:j) |
|---|
| 134 | do 22 j=1,i2 |
|---|
| 135 | 22 trx(18+j:18+j)=trs2(j:j) |
|---|
| 136 | if(imole.eq.11) trx(18+i1+1:18+i1+1)=trs2(i2:i2) |
|---|
| 137 | c print *,'i=',i |
|---|
| 138 | if(i.eq.1) write(isor,1030) trx(1:35),code(imole),ch5,ch6,ixot, |
|---|
| 139 | &p(50),(nq(j),j=ki,kf) |
|---|
| 140 | 1030 format( 1x,35x,'vibration-rotation transitions involved in the tra |
|---|
| 141 | &nsition '/1x,36x,15x,'e''',16x,'e'''''/1x,39x,'transition ', |
|---|
| 142 | &a35 /1x,40x,'of the molecule ',a4,a1,a1,'/ isotope ',i3/ |
|---|
| 143 | &1x,41x,'quantum number',a1,' : ',10a4) |
|---|
| 144 | C |
|---|
| 145 | C |
|---|
| 146 | C TITRE ROTATION PURE |
|---|
| 147 | C |
|---|
| 148 | nbl=35-i1-4 |
|---|
| 149 | c print *,'i=',i,'mole=',code(imole),'isot=',ixot |
|---|
| 150 | c if(i.eq.0)write(isor,1040)(trs1),(bl,j=1,3),trs2(i1+1:i1+1) |
|---|
| 151 | c &,(bl,j=1,nbl),code(imole),ch5,ch6,ixot,p(50),p(50),(nq(j),j=ki,kf) |
|---|
| 152 | if(i.eq.0)write(isor,1040) trx(1:35) |
|---|
| 153 | &,code(imole),ch5,ch6,ixot,p(50),p(50),(nq(j),j=ki,kf) |
|---|
| 154 | 1040 format( 1x,45x,'pure rotation transitions associated with'/1x,46x, |
|---|
| 155 | &' the vibrational level ',a35/1x,47x,'of the molecule ' |
|---|
| 156 | &,a4,a1,a1,'/ isotope ',i3/1x,48x,'nombre',a1, |
|---|
| 157 | & ' : ',10a4) |
|---|
| 158 | if(liste.ne.oui) go to 50 |
|---|
| 159 | write(isor,1050) |
|---|
| 160 | 1050 format(/1x,18x,101('-')) |
|---|
| 161 | write(isor,5000) |
|---|
| 162 | 5000 format(1x,18x,'| (a) | (b) | (c) | (d) |',16x,'(e)' |
|---|
| 163 | &,17x,'|(f)| (g)|','(h)|',' mole |(i)|') |
|---|
| 164 | write(isor,4000) |
|---|
| 165 | 4000 format(1x,18x,101('-')) |
|---|
| 166 | 50 continue |
|---|
| 167 | icodem=code(imole) |
|---|
| 168 | rewind juni |
|---|
| 169 | nbre=0 |
|---|
| 170 | icod3=icod(3) |
|---|
| 171 | icod4=icod(4) |
|---|
| 172 | icod5=icod(5) |
|---|
| 173 | icod6=icod(6) |
|---|
| 174 | qi2=0. |
|---|
| 175 | 100 continue |
|---|
| 176 | call lgeisa(v,*200) |
|---|
| 177 | if(.not.qq(imol).or.izot.ne.ixot) go to 100 |
|---|
| 178 | C |
|---|
| 179 | C H2O CO2 O3 N2O CO CH4 O2 NO SO2 NO2 NH3 PH3 |
|---|
| 180 | go to (51, 52, 51, 58, 55, 54, 53, 54, 51, 51, 52, 58, |
|---|
| 181 | C HNO3 OH HF HCL HBR HI CLO OCS H2CO C2H6 CH3D C2H2 |
|---|
| 182 | & 54, 54, 55, 55, 55, 55, 54, 58, 57, 54, 54, 54, |
|---|
| 183 | C C2H4 GEH4 HCN C3H8 C2N2 C4H2 HC3N HOCL N2 CH3CL H2O2 H2S |
|---|
| 184 | & 54, 54, 58, 54, 61, 54, 60, 51, 55, 54, 57, 51, |
|---|
| 185 | C HCOOH COF2 SF6 C3H4 HO2 ClONO2 |
|---|
| 186 | & 54, 57, 54, 54, 51, 54 ),imol |
|---|
| 187 | C |
|---|
| 188 | write(isor,4100) pgm,imol |
|---|
| 189 | 4100 format(///' *',a3,'* erreur sur le code molecule'/// |
|---|
| 190 | &9x,'le code molecule ',i4,' n''existe pas dans le fichier'///) |
|---|
| 191 | C |
|---|
| 192 | C H2O - O3 - HOCL - H2S - SO2 - NO2 - HO2 |
|---|
| 193 | C |
|---|
| 194 | 51 continue |
|---|
| 195 | i=0 |
|---|
| 196 | do 261 jj=7,9 |
|---|
| 197 | i=i+1 |
|---|
| 198 | trx(i:i)=ib(jj:jj) |
|---|
| 199 | trx(i+3:i+3)=ib(jj+9:jj+9) |
|---|
| 200 | 261 continue |
|---|
| 201 | go to 70 |
|---|
| 202 | C |
|---|
| 203 | C CO2 |
|---|
| 204 | C |
|---|
| 205 | 52 continue |
|---|
| 206 | i=0 |
|---|
| 207 | do 271 jj=5,9 |
|---|
| 208 | i=i+1 |
|---|
| 209 | trx(i:i)=ib(jj:jj) |
|---|
| 210 | trx(i+5:i+5)=ib(jj+9:jj+9) |
|---|
| 211 | 271 continue |
|---|
| 212 | go to 70 |
|---|
| 213 | C |
|---|
| 214 | C O2 |
|---|
| 215 | C |
|---|
| 216 | 53 continue |
|---|
| 217 | i=0 |
|---|
| 218 | do 281 jj=8,9 |
|---|
| 219 | i=i+1 |
|---|
| 220 | trx(i:i)=ib(jj:jj) |
|---|
| 221 | trx(i+2:i+2)=ib(jj+9:jj+9) |
|---|
| 222 | 281 continue |
|---|
| 223 | go to 70 |
|---|
| 224 | C |
|---|
| 225 | C CH4 - CH3D - CH3Cl - C2H6 - HNO3 - HCOOH - SF6 - NO - OH - ClO - C2H2 |
|---|
| 226 | C C3H8 - C3H4 - C2H4 - C4H2 - ClONO2 |
|---|
| 227 | C |
|---|
| 228 | 54 continue |
|---|
| 229 | iecar=8 |
|---|
| 230 | i=0 |
|---|
| 231 | do 291 jj=2,9 |
|---|
| 232 | if(ib(jj:jj).eq.bl) then |
|---|
| 233 | iecar=iecar-1 |
|---|
| 234 | else |
|---|
| 235 | i=i+1 |
|---|
| 236 | trx(i:i)=ib(jj:jj) |
|---|
| 237 | endif |
|---|
| 238 | 291 continue |
|---|
| 239 | i=0 |
|---|
| 240 | do 292 jj=2,9 |
|---|
| 241 | if(ib(9+jj:9+jj).eq.bl) go to 292 |
|---|
| 242 | i=i+1 |
|---|
| 243 | trx(iecar+i:iecar+i)=ib(9+jj:9+jj) |
|---|
| 244 | 292 continue |
|---|
| 245 | go to 70 |
|---|
| 246 | C |
|---|
| 247 | C CO - HF - HCL - HBR - HI - N2 |
|---|
| 248 | C |
|---|
| 249 | 55 continue |
|---|
| 250 | trx(1:1)=ib(9:9) |
|---|
| 251 | trx(2:2)=ib(18:18) |
|---|
| 252 | go to 70 |
|---|
| 253 | C |
|---|
| 254 | C H2CO - H2O2 - COF2 |
|---|
| 255 | C |
|---|
| 256 | 57 continue |
|---|
| 257 | i=0 |
|---|
| 258 | do 301 jj=4,9 |
|---|
| 259 | i=i+1 |
|---|
| 260 | trx(i:i)=ib(jj:jj) |
|---|
| 261 | trx(i+6:i+6)=ib(jj+9:jj+9) |
|---|
| 262 | 301 continue |
|---|
| 263 | go to 70 |
|---|
| 264 | C |
|---|
| 265 | C N2O - OCS - HCN |
|---|
| 266 | C |
|---|
| 267 | 58 continue |
|---|
| 268 | i=0 |
|---|
| 269 | do 311 jj=6,9 |
|---|
| 270 | i=i+1 |
|---|
| 271 | trx(i:i)=ib(jj:jj) |
|---|
| 272 | trx(i+4:i+4)=ib(jj+9:jj+9) |
|---|
| 273 | 311 continue |
|---|
| 274 | go to 70 |
|---|
| 275 | C |
|---|
| 276 | C HC3N |
|---|
| 277 | C |
|---|
| 278 | 60 continue |
|---|
| 279 | do 511 jj=3,8 |
|---|
| 280 | trx(jj-2:jj-2)=ib(jj:jj) |
|---|
| 281 | trx(4+jj:4+jj)=ib(8+jj:8+jj) |
|---|
| 282 | 511 continue |
|---|
| 283 | go to 70 |
|---|
| 284 | C |
|---|
| 285 | C C2N2 |
|---|
| 286 | C |
|---|
| 287 | 61 continue |
|---|
| 288 | do 515 jj=3,9 |
|---|
| 289 | trx(jj-2:jj-2)=ib(jj:jj) |
|---|
| 290 | trx(5+jj:5+jj)=ib(14+jj:14+jj) |
|---|
| 291 | 515 continue |
|---|
| 292 | go to 70 |
|---|
| 293 | C |
|---|
| 294 | C C3H8 |
|---|
| 295 | C |
|---|
| 296 | 63 continue |
|---|
| 297 | do 519 jj=3,16 |
|---|
| 298 | trx(jj-2:jj-2)=ib(jj:jj) |
|---|
| 299 | 519 continue |
|---|
| 300 | do 520 jj=19,30 |
|---|
| 301 | trx(jj-4:jj-4)=ib(jj:jj) |
|---|
| 302 | 520 continue |
|---|
| 303 | go to 70 |
|---|
| 304 | 70 continue |
|---|
| 305 | if (i1.eq.i2) then |
|---|
| 306 | do 71 j=1,i1 |
|---|
| 307 | if(trs1(j:j).ne.trx(j:j)) go to 100 |
|---|
| 308 | if(trs2(j:j).ne.trx(j+i1:j+i1)) go to 100 |
|---|
| 309 | 71 continue |
|---|
| 310 | else |
|---|
| 311 | do 72 j=1,i1 |
|---|
| 312 | 72 if(trs1(j:j).ne.trx(j:j)) go to 100 |
|---|
| 313 | do 73 j=1,i2 |
|---|
| 314 | 73 if(trs2(j:j).ne.trx(j+i1:j+i1)) go to 100 |
|---|
| 315 | endif |
|---|
| 316 | nbre=nbre+1 |
|---|
| 317 | aa2=v(2)*(1./cor) |
|---|
| 318 | qi2=qi2+aa2 |
|---|
| 319 | fnl(15:16)=icod4 |
|---|
| 320 | fmc(7:8)=icod4 |
|---|
| 321 | if(a.ge.1000.) go to 74 |
|---|
| 322 | fnl(15:16)=icod6 |
|---|
| 323 | fmc(7:8)=icod6 |
|---|
| 324 | go to 75 |
|---|
| 325 | 74 continue |
|---|
| 326 | if(a.ge.10000.) go to 75 |
|---|
| 327 | fnl(15:16)=icod5 |
|---|
| 328 | fmc(7:8)=icod5 |
|---|
| 329 | 75 continue |
|---|
| 330 | aa2=aa(2)*(1/cor) |
|---|
| 331 | if(liste.eq.oui) |
|---|
| 332 | & write(isor,fnl) aa(1),aa2,aa(3),aa(4),ia,in,izot,imol, |
|---|
| 333 | &icodem,ch5,ch6,iver,nbre |
|---|
| 334 | if(mode) 100,120,105 |
|---|
| 335 | 105 continue |
|---|
| 336 | C |
|---|
| 337 | C ECRITURE SUR FICHIER (FORMATE) |
|---|
| 338 | C |
|---|
| 339 | CBB write(juni,fmc) aa,ia,in,izot,imol,(v(j),j=17,24) |
|---|
| 340 | write(juni,fmc) aa(1),aa2,aa(3),aa(4),ia,in,izot,imol, |
|---|
| 341 | &(v(j),j=17,24) |
|---|
| 342 | go to 100 |
|---|
| 343 | 120 continue |
|---|
| 344 | C |
|---|
| 345 | C ECRITURE SUR FICHIER (NON FORMATE) |
|---|
| 346 | C |
|---|
| 347 | CBB write(juni) aa,ia,in,izot,imol,(v(j),j=17,29) |
|---|
| 348 | aa2=aa(2)*(1/cor) |
|---|
| 349 | write(juni) aa(1),aa2,aa(3),aa(4),ia,in,izot,imol, |
|---|
| 350 | &(v(j),j=17,24) |
|---|
| 351 | go to 100 |
|---|
| 352 | 200 continue |
|---|
| 353 | if(nbre.eq.0) write(isor,7400) |
|---|
| 354 | 7400 format(1x,18x,'|',10x,'dans l''intervalle spectral demande il n''y |
|---|
| 355 | & a aucune pareille transition', 19x,'|') |
|---|
| 356 | if(liste.eq.oui) write(isor,4200) |
|---|
| 357 | 4200 format(1x,18x,101('-')//40x,'(a) wavenumber (cm-1)'/ |
|---|
| 358 | &40x,'(b) intensity (cm molec-1 at 296 k)'/ |
|---|
| 359 | &40x,'(c) collision halfwidth (cm-1 atm-1)'/ |
|---|
| 360 | &40x,'(d) energy of the lower level of the transition (cm-1)'/ |
|---|
| 361 | &40x,'(e) identification of the transition'/ |
|---|
| 362 | &40x,'(f) coefficient for temperature dependence of halfwidth'/ |
|---|
| 363 | &40x,'(g) identification of the isotope'/ |
|---|
| 364 | &40x,'(h) identification of the molecule'/ |
|---|
| 365 | &40x,'(i) geisa internal code for data identification'/) |
|---|
| 366 | if(nbre.eq.0) go to 900 |
|---|
| 367 | if(mode.ge.0) rewind juni |
|---|
| 368 | if(mode.eq.0) write(isor,7501) juni |
|---|
| 369 | 7501 format(/1x,19x,'end of output on binary file',i3) |
|---|
| 370 | if(mode.eq.1) write(isor,7601) juni |
|---|
| 371 | 7601 format(/1x,19x,'end of output on coded file',i3) |
|---|
| 372 | qj2=qi2*coeff |
|---|
| 373 | if(nbre.ne.0) write(isor,7502) nbre,qi2,qj2 |
|---|
| 374 | 7502 format(/1x,19x,'total number of transitions : ',i12/ |
|---|
| 375 | &1x,26x,'intensity sum : ',1pd12.3,' cm molec-1'/ |
|---|
| 376 | &1x,26x,' or : ',1pd12.3,' cm-2 atm-1') |
|---|
| 377 | 900 continue |
|---|
| 378 | return 1 |
|---|
| 379 | end |
|---|
