SUBROUTINE DENROT IMPLICIT DOUBLE PRECISION (A-H,O-Z) INCLUDE 'SIZES' COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) COMMON /GEOM / GEO(3,NUMATM) COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 1 NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 2 NCLOSE,NOPEN,NDUMY,FRACT COMMON /ELEMTS/ ELEMNT(107) COMMON /SCRACH/ B(MAXORB*MAXORB), BONDAB(MAXPAR**2-MAXORB*MAXORB) ************************************************************************ * * DENROT PRINTS THE DENSITY MATRIX AS (S-SIGMA, P-SIGMA, P-PI) RATHER * THAN (S, PX, PY, PZ). * ************************************************************************ DIMENSION AROT(9,9), C(3,5,5), PAB(9,9), VECT(9,9) DIMENSION NATOM(MAXORB) DIMENSION XYZ(3,NUMATM), IROT(5,35), ISP(9) CHARACTER * 6 LINE(21) CHARACTER ELEMNT*2,ATORBS(9)*7,ITEXT(MAXORB)*7,JTEXT(MAXORB)*2 SAVE ATORBS, IROT, ISP DATA ATORBS/'S-SIGMA','P-SIGMA',' P-PI ',' P-PI ','D-SIGMA', 1 ' D-PI ',' D-PI ',' D-DELL',' D-DELL'/ *********************************************************************** * IROT IS A MAPPING LIST. FOR EACH ELEMENT OF AROT 5 NUMBERS ARE * NEEDED. THESE ARE, IN ORDER, FIRST AND SECOND SUBSCRIPTS OF AROT, * AND FIRST,SECOND, AND THIRD SUBSCRIPTS OF C, THUS THE FIRST * LINE OF IROT DEFINES AROT(1,1)=C(1,3,3) * *********************************************************************** DATA IROT/1,1,1,3,3, 2,2,2,4,3, 3,2,2,2,3, 4,2,2,3,3, 2,3,2,4,2, 1 3,3,2,2,2, 4,3,2,3,2, 2,4,2,4,4, 3,4,2,2,4, 4,4,2,3,4, 2 5,5,3,1,5, 6,5,3,4,3, 7,5,3,3,3, 8,5,3,2,3, 9,5,3,5,3, 3 5,6,3,1,2, 6,6,3,4,2, 7,7,3,3,2, 8,6,3,2,2, 9,6,3,5,2, 4 5,7,3,1,4, 6,7,3,4,4, 7,7,3,3,4, 8,7,3,2,4, 9,7,3,5,4, 5 5,8,3,1,1, 6,8,3,4,1, 7,8,3,3,1, 8,8,3,2,1, 9,8,3,5,1, 6 5,9,3,1,5, 6,9,3,4,5, 7,9,3,3,5, 8,9,3,2,5, 9,9,3,5,5/ DATA ISP /1,2,3,3,4,5,5,6,6/ CALL GMETRY(GEO,XYZ) IPRT=0 DO 120 I=1,NUMAT IF=NFIRST(I) IL=NLAST(I) IPQ=IL-IF-1 II=IPQ+2 IF(II.EQ.0)GOTO 120 DO 10 I1=1,II J1=IPRT+ISP(I1) ITEXT(J1)=ATORBS(I1) JTEXT(J1)=ELEMNT(NAT(I)) NATOM(J1)=I 10 CONTINUE IPRT=J1 IF(IPQ.NE.2)IPQ=MIN(MAX(IPQ,1),3) DO 110 J=1,I JF=NFIRST(J) JL=NLAST(J) JPQ=JL-JF-1 JJ=JPQ+2 IF(JJ.EQ.0)GOTO 110 IF(JPQ.NE.2)JPQ=MIN(MAX(JPQ,1),3) DO 20 I1=1,9 DO 20 J1=1,9 20 PAB(I1,J1)=0.D0 KK=0 DO 30 K=IF,IL KK=KK+1 LL=0 DO 30 L=JF,JL LL=LL+1 30 PAB(KK,LL)=P(L+(K*(K-1))/2) CALL COE(XYZ(1,I),XYZ(2,I),XYZ(3,I), 1 XYZ(1,J),XYZ(2,J),XYZ(3,J),IPQ,JPQ,C,R) DO 40 I1=1,9 DO 40 J1=1,9 40 AROT(I1,J1)=0.D0 DO 50 I1=1,35 50 AROT(IROT(1,I1),IROT(2,I1))= 1 C(IROT(3,I1),IROT(4,I1),IROT(5,I1)) L1=ISP(II) L2=ISP(JJ) DO 60 I1=1,9 DO 60 J1=1,9 60 VECT(I1,J1)=-1.D0 DO 70 I1=1,L1 DO 70 J1=1,L2 70 VECT(I1,J1)=0.D0 IF(I.NE.J) THEN IJ=MAX(II,JJ) DO 90 I1=1,II DO 90 J1=1,JJ SUM=0.D0 DO 80 L1=1,IJ DO 80 L2=1,IJ 80 SUM=SUM+AROT(L1,I1)*PAB(L1,L2)*AROT(L2,J1) 90 VECT(ISP(I1),ISP(J1))= 1 VECT(ISP(I1),ISP(J1))+SUM**2 ENDIF K=0 DO 100 I1=IF,IL K=K+1 L=0 DO 100 J1=JF,JL L=L+1 100 IF(J1.LE.I1) B(J1+(I1*(I1-1))/2)=VECT(K,L) 110 CONTINUE 120 CONTINUE C C NOW TO REMOVE ALL THE DEAD SPACE IN P, CHARACTERIZED BY -1.0 C LINEAR=(NORBS*(NORBS+1))/2 L=0 DO 130 I=1,LINEAR IF(B(I).GT.-0.1) THEN L=L+1 B(L)=B(I) ENDIF 130 CONTINUE C C PUT ATOMIC ORBITAL VALENCIES ONTO THE DIAGONAL C DO 160 I=1,IPRT SUM=0.D0 II=(I*(I-1))/2 DO 140 J=1,I 140 SUM=SUM+B(J+II) DO 150 J=I+1,IPRT 150 SUM=SUM+B((J*(J-1))/2+I) 160 B((I*(I+1))/2)=SUM DO 170 I=1,21 170 LINE(I)='------' LIMIT=(IPRT*(IPRT+1))/2 KK=8 NA=1 180 LL=0 M=MIN0((IPRT+1-NA),6) MA=2*M+1 M=NA+M-1 WRITE(6,'(/16X,10(1X,A7,3X))')(ITEXT(I),I=NA,M) WRITE(6,'(15X,10(2X,A2,I3,4X))')(JTEXT(I),NATOM(I),I=NA,M) WRITE (6,'(20A6)') (LINE(K),K=1,MA) DO 200 I=NA,IPRT LL=LL+1 K=(I*(I-1))/2 L=MIN0((K+M),(K+I)) K=K+NA IF ((KK+LL).LE.50) GO TO 190 WRITE (6,'(''1'')') WRITE(6,'(/17X,10(1X,A7,3X))')(ITEXT(N),N=NA,M) WRITE(6,'( 17X,10(2X,A2,I3,4X))')(JTEXT(N),NATOM(N),N=NA,M) WRITE (6,'(20A6)') (LINE(N),N=1,MA) KK=4 LL=0 190 WRITE (6,'(1X,A7,1X,A2,I3,10F11.6)') 1 ITEXT(I),JTEXT(I),NATOM(I),(B(N),N=K,L) 200 CONTINUE IF (L.GE.LIMIT) GO TO 210 KK=KK+LL+4 NA=M+1 IF ((KK+IPRT+1-NA).LE.50) GO TO 180 KK=4 WRITE (6,'(''1'')') GO TO 180 210 RETURN END