1 SUBROUTINE DENROT 2 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3 INCLUDE 'SIZES' 4 COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) 5 COMMON /GEOM / GEO(3,NUMATM), XCOORD(3,NUMATM) 6 COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 7 1 NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA, 8 2 NCLOSE,NOPEN,NDUMY,FRACT 9 COMMON /ELEMTS/ ELEMNT(107) 10 COMMON /SCRACH/ B(MAXORB*MAXORB), BONDAB(MAXPAR**2-MAXORB*MAXORB) 11************************************************************************ 12* 13* DENROT PRINTS THE DENSITY MATRIX AS (S-SIGMA, P-SIGMA, P-PI) RATHER 14* THAN (S, PX, PY, PZ). 15* 16************************************************************************ 17 DIMENSION AROT(9,9), C(3,5,5), PAB(9,9), VECT(9,9) 18 DIMENSION NATOM(MAXORB) 19 DIMENSION XYZ(3,NUMATM), IROT(5,35), ISP(9) 20 CHARACTER * 6 LINE(21) 21 CHARACTER ELEMNT*2,ATORBS(9)*7,ITEXT(MAXORB)*7,JTEXT(MAXORB)*2 22 SAVE ATORBS, IROT, ISP 23 DATA ATORBS/'S-SIGMA','P-SIGMA',' P-PI ',' P-PI ','D-SIGMA', 24 1 ' D-PI ',' D-PI ',' D-DELL',' D-DELL'/ 25*********************************************************************** 26* IROT IS A MAPPING LIST. FOR EACH ELEMENT OF AROT 5 NUMBERS ARE 27* NEEDED. THESE ARE, IN ORDER, FIRST AND SECOND SUBSCRIPTS OF AROT, 28* AND FIRST,SECOND, AND THIRD SUBSCRIPTS OF C, THUS THE FIRST 29* LINE OF IROT DEFINES AROT(1,1)=C(1,3,3) 30* 31*********************************************************************** 32 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, 33 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, 34 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, 35 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, 36 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, 37 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, 38 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/ 39 DATA ISP /1,2,3,3,4,5,5,6,6/ 40 CALL GMETRY(GEO,XYZ) 41 IPRT=0 42 DO 120 I=1,NUMAT 43 IF=NFIRST(I) 44 IL=NLAST(I) 45 IPQ=IL-IF-1 46 II=IPQ+2 47 IF(II.EQ.0)GOTO 120 48 DO 10 I1=1,II 49 J1=IPRT+ISP(I1) 50 ITEXT(J1)=ATORBS(I1) 51 JTEXT(J1)=ELEMNT(NAT(I)) 52 NATOM(J1)=I 53 10 CONTINUE 54 IPRT=J1 55 IF(IPQ.NE.2)IPQ=MIN(MAX(IPQ,1),3) 56 DO 110 J=1,I 57 JF=NFIRST(J) 58 JL=NLAST(J) 59 JPQ=JL-JF-1 60 JJ=JPQ+2 61 IF(JJ.EQ.0)GOTO 110 62 IF(JPQ.NE.2)JPQ=MIN(MAX(JPQ,1),3) 63 DO 20 I1=1,9 64 DO 20 J1=1,9 65 20 PAB(I1,J1)=0.D0 66 KK=0 67 DO 30 K=IF,IL 68 KK=KK+1 69 LL=0 70 DO 30 L=JF,JL 71 LL=LL+1 72 30 PAB(KK,LL)=P(L+(K*(K-1))/2) 73 CALL COE(XYZ(1,I),XYZ(2,I),XYZ(3,I), 74 1 XYZ(1,J),XYZ(2,J),XYZ(3,J),IPQ,JPQ,C,R) 75 DO 40 I1=1,9 76 DO 40 J1=1,9 77 40 AROT(I1,J1)=0.D0 78 DO 50 I1=1,35 79 50 AROT(IROT(1,I1),IROT(2,I1))= 80 1 C(IROT(3,I1),IROT(4,I1),IROT(5,I1)) 81 L1=ISP(II) 82 L2=ISP(JJ) 83 DO 60 I1=1,9 84 DO 60 J1=1,9 85 60 VECT(I1,J1)=-1.D0 86 DO 70 I1=1,L1 87 DO 70 J1=1,L2 88 70 VECT(I1,J1)=0.D0 89 IF(I.NE.J) THEN 90 IJ=MAX(II,JJ) 91 DO 90 I1=1,II 92 DO 90 J1=1,JJ 93 SUM=0.D0 94 DO 80 L1=1,IJ 95 DO 80 L2=1,IJ 96 80 SUM=SUM+AROT(L1,I1)*PAB(L1,L2)*AROT(L2,J1) 97 90 VECT(ISP(I1),ISP(J1))= 98 1 VECT(ISP(I1),ISP(J1))+SUM**2 99 ENDIF 100 K=0 101 DO 100 I1=IF,IL 102 K=K+1 103 L=0 104 DO 100 J1=JF,JL 105 L=L+1 106 100 IF(J1.LE.I1) B(J1+(I1*(I1-1))/2)=VECT(K,L) 107 110 CONTINUE 108 120 CONTINUE 109C 110C NOW TO REMOVE ALL THE DEAD SPACE IN P, CHARACTERIZED BY -1.0 111C 112 LINEAR=(NORBS*(NORBS+1))/2 113 L=0 114 DO 130 I=1,LINEAR 115 IF(B(I).GT.-0.1) THEN 116 L=L+1 117 B(L)=B(I) 118 ENDIF 119 130 CONTINUE 120C 121C PUT ATOMIC ORBITAL VALENCIES ONTO THE DIAGONAL 122C 123 DO 160 I=1,IPRT 124 SUM=0.D0 125 II=(I*(I-1))/2 126 DO 140 J=1,I 127 140 SUM=SUM+B(J+II) 128 DO 150 J=I+1,IPRT 129 150 SUM=SUM+B((J*(J-1))/2+I) 130 160 B((I*(I+1))/2)=SUM 131 DO 170 I=1,21 132 170 LINE(I)='------' 133 LIMIT=(IPRT*(IPRT+1))/2 134 KK=8 135 NA=1 136 180 LL=0 137 M=MIN0((IPRT+1-NA),6) 138 MA=2*M+1 139 M=NA+M-1 140 WRITE(6,'(/16X,10(1X,A7,3X))')(ITEXT(I),I=NA,M) 141 WRITE(6,'(15X,10(2X,A2,I3,4X))')(JTEXT(I),NATOM(I),I=NA,M) 142 WRITE (6,'(20A6)') (LINE(K),K=1,MA) 143 DO 200 I=NA,IPRT 144 LL=LL+1 145 K=(I*(I-1))/2 146 L=MIN0((K+M),(K+I)) 147 K=K+NA 148 IF ((KK+LL).LE.50) GO TO 190 149 WRITE (6,'(''1'')') 150 WRITE(6,'(/17X,10(1X,A7,3X))')(ITEXT(N),N=NA,M) 151 WRITE(6,'( 17X,10(2X,A2,I3,4X))')(JTEXT(N),NATOM(N),N=NA,M) 152 WRITE (6,'(20A6)') (LINE(N),N=1,MA) 153 KK=4 154 LL=0 155 190 WRITE (6,'(1X,A7,1X,A2,I3,10F11.6)') 156 1 ITEXT(I),JTEXT(I),NATOM(I),(B(N),N=K,L) 157 200 CONTINUE 158 IF (L.GE.LIMIT) GO TO 210 159 KK=KK+LL+4 160 NA=M+1 161 IF ((KK+IPRT+1-NA).LE.50) GO TO 180 162 KK=4 163 WRITE (6,'(''1'')') 164 GO TO 180 165 210 RETURN 166 END 167