C CE PROGRAMME EXTRAIT UN SOUS-FICHIER DE LA BANQUE POUR UN C ENSEMBLE DE TRANSITIONS DE ROTATION-VIBRATION ASSOCIEES A UNE C TRANSITION VIBRATIONNELLE DONNEE D'UNE VARIETE ISOTOPIQUE C C NU1,NU2: LIMITES INF ET SUP DU DOMAINE SPECTRAL ETUDIE C MOLE = MOLECULE DEMANDEE C ISOT = ISOTOPE DEMANDE EXEMPLE ISOT=161 OU 162 ... C LISTE = 'OUI' SORTIE SUR PAPIER DES TRANSIIONS DEMANDEES C = 'NON' (PAR DEFAUT) C UNITE = 'BINAIRE' SORTIE SUR DISQUE OU BANDE MAGNETIQUE EN BINAIRE C = 'FORMATE' SORTIE SUR DISQUE OU BANDE MAGNETIQUE EN FORMATE C PAR DEFAUT PAS DE SORTIE SUR FICHIER C TRS1 : VIBRATION DE DEPART DE LA TRANSITION C TRS2 : VIBRATION D ARRIVEE DE LA TRANSITION C JUNI : UNITE LOGIQUE DU SOUS-FICHIER SPECTRAL DEMANDE C C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * C C MODIF : 06.05.1991 PASSAGE DE 40 MOLECULES A 75 DANS LES COMMON C LAST MODIF : 11.03.1997 PASSAGE DE v(2) en double precision par cor C C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * subroutine list(p,qq,*) C logical*1 qq(1) character*132 fnt character*112 fml,fnl character*80 fmc character*36 trx,ib character*44 fmt character*9 trs1,trs2 character*7 form,bin,unite character*6 fff character*4 mole,ctlg,code,blanc,icodem character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre,liste, & iopt,modif,oui,trans,iref character*2 ikod,icod,icod3,icod4,icod5,icod6 character*1 bl,cs,ch5,ch6,p(300000) integer*2 ia5,x20,vir,a4 integer ia(9),vers,in C C GEISA90 : 16 -> 29 C real nu1,nu2 real*8 aa2,cor,qi2,qj2 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),ib),(v(14),in),(v(15),izot) &,(v(16),imol),(v(17),iver) equivalence (ia(5),ia5) data fnl/'( 19x,1h|,f10. 6 ,1h|,1pd10.3,1h|,0pf5.3,1h|,f10.3,1h|,9 &a4,1h|,f3.2,1h|,i4,1h|,i3,1h|,a4,a1,a1,1h|,a3,1h|,i6)'/ data bl,cs/' ','s'/,coeff/2.479426e+19/,cor/1.d50/ data trx/' '/ C C RECHERCHE DE LA MOLECULE C i1=0 i2=0 call pgeisa(nu1,nu2,*900) ixot=ival C C RECHERCHE DES VALEURS @ BLANC DANS LES TRS1,2 C do 10 i=1,9 if(trs1(i:i).eq.bl) go to 5 i1=i1+1 5 if(trs2(i:i).eq.bl) go to 10 i2=i2+1 10 continue c print *,'i1=',i1,'i2=',i2 if(imole.eq.11) i1=i1+1 ii=i1+i2 c if(mod(ii,2).eq.0.and.ii.ne.0.or.imole.eq.11) go to 11 c write(isor,1010) trs1,trs2 c1010 format(///' *lst* erreur sur la transition vibrationnelle demande c &e : ',a9,5x,a9) 11 continue C C DETERMINATION DE LA NATURE DE LA TRANSITION C I=0 ROTATION PURE C I=1 VIBRATION ROTATION C i=0 imax=i1 if(i2.ge.i1) imax=i2 c print *,'imax=',imax do 12 j=1,imax if(trs1(j:j).eq.trs2(j:j)) go to 12 i=1 12 continue c print *,'i=',i C C PREPARATION DU TITRE C kk=1 do 14 j=1,imole kn=nq(kk) kk=kk+kn+1 14 continue ki=kk-kn kf=kk-1 p(50)=cs if(kn.eq.1) p(50)=bl write(isor,1020) vers,pgm,pgm,nu1,nu2 1020 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, &21x,'* geisa geisa *'/1x,17('*'),98x,17('*')) ch5=bl ch6=bl if(imole.eq.34) ch5='l' if(imole.eq.37) ch5='h' if(imole.eq.42) ch5='o' if(imole.eq.42) ch6='2' C C C TITRE VIBRATION ROTATION C c print *,'i1=',i1,'i2=',i2 do 21 j=1,i1 21 trx(j:j)=trs1(j:j) do 22 j=1,i2 22 trx(18+j:18+j)=trs2(j:j) if(imole.eq.11) trx(18+i1+1:18+i1+1)=trs2(i2:i2) c print *,'i=',i if(i.eq.1) write(isor,1030) trx(1:35),code(imole),ch5,ch6,ixot, &p(50),(nq(j),j=ki,kf) 1030 format( 1x,35x,'vibration-rotation transitions involved in the tra &nsition '/1x,36x,15x,'e''',16x,'e'''''/1x,39x,'transition ', &a35 /1x,40x,'of the molecule ',a4,a1,a1,'/ isotope ',i3/ &1x,41x,'quantum number',a1,' : ',10a4) C C C TITRE ROTATION PURE C nbl=35-i1-4 c print *,'i=',i,'mole=',code(imole),'isot=',ixot c if(i.eq.0)write(isor,1040)(trs1),(bl,j=1,3),trs2(i1+1:i1+1) c &,(bl,j=1,nbl),code(imole),ch5,ch6,ixot,p(50),p(50),(nq(j),j=ki,kf) if(i.eq.0)write(isor,1040) trx(1:35) &,code(imole),ch5,ch6,ixot,p(50),p(50),(nq(j),j=ki,kf) 1040 format( 1x,45x,'pure rotation transitions associated with'/1x,46x, &' the vibrational level ',a35/1x,47x,'of the molecule ' &,a4,a1,a1,'/ isotope ',i3/1x,48x,'nombre',a1, & ' : ',10a4) if(liste.ne.oui) go to 50 write(isor,1050) 1050 format(/1x,18x,101('-')) write(isor,5000) 5000 format(1x,18x,'| (a) | (b) | (c) | (d) |',16x,'(e)' &,17x,'|(f)| (g)|','(h)|',' mole |(i)|') write(isor,4000) 4000 format(1x,18x,101('-')) 50 continue icodem=code(imole) rewind juni nbre=0 icod3=icod(3) icod4=icod(4) icod5=icod(5) icod6=icod(6) qi2=0. 100 continue call lgeisa(v,*200) if(.not.qq(imol).or.izot.ne.ixot) go to 100 C C H2O CO2 O3 N2O CO CH4 O2 NO SO2 NO2 NH3 PH3 go to (51, 52, 51, 58, 55, 54, 53, 54, 51, 51, 52, 58, C HNO3 OH HF HCL HBR HI CLO OCS H2CO C2H6 CH3D C2H2 & 54, 54, 55, 55, 55, 55, 54, 58, 57, 54, 54, 54, C C2H4 GEH4 HCN C3H8 C2N2 C4H2 HC3N HOCL N2 CH3CL H2O2 H2S & 54, 54, 58, 54, 61, 54, 60, 51, 55, 54, 57, 51, C HCOOH COF2 SF6 C3H4 HO2 ClONO2 & 54, 57, 54, 54, 51, 54 ),imol C write(isor,4100) pgm,imol 4100 format(///' *',a3,'* erreur sur le code molecule'/// &9x,'le code molecule ',i4,' n''existe pas dans le fichier'///) C C H2O - O3 - HOCL - H2S - SO2 - NO2 - HO2 C 51 continue i=0 do 261 jj=7,9 i=i+1 trx(i:i)=ib(jj:jj) trx(i+3:i+3)=ib(jj+9:jj+9) 261 continue go to 70 C C CO2 C 52 continue i=0 do 271 jj=5,9 i=i+1 trx(i:i)=ib(jj:jj) trx(i+5:i+5)=ib(jj+9:jj+9) 271 continue go to 70 C C O2 C 53 continue i=0 do 281 jj=8,9 i=i+1 trx(i:i)=ib(jj:jj) trx(i+2:i+2)=ib(jj+9:jj+9) 281 continue go to 70 C C CH4 - CH3D - CH3Cl - C2H6 - HNO3 - HCOOH - SF6 - NO - OH - ClO - C2H2 C C3H8 - C3H4 - C2H4 - C4H2 - ClONO2 C 54 continue iecar=8 i=0 do 291 jj=2,9 if(ib(jj:jj).eq.bl) then iecar=iecar-1 else i=i+1 trx(i:i)=ib(jj:jj) endif 291 continue i=0 do 292 jj=2,9 if(ib(9+jj:9+jj).eq.bl) go to 292 i=i+1 trx(iecar+i:iecar+i)=ib(9+jj:9+jj) 292 continue go to 70 C C CO - HF - HCL - HBR - HI - N2 C 55 continue trx(1:1)=ib(9:9) trx(2:2)=ib(18:18) go to 70 C C H2CO - H2O2 - COF2 C 57 continue i=0 do 301 jj=4,9 i=i+1 trx(i:i)=ib(jj:jj) trx(i+6:i+6)=ib(jj+9:jj+9) 301 continue go to 70 C C N2O - OCS - HCN C 58 continue i=0 do 311 jj=6,9 i=i+1 trx(i:i)=ib(jj:jj) trx(i+4:i+4)=ib(jj+9:jj+9) 311 continue go to 70 C C HC3N C 60 continue do 511 jj=3,8 trx(jj-2:jj-2)=ib(jj:jj) trx(4+jj:4+jj)=ib(8+jj:8+jj) 511 continue go to 70 C C C2N2 C 61 continue do 515 jj=3,9 trx(jj-2:jj-2)=ib(jj:jj) trx(5+jj:5+jj)=ib(14+jj:14+jj) 515 continue go to 70 C C C3H8 C 63 continue do 519 jj=3,16 trx(jj-2:jj-2)=ib(jj:jj) 519 continue do 520 jj=19,30 trx(jj-4:jj-4)=ib(jj:jj) 520 continue go to 70 70 continue if (i1.eq.i2) then do 71 j=1,i1 if(trs1(j:j).ne.trx(j:j)) go to 100 if(trs2(j:j).ne.trx(j+i1:j+i1)) go to 100 71 continue else do 72 j=1,i1 72 if(trs1(j:j).ne.trx(j:j)) go to 100 do 73 j=1,i2 73 if(trs2(j:j).ne.trx(j+i1:j+i1)) go to 100 endif nbre=nbre+1 aa2=v(2)*(1./cor) qi2=qi2+aa2 fnl(15:16)=icod4 fmc(7:8)=icod4 if(a.ge.1000.) go to 74 fnl(15:16)=icod6 fmc(7:8)=icod6 go to 75 74 continue if(a.ge.10000.) go to 75 fnl(15:16)=icod5 fmc(7:8)=icod5 75 continue aa2=aa(2)*(1/cor) if(liste.eq.oui) & write(isor,fnl) aa(1),aa2,aa(3),aa(4),ia,in,izot,imol, &icodem,ch5,ch6,iver,nbre if(mode) 100,120,105 105 continue C C ECRITURE SUR FICHIER (FORMATE) C CBB write(juni,fmc) aa,ia,in,izot,imol,(v(j),j=17,24) 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 CBB write(juni) aa,ia,in,izot,imol,(v(j),j=17,29) aa2=aa(2)*(1/cor) 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,18x,'|',10x,'dans l''intervalle spectral demande il n''y & a aucune pareille transition', 19x,'|') if(liste.eq.oui) write(isor,4200) 4200 format(1x,18x,101('-')//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(/1x,19x,'end of output on binary file',i3) if(mode.eq.1) write(isor,7601) juni 7601 format(/1x,19x,'end of output on coded file',i3) qj2=qi2*coeff if(nbre.ne.0) write(isor,7502) nbre,qi2,qj2 7502 format(/1x,19x,'total number of transitions : ',i12/ &1x,26x,'intensity sum : ',1pd12.3,' cm molec-1'/ &1x,26x,' or : ',1pd12.3,' cm-2 atm-1') 900 continue return 1 end