      SUBROUTINE CALPOS (ICOOR,JCOOR,MESH,BLKNUM,XCELL,YCELL,ERROR)
C*********************************************************************
C
C   NAME- CALPOS
C
C   LANGUAGE- FORTRAN 77     TYPE- SUBROUTINE      COMPUTER- CRAY     
C
C   VERSION- 1.0  DATE- 08/22/91   PROGRAMMER- JEFFREY R. JONES (SMSRC)
C   VERSION- 3.0  DATE- 05/21/96   PROGRAMMER- ALEX POZDNYAK (FDC)      
C     FOR REHOSTING TO THE CRAY, CHANGED ALL I*4 DECLARATIONS TO
C     INTEGER, ALL R*4 TO REAL.
C
C   DESCRIPTION- THIS ROUTINE CONVERTS I,J COORDINATES TO A BLOCK AND
C                CELL COORDINATES CONVENTION. THE I-COORDINATE
C                CORRESPONDS TO THE COLUMN AND THE J-COORDINATE TO THE
C                ROW. THE BLOCK'S ROW AND COLUMN ARE COMPUTED FIRST BY
C                SUBTRACTING 1 FROM THE CORRESPONDING I-COORDINATE OR
C                J-COORDINATE,DIVIDING BY THE NUMBER OF CELLS ON A SIDE
C                OF A BLOCK (64), ADDING ONE AND MAKING THE RESULT AN
C                INTEGER. THE CELL COORDINATES ARE COMPUTED BY TAKING
C                THE REMAINDER OF THESE CALCULATIONS AND MULTIPLYING BY
C                THE NUMBER OF CELLS ON A SIDE OF A BLOCK. BEFORE
C                THE BLOCK NUMBER IS COMPUTED, THE ROW AND COLUMN
C                ARE CHECKED TO INSURE THEY LIE ON THE GRID.
C                IF NOT, CALPO$ IS CALLED TO WRITE A MESSAGE TO THE
C                KIDS MESSAGE LOG AND SET THE ERROR RETURN CODE.
C                THE COLUMN IS THEN ADDED TO THE NUMBER OF BLOCKS ON
C                A SIDE OF THE GRID TIMES THE ROW MINUS, ONE,TO GIVE
C                US THE BLOCK NUMBER. THE BLOCK NUMBER IS THEN ADJUSTED
C                BY ADJBLK TO REMOVE THE BLOCKS THAT DO NOT CONTAIN THE
C                MAP.
C
C                THERE ARE THREE ADDITIONAL ERRORS THAT ARE CHECKED FOR
C                IN THIS ROUTINE. WMESHC IS A CONSTANT IN THE INCLUDE
C                FILE MAPCST AND IS DEFINED AS THE NUMBER OF CELLS IN A
C                WHOLE MESH GRID. THIS VALUE MUST BE GREATER THAN OR
C                EQUAL TO 0. IT IS CURRENTLY SET TO 64. THE MESH FACTOR
C                AND THE CONSTANT MAPCST:ADJFAC MUST HAVE VALUES
C                GREATER THAN 0. IF ANY OF THESE CONDITIONS ARE NOT MET,
C                CALPO$ IS CALLED TO WRITE A MESSAGE TO THE KIDS
C                MESSAGE LOG AND SET THE ERROR RETURN CODE.
C
C
C   CALLING SEQUENCE PARAMETERS-
C
C      ARGUMENTS  TYPE  I/O             DESCRIPTION
C      ---------  ----  --- -----------------------------------
C      ICOOR      REAL   I  THE I COORDINATE OF THE LOCATION.
C      JCOOR      REAL   I  THE J COORDINATE OF THE LOCATION.
C      MESH       REAL   I  THE MESH FACTOR OF THE MAP.
C      BLKNUM     INT    O  THE BLOCK NUMBER OF THE LOCATION.
C      XCELL      REAL   O  THE CELL'S X COORDINATE IN THE BLOCK.
C      YCELL      REAL   O  THE CELL'S Y COORDINATE IN THE BLOCK.
C      ERROR      INT   I/O THE ERROR RETURN CODE.
C                               0 - SUCCESSFUL COMPLETION.
C                              99 - FATAL ERROR.
C
C   COMMON AREA PARAMETERS-
C
      INCLUDE 'MAPCST'
C
C   LOCAL PARAMETERS-
C
C      ARGUMENTS  TYPE  I/O             DESCRIPTION
C      ---------  ----  ---  ----------------------------------
C      BLKCOL     INT   N/A  THE COLUMN THAT THE BLOCK IS IN.
C      BLKROW     INT   N/A  THE ROW THAT THE BLOCK IS IN.
C      TOTBLK     INT   N/A  THE NUMBER OF BLOCKS ON A SIDE.  THIS
C                            VALUE IS EQUAL TO THE INVERSE OF THE MESH
C                            FACTOR.
C      DELBLK     INT   N/A  HOLDS THE NUMBER OF ROWS THAT HAVE BLOCKS
C                            THAT MAY BE DELETED IN ONE GROUP. THERE ARE
C                            TWO GROUPS, ONE AT THE BOTTOM OF THE BLOCK
C                            AND THE OTHER AT THE TOP.
C      LSTBLK     INT   N/A  HOLDS THE ROW NUMBER OF THE FIRST ROW IN
C                            THE GROUP THAT HAS HIGHER BLOCK NUMBERS
C                            THAT CONTAINS BLOCKS THAT MAY BE DELETED.
C
C   SUBPROGRAMS CALLED- ADJBLK, CALPO$
C
C   INTRINSIC FUNCTIONS-
C
      INTRINSIC AMOD, FLOAT, INT, MOD
C
C   EXIT STATES-
C      99 - FATAL ERROR: AN INVALID VALUE WAS FOUND, POSSIBLY CAUSED BY
C                        AN ERRONEOUS VALUE IN THE INCLUDE MAPCST.
C
C*********************************************************************
C
      REAL     ICOOR, JCOOR, XCELL, YCELL, MESH
      INTEGER  BLKNUM, ERROR
C
      INTEGER  BLKCOL, BLKROW, TOTBLK, DELBLK, LSTBLK
C
C     INITIALIZE OUTPUT VARIABLES
C
      BLKNUM = 0
      XCELL = 0.0
      YCELL = 0.0
C
C     INITIALIZE LOCAL VARIABLES.
C
      BLKCOL = 0
      BLKROW = 0
      TOTBLK = 0
      DELBLK = 0
      LSTBLK = 0
C
C     MAKE SURE MESH FACTOR IS DEFINED CORRECTLY.
C
      IF (MESH .LE. 0.0) THEN
C
C         WRITE ERROR MESSAGE.
C
          CALL CALPO$ (710, 0, 0, MESH, ERROR)
          GOTO 10
C
      ELSE
C
C         MESH FACTOR GOOD.
C         COMPUTE TOTAL NUMBER OF BLOCKS ON A SIDE OF THE GRID.
C
          TOTBLK = INT (1 / MESH)
          DELBLK = TOTBLK / ADJFAC
          LSTBLK = TOTBLK - DELBLK
C
      END IF
C
C     MAKE SURE NUMBER OF CELLS IN A WHOLE MESH GRID IS DEFINED
C     CORRECTLY
C
      IF (WMESHC .LE. 0) THEN
C
C          NUMBER OF CELLS IN A WHOLE MESH GRID IS DEFINED AS LESS THAN
C          OR EQUAL TO ZERO. HANDLE ERROR.
C
           CALL CALPO$ (720, WMESHC, 0, 0.0, ERROR)
           GOTO 10
C
      ELSE
C
C          NUMBER WHOLE MESH GRID CELLS DEFINED CORRECTLY
C          CALCULATE BLOCK COLUMN AND ROW
C
           BLKCOL = ((ICOOR - 1.0) / WMESHC) + 1
           BLKROW = ((JCOOR - 1.0) / WMESHC) + 1
C
C          CALCULATE THE CELL'S LOCATION IN THE BLOCK.
C
C          THE ICOOR WILL BE USED AS THE COLUMN INDEX OR YCELL
C          AND THE JCOOR WILL BE USED AS THE ROW INDEX OR XCELL.
C
           XCELL = AMOD (JCOOR, FLOAT(WMESHC))
           IF ((XCELL .GE. 0.0) .AND. (XCELL .LT. 1.0)) XCELL = WMESHC
           YCELL = AMOD (ICOOR, FLOAT(WMESHC))
           IF ((YCELL .GE. 0.0) .AND. (YCELL .LT. 1.0)) YCELL = WMESHC
C
C
C          MAKE SURE ADJUSTMENT FACTOR IS DEFINED CORRECTLY.
C
           IF (ADJFAC .LE. 0) THEN
C
C              ADJUSTMENT FACTOR IS INVALID; HANDLE ERROR.
C
               CALL CALPO$(730, ADJFAC, 0, 0.0, ERROR)
               GOTO 10
C
           ELSE
C
C              MAKE SURE BLOCK IS ON MAP.
C
C              TEST 1 - IS BLOCK TO THE LEFT SIDE OF GRID.
C              TEST 2 - IS BLOCK TO THE RIGHT SIDE OF GRID.
C              TEST 3 - IS BLOCK ABOVE GRID.
C              TEST 4 - IS BLOCK BELOW GRID.
C              TEST 5 - DOES GRID HAVE ANY DELETABLE BLOCKS AND IF SO,
C                       IS BLOCK ON GRID IN THE CORNERS BUT OFF OF THE
C                       MAP.
C
               IF ((BLKCOL .LT. 1) .OR.
     2             (BLKCOL .GT. TOTBLK) .OR.
     3             (BLKROW .LT. 1) .OR.
     4             (BLKROW .GT. TOTBLK) .OR.
     5             ((TOTBLK .GE. ADJFAC) .AND.
     5              ((BLKCOL .LE. DELBLK).OR.
     5               (BLKCOL .GT. LSTBLK)) .AND.
     5              ((BLKROW .LE. DELBLK) .OR.
     5               (BLKROW .GT. LSTBLK)))) THEN
C
C                      BLOCK IS OFF OF THE MAP.  HANDLE ERROR.
C
                       CALL CALPO$ (740, BLKROW, BLKCOL, 0.0,ERROR)
                       GOTO 10
C
               ELSE
C
C                  BLOCK IS ON THE MAP.
C                  COMPUTE BLOCK NUMBER.
C
                   BLKNUM = ((BLKROW - 1) * TOTBLK) + BLKCOL
C
C                  IF MESH SIZE IS LESS THAN OR EQUAL TO 1/8 THEN
C                  REMOVE UNUSED BLOCKS FROM BLKNUM.
C
                   IF (TOTBLK .GE. ADJFAC) THEN
C
C                      REMOVE UNUSED BLOCKS
C
                     CALL ADJBLK(BLKNUM,BLKROW,TOTBLK,DELBLK,ERROR)
C
                   END IF
C
               END IF
C
           END IF
C
      END IF
  10  RETURN
C
      END
C**********************************************************************
      SUBROUTINE CALPO$(MSGCOD,ROWWMB,COL,MESH,STAT)
C**********************************************************************
C   NAME- CALPO$
C
C   LANGUAGE- FORTRAN 77     TYPE- SUBROUTINE      COMPUTER- CRAY     
C
C   VERSION- 1.0  DATE- 05/07/91   PROGRAMMER- JEFFREY R. JONES (SMSRC)
C   VERSION- 3.0  DATE- 10/07/97   PROGRAMMER- LEAH WILSON (HSTX)
C
C   FUNCTION- THIS SUBROUTINE IS THE ERROR HANDLING ROUTINE FOR
C             ROUTINE CALPOS.
C   VERSION- 3.0 WRITE ERROR MESSAGES TO THE KIDS FILE.  INCLUDE /SPGUNT/.
C
C   FILES-
C     DSN                    I/O   UNIT    FUNCTIONAL DESCRIPTION
C     ---                    ---  ------   -----------------------
C     ...KIDS                 O    KUNIT   KRAY INTERACTIVE DOCUMENTATION
C
C   CALLING SEQUENCE PARAMETERS-
C
C     VARIABLE               TYPE  I/O  FUNCTION
C     --------               ----  ---  --------
C     MSGCOD                  INT   I   MESSAGE CODE USED TO
C                                       IDENTITIFY THE ERROR.
C
C     ROWWMB                  INT   I   DEPENDING ON THE ERROR, THIS
C                                       WILL HOLD THE BLOCKS ROW OR
C                                       THE NUMBER OF WHOLE MESH
C                                       BLOCKS IN THE GRID.
C
C     COL                     INT   I   DEPENDING ON THE ERROR, THIS
C                                       WILL HOLD THE BLOCKS COLUMN.
C
C     MESH                    REAL      DEPENDING ON THE ERROR, THIS
C                                       WILL HOLD THE MESH FACTOR.
C
C     STAT                    INT   O   STATUS CODE IF AN ERROR
C                                       OCCURS DURING I/O
C
C   COMMON AREA PARAMETERS-
      INCLUDE 'SPGUNT'
      INCLUDE 'ERPARM'
      INCLUDE 'ERINFO'
C
C   LOCAL PARAMETERS-
C     VARIABLE                TYPE    FUNCTION
C     --------                ----    --------
C     KMSG                   CH*100   KIDS MESSAGE BUFFER
C     C4TEMP                  CH*4    HOLDING BUFFER FOR WRITING TO KIDS
C     C7TEMP                  CH*7    HOLDING BUFFER FOR WRITING TO KIDS
C
C   SUBROUTINES CALLED- KIDS
C
C**********************************************************************
C
      INTEGER   MSGCOD,ROWWMB, COL, STAT
      REAL      MESH
      CHARACTER*4   C4TEMP
      CHARACTER*7   C7TEMP
      CHARACTER*100 KMSG
C
C  SET ERINFO:SUBNAM
C
      SUBNAM = 'SPGDVR'
C
C  CHECK MESSAGE CODE AND WRITE ERROR MESSAGE
C
      IF (MSGCOD .EQ. 710) THEN
        KMSG=' * FATAL ERROR * Mesh fact <= 0.  Mesh =         '
        WRITE(C7TEMP,'(F7.3)') MESH
        KMSG(42:48) = C7TEMP
        STAT = 99
        CALL KIDS(KUNIT,SUBNAM,0,KMSG,0)
C
      ELSE IF (MSGCOD .EQ. 720) THEN
        KMSG(1:50)=' * FATAL ERROR * # cells in a whole mesh grid is d'
        KMSG(51:100)='efined as <= 0.  /MAPCST/:WMESHC =        '
        WRITE(C7TEMP,'(I7)') ROWWMB
        KMSG(86:92) = C7TEMP
        STAT = 99
        CALL KIDS(KUNIT,SUBNAM,0,KMSG,0)
C
      ELSE IF (MSGCOD .EQ. 730) THEN
        KMSG(1:50)=' * FATAL ERROR * The block adjustment factor is de'
        KMSG(51:100)='fined as <= 0.  /MAPCST/:WMESHC =        '
        WRITE(C7TEMP,'(I7)') ROWWMB
        KMSG(85:91) = C7TEMP
        STAT = 99
        CALL KIDS(KUNIT,SUBNAM,0,KMSG,0)
C
      ELSE IF (MSGCOD .EQ. 740) THEN
        KMSG(1:50)=' * FATAL ERROR * The locations block is off the gr'
        KMSG(51:100)='id - blkrow         blkcol        '
        WRITE(C7TEMP,'(I7)') ROWWMB
        KMSG(63:69) = C7TEMP
        WRITE(C7TEMP,'(I7)') COL
        KMSG(78:84) = C7TEMP
        STAT = 99
        CALL KIDS(KUNIT,SUBNAM,0,KMSG,0)
C
      ELSE
C
C NOT A VALID MSGCOD
C
        STAT=0
        KMSG = ' Invalid error message code = '
        WRITE(C4TEMP,'(I4)') MSGCOD
        KMSG(31:34) = C4TEMP
        CALL KIDS(KUNIT,SUBNAM,0,KMSG,0)
      ENDIF
      RETURN
      END
