C----------------------------------------------------------------------------- c c P I S L I N - Checking and sorting of a .LIN data file for Pickett's c SPFIT program C C----------------------------------------------------------------------------- C C CHECKS aim to catch: C 1/ duplicated lines with identical values of quantum numbers C 2/ split blends i.e. nan-adjacent lines with same (or similar) C frequency C C SORTING operations can be cumulated as many times as necessary by means C of subsorting within the criterion of an immediately preceding sort. C C C Output of checks is written to PISLIN.OUT C Output of data file resulting from corrections is to PISLIN.RES C Output of sorted data file is to a user named file. C C C Version 31a.I.2023 ----- Zbigniew KISIEL ----- C 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 C Modification history: C C 1.95: creation C 17.01.06: major update to cope with demands posed by current .LIN files C 10.03.06: sort debugging and refinements c 20.01.09: transition type annotations c 14.01.14: preservation of information at the end of the recognised .LIN block c 31.01.23: modified addition of band annotations + warnings of problems C C=========================================================================== c c parameter (maxlin=50000, maxpr=maxlin/2) c real*8 f(maxlin),ff,fin(maxlin),fintmp(maxlin),freqn,freqnn,freqj real*4 err(maxlin) integer*4 i(maxlin),nstart,nlines,jfirst,jj,longL1(maxlin) integer*4 nqn(maxlin,12),nqntmp(maxlin,12) integer*4 irem(maxlin),ipair(maxpr,2) character*200 L1(maxlin),L1tmp(maxlin),line,lextra(1000) character filin*30,filout*30,branch*1,dipole*1,band*7 common /freq/f common /point/i common /lin/line c WRITE(*,3344) 3344 FORMAT(1X//' ',76('_')/' |',T79,'|'/ * ' | PISLIN - Checking and Sorting of .LIN files for Herb ', * 'Pickett''s ',T79,'|'/ * ' | SPFIT program ',T79,'|'/ * ' |',76('_'),'|'/' version 31a.I.2023',T64,'Zbigniew KISIEL'/) c c...read dataset, replacing blanks in quantum number fields by zeros c 2 write(*,1)' Name of the lines file:' 1 format(1x//1x,a,' ',$) read(*,'(a)',err=2)filin open(3,file=filin,err=2,status='old') c nlines=0 nextra=0 5 read(3,'(a)',end=6,err=5)line c if(len_trim(line).le.36.or.nextra.ne.0)then 190 nextra=nextra+1 lextra(nextra)=line read(3,'(a)',end=6,err=5)line goto 190 endif c if(line(3:3).eq.' ')goto 5 if(line(6:6).eq.' ')goto 5 do 210 n=7,34,3 if(line(n:n+2).eq.' ')line(n:n+2)=' 0' 210 continue nlines=nlines+1 L1(nlines)=line read(line(1:36),'(12I3)',err=8)(nqn(nlines,j),j=1,12) read(line(37:),*,err=8)f(nlines),err(nlines) if(nlines.eq.maxlin)goto 6 goto 5 8 nlines=nlines-1 goto 5 c 6 write(*,7)nlines,nextra 7 format(1x/1x,i5,' lines read in'/ * 1x,i5,' extra lines after the main .LIN block'/) close(3) c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...optional checks c 120 write(*,121) 121 format(1x/' Do you want checks on this .LIN file (0/1) ? .... ',$) read(*,'(i5)',err=120)icheck if(icheck.ne.1)goto 18 open(2,file='pislin.out',status='unknown') write(*,220) 220 format(1x/'***** Results will be listed to file PISLIN.OUT'/) write(2,221)filin(1:len_trim(filin)) 221 format(100('-')/'Results of checks on file: 'a/100('-')/) c c...quantum number duplication c nsameq=0 write(*,'(1x/'' Working '',$)') do 122 n=1,nlines-1 if((n/100)*100.eq.n)write(*,'(''+'',''.'',$)') do 123 nn=n+1,nlines do 124 j=1,12 if(nqn(n,j).ne.nqn(nn,j))goto 123 124 continue nsameq=nsameq+1 write(2,125)n,f(n),(nqn(n,j),j=1,12),err(n), * nn,f(nn),(nqn(nn,j),j=1,12),err(nn) 123 continue 122 continue 125 format(' Duplicate lines:',i5,' =',f14.5,i6,11i4,f12.5/ * 17x,i5,' =',f14.5,i6,11i4,f12.5/ ) c if(nsameq.gt.0)then write(2,126)nsameq write(*,126)nsameq else write(*,201) 201 format( * ' -----'/' | :=) | No duplicate lines found'/' -----'/) endif 126 format(1x/i7,' duplicate pairs of lines with identical quantum'/ * 7x,' numbers have been found'//) c c...Split blends and frequency duplication on non-adjacent lines c 151 write(*,150) 150 format(' Resolution criterion for blend identification = ',$) read(*,*,err=151)fres if(fres.le.0.d0)goto 151 c nsamef=0 nrem=0 write(*,'(1x/'' Working '',$)') do 132 n=1,nlines-1 if(f(n).eq.0.d0)goto 132 if((n/100)*100.eq.n)write(*,'(''+'',''.'',$)') freqn=f(n) if(err(n).lt.0.d0)freqn=freqn*29979.2458d0 do 133 nn=n+1,nlines if(f(nn).eq.0.d0)goto 133 freqnn=f(nn) if(err(nn).lt.0.d0)freqnn=freqnn*29979.2458d0 if(abs(freqn-freqnn).le.fres)then if( (f(n).eq.f(nn)) .and. nn-n.eq.1)goto 133 idiff=0 do 134 j=n+1,nn-1 freqj=f(j) if(err(j).lt.0.d0)freqj=freqj*29979.2458d0 if(freqj.ne.freqnn)idiff=idiff+1 134 continue if(idiff.eq.0)goto 133 c nsamef=nsamef+1 write(2,135)n,f(n),(nqn(n,j),j=1,12),err(n), * nn,f(nn),(nqn(nn,j),j=1,12),err(nn) ipair(nsamef,1)=n ipair(nsamef,2)=nn c if(nrem.eq.0)then irem(1)=n irem(2)=nn nrem=2 goto 133 endif do 137 j=1,nrem if(n.eq.irem(j))goto 138 137 continue nrem=nrem+1 irem(nrem)=n 138 do 139 j=1,nrem if(nn.eq.irem(j))goto 133 139 continue nrem=nrem+1 irem(nrem)=nn endif c 133 continue 132 continue 135 format(' Split blend: ',i5,' =',f14.5,i6,11i4,f12.5/ * 17x,i5,' =',f14.5,i6,11i4,f12.5/ ) c if(nsamef.gt.0)then write(2,136)nsamef,fres write(*,136)nsamef,fres write(2,141)nrem write(*,141)nrem do 140 j=1,nrem,10 if(j+9.lt.nrem)then write(2,'(1x,10I6)')(irem(jj),jj=j,j+9) write(*,'(1x,10I6)')(irem(jj),jj=j,j+9) else write(2,'(1x,10I6)')(irem(jj),jj=j,nrem) write(*,'(1x,10I6)')(irem(jj),jj=j,nrem) endif 140 continue c c IREM() - blend indices stored sequentially as found, and then sorted c IPAIR() - pairs of blend indices in order of identification (first c index increasing) c NSAMEF - number of pairs of split blend lines c NREM - number of lines involved in split blends c write(2,145) write(*,145) do 142 j=1,nrem f(j)=irem(j) i(j)=irem(j) 142 continue call sortc(1,nrem) <----- do 143 j=1,nrem irem(j)=i(j) 143 continue do 144 j=1,nrem,10 if(j+9.lt.nrem)then write(2,'(1x,10I6)')(irem(jj),jj=j,j+9) write(*,'(1x,10I6)')(irem(jj),jj=j,j+9) else write(2,'(1x,10I6)')(irem(jj),jj=j,nrem) write(*,'(1x,10I6)')(irem(jj),jj=j,nrem) endif 144 continue c endif 136 format(1x/i7,' pairs of split blends with frequencies closer than' * /7x,' the resolution criterion of',f8.2) 141 format(1x/i7,' lines are implicated in split blends:'/) 145 format(1x/7x,' In order of line number the split blend lines are:' * /) write(2,222) 222 format(1x/100('-')/100('-')) close(2) c c...Cleaning up ? c if(nrem.gt.0)then write(*,146) 146 format(1x/ * ' Treatment of split blends:'//15x,'0 = do nothing' * /15x,'1 = remove'/15x,'2 = bring together',7x'.... ',$) read(*,'(i5)')ifrem else write(*,200) 200 format(' -----'/' | :=) | No split blends found'/' -----') endif c c...remove split blends c if(ifrem.eq.1)then open(2,file='pislin.res',status='unknown') jrem=1 nout=0 do 148 j=1,nlines if(j.gt.irem(jrem))jrem=jrem+1 if(j.eq.irem(jrem))goto 148 write(2,'(a)')L1(j)(1:len_trim(L1(j))) nout=nout+1 148 continue close(2) write(*,147)nout stop endif 147 format(1x/i7,' lines have been written to a reduced data set in'/ * 7x,' file PISLIN.RES'//) c c...bring split blends together (in all cases line with higher index moved c to be adjacent to that with the lower index) c if(ifrem.eq.2)then jrem=1 nout=0 open(2,file='pislin.res',status='unknown') do 203 j=1,nlines line=L1(j) if(len_trim(line).le.1)goto 203 write(2,'(a)')line(1:len_trim(line)) nout=nout+1 c jj=ipair(jrem,1) if(j.eq.jj)then 205 jjj=ipair(jrem,2) line=L1(jjj) if(len_trim(line).le.1)then jrem=jrem+1 jjjj=ipair(jrem,1) if(jjjj.eq.jj)goto 205 goto 203 else write(2,'(a)')line(1:len_trim(line)) nout=nout+1 L1(jjj)=' ' jrem=jrem+1 jjjj=ipair(jrem,1) if(jjjj.eq.jj)goto 205 endif endif 203 continue close(2) write(*,204)nlines,nout stop endif 204 format(1x/i7,' lines in original dataset'/ * i7,' lines written to file PISLIN.RES'// * ' ******',' RERUN the program to check, and repeat blending'/ * 7x,' operation if necessary'//) c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...options for primary sort c 18 write(*,'(1x)') 3 write(*,1) * 'Name of output file for sorted lines (or ENTER to exit):' read(*,'(a)',err=3)filout if(len_trim(filout).lt.1)stop c if(filin(1:len_trim(filin)).eq.filout(1:len_trim(filout)))then write(*,19) 19 format(1x/' ***** WARNING: Input and output filenames are the ', * 'same.'/16x, * 'This is allowed but the original .LIN file will be lost.'// * 16x,'Do you want to continue nonetheless (1/0) ? ... ',$) read(*,'(i5)')icontn if(icontn.ne.1)goto 3 endif c open(4,file=filout,err=3,status='unknown') c 14 write(*,15)(l1(n)(1:78),n=1,5) 15 format(1x/5(1x,a/)/ * ' Select one of the sorting options:'// * ' -2 = error sort'/ * ' -1 = frequency sort'/ * ' 0 = EXIT'/ * ' 1-12 = quantum number'/ * ' 20 = sort by selection rule'/ * ' 30 = sort by transition sequence'// * 41x,' .... ',$) c read(*,'(i5)',err=14)icflag c if(icflag.lt.-2)goto 14 if(icflag.gt.12.and.icflag.ne.20.and.icflag.ne.30)goto 14 if(icflag.eq.0)then close(4) stop endif c c c...quantum number sort c if(icflag.ge.1.and.icflag.le.12)then nn1=(icflag-1)*3+1 nn2=nn1+2 do 61 n=1,nlines line=L1(n) read(line(nn1:nn2),'(i3)',err=61)n3 f(n)=n3 i(n)=n 61 continue endif c c...quantum number change sort c if(icflag.eq.20)then 102 write(*,101) 101 format(1x/' Sorting according to quantum number change - ', * ' specify indices of'/ * ' two quantum numbers (1-12) separated by a comma:'/ * /41x,' .... ',$) read(*,*,err=102)nq1,nq2 if(nq1.lt.1.or.nq1.gt.12)goto 102 if(nq2.lt.1.or.nq2.gt.12)goto 102 if(nq1.eq.nq2)goto 102 c nn1=(nq1-1)*3+1 nn2=nn1+2 nnn1=(nq2-1)*3+1 nnn2=nnn1+2 do 103 n=1,nlines line=L1(n) read(line(nn1:nn2),'(i3)',err=103)na read(line(nnn1:nnn2),'(i3)',err=103)nb f(n)=na-nb i(n)=n 103 continue endif c c---------------------------------- c c...sort into transition sequences c if(icflag.eq.30)then 302 write(*,301) 301 format(1x/' Sorting into transition sequences: '/ * 20x,'step I: sort into P,Q,R'/ * 20x,'step II: subsort in Ka within PQR'/ * 20x,'step III: subsort in J within Ka'// * ' Specify which are the rotational quantum numbers of the', * ' upper '/ * ' and of the lower energy levels (six integer indices)' * //41x,' .... ',$) read(*,*,err=302)nu1,nu2,nu3,nl1,nl2,nl3 c c...work out transition index c do 303 n=1,nlines jsum=(nqn(n,nl3)+nqn(n,nl2))-nqn(n,nl1) f(n)= 1000.d0*(nqn(n,nu1)-nqn(n,nl1)) + delta J * 100.d0*(nqn(n,nu2)-nqn(n,nl2)) + delta Ka * 10.d0*(nqn(n,nu3)-nqn(n,nl3)) + delta Kc * jsum Ka+Kc-J (lower) i(n)=n 303 continue c write(*,'(1x/'' S O R T I N G transition index'')') nstart=1 call sortc(nstart,nlines) <----- c c...reorder and subsort in Ka'' within transition index c do 304 n=1,nlines L1tmp(n)=L1(n) do 304 nn=1,12 nqntmp(n,nn)=nqn(n,nn) 304 continue c do 305 n=1,nlines ii=i(n) L1(n)=L1tmp(ii) fin(n)=f(n) do 305 nn=1,12 nqn(n,nn)=nqntmp(ii,nn) 305 continue c nstart=1 findx=fin(1) i(1)=1 f(1)=nqn(1,nl2) do 306 n=2,nlines if(fin(n).ne.findx)then nend=n-1 write(*,'('' sub S O R T I N G Ka'')') call sortc(nstart,nend) <----- nstart=n findx=fin(n) endif i(n)=n f(n)=nqn(n,nl2) 306 continue if(nend.lt.nlines)then nend=nlines write(*,'('' sub S O R T I N G Ka'')') call sortc(nstart,nend) <----- endif c c...reorder and subsort in J'' within Ka and transition index c do 308 n=1,nlines L1tmp(n)=L1(n) fintmp(n)=fin(n) do 308 nn=1,12 nqntmp(n,nn)=nqn(n,nn) 308 continue c do 309 n=1,nlines ii=i(n) L1(n)=L1tmp(ii) fin(n)=fintmp(ii) do 309 nn=1,12 nqn(n,nn)=nqntmp(ii,nn) 309 continue c c__go through sequences nstart=1 kaold=nqn(1,nl2) findx=fin(1) i(1)=1 f(1)=nqn(1,nl1) do 310 n=2,nlines if(nqn(n,nl2).ne.kaold.or.fin(n).ne.findx)then nend=n-1 write(*,'('' sub sub S O R T I N G J'')') call sortc(nstart,nend) <----- ii=i(nstart) c c...set up the band annotation string c idj =(nqn(ii,nu1)-nqn(ii,nl1)) idka=(nqn(ii,nu2)-nqn(ii,nl2)) idkc=(nqn(ii,nu3)-nqn(ii,nl3)) if(idj.eq.-1)branch='P' if(idj.eq. 0)branch='Q' if(idj.eq. 1)branch='R' if((idka/2)*2.eq.idka.and.(idkc/2)*2.ne.idkc)dipole='a' eo if((idka/2)*2.ne.idka.and.(idkc/2)*2.ne.idkc)dipole='b' oo if((idka/2)*2.ne.idka.and.(idkc/2)*2.eq.idkc)dipole='c' oe write(band,400)dipole,branch,idka,idkc 400 format(a1,a1,i2,',',i2) c c...Deal with annotations: c c___check if a line is long enough for possible collision of annotations c (will be used to produce a warning) c if(len_trim(L1(ii)).ge.84)then longL1(ii)=1 else longL1(ii)=0 endif c c___first scan from end of the line for presence of first ! and # c nexclam=0 nhash=0 L1len=len_trim(L1(ii)) do 500 nn=L1len,37,-1 if(L1(ii)(nn:nn).eq.'!')then if(nexclam.eq.0)nexclam=nn endif if(L1(ii)(nn:nn).eq.'#')then if(nhash.eq.0)nhash=nn endif 500 continue c c___modify line as necessary c if(L1len.lt.84.and.nexclam.eq.0.and.nhash.eq.0)then ! simple modification L1(ii)(85:94)='!# '//band goto 501 endif c if(nhash.ne.0)then ! extend # annotation L1(ii)=L1(ii)(1:nhash-1)//'# '//band//' '// * L1(ii)(nhash+1:L1len) goto 501 else ! add # band annotation L1(ii)=L1(ii)(1:L1len)//' # '//band endif c 501 nstart=n findx=fin(n) kaold=nqn(n,nl2) endif i(n)=n f(n)=nqn(n,nl1) 310 continue c c__final sequence if the sort above did not cover all lines if(nend.lt.nlines)then nend=nlines write(*,'('' sub sub S O R T I N G J'')') call sortc(nstart,nend) <----- ii=i(nstart) c c...set up the band annotation string c idj =(nqn(ii,nu1)-nqn(ii,nl1)) idka=(nqn(ii,nu2)-nqn(ii,nl2)) idkc=(nqn(ii,nu3)-nqn(ii,nl3)) if(idj.eq.-1)branch='P' if(idj.eq. 0)branch='Q' if(idj.eq. 1)branch='R' if((idka/2)*2.eq.idka.and.(idkc/2)*2.ne.idkc)dipole='a' eo if((idka/2)*2.ne.idka.and.(idkc/2)*2.ne.idkc)dipole='b' oo if((idka/2)*2.ne.idka.and.(idkc/2)*2.eq.idkc)dipole='c' oe write(band,400)dipole,branch,idka,idkc c if(len_trim(L1(ii)).ge.84)then longL1(ii)=1 else longL1(ii)=0 endif c L1(ii)(85:94)='!# '//band endif c do 311 n=1,nlines ii=i(n) line=L1(ii) write(4,'(a)')line(1:len_trim(line)) OUTPUT 311 continue c if(nextra.gt.0)then do 600 n=1,nextra write(4,'(a)')lextra(n)(1:len_trim(line)) OUTPUT 600 continue endif c longout=0 do 601 n=1,nlines ii=i(n) if(longL1(ii).eq.1)then if(longout.eq.0)then write(*,'(1x//1x,a/)') * 'Check/modify annotations on the following lines:' longout=1 endif write(*,'(1x,a,i5,a,a)')'Line', n,' --> ',L1(ii)(37:99) endif 601 continue c close(4) stop c endif c c---------------------------------- c c...frequency sort c if(icflag.eq.-1)then do 62 n=1,nlines line=L1(n) read(line(37:51),'(f15.10)',err=62)ff f(n)=ff i(n)=n 62 continue endif c c...error sort c if(icflag.eq.-2)then do 63 n=1,nlines line=L1(n) read(line(52:61),'(f10.5)',err=63)ff f(n)=ff i(n)=n 63 continue endif c 100 write(*,'(1x/'' S O R T I N G'')') nstart=1 call sortc(nstart,nlines) <----- c c c...Output c do 12 n=1,nlines ii=i(n) line=L1(ii) write(4,'(a,f15.2)')line(1:len_trim(line)) OUTPUT 12 continue c if(nextra.gt.0)then do 511 n=1,nextra write(4,'(a)')lextra(n)(1:len_trim(line)) OUTPUT 511 continue endif close(4) c c...If primary sort was according to frequency or error then subsorting is c not allowed so go back to the main sorting selection c if(icflag.lt.0)then open(4,file=filout,err=3,status='old') do 168 n=1,nlines read(4,'(a)',end=169,err=169)line L1(n)=line 168 continue 169 close(4) goto 14 endif c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Subsorting c 66 write(*,65) 65 format(1x/' Subsort within previous sort criterion ? .... ',$) read(*,'(i5)',err=66)isubs if(isubs.lt.0.or.isubs.gt.1)goto 66 if(isubs.eq.0)then close(4) stop endif c 74 write(*,75)(l1(n)(1:78),n=1,5),icflag 75 format(1x/5(1x,a/)/ * ' Subsort entries for criterion',i3, * ' according to :'// * ' -2 = error'/ * ' -1 = frequency'/ * ' 0 = EXIT'/ * ' 1-12 = quantum number'/ * ' 20 = selection rule'// * 41x,' .... ',$) read(*,'(i5)',err=74)isubs if(isubs.eq.icflag.and.isubs.ne.20)goto 74 if(isubs.lt.-2)goto 74 if(isubs.gt.12.and.isubs.ne.20)goto 74 c if(icflag.eq.20)then nqo1=nq1 nqo2=nq2 endif c if(isubs.eq.20)then 110 write(*,101) read(*,*,err=110)nq1,nq2 if(nq1.lt.1.or.nq1.gt.12)goto 110 if(nq2.lt.1.or.nq2.gt.12)goto 110 if(nq1.eq.nq2)goto 110 endif c iprev=0 if(icflag.eq.20)then 21 write(*,20) 20 format(1x/' Apply precedence of quantum number values of '/ * ' previous sort (1/0) ?'/ * /41x,' .... ',$) read(*,'(i5)',err=21)iprev if(iprev.lt.0.or.iprev.gt.1)goto 21 endif c c c...Reread from unit 4 c open(4,file=filout,err=3,status='old') do 68 n=1,nlines read(4,'(a)',end=80,err=68)line L1(n)=line 68 continue 80 close(4) c c...Find blocks with same value of previous quantum number and subsort c in new quantum number c line=L1(1) if(icflag.ne.20)then nn1=(icflag-1)*3+1 nn2=nn1+2 read(line(nn1:nn2),'(i3)')lstval else nn1=(nqo1-1)*3+1 nn2=nn1+2 nnn1=(nqo2-1)*3+1 nnn2=nnn1+2 read(line(nn1:nn2),'(i3)')na read(line(nnn1:nnn2),'(i3)')nb lstval=na-nb endif c jfirst=1 do 70 n=1,nlines line=L1(n) if(icflag.ne.20)then read(line(nn1:nn2),'(i3)',err=70)newval else read(line(nn1:nn2),'(i3)')na read(line(nnn1:nnn2),'(i3)')nb newval=na-nb endif call getf(ff,isubs,nq1,nq2) <----- if(iprev.eq.1)then ff=ff+100*nb endif i(n)=n f(n)=ff if(newval.ne.lstval)then jj=n-1 write(*,*)jfirst,jj if(jfirst.ne.jj)call sortc(jfirst,jj) <----- jfirst=n lstval=newval endif 70 continue if(jfirst.ne.nlines)then write(*,*)jfirst,nlines call sortc(jfirst,nlines) <----- endif c c...Output of subsort c open(4,file=filout,err=3,status='unknown') do 69 n=1,nlines ii=i(n) line=L1(ii) write(4,'(a)')line(1:len_trim(line)) OUTPUT 69 continue c if(nextra.gt.0)then do 300 n=1,nextra write(4,'(a)')lextra(n)(1:len_trim(line)) OUTPUT 300 continue endif c close(4) c icflag=isubs goto 66 c 9 stop end C_____________________________________________________________________________ C subroutine getf(ff,iflag,nq1,nq2) c c...This routine extracts the numerical value of the parameter to be c used for sorting c C ff - value to be used for sorting C iflag - sorting parameter C nq1,nq2 - only used for iflag=20 and are indices of two quantum numbers C for selection rule sorting C common /lin/line character*200 line real*8 ff integer*4 nqn(12) c if(iflag.ge.1.and.iflag.le.12)then nn1=(iflag-1)*3+1 nn2=nn1+2 read(line(nn1:nn2),'(i3)',err=61)n3 ff=n3 endif c if(iflag.eq.20)then nn1=(nq1-1)*3+1 nn2=nn1+2 nnn1=(nq2-1)*3+1 nnn2=nnn1+2 read(line(nn1:nn2),'(i3)',err=61)na read(line(nnn1:nnn2),'(i3)',err=61)nb ff=na-nb endif c if(iflag.eq.-1)then read(line,*,err=61)(nqn(i),i=1,12),ff endif c if(iflag.eq.-2)then read(line,*,err=61)(nqn(i),i=1,12),temp,ff endif goto 62 c 61 ff=0 c 62 return 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 (maxlin=50000) real*8 wk(maxlin),EE INTEGER*4 IPT(maxlin),n,m c COMMON /FReq/WK COMMON /point/IPT 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_____________________________________________________________________________