C------------------------------------------------------------------------------- C L I N E R H - Converter of a .LIN file for the ERHam program C------------------------------------------------------------------------------- C C This program goes through the .LIN file for Pickett's SPFIT program C and produces C C either: a line listing compatible with line input block C required by Groner's ERHAM program C or: modifies the line input block for ERHAM within a specified C template file C C C ver. 15.V.2019 ----- 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 C Pertinent control data is to be placed in file LINERH.INP C C C Two modes of operation are possible: C C 1/ only the rotational quantum numbers are taken from the .LIN file and C IS1,IS2 are specified in the LINERH.INP file: C C name of the input file: v32e.lin C name of the output file: v32e.erh C transitions (1) or full input (2): 1 Corder of rotational qns in .LIN file: 1,2,3,4,5,6 C symmetry labels IS1,IS2: 1,0 C_______________________________________ C d e s c r i p t o r |_____ d a t a (starting on column 41) C C C 2/ IS1,IS2 are also taken from the .LIN file and their positions among the C .LIN quantum numbers are specified by negative values of IS1,IS2 in C LINERH.INP. For quantum number ordering as in the .CAT file generated C by ERHAM R3 the LINERH.INP needs to be as below: C C name of the input file: test.lin C name of the output file: test.in C transitions (1) or full input (2): 2 Corder of rotational qns in .LIN file: 1,2,3,5,6,7 C symmetry labels IS1,IS2: -4,-8 C_______________________________________ C d e s c r i p t o r |_____ d a t a (starting on column 41) c c c ADDITIONAL NOTES: c The output file resulting from LINERH example 1/ can be pasted directly c into the ERHAM as the input of transitions block 7. c C The output file from example 2/ is a modified version of the full C ERHAM input file test.in, provided this already exists. c c Lines to be excluded from the fit are to be assigned zero error c in the .LIN file. c c The only formatting aside from that affecting each line is to insert an c empty line in the output before any transition line containing c the '!' annotation. c C_____________________________________________________________________________ c C Modification history: C c 15.09.06: creation c 17.09.09: dealing with blends and end of line comments c 2.02.18: modification for .LIN compatible with .CAT of ERHAM_R3 C 4.02.18: option of insertion of transition block into ERHAM input c 14.03.18: debugging of treatment of excluded lines c 15.05.19: more debugging and commenting C_____________________________________________________________________________ C C USE IFPORT c IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) parameter (maxlin=20000,maxc=200) character line*200,filein*100,filout*100,filbak*100 character*100 descr(maxlin) integer lq(6),linq(12) dimension is1out(maxlin),is2out(maxlin),jupout(maxlin), * nupout(maxlin),jloout(maxlin),nloout(maxlin), * freqout(maxlin),wtout(maxlin),ferrout(maxlin) logical exlin,fsys c c c...Deal with the control file c WRITE(*,5500) 5500 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | LINERH - Converter of a .LIN file for the ERHam prog', * 'ram ',T79,'|'/ * ' |',76(1H_),'|'/' version 15.V.2019',T64,'Zbigniew KISIEL'/) c open(4,file='linerh.inp',status='old',err=400) read(4,'(40x,a)')filein read(4,'(40x,a)')filout read(4,'(40x,i20)',err=402)iout if(iout.lt.1.or.iout.gt.2)goto 402 read(4,'(40x,6i5)')lq read(4,'(40x,2i5)')is1,is2 close(4) c if(is1*is2.lt.0)then write(*,'(1x/1x,a,2i7/1x,a//)') * 'ERROR: IS1,IS2=',is1,is2, * ' but both should both have the same sign' stop endif c if( (is1.lt.0.and.is2.eq.0).or.(is2.lt.0.and.is1.eq.0) )then write(*,'(1x/1x,a,2i7/1x,a//)') * 'ERROR: IS1,IS2=',is1,is2, * ' the combination of zero and negative IS is not allowed' stop endif c c...Open .LIN input c open(2,file=filein,status='old',err=401) write(*,'(1x,2a)') * ' Reading from: ', * filein(1:len_trim(filein)) c c c...Open output: if output file exists then back it up c inquire(file=filout(1:len_trim(filout)), EXIST=exlin) if(exlin)then write(*,'(1x,2a/1x,2a/)') * ' Backing up: ', * filout(1:len_trim(filout)), * ' to: ', * filout(1:len_trim(filout))//'.bak' fsys=systemqq('copy '//filout(1:len_trim(filout))// * ' '//filout(1:len_trim(filout))//'.bak') endif c if(.not.exlin.and.iout.eq.2)then write(*,'(1x/a/a/a//)') * ' **** ERROR: full ERHAM output is not possible, since there', * ' should be a previous file with the same name', * ' to use as a template' stop endif c c c...Open output and if it is to be a complete ERHAM input file then c transfer lines preceding the frequency block from the just c backed up template c open(3,file=filout(1:len_trim(filout)),status='unknown') if(iout.eq.1)then write(*,'(1x,2a)') * ' Writing ERHAM frequency block to: ', * filout(1:len_trim(filout)) else write(*,'(1x,2a)') * ' Writing full ERHAM input file to: ', * filout(1:len_trim(filout)) endif c if(iout.eq.2)then filbak=filout(1:len_trim(filout))//'.bak' open(4,file=filbak(1:len_trim(filbak)),status='old') c read(4,'(a)')line write(3,'(a)')line(1:len_trim(line)) read(4,'(a)')line write(3,'(a)')line(1:len_trim(line)) c 405 read(4,'(a)')line write(3,'(a)')line(1:len_trim(line)) read(line,*)nn if(nn.ne.-1)goto 405 endif c c c...Go through the .LIN file and read lines c nlin=0 1 read(2,'(a)',err=4,end=4)line read(line,'(12I3)',err=4,end=4)linq line=line(37:len_trim(line)) c read(line,*,err=4,end=4)freq,ferr,rint c jup=linq(lq(1)) kau=linq(lq(2)) kpu=linq(lq(3)) jlo=linq(lq(4)) kal=linq(lq(5)) kpl=linq(lq(6)) c nup=kau-kpu+jup+1 nlo=kal-kpl+jlo+1 c if(freq.eq.0.d0)ferr=0.d0 nlin=nlin+1 if(is1.ge.0)then is1out(nlin)=is1 is2out(nlin)=is2 else is1out(nlin)=linq(iabs(is1)) is2out(nlin)=linq(iabs(is2)) endif c jupout(nlin)=jup nupout(nlin)=nup jloout(nlin)=jlo nloout(nlin)=nlo freqout(nlin)=freq wtout(nlin)=rint ferrout(nlin)=ferr c c...transfer annotation c descr(nlin)=' ' do 6 n=37,len_trim(line) if(line(n:n).eq.'!'.or.line(n:n).eq.'#')then descr(nlin)=' '//line(n:len_trim(line)) goto 1 endif 6 continue c goto 1 c c...assign blending as required by ERHAM c 4 write(*,'(1x/i7,a)')nlin,' lines have been read in' c nbl=0 do 3 n=1,nlin-1 if(ferrout(n).gt.100.)ferrout(n)=0.0d0 if(freqout(n+1).eq.freqout(n))then nbl=1 goto 3 else if(nbl.eq.0)then wtout(n)=0.d0 goto 3 endif if(nbl.eq.1)then wtout(n)=-wtout(n) nbl=0 goto 3 endif endif 3 continue if(ferrout(nlin).gt.100.)ferrout(nlin)=0.0d0 if(freqout(nlin-1).ne.freqout(nlin))wtout(nlin)=0.d0 C C...write out transition lines to the .RES file: c end of .LIN line annotations are kept except for the case of c excluded lines C nout=0 do 2 n=1,nlin c c__insert an empty line into .RES if(descr(n)(3:3).eq.'!')then write(3,'(1x)') nout=nout+1 endif c c__add an end of line annotation to an excluded line (keeping spacing c lines and their text but replacing any other end of line annotation) if(ferrout(n).eq.0.d0)then if(descr(n)(3:3).eq.'!')then nfin=len_trim(descr(n)) do 22 nn=3,len_trim(descr(n)) if(descr(n)(nn:nn).eq.'#')then nfin=nn-1 goto 23 endif 22 continue 23 descr(n)=' '//descr(n)(3:nfin)//'# excluded' else descr(n)=' # excluded' endif endif c write(3,5)is1out(n),is2out(n),jupout(n),nupout(n),jloout(n), * nloout(n),freqout(n),wtout(n),ferrout(n), * descr(n)(1:len_trim(descr(n))) 5 format(2i3,i5,i3,i5,i3,f20.6,f7.1,f12.6,a) nout=nout+1 2 continue close(2) LIN input c c c...If necessary then copy over the remainder of the ERHAM input c if(iout.eq.2)then write(3,'(1x)') c 406 read(4,'(a)')line read(line,*,err=406,end=406)nn if(nn.ne.-1)goto 406 c write(3,'(a)')line(1:len_trim(line)) c 407 read(4,'(a)',END=408)line write(3,'(a)')line(1:len_trim(line)) goto 407 endif c c 408 close(4) ERHAM input backup close(3) ERHAM output write(*,'(i7,a//)')nout, * ' transition lines have been output (counting also empty lines)' c stop c 400 write(*,'(1x/1x,a//)')'**** ERROR: cannot open LINERH.INP' stop c 401 write(*,'(1x/1x,2a//)') * '**** ERROR: cannot open the input file -> ', * filein(1:len_trim(filein)) stop c 402 write(*,'(1x/1x,a,i5//)') * '**** ERROR: bad flag for type of output -> ',iout stop end C_____________________________________________________________________________ C_____________________________________________________________________________