perm filename AMINE.REC[NET,GUE] blob
sn#021104 filedate 1973-01-24 generic text, type T, neo UTF8
COMMON/LGASP/LOOSE,LOOS2
DIMENSION IDIFF(500),IOK(500),KOK(500),JOK(500)
DIMENSION ISTRT(25)
DIMENSION TITL(15)
DIMENSION NUM(500),KVEC(2500),IADR(500)
DIMENSION SPECT(100)
DATA ONAME/5HAMEND/,TMS/4HTMS /
COMMON/KLUDG/NDF,NDIFF
COMMON/ACDNT/NAD,ADDEL,CMSPC(100),NCOM
COMMON/PASS/QDUM(126)
COMMON/LIL/IDOOM,JDOOM
COMMON/RMSVAL/NSF,MORE,RUMS2,XDEL,XAM,RMS
COMMON/STUFF/XSP(100),NXP,XRM,LIM,MR,STD,IEYE,
1ICNT2,ICNT3,JJPT,KKPT
WRITE(5,1995)
1995 FORMAT('0CARHART''S AMINE IDENTIFIER'/)
CALL TIME(ITIME)
12345 READ(1,1999,END=777)TITL,RMS,ADDEL,LIMAT,NAD,NDIFF,STD
IF(NDIFF.EQ.0)NDIFF=LIMAT
READ(1,1998)NSPECT,(SPECT(I),I=1,NSPECT)
WRITE(5,1997)TITL,RMS,ADDEL,LIMAT,NAD,NDIFF,STD
1,(SPECT(I),I=1,NSPECT)
NSF=0
NAM=0
IF(STD.NE.TMS)GO TO 12347
DO 12346 I=1,NSPECT
SPECT(I)=192.8-SPECT(I)
12346 CONTINUE
12347 CALL SORT(SPECT,NSPECT)
1999 FORMAT(15A4/2F5.1,3I5,A4)
1998 FORMAT(I5,15F5.0/(16F5.0))
1997 FORMAT('0CASE TITLE:',15A4/' RMS,ADDEL,LIMAT,NAD,NDIFF:',
12F7.2,3I5/' STANDARD IS ',A4/' INPUT SHIFTS:',8F7.2/(14X,8F7.2))
MORE=LIMAT-NSPECT
NCOM=0
SPECT(NSPECT+1)=-1.E20
DO 45 I=1,NSPECT
IF(SPECT(I).EQ.SPECT(I+1))GO TO 45
NCOM=NCOM+1
CMSPC(NCOM)=SPECT(I)
45 XSP(I)=SPECT(I)
NXP=NSPECT
XRM=RMS
LIM=LIMAT
MR=MORE
IEYE=1
ICNT2=0
ICNT3=0
JJPT=0
KKPT=0
IADR(1)=0
NDF=1
CALL AMINE(1,2,0,0,SPECT,IADR,IADR,NAM,NSF)
CALL AMINE(1,3,0,0,SPECT,IADR,IADR,NAM,NSF)
IEOC=2600
KVEC(1)=IEOC
NPOOL=0
NPL=1
IDIFF(1)=1
IOK(1)=15
JOK(1)=15
KOK(1)=15
IADR(1)=1
NUM(1)=1
KK=1
ISTRT(1)=1
LMP=LIMAT+1
LOOSE=0
LOOS2=0
DO 401 LIMIT=2,LMP
IGOON=0
C IF(LIMIT.GT.(LIMAT/2))LOOS2=1
C IF(LIMIT.GT.((2*LIMAT)/3))LOOSE=1
ISTRT(LIMIT)=NPL+1
WRITE(5,1994)NPL,NAM,NSF
IF(LIMIT.EQ.LMP)GO TO 401
1994 FORMAT(' POOLNUM=',I4,' NAM=',I4,' NSF=',I4/)
IF(IGOON.EQ.0)READ(5,1993)IGOON
1993 FORMAT(I1)
IF(IGOON.EQ.1)GO TO 500
NPOOL=NPL
INIT=ISTRT((LIMIT+1)/3)
IF(INIT.GT.NPOOL)GO TO 500
DO 400 I=INIT,NPOOL
LIMOT=LIMIT-NUM(I)-1
IDF=1+IDIFF(I)
IF(LIMOT)401,48,50
48 IF(IOK(I).EQ.0)GO TO 400
IF((IOK(I).EQ.2).AND.(LIMIT.NE.LIMAT))GO TO 400
LL=KK+2
KVEC(LL-1)=IEOC
KVEC(LL)=IADR(I)
NPLP=NPL+1
NDF=IDF
IF(IDF.GT.NDIFF)GO TO 400
IH=IOK(I)
CALL CMRTST(SPECT,NSPECT,KVEC,LL,NAM,IH,IOK(NPLP),JOK(NPLP)
1,KOK(NPLP))
IF(IH.EQ.0)GO TO 400
KK=LL
NPL=NPL+1
IADR(NPL)=LL
NUM(NPL)=LIMIT
IDIFF(NPL)=IDF
LL=KK+2
KVEC(LL-1)=IEOC
KVEC(LL)=IADR(I)
GO TO 400
50 IF((JOK(I)+KOK(I)).EQ.0)GO TO 400
JMIN=ISTRT((LIMOT+1)/2)
IF(JMIN.GT.I)GO TO 400
DO 399 J=JMIN,I
LIMUT=LIMOT-NUM(J)
IF(LIMUT)400,52,52
52 JDF=IDF
IF(J.NE.I)JDF=IDF+IDIFF(J)
NDF=JDF
IF(JDF.GT.NDIFF)GO TO 399
LL=KK+3
KVEC(LL-2)=IEOC
KVEC(LL-1)=IADR(I)
KVEC(LL)=IADR(J)
IF(LIMUT.GT.0)GO TO 53
IF(JOK(I).EQ.0)GO TO 399
IF(JOK(J).EQ.0)GO TO 399
IH=JOK(I)
CALL AND(IH,JOK(J))
IF(IH.EQ.0)GO TO 399
IF((IH.EQ.2).AND.(LIMIT.NE.LIMAT))GO TO 399
NPLP=NPL+1
CALL CMRTST(SPECT,NSPECT,KVEC,LL,NAM,IH,IOK(NPLP),JOK(NPLP)
1,KOK(NPLP))
IF(IH.NE.0)GO TO 51
GO TO 399
53 IF(KOK(I).EQ.0)GO TO 399
IF(KOK(J).EQ.0)GO TO 399
IH2=KOK(I)
CALL AND(IH2,KOK(J))
IF(IH2.EQ.0)GO TO 399
IH=IH2
MIN1=-1
LL=LL+1
KVEC(LL)=IADR(1)
CALL CMRTST(SPECT,NSPECT,KVEC,LL,MIN1,IH,IT,IT,IT)
IF(IH.EQ.0)GO TO 399
GO TO 100
51 KK=LL
NPL=NPL+1
IADR(NPL)=LL
NUM(NPL)=LIMIT
IDIFF(NPL)=JDF
KVEC(KK+1)=IEOC
KVEC(KK+2)=IADR(I)
KVEC(KK+3)=IADR(J)
LL=KK+3
GO TO 399
100 KMIN=ISTRT(LIMUT)
IF(KMIN.GT.J)GO TO 399
DO 398 K=KMIN,J
IF(NUM(K).GT.LIMUT)GO TO 399
IF(KOK(K).EQ.0)GO TO 398
IH=IH2
CALL AND(IH,KOK(K))
IF(IH.EQ.0)GO TO 398
IF((IH.EQ.2).AND.(LIMIT.NE.LIMAT))GO TO 398
LL=KK+4
KVEC(LL-3)=IEOC
KVEC(LL-2)=IADR(I)
KVEC(LL-1)=IADR(J)
KVEC(LL)=IADR(K)
NPLP=NPL+1
KDF=JDF
IF(K.NE.J)KDF=JDF+IDIFF(K)
NDF=KDF
IF(KDF.GT.NDIFF)GO TO 398
CALL CMRTST(SPECT,NSPECT,KVEC,LL,NAM,IH,IOK(NPLP),JOK(NPLP)
1,KOK(NPLP))
IF(IH.EQ.0)GO TO 398
KK=LL
NPL=NPL+1
IADR(NPL)=LL
NUM(NPL)=LIMIT
IDIFF(NPL)=KDF
KVEC(KK+1)=IEOC
KVEC(KK+2)=IADR(I)
KVEC(KK+3)=IADR(J)
KVEC(KK+4)=IADR(K)
LL=KK+4
398 CONTINUE
399 CONTINUE
400 CONTINUE
401 CONTINUE
500 CALL TIME(ITIME)
TTIME=FLOAT(ITIME)/1000.
WRITE(5,5678)TTIME
5678 FORMAT('0CASE FINISHED. PROCESSING CPU TIME (IN SEC.) WAS'/
1F9.3//)
GO TO 12345
777 STOP
END
SUBROUTINE AMCOR(COR,IA,IB,NBR,N)
DIMENSION IA(1),COR(1),NBR(4,1),IB(1)
DIMENSION IM(3),IP(3),IS(3),IT(3)
DIMENSION TST(12),GAMCR(3)
DATA TST/1.65,3.80,2.0,-1.7,2.15,4.5,-2.45,-1.55
1,-1.6,-4.1,4.5,-2.95/,OFFST/-0.35/,CROWD/1.7/
2,TBUN3/1.75/,GAMCR/-1.8,-.9,-2.0/
DO 1 I=1,N
1 COR(I)=0.
IMP=0
IPP=0
ISP=0
ITP=0
ITYP=IA(1)
GMCR=GAMCR(ITYP)
DO 6 I=1,ITYP
IAD=NBR(I,1)
ID=IA(IAD)
GO TO (2,3,4,5),ID
2 IMP=IMP+1
IM(IMP)=IAD
GO TO 6
3 IPP=IPP+1
IP(IPP)=IAD
GO TO 6
4 ISP=ISP+1
IS(ISP)=IAD
40 ID1=NBR(1,IAD)
ID2=NBR(2,IAD)
N1=IA(ID1)-1
N2=IA(ID2)-1
IF(N1.EQ.0)GO TO 42
DO 41 J=1,N1
41 COR(NBR(J,ID1))=GMCR
42 IF(N2.EQ.0)GO TO 44
DO 43 J=1,N2
43 COR(NBR(J,ID2))=GMCR
44 IF(ID.EQ.3)GO TO 6
IF((N1+N2+N3).NE.0)GO TO 6
IF(ITYP.EQ.3)GO TO 6
COR(ID1)=TBUN3
COR(ID2)=TBUN3
COR(ID3)=TBUN3
GO TO 6
5 ITP=ITP+1
IT(ITP)=IAD
ID3=NBR(3,IAD)
N3=IA(ID3)-1
IF(N3.EQ.0)GO TO 40
DO 50 J=1,N3
50 COR(NBR(J,ID3))=GMCR
GO TO 40
6 CONTINUE
IF(ITYP.EQ.1)GO TO 5000
GO TO (5000,7,1000),ITYP
7 IF(ISP.NE.2)GO TO 100
COR(IS(1))=TST(1)
COR(IS(2))=TST(1)
GO TO 5000
100 IF(ITP.NE.1)GO TO 5000
IF(IMP.EQ.1)COR(IM(1))=TST(2)
IF(IPP.EQ.1)COR(IP(1))=TST(2)
IF(ISP.EQ.1)COR(IS(1))=TST(2)
GO TO 5000
1000 IF((ISP.NE.1).OR.(ITP.NE.0))GO TO 2000
IF(IMP-1)1003,1002,1001
1001 COR(IM(1))=TST(3)+TST(7)
COR(IM(2))=TST(3)+TST(7)
GO TO 1500
1002 COR(IM(1))=TST(3)
COR(IP(1))=TST(3)+TST(8)
COR(IS(1))=TST(8)
COR(NBR(1,IP(1)))=TST(4)
GO TO 1500
1003 COR(IP(1))=TST(3)
COR(IP(2))=TST(3)
COR(NBR(1,IP(1)))=TST(4)
COR(NBR(1,IP(2)))=TST(4)
1500 IAD=IS(1)
ID1=NBR(1,IAD)
ID2=NBR(2,IAD)
N1=IA(ID1)
N2=IA(ID2)
IF(((N1.EQ.1).AND.(N2.EQ.1)).OR.((N1.NE.1).
1AND.(N2.NE.1)))GO TO 1501
IF(N1.EQ.1)COR(ID1)=TST(6)
IF(N2.EQ.1)COR(ID2)=TST(6)
GO TO 5000
1501 COR(ID1)=TST(5)
COR(ID2)=TST(5)
GO TO 5000
2000 IF(IMP-1)2003,2002,2001
2001 COR(IM(1))=TST(7)
COR(IM(2))=TST(7)
IF(IMP.EQ.3)COR(IM(3))=TST(7)
GO TO 5000
2002 IF(IPP.GT.1)COR(IP(2))=TST(8)
IF(IPP.GE.1)COR(IP(1))=TST(8)
IF(ISP.GT.1)COR(IS(2))=TST(8)
IF(ISP.GE.1)COR(IS(1))=TST(8)
IF(ITP.GT.1)COR(IT(2))=TST(8)
IF(ITP.GE.1)COR(IT(1))=TST(8)
GO TO 5000
2003 IF((IPP.NE.2).OR.(ITP.NE.1))GO TO 2004
ID1=IP(1)
ID2=IP(2)
COR(ID1)=TST(9)
COR(ID2)=TST(9)
COR(NBR(1,ID1))=TST(10)
COR(NBR(1,ID2))=TST(10)
GO TO 5000
2004 IF((IPP.NE.1).OR.(ISP.NE.2))GO TO 5000
ID1=IP(1)
COR(ID1)=TST(11)
COR(NBR(1,ID1))=TST(12)
5000 DO 5001 I=1,N
IF(IA(I).NE.2)GO TO 5001
IF(IB(I).NE.6)GO TO 5001
COR(I)=COR(I)+CROWD
5001 COR(I)=COR(I)+OFFST
RETURN
END
SUBROUTINE AMINE(N1,ITEST,IDUP,JJ,S,IA,IIA,NAM,NSF)
DIMENSION S2(100),S3(100),TITL(10)
DIMENSION S(100),IA(200),IIA(101),L2S(250),
1 L3S(250),LST(250),NM(500),
2 ID(500),JI(500),ISS(500),ISN(500),IDF(500),
3 SFLST(3000),NLST(3000)
COMMON/KLUDG/NDF,NDIFF
COMMON/STUFF/SPECT(100),NSPECT,RMS,LIMAT,MORE,STD,
1I,ICNT2,ICNT3,JPT,KPT
IIASV=IIA(1)
ISAVE=I
GO TO (53,60,65),ITEST
53 IIA(1)=1
CALL TEST(IIA,N1,S,JJ)
GO TO 50
60 IF(N1.GT.(LIMAT/2))GO TO 40
ICNT2=ICNT2+1
L2S(ICNT2)=I
GO TO 67
65 IF(N1.GT.((LIMAT-1)/2))GO TO 45
ICNT3=ICNT3+1
L3S(ICNT3)=I
67 NM(I)=N1
IDF(I)=NDF
ID(I)=IDUP
JI(I)=JJ
ISS(I)=JPT
IF(JJ.EQ.0)GO TO 69
DO 68 J=1,JJ
JPT=JPT+1
68 SFLST(JPT)=S(J)
69 ISN(I)=KPT
DO 70 J=1,N1
KPT=KPT+1
70 NLST(KPT)=IA(J)
I=I+1
NAM=NAM+1
NSF=NSF+JJ
IF(N1.LT.((LIMAT+1)/ITEST))GO TO 50
IF(ITEST.EQ.3)GO TO 45
40 JM=ICNT2
DO 41 J=1,ICNT2
LST(J)=L2S(J)
41 CONTINUE
GO TO 49
45 JM=ICNT3
DO 46 J=1,ICNT3
LST(J)=L3S(J)
46 CONTINUE
49 K1=JJ+1
N1P=N1+1
DO 300 JJJ=1,JM
J=LST(JJJ)
N2=NM(J)+N1
IF(LIMAT-N2)50,700,701
700 IF(ITEST.EQ.3)GO TO 50
GO TO 702
701 IF(ITEST.EQ.2)GO TO 300
IF((N2+NM(J)).LT.LIMAT)GO TO 300
702 JDUP=IDUP+ID(J)
IF(JDUP.GT.MORE)GO TO 300
MDF=NDF
IF((ISAVE.EQ.I).OR.(JJJ.NE.JM))MDF=NDF+IDF(J)
IF(MDF.GT.NDIFF)GO TO 300
KK=JI(J)
K2=JJ+KK
IF(KK.EQ.0)GO TO 72
IPT=ISS(J)
DO 71 K=K1,K2
IPT=IPT+1
71 S(K)=SFLST(IPT)
72 CALL MERGE(S,JJ,K2,S2)
IPT=ISN(J)
DO 73 K=N1P,N2
IPT=IPT+1
73 IA(K)=NLST(IPT)
IF(MATCH(SPECT,NSPECT,S2,K2,RMS,MORE).NE.1)GO TO 300
IF(ITEST.EQ.3)GO TO 80
IIA(1)=2
CALL TEST(IIA,N2,S2,K2)
GO TO 300
80 N2P=N2+1
L1=K2+1
DO 200 KKK=1,JJJ
K=LST(KKK)
N3=NM(K)+N2
IF(LIMAT-N3)300,201,200
201 IF((JDUP+ID(K)).GT.MORE)GO TO 200
IF(K.EQ.J)GO TO 202
IF((MDF+IDF(K)).GT.NDIFF)GO TO 200
202 LL=JI(K)
L2=K2+LL
IF(LL.EQ.0)GO TO 82
IPT=ISS(K)
DO 81 L=L1,L2
IPT=IPT+1
81 S2(L)=SFLST(IPT)
82 CALL MERGE(S2,K2,L2,S3)
IPT=ISN(K)
DO 83 L=N2P,N3
IPT=IPT+1
83 IA(L)=NLST(IPT)
IF(MATCH(SPECT,NSPECT,S3,L2,RMS,MORE).NE.1)GO TO 200
IIA(1)=3
CALL TEST(IIA,N3,S3,L2)
200 CONTINUE
300 CONTINUE
50 IIA(1)=IIASV
RETURN
END
SUBROUTINE CMRTST(SPECT,NSPECT,KVEC,KADR,NAM,IH,I1,I2,I3)
DIMENSION COR(25),IREM(3)
DIMENSION SPECT(1),KVEC(1),A(4,4),B(4),GAM(4),DEL(4)
1,KKSV(25),ISV(25)
DIMENSION IBT(25),IC(25),ID(25),NBR(4,25),IF(25),IIF(24)
EQUIVALENCE (IF(2),IIF(1))
DIMENSION ACOR(3),BCOR(3),XCOR(3)
DATA R1/.49/,R2/1.02/,XXG/-1.45/,AG/.9585/,BG/8.0012/
DATA CROWD/1.7/,OFFST/-.35/
DATA ACOR/.951,.950,.966/
DATA BCOR/10.5272,10.5800,8.1552/
DATA XCOR/-1.8,-.9,-2.0/
DATA GAM/2.99,2.69,2.07,-0.68/
DATA DEL/-0.49,-0.25,0.0,0.0/
DATA B/186.0,177.5,169.3,165.0/
DATA A/0.0,0.0,0.0,0.0,-9.56,-9.75,-6.60,-2.26,
1-17.83,-16.70,-11.14,-3.96,-25.48,-21.43,-14.70,-7.35/
COMMON/RMSVAL/NSF,MORE,RUMS2,XXDEL,XXAM,RMS
COMMON/LIL/IDUP,JJ
COMMON/PASS/SHIFT(25),LEV(25),IDEG(25),SHF(25),R(25),ITEMP
COMMON/LGASP/LOOSE,LOOS2
DATA IFULL/1/
KVEC(2500)=KADR
KVEC(2499)=2600
KTEMP=2500
IFF=0
IPT=0
JPT=1
GO TO 11
10 IF(JPT)=IFF
IFF=0
IF(IPT.EQ.0)GO TO 20
KTEMP=ISV(IPT)
IPT=IPT-1
JPT=JPT+1
11 KV=KVEC(KTEMP)
IF(KV.GT.2500)GO TO 10
IFF=IFF+1
IPT=IPT+1
ISV(IPT)=KV
KTEMP=KTEMP-1
GO TO 11
20 IF(JPT+1)=-1
CALL LOCAL(IF,IDEG,IBT,IC,ID,LEV,NBR,IDUM)
DO 21 I=1,IDUM
COR(I)=OFFST
IF(IDEG(I).NE.2)GO TO 21
IF(IBT(I).NE.6)GO TO 21
COR(I)=OFFST+CROWD
21 CONTINUE
CALL SHFT(SHIFT,I,IDEG,NBR,IC,ID,IDUM,LEV,0,100,COR)
ITEMP=I
M=MORE+NSPECT-I+1
JTEST=IH/2
ITEST=IH-2*JTEST
IH=0
IREM(1)=0
IREM(2)=0
IREM(3)=0
IXX=3
IF(NAM.LT.0)IXX=6
MIN=2
IF(M.EQ.0)GO TO 199
JTEST=JTEST/2
IF(ITEST.EQ.0)GO TO 200
FAC=FLOAT(MIN0(IXX,M)-1)/2.
IF(ICTST(GAM,DEL,RMS,3,0,FAC,0.,0,0.,0.,0.,0.).NE.1)
1GO TO 200
IF(NAM.LT.0)GO TO 300
RG=R1
XG=0.
DO 110 II=1,3
IP=0
FAC2=FLOAT(II)
IF(M-II)109,102,101
101 FAC=FLOAT(MIN0(3*II,M-II)-1)/2.
IF(ICTST(GAM,DEL,RMS,2,0,FAC,FAC2,3,0.,0.,0.,0.).EQ.1)
1GO TO 103
102 IF((IP.EQ.1).AND.(LOOSE.EQ.1))GO TO 104
FAC=FLOAT(MIN0(3*II-1,M-II))/2.
IF(ICTST(GAM,DEL,RMS,2,1,FAC,FAC2,3,RG,XG,AG,BG).NE.1)
1GO TO 109
104 DO 105 III=1,3
IF((M-II).LT.(III-1))GO TO 109
IF((IP.EQ.1).AND.(LOOSE.EQ.1))GO TO 1055
XC=XCOR(III)
IF(II.EQ.1)XC=0.
AC=ACOR(III)
BC=BCOR(III)
FAC=FLOAT(MIN0(3*(II-1),M-II-III+1))*.5
IF(ICTST(GAM,DEL,RMS,2,III,FAC,FAC2,3,0.,XC,AC,BC).NE.1)
1GO TO 105
NUN=2.*FAC+.5
IF((LOOS2.EQ.1).OR.(NUN.EQ.0))GO TO 1050
DO 1049 IIII=1,NUN
JIJI=IIII+III
IF(ICTST(GAM,DEL,RMS,2,IJIJ,0.,FAC2,3,0.,XC,AC,BC).EQ.1)
1GO TO 1050
1049 CONTINUE
GO TO 105
1050 IH=1
IP=1
1055 IREM(II)=IREM(II)+2**III
105 CONTINUE
GO TO 109
103 IF(LOOS2.EQ.1)GO TO 1036
NUN=FAC*2+1.5
IF(NUN.EQ.1)GO TO 1036
DO 1035 III=1,NUN
JJJ=1-III
IF(ICTST(GAM,DEL,RMS,2,JJJ,0.,FAC2,3,0.,0.,0.,0.).EQ.1)
1GO TO 1036
1035 CONTINUE
GO TO 102
1036 IH=1
IP=1
IREM(II)=1
IF(IFULL.NE.1)GO TO 200
GO TO 102
109 RG=R2
XG=XXG
110 CONTINUE
GO TO 200
199 MIN=1
200 IF(JTEST.EQ.0)GO TO 202
FAC=FLOAT(MIN0(IXX-1,M))/2.
ICOR=0
IF(IDEG(2).GT.2)ICOR=1
XXXXG=XXG
RR2=R2
IF(ICOR.EQ.1)GO TO 250
XXXXG=0.
RR2=R1
250 IF(ICTST(GAM,DEL,RMS,3,1,FAC,0.,0,RR2,XXXXG,AG,BG).NE.1)
1GO TO 202
IF(NAM.LT.0)GO TO 300
NUM=I-1
DO 201 ITEST=MIN,3
IF(M.LT.(ITEST-1))GO TO 202
IF(JTEST.EQ.(JTEST/2)*2)GO TO 201
FAC2=FLOAT(ITEST)-1.
XC=0.
IF(ICOR.EQ.1)XC=XCOR(ITEST)
AC=ACOR(ITEST)
BC=BCOR(ITEST)
IF(ICTST(DEL,DEL,RMS,3,1,0.,FAC2,3,0.,XC,AC,BC).NE.1)
1GO TO 201
CALL AMINE(NUM,ITEST,IDUP,JJ,SHF,IIF,IF,NAM,NSF)
201 JTEST=JTEST/2
202 I1=IREM(1)
I2=IREM(2)
I3=IREM(3)
RETURN
300 IH=1
RETURN
END
INTEGER FUNCTION IACC(P,NP,RMS)
COMMON/ACDNT/NAD,ADDEL,CMSPC(100),NCOM
COMMON/LIL/IDUP,JDOOM
DIMENSION P(1),PC(100),RC(100)
IF(NP.LE.(NAD+1))GO TO 2
JDUP=IDUP
PL=P(1)
PF=PL
I=0
DO 1 J=2,NP
PJ=P(J)
IF((PL-PJ).LE.ADDEL)GO TO 1
I=I+1
PC(I)=(PL+PF)*0.5
RC(I)=RMS+(PF-PL)*0.5
PF=PJ
1 PL=PJ
I=I+1
PC(I)=(PF+PL)*0.5
RC(I)=RMS+(PF-PL)*0.5
ITMP=MCHGEN(CMSPC,NCOM,PC,I,RC,NAD)
IACC=ITMP
IDUP=JDUP
RETURN
2 IACC=1
RETURN
END
INTEGER FUNCTION ICTST(GAM,DEL,RMS,LVC,IAM,FAC,FAC2,IFLAG,
1R1,XCOR,A,B)
COMMON/STUFF/SPECT(100),NSPECT,XRMS,LIMAT,MORE
COMMON/PASS/SHIFT(25),LEV(25),IDEG(25),SHF(25),R(25),N
COMMON/LIL/IDUP,II
DIMENSION GAM(1),DEL(1),SHF2(25)
II=0
FACP=FAC+1.-FLOAT(IAM)
IF(IAM.GT.0)FACP=FAC+FLOAT(IAM-1)
DO 1 I=1,N
ID=IDEG(I)
LI=LEV(I)
IF(LI-LVC)1,2,3
3 II=II+1
SHF(II)=SHIFT(I)
R(II)=RMS
IF(LI.EQ.IFLAG)SHF(II)=SHF(II)+FAC2*DEL(ID)
GO TO 1
2 II=II+1
DID=DEL(ID)
R(II)=RMS+ABS(FAC*DID)+R1
SHF(II)=SHIFT(I)+FACP*DID+XCOR
IF(IFLAG.NE.0)SHF(II)=SHF(II)+FAC2*GAM(ID)
IF(IAM.LE.0)GO TO 1
SHF(II)=SHF(II)*A+B
1 CONTINUE
IF((FAC.LT.1.E-4).AND.(R1.LT.1.E-4))GO TO 10
ITTMP=MCHGEN(SPECT,NSPECT,SHF,II,R,MORE)
IF(ITTMP.EQ.0)GO TO 5
JJ=0
RMSP=RMS+1.E-4
DO 4 I=1,II
IF(R(I).GT.RMSP)GO TO 4
JJ=JJ+1
SHF2(JJ)=SHF(I)
4 CONTINUE
CALL SORT(SHF2,JJ)
ITTMP=IACC(SHF2,JJ,RMS)
5 ICTST=ITTMP
RETURN
10 CALL SORT(SHF,II)
ITTMP=MATCH(SPECT,NSPECT,SHF,II,RMS,MORE)
ICTST=ITTMP
RETURN
END
SUBROUTINE LOCAL(IS,IA,IB,IC,ID,LV,NBR,I)
DIMENSION IS(1),IA(1),IB(1),IC(1),ID(1),LV(1),NBR(4,1)
DIMENSION LEV(100),IBL(100),IBD(100)
IPT=0
NB=0
I=0
LV(1)=0
IBD(1)=0
50 IPT=IPT+1
ISIPT=IS(IPT)
IF(ISIPT.LT.0)GO TO 200
I=I+1
IA(I)=0
IB(I)=0
IC(I)=0
ID(I)=0
IF(I.EQ.1)GO TO 100
J=IBL(NB)
LV(I)=LEV(NB)
NB=NB-1
IBD(I)=J
ILP=IA(J)+1
NBR(ILP,J)=I
IA(J)=ILP
J=IBD(J)
IF(J.EQ.0)GO TO 100
IB(J)=IB(J)+1
J=IBD(J)
IF(J.EQ.0)GO TO 100
IC(J)=IC(J)+1
J=IBD(J)
IF(J.EQ.0)GO TO 100
ID(J)=ID(J)+1
100 IF(ISIPT.EQ.0)GO TO 50
LIP=LV(I)+1
DO 102 M=1,ISIPT
NB=NB+1
IBL(NB)=I
102 LEV(NB)=LIP
GO TO 50
200 IF(I.EQ.1)RETURN
DO 300 J=2,I
IBON=IBD(J)
ILP=IA(J)+1
NBR(ILP,J)=IBON
ID(J)=ID(J)+IC(IBON)-IB(J)
IC(J)=IC(J)+IB(IBON)-IA(J)
IB(J)=IB(J)+IA(IBON)-1
300 IA(J)=ILP
RETURN
END
INTEGER FUNCTION MATCH(SPECT,NSPECT,SHFT,JJ,RMS,MORE)
COMMON/LIL/IDUP,JDOOM
DIMENSION SPECT(1),SHFT(1)
IP=0
IS=0
IDUP=0
260 IP=IP+1
261 IS=IS+1
IF(IP.GT.JJ)GO TO 278
IF(IS.GT.NSPECT)GO TO 263
262 IF(SPECT(IS).LT.(SHFT(IP)-RMS))GO TO 264
IF(SPECT(IS)-SHFT(IP)-RMS)260,260,261
263 IS=IS-1
IDUP=IDUP+1
IF(IDUP.GT.MORE)GO TO 279
GO TO 262
264 IF(IS.EQ.1)GO TO 279
IF(ABS(SHFT(IP)-SPECT(IS-1)).GT.RMS)GO TO 279
IDUP=IDUP+1
IF(IDUP.GT.MORE)GO TO 279
IS=IS-1
GO TO 260
278 ITMP=IACC(SHFT,JJ,RMS)
MATCH=ITMP
RETURN
279 MATCH=0
RETURN
END
INTEGER FUNCTION MCHGEN(S,NS,P,NP,R,M)
DIMENSION S(1),P(1),R(1),PP(100),PM(100),IAS(100)
COMMON/LIL/IDUP,JDOOM
IF(NP.EQ.0)GO TO 10
DO 1 I=1,NP
IAS(I)=0
PP(I)=P(I)+R(I)
1 PM(I)=P(I)-R(I)
IF(NP.EQ.1)GO TO 6
NM=NP-1
DO 5 I=1,NM
JT=0
IP=I+1
PPT=PP(I)
PMT=PM(I)
DO 4 J=IP,NP
IF(PMT-PM(J))3,2,4
2 IF(PPT-PP(J))3,4,4
3 JT=J
PPT=PP(J)
PMT=PM(J)
4 CONTINUE
IF(JT.EQ.0)GO TO 5
PP(JT)=PP(I)
PM(JT)=PM(I)
PM(I)=PMT
PP(I)=PPT
5 CONTINUE
6 IDUP=0
NSP=NS+1
S(NSP)=-1.E20
DO 9 I=1,NSP
SI=S(I)
DO 8 J=1,NP
IF(IAS(J).GT.0)GO TO 8
IF(SI.LT.PM(J))GO TO 7
IF(SI.GT.PP(J))GO TO 8
IAS(J)=1
GO TO 9
7 IF(I.EQ.1)GO TO 11
IF(S(I-1).GT.PP(J))GO TO 11
IAS(J)=1
IDUP=IDUP+1
IF(IDUP.GT.M)GO TO 11
8 CONTINUE
9 CONTINUE
10 MCHGEN=1
RETURN
11 MCHGEN=0
RETURN
END
SUBROUTINE MERGE(T,N1,N,V)
DIMENSION V(1),T(1)
I=1
J=N1+1
DO 4 JJ=1,N
IF(J.GT.N)GO TO 2
IF(I.GT.N1)GO TO 3
IF(T(I)-T(J))3,3,2
2 V(JJ)=T(I)
I=I+1
GO TO 4
3 V(JJ)=T(J)
J=J+1
4 CONTINUE
RETURN
END
SUBROUTINE SHFT(S,M,IA,NBR,IG,ID,N,LV,LMIN,LMAX,COR)
DIMENSION S(1),IA(1),NBR(4,1),IG(1),ID(1),COR(1),LV(1)
DIMENSION A(4,4),B(4),GAM(4),DEL(4)
DATA GAM/2.99,2.69,2.07,-0.68/
DATA DEL/-0.49,-0.25,0.0,0.0/
DATA B/186.0,177.5,169.3,165.0/
DATA A/0.0,0.0,0.0,0.0,-9.56,-9.75,-6.60,-2.26,
1-17.83,-16.70,-11.14,-3.96,-25.48,-21.43,-14.70,-7.35/
M=0
DO 1 I=1,N
LVI=LV(I)
IF((LVI-LMIN)*(LMAX-LVI))1,2,2
2 M=M+1
IDG=IA(I)
SF=0.
DO 3 J=1,IDG
3 SF=SF+A(IDG,IA(NBR(J,I)))
S(M)=SF+FLOAT(IG(I))*GAM(IDG)+FLOAT(ID(I))*DEL(IDG)
1+B(IDG)+COR(I)
1 CONTINUE
RETURN
END
SUBROUTINE SORT(VEC,N)
DIMENSION VEC(1)
IF(N.LE.1)RETURN
NM=N-1
DO 1 I=1,NM
IP=I+1
DO 1 J=IP,N
IF(VEC(I).GT.VEC(J))GO TO 1
TEMP=VEC(J)
VEC(J)=VEC(I)
VEC(I)=TEMP
1 CONTINUE
RETURN
END
SUBROUTINE TEST(IF,NN,S,M)
DIMENSION IF(1),S(1),IA(100),IB(100),IC(100),ID(100),
1 LV(100),NBR(4,100),COR(100),ST(12),SHF(100),A(3)
2,B(3),AA(3),BB(3),AAA(3),BBB(3)
COMMON/STUFF/SPECT(100),NSPECT,RMS,LIMAT,MORE,STD
DATA TTMS/4HTMS /
DATA A/.846,.850,.938/
DATA B/6.6012,4.2200,-9.9564/
DATA AA/.955,.958,.946/
DATA BB/5.5360,6.3276,8.6212/
DATA AAA/.951,.950,.966/
DATA BBB/10.5272,10.58,8.1552/
DATA IQDOT/1H./,IQC/1HC/,IQN/1HN/
N=NN+1
ITYP=IF(1)
IF(N+1)=-1
CALL LOCAL(IF,IA,IB,IC,ID,LV,NBR,IDUM)
CALL AMCOR(COR,IA,IB,NBR,N)
CALL SHFT(ST,I,IA,NBR,IC,ID,N,LV,1,2,COR)
J=0
DO 3 II=1,N
L=LV(II)
IF((L.EQ.0).OR.(L.GT.2))GO TO 3
J=J+1
GO TO (1,2),L
1 ST(J)=ST(J)*A(ITYP)+B(ITYP)
GO TO 3
2 ST(J)=ST(J)*AA(ITYP)+BB(ITYP)
3 CONTINUE
CALL SORT(ST,J)
JJ=M
DO 4 J=1,I
JJ=JJ+1
4 S(JJ)=ST(J)
CALL MERGE(S,M,JJ,SHF)
IF(MATCH(SPECT,NSPECT,SHF,JJ,RMS,MORE).NE.1)RETURN
JJ=0
DO 6 J=1,N
JJ=JJ+1
IB(JJ)=IQC
IFJ=IF(J)
IF(IFJ.EQ.0)GO TO 6
DO 5 K=1,IFJ
JJ=JJ+1
5 IB(JJ)=IQDOT
6 CONTINUE
IB(1)=IQN
WRITE(5,100)(IB(J),J=1,JJ)
CALL SHFT(SHF,I,IA,NBR,IC,ID,N,LV,0,100,COR)
DO 7 I=1,N
IF(LV(I).EQ.1)SHF(I)=SHF(I)*A(ITYP)+B(ITYP)
IF(LV(I).EQ.2)SHF(I)=SHF(I)*AA(ITYP)+BB(ITYP)
IF(LV(I).EQ.3)SHF(I)=SHF(I)*AAA(ITYP)+BBB(ITYP)
IF(STD.EQ.TTMS)SHF(I)=192.8-SHF(I)
7 CONTINUE
WRITE(5,101)(SHF(I),I=2,N)
100 FORMAT(1H0,50A1/(1H ,50A1))
101 FORMAT(' SHIFTS: ',6F8.3/(1H ,8X,6F8.3))
RETURN
END
SUBROUTINE TIME(I)
DATA J/0/
I=0
CALL ETIME(I)
K=I
I=I-J
J=K
RETURN
END