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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [compile/] [pr32663.f] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 303 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.