C 13 MAR 06 - DGF - SEQOPN: MOVE NODEXT INITIALIZATION HERE
C 22 FEB 06 - TN  - STOREENV: STORE ONE MORE FILE NAME FOR EFP+FMO
C 17 JAN 06 - RAK - SEQOPN: TRY TO SET FLUSH ON WRITE FOR PUNCH/IRCDATA
C 18 NOV 05 - MWS - ADD SQRDCH/SQWRCH CHUNKED SEQUENTIAL I/O ROUTINES
C 14 NOV 05 - DGF - STORENV: MORE GDDI FILE NAMES BROADCAST
C 19 SEP 05 - IA  - SYNCHRONIZE FRGINF COMMON
C  6 JUL 05 - DGF - STORENV: ADD NEW CC FILE NAMES
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 30 APR 05 - DGF - CHANGE GDDI FILE EXTENSIONS TO GLOBAL RANK
C  7 MAR 05 - IA  - FIX COMMON BLOCK FRGINF
C 13 FEB 05 - MWS - PAD COMMON BLOCK FRGINF
C  5 FEB 05 - DGF - STORENV: SAVE ERIC FILE, PARENV: ALLOW P>999
C 23 JUL 04 - MWS - PREAD: MODIFY NINTIC WARNING
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C  9 DEC 03 - OQ  - RAISE MXUNIT FROM 100 TO 299 (THIS IS BAD FOR F2C)
C  4 NOV 03 - DGF - DAREAD,DAWRIT: ALLOW EACH NODE TO HAVE ITS OWN DAF
C  3 SEP 03 - MWS - RAOPEN,RACLOS,CCOPEN,SEQOPN,SEQCLO: MAX. FILE NUMBER
C  3 JUL 03 - JMM - SUPPRESS PRINTING FOR MONTE CARLO JOBS
C 12 DEC 02 - MWS - DAREAD: IMPROVED ERROR HANDLING/MESSAGES
C 17 APR 02 - MWS - SYNCH UP FRGINF COMMON
C 26 MAR 02 - MWS - ADD ROUTINE TO OPEN CC DIRECT ACCESS FILES
C  6 SEP 01 - HU  - PREADP: CORRECT LABEL READING LENGTHS
C 20 FEB 01 - PND - PUVIB: ADITIONAL PRINT OUT CONTROL
C 21 DEC 99 - DGF - RAOPEN,RAOPEN2: PHYSICAL RECORD SIZE CHANGES
C 12 NOV 98 - GDF - PREAD,PKREAD,PWRIT,PKWRIT: CHOOSE INT. LENGTHS
C 27 SEP 98 - MWS - RAOPEN: CHANGE FORMAT FIELD WIDTH
C 27 FEB 98 - AL  - PARENV: STRIP OF PATH NAME MADE MORE OPTIONAL
C  6 JAN 98 - MWS - RAOPEN: PASS CORRECT FILE NAMES TO OTHER NODES
C 14 OCT 97 - DGF - ADD RAWRITE ROUTINE
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C  2 SEP 97 - MWS - PKWRIT,PWRIT1,PWRIT2,PXWRIT,SQWRIT,SEQREW,
C                   PKREAD,PREAD1,PREAD2,PXREAD: ADD ERROR BRANCHES
C 16 JUL 97 - GNM - PUVIB: CHANGE FOR FRAGONLY OPTION
C 10 JUL 97 - MWS - SQREAD: ERROR BRANCH LEADS TO JOB TERMINATION
C  7 FEB 97 - MWS - DAREAD,DAWRIT: IMPROVE ERROR MESSAGE CONTENT
C  6 NOV 96 - MWS - ADD MQOPDA,MQDARE,MQDAWR
C 30 OCT 96 - HN  - SEQOPN,SEQCLO: ALLOW UNIT NUMBERS TO 99
C 24 MAY 96 - GMC - RAOPEN: CHANGE FILE NAME TO MCDIIS FOR UNIT 30
C  3 JAN 96 - MWS - BRING XABI'S THREE DUMMY ROUTINES HERE
C 24 MAY 95 - MWS - INCLUDE NEW PREADP ROUTINE
C 21 APR 95 - MWS - SEQCLO,SEQOPN: AVOID REPEAT OPEN REQUESTS
C 17 NOV 94 - WC  - PUVIB: FRAGMENT RELATED CHANGES
C 10 NOV 94 - MWS - REMOVE SOME FTNCHEK WARNINGS
C 11 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  4 AUG 94 - MWS - PREAD,PWRIT: ALLOW DOUBLE LABELS
C 31 MAY 94 - PRD - PUVIB: ADD FRAGMENT OUTPUT
C  4 JAN 94 - MWS - FIX RA ROUTINES TO WORK ON ALL NODES
C 16 JUL 93 - MWS - ADD PXREAD ROUTINE
C  5 JUN 92 - TLW - ADD ROUTINE PARENV; CHANGE ROUTINE ADVFIL TO SEQFIL;
C                   MAKE SEQENTIAL DISK OPS WORK ON DIFFERENT NODES
C  3 APR 92 - TLW - DAREAD/WRIT: ACCOUNT FOR PURELY INTEGER RECORDS
C  2 MAR 92 - TLW - SQREAD: BROADCAST INFORMATION
C 21 FEB 92 - TLW - RARD: BROADCAST INFORMATION
C  3 FEB 92 - TLW - DARD: BROADCAST DAF INFORMATION
C 30 JAN 92 - TLW - OPENDA: BROADCAST OLD DAF INFORMATION IF NEEDED
C 11 JAN 92 - TLW - MAKE READS PARALLEL
C 10 JAN 92 - TLW - MAKE NEW ROUTINE SEQREW
C 10 JAN 92 - TLW - MAKE OPENS AND CLOSES PARALLEL
C 10 JAN 92 - TLW,MWS - DELETE OPEN ROUTINES OPENCI,OPENCF,OPENDF,
C                   OPENFM,OPENIP,OPENIR,OPENIS,OPENIW,OPENJK,OPENPK,
C                   OPNIRC TO USE GENERIC SEQOPN; SEQCLO REPLACED CLOSJK
C  7 JAN 92 - TLW - MAKE WRITES PARALLEL; ADD COMMON PAR
C 18 NOV 91 - MWS,JHJ - SEQOPN:INTRODUCED FROM UTILS.CODE.
C 19 JAN 90 - MWS - INITIALIZE FILENM IN OPENIW IN UNIX SECTION
C 21 DEC 89 - STE - ADD ERROR MESSAGES TO PKREAD,PREAD
C 26 SEP 89 - MWS - ADD NFT13,NFT14 TO /CIFILS/
C 12 APR 89 - STE - ADD FILE CIINTS (NFT14) TO OPENCI
C 28 MAR 89 - MWS - RAOPEN RETURNS W/O OPENING IF EXETYP.EQ.CHECK
C 25 FEB 89 - MWS - USE FLSHBF IN PUVIB, LOWER CASE CTSS SUFFIXES
C 27 JAN 89 - MWS - OPENCI OPENS A FILE ONLY IF ITS LRECL IS NONZERO
C 18 JAN 89 - MWS - ADD ROUTINE OPENDF, DELETE RDGRD AND WRTGRD
C 14 NOV 88 - MWS - PKREAD,PKWRIT,PREAD,PWRIT: NX,IX BEFORE XP,XK VALUES
C  7 OCT 88 - MWS - ADD NEW ROUTINE OPENFM
C  1 APR 88 - MWS - INCREASE NON-IBM RECORD SIZES FOR DASORT
C                   TO VAX MAXIMUM OF 2047 W.P. WORDS.
C 15 MAR 88 - MWS - ALTER IBM CLOSE IN RAOPEN, FIX VAX LDAR IN RASIZE
C 29 FEB 88 - STE - ADD FPS INFO TO OPENCF
C 18 FEB 88 - MWS - ADD NEW ROUTINE OPENCF
C 11 JAN 88 - MWS - ADD DIPOLE TO $VIB OUTPUT GROUP
C  2 NOV 87 - STE - CHANGE VAX RECL TO WORK WITH REMOTE DISKS
C 24 AUG 87 - STE - OPENJK: FIX FPS TO WORK LIKE OTHER FILES
C  6 AUG 87 - MWS - INCLUDE ETA VERSION
C 26 JUN 87 - MWS - DON'T PRINT FORCE RESTART DATA IN PUVIB
C  5 MAY 87 - STE - PUVIB: DIMENSION BLANK,VIBWRD
C 12 APR 87 - MWS - ROUTINE PUVIB TRANSFERRED FROM FORCE MODULE
C 15 OCT 86 - MWS - ADD CRAY/CTSS SPECIFIC INSTRUCTIONS IN ORDER
C                   TO BUILD UNIQUE FILENAMES UNDER CTSS
C 13 OCT 86 - MWS - USE IDMY IN DAWRIT COMMON TO AVOID ARG COLLISIONS
C 14 AUG 86 - MWS - REMOVE MULTIPLE FILE OPTION STUFF FOR IBM
C                   IN PREAD,PWRIT,PKREAD,PKWRIT,   ADD ROUTINE OPNIRC
C  1 AUG 86 - MWS - OBTAIN FILE NAME FROM THE ENVIRONMENT FOR CELERITY
C  9 JUL 86 - MWS - OPEN/CLOSE STATEMENTS FOR CELERITY AND CRAY,
C                   SANITIZE FLOATING POINT CONSTANTS, MOVE ROUTINES
C                   ABRT,MCHPAR,SECOND,TMDATE TO MODULE GAMESS
C 11 JUN 86 - MWS - WRITE CORRECT ERROR MESSAGE IN DAWRIT
C 25 APR 86 - LAM - OPEN IP WITH CC='LIST' IN OPENIP ON THE VAX
C 16 APR 86 - LAM - CHANGE FORMAT STATEMENT IN RAOPEN
C 26 FEB 86 - LAM - FIX PKREAD AND PWRIT TO READ INTEGRALS PROPERLY
C                   FROM MORE THAN ONE FILE
C 13 FEB 86 - LAM - PKREAD, PKWRIT, PREAD, PWRIT CHANGED TO HANDLE
C                   MULTIPLE (TAPE) FILES FOR IBM
C 31 JAN 86 - LAM - DEFINE LOCAL VARIABLE FIRLCL IN SECOND
C 13 NOV 85 - STE - FPS COMMAND LINE CONTROL OF FILES
C 26 OCT 85 - STE - TMDATE: FPS CAN GET DATE NOW
C 23 OCT 85 - STE - OPENCI: CHANGE CALL
C  9 SEP 85 - STE - FIX FPS OPEN IN OPENIS; CHANGE 700 IN RACLOS TO 7
C                   ADD /IOFILE/ FOR FPS IN OPENCI
C  6 SEP 85 - LAM - IRECLN=512 IN OPENDA, IRECLN=4094 IN RAOPEN
C                   AND LDAR=4090 IN RASIZE (IBM)
C 12 JUL 85 - MWS - 7 CHAR FILENAMES, JKFILE UNKOWN, KNOWN
C                   DON'T OPEN IBM FT06F001
C 30 MAY 85 - MWS - ADD NPRINT ARGUMENT TO RAOPEN
C 15 APR 85 - MWS - PUT ERR= BRANCH IN RACLOS
C 10 APR 85 - MWS - REMOVE VAX RECL= FROM OPENCI
C 15 MAR 85 - MWS - ADD ROUTINE RASIZE TO SET LDAR
C 10 MAR 85 - MWS - ADD ROUTINE OPENCI,OPENJK,SEQCLO,
C                   CONVERT IBM VERSION TO VS FORTRAN OPEN/CLOSES,
C 22 AUG 84 - STE - REMOVE UNUSED PARAMETER N FROM MSREAD/WRITE
C 21 JUL 84 - STE - ADD IS,IPK TO UNIT10 REC=1 IN DAWRIT,OPENDA
C 15 MAY 84 - STE - FPS TRACEBACK IN ABRT
C 28 APR 84 - STE - FIX MSREAD,MSWRIT TO ALLOW RESTARTS
C 26 MAR 84 - STE - ALLOW RUN-TIME ACCESS TO OPEN STATEMENTS
C 23 FEB 84 - STE - INCLUDE PXWRIT
C  2 FEB 84 - STE - REMOVE REWRITE LENGTH CHECK FROM RAWRIT
C 21 JAN 84 - STE - OPEN VAX INPUT READONLY, SHARED
C 17 JAN 84 - STE - EVALUATE ELAPSED REAL TIME IN SECOND
C 10 JAN 84 - STE - CHANGE STATUS=NEW TO STATUS=UNKNOWN, EXCEPT IW
C 28 DEC 83 - STE - REMOVE INTEGER*2 IN P/PK-READ/WRIT
C 27 DEC 83 - STE - ADD ROUTINES SQREAD AND SQWRIT
C 19 DEC 83 - STE - SAVE TIME FROM INITIAL CALL TO SECOND FOR VAX
C 15 DEC 83 - STE - ADD LRECL TO OPENIS, OPENPK
C  1 DEC 83 - STE - FIX NWDVAR INDEXING IN MSREAD,MSWRIT,RDGRD,WRTGRD
C 29 NOV 83 - STE - FPS CONVERSION; CHANGE OPENDA,RAOPEN
C 21 NOV 83 - STE - FPS CONVERSION; ADD OPENIP AND OPENPK
C  5 NOV 83 - STE - INCLUDE ABRT,MCHPAR,SECOND,TMDATE FROM IBMLIB
C                   FIX VAX I/O, INITIALIZE IBM TIME CORRECTLY
C                   INSERT CORRECT TMDATE FOR VAX
C                   DELETE BUFINT,DARTRN,REWBF,UNPACK
C 13 MAY 83 - STE - INITIALIZE IBM TIMES TO ZERO.
C  8 MAY 83 - MWS - IOLIB FORMED FROM PIECES OF
C                   GAMESS, IBMLIB, AND CILIB.
C  2 NOV 82 - MWS - DEFINE FILE STATEMENT MADE FOR WORST CASE
C 29 SEP 82 - MWS - CONVERT FOR IBM
C
C   IN THIS FILE,
C       *IBM REFERS TO IBM MAINFRAMES RUNNING MVS OR VM (NOT RS/6000)
C       *VMS REFERS TO VAX OR AXP RUNNING VMS OPERATING SYSTEM
C       *UNX REFERS TO EVERYTHING ELSE, RUNNING A UNIX O/S
C
C*MODULE IOLIB   *DECK CHGMIU
      SUBROUTINE CHGMIU(IR,IW)
      RETURN
      END
C*MODULE IOLIB   *DECK CHMDAT
      SUBROUTINE CHMDAT(AATOM,AZNUC,CORD,NAT)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      CHARACTER*10 AATOM(*)
      DIMENSION AZNUC(*),CORD(*)
      RETURN
      END
C*MODULE IOLIB   *DECK FDNAI
      DOUBLE PRECISION FUNCTION FDNAI(PLAMBDA,AI,AJ,
     *                                L1A,M1A,N1A,L2B,M2B,N2B,
     *                                XI,YI,ZI,XJ,YJ,ZJ,CX,CY,CZ)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C        THESE THREE ROUTINES IMPLEMENT THE SCREENED INTEGRAL
C        METHOD OF JOSE UGALDE AND XABI LOPEZ, WHICH IS NOT
C        AT PRESENT IN THE STANDARD GAMESS CODE.
C
      FDNAI = 0.0D+00
      RETURN
      END
C*MODULE IOLIB   *DECK STWOEI
      SUBROUTINE STWOEI(SCFTYP,DIRSCF,DIRNLO,DIRTRF,
     *               INTG76,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *               BUFP,BUFK,IBUF,NINTMX,
     *               XINTS,NSH2,GHONDO,MAXG,DDIJ,
     *               IA,DA,FA,DB,FB,DSH,DNLO,FNLO)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      RETURN
      END
C*MODULE IOLIB   *DECK INITFCTS
      SUBROUTINE INITFCTS
      RETURN
      END
C*MODULE IOLIB   *DECK DARD
      SUBROUTINE DARD(V,LEN,IDAF,NS,IDTYP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION V(LEN)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C       READ A PHYSICAL RECORD FROM THE DAF
C
      IF (MASWRK) READ (UNIT=IDAF, REC=NS) V
      ITYP = 100 + IDAF
      IF (GOPARR) THEN
         IF (IDTYP.NE.1) THEN
            CALL DDI_BCAST(ITYP,'F',V,LEN,MASTER)
         ELSE
            CALL DDI_BCAST(ITYP,'I',V,NWDVAR*LEN,MASTER)
         END IF
      END IF
      RETURN
      END
C*MODULE IOLIB   *DECK DAREAD
      SUBROUTINE DAREAD(IDAF,IODA,V,LEN,NREC,IDTYP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION V(LEN),IODA(950)
C
      COMMON /DAIOLN/ IRECLN,IRECST,IFILEN(950)
      COMMON /IOFILE/ IR,IW,IP,IIS,IPK,IDAFX,NAV,IODAX(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C         READ A LOGICAL RECORD FROM THE DAF DICTIONARY FILE
C         A LOGICAL RECORD MAY SPAN SEVERAL PHYSICAL RECORDS.
C
C         CALLING ARGUMENT -IDTYP- IS 0 OR 1 FOR FLOATING POINT
C         OR INTEGER RECORDS.  NO OTHER DATA TYPE IS ALLOWED!
C         RECORDS MUST BE PURELY FLOATING POINT OR PURELY INTEGER.
C         NO MATTER WHAT -IDTYP- IS, THE -LEN- OF THE RECORD
C         MUST BE GIVEN IN TERMS OF FLOATING POINT WORDS.  IN
C         TURN, THIS MEANS THAT INTEGER RECORDS ON 32 BIT MACHINES
C         MUST CONTAIN AN EVEN NUMBER OF INTEGERS.
C
      IF(IDAF.NE.10) THEN
         CALL RAREAD(IDAF,IODA,V,LEN,NREC,NAV)
         RETURN
      ENDIF
C
      N = IODA(NREC)
      IF(N.EQ.-1) GO TO 800
C
C         TRAP TOO LARGE READS, PERMITTING READS WITH SIZES
C         BETWEEN 1 AND THE AVAILABLE RECORD TO PROCEED.
C
      IF(LEN.LE.0           ) GO TO 810
      IF(LEN.GT.IFILEN(NREC)) GO TO 820
C
      IS = -IRECLN + 1
      NS = N
      LENT = LEN
  100 CONTINUE
         IS = IS + IRECLN
         IF = IS + LENT - 1
         IF ((IF-IS+1) .GT. IRECLN) IF = IS + IRECLN - 1
         NSP = NS
         LENW = IF - IS + 1
         CALL DARD(V(IS),LENW,IDAF,NSP,IDTYP)
         LENT = LENT - IRECLN
         NS = NS + 1
         N = NS
      IF (LENT .GE. 1) GO TO 100
      RETURN
C
  800 CONTINUE
      IF(MASWRK) WRITE(IW,9000) NREC,LEN
      GO TO 890
  810 CONTINUE
      IF(MASWRK) WRITE(IW,9010) NREC,LEN
      GO TO 890
  820 CONTINUE
      IF(MASWRK) WRITE(IW,9020) LEN,NREC,IFILEN(NREC)
      GO TO 890
C
  890 CONTINUE
      IF(MASWRK) WRITE(IW,9090)
      CALL ABRT
      RETURN
C
 9000 FORMAT(/1X,'ERROR *** ATTEMPTING A BOGUS READ OF A DAF RECORD.'/
     *       1X,'RECORD NUMBER',I5,' OF LENGTH',I10,
     *          ' WAS NEVER PREVIOUSLY WRITTEN.')
 9010 FORMAT(/1X,'ERROR *** ATTEMPTING A BOGUS READ OF A DAF RECORD.'/
     *       1X,'RECORD NUMBER',I5,' OF LENGTH',I10,' HAS NO LENGTH.')
 9020 FORMAT(/1X,'ERROR *** ATTEMPTING A BOGUS READ OF A DAF RECORD.'/
     *       1X,'ATTEMPTING TO READ',I10,' WORDS FROM RECORD NUMBER',I5/
     *       1X,'BUT THIS RECORD WAS PREVIOUSLY WRITTEN WITH ONLY',
     *          I10,' WORDS.')
 9090 FORMAT(/1X,'THIS ERROR IS LIKELY TO BE A BUG IN THE PROGRAM, BUT'/
     *       1X,'PLEASE CONSIDER INPUT ERRORS AS A POSSIBLE',
     *          ' CAUSE, TOO.'/
     *       1X,'MANUAL CHAPTER -PROG.DOC- HAS A LIST OF ALL',
     *          ' DIRECT ACCESS FILE RECORD NUMBERS,'/
     *       1X,'WHICH WILL HELP YOU UNDERSTAND WHAT THE INCORRECT',
     *          ' DATA IS SUPPOSED TO BE.'/)
      END
C*MODULE IOLIB   *DECK DAWRIT
      SUBROUTINE DAWRIT(IDAF,IODA,V,LEN,NREC,IDTYP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL NEWREC,GOPARR,DSKWRK,MASWRK
C
      DIMENSION V(LEN),IODA(950)
C
      COMMON /DAIOLN/ IRECLN,IRECST,IFILEN(950)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAFX,NAV,IODAX(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF(IDAF.LT.0) WRITE(6,*) 'BOGUS DAWRIT, IDTYP=',IDTYP
C
C         WRITE A LOGICAL RECORD ON THE DAF DICTIONARY FILE
C         A LOGICAL RECORD MAY SPAN SEVERAL PHYSICAL RECORDS
C
      IF(IDAF.NE.10) THEN
         CALL RAWRIT(IDAF,IODA,V,LEN,NREC,NAV)
         RETURN
      ENDIF
C
      N = IODA(NREC)
      IF (N .GT. 0 .AND. LEN .NE. IFILEN(NREC)) GO TO 800
C
      NEWREC = .FALSE.
      IF (N .GT. 0) GO TO 100
      IODA(NREC) = IRECST
      IFILEN(NREC) = LEN
      NEWREC = .TRUE.
      IRECST = IRECST + (LEN-1)/IRECLN + 1
      N = IODA(NREC)
  100 CONTINUE
      IST = -IRECLN + 1
      NS = N
      LENT = LEN
  120 CONTINUE
         IST = IST + IRECLN
         IF = IST + LENT - 1
         IF ((IF-IST+1) .GT. IRECLN) IF = IST+IRECLN-1
         NSP = NS
         LENW = IF - IST + 1
         CALL DAWRT(V(IST),LENW,IDAF,NSP)
         LENT = LENT - IRECLN
         NS = NS + 1
         N = NS
      IF (LENT .GE. 1) GO TO 120
      IF (NEWREC .AND. MASWRK)
     *      WRITE(UNIT=IDAF,REC=1) IRECST,IODA,IFILEN,IS,IPK
      RETURN
C
  800 CONTINUE
      WRITE (IW,9008) ME,NREC,LEN,IFILEN(NREC)
      CALL ABRT
      RETURN
C
 9008 FORMAT(1X,'*** ERROR *** IN -DAWRIT- ROUTINE ON NODE',I4/
     *       1X,'DAWRIT HAS REQUESTED A RECORD WITH LENGTH',
     *       1X,'DIFFERENT THAN BEFORE - ABORT FORCED.'/
     *       1X,'DAF RECORD ',I5,' NEW LENGTH =',I10,
     *                           ' OLD LENGTH =',I10)
      END
C*MODULE IOLIB   *DECK DAWRT
      SUBROUTINE DAWRT(V,LEN,IDAF,NS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION V(LEN)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- WRITE A PHYSICAL RECORD ON THE DAF -----
C
      IF (MASWRK) WRITE (UNIT=IDAF, REC=NS) V
      RETURN
      END
C*MODULE IOLIB   *DECK OPENDA
      SUBROUTINE OPENDA(IREST)
C
C     - - - - OPEN MASTER DICTIONARY FILE 10 - - - -
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT
C
*UNX  PARAMETER (MXUNIT=299)
*UNX  CHARACTER*256 FILENM,ENVBUF
*UNX  COMMON /ENVIR/ ENVBUF(MXUNIT)
C
      COMMON /DAIOLN/ IRECLN,IRECST,IFILEN(950)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
C
      IDAF = 10
      IRECLN=NRASIZ(IDAF)
C
      IF (MASWRK) THEN
      NFTOPN(IDAF) =1
C
*IBM  OPEN (UNIT=IDAF, FILE='DICTNRY', STATUS='UNKNOWN',
*IBM *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=8*IRECLN)
C
*UNX  IF(ISGDDI) THEN
*UNX     FILENM=ENVBUF(IDAF)
*UNX     IF(PAROUT.AND.NODEXT(IDAF).EQ.0) CALL ADDNANODE(FILENM,MEGLOB)
*UNX  ELSE
*UNX     CALL GETENV('DICTNRY',FILENM)
*UNX  ENDIF
*UNX  OPEN (UNIT=IDAF, FILE=FILENM, STATUS='UNKNOWN',
*UNX *      ACCESS='DIRECT', FORM='UNFORMATTED',
*UNX *      RECL=8*IRECLN)
C
*VMS  OPEN (UNIT=IDAF, FILE='DICTNRY', STATUS='UNKNOWN',
*VMS *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=2*IRECLN)
C
      END IF
C
C     ----- IS THIS A NEW OR OLD DAF FILE? -----
C     EITHER MARK THE NEW DAF RECORDS AS EMPTY
C     OR ELSE LOAD THE OLD DAF DIRECTORY
C
      IF(IREST.EQ.0) THEN
         IRECST = 1
         DO 100 I = 1,950
            IODA(I) = -1
  100    CONTINUE
         IRECST = IRECST + 1
         IF(MASWRK) WRITE(UNIT=IDAF, REC=1) IRECST,IODA,IFILEN,IS,IPK
      ELSE
         IF(MASWRK) READ (UNIT=IDAF, REC=1) IRECST,IODA,IFILEN,IS,IPK
         IF(GOPARR) THEN
            CALL DDI_BCAST(200,'I',IRECST,1,MASTER)
            CALL DDI_BCAST(201,'I',IODA,950,MASTER)
            CALL DDI_BCAST(202,'I',IFILEN,950,MASTER)
            CALL DDI_BCAST(203,'I',IS,1,MASTER)
            CALL DDI_BCAST(204,'I',IPK,1,MASTER)
         END IF
      END IF
      RETURN
      END
C*MODULE IOLIB   *DECK MQDARE
      SUBROUTINE MQDARE(IDAF,IODA,V,LEN,NREC,IDTYP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION V(LEN),IODA(400)
C
      COMMON /IOFILE/ IR,IW,IP,IIS,IPK,IDAFX,NAV,IODAX(950)
      COMMON /MQDAIO/ IRECLN,IRECST,IFILEN(400)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C         READ A LOGICAL RECORD FROM THE DAF DICTIONARY FILE
C         A LOGICAL RECORD MAY SPAN SEVERAL PHYSICAL RECORDS.
C
C         CALLING ARGUMENT -IDTYP- IS 0 OR 1 FOR FLOATING POINT
C         OR INTEGER RECORDS.  NO OTHER DATA TYPE IS ALLOWED!
C         RECORDS MUST BE PURELY FLOATING POINT OR PURELY INTEGER.
C         NO MATTER WHAT -IDTYP- IS, THE -LEN- OF THE RECORD
C         MUST BE GIVEN IN TERMS OF FLOATING POINT WORDS.  IN
C         TURN, THIS MEANS THAT INTEGER RECORDS ON 32 BIT MACHINES
C         MUST CONTAIN AN EVEN NUMBER OF INTEGERS.
C
      N = IODA(NREC)
      IF(N.EQ.-1) GO TO 800
      IS = -IRECLN + 1
      NS = N
      LENT = LEN
  100 CONTINUE
         IS = IS + IRECLN
         IF = IS + LENT - 1
         IF ((IF-IS+1) .GT. IRECLN) IF = IS + IRECLN - 1
         NSP = NS
         LENW = IF - IS + 1
         CALL DARD(V(IS),LENW,IDAF,NSP,IDTYP)
         LENT = LENT - IRECLN
         NS = NS + 1
         N = NS
      IF (LENT .GE. 1) GO TO 100
      RETURN
C
  800 CONTINUE
      IF (MASWRK) WRITE(IW,9000) NREC,LEN
      CALL ABRT
      RETURN
C
 9000 FORMAT(1X,'*** ERROR ***, ATTEMPT TO READ A -MCQD50- RECORD',
     *         ' THAT WAS NEVER WRITTEN.'/1X,'NREC,LEN=',I5,I10)
      END
C*MODULE IOLIB   *DECK MQDAWR
      SUBROUTINE MQDAWR(IDAF,IODA,V,LEN,NREC,IDTYP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL NEWREC,GOPARR,DSKWRK,MASWRK
C
      DIMENSION V(LEN),IODA(400)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAFX,NAV,IODAX(950)
      COMMON /MQDAIO/ IRECLN,IRECST,IFILEN(400)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C         WRITE A LOGICAL RECORD ON THE DAF DICTIONARY FILE
C         A LOGICAL RECORD MAY SPAN SEVERAL PHYSICAL RECORDS
C
      IF(IDAF.LT.0) WRITE(6,*) 'BOGUS DAWRIT, IDTYP=',IDTYP
C
      N = IODA(NREC)
      IF (N .GT. 0 .AND. LEN .NE. IFILEN(NREC)) GO TO 800
      NEWREC = .FALSE.
      IF (N .GT. 0) GO TO 100
      IODA(NREC) = IRECST
      IFILEN(NREC) = LEN
      NEWREC = .TRUE.
      IRECST = IRECST + (LEN-1)/IRECLN + 1
      N = IODA(NREC)
  100 CONTINUE
      IST = -IRECLN + 1
      NS = N
      LENT = LEN
  120 CONTINUE
         IST = IST + IRECLN
         IF = IST + LENT - 1
         IF ((IF-IST+1) .GT. IRECLN) IF = IST+IRECLN-1
         NSP = NS
         LENW = IF - IST + 1
         CALL DAWRT(V(IST),LENW,IDAF,NSP)
         LENT = LENT - IRECLN
         NS = NS + 1
         N = NS
      IF (LENT .GE. 1) GO TO 120
      IF (NEWREC .AND. MASWRK)
     *      WRITE(UNIT=IDAF,REC=1) IRECST,IODA,IFILEN,IS,IPK
      RETURN
C
  800 CONTINUE
      IF (MASWRK) WRITE (IW,9008) NREC,LEN,IFILEN(NREC)
      CALL ABRT
      RETURN
C
 9008 FORMAT(1X,'MQDAWR HAS REQUESTED A RECORD WITH LENGTH',
     *       1X,'DIFFERENT THAN BEFORE - ABORT FORCED.'/
     *       1X,'MCQD50 RECORD ',I5,' NEW LENGTH =',I5,
     *          ' OLD LENGTH =',I5)
      END
C*MODULE IOLIB   *DECK MQOPDA
      SUBROUTINE MQOPDA(IREST)
C=====================================================
C     A VARIANT OF OPENDA CREATED BY H. NAKANO 8/14/96
C=====================================================
C
C     - - - - OPEN RANDOM ACCESS FILE - - - -
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
*UNX  CHARACTER*256 FILENM
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MQDAIO/ IRECLN,IRECST,IFILEN(400)
      COMMON /MQIOFI/ IDAF50,NAV50,IODA50(400)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
*IBM  IRECLN = 512
*UNX  IRECLN = 1023
*VMS  IRECLN = 512
C
      IF (MASWRK) THEN
C
*IBM  OPEN (UNIT=IDAF50, FILE='MCQD50', STATUS='UNKNOWN',
*IBM *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=8*IRECLN)
C
*UNX  CALL GETENV('MCQD50',FILENM)
*UNX  OPEN (UNIT=IDAF50, FILE=FILENM, STATUS='UNKNOWN',
*UNX *      ACCESS='DIRECT', FORM='UNFORMATTED',
*UNX *      RECL=8*IRECLN)
C
*VMS  OPEN (UNIT=IDAF50, FILE='MCQD50', STATUS='UNKNOWN',
*VMS *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=2*IRECLN)
C
      END IF
C
C     ----- IS THIS A NEW OR OLD DAF FILE? -----
C     EITHER MARK THE NEW DAF RECORDS AS EMPTY
C     OR ELSE LOAD THE OLD DAF DIRECTORY
C
      IF(IREST.EQ.0) THEN
         IRECST = 1
         DO 100 I = 1,400
            IODA50(I) = -1
  100    CONTINUE
         IRECST = IRECST + 1
         IF(MASWRK) WRITE(UNIT=IDAF50,REC=1) IRECST,IODA50,IFILEN,IS,IPK
      ELSE
         IF(MASWRK) READ (UNIT=IDAF50,REC=1) IRECST,IODA50,IFILEN,IS,IPK
         IF(GOPARR) THEN
            CALL DDI_BCAST(200,'I',IRECST,1,MASTER)
            CALL DDI_BCAST(201,'I',IODA50,400,MASTER)
            CALL DDI_BCAST(202,'I',IFILEN,400,MASTER)
            CALL DDI_BCAST(203,'I',IS,1,MASTER)
            CALL DDI_BCAST(204,'I',IPK,1,MASTER)
         END IF
      END IF
      RETURN
      END
C*MODULE IOLIB   *DECK PARENV
      SUBROUTINE PARENV(FNAME,FILENM,IOUT)
C
      IMPLICIT INTEGER (A-Z)
C
      PARAMETER (MAXLEN=256)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT
C
      INTEGER CFILENM(MAXLEN)
C
      CHARACTER*(*) FNAME
      CHARACTER*256 FILENM
      CHARACTER*256 DUMMY
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
C
C     THIS SUBROUTINE DECIDES WHETHER OR NOT SLAVES SHOULD OPEN A FILE.
C     IF A FILE IS TO BE OPENED, THE SLAVES GET THE NAME OF THE FILE
C     TO OPEN.
C
      IOUT = 0
C
      IF ((FNAME.EQ.'INPUT').OR.(FNAME.EQ.'OUTPUT').OR.
     *    (FNAME.EQ.'PUNCH').OR.(FNAME.EQ.'IRCDATA').OR.
     *    (.NOT.DSKWRK).OR.(NPROC.EQ.1)) THEN
         IF (.NOT.MASWRK) IOUT = 1
C
C        THIS IS USEFUL FOR DEBUGGING. SLAVE NODES ARE NOT SUPPOSED
C        TO NORMALLY WRITE SOMETHING OUT TO IW. AS USUAL, WRITING TO
C        THE SAME FILE BY SEVERAL NODES CAN LEAD TO FILE CONTENT
C        CORRUPTION.
C
         IF(ISGDDI.AND.FNAME.EQ.'OUTPUT') IOUT = 0
         RETURN
      END IF
C
C     IF FILENM IS EMPTY, ABRT ALL SLAVES; ELSE STRIP OFF THE PATH
C     AND SEND THE NAME TO ALL SLAVES.
C
      IF (MASWRK) THEN
C
         IEND = 0
         IF (FILENM(1:1).EQ.' ') THEN
            IEND = 1
            CALL DDI_BCAST(205,'I',IEND,1,MASTER)
            RETURN
         END IF
C
         DUMMY = FILENM
         INDEX = 0
C
C             NEXT CODE STRIPS PATH NAME IF ISTRIP IS 1
C             A 'SED' HACK CAN BE USED TO PREVENT STRIPPING.
C
         ISTRIP=1
         IF(ISTRIP.EQ.1) THEN
            DO 10 I = MAXLEN,1,-1
               IF (FILENM(I:I).EQ.'/') THEN
                  INDEX = I
                  GO TO 20
               END IF
   10       CONTINUE
   20       CONTINUE
C
            IF (INDEX.NE.0) THEN
               LDIFF = MAXLEN - INDEX
               DO 30 I = 1,LDIFF
                  INDEX = INDEX + 1
                  FILENM(I:I) = FILENM(INDEX:INDEX)
   30          CONTINUE
            END IF
         END IF
C
         LWORD = 0
         DO 40 I = 1,MAXLEN
            IF ((FILENM(I:I).EQ.CHAR(0)).OR.(FILENM(I:I).EQ.' '))
     *        GO TO 50
            LWORD = LWORD + 1
   40    CONTINUE
   50    CONTINUE
      END IF
C
      CALL DDI_BCAST(205,'I',IEND,1,MASTER)
      IF ((.NOT.MASWRK).AND.(IEND.EQ.1)) CALL ABRT
C
      IF (MASWRK) THEN
         DO 100 I=1,MAXLEN
            CFILENM(I) = ICHAR(FILENM(I:I))
  100    CONTINUE
      END IF
C
      CALL DDI_BCAST(206,'I',CFILENM,MAXLEN,MASTER)
      CALL DDI_BCAST(207,'I',LWORD,1,MASTER)
C
C     MASTER CAN RETURN NOW.
C
      IF (MASWRK) THEN
         FILENM = DUMMY
         RETURN
      END IF
C
      DO 150 I=1,MAXLEN
         FILENM(I:I) = CHAR(CFILENM(I))
  150 CONTINUE
C
C     APPEND NODE NUMBER, IN ORDER TO OPEN UNIQUE FILE NAMES.
C
      DO 175 I = 1,LWORD
         DUMMY(I:I) = FILENM(I:I)
  175 CONTINUE
C
                          NDIGIT=3
      IF(NPROC.GE.1000)   NDIGIT=4
      IF(NPROC.GE.10000)  NDIGIT=5
      IF(NPROC.GE.100000) NDIGIT=6
C
      IF(NDIGIT.EQ.3) THEN
         WRITE(UNIT=DUMMY(LWORD+1:LWORD+4),FMT='(1H.,I3.3)') ME
         DUMMY(LWORD+5:LWORD+5) = CHAR(0)
      ELSE IF(NDIGIT.EQ.4) THEN
         WRITE(UNIT=DUMMY(LWORD+1:LWORD+5),FMT='(1H.,I4.4)') ME
         DUMMY(LWORD+6:LWORD+6) = CHAR(0)
      ELSE IF(NDIGIT.EQ.5) THEN
         WRITE(UNIT=DUMMY(LWORD+1:LWORD+6),FMT='(1H.,I5.5)') ME
         DUMMY(LWORD+7:LWORD+7) = CHAR(0)
      ELSE
         IF(MASWRK) WRITE(6,*) 'PARENV: TOO MANY CPUS REQUESTED'
         CALL ABRT
      END IF
C
      FILENM = DUMMY
C
      RETURN
      END
C*MODULE IOLIB   *DECK PKREAD
      SUBROUTINE PKREAD(IS,XP,XK,IX,NX,MAX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XP(*),XK(*),IX(*)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      IF (LABSIZ.EQ.1) THEN
         IF(NWDVAR.EQ.2) MAX2 = MAX
         IF(NWDVAR.EQ.1) MAX2 = (MAX+1)/2
      ELSE IF (LABSIZ.EQ.2) THEN
         IF(NWDVAR.EQ.2) MAX2 = MAX*2
         IF(NWDVAR.EQ.1) MAX2 = MAX
      ELSE
         IF(MASWRK) WRITE(6,*) 'PKREAD: CONFUSION WITH -LABSIZ-'
         CALL ABRT
      END IF
      CALL PKRD(IS,XP,XK,IX,NX, MAX, MAX2 )
      RETURN
      END
C*MODULE IOLIB   *DECK PKRD
      SUBROUTINE PKRD(IS,XP,XK,IX,NX,MAX,MAX2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XP(MAX),XK(MAX),IX(MAX2)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF (DSKWRK.OR.MASWRK) READ(IS,END=200,ERR=300) NX,IX,XP,XK
      RETURN
C
  200 CONTINUE
      WRITE(6,9010) ME,IS
 9010 FORMAT(1X,'PKRD: NODE',I4,
     *          ' ENCOUNTERED UNEXPECTED END OF FILE READING UNIT',I4)
      CALL ABRT
C
  300 CONTINUE
      WRITE(6,9020) ME,IS
 9020 FORMAT(1X,'PKRD: NODE',I4,
     *          ' ENCOUNTERED I/O ERROR READING UNIT',I4)
      CALL ABRT
C
      RETURN
      END
C*MODULE IOLIB   *DECK PREAD
      SUBROUTINE PREAD(IS,XX,IX,NX,MAX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XX(MAX),IX(*)
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      IF (LABSIZ.EQ.1) THEN
         IF(NWDVAR.EQ.2) MAX2 = MAX
         IF(NWDVAR.EQ.1) MAX2 = (MAX+1)/2
      ELSE IF (LABSIZ.EQ.2) THEN
         IF(NWDVAR.EQ.2) MAX2 = MAX*2
         IF(NWDVAR.EQ.1) MAX2 = MAX
      ELSE
         IF(MASWRK) WRITE(6,*) 'PREAD: CONFUSION WITH -LABSIZ-'
         CALL ABRT
      END IF
C
      CALL PRD(IS,XX,IX,NX, MAX, MAX2 )
C
C       MOST LIKELY, THE CORRESPONDING CODE HAS NOT BEEN CHANGED.
C       IT IS ALSO POSSIBLE THAT THE NUMBER OF INTEGRALS EXACTLY MATCHES
C       THE NINTIC CAPACITY, THUS ONE EMPTY PWRITE IS DONE TO INDICATE
C       NO MORE INTEGRALS.
C
      IF(NX.EQ.0 .AND. IS.EQ.8 .AND. NINTIC.NE.0 .AND. MASWRK) THEN
         WRITE(6,*) 'WARNING: NO INTEGRALS TO READ: NINTIC BUG?'
      END IF
      RETURN
      END
C*MODULE IOLIB   *DECK PRD
      SUBROUTINE PRD(IS,XX,IX,NX,MAX,MAX2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XX(MAX),IX(MAX2)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF (DSKWRK.OR.MASWRK) READ(IS,END=200,ERR=300) NX,IX,XX
      RETURN
C
  200 CONTINUE
      WRITE(6,9010) ME,IS
 9010 FORMAT(1X,'PRD: NODE',I4,
     *          ' ENCOUNTERED UNEXPECTED END OF FILE READING UNIT',I4)
      CALL ABRT
C
  300 CONTINUE
      WRITE(6,9020) ME,IS
 9020 FORMAT(1X,'PRD: NODE',I4,
     *          ' ENCOUNTERED I/O ERROR READING UNIT',I4)
      CALL ABRT
C
      RETURN
      END
C*MODULE IOLIB   *DECK PREADP
      SUBROUTINE PREADP(NFT,XX,IX,NXX,NINTMX,KAP,IFLG,JFLG,NPROC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XX(NINTMX),IX(NINTMX),JFLG(0:NPROC-1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROCX,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
C     ----- PARALLEL FORM OF -PREAD- ROUTINE -----
C     THIS ROUTINE READS A SINGLE RECORD, FROM WHICHEVER NODE WHOSE
C     TURN IS NEXT, AND BROADCASTS IT TO ALL NODES.  THIS MAKES A
C     FILE WHICH HAS BEEN DISTRIBUTED ACROSS NODES AVAILABLE IN ITS
C     ENTIRETY TO ALL NODES.
C
C     THIS ROUTINE READS IN A ROUND-ROBIN FASHION, WITH NODE -KAP-
C     READING THE 1ST RECORD FROM NODES 0,1,...,NPROC-1, THEN THE 2ND
C     RECORDS FROM EACH, ETC, ETC.  -JFLG- KEEPS TRACK OF END-OF-FILE
C     ON EACH NODE, WHEREAS -IFLG- KEEPS TRACK OF END-OF-FILE ON ALL
C     NODES, IFLG.EQ.0 ON EXIT MEANS ALL NODES HAVE PREVIOUSLY HIT
C     END OF FILE, AND THUS NO DATA RECORD IS RETURNED.
C
C
  100 CONTINUE
      KAP = KAP+1
      IF(KAP.EQ.NPROC) THEN
         IF(IFLG.EQ.0) RETURN
         KAP = 0
         IFLG= 0
      END IF
C
      IF(JFLG(KAP).GT.0) THEN
         IFLG=1
         IF(KAP.EQ.ME) CALL PREAD(NFT,XX,IX,NXX,NINTMX)
         CALL DDI_BCAST(1205,'I',NXX,1,KAP)
         NINT = ABS(NXX)
         IF (LABSIZ.EQ.1) THEN
            IF(NWDVAR.EQ.2) NINT2 = NINT
            IF(NWDVAR.EQ.1) NINT2 = (NINT+1)/2
         ELSE IF (LABSIZ.EQ.2) THEN
            IF(NWDVAR.EQ.2) NINT2 = NINT*2
            IF(NWDVAR.EQ.1) NINT2 = NINT
         ELSE
            IF(MASWRK) WRITE(6,*) 'PREADP: CONFUSION WITH -LABSIZ-'
            CALL ABRT
         END IF
         CALL DDI_BCAST(1210,'F',XX,NINT,KAP)
         CALL DDI_BCAST(1215,'I',IX,NINT2,KAP)
         JFLG(KAP) = NXX
         RETURN
      END IF
C
      GO TO 100
      END
C*MODULE IOLIB   *DECK PXREAD
      SUBROUTINE PXREAD(NFT,X,XX,MX,NX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION X(NX),XX(NX)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF (DSKWRK.OR.MASWRK) READ(NFT,END=200,ERR=300) X,XX,MX
      RETURN
C
  200 CONTINUE
      WRITE(6,9010) ME,NFT
 9010 FORMAT(1X,'PXREAD: NODE',I4,
     *          ' ENCOUNTERED UNEXPECTED END OF FILE READING UNIT',I4)
      CALL ABRT
C
  300 CONTINUE
      WRITE(6,9020) ME,NFT
 9020 FORMAT(1X,'PXREAD: NODE',I4,
     *          ' ENCOUNTERED I/O ERROR READING UNIT',I4)
      CALL ABRT
C
      RETURN
      END
C*MODULE IOLIB   *DECK PUVIB
      SUBROUTINE PUVIB(IFCM,IW,RSTART,NCOORD,IVIB,IATOM,ICOORD,
     *                 E,EG,DIP)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000, MXFRG=1050, MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      DIMENSION EG(NCOORD), DIP(3), BLANK(1), VIBWRD(1)
C
      LOGICAL RSTART,GOPARR,DSKWRK,MASWRK,FGONLY
C
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
C
      DATA BLANK/8H        /, VIBWRD/8H $VIB   /
C
C     ----- SAVE DATA FOR CURRENT VIBRATION FOR FORCE RESTARTS -----
C     THIS IS CRUCIAL DATA, SO IF POSSIBLE FLUSH THE BUFFER TO DISK.
C     AND FOR GOOD MEASURE, PUT A COPY IN THE PRINTOUT.
C
      FGONLY = NUM.EQ.0  .AND.  NFRG.GT.0
C
      IF(.NOT.MASWRK  .OR.  NPRTGO.LE.0) RETURN
C
      IF(IVIB.EQ.0) WRITE(IFCM,9000) VIBWRD
      WRITE(IFCM,9020) BLANK,IVIB,IATOM,ICOORD,E
C
      IF (.NOT. FGONLY) WRITE(IFCM,9040) EG
      IF(NFRG.GT.0) THEN
         DO IFR=1,NFRG
            WRITE(IFCM,9040) (DEFT(IFRC,IFR),IFRC=1,3)
            WRITE(IFCM,9040) (TORQ(IFRC,IFR),IFRC=1,3)
         ENDDO
      END IF
      WRITE(IFCM,9040) DIP
      CALL FLSHBF(IFCM)
C
      IF(RSTART) RETURN
      WRITE(IW,9100) VIBWRD
      WRITE(IW,9120) BLANK,IVIB,IATOM,ICOORD,E
      IF (.NOT. FGONLY) WRITE(IW,9140) EG
C
      IF(NFRG.GT.0) THEN
         DO IFR=1,NFRG
            WRITE(IW,9040) (DEFT(IFRC,IFR),IFRC=1,3)
            WRITE(IW,9040) (TORQ(IFRC,IFR),IFRC=1,3)
         ENDDO
      END IF
      WRITE(IW,9140) DIP
      RETURN
C
 9000 FORMAT(A8)
 9020 FORMAT(A8,' IVIB=',I4,' IATOM=',I4,' ICOORD=',I4,' E=',F20.10)
 9040 FORMAT(1P,5E16.9)
 9100 FORMAT(1X,A8)
 9120 FORMAT(1X,A8,' IVIB=',I4,' IATOM=',I4,' ICOORD=',I4,' E=',F20.10)
 9140 FORMAT(1X,1P,5E16.9)
      END
C*MODULE IOLIB   *DECK PKWRIT
      SUBROUTINE PKWRIT(IS,XP,XK,IX,NX,MAX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XP(*),XK(*),IX(*)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      IF (LABSIZ.EQ.1) THEN
         IF(NWDVAR.EQ.2) MAX2 = MAX
         IF(NWDVAR.EQ.1) MAX2 = (MAX+1)/2
      ELSE IF (LABSIZ.EQ.2) THEN
         IF(NWDVAR.EQ.2) MAX2 = MAX*2
         IF(NWDVAR.EQ.1) MAX2 = MAX
      ELSE
         IF(MASWRK) WRITE(6,*) 'PKWRIT: CONFUSION WITH -LABSIZ-'
         CALL ABRT
      END IF
      CALL PKWRT(IS,XP,XK,IX,NX, MAX, MAX2 )
      RETURN
      END
C*MODULE IOLIB   *DECK PKWRT
      SUBROUTINE PKWRT(IS,XP,XK,IX,NX,MAX,MAX2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XP(MAX),XK(MAX),IX(MAX2)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF (DSKWRK.OR.MASWRK) WRITE(IS,ERR=300) NX,IX,XP,XK
      RETURN
C
  300 CONTINUE
      WRITE(6,9020) ME,IS
 9020 FORMAT(1X,'PKWRT: NODE',I4,
     *          ' ENCOUNTERED I/O ERROR READING UNIT',I4)
      CALL ABRT
C
      RETURN
      END
C*MODULE IOLIB   *DECK PWRIT
      SUBROUTINE PWRIT(IS,XX,IX,NX,MAX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XX(MAX),IX(*)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      IF (LABSIZ.EQ.1) THEN
         IF(NWDVAR.EQ.2) MAX2 = MAX
         IF(NWDVAR.EQ.1) MAX2 = (MAX+1)/2
      ELSE IF (LABSIZ.EQ.2) THEN
         IF(NWDVAR.EQ.2) MAX2 = MAX*2
         IF(NWDVAR.EQ.1) MAX2 = MAX
      ELSE
         IF(MASWRK) WRITE(6,*) 'PWRIT: CONFUSION WITH -LABSIZ-'
         CALL ABRT
      END IF
C
      CALL PWRT(IS,XX,IX,NX, MAX, MAX2 )
      RETURN
      END
C*MODULE IOLIB   *DECK PWRT
      SUBROUTINE PWRT(IS,XX,IX,NX,MAX,MAX2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION XX(MAX),IX(MAX2)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF (DSKWRK.OR.MASWRK) WRITE(IS,ERR=300) NX,IX,XX
      RETURN
C
  300 CONTINUE
      WRITE(6,9020) ME,IS
 9020 FORMAT(1X,'PWRT: NODE',I4,
     *          ' ENCOUNTERED I/O ERROR WRITING UNIT',I4)
      CALL ABRT
C
      RETURN
      END
C*MODULE IOLIB   *DECK PXWRIT
      SUBROUTINE PXWRIT(NFT,X,XX,MX,NX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION X(NX),XX(NX)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF (DSKWRK.OR.MASWRK) WRITE (NFT,ERR=300) X,XX,MX
      RETURN
C
  300 CONTINUE
      WRITE(6,9020) ME,NFT
 9020 FORMAT(1X,'PXWRIT: NODE',I4,
     *          ' ENCOUNTERED I/O ERROR WRITING UNIT',I4)
      CALL ABRT
C
      RETURN
      END
C*MODULE IOLIB   *DECK RACLOS
      SUBROUTINE RACLOS(IRAF,FSTAT)
C
      CHARACTER*(*) FSTAT
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXUNIT=299)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- CLOSE FILE IRAF -----
C
      IF(IRAF.GT.MXUNIT) THEN
         WRITE(IW,900) IRAF,MXUNIT
         CALL ABRT
      END IF
      IF(NFTOPN(IRAF).EQ.0) RETURN
  900 FORMAT(1X,'RACLOS: ATTEMPT TO CLOSE FILE',I5,
     *          ' GREATER THAN MAXIMUM',I5)
C
      IF(MASWRK  .OR.  DSKWRK) CLOSE(UNIT=IRAF, STATUS=FSTAT)
      NFTOPN(IRAF) = 0
      RETURN
      END
C*MODULE IOLIB   *DECK RAOPEN
      SUBROUTINE RAOPEN(IRAF,IORA,LPHYS,NUMREC,LENREC,NPRINT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,PAROUT,ISGDDI
C
      PARAMETER (MXUNIT=299)
C
      CHARACTER*6 FILENM
*UNX  CHARACTER*1 NULL
*UNX  CHARACTER*256 PATHNM,ENVBUF
*UNX  COMMON /ENVIR/ ENVBUF(MXUNIT)
C
      DIMENSION IORA(NUMREC)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RAIOLN/ JRECLN(10),JRECST(10)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
C
      DATA CHECK/8HCHECK    /
C
C     THIS ROUTINE, AND OTHERS IN THIS GROUP CONTROL THE RANDOM
C     ACCESS SORTFILE IRAF, WHICH IS USED FOR SORTING MANY THINGS,
C     SUCH AS ATOMIC INTEGRALS, TRANSFORMED INTEGRALS, MCSCF
C     HESSIAN MATRIX, 2-PARTICLE DENSITY, ETC.
C     EACH TIME A SORT IS DONE, THE DISK REQUIREMENTS CHANGE.
C     HENCE RAOPEN AND RACLOS BENEFIT MUCH FROM THE FORTRAN-77
C     OPEN AND CLOSE STATEMENTS. IN THE ABSENCE OF FORTRAN-77,
C     ONE MAKES FILE 20 LARGE ENOUGH FOR THE BIGGEST SORT.
C     IF ONE CANNOT TELL HOW BIG THIS IS, ONE OPENS A FIXED
C     AND VERY LARGE SORTFILE.
C
C     -NUMREC- LOGICAL RECORDS OF LENGTH -LENREC- ARE SPREAD OVER AS
C     MANY PHYSICAL RECORDS OF LENGTH -IRECLN- AS NEEDED, SO THAT
C     -MXREC- PHYSICAL RECORDS ARE REQUIRED.
C     IF -LPHYS- IS NONZERO, AND THE RECORD SIZE -LENREC- IS SMALLER
C     THAN THE DEFAULT PHYSICAL LENGTH, THE PHYSICAL LENGTH IS
C     TRIMMED TO JUST THE SIZE NEEDED.
C
      IF(IRAF.GT.MXUNIT) THEN
         WRITE(IW,900) IRAF,MXUNIT
         CALL ABRT
      END IF
      IF(NFTOPN(IRAF).EQ.1) RETURN
      NFTOPN(IRAF) = 1
  900 FORMAT(1X,'RAOPEN: ATTEMPT TO OPEN FILE',I5,
     *          ' GREATER THAN MAXIMUM',I5)
C
C     ----- SET THE PHYSICAL RECORD LENGTH -----
C
      IRECLN=NRASIZ(IRAF)
      IF(LPHYS.NE.0  .AND.  LENREC.LT.IRECLN) IRECLN=LENREC
C
C     ----- COUNT HOW MANY PHYSICAL RECORDS ARE NEEDED -----
C
      MXREC = (((LENREC-1)/IRECLN)+1)*NUMREC
      JRECST(IRAF/10)=1
      JRECLN(IRAF/10)=IRECLN
      IF(EXETYP.EQ.CHECK) RETURN
C
C     ----- OPEN THE RANDOM ACCESS FILE -----
C
C        BY CONVENTION, FILES ENDING IN 0'S ARE DIRECT ACCESS,
C        AT PRESENT ONLY FILE 20 AND 30 ARE USED.
C
      FILENM='      '
      IF(IRAF.EQ.20) FILENM = 'DASORT'
      IF(IRAF.EQ.30) FILENM = 'DAFL30'
      IF(IRAF.EQ.40) FILENM = 'FMODAT'
      IF(FILENM.EQ.'      ') THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR IN RAOPEN WITH UNIT NUMBER',IRAF
         CALL ABRT
      END IF
C
      IF(NPRINT.NE.-5  .AND.  MASWRK)
     *     WRITE(IW,9000) FILENM,NUMREC,LENREC,MXREC,IRECLN
C
      IF (MASWRK  .OR.  DSKWRK) THEN
C
*IBM  OPEN (UNIT=IRAF, FILE=FILENM, STATUS='UNKNOWN',
*IBM *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=8*IRECLN)
C
*UNX  IF(MASWRK) CALL GETENV(FILENM,PATHNM)
*UNX  IF(ISGDDI) THEN
*UNX     PATHNM=ENVBUF(IRAF)
*UNX     IF(PAROUT.AND.NODEXT(IRAF).EQ.0) CALL ADDNANODE(PATHNM,MEGLOB)
*UNX  ELSE
*UNX     CALL PARENV(FILENM,PATHNM,IOUT)
*UNX     IF (IOUT.EQ.1) RETURN
*UNX  ENDIF
*UNX  NULL = CHAR(0)
*UNX  DO 3 KOL=1,256
*UNX     IF(PATHNM(KOL:KOL).EQ.' '  .OR.
*UNX *      PATHNM(KOL:KOL).EQ.NULL) GO TO 4
*UNX3 CONTINUE
*UNX  KOL=257
*UNX4 CONTINUE
*UNX  IF(KOL.EQ.1) THEN
*UNX     WRITE(IW,1) FILENM
*UNX     CALL ABRT
*UNX  END IF
*UNX  KOL=KOL-1
*UNX  OPEN (UNIT=IRAF, FILE=PATHNM(1:KOL), STATUS='UNKNOWN',
*UNX *      ACCESS='DIRECT', FORM='UNFORMATTED',
*UNX *      RECL=8*IRECLN)
*UNX1 FORMAT(1X,'YOU MUST ASSIGN GENERIC NAME ',A,' WITH A SETENV.')
C
*VMS  OPEN (UNIT=IRAF, FILE=FILENM, STATUS='UNKNOWN',
*VMS *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=2*IRECLN)
C
      END IF
C
C      ----- INITIALIZE FOR EMPTY SORTFILE ----
C
      DO 100 I = 1,NUMREC
         IORA(I) = -1
  100 CONTINUE
      RETURN
C
 9000 FORMAT(1X,'OPENING FILE ',A6,' WITH',I8,' LOGICAL RECORDS OF',I8,
     *          ' WORDS'/1X,'WITH A MAXIMUM OF',I12,
     *          ' PHYSICAL RECORDS OF',I8,' WORDS')
      END
C*MODULE IOLIB   *DECK RAOPEN2
      SUBROUTINE RAOPEN2(IRAF,IORA,LPHYS,NUMREC,LENREC,LDAR,NPRINT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT
      PARAMETER (MXUNIT=299)
C
      CHARACTER*7 FILENM
*UNX  CHARACTER*1 NULL
*UNX  CHARACTER*256 PATHNM,ENVBUF
*UNX  COMMON /ENVIR/ ENVBUF(MXUNIT)
C
      DIMENSION IORA(NUMREC)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RAIOLN/ JRECLN(10),JRECST(10)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
C
      DATA CHECK/8HCHECK    /
C
C     THIS ROUTINE, AND OTHERS IN THIS GROUP CONTROL THE RANDOM
C     ACCESS SORTFILE IRAF, WHICH IS USED FOR SORTING MANY THINGS,
C     SUCH AS ATOMIC INTEGRALS, TRANSFORMED INTEGRALS, MCSCF
C     HESSIAN MATRIX, 2-PARTICLE DENSITY, ETC.
C     EACH TIME A SORT IS DONE, THE DISK REQUIREMENTS CHANGE.
C     HENCE RAOPEN AND RACLOS BENEFIT MUCH FROM THE FORTRAN-77
C     OPEN AND CLOSE STATEMENTS. IN THE ABSENCE OF FORTRAN-77,
C     ONE MAKES FILE 20 LARGE ENOUGH FOR THE BIGGEST SORT.
C     IF ONE CANNOT TELL HOW BIG THIS IS, ONE OPENS A FIXED
C     AND VERY LARGE SORTFILE.
C
C     DIFFERS FROM -RAOPEN- IN THAT THERE IS A FILE 40, AND
C     THE SIZE OF THE RECORDS IS A CALLING ARGUMENT -LDAR-.
C
C     -NUMREC- LOGICAL RECORDS OF LENGTH -LENREC- ARE SPREAD OVER AS
C     MANY PHYSICAL RECORDS OF LENGTH -IRECLN- AS NEEDED, SO THAT
C     -MXREC- PHYSICAL RECORDS ARE REQUIRED.
C     IF -LPHYS- IS NONZERO, AND THE RECORD SIZE -LENREC- IS SMALLER
C     THAN THE DEFAULT PHYSICAL LENGTH, THE PHYSICAL LENGTH IS
C     TRIMMED TO JUST THE SIZE NEEDED.
C
C     ----- SET THE PHYSICAL RECORD LENGTH -----
C
      IF(LDAR.EQ.0) THEN
         IRECLN=NRASIZ(IRAF)
      ELSE
         IRECLN=LDAR
      END IF
      IF(LPHYS.NE.0  .AND.  LENREC.LT.IRECLN) IRECLN=LENREC
C
C     ----- COUNT HOW MANY PHYSICAL RECORDS ARE NEEDED -----
C
      MXREC = (((LENREC-1)/IRECLN)+1)*NUMREC
      JRECST(IRAF/10)=1
      JRECLN(IRAF/10)=IRECLN
      IF(EXETYP.EQ.CHECK) RETURN
C
C        BY CONVENTION, FILES ENDING IN 0'S ARE DIRECT ACCESS,
C        AT PRESENT ONLY FILE 20, 30, AND 40 ARE USED.
C
      FILENM='      '
      NFILNM=6
      IF(IRAF.EQ.20) FILENM = 'DASORT'
      IF(IRAF.EQ.30) FILENM = 'DAFL30'
      IF(IRAF.EQ.40) FILENM = 'SOCCDAT'
      IF(IRAF.EQ.40) NFILNM = 7
      IF(FILENM(1:1).EQ.' ') THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR IN RAOPEN2 WITH UNIT NUMBER',IRAF
         CALL ABRT
      END IF
C
      IF(NPRINT.NE.-5  .AND.  MASWRK)
     *     WRITE(IW,9000) FILENM(1:NFILNM),NUMREC,LENREC,MXREC,IRECLN
C
C     ----- OPEN THE RANDOM ACCESS FILE -----
C
      IF (MASWRK  .OR.  DSKWRK) THEN
C
*IBM  OPEN (UNIT=IRAF, FILE=FILENM(1:NFILNM), STATUS='UNKNOWN',
*IBM *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=8*IRECLN)
C
*UNX  IF(MASWRK) CALL GETENV(FILENM(1:NFILNM),PATHNM)
*UNX  IF(ISGDDI) THEN
*UNX     PATHNM=ENVBUF(IRAF)
*UNX     IF(PAROUT.AND.NODEXT(IRAF).EQ.0) CALL ADDNANODE(PATHNM,MEGLOB)
*UNX  ELSE
*UNX     CALL PARENV(FILENM(1:NFILNM),PATHNM,IOUT)
*UNX     IF (IOUT.EQ.1) RETURN
*UNX  ENDIF
*UNX  NULL = CHAR(0)
*UNX  DO 3 KOL=1,256
*UNX     IF(PATHNM(KOL:KOL).EQ.' '  .OR.
*UNX *      PATHNM(KOL:KOL).EQ.NULL) GO TO 4
*UNX3 CONTINUE
*UNX  KOL=257
*UNX4 CONTINUE
*UNX  IF(KOL.EQ.1) THEN
*UNX     WRITE(IW,1) FILENM(1:NFILNM)
*UNX     CALL ABRT
*UNX  END IF
*UNX  KOL=KOL-1
*UNX  OPEN (UNIT=IRAF, FILE=PATHNM(1:KOL), STATUS='UNKNOWN',
*UNX *      ACCESS='DIRECT', FORM='UNFORMATTED',
*UNX *      RECL=8*IRECLN)
*UNX1 FORMAT(1X,'YOU MUST ASSIGN GENERIC NAME ',A,' WITH A SETENV.')
C
*VMS  OPEN (UNIT=IRAF, FILE=FILENM(1:NFILNM), STATUS='UNKNOWN',
*VMS *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=2*IRECLN)
C
      END IF
C
C      ----- INITIALIZE FOR EMPTY SORTFILE ----
C
      DO 100 I = 1,NUMREC
         IORA(I) = -1
  100 CONTINUE
      RETURN
C
 9000 FORMAT(1X,'OPENING FILE ',A,' WITH',I8,' LOGICAL RECORDS OF',I8,
     *          ' WORDS'/1X,'WITH A MAXIMUM OF',I12,
     *          ' PHYSICAL RECORDS OF',I8,' WORDS')
      END
C*MODULE IOLIB   *DECK RARD
      SUBROUTINE RARD(V,LEN,IRAF,NS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION V(LEN)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- READ A PHYSICAL RECORD FROM IRAF -----
C
      IF(MASWRK  .OR.  DSKWRK) READ(UNIT=IRAF,REC=NS) V
C
      IF(GOPARR  .AND.  .NOT.DSKWRK) THEN
         CALL DDI_BCAST(225,'F',V,LEN,MASTER)
      END IF
      RETURN
      END
C*MODULE IOLIB   *DECK RAREAD
      SUBROUTINE RAREAD(IRAF,IORA,V,LEN,NREC,NAV)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(*),IORA(*)
      COMMON /RAIOLN/ JRECLN(10),JRECST(10)
C
C      ----- READ A LOGICAL RECORD FROM IRAF -----
C
      IF(IRAF.LT.0) WRITE(6,*) 'BOGUS RAREAD, NAV=',NAV
C
      IRECLN=JRECLN(IRAF/10)
      N = IORA(NREC)
      IS = -IRECLN + 1
      NS = N
      LENT = LEN
C
  100 CONTINUE
         IS = IS + IRECLN
         IF = IS + LENT - 1
         IF ((IF-IS+1) .GT. IRECLN) IF = IS + IRECLN - 1
         NSP = NS
         LENW = IF - IS + 1
         CALL RARD(V(IS),LENW,IRAF,NSP)
         LENT = LENT - IRECLN
         NS = NS + 1
         N = NS
      IF (LENT .GE. 1) GO TO 100
      RETURN
      END
C*MODULE IOLIB   *DECK RASIZE
      SUBROUTINE RASIZE(LDAR)
C
C     THIS ROUTINE RETURNS THE LENGTH OF PHYSICAL RECORDS (IN UNITS OF
C     W.P. FLOATING POINT NOS) USED BY THE DIRECT ACCESS SORT FILE IRAF.
C     SELECT A ROUND NUMBER FOR LEN, A BIT SMALLER THAN THE PHYSICAL
C     RECORD LENGTH USED IN ROUTINE RAOPEN.  SEE ROUTINE RAOPEN.
C
*VMS  LDAR=2045
*IBM  LDAR=2930
*UNX  LDAR=2045
      RETURN
      END
C*MODULE IOLIB   *DECK NRASIZ
      INTEGER FUNCTION NRASIZ(IRAF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     USED BY DIRECT ACCESS FILE OPENING ROUTINES
C
      IF(IRAF.EQ.10) THEN
*IBM      NRASIZ = 2048
*UNX      NRASIZ = 4090
*VAX      NRASIZ = 2048
      ELSE
*IBM      NRASIZ = 2934
*UNX      NRASIZ = 2048
*VAX      NRASIZ = 2046
C         PLEASE USE AN EVEN NUMBER
      ENDIF
      RETURN
      END
C*MODULE IOLIB   *DECK RAWRIT
      SUBROUTINE RAWRIT(IRAF,IORA,V,LEN,NREC,NAVM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(*),IORA(*)
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RAIOLN/ JRECLN(10),JRECST(10)
C
C     ------ WRITE A LOGICAL RECORD ON IRAF -----
C
      IF(IRAF.LT.0) WRITE(6,*) 'BOGUS RAWRIT, NAVM=',NAVM
C
      IRECST=JRECST(IRAF/10)
      IRECLN=JRECLN(IRAF/10)
      N = IORA(NREC)
      IF(N.LE.0) THEN
         IORA(NREC) = IRECST
         IRECST = IRECST + (LEN-1)/IRECLN + 1
         N = IORA(NREC)
      END IF
C
      JRECST(IRAF/10)=IRECST
      IF(GOPARR  .AND.  .NOT.(MASWRK.OR.DSKWRK)) RETURN
C
      IST = -IRECLN + 1
      NS = N
      LENT = LEN
  120 CONTINUE
         IST = IST + IRECLN
         IF = IST + LENT - 1
         IF ((IF-IST+1) .GT. IRECLN) IF = IST+IRECLN-1
         NSP = NS
         LENW = IF - IST + 1
         CALL RAWRT(V(IST),LENW,IRAF,NSP)
         LENT = LENT - IRECLN
         NS = NS + 1
         N = NS
      IF (LENT .GE. 1) GO TO 120
      RETURN
C
      END
C*MODULE IOLIB   *DECK RAWRITE
      SUBROUTINE RAWRITE(IRAF,IORA,V,LEN1,LEN,NREC,NPHYSOFF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(*),IORA(*)
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RAIOLN/ JRECLN(10),JRECST(10)
C
C     ------ WRITE A LOGICAL RECORD ON IRAF -----
C     THIS IS THE SAME AS RAWRIT EXCEPT IT ENFORCES THAT LEN1 WORDS
C     BE ALLOCATED ON IRAF FOR THIS RECORD EVEN IF ONE WRITES ONLY
C     LEN WORDS THIS TIME
C
C     NPHYSOFF SETS AN OFFSET IN PHYSICAL RECORDS
C     (IN ORDER TO WRITE A PARTIAL LOGICAL ERCORD)
C
      IRECST=JRECST(IRAF/10)
      IRECLN=JRECLN(IRAF/10)
      N = IORA(NREC)
      IF(N.LE.0) THEN
         IORA(NREC) = IRECST
         IRECST = IRECST + (LEN1-1)/IRECLN + 1
         N = IORA(NREC)
      END IF
C
      JRECST(IRAF/10)=IRECST
      IF(GOPARR  .AND.  .NOT.(MASWRK.OR.DSKWRK)) RETURN
C
      IST = -IRECLN + 1
      NS = N
      LENT = LEN
  120 CONTINUE
         IST = IST + IRECLN
         IF = IST + LENT - 1
         IF ((IF-IST+1) .GT. IRECLN) IF = IST+IRECLN-1
         NSP = NS
         LENW = IF - IST + 1
         CALL RAWRT(V(IST),LENW,IRAF,NSP+NPHYSOFF)
         LENT = LENT - IRECLN
         NS = NS + 1
         N = NS
      IF (LENT .GE. 1) GO TO 120
      RETURN
      END
C*MODULE IOLIB   *DECK RAWRT
      SUBROUTINE RAWRT(V,LEN,IRAF,NS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(LEN)
C
C     ----- WRITE A PHYSICAL RECORD ON IRAF -----
C
      WRITE (UNIT=IRAF, REC=NS) V
      RETURN
      END
C*MODULE IOLIB   *DECK SEQADV
      SUBROUTINE SEQADV(LUNIT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ----- ADVANCE ONE RECORD ON FILE LUNIT -----
C
      IF (DSKWRK.OR.MASWRK) READ (LUNIT)
      RETURN
      END
C*MODULE IOLIB   *DECK SEQCLO
      SUBROUTINE SEQCLO(IFILE,FSTAT)
C
      CHARACTER*(*) FSTAT
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      PARAMETER (MXUNIT=299)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
C
C     ----- CLOSE THE SEQUENTIAL FILE IFILE -----
C     ----- FSTAT MAY BE 'KEEP' OR 'DELETE' -----
C
      IF(IFILE.GT.MXUNIT) THEN
         WRITE(IW,900) IFILE,MXUNIT
         CALL ABRT
      END IF
      IF(NFTOPN(IFILE).EQ.0) RETURN
C
      IF(DSKWRK.OR.MASWRK) CLOSE (UNIT=IFILE, STATUS=FSTAT)
      NFTOPN(IFILE) = 0
      RETURN
  900 FORMAT(1X,'SEQCLO: ATTEMPT TO CLOSE FILE',I5,
     *          ' GREATER THAN MAXIMUM',I5)
      END
C*MODULE IOLIB   *DECK SEQOPN
      SUBROUTINE SEQOPN(IUNIT,FNAME,FSTAT,RDONLY,FMT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER*(*) FNAME,FSTAT,FMT
      LOGICAL RDONLY,GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT
      PARAMETER (MXUNIT=299)
C
*UNX  CHARACTER*256 FILENM,ENVBUF
*UNX  CHARACTER*1 NULL
*UNX  COMMON /ENVIR/ ENVBUF(MXUNIT)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
C
C      OPEN SEQUENTIAL FILE -IUNIT- WITH GENERIC NAME -FNAME-
C      WITH STATUS -FSTAT-, AS EITHER READONLY/READWRITE, AND
C      FOR EITHER FORMATTED OR UNFORMATTED I/O. EXAMPLE:
C           CALL SEQOPN(IS,'AOINTS','UNKNOWN',.FALSE.,'UNFORMATTED')
C
C
C      SOME COMPILERS (NOTABLY F2C OR G77) MAY LIMIT THE UNIT NUMBER
C      TO A SMALL VALUE (99 IN THE CASE OF THOSE TWO).  A 'SED HACK'
C      CAN BE USED TO ADJUST -MXUNIT- BEFORE COMPILING, IF SO. ANY
C      ATTEMPT TO OPEN TOO LARGE A UNIT NUMBER SHOULD BE TERMINATED.
C      IF THE LIMIT IS 99, ASSUME THIS IS G77, AND PRINT A MESSAGE
C      ABOUT THE ONLY RUNTYP THAT PRESENTLY GOES OVER 99.
C
      IF(IUNIT.GT.MXUNIT) THEN
         WRITE(IW,900) IUNIT,MXUNIT
         IF(MXUNIT.EQ.99) WRITE(IW,901)
         CALL ABRT
      END IF
  900 FORMAT(1X,'SEQOPN: ATTEMPT TO OPEN FILE',I5,
     *          ' GREATER THAN MAXIMUM',I5)
  901 FORMAT(1X,'G77 HAS AN INTERNAL LIMIT OF 99 FILES,',
     *          ' AND SO CANNOT EXECUTE RUNTYP=TDHFX')
C
C         -NFTOPN- IS FOR THE AIX XL FORTRAN VERSION 3, WHICH DOESN'T
C         SILENTLY IGNORE REQUESTS TO OPEN A FILE WHICH IS ALREADY
C         OPEN.  IF ANY FILE HAS ALREADY BEEN OPENED, WE JUST EXIT,
C         WHICH IS THE USUAL FORTRAN BEHAVIOR.  0=NOT OPEN, 1=OPEN.
C
C         -NODEXT- CONTROLS WHETHER TO ADD PROCESS (RANK) EXTENSION
C         OF .001, .002, ETC TO EACH FILE NAME: 0=ADD, 1=DO NOT ADD.
C         NOTE THAT -NODEXT- IS POSSIBLE INPUT (LATER) IN $SYSTEM.
C
C         THE INPUT FILE -5- IS THE FIRST FILE OPENED, AND THUS A
C         GOOD TRIGGER FOR DOING THESE INITIALIZATIONS.  (2=ERICFMT)
C
      IF(IUNIT.EQ.5) THEN
         DO I=1,MXUNIT
            NFTOPN(I)=0
            NODEXT(I)=0
         ENDDO
         NODEXT(2)=1
         NODEXT(5)=1
         IF(.NOT.RDONLY) WRITE(IW,*) 'CAUTION, INPUT FILE NOT READ ONLY'
      END IF
C
      IF(NFTOPN(IUNIT).EQ.1) RETURN
      NFTOPN(IUNIT) = 1
C
*IBM  IF (MASWRK) THEN
*IBM  IF(FNAME.NE.'OUTPUT') THEN
*IBM     OPEN(UNIT=IUNIT, FILE=FNAME, STATUS=FSTAT,
*IBM *        ACCESS='SEQUENTIAL', FORM=FMT)
*IBM  END IF
*IBM  END IF
C
C     FOR NON-GDDI RUNS,
C         FIRST, TRANSLATE THE ENVIRONMENT VARIABLE TO A FULLY
C                QUALIFIED FILE NAME, FNAME --> FILENM.
C          NEXT, APPEND AN EXTENSION TO THE FILE NAME, GIVING ITS
C                RANK, SUCH AS .001, ON ALL PROCESSES WHICH ARE NOT
C                THE MASTER.  THUS SMP SYSTEMS HAVE UNIQUE FILE NAMES.
C         THIRD, STICK IN A NULL BYTE SO THAT UNIX COMPILERS, WHICH
C                DON'T UNDERSTAND THE FORTRAN CHARACTER TYPE, HAVE
C                A C-STYLE CHAR VARIABLE TO WORK WITH (UGH).
C   AND FINALLY, OPEN THE FILE.
C
C     FOR GDDI RUNS,
C       THE ENVIRONMENT VARIABLES ARE ALREADY TRANSLATED, SEE -STORENV-
C       THE RANK EXTENSIONS MAY NOT BE WANTED (SEE -NODEXT- IN $SYSTEM)
C
C     MOST PEOPLE DO NOT DEFINE 'OUTPUT' IN -RUNGMS-, WHICH LEADS TO
C     NO OPEN STATEMENT BEING EXECUTED: PRINT OUT TO "STANDARD OUTPUT".
C     IN CONTRAST, UNIT 5 IS ALWAYS A DISK FILE, AND IS ALWAYS OPENED.
C
*UNX  FILENM=' '
*UNX  IF (MASWRK) CALL GETENV(FNAME,FILENM)
*UNX  IF(ISGDDI) THEN
*UNX    FILENM=ENVBUF(IUNIT)
*UNX    IF(PAROUT.AND.NODEXT(IUNIT).EQ.0) CALL ADDNANODE(FILENM,MEGLOB)
*UNX  ELSE
*UNX    CALL PARENV(FNAME,FILENM,IOUT)
*UNX    IF (IOUT.EQ.1) RETURN
*UNX  END IF
*UNX  IF(FNAME.EQ.'OUTPUT') THEN
*UNX     IF(FILENM(1:1).NE.' '  .AND.  FILENM(1:6).NE.'OUTPUT') THEN
*UNX        OPEN(UNIT=IUNIT, FILE=FILENM, STATUS=FSTAT,
*UNX *           ACCESS='SEQUENTIAL', FORM=FMT)
*UNX     END IF
*UNX  ELSE
*UNX     NULL = CHAR(0)
*UNX     DO 1 KOL=1,256
*UNX        IF(FILENM(KOL:KOL).EQ.' '  .OR.
*UNX *         FILENM(KOL:KOL).EQ.NULL) GO TO 2
*UNX1    CONTINUE
*UNX     KOL=257
*UNX2    CONTINUE
*UNX     IF(KOL.EQ.1) THEN
*UNX        WRITE(IW,3) FNAME
*UNX        CALL ABRT
*UNX     END IF
*UNX     KOL=KOL-1
*UNX     OPEN(UNIT=IUNIT, FILE=FILENM(1:KOL), STATUS=FSTAT,
*UNX *        ACCESS='SEQUENTIAL', FORM=FMT, ERR=4)
*UNX  END IF
*UNX  RETURN
C
C         ERROR HANDLING (E.G. FOR ERICFMT, ...)
C
*UNX3 FORMAT(1X,'YOU MUST ASSIGN GENERIC NAME ',A,' WITH A SETENV.')
C
*UNX4 CONTINUE
*UNX  IF(FSTAT.EQ.'OLD') THEN
*UNX     IF(MASWRK) WRITE(IW,5) 'PRE-EXISTING',FNAME,FILENM(1:KOL)
*UNX  ELSE
*UNX     IF(MASWRK) WRITE(IW,5) 'NEW',FNAME,FILENM(1:KOL)
*UNX  ENDIF
*UNX  CALL ABRT
*UNX5 FORMAT(//1X,'ERROR OPENING ',A,' FILE ',A,','/
*UNX *         1X,'ASSIGNED TO EXPLICIT FILE NAME ',A/
*UNX *         1X,'PLEASE CHECK THE -SETENV- FILE ASSIGNMENTS',
*UNX *            ' IN YOUR -RUNGMS- SCRIPT.')
C
*VMS  IF(RDONLY) THEN
*VMS     OPEN(UNIT=IUNIT, FILE=FNAME, STATUS=FSTAT, READONLY,
*VMS *        ACCESS='SEQUENTIAL', FORM=FMT, SHARED)
*VMS  ELSE
*VMS     IF(FNAME.EQ.'OUTPUT') THEN
*VMS        OPEN(UNIT=IUNIT, FILE=FNAME, STATUS=FSTAT,
*VMS *           ACCESS='SEQUENTIAL', FORM=FMT, SHARED)
*VMS     ELSE IF(FNAME.EQ.'PUNCH'  .OR.  FNAME.EQ.'IRCDATA') THEN
*VMS        OPEN(UNIT=IUNIT, FILE=FNAME, STATUS=FSTAT,
*VMS *           ACCESS='SEQUENTIAL', FORM=FMT,
*VMS *           CARRIAGECONTROL='LIST', SHARED)
*VMS     ELSE
*VMS        OPEN(UNIT=IUNIT, FILE=FNAME, STATUS=FSTAT,
*VMS *           ACCESS='SEQUENTIAL', FORM=FMT)
*VMS     END IF
*VMS  END IF
C
C       IT MAY BE USEFUL TO SET FLUSH-ON-WRITE FOR ASCII OUTPUT FILES
C       ALTHOUGH WE SKIP HERE UNIT 6 WHICH SHOULD BE ALREADY OK.
C       SOME SYSTEMS MAY NEED EXTRA HELP 'FLUSH'ING OTHER UNITS....
C
      IF(FNAME.EQ.'IRCDATA') CALL FLUSHONWRITE(IUNIT)
      IF(FNAME.EQ.'PUNCH')   CALL FLUSHONWRITE(IUNIT)
      IF(FNAME.EQ.'SIMEN')   CALL FLUSHONWRITE(IUNIT)
      IF(FNAME.EQ.'SIMCOR')  CALL FLUSHONWRITE(IUNIT)
      RETURN
      END
C*MODULE IOLIB   *DECK SEQREW
      SUBROUTINE SEQREW(IFILE)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C   ----- REWIND FILE IFILE ----
C
      IF (DSKWRK.OR.MASWRK) REWIND (UNIT=IFILE, ERR=300)
  300 CONTINUE
      RETURN
      END
C*MODULE IOLIB   *DECK SQRDCH
      SUBROUTINE SQRDCH(LFILE,REGION,LENGTH)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION REGION(LENGTH)
C
C         READ A SEQUENTIAL RECORD FROM FILE -LFILE- OF -LENGTH- WORDS.
C         SEE ALSO THE ROUTINE SQWRCH, WHICH IS SQRDCH'S PARTNER.
C
C         IN CASE OF END OF FILE DETECTION, -LENGTH- IS RETURNED AS 0!
C
C         IN CASE THE -LENGTH- IS VERY LARGE, THE I/O IS DIVIDED INTO
C         SMALLER SUBRECORDS, OF -MAXSEQ- WORDS.  AS AN EXAMPLE, IF
C         THE DISK STRIPE SIZE IS 32K, A RECORD OF 250,000 WORDS WILL
C         CONSIST OF ABOUT 61 STRIPES, AND IS THUS A RATHER BIG
C         RECORD SIZE, AT LEAST IN THE YEAR 2005.
C
C         NOTE THAT CHUNKING IS INCOMPATIBLE WITH THE ABILITY TO USE
C         THE -SEQADV- ROUTINE.
C
      MAXSEQ = 250000
C
      IADD = 1
  100 CONTINUE
         LEN = MIN(MAXSEQ,LENGTH-IADD+1)
         CALL SQREAD(LFILE,REGION(IADD),LEN)
C               THIS RETURNS THE END OF FILE HAS BEEN DETECTED
         IF(LEN.EQ.0) LENGTH=0
         IADD = IADD+MAXSEQ
         IF(IADD.GT.LENGTH) RETURN
      GO TO 100
      END
C*MODULE IOLIB   *DECK SQREAD
      SUBROUTINE SQREAD(LFILE,REGION,LENGTH)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION REGION(LENGTH)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR,IW,IP,IIS,IPK,IDAFX,NAV,IODAX(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     READ -LENGTH- FLOATING POINT WORDS INTO -REGION- FROM -LFILE-
C     A POSSIBLE END-OF-FILE RESULTS IN RETURNING -LENGTH- AS ZERO!
C     NOTE THAT DUE TO ITS POSSIBLE RESET TO 0, -LENGTH- SHOULD
C     BE A INTEGER VARIABLE, RATHER THAN AN INTEGER CONSTANT.
C     SEE ALSO -SQWRIT- AND -SEQADV- WHICH ARE PARTNERS TO SQREAD.
C
C         THE FLAG -DSKWRK- DISTINGUISHES THE PARALLEL I/O STRATEGY:
C           IF DSKWRK=.TRUE.,  ALL PROCESSES READ THEIR OWN FILES.
C           IF DSKWRK=.FALSE., ONLY THE MASTER WILL READ THE FILE,
C           BUT THE DATA IS THE BROADCAST TO ALL OTHER PROCESSES.
C
      IF (DSKWRK.OR.MASWRK) READ(LFILE, END=200, ERR=300) REGION
C
C         IF RUNNING IN PARALLEL, AND THE FILE EXISTS ONLY
C         ON THE MASTER NODE (DSKWRK=.FALSE.), THEN THE DATA
C         SHOULD BE BROADCAST FROM THE MASTER TO ALL OTHER NODES.
C
      IF (GOPARR.AND.(.NOT.DSKWRK)) THEN
         CALL DDI_BCAST(230,'F',REGION,LENGTH,MASTER)
      END IF
      RETURN
C
C                  END OF FILE
C        THIS IS HANDLED BY RETURNING ZERO LENGTH READ, SO THE CALLER
C        CAN DETERMINE IF THIS IS REALLY AN ERROR, OR WAS EXPECTED.
C
  200 CONTINUE
      LENGTH=0
      RETURN
C
C                  ERROR READING FILE, PULL THE PLUG ON THE JOB
C
  300 CONTINUE
      WRITE(IW,9000) LFILE,ME,LENGTH
      CALL ABRT
C
      RETURN
 9000 FORMAT(1X,'ERROR READING FILE',I4,' ON NODE',I5,' LENGTH=',I10)
      END
C*MODULE IOLIB   *DECK SQWRCH
      SUBROUTINE SQWRCH(LFILE,REGION,LENGTH)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION REGION(LENGTH)
C
C         WRITE A SEQUENTIAL RECORD TO FILE -LFILE- OF -LENGTH- WORDS,
C         CHUNKED INTO -MAXSEQ- SUBRECORDS.
C         SEE ALSO THE ROUTINE SQRDCH, WHICH IS SQWRCH'S PARTNER.
C
      MAXSEQ = 250000
C
      IADD = 1
  100 CONTINUE
         LEN = MIN(MAXSEQ,LENGTH-IADD+1)
         CALL SQWRIT(LFILE,REGION(IADD),LEN)
         IADD = IADD+MAXSEQ
         IF(IADD.GT.LENGTH) RETURN
      GO TO 100
      END
C*MODULE IOLIB   *DECK SQWRIT
      SUBROUTINE SQWRIT(LFILE,REGION,LENGTH)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION REGION(LENGTH)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     WRITE AN ARRAY -REGION- OF LENGTH -LENGTH- TO UNIT -LFILE-
C     SEE ALSO -SQREAD- AND -SEQADV- WHICH ARE PARTNERS TO SQWRIT.
C
C         THE FLAG -DSKWRK- DISTINGUISHES THE PARALLEL I/O STRATEGY:
C           IF DSKWRK=.TRUE.,  ALL PROCESSES WRITE THEIR OWN FILES.
C           IF DSKWRK=.FALSE., ONLY THE MASTER WILL WRITE THE FILE.
C
      IF (DSKWRK.OR.MASWRK) WRITE(LFILE,ERR=300) REGION
      RETURN
C
  300 CONTINUE
      WRITE(6,9020) ME,LFILE
      CALL ABRT
      STOP
C
 9020 FORMAT(1X,'SQWRIT: NODE',I4,
     *          ' ENCOUNTERED I/O ERROR WRITING UNIT',I4)
      END
C
C*MODULE IOLIB   *DECK CCCLOS
      SUBROUTINE CCCLOS(IFILE,FSTAT)
C
      CHARACTER*(*) FSTAT
C
      LOGICAL GOPARR,DSKWRK,MASWRK
      PARAMETER (MXUNIT=299)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
C
C     ----- CLOSE THE SEQUENTIAL FILE IFILE -----
C     ----- FSTAT MAY BE 'KEEP' OR 'DELETE' -----
C
      IF(IFILE.GT.MXUNIT) THEN
         WRITE(IW,900) IFILE,MXUNIT
         CALL ABRT
      END IF
      IF(NFTOPN(IFILE).EQ.0) RETURN
C
      IF(DSKWRK.OR.MASWRK) CLOSE (UNIT=IFILE, STATUS=FSTAT)
      NFTOPN(IFILE) = 0
      RETURN
  900 FORMAT(1X,'CCCLOS: ATTEMPT TO CLOSE FILE',I5,
     *          ' GREATER THAN MAXIMUM',I5)
      END
C
C*MODULE IOLIB   *DECK CCOPEN
      SUBROUTINE CCOPEN(IUNIT,IRECLN,FNAME)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT
C
      PARAMETER (MXUNIT=299)
C
*UNX  CHARACTER*256 FILENM,ENVBUF
*UNX  COMMON /ENVIR/  ENVBUF(MXUNIT)
      CHARACTER*(*) FNAME
C
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C        ----- OPEN DIRECT ACCESS FILES USED BY CC PROGRAM -----
C
      IF(IUNIT.GT.MXUNIT) THEN
         WRITE(IW,900) IUNIT,MXUNIT
         CALL ABRT
      END IF
      IF(NFTOPN(IUNIT).EQ.1) RETURN
      NFTOPN(IUNIT) = 1
  900 FORMAT(1X,'CCOPEN: ATTEMPT TO OPEN FILE',I5,
     *          ' GREATER THAN MAXIMUM',I5)
C
      IF (MASWRK) THEN
C
*IBM  OPEN (UNIT=IUNIT, FILE=FNAME, STATUS='UNKNOWN',
*IBM *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=8*IRECLN)
C
*UNX  CALL GETENV(FNAME,FILENM)
*UNX  IF(ISGDDI) THEN
*UNX    FILENM=ENVBUF(IUNIT)
*UNX    IF(PAROUT.AND.NODEXT(IUNIT).EQ.0) CALL ADDNANODE(FILENM,MEGLOB)
CUNX  ELSE
CUNX    CALL PARENV(FNAME,FILENM,IOUT)
CUNX    IF (IOUT.EQ.1) RETURN
*UNX  END IF
*UNX  OPEN (UNIT=IUNIT, FILE=FILENM, STATUS='UNKNOWN',
*UNX *      ACCESS='DIRECT', FORM='UNFORMATTED',
*UNX *      RECL=8*IRECLN)
C
*VMS  OPEN (UNIT=IUNIT, FILE=FNAME, STATUS='UNKNOWN',
*VMS *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=2*IRECLN)
C
      END IF
      RETURN
      END
C*MODULE FMO     *DECK RAWRITES
      SUBROUTINE RAWRITES(IRAF,IORA,V,LEN1,LEN,NREC,NPHYSOFF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(*),IORA(*)
      LOGICAL GOPARR,DSKWRK,MASWRK,DSKSAV
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      DSKSAV=DSKWRK
      DSKWRK=.TRUE.
      CALL RAWRITE(IRAF,IORA,V,LEN1,LEN,NREC,NPHYSOFF)
      DSKWRK=DSKSAV
      RETURN
      END
C*MODULE FMO     *DECK RAREADS
      SUBROUTINE RAREADS(IRAF,IORA,V,LEN,NREC,NAV)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(*),IORA(*)
      LOGICAL GOPARR,DSKWRK,MASWRK,DSKSAV
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      DSKSAV=DSKWRK
      DSKWRK=.TRUE.
      CALL RAREAD(IRAF,IORA,V,LEN,NREC,NAV)
      DSKWRK=DSKSAV
      RETURN
      END
C*MODULE IOLIB   *DECK CLOSDA
      SUBROUTINE CLOSDA(FSTAT)
C
      CHARACTER*(*) FSTAT
C
      PARAMETER (MXUNIT=299)
C
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
C     ----- CLOSE THE SEQUENTIAL FILE IFILE -----
C     ----- FSTAT MAY BE 'KEEP' OR 'DELETE' -----
C
CNBB
C     SNACK FOR THOUGHT: ON SMP MACHINES THERE IS A CONFLICT OF
C     CLOSING DAF, BECAUSE EACH NODE OPENS/CLOSES DAF THAT HAS NO
C     NODE-SPECIFIC EXTENSION.  (THUS FOR HALF NODES THE FILE IS
C     SNEAKINGLY CLOSED BY ANOTHER HALF). THIS BOMBS OUT ON AIX.
C     THIS IS SOLVED BY STARTING OFF WITH NGROUPS EQUAL TO THE NUMBER
C     OF SMP BOXES, NOT THE NUMBER OF CPUS. ALTERNATIVELY, SHOULD
C     WE ADD .001 ETC?
C
      IF (NFTOPN(IDAF).NE.0) THEN
        CLOSE (UNIT=IDAF, STATUS=FSTAT)
        NFTOPN(IDAF) = 0
      ENDIF
      RETURN
      END
C*MODULE IOLIB   *DECK ADDNANODE
      SUBROUTINE ADDNANODE(FILENM,ME)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*256 FILENM
      CHARACTER*30 NODFMT
      LOGICAL ISGDDI,PAROUT
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
C
C     APPEND NODE NUMBER (ACTUALLY, GROUP NUMBER) TO A FILE NAME.
C     THIS ONLY WORKS FOR UNX(?)
C
      IF(FILENM(1:1).EQ.CHAR(0)) THEN
         WRITE(6,190)
         CALL ABRT
      ENDIF
  190 FORMAT(1X,'ADDNANODE: ERROR, PLEASE PRESTORE YOUR FILE NAME.')
C
      LENSTR=256
      DO 175 I = 1,256
         IF(FILENM(I:I).EQ.' '.OR.FILENM(I:I).EQ.CHAR(0)) THEN
            LENSTR=I-1
            GOTO 200
         ENDIF
  175 CONTINUE
  200 CONTINUE
      IF(LENSTR.GT.256-4) CALL ABRT
C
C
C     ADDING 1.0D+00 SERVES TWO PURPOSES: TYPE CONVERSION AND ROUND-OFF
      NFINGERS=3
      IF(NPGLOB.GT.999) NFINGERS=INT(LOG10(NPGLOB+1.0D+00))+1
C     USING I1 BELOW MEANS WE CAN ONLY USE AT MOST 10**10-1 NODES.
C     POOR US! WHAT SHALL WE DO IF WE HAVE GOT MORE?!
      WRITE(UNIT=NODFMT,FMT='(6H(1H.,I,I1,1H.,I1,1H))')NFINGERS,NFINGERS
      WRITE(UNIT=FILENM(LENSTR+1:LENSTR+NFINGERS+1),FMT=NODFMT) ME
      FILENM(LENSTR+NFINGERS+2:LENSTR+NFINGERS+2) = CHAR(0)
C     WRITE(6,*) 'ADDNANODE',ME,' WITH NAME: ',FILENM
C
      RETURN
      END
C*MODULE INPUTA  *DECK STORENV
      SUBROUTINE STORENV
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXUNIT=299)
      CHARACTER*256 ENVBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /ENVIR/ ENVBUF(MXUNIT)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
C
      DO I=1,MXUNIT
         ENVBUF(I)(1:1)=CHAR(0)
      ENDDO
      IF (MASWRK) THEN
         CALL GETENV('ERICFMT',ENVBUF(2))
         CALL GETENV('EXTBAS', ENVBUF(3))
         CALL GETENV('IRCDATA',ENVBUF(4))
         CALL GETENV('INPUT',  ENVBUF(IR))
         CALL GETENV('OUTPUT', ENVBUF(IW))
         CALL GETENV('PUNCH',  ENVBUF(IP))
         CALL GETENV('AOINTS', ENVBUF(IJK))
         CALL GETENV('MOINTS', ENVBUF(IJKT))
         CALL GETENV('DICTNRY',ENVBUF(10))
         CALL GETENV('DRTFILE',ENVBUF(11))
         CALL GETENV('CIVECTR',ENVBUF(12))
         CALL GETENV('CASINTS',ENVBUF(13))
         CALL GETENV('CIINTS', ENVBUF(14))
         CALL GETENV('WORK15', ENVBUF(15))
         CALL GETENV('WORK16', ENVBUF(16))
         CALL GETENV('FOCKDER',ENVBUF(18))
         CALL GETENV('DASORT', ENVBUF(IDAF20))
         CALL GETENV('DFTGRID',ENVBUF(22))
         CALL GETENV('JKFILE', ENVBUF(23))
         CALL GETENV('EFPIND', ENVBUF(25))
         CALL GETENV('PCMDATA',ENVBUF(26))
         CALL GETENV('PCMINTS',ENVBUF(27))
         CALL GETENV('MLTPL',  ENVBUF(28))
         CALL GETENV('MLTPLT', ENVBUF(29))
         CALL GETENV('DAFL30', ENVBUF(30))
         CALL GETENV('HESSIAN',ENVBUF(38))
         CALL GETENV('SOCCDAT',ENVBUF(40))
         CALL GETENV('AABB41', ENVBUF(41))
         CALL GETENV('BBAA42', ENVBUF(42))
         CALL GETENV('BBBB43', ENVBUF(43))
         CALL GETENV('NMRINT1',ENVBUF(61))
         CALL GETENV('CCREST', ENVBUF(70))
         CALL GETENV('CCDIIS', ENVBUF(71))
         CALL GETENV('CCINTS', ENVBUF(72))
         CALL GETENV('CCT1AMP',ENVBUF(73))
         CALL GETENV('CCT2AMP',ENVBUF(74))
         CALL GETENV('CCT3AMP',ENVBUF(75))
         CALL GETENV('CCVM',   ENVBUF(76))
         CALL GETENV('CCVE',   ENVBUF(77))
         CALL GETENV('CCQUADS',ENVBUF(78))
         CALL GETENV('QUADSVO',ENVBUF(79))
         CALL GETENV('EOMHHHH',ENVBUF(85))
         CALL GETENV('EOMPPPP',ENVBUF(86))
      END IF
C
C     A LITTLE NASTY TRICK TO BROADCAST CHARACTERS: PRETEND THEY ARE
C     INTEGERS.  IT IS NOT SAFE TO PRETEND THEY ARE REAL DUE TO SOME
C     "MAGIC" COMBINATIONS THAT CAN CAUSE SOME CAUTIOUS COMPILERS TO
C     REPORT FPU ERRORS.
C     DIMENSIONS ASSUME THAT A REAL VARIABLE HOLDS 8 BYTES WHICH SO FAR
C     HAS ALWAYS BEEN TRUE. THAT IS WHY THERE IS AN "8" BELOW.
C     IT DOES HELP THAT 256 IS A MULTIPLE OF 8!
C     A WORD OF CAUTION: THIS SWINDLING MAY PROVE TO BE UNPORTABLE!
C     THE REASON IS THAT SOME COMPILERS MAY SECRETLY STORE THE STRING
C     SIZE.
C
      CALL DDI_BCAST(206,'I',ENVBUF,((MXUNIT*256)/8)*NWDVAR,MASTER)
      RETURN
      END
