$debug C----------------------------------------------------------------------------- c c P I S F I T - PIckett Sort (Sorting of .FIT results file from Pickett's c program SPFIT) c C All occurrences of deviations of fit greater than 2*sigma and 3*sigma c are located, alternatively all deviations greater than a given c threshold. c C ver. 1/95 ----- Zbigniew KISIEL ----- C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, 02-668 Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C_________________________/-------------------------------------------------- parameter (maxbuf=640) c real*8 f(maxbuf) integer*2 jj,i(maxbuf),nexcl,ncut character*100 L2(maxbuf),l3(maxbuf),lexcl(maxbuf),line character*100 lcut(maxbuf) real*4 ratio2(maxbuf),ratio3(maxbuf),ratioe(maxbuf) real*4 ratioc(maxbuf) character*30 filin common /lbuf/l2/lbuf1/l3/lex/lexcl/lcu/lcut common /freq/f common /point/i common /lin/line c WRITE(*,3344) 3344 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | PISFIT - Sorting of .FIT file for Pickett''s ', * 'program SPFIT',T79,'|'/ * ' |',76(1H_),'|'/' version 1/1995',T64,'Zbigniew KISIEL'/) c 2 write(*,1)' Name of input file:' 1 format(1x//1x,a,' ',$) read(*,'(a)',err=2)filin open(3,file=filin,err=2) 81 write(*,80) 80 format(1x/' Mode of operation: 0 = standard'/ * ' 1 = custom cutoff'//, * 40x,'.... ',$) read(*,'(i5)',err=81)modflg if(modflg.lt.0.or.modflg.gt.1)goto 81 if(modflg.eq.1)then ncut=0 82 write(*,83) 83 format(1x/' Cutoff, as a multiple of sigma: ',$) read(*,*,err=82)cut endif c c...Go through lines and transfer lines of interest to buffers c n3sigm=0 n2sigm=0 nexcl=0 c 5 read(3,'(a)',end=6,err=5)line if(line(6:6).ne.':')goto 5 c read(line(81:90),'(f10.3)',err=5)error read(line(71:80),'(f10.3)',err=5)diff read(line(91:100),'(f10.3)',err=5)esterr c if(modflg.eq.0)then c if(int(error).eq.90)then nexcl=nexcl+1 error=error-90.d0 lexcl(nexcl)=line RATIOE(NEXCL)=DIFF/ERROR goto 5 endif c if(int(error).eq.900)then error=error-900.d0 nexcl=nexcl+1 lexcl(nexcl)=line RATIOE(NEXCL)=DIFF/ERROR if(nexcl.eq.maxbuf)goto 66 goto 5 endif c if(int(error).eq.990)then error=error-990.d0 nexcl=nexcl+1 lexcl(nexcl)=line RATIOE(NEXCL)=DIFF/ERROR if(nexcl.eq.maxbuf)goto 66 goto 5 endif c if(abs(diff/error).lt.2.d0)goto 5 c if(abs(diff/error).ge.3.d0)then n3sigm=n3sigm+1 l3(n3sigm)=line RATIO3(N3SIGM)=DIFF/ERROR if(n3sigm.eq.maxbuf)goto 66 goto 5 endif c if(abs(diff/error).lt.3.d0)then n2sigm=n2sigm+1 l2(n2sigm)=line RATIO2(N2SIGM)=DIFF/ERROR if(n2sigm.eq.maxbuf)goto 66 goto 5 endif c else if(abs(diff/error).ge.cut)then ncut=ncut+1 lcut(ncut)=line RATIOc(Ncut)=DIFF/ERROR if(ncut.eq.maxbuf)then write(*,*)ncut,maxbuf goto 66 endif goto 5 endif goto 5 endif c 66 write(*,67)line(1:5),char(7) 67 format(1x/' Buffer for lines filled, only got to line: ',2A/) c c...Results c 6 if(modflg.eq.0)then write(*,7)n3sigm,n2sigm,nexcl 7 format(1x/1x,i5,' lines with obs-calc > 3*sigma'/ * 1x,i5,' lines with obs-calc <3*sigma >2*sigma'/ * 1x,i5,' lines excluded'/) else write(*,17)ncut,cut 17 format(1x/1x,i5,' lines with obs-calc > ',f5.1,' sigma'/) endif close(3) c C...OUTPUT C open(4,file='pisfit.out',status='unknown') c if(n3sigm.gt.0)then write(4,50)n3sigm 50 format(1x/i4,' Lines with obs-calc deviations greater than', * ' 3*sigma:'//' o-c/err ', * ' obs o-c error calc.error'/) do 61 n=1,n3sigm write(4,56)l3(n)(2:31),ratio3(n),l3(n)(43:54),l3(n)(71:78), * l3(n)(81:88),l3(n)(91:98) 61 continue 56 format(a,f6.2,4a) endif c if(n2sigm.gt.0)then write(4,51)n2sigm 51 format(1x/i4,' Lines with obs-calc deviations in region ', * '2* > o-c > 3*sigma:'/) do 53 n=1,n2sigm write(4,56)l2(n)(2:31),ratio2(n),l2(n)(43:54),l2(n)(71:78), * l2(n)(81:88),l2(n)(91:98) 53 continue endif c if(nexcl.gt.0)then write(4,54)nexcl 54 format(1x/i4,' Excluded lines:'/) do 55 n=1,nexcl write(4,56)lexcl(n)(2:31),ratioe(n),lexcl(n)(43:54), * lexcl(n)(71:78),lexcl(n)(81:88),lexcl(n)(91:98) f(n)=abs(ratioe(n)) i(n)=n 55 continue jj=1 call sortc(jj,nexcl) write(4,57) 57 format(1x/' Excluded lines sorted in order of deviation:'/) do 59 jj=1,nexcl n=i(jj) write(4,56)lexcl(n)(2:31),ratioe(n),lexcl(n)(43:54), * lexcl(n)(71:78),lexcl(n)(81:88),lexcl(n)(91:98) 59 continue endif c if(ncut.ne.0)then write(4,94)ncut,cut 94 format(1x/i4,' Lines with obs-cals >',f5.1,'*sigma:'/) do 95 n=1,ncut write(4,96)lcut(n)(2:31),ratioc(n),lcut(n)(43:54), * lcut(n)(71:78),lcut(n)(81:88),lcut(n)(91:98) f(n)=abs(ratioc(n)) i(n)=n 95 continue jj=1 call sortc(jj,ncut) write(4,97) 97 format(1x/' Lines sorted in order of deviation:'/) do 99 jj=1,ncut n=i(jj) write(4,96)lcut(n)(2:31),ratioc(n),lcut(n)(43:54), * lcut(n)(71:78),lcut(n)(81:88),lcut(n)(91:98) 99 continue 96 format(a,f9.1,4a) endif c close(4) c stop end c C_____________________________________________________________________________ C SUBROUTINE SORTC(N,M) C C ... This routine sorts the quantities part of vector WK from N to M in C ascending order of magnitude and also accordingly rearranges vector C IPT of pointers to original positions of sorted quantities. c (this is a pretty grotty sort but does the job) C parameter (maxbuf=640) COMMON /FReq/WK COMMON /point/IPT INTEGER*2 IPT(maxbuf),n,m REAL*8 WK(maxbuf),EE C if(M.le.N) return DO 101 I=N,M-1 J=I 106 J=J+1 IF(WK(J)-WK(I))103,104,104 103 EE=WK(I) WK(I)=WK(J) WK(J)=EE K=IPT(I) IPT(I)=IPT(J) IPT(J)=K 104 IF(J.EQ.M)GOTO 101 GOTO 106 101 CONTINUE C RETURN END C c_____________________________________________________________________________ c_____________________________________________________________________________