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


      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

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`

Browse

Tools

Subversion Repositories openrisc

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