C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C PLAN - PROGRAM TO CHECK THE AGREEMENT OF CONSTANTS DETERMINED C FOR A PLANAR TOP WITH THE QUADRATIC, QUARTIC AND SEXTIC C PLANARITY RELATIONS. C For Watson's Hamiltonian in reduction-A, representation I.r C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c C formulae+tests: J.K.G.Watson, J.Mol.Spec. 65, 123 (1977) C more tests: Z.Kisiel, L.Pszczolkowski, Z.Naturforsch. 50a, 347 (1995) c C C ver. 5a/1995 ----- 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 C Constants are to be input in the .CON format used by ASROT, i.e.: C C......NCON = 15 C A = 49850.68907 C B = 4971.212817 C C = 4513.828233 C DJ = .002243057 C DJK = -.08541195 C DK = 2.714735 C dJ = .000456701 C dK = .0245270 C HJ = .000000005865 C HJK = -.0000001441 C HKJ = -.000007574 C HK = .00037551 C hJ = .000000002132 C hJK = .0000002247 C hK = .00002415 C C Optionally errors on constants may be included after the 37th column c and sextic constants may be omitted if not available C C Output is appended to file PLAN.OUT C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c IMPLICIT REAL*8 (A-H,O-Z) REAL*8 AA(15),AACALC(15),AADIF(15),KAPPA,eraa(15) CHARACTER*30 FILNAM CHARACTER*6 ISTP(15),DUMMY INTEGER INDX(11) EQUIVALENCE (AA(1),A),(AA(2),B),(AA(3),C),(AA(4),DJ), * (AA(5),DJK),(AA(6),DK),(AA(7),DDJ),(AA(8),DDK), * (AA(9),HJ),(AA(10),HJK),(AA(11),HKJ),(AA(12),HK), * (AA(13),HHJ),(AA(14),HHJK),(AA(15),HHK) EQUIVALENCE (erAA(1),erA),(erAA(2),erB),(erAA(3),erC), * (erAA(4),erDJ),(erAA(5),erDJK),(erAA(6),erDK), * (erAA(7),erDDJ),(erAA(8),erDDK), * (erAA(9),erHJ),(erAA(10),erHJK),(erAA(11),erHKJ), * (erAA(12),erHK), * (erAA(13),erHHJ),(erAA(14),erHHJK),(erAA(15),erHHK) DATA ISTP/'A =','B =','C =',' DJ =',' DJK =', 1 ' DK =',' dJ =',' dK ', 1 'HJ =','HJK =','HKJ =','HK =','hJ =','hJK =', 1 'hK ='/ DATA INDX/1,2,3,4,7,5,8,9,13,10,14/ CON=505379.07D0 C WRITE(*,1) 1 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | PLAN - CHECK OF CONSISTENCY OF PLANAR TOP CONSTANTS ', * 'WITH',T79,'|'/ * ' | PLANARITY RELATIONS', * T79,'|'/ * ' |',76(1H_),'|'/' version 5a/1995',T64,'Zbigniew KISIEL'//) C 2908 WRITE(*,6855) 6855 FORMAT(/' NAME OF FILE CONTAINING CONSTANTS (ENTER to exit): '\) 2909 READ(*,'(A)',ERR=2908)FILNAM if(filnam(1:1).eq.' ')stop OPEN(3,FILE=FILNAM,ERR=2908,status='old') READ(3,6866,ERR=2908)DUMMY,NCONST 6866 FORMAT(A7,I5) IF(NCONST.GT.15)NCONST=15 DO 6856 I=1,NCONST 2911 READ(3,6867,ERR=2910)DUMMY,AA(I),eraa(i) 6867 FORMAT(A7,2F30.12) GOTO 6856 2910 WRITE(*,'(1X/1X,A,''ERROR IN CONSTANT '',A)')CHAR(7),ISTP(I) stop 6856 CONTINUE open(4,file='plan.out',access='append') C IF(NCONST.EQ.15)GOTO 2 DO 3 I=NCONST+1,15 AA(I)=0.D0 3 CONTINUE C C...quadratic planarity relation C 2 AACALC(1)=B*C/(B-C) AACALC(2)=A*C/(A-C) AACALC(3)=A*B/(A+B) defect=CON/C-CON/B-CON/A c dera=con/a**2 derb=con/b**2 derc=-con/c**2 erdef=dera**2*era**2+derb**2*erb**2+derc**2*erc**2 erdef=dsqrt(erdef) C C...quartic planarity relation C BC=B-C ABC=2.D0*A+B+C C AACALC(4)=(BC*(DJK-2.D0*DDK)+2.D0*ABC*DDJ)/(4.D0*C) AACALC(5)=(4.D0*C*DJ-BC*(DJK-2.D0*DDK))/(2.D0*ABC) AACALC(6)=2.D0*DDK+(4.D0*C*DJ-2.D0*ABC*DDJ)/BC AACALC(7)=0.5D0*DJK-(2.D0*C*DJ-ABC*DDJ)/BC c qdefect=4.D0*C*DJ-BC*DJK+2.D0*BC*DDK-2.D0*ABC*DDJ c qdef=4*c*dj-(b-c)*djk-2*(2*a+b+c)*ddj+2*(b-c)*ddk dera=-4*ddj derb=-2*ddj+2*ddk-djk derc=-2*ddj-2*ddk+4*dj+djk derdj=4*c derdjk=c-b derhhj=-4*a-2*b-2*c derddk=2*b-2*c erqdef=dera**2*era**2+derb**2*erb**2+derc**2*erc**2+ * derdj**2*erdj**2+derdjk**2*erdjk**2+derddj**2*erddj**2+ * derddk**2*erddk**2 erqdef=dsqrt(erqdef) c C C...sextic planarity relation C ABC1=2.D0*A+B+3.D0*C QUART=4.D0*DJ**2-4.D0*DDJ*(4.D0*DJ+DJK-2.D0*DDJ-2.D0*DDK) C AACALC(8)=(BC*(HJK-2.D0*HHJK)+2.D0*ABC1*HHJ-QUART)/(6.D0*C) AACALC(9)=(6.D0*C*HJ-BC*(HJK-2.D0*HHJK)+QUART)/(2.D0*ABC1) AACALC(10)=(6.D0*C*HJ-2.D0*ABC1*HHJ+QUART)/BC+2.D0*HHJK AACALC(11)=0.5D0*HJK-(3.D0*C*HJ-ABC1*HHJ+0.5D0*QUART)/BC sdefect=6.D0*C*HJ-BC*HJK-2.D0*ABC1*HHJ+2.D0*BC*HHJK+QUART c sdef=6*c*hj-(b-c)*hjk-2*(2*a+b+3*c)*hhj+2*(b-c)*hhjk+ * 4*(dj)**2-4*ddj*(4*dj+djk-2*ddj-2*ddk) dera=-4*hhj derb=-2*hhj+2*hhjk-hjk derc=-6*hhj-2*hhjk+6*hj+hjk derdj=-8*(2*ddj-dj) derdjk=-4*ddj derddj=4*(4*ddj+2*ddk-4*dj-djk) derddk=8*ddj derhj=6*c derhjk=c-b derhhj=-4*a-2*b-6*c dehhjk=2*b-2*c ersdef=dera**2*era**2+derb**2*erb**2+derc**2*erc**2+ * derdj**2*erdj**2+derdjk**2*erdjk**2+derddj**2*erddj**2+ * derddk**2*erddk**2+derhj**2*erhj**2+derhjk**2*erhjk**2+ * derhhj**2*erhhj**2+dehhjk**2*erhhjk**2 ersdef=dsqrt(ersdef) C c...higher planarity defects for reduction S, representation III.r c c abc3=a+b+2.0d0*c c qdefs3=4.D0*C*DJ+ABC3*DJK+2.D0*(a+b)*DK-2.D0*(a-b)*ddj c sdefs3=6*c*hj+(a+b+4.d0*c)*hjk+2*(a+b+c)*hkj+3*(a+b)*hk+ c * 2*(a-b)*hhj+(2.d0*dj+djk)*(2.d0*dj+3.d0*djk-4.d0*dk)+ c * 4.d0*ddj**2 c c c DO 5 I=1,11 J=INDX(I) IF(AA(J).EQ.0.D0)GOTO 5 AADIF(I)=(AA(J)-AACALC(I))/AA(J)*100.D0 5 CONTINUE C KAPPA=(2.D0*B-A-C)/(A-C) SUMI=CON*(1.D0/A+1.D0/B+1.D0/C) c WRITE(*,6) write(4,'(/1x,a)')filnam WRITE(4,6) 6 FORMAT(1X/' CONSTANT OBS CALC from', * ' planarity OBS-CALC (%)'/) DO 7 I=1,11 J=INDX(I) WRITE(*,8)ISTP(J),AA(J),AACALC(I),AADIF(I) WRITE(4,8)ISTP(J),AA(J),AACALC(I),AADIF(I) 7 CONTINUE 8 FORMAT(1X,A,3X,3F22.12) c WRITE(*,9)defect,erdef,qdef,erqdef,sdef,ersdef,KAPPA,SUMI WRITE(4,9)defect,erdef,qdef,erqdef,sdef,ersdef,KAPPA,SUMI 9 FORMAT(1X/ ' INERTIA DEFECT = ',F20.10,' +-',F20.10,' u A**2'/ * ' QUARTIC DEFECT = ',F20.10,' +-',F20.10,' MHz**2'/ * ' SEXTIC DEFECT = ',F20.10,' +-',F20.10,' MHz**2'/ * ' KAPPA = ',F15.6/ * ' SUM OF I''S = ',F15.6/) write(4,14)4*c*dj/qdef,-(b-c)*djk/qdef,-2*(2*a+b+c)*ddj/qdef, * +2*(b-c)*ddk/qdef write(4,12)6.D0*C*HJ/sdef,-BC*HJK/sdef,-2.D0*ABC1*HHJ/sdef, * +2.D0*BC*HHJK/sdef, * 4.D0*DJ**2/sdef,-4.D0*DDJ*(4.D0*DJ+DJK-2.D0*DDJ-2.D0*DDK)/sdef write(*,14)4*c*dj/qdef,-(b-c)*djk/qdef,-2*(2*a+b+c)*ddj/qdef, * +2*(b-c)*ddk/qdef write(*,12)6.D0*C*HJ/sdef,-BC*HJK/sdef,-2.D0*ABC1*HHJ/sdef, * +2.D0*BC*HHJK/sdef, * 4.D0*DJ**2/sdef,-4.D0*DDJ*(4.D0*DJ+DJK-2.D0*DDJ-2.D0*DDK)/sdef 12 format(' Terms in the sextic defect as a multiple of the total:' * /1x,6f10.4) 14 format(' Terms in the quartic defect as a multiple of the total:' * /1x,6f10.4) C if(dj.ne.0.d0)then term1=qdef/(4.d0*c*dj) eterm1=dsqrt( $ (c**2*(dj**2*erqdef**2+erdj**2*qdef**2)+dj**2*erc**2*qdef**2)/ $ (16*c**4*dj**4) ) else term1=0.d0 eterm1=0.d0 endif if(hj.ne.0.d0)then term2=sdef/(6.D0*C*HJ) eterm2=dsqrt( $ (c**2*(erhj**2*sdef**2+ersdef**2*hj**2)+erc**2*hj**2*sdef**2)/ $ (36*c**4*hj**4) ) else term2=0.d0 eterm2=0.d0 endif write(4,31)term1,eterm1,term2,eterm2 31 format(1x/' d.q / 4 C D.J = ',f10.6,' +-',f10.6/ * ' d.s / 6 C H.J = ',f10.6,' +-',f10.6) c c write(4,30)qdefs3,sdefs3 c30 format(1x/' Inertia defects for reduction-S, repr.-IIIr:'/ c * ' quartic =',f20.10/ c * ' sextic =',f20.10) write(4,'(1x,78(1h-))') write(*,'(65x,''Press ENTER '',$)') read(*,'(i1)',err=15)i close(3) close(4) goto 2908 C 15 STOP END C C----------------------------------------------------------------------------- C-----------------------------------------------------------------------------