CFTN7X,Q,T,S C$FILES(0,2,24) C$CDS ON C INCLUDE 'CALPGM.INC' PROGRAM CALMRG C C Copyright (C) 1989, California Institute of Technology C All rights reserved. U. S. Government Sponsorship under C NASA Contract NAS7-918 is acknowledged. C C Herbert M. Pickett, 20 Mar 1989 C HMP: add .bad file output C C get command line file names (.cat = calc input, .lin = exp input, C .mrg = output) C open .cat and read first line for NQN C rewind .cat C DO UNTIL end of file on .lin C read in line from .lin C IF not term value or infrared line THEN C find position in list C insert pointer in list C ENDIF C END DO C close .lin C DO for each line descending from last C SET hash element [J] = line C END DO C SET hash element[max J +1] = number of lines +1 C DO for each J descending from max J C IF hash element is zero set to next larger element C END DO C open .mrg C DO UNTIL end of file on .cat C read in line from .cat C find position in list C IF match THEN C insert FRQX,ERRX, and negate TAG C ENDIF C output line to .mrg C END DO C************************************************************************ INTEGER NDX,NDX1,NHASH,NOUT,IQFMT,NQN,NQN2,NLINE,NL,NFILES EXTERNAL BRKQR INTEGER*2 CLEN5 PARAMETER (NDX=4000,NDX1=NDX+2,NFILES=5,CLEN5=5,NHASH=99) CHARACTER CFIL(NFILES)*64, LINE*80, TMPSTR*80, CEXT(NFILES)*4, : TAGSTR*7,FQSTR*21,QNSTR*24,LINEN*80 REAL*8 FRQX(NDX),FRQC,FRQDIF,XERR,XWT,CLIGHT REAL*4 ERRX(NDX),ERRC,BIG,ST INTEGER JHASH(0:NHASH+1),JMAX,I,IPOS,LPOSN,NBAD,LUBAD,GETLIN,NLP, : LUCAT,LULIN,LUMRG,LULOG,RQEXIT,ICMP,J,JJ,IBPOS,N,DEFLIN, : K2,NMERGE,NMATCH,KMATCH,KCMP INTEGER IQN(12,NDX1),IPTR(NDX),IDQN(12) INTEGER*4 TAG LOGICAL MATCH,NOEOF,MRGLIN C EMA FRQX,ERRX,IQN COMMON FRQX,ERRX,IQN SAVE DATA CEXT/'cat ','lin ','mrg ','bad ','log '/ DATA JHASH/101*0/ C C >>>>>> BEGIN PROGRAM C C following statement is for PRIME computer to enable ^P hot key C CALL MKON$P('QUIT$',CLEN5,BRKQR) CLIGHT=29979.2458D0 BIG=9999.9999D0 NMERGE=0 NMATCH=0 NOUT=0 LUCAT=1 LULIN=2 LUMRG=3 LUBAD=4 LULOG=5 CALL FILGET(CFIL,CEXT,NFILES) CALL OPENLU(LUCAT,CFIL(1),'R') READ(LUCAT,220,END=50) LINEN READ(LINEN,'(44X,I7,I4)',ERR=90) TAG,IQFMT TAG=-TAG WRITE(TAGSTR,'(I7)') TAG NQN=DEFLIN(IQFMT,IDQN) IF(NQN.GT.6) NQN=6 NQN2=NQN+NQN K2=NQN+2 CALL OPENLU(LULIN,CFIL(2),'R') C read and sort exp. lines KMATCH=0 NLINE=0 NL=1 JMAX=0 C while .. 10 IF(NL.LT.NDX) THEN IF(GETLIN(LULIN,IDQN,IQN(1,NL),FRQX(NL),XERR,XWT) & .NE.0) GO TO 20 IF(XERR.LT.0.) THEN FRQX(NL)=FRQX(NL)*CLIGHT XERR=-XERR*CLIGHT ENDIF ERRX(NL)=XERR MATCH=(IQN(NQN+1,NL).GE.0) IF(MATCH) MATCH=(ERRX(NL).LE.999.999) IF(MATCH) THEN IF(FRQX(NL).LT.0.) THEN C swap quanta so frequency is positive DO 13 I=1,NQN J=IQN(I,NL) IQN(I,NL)=IQN(I+NQN,NL) 13 IQN(I+NQN,NL)=J FRQX(NL)=-FRQX(NL) ENDIF IPOS=LPOSN(NL,NLINE,NQN2,IPTR,IQN,ICMP,KMATCH) IF(ICMP.NE.0) THEN DO 15 I=NLINE,IPOS,-1 15 IPTR(I+1)=IPTR(I) IPTR(IPOS)=NL NLINE=NL NL=NL+1 ENDIF ENDIF GO TO 10 ENDIF 20 IF(NLINE.GT.0) JMAX=IQN(1,IPTR(NLINE)) JJ=MIN(JMAX,NHASH) JHASH(JJ+1)=NL DO 22 NL=NLINE,1,-1 J=MIN(IQN(1,IPTR(NL)),99) 22 JHASH(J)=NL DO 24 J=JJ,0,-1 IF(JHASH(J).EQ.0) JHASH(J)=JHASH(J+1) 24 CONTINUE CALL OPENLU(LULOG,CFIL(5),'W') WRITE(*,*) NLINE,' experimental lines read' J=-1 I=RQEXIT(J) NL=NLINE+1 NLP=NL+1 IPTR(NL)=NL QNSTR=LINEN(56:55+NQN2)//LINEN(68:79) CALL READQN(QNSTR,IQN(1,NLP),NQN2) CALL OPENLU(LUMRG,CFIL(3),'W') NOEOF=.TRUE. MATCH=.FALSE. 30 IF(NOEOF) THEN LINE=LINEN DO 31 I=1,NQN2 31 IQN(I,NL)=IQN(I,NLP) NOEOF=.FALSE. READ(LUCAT,220,END=55) LINEN IF(RQEXIT(0).NE.0) GO TO 55 QNSTR=LINEN(56:55+NQN2)//LINEN(68:79) CALL READQN(QNSTR,IQN(1,NLP),NQN2) NOEOF=.TRUE. C set NOEOF = false for end of file 55 KMATCH=0 IF(MATCH) KMATCH=K2 MATCH=NOEOF C ...test for equality of frequency and quanta except K IF(MATCH) MATCH=( LINE( 1:13).EQ.LINEN( 1:13) ) IF(MATCH) THEN N=1 IPOS=LPOSN(NLP,N,NQN2,IPTR(NL),IQN,ICMP,K2) MATCH= (ICMP.EQ.0) ENDIF IF(MATCH) MATCH=MRGLIN(LINE,LINEN) IF(MATCH) THEN C K's are equivalent IF(IQN(2,NLP).LT.0) THEN LINEN(58:58)=LINE(58:58) IQN(2,NLP)=-IQN(2,NLP) ENDIF IF(IQN(K2,NLP).LT.0) THEN LINEN(70:70)=LINE(70:70) IQN(K2,NLP)=-IQN(K2,NLP) ENDIF NMERGE=NMERGE+1 ELSE J=IQN(1,NL) ICMP=1 IF(J.LE.JMAX) THEN JJ=MIN(J,NHASH) IBPOS=JHASH(JJ) N=JHASH(JJ+1)-IBPOS IPOS=LPOSN(NL,N,NQN2,IPTR(IBPOS),IQN,ICMP,KMATCH) ENDIF KCMP=ICMP 35 IF(ICMP.EQ.0) THEN I=IPTR(IPOS+IBPOS-1) IF(KCMP.EQ.0) THEN READ(LINE,'(F13.4,F8.4)',ERR=30) FRQC,ERRC KCMP=1 ENDIF IF(ERRX(I).GE.0) THEN WRITE(FQSTR,'(F13.4,F8.4)') FRQX(I),ERRX(I) ELSE WRITE(FQSTR,'(F13.6,F8.5)') FRQX(I),ERRX(I) ENDIF TMPSTR=FQSTR//LINE(22:44)//TAGSTR//LINE(52:80) FRQDIF=FRQX(I)-FRQC FRQDIF=MIN(FRQDIF,BIG) FRQDIF=MAX(FRQDIF,-BIG) WRITE(LULOG,'(1X,A,F14.4,3F10.4)') LINE(56:),FRQX(I), : FRQDIF,ERRX(I),ERRC IF(ABS(FRQDIF).LT.100.*ABS(ERRX(I))) THEN LINE=TMPSTR NMATCH=NMATCH+1 FRQX(I)=-FRQX(I) ELSE WRITE(LULOG,*) ' Above Experiment not used' ENDIF ICMP=1 N=N-IPOS IF(KMATCH.GT.0.AND.N.GT.0) THEN IBPOS=IBPOS+IPOS IPOS=LPOSN(NL,N,NQN2,IPTR(IBPOS),IQN,ICMP,KMATCH) ENDIF GO TO 35 ENDIF IF(LINE(14:21).NE.'999.9999') THEN NOUT=NOUT+1 WRITE(LUMRG,220) LINE ENDIF ENDIF GO TO 30 ENDIF 50 WRITE(*,*) NOUT,' lines written ', & NMATCH,' experimental lines ' WRITE(LULOG,*) NOUT,' lines written ', & NMATCH,' experimental lines ' IF(NMERGE.GT.0) THEN WRITE(*,*) NMERGE,' lines merged' WRITE(LULOG,*) NMERGE,' lines merged' ENDIF CALL OPENLU(LUCAT,CFIL(1),'C') IF(NMATCH.EQ.NLINE) STOP C find bad lines NBAD=0 DO 51 J=1,NLINE IF(FRQX(J).GT.0) THEN I=NBAD 56 IF(I.GT.0) THEN JJ=IPTR(I) IF(FRQX(JJ).LT.FRQX(J)) GO TO 57 IPTR(I+1)=JJ I=I-1 GO TO 56 ENDIF 57 IPTR(I+1)=J NBAD=NBAD+1 WRITE(*,200) (IQN(I,J),I=1,12),FRQX(J),ERRX(J) WRITE(LULOG,200) (IQN(I,J),I=1,12),FRQX(J),ERRX(J) ENDIF 51 CONTINUE WRITE(*,*) NBAD,' lines to be matched by frequency ' BIG=0. WRITE(*,*) ' enter MAX (obs-calc)/(exp. error) or 0 to stop' READ(*,*) BIG IF(BIG.LT.0.001) STOP NMATCH=0 CALL OPENLU(LUBAD,CFIL(4),'W') REWIND(LUMRG) 60 READ(LUMRG,220,END=90) LINE C check for already assigned IF(LINE(45:51).EQ.TAGSTR) GO TO 60 READ(LINE,'(F13.4,2F8.4)',ERR=60) FRQC,ERRC,ST DO 61 J=1,NBAD IPOS=IPTR(J) FRQDIF=ABS(FRQX(IPOS)-FRQC) IF(FRQDIF.LT.ERRX(IPOS)*BIG) THEN QNSTR=LINE(56:55+NQN2)//LINE(68:79) CALL READQN(QNSTR,IDQN,NQN2) ST=10.**ST WRITE(LUBAD,200) (IDQN(I),I=1,12), : FRQX(IPOS),ERRX(IPOS),ST NMATCH=NMATCH+1 ENDIF 61 CONTINUE GO TO 60 90 WRITE(*,*) NMATCH,' lines found' STOP C 200 FORMAT(12I3,F15.4,F10.4,E10.3) 220 FORMAT(A) END INTEGER FUNCTION LPOSN(KEY,N,NT,IPTR,IQN,ICMP,NFLG) INTEGER KEY,N,NT,ICMP,NFLG INTEGER IQN(12,*),IPTR(*) C EMA IQN INTEGER LEFT,RIGHT,LL,I,IKEY(12),IPHASE IF(N.LE.0) THEN ICMP=1 LPOSN=1 RETURN ENDIF IF(NFLG.LE.0) THEN IPHASE=0 LL=0 ELSE IPHASE=3 LL=2 ENDIF DO 5 I=1,NT ICMP=IQN(I,KEY) IF(I.EQ.LL.OR.I.EQ.NFLG) ICMP=-ABS(ICMP) 5 IKEY(I)=ICMP LEFT=1 RIGHT=N+1 10 IF(LEFT.LT.RIGHT) THEN LPOSN=(LEFT+RIGHT)/2 LL=IPTR(LPOSN) DO 20 I=1,NT ICMP=IKEY(I)-IQN(I,LL) IF(ICMP.GT.0) THEN LPOSN=LPOSN+1 LEFT=LPOSN GO TO 10 ELSE IF(ICMP.LT.0) THEN RIGHT=LPOSN GO TO 10 ENDIF 20 CONTINUE C equality of value and key RETURN ENDIF IF(IPHASE.EQ.0) RETURN IKEY(NFLG)=-IKEY(NFLG) IF(IPHASE.EQ.2) IKEY(2)=-IKEY(2) IPHASE=IPHASE-1 LEFT=LPOSN RIGHT=N+1 GO TO 10 END LOGICAL FUNCTION MRGLIN(LINE2,LINE) CHARACTER*80 LINE2,LINE CHARACTER*44 TMPSTR REAL*8 STR1,STR2,DIF INTEGER IG1,IG2 MRGLIN=.TRUE. READ(LINE,100,ERR=50) STR1,IG1 IF(LINE(22:29).EQ.LINE2(22:29)) THEN STR1=STR1+0.30103 IG1=IG1+IG1 ELSE READ(LINE2,100,ERR=50) STR2,IG2 IF(STR2.LT.STR1) THEN DIF=STR2-STR1 ELSE DIF=STR1-STR2 STR1=STR2 ENDIF IF(DIF.GT.-5.) STR1=STR1+LOG10(1.+10.**DIF) IG1=IG1+IG2 ENDIF WRITE(TMPSTR,100) STR1,IG1 LINE(22:29)=TMPSTR(22:29) LINE(42:44)=TMPSTR(42:44) RETURN 50 MRGLIN=.FALSE. 100 FORMAT(21X,F8.4,12X,I3) END SUBROUTINE READQN(QNSTR,IQN,N) CHARACTER*(*) QNSTR INTEGER IQN(*),N,I,II,K CHARACTER*1 CH II=0 DO 1 I=1,N II=II+1 CH=QNSTR(II:II) II=II+1 K=ICHAR(QNSTR(II:II))-ICHAR('0') IF(K.LT.0.OR.K.GT.9) K=0 IF(CH.NE.' ') THEN IF(CH.EQ.'-') THEN K=-K ELSE IF(CH.GE.'0'.AND.CH.LE.'9') THEN K= K+10*(ICHAR(CH)-ICHAR('0')) ELSE IF(CH.GE.'a'.AND.CH.LE.'z') THEN K=-K-10*(ICHAR(CH)-ICHAR('a')+1) ELSE IF(CH.GE.'A'.AND.CH.LE.'Z') THEN K= K+10*(ICHAR(CH)-ICHAR('A')+10) ELSE K=999 ENDIF ENDIF IQN(I)=K 1 CONTINUE RETURN END