pr32663.f

来自「用于进行gcc测试」· F 代码 · 共 148 行

      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