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