|
|
PROGRAM CONPUC2
DIMENSION Q(20),PHI(20)
OPEN(UNIT=1,FILE='PUCIN',STATUS='OLD')
OPEN(UNIT=2,FILE='PUCPRT',STATUS='UNKNOWM')
CALL PUCKER(Q,PHI,AAZ,NR)
CLOSE(1)
CLOSE(2)
STOP
END
SUBROUTINE PUCKER(Q,PHI,AAZ,NRAT)
DIMENSION X(200),Y(200),Z(200),XC(200),YC(200),ZC(200),XR(25),YR(2
&5),ZR(25),EN(3),EM(3),EL(3),XP(25),YP(25),ZP(25),QC(15),QS(15),Q(2
&0),PHI(20),TLE(10),NAME(200),IAT(40,25),AF(200),IN(2),NRA(50)
READ(1,1)TLE
WRITE(2,5)TLE
WRITE(2,3)TLE
NORS=0
NAT=0
ICART = 0
K=1
20 CALL FREFOR(AF,IN)
INT=IN(2)+2
GO TO(145,26,25,21,22,23),INT
21 IF(AF(1).LT.0) GO TO 16
IF(AF(1).EQ.1) K=0
ICART=AF(1)
GO TO 20
16 K=0
GO TO 20
22 A=AF(1)
B=AF(2)
C=AF(3)
GAL=AF(4)
GBE=AF(5)
GGA=AF(6)
GO TO 20
23 NORS=NORS+1
M=AF(1)
NRA(NORS)=AF(1)
DO 24 J=1,M
24 IAT(NORS,J)=AF(J+1)
GO TO 20
25 NAT=NAT+1
NAME(NAT)=IN(1)
X(NAT)=AF(K+1)
Y(NAT)=AF(K+2)
Z(NAT)=AF(K+3)
GO TO 20
26 FACT=0.01745329
IF(ICART.EQ.2)GO TO 40
WRITE(2,6)
DO 27 I=1,NAT
27 WRITE(2,4)I,NAME(I),X(I),Y(I),Z(I)
IF(ICART.NE.1)GO TO 40
DO 30 I=1,NAT
XC(I)=X(I)
YC(I)=Y(I)
30 ZC(I)=Z(I)
GO TO 60
40 IF(ICART.EQ.0)GO TO 45
WRITE(2,15)
XF=0.0
YF=0.0
ZF=0.0
DO 41 I=1,NAT
X(I)=-X(I)
Y(I)=-Y(I)
Z(I)=-Z(I)
XF=XF+X(I)
YF=YF+Y(I)
41 ZF=ZF+Z(I)
NX=1-XF/NAT
NY=1-YF/NAT
NZ=1-ZF/NAT
DO 43 I=1,NAT
X(I)=X(I)+NX
Y(I)=Y(I)+NY
Z(I)=Z(I)+NZ
43 WRITE(2,4)I,NAME(I),X(I),Y(I),Z(I)
45 AL=GAL*FACT
BE=GBE*FACT
GA=GGA*FACT
PA=COS(BE)*COS(GA)
R=(COS(AL)-PA)/SIN(GA)
QA=SQRT(1.-COS(BE)**2-R**2)
CAB=B*COS(GA)
CAC=C*COS(BE)
CBB=B*SIN(GA)
CBC=C*R
CCC=C*QA
DO 50 I=1,NAT
XC(I)=X(I)*A+Y(I)*CAB+Z(I)*CAC
YC(I)=Y(I)*CBB+Z(I)*CBC
50 ZC(I)=Z(I)*CCC
60 DO 140 I=1,NORS
NRAT=NRA(I)
WRITE(2,8)NRAT
65 DO 70 J=1,NRAT
IF(NRAT.EQ.NAT)IAT(I,J)=J
XR(J)=XC(IAT(I,J))
YR(J)=YC(IAT(I,J))
70 ZR(J)=ZC(IAT(I,J))
BX=0.0
BY=0.0
BZ=0.0
DO 80 J=1,NRAT
BX=BX+XR(J)
BY=BY+YR(J)
80 BZ=BZ+ZR(J)
BX=BX/NRAT
BY=BY/NRAT
BZ=BZ/NRAT
XD=0.0
YD=0.0
ZD=0.0
XDD=0.0
YDD=0.0
ZDD=0.0
DO 90 J=1,NRAT
XR(J)=XR(J)-BX
YR(J)=YR(J)-BY
ZR(J)=ZR(J)-BZ
SINF=SIN(6.283185*(J-1)/NRAT)
COSF=COS(6.283185*(J-1)/NRAT)
XD=XD+XR(J)*SINF
YD=YD+YR(J)*SINF
ZD=ZD+ZR(J)*SINF
XDD=XDD+XR(J)*COSF
YDD=YDD+YR(J)*COSF
90 ZDD=ZDD+ZR(J)*COSF
A=YD*ZDD-ZD*YDD
B=ZD*XDD-XD*ZDD
C=XD*YDD-YD*XDD
R=SQRT(A**2+B**2+C**2)
EN(1)=A/R
EN(2)=B/R
EN(3)=C/R
D=EN(1)*XR(1)+EN(2)*YR(1)+EN(3)*ZR(1)
XO=XR(1)-EN(1)*D
YO=YR(1)-EN(2)*D
ZO=ZR(1)-EN(3)*D
R=SQRT(XO**2+YO**2+ZO**2)
EM(1)=XO/R
EM(2)=YO/R
EM(3)=ZO/R
EL(1) =EM(2)*EN(3)-EM(3)*EN(2)
EL(2)=EM(3)*EN(1)-EM(1)*EN(3)
EL(3)=EM(1)*EN(2)-EM(2)*EN(1)
A=0.0
B=0.0
IE=0
WRITE(2,9)
DO 100 J=1,NRAT
XP(J)=EL(1)*XR(J)+EL(2)*YR(J)+EL(3)*ZR(J)
YP(J)=EM(1)*XR(J)+EM(2)*YR(J)+EM(3)*ZR(J)
ZP(J)=EN(1)*XR(J)+EN(2)*YR(J)+EN(3)*ZR(J)
100 WRITE(2,7)NAME(IAT(I,J)),XC(IAT(I,J)),YC(IAT(I,J)),ZC(IAT(I,J)),XP
&(J),YP(J),ZP(J)
M=(NRAT-1)/2
WRITE(2,11)
DO 120 N=2,M
QS(N)=0.0
QC(N)=0.0
DO 110 J=1,NRAT
QC(N)=QC(N)+ZP(J)*COS(6.283185*N*(J-1)/NRAT)
110 QS(N)=QS(N)+ZP(J)*SIN(6.283185*N*(J-1)/NRAT)
IF(NRAT/2.GT.M)IE=1
QC(N)=QC(N)*SQRT(2./NRAT)
QS(N)=-QS(N)*SQRT(2./NRAT)
Q(N)=SQRT(QC(N)**2+QS(N)**2)
SNTH=QS(N)/Q(N)
CSTH=QC(N)/Q(N)
IF(CSTH.LT.0)GO TO 115
PHI(N)=ASIN(SNTH)/FACT
IF(PHI(N).LT.0)PHI(N)=PHI(N)+360.0
GO TO 120
115 PHI(N)=ACOS(CSTH)/FACT
IF(SNTH.LT.0)PHI(N)=360.0-PHI(N)
120 WRITE(2,12)N,Q(N),PHI(N)
IF(IE.NE.1)GO TO 135
BQ=0.0
N2=NRAT/2
Q(N2)=0.0
DO 130 J=1,NRAT
Q(N2)=(-1)**(J-1)*ZP(J)+Q(N2)
130 BQ=BQ+ZP(J)**2
Q(N2)=Q(N2)*SQRT(1./NRAT)
WRITE(2,13)Q(N2)
BQ=SQRT(BQ)
TH=ACOS(Q(N2)/BQ)/FACT
WRITE(2,14)BQ,TH
135 AAZ=0
IF(IE.EQ.1)AAZ=Q(N2)
CALL CONFOR(Q,PHI,AAZ,NRAT)
140 CONTINUE
GO TO 150
145 WRITE(2,2)IN(1)
1 FORMAT(4X,10A4)
2 FORMAT(1X,' BAD DATA'/' UNSUITABLE ',A4,' RECORD')
3 FORMAT(1X,' INPUT DATA'//' TITL ',10A4)
4 FORMAT(I3,3X,A4,3F10.4)
5 FORMAT(1X,'PUCKERING ANALYSIS OF ',10A4)
6 FORMAT(1X,'ATOM COORDINATES')
7 FORMAT(1X,A4,5X,3F13.4,5X,3F13.4)
8 FORMAT(//,I5,' MEMBERED RING')
9 FORMAT(1X,'CARTESIAN AND PUCKERING COORDINATES')
10 FORMAT(1X,'CELL CONSTANTS',6F10.4)
11 FORMAT(1X,'PUCKERING PARAMETERS')
12 FORMAT(1X,'M =',I3,' Q(M) =',F7.4,' PHI(M) =',F8.4)
13 FORMAT(1X,'Q(N/2) =',F7.4)
14 FORMAT(1X,'PUCKERING AMPLITUDE =',F7.4,' THETA =',F8.4)
15 FORMAT(1X,'ENANTIOMORPHIC COORDINATES')
150 RETURN
END
SUBROUTINE FREFOR(A,IN)
DIMENSION IR(76),IH(14),A(200),IN(2),JZ(8)
DATA IH(1)/1H0/,IH(2)/1H1/,IH(3)/1H2/,IH(4)/1H3/,IH(5)/1H4/
DATA IH(6)/1H5/IH(7)/1H6/,IH(8)/1H7/,IH(9)/1H8/,IH(10)/1H9/
DATA IH(11)/1H./,IH(12)/1H-/,IH(13)/1H+/,IH(14)/1H=/
DATA JZ(1)/4H /,JZ(2)/4HFVAR/,JZ(3)/4HWGHT/,JZ(4)/4HAFIX/
DATA JZ(5)/4HCOOR/,JZ(6)/4HCELL/,JZ(7)/4HRING/,JZ(8)/4HEND /
1 FORMAT(A4,76A1)
2 FORMAT(1H ,A4,76A1)
3 READ(1,1)I,IR
IN(1)=I
WRITE(2,2)I,IR
IN(2)=1
DO 5 J=1,4
IF(I.EQ.JZ(J))GO TO 3
5 CONTINUE
IF(I.EQ.JZ(8)) GO TO 40
DO 15 J=5,7
IF(I.EQ.JZ(J))IN(2)=J-3
15 CONTINUE
N=0
GO TO 25
6 W=1.
7 V=0.
NB=0
Y=1.
U=10.
Z=1.
GO TO 10
8 Z=Y*Z
V=U*ABS(V)+Z*X
NB=1
IF(V)9,10,9
9 V=SIGN(V,W)
W=V
10 N=N+1
K=6
IF(76-N)27,11,11
11 X=0.
DO 12 M=1,10
IF(IR(N).EQ.IH(M))GO TO 8
12 X=X+1.
GO TO 14
13 IF(IR(N).EQ.IH(K+9)) GO TO 27
14 K=K-1
IF(K-2)27,13,13
17 U=1.
Y=0.1
GO TO 10
21 READ(1,1)M,IR
WRITE(2,2)M,IR
N=0
IF(JZ(1).EQ.M)GO TO 6
C ERROR MESSAGE RETURN. IN(2)=-1
23 IN(2)=-1
GO TO 35
25 DO 26 J=1,200
26 A(J)=0.
NA=0
GO TO 6
27 IF(K-2)28,17,28
28 NA=NA+NB
IF(200-NA)23,29,29
29 IF(-NA)30,31,31
30 A(NA)=V+A(NA)
31 IF(K-5)33,21,35
32 CONTINUE
33 IF(K-3)6,34,6
34 W=-1.
GO TO 7
40 IN(2)=0
C END OF FILE
35 RETURN
END
SUBROUTINE CONFOR(Q,PHI,AAZ,NR)
C ***************************************************************
C THIS PROGRAM EXPRESSES ANY CONFORMATION AS A LINEAR COMBINATION
C OF PRIMITIVE FORMS- AS DEFINED BY THE CREMER-POPLE EQUATIONS.
C THE PROGRAM IS ONLY FOR 18 -MEMBERED RINGS OR LESS.
C ***************************************************************
DIMENSION Q(20),PHI(20),XA(20),XB(20),XXA(20),XXB(20)
N=(NR-1)/2
WRITE(2,111)
WRITE(2,109)
WRITE(2,503)
WRITE(2,103)(M,Q(M),PHI(M),M=2,N)
C
C ***********************************************
C DISTINGUISH BETWEEN ODD AND EVEN MEMBERED RINGS
C ***********************************************
C
IF(NR/2.GT.N)THEN
IC=NR/2
Q(IC)=AAZ
WRITE(2,104)IC,Q(IC)
R=Q(IC)
IF(NR.LE.8)CALL EVEN(Q,PHI,N,NR,R)
IF(NR.GT.8)CALL LARGE(Q,PHI,N,NR,R)
ELSE
CALL ODD(Q,PHI,N,NR)
ENDIF
111 FORMAT(///,5X,'CONFORMATIONAL ANALYSIS')
103 FORMAT(5X,I2,4X,F5.3,4X,F7.2)
109 FORMAT(//,5X,'PUCKERING PARAMETERS')
104 FORMAT(//,5X,'Q(',I1,')=',F6.3)
503 FORMAT(//,6X,'M',4X,'Q(M)',7X,'PHI(M)')
RETURN
END
SUBROUTINE MINI(N,KK,KM,NR,PHI)
C
C ***********************************************************
C THIS SUBROUTINE FINDS THE PHI VALUES OF THE PRIMITIVE FORMS
C CLOSEST TO THE RING
C ***********************************************************
C
REAL KK(50),KM
YM=380
DO 1000 I=1,N
Y=ABS(((KK(I)*180)/(2*NR))-PHI)
IF(Y.LT.YM)GO TO 1010
GOTO 1000
1010 YM=Y
KM=KK(I)
1000 CONTINUE
RETURN
END
SUBROUTINE SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
C
C ****************************************************
C THIS FINDS THE COEFFICIENTS IN THE LINEAR EXPRESSION
C ****************************************************
C
DIMENSION Q(20),PHI(20),XA(20),XB(20),A(20),B(20),W(20),RHI(20)
REAL KMIN(50),LMIN(50)
C
C THE EQUATIONS IN THE LINEAR COMBINATION ARE NOW SOLVED
150 PI=3.14159265
DO 201 M=2,N
A(M)=((KMIN(M)*PI)/(2*NR))
B(M)=((LMIN(M)*PI)/(2*NR))
W(M)=(SIN(A(M)))*(COS(B(M)))-(COS(A(M)))*(SIN(B(M)))
C THE COEFFICIENTS IN THE EXPRESSION ARE NOW SOLVED
FACT=0.01745329
RHI(M)=PHI(M)*(FACT)
XA(M)=(1/W(M))*((-Q(M))*(COS(RHI(M)))*(SIN(B(M)))+Q(M)*(SIN(RHI(M)
&))*(COS(B(M))))
XB(M)=(1/W(M))*(Q(M)*(COS(RHI(M)))*(SIN(A(M)))-Q(M)*(SIN(RHI(M)))*
&(COS(A(M))))
201 CONTINUE
RETURN
END
SUBROUTINE WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
C
C ****************************************************
C THIS NORMALISES COEFFICIENTS AND WRITES THEM TO FILE
C ****************************************************
C
DIMENSION XA(20),XB(20),XXA(20),XXB(20)
REAL KMIN(50),LMIN(50)
TOTL=0
DO 250 M=2,N
TOTL=TOTL+XA(M)+XB(M)
250 CONTINUE
TOTL=TOTL+V
WRITE(2,110)
WRITE(2,504)
WRITE(2,105)(M,XA(M),XB(M),M=2,N)
WRITE(2,111)
WRITE(2,505)
WRITE(2,506)
WRITE(2,507)
DO 300 M=2,N
XXA(M)=XA(M)/(TOTL)
XXB(M)=XB(M)/(TOTL)
WRITE(2,106)M,XXA(M),KMIN(M)
WRITE(2,107)XXB(M),LMIN(M)
300 CONTINUE
VV=V/(TOTL)
105 FORMAT(5X,I2,8X,F5.3,8X,F5.3)
106 FORMAT(5X,I2,8X,F5.3,8X,F4.1)
107 FORMAT(15X,F5.3,8X,F4.1)
110 FORMAT(//,5X,'COEFFICIENTS OF PRIMITIVE FORMS')
111 FORMAT(//,5X,'NORMALISED COEFFICIENTS')
504 FORMAT(//,6X,'M',7X,'COSFORM',5X,'SINFORM')
505 FORMAT(//,6X,'M',5X,'COEFFICIENT',3X,'ANGULAR VALUE')
506 FORMAT(12X,'OF PRIMITIVE',2X,'OF PRIMITIVE')
507 FORMAT(12X,'FORM',11X,'FORM')
RETURN
END
SUBROUTINE EVEN(Q,PHI,N,NR,R)
C
C **********************************************
C THIS GENERATES THE PRIMITIVE FORMS FOR 6 AND 8
C MEMBERED RINGS
C **********************************************
C
DIMENSION Q(20),PHI(20),XA(20),XB(20),XXA(20),XXB(20),TF1(6),TF2(6
&),TF3(6),UF1(15),UF2(15),UF3(15),UF4(15),UF5(15),YXZ(15),QX(8),QXA
&(8)
REAL K(50),L(50),KMIN(50),LMIN(50)
CHARACTER NAME(6),NAMEX(15)*3
C
C *********************************************
C THIS FINDS THE CROWN FORM CLOSEST TO THE RING
C *********************************************
C
IF (R.LE.0)THEN
AA=-1.0
ELSE
AA=1.0
ENDIF
V=ABS(R)
C
C ******************************************************************
C THIS DETERMINES THE ANGULAR VALUES OF PRIMITIVE FORMS OF 6-M RINGS
C ******************************************************************
C
IF(NR.EQ.6)THEN
DO 86 M=2,N
DO 85 I=1,7
K(I)=4*(I-1)
L(I)=4*(I-1)+2
85 CONTINUE
NX=7
CALL MINI(NX,K,KMIN(M),NR,PHI(M))
CALL MINI(NX,L,LMIN(M),NR,PHI(M))
86 CONTINUE
CALL SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
CALL WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
WRITE(2,108)NR/2,VV,AA
C
C **************************************************
C THIS FINDS OUT IF THE 6-M RING IS A CLASSICAL FORM
C DATA FOR 6-M CLASSICAL FORMS
C **********************************************
C
DATA NAME /'B','T','C','E','S','H'/
DATA TF1 /1.0,0.0,0.0,0.586,0.0,0.0/
DATA TF2 /0.0,1.0,0.0,0.0,0.707,0.551/
DATA TF3 /0.0,0.0,1.0,0.414,0.293,0.449/
DO 7000 I=1,6
YXX=ABS(TF1(I)-XXA(2))+ABS(TF2(I)-XXB(2))+ABS(TF3(I)-VV)
IF(YXX.LE.0.2.AND.YXX.GT.0.1)WRITE(2,7031)NAME(I)
IF(YXX.LE.0.1)WRITE(2,7030)NAME(I)
7000 CONTINUE
7030 FORMAT(/,5X,'WARNING:THIS IS A',A4,' FORM')
7031 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A ',A4,' FORM')
C
C *******************************************
C THE PRIMITIVE FORMS OF EIGHT MEMBERED RINGS
C *******************************************
C
ELSE
DO 141 M=2,N
C
C *********************************************************
C PRIMITIVE FORMS ARE AT DIFFERENT PHI VALUES FOR M=2 AND 3
C *********************************************************
C
90 IF(M.EQ.2)THEN
DO 120 I=1,3
K(I)=16*(I-1)
L(I)=16*(I-1)+8
120 CONTINUE
MY=3
CALL MINI(MY,K,KMIN(M),NR,PHI(M))
CALL MINI(MY,L,LMIN(M),NR,PHI(M))
ELSE
DO 140 I=1,5
K(I)=8*(I-1)
L(I)=8*(I-1)+4
140 CONTINUE
NI=5
CALL MINI(NI,K,KMIN(M),NR,PHI(M))
CALL MINI(NI,L,LMIN(M),NR,PHI(M))
ENDIF
141 CONTINUE
CALL SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
CALL WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
WRITE(2,108)NR/2,VV,AA
C
C THIS FINDS OUT IF A 8-M RING IS A CLASSICAL FORM
C
C ************************************************
C DATA FOR CLASSICAL FORMS
C ************************************************
C
DATA NAMEX /'BB ','BB ','CR ','TC ','TC ','C ','B ','S ','S '
&,'CC ','CC ','TCC','BC ','BC ','TBC'/
DATA UF1 /1.0,0.0,0.0,0.0,0.0,0.0,0.5,0.707,0.293,0.352,0.0,0.234
&,0.530,0.0,0.229/
DATA UF2 /0.0,1.0,0.0,0.0,0.0,0.0,0.5,0.293,0.707,0.0,0.352,0.234
&,0.0,0.530,0.229/
DATA UF3 /0.0,0.0,0.0,1.0,0.0,0.5,0.0,0.0,0.0,0.0,0.0,0.0,0.298,0
&.0,0.213/
DATA UF4 /0.0,0.0,0.0,0.0,1.0,0.5,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.2
&98,0.213/
DATA UF5 /0.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0,0.648,0.648,0.533,0
&.172,0.172,0.116/
DO 7500 I=1,15
YXZ(I)= ABS(XXA(2)-UF1(I))+ ABS(XXB(2)-UF2(I))+ ABS(XXA(3)-UF3(I)
&)+ ABS(XXB(3)-UF4(I)) + ABS(VV-UF5(I))
7500 CONTINUE
DO 7501 I=1,12
IF(YXZ(I).LE.0.2.AND.YXZ(I).GT.0.1)WRITE(2,7514)NAMEX(I)
IF(YXZ(I).LE.0.1)WRITE(2,7513)NAMEX(I)
7501 CONTINUE
DO 9669 I=2,N
RZ=ABS(PHI(I)-360)
IF(RZ.LT.5)PHI(I)=360-PHI(I)
9669 CONTINUE
IF(YXZ(13).LE.0.2.OR.YXZ(14).LE.0.2)THEN
DO 3010 J=1,8
ANG=(8*180*(J-1))/16
ANGA=180+(8*180*(J-1))/16
ANGL=180 + (4*180*(J-1))/16
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720)RL= ABS(PHI(2)+720-ANG)
RLA= ABS(PHI(2)-ANGA)
IF(ANGA.GE.360.AND.ANGA.LT.720)RLA= ABS(PHI(2)+360-ANGA)
IF(ANGA.GE.720)RLA= ABS(PHI(2)+720-ANGA)
RLL= ABS(PHI(3)-ANGL)
IF(ANGL.GE.360)RLL= ABS(PHI(3)+360-ANGL)
QX(J)=RL+RLL
QXA(J)=RLA+RLL
3010 CONTINUE
QXX=10.03
QXXA=10.03
DO 3000 J=1,8
IF(QX(J).LE.10.AND.AA.EQ.-1.0)QXX=QX(J)
IF(QXA(J).LE.10.AND.AA.EQ.1.0)QXXA=QXA(J)
3000 CONTINUE
IF(QXX.LE.10.AND.YXZ(13).LE.0.1.OR.QXX.LE.10.AND.YXZ(14).LE.0.1)WR
&ITE(2,7513)NAMEX(13)
IF(QXXA.LE.10.AND.YXZ(13).GT.0.1.OR.QXXA.LE.10.AND.YXZ(14).GT.0.1)
&WRITE(2,7514)NAMEX(13)
ELSEIF(YXZ(15).LE.0.2)THEN
DO 3002 J=1,8
ANG= (4*180)/16 +(8*180*(J-1))/16
ANGA=180+ 4*180/16 + (8*180*(J-1))/16
ANGL=180 + 2*180/16 + (4*180*(J-1))/16
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720)RL= ABS(PHI(2)+720-ANG)
RLA= ABS(PHI(2)-ANGA)
IF(ANGA.GE.360.AND.ANGA.LT.720)RLA= ABS(PHI(2)+360-ANGA)
IF(ANGA.GE.720)RLA= ABS(PHI(2)+720-ANGA)
RLL= ABS(PHI(3)-ANGL)
IF(ANGL.GE.360)RLL= ABS(PHI(3)+360-ANGL)
QX(J)=RL+RLL
QXA(J)=RLA+RLL
3002 CONTINUE
QXX=10.03
QXXA=10.03
DO 3005 J=1,8
IF(QX(J).LE.10.AND.AA.EQ.-1.0)QXX=QX(J)
IF(QXA(J).LE.10.AND.AA.EQ.1.0)QXXA=QXA(J)
3005 CONTINUE
IF(QXX.LE.10.AND.YXZ(15).LE.0.1)WRITE(2,7513)NAMEX(15)
IF(QXXA.LE.10.AND.YXZ(15).GT.0.1)WRITE(2,7514)NAMEX(15)
IF(QXXA.LE.10.AND.YXZ(15).LE.0.1)WRITE(2,7513)NAMEX(15)
IF(QXX.LE.10.AND.YXZ(15).GT.0.1)WRITE(2,7514)NAMEX(15)
ELSE
CONTINUE
ENDIF
7513 FORMAT(/,5X,'WARNING: THIS IS A',A4,' FORM')
7514 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A',A4,' FORM')
7552 ENDIF
108 FORMAT(5X,I2,8X,F5.3,8X,F4.1)
RETURN
END
SUBROUTINE ODD(Q,PHI,N,NR)
C
C ******************************************************
C THIS FINDS THE PRIMITIVE FORMS OF ODD MEMBERED RINGS
C ****************************************************
C
DIMENSION Q(20),PHI(20),XA(20),XB(20),XXA(20),XXB(20),SF1(2),SF2(2
&),XF1(9),XF2(9),XF3(9),XF4(9),XN1(16),XN2(16),XN3(16),XN4(16),XN5(
&16),XN6(16),YZZ(16),QY(14),QX(19),QXA(14),QYA(14),QX1(18),QX2(18),
&QX3(18),QX4(18)
REAL K(50),L(50),KMIN(50),LMIN(50)
CHARACTER NAME(2),NAMEX(9)*2,NAMX(16)*4
DO 45 M=2,N
NRR=2*NR+1
IF(NR.EQ.9.AND.M.EQ.3)THEN
NUM=7
DO 4040 I=1,7
K(I)=6*(I-1)
L(I)=6*(I-1)+3
4040 CONTINUE
CALL MINI(NUM,K,KMIN(M),NR,PHI(M))
CALL MINI(NUM,L,LMIN(M),NR,PHI(M))
ELSEIF(NR.EQ.15.AND.M.EQ.5)THEN
NUM=7
DO 4031 I=1,7
K(I)=10*(I-1)
L(I)=10*(I-1)+5
4031 CONTINUE
CALL MINI(NUM,K,KMIN(M),NR,PHI(M))
CALL MINI(NUM,L,LMIN(M),NR,PHI(M))
ELSEIF(NR.EQ.15.AND.M.EQ.3.OR.NR.EQ.15.AND.M.EQ.6)THEN
NUM=11
DO 4033 I=1,11
K(I)=6*(I-1)
L(I)=6*(I-1)+3
4033 CONTINUE
CALL MINI(NUM,K,KMIN(M),NR,PHI(M))
CALL MINI(NUM,L,LMIN(M),NR,PHI(M))
ELSE
DO 40 I=1,NRR
K(I)=2*(I-1)
L(I)=2*(I-1)+1
40 CONTINUE
CALL MINI(NRR,K,KMIN(M),NR,PHI(M))
CALL MINI(NRR,L,LMIN(M),NR,PHI(M))
ENDIF
45 CONTINUE
V=0
CALL SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
CALL WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
C
C *********************************************
C THIS DETERMINES IF A RING IS A CLASSICAL FORM
C *********************************************
C
IF(NR.GT.9)GO TO 4994
IF(NR.EQ.5)THEN
C
C ****************************
C DATA FOR 5-M CLASSICAL FORMS
C ****************************
C
DATA NAME /'E','T'/
DATA SF1 /1.0,0.0/
DATA SF2 /0.0,1.0/
DO 9000 I=1,2
YX = ABS(SF1(I)-XXA(2))+ABS(SF2(I)-XXB(2))
IF(YX.LE.0.1)WRITE(2,9200)NAME(I)
IF(YX.GT.0.1.AND.YX.LE.0.2)WRITE(2,9201)NAME(I)
9000 CONTINUE
9200 FORMAT(/,5X,'WARNING:THIS IS A',A4,' FORM')
9201 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A',A4,' FORM')
ELSEIF(NR.EQ.7)THEN
C
C ****************************
C DATA FOR 7-M CLASSICAL FORMS
C ****************************
C
DATA NAMEX /'B ','TB','C ','TC','BS','S ','TS','H ','T '/
DATA XF1 /1.00,0.0,0.0,0.0,0.783,0.5,0.0,0.417,0.0/
DATA XF2 /0.0,1.0,0.0,0.0,0.0,0.0,0.444,0.0,0.46/
DATA XF3 /0.0,0.0,1.0,0.0,0.217,0.5,0.0,0.583,0.0/
DATA XF4 /0.0,0.0,0.0,1.0,0.0,0.0,0.555,0.0,0.54/
DO 4000 I=1,9
YZZ(I)= ABS(XXA(2)-XF1(I))+ ABS(XXB(2)-XF2(I))+ ABS(XXA(3)-XF3(I))
&+ABS(XXB(3)-XF4(I))
4000 CONTINUE
DO 9669 I=2,N
RZ=ABS(PHI(I)-360)
IF(RZ.LT.5)PHI(I)=360-PHI(I)
9669 CONTINUE
IF (YZZ(5).LE.0.2)THEN
DO 4041 J=1,14
ANGA=180+(6*180*(J-1))/14
ANGL=(2*180*(J-1))/14
RLA= ABS(PHI(2)-ANGA)
IF(ANGA.GE.360.AND.ANGA.LT.720)RLA= ABS(PHI(2)+360-ANGA)
IF(ANGA.GE.720.AND.ANGA.LT.1080)RLA= ABS(PHI(2)+720-ANGA)
IF(ANGA.GE.1080)RLA= ABS(PHI(2)+1080-ANGA)
RLL= ABS(PHI(3)-ANGL)
QX(J)=RLA+RLL
4041 CONTINUE
QXX=10.03
DO 4944 J=1,14
IF(QX(J).LE.10)QXX=QX(J)
4944 CONTINUE
IF(QXX.LE.10.AND.YZZ(5).LE.0.1)WRITE(2,4091)
IF(QXX.LE.10.AND.YZZ(5).GT.0.1)WRITE(2,4092)
ELSEIF(YZZ(6).LE.0.2.OR.YZZ(8).LE.0.2)THEN
4020 DO 4021 J=1,14
ANG=(6*180*(J-1))/14
ANGA=180+(6*180*(J-1))/14
ANGL=(2*180*(J-1))/14
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720)RL= ABS(PHI(2)+720-ANG)
RLA= ABS(PHI(2)-ANGA)
IF(ANGA.GE.360.AND.ANGA.LT.720)RLA= ABS(PHI(2)+360-ANGA)
IF(ANGA.GE.720.AND.ANGA.LT.1080)RLA= ABS(PHI(2)+720-ANGA)
IF(ANGA.GE.1080)RLA= ABS(PHI(2)+1080-ANGA)
RLL= ABS(PHI(3)-ANGL)
QX(J)=RL+RLL
QXA(J)=RLA+RLL
4021 CONTINUE
QXX=10.03
QXXA=10.03
DO 4998 J=1,14
IF(QX(J).LE.10)QXX=QX(J)
IF(QXA(J).LE.10)QXXA=QXA(J)
4998 CONTINUE
IF(QXX.LE.10.AND.YZZ(6).LE.0.1)WRITE(2,4071)
IF(QXX.LE.10.AND.YZZ(6).GT.0.1.AND.YZZ(6).LE.0.2)WRITE(2,4072)
IF(QXXA.LE.10.AND.YZZ(8).LE.0.1)WRITE(2,4081)
IF(QXXA.LE.10.AND.YZZ(8).GT.0.1.AND.YZZ(8).LE.0.2)WRITE(2,4082)
GO TO 5001
ELSEIF(YZZ(7).LE.0.2.OR.YZZ(9).LE.0.2)THEN
DO 5005 J=1,14
ANGM=((3*180)/14) + ((6*180*(J-1))/14)
ANGMA=180+((3*180)/14) + ((6*180*(J-1))/14)
ANGLM= (180/14) + ((2*180*(J-1))/14)
RM= ABS(PHI(2)-ANGM)
IF(ANGM.GE.360.AND.ANGM.LT.720)RM= ABS(PHI(2)+360-ANGM)
IF(ANGM.GE.720)RM= ABS(PHI(2)+720-ANGM)
RMA= ABS(PHI(2)-ANGMA)
IF(ANGMA.GE.360.AND.ANGMA.LT.720)RMA= ABS(PHI(2)+360-ANGMA)
IF(ANGMA.GE.720.AND.ANGMA.LT.1080)RMA= ABS(PHI(2)+720-ANGMA)
IF(ANGMA.GE.1080)RMA= ABS(PHI(2)+1080-ANGMA)
RMM= ABS(PHI(3)-ANGLM)
QY(J)= RM + RMM
QYA(J)= RMA + RMM
5005 CONTINUE
QYY=10.03
QYYA=10.03
DO 4999 J=1,14
IF(QY(J).LE.10)QYY= QY(J)
IF(QYA(J).LE.10)QYYA= QYA(J)
4999 CONTINUE
IF(QYY.LE.10.AND.YZZ(7).LE.0.1)WRITE(2,5010)
IF(QYY.LE.10.AND.YZZ(7).GT.0.1.AND.YZZ(7).LE.0.2)WRITE(2,5011)
IF(QYYA.LE.10.AND.YZZ(9).LE.0.1)WRITE(2,5012)
IF(QYYA.LE.10.AND.YZZ(9).GT.0.1.AND.YZZ(9).LE.0.2)WRITE(2,5013)
ELSE
DO 4919 I=1,9
IF(YZZ(I).LE.0.1)WRITE(2,4902)NAMEX(I)
IF(YZZ(I).GT.0.1.AND.YZZ(I).LE.0.2)WRITE(2,4903)NAMEX(I)
4919 CONTINUE
ENDIF
4071 FORMAT(/,5X,'WARNING:THIS IS A S FORM')
4072 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A S FORM')
4081 FORMAT(/,5X,'WARNING:THIS IS AN H FORM')
4082 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A H FORM')
4091 FORMAT(/,5X,'WARNING:THIS IS AN BS FORM')
4092 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A BS FORM')
5010 FORMAT(/,5X,'WARNING:THIS IS A TS FORM')
5011 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A TS FORM')
5012 FORMAT(/,5X,'WARNING:THIS IS A T FORM')
5013 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A T FORM')
4902 FORMAT(/,5X,'WARNING:THIS IS A',A4,' FORM')
4903 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A ',A4,' FORM')
ELSE
C ****************************
C DATA FOR 9-M CLASSICAL FORMS
C ****************************
C
DATA NAMX /'BB','TBB','BC ','TBC','CC','TCC','BC"','TBC"','B','CC
&"','TB','TCC"','C','CB','TC','TCB'/
DATA XN1 /1.00,0.0,0.0,0.0,0.0,0.0,0.308,0.0,0.582,0.401,0.0,0.0
&,0.280,0.601,0.0,0.0/
DATA XN2 /0.0,1.00,0.0,0.0,0.0,0.0,0.0,0.317,0.0,0.0,0.584,0.397
&,0.0,0.,0.340,0.498/
DATA XN3 /0.0,0.0,1.0,0.0,0.379,0.0,0.563,0.0,0.168,0.189,0.0,0.
&0,0.617,0.245,0.0,0.0/
DATA XN4 /0.0,0.0,0.0,1.0,0.0,0.379,0.0,0.564,0.0,0.0,0.168,0.19
&2,0.0,0.0,0.515,0.319/
DATA XN5 /0.0,0.0,0.0,0.0,0.621,0.0,0.129,0.0,0.250,0.410,0.0,0.0
&0,0.104,0.154,0.0,0.0/
DATA XN6 /0.0,0.0,0.0,0.0,0.0,0.621,0.0,0.119,0.0,0.0,0.248,0.411
&,0.0,0.0,0.145,0.183/
DO 4101 I=1,16
YZZ(I)= ABS(XXA(2)-XN1(I))+ ABS(XXB(2)-XN2(I))+ ABS(XXA(3)-XN3(I))
&+ABS(XXB(3)-XN4(I))+ABS(XXA(4)-XN5(I))+ABS(XXB(4)-XN6(I))
4101 CONTINUE
DO 9666 I=2,N
RH=ABS(PHI(I)-360)
IF(RH.LT.5)PHI(I)=360-PHI(I)
9666 CONTINUE
IF(YZZ(5).LE.0.2)THEN
DO 5111 J=1,18
ANG=180+(6*180*(J-1))/18
ANGL=(2*180*(J-1))/18
RL= ABS(PHI(3)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(3)+360-ANG)
IF(ANG.GE.720.AND.ANG.LT.1080)RL= ABS(PHI(3)+720-ANG)
IF(ANG.GE.1080)RL= ABS(PHI(3)+1080-ANG)
RLL= ABS(PHI(4)-ANGL)
QX(J)=RL+RLL
5111 CONTINUE
QXX=10.03
DO 5998 J=1,18
IF(QX(J).LE.10)QXX=QX(J)
5998 CONTINUE
IF(QXX.LE.10.AND.YZZ(5).GT.0.1)WRITE(2,7010)NAMX(5)
IF(QXX.LE.10.AND.YZZ(5).LE.0.1)WRITE(2,7011)NAMX(5)
ELSEIF(YZZ(6).LE.0.2)THEN
DO 5112 J=1,18
ANG=180+ 3*180/18+(6*180*(J-1))/18
ANGL=180/18+(2*180*(J-1))/18
RL= ABS(PHI(3)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(3)+360-ANG)
IF(ANG.GE.720.AND.ANG.LT.1080)RL= ABS(PHI(3)+720-ANG)
IF(ANG.GE.1080)RL= ABS(PHI(3)+1080-ANG)
RLL= ABS(PHI(4)-ANGL)
QX(J)=RL+RLL
5112 CONTINUE
QXX=10.03
DO 5997 J=1,18
IF(QX(J).LE.10)QXX=QX(J)
5997 CONTINUE
IF(QXX.LE.10.AND.YZZ(6).GT.0.1)WRITE(2,7010)NAMX(6)
IF(QXX.LE.10.AND.YZZ(6).LE.0.1)WRITE(2,7011)NAMX(6)
C
ELSEIF(YZZ(7).LE.0.2.OR.YZZ(9).LE.0.2.OR.YZZ(10).LE.0.2.OR.YZZ(13)
&.LE.0.2.OR.YZZ(14).LE.0.2)THEN
DO 5113 J=1,18
ANG= 180 + (10*180*(J-1))/18
ANGL=180 + (6*180*(J-1))/18
ANGM= (2*180*(J-1))/18
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720.AND.ANG.LT.1080)RL= ABS(PHI(2)+720-ANG)
IF(ANG.GE.1080.AND.ANG.LT.1440)RL= ABS(PHI(2)+1080-ANG)
IF(ANG.GE.1440.AND.ANG.LT.1800)RL= ABS(PHI(2)+1440-ANG)
IF(ANG.GE.1800)RL= ABS(PHI(2)+1800-ANG)
RLL= ABS(PHI(3)-ANGL)
IF(ANGL.GE.360.AND.ANGL.LT.720)RLL= ABS(PHI(3)+360-ANGL)
IF(ANGL.GE.720.AND.ANGL.LT.1080)RLL= ABS(PHI(3)+720-ANGL)
IF(ANGL.GE.1080)RLL= ABS(PHI(3)+1080-ANGL)
RLM= ABS(PHI(4)-ANGM)
IF(ANGM.GE.360)RLM= ABS(PHI(4)+360-ANGM)
QX(J)=RL+RLL+RLM
5113 CONTINUE
QXX=15.03
DO 5996 J=1,18
IF(QX(J).LE.15)QXX=QX(J)
5996 CONTINUE
IF(QXX.LE.15.AND.YZZ(7).GT.0.1.AND.YZZ(7).LE.0.2)WRITE(2,7010)NAMX
&(7)
IF(QXX.LE.15.AND.YZZ(7).LE.0.1)WRITE(2,7011)NAMX(7)
DO 5115 J=1,18
ANG= (10*180*(J-1))/18
ANGL=180+(6*180*(J-1))/18
ANGM=(2*180*(J-1))/18
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720.AND.ANG.LT.1080)RL= ABS(PHI(2)+720-ANG)
IF(ANG.GE.1080.AND.ANG.LT.1440)RL= ABS(PHI(2)+1080-ANG)
IF(ANG.GE.1440.AND.ANG.LT.1800)RL= ABS(PHI(2)+1440-ANG)
IF(ANG.GE.1800)RL= ABS(PHI(2)+1800-ANG)
RLL= ABS(PHI(3)-ANGL)
IF(ANGL.GE.360.AND.ANGL.LT.720)RLL= ABS(PHI(3)+360-ANGL)
IF(ANGL.GE.720.AND.ANGL.LT.1080)RLL= ABS(PHI(3)+720-ANGL)
IF(ANGL.GE.1080)RLL= ABS(PHI(3)+1080-ANGL)
RLM= ABS(PHI(4)-ANGM)
IF(ANGM.GE.360)RLM= ABS(PHI(4)+360-ANGM)
QX1(J)=RL+RLL+RLM
5115 CONTINUE
QXX1=15.03
DO 5994 J=1,18
IF(QX1(J).LE.15)QXX1=QX1(J)
5994 CONTINUE
IF(QXX1.LE.15.AND.YZZ(9).GT.0.1.AND.YZZ(9).LE.0.2)WRITE(2,7010)NAM
&X(9)
IF(QXX1.LE.15.AND.YZZ(9).LE.0.1)WRITE(2,7011)NAMX(9)
IF(QXX1.LE.15.AND.YZZ(10).GT.0.1.AND.YZZ(10).LE.0.2)WRITE(2,7010)N
&AMX(10)
IF(QXX1.LE.15.AND.YZZ(10).LE.0.1)WRITE(2,7011)NAMX(10)
C
DO 5117 J=1,18
ANG= 180+(10*180*(J-1))/18
ANGL=(6*180*(J-1))/18
ANGM=(2*180*(J-1))/18
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720.AND.ANG.LT.1080)RL= ABS(PHI(2)+720-ANG)
IF(ANG.GE.1080.AND.ANG.LT.1440)RL= ABS(PHI(2)+1080-ANG)
IF(ANG.GE.1440.AND.ANG.LT.1800)RL= ABS(PHI(2)+1440-ANG)
IF(ANG.GE.1800)RL= ABS(PHI(2)+1800-ANG)
RLL= ABS(PHI(3)-ANGL)
IF(ANGL.GE.360.AND.ANGL.LT.720)RLL= ABS(PHI(3)+360-ANGL)
IF(ANGL.GE.720.AND.ANGL.LT.1080)RLL= ABS(PHI(3)+720-ANGL)
IF(ANGL.GE.1080)RLL= ABS(PHI(3)+1080-ANGL)
RLM= ABS(PHI(4)-ANGM)
IF(ANGM.GE.360)RLM= ABS(PHI(4)+360-ANGM)
QX2(J)=RL+RLL+RLM
5117 CONTINUE
QXX2=15.03
DO 5992 J=1,18
IF(QX2(J).LE.15)QXX2=QX2(J)
5992 CONTINUE
IF(QXX2.LE.15.AND.YZZ(13).GT.0.1.AND.YZZ(13).LE.0.2)WRITE(2,7010)N
&AMX(13)
IF(QXX2.LE.15.AND.YZZ(13).LE.0.1)WRITE(2,7011)NAMX(13)
IF(QXX2.LE.15.AND.YZZ(14).GT.0.1.AND.YZZ(14).LE.0.2)WRITE(2,7010)N
&AMX(14)
IF(QXX2.LE.15.AND.YZZ(14).LE.0.1)WRITE(2,7011)NAMX(14)
ELSEIF(YZZ(8).LE.0.2.OR.YZZ(11).LE.0.2.OR.YZZ(12).LE.0.2.OR.YZZ(15
&).LE.0.2.OR.YZZ(16).LE.0.2)THEN
DO 5114 J=1,18
ANG= 180 + 5*180/18+(10*180*(J-1))/18
ANGL= 180 + 3*180/18+(6*180*(J-1))/18
ANGM=180/18+ (2*180*(J-1))/18
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720.AND.ANG.LT.1080)RL= ABS(PHI(2)+720-ANG)
IF(ANG.GE.1080.AND.ANG.LT.1440)RL= ABS(PHI(2)+1080-ANG)
IF(ANG.GE.1440.AND.ANG.LT.1800)RL= ABS(PHI(2)+1440-ANG)
IF(ANG.GE.1800)RL= ABS(PHI(2)+1800-ANG)
RLL= ABS(PHI(3)-ANGL)
IF(ANGL.GE.360.AND.ANGL.LT.720)RLL= ABS(PHI(3)+360-ANGL)
IF(ANGL.GE.720.AND.ANGL.LT.1080)RLL= ABS(PHI(3)+720-ANGL)
IF(ANGL.GE.1080)RLL= ABS(PHI(3)+1080-ANGL)
RLM= ABS(PHI(4)-ANGM)
IF(ANGM.GE.360)RLM= ABS(PHI(4)+360-ANGM)
QX(J)=RL+RLL+RLM
5114 CONTINUE
QXX=15.03
DO 5995 J=1,18
IF(QX(J).LE.15)QXX=QX(J)
5995 CONTINUE
IF(QXX.LE.15.AND.YZZ(8).GT.0.1.AND.YZZ(8).LE.0.2)WRITE(2,7010)NAMX
&(8)
IF(QXX.LE.15.AND.YZZ(8).LE.0.1)WRITE(2,7011)NAMX(8)
DO 5116 J=1,18
ANG= 5*180/18+(10*180*(J-1))/18
ANGL=180+ 3*180/18+(6*180*(J-1))/18
ANGM=180/18+(2*180*(J-1))/18
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720.AND.ANG.LT.1080)RL= ABS(PHI(2)+720-ANG)
IF(ANG.GE.1080.AND.ANG.LT.1440)RL= ABS(PHI(2)+1080-ANG)
IF(ANG.GE.1440.AND.ANG.LT.1800)RL= ABS(PHI(2)+1440-ANG)
IF(ANG.GE.1800)RL= ABS(PHI(2)+1800-ANG)
RLL= ABS(PHI(3)-ANGL)
IF(ANGL.GE.360.AND.ANGL.LT.720)RLL= ABS(PHI(3)+360-ANGL)
IF(ANGL.GE.720.AND.ANGL.LT.1080)RLL= ABS(PHI(3)+720-ANGL)
IF(ANGL.GE.1080)RLL= ABS(PHI(3)+1080-ANGL)
RLM= ABS(PHI(4)-ANGM)
IF(ANGM.GE.360)RLM= ABS(PHI(4)+360-ANGM)
QX3(J)=RL+RLL+RLM
5116 CONTINUE
QXX3=15.03
DO 5993 J=1,18
IF(QX3(J).LE.15)QXX3=QX3(J)
5993 CONTINUE
IF(QXX3.LE.15.AND.YZZ(11).GT.0.1.AND.YZZ(11).LE.0.2)WRITE(2,7010)N
&AMX(11)
IF(QXX3.LE.15.AND.YZZ(11).LE.0.1)WRITE(2,7011)NAMX(11)
IF(QXX3.LE.15.AND.YZZ(12).GT.0.1.AND.YZZ(12).LE.0.2)WRITE(2,7010)N
&AMX(12)
IF(QXX3.LE.15.AND.YZZ(12).LE.0.1)WRITE(2,7011)NAMX(12)
DO 5118 J=1,18
ANG= 5*180/18+180+(10*180*(J-1))/18
ANGL= 3*180/18+(6*180*(J-1))/18
ANGM=180/18+(2*180*(J-1))/18
RL= ABS(PHI(2)-ANG)
IF(ANG.GE.360.AND.ANG.LT.720)RL= ABS(PHI(2)+360-ANG)
IF(ANG.GE.720.AND.ANG.LT.1080)RL= ABS(PHI(2)+720-ANG)
IF(ANG.GE.1080.AND.ANG.LT.1440)RL= ABS(PHI(2)+1080-ANG)
IF(ANG.GE.1440.AND.ANG.LT.1800)RL= ABS(PHI(2)+1440-ANG)
IF(ANG.GE.1800)RL= ABS(PHI(2)+1800-ANG)
RLL= ABS(PHI(3)-ANGL)
IF(ANGL.GE.360.AND.ANGL.LT.720)RLL= ABS(PHI(3)+360-ANGL)
IF(ANGL.GE.720.AND.ANGL.LT.1080)RLL= ABS(PHI(3)+720-ANGL)
IF(ANGL.GE.1080)RLL= ABS(PHI(3)+1080-ANGL)
RLM= ABS(PHI(4)-ANGM)
IF(ANGM.GE.360)RLM= ABS(PHI(4)+360-ANGM)
QX4(J)=RL+RLL+RLM
5118 CONTINUE
QXX4=15.03
DO 5991 J=1,18
IF(QX4(J).LE.15)QXX4=QX4(J)
5991 CONTINUE
IF(QXX4.LE.15.AND.YZZ(15).GT.0.1.AND.YZZ(15).LE.0.2)WRITE(2,7010)N
&AMX(15)
IF(QXX4.LE.15.AND.YZZ(15).LE.0.1)WRITE(2,7011)NAMX(15)
IF(QXX4.LE.15.AND.YZZ(16).GT.0.1.AND.YZZ(16).LE.0.2)WRITE(2,7010)N
&AMX(16)
IF(QXX4.LE.15.AND.YZZ(16).LE.0.1)WRITE(2,7011)NAMX(16)
ELSE
DO 5000 I=1,4
IF(YZZ(I).LE.0.2.AND.YZZ(I).GT.0.1)WRITE(2,7010)NAMX(I)
IF(YZZ(I).LE.0.1)WRITE(2,7011)NAMX(I)
5000 CONTINUE
ENDIF
7011 FORMAT(/,5X,'WARNING:THIS IS A ',A4,' FORM')
7010 FORMAT(/,5X,'WARNING:THIS IS VERY SIMILAR TO A ',A4,' FORM')
5001 ENDIF
4994 RETURN
END
SUBROUTINE LARGE(Q,PHI,N,NR,R)
C
C ********************************************************
C THIS SUBROUTINE FINDS THE PRIMITIVE FORMS OF EVEN RINGS
C WITH MORE THAN 10 RING ATOMS
C ********************************************************
DIMENSION Q(20),PHI(20),XA(20),XB(20),XXA(20),XXB(20)
REAL K(50),L(50),KMIN(50),LMIN(50)
C
IF (R.LE.0)THEN
AA=-1.0
ELSE
AA=1.0
ENDIF
V=ABS(R)
C
IF(NR.EQ.10)THEN
DO 286 M=2,N
DO 285 I=1,11
K(I)=4*(I-1)
L(I)=4*(I-1)+2
285 CONTINUE
NXN=11
CALL MINI(NXN,K,KMIN(M),NR,PHI(M))
CALL MINI(NXN,L,LMIN(M),NR,PHI(M))
286 CONTINUE
CALL SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
CALL WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
WRITE(2,118)NR/2,VV,AA
118 FORMAT(5X,I2,8X,F5.3,8X,F4.1)
ELSEIF(NR.EQ.12)THEN
DO 296 M=2,N
IF(M.EQ.3)THEN
DO 300 I=1,3
K(I)=24*(I-1)
L(I)=24*(I-1)+12
300 CONTINUE
NZX=3
ELSE
DO 295 I=1,13
K(I)=8*(I-1)
L(I)=8*(I-1)+4
295 CONTINUE
NZX=13
ENDIF
CALL MINI(NZX,K,KMIN(M),NR,PHI(M))
CALL MINI(NZX,L,LMIN(M),NR,PHI(M))
296 CONTINUE
CALL SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
CALL WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
WRITE(2,117)NR/2,VV,AA
117 FORMAT(5X,I2,8X,F5.3,8X,F4.1)
ELSEIF(NR.EQ.14)THEN
DO 302 M=2,N
DO 303 I=1,15
K(I)=4*(I-1)
L(I)=4*(I-1)+2
303 CONTINUE
NXC=15
CALL MINI(NXC,K,KMIN(M),NR,PHI(M))
CALL MINI(NXC,L,LMIN(M),NR,PHI(M))
302 CONTINUE
CALL SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
CALL WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
WRITE(2,111)NR/2,VV,AA
111 FORMAT(5X,I2,8X,F5.3,8X,F4.1)
ELSEIF(NR.EQ.16)THEN
DO 309 M=2,N
IF(M.EQ.2.OR.M.EQ.6)THEN
DO 393 I=1,5
K(I)=16*(I-1)
L(I)=16*(I-1)+8
393 CONTINUE
NXC=5
ELSEIF(M.EQ.4)THEN
DO 373 I=1,3
K(I)=32*(I-1)
L(I)=32*(I-1)+16
373 CONTINUE
NXC=3
ELSE
DO 383 I=1,9
K(I)=8*(I-1)
L(I)=8*(I-1)+4
383 CONTINUE
NXC=9
ENDIF
CALL MINI(NXC,K,KMIN(M),NR,PHI(M))
CALL MINI(NXC,L,LMIN(M),NR,PHI(M))
309 CONTINUE
CALL SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
CALL WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
WRITE(2,151)NR/2,VV,AA
151 FORMAT(5X,I2,8X,F5.3,8X,F4.1)
ELSE
DO 509 M=2,N
IF(M.EQ.3.OR.M.EQ.6)THEN
DO 593 I=1,7
K(I)=12*(I-1)
L(I)=12*(I-1)+6
593 CONTINUE
NYC=7
ELSE
DO 573 I=1,19
K(I)=4*(I-1)
L(I)=4*(I-1)+2
573 CONTINUE
NYC=19
ENDIF
CALL MINI(NYC,K,KMIN(M),NR,PHI(M))
CALL MINI(NYC,L,LMIN(M),NR,PHI(M))
509 CONTINUE
CALL SOLVE(Q,KMIN,LMIN,N,NR,PHI,XA,XB)
CALL WRITES(N,XA,XB,V,KMIN,LMIN,XXA,XXB,VV)
WRITE(2,551)NR/2,VV,AA
551 FORMAT(5X,I2,8X,F5.3,8X,F4.1)
ENDIF
RETURN
END
|
