C------------------------------------------------------------------------------- C E R H A S R - Converter of an ERHam output to .ASR output C------------------------------------------------------------------------------- C C This program goes through the output file of Groner's ERHAM program C and converts the final part of the output into a file in the .ASR C standard for use in ASCP and ASCP_L C C Pertinent control data is to be placed in file ERHASR.INP C C C ver. 12.IX.2009 ----- 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 15.09.06: creation c 12.IX.09: optional intensity assignment C_____________________________________________________________________________ C IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) character line*110,filein*30,filout*30,ind*3,cdip*2,linasr*80 c DATA FV,SIGMA,GI,HALFW,ABUND/0.95D0, 1.D0, 1.D0, 20.D0, 1.0D0/ c CLIGHT=29979.2458D0 BOLTZK=0.6950356D0 c c...Deal with the control file c WRITE(*,5500) 5500 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | ERHASR - Converter of an ERHAM output file into an .A', * 'SR file ',T79,'|'/ * ' |',76(1H_),'|'/' version 12.IX.2009',T64,'Zbigniew KISIEL'/) cc open(4,file='erhasr.inp',status='old') read(4,'(40x,a)')filein read(4,'(40x,a)')filout close(4) c open(2,file=filein,status='old') write(*,'(1x,2a)')'Reading from: ',filein(1:len_trim(filein)) open(3,file=filout,status='unknown') write(*,'(1x,2a)')' Writing to: ',filout(1:len_trim(filout)) c c c...Go through the part of ERHAM output prior to the 'BY FREQUENCY' string c and fish out dipole moment components, A,B,C and T c 1 read(2,'(a)',err=4,end=4)line c if(line(1:31).eq.' DIPOLE MOMENT COMPONENTS (DIP)')then read(line(33:50),'(3f6.3)')dipa,dipb,dipc read(2,'(a)')line read(line(27:38),'(F12.2)')TEMP endif if(line(9:20).eq.' A ')then read(line(23:40),*)a endif if(line(9:20).eq.' B ')then read(line(23:40),*)b endif if(line(9:20).eq.' C ')then read(line(23:40),*)c endif c if(line(22:33).ne.'BY FREQUENCY')goto 1 c c write(*,10)' A,B,C /MHz and mu_a,mu_b,mu_c /D:', * A,dipa,B,dipb,C,dipc 10 format(1x/a//f20.6,f10.4/f20.6,f10.4/f20.6,f10.4/) write(*,11)' Temperature =',temp 11 format(1x,a,f12.2/) c 221 write(*,220) 220 format(1x/' Specify intensity assignment:'// * 7x,'0 or ENTER - translate directly'/ * 7x,'1 - calculate from line strength and mu',// * ' ..... ',$) read(*,'(i5)',err=221)intass if(intass.lt.0.or.intass.gt.1)goto 221 c read(2,'(a)')line c c c...Go through the lines c c ERHAM lines: c c v' J' N' Ka' Kc' v" J" N" Ka" Kc" freq ferror spin S_a S_b S_c I_rel E_upper c /MHz /MHz wt /cm-1 c c10 1 31 7 3 28 1 30 7 3 27 151687.195 0.003 8 28.8853 0.0002 0.0000 19.2880 87.721 c10 1 31 8 4 28 1 30 7 3 27 151687.195 0.003 8 0.0003 25.5555 0.0000 0.4149 87.721 c00 1 31 -7 3 28 1 30 -8 4 27 151691.053 0.003 8 0.0060 25.5506 0.0000 0.3692 87.701 c00 1 31 -8 4 28 1 30 -8 4 27 151691.053 0.003 8 28.8684 0.0151 0.0000 19.3391 87.701 c c I_rel = (S * mu(x)^2 * spin weight * Boltzmann factor) c c c ASROT line: c C117444.1572 2.86E-04 16, 1, 15 15, 2, 14 b 1,16,15-- 0,15,14 40.144 c c nlin=0 2 read(2,7,err=4,end=4)ind,ivu,ju,nu,kau,kcu, * ivl,jl,nl,kal,kcl, * freq,ferr,iwt,sa,sb,sc,rint,elow 7 format(a3,i3,4i4,i3,4i4,f12.3,f9.3,i4,3f8.4,f8.4,f10.4) c read(ind(2:2),'(I1)')is1 read(ind(3:3),'(I1)')is2 elow=elow-freq/clight c kdelm=kau-kal c kmu-kml kdelp=kcu-kcl c kpu-kpl im=iabs(mod(kdelm,2)) ip=iabs(mod(kdelp,2)) if(im.eq.0.and.ip.eq.1)then cdip=' a' s=sa dip=dipa if(sb.gt.s)s=sb ! quick fix endif if(im.eq.1.and.ip.eq.1)then cdip=' b' s=sb dip=dipb if(sa.gt.s)s=sa ! quick fix endif if(im.eq.1.and.ip.eq.0)then cdip=' c' s=sc dip=dipc endif c c NOTE: the two lines marked 'fix' are a temporary solution to problems c with aR and bR-type transitions between two nearly degenerate c energy levels. c These problems are more universal than this case c as can be seen from comparison between ERHAM line strengths and c those from a Watsonian calculation: line strength seems to spill c over from the primary dipole moment term to one of the other two c c c Maximum absorption coefficient alpha_max/cm-1 is calculated using c eq.7.73 3rd edition G&C as used in ASROT and using the same assumptions c if(intass.eq.1)then almax=3.85D-14*FV*SIGMA*DSQRT(A*B*C) * *s*dip**2 * *(freq**2/(HALFW*TEMP**2.5))*GI*ABUND almax=almax * *DEXP(-elow/(boltzk*TEMP)) * *(1.d0-0.5D0*freq/(clight*boltzk*TEMP)) else almax=rint endif c write(linasr(1:12),'(f12.4)')freq linasr(13:14)=' ' write(linasr(15:24),'(1PE10.2)')almax write(linasr(25:71),6)ju,kau,kcu,jl,kal,kcl, * is1,is2,ivu,is1,is2,ivl linasr(51:52)=cdip write(linasr(72:79),'(f8.3)')elow c 6 format(2(i5,',',i3,',',i3),' ',i2,',',i2,',',i2, * '--',i2,',',i2,',',i2) c nlin=nlin+1 if(nlin.eq.1)then write(3,210)filein(1:len_trim(filein)) 210 format(93('-')/' Converted from the ERHAM output file: ',a/ * 93('-')/' ') write(3,211) 211 format(1x,' ' * /' FREQUENCY abs.coeff. upper <- lower', * ' G upper <- lower E.low Linestr.'/ * ' /MHz /cm-1 quanta quanta', * ' quanta quanta /cm-1 * muG**2'/) C endif sdsq=s*dip**2 write(3,'(A79,F13.5)')linasr(1:79),sdsq c goto 2 c c 4 write(3,212) 212 format(93('-')/93('-')) close(2) close(3) write(*,'(1x/i7,a//)')nlin,' lines have been converted' c stop end C_____________________________________________________________________________ C_____________________________________________________________________________