1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
SUBROUTINE DIMOID(DEN,RLMO,SSQU,STRI,ATMU,IATM,IWHI,MAPT,INAT,
* IATB,L1,L2,M1,M2,NATS,NOSI,NCAT,NSWE)
C
IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
DIMENSION RLMO(L1,L1),SSQU(L1,L1),STRI(L2),ATMU(NATS),DEN(M2)
DIMENSION IATM(NATS,M1),IWHI(M1+NATS),MAPT(M1),INAT(M1+NATS)
DIMENSION IATB(NATS,M1)
C
PARAMETER (MXATM=500, MXSH=1000, MXGTOT=5000, MXAO=2047)
C
LOGICAL GOPARR,DSKWRK,MASWRK
C
COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
* ZAN(MXATM),C(3,MXATM)
COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(400)
COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
* CF(MXGTOT),CG(MXGTOT),
* KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),
* KNG(MXSH),KLOC(MXSH),KMIN(MXSH),
* KMAX(MXSH),NSHELL
COMMON /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB,
* MOOUTA(MXAO),MOOUTB(MXAO)
COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
C
C
DO 920 II=1,M1
INAT(II) = 0
920 CONTINUE
C
DO 900 IO = NOUTA+1,NUMLOC
IZ = IO - NOUTA
DO 895 II=NST,NEND
ATMU(II) = 0.0D+00
IATM(II,IZ) = 0
895 CONTINUE
IFUNC = 0
DO 890 ISHELL = 1,NSHELL
IAT = KATOM(ISHELL)
IST = KMIN(ISHELL)
IEN = KMAX(ISHELL)
DO 880 INO = IST,IEN
IFUNC = IFUNC + 1
IF (IAT.LT.NST.OR.IAT.GT.NEND) GOTO 880
ZINT = 0.0D+00
DO 870 II = 1,L1
ZINT = ZINT + RLMO(II,IO)*SSQU(II,IFUNC)
870 CONTINUE
ATMU(IAT) = ATMU(IAT) + RLMO(IFUNC,IO)*ZINT
880 CONTINUE
890 CONTINUE
IF (MASWRK) WRITE(IW,9010) IZ,(ATMU(II),II=NST,NEND)
900 CONTINUE
C
NOSI = 0
DO 700 II=1,M1
NO=0
DO 720 JJ=1,NAT
NO = NO + 1
720 CONTINUE
740 CONTINUE
IF (NO.GT.1.OR.NO.EQ.0) THEN
NOSI = NOSI + 1
IWHI(NOSI) = II
ENDIF
IF (MASWRK)
* WRITE(IW,9030) II,(IATM(J,II),A(IATM(J,II)),J=1,NO)
700 CONTINUE
C
IF (MASWRK) THEN
WRITE(IW,9035) NOSI
IF (NOSI.GT.0) THEN
WRITE(IW,9040) (IWHI(I),I=1,NOSI)
WRITE(IW,9040)
ELSE
WRITE(IW,9040)
ENDIF
ENDIF
C
CALL DCOPY(L1*L1,RLMO,1,SSQU,1)
CALL DCOPY(M2,DEN,1,STRI,1)
C
IP2 = NOUTA
IS2 = M1+NOUTA-NOSI
DO 695 II=1,NAT
INAT(II) = 0
695 CONTINUE
C
DO 690 IAT=1,NAT
DO 680 IORB=1,M1
IP1 = IORB + NOUTA
IF (IATM(1,IORB).NE.IAT) GOTO 680
IF (IATM(2,IORB).NE.0) GOTO 680
INAT(IAT) = INAT(IAT) + 1
IP2 = IP2 + 1
CALL DCOPY(L1,SSQU(1,IP1),1,RLMO(1,IP2),1)
CALL ICOPY(NAT,IATM(1,IORB),1,IATB(1,IP2-NOUTA),1)
MAPT(IORB) = IP2-NOUTA
680 CONTINUE
DO 670 IORB=1,NOSI
IS1 = IWHI(IORB) + NOUTA
IF (IAT.EQ.NAT.AND.IATM(1,IWHI(IORB)).EQ.0) GOTO 675
IF (IATM(1,IWHI(IORB)).NE.IAT) GOTO 670
675 CONTINUE
IS2 = IS2 + 1
MAPT(IWHI(IORB)) = IS2-NOUTA
670 CONTINUE
690 CONTINUE
C
NSWE = 0
NCAT = 0
LASP = 1
NLAST = 0
DO 620 II=1,NAT
NSWE = NSWE + (IWHI(II)*(IWHI(II)-1))/2
NCAT = NCAT + 1
INAT(NCAT) = LASP + NLAST
LASP = INAT(NCAT)
NLAST = IWHI(II)
IWHI(NCAT) = II
620 CONTINUE
C
DO 610 II=1,NOSI
NCAT = NCAT + 1
INAT(NCAT) = LASP + NLAST
LASP = INAT(NCAT)
NLAST = 1
IWHI(NCAT) = 0
610 CONTINUE
C
RETURN
C
8000 FORMAT(/1X,'** MULLIKEN ATOMIC POPULATIONS FOR EACH NON-FROZEN ',
* 'LOCALIZED ORBITAL **')
9000 FORMAT(/3X,'ATOM',2X,100(I2,1X,A4))
9005 FORMAT(1X,'LMO')
9010 FORMAT(1X,I3,3X,100F7.3)
9015 FORMAT(/1X,'** ATOMIC POPULATIONS GREATER THAN ',F4.2,
* ' ARE CONSIDERED MAJOR **')
9020 FORMAT(/2X,'LMO',3X,'MAJOR CONTRIBUTIONS FROM ATOM(S)')
9030 FORMAT(2X,I3,2X,100(I2,1X,A2,2X))
9035 FORMAT(/1X,'NO OF LMOS INVOLVING MORE THAN ONE ATOM =',I3)
9040 FORMAT(1X,'THESE ARE LMOS :',100I3)
C
END
|
