c$DEBUG c-------------------------------------------------------------------------- c ASRGLE c c Conversion of .asr data into a string of points that will result c in a stick diagram when connected with lines c c - Lines are sorted in frequency (necessary eg. for output from ASQASR) c - Lines closer in frequency than RES are coalesced (this is not c carried out if filtering is used) c C ver. 27.08/97 ----- Zbigniew KISIEL ----- C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- C C Modification history: C c 29.10.95: addition of optional frequency and J-range filtering C 30.10.95: do not apply the RES criterion on filtered operation c 26.03.97: minor modifications to deal with disappearing output c 22.08.97: output modified to avoid backtracking over drawn stick c 25.08.97: possibility of subtracting excitation frequency c 27.08.97: separation of filtering and blending C_____________________________________________________________________________ c implicit real*8 (a-h,o-z) parameter (maxlin=5000) COMMON /FRBLK/freqs(maxlin) COMMON /LNUMS/iwork(maxlin) integer*2 nstart,nlines,iwork real*8 inten,intens(maxlin),intlin(maxlin),sblen(maxlin), * fblen(maxlin),fcent character*40 filin,filout character*79 linein equivalence (intens(1),sblen(1)) c res=0.000001d0 base=-.1 nout=0 c WRITE(*,5500) 5500 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | ASRGLE - Conversion of .ASR output into data suita', * 'ble for producing',T79,'|'/ * ' | a stick diagram with GLE',T79,'|'/ * ' |',76(1H_),'|'/' version 27.08/1997',T64,'Zbigniew KISIEL'/) c 1 write(*,'(1x//'' input file name: '',$)') read(*,'(a)')filin IF(FILIN.EQ.'END'.OR.FILIN.EQ.'end')STOP open(2,file=filin,err=1) c 2 write(*,'(1x//'' output file name: '',$)') read(*,'(a)')filout open(3,file=filout,err=2,status='unknown') C C...Blending/Input filters C 70 write(*,'(1x/'' Blend lines (0/1) ? '',$)') read(*,'(i1)',err=70)iblend if(iblend.lt.0.or.iblend.gt.1)goto 70 c 170 write(*,'(1x/'' Use input filters (0/1) ? '',$)') read(*,'(i1)',err=170)ifilt if(ifilt.lt.0.or.ifilt.gt.1)goto 170 c if(ifilt.eq.1)then 71 write(*,'(1x//'' Frequency limits: '',$)') read(*,*,err=71)fmin,fmax if(fmax.le.fmin)goto 71 72 write(*,'(1x//'' J limits: '',$)') read(*,*,err=72)jmin,jmax if(jmax.lt.jmin)goto 72 73 write(*,'(1x//'' Frequency for DeltaF: '',$)') read(*,*,err=73)fcent if(fcent.lt.0.0d0)goto 73 endif c c...Go through the .ASR file and fish-out spectral lines c nlines=0 write(*,'(1x//'' Now reading line:'',1x,i5,$)')nlines c 3 read(2,'(a)',end=51)linein if(linein(8:8).ne.'.')goto 3 read(linein(1:24),50,err=3,end=51)freq,inten 50 format(f14.6,e10.3) if(ifilt.eq.1)then read(linein(40:42),'(i3)',err=3,end=51)j if(j.lt.jmin.or.j.gt.jmax)goto 3 if(freq.lt.fmin.or.freq.gt.fmax)goto 3 endif nlines=nlines+1 freqs(nlines)=freq intens(nlines)=inten iwork(nlines)=nlines if((nlines/10)*10.eq.nlines)write(*,'(i5,$)')nlines goto 3 c c...sort the input according to frequency c 51 write(*,'(1x//i10,'' lines read in altogether'')')nlines nstart=1 call sorth(nstart,nlines) do 52 i=1,nlines ii=iwork(i) intlin(i)=intens(ii) 52 continue c c...blend lines c if(iblend.eq.1)then nblend=0 flast=freqs(1) slast=intens(1) do 53 i=2,nlines-1 if(freqs(i)-flast.gt.res)then nblend=nblend+1 fblen(nblend)=flast sblen(nblend)=slast flast=freqs(i) slast=intens(i) else flast=(flast+freqs(i))/2.d0 slast=slast+intens(i) endif 53 continue c if(freqs(nlines)-flast.gt.res)then nblend=nblend+1 fblen(nblend)=flast sblen(nblend)=slast nblend=nblend+1 fblen(nblend)=freqs(nlines) sblen(nblend)=intens(nlines) else nblend=nblend+1 fblen(nblend)=(flast+freqs(i))/2.d0 sblen(nblend)=slast+intens(i) endif endif c c c...Output c nout=0 write(*,'(1x/i10,'' lines readied for output'')')nlines write(*,'(1x//'' Now writing line:'',1x,i5,$)')nout c c...without filter c if(iblend.eq.1)then do 54 i=1,nblend freq=dabs(fblen(i)-fcent) inten=sblen(i) write(3,4)freq,base write(3,4)freq,inten write(3,'(f11.4,a)')freq,' *' 4 format(F11.4,1PE11.3) nout=nout+1 if((nout/10)*10.eq.nout)write(*,'(i5,$)')nout 54 continue c c...with filter c else flast=0.d0 do 84 i=1,nlines freq=dabs(freqs(i)-fcent) inten=intlin(i) if(freq.eq.flast.and.inten.le.slast)goto 84 flast=freq slast=inten write(3,4)freq,base write(3,4)freq,inten write(3,'(f11.4,a)')freq,' *' nout=nout+1 if((nout/10)*10.eq.nout)write(*,'(i5,$)')nout 84 continue endif c close(3) close(2) GOTO 1 c stop end C C_____________________________________________________________________________ C SUBROUTINE SORTH(NSTART,N) c c This routine is based on the SORT2 'heapsort' routine from Numerical c Recipes and sorts the quantities in vector WK from WK(NSTART) to WK(N) C in ascending order of magnitude and also accordingly rearranges vector C IPT of pointers to original positions of sorted quantities. c PARAMETER (MAXLIN=5000) c COMMON /FRBLK/WK COMMON /LNUMS/IPT INTEGER*2 IPT(MAXLIN),IIPT,L,N,NSTART,I,J,IR REAL*8 WK(MAXLIN),WWK C L=N/2+1 IR=N 10 CONTINUE IF(L.GT.NSTART)THEN L=L-1 WWK=WK(L) IIPT=IPT(L) ELSE WWK=WK(IR) IIPT=IPT(IR) WK(IR)=WK(1) IPT(IR)=IPT(1) IR=IR-1 IF(IR.EQ.NSTART)THEN WK(1)=WWK IPT(1)=IIPT RETURN ENDIF ENDIF I=L J=L+L 20 IF(J.LE.IR)THEN IF(J.LT.IR)THEN IF(WK(J).LT.WK(J+1))J=J+1 ENDIF IF(WWK.LT.WK(J))THEN WK(I)=WK(J) IPT(I)=IPT(J) I=J J=J+J ELSE J=IR+1 ENDIF GO TO 20 ENDIF WK(I)=WWK IPT(I)=IIPT GO TO 10 c RETURN END C C_____________________________________________________________________________ C_____________________________________________________________________________