| 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 |
