C
C $Id: glbpnt.F,v 1.3 1998/07/16 16:39:58 jjv5 Exp arjan $
C
C------------------------------------------------------------------------
      SUBROUTINE GLBPNT(IERROR)
C
C     SETS UP POINTERS TO ACCESS DIATOMIC AND DIAGONAL BLOCKS OF
C     GLOBAL MATRICES.  SHOULD BE CALLED AFTER SUBSYSTEMS ARE DEFINED
C     AND THE BONDED ATOM PAIRLIST IS CREATED.
C
C     ERROR FLAG IS SET TO 1 IF STORAGE LIMITS FOR GLOBAL MATRICES
C     WOULD BE EXCEEDED.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
#include "divcon.dim"
#include "divcon.h"
C
      LOGICAL FIRST
      DATA FIRST /.TRUE./
      SAVE FIRST
C
      IERROR = 0
C
C     FIRST SET UP POINTERS FOR ENTIRE SYSTEM:
C
C
C     IIMAT(K) --> START OF DIAGONAL BLOCK IN HDIAG, PDIAG, AND FDIAG
C                  FOR ATOM K (ONLY NEEDS TO BE DETERMINED ONCE).
C
C     IJMAT(I) --> START OF DIATOMIC BLOCKS IN HDIAT, PDIAT, AND
C                  FDIAT FOR BONDED ATOM PAIRLIST ENTRY I.
C
C     IJREP(I) --> START OF DIATOMIC REPULSIONS IN EEREP FOR FULL
C                  PAIRLIST ENTRY I (DONE ONLY ONCE, AND ONLY IF
C                  IT'S NOT A DIRECT CALCULATION).
C
C
      IF(FIRST)THEN
C
C       ASSIGN IIMAT AND IJREP.
C
        FIRST = .FALSE.
        IIM = 1
        DO 10 I=1,NATOMS
          IIMAT(I) = IIM
          NORBSI = NATORB(IATNUM(I))
          IIM = IIM + (NORBSI*(NORBSI+1))/2
 10     CONTINUE
        IIMAT(NATOMS+1) = IIM
        IF(IIM-1.GT.MXDIAG)THEN
          IERROR = 1
          WRITE(IOUT,'(/" MAXIMUM STORAGE EXCEEDED FOR DIAGONAL BLOCKS",
     .                  " OF GLOBAL H, F, P MATRICES"/" -- INCREASE",
     .                  " MXDIAG PARAMETER IN divcon.dim TO AT LEAST ",
     .                  I6)') IIM
        ENDIF
C
C       ASSIGN IJREP IF IT'S NOT A DIRECT CALCULATION.  IJREP IS
C       BASED ON ALL POSSIBLE ATOM PAIRS.
C
        IF(.not.DIRECT.AND.NATOMS.GT.1)THEN
          IJR = 0
          IJPNT = 1
C
C         IJR COUNTS THE NUMBER OF NON-DUMMY ATOM PAIRS, AND IJPNT
C         COUNTS THE NUMBER OF TWO-CENTER, TWO-ELECTRON INTEGRALS.
C
          DO 100 IATM=2,NATOMS
            IAI = IATNUM(IATM)
C
C           SKIP DUMMY ATOMS.
C
            IF(IAI.EQ.0) GO TO 100
C
            NORBSI = NATORB(IAI)
            NREPI = MAX((NORBSI*(NORBSI+1))/2,1)
            DO 80 JATM=1,IATM-1
              IAJ = IATNUM(JATM)
C
C             SKIP DUMMY ATOMS.
C
              IF(IAJ.EQ.0) GO TO 80
C
              IJR = IJR + 1
              NORBSJ = NATORB(IAJ)
              NREPJ = MAX((NORBSJ*(NORBSJ+1))/2,1)
              IJREP(IJR) = IJPNT
              IJPNT = IJPNT + NREPI*NREPJ
 80         CONTINUE
 100      CONTINUE
          IF(IJPNT-1.GT.MAXREP)THEN
            IERROR = 1
            WRITE(IOUT,'(/" MAXIMUM STORAGE EXCEEDED FOR GLOBAL TWO-",
     .                    "ELECTRON MATRIX"/" -- INCREASE MAXREP",
     .                    " PARAMETER IN divcon.dim TO AT LEAST ",I7,
     .                   /" OR USE ''DIRECT'' KEYWORD")') IJPNT
            RETURN
          ENDIF
        ENDIF
      ENDIF
C
C     ASSIGN IJMAT.  THIS GETS DONE WHENEVER SUSBYSTEMS ARE UPDATED
C     AND IS BASED ON THE BONDED ATOM PAIRLIST IPAIR.
C
      IF(NATOMS.EQ.1) RETURN
      IJM = 1
      DO 200 IATM=2,NATOMS
        J1 = IP1(IATM)
        J2 = IP1(IATM+1)-1
C
C       SKIP IATM IF IT NAS NO PAIRS.
C
        IF(J2.LT.J1) GO TO 200
        IAI = IATNUM(IATM)
        NORBSI = NATORB(IAI)
        DO 180 J=J1,J2
          JATM = IPAIR(J)
          IAJ = IATNUM(JATM)
          NORBSJ = NATORB(IAJ)
          IJMAT(J) = IJM
          IJM = IJM + NORBSI*NORBSJ
 180    CONTINUE
 200  CONTINUE
      IF(IJM-1.GT.MXDIAT)THEN
        IERROR = 1
        WRITE(IOUT,'(/" MAXIMUM STORAGE EXCEEDED FOR DIATOMIC BLOCKS",
     .                " OF GLOBAL H, F, P MATRICES"/" -- INCREASE",
     .                " MXDIAT PARAMETER IN divcon.dim TO AT LEAST ",
     .                  I7)') IJM
      ENDIF
      IPMAX = IP1(NATOMS+1)
      IJMAT(IPMAX) = IJM
c sld
      IIMAX = IIMAT(NATOMS+1)-1
      IJMAX = IJMAT(IP1(NATOMS+1))-1
      BYTES = 8.0D0*(IIMAX + IJMAX)
c      WRITE(0,'(/" STORAGE FOR P=",F8.4," Mb")') BYTES/1.0D6
c      WRITE(8,'(/" STORAGE FOR P=",F8.4," Mb")') BYTES/1.0D6
c sld
      RETURN
      END