mopac606_nbo/src/partxy.f

   1       SUBROUTINE PARTXY(C34,PQ34)
   2       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
   3       INCLUDE 'SIZES'
   4       DIMENSION C34(*),PQ34(*)
   5       COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
   6      1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
   7      2                NCLOSE,NOPEN,NDUMY,FRACT
   8       COMMON /WMATRX/ WJ(N2ELEC), WK(N2ELEC)
   9      1       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107)
  10      2               ,GSD(107),GPD(107),GDD(107)
  11      3       /KEYWRD/ KEYWRD
  12       COMMON /NUMCAL/ NUMCAL
  13       DIMENSION W(N2ELEC*2)
  14       EQUIVALENCE (W,WJ)
  15       REAL WJ, WK
  16       CHARACTER*241 KEYWRD
  17 C------------------------------------------------------------------
  18 C
  19 C    PARTXY WORKS OUT  IN MNDO FORMALISM THE FIRST 2-INDICES TRANSFO.
  20 C          REQUIRED IN THE COMPUTATION OF 2-ELECTRONS REPULSION OVER M.O
  21 C  INPUT
  22 C     C34   : VECTOR OF THE CURRENT CHARGE DISTRIBUTION BETWEEN TWO M.O.
  23 C  OUTPUT
  24 C     PQ34(PQ) : <P(1),Q(1)|C3(2),C4(2)> WHERE P ,Q  ARE A.O.
  25 C                                          AND C3,C4 ARE M.O.
  26 C                P AND Q RUN IN CANONICAL ORDER OVER THE A.O BELONGING
  27 C                TO AN ATOM 'A' ONLY (BASIC ASSUMPTION OF MNDO SCHEME)
  28 C                AND 'A' RUNS OVER THE ATOMS OF THE SYSTEM.
  29 C     D.L. (DEWAR GROUP) 1986
  30 C----------------------------------------------------------------------
  31       DIMENSION LD(9),PTOT(NUMATM), NB(0:8), INDX(NUMATM)
  32       DATA LD /0,2,5,9,14,20,27,35,44/
  33       DATA NB /1,0,0,10,0,0,0,0,45/
  34       DATA ICALCN/0/
  35       IF(NUMCAL.NE.ICALCN)THEN
  36          ICALCN=NUMCAL
  37          INDX(1)=1
  38          DO 10 I=2,NUMAT
  39    10    INDX(I)=INDX(I-1)+NB(NLAST(I-1)-NFIRST(I-1))
  40       ENDIF
  41 C     IJ    : POINTER OF CANONICAL PACKED LOCATION OF COUPLE IJ.
  42 C     KK    : POINTER OF SUPPORTING ATOM, SPARKLES SKIPPED OUT.
  43 C     IPQRS : CURRENT ENTRY POINT IN THE <PQ|RS> FILE.
  44       KK=0
  45       IPQRS=1
  46       IJ=0
  47       IJOLD=0
  48 C
  49 C     LOOP OVER OUTER ATOM A, SPARKLES EXCLUDED.
  50 C     ------------------------------------------
  51       NBAND=1
  52       KR=1
  53       LS=0
  54       DO 30 II=1,NUMAT
  55          IA=NFIRST(II)
  56          IB=NMIDLE(II)
  57          IC=NLAST (II)
  58          IF(IC.LT.IA) GO TO 30
  59          KK=KK+1
  60          LS=LS+NBAND
  61          NBAND=NB(IC-IA)
  62          IJ=IJ+NBAND
  63 C
  64 C     PQ34(IJ) = <IJ|KL> * C34(KL)  , 1-CENTRE CONTRIBUTIONS.
  65          IZN=NAT(II)
  66 C     BLOCK SS
  67          PTOT(KK)=C34(LS)
  68          PQ34(LS)=C34(LS)*GSS(IZN)*0.25D0
  69          IF(IB.GT.IA) THEN
  70 C        BLOCK SP AND PP
  71             HPP=0.5D0*(GPP(IZN)-GP2(IZN))
  72             LX=LS+LD(2)
  73             LY=LS+LD(3)
  74             LZ=LS+LD(4)
  75             PP=C34(LX)+C34(LY)+C34(LZ)
  76             PQ34(LS+1)=HSP(IZN)*C34(LS+1)
  77             PQ34(LX  )=GPP(IZN)*C34(LX  )*0.25D0
  78             PQ34(LS+3)=HSP(IZN)*C34(LS+3)
  79             PQ34(LS+4)=HPP     *C34(LS+4)
  80             PQ34(LY  )=GPP(IZN)*C34(LY  )*0.25D0
  81             PQ34(LS+6)=HSP(IZN)*C34(LS+6)
  82             PQ34(LS+7)=HPP     *C34(LS+7)
  83             PQ34(LS+8)=HPP     *C34(LS+8)
  84             PQ34(LZ  )=GPP(IZN)*C34(LZ  )*0.25D0
  85             GSPSS=     GSP(IZN)*C34(LS  )*0.25D0
  86             PQ34(LS)=PQ34(LS)+GSP(IZN)*PP*0.25D0
  87             PQ34(LX)=PQ34(LX)+GP2(IZN)*(C34(LY)+C34(LZ))*0.25D0+GSPSS
  88             PQ34(LY)=PQ34(LY)+GP2(IZN)*(C34(LZ)+C34(LX))*0.25D0+GSPSS
  89             PQ34(LZ)=PQ34(LZ)+GP2(IZN)*(C34(LX)+C34(LY))*0.25D0+GSPSS
  90             PTOT(KK)=PTOT(KK)+PP
  91             IF(IC.GT.IB) THEN
  92 C           BLOCK SD, PD AND DD
  93 C           --- WAITING FOR 'D' PARAMETERS ---
  94 C               TAKE CARE : DIAGONAL ELEMENTS OF C34 ARE DOUBLED.
  95             ENDIF
  96          ENDIF
  97          IF(KK.GT.1)THEN
  98 C
  99 C        LOOP OVER CHARGE DISTRIBUTION OF INNER ATOMS  B < A .
 100 C        -----------------------------------------------------
 101 C        PQ34(IJ)=<IJ|KL>*C34(KL) 2-CENTRES CONTRIBUTIONS.
 102 C
 103             JBAND=1
 104             JS=0
 105             DO 20 JJ=1,II-1
 106                JS=JS+JBAND
 107                JBAND=NB(NLAST(JJ)-NFIRST(JJ))
 108 C
 109 C   NBAND AND JBAND ARE EITHER 1 OR 10
 110 C
 111                CALL FORMXY
 112      1(W(KR), KR, PQ34(LS), PQ34(JS), C34(LS), NBAND, C34(JS), JBAND)
 113    20       IPQRS=IPQRS+IJOLD
 114          ENDIF
 115          IJOLD=IJ
 116    30 CONTINUE
 117       RETURN
 118       END