C 11 APR 08 - JMM - GMS_GETENV: MAKEFP OUTPUT GOES TO -MAKEFP- ENV.VAR.
C 20 AUG 07 - DGF - PAD FILES IN STORENV
C 20 AUG 07 - KI  - ADD MPOPEN AND MPCLOS FOR MP2 DIRECT ACCESS FILES
C 20 AUG 07 - MWS - CCOPEN: PRINT WARNING IF RECORD LENGTH EXCEEDS 2GB
C 25 JUN 07 - MWS - PKWRT: FIX ERROR MSG'S PRINTING OF THE I/O DIRECTION
C 24 MAR 07 - MWS - PAD FRGINF COMMON BLOCK
C 15 FEB 07 - MWS - ADD GMS_GETENV WRAPPER AROUND CALLS TO UNIX GETENV
C 22 DEC 06 - DGF - ADD SMP I/O OPTION, PAD MORE FILE NAMES TO STORENV
C 22 DEC 06 - BN  - DAWRIT: INITGDDI MAKES ALL GROUP MASTERS WRITE DAF
C  6 NOV 06 - MWS - ADJUST GDDI COMMON BLOCK
C 13 MAR 06 - DGF - SEQOPN: MOVE NODEXT INITIALIZATION HERE
C 22 FEB 06 - TN  - STORENV: 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)
C     SATISFY FTNCHEK'S STALWARTH ZEAL
      IF(IR.LT.0) WRITE(6,*) 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(*)
C     SATISFY FTNCHEK'S STALWARTH ZEAL
      IF(NAT.LT.0) WRITE(6,*) AATOM(1),AZNUC(1),CORD(1),NAT
      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
C     SATISFY FTNCHEK'S STALWARTH ZEAL
      IF(FDNAI.GT.1) WRITE(6,*) PLAMBDA,AI,AJ,L1A,M1A,N1A,L2B,M2B,N2B,
     *                          XI,YI,ZI,XJ,YJ,ZJ,CX,CY,CZ
      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)
C     SATISFY FTNCHEK'S STALWARTH ZEAL
      IF(SCFTYP.EQ.1) WRITE(6,*) 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
      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,ISGDDI,PAROUT,INITGDDI
C
      DIMENSION V(LEN),IODA(950)
C
      INTEGER DDI_WORLD,DDI_GROUP
      PARAMETER (DDI_WORLD=0,DDI_GROUP=1)
C
      COMMON /DAIOLN/ IRECLN,IRECST,IFILEN(950)
      COMMON /GDDI  / ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAFX,NAV,IODAX(950)
      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
C     INITILIZE ON ALL MASTERS EVERYTHING THAT HAS BEEN INITIALIZED
C     ON THE GLOBAL MASTER (IF -INITGDDI-).  IN OTHER WORDS, SWITCH
C     TO THE GROUP SCOPE, AND AFTER THE WRITE, SWITCH BACK TO WORLD.
C
      IF(ISGDDI.AND.INITGDDI) CALL GDDI_SCOPE(DDI_GROUP)
C
      IF(IDAF.NE.10) THEN
         CALL RAWRIT(IDAF,IODA,V,LEN,NREC,NAV)
         IF(ISGDDI.AND.INITGDDI) CALL GDDI_SCOPE(DDI_WORLD)
         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
      IF(ISGDDI.AND.INITGDDI) CALL GDDI_SCOPE(DDI_WORLD)
      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,INITGDDI
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,INITGDDI
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT),IOSMP(2)
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 GMS_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 GMS_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,INITGDDI
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,INITGDDI
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,LSTMPTS(MXFRG)
      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 WRITING 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),IOSMP(2)
      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,ISGDDI,PAROUT,INITGDDI
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),IOSMP(2)
      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,INITGDDI
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 GMS_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,INITGDDI
      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,INITGDDI
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT),IOSMP(2)
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 GMS_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),IOSMP(2)
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,INITGDDI
      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),IOSMP(2)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
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 GMS_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         IF YOU HAVE A F90 COMPILER, AND ARE TRYING TO KEEP SOME OF
C         THE FILES LIKE -ERICFMT- AND -MCPDATA- READ-ONLY, YOU COULD
C         CHANGE THE OPEN STATEMENT ABOVE TO:    (USE *'S IN COLUMN 1)
CUNX     IF (RDONLY) THEN
CUNX        OPEN(UNIT=IUNIT, FILE=FILENM(1:KOL), STATUS=FSTAT,
CUNX *           ACCESS='SEQUENTIAL', FORM=FMT, ERR=4, ACTION='READ')
CUNX     ELSE
CUNX        OPEN(UNIT=IUNIT, FILE=FILENM(1:KOL), STATUS=FSTAT,
CUNX *           ACCESS='SEQUENTIAL', FORM=FMT, ERR=4)
CUNX     END IF
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),IOSMP(2)
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,INITGDDI,CHK2GB
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,INITGDDI
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT),IOSMP(2)
      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
C        THE OPEN SHELL CC CODES CAN HAVE VERY LARGE RECORD SIZES,
C        WHICH ARE NOT HANDLED WELL BY GFORTRAN OR PATHF90 (AT LEAST).
C        WE PRINT A WARNING THAT THE NEXT OPEN MAY FAIL.
C
      IF (CHK2GB(8*IRECLN)) THEN
         IF(MASWRK) WRITE(IW,910) IUNIT,FNAME,IRECLN
         CALL FLSHBF(IW)
      END IF
  910 FORMAT(/1X,'WARNING: ATTEMPTING TO OPEN FILE',I4,' NAMED ',A/
     *    1X,'WITH A RECORD SIZE OVER 2 GBYTES, NAMELY,',I20,' WORDS'/
     *    1X,'YOUR FORTRAN I/O LIBRARY MAY CRASH TRYING THIS!')
C
      IF (MASWRK) THEN
C
*IBM  OPEN (UNIT=IUNIT, FILE=FNAME, STATUS='UNKNOWN',
*IBM *      ACCESS='DIRECT', FORM='UNFORMATTED', RECL=8*IRECLN)
C
*UNX  CALL GMS_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 IOLIB   *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 IOLIB   *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),IOSMP(2)
      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)
      PARAMETER (MXUNIT=299)
      CHARACTER*256 FILENM
      CHARACTER*30 NODFMT
      LOGICAL ISGDDI,PAROUT,INITGDDI
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT),IOSMP(2)
C
C     APPEND PROCESS RANK TO A FILE NAME, THIS ONLY WORKS FOR UNIX(?)
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
C     PARALLELISE I/O ON SMPS!
C     SOME (INPUT) FILES ARE EXCEPTED FROM THIS: 2, 3 AND IR.
C
      J=IOSMP(2)
      IF(J.NE.0.AND.J.LE.LENSTR) THEN
        M=MOD(MEGLOB,IOSMP(1))
        READ(UNIT=FILENM(J:J),FMT='(I1)') ID
        WRITE(UNIT=FILENM(J:J),FMT='(I1)') ID+M
      ENDIF
C
      RETURN
      END
C*MODULE IOLIB   *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 GMS_GETENV('MAKEFP', ENVBUF(1))
         CALL GMS_GETENV('ERICFMT',ENVBUF(2))
         CALL GMS_GETENV('EXTBAS', ENVBUF(3))
         CALL GMS_GETENV('IRCDATA',ENVBUF(4))
         CALL GMS_GETENV('INPUT',  ENVBUF(IR))
         CALL GMS_GETENV('OUTPUT', ENVBUF(IW))
         CALL GMS_GETENV('PUNCH',  ENVBUF(IP))
         CALL GMS_GETENV('AOINTS', ENVBUF(IJK))
         CALL GMS_GETENV('MOINTS', ENVBUF(IJKT))
         CALL GMS_GETENV('DICTNRY',ENVBUF(10))
         CALL GMS_GETENV('DRTFILE',ENVBUF(11))
         CALL GMS_GETENV('CIVECTR',ENVBUF(12))
         CALL GMS_GETENV('CASINTS',ENVBUF(13))
         CALL GMS_GETENV('CIINTS', ENVBUF(14))
         CALL GMS_GETENV('WORK15', ENVBUF(15))
         CALL GMS_GETENV('WORK16', ENVBUF(16))
         CALL GMS_GETENV('FOCKDER',ENVBUF(18))
         CALL GMS_GETENV('WORK19', ENVBUF(19))
         CALL GMS_GETENV('DASORT', ENVBUF(IDAF20))
         CALL GMS_GETENV('DFTINTS',ENVBUF(21))
         CALL GMS_GETENV('DFTGRID',ENVBUF(22))
         CALL GMS_GETENV('JKFILE', ENVBUF(23))
         CALL GMS_GETENV('EFPIND', ENVBUF(25))
         CALL GMS_GETENV('PCMDATA',ENVBUF(26))
         CALL GMS_GETENV('PCMINTS',ENVBUF(27))
         CALL GMS_GETENV('MLTPL',  ENVBUF(28))
         CALL GMS_GETENV('MLTPLT', ENVBUF(29))
         CALL GMS_GETENV('DAFL30', ENVBUF(30))
         CALL GMS_GETENV('SIMEN',  ENVBUF(35))
         CALL GMS_GETENV('SIMCOR', ENVBUF(36))
         CALL GMS_GETENV('HESSIAN',ENVBUF(38))
         CALL GMS_GETENV('SOCCDAT',ENVBUF(40))
         CALL GMS_GETENV('AABB41', ENVBUF(41))
         CALL GMS_GETENV('BBAA42', ENVBUF(42))
         CALL GMS_GETENV('BBBB43', ENVBUF(43))
         CALL GMS_GETENV('MCQD50', ENVBUF(50))
         CALL GMS_GETENV('MCQD51', ENVBUF(51))
         CALL GMS_GETENV('MCQD52', ENVBUF(52))
         CALL GMS_GETENV('MCQD53', ENVBUF(53))
         CALL GMS_GETENV('MCQD54', ENVBUF(54))
         CALL GMS_GETENV('MCQD55', ENVBUF(55))
         CALL GMS_GETENV('MCQD56', ENVBUF(56))
         CALL GMS_GETENV('MCQD57', ENVBUF(57))
         CALL GMS_GETENV('MCQD58', ENVBUF(58))
         CALL GMS_GETENV('MCQD59', ENVBUF(59))
         CALL GMS_GETENV('MCQD60', ENVBUF(60))
         CALL GMS_GETENV('MCQD61', ENVBUF(61))
         CALL GMS_GETENV('MCQD62', ENVBUF(62))
         CALL GMS_GETENV('MCQD63', ENVBUF(63))
         CALL GMS_GETENV('MCQD64', ENVBUF(64))
         CALL GMS_GETENV('NMRINT1',ENVBUF(61))
         CALL GMS_GETENV('CCREST', ENVBUF(70))
         CALL GMS_GETENV('CCDIIS', ENVBUF(71))
         CALL GMS_GETENV('CCINTS', ENVBUF(72))
         CALL GMS_GETENV('CCT1AMP',ENVBUF(73))
         CALL GMS_GETENV('CCT2AMP',ENVBUF(74))
         CALL GMS_GETENV('CCT3AMP',ENVBUF(75))
         CALL GMS_GETENV('CCVM',   ENVBUF(76))
         CALL GMS_GETENV('CCVE',   ENVBUF(77))
         CALL GMS_GETENV('CCQUADS',ENVBUF(78))
         CALL GMS_GETENV('QUADSVO',ENVBUF(79))
         CALL GMS_GETENV('EOMSTAR',ENVBUF(80))
         CALL GMS_GETENV('EOMVEC1',ENVBUF(81))
         CALL GMS_GETENV('EOMVEC2',ENVBUF(82))
         CALL GMS_GETENV('EOMHC1', ENVBUF(83))
         CALL GMS_GETENV('EOMHC2', ENVBUF(84))
         CALL GMS_GETENV('EOMHHHH',ENVBUF(85))
         CALL GMS_GETENV('EOMPPPP',ENVBUF(86))
         CALL GMS_GETENV('EOMRAMP',ENVBUF(87))
         CALL GMS_GETENV('EOMRTMP',ENVBUF(88))
         CALL GMS_GETENV('EOMDG12',ENVBUF(89))
         CALL GMS_GETENV('MMPP',   ENVBUF(90))
         CALL GMS_GETENV('MMHPP',  ENVBUF(91))
         CALL GMS_GETENV('MMCIVEC',ENVBUF(92))
         CALL GMS_GETENV('MMCIVC1',ENVBUF(93))
         CALL GMS_GETENV('MMCIITR',ENVBUF(94))
         CALL GMS_GETENV('EOMVL1', ENVBUF(95))
         CALL GMS_GETENV('EOMVL2', ENVBUF(96))
         CALL GMS_GETENV('EOMLVEC',ENVBUF(97))
         CALL GMS_GETENV('EOMHL1', ENVBUF(98))
         CALL GMS_GETENV('EOMHL2', ENVBUF(99))
      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
C
C*MODULE IOLIB   *DECK GMS_GETENV
      SUBROUTINE GMS_GETENV(NAME,VALUE)
      CHARACTER*(*) NAME,VALUE
C
C        THIS IS JUST A SILLY WRAPPER AROUND THE SYSTEM'S -GETENV-
C
C        HOWEVER, A SED HACK WOULD ALLOW US TO CALL SOME
C        OTHER NAME, INSTEAD OF GETENV, IF NEEDS MUST.
C
C        AS AN EXAMPLE, SEE THE FILE_GETENV CODE IN UNPORT.SRC.
C
      LENNAM = LEN(NAME)
      IF(LENNAM.LE.0) THEN
         WRITE(6,*) '--ERROR CALLING GMS_GETENV--'
         CALL ABRT
      END IF
C
*UNX  CALL GETENV(NAME,VALUE)
      RETURN
      END
C
C*MODULE IOLIB   *DECK MPOPEN
      SUBROUTINE MPOPEN(IUNIT,IRECLN,FNAME)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT,INITGDDI
C
      PARAMETER (MXUNIT=299)
C
*UNX  CHARACTER*256 FILENM,ENVBUF
*UNX  COMMON /ENVIR/  ENVBUF(MXUNIT)
*UNX  CHARACTER*1 NULL
      CHARACTER*(*) FNAME
C
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT),IOSMP(2)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C        ----- OPEN DIRECT ACCESS FILES USED BY IMS MP2 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,'MPOPEN: ATTEMPT TO OPEN FILE',I5,
     *          ' GREATER THAN MAXIMUM',I5)
C
*IBM  IF (MASWRK)
*IBM *   OPEN (UNIT=IUNIT, FILE=FNAME, STATUS='UNKNOWN',
*IBM *         ACCESS='DIRECT', FORM='UNFORMATTED', RECL=8*IRECLN)
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  NULL = CHAR(0)
*UNX  DO 3 KOL=1,256
*UNX     IF(FILENM(KOL:KOL).EQ.' '  .OR.
*UNX *      FILENM(KOL:KOL).EQ.NULL) GO TO 4
*UNX3 CONTINUE
*UNX  KOL=257
*UNX4 CONTINUE
*UNX  IF(KOL.EQ.1) THEN
*UNX     WRITE(IW,1) FNAME
*UNX     CALL ABRT
*UNX  END IF
*UNX1 FORMAT(1X,'YOU MUST ASSIGN GENERIC NAME ',A,' WITH A SETENV.')
*UNX  KOL=KOL-1
*UNX  OPEN (UNIT=IUNIT, FILE=FILENM(1:KOL), STATUS='UNKNOWN',
*UNX *      ACCESS='DIRECT', FORM='UNFORMATTED',
*UNX *      RECL=8*IRECLN)
C
*VMS  IF (MASWRK)
*VMS *    OPEN (UNIT=IUNIT, FILE=FNAME, STATUS='UNKNOWN',
*VMS *       ACCESS='DIRECT', FORM='UNFORMATTED', RECL=2*IRECLN)
C
      RETURN
      END
C
C
C*MODULE IOLIB   *DECK MPCLOS
      SUBROUTINE MPCLOS(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),IOSMP(2)
C
C     ----- CLOSE THE DIRECT ACCESS 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,'MPCLOS: ATTEMPT TO CLOSE FILE',I5,
     *          ' GREATER THAN MAXIMUM',I5)
      END
