| 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 |
|---|
