C----------------------------------------------------------------------------- c c X I A R E S - converter for XIAM5 output --> PIFORM type input c C ver. 19.II.2024 ----- Zbigniew KISIEL ----- C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, 02-668 Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- c c C Modification history: C C 25.08.20: creation C 1.09.20: further development after much more testing C 15.09.20: output and conversion mods c 7.11.20: debugging output for calculated hyperfine transitions c 16.11.23: general update c 15.12.23: some debugging c 19.02.24: clarification of "Standard Deviation" c C----------------------------------------------------------------------------- C NOTES: C C - XIARES is currently intended to be used on fitting output C from XIAM5 generated with INTS=0 and PRINT=4 C C - XARES needs both MOLNAM.XI and MOLNAM.XO files to be available, C where MOLNAM is an arbitray leading name C C - XARES will produce a MOLNAM.RES file and transfer to it: C a) the Hartwig header C b) job comment C c) block of fitted lines, all numbers in MHz C d) unchanged block of fitted parameters and correlation coefficients C C PROBLEMS = TODO: C C & declaration processing C in this case the preceding blended lines have just the calculated frequency C printed, while the concluding line has the average value as the calculated C frequency nad last digit of o-c replaced by & (thus the four digit o-c C has to be evaluated from obs and calc (average) C # declaration processing C fixed and derived parameters ? C C C CNTOLQ works with XIAM1, XIAM2, XIAM3, XIAM4, XIAM5 C crashes with XIAM: run-time error M6101: MATH C - floating-point error: invalid C XIAM executable is 365 kB, others are near 700 kB or more C XIARES crashed with output from XIAM1, XIAM2, XIAM3 C C C----------------------------------------------------------------------------- c c implicit real*8 (a-h,o-z) parameter (maxlin=9999) c character*125 line,linexi,linexo,lineres character*125 xolines(maxlin),statspfit(3) character*50 filin,filout,filxi,filxo,filres character ermes*40,spaces*100,CONVAL*27,ERVAL*27,blocknam*80 real*8 ialph c real*8 freq(maxlin) c radeg=57.295780d0 mhzcm=29979.2458d0 nerd=2 iquartic=0 isextic=0 ihyperf=0 ispinrot=0 itoptop=0 iintrot=0 c WRITE(*,3344) 3344 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | X I A R E S - XIAM5 output --> PIFORM type output ', * T79,'|'/ *' | (for XIAM5 run with INTS=0, PRINT=4) ', * T79,'|'/ * ' |',76(1H_),'|'/' version 19.II.2024',T64,'Zbigniew KISIEL'/) c write(*,3345) 3345 format(1x/ * ' For stable operation ensure that the .xi file:'// * ' 1/ does not contain any TAB characters'/ * ' 2/ is free from trailing blanks'/ * ' 3/ is based on one of the annotated templates from the', * ' website'//' and '// * ' a/ lines separating input blocks do not contain any', * ' characters.'/ * ' b/ XIAM5.EXE or later (see website) is used for fitting.'/) c do 133 i=1,100 spaces(i:i)=' ' 133 continue c c c...open the .xo file (unit 3) c 2 write(*,1)' Name of input .xo file (without extension):' 1 format(1x//1x,a,' ',$) read(*,'(a)',err=2)filin do 100 n=30,1,-1 if(filin(n:n).ne.' '.and.ichar(filin(n:n)).ne.0)then filxo=filin(1:n)//'.xo' goto 101 endif 100 continue 101 open(3,file=filxo,status='OLD',err=200) write(*,'(1x//'' R E A D I N G: '',a)')filxo(1:len_trim(filxo)) c c c...open the .xi file (unit 2) c filxi=filin(1:n)//'.xi' open(2,file=filxi,status='OLD',err=300) write(*,'('' R E A D I N G: '',a)')filxi(1:len_trim(filxi)) c c c...open the .res file (unit 4) c filres=filin(1:n)//'.res' open(4,file=filres,status='UNKNOWN',err=400) c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...copy over the four top copyright lines from the .xo file c do 58 n=1,4 read(3,'(a)',end=6,err=5)linexo write(4,'(a)')linexo(1:len_trim(linexo)) 58 continue write(4,'(1x)') c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Block I of the .xi file: fish out the comment as follows c 1/ ignore lines beginning with c 2/ copy over to the .RES output all lines longer than zero characters c 3/ if a zero length line is encountered then proceed to the next block c nblock=1 56 read(2,'(a)',end=6,err=5)linexi if(linexi(1:1).eq.'\')then goto 56 else write(4,'(a)')linexi(1:len_trim(linexi)) goto 57 endif c 57 read(2,'(a)',end=6,err=5)linexi if(len_trim(linexi).ne.0)then write(4,'(a)')linexi(1:len_trim(linexi)) goto 57 endif c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Block II of the .xi file (control parameters): c only fish out the ADJF parameter and stop operation if INTS and c PRINT are not set properly c iadjf=0 151 read(2,'(a)',end=6,err=600)linexi c if(linexi(1:4).eq.'ints')then read(linexi(5:),*)ints if(ints.ne.0)then write(*,153)ints 153 format(1x//' ***** ERROR: ints=',i2,' while it should be 0'//) stop endif endif c if(linexi(1:5).eq.'print')then read(linexi(6:),*)iprint if(iprint.ne.4)then write(*,154)iprint 154 format(1x//' ***** ERROR: print=',i2, * ' while it should be 4'//) stop endif endif c if(linexi(1:4).eq.'adjf')then read(linexi(5:),*)iadjf endif c if(len_trim(linexi).ne.0)goto 151 c write(*,'(1x/2x,a,i5/)')'adjf',iadjf write(4,'(1x/2x,a,i5)')'adjf',iadjf write(*,152)nblock,'Control parameters' 152 format(' Processing block', i3,3x,a) c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Block III of the .xi file (molecular parameters): just skip for now c nblock=3 161 read(2,'(a)',end=6,err=600)linexi if(len_trim(linexi).ne.0)goto 161 write(*,152)nblock,'Molecular parameters' c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Block IV of the .xi file (fitting of parameters): just skip for now c nblock=4 171 read(2,'(a)',end=6,err=600)linexi if(len_trim(linexi).ne.0)goto 171 write(*,152)nblock,'Fitting of parameters' c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Block V of the .xi file (torsional symmetry): use to determine if alphanumeric c torsional symmetry descriptor is in use, if so then what is the longest one c nblock=5 nlenmax=0 181 read(2,'(a)',end=6,err=600)linexi if(len_trim(linexi).ne.0)then do 203 nn=1,len_trim(linexi) if(linexi(nn:nn).eq.'/')then nlensym=1 do 201 nnn=nn+1,len_trim(linexi) if(linexi(nnn:nnn).eq.' ')goto 202 nlensym=nlensym+1 201 continue endif 203 continue 202 if(nlensym.gt.nlenmax)nlenmax=nlensym goto 181 endif lens=nlenmax if(nlenmax.eq.0)lens=3 write(blocknam,'(a,i3)')', identifier length =',lens write(*,152)nblock, * 'Torsional symmetry'//blocknam(1:len_trim(blocknam)) c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Block VI of the .xi file (torsional states): just skip for now c nblock=6 191 read(2,'(a)',end=6,err=600)linexi if(len_trim(linexi).ne.0)goto 191 write(*,152)nblock,'Torsional states' c c c...Block VII of the the .xi file (transitions): advance through all possible c comments and stop at the first transition c 16 read(2,'(a)',end=6,err=600)linexi if(linexi(1:1).eq.'\')goto 16 c nblock=7 write(*,152)nblock,'Transitions' write(*,'(/1x,a/1x,a)')'First transition in the .xi file:', ! debug * linexi(1:len_trim(linexi)) ! debug c c c...Advance the .xo file to the lines block: c for hyperfine free data there is also an inital block, while for c hyperfine data there is only the final fit block c c Fish out and copy some key information from the top of the .xo file c 55 read(3,'(a)',end=6,err=5)linexo c if(linexo( 2:13).eq.'Using Watson')then write(*,'(1x/2x,a)')linexo(2:len_trim(linexo)) write(4,'(1x/2x,a)')linexo(2:len_trim(linexo)) endif if(linexo(17:27).eq.'Data Points')then write(*,'(2x,a)')linexo(4:len_trim(linexo)) write(4,'(2x,a)')linexo(4:len_trim(linexo)) endif if(linexo( 7:13).eq.'Maximal')then write(*,'(2x,a/)')linexo(7:len_trim(linexo)) write(4,'(2x,a/)')linexo(7:len_trim(linexo)) endif c if(linexo(1:14).ne.' End at Cycle')goto 55 c c.."End at Cycle" has been reached, and this is just above the final block c of fitted lines c 5 read(3,'(a)',end=6,err=5)linexo if(linexo(1:22).ne.' J K- K+ J K- K+')goto 5 c read(3,'(a)',end=6,err=5)linexo c write(*,'(1x/1x,a/1x,a)')'First transition in the .xo file:', ! debug c * linexo(1:len_trim(linexo)) ! debug c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Go through .xi and .xo writing to .res as necessary while converting c transitions to output similar to that from PIFORM c C .xo examples for hyperfine structure c 276: 11 1 10 11 1 11 F 20 20 /A 9.3663526 0.0022 9.3663548 Err 0.2D-05 /A -/A c 277: 2 K 1 1 K 1 F 6 4 /E 3.6313130 0.0026 3.6313156 Err 0.2D-05 /E -/E c 463: 9 K 1 8 K 1 F 20 18 /E 15.9822644 --- --- --- /E -/E c c .xo examples without hyperfine structure: c 52: 10 2 8 10 2 9 V 1 /A 22.7573061 1.6210 22.7589271 Err 0.5D-05 /A -/A c 53: 2 K 1 1 K 1 V 1 /E 8.4808837 -0.0232 8.4808605 Err 0.2D-05 /E -/E c101: 6 K 4 6 K 0 V 1 /E 11.6376847 --- --- --- /E -/E c c .res example: c256: 10 0 10 9 9 0 9 8 17684.3958 0.0011 0.002 c257: 10 0 10 11 9 0 9 10 17684.4128 0.0014 0.002 -0.0001 0.50 c258: 10 0 10 10 9 0 9 9 17684.4128 -0.0016 0.002 -0.0001 0.50 c c c...write header of the frequency table c nlines=0 nconv=0 c c...Analyse line contents i.e. column positions of various fields in the printout c c NORIG=-1 accounts for line numbers written in I4 format in the original XIAM c NORIG= 0 is for the INTEL recompiled versions based on the XIAMALL concatenation c of sources c norig=0 if(linexo(5:5).eq.':')norig=-1 c c...Identify columns for B, V, S (or /) identifiers and numerical fields c ncolb=0 ncolv=0 ncols=0 nfcalc=0 nerr=0 c do 301 nn=25,len_trim(linexo) if(linexo(nn:nn).eq.'B')ncolb=nn if(linexo(nn:nn).eq.'V')ncolv=nn if(ncols.eq.0.and. * (linexo(nn:nn).eq.'S'.or.linexo(nn:nn).eq.'/'))ncols=nn if(linexo(nn:nn).eq.'.'.and.nfcalc.eq.0)nfcalc=nn if(linexo(nn:nn).eq.'r')nerr=nn 301 continue c nerr=nerr+1 nfcalc=nfcalc-4 ndiff=nfcalc+12 nfobs=ndiff+10 c ifirst=ncolb if(ifirst.eq.0)ifirst=ncolv if(ifirst.eq.0)ifirst=ncols ilast=ncols+lens-1 c write(*,'(1x,a,3i5,a,2i5/1x,a,4i5)') * ' B V S columns: ',ncolb,ncolv,ncols, * ' limits:',ifirst,ilast, * ' Fcalc,Fdiff,Fobs,err columns: ',nfcalc,ndiff,nfobs,nerr c write(4,'(1x/a,6x,a,''obs o-c error''/)') * spaces(1:ilast),spaces(1:11) c goto 24 c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Main loop c 23 read(3,'(a)',end=7,err=500)linexo c c...if previous lines were prediction lines and error position was not c established then do it now c 1302 continue if(nerr.eq.1)then nerr=0 do 1301 nn=25,len_trim(linexo) if(linexo(nn:nn).eq.'r')nerr=nn 1301 continue nerr=nerr+1 write(*,'(8x,a,i5)')'err column corrected to: ',nerr if(nerr.gt.1)write(*,'(1x)') endif c c...exit to copying over of the rest of the .xo file (and correction c of (obs-calc)/err c if(linexo(1:19).eq.' Maximum (obs-calc)')then read(linexo(37:47),'(f11.7)')ermax ermaxmhz=ermax*1000.d0 write(linexo(36:),'(a,f9.4)')' with (obs-calc) =',ermaxmhz write(4,'(1x/a)')linexo(1:len_trim(linexo)) read(3,'(a)',err=500,end=7)linexo c c...fish out the three SPFIT type statistics lines c do 65 nn=1,3 read(3,'(a)',err=500,end=7)linexo statspfit(nn)=linexo(1:len_trim(linexo)) 65 continue goto 33 ! exit to copy rest of .xo endif c c...copy over any .xi lines beginning with \ (synchronised in position c with the .xo output) c 25 read(2,'(a)',end=7,err=600)linexi if(linexi(1:1).eq.'\')then write(4,'(a)',err=700)linexi(1:len_trim(linexi)) goto 25 endif c c c...Process identified .xo lines: c 24 lineres='Unconverted: '//linexo(1:len_trim(linexo)) c c...line with hyperfine c if(linexo(26+norig:26+norig).eq.'F')then ! obs and calc if(linexo(nfobs+norig:nfobs+norig+11).ne.' --- ')then ermes='FREQOBS with hyperfine' read(linexo(nfobs:nfobs+11),'(f12.7)',err=800)freqobs freqmhz=freqobs*1000.d0 c if(linexo(58+norig:58+norig).ne.'&')then ermes='FOMC with hyperfine' read(linexo(ndiff:ndiff+9),'(f10.4)',err=800)fomc else ! blend ermes='FREQCALC with hyperfine' read(linexo(nfcalc:nfcalc+11),'(f12.7)',err=800)freqcalc fomc=freqmhz-freqcalc*1000.d0 endif c ermes='FERR with hyperfine' read(linexo(nerr:nerr+7),'(F8.1)',err=800)ferr ferrmhz=ferr*1000.d0 write(lineres,30,err=900)linexo(2+norig:15+norig), * linexo(16+norig:24+norig), * linexo(26+norig:32+norig), * linexo(ifirst:ilast), * freqmhz,fomc,ferrmhz if(linexo(58+norig:58+norig).eq.'&')then ! blend nn=len_trim(lineres) lineres=lineres(1:nn)//' _\ blend' endif else ! calc freq only ermes='FREQCALC with hyperfine' read(linexo(nfcalc:nfcalc+11),'(f12.7)',err=800)freqcalc freqmhz=freqcalc*1000.d0 fomc=0.d0 ferrmhz=0.d0 write(lineres,40,err=900)linexo(2+norig:15+norig), * linexo(16+norig:24+norig), * linexo(26+norig:32+norig), * linexo(ifirst:ilast), * freqmhz,' <----------------- calc' endif goto 20 endif 30 format(a,2x,a,4x,a,3x,a,f18.4,f10.4,f9.3) 40 format(a,2x,a,4x,a,3x,a,f18.4,a) c c...line w/o hyperfine c if(linexo(6+norig:6+norig).eq.':')then ! obs and calc if(linexo(nfobs:nfobs+11).ne.' --- '.and. * linexo(ndiff+9:ndiff+9).ne.'#')then ermes='FREQOBS' read(linexo(nfobs:nfobs+11),'(f12.7)',err=800)freqobs freqmhz=freqobs*1000.d0 ermes='FOMC' read(linexo(ndiff:ndiff+9),'(f10.4)',err=800)fomc ermes='FERR' read(linexo(nerr:nerr+7),'(F8.5)',err=800)ferr ferrmhz=ferr*1000.d0 write(lineres,31,err=900)linexo(2+norig:15+norig), * linexo(16+norig:24+norig), * linexo(ifirst:ilast), * freqmhz,fomc,ferrmhz else ! calc freq only ermes='FREQCALC' read(linexo(nfcalc:nfcalc+11),'(f12.7)',err=800)freqcalc freqmhz=freqcalc*1000.d0 fomc=0.d0 ferrmhz=0.d0 write(lineres,41,err=900)linexo(2+norig:15+norig), * linexo(16+norig:24+norig), * linexo(ifirst:ilast), * freqmhz,' <----------------- calc' endif endif 31 format(a,2x,a,6x,a,f18.4,f10.4,f9.3) ! obs and calc 41 format(a,2x,a,6x,a,f18.4,a) ! calc only c 20 write(4,'(a)')lineres(1:len_trim(lineres)) c if(lineres(1:11).ne.'Unconverted')nconv=nconv+1 nlines=nlines+1 goto 23 c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...copy over the .xo file below the block of lines fishing out c the selected parameters for conversion to customary units such as c MHz, kHz, Hz, deg etc. c 33 read(3,'(a)',err=500,end=7)linexo c c...there is only one occurrence of "Standard Deviation", which is after c the block headed "Parameters and Errors" c if(linexo(1:19).eq.' Standard Deviation')then write(*,157) write(4,157) 157 format(1x/' Statistics of fit as in original XIAM ', * '(n=n_lines, df=n-n_fittedconst, w=1/err^2):'/1x,81('-')) write(*,'(1x,a)')linexo(1:len_trim(linexo))// * ' = [(sum (w(o-c)^2)) (n/(df-1) sum(w) ]^(1/2)' write(4,'(a)')linexo(1:len_trim(linexo))// * ' = [(sum (w(o-c)^2)) (n/(df-1) sum(w) ]^(1/2)' write(*,'(44x,a)')'= [(sum(o-c)^2)/(df-1)]^(1/2) equal weights' write(4,'(43x,a)')'= [(sum(o-c)^2)/(df-1)]^(1/2) equal weights' c write(*,156) write(4,156) 156 format(1x/' Statistics of fit as in SPFIT ', * '(added by ZK to original XIAM):'/1x,81('-')) do 155 nn=1,3 write(*,'(1x,a)')statspfit(nn)(1:len_trim(statspfit(nn))) write(4,'(1x,a)')statspfit(nn)(1:len_trim(statspfit(nn))) 155 continue write(*,'(1x)') goto 33 endif c if(linexo(17:17).eq.'.')read(linexo(10:26),'(f17.9)',err=33)cval if(linexo(18:18).eq.'.')read(linexo(13:27),'(f15.9)',err=33)cval if(linexo(28:28).eq.'{'.and.linexo(41:41).eq.'}') * read(linexo(10:26),'(f17.9)',err=33)cval if(linexo(31:31).eq.'.')read(linexo(29:40),'(f12.9)',err=33)ercval if(linexo(36:36).eq.'.')read(linexo(28:45),'(f18.9)',err=33)ercval c if(linexo(34:38).eq.'fixed')ercval=0.d0 if(linexo(34:40).eq.'derived')ercval=0.d0 if(linexo(28:28).eq.'{'.and.linexo(41:41).eq.'}'.and. * (linexo(34:38).ne.'fixed'.and.linexo(34:40).ne.'derived')) * read(linexo(29:40),'(f12.9)',err=33)ercval if(linexo(56:56).eq.'.')read(linexo(50:68),'(f19.9)',err=33)cval if(linexo(75:75).eq.'.')read(linexo(69:87),'(f19.9)',err=33)ercval c c if(linexo(1:4).eq.' BJ '.and.linexo(11:11).ne.'.')then read(linexo(10:26),'(f17.9)')BJ if(linexo(34:38).eq.'fixed')then erbj=0.d0 else read(linexo(29:40),'(f12.9)')erbj endif BJ=BJ*1000.d0 ERBJ=ERBJ*1000.d0 endif c if(linexo(1:4).eq.' BK '.and.linexo(11:11).ne.'.')then read(linexo(10:26),'(f17.9)')BK if(linexo(34:38).eq.'fixed')then erbk=0.d0 else read(linexo(29:40),'(f12.9)')erbk endif BK=BK*1000.d0 ERBK=ERBK*1000.d0 endif c if(linexo(1:4).eq.' B- '.and.linexo(11:11).ne.'.')then read(linexo(10:26),'(f17.9)')BM if(linexo(34:38).eq.'fixed')then erbm=0.d0 else read(linexo(29:40),'(f12.9)')erbm endif BM=BM*1000.d0 ERBM=ERBM*1000.d0 endif c c...quartics c if(linexo(1:4).eq.' DJ '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iquartic=iquartic+1 DJ= cval erdj=ercval DJ= DJ*1.d6 ERDJ=ERDJ*1.d6 endif c if(linexo(1:5).eq.' DJK '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iquartic=iquartic+1 DJK= cval erdjk=ercval DJK= DJK*1.d6 ERDJK=ERDJK*1.d6 endif c if(linexo(1:5).eq.' DK '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iquartic=iquartic+1 DK=cval erdk=ercval DK= DK *1.d6 ERDK=ERDK *1.d6 endif c if(linexo(1:5).eq.' dj '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iquartic=iquartic+1 delj= cval erdelj=ercval delj= delj*1.d6 ERdelj=ERdelj*1.d6 endif c if(linexo(1:5).eq.' dk '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iquartic=iquartic+1 delk= cval erdelk=ercval delk= delk*1.d6 ERdelk=ERdelk*1.d6 endif c c...sextics c if(linexo(1:4).eq.' H_J'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)isextic=isextic+1 HJ= cval erhj=ercval HJ= HJ*1.d9 ERHJ=ERHJ*1.d9 endif c if(linexo(1:5).eq.' HJK '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)isextic=isextic+1 HJK= cval erhjk=ercval HJK= HJK*1.d9 ERHJK=ERHJK*1.d9 endif c if(linexo(1:5).eq.' HKJ '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)isextic=isextic+1 HKJ= cval erhkj=ercval HKJ= HKJ*1.d9 ERHKJ=ERHKJ*1.d9 endif c if(linexo(1:5).eq.' H_K '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)isextic=isextic+1 HK= cval erhk=ercval HK= HK *1.d9 ERHK=ERHK *1.d9 endif c if(linexo(1:4).eq.' h_J'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)isextic=isextic+1 h_j= cval erh_j=ercval H_J= H_J*1.d9 ERH_J=ERH_J*1.d9 endif c if(linexo(1:4).eq.' hjk'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)isextic=isextic+1 h_jk= cval ierh_jk=ercval H_JK= H_JK*1.d9 ERH_JK=ERH_JK*1.d9 endif c if(linexo(1:4).eq.' h_k'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)isextic=isextic+1 h_k= cval erh_k=ercval H_K= H_K*1.d9 ERH_K=ERH_K*1.d9 endif c c...hyperfine c if(linexo(1:7).eq.' chi_z '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)ihyperf=ihyperf+1 chiz= cval erchiz=ercval chiz= chiz*1000.d0 ERchiz=ERchiz*1000.d0 endif c if(linexo(1:7).eq.' chi_- '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)ihyperf=ihyperf+1 chimin = cval erchimin =ercval chimin = chimin*1000.d0 ERchimin =ERchimin*1000.d0 endif c if(chiz.ne.0.d0.and.chimin.ne.0.0d0)then chix=(chimin-chiz)*0.5d0 chiy=chix-chimin erchix=0.5d0*dsqrt(erchimin**2+erchiz**2) erchiy= dsqrt(erchimin**2+erchix**2) endif c if(linexo(1:7).eq.' chi_xy'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)ihyperf=ihyperf+1 chixy = cval erchixy =ercval chixy = chixy *1000.d0 ERchixy =ERchixy *1000.d0 endif c if(linexo(1:7).eq.' chi_xz'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)ihyperf=ihyperf+1 chixz = cval erchixz =ercval chixz = chixz *1000.d0 ERchixz =ERchixz *1000.d0 endif c if(linexo(1:7).eq.' chi_yz'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)ihyperf=ihyperf+1 chiyz = cval erchiyz =ercval chiyz = chiyz *1000.d0 ERchiyz =ERchiyz *1000.d0 endif c c...spin-rotation c if(linexo(1:7).eq.' C+ '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)ispinrot=ispinrot+1 cplus = cval ercplus =ercval cplus = cplus * 1.d3 ERcplus =ERcplus * 1.d3 endif c if(linexo(1:7).eq.' C_z '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)ispinrot=ispinrot+1 cz = cval ercz =ercval cz = cz * 1.d3 ERcz =ERcz * 1.d3 endif c if(linexo(1:7).eq.' C- '.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)ispinrot=ispinrot+1 cmin = cval ercmin =ercval cmin = cmin * 1.d3 ERcmin =ERcmin * 1.d3 endif c c...top-top c if(linexo(2:7).eq.'F12 '.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)itoptop=itoptop+1 f12 = cval erf12 =ercval f12 = f12 * 1.d3 erf12 =ERf12 * 1.d3 endif c if(linexo(1:7).eq.' Vss '.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)itoptop=itoptop+1 vss = cval ervss =ercval vss = vss * 1.d3 ervss =ERvss * 1.d3 endif c if(linexo(1:7).eq.' Vcc '.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)itoptop=itoptop+1 vcc = cval ervcc =ercval vcc = vcc * 1.d3 ervcc =ERvcc * 1.d3 endif c c...int-rot c if(linexo(1:4).eq.' V1n'.and. * linexo(28:28).eq.'{'.and.linexo(41:41).eq.'}')then if(cval.ne.0.d0)iintrot =iintrot+1 v1n = cval erv1n =ercval v1n = v1n ! for MHz: * 1.d3 erv1n =ERv1n ! for MHz: * 1.d3 v1ncm =v1n*1000.d0/mhzcm erv1ncm=erv1n*1000.d0/mhzcm endif c if(linexo(1:4).eq.' V2n'.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 v2n = cval erv2n =ercval v2n = v2n * 1.d3 erv2n =ERv2n * 1.d3 endif c if(linexo(2:4).eq.'rho'.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 rho =cval errho =ercval endif c if(linexo(2:4).eq.'F '.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 F =cval erF =ercval F = F * 1.d3 erF =ERF * 1.d3 endif c if(linexo(2:5).eq.'beta'.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 beta = cval erbeta =ercval beta = beta * radeg erbeta =erbeta * radeg endif c if(linexo(2:6).eq.'delta'.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 delta = cval erdelta =ercval delta = delta * radeg erdelta =erdelta * radeg endif c if(linexo(2:6).eq.'gamma'.and.linexo(17:17).eq.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 gamma = cval ergamma =ercval gamma = gamma * radeg ergamma =ergamma * radeg endif c if(linexo(2:7).eq.'<(i,x)'.and.linexo(33:33).eq.'.')then read(linexo(24:),*)aix,aiy,aiz write(4,'(a)')linexo(1:len_trim(linexo)) read(3,'(a)',err=500,end=7)linexo read(linexo(24:),*)eraix,eraiy,eraiz iintrot =iintrot+3 endif c if(linexo(2:8).eq.'I_alpha'.and.linexo(18:18).eq.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 ialph = cval erialph =ercval endif c if(linexo(2:3).eq.'F0')then if(cval.ne.0.d0)iintrot =iintrot+1 f0 = cval erf0 =ercval f0 = f0 * 1.d3 erf0 =erf0 * 1.d3 endif c if(linexo(1:6).eq.' Dpi2J'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 dpi2j = cval erdpi2j =ercval dpi2j = dpi2j * 1.d3 erdpi2j =ERdpi2j * 1.d3 endif c if(linexo(1:6).eq.' Dpi2K'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 dpi2k = cval erdpi2k =ercval dpi2k = dpi2k * 1.d3 erdpi2k =ERdpi2k * 1.d3 endif c if(linexo(1:6).eq.' Dpi2-'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 dpi2m = cval erdpi2m =ercval dpi2m = dpi2m * 1.d3 erdpi2m =ERdpi2m * 1.d3 endif c if(linexo(1:5).eq.' Dc3J'.and.linexo(11:11).ne.'.')then if(cval.ne.0.d0)iintrot =iintrot+1 dc3j = cval erdc3j =ercval dc3j = dc3j * 1.d3 erdc3j =erdc3j * 1.d3 endif c if(linexo(1:5).eq.' Dc3K'.and.linexo(11:11).ne.'.')then ! only in XIAM_mod if(cval.ne.0.d0)iintrot =iintrot+1 dc3k =c val erdc3k =ercval dc3k = dc3k * 1.d3 erdc3k =erdc3k * 1.d3 endif c if(linexo(1:5).eq.' Dc3-'.and.linexo(11:11).ne.'.')then ! only in XIAM_mod if(cval.ne.0.d0)iintrot =iintrot+1 dc3m = cval erdc3m =ercval dc3m = dc3m * 1.d3 erdc3m =erdc3m * 1.d3 endif c c...A,B,C c if(linexo(1:10).eq.' B_z '.and.linexo(11:11).ne.'.')then read(linexo(10:26),'(f17.9)')bz read(linexo(28:45),'(f18.9)')erbz bz=bz*1000.d0 ERbz=ERbz*1000.d0 endif c if(linexo(1:10).eq.' B_x '.and.linexo(11:11).ne.'.')then read(linexo(10:26),'(f17.9)')bx read(linexo(28:45),'(f18.9)')erbx bx=bx*1000.d0 ERbx=ERbx*1000.d0 endif c if(linexo(1:10).eq.' B_y '.and.linexo(11:11).ne.'.')then read(linexo(10:26),'(f17.9)')by read(linexo(28:45),'(f18.9)')erby by=by*1000.d0 ERby=ERby*1000.d0 endif c c...The "Correlation Matrix" text concludes the final .xo file block listing c fitted and derived parameters c if(linexo(1:19).ne.' Correlation Matrix')then write(4,'(a)')linexo(1:len_trim(linexo)) ! echo the .xo line to .res goto 33 ! read another .xo line endif c c - - - - - - - - - - - - - - - - - - - c c...Output of selected parameters c c write(4,'(44(''-'')/a/44(''-''))')'Selected parameters:' if(bj.ne.0.d0)then if(erbj.ne.0.d0)call conforx(bj,erbj,' BJ /MHz ') if(erbj.eq.0.d0)call confixx(bj, ' BJ /MHz ') c write(4,62)' BJ ',bj endif c if(bk.ne.0.d0)then if(erbk.ne.0.d0)call conforx(bk,erbk,' BK /MHz ') if(erbk.eq.0.d0)call confixx(bk, ' BK /MHz ') c write(4,60)' BK ',bk,erbk endif c if(bm.ne.0.d0)then if(erbm.ne.0.d0)call conforx(bm,erbm,' B- /MHz ') if(erbm.eq.0.d0)call confixx(bm, ' B- /MHz ') c write(4,60)' B- ',bm,erbm endif write(4,'(1x)') c if(bz.ne.0.d0)then if(erbz.ne.0.d0)call conforx(bz,erbz,' Bz /MHz ') if(erbz.eq.0.d0)call confixx(bz, ' Bz /MHz ') c write(4,60)' Bz ',bz,erbz endif c if(bx.ne.0.d0)then if(erbx.ne.0.d0)call conforx(bx,erbx,' Bx /MHz ') if(erbx.eq.0.d0)call confixx(bx, ' Bx /MHz ') c write(4,60)' Bx ',bx,erbx endif if(by.ne.0.d0)then if(erby.ne.0.d0)call conforx(by,erby,' By /MHz ') if(erby.eq.0.d0)call confixx(by, ' By /MHz ') c write(4,60)' By ',by,erby endif c c...output of any quartics c if(iquartic.gt.0)write(4,'(1x)') c if(dj.ne.0.d0)then if(erdj.ne.0.d0)call conforx(dj,erdj,' DJ /kHz ') if(erdj.eq.0.d0)call confixx(dj, ' DJ /kHz ') endif c if(djk.ne.0.d0)then if(erdjk.ne.0.d0)call conforx(djk,erdjk,' DJK /kHz ') if(erdjk.eq.0.d0)call confixx(djk, ' DJK /kHz ') endif c if(dk.ne.0.d0)then if(erdk.ne.0.d0)call conforx(dk,erdk,' DK /kHz ') if(erdk.eq.0.d0)call confixx(dk, ' DK /kHz ') endif c if(delj.ne.0.d0)then if(erdelj.ne.0.d0) * call conforx(delj,erdelj,' delJ /kHz ') if(erdelj.eq.0.d0) * call confixx(delj, ' delJ /kHz ') endif c if(delk.ne.0.d0)then if(erdelk.ne.0.d0) * call conforx(delk,erdelk,' delK /kHz ') if(erdelk.eq.0.d0) * call confixx(delk, ' delK /kHz ') endif c c...output of any sextics c if(isextic.gt.0)write(4,'(1x)') c if(hj.ne.0.d0)then if(erhj.ne.0.d0)call conforx(hj,erhj,' H_J /Hz ') if(erhj.eq.0.d0)call confixx(hj, ' H_J /Hz ') endif c if(hjk.ne.0.d0)then if(erhjk.ne.0.d0) * call conforx(hjk,erhjk,' HJK /Hz ') if(erhjk.eq.0.d0) * call confixx(hjk, ' HJK /Hz ') endif c if(hkj.ne.0.d0)then if(erhkj.ne.0.d0) * call conforx(hkj,erhkj,' HKJ /Hz ') if(erhkj.eq.0.d0) * call confixx(hkj, ' HKJ /Hz ') endif c if(hk.ne.0.d0)then if(erhk.ne.0.d0)call conforx(hk,erhk,' H_K /Hz ') if(erhk.eq.0.d0)call confixx(hk, ' H_K /Hz ') endif c if(h_j.ne.0.d0)then if(erh_j.ne.0.d0) * call conforx(h_j,erh_j,' h_j /Hz ') if(erh_j.eq.0.d0) * call confixx(h_j, ' h_j /Hz ') endif c if(h_jk.ne.0.d0)then if(erh_jk.ne.0.d0) * call conforx(h_jk,erh_jk,' hjk /Hz ') if(erh_jk.eq.0.d0) * call confixx(h_jk, ' hjk /Hz ') endif c if(h_k.ne.0.d0)then if(erh_k.ne.0.d0) * call conforx(h_k,erh_k,' h_k /Hz ') if(erh_k.eq.0.d0) * call confixx(h_k, ' h_k /Hz ') endif c c...output of any hyperfine c if(ihyperf.gt.0)write(4,'(1x)') c if(chiz.ne.0.d0)then if(erchiz.ne.0.d0) * call conforx(chiz,erchiz, ' chi_z /MHz ') if(erchiz.eq.0.d0) * call confixx(chiz, ' chi_z /MHz ') endif c if(chix.ne.0.d0)then if(erchix.ne.0.d0) * call conforx(chix ,erchix ,' chi_x /MHz ') if(erchix.eq.0.d0) * call confixx(chix , ' chi_x /MHz ') endif c if(chiy.ne.0.d0)then if(erchiy.ne.0.d0) * call conforx(chiy ,erchiy ,' chi_y /MHz ') if(erchix.eq.0.d0) * call confixx(chiy , ' chi_y /MHz ') endif c if(chimin.ne.0.d0)then if(erchimin.ne.0.d0) * call conforx(chimin,erchimin,' chi_- /MHz ') if(erchimin.eq.0.d0) * call confixx(chimin, ' chi_- /MHz ') endif c if(chiz.ne.0.d0)then if(erchiz.ne.0.d0) * call conforx(chiz*1.5d0,erchiz*1.5d0,' (3/2) chi_z /MHz ') if(erchiz.eq.0.d0) * call confixx(chiz*1.5d0, ' (3/2) chi_z /MHz ') endif c if(chimin.ne.0.d0)then if(erchimin.ne.0.d0) call conforx(chimin*0.25d0, * erchimin*0.25d0,' (1/4) chi_- /MHz ') if(erchimin.eq.0.d0)call confixx(chimin*0.25d0, * ' (1/4) chi_- /MHz ') endif c if(chixy .ne.0.d0)then if(erchixy .ne.0.d0)call conforx(chixy, * erchixy,' chi_xy /MHz ') if(erchixy .eq.0.d0)call confixx(chixy, * ' chi_xy /MHz ') endif c if(chixz .ne.0.d0)then if(erchixz .ne.0.d0)call conforx(chixz, * erchixz,' chi_xz /MHz ') if(erchixz .eq.0.d0)call confixx(chixz, * ' chi_xz /MHz ') endif c if(chiyz .ne.0.d0)then if(erchiyz .ne.0.d0)call conforx(chiyz, * erchiyz,' chi_yz /MHz ') if(erchiyz .eq.0.d0)call confixx(chiyz, * ' chi_yz /MHz ') endif c c...output of any spin-rotation c if(ispinrot.gt.0)write(4,'(1x)') c if(cplus .ne.0.d0)then if(ercplus .ne.0.d0)call conforx(cplus, * ercplus,' C+ /MHz ') if(ercplus .eq.0.d0)call confixx(cplus, * ' C+ /MHz ') endif c if(cz .ne.0.d0)then if(ercz .ne.0.d0)call conforx(cz , * ercz ,' C_z /MHz ') if(ercz .eq.0.d0)call confixx(cz , * ' C_z /MHz ') endif c if(cmin .ne.0.d0)then if(ercmin .ne.0.d0)call conforx(cmin , * ercmin ,' C- /MHz ') if(ercmin .eq.0.d0)call confixx(cmin , * ' C- /MHz ') endif c c...output of any top-top c if(itoptop.gt.0)write(4,'(1x)') c if(f12.ne.0.d0)then if(erf12.ne.0.d0) * call conforx(f12,erf12,' F12 /MHz ') if(erf12.eq.0.d0) * call confixx(f12, ' F12 /MHz ') endif c if(vss.ne.0.d0)then if(ervss.ne.0.d0) * call conforx(vss,ervss,' Vss /MHz ') if(ervss.eq.0.d0) * call confixx(vss, ' Vss /MHz ') endif c if(vcc.ne.0.d0)then if(ervcc.ne.0.d0) * call conforx(vcc,ervcc,' Vcc /MHz ') if(ervcc.eq.0.d0) * call confixx(vcc, ' Vcc /MHz ') endif c c...output of any int-rot c if(iintrot.gt.0)write(4,'(1x)') c if(v1n.ne.0.d0)then if(erv1n.ne.0.d0)then call conforx(v1n,erv1n,' V1n /GHz ') call conforx(v1ncm,erv1ncm,' V1n /cm-1 ') endif if(erv1n.eq.0.d0)then call confixx(v1n, ' V1n /GHz ') call confixx(v1ncm, ' V1n /cm-1 ') endif endif c if(v2n.ne.0.d0)then if(erv2n.ne.0.d0) * call conforx(v2n,erv2n,' V2n /MHz ') if(erv2n.eq.0.d0) * call confixx(v2n, ' V2n /MHz ') endif c if(rho.ne.0.d0)then if(errho.ne.0.d0) * call conforx(rho,errho,' rho ') if(errho.eq.0.d0) * call confixx(rho, ' rho ') endif c if(beta.ne.0.d0)then if(erbeta.ne.0.d0) * call conforx(beta,erbeta,' beta /deg ') if(erbeta.eq.0.d0) * call confixx(beta, ' beta /deg ') endif c if(delta.ne.0.d0)then if(erdelta.ne.0.d0) * call conforx(delta,erdelta,' delta /deg ') if(erdelta.eq.0.d0) * call confixx(delta, ' delta /deg ') endif c if(gamma.ne.0.d0)then if(ergamma.ne.0.d0) * call conforx(gamma,ergamma,' gamma /deg ') if(ergamma.eq.0.d0) * call confixx(gamma, ' gamma /deg ') endif c if(aiz.ne.0.d0)then write(4,'(1x)') if(eraiz.ne.0.d0) * call conforx(aiz, eraiz ,' <(i,z) /deg ') if(eraiz.eq.0.d0) * call confixx(aiz, ' <(i,z) /deg ') endif c if(aix.ne.0.d0)then if(eraix.ne.0.d0) * call conforx(aix, eraix ,' <(i,x) /deg ') if(eraix.eq.0.d0) * call confixx(aix, ' <(i,x) /deg ') endif c if(aiy.ne.0.d0)then if(eraiy.ne.0.d0) * call conforx(aiy, eraiy ,' <(i,y) /deg ') if(eraiy.eq.0.d0) * call confixx(aiy, ' <(i,y) /deg ') endif c if(f .ne.0.d0)then if(erf .ne.0.d0) * call conforx(f ,erf ,' F /MHz ') if(erf .eq.0.d0) * call confixx(f , ' F /MHz ') endif c if(f0 .ne.0.d0)then if(erf0 .ne.0.d0) * call conforx(f0 ,erf0 ,' F0 /MHz ') if(erf0 .eq.0.d0) * call confixx(f0 , ' F0 /MHz ') endif c if(ialph.ne.0.d0)then if(erialph .ne.0.d0) * call conforx(ialph,erialph,' I_alpha /uA^2 ') if(erialph.eq.0.d0) * call confixx(ialph, ' I_alpha /uA^2 ') endif c if(dpi2j .ne.0.d0)then if(erdpi2j .ne.0.d0) * call conforx(dpi2j ,erdpi2j ,' Dpi2J /MHz ') if(erdpi2j .eq.0.d0) * call confixx(dpi2j , ' Dpi2J /MHz ') endif c if(dpi2k .ne.0.d0)then if(erdpi2k .ne.0.d0) * call conforx(dpi2k ,erdpi2k ,' Dpi2K /MHz ') if(erdpi2k .eq.0.d0) * call confixx(dpi2k , ' Dpi2K /MHz ') endif c if(dpi2m .ne.0.d0)then if(erdpi2m .ne.0.d0) * call conforx(dpi2m ,erdpi2m ,' Dpi2- /MHz ') if(erdpi2m .eq.0.d0) * call confixx(dpi2m , ' Dpi2- /MHz ') endif c if(dc3j .ne.0.d0)then if(erdc3j .ne.0.d0) * call conforx(dc3j ,erdc3j ,' Dc3J /MHz ') if(erdc3j .eq.0.d0) * call confixx(dc3j , ' Dc3J /MHz ') endif c if(dc3k .ne.0.d0)then if(erdc3k .ne.0.d0) * call conforx(dc3k ,erdc3k ,' Dc3K /MHz ') if(erdc3k .eq.0.d0) * call confixx(dc3k , ' Dc3K /MHz ') endif c if(dc3m .ne.0.d0)then if(erdc3m .ne.0.d0) * call conforx(dc3m ,erdc3m ,' Dc3- /MHz ') if(erdc3m .eq.0.d0) * call confixx(dc3m , ' Dc3- /MHz ') endif c write(4,'(44(''-'')/1x)') ! end of selected output c c 60 format(a,f20.8,' +-',f14.8) 61 format(a,f17.8,' +-',f14.8) 62 format(a,f20.8,' fixed') c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Copy over the block with the correlation matrix onwards c write(4,'(a)')linexo(1:len_trim(linexo)) 53 read(3,'(a)',err=500,end=7)linexo write(4,'(a)')linexo(1:len_trim(linexo)) goto 53 c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c 7 close(3) close(2) close(4) c 6 write(*,'(i7,a/i7,a//)')nlines,' lines read', * nconv, ' lines successfully converted' c c write(*,'(i7/)')norig stop 200 write(*,'(1x//1x,a//)') * '***** Cannot open: '//filxo(1:len_trim(filxo)) stop 300 write(*,'(1x//1x,a//)') * '***** Cannot open: '//filxi(1:len_trim(filxi)) stop 400 write(*,'(1x//1x,a//)') * '***** Cannot open: '//filres(1:len_trim(filres)) stop 500 write(*,'(1x//1x,a//)') * '***** Error reading from: '//filxo(1:len_trim(filxo)) stop 600 write(*,'(1x//1x,a//)') * '***** Error reading from: '//filxi(1:len_trim(filxi)) stop 700 write(*,'(1x//1x,a//)') * '***** Error writing to: '//filres(1:len_trim(filres)) stop 800 write(*,'(1x//1x,a,1x,a,a/1x,a//)') * '***** Error on reading ', * ermes(1:len_trim(ermes)),' from .xo line:', * linexo(1:len_trim(linexo)) stop 900 write(*,'(1x//1x,a/1x,a//)') * '***** Error on writing to .RES line based on .xo line: ', * linexo(1:len_trim(linexo)) stop end C C_____________________________________________________________________________ c c SUBROUTINE CONFOR(CONVAL,ERVAL,NDCON,NDEROR,NERD) SUBROUTINE CONFORX(constval,erconst,cdescr) C C Parameter and error formatting for output (adapted from routine CONFOR in PIFORM) c c CONSTVAL - numerical value of the parameter to be formatted (copied to CONVAL c which may be subjected to rounding) C ERCONST - estimated error in the above C CDESCR - 20 character alphanumeric descriptor of the parameter C C Internal to CONFOR: C c CONVAL - String containing the parameter value. This is to be c input in F format and will be replaced on output by the 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 the result c string, which does not contain the decimal point and is meant c to be included in brackets c NDCON - The number of digits in the CONVAL string (inclusive of any c leading zeros) c NDEROR - The number of digits in the ERVAL string (just the significant c digits) and is either equal to NERD, or is larger if there c are more significant digits than NERD before the decimal point. c NERD - the number of desired error digits, which is to be set on input. c c Both NDCON and NDEROR are generated on output C implicit real*8(a-h,o-z) CHARACTER(27) CONVAL,ERVAL,CONOUT,EROUT character cdescr*20 c NERD=2 NITER=0 const=constval C C...preliminaries C 417 WRITE(CONVAL,'(F27.16)')const WRITE(ERVAL,'(F27.16)')erconst C NDEROR=0 NDNOTZ=0 ICZERO=0 erout='???????????' C C...Go through digits of parameter 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 parameter 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 c...output string with fitted value (rounding is to be carried out externally) c 2 CONVAL(1:NDCON)=CONOUT(1:NDCON) c c...output string with error (rounded if necessary) c if(nderor.gt.0)then c write(*,'(1x,2a,5x,a)') DEBUG c * 'ERROR: ',erval,erout(1:nderor) DEBUG c if(erval(ndcon+1:ndcon+1).eq.'5'.or. * erval(ndcon+1:ndcon+1).eq.'6'.or. * erval(ndcon+1:ndcon+1).eq.'7'.or. * erval(ndcon+1:ndcon+1).eq.'8'.or. * erval(ndcon+1:ndcon+1).eq.'9')then read(erout(1:nderor),*)ieror net=int(dlog10(dble(ieror))) ! Fortran2018 ieror=ieror+1 net1=int(dlog10(dble(ieror))) ! Fortran2018 if(net1-net.gt.0)nderor=nderor+1 write(erout,'(i12)')ieror erval(1:nderor)=erout(12-nderor+1:12) else ERVAL(1:NDEROR)=EROUT(1:NDEROR) endif endif C C...rounding (if necessary) (rounding as coded tends in rare cases to go into c an infinite loop, hence the NITER cludge) C if(conval(ndcon+1:ndcon+1).eq.'5'.or. * conval(ndcon+1:ndcon+1).eq.'6'.or. * conval(ndcon+1:ndcon+1).eq.'7'.or. * conval(ndcon+1:ndcon+1).eq.'8'.or. * conval(ndcon+1:ndcon+1).eq.'9')then c write(*,'(1x,2a,i8,f27.16)')conval,conval(1:ndcon),ndcon, c * 10.d0**(-(ndcon-10)) const=const+dsign(1.d0,const)*10.0d0**(-(ndcon-10)) niter=niter+1 if(niter.le.5)goto 417 endif C write(4,518)cdescr(1:20),CONVAL(1:NDCON),ERVAL(1:NDEROR) 518 format(a,a,'(',a,')') C RETURN END C_____________________________________________________________________________ c c subroutine confixx(const,cdescr) c C Fixed parameter formatting for output: adapted from routine CONFIX in PIFORM C c CONST - numerical value of the parameter to be formatted C CDESCR - 20 character alphanumeric descriptor of the parameter c implicit real(8) (a-h,o-z) character conval*27,cdescr*20 C ASCLD=const if(dabs(const).le.1.d-19)ascld=0.0d0 IF(ASCLD.NE.0.0D0)ASCLD=ASCLD+DMOD(ASCLD,1.0D-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.0d0)then mmm=int(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 (while for a fixed angle in degrees truncate c to five digits after the decimal point) if(cdescr(10:13).ne.'/deg')then 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 else DO 1118 MM=27,1,-1 IF(CONVAL(MM:MM).eq.'.')then m=mm+5 GOTO 1115 ENDIF 1118 CONTINUE endif C C...terminating square bracket C 1115 iend=m+1 if(iend.gt.27)iend=27 conval(iend:iend)=']' c c write(*,'(1x,a)')cdescr(1:20) DEBUG c write(*,'(1x,a)')CONVAL(1:iend) DEBUG write(4,519)cdescr(1:20),CONVAL(1:iend) 519 format(a,a) c return end C_____________________________________________________________________________ C_____________________________________________________________________________