      SUBROUTINE DBMMGR ( OPCODE )
C*********************************************************************
C        / FCB /
C            FCB(1,I) - OPEN FLAG
C            FCB(2,I) - BUFFER ADDRESS
C            FCB(3,I) - CURRENT CLR
C            FCB(4,I) - CURRENT BLOCK NUMBER
C            FCB(5,I) - FIRST BLOCK NUMBER WRITTEN TO THIS FILE
C            FCB(6,I) - LAST BLOCK NUMBER WRITTEN TO THIS FILE
C            FCB(7,I) - MAXIMUM NUMBER OF BLOCKS TO BE ALLOCATED
C                       TO THIS FILE
C            FCB(8,I) - =0, IF NO MATRIX STRINGS WRITTEN TO FILE
C                       =1, OTHERWISE, USED TO INITIALIZE COLUMN
C                           NUMBER TO 1.
C            FCB(9,I) - INDEX TO FIRST IN-MEMORY BLOCK
C            FCB(10,I)- INDEX TO LAST IN-MEMORY BLOCK
C            FCB(11,I)- INDEX TO CURRENT IN-MEMORY BLOCK
C            FCB(12,I)- ORIGINAL BUFFER ADDRESS
C            FCB(13-14,I) - DMAP FILE NAME (2A4)
C            FCB(15,I)- OPEN FLAG FOR EXTERNAL FILE
C        / DBM/
C            IDBBAS - (INPUT)-INDEX TO IN-MEMORY DATA BASE RELATIVE
C                              TO /DBM/
C            IDBFRE - (INPUT)-INDEX TO FREE CHAIN OF IN-MEMORY DATA
C                              BASE RELATIVE TO /DBM/
C            IDBDIR - (INPUT)-INDEX TO FIRST DIRECTORY BLOCK
C            MAXALC - (OUTPUT)-MAXIMUM NUMBER OF BLOCKS AVAILABLE FOR
C                              JOB
C            MAXBLK - (OUTPUT)-MAXIMUM NUMBER OF BLOCKS ALLOCATED(JOB)
C            MAXDSK - (OUTPUT)-MAXIMUM NUMBER OF BLOCKS WRITTEN TO
C                              TO DISK
C            LENALC - (OUTPUT)-LENGTH OF EACH ALLOCATED BLOCK
C            IOCODE - (INPUT) -IO-CODE FOR OPEN/CLOSE CALL
C            IFILEX - (INPUT) -FILE NUMBER FOR GINO FILE IN /XFIAT/
C            NBLOCK - (INPUT/OUTPUT) -BLOCK NUMBER BEING REFERENCED
C            NAME   - (INPUT) -GINO FILE NAME (E.G., 101,201,303,...)
C            INDBAS - INDEX TO START OF BUFFER RELATIVE TO /ZZZZZZ/
C            INDCLR - INDEX TO CLR WITHIN BUFFER RELATIVE TO /ZZZZZZ/
C            INDCBP - INDEX TO CBP WITHIN BUFFER RELATIVE TO /ZZZZZZ/
C        FREE CHAIN FORMAT (ALSO, ALL BLOCKS ALLOCATED)
C               IDBFRE==> WORD 0    POINTER TO PREVIOUS FREE BLOCK
C                                      IN CHAIN, ALWAYS 0 FOR 1ST BLK)
C                         WORD 1    POINTER TO NEXT BLOCK IN CHAIN
C                                      -INITIALLY SET TO ZERO)
C                         WORD 2    NUMBER OF FREE WORDS IN BLOCK
C                         WORD 3    RELATIVE BLOCK NUMBER
C
C         OPCODE
C           1    OPEN
C                  /GINOX/ IOCODE = 0 ; READ WITH REWIND
C                                 = 1 ; WRITE WITH REWIND
C                                 = 2 ; READ WITHOUT REWIND
C                                 = 3 ; WRITE WITHOUT REWIND
C           2    CLOSE
C                  /GINOX/ IOCODE = 1 ; CLOSE WITH REWIND
C                                    (OTHERWISE NO REWIND)
C           3    REWIND
C           4    WRITE
C           5    READ
C           6    POSITION FILE
C                  NBLOCK = BLOCK NUMBER TO POSITION TO
C           7    DELETE FILE
C           8    PROCESS WRTBLK REQUEST (SUBSTRUCTURING)
C           9    PROCESS RDBLK REQUEST (SUBSTRUCTURING)
C********************************************************************
      INTEGER    OPCODE
      INTEGER    CASE  / 4HCASE /
      INTEGER    XYCD  / 4HXYCD /
      INTEGER    PCDB  / 4HPCDB /
      INTEGER    POOL  / 4HPOOL /
      INTEGER    XPDT  / 4HXPDT /
      INCLUDE    'DSIOF.COM'
      COMMON / XFIST  / FIST(10)
      COMMON / XFIAT  / FIAT(10)
      COMMON / ZZZZZZ / MEM(4)
      COMMON / SYSTEM / ISYSBF, IWR
      DATA     LENBUF / 0 /
      IF ( LENBUF .NE. 0 ) GO TO 10
C SET UP BLOCK ALLOCATIONS FOR DOUBLE WORD BOUNDARIES
      IBASBF = LOCFX( MEM )
      LENBUF = ISYSBF - 3 + 8
      LENALC = LENBUF
      NBUFF3 = ISYSBF - 4
      ITEST  = MOD( LENBUF,2)
      IF ( ITEST .NE. 0 ) LENBUF = LENBUF + 1
10    IF ( IDBDIR .NE. 0 ) GO TO 30
C OPCODES OF 8 AND 9 HAVE NO PURPOSE WHEN THERE IS NO USE OF THE
C IN-MEMORY DATA BASE
      IF ( OPCODE .EQ. 8 .OR. OPCODE .EQ. 9 ) GO TO 7777
C  CALL DBMIO DIRECTLY, NO IN-MEMORY DATA BASE
20    CALL DBMIO ( OPCODE )
      GO TO 7777
30    IF ( NAME .GT. 100 .AND. NAME .LT. 400 ) GO TO 50
C30    IF ( NAME .GT. 300 .AND. NAME .LT. 400 ) GO TO 50
C  CHECK FOR CASECC, XYCD, AND PCDB (SETUP IN FIAT FOR PREFACE)
      IF ( NAME .EQ. CASE ) GO TO 50
      IF ( NAME .EQ. XYCD ) GO TO 50
      IF ( NAME .EQ. PCDB ) GO TO 50
      IF ( NAME .EQ. XPDT ) GO TO 50
      IF ( NAME .EQ. POOL ) GO TO 50
C OPCODES OF 8 AND 9 HAVE NO PURPOSE WHEN THERE IS NO USE OF THE
C IN-MEMORY DATA BASE
      IF ( OPCODE .EQ. 8 .OR. OPCODE .EQ. 9 ) GO TO 7777
C CALL DBMIO DIRECTLY BECAUSE THIS IS AN EXECUTIVE FILE
      IF ( FCB(  9, IFILEX ) .NE. 0 ) CALL DBMREL
      GO TO 20
50    CONTINUE
C      IF ( IFILEX .NE. 48 ) GO TO 55
C      IF ( NAME .NE. 307 ) GO TO 55
C      WRITE(IWR,40646)OPCODE,IOCODE,NBLOCK,IFILEX,NAME,INDBAS
40646 FORMAT(/,' OPCODE,IOCODE,NBLOCK,IFILEX,NAME,INDBAS=',6I6)
C      WRITE(IWR,40647)(MEM(INDBAS+KB),KB=-4,20)
40647 FORMAT(' INPUT BUFFER HAS=',/,10(4(1X,Z8),/))
C      WRITE(6,44770)(FCB(K,IFILEX),K=1,15)
44770 FORMAT(' ENTERRED FCB=',/,2(5I8,/),2I8,4X,2A4,4X,I8)
C      CALL DBMFDP
55    CONTINUE
      GO TO ( 100,200,300,400,500,600,700,800,900),OPCODE
C****************
C OPEN CODE *********************************************************
C****************
100   CONTINUE
      FCB(  1, IFILEX ) = IOCODE
      FCB( 12, IFILEX ) = FCB(  2, IFILEX )
      IF ( FCB( 9, IFILEX ) .NE. 0 ) GO TO 130
C CHECK TO SEE IF FILE IS SELF CONTAINED ON DISK
      IF ( FCB( 5, IFILEX ) .NE. 0 ) GO TO 120
105   CONTINUE
      IF ( IOCODE .NE. 0 .AND. IOCODE .NE. 2 ) GO TO 108
      WRITE ( IWR, 9900 ) IFILEX, FCB( 13, IFILEX), FCB( 14, IFILEX )
9900  FORMAT(///,' DBMMGR ERROR, ATTEMPT TO OPEN FOR READ OR WRITE APP'
     &,'END:'
     &,/,' UNIT-',I4,'  NAME=',2A4,' WHICH DOES NOT EXIST.')
C      CALL DBMDMP
      CALL DSMSG ( 777 )
      CALL MESAGE ( -61, 0, 0 )
108   CONTINUE
C NEW FILE NAME FOR IFILEX, RELEASE ANY PREVIOUSLY ALLOCATED BLOCKS
      IF ( FCB(  9, IFILEX ) .NE. 0 ) CALL DBMREL
C CREATE FILE ENTRY IN FCB
      DO 110 I = 3,11
      IF ( I .EQ. 7 ) GO TO 110
      FCB(  I, IFILEX ) = 0
110   CONTINUE
      FCB(  4, IFILEX ) = 1
      NBLOCK            = 1
115   CONTINUE
C ALLOCATE FIRST BLOCK
      CALL DBMALB ( LENBUF, NEXBLK )
      IF ( NEXBLK .LE. 0 ) GO TO 120
      FCB(  9, IFILEX ) = NEXBLK
      FCB( 10, IFILEX ) = NEXBLK
      FCB( 11, IFILEX ) = NEXBLK
C INITIALIZE PREVIOUS, NEXT, LENGTH AND BLOCK NUMBER FOR ALLOCATED BLK
      MEM( NEXBLK   ) = 0
      MEM( NEXBLK+1 ) = 0
      MEM( NEXBLK+2 ) = LENBUF
      MEM( NEXBLK+3 ) = 1
      FCB(  2, IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
      CALL DBMMOV ( INDBAS, NEXBLK+4, 4)
      GO TO 7000
C NO MORE SPACE WITHIN IN-MEMORY DATA BASE, USE I/O
120   CALL DBMIO ( OPCODE )
      GO TO 7777
C FILE EXISTS IN IN-MEMORY DATA BASE
130   CONTINUE
      IF ( IOCODE .EQ. 0 ) GO TO 150
      IF ( IOCODE .EQ. 1 ) GO TO 160
      IF ( IOCODE .EQ. 2 ) GO TO 170
      IF ( IOCODE .EQ. 3 ) GO TO 180
C FILE IS OPENED FOR READ WITH REWIND
150   CONTINUE
      NEXBLK = FCB( 9, IFILEX )
      IF ( NEXBLK .GT. 0 ) GO TO 155
      WRITE ( IWR, 9910 ) IFILEX
9910  FORMAT(///,' DBMMGR ERROR, ATTEMPT TO READ FILE WITH NO BLOCKS'
     &        /,' UNIT=',I4)
C      CALL DBMDMP
      CALL DSMSG ( 777 )
      CALL MESAGE( -61, 0, 0 )
155   CONTINUE
      FCB( 11, IFILEX ) = NEXBLK
      FCB(  4, IFILEX ) = 1
      NBLOCK            = 1
      FCB(  2, IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
      CALL DBMMOV ( INDBAS, NEXBLK+4, 3 )
      GO TO 7000
C FILE IS OPENED FOR WRITE WITH REWIND
160   CONTINUE
      GO TO 105
C FILE IS OPENED FOR READ WITHOUT REWIND
170   CONTINUE
      NEXBLK = FCB(  10, IFILEX )
      LASTIB = MEM( NEXBLK+3 )
      NBLOCK = FCB( 4, IFILEX )
      IF ( FCB( 4, IFILEX ) .GT. LASTIB ) GO TO 120
      IF ( FCB( 4, IFILEX ) .EQ. 1 ) GO TO 150
      NEXBLK = FCB( 11, IFILEX )
      IBLK1 = FCB(  4, IFILEX )
      IBLK2 = MEM( NEXBLK+3 )
      IBLK3 = MEM( NEXBLK+7 )
      FCB(  2, IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
C CHECK THAT CURRENT BLOCK NUMBER MATCHES BLOCK NO. IN IN-MEM BLK
      IF ( IBLK1 .EQ. IBLK2 .AND. IBLK1 .EQ. IBLK3 ) GO TO 7000
      GO TO 190
C FILE IS OPENED FOR WRITE WITHOUT REWIND
180   CONTINUE
      NEXBLK = FCB(  10, IFILEX )
      LASTIB = MEM( NEXBLK+3 )
      IF ( FCB( 4, IFILEX ) .GT. LASTIB ) GO TO 120
C======      IF ( FCB( 4, IFILEX ) .EQ. 1      ) GO TO 160
      NEXBLK = FCB( 11, IFILEX )
C IGNORE ANY PREVIOUSLY WRITTEN BLOCKS FOR THIS FILE
      FCB(  5, IFILEX ) = 0
      FCB(  6, IFILEX ) = 0
      IBLK1  = FCB(  4, IFILEX )
      IBLK2  = MEM( NEXBLK+3 )
      IBLK3  = MEM( NEXBLK+7 )
      FCB(  2, IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
C CHECK THAT CURRENT BLOCK NUMBER MATCHES BLOCK NO. IN IN-MEM BLK
      IF ( IBLK1 .EQ. IBLK2 .AND. IBLK1 .EQ. IBLK3 ) GO TO 7000
190   CONTINUE
      WRITE ( IWR, 9911 ) IFILEX, IBLK1, IBLK2, IBLK3
9911  FORMAT(///' BLOCK NUMBERS INCONSISTANT ON OPEN IN DBMMGR'
     &,/,' UNIT =',I4
     &,/,' BLOCK NUMBER EXPECTED (IN FCB)  =',I8
     &,/,' BLOCK NUMBER IN IN-MEMORY BLOCK =',I8
     &,/,' BLOCK NUMBER IN BUFFER          =',I8 )
C      CALL DBMDMP
      CALL DBMFDP
      CALL DSMSG ( 777 )
      CALL MESAGE ( -61, 0, 0 )
C****************
C CLOSE CODE ********************************************************
C****************
200   CONTINUE
C CHECK TO SEE IF FILE HAS IN-MEMORY BLOCKS
      IF ( FCB(  9, IFILEX ) .NE. 0 ) GO TO 220
210   CALL DBMIO ( OPCODE )
      GO TO 7000
220   CONTINUE
CWKBDB SPR94012 10/94
C      IF ( IOCODE .NE. 1 ) GO TO 225
CC CLOSE FILE WITH REWIND
C      FCB( 11, IFILEX ) = FCB(  9, IFILEX )
C      FCB(  4, IFILEX ) = 1
C      IF ( FCB( 5, IFILEX ) .NE. 0 ) GO TO 210
CWKBDE SPR94012 10/94
C IF FILE IS OPENED FOR READ THAN GO COMPUTE STATISTICS
225   IF ( FCB(  1, IFILEX ) .EQ. 0.OR.
     &     FCB(  1, IFILEX ) .EQ. 2 ) GO TO 240
      IF ( FCB( 15, IFILEX ) .NE. 0 ) GO TO 240
C FILE OPENED FOR WRITE AND FILE NOT SPILLED TO DISK, THEN
C RELEASE LAST ALLOCATED BLOCK, BECAUSE IT WAS NOT USED
      NEXBLK = FCB( 11, IFILEX )
C RESET LAST BLOCK POINTER, GET PREVIOUS BLOCK ALLOCATED
CWKBNB SPR94012 10/94
228   IBLOCK = MEM( NEXBLK+3 )
C CHECK IF LAST BLOCK NOT USED, THERE COULD HAVE BEEN A BACKPSPACE BACK
C TO A PREVIOUS USED BLOCK (CAUSED BY CLOSE CALLING DSBRC1 TO BACKSPACE
C OVER AN EOF THAT WAS AT THE END OF A PREVIOUS BLOCK).
      IF ( IBLOCK .GT. NBLOCK ) GO TO 230
      NEXBLK = MEM( NEXBLK+1 )
      IF ( NEXBLK .EQ. 0 ) GO TO 240
      GO TO 228
230   CONTINUE
CWKBNE SPR94012 10/94
      INDBLK            = MEM( NEXBLK )
      FCB( 10, IFILEX ) = INDBLK
      FCB( 11, IFILEX ) = INDBLK
      FCB(  4, IFILEX ) = MEM( INDBLK+3 )
      FCB(  2, IFILEX ) = LOCFX( MEM( INDBLK+4 ) ) - IBASBF + 1
      CALL DBMRLB( NEXBLK )
CWKBNB SPR94012 10/94
240   IF ( IOCODE .NE. 1 ) GO TO 245
C CLOSE FILE WITH REWIND
      FCB( 11, IFILEX ) = FCB(  9, IFILEX )
      FCB(  4, IFILEX ) = 1
CWKBNE SPR94012 10/94
CWKBR  SPR94012 10/94
C240   IF ( FCB( 5, IFILEX ) .NE. 0 ) CALL DBMIO ( OPCODE )
245   IF ( FCB( 5, IFILEX ) .NE. 0 ) CALL DBMIO ( OPCODE )
      IF ( FCB( 5, IFILEX ) .LE. FCB( 6, IFILEX ) ) GO TO 7000
C SPECIAL CASE, LAST BLOCK ALLOCATED WAS FOR DISK BUT NEVER USED, RESET
C INDBAS BACK TO LAST IN-MEMORY BLOCK
      NEXBLK = FCB( 10, IFILEX )
      FCB( 2, IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
      FCB( 5, IFILEX ) = 0
      FCB( 6, IFILEX ) = 0
      FCB(11, IFILEX ) = FCB( 10, IFILEX )
      GO TO 7000
C****************
C REWIND OPCODE *****************************************************
C****************
300   CONTINUE
C IF FILE IS ON EXTERNAL FILE CALL DBMIO DIRECTLY
      IF ( FCB( 9, IFILEX ) .NE. 0 ) GO TO 320
      CALL DBMIO ( OPCODE )
      GO TO 7777
320   CONTINUE
      NEXBLK            = FCB(  9, IFILEX )
      FCB( 11, IFILEX ) = NEXBLK
      FCB(  4, IFILEX ) = 1
C REPLACE BUFFER ADDRESS IN FCB
      FCB( 2,IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
      CALL DBMMOV ( INDBAS, NEXBLK+4, 3 )
      IOCODE = 0
      IF ( FCB( 5, IFILEX ) .NE. 0 ) CALL DBMIO ( 2 )
      GO TO 7000
C****************
C WRITE CODE ********************************************************
C****************
400   CONTINUE
C CHECK TO SEE IF THIS BLOCK IS ON EXTERNAL FILE
      IF ( FCB( 15, IFILEX ) .NE. 0 ) GO TO 450
C CHECK THAT BLOCK NUMBER MATCHES
      NEXBLK = FCB( 11, IFILEX )
      IBLK1  = FCB(  4, IFILEX )
      IBLK2  = MEM( NEXBLK+3 )
      IBLK3  = MEM( NEXBLK+7 )
      IF ( IBLK1 .EQ. IBLK2 .AND. IBLK1 .EQ. IBLK3 ) GO TO 410
      WRITE ( IWR, 9940 ) IFILEX, IBLK1, IBLK2, IBLK3
9940  FORMAT(///' BLOCK NUMBERS INCONSISTANT ON WRITE IN DBMMGR'
     &,/,' UNIT = ',I4
     &,/,' BLOCK NUMBER EXPECTED (IN FCB)  =',I8
     &,/,' BLOCK NUMBER IN IN-MEMORY BLOCK =',I8
     &,/,' BLOCK NUMBER IN BUFFER          =',I8 )
C      CALL DBMDMP
      CALL DBMFDP
      CALL DSMSG ( 777 )
      CALL MESAGE ( -61, 0, 0 )
410   CONTINUE
      FCB(  4, IFILEX ) = FCB(  4, IFILEX ) + 1
      NEXBLK = MEM( INDBAS-3 )
      IF ( NEXBLK .EQ. 0 ) GO TO 420
C USE EXISTING BLOCK ALREADY ALLOCATED FROM PREVIOUS OPEN FOR WRITE
      FCB( 11, IFILEX) = NEXBLK
      FCB( 2,IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
      CALL DBMMOV ( INDBAS, NEXBLK+4, 4 )
      GO TO 7000
420   CONTINUE
      CALL DBMALB ( LENBUF, NEXBLK )
      IF ( NEXBLK .LE. 0 ) GO TO 440
C ANOTHER BLOCK SUCCESSFULLY ALLOCATED, CONNECT TO CHAIN
      INDBLK          = FCB( 11, IFILEX )
      MEM( INDBLK+1 ) = NEXBLK
      MEM( NEXBLK   ) = INDBLK
      MEM( NEXBLK+1 ) = 0
      MEM( NEXBLK+2 ) = LENBUF
      MEM( NEXBLK+3 ) = FCB(  4, IFILEX )
      FCB( 10, IFILEX) = NEXBLK
      FCB( 11, IFILEX) = NEXBLK
      FCB( 2,IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
      CALL DBMMOV ( INDBAS, NEXBLK+4, 4 )
      GO TO 7000
C NO MORE SPACE IN IN-MEMORY DATA BASE, WRITE DATA TO FILE
440   CONTINUE
C CALL DBMIO TO OPEN EXTERNAL FILE WITH REWIND
      ISAVE  = IOCODE
      ISAVEB = NBLOCK
      IOCODE = 1
      NBLOCK = FCB( 4, IFILEX )
      IPRBLK = INDBAS
C RESET BUFFER ADDRESS TO BUFFER IN USER'S OPEN CORE
      FCB( 2,IFILEX ) = FCB( 12, IFILEX )
      INDBAS = FCB( 2, IFILEX )
      CALL DBMIO ( 1 )
      IOCODE   = ISAVE
      NBLOCK   = ISAVEB
C      WRITE(6,88771)(MEM(IPRBLK+K),K=-4,4)
88771 FORMAT(' MEMPRBLK=',9(1X,Z8))
C      WRITE(6,88772)(MEM(INDBAS+K),K=-4,4)
88772 FORMAT(' MEMINDBAS=',9(1X,Z8))
C      PRINT *,' IFILEX,NBLOCK,IPRBLK,INDBAS=',IFILEX,NBLOCK,
C     & IPRBLK,INDBAS
      CALL DBMMOV ( IPRBLK, INDBAS, 4 )
C      PRINT *,' MEM(IPRBLK=',MEM(IPRBLK)
C      WRITE(6,88771)(MEM(IPRBLK+K),K=-4,4)
C      WRITE(6,88772)(MEM(INDBAS+K),K=-4,4)
      GO TO 7000
450   CONTINUE
      CALL DBMIO ( OPCODE )
      GO TO 7777
C****************
C READ CODE *********************************************************
C****************
500   CONTINUE
      IF ( FCB( 5, IFILEX ) .EQ. 0 ) GO TO 505
      IF ( FCB( 4, IFILEX ) .GE. ( FCB( 5, IFILEX ) - 1 ) ) GO TO 540
505   FCB( 4, IFILEX ) = FCB( 4, IFILEX ) + 1
      NEXBLK = MEM( INDBAS-3 )
      IF ( NEXBLK .GT. 0 ) GO TO 510
      WRITE ( IWR, 9950 ) FCB( 4, IFILEX ), IFILEX
9950  FORMAT(///,' ERROR IN DBMMGR DURING READ',/,' EXPECTED ANOTHER '
     &,' IN-MEMORY BLOCK FOR BLOCK=',I8,' UNIT=',I3)
C      CALL DBMDMP
      CALL DBMFDP
      CALL DSMSG ( 777 )
      CALL MESAGE ( -61, 0, 0 )
510   FCB(  2, IFILEX ) = LOCFX( MEM( NEXBLK+4 ) ) - IBASBF + 1
      FCB( 11, IFILEX ) = NEXBLK
      CALL DBMMOV ( INDBAS, NEXBLK+4, 3 )
      IBLK1 = FCB( 4, IFILEX)
      IBLK2 = MEM( NEXBLK+3 )
      IBLK3 = MEM( NEXBLK+7 )
      IF ( IBLK1 .EQ. IBLK2 .AND. IBLK1 .EQ. IBLK3 ) GO TO 7000
      WRITE ( IWR, 9951 ) IFILEX, IBLK1, IBLK2, IBLK3
9951  FORMAT(///' BLOCK NUMBERS INCONSISTANT ON READ IN DBMMGR'
     &,/,' UNIT =',I4
     &,/,' BLOCK NUMBER  (IN FCB)          =',I8
     &,/,' BLOCK NUMBER IN IN-MEMORY BLOCK =',I8
     &,/,' BLOCK NUMBER IN BUFFER          =',I8 )
C      CALL DBMDMP
      CALL DBMFDP
      CALL DSMSG ( 777 )
      CALL MESAGE ( -61, 0, 0 )
C BLOCK IS NOT IN MEMORY, CALL DBMIO
540   CONTINUE
      IF ( FCB( 15, IFILEX ) .NE. 0 ) GO TO 550
      ISAVE  = IOCODE
      ISAVEB = NBLOCK
      IOCODE = 0
      NBLOCK = FCB( 4, IFILEX ) + 1
      IPRBLK = INDBAS
      INDBAS = FCB( 12, IFILEX )
      FCB( 2, IFILEX ) = INDBAS
      CALL DBMIO ( 1 )
      IOCODE = ISAVE
      NBLOCK = ISAVEB
      CALL DBMMOV ( IPRBLK, INDBAS, 3 )
      GO TO 7777
550   CONTINUE
      IF ( FCB( 4, IFILEX ) .GT. FCB( 6, IFILEX ) ) GO TO 570
      INDBAS = FCB( 12, IFILEX )
      FCB( 2, IFILEX ) = INDBAS
      CALL DBMIO ( OPCODE )
      GO TO 7777
570   CONTINUE
      WRITE ( IWR, 9052 ) IFILEX
9052  FORMAT(///,' DBMMGR ERROR, ATTEMPT TO READ BEYOND EOF'
     &,/' UNIT=',I5)
C      CALL DBMDMP
      CALL DBMFDP
      CALL DSMSG ( 777 )
      CALL MESAGE ( -61, 0, 0 )
C****************
C POSITION CODE *****************************************************
C****************
600   CONTINUE
      IF ( FCB( 5, IFILEX ) .EQ. 0 ) GO TO 605
      IF ( NBLOCK .GE. FCB( 5, IFILEX ) ) GO TO 690
605   CONTINUE
C BLOCK IS IN THE IN-MEMORY DATA BASE, WALK CHAIN TO CORRECT BLOCK
      IOFF    = 1
      NBLK    = NBLOCK - 1
      NEXBLK  = FCB( 9, IFILEX )
      IF ( NBLOCK .EQ. 1 ) GO TO 670
      ICNDEX = FCB( 11, IFILEX )
      IF ( ICNDEX .EQ. 0 ) GO TO 610
      NEXBLK  = ICNDEX
      ICBLK   = MEM( ICNDEX+3 )
      IF ( ICBLK .EQ. NBLOCK ) GO TO 670
      IDIFF   = NBLOCK - ICBLK
      NBLK    = IABS( IDIFF )
      IF ( IDIFF .LT. 0 ) IOFF = 0
610   CONTINUE
      DO 620 I = 1, NBLK
      NEXBLK  = MEM( NEXBLK+IOFF )
620   CONTINUE
C SET DIRECTORY ENTRIES FOR THE POSITIONED BLOCK
670   FCB( 11, IFILEX ) = NEXBLK
      FCB(  4, IFILEX ) = NBLOCK
      FCB(  2, IFILEX ) = LOCFX( MEM(NEXBLK+4) ) - IBASBF + 1
      CALL DBMMOV ( INDBAS, NEXBLK+4, 3 )
      GO TO 7000
690   CONTINUE
      IF ( FCB( 15, IFILEX ) .NE. 0 ) GO TO 695
      ISAVE  = IOCODE
      IOCODE = 0
      IPRBLK = INDBAS
      INDBAS = FCB( 12, IFILEX )
      FCB( 2, IFILEX ) = INDBAS
      FCB( 4, IFILEX ) = NBLOCK
      CALL DBMIO( 1 )
      IOCODE = ISAVE
      CALL DBMMOV ( IPRBLK, INDBAS, 3 )
      GO TO 7777
695   CONTINUE
      FCB( 4, IFILEX ) = NBLOCK
      INDBAS = FCB( 12, IFILEX )
      FCB( 2, IFILEX ) = INDBAS
      CALL DBMIO ( OPCODE )
      GO TO 7777
C****************
C DELETE CODE *******************************************************
C****************
700   CONTINUE
      IF ( FCB( 9, IFILEX ) .EQ. 0 ) GO TO 710
      CALL DBMREL
710   CONTINUE
      CALL DBMIO ( 7 )
      DO 720 K = 1,15
      IF ( K .EQ. 7 ) GO TO 720
      FCB( K, IFILEX ) = 0
720   CONTINUE
      GO TO 7777
C****************
C WRTBLK CODE *******************************************************
C****************
C SPECIAL ENTRY FOR SUBSTRUCTURING, MOVE DATA FROM OPENCORE BUFFER
C CALLED BY WRTBLK OF GINO
800   CONTINUE
      IF ( FCB( 15, IFILEX ) .EQ. 0 ) GO TO 810
C ORIGINAL BUFFER IS BEING USED BY GINO, JUST RETURN
      GO TO 7777
810   IND1 = FCB(  2, IFILEX )
      IND2 = FCB( 12, IFILEX )
      IND1 = IND1 + 2
      IND2 = IND2 + 2
C      PRINT *,' DBMMGR,WRTBLK,IND1,IND2,NBUFF3=',IND1,IND2,NBUFF3
C      PRINT *,' DBMMGR,WRTBLK,INDBAS=',INDBAS
C      WRITE(6,44771)(FCB(K,IFILEX),K=1,15)
C      WRITE(6,44772)(MEM(IND2+K),K=1,8)
44772 FORMAT(' DBMMGR,BUFFER,IND2=',8(1X,Z8))
      DO 820 I = 1, NBUFF3
      MEM( IND1+I ) = MEM( IND2+I )
820   CONTINUE
      GO TO 7000
C****************
C RDBLK  CODE *******************************************************
C****************
C SPECIAL ENTRY FOR SUBSTRUCTURING, MOVE DATA TO ORIGINAL BUFFER IF
C THE IN-MEMORY DATA BASE IS BEING USED
C CALLED BY RDBLK
900   CONTINUE
      IF ( FCB( 15, IFILEX ) .EQ. 0 ) GO TO 910
C ORIGINAL BUFFER IS BEING USED, JUST RETURN
      GO TO 7777
910   IND1 = FCB(  2, IFILEX )
      IND2 = FCB( 12, IFILEX )
      IND1 = IND1 + 2
      IND2 = IND2 + 2
C      PRINT *,' DBMMGR,RDBLK,IND1,IND2,NBUFF3=',IND1,IND2,NBUFF3
C      PRINT *,' DBMMGR,RDBLK,INDBAS=',INDBAS
C      WRITE(6,44771)(FCB(K,IFILEX),K=1,15)
C      WRITE(6,44773)(MEM(IND1+K),K=1,8)
44773 FORMAT(' DBMMGR,BUFFER,IND1=',8(1X,Z8))
      DO 920 I = 1, NBUFF3
      MEM( IND2+I ) = MEM( IND1+I )
920   CONTINUE
      GO TO 7000
7000  CONTINUE
C SET INDBAS TO POINT TO CURRENT BUFFER
      INDBAS = FCB( 2, IFILEX )
C      IF ( NAME .NE. 307 ) GO TO 7777
C      IF ( IFILEX .NE. 48 ) GO TO 7777
C      PRINT *,' DBMMGR RETURNING,IFILEX,INDBAS=',IFILEX,INDBAS
C      PRINT *,' DBMMGR RETURNING,INDCLR,INDCBP=',INDCLR,INDCBP
C      write(6,40648)(mem(kb),kb=indbas-4,indbas+8)
40648 format(' returned buffer=',/,10(4(1x,z8),/))
C      WRITE(6,44771)(FCB(K,IFILEX),K=1,15)
C      CALL DBMFDP
44771 FORMAT(' returned FCB=',/,2(5I8,/),2I8,4X,2A4,4X,I8)
7777  CONTINUE
      RETURN
      END
