C 19 Dec 06 - MWS - add GET/PUT/ACC_COMM routines
C  6 Sep 06 - MWS - add routines to satisfy external refs for DDI V3
C 16 Dec 05 - MWS - fix DDI_DLBNEXT serial code
C 30 Apr 05 - MWS - modify DDI_LEVEL to return implementation value
C  3 May 04 - MWS - include dummy routines to kill group DDI jobs
C  7 APR 04 - RMO - ADD NDISTRIB, PROCDLB FUNCTIONALITY
C 16 JUN 03 - RMO - ADD NONBLOCKING DDI_ISEND/DDI_IRECV/DDI_WAIT
C 12 DEC 02 - CMA - REDIMENSION TO 20 DISTRIBUTED MATRICES
C 22 MAY 02 - GDF - ALLOW FOR TOGGLING OF CREATE/DESTROY PRINTING
C 17 APR 02 - MWS - CHECK RUNS EXPLICITLY ALLOCATE NO DATA SERVER MEMORY
C  8 OCT 01 - MWS - ALL MPI ARGUMENTS EXPLICITLY TYPED AS I*4/L*4
C  6 SEP 01 - HU  - DDI_SERVER: CHECK AVAILABLE DDIMEM FOR GET,PUT,ACC
C 13 JUN 01 - CMC - USE MPI SSEND CALL INSTEAD OF SEND
C 15 AUG 00 - MWS - DDI_MEMORY: CONVERT MWORDS TO WORDS
C 25 OCT 99 - MWS - MPI DATA SERVERS PROBE, SEQUENTIAL CUTOUT ADDED
C 29 AUG 99 - MWS - BUILD A DELAY INTO DDI_PEND ABNORMAL ENDS
C  6 JUN 99 - GDF - COMBINED SOCKET/MPI IMPLEMENTATION OF DDI
C
C  DDI.SRC
C
C<><><><><><><><>  DISTRIBUTED DATA INTERFACE  <><><><><><><><>
C<><><><><><><><>    WRITTEN BY G. FLETCHER    <><><><><><><><>
C
C    SUMMARY OF THE DISTRIBUTED DATA INTERFACE API:
C                         GLOBAL TASKS
C  DDI_PBEG(NWDVAR)                      INITIALIZE DDI PARAMETERS
C  DDI_PEND(ISTAT)                       MAKE TIDY EXIT
C  DDI_NPROC(DDI_NP,DDI_ME)              NUMBER OF PROCS AND PROC ID
C  DDI_NNODE(DDI_NN,DDI_MY)              NUMBER OF NODES AND NODE ID
C  DDI_MEMORY(MEMREP,MEMDDI,EXETYP)      ALLOCATE SHARED MEMORY REGION
C  DDI_OUTPUT(PFLAG)                     SET PRINT FLAG OFF/ON
C  DDI_CREATE(IDIM,JDIM,HANDLE)          CREATE DISTRIBUTED MATRIX
C  DDI_DESTROY(HANDLE)                   DESTROY DISTRIBUTED MATRIX
C  DDI_DISTRIB(HANDLE,PROC,ILOC,IHIC,JLOC,JHIC)  QUERY DM DISTRIBUTION
C  DDI_NDISTRIB(HANDLE,NODE,ILOC,IHIC,JLOC,JHIC) QUERY DM DISTRIBUTION
C  DDI_DLBRESET                          RESET DLB TASK COUNTER
C  DDI_SYNC(SNCTAG)                      BARRIER SYNCHRONIZATION
C  DDI_GSUMF(MSGTAG,BUFF,MSGLEN)         FLOATING POINT GLOBAL SUM
C  DDI_GSUMI(MSGTAG,BUFF,MSGLEN)         INTEGER GLOBAL SUM
C  DDI_BCAST(MSGTAG,TYPE,BUFF,LEN,FROM)  BROADCAST DATA TO ALL NODES
C
C                      POINT-TO-POINT TASKS
C  DDI_SEND(SNDBUF,LEN,TO)               SYNCHRONOUS SEND
C  DDI_RECV(RCVBUF,LEN,TO)               SYNCHRONOUS RECEIVE
C  DDI_RCVANY(RCVBUF,LEN,TO)             SYNCHRONOUS RECEIVE FROM ANY
C  DDI_DLBNEXT(DLB_COUNTER)              GET NEXT DLB TASK INDEX
C  DDI_GET(HANDLE,ILO,IHI,JLO,JHI,BUFF)  GET BLOCK OF MATRIX
C  DDI_PUT(HANDLE,ILO,IHI,JLO,JHI,BUFF)  PUT BLOCK OF MATRIX
C  DDI_ACC(HANDLE,ILO,IHI,JLO,JHI,BUFF)  ACCUMULATE DATA INTO BLOCK
C
C  DDI_SUBPATCH AND DDI_SERVER ARE USED INTERNALLY ONLY.
C
C     SEE INDIVIDUAL ROUTINES FOR DATA TYPES AND OTHER DETAILS
C
C<><><><><><><><>  DATA-SERVER IMPLEMENTATION  <><><><><><><><>
C
C  ONE-SIDED DATA ACCESS VIA COMMUNICATION WITH DATA-SERVERS.
C  *SOC CODE'S TRANSPORT LAYER IS TCP/IP SOCKETS, IN THIS CASE
C       SEE ALSO SOC_XXX IN THIS FILE, DDISOC.C, AND DDIKICK.C
C  *MPI CODE'S TRANSPORT LAYER IS MPI VERSION 1.  THERE IS ALSO
C       AN ASSUMPTION THAT THE MPI LIBRARY EXPECTS TO HAVE 4-BYTE
C       INTEGERS PASSED TO IT.  ACCORDINGLY EVERY MPI ARGUMENT
C       IS TYPED EXPLICITLY AS INTEGER-STAR-FOUR, BUT IF YOU WANT
C       THESE TO BE INTEGER-STAR-EIGHT, YOU CAN JUST DO A SED HACK.
C       ALL INTEGERS ARE COPIED TO AND FROM TEMPORARY 4-BYTE INTEGERS
C       BECAUSE THE CALLER MIGHT ACTUALLY BE USING 8-BYTE INTEGERS.
C       NOTE THAT THERE IS ONE OCCURENCE OF LOGICAL-STAR-FOUR!
C       NOTE THAT OLD IBM MPI LIBRARIES MAY NOT HAVE THE DATA TYPE
C       MPI_INTEGER8 DECLARED, THE FIX IS TO REMOVE THE 8 BY MANUAL
C       EDITING IN 2 PLACES BELOW, AS THOSE LINES WON'T BE EXECUTED.
C
C  COMPUTE PROCESSES HAVE RANK'S  0,1,...,NP-1
C  DATA SERVER PROCS HAVE RANK'S  NP,NP+1,...,2*NP-1
C
C*MODULE DDI      *DECK DDI_LEVEL
      SUBROUTINE DDI_LEVEL(IMPLEMENTATION)
      INTEGER IMPLEMENTATION
C
C         0 means serial
C         1 means distributed memory, but no subgroups
C         2 means distributed memory, and subgroups (full version)
C
      IMPLEMENTATION = 0
*MPI  IMPLEMENTATION = 1
*SOC  IMPLEMENTATION = 1
      RETURN
      END
C*MODULE DDI      *DECK DDI_PBEG
      SUBROUTINE DDI_PBEG(NWDVAR)
C
C  -------------------------------------------------------------------
C  INITIALIZE MESSAGE PASSING
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER NWDVAR
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVRX, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVRX,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
      INTEGER DDI_NP, DDI_ME
C
      LOGICAL DDI_PRT
      COMMON /DDIFLG/ DDI_PRT
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER I
*MPI  INTEGER*4 IERROR, GROUP_WORLD, DDI_NP4, RANKS(MAXPROC),
*MPI *          GROUP_GAMESS, MPI_COMM_GAMESS
*MPI  COMMON /DDIMPI/ MPI_COMM_GAMESS
C
C        NWDVAR = 1-OR-2 FOR 64-OR-32 BIT INTEGER SYSTEMS
C               = NUMBER OF INTEGERS HELD IN 64 BITS.
C
      NWDVRX=NWDVAR
      IW=6
C
      DDI_PRT = .TRUE.
C
C        INITIALIZE NUMBER OF DISTRIBUTED MATRICES (DM) TO ZERO
C
      NDM = 0
*SEQ  RETURN
C
C        OPEN THE COMMUNICATIONS LIBRARY
C
*MPI  CALL MPI_INIT( IERROR )
*SOC  CALL SOC_INIT
C
C        GET TOTAL NUMBER OF COMPUTE PROCESSES, AND PROCESS ID.
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
C
C        THE BOTTOM HALF OF THE PROCESSES ARE COMPUTE PROCESSES.
C        MPI COMPUTE PROCESS COMMUNICATION CONTEXT = MPI_COMM_GAMESS
C
*MPI  CALL MPI_COMM_GROUP( MPI_COMM_WORLD, GROUP_WORLD, IERROR )
*MPI  DO I = 1, DDI_NP
*MPI    RANKS(I) = I-1
*MPI  END DO
*MPI  DDI_NP4 = DDI_NP
*MPI  CALL MPI_GROUP_INCL( GROUP_WORLD, DDI_NP4, RANKS,
*MPI *                     GROUP_GAMESS, IERROR )
*MPI  CALL MPI_COMM_CREATE( MPI_COMM_WORLD, GROUP_GAMESS,
*MPI *                      MPI_COMM_GAMESS, IERROR )
C
C        THE TOP HALF OF ALL PROCESSES BECOME DATA-SERVERS,
C        THERE IS NO RETURN FROM THE -DDI_SERVER- ROUTINE.
C
C        THE BOTTOM HALF OF ALL PROCESSES ARE COMPUTE PROCESSES,
C        WHO SYNCHRONIZE TO BE SURE THAT ALL CORRECTLY STARTED.
C
      IF ( DDI_ME .GE. DDI_NP ) THEN
         CALL DDI_SERVER
      ELSE
         CALL DDI_SYNC(10147)
      END IF
      RETURN
      END
C*MODULE DDI      *DECK DDI_PEND
      SUBROUTINE DDI_PEND(ISTAT)
C
C  -------------------------------------------------------------------
C  WRAP UP PARALLEL COMPUTATION.
C  THIS INCLUDES TERMINATION OF ALL DATA-SERVERS.
C  ISTAT=0 MEANS NORMAL EXIT, 1 MEANS ABNORMAL TERMINATION DESIRED
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER ISTAT
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 IERROR
C
      DOUBLE PRECISION STATS(2)
      INTEGER DDI_NP, DDI_ME, MSG(6), NBYTES, MEMDDI, MEM1
      INTEGER MAXDM, MAXPROC
      DOUBLE PRECISION A,TIM,TIM0
      INTEGER I
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  RETURN
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
C
C        REPORT TO KICKOFF PROGRAM IF ENDING IS NORMAL
C
*SOC  CALL SOC_WAKEKICK(ISTAT)
C
C        FOR NORMAL ENDS, WE SHOULD PAUSE WHILE EVERYBODY GETS HERE,
C        AND THE KICKOFF PROGRAM HAS A CHANCE TO LEARN ABOUT THIS.
C        FOR ABNORMAL TERMINATION, WHICH MIGHT HAPPEN ON ONLY A SINGLE
C        ONE OF THE NODES, DO NOT GET HUNG UP ON A SYNCHRONIZATION.
C
C        IN CASE MANY NODES STOP NEARLY SIMULTANEOUSLY, E.G. ON AN INPUT
C        ERROR, IT IS GOOD TO HAVE THE OTHER PROCESSES STALL SO THAT
C        THE MASTER COMPUTE PROCESS OR MASTER DATA SERVER HAS A CHANCE
C        COME TO THE SAME POINT, AND PRINT WHY THE JOB IS TERMINATING.
C        THERE ISN'T A GOOD PORTABLE SLEEP IN FORTRAN, SO WE TRY TO
C        ENSURE WE BURN 30 SECONDS OF CPU AS OUR STALLING TACTIC.
C
      IF(ISTAT.EQ.0) THEN
         CALL DDI_SYNC( 10148 )
      ELSE
         IF(DDI_ME.NE.0  .AND.  DDI_ME.NE.DDI_NP) THEN
            CALL TSECND(TIM0)
   50       CONTINUE
            DO I=1,500000
               A = I
               A = SQRT(A)
               TIM = A*A
            ENDDO
            CALL TSECND(TIM)
            IF(TIM-TIM0.LT.30.0) GO TO 50
         END IF
         IF(DDI_ME.LT.DDI_NP) THEN
            WRITE(IW,9010) DDI_ME
         ELSE
            WRITE(IW,9015) DDI_ME
         END IF
         CALL FLSHBF(IW)
      END IF
C
C        SEND A SUICIDE ORDER TO MY OWN DATA SERVER
C
      MSG(1) = 8
      MSG(2) = 0
      MSG(3) = 0
      MSG(4) = 0
      MSG(5) = 0
      MSG(6) = 0
      NBYTES = 48/NWDVAR
      CALL DDI_SEND( MSG, NBYTES, DDI_ME+DDI_NP )
C
C        RECEIVE RESOURCE USAGE STATISTICS FROM THE FIRST DATA SERVER
C
      IF(DDI_ME.EQ.0) THEN
         CALL DDI_RECV( STATS, 2*8, DDI_NP)
         MEM1 = INT(STATS(1))
         MEMDDI = INT(DDI_NP * (MEM1/1.0D+06)) + 1
         IF(MEM1.EQ.0) MEMDDI=0
         WRITE(IW,9020) MEMDDI, MEM1, STATS(2)
      END IF
C
C        WAIT FOR SUICIDE ORDER TO BE SENT BY ALL COMPUTE PROCESSES.
C
      IF(ISTAT.EQ.0) CALL DDI_SYNC( 10149 )
C
C              --- CLOSE THE COMMUNICATIONS LIBRARY ---
C        EACH COMPUTE PROCESS SHOULD NOTIFY THE KICKOFF PROGRAM
C        THAT IT IS TERMINATING, SO THE KICKOFF PROGRAM CAN DIE.
C
*SOC  IF(ISTAT.EQ.0) CALL SOC_KILLKICK
C
C        TERMINATE MPI USE. THIS MATCHES A SIMILAR BARRIER AND
C        FINALIZATION BY THE DATA SERVER PROCESSES (QUO VADIS).
C
*MPI  CALL MPI_BARRIER(MPI_COMM_WORLD, IERROR)
*MPI  CALL MPI_FINALIZE(IERROR)
C
      RETURN
C
 9010 FORMAT(1X,'*** ERROR TERMINATION *** IN COMPUTE PROCESS',I6)
 9015 FORMAT(1X,'*** ERROR TERMINATION *** IN DATA SERVER PROCESS',I6)
 9020 FORMAT(/'DATA SERVER STATS: TOTAL DISTRIBUTED MEMORY USED',
     *        ' (MEMDDI)=',I8,' MWORDS.'/
     *        'FIRST DATA SERVER''S MAXIMUM MEMORY=',I14,
     *        ' WORDS, CPU=',F8.1,' SECONDS.'/)
      END
C*MODULE DDI      *DECK DDI_MEMORY
      SUBROUTINE DDI_MEMORY( MEMREP, MEMDDI , EXETYP)
C
C  -------------------------------------------------------------------
C  INITIALIZE DDI DISTRIBUTED MEMORY
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER MEMREP, MEMDDI
      DOUBLE PRECISION EXETYP,TEMP
C
      INTEGER DDI_NP, DDI_ME, MSG(6), NBYTES
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
      DOUBLE PRECISION CHECK
      DATA CHECK/8HCHECK   /
C
*SEQ  RETURN
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
C
C     MEMDDI AGGREGATE TOTAL IN MWORDS IS NOW PARTITIONED INTO EACH
C     NODE'S SHARE, THEN CONVERTED TO WORDS, IN ORDER TO AVOID 32 BIT
C     OVERFLOWING PROBLEMS.
C
      TEMP = MEMDDI
      TEMP = 1.0D+06 * (TEMP/DDI_NP)
      MEMDDI = INT(TEMP)
      IF (MEMDDI.LT.0) RETURN
C
C  MEMREP => REPLICATED DATA
C  MEMDDI => DISTRIBUTED DATA
C  MEMDDI IS PADDED A BIT FOR MESSAGE BUFFERS: NOTE 100,000 IS A GUESS
C  IF THIS RUN IS NOT USING DISTRIBUTED MEMORY AT ALL (MEMDDI=0), WE
C  ALLOCATE AT LEAST A TRIVIAL AMOUNT (0 IS REJECTED BY SETFM).
C
C  EXETYP=CHECK JOBS DON'T FORMALLY ALLOCATE DISTRIBUTED MEMORY.
C  HOWEVER, THE TRUE BIG VALUE OF -MEMDDI- MUST NOT BE MADE SMALL.
C
      MSG(1) = 0
      MSG(2) = MEMDDI + MIN(100000,MEMREP)
      IF(MEMDDI.EQ.0)     MSG(2) = 100
      IF(EXETYP.EQ.CHECK) MSG(2) = 100
      MSG(3) = 0
      MSG(4) = 0
      MSG(5) = 0
      MSG(6) = 0
      NBYTES = 48/NWDVAR
      CALL DDI_SEND( MSG, NBYTES, DDI_ME+DDI_NP )
      CALL DDI_SYNC( 10147 )
      RETURN
      END
C
C*MODULE DDI      *DECK DDI_OUTPUT
      SUBROUTINE DDI_OUTPUT(DDI_ON_OFF)
C
C  -------------------------------------------------------------------
C  TOGGLE MESSAGES FROM DDI_CREATE,DDI_DESTROY
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      LOGICAL DDI_ON_OFF, DDI_PRT
      COMMON /DDIFLG/ DDI_PRT
C
      DDI_PRT = DDI_ON_OFF
      RETURN
      END
C*MODULE DDI      *DECK DDI_CREATE
      SUBROUTINE DDI_CREATE( IDIM, JDIM, HANDLE )
C
C  -------------------------------------------------------------------
C  CREATE DISTRIBUTED DOUBLE PRECISION DATA STRUCTURE
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER IDIM, JDIM, HANDLE
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
      INTEGER MINCOL, LFTCOL, ICOL,
     *        ILOC,   IHIC,   JLOC,   JHIC, I,
     *        DDI_NP, DDI_ME, MSG(6), NBYTES
C
      LOGICAL DDI_PRT
      COMMON /DDIFLG/ DDI_PRT
C
*SEQ  WRITE(IW,*) 'SEQUENTIAL VERSION DOES NOT SUPPORT DISTRIBUTED DATA'
*SEQ  WRITE(IW,*) 'THIS JOB CANNOT BE RUN'
*SEQ  STOP
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      NDM          = NDM + 1
      IF(NDM.GT.MAXDM) THEN
         WRITE(IW,9010) DDI_ME,MAXDM
         CALL ABRT
      END IF
      HANDLE       = NDM
      NROW(HANDLE) = IDIM
C
C  DETERMINE THE `COLUMN' DISTRIBUTION
C
      MINCOL = JDIM/DDI_NP        ! MINIMUM NO. COLUMNS PER NODE
      LFTCOL = MOD(JDIM,DDI_NP)   ! LEFT-OVER COLUMNS
C
C  GENERATE THE COLUMN-NODE MAPPING
C
      ICOL = 1
      DO I = 0 , DDI_NP
        CMAP(I,HANDLE) = ICOL
        ICOL = ICOL + MINCOL
        IF ( I .LT. LFTCOL ) ICOL = ICOL + 1
      END DO
C
C  GET SIZE OF LOCAL `CHUNK'
C
      CALL DDI_DISTRIB( HANDLE, DDI_ME, ILOC, IHIC, JLOC, JHIC )
C
C  SEND REQUEST TO DATA SERVER
C
      MSG(1) = 1
      MSG(2) = HANDLE
      MSG(3) = ILOC
      MSG(4) = IHIC
      MSG(5) = JLOC
      MSG(6) = JHIC
      NBYTES = 48/NWDVAR
      CALL DDI_SEND( MSG, NBYTES, DDI_ME+DDI_NP )
      IF (DDI_ME.EQ.0.AND.DDI_PRT) WRITE(IW,9000) HANDLE,IDIM,JDIM
C
C  SYNC TO ENSURE ENTIRE SHARED MEMORY REGION IS AVAILABLE
C  BEFORE USING IT.
C
      CALL DDI_SYNC( 10150 )
      RETURN
9000  FORMAT(6X,'DDI_CREATE: [',1I2,'] SIZE: ',1I8,' BY ',1I8)
9010  FORMAT(1X,' *** ERROR *** '/
     *     1X,'PROCESS',I6,' TRIED TO CREATE A NEW DISTRIBUTED ARRAY,'/
     *     1X,'BUT MAXIMUM NUMBER OF DM-S IS',I6)
      END
C*MODULE DDI      *DECK DDI_DESTROY
      SUBROUTINE DDI_DESTROY( HANDLE )
C
C  -------------------------------------------------------------------
C  DESTROY A DM - MUST BE DONE IN REVERSE ORDER TO THE CREATE'S
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER HANDLE
C
      INTEGER DDI_NP, DDI_ME, MSG(6), NBYTES
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
      LOGICAL DDI_PRT
      COMMON /DDIFLG/ DDI_PRT
C
*SEQ  WRITE(IW,*) 'SEQUENTIAL VERSION DOES NOT SUPPORT DISTRIBUTED DATA'
*SEQ  WRITE(IW,*) 'THIS JOB CANNOT BE RUN'
*SEQ  STOP
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
C
C  SYNC TO ENSURE ENTIRE SHARED MEMORY REGION IS UNUSED
C  BEFORE REMOVING IT.
C
      CALL DDI_SYNC( 10151 )
      IF(NDM.LE.0) THEN
         WRITE(IW,9010) DDI_ME,NDM
         CALL ABRT
      END IF
      NDM = NDM - 1
C
C  SEND REQUEST TO DATA SERVER
C
      MSG(1) = 2
      MSG(2) = HANDLE
      MSG(3) = 0
      MSG(4) = 0
      MSG(5) = 0
      MSG(6) = 0
      NBYTES = 48/NWDVAR
      CALL DDI_SEND( MSG, NBYTES, DDI_ME+DDI_NP )
      IF (DDI_ME.EQ.0.AND.DDI_PRT) WRITE(IW,9000) HANDLE
      RETURN
9000  FORMAT(6X,'DDI_DESTROY: [',1I2,'] ')
9010  FORMAT(1X,' *** ERROR *** '/
     *     1X,'PROCESS',I6,' TRIED TO DESTROY DISTRIBUTED ARRAY',I4)
      END
C*MODULE DDI      *DECK DDI_DISTRIB
      SUBROUTINE DDI_DISTRIB( HANDLE, NODE, ILOC, IHIC, JLOC, JHIC )
C
C  -------------------------------------------------------------------
C  QUERY THE DISTRIBUTION OF A DM
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER  HANDLE, NODE, ILOC, IHIC, JLOC, JHIC
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  WRITE(IW,*) 'SEQUENTIAL VERSION DOES NOT SUPPORT DISTRIBUTED DATA'
*SEQ  WRITE(IW,*) 'THIS JOB CANNOT BE RUN'
*SEQ  STOP
C
      ILOC = 1
      IHIC = NROW(HANDLE)
      JLOC = CMAP( NODE  , HANDLE )
      JHIC = CMAP( NODE+1, HANDLE ) - 1
      RETURN
      END
C*MODULE DDI      *DECK DDI_NDISTRIB
      SUBROUTINE DDI_NDISTRIB(HANDLE,NODE,ILOC,IHIC,JLOC,JHIC)
      IMPLICIT NONE
      INTEGER  HANDLE, NODE, ILOC, IHIC, JLOC, JHIC
      call DDI_DISTRIB(HANDLE,NODE,ILOC,IHIC,JLOC,JHIC)
      RETURN
      END
C*MODULE DDI      *DECK DDI_PROCDLB_CREATE
      subroutine ddi_procdlb_create(hnd)
      implicit none
      integer hnd,ddi_np,ddi_me
      call ddi_nproc(ddi_np,ddi_me)
      call ddi_create(1,ddi_np,hnd)
      return
      end
C*MODULE DDI      *DECK DDI_PROCDLB_DESTROY
      subroutine ddi_procdlb_destroy(hnd)
      implicit none
      integer hnd
      call ddi_destroy(hnd)
      return
      end
C*MODULE DDI      *DECK DDI_PROCDLB_RESET
      subroutine ddi_procdlb_reset(hnd)
      implicit none
      integer hnd,ddi_np,ddi_me
      double precision buff
      buff = 0.0D+00
      call ddi_nproc(ddi_np,ddi_me)
      call ddi_sync(1)
      call ddi_put(hnd,1,1,ddi_me+1,ddi_me+1,buff)
      call ddi_sync(2)
      return
      end
C*MODULE DDI      *DECK DDI_PROCDLB_NEXT
      subroutine ddi_procdlb_next(hnd,proc,value)
      implicit none
      integer hnd,proc,value
      double precision buff
      buff = 1.0d+00
      call ddi_getacc(hnd,1,1,proc+1,proc+1,buff)
      value = int(buff+0.01d+00)
      return
      end
C*MODULE DDI      *DECK DDI_DLBRESET
      SUBROUTINE DDI_DLBRESET
C
C  -------------------------------------------------------------------
C  RESET DLB COUNTER (GLOBAL EVENT)
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER DDI_ME, DDI_NP, MSG(6), NBYTES
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  INTEGER ICOUNT
*SEQ  COMMON /DLBVAL/ ICOUNT
C
*SEQ  ICOUNT=0
*SEQ  RETURN
C
      CALL DDI_SYNC( 10152 )
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      IF ( DDI_ME .EQ. 0 ) THEN
        MSG(1) = 6
        MSG(2) = 0
        MSG(3) = 0
        MSG(4) = 0
        MSG(5) = 0
        MSG(6) = 0
        NBYTES = 48/NWDVAR
        CALL DDI_SEND( MSG, NBYTES, DDI_NP )
      END IF
      CALL DDI_SYNC( 10153 )
      RETURN
      END
C*MODULE DDI      *DECK DDI_DLBNEXT
      SUBROUTINE DDI_DLBNEXT( DLB_COUNTER )
C
C  -------------------------------------------------------------------
C  GET DYNAMIC LOAD BALANCING TASK INDEX
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER DLB_COUNTER
C
      INTEGER DDI_ME, DDI_NP, MSG(6), NBYTES
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  INTEGER ICOUNT
*SEQ  COMMON /DLBVAL/ ICOUNT
C
*SEQ  DLB_COUNTER = ICOUNT
*SEQ  ICOUNT=ICOUNT+1
*SEQ  RETURN
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      MSG(1) = 7
      MSG(2) = 0
      MSG(3) = 0
      MSG(4) = 0
      MSG(5) = 0
      MSG(6) = 0
      NBYTES = 48/NWDVAR
      CALL DDI_SEND( MSG, NBYTES, DDI_NP )
      CALL DDI_RECV( DLB_COUNTER, 8/NWDVAR, DDI_NP )
      RETURN
      END
C*MODULE DDI      *DECK DDI_GET
      SUBROUTINE DDI_GET( HANDLE, ILO, IHI, JLO, JHI, BUFF )
C
C  -------------------------------------------------------------------
C  COPY A PATCH OF A DM FROM THE SHARED REGION
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER HANDLE, ILO, IHI, JLO, JHI
      DOUBLE PRECISION BUFF(*)
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NSUBPATCH, NODEOFF, ILOSP(MAXPROC)
     *,       IHISP(MAXPROC), JLOSP(MAXPROC), JHISP(MAXPROC)
     *,       ILSP,   IHSP,   JLSP,  JHSP,  ILEN, JLEN, NBYTES
     *,       ISP,    NODE,   IBOFF, LENB,  DDI_NP, DDI_ME, MSG(6)
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  WRITE(IW,*) 'SEQUENTIAL VERSION DOES NOT SUPPORT DISTRIBUTED DATA'
*SEQ  WRITE(IW,*) 'THIS JOB CANNOT BE RUN'
*SEQ  STOP
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      CALL DDI_SUBPATCH( HANDLE, ILO, IHI, JLO, JHI
     *,                  NSUBPATCH, NODEOFF
     *,                  ILOSP, IHISP, JLOSP, JHISP )
C
C  LOOP OVER SUB-PATCHES
C
      IBOFF  = 1
      DO ISP = 1 , NSUBPATCH
        ILSP = ILOSP(ISP)
        IHSP = IHISP(ISP)
        JLSP = JLOSP(ISP)
        JHSP = JHISP(ISP)
        NODE = ISP + NODEOFF
        ILEN = IHSP - ILSP + 1
        JLEN = JHSP - JLSP + 1
        LENB = ILEN*JLEN
        MSG(1) = 3
        MSG(2) = HANDLE
        MSG(3) = ILSP
        MSG(4) = IHSP
        MSG(5) = JLSP
        MSG(6) = JHSP
        NBYTES = 48/NWDVAR
        CALL DDI_SEND( MSG, NBYTES, NODE+DDI_NP )
        CALL DDI_RECV( BUFF(IBOFF), LENB*8, NODE+DDI_NP )
        IBOFF = IBOFF + LENB
      END DO
      RETURN
      END
C*MODULE DDI      *DECK DDI_PUT
      SUBROUTINE DDI_PUT( HANDLE, ILO, IHI, JLO, JHI, BUFF )
C
C  -------------------------------------------------------------------
C  COPY A PATCH OF A DM TO THE SHARED REGION
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER HANDLE, ILO, IHI, JLO, JHI
      DOUBLE PRECISION BUFF(*)
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NSUBPATCH, NODEOFF, ILOSP(MAXPROC)
     *,       IHISP(MAXPROC), JLOSP(MAXPROC), JHISP(MAXPROC)
     *,       ILSP,   IHSP,   JLSP,  JHSP,  ILEN, JLEN, NBYTES
     *,       ISP,    NODE,   IBOFF, LENB,  DDI_NP, DDI_ME, MSG(6)
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  WRITE(IW,*) 'SEQUENTIAL VERSION DOES NOT SUPPORT DISTRIBUTED DATA'
*SEQ  WRITE(IW,*) 'THIS JOB CANNOT BE RUN'
*SEQ  STOP
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      CALL DDI_SUBPATCH( HANDLE, ILO, IHI, JLO, JHI
     *,                  NSUBPATCH, NODEOFF
     *,                  ILOSP, IHISP, JLOSP, JHISP )
C
C  LOOP OVER SUB-PATCHES
C
      IBOFF  = 1
      DO ISP = 1 , NSUBPATCH
        ILSP = ILOSP(ISP)
        IHSP = IHISP(ISP)
        JLSP = JLOSP(ISP)
        JHSP = JHISP(ISP)
        NODE = ISP + NODEOFF
        ILEN = IHSP - ILSP + 1
        JLEN = JHSP - JLSP + 1
        LENB = ILEN*JLEN
        MSG(1) = 4
        MSG(2) = HANDLE
        MSG(3) = ILSP
        MSG(4) = IHSP
        MSG(5) = JLSP
        MSG(6) = JHSP
        NBYTES = 48/NWDVAR
        CALL DDI_SEND( MSG, NBYTES, NODE+DDI_NP )
        CALL DDI_SEND( BUFF(IBOFF), LENB*8, NODE+DDI_NP )
        IBOFF = IBOFF + LENB
      END DO
      RETURN
      END
C*MODULE DDI      *DECK DDI_ACC
      SUBROUTINE DDI_ACC( HANDLE, ILO, IHI, JLO, JHI, BUFF)
C
C  -------------------------------------------------------------------
C  SUM DATA TO A PATCH OF A DM IN THE SHARED REGION
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER HANDLE, ILO, IHI, JLO, JHI
      DOUBLE PRECISION BUFF(*)
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NSUBPATCH, NODEOFF, ILOSP(MAXPROC)
     *,       IHISP(MAXPROC), JLOSP(MAXPROC), JHISP(MAXPROC)
     *,       ILSP,   IHSP,   JLSP,  JHSP,  ILEN, JLEN, NBYTES
     *,       ISP,    NODE,   IBOFF, LENB,  DDI_NP, DDI_ME, MSG(6)
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  WRITE(IW,*) 'SEQUENTIAL VERSION DOES NOT SUPPORT DISTRIBUTED DATA'
*SEQ  WRITE(IW,*) 'THIS JOB CANNOT BE RUN'
*SEQ  STOP
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      CALL DDI_SUBPATCH( HANDLE, ILO, IHI, JLO, JHI
     *,                  NSUBPATCH, NODEOFF
     *,                  ILOSP, IHISP, JLOSP, JHISP )
C
C  LOOP OVER SUB-PATCHES
C
      IBOFF  = 1
      DO ISP = 1 , NSUBPATCH
        ILSP = ILOSP(ISP)
        IHSP = IHISP(ISP)
        JLSP = JLOSP(ISP)
        JHSP = JHISP(ISP)
        NODE = ISP + NODEOFF
        ILEN = IHSP - ILSP + 1
        JLEN = JHSP - JLSP + 1
        LENB = ILEN*JLEN
        MSG(1) = 5
        MSG(2) = HANDLE
        MSG(3) = ILSP
        MSG(4) = IHSP
        MSG(5) = JLSP
        MSG(6) = JHSP
        NBYTES = 48/NWDVAR
        CALL DDI_SEND( MSG, NBYTES, NODE+DDI_NP )
        CALL DDI_SEND( BUFF(IBOFF), LENB*8, NODE+DDI_NP )
        IBOFF = IBOFF + LENB
      END DO
      RETURN
      END
C*MODULE DDI      *DECK DDI_GETACC
      SUBROUTINE DDI_GETACC( HANDLE, ILO, IHI, JLO, JHI, BUFF)
C
C  -------------------------------------------------------------------
C  SUM DATA TO A PATCH OF A DM IN THE SHARED REGION
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER HANDLE, ILO, IHI, JLO, JHI
      DOUBLE PRECISION BUFF(*)
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NSUBPATCH, NODEOFF, ILOSP(MAXPROC)
     *,       IHISP(MAXPROC), JLOSP(MAXPROC), JHISP(MAXPROC)
     *,       ILSP,   IHSP,   JLSP,  JHSP,  ILEN, JLEN, NBYTES
     *,       ISP,    NODE,   IBOFF, LENB,  DDI_NP, DDI_ME, MSG(6)
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  WRITE(IW,*) 'SEQUENTIAL VERSION DOES NOT SUPPORT DISTRIBUTED DATA'
*SEQ  WRITE(IW,*) 'THIS JOB CANNOT BE RUN'
*SEQ  STOP
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      CALL DDI_SUBPATCH( HANDLE, ILO, IHI, JLO, JHI
     *,                  NSUBPATCH, NODEOFF
     *,                  ILOSP, IHISP, JLOSP, JHISP )
C
C  LOOP OVER SUB-PATCHES
C
      IBOFF  = 1
      DO ISP = 1 , NSUBPATCH
        ILSP = ILOSP(ISP)
        IHSP = IHISP(ISP)
        JLSP = JLOSP(ISP)
        JHSP = JHISP(ISP)
        NODE = ISP + NODEOFF
        ILEN = IHSP - ILSP + 1
        JLEN = JHSP - JLSP + 1
        LENB = ILEN*JLEN
        MSG(1) = 15
        MSG(2) = HANDLE
        MSG(3) = ILSP
        MSG(4) = IHSP
        MSG(5) = JLSP
        MSG(6) = JHSP
        NBYTES = 48/NWDVAR
        CALL DDI_SEND( MSG, NBYTES, NODE+DDI_NP )
        CALL DDI_SEND( BUFF(IBOFF), LENB*8, NODE+DDI_NP )
        CALL DDI_RECV( BUFF(IBOFF), LENB*8, NODE+DDI_NP )
        IBOFF = IBOFF + LENB
      END DO
      RETURN
      END
C*MODULE DDI      *DECK DDI_SUBPATCH
      SUBROUTINE DDI_SUBPATCH( HANDLE, ILO, IHI, JLO, JHI
     *,                        NSUBPATCH, NODEOFF
     *,                        ILOSP, IHISP, JLOSP, JHISP )
C
C  -------------------------------------------------------------------
C  SPLIT PATCH INTO NODAL SUBPATCHES
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER HANDLE, ILO,  IHI,  JLO,  JHI
C
      INTEGER NSUBPATCH, NODEOFF
     *,       ILOSP(*), IHISP(*), JLOSP(*), JHISP(*)
     *,       ILOC, IHIC, JLOC, JHIC, I, DDI_NP, DDI_ME
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      NSUBPATCH = 0
      DO I = 0 , DDI_NP - 1
        CALL DDI_DISTRIB( HANDLE, I, ILOC, IHIC, JLOC, JHIC)
        IF ( JLOC .GT. JHI .OR. JHIC .LT. JLO ) THEN
C
C  PATCH DOES NOT OVERLAP WITH THIS NODE
C
        ELSE
          NSUBPATCH = NSUBPATCH + 1
          IF ( NSUBPATCH .EQ. 1 ) NODEOFF = I-1
          IF ( JLO .GT. JLOC ) THEN
            JLOSP( NSUBPATCH ) = JLO
          ELSE
            JLOSP( NSUBPATCH ) = JLOC
          END IF
          IF ( JHIC .GT. JHI ) THEN
            JHISP( NSUBPATCH ) = JHI
          ELSE
            JHISP( NSUBPATCH ) = JHIC
          END IF
          ILOSP( NSUBPATCH ) = ILO
          IHISP( NSUBPATCH ) = IHI
        END IF
      END DO
      RETURN
      END
C*MODULE DDI      *DECK DDI_SYNC
      SUBROUTINE DDI_SYNC( SNCTAG )
C
C  -------------------------------------------------------------------
C  COMPUTE PROCESS SYNC = SMALL GLOBAL SUM
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER SNCTAG
C
*MPI  INTEGER*4 MPI_COMM_GAMESS, IERROR
*MPI  COMMON /DDIMPI/ MPI_COMM_GAMESS
*MPI  CALL MPI_BARRIER(MPI_COMM_GAMESS,IERROR)
C
*SOC  INTEGER DUMMY
*SOC  DUMMY = 0
*SOC  CALL DDI_GSUMI( SNCTAG, DUMMY, 1 )
C
      RETURN
      END
C*MODULE DDI      *DECK DDI_GSUMF
      SUBROUTINE DDI_GSUMF( MSGTAG, BUFF, MSGLEN )
C
C  -------------------------------------------------------------------
C  FLOATING POINT GLOBAL SUM
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER MSGTAG, MSGLEN
      DOUBLE PRECISION BUFF(*)
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER J
*MPI  INTEGER*4 MPITYP, MPI_COMM_GAMESS, IERROR, LENGTH
*MPI  COMMON /DDIMPI/ MPI_COMM_GAMESS
C
*SOC  INTEGER LENGTH
C
*SEQ  INTEGER LENGTH
C
      INTEGER NPASS, LOCBUF, I, MAXWRK
      PARAMETER ( MAXWRK = 16384 )
      DOUBLE PRECISION RCVBUF
      COMMON /DDIBUF/ RCVBUF(MAXWRK)
C
*SEQ  RETURN
C
      NPASS  = ( MSGLEN - 1 )/MAXWRK + 1
      LOCBUF = 1
      LENGTH = MAXWRK
      DO I = 1 , NPASS
        IF ( I .EQ. NPASS ) LENGTH = MSGLEN - MAXWRK*(NPASS-1)
C
*MPI    MPITYP = MPI_REAL8
*MPI    CALL MPI_ALLREDUCE( BUFF(LOCBUF), RCVBUF, LENGTH, MPITYP,
*MPI *                      MPI_SUM, MPI_COMM_GAMESS, IERROR )
*MPI    DO J=1,LENGTH
*MPI       BUFF(LOCBUF-1+J) = RCVBUF(J)
*MPI    END DO
C
*SOC    CALL SOC_GSUMP( MSGTAG, BUFF(LOCBUF), RCVBUF, LENGTH, 'F')
C
        LOCBUF = LOCBUF + LENGTH
      END DO
C
C  SOCKET CODE HAS ONLY DONE SUMMING ONTO MASTER, NOW BROADCAST TO ALL
C
*SOC  CALL DDI_BCAST( MSGTAG, 'F', BUFF, MSGLEN, 0 )
      RETURN
      END
C*MODULE DDI      *DECK DDI_GSUMI
      SUBROUTINE DDI_GSUMI( MSGTAG, BUFF, MSGLEN )
C
C  -------------------------------------------------------------------
C  INTEGER GLOBAL SUM
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER MSGTAG, MSGLEN, BUFF(MSGLEN)
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER J
*MPI  INTEGER*4 MPITYP, MPI_COMM_GAMESS, IERROR, LENGTH
*MPI  COMMON /DDIMPI/ MPI_COMM_GAMESS
*MPI  INTEGER MAXDM, MAXPROC
*MPI  PARAMETER ( MAXDM = 20, MAXPROC = 512 )
*MPI  INTEGER NWDVAR, IW, NDM, NROW, CMAP
*MPI  COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SOC  INTEGER LENGTH
C
*SEQ  INTEGER LENGTH
C
      INTEGER NPASS, LOCBUF, I, MAXWRK
      DOUBLE PRECISION RCVBUF
      PARAMETER ( MAXWRK = 16384 )
      COMMON /DDIBUF/ RCVBUF(MAXWRK)
*SEQ  INTEGER   IRCVBF(16384)
*SOC  INTEGER   IRCVBF(16384)
*MPI  INTEGER*4 IRCVBF(16384),BUFF4(16384)
      EQUIVALENCE (RCVBUF(1),IRCVBF(1))
C
*SEQ  RETURN
C
      NPASS  = ( MSGLEN - 1 )/MAXWRK + 1
      LOCBUF = 1
      LENGTH = MAXWRK
      DO I = 1 , NPASS
        IF ( I .EQ. NPASS ) LENGTH = MSGLEN - MAXWRK*(NPASS-1)
C
*MPI    MPITYP= MPI_INTEGER4
*MPI    IF(NWDVAR.EQ.1) MPITYP=MPI_INTEGER8
*MPI    DO J=1,LENGTH
*MPI       BUFF4(LOCBUF-1+J) = BUFF(LOCBUF-1+J)
*MPI    END DO
*MPI    CALL MPI_ALLREDUCE( BUFF4(LOCBUF), IRCVBF, LENGTH, MPITYP,
*MPI *                      MPI_SUM, MPI_COMM_GAMESS, IERROR )
*MPI    DO J=1,LENGTH
*MPI       BUFF(LOCBUF-1+J) = IRCVBF(J)
*MPI    END DO
C
*SOC    CALL SOC_GSUMP( MSGTAG, BUFF(LOCBUF), IRCVBF, LENGTH, 'I' )
C
        LOCBUF = LOCBUF + LENGTH
      END DO
C
C  SOCKET CODE HAS ONLY DONE SUMMING ONTO MASTER, NOW BROADCAST TO ALL
C
*SOC  CALL DDI_BCAST( MSGTAG, 'I', BUFF, MSGLEN, 0 )
      RETURN
      END
C*MODULE DDI      *DECK DDI_BCAST
      SUBROUTINE DDI_BCAST( MSGTAG, TYPE, BUFF, LEN, FROM )
C
C  -------------------------------------------------------------------
C  BROADCAST
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER MSGTAG, BUFF(*), LEN, FROM
      CHARACTER*1 TYPE
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 LEN4, MPITYP, FROM4, MPI_COMM_GAMESS, IERROR
*MPI  COMMON /DDIMPI/ MPI_COMM_GAMESS
C
*SOC  INTEGER MSGLEN, DDI_NP, DDI_ME
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SEQ  RETURN
C
      IF ( TYPE .EQ. 'F' ) THEN
*MPI    MPITYP = MPI_REAL8
*SOC    MSGLEN = LEN*8
      ELSE IF ( TYPE .EQ. 'I' ) THEN
*MPI    MPITYP = MPI_INTEGER4
*MPI    IF(NWDVAR.EQ.1) MPITYP = MPI_INTEGER8
*SOC    MSGLEN = LEN*(8/NWDVAR)
      ELSE
        WRITE(IW,*) 'DDI_BCAST:',MSGTAG,'ILLEGAL TYPE:',TYPE
        CALL ABRT
      END IF
C
*MPI  LEN4 = LEN
*MPI  FROM4= FROM
*MPI  CALL MPI_BCAST( BUFF,LEN4,MPITYP,FROM4,MPI_COMM_GAMESS,IERROR )
C
C        BINARY TREE BROADCAST ASSUMES MESSAGE PROPAGATES FROM 0
C
*SOC  IF ( FROM .NE. 0 ) THEN
*SOC    CALL DDI_NPROC( DDI_NP, DDI_ME)
*SOC    IF(DDI_ME.EQ.FROM) CALL SOC_SEND( BUFF, MSGLEN, 0)
*SOC    IF(DDI_ME.EQ.0)    CALL SOC_RECV( BUFF, MSGLEN, FROM)
*SOC  END IF
*SOC  CALL SOC_BCSTMP( BUFF, MSGLEN )
C
      RETURN
      END
C*MODULE DDI      *DECK DDI_NPROC
      SUBROUTINE DDI_NPROC( DDI_NP, DDI_ME )
C
C  -------------------------------------------------------------------
C  RETURN TOTAL NUMBER OF NODES AND INDIVIDUAL NODE IDENTITY.
C  NOTE THAT THIS ROUTINE SHOULD RETURN THE NUMBER OF COMPUTE
C  PROCESSES ONLY, NOT THE TOTAL NUMBER OF PROCESSES.
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER DDI_NP, DDI_ME
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 DDI_NP4,DDI_ME4,IERROR
C
*MPI  CALL MPI_COMM_SIZE( MPI_COMM_WORLD, DDI_NP4, IERROR )
*MPI  CALL MPI_COMM_RANK( MPI_COMM_WORLD, DDI_ME4, IERROR )
*MPI  DDI_ME = DDI_ME4
*MPI  DDI_NP = DDI_NP4/2
C
*SOC  CALL SOC_NPROC(DDI_NP, DDI_ME)
C
*SEQ  DDI_NP=1
*SEQ  DDI_ME=0
C
      RETURN
      END
C*MODULE DDI      *DECK DDI_NNODE
      SUBROUTINE DDI_NNODE( DDI_NN, DDI_MY )
      IMPLICIT NONE
      INTEGER DDI_NN,DDI_MY
      CALL DDI_NPROC(DDI_NN,DDI_MY)
      RETURN
      END
C*MODULE DDI      *DECK DDI_SEND
      SUBROUTINE DDI_SEND( SNDBUF, LEN, TO )
C
C  ----------------
C  SYNCHRONOUS SEND
C  ----------------
C
      IMPLICIT NONE
      DOUBLE PRECISION SNDBUF(*)
      INTEGER LEN, TO
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 LEN4, MPITYP, TO4, MSGTAG, IERROR
C
*MPI  MSGTAG = 100374
*MPI  MPITYP = MPI_BYTE
*MPI  LEN4   = LEN
*MPI  TO4    = TO
*MPI  CALL MPI_SSEND( SNDBUF, LEN4, MPITYP, TO4, MSGTAG,
*MPI *                MPI_COMM_WORLD, IERROR )
C
*SOC  CALL SOC_SEND( SNDBUF, LEN, TO)
C
      RETURN
      END
C*MODULE DDI      *DECK DDI_RECV
      SUBROUTINE DDI_RECV( RCVBUF, LEN, FROM )
C
C  -------------------------------------------------------------------
C  SYNCHRONOUS RECEIVE
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      DOUBLE PRECISION RCVBUF(*)
      INTEGER LEN, FROM
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 LEN4,MPITYP,FROM4,MSGTAG,STATUS(MPI_STATUS_SIZE),IERROR
C
*MPI  MSGTAG = 100374
*MPI  MPITYP = MPI_BYTE
*MPI  LEN4   = LEN
*MPI  FROM4  = FROM
*MPI  CALL MPI_RECV( RCVBUF, LEN4, MPITYP, FROM4, MSGTAG,
*MPI *                MPI_COMM_WORLD, STATUS, IERROR )
C
*SOC  CALL SOC_RECV( RCVBUF, LEN, FROM )
C
      RETURN
      END
C*MODULE DDI      *DECK DDI_ISEND
      SUBROUTINE DDI_ISEND( SNDBUF, LEN, TO, IREQSND)
C
C  -----------------
C  NON-BLOCKING SEND
C  -----------------
C
C  N.B. THE RECEIVE FOR DDI_ISEND MUST BE A DDI_IRECV CALL.
C
C  THE DDI_WAIT CALL IS EXPLICITLY PAIRED TO THE USE OF THIS
C  ROUTINE, VIA THE REQUEST NUMBER -IREQSND- RETURNED FROM 
C  DDI_ISEND WHICH IS TO BE PASSED TO DDI_WAIT.
C
C  THERE MAY NOT BE ANY OTHER MESSAGE SENT FROM THE CALLER
C  TO THE RECIEPIENT BETWEEN THE ISEND/IRECV CALLS, AND THEIR
C  MATCHING WAITS, DUE TO A LIMITATION IN THE TCP/IP SOCKET
C  IMPLEMENTATION (NAMELY THAT THERE IS ONLY ONE SOCKET).
C
C  IT IS SAFE TO USE THESE TWO IN A BIDIRECTIONAL FASHION.
C
      IMPLICIT NONE
      DOUBLE PRECISION SNDBUF(*)
      INTEGER LEN, TO, IREQSND
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 LEN4, MPITYP, TO4, MSGTAG, IREQSND4, IERROR
C
*MPI  MSGTAG  = 100377
*MPI  MPITYP  = MPI_BYTE
*MPI  LEN4    = LEN
*MPI  TO4     = TO
*MPI  CALL MPI_ISEND( SNDBUF, LEN4, MPITYP, TO4, MSGTAG,
*MPI *                MPI_COMM_WORLD, IREQSND4, IERROR )
*MPI  IREQSND = IREQSND4
C
*SOC  CALL SOC_ISEND( SNDBUF, LEN, TO, IREQSND)
C
      RETURN
      END
C*MODULE DDI      *DECK DDI_IRECV
      SUBROUTINE DDI_IRECV( RCVBUF, LEN, FROM, IREQRCV )
C
C  -----------------
C  NON-BLOCKING RECV
C  -----------------
C
C  SEE COMMENTS IN DDI_ISEND.
C
      IMPLICIT NONE
      DOUBLE PRECISION RCVBUF(*)
      INTEGER LEN, FROM, IREQRCV
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 LEN4, MPITYP, FROM4, MSGTAG, STATUS(MPI_STATUS_SIZE),
*MPI *          IERROR, IREQRCV4
C
*MPI  MSGTAG  = 100377
*MPI  MPITYP  = MPI_BYTE
*MPI  LEN4    = LEN
*MPI  FROM4   = FROM
*MPI  CALL MPI_IRECV( RCVBUF, LEN4, MPITYP, FROM4, MSGTAG,
*MPI *                MPI_COMM_WORLD, IREQRCV4, IERROR )
*MPI  IREQRCV = IREQRCV4
C
*SOC  CALL SOC_IRECV( RCVBUF, LEN, FROM, IREQRCV)
C
      RETURN
      END
C*MODULE DDI      *DECK DDI_WAIT
      SUBROUTINE DDI_WAIT(IREQ)
      IMPLICIT NONE
      INTEGER IREQ
C
C     COMMUNICATION COMPLETION FOR DDI_ISEND/DDI_IRECV (QUO VADIS)
C     THE REQUEST NUMBER -IREQ- WAS GENERATED BY ONE OF THESE.
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 IREQ4,  STATUS(MPI_STATUS_SIZE), IERROR
*MPI  IREQ4 = IREQ
*MPI  CALL MPI_WAIT(IREQ4, STATUS, IERROR)
C
*SOC  CALL SOC_WAIT(IREQ)
      RETURN
      END
C*MODULE DDI      *DECK DDI_RCVANY
      SUBROUTINE DDI_RCVANY( RCVBUF, LEN, FROM )
C
C  -------------------------------------------------------------------
C  RECEIVE FROM ANY SOURCE
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER RCVBUF(*)
      INTEGER LEN, FROM
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 LEN4,MPITYP,MSGTAG,STATUS(MPI_STATUS_SIZE),IERROR
C
*MPI  MSGTAG = 100374
*MPI  MPITYP = MPI_BYTE
*MPI  LEN4   = LEN
*MPI  CALL MPI_RECV( RCVBUF, LEN4, MPITYP, MPI_ANY_SOURCE,
*MPI *               MSGTAG, MPI_COMM_WORLD, STATUS, IERROR )
*MPI  FROM = STATUS(MPI_SOURCE)
C
*SOC  CALL SOC_RCVANY( RCVBUF, LEN, FROM )
C
      RETURN
      END
C*MODULE DDI      *DECK DDI_PROBE
*MPI  SUBROUTINE DDI_PROBE(PROBING)
*MPI  LOGICAL PROBING
C
*MPI  INCLUDE 'mpif.h'
*MPI  LOGICAL*4 GOTMSG
*MPI  INTEGER*4 MSGTAG, STATUS(MPI_STATUS_SIZE), IERROR
C
C        -PROBING- IS TRUE IF DATA SERVER MESSAGES ARE NOT EXPECTED.
C        WE SHOULD NOT WASTE TIME ON -PROBING- WHEN IT IS FALSE, AS
C        THIS MEANS WE HAVE RECENTLY BEEN SERVICING DDI REQUESTS.
C
*MPI  IF(.NOT.PROBING) RETURN
C
*MPI  MSGTAG = 100374
*MPI  GOTMSG=.FALSE.
*MPI  DO WHILE (.NOT.GOTMSG)
*MPI     CALL MPI_IPROBE(MPI_ANY_SOURCE, MSGTAG, MPI_COMM_WORLD,
*MPI *                   GOTMSG, STATUS, IERROR)
*MPI     IF(GOTMSG) THEN
*MPI        PROBING=.FALSE.
*MPI        RETURN
*MPI     ELSE
*MPI        CALL NAPTIME(1)
*MPI     END IF
*MPI  END DO
C
C  WE ACTUALLY RETURN DIRECTLY OUT OF THE WHILE LOOP ABOVE, NOT HERE
C
*MPI  RETURN
*MPI  END
C
C          THEN NEXT FEW ROUTINES CONVERT FROM GLOBAL
C          OPERATIONS INTO POINT-TO-POINT MESSAGE CALLS.
C
C          THE FOLLOWING CODE WOULD WORK WITH ANY MESSAGE
C          PASSING, E.G. CHANGE SOC_XXX TO DDI_XXX AND IT
C          WILL WORK FOR ANY OTHER MESSAGE PASSING LAYER.
C
C*MODULE DDI      *DECK SOC_GSUMP
*SOC  SUBROUTINE SOC_GSUMP( MSGTAG, BUFF, RCVBUF, LEN, TYPE )
C
C  -------------------------------------------------------------------
C  MESSAGE-PASSING GENERIC GLOBAL SUM - BINARY TREE MODEL
C  -------------------------------------------------------------------
C
*SOC  IMPLICIT NONE
*SOC  INTEGER MSGTAG, LEN, ABOVE, BELOWL, BELOWR, DDI_ME, DDI_NP
*SOC *,       MSGLEN, BUFF(*), RCVBUF(*)
*SOC  CHARACTER*1 TYPE
*SOC  INTEGER MAXDM, MAXPROC
*SOC  PARAMETER ( MAXDM = 20, MAXPROC = 512 )
*SOC  INTEGER NWDVAR, IW, NDM, NROW, CMAP
*SOC  COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
C
*SOC  IF ( TYPE .EQ. 'F' ) THEN
*SOC    MSGLEN = LEN*8
*SOC  ELSE IF ( TYPE .EQ. 'I' ) THEN
*SOC    MSGLEN = LEN*(8/NWDVAR)
*SOC  ELSE
*SOC    WRITE(IW,*) 'SOC_GSUMP:',MSGTAG,'ILLEGAL TYPE:',TYPE
*SOC    CALL ABRT
*SOC  END IF
C
*SOC  CALL SOC_NPROC( DDI_NP, DDI_ME )
*SOC  ABOVE  = ( DDI_ME - 1 )/2    ! RELIES ON TRUNCATION
*SOC  BELOWL = 2*DDI_ME + 1
*SOC  BELOWR = 2*DDI_ME + 2
C
C   GATHER FROM BOTTOM OF BINARY TREE TO ITS TOP
C
*SOC  IF ( BELOWL .LT. DDI_NP ) THEN
*SOC    CALL SOC_GRECV( RCVBUF, MSGLEN, BELOWL )
*SOC    IF(TYPE.EQ.'F') CALL SOC_GOPF( BUFF, RCVBUF, LEN)
*SOC    IF(TYPE.EQ.'I') CALL SOC_GOPI( BUFF, RCVBUF, LEN)
*SOC  END IF
*SOC  IF ( BELOWR .LT. DDI_NP ) THEN
*SOC    CALL SOC_GRECV( RCVBUF, MSGLEN, BELOWR )
*SOC    IF(TYPE.EQ.'F') CALL SOC_GOPF( BUFF, RCVBUF, LEN)
*SOC    IF(TYPE.EQ.'I') CALL SOC_GOPI( BUFF, RCVBUF, LEN)
*SOC  END IF
*SOC  IF ( DDI_ME .NE. 0 ) THEN
*SOC    CALL SOC_GSEND( BUFF, MSGLEN, ABOVE )
*SOC  END IF
*SOC  RETURN
*SOC  END
C*MODULE DDI      *DECK SOC_BCSTMP
*SOC  SUBROUTINE SOC_BCSTMP( BUFF, MSGLEN )
C
C  -------------------------------------------------------------------
C  MESSAGE-PASSING GENERIC BROADCAST - BINARY TREE MODEL
C  -------------------------------------------------------------------
C
*SOC  IMPLICIT NONE
*SOC  INTEGER BUFF(*), MSGLEN
*SOC  INTEGER ABOVE, BELOWL, BELOWR, DDI_ME, DDI_NP
C
*SOC  CALL SOC_NPROC( DDI_NP, DDI_ME )
*SOC  ABOVE  = ( DDI_ME - 1 )/2
*SOC  BELOWL = 2*DDI_ME + 1
*SOC  BELOWR = 2*DDI_ME + 2
C
C  SCATTER DOWN BINARY TREE FROM TOP TO ALL OTHER NODES
C
*SOC  IF ( DDI_ME .NE.    0   )
*SOC *  CALL SOC_GRECV( BUFF, MSGLEN, ABOVE )
*SOC  IF ( BELOWL .LT. DDI_NP )
*SOC *  CALL SOC_GSEND( BUFF, MSGLEN, BELOWL )
*SOC  IF ( BELOWR .LT. DDI_NP )
*SOC *  CALL SOC_GSEND( BUFF, MSGLEN, BELOWR )
*SOC  RETURN
*SOC  END
C*MODULE DDI      *DECK SOC_GOPF
*SOC  SUBROUTINE SOC_GOPF( BUFF, RCVBUF, LEN)
*SOC  INTEGER LEN, I
*SOC  DOUBLE PRECISION BUFF(LEN), RCVBUF(LEN)
C
C  -------------------------------------------------------------------
C  GLOBAL REDUCTION OPERATIONS
C  -------------------------------------------------------------------
C
*SOC  DO I = 1 , LEN
*SOC     BUFF(I) = BUFF(I) + RCVBUF(I)
*SOC  END DO
*SOC  RETURN
*SOC  END
C*MODULE DDI      *DECK SOC_GOPI
*SOC  SUBROUTINE SOC_GOPI( BUFF, RCVBUF, LEN)
*SOC  INTEGER LEN, BUFF(LEN), RCVBUF(LEN), I
C
C  -------------------------------------------------------------------
C  GLOBAL REDUCTION OPERATIONS
C  -------------------------------------------------------------------
C
*SOC  DO I = 1 , LEN
*SOC     BUFF(I) = BUFF(I) + RCVBUF(I)
*SOC  END DO
*SOC  RETURN
*SOC  END
C
C       THE FINAL ROUTINE IS THE BRAINS OF THE WHOLE SHOW.
C       DATA SERVER PROCESSES ENTER THIS ROUTINE, AND LOOP
C       FOREVER SERVICING THE DISTRIBUTED MEMORY REQUESTS
C       FROM ALL DIRECTIONS, UNTIL TERMINATION IS REQUESTED.
C
C*MODULE DDI      *DECK DDI_SERVER
      SUBROUTINE DDI_SERVER
C
C  -------------------------------------------------------------------
C  `SPMD' DATA-SERVER PROGRAM
C  -------------------------------------------------------------------
C
      IMPLICIT NONE
C
*MPI  INCLUDE 'mpif.h'
*MPI  INTEGER*4 IERROR
*MPI  LOGICAL PROBING
C
      INTEGER MAXDM, MAXPROC
      PARAMETER ( MAXDM = 20, MAXPROC = 512 )
      DOUBLE PRECISION ZERO
      PARAMETER ( ZERO=0.0D+00 )
      LOGICAL SERVER
      INTEGER MEMORY, OPER, FROM, HANDLE, MSG(6), LOADFM,IBUF
     *,       DDIMEM(MAXDM),DDIADDR(MAXDM)
     *,       ILOS(MAXDM),IHIS(MAXDM),JLOS(MAXDM),JHIS(MAXDM)
     *,       ILOSP,IHISP,JLOSP,JHISP,IDIM,JDIM,ILEN,JLEN
     *,       IHIC,ILOC,JHIC,JLOC,IXOFF,IBOFF,LENB,J,I,IB,IX
     *,       NBYTES, DLB_COUNTER, DDI_NP, DDI_ME, NGOTMX, NEED
      DOUBLE PRECISION STATS(2), TIM, XXTMP
      INTEGER NWDVAR, IW, NDM, NROW, CMAP
      COMMON /DDINFO/ NWDVAR,IW,NDM,NROW(MAXDM),CMAP(0:MAXPROC,MAXDM)
      DOUBLE PRECISION XX
      COMMON /FMCOM / XX(1)
C
      CALL TSECND(TIM)
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      DLB_COUNTER = 0
*MPI  PROBING = .TRUE.
C
      SERVER = .TRUE.
      DO WHILE (SERVER)
C
C  WAIT ON CALLS FROM COMPUTE NODES
C
        NBYTES = 48/NWDVAR
*MPI    CALL DDI_PROBE(PROBING)
        CALL DDI_RCVANY( MSG, NBYTES, FROM )
        OPER = MSG(1)
        IF ( OPER .EQ. 0 ) THEN
C
C  ALLOCATE MAIN DDI WORKSPACE
C
          MEMORY = MSG(2)
          CALL SETFM( MEMORY )
*MPI      PROBING = .TRUE.
        ELSE IF ( OPER .EQ. 1 ) THEN
C
C  CREATE LOCAL PART OF DM AND INITIALIZE TO ZERO
C
          HANDLE = MSG(2)
          ILOC   = MSG(3)
          IHIC   = MSG(4)
          JLOC   = MSG(5)
          JHIC   = MSG(6)
          IDIM   = IHIC - ILOC + 1
          JDIM   = JHIC - JLOC + 1
          DDIMEM(HANDLE) = IDIM*JDIM
            ILOS(HANDLE) = ILOC
            IHIS(HANDLE) = IHIC
            JLOS(HANDLE) = JLOC
            JHIS(HANDLE) = JHIC
          CALL GOTFM( NGOTMX )
          CALL VALFM( LOADFM )
          IX = LOADFM + 1
          IF(DDIMEM(HANDLE).GT.NGOTMX  .AND.  DDI_ME.EQ.DDI_NP) THEN
             NEED = INT(DDI_NP*((DDIMEM(HANDLE)-NGOTMX)/1000000.0)) + 1
             CALL FLSHBF(IW)
             WRITE(IW,9100) NEED
             CALL FLSHBF(IW)
          END IF
          CALL GETFM( DDIMEM(HANDLE) )
          DDIADDR(HANDLE) = IX
          DO I = 0, DDIMEM(HANDLE)-1
            XX( IX + I ) = ZERO
          END DO
        ELSE IF ( OPER .EQ. 2 ) THEN
C
C  DESTROY DM
C
          HANDLE = MSG(2)
          CALL RETFM( DDIMEM(HANDLE) )
*MPI      PROBING = .TRUE.
        ELSE IF ( OPER .EQ. 6 ) THEN
C
C  RESET DLB COUNTER
C
          DLB_COUNTER = 0
*MPI      PROBING = .TRUE.
        ELSE IF ( OPER .EQ. 7 ) THEN
C
C  SERVICE DLB COUNTER REQUEST
C
          NBYTES = 8/NWDVAR
          CALL DDI_SEND( DLB_COUNTER, NBYTES, FROM )
          DLB_COUNTER = DLB_COUNTER + 1
        ELSE IF ( OPER .EQ. 8 ) THEN
C
C  TERMINATE SERVER LOOP
C
          SERVER = .FALSE.
        ELSE
C
C  GET, PUT, OR ACC
C
          HANDLE = MSG(2)
          ILOSP  = MSG(3)
          IHISP  = MSG(4)
          JLOSP  = MSG(5)
          JHISP  = MSG(6)
          ILEN   = IHISP - ILOSP + 1
          JLEN   = JHISP - JLOSP + 1
          LENB   = ILEN*JLEN
          ILOC   = ILOS(HANDLE)
          IHIC   = IHIS(HANDLE)
          JLOC   = JLOS(HANDLE)
          JHIC   = JHIS(HANDLE)
          IDIM   = IHIC - ILOC + 1
C
C  OFFSET TO START OF LOCAL SUBPATCH
C
          IXOFF  = DDIADDR(HANDLE)    +
     *            (JLOSP - JLOC)*IDIM +
     *             ILOSP - ILOC
C
C  ALLOCATE MESSAGE BUFFER
C
          CALL VALFM( LOADFM )
          IBUF  = LOADFM + 1
C
          CALL GOTFM( NGOTMX )
          IF(LENB.GT.NGOTMX  .AND.  DDI_ME.EQ.DDI_NP) THEN
             NEED = INT(DDI_NP*((LENB-NGOTMX)/1000000.0)) + 1
             CALL FLSHBF(IW)
             WRITE(IW,9110) NEED
             CALL FLSHBF(IW)
          END IF
C
          CALL GETFM( LENB )
          IBOFF = IBUF
          IF ( OPER .EQ. 3 ) THEN
C
C  SERVICE A GET
C
            DO J = JLOSP , JHISP
              IB = IBOFF
              IX = IXOFF
              DO I = 0, ILEN-1
                XX( IB + I ) = XX( IX + I )
              END DO
              IXOFF = IXOFF + IDIM
              IBOFF = IBOFF + ILEN
            END DO
            CALL DDI_SEND( XX(IBUF), LENB*8, FROM )
          ELSE IF ( OPER .EQ. 4 ) THEN
C
C  SERVICE A PUT
C
            CALL DDI_RECV( XX(IBUF), LENB*8, FROM )
            DO J = JLOSP , JHISP
              IB = IBOFF
              IX = IXOFF
              DO I = 0, ILEN-1
                XX( IX + I ) = XX( IB + I )
              END DO
              IXOFF = IXOFF + IDIM
              IBOFF = IBOFF + ILEN
            END DO
          ELSE IF ( OPER .EQ. 5 ) THEN
C
C  SERVICE AN ACC
C
            CALL DDI_RECV( XX(IBUF), LENB*8, FROM )
            DO J = JLOSP , JHISP
              IB = IBOFF
              IX = IXOFF
              DO I = 0, ILEN-1
                XX( IX + I ) = XX( IX + I ) + XX( IB + I )
              END DO
              IXOFF = IXOFF + IDIM
              IBOFF = IBOFF + ILEN
            END DO
          ELSE IF ( OPER .EQ. 15 ) THEN
c
c  service a getacc
c
            CALL DDI_RECV( XX(IBUF), LENB*8, FROM )
            DO J = JLOSP , JHISP
              IB = IBOFF
              IX = IXOFF
              DO I = 0, ILEN-1
                XXTMP = XX( IX + I )
                XX( IX + I ) = XX( IX + I ) + XX( IB + I )
                XX( IB + I ) = XXTMP
              END DO
              IXOFF = IXOFF + IDIM
              IBOFF = IBOFF + ILEN
            END DO
            CALL DDI_SEND( XX(IBUF), LENB*8, FROM )
          END IF
C
C  DEALLOCATE MESSAGE BUFFER
C
          CALL RETFM( LENB )
        END IF
      END DO
C
C        THE DATA SERVER ASSOCIATED WITH COMPUTE PROCESS 0 SHOULD
C        MESSAGE IT WITH ITS MAXIMUM MEMORY CONSUMED AND TIME SPENT,
C        SO THAT THESE CAN BE PRINTED FOR THE BENEFIT OF THE USER.
C
      CALL DDI_NPROC( DDI_NP, DDI_ME )
      CALL BIGFM( MEMORY )
      STATS(1) = MEMORY
      CALL TSECND(TIM)
      STATS(2) = TIM
      IF(DDI_ME.EQ.DDI_NP) CALL DDI_SEND(STATS,2*8,0)
C
C        TERMINATE MPI USE
C
*MPI  CALL MPI_BARRIER(MPI_COMM_WORLD, IERROR)
*MPI  CALL MPI_FINALIZE(IERROR)
C
C        HALT FORTRAN EXECUTION.
C
      STOP
 9100 FORMAT(1X,'PLEASE INCREASE -MEMDDI- IN $SYSTEM BY AT LEAST',I20,
     *          ' MWORDS.')
 9110 FORMAT(1X,'PROBLEM ALLOCATING MESSAGE BUFFER FOR DATA SERVER'/
     *       1X,'PLEASE INCREASE -MEMDDI- IN $SYSTEM BY AT LEAST',I20,
     *          ' MWORDS.')
      END
c
c*module ddi    *deck ddi_timer_reset
      subroutine ddi_timer_reset
c
c        in fond memory of General Douglas MacArthur...
c
      return
      end
c
c*module ddi    *deck DDI_GET_COMM
      subroutine DDI_GET_COMM(handle,ilo,ihi,jlo,jhi,buff,commid)
      integer handle,commid
      double precision buff(*)
c        if operating w/o groups, just ignore the communicator
      call ddi_get(handle, ilo, iji, jlo, jhi, buff)
      return
      end
c
c*module ddi    *deck DDI_PUT_COMM
      subroutine DDI_PUT_COMM(handle,ilo,ihi,jlo,jhi,buff,commid)
      integer handle,commid
      double precision buff(*)
c        if operating w/o groups, just ignore the communicator
      call ddi_put(handle, ilo, iji, jlo, jhi, buff)
      return
      end
c
c*module ddi    *deck DDI_ACC_COMM
      subroutine DDI_ACC_COMM(handle,ilo,ihi,jlo,jhi,buff,commid)
      integer handle,commid
      double precision buff(*)
c        if operating w/o groups, just ignore the communicator
      call ddi_acc(handle, ilo, iji, jlo, jhi, buff)
      return
      end
c
c*module ddi    *deck ddi_ngroup
      subroutine ddi_ngroup(ngroup,mygroup)
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_NGROUP')
      return
      end
c
c*module ddi    *deck ddi_scope
      subroutine ddi_scope(iscope,imaster)
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_SCOPE')
      return
      end
c
c*module ddi    *deck ddi_group_create_custom
      subroutine ddi_group_create_custom(ngroups,igrpsiz)
      implicit double precision(a-h,o-z)
      dimension igrpsiz(ngroups)
      call ddi_gddi_arimasen('DDI_GROUP_CREATE_CUSTOM')
      return
      end
c
c*module ddi    *deck ddi_group_create
      subroutine ddi_group_create(ngroups)
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_GROUP_CREATE')
      return
      end
c
c*module ddi    *deck ddi_gdlbreset
      subroutine ddi_gdlbreset
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_GDLBRESET')
      return
      end
c
c*module ddi    *deck ddi_gdlbnext
      subroutine ddi_gdlbnext(nxtval)
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_GDLBNEXT')
      return
      end
c
c*module ddi    *deck ddi_smp_nproc
      subroutine ddi_smp_nproc(nproc,me)
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_SMP_NPROC')
      return
      end
c
c*module ddi    *deck ddi_smp_create
      subroutine ddi_smp_create(isize,ihandle)
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_SMP_CREATE')
      return
      end
c
c*module ddi    *deck ddi_smp_offset
      subroutine ddi_smp_offset(ihandle, addr, ioffset)
      implicit double precision(a-h,o-z)
      character*(*) addr
      call ddi_gddi_arimasen('DDI_SMP_OFFSET')
      return
      end
c
c*module ddi    *deck ddi_smp_sync
      subroutine ddi_smp_sync()
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_SMP_SYNC')
      return
      end
c
c*module ddi    *deck ddi_smp_destroy
      subroutine ddi_smp_destroy(ihandle)
      implicit double precision(a-h,o-z)
      call ddi_gddi_arimasen('DDI_SMP_DESTROY')
      return
      end
c
c*module ddi    *deck ddi_smp_gsumf
      subroutine ddi_smp_gsumf(msgtag,buff,len)
      implicit double precision(a-h,o-z)
      dimension buff(*)
      call ddi_gddi_arimasen('DDI_SMP_GSUMF')
      return
      end
c
c*module ddi    *deck ddi_smp_bcast
      subroutine ddi_smp_bcast(msgtag, type, buff, len, ifrom)
      implicit double precision(a-h,o-z)
      character*(*) type
      dimension buff(*)
      call ddi_gddi_arimasen('DDI_SMP_BCAST')
      return
      end
c
c*module ddi    *deck ddi_masters_gsumf
      subroutine ddi_masters_gsumf(msgtag, buff, len)
      implicit double precision(a-h,o-z)
      dimension buff(*)
      call ddi_gddi_arimasen('DDI_MASTERS_GSUMF')
      return
      end
c
c*module ddi    *deck ddi_masters_bcast
      subroutine ddi_masters_bcast(msgtag, type, buff, len, ifrom)
      implicit double precision(a-h,o-z)
      character*(*) type
      dimension buff(*)
      call ddi_gddi_arimasen('DDI_MASTERS_BCAST')
      return
      end
c
c*module ddi    *deck ddi_arimasen
      subroutine ddi_gddi_arimasen(routine)
      character*(*) routine
c
c        arimasen is Japanese for "does not exist"
c
      write(6,900) routine
      call abrt
      stop
  900 format(1x,'Group DDI is not implemented in the fallback',
     *          ' DDI code,'/
     *       1x,'but your input has tried to call GDDI routine ',a,
     *          ' anyway.'/
     *       1x,'Please migrate to the current DDI implementation'/
     *       1x,'if you want to use groups of processors.')
      end
