SUBROUTINE VERI_LSM()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Verify the contents of the LSM file read in.
C-
C-   Inputs  : none
C-   Outputs : none
C-   Controls: none
C-
C-   Created  20-AUG-1990   MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE
C-
C----------------------------------------------------------------------
      IMPLICIT NONE
C----------------------------------------------------------------------
C
C       Global declarations
C
      INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.PARAMS'
      INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.INC'
      INTEGER  PFNUM
      EXTERNAL PFNUM
      INTEGER  READPF
      EXTERNAL READPF
C
C       Local variables
C
      INTEGER ROUTINE_ID
      PARAMETER (ROUTINE_ID = 413)
      INTEGER STATUS
      INTEGER NUM_PARAMETERS
      PARAMETER (NUM_PARAMETERS = 4)
      CHARACTER*33 PROMPTS(NUM_PARAMETERS)
      INTEGER NUM_OPTIONS(NUM_PARAMETERS)
      CHARACTER*3 OPTIONS(10, NUM_PARAMETERS)
      INTEGER OPTS_CHOSEN(NUM_PARAMETERS)
      INTEGER YES, NO
      PARAMETER (YES =1, NO=2)
      INTEGER LIMITS(2)
      CHARACTER*8 NUMBER_STRING
C
      INTEGER I_RANGE, I_PROM_OUTPUT_CUT, I_PROM_TRANSFER_COEFF,
     &  I_TOWER_GEOMETRY
      PARAMETER (I_RANGE = 1, I_PROM_OUTPUT_CUT = 2,
     &  I_PROM_TRANSFER_COEFF = 3, I_TOWER_GEOMETRY = 4)
C
      DATA PROMPTS/ 'Perform range checks',
     &  'Verify quantity PROM_OUTPUT_CUT',
     &  'Verify quant PROM_TRANSFER_COEFF',
     &  'Verify tower geometry sections' /
      DATA NUM_OPTIONS/ 2, 2, 2, 2/
      DATA OPTIONS/ 'Yes', 'No', 8*' ',
     &  'Yes', 'No', 8*' ',
     &  'Yes', 'No', 8*' ',
     &  'Yes', 'No', 8*' ' /
      DATA OPTS_CHOSEN/ YES, YES, YES, NO /
      DATA LIMITS/ 0, 0/
C
C       Check if a file has already been loaded
C
      IF ((.NOT. LSM_FILE_LOADED) .OR. (.NOT. LSO_FILE_LOADED)) THEN
        CALL OUTMSG(' No LSM file loaded. Cannot proceed.')
        CALL PFWAIT()
        GOTO 999
      ENDIF
C
C       Find out which sets of checks to perform
C
      CALL GETOPT(NUM_PARAMETERS, PROMPTS, NUM_OPTIONS, OPTIONS,
     &  OPTS_CHOSEN)
C
C       See if none of the checks were selected
C
      IF ((OPTS_CHOSEN(I_RANGE) .EQ. NO) .AND.
     &  (OPTS_CHOSEN(I_PROM_OUTPUT_CUT) .EQ. NO) .AND.
     &  (OPTS_CHOSEN(I_PROM_TRANSFER_COEFF) .EQ. NO) .AND.
     &  (OPTS_CHOSEN(I_TOWER_GEOMETRY) .EQ. NO)) THEN
        CALL OUTMSG(' No checks selected.')
        CALL PFWAIT()
        GOTO 999
      ENDIF
C
C       Set up the message dump file
C
      CALL GETDIS(1, 'Message file name', 'C', LIMITS, LSM_MESSAGE_FILE)
      IF (PFNUM() .NE. 0) GOTO 999
C
      CALL GTUNIT(ROUTINE_ID, MESSAGE_UNIT_NUM, STATUS)
      IF (STATUS .NE. 0) THEN
        CALL ABORT('Error calling GTUNIT from VERI_LSM')
      ENDIF
      CALL SETDMP(MESSAGE_UNIT_NUM, LSM_MESSAGE_FILE)
C
      CALL OUTMSG(' Performing selected checks.')
      MESSAGE_COUNT = 0
      IF (OPTS_CHOSEN(I_RANGE) .EQ. YES) CALL CHECK_ANALYSIS()
C
      IF ((OPTS_CHOSEN(I_PROM_OUTPUT_CUT) .EQ. YES) .AND.
     &  (OPTS_CHOSEN(I_PROM_TRANSFER_COEFF) .EQ. YES)) THEN
        CALL CHECK_PTCPRC()
      ELSEIF (OPTS_CHOSEN(I_PROM_OUTPUT_CUT) .EQ. YES) THEN
        CALL CHECK_PRC()
      ELSEIF (OPTS_CHOSEN(I_PROM_TRANSFER_COEFF) .EQ. YES) THEN
        CALL CHECK_PTC()
      ENDIF
C
      IF (OPTS_CHOSEN(I_TOWER_GEOMETRY) .EQ. YES) CALL OUTMSG(
     &  ' Verify tower geometry not implemented yet.')
C
C       Close the message file
C
      CALL ENDDMP(MESSAGE_UNIT_NUM)
      CALL RLUNIT(ROUTINE_ID, MESSAGE_UNIT_NUM, STATUS)
      IF (STATUS .NE. 0) THEN
        CALL ABORT('Error calling GTUNIT from VERI_LSM')
      ENDIF
C
      IF (MESSAGE_COUNT .GT. 0) THEN
        CALL PFLABL('VIEW', ' ', ' ', 'BACK')
        WRITE(NUMBER_STRING, 100) MESSAGE_COUNT
  100   FORMAT( I8 )
        CALL OUTMSG(' '// NUMBER_STRING // ' messages generated.')
        CALL OUTMSG(' Do you wish to view them?')
        IF (READPF() .EQ. 1) THEN
          CALL OUTMSG(' Creating subprocess...')
          CALL EVEFIL(LSM_MESSAGE_FILE)
        ENDIF
      ELSE
        CALL OUTMSG(' No warning messages generated.')
        CALL PFWAIT()
      ENDIF
C
  999 RETURN
      END
C
C
C
      SUBROUTINE CHECK_PTCPRC()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Check the contents of both PROM_SLOPE and PROM_CUT.
C-
C-   Inputs  : none
C-   Outputs : none
C-   Controls: none
C-
C-   Created  11-SEP-1990   MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE
C-
C----------------------------------------------------------------------
      IMPLICIT NONE
C----------------------------------------------------------------------
C
C       Global declarations
C
      INCLUDE 'D0$PARAMS:LEVEL1_LOOKUP.PARAMS'
      INCLUDE 'D0$INC:LEVEL1_LOOKUP.INC'
      INCLUDE 'LSMP$SOURCE:LEVEL1_LOOKUP_EXPANSION.INC'
      INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.PARAMS'
      INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.INC'
C
      REAL SAVE_SLOPES(POS_ETA:NEG_ETA,
     &                 ETA_RANGE_MIN:ETA_RANGE_MAX,
     &                 PHI_MIN:PHI_MAX,
     &                 EM_PROM:PY_PROM,
     &                 PAGE_INDEX_MIN:PAGE_INDEX_MAX)
      INTEGER SAVE_CUTS(POS_ETA:NEG_ETA,
     &                  ETA_RANGE_MIN:ETA_RANGE_MAX,
     &                  PHI_MIN:PHI_MAX,
     &                  EM_PROM:PY_PROM,
     &                  PAGE_INDEX_MIN:PAGE_INDEX_MAX)
      INTEGER SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX
      LOGICAL SLOPES_OK, CUTS_OK
      REAL TOLERANCE
      PARAMETER (TOLERANCE = 1.0E-4)
C
C       Save the origional contents of the arrays
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                SAVE_SLOPES(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            PROM_SLOPE( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
                SAVE_CUTS(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            PROM_CUT( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
              END DO
            END DO
          END DO
        END DO
      END DO
C
      CALL COMPILE_ALL_PROM_SLOPES()
      CALL COMPILE_ALL_PROM_CUTS()
C
      SLOPES_OK = .TRUE.
      CUTS_OK = .TRUE.
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                IF (PROM_SLOPE( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
     &            .NE. 0) THEN
                  IF ( ABS((SAVE_SLOPES(SIGN_ETA, MAGN_ETA, PHI, PROM,
     &                    INDEX) - PROM_SLOPE( SIGN_ETA, MAGN_ETA, PHI,
     &                    PROM, INDEX)) / PROM_SLOPE( SIGN_ETA,
     &                    MAGN_ETA, PHI, PROM, INDEX)) .GT. TOLERANCE)
     &            THEN
                    SLOPES_OK = .FALSE.
                    GOTO 1000
                  ENDIF
                ELSEIF ( SAVE_SLOPES(SIGN_ETA, MAGN_ETA, PHI, PROM,
     &            INDEX) .NE. 0) THEN
                  SLOPES_OK = .FALSE.
                  GOTO 1000
                ENDIF
              END DO
            END DO
          END DO
        END DO
      END DO
 1000 CONTINUE
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                IF ( SAVE_CUTS(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
     &            .NE. PROM_CUT( SIGN_ETA, MAGN_ETA, PHI, PROM,
     &                                                   INDEX) ) THEN
                  CUTS_OK = .FALSE.
                  GOTO 2000
                ENDIF
              END DO
            END DO
          END DO
        END DO
      END DO
 2000 CONTINUE
C
      IF (.NOT. SLOPES_OK) THEN
        CALL MESSAGE_OUT(MES_ANALYSIS_GENERAL, I_PTC_INDEX,
     &    'Section PROM_TRANSFER_COEFF does not agree with '//
     &    'other data in file that it is compiled from.')
      ENDIF
      IF (.NOT. CUTS_OK) THEN
        CALL MESSAGE_OUT(MES_ANALYSIS_GENERAL, I_PRC_INDEX,
     &    'Section PROM_OUTPUT_CUT does not agree with '//
     &    'other data in file that it is compiled from.')
      ENDIF
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                PROM_SLOPE(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            SAVE_SLOPES( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
              END DO
            END DO
          END DO
        END DO
      END DO
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                PROM_CUT(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            SAVE_CUTS( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
              END DO
            END DO
          END DO
        END DO
      END DO
C
  999 RETURN
      END
C
C
C
      SUBROUTINE CHECK_PRC()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-
C-   Inputs  :
C-   Outputs :
C-   Controls:
C-
C-   Created  11-SEP-1990   MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE
C-
C----------------------------------------------------------------------
      IMPLICIT NONE
C----------------------------------------------------------------------
C
C       Global declarations
C
      INCLUDE 'D0$PARAMS:LEVEL1_LOOKUP.PARAMS'
      INCLUDE 'D0$INC:LEVEL1_LOOKUP.INC'
      INCLUDE 'LSMP$SOURCE:LEVEL1_LOOKUP_EXPANSION.INC'
      INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.PARAMS'
      INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.INC'
C
C       Local variables
C
      REAL SAVE_SLOPES(POS_ETA:NEG_ETA,
     &                 ETA_RANGE_MIN:ETA_RANGE_MAX,
     &                 PHI_MIN:PHI_MAX,
     &                 EM_PROM:PY_PROM,
     &                 PAGE_INDEX_MIN:PAGE_INDEX_MAX)
      INTEGER SAVE_CUTS(POS_ETA:NEG_ETA,
     &                  ETA_RANGE_MIN:ETA_RANGE_MAX,
     &                  PHI_MIN:PHI_MAX,
     &                  EM_PROM:PY_PROM,
     &                  PAGE_INDEX_MIN:PAGE_INDEX_MAX)
      INTEGER SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX
      LOGICAL CUTS_OK
C
C       Save the cuts and slopes. The slopes must be compiled before the cuts
C       can be compiled. Both must be compiled before
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                SAVE_SLOPES(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            PROM_SLOPE( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
                SAVE_CUTS(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            PROM_CUT( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
              END DO
            END DO
          END DO
        END DO
      END DO
C
      CALL COMPILE_ALL_PROM_SLOPES()
      CALL COMPILE_ALL_PROM_CUTS()
C
      CUTS_OK = .TRUE.
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                IF ( SAVE_CUTS(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
     &            .NE. PROM_CUT( SIGN_ETA, MAGN_ETA, PHI, PROM,
     &                                                   INDEX) ) THEN
                  CUTS_OK = .FALSE.
                  GOTO 2000
                ENDIF
              END DO
            END DO
          END DO
        END DO
      END DO
 2000 CONTINUE
C
      IF (.NOT. CUTS_OK) THEN
        CALL MESSAGE_OUT(MES_ANALYSIS_GENERAL, I_PRC_INDEX,
     &    'Section PROM_OUTPUT_CUT does not agree with '//
     &    'other data in file that it is compiled from.')
      ENDIF
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                PROM_SLOPE(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            SAVE_SLOPES( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
              END DO
            END DO
          END DO
        END DO
      END DO
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                PROM_CUT(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            SAVE_CUTS( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
              END DO
            END DO
          END DO
        END DO
      END DO
C

  999 RETURN
      END
C
C
C
      SUBROUTINE CHECK_PTC()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-
C-   Inputs  :
C-   Outputs :
C-   Controls:
C-
C-   Created  11-SEP-1990   MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE
C-
C----------------------------------------------------------------------
      IMPLICIT NONE
C----------------------------------------------------------------------
C
C       Global declarations
C
      INCLUDE 'D0$PARAMS:LEVEL1_LOOKUP.PARAMS'
      INCLUDE 'D0$INC:LEVEL1_LOOKUP.INC'
      INCLUDE 'LSMP$SOURCE:LEVEL1_LOOKUP_EXPANSION.INC'
      INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.PARAMS'
      INCLUDE 'LSMP$SOURCE:PARSE_TOKENS.INC'
C
C       Local declarations
C
      REAL SAVE_SLOPES(POS_ETA:NEG_ETA,
     &                 ETA_RANGE_MIN:ETA_RANGE_MAX,
     &                 PHI_MIN:PHI_MAX,
     &                 EM_PROM:PY_PROM,
     &                 PAGE_INDEX_MIN:PAGE_INDEX_MAX)
      INTEGER SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX
      LOGICAL SLOPES_OK
      REAL TOLERANCE
      PARAMETER (TOLERANCE = 1.0E-4)
C
C       Save the array first
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                SAVE_SLOPES( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            PROM_SLOPE(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
              END DO
            END DO
          END DO
        END DO
      END DO
C
      CALL COMPILE_ALL_PROM_SLOPES()
C
      SLOPES_OK = .TRUE.
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                IF (PROM_SLOPE(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
     &            .NE. 0) THEN
                  IF (ABS((SAVE_SLOPES(SIGN_ETA, MAGN_ETA, PHI, PROM,
     &              INDEX) - PROM_SLOPE(SIGN_ETA, MAGN_ETA, PHI, PROM,
     &              INDEX)) / PROM_SLOPE(SIGN_ETA, MAGN_ETA, PHI, PROM,
     &              INDEX)) .GT. TOLERANCE) THEN
                    SLOPES_OK = .FALSE.
                    GOTO 1000
                  ENDIF
                ELSEIF (SAVE_SLOPES( SIGN_ETA, MAGN_ETA, PHI, PROM,
     &            INDEX) .NE. 0) THEN
                  SLOPES_OK = .FALSE.
                  GOTO 1000
                ENDIF
              END DO
            END DO
          END DO
        END DO
      END DO
 1000 CONTINUE
C
      IF (.NOT. SLOPES_OK) THEN
        CALL MESSAGE_OUT(MES_ANALYSIS_GENERAL, I_PTC_INDEX,
     &    'Section PROM_TRANSFER_COEFF does not agree with '//
     &    'other data in file that it is compiled from.')
      ENDIF
C
C       Restore the array
C
      DO INDEX = PAGE_INDEX_MIN, PAGE_INDEX_MAX
        DO PROM = EM_PROM, PY_PROM
          DO PHI = PHI_MIN, PHI_MAX
            DO MAGN_ETA = ETA_RANGE_MIN, ETA_RANGE_MAX
              DO SIGN_ETA = POS_ETA, NEG_ETA
                PROM_SLOPE( SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX) =
     &            SAVE_SLOPES(SIGN_ETA, MAGN_ETA, PHI, PROM, INDEX)
              END DO
            END DO
          END DO
        END DO
      END DO
C
  999 RETURN
      END