OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [compile/] [pr32663.f] - Blame information for rev 747

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.