C------------------------------------------------------------------------------- C C VIFORM - Formatter of output from Vadim Ilyushin's threefold+sixfold C internal rotation programs RAM36 and RAM36HF to produce: C C 1/ LIN type file for use in AABS C 2/ RES type files for use with AC C 3/ file with readable parameters of fit and the C correlation matrix C C C input is from: C NAME.OUT unit4 C NAME.INP unit12 C C main output is to: C NAME.RES unit8 C NAME.LIN unit3 reused C C additional optional output is to C NAME_frequency.RES unit2 C NAME_frequency.LIN unit3 C NAME.CON (constants+correlation matrix) unit7 C NAME_original.res unit2 reused C c where NAME.OUT is the name of the RAM36 output file (NAME can be any c string, extension .OUT is mandatory) C C The file NAME.RES is a concatenation of output in NAME_original.RES and C NAME.CON and is the main formatted output file intended for routine inspection. c C C Note that in this version (as from VADLIN5): C C 1/ 2*F*rho is a paramater of fit instead of rho C 2/ A in fitted parameter A-(B+C)/2 is now A_eff i.e. as resulting from C the Watsonian fit and thus without the contribution I_alpha from C the internal rotor group C C C C ver. 20.10.2023 ----- 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 4.06.2008: Created as VADLIN, which became VADLIN1 after some format C changes in Vadim's output C 24.09.2009: Derived from VADLIN1 by addition of correlation matrix c output to the VADLIN.CON file and printout of various c derived constants C 9.04.2009 Derived from VADLIN2 by modifying the 'simple formulae' output C 28.04.2009 Derived from VADLIN3 to account for fitting -2*F*rho instead of rho C 15.07.2009 Derived from VADLIN4 to account for changes in signs of quartics C 27.07.2010 Derived from VADLIN5 to account for changes in V6,dj,dk notation C 4.10.2010 Derived from VADLIN7 to account for format change in measured line C 14.11.2010 Derived from VADLIN8 after receiving the EXE and readme for V6 C 12.12.2012 Changes for compatibility with RAM36 (which is replacing V6) C 18.12.2015 Changes to improve the convenience of working with RAM36 C 12.01.2016 More of the above c 27.01.2016 Addition of the comprehensive MOLNAM.RES output c 1.08.2016 Debugging + small mods c 8.08.2016 Tidying up output files c 30.03.2018: Modifications to .RES output c 15.12.2019: Correction to derived V6 output c 27.03.2020: Adaptation to deal also with RAM36HF c 8.11.2020: Transition commenting upgraded to the level in PIFORM c 23.11.2020: Transfer subset statistics from OUT to RES c 15.01.2021: Selection of output files C 28.01.2021: Debugging I_alpha output and other I/O C 18.02.2021: Modifying statistics output in header + debugging C 20.10.2023: More robust operation when fit goes bad C C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c for RAM36 conversion is from: c (note that first character of upper state symmetry descriptor replaced by c to keep column count) c c Upper level Lower level Intensity Measured Calculated o.-c. Elow Strength incl comment c2 0 5 1 5 B1 0 4 1 4 0.170E+00 8708.6259( 0.0100) 8708.6144(0.0085) 0.0115 0.313E+01 2.025 1 ! c2 -3 5 1 5 A1 -3 4 1 4 0.228E+00 8817.8716( 0.0100) 8817.8685(0.0101) 0.0031 0.540E+02 3.375 1 ! c c to: C c 2 0 2 -3 1 0 1 -3 0 0 0 0 8513.2168 0.015 1.0000 c 2 1 1 -3 1 1 0 -3 0 0 0 0 9097.4556 0.015 1.0000 # giant doublet c C___:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____| c for RAM36HF conversion is from: c (note that first character of upper state symmetry descriptor replaced by c to keep column count) c c Upper level Lower level Intensity Measured Calculated o.-c. Elow Strength incl comment c2 0 6.0 6 1 5 B1 0 6.0 6 1 6 0.747E-01 3019.1949( 0.0020) 3019.1942(0.0012) 0.0007 0.376E+01 7.411 1 ! Q-type m=0 c2 0 7.0 6 1 5 B1 0 7.0 6 1 6 0.886E-01 3019.3376( 0.0020) 3019.3361(0.0010) 0.0015 0.376E+01 8.791 1 c1 2 -1.0 8 1 7 E1 2 -1.0 7 1 6 0.127E+03 14776.8665( 0.0100) 14776.8660(0.0077) 0.0005 0.254E+02 582.445 1 c1 3 -1.0 8 3 6 B2 3 -1.0 7 3 5 0.106E+03 14831.3561( 0.0100) 14831.3962(0.0099) -0.0401 0.514E+02 550.074 1 c c to: C c 6 1 5 0 6 6 1 6 0 6 0 0 3019.1949 0.002 1.0000 ! Q-type m=0 c 8 1 7 2 -1 7 1 6 2 -1 0 0 14776.8665 0.010 1.0000 c c C___:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____| C implicit real*8 (a-h,o-z) character line*200,inptxt*200,prefix*2,conval*27,erval*27, * cwork*42,lout1*100,lout2*100,lout3*100,indbad*1, * comnt*12,strdat*100,trind*1,coment*200,lincom*200, * linout*200,appstr*2,nfitpar*50,cmcon*35,errtxt*100 character filinp*200,filgen*200,filout*200,cfupper*3,cflower*3 character*200 rmserr(50),rmssym(20),rmstor(20) real*8 ial,ia,iaef c PARAMETER (maxlin=20000,maxpar=300) c real*8 parcm(maxpar),eparcm(maxpar) C COMMON /SORTCC/OMINC,IPT INTEGER*2 IPT(maxlin) REAL*8 OMINC(maxlin),blend(maxlin,2) C C C...Type of output: this is determined by the value of the flaf C INPOUT which is set below and requires recompiling the program C C INPOUT = 0 output limited to .RES and .LIN files C = 1 four additional output files as specified in C the header above C INPOUT=0 C c c...Type of input: this is determined by VIFORM on the basis of c the .OUT file and is coded by an appropriate value of the flag IRAM36HF: c c IRAM36HF = -1 undefined c = 0 RAM36 c iram36hf=-1 c c WRITE(*,5500) 5500 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | VIFORM - Formatter of output from Vadim Ilyushin''s', * T79,'|'/ * ' | internal rotation programs RAM36 and RAM36HF', * T79,'|'/ * ' |',76(1H_),'|'/' version 20.X.2023',T64,'Zbigniew KISIEL'/) c icrho=0 nlines=0 ninfit=0 nblnd=0 lstr0=0 lstrm1=0 frlast=0.d0 nblend=0 c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Locate and transform the data lines: c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c There are three output blocks for lines in the fit: c C first - ordered in frequency c second - in the order of the dataset c third - sorted into branches c c Headers of the three blocks in RAM36 are as below: c cElowest is used only in intensity calculation c Upper level Lower level Intensity Measured Calculated o.-c. Elow Strength incl comment c2 0 5 2 3 A1 0 5 2 4 0.118E-01 3507.2349( 0.0020) 3507.2349(0.0001) 0.0000 0.501E+01 0.875 1 c2 0 1 0 1 A1 0 0 0 0 0.142E-01 4266.3395( 0.0040) 4266.3343(0.0000) 0.0052 0.240E+01 0.703 1 c c cOutput in the original order defined in input file c Upper level Lower level Intensity Measured Calculated o.-c. Elow Strength incl comment c2 -3 31 7 24 A2 -3 31 7 25 0.890E-01 9552.2787( 0.0200) 9552.2832(0.0028) -0.0045 0.138E+03 1.533 1 c2 -3 32 7 25 A1 -3 32 7 26 0.146E+00 12918.7833( 0.0200) 12918.7906(0.0037) -0.0073 0.142E+03 1.402 1 c c cTransitions sorted by branch c c Upper level Lower level Intensity Measured Calculated o.-c. Elow Strength incl comment c1 1.00 -3 2 0 2 B2 -1.00 -3 1 0 1 0.552E-01 8513.2174( 0.0050) 8513.2248(0.0001) -0.0074 0.529E+02 0.843 1 c2 -1.00 -3 3 0 3 B1 1.00 -3 2 0 2 0.185E+00 12723.0622( 0.0050) 12723.0641(0.0001) -0.0019 0.532E+02 1.264 1 c C___:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____|____:____| c c Headers of the three blocks in RAM36HF are as below: c cElowest is used only in intensity calculation cIt is not subtracted from the values given in column Elow c Upper level Lower level Intensity Measured Calculated o.-c. Elow Strength incl comment c2 0 5 1 5 B1 0 4 1 4 0.170E+00 8708.6259( 0.0100) 8708.6144(0.0085) 0.0115 0.313E+01 2.025 1 ! c2 -3 5 1 5 A1 -3 4 1 4 0.228E+00 8817.8716( 0.0100) 8817.8685(0.0101) 0.0031 0.540E+02 3.375 1 ! c c cOutput in the original order defined in input file c Upper level Lower level Intensity Measured Calculated o.-c. Elow Strength incl comment c1 0 3.0 2 0 2 A2 0 2.0 1 0 1 0.171E+01 3629.7406( 0.0020) 3629.7404(0.0002) 0.0002 0.244E+01 116.647 1 !! m=0 ! c1 0 2.0 2 0 2 A2 0 2.0 1 0 1 0.305E+00 3628.3902( 0.0020) 3628.3903(0.0004) -0.0001 0.244E+01 20.830 1 c c cTransitions sorted by branch c c Upper level Lower level Intensity Measured Calculated o.-c. Elow Strength incl comment c2 -1.00 -3 -1.0 5 0 5 B1 1.00 -3 -1.0 4 0 4 0.269E+02 9070.1364( 0.0100) 9070.1227(0.0045) 0.0137 0.534E+02 374.956 1 !! m=-3 ! c1 1.00 -3 -1.0 6 0 6 B2 -1.00 -3 -1.0 5 0 5 0.463E+02 10877.6862( 0.0100) 10877.6859(0.0052) 0.0003 0.537E+02 449.923 1 c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Conversion for RAM36 is to .LIN lines: c c 2 0 2 -3 1 0 1 -3 0 0 0 0 8513.2168 0.015 1.0000 c 2 1 1 -3 1 1 0 -3 0 0 0 0 9097.4556 0.015 1.0000 # giant doublet c c and to .RES lines: c c310: 32 25 8 0 31 24 7 0 213849.3893 0.0355 0.050 c311/ 44 25 20 0 43 24 19 0 268955.0592 -0.1956 0.050 c312: 58 25 34 0 57 24 33 0 332565.0015 0.0391 0.050 -0.0637 0.50 c313: 58 25 33 0 57 24 34 0 332565.0015 -0.1666 0.050 -0.0637 0.50 c 62: 46 13 34 46 12 35 34632.4660 -0.314 UNFITTD 34632.7809 c314: 26 26 1 0 25 25 0 0 188987.8353 -0.0077 0.050 bR 1, 1 c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Conversion for RAM36HF is to .LIN lines: c c 6 1 5 0 6 6 1 6 0 6 0 0 3019.1949 0.002 1.0000 ! Q-type m=0 c 8 1 7 2 -1 7 1 6 2 -1 0 0 14776.8665 0.010 1.0000 c c and to .RES lines: c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...decide on input and output c 50 write(*,'(1x// *5x,'' Generic name MOLNAM for the RAM36 input and output files''/ *5x,'' (input is expected in MOLNAM.INP and output in MOLNAM.OUT)'' * // *5x,'' .... '',$)') read(*,'(a)',err=50)filgen nfilgn=len_trim(filgen) if(nfilgn.lt.1)goto 50 filout=filgen(1:len_trim(filgen))//'.out' filinp=filgen(1:len_trim(filgen))//'.inp' c open(12,file=filinp(1:len_trim(filinp)),status='old',err=30) 12 = RAM36/HF input read(12,*)isigma,idelm read(12,*)ktronc,nvt,ispecf open(4,file=filout(1:len_trim(filinp)),status='old',err=8) 4 = RAM36/HF output c c...read date and time strings from the top of the .OUT file c read(4,'(a)')lout1 OUT input read(4,'(a)')lout2 c c...read isigma and idelm c 102 read(4,'(a)')line if(line(2:8).eq.'isigma=')then read(line(20:20),'(i1)')isigma OUT input read(line(40:40),'(i1)')idelm OUT input goto 102 endif c c...read the cutoff criterion for frequencies (here distinction between c RAM36 and RAM36HF is made) c 101 read(4,'(a)')line if(line(2:21).ne.'maximum ratio of o-c')goto 101 c read(4,'(a)')line if(line(2:8).eq.'allowed')then iram36hf=0 read(4,'(a)')line read(line(43:),'(f19.14)')fcut else iram36hf=1 read(4,'(a)')line read(4,'(a)')line c write(*,'(1x,a/)')line(1:len_trim(line)) debug c pause debug read(line(1:19),'(F19.13)')fcut endif c c...find the number of fitted parameters c errtxt='EOF on scanning .OUT file for Number of fitted parameters' 103 read(4,'(a)',end=115)line OUT input if(line(2:28).ne.'Number of fitted parameters')goto 103 nfitpar=line c c c...Deal with the block of frequency sorted lines c if(inpout.eq.1)then open(3,file=filgen(1:nfilgn)//'_frequency.lin',status='unknown') open(2,file=filgen(1:nfilgn)//'_frequency.res',status='unknown') endif c strdat=lout1(1:len_trim(lout1))//', '//lout2(1:len_trim(lout2)) if(inpout.eq.1) * write(2,'(72(1h-)/''Fit dated: '',a/72(1h-)//a/)') * strdat(1:len_trim(strdat)),'Output in order of frequency:' optional RES c c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Frequency sorted output block c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c 1 read(4,'(a)')line OUT input c c EWRMS,NEV6LIN,ERMSMHZ are statistics after each fitting cycle. c Successive cycles erase previous values so that only those after c the final cycle are retained. c c write(*,*)line(1:70) debug if(line(2:6).eq.'wrms=')then read(line(7:26),'(f20.10)')ewrms read(line(36:47),'(i12)')nev6lin read(4,'(a)')line read(line(12:36),'(f25.10)')ermsmhz goto 1 endif c nomc=0 sumomc=0.d0 sumomcw=0.d0 nomcnet=0 sumomcnet=0.d0 sumomcwnet=0.d0 cc c...skip to the top of the frequency sorted upper block c if( line(8:18) .ne.'Upper level'. * and.line(14:24).ne.'Upper level')goto 1 c write(*,'(1x/'' Number of processed lines:''//1x,$)') c c c...Loop over line entries c 5 read(4,'(a)',end=6)line OUT input of transition c c...process 'calculated frequency of the blend' line c if(line(1:33).eq.'calculated frequency of the blend')then ignore calc. fr. of blend nblend=nblend+1 if(iram36hf.eq.0)then if(line(52:52).ne.'*')then read(line(52: 65),'(f14.4)')blend(nblend,1) else blend(nblend,1)=1.d+10 endif if(line(97:97).ne.'*')then read(line(97:106),'(f10.4)')blend(nblend,2) else blend(nblend,2)=1.d+10 endif else if(line(64:64).ne.'*')then read(line(64: 77),'(f14.4)')blend(nblend,1) else blend(nblend,1)=1.d+10 endif if(line(109:109).ne.'*')then read(line(109:118),'(f10.4)')blend(nblend,2) else blend(nblend,2)=1.d+10 endif endif goto 5 endif c if(iram36hf.eq.0.and.len_trim(line).lt.129)goto 6 if(iram36hf.eq.1.and.len_trim(line).lt.141)goto 6 c c c...convert the line to a .LIN line c c Mark as excluded (error increased to 900.xx): c 1/ lines with fitting parameter of zero c 2/ lines with obs-calc all stars c 3/ lines with linestrength set to -1 c c__RAM36 c if(iram36hf.eq.0)then prefix=' ' if(line(131:131).eq.'0'.or.line(104:106).eq.'***')prefix='90' if(line(123:124).eq.'-1')prefix='90' c if(inpout.eq.1) * write(3,'(100A)') * line( 7: 9),line(11:13),line(15:17),line( 3: 5), qnupper * line(28:30),line(32:34),line(36:38),line(24:26), qnlower * ' 0 0 0 0', remaining * line(52:65),' ', freq * prefix,line(68:73), error * ' 1.00000 ',line(133:144) final nlines=nlines+1 if((nlines/50)*50.eq.nlines)then write(*,'(1H+,i8,$)')nlines endif endif c c__RAM36HF c if(iram36hf.eq.1)then prefix=' ' if(line(143:143).eq.'0'.or.line(104:106).eq.'***')prefix='90' if(line(135:136).eq.'-1')prefix='90' c read(line( 6:11),'(f6.1)')fupper if(fupper.lt.0.d0)then ifupper=-1 else fupper=fupper+0.25d0 ifupper=nint(fupper) endif write(cfupper,'(i3)')ifupper c read(line(33:38),'(f6.1)')flower if(flower.lt.0.d0)then iflower=-1 else flower=flower+0.25d0 iflower=nint(flower) endif write(cflower,'(i3)')iflower c if(inpout.eq.1) * write(3,'(100A)') * line(13:15),line(17:19),line(21:23),line( 3: 5),cfupper, qnupper * line(40:42),line(44:46),line(48:50),line(30:32),cflower, qnlower * ' 0 0', remaining * line(64:77),' ', freq * prefix,line(80:85), error * ' 1.00000 ',line(133:144) final nlines=nlines+1 if((nlines/50)*50.eq.nlines)then write(*,'(1H+,i8,$)')nlines endif endif c c c...convert to a .RES line: c c NOTE: the end of line comment is read into COMNT from the .OUT c file and is subject to the 12-character truncation that RAM36 c enforces on .INP -> .OUT c c c Output formats for RAM36: c c310: 32 25 8 0 31 24 7 0 213849.3893 0.0355 0.050 c311/ 44 25 20 0 43 24 19 0 268955.0592 -0.1956 0.050 c312: 58 25 34 0 57 24 33 0 332565.0015 0.0391 0.050 -0.0637 0.50 c313: 58 25 33 0 57 24 34 0 332565.0015 -0.1666 0.050 -0.0637 0.50 c 62: 46 13 34 46 12 35 34632.4660 -0.314 UNFITTD 34632.7809 c c671: 19 10 10 18 9 9 113415.2332 0.0227 0.050 bR 1, 1 c c__RAM36 c if(iram36hf.eq.0)then if(line(52:52).eq.'*')then fmeas=1.d+10 else read(line(52:65),'(f14.4)')fmeas endif if(fmeas.eq.flast)then nblnd=nblnd+1 else flast=fmeas endif if(line(75:75).eq.'*')then fcalc=1.d+10 else read(line(75:88),'(f14.4)')fcalc endif if(line(67:67).eq.'*')then ferror=1.d+10 else read(line(67:73),'(f7.4)')ferror endif if(line(97:106).eq.'**********')then fomc=1.d+10 else read(line(97:106),'(f10.4)')fomc endif read(line(131:131),'(i1)')ifit read(line(119:128),'(f10.3)',err=500)stren if(stren.eq. 0.d0)lstr0=lstr0+1 if(stren.eq.-1.d0)lstrm1=lstrm1+1 if(ifit.eq.1.and.stren.gt.-1.0d0)then ninfit=ninfit+1 nomc=nomc+1 sumomc=sumomc+fomc*fomc sumomcw=sumomcw+(fomc/ferror)**2 if(dabs(fomc/ferror).le.fcut)then nomcnet=nomcnet+1 sumomcnet=sumomcnet+fomc*fomc sumomcwnet=sumomcwnet+(fomc/ferror)**2 endif else ifit=0 endif read(line(133:144),'(a12)')comnt c if(abs(fomc).gt.3.d0*ferror)then indbad='/' else indbad=':' endif c if(inpout.eq.1)then if(ifit.eq.1)then write(2,200)nlines,indbad, * line( 7: 9),line(11:13),line(15:17),line( 3: 5), qnupper * line(28:30),line(32:34),line(36:38),line(24:26), qnlower * fmeas,fomc,ferror,comnt else write(2,201)nlines,indbad, * line( 7: 9),line(11:13),line(15:17),line( 3: 5), qnupper * line(28:30),line(32:34),line(36:38),line(24:26), qnlower * fmeas,fomc,fcalc,comnt endif endif endif 200 format(i4,a1,4a3,2x,4a3,f24.4,f9.4,f7.3,1x,a12) 201 format(i4,a1,4a3,2x,4a3,f24.4,f8.3,' UNFITTD',f13.4,1x,a12) c c__RAM36HF c if(iram36hf.eq.1)then if(line(64:64).ne.'*')then read(line(64:77),'(f14.4)')fmeas else fmeas=1.d+10 endif if(fmeas.eq.flast)then nblnd=nblnd+1 else flast=fmeas endif if(line(87:87).ne.'*')then read(line(87:100),'(f14.4)')fcalc else fcalc=1.d+10 endif read(line(79:85),'(f7.4)')ferror if(line(109:109).ne.'*')then read(line(109:118),'(f10.4)')fomc else fomc=1.d+10 endif read(line(143:143),'(i1)')ifit read(line(131:140),'(f10.3)',err=500)stren if(stren.eq. 0.d0)lstr0=lstr0+1 if(stren.eq.-1.d0)lstrm1=lstrm1+1 if(ifit.eq.1.and.stren.gt.-1.0d0)then ninfit=ninfit+1 nomc=nomc+1 sumomc=sumomc+fomc*fomc sumomcw=sumomcw+(fomc/ferror)**2 if(dabs(fomc/ferror).le.fcut)then nomcnet=nomcnet+1 sumomcnet=sumomcnet+fomc*fomc sumomcwnet=sumomcwnet+(fomc/ferror)**2 endif else ifit=0 endif read(line(145:156),'(a12)')comnt c if(abs(fomc).gt.3.d0*ferror)then indbad='/' else indbad=':' endif c if(inpout.eq.1)then if(ifit.eq.1)then write(2,1200)nlines,indbad, * line(13:15),line(17:19),line(21:23),line( 3: 5),cfupper, qnupper * line(40:42),line(44:46),line(48:50),line(30:32),cflower, qnlower * fmeas,fomc,ferror,comnt else write(2,1201)nlines,indbad, * line(13:15),line(17:19),line(21:23),line( 3: 5),cfupper, qnupper * line(40:42),line(44:46),line(48:50),line(30:32),cflower, qnlower * fmeas,fomc,fcalc,comnt endif endif endif 1200 format(i4,a1,5a3,2x,5a3,f21.4,f9.4,f7.3,1x,a12) 1201 format(i4,a1,5a3,2x,5a3,f21.4,f8.3,' UNFITTD',f13.4,1x,a12) c c goto 5 c 500 if(inpout.eq.1)write(2,'('' unreadable line'')') goto 5 c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Conclusion of the frequency sorted block c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c WRMS,NV6LIN,RMSMHZ are final fit statistics from the end of c the frequency sorted block c 6 read(4,'(a)')line OUT input read(line(7:26),'(f20.10)')wrms read(line(36:47),'(i12)')nv6lin read(4,'(a)')line OUT input read(line(12:36),'(f25.10)')rmsmhz if(inpout.eq.1) * write(2,202)fcut, nv6lin, nev6lin, optional RES * rmsmhz, ermsmhz, * wrms, ewrms 202 format(1x/ * ' no exclusions only (o-c)/df <', * F8.2// * ' Ninfit = ',i8,15x,i8/ * ' sigma_fit/MHz = ',f15.6,8x,f15.6/ * ' sigma_rms = ',f15.6,8x,f15.6) c if(inpout.eq.1)close(3) if(inpout.eq.1)then write(2,'(1x/43x,37(''_'')/42(''_''), optional RES * ''/ RAM36 output reformatted with VIFORM''/)') close(2) endif write(*,'(1x// * '' Total = '',I6/ )')nlines write(*,'('' Lstr > -1 and IFIT=1 = '',I6 )')ninfit write(*,'('' Blends = '',I6 )')nblend write(*,'('' Extra components in blends = '',I6/ )')nblnd c write(*,'('' Lines in fit (Lstr>-1-extra) = '',I6 )')ninfit-nblnd c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Extract from the .OUT file the subset rms statistics for groups: c 1/ according to declared measurement uncertainty c 2/ by symmetry species c 3/ by torsional state C as found just below the frequency sorted block c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c nrmserr=0 nrmssym=0 nrmstor=0 c 600 read(4,'(a)')line OUT input if(line(1:6).eq.'rmscat')then nrmserr=nrmserr+1 rmserr(nrmserr)=line(1:len_trim(line)) goto 600 endif c read(4,'(a)')line OUT input read(4,'(a)')line OUT input read(4,'(a)')line OUT input read(4,'(a)')line OUT input 601 read(4,'(a)')line OUT input if(line(1:10).eq.'rmscat_MHz')then nrmssym=nrmssym+1 rmssym(nrmssym)=line(1:len_trim(line)) goto 601 endif c read(4,'(a)')line OUT input 602 read(4,'(a)')line OUT input if(line(1:10).eq.'rmscat_MHz')then nrmstor=nrmstor+1 rmstor(nrmstor)=line(1:len_trim(line)) goto 602 endif c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Convert constants into readable form and output in NAME.CON with such c strings appended to normal output lines for constants c C Use the 'Parameters in MHz' block in the .OUT file c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c if(inpout.eq.1) * open(7,file=filgen(1:nfilgn)//'.con',status='unknown') CON output open(8,file=filgen(1:nfilgn)//'.res' ,status='unknown') RES output c c c...read the final cm-1 parameter values c numpar=0 113 read(4,'(a)',end=111)line OUT input if(line(1:21).ne.' Parameters in cm-1:')goto 113 c 114 read(4,'(a)',end=111)line if(line(1:29).eq.' Parameters in cm-1 truncated')goto 10 if(line(1:20).eq.' Parameters in MHz:')goto 1010 all parameters fixed numpar=numpar+1 read(line(56:82),'(d27.2)')parcm(numpar) read(line(84:94),'(d11.2)')eparcm(numpar) goto 114 c c c...read and process the final MHz parameter values: c 10 read(4,'(a)',end=111)line if(line(1:20).ne.' Parameters in MHz:')goto 10 c 1010 if(inpout.eq.1) * write(7,'(90(1h-)/''Fit dated: '',a/90(1h-))') optional CON output * strdat(1:len_trim(strdat)) write(8,'(90(1h-)/''Fit dated: '',a/90(1h-))') RES output * strdat(1:len_trim(strdat)) c nomc=nomc-nblend nomcnet=nomcnet-nblend sumomc = dsqrt(sumomc /nomc) sumomcw = dsqrt(sumomcw /nomc) sumomcnet = dsqrt(sumomcnet /nomcnet) sumomcwnet = dsqrt(sumomcwnet/nomcnet) c if(inpout.eq.1) * write(7,202)fcut,nv6lin,nev6lin, optional CON output * rmsmhz,ermsmhz, * wrms,ewrms c write(8,'(1x/ * '' Total lines in .INP file = '',I6/ )')nlines write(8,'('' Excluded from fit = '',I6 )')nlines-ninfit write(8,'('' Submitted for fitting = '',I6 )')ninfit write(8,'('' Blends = '',I6 )')nblend write(8,'('' Distinct fitted frequencies = '',I6 )')ninfit-nblend c write(8,2002) fcut, nv6lin, nomc, nomcnet, * rmsmhz, sumomc, sumomcnet, * wrms, sumomcw, sumomcwnet 2002 format(1x/25x, * 'from RAM36 output recalculated from RAM36 frequency table'/ * 46x,' all fitted only (o-c)/df <',F8.2// * ' Ninfit = ',i15,2i22/ * ' sigma_fit/MHz = ',3f22.6/ * ' sigma_rms = ',3f22.6) c c write(8,202)fcut,nv6lin,nev6lin, RES output: fit statistics c * rmsmhz,ermsmhz, c * wrms,ewrms c write(8,'(1x/a)')nfitpar(1:len_trim(nfitpar)) c write(8,'(1x//1x, RES output: subset statistics * ''Subset statistics (without special treatment of blends):''/)') c do 603 n=1,nrmserr write(8,'(a)')rmserr(n)(1:len_trim(rmserr(nrmserr))) 603 continue write(8,'(1x)') do 604 n=1,nrmssym write(8,'(a)')rmssym(n)(1:len_trim(rmssym(nrmssym))) 604 continue write(8,'(1x)') do 605 n=1,nrmstor write(8,'(a)')rmstor(n)(1:len_trim(rmstor(nrmstor))) 605 continue write(8,'(1x)') c if(inpout.eq.1)write(7,215) optional CON output write(8,215) RES output 215 format(1x/ * ' Operators in the Hamiltonian:'/ * 12x,'J^2k Jz^n Jx^p Jy^q p_alfa^r cos(3s*alfa) ', * ' sin(3t*alfa)'///28x,'Parameters in MHz: ', * ' _diagonalization stage ', * 'Parameters in cm-1:'/64x,'| _fixed(0),floated(+1),'/ * 28x,'As printed in the output file | |', * ' linked (-1) (* = dimensionless)'/ * 64x,'| |'/ * 12x,'k,n,p,q,r,s,t value',20x,'error | | ', * 'FORMATTED value error'/ * 64x,'| |') c c numpar=0 c 12 read(4,'(a)',end=11)line parameter line if(len_trim(line).lt.106)goto 11 read(line(56:81),'(e26.17)',err=11)const read(line(84:93),'(e10.2)',err=11)ercon read(line(101:106),'(i6)')ifitc c numpar=numpar+1 write(cmcon,'(1pe16.8,0pe11.2)')parcm(numpar),eparcm(numpar) c c...test for fitted or fixed constant (IFIXC=1 for a fixed constant) c ifixc=0 if(abs(const).lt.1.1E-16)then ifixc=1 ascld=0.0d0 endif if(ercon.lt.1.0E-18)then ifixc=1 ascld=const endif c c...fish out constants for calculation of derived constants c if( (line(1:10).eq.'0.5*V6 '.or.line(1:10).eq.'0.5V6 ') * .and.ifitc.ne.-1)then v6mhz=2.d0*const erv6mhz=0.d0 if(ifitc.eq.1)erv6mhz=2.d0*ercon v6cm=v6mhz/29979.2458d0 erv6cm=0.d0 if(ifitc.eq.1)erv6cm=erv6mhz/29979.2458d0 endif c if( (line(1:10).eq.'0.5*V3 '.or.line(1:10).eq.'0.5V3 ') * .and.ifitc.ne.-1)then v3=2.d0*const/29979.2458d0 erv3=0.d0 if(ifitc.eq.1)erv3=2.d0*ercon/29979.2458d0 endif if(line(1:10).eq.'A-0.5(B+C)')then abc=const erabc=ercon endif if(line(1:10).eq.'0.5(B+C) ')then bpc=const erbpc=ercon endif if(line(1:10).eq.'0.5(B-C) '.and.ifitc.ne.-1)then bmc=const erbmc=0.d0 if(ifitc.eq.1)erbmc=ercon endif c if(line(1:10).eq.'F ')then f=const erf=ercon endif c c...There seems to be a bug in RAM36 for ISPECF.NE.0: c 1/ when RHO is fixed it is still multiplied to MHz as if it was in cm-1 c so it needs backconverting to unitless c 2/ when RHO is a floated constant it is left alone so it does not need conversion c if(line(1:10).eq.'RHO ')then if(ispecf.ne.0)then if(ifixc.eq.1)then fixed rho=const/29979.2458d0 errho=ercon/29979.2458d0 const=rho ercon=errho ascld=const else rho=const floated errho=ercon endif else rho=const errho=ercon endif endif c if(line(1:10).eq.'-2*RHO*F ')then icrho=1 rho=-const/(2.d0*F) errho=0.5d0* dsqrt(ercon**2+(0.5d0*rho)**2*erf**2)/F endif c if(line(1:10).eq.'F ')then ef=const/29979.2458d0 eref=ercon/29979.2458d0 endif c if(line(1:10).eq.'-DJ ')then dj=-const*1000.d0 erdj=ercon*1000.d0 endif if(line(1:10).eq.'-DJK ')then djk=-const*1000.d0 erdjk=ercon*1000.d0 endif if(line(1:10).eq.'-DK ')then dk=-const*1000.d0 erdk=ercon*1000.d0 endif if( (line(1:10).eq.'-2*dj '.or.line(1:10).eq.'2dj ') * .and.ifitc.ne.-1)then delj=-0.5d0*const*1000.d0 erdelj=0.d0 if(ifitc.eq.1)erdelj=0.5d0*ercon*1000.d0 endif if( (line(1:10).eq.'-2*dk '.or.line(1:10).eq.'2dk ') * .and.ifitc.ne.-1)then delk=-0.5d0*const*1000.d0 erdelk=0.d0 if(ifitc.eq.1)erdelk=0.5*ercon*1000.d0 endif if( (line(1:10).eq.'2d1 '.or.line(1:10).eq.'2*d1 ') * .and.ifitc.ne.-1)then d1 = 0.5d0*const*1000.d0 erd1=0.d0 if(ifitc.eq.1)erd1 = 0.5d0*ercon*1000.d0 endif if( (line(1:10).eq.'2d2 '.or.line(1:10).eq.'2*d2 ') * .and.ifitc.eq.1)then d2 = 0.5d0*const*1000.d0 erd2=0.d0 if(ifitc.eq.1)erd2 = 0.5d0*ercon*1000.d0 endif c if(line(1:10).eq.'HJ ')then hj= const*1000000.d0 erhj=ercon*1000000.d0 endif if(line(1:10).eq.'HJK ')then hjk= const*1000000.d0 erhjk=ercon*1000000.d0 endif if(line(1:10).eq.'HKJ ')then hkj= const*1000000.d0 erhkj=ercon*1000000.d0 endif if(line(1:10).eq.'HK ')then hk= const*1000000.d0 erhk=ercon*1000000.d0 endif if(line(1:10).eq.'2hj '.and.ifitc.ne.-1)then hhj =0.5d0*const*1000000.d0 erhhj=0.d0 if(ifitc.eq.1)erhhj =0.5d0*ercon*1000000.d0 endif if(line(1:10).eq.'2hjk '.and.ifitc.ne.-1)then hhjk =0.5d0*const*1000000.d0 erhhjk=0.d0 if(ifitc.eq.1)erhhjk=0.5d0*ercon*1000000.d0 endif if(line(1:10).eq.'2hk '.and.ifitc.ne.-1)then hhk =0.5d0*const*1000000.d0 erhhk=0.d0 if(ifitc.eq.1)erhhk =0.5d0*ercon*1000000.d0 endif if(line(1:10).eq.'2h1 '.and.ifitc.ne.-1)then h1 = 0.5d0*const*1000000.d0 erhh1=0.d0 if(ifitc.eq.1)erh1 = 0.5d0*ercon*1000000.d0 endif if(line(1:10).eq.'2h2 '.and.ifitc.ne.-1)then h2 = 0.5d0*const*1000000.d0 erhh2=0.d0 if(ifitc.eq.1)erh2 = 0.5d0*ercon*1000000.d0 endif if(line(1:10).eq.'2h3 '.and.ifitc.ne.-1)then h3 = 0.5d0*const*1000000.d0 erhh3=0.d0 if(ifitc.eq.1)erh3 = 0.5d0*ercon*1000000.d0 endif c c c...CONSTANT OUTPUT c appstr=' ' if(ispecf.ne.0.and.line(1:10).eq.'RHO ') * appstr=' *' c if(ifixc.eq.1)then escld=0.0d0 goto 1003 endif c c c...fitted constant output c WRITE(CONVAL,'(F27.16)')const+1.D-14*const WRITE(ERVAL,'(F27.16)')ercon+1.D-14*ercon call confor(conval,erval,ndcon,nderor,2) <----- c write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) 518 format(a,'(',a,')') write(line(107:),'(a)')cwork(1:len_trim(cwork)) call shortn(line) <----- line=line(1:len_trim(line))//appstr line(96:)=cmcon c if(inpout.eq.1)write(7,'(a)')line(1:len_trim(line))//appstr CON output write(8,'(a)')line(1:len_trim(line))//appstr RES output goto 12 c c c...fixed constant output c 1003 call CONFIX(const,ascld,conval,iend) <----- write(line(107:),'(a)')conval(1:iend) call shortn(line) <----- line=line(1:len_trim(line))//appstr line(96:)=cmcon(1:18) c if(inpout.eq.1)write(7,'(a)')line(1:len_trim(line))//appstr CON output write(8,'(a)')line(1:len_trim(line))//appstr RES output goto 12 c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Work out various derived constants c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c 11 if(inpout.eq.1)write(7,'(1x//''Key parameters:''/)') CON output write(8,'(1x//''Key parameters:''/)') RES output c c if(v3.ne.0.d0)then WRITE(CONVAL,'(F27.16)')v3+1.D-14*v3 if(erv3.ne.0.d0)then WRITE(ERVAL,'(F27.16)')erv3+1.D-14*erv3 call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) else call CONFIX(v3 ,v3 ,conval,iend) <----- write(cwork,'(a)')CONVAL(1:iend) endif if(inpout.eq.1) * write(7,'(2a )')'V3 /cm-1 ',cwork(1:len_trim(cwork)) write(8,'(2a )')'V3 /cm-1 ',cwork(1:len_trim(cwork)) endif c if(ef.ne.0.d0)then WRITE(CONVAL,'(F27.16)')ef+1.D-14*ef if(eref.ne.0.d0)then WRITE(ERVAL,'(F27.16)')eref+1.D-14*eref call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) else call CONFIX(ef ,ef ,conval,iend) <----- write(cwork,'(a)')CONVAL(1:iend) endif if(inpout.eq.1) * write(7,'(2a )')'F /cm-1 ',cwork(1:len_trim(cwork)) write(8,'(2a )')'F /cm-1 ',cwork(1:len_trim(cwork)) endif c if(rho.ne.0.0d0)then WRITE(CONVAL,'(F27.16)')rho+1.D-14*rho if(errho.ne.0.d0)then WRITE(ERVAL,'(F27.16)')errho+1.D-14*errho call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) else call CONFIX(rho ,rho ,conval,iend) <----- write(cwork,'(a)')CONVAL(1:iend) endif if(inpout.eq.1) * write(7,'(2a)')'rho ',cwork(1:len_trim(cwork)) write(8,'(2a)')'rho ',cwork(1:len_trim(cwork)) else if(inpout.eq.1) * write(7,'(2a)')'rho [ 0.0 ]' write(8,'(2a)')'rho [ 0.0 ]' endif c if(inpout.eq.1)write(7,'(1x)') write(8,'(1x)') c aef=abc+bpc eraef=dsqrt(erabc**2+erbpc**2) c b=bpc+bmc erb=dsqrt(erbpc**2+erbmc**2) c=bpc-bmc erc=dsqrt(erbpc**2+erbmc**2) c c if(v6cm.ne.0.d0)then v6ghz=v6mhz/1000.d0 erv6ghz=erv6mhz/1000.d0 WRITE(CONVAL,'(F27.16)')v6ghz+1.D-14*v6ghz WRITE(ERVAL,'(F27.16)')erv6ghz+1.D-14*erv6ghz call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'V6 /GHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'V6 /GHz ',cwork(1:len_trim(cwork)) c WRITE(CONVAL,'(F27.16)')v6cm+1.D-14*v6cm WRITE(ERVAL,'(F27.16)')erv6cm+1.D-14*erv6cm call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'V6 /cm-1 ',cwork(1:len_trim(cwork)) write(8,'(2a)')'V6 /cm-1 ',cwork(1:len_trim(cwork)) c v6cal=(v6ghz/29.9792458d0)*1000.d0/(83.5935d0*4.184d0) erv6cal=(erv6ghz/29.9792458d0)*1000.d0/(83.5935d0*4.184d0) WRITE(CONVAL,'(F27.16)')v6cal+1.D-14*v6cal WRITE(ERVAL,'(F27.16)')erv6cal+1.D-14*erv6cal call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'V6 /cal mol^-1',cwork(1:len_trim(cwork)) write(8,'(2a)')'V6 /cal mol^-1',cwork(1:len_trim(cwork)) write(8,'(1x)') endif c WRITE(CONVAL,'(F27.16)')aef+1.D-14*aef WRITE(ERVAL,'(F27.16)')eraef+1.D-14*eraef call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) *write(7,'(2a)')'A_eff /MHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'A_eff /MHz ',cwork(1:len_trim(cwork)) c if(aef.eq.0.0d0)goto 203 c iaef=505379.0089d0/Aef eriaef=505379.0089d0*eraef/aef**2 WRITE(CONVAL,'(F27.16)')iaef+1.D-14*iaef WRITE(ERVAL,'(F27.16)')eriaef+1.D-14*eriaef call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) *write(7,'(2a)')'I_a^eff /u A^2 ',cwork(1:len_trim(cwork)) write(8,'(2a)')'I_a^eff /u A^2 ',cwork(1:len_trim(cwork)) c c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...I_alpha estimate using A_eff=A+F*rho^2 c a=Aef-F*rho**2 era=2.d0*rho*errho error in rho^2 era=dsqrt( (rho**2)**2*erf**2+f**2*era**2) error in F*rho^2 era=dsqrt(eraef**2+era**2) error in A+F*rho^2 c c aef=A+F*rho**2 c eraef=2.d0*rho*errho error in rho^2 c eraef=dsqrt( (rho**2)**2*erf**2+f**2*eraef**2) error in F*rho^2 c eraef=dsqrt(era**2+eraef**2) error in A+F*rho^2 c ia=505379.0089d0/a eria=505379.006d0*era/a**2 c ial=ia-iaef erial=dsqrt(eria**2+eriaef**2) c WRITE(CONVAL,'(F27.16)')ial+1.D-14*ial WRITE(ERVAL,'(F27.16)')erial+1.D-14*erial call confor(conval,erval,ndcon,nderor,2) <----- c c write(*,*)CONVAL(1:NDCON),' ',ERVAL(1:NDEROR) DEBUG c write(*,*)ndcon,nderor DEBUG c pause DEBUG c write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout1,'(2a)')'I_alpha /u A^2 ',cwork(1:len_trim(cwork)) c WRITE(CONVAL,'(F27.16)')ia+1.D-14*ia WRITE(ERVAL,'(F27.16)')eria+1.D-14*eria call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout2,'(2a)')'I_a^rho /u A^2 ',cwork(1:len_trim(cwork)) c WRITE(CONVAL,'(F27.16)')a+1.D-14*a WRITE(ERVAL,'(F27.16)')era+1.D-14*era call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout3,'(2a)')'A_rho /MHz ',cwork(1:len_trim(cwork)) c c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...I_alpha estimate using A_alpha=F(1-rho) c ial=505379.0089d0/(F*(1.d0-rho)) erinv=dsqrt(F**2*errho**2+(1.d0-rho)**2*erf**2)/505379.0089d0 erial=erinv/(1.d0/ial)**2 c ia=iaef+ial eria=dsqrt(eriaef**2+erial**2) c c iaef=ia-ial c eriaef=dsqrt(eria**2+erial**2) c a=505379.0089D0/ia era=505379.0089d0*eria/ia**2 c c aef=505379.006/iaef c eraef=505379.006d0*eriaef/iaef**2 c WRITE(CONVAL,'(F27.16)')ial+1.D-14*ial WRITE(ERVAL,'(F27.16)')erial+1.D-14*erial call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout1(44:),'(a)')cwork(1:len_trim(cwork)) c WRITE(CONVAL,'(F27.16)')ia+1.D-14*ia WRITE(ERVAL,'(F27.16)')eria+1.D-14*eria call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout2(44:),'(a)')cwork(1:len_trim(cwork)) c WRITE(CONVAL,'(F27.16)')a+1.D-14*a WRITE(ERVAL,'(F27.16)')era+1.D-14*era call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout3(44:),'(a)')cwork(1:len_trim(cwork)) c c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...I_alpha estimate using I_alpha=rho*I_a c ial=rho*IA erial=dsqrt(IA**2*errho**2+rho**2*eria**2) c ia=iaef+ial eria=dsqrt(eriaef**2+erial**2) c c iaef=ia-ial c eriaef=dsqrt(eria**2+erial**2) c a=505379.0089D0/ia era=505379.0089d0*eria/ia**2 c c aef=505379.006/iaef c eraef=505379.006d0*eriaef/iaef**2 c WRITE(CONVAL,'(F27.16)')ial+1.D-14*ial WRITE(ERVAL,'(F27.16)')erial+1.D-14*erial call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout1(68:),'(a)',err=2201)cwork(1:len_trim(cwork)) goto 2202 c 2201 write(*,2203)cwork(1:len_trim(cwork)),conval,erval, * ial,erial,rho,IA 2203 format(1x//1x,70(1h-)/ * ' WARNING: problem with IAL=rho*IA evaluation:' * //1x,a/ * /1x,'conval= ',a * /1x,'erval = ',a/ * /1x,' ial= ',f37.16 * /1x,' erial= ',f37.16 * /1x,' rho= ',f37.16 * /1x,' IA= ',f37.16) if(IA.lt.0.d0)then IA=0.d0 ERIA=0.d0 write(*,'(/1x,''NOTE: Negative IA has been zeroed'')') endif write(*,'(1x,70(1h-)/)') c 2202 WRITE(CONVAL,'(F27.16)')ia+1.D-14*ia WRITE(ERVAL,'(F27.16)')eria+1.D-14*eria call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout2(68:),'(a)')cwork(1:len_trim(cwork)) c WRITE(CONVAL,'(F27.16)')a+1.D-14*a WRITE(ERVAL,'(F27.16)')era+1.D-14*era call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) write(lout3(68:),'(a)')cwork(1:len_trim(cwork)) c if(inpout.eq.1) *write(7,'(1x//2a/)')'Estimate from: A_eff=A+F*rho^2', * ' A_alpha=F(1-rho) I_alpha=rho*I_a' write(8,'(1x//2a/)')'Estimate from: A_eff=A+F*rho^2', * ' A_alpha=F(1-rho) I_alpha=rho*I_a' c if(inpout.eq.1)then write(7,'(a)')lout1(1:len_trim(lout1)) write(7,'(a)')lout2(1:len_trim(lout2)) write(7,'(a)')lout3(1:len_trim(lout3)) endif write(8,'(a)')lout1(1:len_trim(lout1)) write(8,'(a)')lout2(1:len_trim(lout2)) write(8,'(a)')lout3(1:len_trim(lout3)) c c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c..A,B,C c WRITE(CONVAL,'(F27.16)')aef+1.D-14*aef WRITE(ERVAL,'(F27.16)')eraef+1.D-14*eraef call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1)write(7,'(1x)') write(8,'(1x)') if(inpout.eq.1) *write(7,'(2a)')'A_eff /MHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'A_eff /MHz ',cwork(1:len_trim(cwork)) c WRITE(CONVAL,'(F27.16)')b+1.D-14*b WRITE(ERVAL,'(F27.16)')erb+1.D-14*erb call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) *write(7,'(2a)')'B /MHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'B /MHz ',cwork(1:len_trim(cwork)) c WRITE(CONVAL,'(F27.16)')c+1.D-14*c WRITE(ERVAL,'(F27.16)')erc+1.D-14*erc call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) *write(7,'(2a)')'C /MHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'C /MHz ',cwork(1:len_trim(cwork)) c ria=505379.0089d0/aef rib=505379.0089d0/b ric=505379.0089d0/c dria=05379.0089d0*eraef/(a*a) drib=05379.0089d0*erb/(b*b) dric=05379.0089d0*erc/(c*c) defect=ric-ria-rib ddefec=dsqrt(dria**2+drib**2+dric**2) c WRITE(CONVAL,'(F27.16)')defect+1.D-14*defect WRITE(ERVAL,'(F27.16)')ddefec+1.D-14*ddefec call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) *write(7,'(2a)')'Delta_i /u A**2 ',cwork(1:len_trim(cwork)) write(8,'(2a)')'Delta_i /u A**2 ',cwork(1:len_trim(cwork)) c c...Quartics c if(inpout.eq.1)write(7,'(1x)') write(8,'(1x)') if(dj.ne.0.d0)then WRITE(CONVAL,'(F27.16)')dj+1.D-14*dj WRITE(ERVAL,'(F27.16)')erdj+1.D-14*erdj call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'D_J /kHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'D_J /kHz ',cwork(1:len_trim(cwork)) endif c if(djk.ne.0.d0)then WRITE(CONVAL,'(F27.16)')djk+1.D-14*djk WRITE(ERVAL,'(F27.16)')erdjk+1.D-14*erdjk call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'D_JK /kHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'D_JK /kHz ',cwork(1:len_trim(cwork)) endif c if(dk.ne.0.d0)then WRITE(CONVAL,'(F27.16)')dk+1.D-14*dk WRITE(ERVAL,'(F27.16)')erdk+1.D-14*erdk call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'D_K /kHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'D_K /kHz ',cwork(1:len_trim(cwork)) endif c if(delj.ne.0.d0)then WRITE(CONVAL,'(F27.16)')delj+1.D-14*delj WRITE(ERVAL,'(F27.16)')erdelj+1.D-14*erdelj call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'delta_J /kHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'delta_J /kHz ',cwork(1:len_trim(cwork)) endif c if(d1 .ne.0.d0)then WRITE(CONVAL,'(F27.16)')d1 +1.D-14*d1 WRITE(ERVAL,'(F27.16)')erd1 +1.D-14*erd1 call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'d_1 /kHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'d_1 /kHz ',cwork(1:len_trim(cwork)) endif c if(delk.ne.0.d0)then WRITE(CONVAL,'(F27.16)')delk+1.D-14*delk WRITE(ERVAL,'(F27.16)')erdelk+1.D-14*erdelk call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'delta_K /kHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'delta_K /kHz ',cwork(1:len_trim(cwork)) endif c if(d2 .ne.0.d0)then WRITE(CONVAL,'(F27.16)')d2 +1.D-14*d2 WRITE(ERVAL,'(F27.16)')erd2 +1.D-14*erd2 call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'d_2 /kHz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'d_2 /kHz ',cwork(1:len_trim(cwork)) endif c c...Sextics c if(inpout.eq.1)write(7,'(1x)') write(8,'(1x)') c if(hj.ne.0.d0)then WRITE(CONVAL,'(F27.16)')hj+1.D-14*hj WRITE(ERVAL,'(F27.16)')erhj+1.D-14*erhj call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'H_J /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'H_J /Hz ',cwork(1:len_trim(cwork)) endif c if(hjk.ne.0.d0)then WRITE(CONVAL,'(F27.16)')hjk+1.D-14*hjk WRITE(ERVAL,'(F27.16)')erhjk+1.D-14*erhjk call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'H_JK /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'H_JK /Hz ',cwork(1:len_trim(cwork)) endif c if(hkj.ne.0.d0)then WRITE(CONVAL,'(F27.16)')hkj+1.D-14*hkj WRITE(ERVAL,'(F27.16)')erhkj+1.D-14*erhkj call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'H_KJ /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'H_KJ /Hz ',cwork(1:len_trim(cwork)) endif c if(hk.ne.0.d0)then WRITE(CONVAL,'(F27.16)')hk +1.D-14*hk WRITE(ERVAL,'(F27.16)')erhk +1.D-14*erhk call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'H_K /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'H_K /Hz ',cwork(1:len_trim(cwork)) endif c if(hhj.ne.0.d0)then WRITE(CONVAL,'(F27.16)')hhj +1.D-14*hhj WRITE(ERVAL,'(F27.16)')erhhj+1.D-14*erhhj call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'h_J /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'h_J /Hz ',cwork(1:len_trim(cwork)) endif c if(h1.ne.0.d0)then WRITE(CONVAL,'(F27.16)')h1+1.D-14*h1 WRITE(ERVAL,'(F27.16)')erh1+1.D-14*erh1 call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'h_1 /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'h_1 /Hz ',cwork(1:len_trim(cwork)) endif c if(hhjk.ne.0.d0)then WRITE(CONVAL,'(F27.16)')hhjk +1.D-14*hhjk WRITE(ERVAL,'(F27.16)')erhhjk+1.D-14*erhhjk call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'h_JK /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'h_JK /Hz ',cwork(1:len_trim(cwork)) endif c if(h2.ne.0.d0)then WRITE(CONVAL,'(F27.16)')h2+1.D-14*h2 WRITE(ERVAL,'(F27.16)')erh2+1.D-14*erh2 call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'h_2 /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'h_2 /Hz ',cwork(1:len_trim(cwork)) endif c if(hhk.ne.0.d0)then WRITE(CONVAL,'(F27.16)')hhk +1.D-14*hhk WRITE(ERVAL,'(F27.16)')erhhk+1.D-14*erhhk call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'h_K /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'h_K /Hz ',cwork(1:len_trim(cwork)) endif c if(h3.ne.0.d0)then WRITE(CONVAL,'(F27.16)')h3+1.D-14*h3 WRITE(ERVAL,'(F27.16)')erh3+1.D-14*erh3 call confor(conval,erval,ndcon,nderor,2) <----- write(cwork,518)CONVAL(1:NDCON),ERVAL(1:NDEROR) if(inpout.eq.1) * write(7,'(2a)')'h_3 /Hz ',cwork(1:len_trim(cwork)) write(8,'(2a)')'h_3 /Hz ',cwork(1:len_trim(cwork)) endif c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Frequency output block in the order of input c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Reminder that input is from C NAME.OUT unit4 C NAME.INP unit12 C output is to: C NAME_RES unit8 C NAME_LIN unit3 c c Convert the appropriate block from the output file but transfer full c comments directly from the RAM36 input file, which is normally INPUT.TXT c but is suggested that it is renamed to MOLNAM.INP c 203 read(4,'(a)')line if( line(8:18) .ne.'Upper level'. * and.line(14:24).ne.'Upper level')goto 203 c nlines=0 ninfit=0 nunfit=0 write(*,'(1x/'' Number of processed lines:''//1x,$)') c c 210 read(12,'(a)')inptxt RAM36 RAM36hf input if(inptxt(1:12).ne.' meas.freq')goto 210 read(12,'(a)')inptxt skip dividing line c if(inpout.eq.1) *open(2,file=filgen(1:nfilgn)//'_original.res',status='unknown') open(3,file=filgen(1:nfilgn)//'.lin',status='unknown') LIN output c if(inpout.eq.1) *write(2,'(72(1h-)/''Fit dated: '',a/72(1h-)//a/)') optional RES * strdat(1:len_trim(strdat)), * 'Output in the original order defined in the input file:' write(8,'(1x//1x,a/)')'Transition output in the original order'// * ' defined in the input file:' c c c...Loop over line entries c 305 read(4,'(a)',end=306)line OUT input c if(iram36hf.eq.0.and.len_trim(line).lt.129)goto 306 if(iram36hf.eq.1.and.len_trim(line).lt.141)then write(*,'(1x/1x,a/1x,a/)')'ERROR reading:', * line(1:len_trim(line)) goto 306 endif c nlines=nlines+1 if((nlines/50)*50.eq.nlines)then write(*,'(1H+,i8,$)')nlines endif c c Read matching line in the input file for complete line comment and to c determine additional annotations c c267494.787 0 76 1 76 0 75 1 75 1 0.0500 c if(iram36hf.eq.0)read(line(52:65),'(f14.4)')fmeas OUT input if(iram36hf.eq.1)read(line(64:77),'(f14.4)')fmeas c 310 read(12,'(a)')inptxt INP input c read(inptxt(1:12),'(f12.4)',err=306)fexp if(abs(fmeas-fexp).gt.0.0001d0)goto 310 c if(iram36hf.eq.0)then read(inptxt(18:22),'(i5)')jupper read(inptxt(41:45),'(i5)')jlower read(inptxt(15:17),'(i3)')mupper read(inptxt(38:40),'(i3)')mlower endif c if(iram36hf.eq.1)then read(inptxt(24:28),'(i5)')jupper read(inptxt(53:57),'(i5)')jlower read(inptxt(15:17),'(i3)')mupper read(inptxt(44:46),'(i3)')mlower endif jdelta=jupper-jlower trind='U' if(jdelta.eq.-1)trind='P' if(jdelta.eq.0 )trind='Q' if(jdelta.eq.1 )trind=' ' c mdelta=mupper-mlower if(mdelta.ne.0)then if(mdelta.gt.0)trind='<' if(mdelta.lt.0)trind='>' endif c c...copy complete transition comment from the end of the MOLNAM.INP file: c 1/ this is to start one space after the error (i.e. the weight column) c 2/ end of line comment marked by # should be first c c LINCOM is the complete end of line comment as transferred to C the .LIN file c COMENT is abbreviated to the end of line comment c coment=' ' if(iram36hf.eq.0)read(inptxt(75:),'(a)')coment if(iram36hf.eq.1)read(inptxt(87:),'(a)')coment lincom=coment lencom=len_trim(lincom) c c...no comment to be transferred to the .RES output c if(lincom(1:1).ne.'#'.and.lincom(1:1).ne.'!')then coment=' ' goto 1002 endif c c...extract end of line comment c if(lincom(1:1).eq.'#')then if(lencom.eq.1)then coment=' ' goto 1002 endif do 1000 n=2,lencom if(lincom(n:n).eq.'!')then lenc=n-1 goto 1001 endif 1000 continue lenc=n 1001 coment=lincom(2:lenc) else lenc=0 coment=' ' endif c c...extract and write comment line(s) preceding the current line c lstart=lenc+1 lfinal=lencom if(lstart.lt.1)goto 1002 1006 if(lincom(lstart:lstart).eq.'!')then do 1004 n=lstart+1,lencom if(lincom(n:n).eq.'!')then lfinal=n-1 goto 1005 endif 1004 continue lfinal=lencom 1005 if(inpout.eq.1)write(2,'(1x,a)')lincom(lstart:lfinal) optional RES write(8,'(1x,a)')lincom(lstart:lfinal) RES output if(lfinal.eq.lencom)then goto 1002 else lstart=lfinal+1 goto 1006 endif endif C 1002 if(iram36hf.eq.0)read(line(131:131),'(i1)')ifit if(iram36hf.eq.1)read(line(143:143),'(i1)')ifit c if(ifit.eq.1)then if(jdelta.eq.1.and.mdelta.eq.0)then if(mlower.eq. 0)m0r=m0r+1 if(mlower.eq. 1)m1r=m1r+1 if(mlower.eq. 2)m2r=m2r+1 if(mlower.eq. 3)m3r=m3r+1 if(mlower.eq.-3)mm3r=mm3r+1 endif c if(jdelta.eq.-1.and.mdelta.eq.0)then if(mlower.eq. 0)m0p=m0p+1 if(mlower.eq. 1)m1p=m1p+1 if(mlower.eq. 2)m2p=m2p+1 if(mlower.eq. 3)m3p=m3p+1 if(mlower.eq.-3)mm3p=mm3p+1 endif c if(jdelta.eq.0.and.mdelta.eq.0)then if(mlower.eq. 0)m0q=m0q+1 if(mlower.eq. 1)m1q=m1q+1 if(mlower.eq. 2)m2q=m2q+1 if(mlower.eq. 3)m3q=m3q+1 if(mlower.eq.-3)mm3q=mm3q+1 endif c if(mdelta.ne.0)then if(mlower.eq. 0)m0i=m0i+1 if(mlower.eq. 1)m1i=m1i+1 if(mlower.eq. 2)m2i=m2i+1 if(mlower.eq. 3)m3i=m3i+1 if(mlower.eq.-3)mm3i=mm3i+1 endif endif c if(ifit.eq.0)then if(jdelta.eq.1.and.mdelta.eq.0)then if(mlower.eq. 0)jjm0r= jjm0r+1 if(mlower.eq. 1)jjm1r= jjm1r+1 if(mlower.eq. 2)jjm2r= jjm2r+1 if(mlower.eq. 3)jjm3r= jjm3r+1 if(mlower.eq.-3)jjmm3r=jjmm3r+1 endif if(jdelta.eq.-1.and.mdelta.eq.0)then if(mlower.eq. 0)jjm0p= jjm0p+1 if(mlower.eq. 1)jjm1p= jjm1p+1 if(mlower.eq. 2)jjm2p= jjm2p+1 if(mlower.eq. 3)jjm3p= jjm3p+1 if(mlower.eq.-3)jjmm3p=jjmm3p+1 endif if(jdelta.eq.0.and.mdelta.eq.0)then if(mlower.eq. 0)jjm0q= jjm0q+1 if(mlower.eq. 1)jjm1q= jjm1q+1 if(mlower.eq. 2)jjm2q= jjm2q+1 if(mlower.eq. 3)jjm3q= jjm3q+1 if(mlower.eq.-3)jjmm3q=jjmm3q+1 endif if(mdelta.ne.0)then if(mlower.eq. 0)jjm0i= jjm0i+1 if(mlower.eq. 1)jjm1i= jjm1i+1 if(mlower.eq. 2)jjm2i= jjm2i+1 if(mlower.eq. 3)jjm3i= jjm3i+1 if(mlower.eq.-3)jjmm3i=jjmm3i+1 endif endif c c...convert to a .LIN line c c Mark as excluded (error increased to 900.xx): c 1/ lines with fitting parameter of zero c 2/ lines with obs-calc all stars c 3/ lines with linestrength set to -1 c c__RAM36 c if(iram36hf.eq.0)then prefix=' ' if(line(131:131).eq.'0'.or.line(104:106).eq.'***')prefix='90' if(line(123:124).eq.'-1')prefix='90' write(linout,'(100A)') * line( 7: 9),line(11:13),line(15:17),line( 3: 5), qnupper * line(28:30),line(32:34),line(36:38),line(24:26), qnlower * ' 0 0 0 0', remaining * line(52:65),' ', freq * prefix,line(68:73), error * ' 1.00000 ',lincom(1:len_trim(lincom)) final write(3,'(a)')linout(1:len_trim(linout)) endif c c__RAM36HF c if(iram36hf.eq.1)then prefix=' ' if(line(143:143).eq.'0'.or.line(104:106).eq.'***')prefix='90' if(line(135:136).eq.'-1')prefix='90' c read(line( 6:11),'(f6.1)')fupper if(fupper.lt.0.d0)then ifupper=-1 else fupper=fupper+0.25d0 ifupper=nint(fupper) endif write(cfupper,'(i3)')ifupper c read(line(33:38),'(f6.1)')flower if(flower.lt.0.d0)then iflower=-1 else flower=flower+0.25d0 iflower=nint(flower) endif write(cflower,'(i3)')iflower c write(linout,'(100A)') * line(13:15),line(17:19),line(21:23),line( 3: 5),cfupper, qnupper * line(40:42),line(44:46),line(48:50),line(30:32),cflower, qnlower * ' 0 0', remaining * line(64:77),' ', freq * prefix,line(80:85), error * ' 1.00000 ',lincom(1:len_trim(lincom)) final write(3,'(a)')linout(1:len_trim(linout)) endif c c...convert to a .RES line and write it to NAME.RES (unit 8) c and to NAME_original.RES (unit 2) c c NOTE: the end of line comment is read into COMENT from the .INP c file and can be much longer than that in the .OUT file c c__RAM36 c if(iram36hf.eq.0)then read(line(52:65),'(f14.4)',err=2205)fmeas read(line(75:88),'(f14.4)',err=2205)fcalc read(line(67:73),'(f7.4)' ,err=2205)ferror goto 2206 c 2205 write(*,2207)line(1:len_trim(line)) 2207 format(1x//' ***** ERROR: Cannot read fmeas,fcal,ferror from:'// * 1x,a//) stop c 2206 if(line(97:106).eq.'**********')then fomc=1.d+10 else read(line(97:106),'(f10.4)')fomc endif if(ifit.eq.1)then ninfit=ninfit+1 else nunfit=nunfit+1 endif c if(abs(fomc).gt.3.d0*ferror)then indbad='/' else indbad=':' endif if(ifit.eq.0)indbad=' ' if(ifit.eq.1.and.abs(fomc).gt.fcut)indbad='*' c do 240 n=1,nblend if(fmeas.eq.blend(n,1))then fomc=blend(n,2) indbad='B' goto 241 endif 240 continue c 241 numl=nlines if(nlines.gt.9999)numl=nlines-10000 if(ifit.eq.1)then if(inpout.eq.1) * write(2,206)numl,indbad, optional RES * line( 7: 9),line(11:13),line(15:17),line( 3: 5), qnupper * line(28:30),line(32:34),line(36:38),line(24:26), qnlower * fmeas,fomc,ferror,trind,coment(1:len_trim(coment)) write(8,206)numl,indbad, RES output of transition * line( 7: 9),line(11:13),line(15:17),line( 3: 5), qnupper * line(28:30),line(32:34),line(36:38),line(24:26), qnlower * fmeas,fomc,ferror,trind,coment(1:len_trim(coment)) else if(inpout.eq.1) * write(2,207)numl,indbad, optional RES * line( 7: 9),line(11:13),line(15:17),line( 3: 5), qnupper * line(28:30),line(32:34),line(36:38),line(24:26), qnlower * fmeas,fomc,fcalc,trind,coment(1:len_trim(coment)) write(8,207)numl,indbad, RES output of transition * line( 7: 9),line(11:13),line(15:17),line( 3: 5), qnupper * line(28:30),line(32:34),line(36:38),line(24:26), qnlower * fmeas,fomc,fcalc,trind,coment(1:len_trim(coment)) endif endif 206 format(i4,a1,4a3,2x,4a3,f24.4,f9.4,f7.3, 13x, 2x,a,2x,a) 207 format(i4,a1,4a3,2x,4a3,f24.4,f8.3,' UNFITTD',f13.4,2x,a,2x,a) c c__RAM36HF c if(iram36hf.eq.1)then read(line(64:77),'(f14.4)')fmeas if(line(87:87).ne.'*')then read(line(87:100),'(f14.4)')fcalc else fcalc=1.d+10 endif if(line(80:80).ne.'*')then read(line(80:85),'(f7.4)')ferror else ferror=1.d+10 endif if(line(109:109).eq.'*')then fomc=1.d+10 else read(line(109:118),'(f10.4)')fomc endif if(ifit.eq.1)then ninfit=ninfit+1 else nunfit=nunfit+1 endif c if(abs(fomc).gt.3.d0*ferror)then indbad='/' else indbad=':' endif if(ifit.eq.0)indbad=' ' if(ifit.eq.1.and.abs(fomc).gt.fcut)indbad='*' c do 1240 n=1,nblend if(fmeas.eq.blend(n,1))then fomc=blend(n,2) indbad='B' goto 1241 endif 1240 continue c 1241 numl=nlines if(nlines.gt.9999)numl=nlines-10000 if(ifit.eq.1)then if(inpout.eq.1) * write(2,1206)numl,indbad, optional RES * line(13:15),line(17:19),line(21:23),line( 3: 5),cfupper, qnupper * line(40:42),line(44:46),line(48:50),line(30:32),cflower, qnlower * fmeas,fomc,ferror,trind,coment(1:len_trim(coment)) write(8,1206)numl,indbad, RES output of transition * line(13:15),line(17:19),line(21:23),line( 3: 5),cfupper, qnupper * line(40:42),line(44:46),line(48:50),line(30:32),cflower, qnlower * fmeas,fomc,ferror,trind,coment(1:len_trim(coment)) else if(inpout.eq.1) * write(2,1207)numl,indbad, optional RES * line(13:15),line(17:19),line(21:23),line( 3: 5),cfupper, qnupper * line(40:42),line(44:46),line(48:50),line(30:32),cflower, qnlower * fmeas,fomc,fcalc,trind,coment(1:len_trim(coment)) write(8,1207)numl,indbad, RES output of transition * line(13:15),line(17:19),line(21:23),line( 3: 5),cfupper, qnupper * line(40:42),line(44:46),line(48:50),line(30:32),cflower, qnlower * fmeas,fomc,fcalc,trind,coment(1:len_trim(coment)) endif endif 1206 format(i4,a1,5a3,2x,5a3,f21.4,f9.4,f7.3, 13x, 2x,a,2x,a) 1207 format(i4,a1,5a3,2x,5a3,f21.4,f8.3,' UNFITTD',f13.4,2x,a,2x,a) c ipt(nlines)=nlines if(ifit.eq.1)then ominc(nlines)=fomc/ferror else ominc(nlines)=0.d0 endif c goto 305 c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Output the statistics breakdown block below the line frequency block to: c 1/ to the main NAME.RES file (unit 8) c 2/ to the NAME_original.RES file (unit 2) reused c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c 306 if(inpout.eq.1) * write(2,202)fcut,nv6lin,nev6lin, optional RES * rmsmhz,ermsmhz, * wrms,ewrms if(inpout.eq.1)write(2,205)nunfit optional RES write(8,202)fcut,nv6lin,nev6lin, RES output * rmsmhz,ermsmhz, * wrms,ewrms write(8,205)nunfit 205 format(1x//' IFIT=0 lines = ',i8' and their breakdown:') jisumr=jjm0r+jjm1r+jjm2r+jjm3r+jjmm3r jisumq=jjm0q+jjm1q+jjm2q+jjm3q+jjmm3q jisump=jjm0p+jjm1p+jjm2p+jjm3p+jjmm3p jisumi=jjm0i+jjm1i+jjm2i+jjm3i+jjmm3i if(inpout.eq.1)then optional RES write(2,'(1x/a/)' )' m"= 0 1 2 3 -3'// * ' subtotal' write(2,'(a,5i6,i14)' )' R ', * jjm0r,jjm1r,jjm2r,jjm3r,jjmm3r,jisumr write(2,'(a,5i6,i14)' )' Q ', * jjm0q,jjm1q,jjm2q,jjm3q,jjmm3q,jisumq write(2,'(a,5i6,i14)' )' P ', * jjm0p,jjm1p,jjm2p,jjm3p,jjmm3p,jisump write(2,'(a,5i6,i14/)')' istate ', * jjm0i,jjm1i,jjm2i,jjm3i,jjmm3i,jisumi endif c write(8,'(1x/a/)' )' m"= 0 1 2 3 -3'// * ' subtotal' write(8,'(a,5i6,i14)' )' R ', * jjm0r,jjm1r,jjm2r,jjm3r,jjmm3r,jisumr write(8,'(a,5i6,i14)' )' Q ', * jjm0q,jjm1q,jjm2q,jjm3q,jjmm3q,jisumq write(8,'(a,5i6,i14)' )' P ', * jjm0p,jjm1p,jjm2p,jjm3p,jjmm3p,jisump write(8,'(a,5i6,i14/)')' istate ', * jjm0i,jjm1i,jjm2i,jjm3i,jjmm3i,jisumi c isumr=m0r+m1r+m2r+m3r+mm3r isumq=m0q+m1q+m2q+m3q+mm3q isump=m0p+m1p+m2p+m3p+mm3p isumi=m0i+m1i+m2i+m3i+mm3i if(inpout.eq.1)then optional RES write(2,225)ninfit 225 format(1x/ ' IFIT=1 lines = ',i8,' and their breakdown:') write(2,'(1x/a/)' )' m"= 0 1 2 3 -3'// * ' subtotal' write(2,'(a,5i6,i14)' )' R ',m0r,m1r,m2r,m3r,mm3r,isumr write(2,'(a,5i6,i14)' )' Q ',m0q,m1q,m2q,m3q,mm3q,isumq write(2,'(a,5i6,i14)' )' P ',m0p,m1p,m2p,m3p,mm3p,isump write(2,'(a,5i6,i14/)')' istate ',m0i,m1i,m2i,m3i,mm3i,isumi endif c write(8,225)ninfit write(8,'(1x/a/)' )' m"= 0 1 2 3 -3'// * ' subtotal' write(8,'(a,5i6,i14)' )' R ',m0r,m1r,m2r,m3r,mm3r,isumr write(8,'(a,5i6,i14)' )' Q ',m0q,m1q,m2q,m3q,mm3q,isumq write(8,'(a,5i6,i14)' )' P ',m0p,m1p,m2p,m3p,mm3p,isump write(8,'(a,5i6,i14/)')' istate ',m0i,m1i,m2i,m3i,mm3i,isumi c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Output the list of worst fitting lines to: c 1/ to the main NAME.RES file (unit 8) c 2/ to the NAME_original.RES file (unit 2) reused c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c call worstl(nlines,inpout) <----- c if(inpout.eq.1) * write(2,'(43x,37(''_'')/42(''_''), optional RES * ''/ RAM36 output reformatted with VIFORM''/)') c if(inpout.eq.1)close(2) close(12) c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Deal with the correlation matrix and output to: c 1/ to the main NAME.RES file (unit 8) c 2/ to the NAME.CON fle (unit 7) c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c if(inpout.eq.1)write(7,'(1x/)') write(8,'(1x/)') 18 read(4,'(a)',end=16)line if(line(1:20).ne.' correlation matrix')goto 18 if(inpout.eq.1)write(7,'(a/)')line(1:len_trim(line)) write(8,'(a/)')line(1:len_trim(line)) read(4,'(a)',end=16)line read(4,'(a)',end=16)line c c 17 read(4,'(a)',end=16)line c if(line(1:20).eq.' covariation matrix')goto 16 c if(line(4:4).eq.' '.and.line(22:22).ne.' ')then if(inpout.eq.1)then write(7,'(a)')line(1:len_trim(line)) write(7,'(1x)') endif write(8,'(a)')line(1:len_trim(line)) write(8,'(1x)') goto 17 endif c if(len_trim(line).ne.0)then if(inpout.eq.1)write(7,'(a)')line(1:len_trim(line)) write(8,'(a)')line(1:len_trim(line)) endif goto 17 c c 16 close(4) if(inpout.eq.1)write(7,'(1x/43x,37(''_'')/42(''_''), * ''/ RAM36 output reformatted with VIFORM''/)') write(8,'(1x/43x,37(''_'')/42(''_''), * ''/ RAM36 output reformatted with VIFORM''/)') if(inpout.eq.1)close(7) close(8) close(3) c stop c c...ERROR messages c 8 write(*,9)filout(1:len_trim(filout)) 9 format(1x///' ***** ERROR: the required RAM36 output is not ', * 'present in'/14x,a//) stop c 30 write(*,31)filinp(1:len_trim(filinp)) 31 format(1x///' ***** ERROR: the required RAM36 input is not ', * 'present in'/14x,a//) stop c 111 write(*,112)filout(1:len_trim(filout)) 112 format(1x///' ***** ERROR: end of RAM36 output reached but no ', * 'final fit parameters'/14x,a//) stop c 115 write(*,116)errtxt(1:len_trim(errtxt)) 116 format(1x///' ***** ERROR: ',a//) c end C C_____________________________________________________________________________ c SUBROUTINE shortn(line) c c To debloat lines of fitted constants so that they can print in c reasonable font size c character line*200 c line(101:)=line(105:) line(94:)=line(96:) line(82:)=line(84:) line(55:)=line(56:) line(50:)=line(54:) line(44:)=line(48:) line(38:)=line(42:) line(32:)=line(36:) line(26:)=line(30:) line(20:)=line(24:) line(13:)=line(18:) return end C 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, this is 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, this is 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 C...safety feature to avoid overwriting CWORK after return C 5 if(ndcon+nderor+2.gt.42)then ndcon=ndcon-1 nderor=nderor-1 goto 5 endif C RETURN END C_____________________________________________________________________________ c c subroutine confix(const,ascld,conval,iend) c C Fixed constant formating for output c implicit real*8 (a-h,o-z) character conval*27 C if(abs(const).le.1.d-16)ascld=0.d0 IF(ASCLD.NE.0.D0)ASCLD=ASCLD+MOD(ASCLD,1.D-15*ASCLD) WRITE(CONVAL,'(F27.16)')ASCLD c c...deal with leading zero IF(ASCLD.EQ.0.0D0)CONVAL=' 0.0 ' IF(CONVAL(10:10).EQ.' ')CONVAL(10:10)='0' IF(CONVAL(10:10).EQ.'-')THEN CONVAL(10:10)='0' CONVAL(9:9)='-' ENDIF c c...set leading square bracket do 2115 m=1,27 if(CONVAL(M:M).NE.' ')GOTO 2116 2115 continue 2116 if(m.gt.8)then conval(8:8)='[' else if(m.gt.1.and.m.le.8)then conval(m-1:m-1)='[' endif c c...blank at the end so that number processed is within 15 digit accuracy if(ascld.ne.0.d0)then mmm=alog10(real(abs(ascld))) if(mmm.ge.-1)mmm=mmm+1 do 2117 m=27,27-mmm,-1 conval(m:m)='0' 2117 continue endif c c...find last non-zero digit DO 1114 M=27,1,-1 IF(CONVAL(M:M).NE.'0'.AND.CONVAL(M:M).NE.' ')GOTO 1115 IF(CONVAL(M:M).EQ.'0')CONVAL(M:M)=' ' 1114 CONTINUE C C...terminating square bracket C 1115 iend=m+1 if(iend.gt.27)iend=27 conval(iend:iend)=']' c return end C C____________________________________________________________________________ C SUBROUTINE WORSTL(NLIN,inpout) c c...Sort and list worst fitting lines c IMPLICIT INTEGER*2 (I-N) PARAMETER (maxlin=20000,lastl=50) C COMMON /SORTCC/OMINC,IPT INTEGER*2 IPT(maxlin) REAL*8 OMINC(maxlin) C CALL SORTC(1,NLIN) <----- if(inpout.eq.1)write(2,1) optional RES write(8,1) write(*,1) 1 Format(1x/' Worst fitting lines (obs-calc/error):'/) RES output c nst=nlin-lastl+1 if(nst.le.0)nst=1 do 2 n=nlin,nst,-4 nlst=n-3 if(nlst.lt.nst)nlst=nst if(inpout.eq.1) optional RES * write(2,4)(ipt(nn),ominc(nn),nn=n,nlst,-1) write(8,4)(ipt(nn),ominc(nn),nn=n,nlst,-1) RES output write(*,4)(ipt(nn),ominc(nn),nn=n,nlst,-1) 2 continue 4 format(1x,4(i5,':',f7.1,6x)) C RETURN END C____________________________________________________________________________ C SUBROUTINE SORTC(N,M) IMPLICIT INTEGER*2 (I-N) PARAMETER (maxlin=20000) C COMMON /SORTCC/WK,IPT INTEGER*2 IPT(maxlin) REAL*8 WK(maxlin),EE C C ... This routine sorts the ABSOLUTE values of the quantities in vector WK in C ascending order C of magnitude and also accordingly rearranges vector IPT of pointers C to original positions of sorted quantities C DO 101 I=N,M-1 J=I 106 J=J+1 IF(abs(WK(J))-abs(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_____________________________________________________________________________