C CE PROGRAMM EXTRAIT UN SOUS FICHIER DU CONTENU DE LA BANQUE C DANS UN DOMAINE SPECTRAL DONNE C IL PERMET DE LISTER,DE COPIER SUR DISQUE OU BANDE C UNE ZONE COMPRISE ENTRE NU1 ET NU2 POUR UNE OU PLUSIEURS C MOLECULES,UNE OU PLUSIEURS VARIETES ISOTOPIQUES C NU1,NU2 LIMITES INF ET SUP DU DOMAINE SPECTRAL ETUDIE C LISTE='OUI' SORTIE SUR PAPIER DE 1 OU PLUSIEURS MOLECULES C 1 OU PLUSIEURS VARIETES ISOTOPIQUES C ='NON' (PAR DEFAUT) C UNITE='BINAIRE' SORTIE SUR DISQUE OU BANDE MAGNETIQUE EN BINAIRE C UNITE='FORMATE' SORTIE SUR DISQUE OU BANDE MAGNETIQUE EN FORMATE C PAR DEFAUT PAS DE SORTIE SUR FICHIER C MOLE= SUITE DES MOLECULES DEMANDEES EXEMPLE MOLE='H2O' OU 'CO2' C ISOT= SUITE DES ISOTOPES DEMANDES EXEMPLE ISOT=161,162,666... C IUNI UNITE LOGIQUE CORRESPONDANT AU FICHIER SPECTRAL C JUNI UNITE LOGIQUE DU SOUS-FICHIER SPECTRAL DEMANDE C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -* C C MODIF : 06.05.1991 PASSAGE DE 40 A 75 MOLECULES DANS LES COMMON C LAST MODIF : 11.03.1997 passage en double precision de v(2) par C un facteur de corr=1.d50 C C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -* subroutine extr(p,qq,*) C character*132 fnt character*112 fml character*80 fmc,fb character*35 mkod character*44 fmt character*9 trs1,trs2 character*7 form,bin,unite character*6 fff character*4 mole,ctlg,code,blanc,mcode character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre,liste, & oui,iopt,modif,trans,ver,sla character*2 ikod,icod,icod3,icod4,icod5,icod6 character*1 moins,slash,bl,mcod(4) logical*1 p(1),qq(1) integer ia(9),in,vers C C GEISA90 : 16 -> 29 C real nu1,nu2 CBB 11.03 element correctif de v(2) real*8 aa2,cor CBB fin real aa(4),v(29) C common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste common/p2/ mole(75),isot(100),nbi(75),nbt(75),iopt,ctlg,trans, & trs1,trs2 common/p3/ imole,iran,ival,pgm,ianl,iext,itrs,ilst,icop,info,icre common/p4/ nmol,knmol,ksot,kksot,ntab,nhist,kp,lre,form,bin,modif common/p5/ code(75),nn(150),nq(150),ikod(18),icod(18),jdeb(75) common/ffff/ fml,fmc,fmt,fnt,fff common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui C equivalence (a,aa(1),v(1)),(v(5),ia(1)),(v(15),izot),(v(16),imol) equivalence (v(14),in),(mcode,mcod(1)),(mkod,ikod(1)),(v(17),ver) C data moins,slash/'-','/'/,bl/' '/,sla/' /'/,cor/1.d50/ C C P(1 A 1000) EST MIS A .FALSE. SI L'ISOTOPE N'EST PAS DEMANDE C ET A .TRUE. SI L'ISOTOPE EST DEMANDE C C C IMPRESSION,PERFORATION OU ECRITURE SUR FICHIER DES RESULTATS C call pgeisa(nu1,nu2,*900) C C IMPRESSION DU TITRE C write(isor,3000) vers,pgm,pgm,nu1,nu2 3000 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *', &31x,'consultation of GEISA',i2.2,' contents ',33x, &'* geisa geisa *'/' *',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/ &' * geisa geisa *',20x,'spectral interval (cm-1) ', &' nu1=',f10.3,3x,'nu2=',f10.3, &20x,'* geisa geisa *'/1x,17('*'),98x,17('*')) write(isor,3500) 3500 format( 44x,'extraction of the following '/ &44x,' molecules and isotopes '/) do 35 i=1,nmol if(.not.qq(i)) go to 35 sla(1:1)=bl sla(2:2)=bl if(i.eq.34) sla(1:1)='l' if(i.eq.37) sla(1:1)='h' if(i.eq.42) sla(1:1)='o' if(i.eq.42) sla(2:2)='2' kk=jdeb(i) ki=kk+1 kf=kk+nn(kk) jj=0 do 33 j=ki,kf if(.not.p(nn(j)))go to 33 jj=jj+1 ia(jj)=nn(j) 33 continue C C IMPRESSION DES MOLECULES ET ISOTOPES DEMANDES C j1=jj-1 fmt(13:14)=icod(jj) if(jj.ne.1) &write(isor,fmt)code(i),sla ,(ia(j),moins,j=1,j1),ia(jj),slash if(jj.eq.1) write(isor,fmt) code(i),sla ,ia(jj),slash sla(1:1)=bl sla(2:2)=bl 35 continue if(liste.ne.oui) go to 50 write(isor,3600) 3600 format(/1x,128('-')) write(isor,5000) 5000 format(' | (a) | (b) | (c) | (d) |',16x,'(e)',17x, &'|(f)|(g)| h|(i)|',13x,'molecules',13x,'|') write(isor,4000) 4000 format(1x,128('-')) 50 continue rewind juni nbre = 0 icod3=icod(3) icod4=icod(4) icod5=icod(5) icod6=icod(6) 100 continue call lgeisa(v,*200) if(.not.qq(imol).or..not.p(izot)) go to 100 nbre=nbre+1 fml(15:16)=icod4 fmc(6:7) =icod4 if(a.ge.1000.) go to 53 fml(15:16)=icod6 fmc(6:7) =icod6 go to 55 53 continue if(a.ge.10000.) go to 55 fml(15:16)=icod5 fmc(6:7) =icod5 55 continue if(liste.ne.oui) go to 56 mcode=code(imol) C C NE PAS DEPASSER LES 34 CARACTERES DE MKOD C jmol=min0(30,imol) do 551 j=1,4 mkod(jmol+j-1:jmol+j-1)=mcod(j) 551 continue CBB correction de v(2) aa2=aa(2)*(1/cor) CBB fin mkod(jmol+4:jmol+4)=bl mkod(jmol+5:jmol+5)=bl if(imol.eq.34) mkod(jmol+4:jmol+4)='l' if(imol.eq.37) mkod(jmol+4:jmol+4)='h' if(imol.eq.42) mkod(jmol+4:jmol+4)='0' if(imol.eq.42) mkod(jmol+5:jmol+5)='2' write(isor,fml ) aa(1),aa2,aa(3),aa(4),ia,in,izot, &imol,ver,mkod,nbre do 552 j=1,4 mkod(jmol+j-1:jmol+j-1)=bl 552 continue mkod(jmol+4:jmol+4)=bl mkod(jmol+5:jmol+5)=bl 56 continue CBB correction de v(2) aa2=aa(2)*(1/cor) CBB fin if(mode) 100,120,105 105 continue C C ECRITURE SUR FICHIER (FORMATE) C write(juni,fmc ) aa(1),aa2,aa(3),aa(4),ia,in,izot,imol, &(v(j),j=17,24) go to 100 120 continue C C * ECRITURE SUR FICHIER (NON FORMATE) C write(juni) aa(1),aa2,aa(3),aa(4),ia,in,izot,imol, &(v(j),j=17,24) go to 100 200 continue if(nbre.eq.0) write(isor,7400) 7400 format(1x,'|',37x,'dans l''intervalle demande il n''y a aucune par &eille raie',34x,'|') if(liste.eq.oui) write(isor,4200) 4200 format(1x,127('-')//,40x,'(a) wavenumber (cm-1)'/ &40x,'(b) intensity (cm molec-1 at 296 k)'/ &40x,'(c) collision halfwidth (cm-1 atm-1)'/ &40x,'(d) energy of the lower level of the transition (cm-1)'/ &40x,'(e) identification of the transition'/ &40x,'(f) coefficient for temperature dependence of halfwidth'/ &40x,'(g) identification of the isotope'/ &40x,'(h) identification of the molecule'/ &40x,'(i) geisa internal code for data identification'/) if(nbre.eq.0) go to 900 if(mode.ge.0) rewind juni if(mode.eq.0) write(isor,7501) juni 7501 format(/' end of output on binary file ',i3) if(mode.eq.1) write(isor,7601) juni 7601 format(/' end of output on coded file',i3) if(nbre.ne.0) write(isor,7502) nbre 7502 format(/1x,'total number of transitions : ',i7) 900 continue return 1 end