C------------------------------------------------------------------------------- C E R H R E S - Converter of an ERHam output to a .RES type output C and a .LIN type data file C------------------------------------------------------------------------------- C C This program goes through the input and output files of Peter Groner's C ERHAM program and produces: C C 1/ output of results of final cycle of fit in the .RES standard similar C to that out of PIFORM or ASFIT C 2/ output of transitions in the .LIN standard of the SPFIT program C C Pertinent control data is to be placed in file ERHRES.INP C C The qq' (IS1,IS2) values are placed as quantum numbers 4 and 8 in C the .LIN file, ensuring compatibility with .CAT output from ERHAM_R3 C C The value of N=Kc-Ka+J+1 as used by ERHAM is placed in the annotation C field of the .RES file. If there is a batch of lines with the same C value of N then only the first such line is annotated. C C If ERHRES finds a previous version of the .LIN file as specified in C ERHRES.INP then this is copied to a .LIN.BAK file. C C ERHRES preserves all annotations from the original .LIN file that was C converted to ERHAM input with LINERH (but only up to 100 characters). c C The treatment of annotations, as transferred to the .RES file, C is the same as in PIFORM: C C Annotations can be added at the ends of .LIN transition lines and c should begin with the character ''!' or '#' c i. the character '!' generates a separate annotation preceding C the line containing this character. The annotation line will c contain any text that has been placed behind !, until c another ! or # is encountered in this line, c ii. each additional ! character encountered after a given transition c definition will generate a new annotation line - so that c multiline blocks of annotations can be generated, c iii. the character '#' places the text that follows behind it c at the end of the current line of output. Leading spaces c in the annotation are ignored. Note that the # annotation c should follow any ! annotations, if those are used on the same line. c C C ver. 5.VII.2018 ----- 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 27.09.06: creation c 11.11.06: constant formatting c 4.10.09: improved handling of comments and partial deviations of fit c 28.10.09: improved handling of blends c 2.02.18: many updates for compatibility with ERHAMZ_R3 and its .CAT output c 3.02.18: backup of previous .LIN file c 18.02.18: transfer of end of LIN line annotations improved c 5.07.18: debugging subset statistics for blended lines C_____________________________________________________________________________ C use IFPORT c IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) parameter(maxlin=9999,maxbl=20) c character line*132,filein*30,filout*30,ind*3,cdip*2,linasr*80, * fillin*30,filinp*30,filres*30,note*10, * lincom(maxlin)*100,lblend(maxbl)*250,linapp*80 character conval*27,erval*27,cwork*40,unit*4,linout*132,CONNAM*9 integer ispace(maxlin) logical exlin c DATA FV,SIGMA,GI,HALFW,ABUND/0.95D0, 1.D0, 1.D0, 20.D0, 1.0D0/ c CLIGHT=29979.2458D0 BOLTZK=0.6950356D0 NERD=2 c c...Deal with the control file c WRITE(*,5500) 5500 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | ERHRES - Converter of an ERHAM input/output into ', * ' RES and LIN type files',T79,'|'/ * ' |',76(1H_),'|'/' version 5.VII.2018',T64,'Zbigniew KISIEL'/) c open(4,file='erhres.inp',status='old') read(4,'(40x,a)')filinp read(4,'(40x,a)')filout read(4,'(40x,a)')filres read(4,'(40x,a)')fillin close(4) c open(5,file=filinp(1:len_trim(filinp)),status='old') write(*,'(1x,2a)')' Reading from ERHAM input: ', * filinp(1:len_trim(filinp)) open(2,file=filout(1:len_trim(filout)),status='old') write(*,'(1x,2a)')' Reading from ERHAM output: ', * filout(1:len_trim(filout)) open(3,file=filres(1:len_trim(filres)),status='unknown') write(*,'(1x,2a/)')' Writing RES type output to: ', * filres(1:len_trim(filres)) c c...If it exists then backup previous version of the .LIN and open new one c for output c inquire(file=fillin(1:len_trim(fillin)), EXIST=exlin) if(exlin)then write(*,'(1x,2a/1x,2a/)') * ' Backing up: ',fillin(1:len_trim(fillin)), * ' to: ',fillin(1:len_trim(fillin)) * //'.bak' fsys=systemqq('copy '//fillin(1:len_trim(fillin))// * ' '//fillin(1:len_trim(fillin))//'.bak') endif c open(4,file=fillin(1:len_trim(fillin)),status='unknown') write(*,'(1x,2a)')' Writing LIN type output to: ', * fillin(1:len_trim(fillin)) c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c Deal with headers c read(2,'(a)',err=4,end=4)line write(3,'(a)')line(1:len_trim(line)) read(5,'(a)',err=4,end=4)line write(3,28)line(1:len_trim(line)) 28 format(1x/80('-')/a/80('-')/) read(5,*)i,i,i,ncycl write(*,29)ncycl 29 format(1x/i4,' fitting cycles in output'/) c c c...Skip ERHAM input file up to the end of the block of lines defining predictions c 40 read(5,*)i1,i2,i3,i4 if(i1.ne.-1)goto 40 if(i2.ne.0.and.i3.ne.0.and.i4.ne.0)goto 40 c c c...Go through transitions in the ERHAM input (unit 5) and convert on the fly to c the corresponding .LIN file (unit 4): c c LIN type output (4th quantum number is IS1, 8th is IS2) c c11 11 1 1 10 10 1 0 0 0 0 0 182264.344417 0.050000 1.00000 c11 11 0 0 10 10 1 0 0 0 0 0 182265.022144 0.050000 1.00000 c11 11 1 0 10 10 0 0 0 0 0 0 182265.022144 0.050000 1.00000 c c from this ERHAM input c c 1 0 11 22 10 20 182264.344400 0.0 0.050000 !! lowest Kc ! c 0 0 11 23 10 20 182265.022100 0.5 0.050000 c 0 0 11 22 10 21 182265.022100 -0.5 0.050000 c c The operation of LINERH and ERHRES are designed to preserve the form of c the .LIN file inclusive of any annotations made on it. The annotations are c actioned on generation of the .RES file further below. c nlines=0 c 41 read(5,'(a)')line if(len_trim(line).lt.15)goto 41 c read(line,*)i1 if(i1.eq.-1)goto 42 end of frequencies c c Establish that this is a genuine transition line c read(line,*,err=41)is1,is2,jup,nup,jlo,nlo,freq,blwt,ferr nlines=nlines+1 if(blwt.eq.0.d0)blwt=1.d0 if(blwt.lt.0.d0)blwt=-blwt ispace(nlines)=0 c c Determine if there are any end of line annotations c do 141 n=37,len_trim(line) if(line(n:n).eq.'!'.or.line(n:n).eq.'#')then if(len_trim(line).ge.1)then lincom(nlines)=' '//line(n:len_trim(line)) else lincom(nlines)=' ' endif if(line(n:n).eq.'!')ispace(nlines)=1 goto 241 endif 141 continue c c Convert ERHAM J,N notation to J,Ka,Kc: c c N is odd: Ka=(N-1)/2 N is even: Ka=N/2 c Kc=J-Ka Kc=J+1-Ka c 241 if((nup/2)*2.eq.nup)then kaup=nup/2 kcup=jup+1-kaup else kaup=(nup-1)/2 kcup=jup-kaup endif c if((nlo/2)*2.eq.nlo)then kalo=nlo/2 kclo=jlo+1-kalo else kalo=(nlo-1)/2 kclo=jlo-kalo endif c c write to the .LIN file: LLCOM scheme is necessary since LEN_TRIM c does not work properly on completely empty lines c llcom=len_trim(lincom(nlines)) if(llcom.eq.100.or.llcom.eq.0)llcom=1 if(llcom.ne.1)then write(4,25)jup,kaup,kcup,is1,jlo,kalo,kclo,is2, * 0,0,0,0,freq,ferr,blwt, * lincom(nlines)(1:llcom) else write(4,25)jup,kaup,kcup,is1,jlo,kalo,kclo,is2, * 0,0,0,0,freq,ferr,blwt endif 25 format(12i3,F16.6,F13.6,F10.5,a) c goto 41 c 42 close(5) ERHAM input close(4) LIN output c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c...Go through the ERHAM output (unit=2) and find the fitting block header. c c Convert only on cycle number equal to the number specified in c second line of the ERHAM input file. c 1 read(2,'(a)',err=4,end=4)line if(line(21:28).ne.'* CYCLE')goto 1 read(line(29:31),'(i3)')nnn if(nnn.ne.ncycl)goto 1 c write(3,*)line(1:len_trim(line)) write(3,'(1x/2a/)')' J'' Ka'' Kc'' J" Ka" Kc" ', * 'obs obs-calc error qq'' N' nlast=-1 nblend=0 c 20 read(2,'(a)',err=4,end=4)line if(line(1:4).ne.' 1')goto 20 c sum00=0.d0 sum00w=0.d0 sum10=0.d0 sum10w=0.d0 n00=0 n10=0 c c...line formats in the ERHAM output: c c176 00 1 59 12 1 58 12 283702.7130 0.00 20.00 -0.1033 -2.0650 c177 00 1 64 13 1 63 13 309981.9434 0.00 20.00 0.0023 0.0469 c178 00 1 29 15 1 28 15 160207.8841 0.50 20.00 -0.1634 -3.2677 c179 00 1 29 16 1 28 16 160207.8841 -0.50 20.00 0.2242 4.4832 0.6078 c c N odd: Ka=(N-1)/2 Kc=J-Ka c N even: Ka=N/2 Kc=J+1-Ka c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c...transitions: c c These are processed on the fly except for blends, when all such lines c are collected in LBLEND. When a blend block is complete the o-c for c the blend is placed in the main o-c column, and the o-c for blend c components are put in the last column, and the whole LBLEND block c written out. c This is done for better compatibility with output from ASFIT and further c processig with AC. c 23 read(line,21)lnum,indqq,ivup,jup,nup,ivlo,jlo,nlo,freq,blend,wt, * omc,omcrms 21 format(i4,i3,i3,2i4,i3,2i4,f13.4,f6.2,f8.2,f14.4,f10.4) c c if(indqq.eq.0)then write(note(1:5),'(a)')' 00' is1=0 is2=0 else write(note(1:5),'(i5)')indqq is1=indqq/10 is2=indqq-10*is1 endif c if(nlo.ne.nlast)then write(note(6:10),'(i4,a1)')nlo,' ' else write(note(6:10),'( a5)')' ' endif nlast=nlo c if(wt.ne.0.d0)then ferr=1.d0/wt else ferr=0.d0 endif c c...read final deviation of blend c if(blend.lt.0.d0)read(line(81:90),'(f10.4)')omcblew c c N is odd: Ka=(N-1)/2 N is even: Ka=N/2 c Kc=J-Ka Kc=J+1-Ka c if((nup/2)*2.eq.nup)then kaup=nup/2 kcup=jup+1-kaup else kaup=(nup-1)/2 kcup=jup-kaup endif c if((nlo/2)*2.eq.nlo)then kalo=nlo/2 kclo=jlo+1-kalo else kalo=(nlo-1)/2 kclo=jlo-kalo endif c c__RES output: add spacing lines and end of line annotations (if any) c call linann(lincom(lnum),linapp,napp) <----- c c__RES output: excluded line if(ferr.eq.0.d0)then c note(1:6)=' -excl' write(3,27)lnum,jup,kaup,kcup,jlo,kalo,kclo,freq,omc, OUTPUT to RES * ferr,note(1:10)//' '//linapp(1:napp) goto 26 endif c 27 format(i4,'.',i6,2i4,i6,2i4,f16.4,f14.4,f9.4,a) c c__RES output: no blend if(blend.eq.0.d0)then write(3,27)lnum,jup,kaup,kcup,jlo,kalo,kclo,freq,omc, OUTPUT to RES * ferr,note(1:10)//' '//linapp(1:napp) if(indqq.eq.0)then n00=n00+1 sum00=sum00+omc**2 sum00w=sum00w+(omc/ferr)**2 endif if(indqq.eq.10)then n10=n10+1 sum10=sum10+omc**2 sum10w=sum10w+(omc/ferr)**2 endif else c c__RES output: blended lines c c__initial blend lines if(blend.gt.0.d0)then nblend=nblend+1 write(lblend(nblend),22) * lnum,jup,kaup,kcup,jlo,kalo,kclo,freq,omc,ferr, * note,blend,omcble,' '//linapp(1:napp) 22 format(i4,'.',i6,2i4,i6,2i4,f16.4,f14.4,f9.4,a10, * 1pE8.1,-1pf14.4,a) c c__terminating blend line (ERHAM prints obs-calc for blend as (o-c)/ferr) else nblend=nblend+1 omcble=omcblew*ferr write(lblend(nblend),22) * lnum,jup,kaup,kcup,jlo,kalo,kclo,freq,omc,ferr, * note,blend,omcble,' '//linapp(1:napp) do 50 n=1,nblend read (lblend(n)(50:63),'(f14.4)')omc read (lblend(n)(64:72),'(f9.4)')ferr read (lblend(n)(73:77),'(A5)')note read(note(1:5),'(i5)')indqq c write(lblend(n)(50:63),'(f14.4)')omcble write(lblend(n)(91:104),'(f14.4)')omc write(3,'(a)')lblend(n)(1:lentrm(lblend(n))) OUTPUT to RES c if(indqq.eq.0)then n00=n00+1 sum00=sum00+omcble**2 sum00w=sum00w+(omcble/ferr)**2 endif if(indqq.eq.10)then n10=n10+1 sum10=sum10+omcble**2 sum10w=sum10w+(omcble/ferr)**2 endif c 50 continue nblend=0 c endif endif c c c 26 note(6:10)='' if(ispace(lnum).gt.0)then i1=ispace(lnum) if(i1.gt.4)i1=4 do 46 i1=1,i1 write(note(6+i1:6+i1),'(a)')'!' 46 continue endif c c...done transitions or loop back for another c read(2,'(a)',err=4,end=4)line if(len_trim(line).lt.80)goto 4 goto 23 c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c...Process the output below the block of fitted frequencies c 4 write(3,'(1x)') write(3,'(a/)')line(1:len_trim(line)) c if(n00.or.n10.gt.0)write(3,48) 48 format(' SUBSET STATISTICS: (Note that in this case all blend ', * 'components are counted, but at the blend obs-calc)') if(n00.gt.0)then sdev00=dsqrt(sum00/n00) sdev00w=dsqrt(sum00w/n00) write(3,47)'00',n00,sdev00,sdev00w endif if(n10.gt.0)then sdev10=dsqrt(sum10/n10) sdev10w=dsqrt(sum10w/n10) write(3,47)'10',n10,sdev10,sdev10w endif 47 format(' State ',a2,': ',i5,' lines', * T30,'MICROWAVE RMS =',F12.6,' RMS ERROR =',F12.6) c c...copy lines up to the SINGULAR..JACOBIANMATRIX header c read(2,'(a)',end=330)line write(3,49) 49 format(1x/' OVERALL STATISTICS: (blends are only counted once' * ' and n=Nlines)') 30 read(2,'(a)',end=330)line if(line(2:9).ne.'SINGULAR')then write(3,'(a)')line(1:len_trim(line)) goto 30 endif c c...skip lines in the SINGULAR..JACOBIANMATRIX block c 31 read(2,'(a)')line if(line(5:12).ne.'SINGULAR')GOTO 31 c read(line(57:),*)erhdev write(3,51)erhdev 51 format(' RMS DEVIATION =',F20.6, * ' = [(sum((o-c)/err)^2)/(Nlines-Nparfit)]^(1/2)'/) C C...echo the header lines to parameter output and the parameter block C WRITE(3,'(a)')line(1:len_trim(line)) 32 read(2,'(a)')line IF(LINE(2:12).EQ.'CORRELATION')goto 34 IF(LINE(1:6).eq.' STATE')line=line(1:56) c read(line(5:8),'(i4)',err=35)i if(i.le.0.or.i.gt.100)goto 35 read(line(21:40),'(E20.9)',err=35)constv read(line(41:55),'(E15.4)',err=35)ercons c WRITE(CONVAL,'(F27.16)')constv WRITE(ERVAL,'(F27.16)')ercons c connam='' unit='/MHz' if(line(12:12).EQ.' ')then if(line(13:15).eq.'DEL'.or.line(13:15).eq.'DDE')unit='/kHz' if(line(13:15).eq.'PHI'.or.line(13:15).eq.'PPH')unit='/Hz ' CONNAM=LINE(13:21) else read(line(10:10),'(i1)')iq read(line(12:12),'(i1)')iqp read(line(16:16),'(i1)')ir read(line(18:18),'(i1)')ik read(line(20:20),'(i1)')ip if(ir.eq.0.and.ik.eq.0.and.ip.eq.0)then write(connam,37)iq,iqp 37 format('eps_',2i1) else write(connam,36)ik,ip,ir,iq,iqp 36 format('B',3i1,'_',2i1) endif c if(ir+ik+ip.eq.2)then WRITE(CONVAL,'(F27.16)')constv*1.d3 WRITE(ERVAL,'(F27.16)')ercons*1.d3 unit='/kHz' endif c if(ir+ik+ip.eq.4)then WRITE(CONVAL,'(F27.16)')constv*1.d6 WRITE(ERVAL,'(F27.16)')ercons*1.d6 unit='/Hz ' endif c if(ir+ik+ip.eq.6)then WRITE(CONVAL,'(F27.16)')constv*1.d9 WRITE(ERVAL,'(F27.16)')ercons*1.d9 unit='/mHz' endif c if(iq.eq.0.and.iqp.eq.0)then read(line(16:16),'(i1)')kap read(line(18:18),'(i1)')jp read(line(20:20),'(i1)')kp if(kap+jp+kp.eq.8)then WRITE(CONVAL,'(F27.16)')constv*1.d9 WRITE(ERVAL,'(F27.16)')ercons*1.d9 unit='/mHz' c if(kap.eq.0.and.jp.eq.8.and.kp.eq.0)connam='LJ' if(kap.eq.0.and.jp.eq.6.and.kp.eq.2)connam='LJJK' if(kap.eq.0.and.jp.eq.4.and.kp.eq.4)connam='LJK' if(kap.eq.0.and.jp.eq.2.and.kp.eq.6)connam='LKKJ' if(kap.eq.0.and.jp.eq.0.and.kp.eq.8)connam='LK' if(kap.eq.2.and.jp.eq.6.and.kp.eq.0)connam='lJ=l1' if(kap.eq.2.and.jp.eq.4.and.kp.eq.2)connam='lJK' if(kap.eq.2.and.jp.eq.2.and.kp.eq.4)connam='lKJ' if(kap.eq.2.and.jp.eq.0.and.kp.eq.6)connam='lK' c if(kap.eq.4.and.jp.eq.4.and.kp.eq.0)connam='l2' if(kap.eq.6.and.jp.eq.2.and.kp.eq.0)connam='l3' if(kap.eq.8.and.jp.eq.0.and.kp.eq.0)connam='l4' c endif endif c endif if(connam(1:4).eq.'BETA')unit='/deg' if(connam(1:4).eq.'ALPH')unit='/deg' if(connam(1:3).eq.'RHO')unit=' ' c CALL CONFOR(CONVAL,ERVAL,NDCON,NDEROR,nerd) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) 518 format(a,'(',a,')') linout=line(1:55)//' '//connam//unit// * cwork(1:len_trim(cwork)) WRITE(3,'(a)')linout(1:len_trim(linout)) goto 32 c 35 WRITE(3,'(a)')line(1:len_trim(line)) goto 32 c c...echo all lines between the CORRELATION and PREDICTIONS headers c 34 WRITE(3,'(a)')line(1:len_trim(line)) 33 read(2,'(a)')line IF(LINE(2:12).NE.'PREDICTIONS')then WRITE(3,'(a)')line(1:len_trim(line)) goto 33 endif c write(3,212) 212 format(93('-')/93('-')) c close(2) ERHAM output close(3) RES output c stop c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c Error messages c 330 write(*,332)filout(1:len_trim(filout)) 332 format(1x//' ERROR on input from: ',a// * ' End of file while searching for the string SINGULAR'//) goto 331 c 331 close(2) close(3) stop c 400 write(*,401)note 401 format(1x//' ERROR: cannot read IS,IS2 from string NOTE ='/1x,a//) stop c end C_____________________________________________________________________________ c SUBROUTINE CONFOR(CONVAL,ERVAL,NDCON,NDEROR,NERD) C C Constant and error formating for output c c CONVAL - string containing the constant value, to be c input in F format and will be replaced on output by result c string of length extending to the last digit of the error c ERVAL - string containing the error value, to be c input in F format and will be replaced on output by result c string, this does not contain the decimal point and is meant c to be included in brackets c NDCON - number of digits in the constant value c NDEROR - number of digits in the error value c both NDCON and NDEROR are generated on output c NERD - number of error digits which is to be set on input C IMPLICIT INTEGER*2 (I-N) CHARACTER*27 CONVAL,ERVAL,CONOUT,EROUT C NDEROR=0 NDNOTZ=0 ICZERO=0 erout='???????????' C C...Go through digits of constant value adding those to output buffer while C checking at the same time digits of the error value, reacting as C necessary. C Terminate when either NERD digits in the error value are C transferred or, if error has more digits before the decimal C point, the decimal point is reached. C conout(1:2)=conval(1:2) ndcon=2 DO 1 N=3,27 NDCON=NDCON+1 CONOUT(NDCON:NDCON)=CONVAL(N:N) C C...ensure that zero precedes the decimal point and use ICZERO to monitor C whether decimal point has been reached IF(CONVAL(N:N).EQ.'.')ICZERO=1 IF(CONVAL(N:N).EQ.'.'.AND.CONVAL(N-1:N-1).EQ.' ') * CONOUT(NDCON-1:NDCON-1)='0' IF(CONVAL(N:N).EQ.'.'.AND.CONVAL(N-1:N-1).EQ.'-')THEN CONOUT(NDCON-2:NDCON-2)='-' CONOUT(NDCON-1:NDCON-1)='0' ENDIF C C...use NDNOTZ (number of digits not zero) to monitor whether significant C digits in constant value have been reached IF(CONVAL(N:N).GE.'1'.AND.CONVAL(N:N).LE.'9') * NDNOTZ=NDNOTZ+1 C C...do not transfer error digit if it is a leading zero, dot or space IF(NDEROR.EQ.0 .AND. (ERVAL(N:N).EQ.' '.OR. * ERVAL(N:N).EQ.'0'.OR.ERVAL(N:N).EQ.'.') )GOTO 1 C C...exit if error larger than value and decimal point reached IF(NDEROR.GE.NERD .AND. NDNOTZ.GT.0 .AND. ICZERO.EQ.1)GOTO 2 C C...do not transfer the dot in error value IF(ERVAL(N:N).EQ.'.')GOTO 1 C C...transfer error digits until NERD or, if more, the first significant C digit in value is reached NDEROR=NDEROR+1 EROUT(NDEROR:NDEROR)=ERVAL(N:N) IF(NDEROR.GE.NERD .AND. NDNOTZ.GT.0 .AND. ICZERO.EQ.1)GOTO 2 1 CONTINUE c 2 CONVAL(1:NDCON)=CONOUT(1:NDCON) if(nderor.gt.0)ERVAL(1:NDEROR)=EROUT(1:NDEROR) C RETURN END C C_____________________________________________________________________________ c subroutine linann(linlin,linapp,napp) c c Reads a line from the .lin file, identifies and writes annotations c to the output file c c Deals with multiline annotations concatenated by generation of a .LIN c file from within ASFIT c c LINAPP - string to be appended to the output for the current line c NAPP - number of characters in the appended string, abbreviated in order c not to exceed LINAPP length c c integer lentrm,napps,nappe character linlin*100,linapp*80 c linapp(1:1)=' ' napp=1 c ncars=lentrm(linlin) nloop=1 c 4 nstart=nloop do 1 n=nstart,ncars c c...annotation line inserted between listed lines c if(linlin(n:n).eq.'!')then c if(n.lt.ncars)then if(linlin(n+1:n+1).eq.'!')then write(3,'(''!'')') / OUTPUT of annotation goto 1 endif else write(3,'(''!'')') / OUTPUT of annotation return endif c do 3 nn=n+1,ncars c if(linlin(nn:nn).eq.'!')then write(3,'(a)')linlin(n:nn-1) / OUTPUT of annotation nloop=nn goto 4 endif c if(linlin(nn:nn).eq.'#')then write(3,'(a)')linlin(n:nn-1) / OUTPUT of annotation napp=ncars-nn if(napp.eq.0)then napp=1 return endif linapp(1:napp)=linlin(nn+1:ncars) goto 5 endif c if(nn.eq.ncars)then write(3,'(a)')linlin(n:nn) / OUTPUT of annotation return endif 3 continue c endif c c...annotation at the end of a line c if(linlin(n:n).eq.'#')then napp=ncars-n if(napp.eq.0)then napp=1 return endif linapp(1:napp)=linlin(n+1:ncars) goto 5 endif c c...remove leading zeros (if any) from appended comment c 5 if(napp.gt.1.and.linapp(1:1).eq.' ')then napp=napp-1 linapp(1:napp)=linapp(2:napp+1) goto 5 endif c 1 continue c 2 return c 6 write(*,7)linlin(1:len_trim(linlin)) 7 format(1x// * ' ERROR on reading from the following line in the .LIN file:' * /1xa//) stop c end C c_____________________________________________________________________________ C C Actual length of a string (equivalent to LEN_TRIM) C integer function lentrm(carg) character carg*(*) integer nn,n c nn=len(carg) do 1 n=nn,1,-1 if(carg(n:n).gt.' ')goto 2 1 continue 2 lentrm=n if(lentrm.lt.1)lentrm=1 c return end C C____________________________________________________________________________ C_____________________________________________________________________________