ATMOL Interface Manual

Revision: 1.3 Date: 1997/08/14 14:14:00

         IA-FILE ATMOLIF/UN=USE16     61ESU=NU\FILOMTA ELIF-AI
=====================================================================
             HOW TO INTERFACE PROGRAMS TO THE ATMOL SYSTEM
                    PRELIMINARY GUIDE (15-4-1984)
                       CYBER205 SARA AMSTERDAM
                       JOOP V. LENTHE (UTRECHT)
======================================================================

 ATMOL KNOWS ABOUT 16 DATASETS (FILES) CALLED :
    ED0,ED1,ED2,ED3,3D4,3D5,ED6,ED7 AND
    MT0,MT1,MT2,MT3,MT4,MT5,MT6,MT7
 INTERNALLY THESE ARE UNIT 1,2,3,....,16
 THE FIRST EIGHT WERE ORIGINALLY DIRECT-ACCESS FILES (ED.)
 THE LAST EIGHT WERE INTENDED TO BE SEQUENTIAL FILES (MT.)
 IS NOT GUARANTEED TO BE SO IN ALL FUTURE SYSTEMS. WE MIGHT CHOOSE
 TO HAVE E.G. MT6 AND MT7 AS SEQUENTIAL FILES IF A TAPE-UNIT WERE
 ATTACHED TO THE 205.

 ALL DATASETS ARE HANDLED BY THE SAME IO-ROUTINES.  AN ATMOL-FILE
 CONSISTS OF ATMOL-BLOCKS / WHERE EACH BLOCK IS 512 WORDS,OF WHICH
 A MAXIMUM OF 511 WORDS IS AVAILABLE TO THE USER; THE 512TH WORD
 IS USED TO STORE THE NUMBER OF MEANINGFULL WORDS AND SOME CHECKSUM
 INFORMATION. IF THE NUMBER OF MEANINGFULL WORDS EQUALS 0 (ZERO) IT
 IS AN ENDFILE BLOCK

THE ROUTINES TO DO THE ATMOL-IO ARE :

SUBROUTINE SEARCH(IBLK,IUNIT)
-POSITION FILE 'IUNIT' TO BLOCK 'IBLK'
 THE FIRST CALL TO SEARCH OPENS THE FILE

SUBROUTINE PUT(C,NWORD,IUNIT)
 0 <= 'IUNIT'  <= 511

SUBROUTINE FIND(IUNIT)
- INITIATE READING OF NEXT ATMOL-BLOCK OF FILE 'IUNIT'
SUBROUTINE GET(C,NW)
- GET BLOCK READ IN BY A PREVIOUS FIND INTO 'C'
  'NW' IS SET TO THE NUMBER OF WORDS ACTUALLY READ (SO <= 511)
** BOTH ROUTINES ARE UNITED IN THE SYNCHRONOUS READ :
**     SUBROUTINE  FGET(C,NW,IUNIT)

SUBROUTINE CLEAR
- EMPTIES ALL BUFFERS /FINISHES ALL PENDING IO-OPERATIONS

SUBROUTINE SHUT
- CLOSES ALL ATMOL DATASETS

SUBROUTINE WHTPS
- GIVES A 'SNAPSHOT' OF THE CURRENT POSITIONS OF ALL ATMOL-FILES

A USUAL SEQUENCE FOR TERMINATING THE EXECUTION OF A JOB IS :
         CALL CLEAR
         CALL WHTPS
         CALL SHUT
   .....................
** THE ABOVE SEQUENCE IS PERFORMED BY SUBROUTINE  CLENUP

THE FOLLOWING ROUTINES WRITE/READ MORE THAN ONE ATMOL-BLOCK

SUBROUTINE WRT3(Q,NWORD,IBLK,NUM3)
-WRITE THE FIRST 'NWORD' WORDS OF ARRAY 'Q' TO FILE 'NUM3'
 STARTING AT BLOCK 'IBLK' .
 AFTER THE WRITE FILE 'NUM3' IS POSITIONED AT BLOCK
     'IBLK' + ('NWORD'-1)/511 + 1

SUBROUTINE RDEDX(Q,NWORD,IBLK,NUM3)
-READ AT LEAST 'NWORD' WORDS OF ARRAY 'Q' FROM FILE 'NUM3'
 STARTING AT BLOCK 'IBLK' .
 ** NOTE : THE ROUTINE READS FULL ATMOL-BLOCKS, SO IF THERE
           ARE MORE WORDS IN THE LAST BLOCK THAN IS NECESSARY
           TO PROVIDE THE 'NWORD' WORDS, THE REMAINING ONES
           ARE NEBERTHELESS ALSO COPIED TO ARRAY Q.

SUBROUTINE WRT3S(1,NWORD,NUM3)
- AS WRT3 BUT STARTING AT THE CURRENT POSITION

SUBROUTINE READS(Q,NWORD,NUM3)
- AS READ BUT STARTING AT THE CURRENT POSITION

THE ATMOL-ROUTINES CALL THE ATMOL ERROR-ROUTINE (CALL ERROR(62))

-------------------------------------------------------------------
ATMOL DUMPFILE  ROUTINES
-------------------------------------------------------------------
THE ATMOL DUMPFILE IS STORED ON CONTIGUOUS BLOCKS OF A STANDARD
ATMOL DIRECT ACCESS DATASET. IT IS BROKEN DOWN INTO SECTIONS, EACH
SECTION BEING A CONTIGUOUS SEQUENCE OF BLOCKS WITHIN THE DUMPFILE.
SECTIONS ARE IDENTIFIED BY AN INTEGER NUMBER IN THE RANGE 1 TO 204
INCLUSIVE, AND EACH SECTION WILL BE ASSIGNED A PARTICULAR USE BY
THE USER (SECTIONS 1-190) AND BY THE SYSTEM (SECTIONS 191-204).
THE FIRST BLOCK OF THE DUMPFILE CONSISTS OF AN INDEX BLOCK, THAT IS
USED TO KEEP TRACK OF THE ATTRIBUTES OF EACH OF THE POSSIBLE 204
SECTIONS. THE INTEGRAL PROGRAMS INTEGV AND INTEGW CREATE A NEW
DUMPFILE (THUS DESTROYING ANY INFORMATION ALREADY ON IT); SERVEC
IS ALSO CAPABLE OF CREATING A NEW DUMPFILE (USING THE INIT DIRECTIVE).
WHEN A SECTION HAS BEEN CREATED, IT IS POSSIBLE TO OVERWRITE IT WITH
A SECTION OF THE SAME OR SHORTER LENGTH. IT IS NOT POSSIBLE TO EXTEND
THE LENGTH OF A SECTION ONCE CREATED.
FOR EACH SECTION THREE NUMBERS ARE STORED IN THE INDEX BLOCK :
  IPOS : STARTING BLOCK OF THE SECTION
  ILEN : LENGTH OF THE SECTION
  TYPE : TYPE , I.E. TYPE = 1 : DUMP FROM GAUSSIAN INTEGRAL PROGRAM
                            2 : 1-ELECTRON INTEGRALS
                            3 : (NATURAL) ORBITALS FROM SCF OR CI
                           50 : GRIDS OF DENSITIES
                           ETC.

 SOFTWARE FOR MANIPULATION OF THE DUMPFILE
-------------------------------------------

SUBROUTINE SECINI(IBL,NUM)
- MAKES UNIT 'NUM' AT BLOCK 'IBL' THE CURRENT DUMPFILE AND READS
  THE INDEX BLOCK FROM IT

SUBROUTINE SECPUT(ISEC,MTYPE,LENGTH,IBLOCK)
- SHOULD BE CALLED BEFORE A SECTION IS WRITTEN TO ESTABLISH THE
  STARTING BLOCK FOR THIS SECTION. YOU PROVIDE SECTION-NUMBER
  'ISEC' , TYPE 'MTYPE' EN THE 'LENGTH' ; THE ROUTINE RETURNS THE
  STARTING BLOCK 'IBLOCK'
  ** THE ROUTINE DOES THE CALL TO SEARCH FOR YOU **

SUBROUTINE SECGET(ISEC,MTYPE,IBLOCK)
- IS CALLED BEFORE A SECTION IS READ TO OBTAIN STARTING BLOCK.
  - AS SECPUT -

SUBROUTINE SECSUM
- A CALL TO THIS ROUTINE CAUSES A SUMMARY OF THE CURRENT DUMPFILE
  TO BE PRINTED

SUBROUTINE REVIND
- WRITES A REVISED INDEX BLOCK TO THE DUMPFILE. THUS THE ROUTINE
  SHOULD CERTAINLY BE CALLED PRIOR TO TERMINATION OF EXECUTION, THE
  USUAL CODING SEQUANCE BEING :
     CALL SECSUM
     CALL REVIND
     CALL WHTPS
     CALL CLENUP
    ................

 THE ERROR CODES GENERATED BY THESE ROUTINES ARE :
  63   : ISEC LESS THEN 1
  64   : THE REQUIRED SECTION DOES NOT EXIST (SECGET)
  65   : THE TYPE OF THE SECTION AND THE TYPE SPECIFIED BY SECGET
         ARE NOT EQUAL  (SECGET)

  71   : SIZE OF DUMPFILE EXCEEDS MAXIMUM
  72   : SECTION ALREADY EXIXTS WITH LENGTH LESS THEN THE ONE
         SPECIFIED BY SECPUT

--------------------------------------------------------------------------
 INCLUDING THE ATMOL SYSTEM IN A PROGRAM
--------------------------------------------------------------------------

THE FOLLOWING LIBRARY MUST BE INCLUDED WHEN LOADING THE PROGRAM
   FTN5  :    UTILI2/UN=400016
   FTN4  :    UTILH2/UN=400016

 THE FOLLOWING SHOULD BE INCLUDED IN THE BLOCK-DATA PROGRAM :

      COMMON/BUFNEW/IBUFA(512,24,2)
      COMMON/IOFILE/IR,IW
      COMMON/WORK/JREC,JUMP,ISTRT(40),INUMB(40),IA(80)
     1  ,ISWIT,IWIDT,NUM2,NUM3,IBLK3P,IBLK
      COMMON/DISC/IREP,IOUT,IIN,IUN,IBLKK,IPOS(16),
     *NAM(16),JAM(16)
      DATA ISWIT,IR,IW/.FALSE.,5,6/
      DATA IWIDT/72/
      DATA JREC/-1/

IN THE FIRST EXECUTABLE STATEMENTS YOU CAN EITHER CALL THE ROUTINES PREP99
AND PREP98 OR SIMULATE THEIR FUNCTION. THESE ROUTINES READ FILE DIRECTIVES
TO ASSIGN EXTERNAL NAMES TO ATMOL FILES AND CORE DIRECTIVES TO READ THE
AMOUNT OF BLANK COMMON REQUIRED.  NOTE : IF YOU CALL THEM AND YOU ARE
NOT USING THE ATMOL  INPUT ROUTINES IN THE REST OF THE PROGRAM YOU FORCE
THE USER TO INSERT ONE EXTRA BLANK LINE, AFTER A FILE DIRECTIVE.
THE ROUTINES ARE INCLUDED HERE :

      SUBROUTINE PREP99(LWORD)
      DIMENSION P(5)
      COMMON/DISC/IREP(21),GAM(16),HAM(16)
      COMMON/WORK/JREC,JUMP,IA(162)
      DATA P/'CHANGE','SWITCH','FILE','STORE','CORE'/
11    CALL INPUT
      CALL INPA(TEXT)
      J=LOCATE(P,5,1,TEXT)
      IF(J)33,22,33
33    GOTO (1,1,1,2,2),J
C... =CHANGE= OR =SWITCH= OR =FILE= DIRECTIVE
1     IF(JREC.GE.JUMP)GOTO 11
      CALL INPA(TEXT)
      J=LOCATE(GAM,16,1,TEXT)
      IF(J.EQ.0)CALL ERROR(3333)
      CALL INPA(BEXT)
      HAM(J)=BEXT
      GOTO 1
C... =STORE= OR =CORE= DIRECTIVE
2     CALL INPI(LWORD)
      GOTO 11
22    JREC=0
      RETURN
      END
      SUBROUTINE PREP98
      COMMON/DISC/IREP(21),JAM(16),KAM(16)
      DO 5 LOOP=1,16
         IF (JAM(LOOP).NE.KAM(LOOP)) GO TO 4
5     CONTINUE
      RETURN
4     WRITE(6,1)
1     FORMAT(//' ATMOL FILE NAME  EXTERNAL FILE NAME'/1X,35('-'))
      DO 2 LOOP=1,16
2     IF (JAM(LOOP).NE.KAM(LOOP)) WRITE(6,3)JAM(LOOP),KAM(LOOP)
3     FORMAT(1X,A4,13X,A8)
      RETURN
      END

NEXT THE USER INITIALISES THE ATMOL IO-SYSTEM BY CALLING

SUBROUTINE SETIO(LPB,LPBSZ)
- THIS INITIALISES THE IO-SYSTEM WITH 'LPB' BUFFERS OF SIZE
  'LPBSZ' EACH. THE DECLARATION OF COMMON/BUFNEW/ IN BLOCK DATA
  SHOULD  CORRESPOND TO THIS CALL :
  COMMON/BUFNEW/ IBUFA(512,SIZE,LB)
  WHERE 'SIZE' > 'LPBSZ' AND 'LB' > 'LPB'

THE NUMBER OF BUFFERS SHOULD BE ABOUT THE NUMBER OF TYPES OF IO
GOING ON SIMULTANEOUSLY, WHILE THE BUFFERSIZE SHOULD BE BIGGER
AS THE IO IS MORE SEQUENTIAL. TYPICAL VALUES ARE  :
   PROGRAM          LPB           LPBSZ
   INTEGV            2              24
   SCF               2              24
   DIRECT            5               9
   LIBV              2               4



========================================================================
 NOW FOLLOW A FEW ROUTINES TAKEN FROM ATMOL PROGRAMS AS EXAMPLES
========================================================================


INITIALISE A DUMPFILE :
-----------------------

      SUBROUTINE INIDUM(NUM3,IBLK3)
C...  START A NEW DUMPFILE
      COMMON /SECTOR/ NUMD,IBLKD,REVISE,IIII(204),MAXBLK,KBLKLA
      LOGICAL REVISE
C
      REVISE = .FALSE.
      CALL IZERO(IIII,204)
      KBLKLA = 1
      MAXBLK = 7777
      NUMD = NUM3
      IBLKD = IBLK3
C
      CALL REVIND
C
      RETURN
      END



ROUTINES TO WRITE AND READ ORBITALS :
--------------------------------------

      SUBROUTINE PUTQ(COMM,TIT,EIG,DEF,NORB,NORBN,NCOLU,IEIG,
     *IDEFF,Q,MPOS,IBLKQ)
C... STANDARD E.VECTOR OUTPUTTING ROUTINE(+ HEADER BLOCKS)
      DIMENSION Q(1),COMM(1),TIT(1),EIG(1),DEF(1)
      COMMON/SECTOR/NUMD,IBLKD
      COMMON/BLKIN/COM(19),TITLE(10),VALUE(255),OCC(255),
     *NBASIS,NEWBAS,NCOL,IVALUE,IOCC
C*************************************************************
C     COMMON/TRAN/ILIFC(256),NTRAN(256),ITRAN(600),CTRAN(600),
C    *IFTRAN
      LOGICAL IFTRAN
      DIMENSION ILIFC(511)
      EQUIVALENCE (ILIFC(1),VALUE(1)),(IFTRAN,VALUE(180))
C*************************************************************
      DATA MS1,M2,M3,M6,M7,M10,M19,M544,M1713/
     *      -1, 2, 3, 6, 7, 10, 19, 544, 1713/
      DATA M190/190/
       IF(MPOS.GT.M190)CALL ERROR(63)
      NBSQ=NORB*NCOLU
      J=(NBSQ+MS1)/511+M7
      CALL SECPUT(MPOS,M3,J,IBLK)
      IBLKQ=IBLK+M6
      CALL FMOVE(COMM,COM,M19)
      CALL FMOVE(TIT,TITLE,M10)
      CALL FMOVE(EIG,VALUE,NCOLU)
      CALL FMOVE(DEF,OCC,NCOLU)
      NBASIS=NORB
      NEWBAS=NORBN
      NCOL=NCOLU
      IVALUE=IEIG
      IOCC=IDEFF
      CALL WRT3(COM(1),M544,IBLK,NUMD)
      J=IBLK+M2
C***************************************************************
      CALL IZERO(ILIFC,511)
      CALL PUT(ILIFC,511,NUMD)
      CALL PUT(ILIFC,511,NUMD)
      CALL PUT(ILIFC,511,NUMD)
C****   NO CONTRACTION ****
      IFTRAN = .TRUE.
C****   NO CONTRACTION ****
      CALL PUT(ILIFC,180,NUMD)
C     CALL WRT3(ILIFC(1),M1713,J,NUMD)
C***************************************************************
      CALL WRT3(Q(1),NBSQ,IBLKQ,NUMD)
      CALL CLEAR
      CALL REVIND
      RETURN
      END
      SUBROUTINE GETQ(Q,EIG,OCC,NBAS,NCOLU,MODE,IEIG,IOCC,J)
      LOGICAL IFTRAN,MUGG,MUG,IPUNCH,JCHEK,IPRIN,NOPR
      DIMENSION Q(1),EIG(1),OCC(1)
      COMMON /CNTRL/ LPRINT,MAXDIM,NCORE,IPFR34(2),IPR34(2)
      LOGICAL LPRINT
      COMMON/SECTOR/NUMD,IBLKD
      COMMON/BLKIN/COM(19),TIT(10),DEIG(255),DOCC(255),
     *NBA,NEW,NCOL,JEIG,JOCC
      COMMON/DISC/JSP(21),IED(16)
      DATA M2,M3,M4,M190,M544/2,3,4,190,544/
      IF(J.GT.M190)CALL ERROR(63)
      IF (LPRINT) WRITE(6,100)J,IBLKD,IED(NUMD)
100   FORMAT(/4X,'VECTORS RESTORED FROM SECTION',I4,
     *' OF DUMPFILE STARTING AT BLOCK',I6,' OF ',A4)
      CALL SECGET(J,M3,K)
      CALL READ(COM(1),M544,K,NUMD)
      K=K+M2
      IF (LPRINT) WRITE(6,200)NCOL,NBA,(COM(7-I),I=1,6),TIT
      NBAS=NBA
      NEWB=NEW
      IF (NBAS.NE.NEWB) CALL ERROR(38)
      NCOLU = NCOL
      IEIG=JEIG
      IOCC=JOCC
      CALL FMOVE(DOCC,OCC,NCOL)
      CALL FMOVE(DEIG,EIG,NCOL)
      IF(NBAS.GT.MAXDIM) CALL ERROR(34)
200   FORMAT(/' HEADER BLOCK INFORMATION :'/,I4,'  * ',I4,
     *'  VECTORS CREATED UNDER ACCT. ',A8/
     *A7,'VECTORS CREATED BY ',A8,' ATMOL3 PROGRAM AT ',
     *A8,' ON ',A8,' IN THE JOB ',A8/
     *' WITH THE TITLE: ',10A8,/)
500   NW=NBAS*NCOL
      K=K+M4
      CALL READ(Q,NW,K,NUMD)
      RETURN
      END
      SUBROUTINE IZERO(II,N)
C...  INTEGER ZERO - SET
      DIMENSION II(N)
      DO 10 I=1,N
10    II(I) = 0
      RETURN
      END


THE NEXT ROUTINES WRITE AND READ 1-ELECTRON INTEGRALS :
-------------------------------------------------------



      SUBROUTINE ONELEC
C
C... SHOW ROUTINE FOR WRITING OF 1-ELECTRON INTEGRALS
C... OVERLAP,KINETIC ENERGY,TOTAL 1-ELECTRON OPERATOR AND DIPOLE
C...  S             T                     H                X Y Z
C... NOTE IKY(I) = I*(I-1)/2
C
      COMMON/BLKIN/
     *     POTNUC,DX,DY,DZ,
     *     SOUT(72),TOUT(72),HOUT(72),XOUT(72),YOUT(72),ZOUT(72),
     *     IOUT(72),MWORD
C
      M192 = 192
      MWORD = 0
      SUM=CPULFT(1)
      WRITE(6,44446)SUM
44446 FORMAT(/' 1-ELECTRON INTEGRAL CALC. STARTED AT',
     *F12.3,' SECS')
C... INITIALIZE SECTION ON DUMPFILE FOR INTEGRALS
       IORBA=(IKY(NBASIS+1)-1)/72+1
       CALL SECPUT(M192,2,IORBA,IBLKI)
      DO 2 IGRPA=1,NGRP
C... ALL INTEGRALS FOR THIS BATCH READY
C... LOAD TO DUMPFILE
       NINT=1
       DO 5050 IA=1,NSTA
       III=IORBA+IA
       IKYI=IKY(III)
       DO 5050 JA=1,NSTB
       IF(LGRPAB.AND.(JA.LT.IA))GOTO 5050
       MWORD=MWORD+1
       JJJ=IORBB+JA
       IF(JJJ.GE.III)GOTO 5051
       IOUT(MWORD)=IKYI+JJJ
       GOTO 5052
5051   IOUT(MWORD)=IKY(JJJ)+III
5052   SOUT(MWORD)=S(NINT)
       TOUT(MWORD)=T(NINT)
       HOUT(MWORD)=H(NINT)
       XOUT(MWORD)=-X(NINT)
       YOUT(MWORD)=-Y(NINT)
       ZOUT(MWORD)=-Z(NINT)
       IF(MWORD.NE.72)GOTO 5050
       CALL PUT(POTNUC,509,NUM3)
        MWORD=0
5050   NINT=NINT+1
2      CONTINUE
C... CLEAR UP LAST FEW INTEGRALS
       IF(MWORD)44441,44444,44441
44441 CALL PUT(POTNUC,509,NUM3)
44444  CALL SEARCH(IBLKHE,NUM3)
       CALL REVIND
      CALL CLEAR
       SUM=CPULFT(1)
      WRITE(6,44445)SUM
44445 FORMAT(/' 1-ELECTRON INTEGRAL CALC. ENDED AT',I5,' SECONDS'/)
C
      RETURN
        END


       SUBROUTINE GETMAT(S,T,F,X,Y,Z,CHARGE,NBASIS,
     *MS,MT,MF,MX,MY,MZ)
      LOGICAL MS,MT,MF,MX,MY,MZ
       DIMENSION S(1),T(1),F(1),X(1),Y(1),Z(1),CHARGE(1)
      COMMON/MAPPER/IKY(256),IKYP(256)
      COMMON/BLKIN/POTNUC(4),AS(72),AT(72),AF(72),AX(72),AY(72),
     *AZ(72),III(72),ICOUNT
      COMMON/SECTOR/NUM3
      COMMON/LINKUP/TIMEST(28),ITESS(7),IONSEC
      DATA M1,M3/1,3/
      CALL SECGET(IONSEC,2,IBLK34)
       CALL SEARCH(IBLK34,NUM3)
      LENTRI=IKYP(NBASIS)
       NBLOCK=(LENTRI-1)/72+M1
      DO 1 II=1,NBLOCK
      CALL FIND(NUM3)
      CALL GET(POTNUC,NW)
      IF(MS)CALL MOVER(AS,S)
      IF(MT)CALL MOVER(AT,T)
      IF(MF)CALL MOVER(AF,F)
      IF(MX)CALL MOVER(AX,X)
      IF(MY)CALL MOVER(AY,Y)
      IF(MZ)CALL MOVER(AZ,Z)
1     CONTINUE
      CALL FMOVE(POTNUC,CHARGE,4)
      RETURN
      END



ROUTINES TO WRITE TWO-ELECTRON INTEGRALS (TO MAINFILE) :
--------------------------------------------------------

      SUBROUTINE ATMOL4
C... OVERALL CONTROL OF 2-ELECTRON INTEGRAL CALC.    EXAMPLE
      TIMLST=CPULFT(1)
       TIMDMP=TIMLST
      WRITE(6,6)TIMLST
6      FORMAT(/' 2-ELECTRON INTEGRAL CALC. STARTED AT',F12.3,
     *' SECS')
      IMIN=MINA
      CALL SEARCH(IBLK2,NUM2)
      MWORD=0
C............
C... FIRST MAJOR LOOP -- IGRPA
C............
      DO 1 IGRPA=IMIN,NGRP
C............
C... SECOND MAJOR LOOP -- IGRPB
C............
      DO 2 IGRPB=JMIN,NGRP
C............
C... THIRD MAJOR LOOP -- IGRPC
C............
      DO 3 IGRPC=KMIN,NGRP
C............
C... FOURTH MAJOR LOOP -- IGRPD
C............
      DO 4 IGRPD=LMIN,NGRP
C...
C... LOAD INTEGRALS TO MAINFILE
C...
1411   IORBD=NORB(IGRPD)
      NINT=IXLM2
      DO 500 I=1,NSTA
       III=IORBA+I
      I512KA=I512(III)
      DO 500 J=1,NSTB
      JJJ=IORBB+J
      IF(LGRPAB.AND.(JJJ.LT.III))GOTO 5503
      JOVAB=I512KA+JJJ
      DO 504 K=1,NSTC
      KKK=IORBC+K
      I512KC=I512(KKK)
      DO 504 L=1,NSTD
      LLL=IORBD+L
      IF((LGRPCD.AND.(LLL.LT.KKK)).OR.
     *(LOABCD.AND.((I512KC+LLL).LT.JOVAB)))GOTO 504
      VALUE=RESULT(NINT+1)
      IF(ABS(VALUE).GE.ACC3)CALL OUTINT
504    NINT=NINT+1
P100
504    NINT=NINT+1
       GOTO 500
5503   NINT=NINT+NSTCD
500    CONTINUE
4     CONTINUE
3     CONTINUE
2     CONTINUE
1     CONTINUE
      IF(MWORD)44448,44444,44448
44448 CALL PUT(GOUT,511,NUM2)
      IBLK2=IBLK2+1
44444 CALL PUT(GOUT,0,NUM2)
C...      ****  ENDFILE BLOCK  ****
      IBLK2=IBLK2+1
       LPH2=.FALSE.
       MINA=1
       MINB=1
       MINC=1
       MIND=1
       CALL SEARCH(IBLKHE,NUM3)
C..   CALL PUT(LPH1,16,NUM3)         (DUMP OF INTEGW)
       CALL CLEAR
      WRITE(6,66112)IBLK2
66112 FORMAT(/' MAINFILE AT BLOCK',I8)
      TIMLST=CPULFT(1)
      WRITE(6,777)TIMLST
777   FORMAT(/' 2-ELECTRON INTEGRAL CALC. ENDED AT',
     *F12.3,' SECS')
      RETURN
      END
      SUBROUTINE OUTINT
      LOGICAL LPH1,LPH2,LPHP,LPHR
      COMMON/BLKIN/GOUT(340),IOUT(170),MWORD
      COMMON/PACKKK/III,JJJ,KKK,LLL,VALUE
      COMMON/DMPCTL/LPH1,LPH2,LPHP,LPHR,IRUN,MINA,MINB,MINC,MIND,
     *MAXA,MAXB,MAXC,MAXD,IBLK2,MXBLK2,NUM2,IBLK3,NUM3
      COMMON/ICON/NUMB(50),IKY(512),MIKY(50),NIKY(50),
     *NSTATE(7),I512(512),IPHASE(7)
      IF(III.GE.JJJ)GOTO 1
      II=JJJ
      JJ =III
      GOTO 2
1     II=III
      JJ=JJJ
2     IF(KKK.GE.LLL)GOTO 3
      KK=LLL
      LL=KKK
      GOTO 4
3     KK=KKK
      LL=LLL
4     IF((IKY(II)+JJ).GE.(IKY(KK)+LL))GOTO 5
      II=OR(SHIFT(KK,24),OR(SHIFT(LL,16),OR(SHIFT(II,8),JJ)))
      GOTO 6
5     II=OR(SHIFT(II,24),OR(SHIFT(JJ,16),OR(SHIFT(KK,8),LL)))
6      MWORD=MWORD+1
      GOUT(MWORD)=VALUE
      IF(MWORD.GT.170)GOTO 8
      IOUT(MWORD)=II
      RETURN
8     IOUT(MWORD-170)=OR(SHIFT(II,32),IOUT(MWORD-170))
      IF(MWORD.NE.340)RETURN
      CALL PUT(GOUT,511,NUM2)
      IBLK2=IBLK2+1
      MWORD=0
       RETURN
      END

========================================================================
 NEW UTILITIES D.D  SEPTEMBER 1984 / UTILM
C
THE MATRIX MULTIPLIERS MXMB,MXMBN USE COMMON/SCRA/
  THE ARRAY IN SCRA SHOULD BE DIMENSION IN THE FIRST SUBROUTINE
  TO ITS MAXIMUM SIZE / FOR THESE ROUTINES THIS AMOUNTS TO THE
  EFFECTIVE SIZE (NDIM**2) OF ONE MATRIX + ONE COLUMN
THE ROUTINES LOCATE/ UPAK8V ETC USE /SCRA/ AS WELL
  USE SAY ONE LARGE PAGE / (65536)