URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [compile/] [pr32663.f] - Rev 303
Compare with Previous | Blame | 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