text:
!------------------------------------------------------------------------------
!M+
! NAME:
!       Tau_OPTRAN_SARTA_Coeff_Define
!
! PURPOSE:
!       Module defining the Tau_OPTRAN_SARTA_Coeff data structure and containing routines to
!       manipulate it.
!
! CATEGORY:
!       Optical Depth : Coefficients
!
! LANGUAGE:
!       Fortran-95
!
! CALLING SEQUENCE:
!       USE Tau_OPTRAN_SARTA_Coeff_Define
!
! MODULES:
!       Type_Kinds:             Module containing definitions for kinds
!                               of variable types.
!
!       Message_Handler:          Module to define simple error codes and
!                               handle error conditions
!                               USEs: FILE_UTILITY module
!
! CONTAINS:
!       Associated_Tau_OPTRAN_Coeff:            Function to test the association status
!                                               of the pointer members of a Tau_OPTRAN_SARTA_Coeff
!                                               structure.
!
!       Destroy_Tau_OPTRAN_Coeff:               Function to re-initialize a Tau_OPTRAN_SARTA_Coeff
!                                               structure.
!
!       Allocate_Tau_OPTRAN_Coeff:              Function to allocate the pointer members
!                                               of a Tau_OPTRAN_SARTA_Coeff structure.
!
!       Assign_Tau_OPTRAN_Coeff:                Function to copy a valid Tau_OPTRAN_SARTA_Coeff structure.
!
!
! DERIVED TYPES:
!       Tau_OPTRAN_SARTA_Coeff_type:   Definition of the public Tau_OPTRAN_SARTA_Coeff data structure.
!       Fields are...
!
!         n_Layers:            Maximum layers for the aborber coefficients.
!                              "Ilayers" dimension.
!                              UNITS:      N/A
!                              TYPE:       INTEGER( Long )
!                              DIMENSION:  Scalar
!
!         n_Predictors:        Number of predictors used in the
!                              gas absorption regression.
!                              "Iuse" dimension.
!                              UNITS:      N/A
!                              TYPE:       INTEGER( Long )
!                              DIMENSION:  Scalar
!
!         n_Channels:          Total number of spectral channels.
!                              "L" dimension.
!                              UNITS:      N/A
!                              TYPE:       INTEGER( Long )
!                              DIMENSION:  Scalar
!
!         n_ProfAves:          Number of predictors for water vapor of OPTRAN in the
!                              data structure.
!                              "J" dimension
!                              UNITS:      N/A
!                              TYPE:       INTEGER
!                              DIMENSION:  Scalar
!
!         Channel_Index:       This is the sensor channel number associated
!                              with the data in the coefficient file. Helps
!                              in identifying channels where the numbers are
!                              not contiguous (e.g. AIRS).
!                              UNITS:      N/A
!                              TYPE:       INTEGER
!                              DIMENSION:  Rank-1 (n_Channels)
!                              ATTRIBUTES: POINTER
!
!         Water_Amount:        Array containing the The OPTRAN water amount
!                              UNITS:      Kilomoles/cm^2
!                              TYPE:       REAL( Single )
!                              DIMENSION:  Ilayers
!                              ATTRIBUTES: POINTER
!
!         Water_ProfAve:       Array containing the gas absorption
!                              model coefficients.
!                              UNITS:      Variable
!                              TYPE:       REAL( Single )
!                              DIMENSION:  J x Ilayers
!                              ATTRIBUTES: POINTER
!
!         Water_Coeff:         Array containing the water vapor absorption
!                              model coefficients.
!                              UNITS:      Variable
!                              TYPE:       REAL( Single )
!                              DIMENSION:  Iuse x Ilayers x L
!                              ATTRIBUTES: POINTER
!
!       *!IMPORTANT!*
!       -------------
!       Note that the Tau_OPTRAN_SARTA_Coeff_type is PUBLIC and its members are not
!       encapsulated; that is, they can be fully accessed outside the
!       scope of this module. This makes it possible to manipulate
!       the structure and its data directly rather than, for e.g., via
!       get() and set() functions. This was done to eliminate the
!       overhead of the get/set type of structure access in using the
!       structure. *But*, it is recommended that the user initialize,
!       destroy, allocate, assign, and concatenate the structure
!       using only the routines in this module where possible to
!       eliminate -- or at least minimise -- the possibility of
!       memory leakage since most of the structure members are
!       pointers.
!
! INCLUDE FILES:
!       None.
!
! EXTERNALS:
!       None.
!
! COMMON BLOCKS:
!       None.
!
! FILES ACCESSED:
!       None.
!
! CREATION HISTORY:
!       Written by:     Yong Chen, CSU/CIRA 02-May-2006
!                       Yong.Chen@noaa.gov
!
!  Copyright (C) 2006 Yong Chen
!
!M-
!------------------------------------------------------------------------------

MODULE Tau_OPTRAN_SARTA_Coeff_Define

  ! ----------
  ! Module use
  ! ----------

  USE Type_Kinds
  USE Message_Handler

  ! -----------------------
  ! Disable implicit typing
  ! -----------------------

  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------

  ! -- Everything private by default
  PRIVATE

  ! -- Public procedures to manipulate the Tau_OPTRAN_SARTA_Coeff structure
  PUBLIC :: Associated_Tau_OPTRAN_Coeff
  PUBLIC :: Destroy_Tau_OPTRAN_Coeff
  PUBLIC :: Allocate_Tau_OPTRAN_Coeff
  PUBLIC :: Assign_Tau_OPTRAN_Coeff

  ! -------------------------
  ! PRIVATE Module parameters
  ! -------------------------

  ! -- RCS Id for the module
  CHARACTER( * ), PRIVATE, PARAMETER :: MODULE_RCS_ID = &

  ! -- Keyword set value
  INTEGER, PRIVATE, PARAMETER :: SET = 1

  ! ------------------------
  ! PUBLIC Module parameters
  ! ------------------------

  ! ------------------------------
  ! Tau_OPTRAN_SARTA_Coeff data type definition
  ! ------------------------------

  TYPE, PUBLIC :: Tau_OPTRAN_SARTA_Coeff_type
    INTEGER :: n_Allocates = 0

    ! -- Array dimensions
    INTEGER( Long ) :: n_Layers      = 0    ! Ilayer
    INTEGER( Long ) :: n_Predictors  = 0    ! Iuse
    INTEGER( Long ) :: n_Channels    = 0    ! L
    INTEGER( Long ) :: n_ProfAves    = 0    ! J

    ! -- The actual sensor channel numbers
    INTEGER( Long ), POINTER, DIMENSION( : ) :: Channel_Index => NULL()    ! L

    ! -- The OPTRAN water amount ( Kilomoles/cm^2)
    REAL( Single ), POINTER, DIMENSION( : ) ::  Water_Amount  => NULL()  ! Ilayer

    ! -- The OPTRAN water average profile values
    REAL( Single ), POINTER, DIMENSION( :, : ) :: Water_ProfAve  => NULL()  ! J x Ilayer

    ! -- The array of coefficients
    REAL( Single ), POINTER, DIMENSION( :, :, : ) :: Water_Coeff => NULL() ! Iuse x Ilayer x L

  END TYPE Tau_OPTRAN_SARTA_Coeff_type

CONTAINS

  SUBROUTINE Clear_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff )

    TYPE( Tau_OPTRAN_SARTA_Coeff_type ), INTENT( IN OUT ) :: Tau_OPTRAN_Coeff

    Tau_OPTRAN_Coeff%n_Layers     = 0
    Tau_OPTRAN_Coeff%n_Predictors = 0
    Tau_OPTRAN_Coeff%n_Channels   = 0
    Tau_OPTRAN_Coeff%n_ProfAves    = 0

  END SUBROUTINE Clear_Tau_OPTRAN_Coeff

  FUNCTION Associated_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff,  & ! Input
                                        ANY_Test ) & ! Optional input
                                        RESULT( Association_Status )

    !#--------------------------------------------------------------------------#
    !#                        -- TYPE DECLARATIONS --                           #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    ! -- Input
    TYPE( Tau_OPTRAN_SARTA_Coeff_type ), INTENT( IN ) :: Tau_OPTRAN_Coeff

    ! -- Optional input
    INTEGER,     OPTIONAL, INTENT( IN ) :: ANY_Test

    ! ---------------
    ! Function result
    ! ---------------

    LOGICAL :: Association_Status

    ! ---------------
    ! Local variables
    ! ---------------

    LOGICAL :: ALL_Test

    !#--------------------------------------------------------------------------#
    !#                           -- CHECK INPUT --                              #
    !#--------------------------------------------------------------------------#

    ! -- Default is to test ALL the pointer members
    ! -- for a true association status....
    ALL_Test = .TRUE.

    ! ...unless the ANY_Test argument is set.
    IF ( PRESENT( ANY_Test ) ) THEN
      IF ( ANY_Test == SET ) ALL_Test = .FALSE.
    END IF

    !#--------------------------------------------------------------------------#
    !#           -- TEST THE STRUCTURE POINTER MEMBER ASSOCIATION --            #
    !#--------------------------------------------------------------------------#

    Association_Status = .FALSE.

    IF ( ALL_Test ) THEN

      IF ( ASSOCIATED( Tau_OPTRAN_Coeff%Channel_Index    ) .AND. &
           ASSOCIATED( Tau_OPTRAN_Coeff%Water_Amount     ) .AND. &
           ASSOCIATED( Tau_OPTRAN_Coeff%Water_ProfAve    ) .AND. &
           ASSOCIATED( Tau_OPTRAN_Coeff%Water_Coeff      )       ) THEN
        Association_Status = .TRUE.
      END IF

    ELSE

      IF ( ASSOCIATED( Tau_OPTRAN_Coeff%Channel_Index    ) .OR. &
           ASSOCIATED( Tau_OPTRAN_Coeff%Water_Amount     ) .OR. &
           ASSOCIATED( Tau_OPTRAN_Coeff%Water_ProfAve    ) .OR. &
           ASSOCIATED( Tau_OPTRAN_Coeff%Water_Coeff      )      ) THEN
        Association_Status = .TRUE.
      END IF

    END IF

  END FUNCTION Associated_Tau_OPTRAN_Coeff

  FUNCTION Destroy_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff,     &  ! Output
                                     No_Clear,     &  ! Optional input
                                     RCS_Id,	   &  ! Revision control
                                     Message_Log ) &  ! Error messaging

                                    RESULT( Error_Status )

    !#--------------------------------------------------------------------------#
    !#                        -- TYPE DECLARATIONS --                           #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    ! -- Output
    TYPE( Tau_OPTRAN_SARTA_Coeff_type ),    INTENT( IN OUT ) :: Tau_OPTRAN_Coeff

    ! -- Optional input
    INTEGER,        OPTIONAL, INTENT( IN )     :: No_Clear

    ! -- Revision control
    CHARACTER( * ), OPTIONAL, INTENT( OUT )    :: RCS_Id

    ! - Error messaging
    CHARACTER( * ), OPTIONAL, INTENT( IN )     :: Message_Log

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: Error_Status

    ! ----------------
    ! Local parameters
    ! ----------------

    CHARACTER( * ), PARAMETER :: ROUTINE_NAME = 'Destroy_Tau_OPTRAN_Coeff'

    ! ---------------
    ! Local variables
    ! ---------------

    CHARACTER( 256 ) :: message
    LOGICAL :: Clear
    INTEGER :: Allocate_Status

    !#--------------------------------------------------------------------------#
    !#                    -- SET SUCCESSFUL RETURN STATUS --                    #
    !#--------------------------------------------------------------------------#

    Error_Status = SUCCESS

    !#--------------------------------------------------------------------------#
    !#                -- SET THE RCS ID ARGUMENT IF SUPPLIED --                 #
    !#--------------------------------------------------------------------------#

    IF ( PRESENT( RCS_Id ) ) THEN
      RCS_Id = ' '
      RCS_Id = MODULE_RCS_ID
    END IF

    !#--------------------------------------------------------------------------#
    !#                      -- CHECK OPTIONAL ARGUMENTS --                      #
    !#--------------------------------------------------------------------------#

    ! -- Default is to clear scalar members...
    Clear = .TRUE.
    ! -- ....unless the No_Clear argument is set
    IF ( PRESENT( No_Clear ) ) THEN
      IF ( No_Clear == SET ) Clear = .FALSE.
    END IF

    !#--------------------------------------------------------------------------#
    !#                     -- PERFORM RE-INITIALISATION --                      #
    !#--------------------------------------------------------------------------#

    ! -----------------------------
    ! Initialise the scalar members
    ! -----------------------------

    IF ( Clear ) CALL Clear_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff )

    ! -----------------------------------------------------
    ! If ALL pointer members are NOT associated, do nothing
    ! -----------------------------------------------------

    IF ( .NOT. Associated_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff ) ) RETURN

    ! ------------------------------
    ! Deallocate the pointer members
    ! ------------------------------

    ! -- Deallocate the sensor channel number array
    IF ( ASSOCIATED( Tau_OPTRAN_Coeff%Channel_Index ) ) THEN

      DEALLOCATE( Tau_OPTRAN_Coeff%Channel_Index, STAT = Allocate_Status )

      IF ( Allocate_Status /= 0 ) THEN
        Error_Status = FAILURE
        WRITE( Message, '( "Error deallocating Tau_OPTRAN_SARTA_Coeff Channel_Index ", &
                          &"member. STAT = ", i5 )' ) &
                        Allocate_Status
        CALL Display_Message( ROUTINE_NAME,    &
                              TRIM( Message ), &
                              Error_Status,    &
                              Message_Log = Message_Log )
      END IF
    END IF

    ! -- Deallocate Water amount
    IF ( ASSOCIATED( Tau_OPTRAN_Coeff%Water_Amount ) ) THEN

      DEALLOCATE( Tau_OPTRAN_Coeff%Water_Amount, STAT = Allocate_Status )

      IF ( Allocate_Status /= 0 ) THEN
        Error_Status = FAILURE
        WRITE( Message, '( "Error deallocating Tau_OPTRAN_SARTA_Coeff Water_Amount ", &
                          &"member. STAT = ", i5 )' ) &
                        Allocate_Status
        CALL Display_Message( ROUTINE_NAME,    &
                              TRIM( Message ), &
                              Error_Status,    &
                              Message_Log = Message_Log )
      END IF
    END IF

    ! -- Deallocate water average profile values
    IF ( ASSOCIATED( Tau_OPTRAN_Coeff%Water_ProfAve ) ) THEN

      DEALLOCATE( Tau_OPTRAN_Coeff%Water_ProfAve, STAT = Allocate_Status )

      IF ( Allocate_Status /= 0 ) THEN
        Error_Status = FAILURE
        WRITE( Message, '( "Error deallocating Tau_OPTRAN_SARTA_Coeff Water_ProfAve ", &
                          &"member. STAT = ", i5 )' ) &
                        Allocate_Status
        CALL Display_Message( ROUTINE_NAME,    &
                              TRIM( Message ), &
                              Error_Status,    &
                              Message_Log = Message_Log )
      END IF
    END IF

    ! -- Deallocate coefficients
    IF ( ASSOCIATED( Tau_OPTRAN_Coeff%Water_Coeff ) ) THEN

      DEALLOCATE( Tau_OPTRAN_Coeff%Water_Coeff, STAT = Allocate_Status )

      IF ( Allocate_Status /= 0 ) THEN
        Error_Status = FAILURE
        WRITE( Message, '( "Error deallocating Tau_OPTRAN_SARTA_Coeff Water_Coeff ", &
                          &"member. STAT = ", i5 )' ) &
                        Allocate_Status
        CALL Display_Message( ROUTINE_NAME,    &
                              TRIM( Message ), &
                              Error_Status,    &
                              Message_Log = Message_Log )
      END IF
    END IF

    !#--------------------------------------------------------------------------#
    !#               -- DECREMENT AND TEST ALLOCATION COUNTER --                #
    !#--------------------------------------------------------------------------#

    Tau_OPTRAN_Coeff%n_Allocates = Tau_OPTRAN_Coeff%n_Allocates - 1

    IF ( Tau_OPTRAN_Coeff%n_Allocates /= 0 ) THEN
      Error_Status = FAILURE
      WRITE( Message, '( "Allocation counter /= 0, Value = ", i5 )' ) &
                      Tau_OPTRAN_Coeff%n_Allocates
      CALL Display_Message( ROUTINE_NAME,    &
                            TRIM( Message ), &
                            Error_Status,    &
                            Message_Log = Message_Log )
    END IF

  END FUNCTION Destroy_Tau_OPTRAN_Coeff

  FUNCTION Allocate_Tau_OPTRAN_Coeff( n_Layers,     &  ! Input
                                      n_Predictors, &  ! Input
                                      n_Channels,   &  ! Input
                                      n_ProfAves ,   &  ! Input
                                      Tau_OPTRAN_Coeff,     &  ! Output
                                      RCS_Id,	    &  ! Revision control
                                      Message_Log ) &  ! Error messaging
                                    RESULT( Error_Status )

    !#--------------------------------------------------------------------------#
    !#                        -- TYPE DECLARATIONS --                           #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    ! -- Input
    INTEGER,                  INTENT( IN )     :: n_Layers
    INTEGER,                  INTENT( IN )     :: n_Predictors
    INTEGER,                  INTENT( IN )     :: n_Channels
    INTEGER,                  INTENT( IN )     :: n_ProfAves

    ! -- Output
    TYPE( Tau_OPTRAN_SARTA_Coeff_type ),    INTENT( IN OUT ) :: Tau_OPTRAN_Coeff

    ! -- Revision control
    CHARACTER( * ), OPTIONAL, INTENT( OUT )    :: RCS_Id

    ! - Error messaging
    CHARACTER( * ), OPTIONAL, INTENT( IN )     :: Message_Log

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: Error_Status

    ! ----------------
    ! Local parameters
    ! ----------------

    CHARACTER( * ), PARAMETER :: ROUTINE_NAME = 'Allocate_Tau_OPTRAN_Coeff'

    ! ---------------
    ! Local variables
    ! ---------------

    CHARACTER( 256 ) :: message

    INTEGER :: Allocate_Status

    !#--------------------------------------------------------------------------#
    !#                    -- SET SUCCESSFUL RETURN STATUS --                    #
    !#--------------------------------------------------------------------------#

    Error_Status = SUCCESS

    !#--------------------------------------------------------------------------#
    !#                -- SET THE RCS ID ARGUMENT IF SUPPLIED --                 #
    !#--------------------------------------------------------------------------#

    IF ( PRESENT( RCS_Id ) ) THEN
      RCS_Id = ' '
      RCS_Id = MODULE_RCS_ID
    END IF

    !#--------------------------------------------------------------------------#
    !#                            -- CHECK INPUT --                             #
    !#--------------------------------------------------------------------------#

    ! ----------
    ! Dimensions
    ! ----------

    IF ( n_Layers     < 1 .OR. &
         n_Predictors < 1 .OR. &
         n_Channels   < 1 .OR. &
	 n_ProfAves   < 1  ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input Tau_OPTRAN_SARTA_Coeff dimensions must all be > 0.', &
                            Error_Status, &
                            Message_Log = Message_Log )
      RETURN
    END IF

    ! -----------------------------------------------
    ! Check if ANY pointers are already associated.
    ! If they are, deallocate them but leave scalars.
    ! -----------------------------------------------

    IF ( Associated_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff, ANY_Test = SET ) ) THEN

      Error_Status = Destroy_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff, &
                                       No_Clear = SET, &
                                       Message_Log = Message_Log )

      IF ( Error_Status /= SUCCESS ) THEN
        CALL Display_Message( ROUTINE_NAME,    &
                              'Error deallocating Tau_OPTRAN_SARTA_Coeff pointer members.', &
                              Error_Status,    &
                              Message_Log = Message_Log )
        RETURN
      END IF

    END IF

    !#--------------------------------------------------------------------------#
    !#                       -- PERFORM THE ALLOCATION --                       #
    !#--------------------------------------------------------------------------#

    ALLOCATE( Tau_OPTRAN_Coeff%Channel_Index( n_Channels ), &
              Tau_OPTRAN_Coeff%Water_Amount( n_Layers ), &
              Tau_OPTRAN_Coeff%Water_ProfAve( n_ProfAves, n_Layers ), &
              Tau_OPTRAN_Coeff%Water_Coeff( n_Predictors, n_Layers, n_Channels ), &
              STAT = Allocate_Status )

    IF ( Allocate_Status /= 0 ) THEN
      Error_Status = FAILURE
      WRITE( Message, '( "Error allocating Tau_OPTRAN_SARTA_Coeff data arrays. STAT = ", i5 )' ) &
                      Allocate_Status
      CALL Display_Message( ROUTINE_NAME,    &
                            TRIM( Message ), &
                            Error_Status,    &
                            Message_Log = Message_Log )
      RETURN
    END IF

    !#--------------------------------------------------------------------------#
    !#                        -- ASSIGN THE DIMENSIONS --                       #
    !#--------------------------------------------------------------------------#

    Tau_OPTRAN_Coeff%n_Layers     = n_Layers
    Tau_OPTRAN_Coeff%n_Predictors = n_Predictors
    Tau_OPTRAN_Coeff%n_Channels   = n_Channels
    Tau_OPTRAN_Coeff%n_ProfAves   = n_ProfAves

    !#--------------------------------------------------------------------------#
    !#                -- INCREMENT AND TEST ALLOCATION COUNTER --               #
    !#--------------------------------------------------------------------------#

    Tau_OPTRAN_Coeff%n_Allocates = Tau_OPTRAN_Coeff%n_Allocates + 1

    IF ( Tau_OPTRAN_Coeff%n_Allocates /= 1 ) THEN
      Error_Status = WARNING
      WRITE( Message, '( "Allocation counter /= 1, Value = ", i5 )' ) &
                      Tau_OPTRAN_Coeff%n_Allocates
      CALL Display_Message( ROUTINE_NAME,    &
                            TRIM( Message ), &
                            Error_Status,    &
                            Message_Log = Message_Log )
    END IF

  END FUNCTION Allocate_Tau_OPTRAN_Coeff

  FUNCTION Assign_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff_in,   &  ! Input
                                    Tau_OPTRAN_Coeff_out,  &  ! Output
                                    RCS_Id,	   &  ! Revision control
                                    Message_Log )  &  ! Error messaging
                                  RESULT( Error_Status )

    !#--------------------------------------------------------------------------#
    !#                        -- TYPE DECLARATIONS --                           #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    ! -- Input
    TYPE( Tau_OPTRAN_SARTA_Coeff_type ),    INTENT( IN )     :: Tau_OPTRAN_Coeff_in

    ! -- Output
    TYPE( Tau_OPTRAN_SARTA_Coeff_type ),    INTENT( IN OUT ) :: Tau_OPTRAN_Coeff_out

    ! -- Revision control
    CHARACTER( * ), OPTIONAL, INTENT( OUT )    :: RCS_Id

    ! - Error messaging
    CHARACTER( * ), OPTIONAL, INTENT( IN )     :: Message_Log

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: Error_Status

    ! ----------------
    ! Local parameters
    ! ----------------

    CHARACTER( * ), PARAMETER :: ROUTINE_NAME = 'Assign_Tau_OPTRAN_Coeff'

    !#--------------------------------------------------------------------------#
    !#                -- SET THE RCS ID ARGUMENT IF SUPPLIED --                 #
    !#--------------------------------------------------------------------------#

    IF ( PRESENT( RCS_Id ) ) THEN
      RCS_Id = ' '
      RCS_Id = MODULE_RCS_ID
    END IF

    !#--------------------------------------------------------------------------#
    !#           -- TEST THE STRUCTURE ARGUMENT POINTER ASSOCIATION --          #
    !#--------------------------------------------------------------------------#

    ! ---------------------------------------
    ! ALL *input* pointers must be associated
    ! ---------------------------------------

    IF ( .NOT. Associated_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff_In ) ) THEN

      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME,    &
                            'Some or all INPUT Tau_OPTRAN_SARTA_Coeff pointer '//&
                            'members are NOT associated.', &
                            Error_Status,    &
                            Message_Log = Message_Log )
      RETURN
    END IF

    !#--------------------------------------------------------------------------#
    !#                       -- PERFORM THE ASSIGNMENT --                       #
    !#--------------------------------------------------------------------------#

    ! -----------------
    ! Assign array data
    ! -----------------

    ! -- Allocate data arrays
    Error_Status = Allocate_Tau_OPTRAN_Coeff( Tau_OPTRAN_Coeff_in%n_Layers, &
                                              Tau_OPTRAN_Coeff_in%n_Predictors, &
                                              Tau_OPTRAN_Coeff_in%n_Channels, &
                                              Tau_OPTRAN_Coeff_in%n_ProfAves, &
                                              Tau_OPTRAN_Coeff_out, &
                                              Message_Log = Message_Log )

    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( ROUTINE_NAME,    &
                            'Error allocating output Tau_OPTRAN_SARTA_Coeff arrays.', &
                            Error_Status,    &
                            Message_Log = Message_Log )
      RETURN
    END IF

    ! -- Copy array data
    Tau_OPTRAN_Coeff_out%Channel_Index    = Tau_OPTRAN_Coeff_in%Channel_Index
    Tau_OPTRAN_Coeff_out%Water_Amount     = Tau_OPTRAN_Coeff_in%Water_Amount
    Tau_OPTRAN_Coeff_out%Water_ProfAve    = Tau_OPTRAN_Coeff_in%Water_ProfAve
    Tau_OPTRAN_Coeff_out%Water_Coeff      = Tau_OPTRAN_Coeff_in%Water_Coeff

  END FUNCTION Assign_Tau_OPTRAN_Coeff

END MODULE Tau_OPTRAN_SARTA_Coeff_Define

max_stars_repo_name: hsbadr/crtm

max_issues_repo_name: hsbadr/crtm

max_forks_repo_name: hsbadr/crtm


text:
program TargetReduction_3D

    use OMP_LIB
    implicit none

    integer :: &
      iV, jV, kV, &
      StopCode
    integer, dimension ( 3 ) :: &
      lV, uV, oV
    real, dimension ( :, :, : ), allocatable :: &
      FEP_1, FEP_2, FEP_3, &
      FEM_1, FEM_2, FEM_3
    real :: &
      MaxSpeed
    real, parameter :: &
      DEFINED_MAX_SPEED = 10.0

    StopCode = 0

    allocate ( FEP_1 ( 32, 16, 8 ) )
    allocate ( FEP_2 ( 32, 16, 8 ) )
    allocate ( FEP_3 ( 32, 16, 8 ) )
    allocate ( FEM_1 ( 32, 16, 8 ) )
    allocate ( FEM_2 ( 32, 16, 8 ) )
    allocate ( FEM_3 ( 32, 16, 8 ) )

    call random_number ( FEP_1 )
    call random_number ( FEP_2 )
    call random_number ( FEP_3 )
    call random_number ( FEM_1 )
    call random_number ( FEM_2 )
    call random_number ( FEM_3 )

    lV = lbound ( FEP_1 )
    uV = ubound ( FEP_1 )

    FEM_1 = -1.0 * FEM_1
    FEM_2 = -1.0 * FEM_2
    FEM_3 = -1.0 * FEM_3

    FEP_1 ( 15, 15, 4 ) = DEFINED_MAX_SPEED

    !$OMP  target enter data &
    !$OMP  map ( to: FEP_1, FEP_2, FEP_3, FEM_1, FEM_2, FEM_3 )

    MaxSpeed = - huge ( 1.0 )

    print*, 'MaxSpeed init',  MaxSpeed
    print*, 'Num devices: ', omp_get_num_devices()
    print*, 'Expected MaxSpeed: ', DEFINED_MAX_SPEED

    !$OMP  target teams distribute parallel do simd collapse ( 3 ) &
    !$OMP  schedule ( static, 1 ) private ( iV, jV, kV ) &
    !$OMP  reduction ( max : MaxSpeed )
    do kV = lV ( 3 ), uV ( 3 )
      do jV = lV ( 2 ), uV ( 2 )
        do iV = lV ( 1 ), uV ( 1 )
          MaxSpeed &
            = max (  FEP_1 ( iV, jV, kV ),  FEP_2 ( iV, jV, kV ), &
                     FEP_3 ( iV, jV, kV ), -FEM_1 ( iV, jV, kV ), &
                    -FEM_2 ( iV, jV, kV ), -FEM_3 ( iV, jV, kV ), MaxSpeed  )
        end do
      end do
    end do
    !$OMP  end target teams distribute parallel do simd

    print*, 'MaxSpeed reduced on device ', MaxSpeed
    if ( MaxSpeed /= DEFINED_MAX_SPEED ) then
      print*, 'Reduction on device: FAILED'
      StopCode = 1
    end if

    MaxSpeed = - huge ( 1.0 )
    MaxSpeed = max ( maxval (  FEP_1 ), maxval (  FEP_2 ), &
                     maxval (  FEP_3 ), maxval ( -FEM_1 ), &
                     maxval ( -FEM_2 ), maxval ( -FEM_3 ), MaxSpeed  )

    print*, 'MaxSpeed reduced on host ', MaxSpeed
    if ( MaxSpeed /= DEFINED_MAX_SPEED ) then
      print*, 'Reduction on host: FAILED'
      StopCode = 1
    end if

    if ( StopCode /= 0 ) stop StopCode

end program TargetReduction_3D

max_stars_repo_name: raramakr/aomp

max_issues_repo_name: raramakr/aomp

max_forks_repo_name: raramakr/aomp


text:
*=============================================================================*

      SUBROUTINE seto2(nz, z, nw, wl, cz, o2xs1, dto2)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Set up an altitude profile of air molecules.  Subroutine includes a      =*
*=  shape-conserving scaling method that allows scaling of the entire        =*
*=  profile to a given sea-level pressure.                                   =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NZ      - INTEGER, number of specified altitude levels in the working (I)=*
*=            grid                                                           =*
*=  Z       - REAL, specified altitude working grid (km)                  (I)=*
*=  NW      - INTEGER, number of specified intervals + 1 in working       (I)=*
*=            wavelength grid                                                =*
*=  WL      - REAL, vector of lower limits of wavelength intervals in     (I)=*
*=            working wavelength grid                                        =*
*=            and each specified wavelength                                  =*
*=  CZ      - REAL, number of air molecules per cm^2 at each specified    (O)=*
*=            altitude layer                                                 =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INCLUDE 'params'

* input: (grids)

      REAL wl(kw)
      REAL z(kz)
      INTEGER iw, nw
      INTEGER iz, nz
      REAL cz(kz)
      REAL o2xs1(kw)

* output:
*  O2 absorption optical depth per layer at each wavelength

      REAL dto2(kz,kw)

*_______________________________________________________________________
*  Assumes that O2 = 20.95 % of air density.  If desire different O2
*    profile (e.g. for upper atmosphere) then can load it here.

      DO iz = 1, nz
         DO iw =1, nw - 1
            dto2(iz,iw) = 0.2095 * cz(iz) * o2xs1(iw)
         ENDDO
      ENDDO

*_______________________________________________________________________

      RETURN
      END

ext: f

max_stars_repo_name: SeregaOsipov/TUV

max_issues_repo_name: SeregaOsipov/TUV

max_forks_repo_name: SeregaOsipov/TUV


text:
C    Copyright(C) 2008-2017 National Technology & Engineering Solutions of
C    Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C
C=======================================================================
      SUBROUTINE COMAND (A, IA, EXODUS, DBNAME, QAREC, INFO,
     &     NAMECO, EBTYPE, EBNAME, ATNAME,
     $     NAMIGV, NAMINV, NAMIEV, NAMINS, NAMISS,
     &     NAMOGV, NAMONV, NAMOEV, NAMONS, NAMOSS,
     &     CORD, MAPEL, DBMAPEL, MAPND, DBMAPND, DOMAPN, DOMAPE,
     &     IDELB, NUMELB, LENE, NUMLNK, NUMATR, LINK, ATRIB,
     &     IDNPS, NNNPS, NDNPS, IXNNPS, IXDNPS, LTNNPS, FACNPS, NSNAME,
     &     IDESS, NEESS, NNESS, IXEESS, IXNESS, LTEESS, LTSESS, FACESS,
     $     SSNAME, ISEVOK, ISNSVOK, ISSSVOK, TIMES,
     $     VARGL, VARNP, VAREL,  VARNS,  VARSS,
     &     LISNP, NLISEL, LISEL, LISNPS, LISESS,
     &     LISGV, LISNV, LISEV, LISMV, LISSV)
C=======================================================================

C   --*** COMAND *** (GROPE) Input and process commands
C   --
C   --COMAND inputs and executes an user command.
C   --
C   --Parameters:
C   --   A - IN - the dynamic memory base array
C   --   EXODUS - IN - true iff database is in the EXODUS database format
C   --   DBNAME - the database name
C   --   QAREC - IN - the QA records containing:
C   --      (1) - the analysis code name
C   --      (2) - the analysis code QA descriptor
C   --      (3) - the analysis date
C   --      (4) - the analysis time
C   --   INFO - IN - the information records
C   --   NAMECO - IN - the names of the coordinates
C   --   EBTYPE - IN - the names of the element block types
C   --   EBNAME - IN - the names of the element blocks
C   --   NAMIGV - IN - the names of the global variables as input
C   --   NAMINV - IN - the names of the nodal variables as input
C   --   NAMIEV - IN - the names of the element variables as input
C   --   NAMOGV - IN - the names of the global variables for comparison
C   --   NAMONV - IN - the names of the nodal variables for comparison
C   --   NAMOEV - IN - the names of the element variables for comparison
C   --   CORD - IN - the coordinates
C   --   MAPEL - IN - the element order map
C   --   MAPND - IN - the node order map
C   --   IDELB - IN - the element block ID for each block
C   --   NUMELB - IN - the number of elements for each block
C   --   LENE - IN - the cumulative element count by element block
C   --   NUMLNK - IN - the number of nodes per element for each block
C   --   NUMATR - IN - the number of attributes for each block
C   --   LINK - IN - the connectivity array for all blocks
C   --   ATRIB - IN - the attribute array for all blocks
C   --   IDNPS - IN - the nodal point set ID for each set
C   --   NNNPS - IN - the number of nodes for each set
C   --   NDNPS - IN - the number of distribution factors for each set
C   --   IXNNPS - IN - the index of the first node for each set
C   --   IXDNPS - IN - the index of the first dist factor for each set
C   --   LTNNPS - IN - the nodes for all sets
C   --   FACNPS - IN - the distribution factors for all sets
C   --   NSNAME - IN - the names of the nodesets
C   --   IDESS - IN - the element side set ID for each set
C   --   NEESS - IN - the number of elements for each set
C   --   NNESS - IN - the number of nodes for each set
C   --   IXEESS - IN - the index of the first element for each set
C   --   IXNESS - IN - the index of the first node for each set
C   --   LTEESS - IN - the elements for all sets
C   --   LTSESS - IN - the element sides for all sets
C   --   FACESS - IN - the distribution factors for all sets
C   --   SSNAME - IN - the names of the sidesets
C   --   TIMES - IN - the times for all time steps
C   --   VARGL - SCRATCH - the global variables for current time step
C   --   VARNP - SCRATCH - the nodal variables for current time step
C   --   VAREL - SCRATCH - the element variables for current time step
C   --   LISNP - SCRATCH - the indices of the selected nodes
C   --   NLISEL - IN/OUT - the number of selected elements for each block
C   --   LISEL - IN/OUT - the indices of the selected elements (by block)
C   --   LISNPS - SCRATCH - the indices of the selected nodal point sets
C   --   LISESS - SCRATCH - the indices of the selected element side sets
C   --   LISGV - SCRATCH - the indices of the selected global variables
C   --   LISNV - SCRATCH - the indices of the selected nodal variables
C   --   LISEV - SCRATCH - the indices of the selected element variables
C   --
C   --Common Variables:
C   --   Uses NDIM, NUMNP, NUMEL, NELBLK,
C   --      NUMNPS, LNPSNL, NUMESS, LESSEL, LESSNL, LESSDF,
C   --      NQAREC, NINFO, NVARGL, NVARNP, NVAREL, NSTEPS of /DBNUMS/
C   --   Uses NOUT, NCRT, NPRT, ANYPRT of /OUTFIL/

      PARAMETER (MAXFLD = 80)
      include 'exodusII.inc'
      INCLUDE 'gr_progqa.blk'
      INCLUDE 'gr_dbtitl.blk'
      INCLUDE 'gr_dbase.blk'
      INCLUDE 'gr_dbnums.blk'
      INCLUDE 'gr_outfil.blk'
      include 'gr_errcnt.blk'

      DIMENSION A(*)
      INTEGER IA(*)
      LOGICAL EXODUS, FFMATC
      LOGICAL DOMAPN, DOMAPE, MAPTMP, DOBLK, DOELE
      CHARACTER*(*) DBNAME
      CHARACTER*(MXSTLN) QAREC(4,*)
      CHARACTER*(MXLNLN) INFO(*)
      CHARACTER*(MXSTLN) EBTYPE(*)
      CHARACTER*(NAMLEN) NAMECO(*)
      CHARACTER*(NAMLEN) EBNAME(*), ATNAME(*), NSNAME(*), SSNAME(*)
      CHARACTER*(NAMLEN) NAMIGV(*), NAMINV(*), NAMIEV(*),
     $     NAMINS(*), NAMISS(*)
      CHARACTER*(NAMLEN) NAMOGV(*), NAMONV(*), NAMOEV(*),
     $     NAMONS(*), NAMOSS(*)
      REAL CORD(*)
      INTEGER MAPEL(*)
      INTEGER DBMAPEL(*)
      INTEGER MAPND(*)
      INTEGER DBMAPND(*)
      INTEGER IDELB(*), NUMELB(*)
      INTEGER LENE(0:*)
      INTEGER NUMLNK(*), NUMATR(*)
      INTEGER LINK(*)
      REAL ATRIB(*)
      INTEGER IDNPS(*), NNNPS(*), IXNNPS(*)
      INTEGER LTNNPS(*)
      REAL FACNPS(*)
      INTEGER IDESS(*), NEESS(*), NNESS(*), IXEESS(*), IXNESS(*)
      INTEGER LTEESS(*), LTSESS(*)
      REAL FACESS(*)
      INTEGER ISEVOK(*), ISNSVOK(*), ISSSVOK(*)
      REAL TIMES(*)
      REAL VARGL(*), VARNP(*), VAREL(*), VARNS(*), VARSS(*)
      INTEGER LISNP(0:*)
      INTEGER NLISEL(0:*), LISEL(0:*)
      INTEGER LISNPS(0:*), LISESS(0:*)
      INTEGER LISGV(0:*), LISNV(0:*), LISEV(0:*), LISMV(0:*), LISSV(0:*)

      LOGICAL FFEXST, MATSTR

      CHARACTER*(MXNAME) WORD, VERB, LISTYP
      INTEGER     INTYP(MAXFLD+1)
      CHARACTER*(MXNAME) CFIELD(MAXFLD)
      INTEGER     IFIELD(MAXFLD)
      REAL        RFIELD(MAXFLD)
      LOGICAL HELP
      LOGICAL ISON
      CHARACTER*(MXNAME) OPT
      CHARACTER*(MXNAME) MMNAME
      CHARACTER MMTYP
      CHARACTER*80 DUMLIN
      character*2048 OUTPUT, LCOUTPUT

      CHARACTER*(MXSTLN) CMDTBL(15), SELTBL(15), LISTBL(38)
      SAVE CMDTBL, SELTBL, LISTBL, KINVC, KINVS
C      --CMDTBL - the valid commands table
C      --SELTBL - the valid SELECT options table
C      --LISTBL - the valid LIST/PRINT options table

C   --Command table follows.  Remember to change the dimensioned size when
C   --changing the table.
      DATA CMDTBL /
     1  'SELECT  ', 'LIST    ', 'PRINT   ', 'LIMITS  ',
     2  'MINMAX  ', 'CHECK   ', 'HELP    ', 'MAP     ',
     3  'EXIT    ', 'MAXERRS ', 'END     ', 'QUIT    ',
     4  'PRECISION','OUTPUT  ',
     5  '        ' /
      DATA SELTBL /
     1  'NODES   ', 'ELEMENTS', 'BLOCKS  ', 'MATERIAL',
     2  'NSETS   ', 'SSETS   ',
     3  'READ    ', 'STEP    ', 'TIME    ',
     4  'GVARS   ', 'NVARS   ', 'EVARS   ', 'NSVARS  ', 'SSVARS  ',
     5  '        ' /
      DATA LISTBL /
     1  'TITLE   ', 'VARS    ',
     2  'COORDINA', 'MAP     ', 'NMAP    ', 'NODEMAP ',
     3  'BLOCKS  ', 'MATERIAL', 'LINK    ', 'CONNECTI', 'ATTRIBUT',
     4  'NSETS   ', 'NNODES  ', 'NFACTORS', 'INVCON  ',
     5  'SSETS   ', 'SELEMS  ', 'SFACES  ', 'SFACTORS',
     6  'NAMES   ', 'TIMES   ', 'STEPS   ',
     7  'GVARS   ', 'GLOBALS ', 'GLOBNODE', 'GLOBELEM',
     8  'NVARS   ', 'NODALS  ', 'EVARS   ', 'ELEMENTS',
     9  'VERSION ', 'COMMANDS', 'NSVARS  ', 'NODESETVARS',
     $  'SSVARS  ', 'SIDESETVARS', 'FRAMES  ', '        ' /

      DATA KINVC,KINVS /0,0/
C   --Initialize

      OUTPUT = "grope.o"
      MAXERRS = 10

      LENE(0) = 0
      DO 100 I = 1, NELBLK
        LENE(I) = LENE(I-1) + NUMELB(I)
 100  CONTINUE

      LISNP(0) = NUMNP
      DO 110 I = 1, NUMNP
        LISNP(I) = I
 110  CONTINUE
      NLISEL(0) = NELBLK
      DO 120 I = 1, NELBLK
        NLISEL(I) = LENE(I) - LENE(I-1)
 120  CONTINUE
      LISEL(0) = NUMEL
      DO 130 I = 1, NUMEL
        LISEL(I) = I
 130  CONTINUE
      LISNPS(0) = NUMNPS
      DO 140 I = 1, NUMNPS
        LISNPS(I) = I
 140  CONTINUE
      LISESS(0) = NUMESS
      DO 150 I = 1, NUMESS
        LISESS(I) = I
 150  CONTINUE
      IF (EXODUS) THEN
        LISGV(0) = NVARGL
        DO 170 I = 1, NVARGL
          LISGV(I) = I
 170    CONTINUE
        LISNV(0) = NVARNP
        DO 180 I = 1, NVARNP
          LISNV(I) = I
 180    CONTINUE
        LISEV(0) = NVAREL
        DO 190 I = 1, NVAREL
          LISEV(I) = I
 190    CONTINUE
        LISMV(0) = NVARNS
        DO 191 I = 1, NVARNS
          LISMV(I) = I
 191   CONTINUE
        LISSV(0) = NVARSS
        DO 192 I = 1, NVARSS
          LISSV(I) = I
 192   CONTINUE
      END IF

      mmname = ' '
      mmvar  = 0

C   --Read first time step variables

      IF (EXODUS) THEN
        NCSTEP = 999
        NSTEPNS = -1
        NSTEPSS = -1
        NSTEP = 1
        CALL TOSTEP (NSTEP, NUMELB, IDELB, ISEVOK,
     &    TIME, VARGL, VARNP, VAREL)
      END IF

      WRITE (*, *)
      CALL PRTERR ('CMDREQ',
     & 'Use "precision low|normal|high|#" to control" output precision')

      if (domape .and. domapn) then
        call PRTERR('CMDREQ',
     *    'Nodes and Elements using Global Ids')
      else if (domape) then
        call PRTERR('CMDREQ',
     *    'Elements use Global Ids, Node Ids are Local')
      else if (domapn) then
        call PRTERR('CMDREQ',
     *    'Element use Local Ids, Node Ids are Global')
      else
        call PRTERR('CMDREQ',
     *    'Nodes and Elements using Local Ids')
      end if

 200  CONTINUE

C   --Read command line

      WRITE (*, *)
      CALL FREFLD (0, 0, 'GROPE> ', MAXFLD,
     &  IOSTAT, NUMFLD, INTYP, CFIELD, IFIELD, RFIELD)
      IF (IOSTAT .LT. 0) GOTO 280
      IF (NUMFLD .EQ. 0) GOTO 200
      INTYP(MIN(MAXFLD,NUMFLD)+1) = -999

      IFLD = 1
      CALL FFCHAR (IFLD, INTYP, CFIELD, ' ', WORD)
      CALL ABRSTR (VERB, WORD, CMDTBL)
      IF ((VERB .EQ. ' ') .AND. (WORD .NE. ' ')) THEN
        VERB = '*'
        IFLD = IFLD - 1
      END IF

      IF (VERB .EQ. 'SELECT') THEN
        CALL FFCHAR (IFLD, INTYP, CFIELD, ' ', WORD)
        CALL ABRSTR (LISTYP, WORD, SELTBL)
        IF (LISTYP .EQ. ' ') LISTYP = WORD

      ELSE IF ((VERB .EQ. 'LIST') .OR. (VERB .EQ. 'PRINT')) THEN
        CALL FFCHAR (IFLD, INTYP, CFIELD, ' ', WORD)
        IF (VERB .EQ. 'PRINT') THEN
          IF ((WORD .EQ. ' ')
     &      .OR. (WORD .EQ. 'ON') .OR. (WORD .EQ. 'OFF')) THEN
            CALL PRTERR ('CMDERR',
     &        'Please use the new PRINT command'
     &        // ' (e.g., PRINT NAMES)')
            GOTO 270
          END IF
        END IF
        CALL ABRSTR (LISTYP, WORD, LISTBL)
        IF (LISTYP .EQ. ' ') LISTYP = WORD

      ELSE IF (VERB .EQ. '*') THEN
        CALL FFCHAR (IFLD, INTYP, CFIELD, ' ', WORD)
        CALL ABRSTR (LISTYP, WORD, LISTBL)
        IF (LISTYP .EQ. ' ') THEN
          CALL ABRSTR (LISTYP, WORD, SELTBL)
          IF (LISTYP .NE. ' ') THEN
            CALL PRTERR ('CMDREQ', 'Please use the SELECT command')
            VERB = 'SELECT'
          ELSE
            LISTYP = WORD
          END IF
        END IF
      END IF

      IF (VERB .EQ. 'PRINT') THEN
        IF (NPRT .LE. 0) THEN
          CALL PRTERR ('CMDERR', 'Print file cannot be opened')
          GOTO 270
        END IF

        IF (.NOT. ANYPRT) THEN

C         --Set up the print file

          OPEN (unit=nprt, file=OUTPUT, IOSTAT=IERR)
          IF (IERR .NE. 0) THEN
            CALL PRTERR ('CMDERR', 'Print file cannot be opened')
            NPRT = -1
            GOTO 270
          END IF

          CALL BANNER (NPRT, QAINFO,
     &      ' ', ' ', ' ')
          CALL PRINIT ('N', NPRT, DBNAME, TITLE,
     &      NDIM, NUMNP, NUMEL, NELBLK,
     &      NUMNPS, LNPSNL, LNPSDF, NUMESS, LESSEL, LESSNL, LESSDF,
     &      NVARGL, NVARNP, NVAREL, NVARNS, NVARSS)

          ANYPRT = .TRUE.
        END IF

        NOUT = NPRT
      ELSE
        NOUT = NCRT
      END IF

      DUMLIN = ' '

C *** GENESIS Print Commands ***

      IF ((VERB .EQ. 'SELECT') .OR.
     &  (FFEXST (IFLD, INTYP) .AND. ((VERB .EQ. '*')
     &  .OR. (VERB .EQ. 'LIST') .OR. (VERB .EQ. 'PRINT')))) THEN

        IF (LISTYP .EQ. 'NODES') THEN
          IF (VERB .EQ. '*') VERB = 'SELECT'
          CALL CKNONE (NUMNP, .FALSE., 'nodes', *270)

          if (FFMATC (IFLD, INTYP, CFIELD, 'NSET', 4) .OR.
     *      FFMATC (IFLD, INTYP, CFIELD, 'NODESET', 7)) THEN
            CALL RIXID (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &        'nodal point set ID',
     &        NUMNPS, IDNPS, LISNPS(0), LISNPS(1), *270)
            if (lisnps(0) .gt. 0) then
              call selset(lisnp(0), lisnp(1),
     *          numnps, lisnps, lnpsnl,
     *          idnps, nnnps, ixnnps, ltnnps, "nodes")
            end if

          else if (FFMATC (IFLD, INTYP, CFIELD, 'BLOCK', 3) .OR.
     *        FFMATC (IFLD, INTYP, CFIELD, 'MATERIAL', 3)) THEN
            CALL MDRSRV ('SCRSEL', KLELB, 1+NELBLK)
            CALL MDRSRV ('SCR',    KSCR,  NUMNP)
            CALL MDSTAT (NERR, MEM)
            IF (NERR .GT. 0) GOTO 280

            CALL RIXID (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &        'element block ID',
     &        NELBLK, IDELB, IA(KLELB), IA(KLELB+1), *205)
 205        continue
            if (IA(KLELB) .gt. 0) then
              call selblk(lisnp(0), lisnp(1),
     *          nelblk, IA(KLELB), numelb, numlnk, link,
     *          A(KSCR), numnp, ebtype)
            end if
            CALL MDDEL ('SCRSEL')
            CALL MDDEL ('SCR')
          else
            CALL RMIXINT (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &        'node number', NUMNP, LISNP(0), LISNP(1), MAPND, *270)
          end if

        ELSE IF ((VERB .NE. 'SELECT')
     &      .AND. (LISTYP .EQ. 'COORDINA')) THEN
          IF (VERB .EQ. '*') VERB = 'LIST'
          CALL CKNONE (NUMNP, .FALSE., 'nodes', *270)
          CALL CKNONE (NDIM, .FALSE., 'coordinates', *270)

          CALL RMIXINT (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &      'node number', NUMNP, LISNP(0), LISNP(1), MAPND, *270)

          ELSE IF ((LISTYP .EQ. 'ELEMENTS')
     &      .OR. ((VERB .NE. 'SELECT')
     &      .AND. ((LISTYP .EQ. 'LINK') .OR. (LISTYP .EQ. 'CONNECTI')
     &      .OR. (LISTYP .EQ. 'ATTRIBUT')))) THEN
          IF (VERB .EQ. '*') VERB = 'LIST'
          CALL CKNONE (NUMEL, .FALSE., 'elements', *270)

          CALL MDRSRV ('SCRSEL', KLEL, 1+NUMEL)
          CALL MDSTAT (NERR, MEM)
          IF (NERR .GT. 0) GOTO 280

          if (FFMATC (IFLD, INTYP, CFIELD, 'SSET', 4) .OR.
     *      FFMATC (IFLD, INTYP, CFIELD, 'SIDESET', 7)) THEN
            CALL RIXID (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &        'side set ID',
     &        NUMESS, IDESS, LISESS(0), LISESS(1), *210)
            if (lisess(0) .gt. 0) then
              call selset(IA(KLEL), IA(KLEL+1),
     *          numess, lisess, lessel,
     *          idess, neess, ixeess, lteess, "elements")
            end if
          else
            CALL RMIXINT (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &        'element number', NUMEL, IA(KLEL), IA(KLEL+1), MAPEL,
     *        *210)
          end if
 210      CONTINUE

          CALL DBSBEL (NELBLK, NUMEL, LENE, A(KLEL), NLISEL, LISEL)

          CALL MDDEL ('SCRSEL')

        ELSE IF ((LISTYP .EQ. 'BLOCKS')
     &      .OR. (LISTYP .EQ. 'MATERIAL')) THEN
          IF (VERB .EQ. '*') VERB = 'LIST'
          CALL CKNONE (NELBLK, .FALSE., 'element blocks', *270)

          CALL MDRSRV ('SCRSEL', KLELB, 1+NELBLK)
          CALL MDSTAT (NERR, MEM)
          IF (NERR .GT. 0) GOTO 280

          CALL RIXID (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &      'element block ID',
     &      NELBLK, IDELB, IA(KLELB), IA(KLELB+1), *220)
 220      CONTINUE

          CALL DBSELB (NELBLK, NUMEL, LENE, A(KLELB),
     &      NLISEL, LISEL)

          CALL MDDEL ('SCRSEL')

        ELSE IF (LISTYP .EQ. 'NSETS') THEN
          NSTEPNS = -1
          IF (VERB .EQ. '*') VERB = 'LIST'
          CALL CKNONE (NUMNPS, .FALSE., 'nodal point sets', *270)

          CALL RIXID (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &      'nodal point set ID',
     &      NUMNPS, IDNPS, LISNPS(0), LISNPS(1), *270)

        ELSE IF (LISTYP .EQ. 'SSETS') THEN
          NSTEPSS = -1
          IF (VERB .EQ. '*') VERB = 'LIST'
          CALL CKNONE (NUMESS, .FALSE., 'element side sets', *270)

          CALL RIXID (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &      'element side set ID',
     &      NUMESS, IDESS, LISESS(0), LISESS(1), *270)

C *** EXODUS Movement Commands ***

        ELSE IF (((VERB .EQ. 'SELECT') .OR. (VERB .EQ. '*'))
     &      .AND. ((LISTYP .EQ. 'READ') .OR. (LISTYP .EQ. 'STEP')
     &      .OR. (LISTYP .EQ. 'TIME'))) THEN
          IF (VERB .EQ. '*') VERB = 'SELECT'
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NSTEPS, .FALSE., 'time steps', *270)

          IF (LISTYP .EQ. 'READ') THEN
            CALL FFINTG (IFLD, INTYP, IFIELD,
     &        'number of steps to read', 1, N, *230)
            NSTEP = MAX (1, NCSTEP + N)
          ELSE IF (LISTYP .EQ. 'STEP') THEN
            CALL FFINTG (IFLD, INTYP, IFIELD,
     &        'step number', NCSTEP, N, *230)
            NSTEP = N
          ELSE IF (LISTYP .EQ. 'TIME') THEN
            CALL FFREAL (IFLD, INTYP, RFIELD,
     &        'time step time', TIME, T, *230)
            NSTEP = LOCREA (T, NSTEPS, TIMES)
          END IF

          CALL TOSTEP (NSTEP, NUMELB, IDELB, ISEVOK, TIME,
     &      VARGL, VARNP, VAREL)

 230      CONTINUE
          CALL PRSTEP ('*', NOUT, TIME, NCSTEP, NSTEPS)

C *** EXODUS Print Commands ***

        ELSE IF (LISTYP .EQ. 'GVARS') THEN
          IF (VERB .EQ. '*') VERB = 'SELECT'
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NVARGL, .FALSE., 'global variables', *270)

          CALL RIXWRD (DUMLIN, IFLD, INTYP, CFIELD,
     &      'global variable name', NVARGL, NAMOGV,
     &      LISGV(0), LISGV(1), *270)

        ELSE IF (LISTYP .EQ. 'NVARS') THEN
          IF (VERB .EQ. '*') VERB = 'SELECT'
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NVARNP, .FALSE., 'nodal variables', *270)

          CALL RIXWRD (DUMLIN, IFLD, INTYP, CFIELD,
     &      'nodal variable name', NVARNP, NAMONV,
     &      LISNV(0), LISNV(1), *270)

        ELSE IF ((VERB .NE. 'SELECT')
     &      .AND. (LISTYP .EQ. 'NODALS')) THEN
          IF (VERB .EQ. '*') VERB = 'LIST'
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NUMNP, .FALSE., 'nodes', *270)

          CALL RMIXINT (DUMLIN, IFLD, INTYP, CFIELD, IFIELD,
     &      'node number', NUMNP, LISNP(0), LISNP(1), MAPND, *270)

        ELSE IF (LISTYP .EQ. 'EVARS') THEN
          IF (VERB .EQ. '*') VERB = 'SELECT'
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NVAREL, .FALSE., 'element variables', *270)

          CALL RIXWRD (DUMLIN, IFLD, INTYP, CFIELD,
     &      'element variable name', NVAREL, NAMOEV,
     &      LISEV(0), LISEV(1), *270)

        ELSE IF (LISTYP .EQ. 'NSVARS') THEN
          NSTEPNS = -1
          IF (VERB .EQ. '*') VERB = 'SELECT'
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NVARNS, .FALSE., 'nodeset variables', *270)

          CALL RIXWRD (DUMLIN, IFLD, INTYP, CFIELD,
     &      'nodeset variable name', NVARNS, NAMONS,
     &      LISMV(0), LISMV(1), *270)

        ELSE IF (LISTYP .EQ. 'SSVARS') THEN
          NSTEPSS = -1
          IF (VERB .EQ. '*') VERB = 'SELECT'
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NVARSS, .FALSE., 'sideset variables', *270)

          CALL RIXWRD (DUMLIN, IFLD, INTYP, CFIELD,
     &      'sideset variable name', NVARSS, NAMOSS,
     &      LISSV(0), LISSV(1), *270)

        ELSE IF (VERB .EQ. 'SELECT') THEN
          CALL SHOCMD ('SELECT Options:', SELTBL)
        END IF
      END IF

      IF (VERB .EQ. '*') VERB = 'LIST'

      IF (VERB .EQ. 'SELECT') THEN
        CONTINUE

      ELSE IF ((VERB .EQ. 'LIST') .OR. (VERB .EQ. 'PRINT')) THEN

        IF (listyp .eq. 'GLOBNODE') THEN
 233      continue
          if (ffexst(ifld, intyp)) THEN
            call ffintg(ifld, intyp, ifield, 'Global ID',
     *        0, IDGLO, *270)
            call selmap(nout, 'node', idglo, numnp, mapnd)
            go to 233
          end if

        ELSE IF (listyp .eq. 'GLOBELEM') THEN
 234      continue
          if (ffexst(ifld, intyp)) then
            call ffintg(ifld, intyp, ifield, 'Global ID',
     *        0, IDGLO, *270)
            call selmap(nout, 'element', idglo, numel, mapel)
            goto 234
          end if

        ELSE IF ((LISTYP .EQ. 'TITLE') .OR. (LISTYP .EQ. 'VARS')) THEN
          IF (EXODUS) THEN
            CALL PRINIT ('NTSICV', NOUT, DBNAME, TITLE,
     &        NDIM, NUMNP, NUMEL, NELBLK,
     &        NUMNPS, LNPSNL, LNPSDF,
     &        NUMESS, LESSEL, LESSNL, LESSDF,
     &        NVARGL, NVARNP, NVAREL, NVARNS, NVARSS)
          ELSE
            CALL PRINIT ('NTSIC', NOUT, DBNAME, TITLE,
     &        NDIM, NUMNP, NUMEL, NELBLK,
     &        NUMNPS, LNPSNL, LNPSDF,
     &        NUMESS, LESSEL, LESSNL, LESSDF,
     &        NVARGL, NVARNP, NVAREL, NVARNS, NVARSS)
          END IF

        ELSE IF (LISTYP .EQ. 'VERSION') THEN
          CALL PRVERS (NDB, NOUT)

        ELSE IF (LISTYP .EQ. 'COORDINA') THEN
          CALL CKNONE (NDIM, .FALSE., 'coordinates', *270)
          CALL CKNONE (NUMNP, .FALSE., 'nodes', *270)
          CALL CKNONE (LISNP(0), .TRUE., 'nodes', *270)

          CALL PRXYZ ('*', NOUT, NDIM, NAMECO, NUMNP, LISNP, CORD,
     *      MAPND, DOMAPN)

        ELSE IF (LISTYP .EQ. 'MAP') THEN
          CALL CKNONE (NUMEL, .FALSE., 'elements', *270)

          CALL PRMAP ('*', NOUT, 'Element', NUMEL, DBMAPEL)

        ELSE IF (LISTYP .EQ. 'NMAP' .OR. LISTYP .EQ. 'NODEMAP') THEN
          CALL CKNONE (NUMNP, .FALSE., 'nodes', *270)

          CALL PRMAP ('*', NOUT, 'Node', NUMNP, DBMAPND)

        ELSE IF ((LISTYP .EQ. 'BLOCKS') .OR. (LISTYP .EQ. 'MATERIAL')
     &      .OR. (LISTYP .EQ. 'LINK') .OR. (LISTYP .EQ. 'CONNECTI')
     &      .OR. (LISTYP .EQ. 'ATTRIBUT')) THEN
          CALL CKNONE (NELBLK, .FALSE., 'element blocks', *270)
          CALL CKNONE (NLISEL(0), .TRUE., 'element blocks', *270)

          IF ((LISTYP .EQ. 'BLOCKS')
     &      .OR. (LISTYP .EQ. 'MATERIAL')) THEN
            IF (EXODUS) THEN
              OPT = 'NV'
            ELSE
              OPT = 'N'
            END IF
          ELSE IF ((LISTYP .EQ. 'LINK')
     &        .OR. (LISTYP .EQ. 'CONNECTI')) THEN
            OPT = 'C'
          ELSE IF (LISTYP .EQ. 'ATTRIBUT') THEN
            OPT = 'A'
          END IF

          IF (INDEX (OPT, 'V') .GT. 0) THEN
            CALL MDRSRV ('XLISEV', KXLSEV, NVAREL)
            CALL MDSTAT (NERR, MEM)
            IF (NERR .GT. 0) GOTO 280
          END IF

          CALL PRELB (OPT, NOUT, NELBLK, NLISEL, LISEL,
     &      IDELB, LENE, NUMLNK, NUMATR, LINK, ATRIB,
     &      EBTYPE, EBNAME, NVAREL, NAMIEV, ISEVOK, A(KXLSEV),
     *      ATNAME, MAPND, DOMAPN, MAPEL, DOMAPE)

          IF (INDEX (OPT, 'V') .GT. 0) THEN
            CALL MDDEL ('XLISEV')
          END IF

        ELSE IF ((LISTYP .EQ. 'NSETS')
     &      .OR. (LISTYP .EQ. 'NNODES')
     &      .OR. (LISTYP .EQ. 'NFACTORS')) THEN
          CALL CKNONE (NUMNPS, .FALSE., 'nodal point sets', *270)
          CALL CKNONE (LISNPS(0), .TRUE., 'nodal point sets', *270)

          IF (LISTYP .EQ. 'NSETS') THEN
             if (exodus) then
                opt = 'V'
             else
                OPT = ' '
             end if
          ELSE IF (LISTYP .EQ. 'NNODES') THEN
            OPT = 'N'
          ELSE IF (LISTYP .EQ. 'NFACTORS') THEN
            OPT = 'F'
          END IF
          IF (INDEX (OPT, 'V') .GT. 0) THEN
            CALL MDRSRV ('XLISNV', KXLSNV, NVARNS)
            CALL MDSTAT (NERR, MEM)
            IF (NERR .GT. 0) GOTO 280
          END IF
          CALL PRNPS (OPT, NOUT, NUMNPS, LISNPS, LNPSNL,
     &         IDNPS, NNNPS, NDNPS, IXNNPS, IXDNPS, LTNNPS, FACNPS,
     *         NSNAME, nvarns, namins, isnsvok, a(kxlsnv),
     $         MAPND, DOMAPN)
          IF (INDEX (OPT, 'V') .GT. 0) THEN
            CALL MDDEL ('XLISNV')
          END IF

        ELSE IF ((LISTYP .EQ. 'SSETS')
     &      .OR. (LISTYP .EQ. 'SELEMS')
     &      .OR. (LISTYP .EQ. 'SFACES')
     &      .OR. (LISTYP .EQ. 'SFACTORS')) THEN
          CALL CKNONE (NUMESS, .FALSE., 'element side sets', *270)
          CALL CKNONE (LISESS(0), .TRUE., 'element side sets', *270)

          IF (LISTYP .EQ. 'SSETS') THEN
             if (exodus) then
                opt = 'V'
             else
                OPT = ' '
             end if
          ELSE IF (LISTYP .EQ. 'SELEMS') THEN
            OPT = 'E'
          ELSE IF (LISTYP .EQ. 'SFACES') THEN
            OPT = 'N'
          ELSE IF (LISTYP .EQ. 'SFACTORS') THEN
            OPT = 'F'
          END IF
          IF (INDEX (OPT, 'V') .GT. 0) THEN
            CALL MDRSRV ('XLISSV', KXLSSV, NVARSS)
            CALL MDSTAT (NERR, MEM)
            IF (NERR .GT. 0) GOTO 280
          END IF
          IF (INDEX (OPT, 'F') .GT. 0) then
            CALL MDRSRV ('NDFSID', KNDFSID, LESSEL)
            CALL MDRSRV ('NODSID', KNODSID, LESSNL)
            CALL MDSTAT (NERR, MEM)
            IF (NERR .GT. 0) GOTO 280
          END IF

          CALL PRESS (OPT, NOUT, NUMESS, LISESS, LESSEL, LESSNL,
     &         IDESS, NEESS, NNESS, IXEESS, IXNESS,
     &         LTEESS, LTSESS, FACESS, SSNAME,
     $         nvarss, namiss, isssvok, a(kxlssv),
     &         a(kndfsid), a(knodsid),MAPEL, MAPND, DOMAPE, DOMAPN)
          IF (INDEX (OPT, 'V') .GT. 0) THEN
            CALL MDDEL ('XLISSV')
          END IF
          IF (INDEX (OPT, 'F') .GT. 0) THEN
            CALL MDDEL ('NDFSID')
            CALL MDDEL ('NODSID')
          END IF

        ELSE IF (LISTYP .EQ. 'INVCON') THEN
           CALL FFCHAR (IFLD, INTYP, CFIELD,' ', WORD)
           doblk = .false.
           doele = .false.
           IF (MATSTR(WORD, 'ELEMENTS', 1)) THEN
              DOELE = .true.
           ELSE IF (MATSTR(WORD, 'BLOCKS', 1)) THEN
              DOBLK = .true.
           ELSE
              DOELE = .true.
              DOBLK = .true.
           END IF
           if (kinvc .eq. 0) then
              CALL MDRSRV ('INVCON', KINVC, NELBLK*NUMNP)
              CALL MDRSRV ('INVSCR', KINVS, 2*NELBLK)
              CALL MDRSRV ('NODMAP', KNDMP, 2*NUMNP)
              CALL MDSTAT (NERR, MEM)
              IF (NERR .GT. 0) GOTO 280
           end if

           call invcon(ia, nelblk, idelb, numelb, numlnk, link, numnp,
     *          ia(kinvc), ia(kinvs), ia(kndmp), lisnp, NOUT, MAPND,
     $          MAPEL, DOMAPN, DOMAPE, DOBLK, DOELE, ebtype)

        ELSE IF (LISTYP .EQ. 'QA') THEN

          CALL PRQA ('*', NOUT, NQAREC, QAREC, NINFO, INFO)

C *** EXODUS Print Commands ***

        ELSE IF (LISTYP .EQ. 'NAMES') THEN
          CALL CKEXOD (EXODUS, *270)

          CALL PRNAME ('*', NOUT,
     &         NAMIGV, NAMINV, NAMIEV, NAMINS, NAMISS)

        ELSE IF ((LISTYP .EQ. 'TIMES')
     &      .OR. (LISTYP .EQ. 'ALLTIMES')) THEN
          IF (LISTYP .EQ. 'ALLTIMES') CALL PRTERR ('CMDREQ',
     &      'Please use the LIST TIMES command')
          CALL CKEXOD (EXODUS, *270)

          CALL PRTIMS ('NT', NOUT, NSTEPS, TIMES)

        ELSE IF (LISTYP .EQ. 'STEPS') THEN
          CALL CKEXOD (EXODUS, *270)

          CALL PRTIMS ('NM', NOUT, NSTEPS, TIMES)

        ELSE IF ((LISTYP .EQ. 'GVARS')
     &      .OR. (LISTYP .EQ. 'GLOBALS')) THEN
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NVARGL, .FALSE., 'global variables', *270)
          CALL CKNONE (LISGV(0), .TRUE., 'global variables', *270)

          CALL PRSTEP ('*', NOUT, TIME, NCSTEP, NSTEPS)

          CALL PRGLOB ('*', NOUT, NVARGL, LISGV, NAMIGV, VARGL)

        ELSE IF ((LISTYP .EQ. 'NVARS')
     &      .OR. (LISTYP .EQ. 'NODALS')) THEN
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NUMNP, .FALSE., 'nodes', *270)
          CALL CKNONE (NVARNP, .FALSE., 'nodal variables', *270)
          CALL CKNONE (LISNV(0), .TRUE., 'nodal variables', *270)

          CALL PRSTEP ('*', NOUT, TIME, NCSTEP, NSTEPS)

          CALL PRNODE ('*', NOUT, NUMNP, LISNP, NVARNP, LISNV, NAMINV,
     &      VARNP, MAPND, DOMAPN)

        ELSE IF ((LISTYP .EQ. 'EVARS')
     &      .OR. (LISTYP .EQ. 'ELEMENTS')) THEN
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NUMEL, .FALSE., 'elements', *270)
          CALL CKNONE (NVAREL, .FALSE., 'element variables', *270)
          CALL CKNONE (LISEV(0), .TRUE., 'element variables', *270)

          CALL PRSTEP ('*', NOUT, TIME, NCSTEP, NSTEPS)

          CALL PRELEM ('*', NOUT, NELBLK, NUMEL, NLISEL, LISEL, LENE,
     &      NVAREL, LISEV, NAMIEV, ISEVOK, VAREL, max(1,nvarel),
     *      MAPEL, DOMAPE)

        ELSE IF ((LISTYP .EQ. 'NSVARS')
     &      .OR. (LISTYP .EQ. 'NODESETVARS')) THEN
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NUMNPS, .FALSE., 'nodesets', *270)
          CALL CKNONE (NVARNS, .FALSE., 'nodeset variables', *270)
          CALL CKNONE (LISMV(0), .TRUE., 'nodeset variables', *270)

          CALL PRSTEP ('*', NOUT, TIME, NCSTEP, NSTEPS)

          CALL PRNSV (NOUT, NCSTEP, NUMNPS, LISNPS, LNPSNL,
     &         IDNPS, NNNPS, IXNNPS, LTNNPS, NSNAME,
     $         NVARNS, LISMV(0), NAMINS, ISNSVOK, VARNS, max(1,nvarns),
     *         MAPND, DOMAPN)

        ELSE IF ((LISTYP .EQ. 'SSVARS')
     &      .OR. (LISTYP .EQ. 'SIDESETVARS')) THEN
          CALL CKEXOD (EXODUS, *270)
          CALL CKNONE (NUMESS, .FALSE., 'sidesets', *270)
          CALL CKNONE (NVARSS, .FALSE., 'sideset variables', *270)
          CALL CKNONE (LISSV(0), .TRUE., 'sideset variables', *270)

          CALL PRSTEP ('*', NOUT, TIME, NCSTEP, NSTEPS)

          CALL PRSSV (NOUT, NCSTEP, NUMESS, LISESS, LESSEL,
     &         IDESS, NEESS, IXEESS, LTEESS, LTSESS, SSNAME,
     $         NVARSS, LISSV(0), NAMISS, ISSSVOK, VARSS, max(1,nvarss),
     *         MAPEL, DOMAPE)

C ... Coordinate Frames
        ELSE IF (LISTYP .EQ. 'FRAMES') THEN
          CALL PRFRM (NOUT)
        ELSE IF (LISTYP .EQ. 'COMMANDS') THEN
          CALL SHOCMD ('COMMAND Options:', CMDTBL)
        ELSE
          CALL SHOCMD ('LIST/PRINT Options:', LISTBL)
        END IF

C *** Miscellaneous Commmands ***

      ELSE IF (VERB .EQ. 'LIMITS') THEN
        call limits(ndim, numnp, cord)

      ELSE IF (VERB .EQ. 'MAP') THEN
        call prterr('CMDERR',
     *    'The map nodes|elements|both command is no longer'
     *    // ' supported.  The mapping of nodes/elements is'
     *    // ' selected at program startup with the -map '
     *    // ' or -nomap option.')
c$$$        CALL FFCHAR (IFLD, INTYP, CFIELD,'BOTH', WORD)
c$$$        CALL FFONOF (IFLD, INTYP, CFIELD, MAPTMP, *270)
c$$$
c$$$        IF (MATSTR(WORD, 'ELEMENTS', 1)) THEN
c$$$          DOMAPE = MAPTMP
c$$$        ELSE IF (MATSTR(WORD, 'NODES', 1)) THEN
c$$$          DOMAPN = MAPTMP
c$$$        ELSE IF (MATSTR(WORD, 'BOTH', 1)) THEN
c$$$          DOMAPE = MAPTMP
c$$$          DOMAPN = MAPTMP
c$$$        END IF

      ELSE IF (VERB .EQ. 'MAXERRS') THEN
         CALL FFINTG (IFLD, INTYP, IFIELD,
     &        'maximum errors to print; 0 for all', 10, MAXERRS, *235)
 235     continue

      ELSE IF (VERB .EQ. 'OUTPUT') THEN
        CALL FFCHAR (IFLD, INTYP, CFIELD, ' ', OUTPUT)
C ... Filename will be converted to lowercase -- FREFLD returns
C     everything in uppercase Assume user wanted lowercase; if they
C     didn't, need to rewrite frefld to return mixed case.
        call lowstr(lcoutput,output)
        if (anyprt) then
          close (nprt)
        end if
        OPEN (unit=nprt, file=lcoutput, IOSTAT=IERR)
        IF (IERR .NE. 0) THEN
          CALL PRTERR ('CMDERR', 'Print file cannot be opened')
          NPRT = -1
          GOTO 270
        END IF
        ANYPRT = .TRUE.

      ELSE IF (VERB .EQ. 'CHECK') THEN

        L = MAX (NUMEL, NUMNPS, LNPSNL, NUMESS, LESSEL, LESSNL, NUMNP)
        CALL MDRSRV ('ICHECK', KICHECK, L)
        CALL MDRSRV ('ISCR',   KISCR, LESSEL)
        CALL MDRSRV ('RCHECK', KRCHECK, NUMNP)
        CALL MDSTAT (NERR, MEM)
        IF (NERR .GT. 0) GOTO 240

        CALL CKMAP (NUMNP, DBMAPND, IA(KICHECK), 'Node   ')
        CALL CKMAP (NUMEL, DBMAPEL, IA(KICHECK), 'Element')
        CALL CKELB (NELBLK, NUMEL, NUMNP, EBTYPE,
     &    IDELB, NUMELB, NUMLNK, NUMATR, LINK, ATRIB, ATNAME,
     &       IA(KICHECK), MAPND)
        CALL CKNPS (NUMNPS, LNPSNL, NUMNP,
     &    IDNPS, NNNPS, IXNNPS, LTNNPS, FACNPS, A(KICHECK))
        CALL CKESS (NUMESS, LESSEL, LESSNL, NUMEL, NUMNP,
     &    IDESS, NEESS, NNESS, IXEESS, IXNESS,
     &    LTEESS, LTSESS, FACESS,
     *    A(KISCR), A(KICHECK), A(KRCHECK), NDIM,
     *    MAPEL, MAPND)

 240    CONTINUE
        CALL MDDEL ('ICHECK')
        CALL MDDEL ('RCHECK')

        IF (EXODUS) THEN
          DO 250 N = 1, NSTEPS
            NSTEP = N
            CALL TOSTEP (NSTEP, NUMELB, IDELB, ISEVOK,
     &        TIME, VARGL, VARNP, VAREL)
            IF (N .NE. NSTEP) GOTO 260
 250      CONTINUE
 260      CONTINUE

          NSTEP = 1
          CALL TOSTEP (NSTEP, NUMELB, IDELB, ISEVOK,
     &      TIME, VARGL, VARNP, VAREL)
        END IF

        WRITE (*, *)
        WRITE (*, 10000) 'Database check is completed'

      ELSE IF (VERB .EQ. 'MINMAX') THEN

        CALL RDMMAX (IFLD, INTYP, CFIELD,
     &    NAMIGV, NAMINV, NAMIEV,
     &    NAMOGV, NAMONV, NAMOEV,
     &    NCSTEP, MMSTEP, MMNAME, MMTYP, MMVAR, MMNUM, *270)

        IF (MMNUM .LT. 0) THEN
          CALL PRTERR ('CMDERR', 'All minimums and maximums'
     &      // ' for this variable have been displayed')
          GOTO 270
        END IF

        CALL PRMMAX (NOUT, MMSTEP, MMNAME, MMTYP, MMVAR, MMNUM,
     &    XMIN, XMAX, NUMELB, IDELB, ISEVOK, VARGL, VARNP, VAREL)

        IF (MMSTEP .EQ. 0) THEN
          NSTEP = 1
          CALL TOSTEP (NSTEP, NUMELB, IDELB, ISEVOK,
     &      TIME, VARGL, VARNP, VAREL)
        END IF

C *** Miscellaneous Commmands ***

      ELSE IF (VERB .EQ. 'HELP') THEN
        ISON = HELP ('GROPE', 'COMMANDS', CFIELD(IFLD))
        IF (.NOT. ISON)
     &    CALL SHOCMD ('COMMANDS', CMDTBL)

      ELSE IF (VERB .EQ. 'PRECISION') THEN
         if (FFMATC (IFLD, INTYP, CFIELD, 'HIGH', 1)) THEN
            IPREC = 9
         else if (FFMATC (IFLD, INTYP, CFIELD, 'LOW', 1) .OR.
     $           FFMATC (IFLD, INTYP, CFIELD, 'NORMAL', 1)) THEN
            IPREC = 4
         else if (ffexst(ifld, intyp)) THEN
            call ffintg(ifld, intyp, ifield, 'Precision',
     *        4, IPREC, *270)
         else
            CALL PRTERR ('CMDERR',
     &        'Syntax: PRECISION high|low|normal|0..9')
            GOTO 270
         end if
         if (IPREC .gt. 16) then
            CALL PRTERR ('CMDERR',
     &        'Maximum precision is 16.')
            IPREC = 16
         end if
         if (IPREC .le. 0) then
            CALL PRTERR ('CMDERR',
     &        'Precision must be positive.')
            GOTO 270
         end if
         CALL SETPRC(IPREC,1)

      ELSE IF ((VERB .EQ. 'EXIT') .OR. (VERB .EQ. 'END')
     &    .OR. (VERB .EQ. 'QUIT')) THEN
        CALL SCNEOF
        GOTO 280

      ELSE
        CALL PRTERR ('CMDERR', '"' // VERB(:LENSTR(VERB))
     &    // '" is an invalid command')
      END IF

 270  CONTINUE
      GOTO 200

 280  CONTINUE
      RETURN
10000 FORMAT (1X, 5A)
      END

max_stars_repo_name: mathstuf/seacas

max_stars_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_issues_repo_name: mathstuf/seacas

max_issues_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_forks_repo_name: mathstuf/seacas

max_forks_repo_licenses: BSD-3-Clause NetCDF Zlib MIT


module test

interface test_value
    module procedure test_value_dp
    module procedure test_value_int
    module procedure test_value_real
    module procedure test_value_cp
    module procedure test_value_dcp
end interface

!--------------------------------------------------------------------------------------------------!
contains
!--------------------------------------------------------------------------------------------------!

subroutine test_value_dp(actual_value,expected_value,string)
implicit none

! Arguments
double precision :: actual_value, expected_value
character(len=*) :: string

! Local variables
double precision :: diff

if (dabs(expected_value).lt.1.0d-10) then
    diff = actual_value - expected_value
else
    diff = (actual_value-expected_value)/actual_value
endif

if (dabs(diff).gt.1.0d-10) then
    write(0,*) 'test FAILED for '//trim(string)
    write(0,*) '    expected value: ',expected_value
    write(0,*) '    computed value: ',actual_value
    call error_exit(1)
else
    write(6,*) 'test passed for '//trim(string)
endif
return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine test_value_int(actual_value,expected_value,string)
implicit none

! Arguments
integer :: actual_value, expected_value
character(len=*) :: string

if (actual_value.ne.expected_value) then
    write(0,*) 'test FAILED for '//trim(string)
    write(0,*) '    expected value: ',expected_value
    write(0,*) '    computed value: ',actual_value
    call error_exit(1)
else
    write(6,*) 'test passed for '//trim(string)
endif
return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine test_value_real(actual_value,expected_value,string)
implicit none

! Arguments
real :: actual_value, expected_value
character(len=*) :: string

! Local variables
real :: diff

if (abs(expected_value).lt.1.0e-10) then
    diff = actual_value - expected_value
else
    diff = (actual_value-expected_value)/actual_value
endif

if (abs(diff).gt.1.0e-7) then
    write(0,*) 'test FAILED for '//trim(string)
    write(0,*) '    expected value: ',expected_value
    write(0,*) '    computed value: ',actual_value
    call error_exit(1)
else
    write(6,*) 'test passed for '//trim(string)
endif
return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine test_value_cp(actual_value,expected_value,string)
implicit none

! Arguments
complex :: actual_value, expected_value
character(len=*) :: string

! Local variables
complex :: diff

if (abs(expected_value).lt.1.0e-10) then
    diff = actual_value - expected_value
else
    diff = (actual_value-expected_value)/abs(actual_value)
endif

if (abs(diff).gt.1.0e-10) then
    write(0,*) 'test FAILED for '//trim(string)
    write(0,*) '    expected value: ',expected_value
    write(0,*) '    computed value: ',actual_value
    call error_exit(1)
else
    write(6,*) 'test passed for '//trim(string)
endif
return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine test_value_dcp(actual_value,expected_value,string)
implicit none

! Arguments
complex (kind=8) :: actual_value, expected_value
character(len=*) :: string

! Local variables
complex (kind=8) :: diff

if (abs(expected_value).lt.1.0d-10) then
    diff = actual_value - expected_value
else
    diff = (actual_value-expected_value)/abs(actual_value)
endif

if (abs(diff).gt.1.0d-10) then
    write(0,*) 'test FAILED for '//trim(string)
    write(0,*) '    expected value: ',expected_value
    write(0,*) '    computed value: ',actual_value
    call error_exit(1)
else
    write(6,*) 'test passed for '//trim(string)
endif
return
end subroutine

end module