!
!=======================================================================
!
MODULE M77ERR
!
!  This module stores the IDELTA and IALPHA values
!
!
      USE ACCURACY_REAL
!
      IMPLICIT NONE
!
!
      INTEGER               ::  IDELTA,IALPHA
!
END MODULE M77ERR
!
!=======================================================================
!
MODULE ERROR_CALTECH
!
!  This module provides the Caltech error library routines
!
!
      USE ACCURACY_REAL
!
CONTAINS
!
!=======================================================================
!
      SUBROUTINE DERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG)
!
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1994-10-20 DERM1  Krogh  Changes to use M77CON
!>> 1994-04-20 DERM1  CLL Edited to make DP & SP files similar.
!>> 1985-08-02 DERM1  Lawson  Initial code.
!--D replaces "?": ?ERM1, ?ERV1
!
      IMPLICIT NONE
!
      INTEGER                    ::  INDIC,LEVEL
!
      REAL (WP)                  ::  VALUE
!
      CHARACTER (LEN = *)        ::  SUBNAM,MSG,LABEL
      CHARACTER (LEN = 1)        ::  FLAG
!
      CALL ERMSG(SUBNAM,INDIC,LEVEL,MSG,',')                  !
      CALL DERV1(LABEL,VALUE,FLAG)                            !
!
      RETURN                                                  !
!
      END SUBROUTINE DERM1
!
!=======================================================================
!
      SUBROUTINE ERMSG(SUBNAM,INDIC,LEVEL,MSG,FLAG)
!
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1995-11-22 ERMSG  Krogh Got rid of multiple entries.
!>> 1995-09-15 ERMSG  Krogh Remove '0' in format.
!>> 1994-11-11 ERMSG  Krogh   Declared all vars.
!>> 1992-10-20 ERMSG  WV Snyder  added ERLSET, ERLGET
!>> 1985-09-25 ERMSG  Lawson  Initial code.
!
!     --------------------------------------------------------------
!
!     Four entries: ERMSG, ERMSET, ERLGET, ERLSET
!     ERMSG initiates an error message. This subr also manages the
!     saved value IDELOC and the saved COMMON block M77ERR to
!     control the level of action. This is intended to be the
!     only subr that assigns a value to IALPHA in COMMON.
!     ERMSET resets IDELOC & IDELTA.  ERLGET returns the last value
!     of LEVEL passed to ERMSG.  ERLSET sets the last value of LEVEL.
!     ERLSET and ERLGET may be used together to determine the level
!     of error that occurs during execution of a routine that uses
!     ERMSG.
!
!     --------------------------------------------------------------
!     SUBROUTINE ARGUMENTS
!     --------------------
!     SUBNAM   A name that identifies the subprogram in which
!              the error occurs.
!
!     INDIC    An integer printed as part of the mininal error
!              message. It together with SUBNAM can be used to
!              uniquely identify an error.
!
!     LEVEL    The user sets LEVEL=2,0,or -2 to specify the
!              nominal action to be taken by ERMSG. The
!              subroutine ERMSG contains an internal variable
!              IDELTA, whose nominal value is zero. The
!              subroutine will compute IALPHA = LEVEL + IDELTA
!              and proceed as follows:
!              If (IALPHA.GE.2)        Print message and STOP.
!              If (IALPHA=-1,0,1)      Print message and return.
!              If (IALPHA.LE.-2)       Just RETURN.
!
!     MSG      Message to be printed as part of the diagnostic.
!
!     FLAG     A single character,which when set to '.' will
!              call the subroutine ERFIN and will just RETURN
!              when set to any other character.
!
!     --------------------------------------------------------------
!
!     C.Lawson & S.Chan, JPL, 1983 Nov
!
!     ------------------------------------------------------------------
!
!
      USE M77ERR
!
      IMPLICIT NONE
!
      INTEGER                    ::  INDIC,LEVEL
      INTEGER                    ::  IDELOC
!
      CHARACTER (LEN = *)         ::  SUBNAM,MSG
      CHARACTER (LEN = 1)         ::  FLAG
!
      IDELOC = 0                                                    !
!
      IF(LEVEL < -1000) THEN                                        !
!
!   Setting a new IDELOC.
!
        IDELTA = LEVEL + 10000                                      !
        IDELOC = IDELTA                                             !
        RETURN                                                      !
      END IF                                                        !
!
      IDELTA = IDELOC                                               !
      IALPHA = LEVEL + IDELTA                                       !
      IF (IALPHA >= -1) THEN                                        !
!
!            Setting FILE = 'CON' works for MS/DOS systems.
!
!
        WRITE (6,10) SUBNAM,INDIC                                   !
        WRITE (6,*) MSG                                             !
        IF (FLAG == '.') CALL ERFIN                                 !
      END IF                                                        !
!
      RETURN                                                        !
!
!  Format:
!
  10  FORMAT(1X/' ',72('$')/' SUBPROGRAM ',A,' REPORTS ERROR NO. ',I4)
!
      END SUBROUTINE ERMSG
!
!=======================================================================
!
      SUBROUTINE ERFIN
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1994-11-11 CLL Typing all variables.
!>> 1985-09-23 ERFIN  Lawson  Initial code.
!
!
      USE M77ERR
!
      IMPLICIT NONE
!
      PRINT 10                                                      !
      IF(IALPHA >= 2) STOP                                          !
!
      RETURN                                                        !
!
!  Format:
!
  10  FORMAT(1X,72('$')/' ')!!
!
      END
!
!=======================================================================
!
      SUBROUTINE ERMSET(IDEL)
!
      IMPLICIT NONE
!
      INTEGER                    ::  IDEL
!
!  Call ERMSG to set IDELTA and IDELOC
!
      CALL ERMSG(' ', 0,IDEL-10000,' ',' ')
!
      RETURN
!
      END SUBROUTINE ERMSET
!
!=======================================================================
!
      SUBROUTINE ERMOR(MSG,FLAG)
!
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1985-09-20 ERMOR  Lawson  Initial code.
!
!     --------------------------------------------------------------
!     SUBROUTINE ARGUMENTS
!     --------------------
!     MSG      Message to be printed as part of the diagnostic.
!
!     FLAG     A single character,which when set to '.' will
!              call the subroutine ERFIN and will just RETURN
!              when set to any other character.
!
!     --------------------------------------------------------------
!
      USE M77ERR
!
      IMPLICIT NONE
!
      CHARACTER (LEN = *)        ::  MSG
      CHARACTER (LEN = 1)        ::  FLAG
!
      IF (IALPHA >= -1) THEN                                        !
        WRITE (6,*) MSG                                             !
        IF (FLAG .EQ. '.') CALL ERFIN                               !
      END IF                                                        !
!        
      RETURN                                                        !
!
      END SUBROUTINE ERMOR
!
!=======================================================================
!
      SUBROUTINE DERV1(LABEL,VALUE,FLAG)
!
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1994-10-20 DERV1  Krogh  Changes to use M77CON
!>> 1994-04-20 DERV1  CLL Edited to make DP & SP files similar.
!>> 1985-09-20 DERV1  Lawson  Initial code.
!--D replaces "?": ?ERV1
!
!     ------------------------------------------------------------
!     SUBROUTINE ARGUMENTS
!     --------------------
!     LABEL     An identifing name to be printed with VALUE.
!
!     VALUE     A floating point number to be printed.
!
!     FLAG      See write up for FLAG in ERMSG.
!
!     ------------------------------------------------------------
!
!
      USE M77ERR
!
      IMPLICIT NONE
!
      REAL (WP)                  ::  VALUE
!
      CHARACTER (LEN = *)        ::  LABEL
      CHARACTER (LEN = 1)        ::  FLAG
!
      IF (IALPHA.GE.-1) THEN
        WRITE (*,*) '  ',LABEL,' = ',VALUE
        IF (FLAG.EQ.'.') CALL ERFIN
      ENDIF
      RETURN
!
      END SUBROUTINE DERV1
!
!=======================================================================
!
      SUBROUTINE IERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG)
!
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1990-01-18 CLL Added Integer stmt for VALUE.  Typed all variables.
!>> 1985-08-02 IERM1  Lawson  Initial code.
!
      IMPLICIT NONE
!
      INTEGER                    ::  INDIC,LEVEL,VALUE
!
      CHARACTER (LEN = *)        ::  SUBNAM,MSG,LABEL
      CHARACTER (LEN = 1)        ::  FLAG
!
      CALL ERMSG(SUBNAM,INDIC,LEVEL,MSG,',')                        !
      CALL IERV1(LABEL,VALUE,FLAG)                                  !
!
      RETURN
!
      END SUBROUTINE IERM1
!
!=======================================================================
!
      SUBROUTINE IERV1(LABEL,VALUE,FLAG)
!
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1995-11-15 IERV1 Krogh  Moved format up for C conversion.
!>> 1985-09-20 IERV1  Lawson  Initial code.
!
!     ------------------------------------------------------------
!     SUBROUTINE ARGUMENTS
!     --------------------
!     LABEL     An identifing name to be printed with VALUE.
!
!     VALUE     A integer to be printed.
!
!     FLAG      See write up for FLAG in ERMSG.
!
!     ------------------------------------------------------------
!
      USE M77ERR
!
      IMPLICIT NONE
!
      INTEGER                    ::  VALUE
!
      CHARACTER (LEN = *)        ::  LABEL
      CHARACTER (LEN = 1)        ::  FLAG
!
      IF (IALPHA >= -1) THEN                                        !
        WRITE (6,10) LABEL,VALUE                                    !
        IF(FLAG .EQ. '.') CALL ERFIN                                !
      END IF                                                        !
!
      RETURN                                                        !
!
!  Format:
!
  10  FORMAT(3X,A,' = ',I5)
!
      END
!
!=======================================================================
!
      SUBROUTINE SERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG)
!
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1994-10-20 SERM1  Krogh  Changes to use M77CON
!>> 1994-04-20 SERM1  CLL Edited to make DP & SP files similar.
!>> 1985-08-02 SERM1  Lawson  Initial code.
!--S replaces "?": ?ERM1, ?ERV1
!
!
      IMPLICIT NONE
!
      INTEGER                    ::  INDIC,LEVEL
!
      REAL (WP)                  ::  VALUE
!
      CHARACTER (LEN = *)        ::  SUBNAM,MSG,LABEL
      CHARACTER (LEN = 1)        ::  FLAG
!
      CALL ERMSG(SUBNAM,INDIC,LEVEL,MSG,',')                        !
      CALL SERV1(LABEL,VALUE,FLAG)                                  !
!
      RETURN
!
      END SUBROUTINE SERM1
!
!=======================================================================
!
      SUBROUTINE SERV1(LABEL,VALUE,FLAG)
!
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
! ALL RIGHTS RESERVED.
! Based on Government Sponsored Research NAS7-03001.
!>> 1994-10-20 SERV1  Krogh  Changes to use M77CON
!>> 1994-04-20 SERV1  CLL Edited to make DP & SP files similar.
!>> 1985-09-20 SERV1  Lawson  Initial code.
!--S replaces "?": ?ERV1
!
!     ------------------------------------------------------------
!     SUBROUTINE ARGUMENTS
!     --------------------
!     LABEL     An identifing name to be printed with VALUE.
!
!     VALUE     A floating point number to be printed.
!
!     FLAG      See write up for FLAG in ERMSG.
!
!     ------------------------------------------------------------
!
      USE M77ERR
!
      IMPLICIT NONE
!
      REAL (WP)                  ::  VALUE
!
      CHARACTER (LEN = *)        ::  LABEL
      CHARACTER (LEN = 1)        ::  FLAG
!
      IF(IALPHA >= -1) THEN                                         !
        WRITE(6,*) '  ',LABEL,' = ',VALUE                           !
        IF(FLAG == '.') CALL ERFIN                                  !
      END IF                                                        !
!
      RETURN                                                        !
!
      END SUBROUTINE SERV1
!
END MODULE ERROR_CALTECH
