C C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * C IMPRESSIONS DES RESULTATS DU PROGRAMME ** ANL ** C SUBROUTINES APPELEES : HISTOG C C C IMPRESSIONS DES TABLEAUX DES FREQUENCES C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * C subroutine impanl(tab,anu1,anu2,impr,ymoyd,ymaxd,alf,qq,ibase) C logical*1 jdh(75),qq(1) integer tab(1),hist(nbclas,1),msot(20),nsot(20),vers real nu1,nu2,pas(2),alf(1 ) CBB passage en double precision real*8 ymoyd(1 ),ymaxd(1 ),yymoyd real ymoy(1 ),ymax(1 ),xmin,xmax character*9 trs1,trs2 character*7 form,bin character*4 tir,code,ctlg,mole,blanc character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre, & iinf,oui,liste,iopt,modif,trans character*2 ikod,icod character*1 ba,bl,ast,ch5,ch6 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/inteh/ incr,pas1,pmax common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui C equivalence (jdh(1),msot(1)) C data bl,ast,tir /' ','*','----'/,icar/45/,iinf/'inf'/ C if(mode.eq.1) pgm=iinf if(impr.eq.0) write(isor,902) vers,pgm,pgm 902 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *',34x, &' geisa',i2.2,' contents ',35x,'* geisa geisa *'/1x, &'*',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/1x, &'* geisa geisa *',38x,'analysis per molecule',39x, &'* geisa geisa *'/1x,17('*'),98x,17('*')/) if(impr.eq.0.and.dnu.gt.0.) write(isor,903) nu1,nu2,dnu 903 format(37x,'nu1=',f10.3,' at nu2=',f10.3,' by step of dnu=' &,f12.6/) molj=0 do 12 j=1,ntab molj=molj+tab(j) 12 continue write(isor,1000) anu1,anu2,molj 1000 format(/' spectral interval (cm-1) nu1=', f09.3,2x,'nu2=',f10.3, &' transitions=',i7) impr=impr+1 kk=1 knn=0 do 24 j=1,nmol if(.not.qq(j)) go to 22 C C AJOUT DU 5EME CARACTERE DES MOLES CH3CL ET HCOOH L(CODE 211) C H(CODE 200) ch5=bl ch6=bl if(j.eq.34) ch5='l' if(j.eq.37) ch5='h' if(j.eq.42) ch5='o' if(j.eq.42) ch6='2' kn=nn(kk) ki=kk+1 kf=kk+kn kx=0 C C ELIMINATION DES ISOTOPES DE FREQUENCE NULLE C MSOT ET NSOT TABLEAUX CONTENANT POUR UNE MOLECULE DONNEE C LES CODES ISOTOPES ET LES FREQUENCES DES ISOTOPES C ORDONNES ET A VALEURS NON NULLES C molj=0 do 202 jk=ki,kf nnt=tab(nn(jk)) nnsot=nn(jk) C C C DANS LE TABLEAU TAB LES INDICES 951 A 990 SONT RESERVES POUR C LES ISOTOPES DUPLIQUES C C BB 06.05.97 cas de C2H4 2 isotopes dupliques, le 2eme indice=ibase=950 C C H2O CO2 O3 N2O CO CH4 O2 NO SO2 NO2 NH3 PH3 go to (541, 541,541, 541, 541, 541, 541, 541, 509, 510, 541, 541, C HNO3 OH HF HCL HBR HI CLO OCS H2CO C2H6 CH3D C2H2 & 541, 541, 541, 541, 517, 518, 519, 541, 541, 541, 541, 541, C C2H4 GEH4 HCN C3H8 C2N2 C4H2 HC3N HOCL N2 CH3CL H2O2 H2S & 525, 526, 541, 528, 541, 530, 531, 541, 541, 541, 541, 536, C HCOOH COF2 SF6 C3H4 HO2 CLONO2 & 541, 541, 541, 541, 537, 541 ),j C C SO2 509 continue if(nnsot.eq.626) nnt=tab(ibase+j) go to 541 C C NO2 510 continue if(nnsot.eq.646) nnt=tab(ibase+j) go to 541 C C HBR 517 continue if(nnsot.eq. 19) nnt=tab(ibase+j) go to 541 C C HI 518 continue if(nnsot.eq. 17) nnt=tab(ibase+j) go to 541 C C CLO 519 continue if(nnsot.eq. 56) nnt=tab(ibase+j) go to 541 C C C2H4 525 continue if(nnsot.eq.211) nnt=tab(ibase+j) if(nnsot.eq.311) nnt=tab(ibase) go to 541 C C GEH4 526 continue if(nnsot.eq.411) nnt=tab(ibase+j) go to 541 C C C3H8 528 continue if(nnsot.eq.221) nnt=tab(ibase+j) go to 541 C C C4H2 530 continue if(nnsot.eq.211) nnt=tab(ibase+j) go to 541 C C HC3N 531 continue if(nnsot.eq.124) nnt=tab(ibase+j) go to 541 C C H2S 536 continue if(nnsot.eq.131) nnt=tab(ibase+j) go to 541 C C HO2 537 continue if(nnsot.eq.166) nnt=tab(ibase+j) go to 541 C 541 continue if(nnt.eq.0) go to 202 kx=kx+1 msot(kx)=nn(jk) nsot(kx)=nnt molj=molj+nnt 202 continue if(molj.eq.0) go to 22 alfmoy=alf(j)/molj CBB yymoy=ymoy(j)/molj yymoyd=ymoyd(j)/molj kn=min0(11,kx) kkn=max0(kn,knn) write(isor,1001)(tir,jj=1,kkn) 1001 format(1x,55(1h-),11(a4,3h---)) write(isor,1002) code(j),ch5,ch6,j,(msot(jj),jj=1,kn) 1002 format(' | moy.i | max.i |alpha.moy| ',a4,a1,a1,'|(',i2,') iso &topes |',11(i5,' |')) write(isor,1003) yymoyd,ymaxd(j),alfmoy,molj,(nsot(jj),jj=1,kn) 1003 format(' |',1pd9.3,'|',1pd9.3,'|',1pe9.3,'|',i7,'|number of lines| &',11(i6,'|')) if(kx.le.11) go to 70 C C AJOUTER LES IMPRESSIONS SUIVANTES DANS LE CAS OU KX>11 C kn=kn+1 write(isor,1005)(nsot(jj),jj=kn,kx) 1005 format(31x,'|',5(i6,1h|)) go to 75 70 continue 75 continue knn=kn 22 kk=kk+nn(kk)+1 24 continue write(isor,1001)(tir,jj=1,knn) return C C C IMPRESSIONS DES HISTOGRAMMES C entry imph(hist,xmin,xmax,pas,anu1,anu2,impr) C ch5=bl ch6=bl if(imole.eq.34) ch5='l' if(imole.eq.37) ch5='h' if(imole.eq.42) ch6='o' if(imole.eq.42) ch6='2' pas(1)=pas1 lk=nbclas if(impr.ne.0) go to 31 C IF(IVAL.EQ.IMOLE) WRITE(ISOR,904) VERS,CODE(IMOLE) C &'* GEISA *',98X,'* GEISA *'/1X, if(ival.eq.imole) &write(isor,904) vers,pgm,pgm,code(imole),ch5,ch6 904 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *',34x, &'geisa',i2.2,' cumulative frequencies ',32x,'* geisa geisa *'/ &1x,'*',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/1x, &'* geisa geisa *',41x,'molecule /',a4,a1,a1,'/',40x, &'* geisa geisa *'/1x,17('*'),98x,17('*')/) C IF(IVAL.NE.IMOLE) WRITE(ISOR,905) VERS,CODE(IMOLE),IVAL C &'* GEISA *',98X,'* GEISA *'/1X, if(ival.ne.imole) &write(isor,905) vers,pgm,pgm,code(imole),ch5,ch6,ival 905 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *',34x, &'geisa',i2.2,' cumulative frequencies ',32x,'* geisa geisa *'/ &1x,'*',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/1x, &'* geisa geisa *',34x,'molecule /',a4,a1,a1,'/ isotope /', &i3,'/',33x,'* geisa geisa *'/1x,17('*'),98x,17('*')/) if(dnu.gt.0.) write(isor,903) nu1,nu2,dnu 31 continue ki=1 kf=2 if(khist.eq.1) kf=1 if(khist.eq.2) ki=2 do 35 k=ki,kf mm=0 do 26 j=1,lk ijk=hist(j,k) mm=max0(mm,ijk) 26 continue if(mm.ne.0) go to 27 impr=impr+1 if(imole.eq.ival) & write(isor,900) anu1,anu2,code(imole),ch5,ch6 if(imole.ne.ival) & write(isor,901) anu1,anu2,ival,code(imole),ch5,ch6 900 format(///' *anl* in the spectral interval ',f10.3,'< nu <', &f10.3,' the molecule ',a4,a1,a1,' does not exist'///) 901 format(///' *anl* in the spectral interval ',f10.3,'< nu <', &f10.3,' the isotope ',i4,' of ',a4,a1,a1,' does not exist'///) return 27 continue ech=mm/float(icar) C C CALCUL DES HAUTEURS DES CLASSES DE HIST C do 30 j=1,lk i=hist(j ,k)/ech hist(j,k+2)=min0(i,icar) 30 continue 35 continue lk1=lk+1 impr=impr+1 if(khist.eq.-1) go to 50 k=khist v=xmax if(k.eq.1) v=pmax if(k.eq.1.and.ival.eq.imole) write(isor,906) anu1,anu2,code(imole) &,ch5,ch6 906 format(/' spectral interval (cm-1) nu1=',f10.3,5x,'nu2=',f10.3/ &1x,' classes effectives intensity - ',a4,a1,a1/) if(k.eq.2.and.ival.eq.imole) write(isor,907) anu1,anu2,code(imole) &,ch5,ch6 907 format(/' spectral interval (cm-1) nu1=',f10.3,5x,'nu2=',f10.3/ &1x,' classes effectives ground level - ',a4,a1,a1/) if(k.eq.1.and.ival.ne.imole) &write(isor,9061) anu1,anu2,code(imole),ch5,ch6,ival 9061 format(/' spectral intarval (cm-1) nu1=',f10.3,5x,'nu2=',f10.3/ &1x,' classes effectives intensity - ',a4,a1,a1,'/',i3/) if(k.eq.2.and.ival.ne.imole) &write(isor,9071) anu1,anu2,code(imole),ch5,ch6,ival 9071 format(/' spectral interval l(cm-1) nu1=',f10.3,5x,'nu2=',f10.3/ &1x,' classes effectives ground level - ',a4,a1,a1,'/',i3/) if(k.eq.1) lk1=lk do 40 j=1,lk1 call histog(hist,pas(k),xmin,k,lk,j,ih,ihh,v,vv,ba,bl,ast) write(isor,2000) vv,ihh,(ba,jj=1,ih) 2000 format(1h , 1pd10.4,i7,3h|*|,45a1) 40 continue return 50 continue if(ival.eq.imole) write(isor,908) &anu1,anu2,anu1,anu2,code(imole),ch5,ch6,code(imole),ch5,ch6 908 format(/' intervalle spectral(cm-1) nu1=',f10.3,5x,'nu2=',f10.3, &6x,'spectral interval (cm-1) nu1=',f10.3,5x,'nu2=',f10.3/ &1x,' classes effectives intensity - ',a4,a1,a1,24x ,' classes & effectives ground level - ',a4,a1,a1/) if(ival.ne.imole) write(isor,909) &anu1,anu2,anu1,anu2,code(imole),ch5,ch6,ival,code(imole),ch5,ch6, &ival 909 format(/' intervalle spectral(cm-1) nu1=',f10.3,5x,'nu2=',f10.3, &6x,'spectral interval (cm-1) nu1=',f10.3,5x,'nu2=',f10.3/ &1x,' classes effectives intensity - ',a4,a1,a1,'/',i3,20x, &' classes effectives ground level - ',a4,a1,a1,'/',i3/) v=pmax v1=xmax do 60 j=1,lk icon=1 call histog(hist,pas(1),xmin,icon,lk,j,ih,ihh,v,vv,ba,bl,ast) write(isor,2000) vv,ihh,(ba,jj=1,ih) icon=2 call histog(hist,pas(2),xmin,icon,lk,j,ih1,ihh1,v1,vv1,ba,bl,ast) write(isor,2001) vv1,ihh1,(ba,jj=1,ih1) 2001 format(1x,67x,1pd10.4,i7,3h|*|,45a1) 60 continue call histog(hist,pas(2),xmin,2,lk,lk+1,ih1,ihh1,v1,vv1,ba,bl,ast) vv=vv*pas1 write(isor,2002) vv,vv1,ihh1,(ba,jj=1,ih1) 2002 format(1x,1pd10.4,6x,4h0|*|,47x,1pd10.4,i7,3h|*|,45a1) return end