C----------------------------------------------------------------------------- c c X A - converter for XIAM output --> ASCP_L (and ASCP) input c C ver. 23.IX.2023 ----- 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 15.09.00: creation via a hatchet job on PISORT C 12.10.00: IEQUAL parameter C 1.03.02: reading of ints=2,ntops=2 output C 10.06.02: B filtering C 3.03.17: significant reworking c 23.09.23: multiple updates and IEQUAL feature dropped until clarified c C----------------------------------------------------------------------------- C NOTES: C C - This version is best used on XIAM output generated with ints=2 C C - The intensity transferred to the output is total/stat.w, otherwise C Q-type lines are much too large relative to low-J R-types. C Stat.w is simply 2J+1 C C - The last three quanta in the ASROT output line are always set to S,V,B C and when the J,K notation is encountered in the input then the K+1 C asymmetric top quantum is set to -99 for both lower and upper state C C----------------------------------------------------------------------------- c parameter (maxlin=100000,maxst=20) c character*125 L(maxlin),line,errmes real*8 f(maxlin),smax(maxst),freqin integer i(maxlin),nstart,nlines,ibnums(maxlin) integer index(maxlin) character*30 filin,filout common /lbuf/L common /scale/smax common /freq/f common /point/i nbees=0 c WRITE(*,3344) 3344 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | X A - XIAM output --> ASCP_L input ', * T79,'|'/ * ' |',T79,'|'/ * ' | 1/ tested with XIAM5 and .xo output with INTS=2' * T79,'|'/ * ' | 2/ might work for some INTS=3 outputs (less tested)', * T79,'|'/ * ' |',76(1H_),'|'/' version 23.IX.2023',T64,'Zbigniew KISIEL'/) write(*,'(1x/'' - compiled for maximum of'',i7,'' lines'')') * maxlin c c c...open .xo file 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 filin=filin(1:n)//'.xo' goto 101 endif 100 continue 101 write(*,'(1x/'' R E A D I N G: '',a)')filin open(3,file=filin,status='OLD',err=2) c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Loop for fishing out spectral lines from the .XO file c (control goes back to line with label 5) c 53 nlines=0 c 5 read(3,'(a)',end=6,err=5)line c if(line(21:26).eq.'ints ')then read(line(33:34),'(i2)',err=5)ints write(*,'(/1x,'' ----> found INTS ='',i3)')ints goto 5 endif c if(line(1:5).eq.'-- B ')then read(line(6:6),'(i1)',err=5)ibval write(*,'(/1x,'' ----> found B ='',i2,'' in linelist'')')ibval nbees=nbees+1 goto 5 endif if(line(42:42).eq.'.'.and.line(81:81).eq.'.')goto 36 ints=3 .XO file if(line(37:37).eq.'.'.and.line(84:84).eq.'.')goto 37 ints=2 .XO file goto 5 c C...ints=3 .XO file C 36 nlines=nlines+1 inptyp=3 L(nlines)=line read(line(38:48),'(f11.6)',err=8)f(nlines) i(nlines)=nlines if(line(22:37).eq.'S 2 ')then l(nlines)(1:18)=l(nlines-1)(1:18) l(nlines)(27:34)=l(nlines-1)(27:34) endif if(nlines.eq.maxlin)goto 6 goto 5 c c...ints=2 .XO file c 37 nlines=nlines+1 inptyp=2 L(nlines)=line read(line(33:43),'(f11.6)',err=8)f(nlines) i(nlines)=nlines ibnums(nlines)=ibval if(nlines.eq.maxlin)goto 6 goto 5 c 8 nlines=nlines-1 goto 5 c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c 6 write(*,7)nlines 7 format(1x/1x,i5,' lines read in'/) close(3) c c...EQUALISE state populations? c this option allows to account for relative intensities in low c temperature spectra where condensation within stacks of the same c symmetry takes place c c 22 write(*,21) c 21 format(1x/' equalise state populations (1,0 = Y/N) ? ',$) c read(*,'(i1)',err=22)iequal iequal=0 c c...frequency sort c write(*,'(1x/'' S O R T I N G'')') nstart=1 call sorth(nstart,nlines) <------ c if(iequal.eq.1)then do 15 n=1,maxst smax(n)=0.d0 15 continue c do 10 n=1,nlines errmes='reading is,iv,ib from sorted lines' c if(inptyp.eq.3)then if(line(30:30).ne.'i')then 'rigid' line read(line(25:25),'(i1)',err=500)is read(line(30:30),'(i1)',err=500)iv read(line(35:35),'(i1)',err=500)ib else is=0 iv=0 ib=0 endif endif c if(inptyp.eq.2)then read(l(n)(25:25),'(i1)',err=500)is read(l(n)(30:30),'(i1)',err=500)iv ib=ibnums(n) endif index(n)=is*iv*ib 10 continue c do 11 n=1,nlines errmes='reading s,statwt from sorted lines' c if(inptyp.eq.3)then if(line(73:73).ne.'E')then read(l(n)(68:76),'(f9.4)',err=500)s else read(l(n)(68:76),'(E9.4)',err=500)s endif read(line(77:88),'(f9.4)',err=500)statwt s=s/statwt if(s.gt.smax(index(n)))smax(index(n))=s endif c if(inptyp.eq.2)then read(l(n)(53:61),'(f9.4)',err=500)s read(line(62:70),'(f9.4)',err=500)statwt s=s/statwt if(s.gt.smax(index(n)))smax(index(n))=s endif 11 continue c s=smax(1) do 12 n=1,maxst if(smax(n).ne.0.d0)smax(n)=s/smax(n) 12 continue endif c iasrot=1 c c...output c 201 write(*,202) 202 format(1x//2x, *'Cut out a subset of lines for a specified value of v ?'// * 20x,' 0 = transfer all lines'/ * 20x,' v = only transfer lines for specified value of v'/ * 20x,'100 = generate separate preprogrammed SV files'/ * 20x,'555 = EXIT'// * 20x,'.... ',$) read(*,'(i5)',err=201)ivcut if(ivcut.eq.555)goto 9 c ibcut=1 if(nbees.gt.1)then write(*,205) 205 format(8x,' Value of B .... ',$) read(*,*,err=206)ibcut 206 if(ibcut.lt.1.or.ibcut.gt.nbees)ibcut=1 endif C if(ivcut.ne.100)then 3 write(*,1)' Name of output file:' read(*,'(a)',err=3)filout open(4,file=filout,err=3,status='unknown') write(4,200)filin else open( 7,file='S1V1.asr',err=33,status='unknown') open( 8,file='S2V1.asr',err=33,status='unknown') open( 9,file='S2V0.asr',err=33,status='unknown') open(10,file='S0V0.asr',err=33,status='unknown') nwrit1=0 nwrit2=0 nwrit3=0 nwrit4=0 write( 7,200)filin write( 8,200)filin write( 9,200)filin write(10,200)filin endif c 200 format(79(1h-)/' Converted from file ',a/ * ' No temperature correction'/79(1h-)/) c c...conversion line by line of frequency sorted lines stored in array L c nwrit=0 do 14 n=1,nlines ii=i(n) line=L(ii) ibval=ibnums(ii) freqin=f(n) c write(*,'(i5,$)')n debug c write(*,'(1x,a)')line(1:77) debug c pause debug call casrot(line,freqin,iequal,inptyp,ibval) <------ read(line(65:65),'(i1)')is read(line(68:68),'(i1)')iv read(line(71:71),'(i1)')ib c C C 2008.4000 1.19E-03 10, 1, 9 9, 2, 8 b 0, 0, 0-- 1, 1, 1 0.00 C 2010.7830 1.76E-03 21, 2, 19 21, 1, 20 b 0, 0, 0-- 1, 1, 1 0.00 C 2011.7770 1.00E-04 3, 3, 1 4, 2, 2 b 0, 0, 0-- 1, 1, 1 0.00 C C 2006.2340 4.35E-06 12, 0, 12 11, 1, 10 c 0, 0, 0-- 2, 1, 1 0.00 C 2034.0480 1.90E-05 11, 1, 10 10, 2, 8 c 0, 0, 0-- 2, 1, 1 0.00 C 2037.6530 5.20E-05 12, 1, 12 12, 0, 12 c 0, 0, 0-- 2, 1, 1 0.00 C if(ivcut.eq.100)then if(is.eq.1.and.iv.eq.1)then nwrit1=nwrit1+1 write(7,'(a)')line(1:79) endif c if(is.eq.2.and.iv.eq.1)then nwrit2=nwrit2+1 write(8,'(a)')line(1:79) endif c if(is.eq.2.and.iv.eq.0)then nwrit3=nwrit3+1 write(9,'(a)')line(1:79) endif c if(is.eq.0.and.iv.eq.0)then nwrit4=nwrit4+1 write(10,'(a)')line(1:79) endif goto 14 endif c if(ivcut.gt.0)then if(ivcut.eq.iv.and.ibcut.eq.ib)then write(4,'(a)')line(1:79) nwrit=nwrit+1 endif else write(4,'(a)')line(1:79) nwrit=nwrit+1 endif 14 continue c if(ivcut.ne.100)then write(*,20)nwrit write(4,20)nwrit 20 format(1x/1x,i5,' lines written to file') close(4) else write(*,'(1x)') write(*,30)nwrit1,'S1V1.ASR' write(*,30)nwrit2,'S2V1.ASR' write(*,30)nwrit3,'S2V0.ASR' write(*,30)nwrit4,'S0V0.ASR' write(*,'(1x)') close(7) close(8) close(9) close(10) 30 format(1x,i5,' lines written to file ',a) endif c if(ivcut.ne.0.and.ivcut.ne.100)goto 201 c 9 stop c 33 write(*,'(1x// * '' ***** ERROR: Cannot open a predefined output file''//)') stop c 500 write(*,501)n,l(n)(1:len_trim(l(n))),errmes(1:len_trim(errmes)) 501 format(1x//' ***** ERROR reading line,',i5,':'// * 1x,a//7x,'Problem = ',a//) c end C_____________________________________________________________________________ C subroutine casrot(line,freq,iequal,inptyp,ibval) c c Routine to convert a line of XIAM output into a line equivalent c to .ASR output c c line - on entry = full ASCII line of .XO output c one exit = replaced by line LINASR into which conversion to ASROT c standard has been made c freq - frequency of the transition contained in the output line c iequal - flag whether intensities in states are to be equalised (=1) c or not C inptyp - type of input to be dealt with i.e. type of XIAM output, so far C two types are recognised: C =3 for XIAM output with ints=3 C =2 for XIAM output with ints=2 C ibval - the value of the B identifier for the line (for inptyp=2) c c sample .XO lines (first character, usually a space, at the beginning of each line replaced by c): c C C--- for ints=3,ntop=1 (also only V 0 in the torsional states block): c c46 2 45 45 1 44 S 2 V 1 B 1 166.278905 .4102 .5247 91.0000 .4879 .0288 K 5 4 t 4 3 c S 2 166.278905 16.0941 .4102 .5247 91.0000 .4879 .0288 K -5 5 t 3 4 c47 1 47 46 0 46 rigid 166.122563 46.7825 63.5195 93.0000 .5073 .0288 K 0 0 t 2 1 c c 1 1 1 0 0 0 rigid 3.303781 1.0000 1.57E-02 1.0000 1.0000 0.0157 K -1 0 t 2 1 c 1 1 1 0 0 0 S 1 V 1 B 1 3.303796 1.0000 2.31E-07 1.0000 0.0000 0.0157 K -1 0 t 2 1 C C--- for ints=2,ntop=2: C C 7 5 3 6 3 4 S 1 V 1 121.469425 0.2545 0.0055 13.0000 0.0856 0.0194 B 1 K -5 -3 t 10 6 C 2 K -1 1 K -1 S 2 V 2 8.507037 1.4996 0.0054 3.0000 0.8831 0.0014 B 1 K -1 -1 t 7 4 c C--- for ints=2,ntop=1 (it appears that for more than two vibrational states only the asymmetric quantisation is C produced, while for one and two states symmetric quantisation is used for the E symmetry): C c-- B 1 Freq/GHz Linestr. total stat.w. popul. hv-ener. c 6 3 3 5 2 4 S 1 V 1 5.801956 2.9419 0.0652 11.0000 0.0155 0.1300 B 1 K 3 -2 t 7 4 c 3 3 0 4 2 3 S 1 V 1 2.014419 0.1260 0.0007 7.0000 0.0162 0.0472 B 1 K 3 -2 t 7 4 c17 K 14 16 K 14 S 2 V 1 6.436583 5.4645 0.0002 33.0000 0.0000 0.1431 B 1 K 14 14 t 26 26 c c c typical ASROT line is: c c 25277.238471 0.99E-07 116, 7,110 115, 6,109 b.R 1, 1 99.048770 543.614 c c but the information past the dipole letter is not read by ASC, and ASCP c uses that space for reading in the remaining 6 SPFIT numbers which are c written by XA as: c C117444.1572 2.86E-04 16, 1, 15 15, 2, 14 b 0, 0, 0--is,iv,ib 0.000 c c c parameter (maxst=20) c character*125 line,linasr,errmes integer nq(12) character*2 cdip real*8 s,freq,smax(maxst) common /scale/smax c c...frequency (convert to MHz) c freq=freq*1000.d0 write(linasr(1:12),'(f12.4)')freq linasr(13:14)=' ' c c...intensity - use value from the 'total' column, but divide it by the c value from the 'stat.w.' column since these are not understood c and seem to increase with J c if(inptyp.eq.3)then errmes='reading S in CASROT' if(line(73:73).ne.'E')then read(line(68:76),'(f9.4)',err=500)s else read(line(68:76),'(E9.4)',err=500)s endif read(line(77:85),'(f9.4)')statwt s=s/statwt errmes='reading IS,IV,IB in CASROT' if(iequal.eq.1)then if(line(30:30).ne.'i')then 'rigid' line read(line(25:25),'(i1)')is read(line(30:30),'(i1)')iv read(line(35:35),'(i1)')ib else is=0 iv=0 ib=0 endif index=is*iv*ib s=s*smax(index) endif endif c if(inptyp.eq.2)then errmes='reading S in CASROT' read(line(44:52),'(f9.4)',err=500)s linestrength errmes='reading STATW in CASROT' read(line(62:70),'(f9.4)',err=500)statwt s=s/statwt if(iequal.eq.1)then errmes='reading IS in CASROT' read(line(25:25),'(i1)',err=500)is errmes='reading IV in CASROT' read(line(30:30),'(i1)',err=500)iv ib=ibval index=is*iv*ib s=s*smax(index) endif endif c write(linasr(15:24),'(1PE10.2)')s c c...The quantum numbers: asymmetric qn's are in format: i2,i3,i3,i4,i3,i3 (31) C or: i3,i3,i3,i4,i3,i3 (22) C J,K,J,K c if(inptyp.eq.3)then read(line(2:19),'(i2,i3,i3,i4,i3,i3)',err=100)(nq(i),i=1,6) if(line(30:30).ne.'i')then 'rigid' line read(line(25:25),'(i1)')is read(line(30:30),'(i1)')iv read(line(35:35),'(i1)')ib else is=0 iv=0 ib=0 endif endif c if(inptyp.eq.2)then if(line(5:5).eq.'K'.and.line(15:15).eq.'K')then read(line(1:3),'(i3)')nq(1) read(line(11:13),'(i3)')nq(4) read(line(6:9),'(i4)')k nq(2)=k nq(3)=-99 read(line(16:19),'(i4)')k nq(5)=k nq(6)=-99 read(line(25:25),'(i1)')is read(line(30:30),'(i1)')iv else if(line(4:6).eq.'***')line(4:6)='-99' if(line(7:9).eq.'***')line(7:9)='-99' if(line(14:16).eq.'***')line(14:16)='-99' if(line(17:19).eq.'***')line(17:19)='-99' read(line(1:19),'(i3,i3,i3,i4,i3,i3)',err=100)(nq(i),i=1,6) read(line(25:25),'(i1)')is read(line(30:30),'(i1)')iv endif ib=ibval endif c goto 101 100 write(*,'(1x//'' **** ERROR reading quantum numbers:''//1x,a//)') * line stop c 101 write(linasr(25:71),2)(nq(i),i=1,6),0,0,0,is,iv,ib 2 format(2(i5,',',i3,',',i3),' ',i2,',',i2,',',i2, * '--',i2,',',i2,',',i2) c kdelm=nq(2)-nq(5) c kmu-kml kdelp=nq(3)-nq(6) c kpu-kpl im=iabs(mod(kdelm,2)) ip=iabs(mod(kdelp,2)) if(im.eq.0.and.ip.eq.1)cdip=' a' if(im.eq.1.and.ip.eq.1)cdip=' b' if(im.eq.1.and.ip.eq.0)cdip=' c' linasr(51:52)=cdip c write(linasr(72:79),'(f8.2)')0.0 c line=linasr goto 502 c 500 write(*,501)n, * line(1:len_trim(line)),errmes(1:len_trim(errmes)) 501 format(1x//' ***** ERROR reading line,',i5,':'// * 1x,a//7x,'Problem = ',a//) c 502 return end c C_____________________________________________________________________________ C SUBROUTINE SORTH(NSTART,N) c c This routine is based on the SORT2 'heapsort' routine from Numerical c Recipes and sorts the quantities in vector WK from WK(NSTART) to WK(N) C in ascending order of magnitude and also accordingly rearranges vector C IPT of pointers to original positions of sorted quantities. c parameter (maxlin=100000) COMMON /FReq/WK COMMON /point/IPT INTEGER IPT(maxlin) REAL*8 WK(maxlin),WWK C L=N/2+1 IR=N 10 CONTINUE IF(L.GT.NSTART)THEN L=L-1 WWK=WK(L) IIPT=IPT(L) ELSE WWK=WK(IR) IIPT=IPT(IR) WK(IR)=WK(1) IPT(IR)=IPT(1) IR=IR-1 IF(IR.EQ.NSTART)THEN WK(1)=WWK IPT(1)=IIPT RETURN ENDIF ENDIF I=L J=L+L 20 IF(J.LE.IR)THEN IF(J.LT.IR)THEN IF(WK(J).LT.WK(J+1))J=J+1 ENDIF IF(WWK.LT.WK(J))THEN WK(I)=WK(J) IPT(I)=IPT(J) I=J J=J+J ELSE J=IR+1 ENDIF GO TO 20 ENDIF WK(I)=WWK IPT(I)=IIPT GO TO 10 c RETURN END C C_____________________________________________________________________________ C_____________________________________________________________________________