!
! Extract_CrIS_TauCoeff_Subset
!
! Program to extract the CRIS channel subset from the individual
! CRIS band netCDF format ODPS data files.
!
! CREATION HISTORY:
!       Written by:     Yong Chen, 26-Oct-2009
!                       Yong.Chen@noaa.gov
!
!       based on Paul van Delst's Extract_IASI_TauCoeff_Subset.f90
!
!       Modified by:    David Groff, 14-Jun-2011
!                       david.groff@noaa.gov

PROGRAM Extract_CrIS_TauCoeff_Subset

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module usage
  USE Message_Handler,       ONLY: SUCCESS, FAILURE, WARNING, INFORMATION, &
                                   Display_Message, Program_Message
  USE Compare_Float_Numbers, ONLY: Compare_Float
  USE List_File_Utility,     ONLY: Integer_List_File_type, &
                                   Read_List_File, &
                                   Get_List_Size, Get_List_Entry
  USE ODPS_Define,           ONLY: ODPS_type, &
                                   Allocate_ODPS, Destroy_ODPS, Allocate_ODPS_OPTRAN
  USE ODPS_netCDF_IO,        ONLY: Inquire_ODPS_netCDF, &
                                   Read_ODPS_netCDF, &
                                   Write_ODPS_netCDF
  USE Subset_Define,         ONLY: Subset_type, &
                                   Subset_Destroy, &
                                   Subset_GetValue
  USE CRIS_Define,           ONLY: N_CRIS_BANDS, &
                                   N_CRIS_CHANNELS, &
                                   CrIS_BandName
  USE CRIS_Subset,           ONLY: N_CRIS_SUBSET_374, CRIS_SUBSET_374, CRIS_SUBSET_374_COMMENT, &
                                   N_CRIS_SUBSET_399, CRIS_SUBSET_399, CRIS_SUBSET_399_COMMENT, &
                                   N_CRIS_VALID_SUBSETS, CRIS_VALID_SUBSET_NAME, &
                                   CrIS_Subset_Index
  ! Disable implicit typing
  IMPLICIT NONE

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'Extract_CrIS_TauCoeff_Subset'
  CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = &

  INTEGER, PARAMETER :: SL = 256

  INTEGER, PARAMETER :: GROUP_1_MAX_COMPONENTS  = 8
  INTEGER, PARAMETER :: GROUP_2_MAX_COMPONENTS  = 5
  INTEGER, PARAMETER :: GROUP_1_MAX_PREDS       = 91
  INTEGER, PARAMETER :: GROUP_2_MAX_PREDS       = 52
  INTEGER, PARAMETER :: N_PREDICTOR_USED_OPTRAN = 6
  INTEGER, PARAMETER :: MAX_ORDER_OPTRAN        = 10

  ! ---------
  ! Variables
  ! ---------
  INTEGER :: err_stat   ;  CHARACTER(SL) :: err_msg
  INTEGER :: io_stat    ;  CHARACTER(SL) :: io_msg
  INTEGER :: alloc_stat ;  CHARACTER(SL) :: alloc_msg
  CHARACTER(256)  :: Message
  CHARACTER(256)  :: List_Filename
  CHARACTER(256)  :: In_Filename
  CHARACTER(256)  :: Out_Filename
  CHARACTER(256)  :: Profile_Set_Id
  CHARACTER(5000) :: Title
  CHARACTER(5000) :: History
  CHARACTER(5000) :: Comment
  CHARACTER(256)  :: Subset_Comment
  CHARACTER(20)   :: Sensor_ID
  INTEGER :: i, Set
  LOGICAL :: First_Band
  LOGICAL :: OPTRAN
  INTEGER :: n_Layers
  INTEGER :: n_Components
  INTEGER :: n_Absorbers
  INTEGER :: n_Channels
  INTEGER :: n_Coeffs
  INTEGER :: n_OPIndex
  INTEGER :: n_OCoeffs
  INTEGER :: Version
  INTEGER :: j, l, l1, l2
  INTEGER :: n_Subset_Channels
  INTEGER :: lch, ls, js, n_Out_Coeffs, j0, np, jp, k
  INTEGER :: n_Subset_Coeffs, n_total_Pred
  INTEGER :: n_orders, n_Subset_OCoeffs, n_Out_OCoeffs, los
  INTEGER :: n_values
  INTEGER, ALLOCATABLE :: idx(:), nmbr(:)
  INTEGER, ALLOCATABLE :: Subset_List(:)
  TYPE(Integer_List_File_type) :: User_Subset_List
  TYPE(ODPS_type) :: In_ODPS, Out_ODPS, Out_ODPS_f
  TYPE(Subset_type) :: Subset

  ! Output program header
  CALL Program_Message(PROGRAM_NAME, &
                       'Program to extract the CRIS channel SUBSET transmittance '//&
                       'coefficient data from the individual band netCDF '//&
                       'ODPS files and write them to a separate netCDF '//&
                       'datafile.', &
                       '$Revision$' )

  ! Select a subset set
  Select_Loop: DO
    ! ...Prompt user to select a subset set
    WRITE( *,'(/5x,"Select an CrIS channel subset")' )
    DO i = 1, N_CRIS_VALID_SUBSETS
      WRITE( *,'(10x,i1,") ",a)' ) i, CRIS_VALID_SUBSET_NAME(i)
    END DO
    WRITE( *,FMT='(5x,"Enter choice: ")',ADVANCE='NO' )
    READ( *,FMT='(i5)',IOSTAT=io_stat, IOMSG=io_msg ) set
    ! ...Check for I/O errors
    IF ( io_stat /= 0 ) THEN
      err_msg = 'Invalid input - '//TRIM(io_msg)
      CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
    END IF
    ! ...Check the input
    IF ( set < 1 .OR. set > N_CRIS_VALID_SUBSETS ) THEN
      err_msg = 'Invalid selection'
      CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
    ELSE
      EXIT Select_Loop
    END IF
  END DO Select_Loop

  ! Get the required channels list
  SELECT CASE ( Set )

    ! The 374 channel subset
    CASE (1)
      ! ...Allocate list array
      n_Subset_Channels = N_CRIS_SUBSET_374
      Subset_Comment    = CRIS_SUBSET_374_COMMENT
      ALLOCATE( subset_list(n_subset_channels), STAT=alloc_stat )!, ERRMSG=alloc_msg )
      IF ( alloc_stat /= 0 ) THEN
        err_msg = 'Error allocating Subset_List array - '!//TRIM(alloc_msg)
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF
      ! ...Fill values
      Subset_List = CRIS_SUBSET_374
      Sensor_ID   = 'cris374_npp'

    ! The 399 channel subset
    CASE (2)
      ! ...Allocate list array
      n_Subset_Channels = N_CRIS_SUBSET_399
      Subset_Comment    = CRIS_SUBSET_399_COMMENT
      ALLOCATE( subset_list(n_subset_channels), STAT=alloc_stat )!, ERRMSG=alloc_msg )
      IF ( alloc_stat /= 0 ) THEN
        err_msg = 'Error allocating Subset_List array - '!//TRIM(alloc_msg)
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF
      ! ...Fill values
      Subset_List = CRIS_SUBSET_399
      Sensor_ID   = 'cris399_npp'

    ! All the channels
    CASE(3)
      ! ...Allocate list array
      n_Subset_Channels = N_CRIS_CHANNELS
      Subset_Comment    = 'CRIS full channel set'
      ALLOCATE( subset_list(n_subset_channels), STAT=alloc_stat )!, ERRMSG=alloc_msg )
      IF ( alloc_stat /= 0 ) THEN
        err_msg = 'Error allocating Subset_List array - '!//TRIM(alloc_msg)
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF
      ! ...Fill values
      Subset_List = (/(l,l=1,N_CRIS_CHANNELS)/)
      Sensor_ID   = 'cris_npp'

    ! A user specified channel subset
    CASE (4)
      ! ...Get the list of channels required
      WRITE( *, FMT='(/5x,"Enter an CrIS channel subset list filename : ")', ADVANCE='NO' )
      READ( *,FMT='(a)' ) list_filename
      list_filename = ADJUSTL(list_filename)
      ! ...Read the channel subset list file
      err_stat = Read_List_File( list_filename, user_subset_list )
      IF ( err_stat /= SUCCESS ) THEN
        err_msg = 'Error reading channel subset list file '//TRIM(list_filename)
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF
      ! ...Retrieve the number of subset channels
      n_subset_channels = Get_List_Size( user_subset_list )
      IF ( n_subset_channels < 1 ) THEN
        err_msg = 'No channels listed in '//TRIM(list_filename)
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF
      ! ...Check the number of channels
      IF ( n_subset_channels < 1 .OR. n_subset_channels > N_CRIS_CHANNELS ) THEN
        err_msg = 'Number of channels listed in '//TRIM(list_filename)//' outside of valid range.'
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF
      ! ...Allocate list array
      ALLOCATE( subset_list(n_subset_channels), STAT=alloc_stat )!, ERRMSG=alloc_msg )
      IF ( alloc_stat /= 0 ) THEN
        err_msg = 'Error allocating Subset_List array - '!//TRIM(alloc_msg)
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF
      ! ...Fill values
      DO i = 1, n_subset_channels
        err_stat = Get_List_Entry( user_subset_list, i, subset_list(i) )
        IF ( err_stat /= SUCCESS ) THEN
          WRITE( err_msg,'("Error retrieving user subset channel list entry ",i0)' ) i
          CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
        END IF
      END DO
      WRITE( sensor_id,'("cris",i0,"_npp")' ) n_subset_channels

  END SELECT

  ! Initialise the start index for output
  ! and the "initial band" flag
  ! -------------------------------------
  l1 = 1
  ls = 0
  n_Out_Coeffs = 0
  los = 0
  n_Out_OCoeffs = 0
  First_Band = .TRUE.
  OPTRAN = .FALSE.

  ! Loop over bands to extract subset channels
  ! ------------------------------------------
  Band_Loop: DO l = 1, N_CRIS_BANDS

    ! Current band channel subset
    ! ---------------------------
    ! Determine the subset channel indices
    ! for the current band
    err_stat = CrIS_Subset_Index( l, Subset_List, Subset )
    IF ( err_stat /= SUCCESS ) THEN
      err_msg = 'Error extracting subset channel indices for band '//TRIM(CrIS_BandName(l))
      CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
    END IF
    CALL Subset_GetValue( Subset, n_Values = n_values, Index = idx, Number = nmbr )

    ! Output the number of channels to extract
    WRITE( *,'(/10x,"There are ",i0," channels to be extracted from band ",a,":")' ) &
             n_values, TRIM(CrIS_BandName(l))

    ! Read the input ODPS file if required
    ! ----------------------------------------
    Non_Zero_n_Channels: IF ( n_values > 0 ) THEN

      ! Output the list of channel numbers to extract
      WRITE( *,'(10x,10i5)' ) nmbr

      ! Define the filename
      In_Filename = 'cris'//TRIM(CrIS_BandName(l))//'_npp.TauCoeff.nc'

      ! Get the file release/version info and
      ! global attributes for the initial band
      ! --------------------------------------
      IF ( First_Band ) THEN

        ! **NOTE: No Update of First_Band here. It's used later**

        ! Inquire the file
        err_stat = Inquire_ODPS_netCDF( TRIM(In_Filename), &
                                        n_Layers         = n_Layers        , &
                                        n_Components     = n_Components    , &
                                        n_Absorbers      = n_Absorbers     , &
                                        n_Channels       = n_Channels      , &
                                        n_Coeffs         = n_Coeffs        , &
                                        n_OPIndex        = n_OPIndex       , &
                                        n_OCoeffs        = n_OCoeffs       , &
                                        Release          = Out_ODPS%Release         , &
                                        Version          = Out_ODPS%Version         , &
                                        WMO_Satellite_Id = Out_ODPS%WMO_Satellite_Id, &
                                        WMO_Sensor_Id    = Out_ODPS%WMO_Sensor_Id   , &
                                        Title            = Title           , &
                                        History          = History         , &
                                        Comment          = Comment         , &
                                        Profile_Set_Id   = Profile_Set_Id)
        IF ( err_stat /= SUCCESS ) THEN
          err_msg = 'Error inquiring the input netCDF ODPS file '//TRIM(In_Filename)
          CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
        END IF

        ! Obtain the total predictors for different Group
        IF( n_Components == GROUP_1_MAX_COMPONENTS) THEN
          n_total_Pred = GROUP_1_MAX_PREDS
        ELSE IF ( n_Components == GROUP_2_MAX_COMPONENTS ) THEN
          n_total_Pred = GROUP_2_MAX_PREDS
        END IF
        ! Estimate the output ODPS Coeffs dimension
        n_Subset_Coeffs = n_total_Pred * n_Layers * n_Subset_Channels

        ! Append onto the comment attribute.
        Comment = TRIM(Subset_Comment)//'; '//TRIM(Comment)

        ! Allocate the output structure
        err_stat = Allocate_ODPS( n_Layers    , &
                                  n_Components, &
                                  n_Absorbers , &
                                  n_Subset_Channels, &
                                  n_Subset_Coeffs  , &
                                  Out_ODPS )
        IF ( err_stat /= SUCCESS ) THEN
          err_msg = 'Error allocating output ODPS data structure.'
          CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
        END IF

        IF ( n_OPIndex > 0 .AND. n_OCoeffs > 0 ) THEN
          OPTRAN = .TRUE.
          n_Subset_OCoeffs =  (MAX_ORDER_OPTRAN+1)*(N_PREDICTOR_USED_OPTRAN+1) * n_Subset_Channels
          err_stat = Allocate_ODPS_OPTRAN(n_Subset_OCoeffs, Out_ODPS)
          IF ( err_stat /= SUCCESS ) THEN
            err_msg = 'Error allocating output ODPS OPTRAN data structure.'
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF

        END IF
      END IF

      ! Get the Version info and compare
      ! --------------------------------
      err_stat = Inquire_ODPS_netCDF( In_Filename, Version = Version )
      IF ( err_stat /= SUCCESS ) THEN
        err_msg = 'Error inquiring the input netCDF ODPS file '//&
                  TRIM(In_Filename)//' for Release/Version info.'
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF

      ! Check the Version value. If different - issue warning and continue,
      ! but modify the Comment global attribute field for output
      IF ( Out_ODPS%Version /= Version ) THEN
        WRITE( err_msg,'("Input file ",a," Version, ",i0, &
                        &", is different from previous file value, ",i0,".")' ) &
                        TRIM(In_Filename), Version, Out_ODPS%Version
        CALL Display_Message( PROGRAM_NAME, err_msg, WARNING )
        Comment = TRIM(Message)//'; '//TRIM(Comment)
      END IF

      ! Read the data
      ! -------------
      err_stat = Read_ODPS_netCDF( In_Filename, In_ODPS )
      IF ( err_stat /= SUCCESS ) THEN
        err_msg = 'Error reading netCDF CRIS ODPS file '//TRIM(In_Filename)
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF

      ! Copy or check the absorber id and alpha data
      ! --------------------------------------------
      IF ( First_Band ) THEN

        ! Now update the First_Band flag
        First_Band = .FALSE.

        ! Simply copy these for the first band
        Out_ODPS%Group_Index      = In_ODPS%Group_Index
        Out_ODPS%WMO_Satellite_ID = In_ODPS%WMO_Satellite_ID
        Out_ODPS%WMO_Sensor_ID    = In_ODPS%WMO_Sensor_ID
        Out_ODPS%Sensor_Type      = In_ODPS%Sensor_Type

        Out_ODPS%Component_ID      = In_ODPS%Component_ID
        Out_ODPS%Absorber_ID       = In_ODPS%Absorber_ID
        Out_ODPS%Ref_Level_Pressure= In_ODPS%Ref_Level_Pressure
        Out_ODPS%Ref_Pressure      = In_ODPS%Ref_Pressure
        Out_ODPS%Ref_Temperature   = In_ODPS%Ref_Temperature
        Out_ODPS%Ref_Absorber      = In_ODPS%Ref_Absorber
        Out_ODPS%Min_Absorber      = In_ODPS%Min_Absorber
        Out_ODPS%Max_Absorber      = In_ODPS%Max_Absorber

        IF ( OPTRAN ) THEN
          Out_ODPS%Alpha            = In_ODPS%Alpha
          Out_ODPS%Alpha_C1         = In_ODPS%Alpha_C1
          Out_ODPS%Alpha_C2         = In_ODPS%Alpha_C2
          Out_ODPS%OComponent_Index = In_ODPS%OComponent_Index
        ENDIF

      ELSE ! Subsequent bands

        ! Check Group_Index
        IF ( IN_ODPS%Group_Index /= Out_ODPS%Group_Index ) THEN
          WRITE( err_msg,'("Group_Index values are different for band ",a)' ) TRIM(CrIS_BandName(l))
          CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
        END IF

        ! Check Sensor_Type
        IF ( IN_ODPS%Sensor_Type /= Out_ODPS%Sensor_Type ) THEN
          WRITE( err_msg,'("Sensor types are different for band ",a)' ) TRIM(CrIS_BandName(l))
          CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
        END IF

        ! Check WMO Satellite ID
        IF ( IN_ODPS%WMO_Satellite_ID /= Out_ODPS%WMO_Satellite_ID ) THEN
          WRITE( err_msg,'("WMO_Satellite_ID values are different for band ",a)' ) TRIM(CrIS_BandName(l))
          CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
        END IF

        ! Check WMO Sensor ID
        IF ( IN_ODPS%WMO_Sensor_ID /= Out_ODPS%WMO_Sensor_ID ) THEN
          WRITE( err_msg,'("WMO_Sensor_ID values are different for band ",a)' ) TRIM(CrIS_BandName(l))
          CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
        END IF

        ! Check Component_ID
        DO j = 1, Out_ODPS%n_Components
          IF ( IN_ODPS%Component_ID(j) /= Out_ODPS%Component_ID(j) ) THEN
            WRITE( err_msg,'("Component #",i2," ID values are different for band ",a)' ) &
                           j, TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
        END DO

        ! Check Absorber IDs
        DO j = 1, In_ODPS%n_Absorbers
          IF ( In_ODPS%Absorber_ID(j) /= Out_ODPS%Absorber_ID(j) ) THEN
            WRITE( err_msg, '( "Absorber #",i2," ID values are different for band ",a)' ) &
                            j, TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
        END DO

        ! Check reference level pressure value
        DO k = 0, In_ODPS%n_Layers
          IF ( .NOT. Compare_Float( In_ODPS%Ref_Level_Pressure(k) , Out_ODPS%Ref_Level_Pressure(k)  ) ) THEN
            WRITE( err_msg, '( "Ref_Level_Pressure #",i2," level values are different for band ",a)' ) &
                            k+1, TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
        END DO

        ! Check reference layer pressure value
        DO k = 1, In_ODPS%n_Layers
          IF ( .NOT. Compare_Float( In_ODPS%Ref_Pressure(k) , Out_ODPS%Ref_Pressure(k)  ) ) THEN
            WRITE( err_msg, '( "Ref_Pressure #",i2," layer values are different for band ",a)' ) &
                            k, TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
        END DO

        ! Check reference Temperature value
        DO k = 1, In_ODPS%n_Layers
          IF ( .NOT. Compare_Float( In_ODPS%Ref_Temperature(k) , Out_ODPS%Ref_Temperature(k)  ) ) THEN
            WRITE( err_msg, '( "Ref_Temperature #",i2," layer values are different for band ",a)' ) &
                            k, TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
        END DO

        ! Check Ref_Absorber value
        DO j = 1, In_ODPS%n_Absorbers
          DO k = 1, In_ODPS%n_Layers
            IF ( .NOT. Compare_Float( In_ODPS%Ref_Absorber(k,j) , Out_ODPS%Ref_Absorber(k,j)  ) ) THEN
              WRITE( err_msg, '( "Ref_Absorber values are different for band ",a, " for index (", i3, 1x, i0, ")" )' ) &
                              TRIM(CrIS_BandName(l)), k, j
              CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
            END IF
          END DO
        END DO

        ! Check Min_Absorber value
        DO j = 1, In_ODPS%n_Absorbers
          DO k = 1, In_ODPS%n_Layers
            IF ( .NOT. Compare_Float( In_ODPS%Min_Absorber(k,j) , Out_ODPS%Min_Absorber(k,j)  ) ) THEN
              WRITE( err_msg, '( "Min_Absorber values are different for band ",a, " for index (", i3, 1x, i0, ")" )' ) &
                              TRIM( CrIS_BandName(l)), k, j
              CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
            END IF
          END DO
        END DO

        ! Check Max_Absorber value
        DO j = 1, In_ODPS%n_Absorbers
          DO k = 1, In_ODPS%n_Layers
            IF ( .NOT. Compare_Float( In_ODPS%Max_Absorber(k,j) , Out_ODPS%Max_Absorber(k,j)  ) ) THEN
              WRITE( err_msg, '( "Max_Absorber values are different for band ",a, " for index (", i3, 1x, i0, ")" )' ) &
                              TRIM( CrIS_BandName(l)), k, j
              CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
            END IF
          END DO
        END DO

        ! Check Optran quantities
        IF ( OPTRAN ) THEN
          ! ...Check Alpha
          IF ( IN_ODPS%Alpha /= Out_ODPS%Alpha ) THEN
            WRITE( err_msg, '( "Alpha values are different for band ",a)' ) &
                              TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
          ! ...Check Alpha_C1
          IF ( IN_ODPS%Alpha_C1 /= Out_ODPS%Alpha_C1 ) THEN
            WRITE( err_msg,'("Alpha_C1 values are different for band ",a)' ) &
                              TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
          ! ...Check Alpha_C2
          IF ( IN_ODPS%Alpha_C2 /= Out_ODPS%Alpha_C2 ) THEN
            WRITE( err_msg,'("Alpha_C2 values are different for band ",a)' ) &
                              TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
          ! ...Check OComponent_Index
          IF ( IN_ODPS%OComponent_Index /= Out_ODPS%OComponent_Index ) THEN
            WRITE( err_msg,'("OComponent_Index values are different for band ",a)' ) &
                              TRIM(CrIS_BandName(l))
            CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
          END IF
         END IF
       END IF

      ! Copy the required channel's data for particular components
      l2 = l1 + n_values - 1
      Out_ODPS%Sensor_Channel(l1:l2) = In_ODPS%Sensor_Channel(idx)

      DO lch = 1, n_values
        ls = ls + 1
        DO j = 1, Out_ODPS%n_Components
          np = In_ODPS%n_Predictors(j,idx(lch))
          Out_ODPS%n_Predictors(j, ls) = np

          j0 = In_ODPS%Pos_Index(j,idx(lch))

          js = n_Out_Coeffs
          IF ( np > 0 ) THEN
            DO i = 1, np
              jp = j0+(i-1)*In_ODPS%n_Layers-1
              DO k = 1, In_ODPS%n_Layers
                n_Out_Coeffs = n_Out_Coeffs + 1
                Out_ODPS%C(n_Out_Coeffs) = In_ODPS%C(jp+k)
              END DO
            END DO
            Out_ODPS%Pos_Index(j, ls) = js+1
          ELSE
            Out_ODPS%Pos_Index(j, ls) = 0
          END IF
        END DO
      END DO

      IF ( OPTRAN ) THEN
        Out_ODPS%OSignificance(l1:l2) = In_ODPS%OSignificance(idx)
        Out_ODPS%Order(l1:l2)         = In_ODPS%Order(idx)
        Out_ODPS%OP_Index(:,l1:l2)    = In_ODPS%OP_Index(:, idx)

        DO lch = 1, n_values
          los = los + 1
          np       = In_ODPS%OP_Index(0, idx(lch))
          n_orders = In_ODPS%Order(idx(lch))
          j0 = In_ODPS%OPos_Index(idx(lch))

          Out_ODPS%OPos_Index(los) = n_Out_OCoeffs + 1

          js = 0
          DO i = 0, np
            jp = j0 + i * (n_orders + 1)
            DO j = 0, n_orders
              js = js + 1
              Out_ODPS%OC(n_Out_OCoeffs + js) = In_ODPS%OC(jp + j)
            END DO
          END DO
          n_Out_OCoeffs = n_Out_OCoeffs + js
        END DO
      END IF

      l1 = l2 + 1

      ! Destroy the input ODPS structure
      ! for the next band read
      err_stat = Destroy_ODPS( In_ODPS )
      IF ( err_stat /= SUCCESS ) THEN
        err_msg = 'Error destroying ODPS structure for input from '//TRIM(In_Filename)
        CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
      END IF

    END IF Non_Zero_n_Channels

    ! Destroy the CRIS channel subset structure
    CALL Subset_Destroy( Subset )

  END DO Band_Loop

  ! Write the output SpcCoeff file
  ! ...The output filename
  Out_Filename = TRIM(Sensor_ID)//'.TauCoeff.nc'
  ! ...Set the sensors ID
  Out_ODPS%Sensor_ID  = TRIM(Sensor_ID)
  ! ...Allocate the final output structure
  err_stat = Allocate_ODPS(n_Layers    , &
                           n_Components, &
                           n_Absorbers , &
                           n_Subset_Channels, &
                           n_Out_Coeffs  , &
                           Out_ODPS_f )
  IF ( err_stat /= SUCCESS ) THEN
    err_msg = 'Error allocating final output ODPS data structure.'
    CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
  END IF

  Out_ODPS_f%Version               = Out_ODPS%Version
  Out_ODPS_f%Release               = Out_ODPS%Release
  Out_ODPS_f%Group_Index           = Out_ODPS%Group_Index
  Out_ODPS_f%Sensor_ID             = Out_ODPS%Sensor_ID
  Out_ODPS_f%Sensor_type           = Out_ODPS%Sensor_type
  Out_ODPS_f%WMO_Satellite_ID      = Out_ODPS%WMO_Satellite_ID
  Out_ODPS_f%WMO_Sensor_ID         = Out_ODPS%WMO_Sensor_ID
  Out_ODPS_f%Component_ID          = Out_ODPS%Component_ID
  Out_ODPS_f%Absorber_ID           = Out_ODPS%Absorber_ID
  Out_ODPS_f%Ref_Level_Pressure    = Out_ODPS%Ref_Level_Pressure
  Out_ODPS_f%Ref_Pressure          = Out_ODPS%Ref_Pressure
  Out_ODPS_f%Ref_Temperature       = Out_ODPS%Ref_Temperature
  Out_ODPS_f%Ref_Absorber          = Out_ODPS%Ref_Absorber
  Out_ODPS_f%Min_Absorber          = Out_ODPS%Min_Absorber
  Out_ODPS_f%Max_Absorber          = Out_ODPS%Max_Absorber
  Out_ODPS_f%Sensor_Channel        = Out_ODPS%Sensor_Channel
  Out_ODPS_f%n_Predictors          = Out_ODPS%n_Predictors
  Out_ODPS_f%Pos_Index             = Out_ODPS%Pos_Index

  IF( n_Out_Coeffs > 0 )THEN
    Out_ODPS_f%C(1: n_Out_Coeffs) = Out_ODPS%C(1: n_Out_Coeffs)
  END IF

  ! COPTRAN part
  IF ( n_Out_OCoeffs > 0 )THEN
    err_stat = Allocate_ODPS_OPTRAN(n_Out_OCoeffs, Out_ODPS_f)
    IF ( err_stat /= SUCCESS ) THEN
      err_msg = 'Error allocating output ODPS OPTRAN data structure.'
      CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
    END IF

    Out_ODPS_f%Alpha               = Out_ODPS%Alpha
    Out_ODPS_f%Alpha_C1            = Out_ODPS%Alpha_C1
    Out_ODPS_f%Alpha_C2            = Out_ODPS%Alpha_C2
    Out_ODPS_f%OComponent_Index    = Out_ODPS%OComponent_Index
    Out_ODPS_f%OSignificance       = Out_ODPS%OSignificance
    Out_ODPS_f%Order               = Out_ODPS%Order
    Out_ODPS_f%OP_Index            = Out_ODPS%OP_Index
    Out_ODPS_f%OPos_Index          = Out_ODPS%OPos_Index
    Out_ODPS_f%OC(1:n_Out_OCoeffs) = Out_ODPS%OC(1:n_Out_OCoeffs)

  ENDIF

  ! Write the data
  WRITE( *,'(/10x,"Creating the output file...")' )
  err_stat = Write_ODPS_netCDF( TRIM(Out_Filename), &
                                Out_ODPS_f    , &
                                Title         = 'Optical depth coefficients for '//&
                                                TRIM(Sensor_ID), &
                                History       = PROGRAM_VERSION_ID//'; '//&
                                                TRIM(History), &
                                Comment       = 'Data extracted from the individual '//&
                                                'CRIS band ODPS datafiles.; '//&
                                                TRIM(Comment), &
                                Profile_Set_Id= TRIM(Profile_Set_Id) )
  IF ( err_stat /= SUCCESS ) THEN
    err_msg = 'Error writing the CRIS ODPS file '//TRIM(Out_Filename)
    CALL Display_Message( PROGRAM_NAME, err_msg, FAILURE ); STOP
  END IF

  ! Destroy the output ODPS structure
  err_stat = Destroy_ODPS( Out_ODPS )
  IF ( err_stat /= SUCCESS ) THEN
    err_msg = 'Error destroying ODPS structure for output to '//TRIM(Out_Filename)
    CALL Display_Message( PROGRAM_NAME, err_msg, WARNING )
  END IF
  err_stat = Destroy_ODPS( Out_ODPS_f )
  IF ( err_stat /= SUCCESS ) THEN
    err_msg = 'Error destroying final ODPS structure for output to '//TRIM(Out_Filename)
    CALL Display_Message( PROGRAM_NAME, err_msg, WARNING )
  END IF

END PROGRAM Extract_CrIS_TauCoeff_Subset


c-----7---------------------------------------------------------------72
c 		  CMORPH ~ 8km, 1/2 hourly data description.
c
c 			Last Update: June 22, 2010
c
c The 8-km 30 minute CMORPH data sets can be found on the ftp.cpc.ncep.noaa.gov
c server in the precip/global_CMORPH/30min_8km directory
c
c The data are compressed using the standard Unix compress function (files have a
c suffix of ".Z")
c
c Each file contains 6 records.  The 1st 3 records pertain to the top half
c of the hour (00-29 minus after the hour) and the last 3 records are for the
c bottom half of the hour.  Within each group:
c
c   -  the 1st record contains the CMORPH precipitation estimates
c
c   -  the 2nd record contains the time (in half hour units) since the most
c      recent microwave pass.  Note that since we do both a forward &
c      backward interpolation in time, the nearest time may be prior to
c      the file time stamp or after it.
c
c   -  the 3rd record contains an ID that tells the satellite from which the last
c      microwave observation was made which can be interpretted by the following
c      table (as of the time of the last update of this documentation):
c
c        13 = DMSP-13 (SSM/I instrument)
c        14 = DMSP-14 (  "       "      )
c        15 = DMSP-15 (  "       "      )
c        16 = DMSP-16 (SSMIS instrument, coming soon)
c        17 = DMSP-17 ( " " )
c        18 = DMSP-18 ( " " )
c       115 = NOAA-15 (AMSU-B    "      )
c       116 = NOAA-16 (  "       "      )
c       117 = NOAA-17 (  "       "      )
c       118 = NOAA-18 (MHS )
c       119 = NOAA-19 ( " " )
c       151 = METOP-A ( " " )
c       201 = TRMM    (TMI       "      )
c       211 = AQUA    (AMSR-E    "      )
c
c
c Each direct access record is a 4948 x 1649 CHARACTER*1 (use FORTRAN ichar
c command to retrieve interger value for all parameters) array with  grid
c increments of 0.072756669 degrees of longitude and 0.072771377 of latitude,
c which is apporoximately 8 km at the equator.  The arrays are oriented from
c North to South, beginning from latitude 59.963614N and from West to EAST from
c longitude  0.036378335E.
c
c Missing data are denoted by values of 255.
c
c Note that the precipitation estimates have been scaled, and when multiplied by
c "0.2", the data units are "mm/hour".
c
c For GrADS users, a descriptor ("ctl") file: CMORPH_8km-30-minute.ctl has been
c provided.  However, since the data are in CHARACTER*1 words (bytes) the parameters
c after each variable (-1,40,1,-1 in our example "ctl file") are system dependent.
c Our example is for an SGI system.
c
c-----7---------------------------------------------------------------72

c The following program reads 8km CMORPH, averages into 0.25 deg lat/lon regions.

      program cmorph_8km
c    Program CMORPH_8-km-30min_read.f
c    Average already made 8 km , half hourly CMORPH into 025 degree and write out to files

      parameter (I8KMMAX=4948,J8KMMAX=1649,XMISSING=330,AMISSING=-9999,
     & ZERO=0,ONE=1,TEN=10,HOURMX=24,inunit=10,inunit2=15,ioutunit=70,
     & MTHMAX=12, IRMAX=1440, JRMAX=480, PIXCNTTHRESH=9, XLATMAX=60.0,
     & XLAT1STPIXLOC=59.963614, XLATINCR= 0.072771377, XLON1STPIX=
     & 0.036378335, XLONINCR=0.072756669, MISSING=-9999)

      character*1 ssmigrid(I8KMMAX,J8KMMAX),
     &  satid(I8KMMAX,J8KMMAX), timestamp(I8KMMAX,J8KMMAX)

      character*120 in1ssmi, out025d
      integer       imndy(MTHMAX), CMISSING

      real*4 ssmipropREG(IRMAX,JRMAX), ssmipropREGCNT(IRMAX,JRMAX)

      CMISSING = 255
      xres     = 0.25

      write (*,*) ' enter start & end day, i.e. 20050802 20050802'
      read (*,*) iyrmndy1, iyrmndy2
      write (*,*) ' start & end day entered ', iyrmndy1, iyrmndy2

      do iyrmndy = iyrmndy1, iyrmndy2

      do ihr = 0, 0

c    Open 8 km half hourly CMORPH

      in1ssmi='/glade/data02/dsswork/tcram/tigge/cmorph/data/8km/'
     &//'advt-8km-interp-prim-sat-spat-2lag-2.5+5dovlp8kmIR-YYYY0M0D0H'
      write (in1ssmi(102:109),'(i8)') iyrmndy
      if (ihr.lt.10) then
       write (in1ssmi(111:111),'(i1)') ihr
      else
       write (in1ssmi(110:111),'(i2)') ihr
      endif
      open (unit=10, file=in1ssmi, access = 'direct',
     &            form='unformatted', recl=4948*1649*3)
      write(6,'(/,'' input comb 8-km advect ssmi '',a120)') in1ssmi

      out025d='/glade/data02/dsswork/tcram/tigge/cmorph/data/025deg/'
     &//'CMORPH_025deg_YYYY0M0D0H'
      write (out025d(68:75),'(i8)') iyrmndy
      if (ihr.lt.10) then
       write (out025d(77:77),'(i1)') ihr
      else
       write (out025d(76:77),'(i2)') ihr
      endif

      open (unit=95, file=out025d, access = 'direct',
     &            form='unformatted', recl=1440*480*4)

      write(6,'(/,'' output comb 025 deg advect ssmi '',a120)') out025d

c    Loop through  1. top of the hour global IR merge and
c                  2. mid hour global IR merged images

      do ihlfhr = 1, 2

c    Init half hourly 0.25 deg region arrays

       do jreg = 1, JRMAX
        do ireg = 1, IRMAX
         ssmipropREG(ireg,jreg)      =ZERO
         ssmipropREGCNT(ireg,jreg)   =ZERO
        enddo
       enddo

       write (6,'('' ihr, ihlfhr '',2i8)') ihr, ihlfhr

       if (ihlfhr.eq.1) then

        read (10, rec = 1) ssmigrid, timestamp, satid

c    Simply read in forward and backward advected SSMI scans

       else

        read (10, rec = 2) ssmigrid, timestamp, satid

       endif

       write (6,'('' real array ihalfhr = '',i8)') ihlfhr
       do j = 700, 720
        write (6,'(21i4)') (ichar(ssmigrid(i,j)),i=3501,3521)
       enddo

c    Accumulate microwave anal derived precip into

       do j = 1, J8KMMAX
        xlat1 = XLAT1STPIXLOC - (j-1)*XLATINCR
        jreg  = ((XLATMAX - xlat1)/xres + 1)
        do i = 1, I8KMMAX
         if (ssmigrid(i,j).ne.char(CMISSING)) then
c    Determine region of 8-km pixel
          xlon1 = XLON1STPIX + (i-1)*XLONINCR
          ireg  = (xlon1/xres + 1)

          if (ireg.lt.1.or.ireg.gt.IRMAX.or.
     &                    jreg.lt.1.or.jreg.gt.JRMAX) then
           write (6,'(''region out of bounds'',4i8)') i, ireg, j, jreg
          else

           if (ssmigrid(i,j).ne.char(CMISSING)) then
            ssmipropREG(ireg,jreg)=ssmipropREG(ireg,jreg)+
     &                            ichar(ssmigrid(i,j))*0.2
            ssmipropREGCNT(ireg,jreg) =
     &                       ssmipropREGCNT(ireg,jreg) + 1
           endif
          endif

         endif
        enddo
       enddo

c    Average microwave derived precip into regional estimates and write to disk

       do jreg = 1, JRMAX
        do ireg = 1, IRMAX
         if (ssmipropREGCNT(ireg,jreg).ge.1) then
          ssmipropREG(ireg,jreg)=ssmipropREG(ireg,jreg)/
     &                           ssmipropREGCNT(ireg,jreg)
         else
          ssmipropREG(ireg,jreg) = MISSING
         endif
        enddo
       enddo

       write (6,*) ''
       write (6,'('' ssmipropREG @ ihalfhr = '',i8)') ihlfhr
       do j = 271, 280
        write (6,'(21f12.6)') (ssmipropREG(i,j),i=1161, 1175)
       enddo

c    Write combined 0.5 hour SSMI precip array to disk

       if (ihlfhr.eq.1) then
        write (95, rec = 1) ssmipropREG
       else
        write (95, rec = 2) ssmipropREG
        close (95)
       endif

      enddo

      enddo

      enddo

      stop

      end


      PROGRAM TRON
C
C     THIS PROGRAM WILL TRANSLATE A CODEV LENS DECK TO AN ACCOSV LENS DECK
C     USING A FILE GENERATED BY THE CODEV COMMANDS `PRI` AND `ANA`.
C
C     SECONDLY, THIS PROGRAM WILL TRANSLATE AN ACCOSV LENS DECK TO A CODEV
C     LENS DECK USING A FILE GENERATED BY THE ACCOSV COMMANDS `LEPRT`
C     AND `PXTY ALL`.
C     USER WILL BE PROMPTED FOR NAME OF FILE TO BE TRANSLATED.
C     NEW FILE NAME IS LENS.
C
C     AUTHOR: LAUREL WOOLEY
C             UNIVERSITY OF ROCHESTER
C             WRITTEN UNDER CONTRACT TO JET PROPULSION LABORATORY, OPERATED
C             BY CALIFORNIA INSTITUTE OF TECHNOLOGY FOR NASA
C
C     QUESTIONS, COMMMENTS, CORRECTIONS:
C             CONTACT JOHN E. STACY
C                     M.S. 169-314
C                     JET PROPULSION LABORATORY
C                     4800 OAK GROVE DRIVE
C                     PASADENA, CA 91109
C                     (818)354-2313
C
C     NO WARRANTIES, EXPRESS OR IMPLIED, ARE MADE FOR THIS PROGRAM WITH
C     RESPECT TO FITNESS FOR ANY PARTICULAR APPLICATION OR USE.
C
C**************************************************************************
C**  COMMON BLOCK CODEV DECLARATIONS
      CHARACTER*4 DIM,APERT(225)
      INTEGER*4 ICCY(0:225),ITHC(0:225),IGLC(0:225),IWTW1,IWTW2,IWTW3
      INTEGER*4 IWTW4,IWTW5,IWTW6,IWTW7,ICCX(30),KC(66),IAC(66),IBC(66)
      INTEGER*4 ICC(66),IDC(66),IXDC(100),IYDC(100),IADC(100),IBDC(100)
      INTEGER*4 ICDC(100),ICCF(66)
      REAL*4 ORDER(66),WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,WLF7
      REAL*4 F(225),AL(66),AM(66),AN(66)
      REAL*8 RFND1(20),RFND2(20),RFND3(20),RFND4(20),RFND5(20)
C**  COMMON BLOCK BOTH DECLARATIONS
      CHARACTER*4 SOLVE(40)
      CHARACTER*13 GLASS(0:225)
      CHARACTER*64 TITLE
      INTEGER*4 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,M,ISTOP,IREF,ISURF
      INTEGER*4 NAPERT(225),NDECE(100),NSOLVE(40),NUMA,MESSAGE(20)
      REAL*4 DIF(66)
      REAL*8 ADE(100),BDE(100),CDE(100),XDE(100),YDE(100),CURVEY(0:225)
      REAL*8 THICKNS(0:225),RK(66),A(66),B(66),C(66),D(66),SOLVF1(40)
      REAL*8 F1(225)
      LOGICAL AFO,IC(66),CUF(66)
C**  COMMON BLOCK ACCOSV DECLARATIONS
      CHARACTER*6 UNITS
      INTEGER*4 IORDER(66),IWT1,IWT2,IWT3,IWT4,IWT5
      REAL*4 WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,WT5,THETA(66)
      REAL*4 RN1
      REAL*8 N1(20),N2(20),N3(20),N4(20),N5(20),F2(225)
C** COMMON BLOCK CAONLY DECLARATIONS
      CHARACTER*3 SURFMES(20),SOLVE1(40),SOLVE2(40)
      CHARACTER*4 TYPE(66)
      CHARACTER*13 CATALOG(20),MATRL(20),GL(0:225)
      CHARACTER*24 SUBMES4(20)
      INTEGER*4 NTYPE(66),NRETUT(100),NRETUF(100),IPKCV1(200)
      INTEGER*4 IPKAD1(200),IPKAD2(200),IPKAE1(200),IPKAE2(200)
      INTEGER*4 IPKAF1(200),IPKAF2(200),IPKAG1(200),IPKAG2(200)
      INTEGER*4 IPKA1(200),IPKA2(200),IPKB1(200),IPKB2(200),IPKG1(200)
      INTEGER*4 IPKG2(200),IPKX1(200),IPKX2(200),IPKY1(200),IPKY2(200)
      INTEGER*4 IPKGL1(200),IPKGL2(200),IPKTH1(200),IPKTH2(200)
      INTEGER*4 IPKCC1(200),IPKCC2(200),ICCA(200),ICVA(200),ITHA(200)
      INTEGER*4 IGLA(200),IAEA(200),IAFA(200),IAGA(200),IADA(200)
      INTEGER*4 IXA(200),IYA(200),IAA(200),IBA(200),IGA(200),J1,J2,J3
      INTEGER*4 J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,JA,JB,JM
      INTEGER*4 INDICE(225),ICIR(225),IRECT(225),IELIP(225),ICOCYF(20)
      INTEGER*4 ICOCYT(20),ICOCXF(20),ICOCXT(20),TILT(66),RTILT(66)
      INTEGER*4 RDECE(100),MESNUM(20),IPKCV2(200)
      REAL*4 WL1(20),WL2(20),WL3(20),WL4(20),WL5(20),WL6(20),WL7(20)
      REAL*4 TWL1(20),TWL2(20),TWL3(20),TWL4(20),TWL5(20)
      REAL*4 CATWL1(20),CATWL2(20),CATWL3(20),CATWL4(20),CATWL5(20)
      REAL*4 CATWL6(20),CATWL7(20),W1(20),W2(20),W3(20),W4(20),W5(20)
      REAL*4 IND1(20),IND2(20),IND3(20),IND4(20),IND5(20),TIND1(20)
      REAL*4 TIND2(20),TIND3(20),TIND4(20),TIND5(20)
C UMARG WAS DECLARED TWICE HERE FOR SOME REASON. BBC 9/84.
      REAL*8 UMARG,YMARG,UCHIEF,CUX(30),RADE(100),RBDE(100)
      REAL*8 RCDE(100),RXDE(100),RYDE(100)
      LOGICAL VIGNET,TEL,RETURN(100),ZMFLAG
C**  COMMON BLOCK ACONLY DECLARATIONS
      CHARACTER*4 TORIC(10),COMMAND(100),PIKUP(200),SHAPE(225),CASE(10)
      CHARACTER*4 SPECSF(225)
      CHARACTER*36 SUBMES1(20)
      CHARACTER*40 SUBMES2(20)
      CHARACTER*48 SUBMES3(20)
      INTEGER*4 INDEX(20),NTORIC(10),NCASE(10),NUMBER(10),IPIKTO(200)
      INTEGER*4 IPIKFR(200),NASP(66),J10,K1,NGRT(10),NSHAPE(225)
      REAL*4 PIKA(200),DDIST(10),RNUMBER(10),RIC1(225),RIC2(225)
      REAL*4 RCUF1(225),RCUF2(225)
      REAL*8 TCVR(10),PY,PUCY,RADIUS(0:225),PIKB(200),NAO,YAN
      LOGICAL OB(225)
C** LOCAL DECLARATIONS
      CHARACTER*1 FLAG1
C VAX USES 9 CHAR FOR FILENAME, 1 FOR SEPARATOR, AND 3 FOR TYPE. BBC 9/84.
      CHARACTER*13 NAME
      CHARACTER*110 LINE
      LOGICAL CVFILE
C
      COMMON /CODEV/DIM,APERT,ICCY,ITHC,IGLC,IWTW1,IWTW2,IWTW3,IWTW4,
     *        IWTW5,IWTW6,ILWTW7,ICCX,KC,IAC,IBC,ICC,IDC,ORDER,IXDC,
     *        IYDC,IADC,IBDC,ICDC,ICCF,WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,
     *        WLF7,RFND1,RFND2,RFND3,RFND4,RFND5,F,AL,AM,AN
      COMMON /BOTH/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,GLASS,MESSAGE,M,
     *        ISTOP,IREF,ISURF,AFO,NAPERT,NDECE,F1,DIF,ADE,BDE,CDE,XDE,
     *        YDE,CURVEY,THICKNS,RK,A,B,C,D,IC,CUF,NSOLVE,SOLVF1,SOLVE,
     *        TITLE,NUMA
      COMMON /ACCOSV/IORDER,WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,
     *        WT5,IWT1,IWT2,IWT3,IWT4,IWT5,THETA,F2,RN1,UNITS,N1,
     *        N2,N3,N4,N5
      COMMON /CAONLY/UMARG,YMARG,UCHIEF,YCHIEF,TYPE,NTYPE,NRETUT,
     *        NRETUF,CATWL1,CATWL2,CATWL3,CATWL4,CATWL5,CATWL6,CATWL7,
     *        CUX,VIGNET,TEL,RETURN,MATRL,SOLVE1,SOLVE2,ZMFLAG,SURFMES,
     *        CATALOG,WL1,WL2,WL3,WL4,WL5,WL6,WL7,IND1,IND2,IND3,IN4,
     *        IND5,TWL1,TWL2,TWL3,TWL4,TWL5,TIND1,TIND2,TIND3,TIND4,
     *        TIND5,GL,IPKCV1,IPKCV2,IPKAD1,IPKAD2,IPKAE1,IPKAE2,
     *        IPKAF1,IPKAF2,IPKAG1,IPKAG2,IPKA1,IPKA2,IPKB1,IPKB2,
     *        IPKG1,IPKG2,IPKX1,IPKX2,IPKY1,IPKY2,IPKTH1,IPKTH2,IPKCC1,
     *        IPKCC2,ICCA,ICVA,ITHA,IGLA,IAEA,IAFA,IAGA,IADA,IXA,IYA,
     *        IAA,IBA,IGA,J1,J2,J3,J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,
     *        JA,JB,JM,INDICE,ICIR,IRECT,IELIP,ICOCYF,ICOCYT,ICOCXF,
     *        ICOCXT,TILT,RTILT,W1,W2,W3,W4,W5,RDECE,RADE,RBDE,RCDE,
     *        RXDE,RYDE,MESNUM,SUBMES4
      COMMON /ACONLY/TCVR,PY,PUCY,INDEX,NTORIC,DDIST,SUBMES1,SUBMES2,
     *        SUBMES3,TORIC,NCASE,COMMAND,NUMBER,RADIUS,PIKA,PIKB,
     *        IPIKTO,IPIKFR,PIKUP,SHAPE,CASE,NASP,OB,SPECSF,NAO,YAN,
     *        J10,K1,NGRT,RIC1,RIC2,RCUF1,RCUF2,RNUMBER,NSHAPE
C
C     OPEN(UNIT=1)	! VAX DOES NOT NEED TO DEFINE SYSTEM OUTPUT. BBC 9/84.
C
C*****FORMAT STATEMENTS
 1    FORMAT(A1)
 2    FORMAT(A110)
 4    FORMAT(A10)
 6    FORMAT(A55)
C
C*******************************************************************************
C*****INITIALIZE
      CVFILE=.FALSE.
C*******************************************************************************
C     PROMPT USER FOR LENS FILE NAME
C WE DID AWAY WITH THE FANCY TITLE.  BBC 9/84.
      PRINT *, '                ENTER NAME OF FILE TO BE TRANSLATED'
      READ (5,77) NAME		! LOGICAL UNIT 5 IS DEFAULT FOR SYSTEM INPUT.
77    FORMAT (A13)		! 13 CHAR FILENAME MAX.
C*******************************************************************************
C*****MAIN PROGRAM
C
      OPEN(UNIT=6,FILE=NAME,STATUS='OLD')
C*****DETERMINE IF FILE IS CODEV OR ACCOSV DATA
200   READ(6,2,END=800)LINE
      IF (LINE(5:7) .EQ. 'PRI') THEN
        CVFILE=.TRUE.
      ELSE IF (LINE(3:7) .NE. 'LEPRT') THEN
        GOTO 200
      ELSE
        CVFILE=.FALSE.
      END IF
C*****REMOVE BLANKS FROM NAME AND OPEN APPROPRIATE FILE
      I = 14
201   I = I - 1
      IF (I .GT. 0 .AND. NAME(I:I) .NE. '.') GOTO 201
      IF (I .EQ. 0) THEN
	I = 14
202     I = I - 1
	IF (I .GT. 0 .AND. NAME(I:I) .EQ. ' ') GOTO 202
	IF (I .EQ. 0) THEN
	  TYPE *,'INVALID FILENAME. PROGRAM HALT.'
	  CALL EXIT
	END IF
      ELSE
	I = I - 1
      END IF
C VAX REQUIRES THREE CHARACTER FILE TYPES. BBC 9/84.
      IF (CVFILE) THEN
        OPEN(UNIT=5,FILE=NAME(1:I)//'.ACC',STATUS='NEW')
        I=1
      ELSE
        OPEN(UNIT=5,FILE=NAME(1:I)//'.SEQ',STATUS='NEW')
        I=1  ! END LOOP
      END IF
      IF (CVFILE) GOTO 600
C*******************************************************************************
C*****ACCOSV TRANSLATED TO CODEV
C
      CALL DECODE1
      CALL CONVERT1
      CALL OUTPUT1
      GOTO 700
C*******************************************************************************
C*****CODEV TRANSLATED TO ACCOSV
C
C600   CALL DECODE2
C      CALL CONVERT2
C      CALL OUTPUT2
C
C*******************************************************************************
C
600   GOTO 700
800   PRINT *, 'FILE CONTAINS UNACCEPTABLE DATA.  PROGRAM ABORTED.'
700   END FILE(5)
      CLOSE(UNIT=5)
      CLOSE(UNIT=6)
      END


C    @(#)linimp.f	20.6 11/11/97
      subroutine  linimp ( num, dist, units, basmva, basekv, freq,
     1   iphase, skin, resis, diam, horiz, vtower, vmid, separ, alpha,
     2   numbnd, zout, ierr )
      implicit real*8 (a-h, o-z),  integer*4 (i-n)

      include 'ipfinc/deck25.inc'
      include 'ipfinc/lfiles.inc'
      include 'ipfinc/prt.inc'
      include 'ipfinc/miscfile.inc'

      common /is_batch / is_batch

      parameter( MAXCND = 36 )    ! N
      parameter( MAXTRI = 666)    ! N*(N+1)/2
      parameter( MAXSQR = 1296)   ! N*N
      parameter( MAXSQ2 = 2592)   ! 2*N*N
      parameter( MAXHAF = 171)    ! N/2*(N/2+1)/2

      dimension  iphase(MAXCND), skin(MAXCND), resis(MAXCND)
      dimension  diam(MAXCND), horiz(MAXCND)
      dimension  itbic(MAXCND), tbtb2(MAXCND), tbr(MAXCND)
      dimension  tbd(MAXCND), tbx(MAXCND), vtower(MAXCND)
      dimension  vmid(MAXCND), separ(MAXCND), alpha(MAXCND)
      dimension  numbnd(MAXCND),  zout(6)
      dimension  ic(MAXCND), r(MAXCND), d(MAXCND), gmd(MAXCND)
      dimension  x(MAXCND), y(MAXCND), tb2(MAXCND), itb3(MAXCND)
      dimension  tbg(MAXCND), tby(MAXCND), itbtb3(MAXCND)
      dimension  workr1(MAXTRI), workr2(MAXTRI)
      dimension  p(MAXTRI), z(MAXTRI)
      dimension  gd(MAXHAF), bd(MAXHAF), yd (MAXHAF)
      dimension  bcars(30), ccars(30),  dcars(30)

      character*7   units
      integer    status, open_file

      integer    iblank, iblanks(2)
      real*8     xblank
      equivalence (xblank, iblanks)

      i = ichar(' ')
      iblank = i + 256*i + 256*256*i + 256*256*256*i
      iblanks(1) = iblank
      iblanks(2) = iblank

      ll0 = 0
      valu1    =  5 584 596.2   d0
      valu2    =   .000 856 465 41  d0
      valu3    =   .000 643 738 88  d0
      valu4    =   .615 931 52  d0
      valu6    =   .000 500 000 0   d0
      onehaf   =  1. / 2. d0
      onetrd   =  1. / 3. d0
      sqrt3    =  dsqrt (3.0 d0)
      valu7    =  onehaf * sqrt3
      valu8    =   .004 044 730 6   d0
      valu9    =   .211 392 17  d0
      valu10   =   .577 215 664 901 532 860 6   d0
      valu11   =   .392 699 1   d0
      valu12   =   .398 942 280 401 433 d0
      valu13   =  1.253 314 137 315 5   d0
      aaa1     =   .785 398 163 397 448 d0
      aaa2     =   .318 309 886 183 791 d0
      sqrt2    =  1.414 213 562 373 095 048 8   d0
      twopi    =  6.283 185 307 179 586 476 92  d0
      pi = twopi * onehaf
      pidiv4 = pi * 0.25 d0
      tenm6 = 1. d-6
      unity = 1. d0
      ccars(2) =  1.365 931 515 658 412 448 8   d0
      nbundl = 0
      ierr = 0

      rearth = 100. d0
      lphase = MAXCND
      lphpl1 = MAXCND + 1
      nthalf = MAXHAF

C     IPRSUP = 4       !  Diagnostic output control
      lunit4 = lunscr1 !  Scratch file
      lunit6 = dbug    !  Output file

      call close_file (lunit4)
      status = open_file (lunit4, ' ', 'U', 'W', iostat)
      rewind lunit4
      finpcm = unity / 2.54d0
      ftpm = 100. * finpcm / 12.0
      fmipkm = ftpm * 1000.0 / 5280.0
      d8 = 0.3048d0
      fspac = .024d0 * twopi * dlog ( d8 )
      bcars(1) = sqrt2 / 6.0
      bcars(2) = unity / 16.0
      dcars(2) = bcars(2) * pidiv4
      do 6603  i=3, 30
      isn = (-1) ** ( (i - 1 ) / 2 )
      bcars(i) = -bcars(i-2) / ( i * i + 2.0 * i ) * isn
 6603 dcars(i) = bcars(i) * pidiv4
      ccars(1) = unity / sqrt2
      ccars(3) = ccars(1)
      ccars(5) = 3.0 * sqrt2 * onehaf
      ccars(7) = -45.0 * onehaf * sqrt2
      do 3964  i=1, 29, 2
      if ( i .gt. num ) ccars(i) = 0.0
 3964 dcars(i) = ccars(i)
      dcars(3) = -dcars(3)
      dcars(7) = -dcars(7)
      do 3846  i=4, 30, 2
 3846 ccars(i) = ccars(i-2) + unity / i  +  unity / ( i + 2.0 )
      fbe(1) = 16.0
      fbed(1) = -4.0
      d1 = unity - valu10
      fke(1) = fbe(1) * d1
      do 1811  i=2, 14
      isn= (-1)**i
      fbe(i) = fbe(i-1) * ( 16.0 / (i*i) ) * (-isn)
      fbed(i) = fbe(i) / ( 2.0 * i + 2.0 ) * isn
      d1 = d1 + unity / i
      fke(i) = fbe(i) * d1
 1811 fked(i-1) = fke(i) * i / 32.0
      fked(14) = 0.0
      fbe(15) =   .011 048 60 d0
      fbe(16) =   0.0
      fbe(17) =  -.000 090 60 d0
      fbe(18) =  -.000 025 20 d0
      fbe(19) =  -.000 003 40 d0
      fbe(20) =   .000 000 60 d0
      fbed(15) = -.011 048 50 d0
      fbed(16) = -.000 976 50 d0
      fbed(17) = -.000 090 10 d0
      fbed(18) =   0.0
      fbed(19) =  .000 005 10 d0
      fbed(20) =  .000 001 90 d0
      fke(15) =  -.062 500 10 d0
      fke(16) =  -.001 381 30 d0
      fke(17) =   .000 000 50 d0
      fke(18) =   .000 034 60 d0
      fke(19) =   .000 011 70 d0
      fke(20) =   .000 001 60 d0
      fked(15) = -.000 000 10 d0
      fked(16) =  .001 381 10 d0
      fked(17) =  .000 245 20 d0
      fked(18) =  .000 033 80 d0
      fked(19) = -.000 002 40 d0
      fked(20) = -.000 003 20 d0
      zero = 0.0

      j = 0
      do 1021  kk = 1, num  ! # OF CONDUCTOR CARDS
      if ( numbnd(kk) .eq. 0 )  j = j + 1
      if ( numbnd(kk) .ne. 0 )  j = j + numbnd(kk)
 1021 continue
      num = j     !  TOTAL NUMBER OF CONDUCTORS
      write (lunit6, '(a, i4)') ' Total # of conductors =', num

      if ( units(1:6) .ne. 'METRIC' ) go to 1258
      metrik = 1
      go to 4239
 1258 metrik = 0

 4239 i = 1
      j = 1      ! needed for counting bundled conductos
      go to 4245
 4241 i = i + 1
      j = j + 1

 4245 itbtb3(j) = 4
      tbg(j) = 0.
      itbic(j) = iphase(i)
      tbtb2(j) = skin(i)
      tbr(j) = resis(i)
      tbd(j) = diam(i)
      tbx(j) = horiz(i)
      h1 = vtower(i)
      h2 = vmid(i)
      d8 = separ(i)
      d9 = alpha(i)
      i3 = numbnd(i)
c
c     The following statement exploit the equivalence (xblanks, iblanks)
c     to test for blanks
c
      if ( i .eq. 1 )  go to 4320
      if ( itbic(j)  .eq. iblank ) itbic(j) = itbic(j-1)
      if ( tbtb2(j)  .eq. xblank ) tbtb2(j) = tbtb2(j-1)
      if ( tbr(j)    .eq. xblank ) tbr(j) = tbr(j-1)
      if ( itbtb3(j) .eq. iblank ) itbtb3(j) = itbtb3(j-1)
      if ( tbg(j)    .eq. xblank ) tbg(j) = tbg(j-1)
      if ( tbd(j)    .eq. xblank ) tbd(j) = tbd(j-1)
 4320 if ( vtower(j) .eq. xblank ) h1 = vmid(i)
      if ( vmid(j)   .eq. xblank ) h2 = vtower(i)
      tby(j) = ( h1 + h2 + h2 ) * onetrd
      if ( i3 .le. 1 )   go to 2405  ! NOT AUTO. BUNDLING
      nbundl = 1
      i4 = 1
      xx = tbx(j)
      yy = tby(j)
      dangl = twopi / i3
      angl = ( pi - dangl ) * onehaf
      radius = d8 / ( 24.0 * dcos ( angl ) )
      if ( metrik .eq. 1 ) radius = radius * 0.12d0
      d9r = d9 * twopi / 360.
 4713 d22 =  d9r - dangl * i4
      tbx(j) = xx + radius * dcos ( d22 )
      tby(j) = yy + radius * dsin ( d22 )
      if ( i4 .eq. i3 )  go to 2405
      i4 = i4 + 1
      j = j + 1
      itbic(j) = itbic(j-1)
      tbtb2(j) = tbtb2(j-1)
      tbr(j) = tbr(j-1)
      itbtb3(j) = itbtb3(j-1)
      tbg(j) = tbg(j-1)
      tbd(j) = tbd(j-1)
      go to 4713
 2405 if ( j .lt. num  )  go to 4241
      if ( iprsup .ge. 1 )
     1 write (lunit6, 3625)  ( itbic(k), itbtb3(k),  tbtb2(k),  tbr(k),
     2                         tbg(k), tbd(k), tbx(k), tby(k),  k=1, j )
 3625 format ( / '   itbic  itbtb3', 12x, 'tbtb2',  14x, 'tbr',  14x,
     1          'tbg',  14x, 'tbd',  14x, 'tbx'  ,14x, 'tby'
     1         , /,  ( 2i8, 6e17.8 )  )
      if ( metrik .ne. 1 ) go to 5981
      do 2982  k = 1, num
      tbd(k) = tbd(k) * finpcm
      tbx(k) = tbx (k) * ftpm
      tby(k) = tby(k) * ftpm
      tbr(k) = tbr(k) / fmipkm
 2982 continue
 5981 do  1248  i = 1, lphase
 1248 ic (i) = 0
      ktot = 0
      kcirct = 0
      do 2810  k=1, num
      i1 = itbic(k)
      if ( i1 .eq. 0 )  go to 4012
      if ( i1 .lt. 0 ) go to 2810
      if ( i1 .gt. kcirct ) kcirct = i1
      i = lphpl1 - i1
      if ( ic(i) .eq. 0 ) go to 4813
 4012 ktot = ktot + 1
      i = ktot
      if ( i1 .eq. 0 ) go to 4813
      ip = ktot
 2918 j = i - 1
      if ( j .eq. 0  .or.
     1     ic(j) .gt. 0 ) go to 4813
      i = j
      ic(ip) = ic(i)
      tb2(ip) = tb2(i)
      itb3(ip) = itb3(i)
      r(ip) = r(i)
      d(ip) = d(i)
      gmd(ip) = gmd(i)
      x(ip) = x(i)
      y(ip) = y(i)
      ip = ip - 1
      go to 2918

 3527 ierr = 1
      write (errbuf(1), 281) kfull
  281 format ('Overflow - KFULL (', i6, ') is larger than MAXCND. Paramet
     1er maxcnd needs be increased.')
      write (errbuf(2), 282) '280', 'LINIMP'
  282 format ('Error called from statemnt ', a, ' in subroutine ', a)
      if (is_batch .eq. 0) then
         call prterx ('E',2)
      else
         call prterx ('F',2)
      endif
      go to 9800
 4813 kfull = ktot + kcirct
      if ( kfull .gt. lphase )  go to 3527
      ic(i) = i1
      tb2(i) = tbtb2(k)
      itb3(i) = itbtb3(k)
      r(i) = tbr(k)
      d(i) = tbd(k)
      gmd(i) = tbg(k)
      x(i) = tbx(k)
      y(i) = tby(k)
 2810 continue
 2715 rewind lunit4

      j5 = 1
      j9 = 1
      j14 = 1
      j16 = 1
      corr = tenm6
      if ( metrik .eq. 1 )  dist = dist * fmipkm
      omega = twopi * freq
      idist = 1
      if ( kcirct .eq. 0 )  go to 4271
      if ( kcirct .lt. lphase/2 )  go to 4275
 4271 idist = 0
 4275 j56 = j5  + idist
      ip = 0
      k = 0
      f1 = unity / omega
      f1 = f1 * valu1
      f2 = f1 * 2.0
 1020 k = k + 1
      if ( k .gt. kfull ) go to 1730
      if ( k .le. kcirct ) go to 2328
      j = k - kcirct
 3621 x1 = x(j)
      y1 = y(j)
      d1 = d(j)
      if ( tb2(j) .gt. 0.0 ) go to 5224

      ierr = 1
      write (errbuf(1), 371) j
  371 format ('Illegal null SKIN data for conductor No. ', i6)
      write (errbuf(2), 282) '371', 'LINIMP'
      call prterx('W', 2)
      go to 9800
 5224 gmd(j) = d(j)
      do 4123  i=1, k-1
      ip = ip + 1
      j = i - kcirct
      if ( i .le. kcirct )  j = lphpl1 - i
      dx = ( x(j) - x1 )**2
      h1 = y(j) - y1
      h2 = y(j) + y1
      if ( dx .eq. 0.0  .and.
     1     h1 .eq. 0.0 ) go to 3026
      d21 = ( dx + h2 * h2 ) / ( dx + h1 * h1 )
      r1 = dlog ( d21 )
      p(ip) = r1 * f1
      z(ip) = r1
 4123 continue
      ip = ip + 1
      p(ip) = dlog ( 48.0 * y1 / d1 ) * f2
      go to 1020

 3026 ierr = 1
      write (errbuf(1), 401) k, j
  401 format ('Illegal duplicate (x,y) coordinates for (sorted) conducto
     1rs ', i6, ' and ', i6)
      write (errbuf(2), 282) '400', 'LINIMP'
      if (is_batch .eq. 0) then
         call prterx ('E',2)
      else
         call prterx ('F',2)
      endif
      go to 9800
 2328 j = lphpl1 - k
      if ( ic(j) .ne. 0 )  go to 3621

      ierr = 1
      write (errbuf(1), 411) k
  411 format ('Missing conductor data for circuit ', i6)
      write (errbuf(2), 282) '411', 'LINIMP'
      if (is_batch .eq. 0) then
         call prterx ('E',2)
      else
         call prterx ('F',2)
      endif
      go to 9800
 1730     write (lunit4) ( z(i), i=1, ip )
      if ( iprsup .ge. 2 )
     1 write (lunit6, 4427)  ( z(i), i=1, ip )
 4427 format ( /, 1p,  ' Z(1:IP) follow ....'  ,/,  ( 1x, 8e16.7 ) )
      if ( iprsup .ge. 2 )
     1 write (lunit6,  1327)  ( p(i), i=1, ip )
 1327 format (    1p,  ' P(1:IP) follow ....'  ,/,  ( 1x, 8e16.7 ) )
      if ( iprsup .ge. 1 )
     1 write (lunit6, 4428)  j1, j4, kcirct, j2, j3, j56, kfull
 4428 format ( ' J1, J4, KCIRCT, J2, J3, J56, KFULL =',  7i10  )
      switch = -unity
 1449 k = kcirct
 2150 k = k + 1
      if ( k .gt. kfull ) go to 4156
      i = k - kcirct
      i = ic(i)
      if ( i .eq. 0 ) go to 2150
      i2 = i * ( i - 1 ) / 2
      k2 = k * ( k - 1 ) / 2
      ndx1 = k2 + i
      h1 = p(ndx1)
      h2 = z(ndx1)
      ndx1 = k2 + k
      l = 0
 1851 if ( l .lt. i ) go to 1154
      i2 = i2 + l
 3652 if ( l .lt. k ) go to 3355
      k2 = k2 + l
 2453 l = l + 1
      p(k2) = p(k2) - p(i2)
      if ( switch .gt. 0.0 ) z(k2) = z(k2) - z(i2)
      if ( l .ne. kfull ) go to 1851
      p(ndx1) = p(ndx1) - h1
      if ( switch .gt. 0.0 ) z(ndx1) = z(ndx1) - h2
      go to 2150
 1154 i2 = i2 + 1
      go to 3652
 3355 k2 = k2 + 1
      go to 2453
 4156 kp = kcirct * ( kcirct + 1 ) / 2
      if ( switch .gt. 0.0 ) go to 5202
      call reduction ( p(1), workr1(1), kfull, kcirct, ierr, iprsup,
     &                 lunit6 )
      if ( ierr .eq. 0 )  go to 4839
      go to 9800
 2980 switch = +unity
      j56 = 2
      rewind lunit4
      f1 = valu2 * dsqrt ( freq / rearth )
      f2 = omega * valu3
      imaxlc = 30
      if ( imaxlc .gt. 31 )  imaxlc = 30
      read (lunit4)  ( p(i), i=1, ip )
      rewind lunit4
      ip = 0
      k = 0
 2120 k = k + 1
      if ( k .gt. kfull ) go to 5200
      if ( k .le. kcirct ) go to 1129
      j = k - kcirct
      go to 5121
 1129 j = lphpl1 - k
 5121 x1 = x(j)
      y1 = y(j)
      r1 = r(j)
      h1 = tb2(j)
      h2 = unity - 2.0 * h1
      if ( h1 .gt. 0.0 )
     1 call lcskin ( h2, r1, r1, h1, freq )
      g1 = gmd(j)
      ix = itb3(j)
      izero = 1
      xm = 0.0
      xs = dlog ( 24.0 * y1 / g1 ) * onehaf
 4122  d17 = dlog ( d(j) * onehaf / g1 )
      xs = xs + h1 / f2 - onehaf * d17
      i = 0
 3123 i = i + 1
      ip = ip + 1
      if ( i .eq. k ) go to 1124
      j = i - kcirct
      if ( i .le. kcirct )
     1 j = lphpl1 - i
      rm = 0.0
      if ( izero .eq. 0 ) go to 5126
      xm = p(ip) / 4.0
      if ( imaxlc .lt. 0 ) go to 5126
      dx = abs ( x(j) - x1 )
      h2 = y(j) + y1
      s = dsqrt ( h2 * h2 + dx * dx )
      z1 = s * f1
      if ( z1 .gt. 5.0 )  go to 4151
      rm = twopi / 16.0
      zl = dlog ( z1 )
      xm = xm  +  ( valu4 - zl ) * onehaf
      if ( imaxlc .eq. 0 ) go to 5126
      s1 = dx / s
      c1 = h2 / s
      cs = c1 * z1
      sn = s1 * z1
      if ( imaxlc .gt. 1 )   phi = dasin ( s1 )
      m5 = 0
      error = 0.0
 1110 k5 = 0
      i5 = m5 * 4
 1111 k5 = k5 + 1
      i5 = i5 + 1
      if ( k5 .eq. 1  .or.
     1     k5 .eq. 3 ) go to 1113
      deltap = ( ( ccars(i5) - zl ) * cs + phi * sn ) * bcars(i5)
      h1 = -dcars(i5) * cs
      if ( k5 .eq. 4 ) go to 1114
      deltaq = h1
 1004 rm = rm + deltap
      xm = xm + deltaq
      if ( i5 .eq. imaxlc ) go to 5126
      if ( dabs ( deltap ) .lt. corr  .and.
     1     dabs ( deltaq ) .lt. corr )  go to 1115
      error = 0.0
 1005 h1 = sn * c1 + cs * s1
      cs = ( cs * c1 - sn * s1 ) * z1
      sn = h1 * z1
      if ( k5 .lt. 4 ) go to 1111
      m5 = m5 + 1
      go to 1110
 1113 deltaq = bcars(i5) * cs
      deltap = deltaq
      if ( k5 .eq. 1 ) deltap = -deltap
      go to 1004
 1114 deltaq = -deltap
      deltap = h1
      go to 1004
 1115 if ( error .gt. onehaf ) go to 5126
      error = unity
      go to 1005
 4151 s = s * z1
      sn = dx / s
      cs = h2 / s
      s2 = sn * cs * 2.0
      c2 = cs * cs - sn * sn
      rm = -c2
      do 1006  i5=1, 7, 2
      rm = rm + ccars(i5) * cs
      xm = xm + dcars(i5) * cs
      h1 = cs * s2 + sn * c2
      cs = cs * c2 - sn * s2
 1006 sn = h1
 5126 p(ip) = rm * f2
      z(ip) = xm * f2
      if ( iprsup .ge. 4 )
     1 write (lunit6, 4439)  i, k, kfull, kcirct, i5, ip, p(ip), z(ip)
 4439 format ( ' I, K, KFULL, KCIRCT, I5, IP, =',  6i6,  2e25.16 )
      go to 3123
 1124 if ( imaxlc .lt. 0 ) go to 4128
      r1 = r1 / f2
      z1 = y1 * f1 * 2.0
      if ( z1 .gt. 5.0 ) go to 5152
      r1 = r1 + twopi / 16.0
      zl = dlog ( z1 )
      xs = xs  +  ( valu4 - zl ) * onehaf
      if ( imaxlc .eq. 0 ) go to 127
      m5 = 0
      cs = z1
      error = 0.0
 2110 k5 = 0
      i5 = m5 * 4
 2111 k5 = k5 + 1
      i5 = i5 + 1
      if ( k5 .eq. 1  .or.
     1     k5 .eq. 3 ) go to 2113
      deltap = ( ccars(i5) - zl ) * bcars(i5) * cs
      h1 = -dcars(i5) * cs
      if ( k5 .eq. 4 ) go to 2114
      deltaq = h1
 2004 r1 = r1 + deltap
      xs = xs + deltaq
      if ( i5 .eq. imaxlc ) go to 127
      if ( dabs ( deltap ) .lt. corr  .and.
     1     dabs ( deltaq ) .lt. corr )  go to 2115
      error = 0.0
 2005 cs = cs * z1
      if ( k5 .lt. 4 ) go to 2111
      m5 = m5 + 1
      go to 2110
 2113 deltaq = bcars(i5) * cs
      deltap = deltaq
      if ( k5 .eq. 1 ) deltap = -deltap
      go to 2004
 2114 deltaq = -deltap
      deltap = h1
      go to 2004
 2115 if ( error .gt. onehaf ) go to 127
      error = unity
      go to 2005
 5152 cs = unity / z1
      c2 = cs * cs
      r1 = r1 - c2
      do 2006  i5=1, 7, 2
      r1 = r1 + ccars(i5) * cs
      xs = xs + dcars(i5) * cs
 2006 cs = cs * c2
  127 r1 = r1 * f2
 4128 z(ip) = xs * f2
      p(ip) = r1
      if ( iprsup .ge. 4 )
     1 write (lunit6, 4439)  i, k, kfull, kcirct, i5, ip, p(ip), z(ip)
      go to 2120
 5200       if ( iprsup .ge. 1 )
     1 write (lunit6, 4434)  j7, j10, j56, kcirct, j8, j11, j12,
     2                       idist, j9, kp, j2, j3, j5, j6
 4434 format ( /,  ' at 4234.   misc. integers.'   ,/, ( 1x, 10i12 ) )
      go to 1449
 5202 call cxredu ( p(1), z(1),  workr1(1), workr2(1),  kfull,  kcirct )
 8202 if ( iprsup .ge. 1 )
     1 write (lunit6, 3202)   dist
 3202 format ( '  DIST =',   e25.16  )
 3203 j56 = 1
      do 1204  i=1, kp
      p(i) = -p(i)
 1204 z(i) = -z(i)
      call cxredu ( p(1), z(1), workr1(1), workr2(1), kcirct, ll0 )
      do 3206  i=1, kp
      gd(i) = p(i)
 3206 bd(i) = z(i)
 3207 go to 5600
 4839 i2 = 3
      i2 = i2 + 1
      do 2391  i=1, kp
 2391 p(i) = -p(i)
      call reduction ( p(1), workr1(1), kcirct, ll0, ierr, iprsup,
     &                 lunit6 )
      if ( iprsup .lt. 1 )  go to 5124
      write (lunit6, '(a, 6e12.5)') ' Ready for [C] avg.  P(1:6) =',
     1                                ( p(i), i=1, 6 )
      write (lunit6, '(a, 6e12.5)') ' Begin averaging of capacitance.'
      write (lunit6, '(a, 6e12.5)') ' 1st diagonal,  P(1) =',  p(1)
      write (lunit6, '(a, 6e12.5)') ' 1st off-diagonal,  P(2) =',  p(2)
      write (lunit6, '(a, 6i10)') ' =======  , KCIRCT, freq =',
     1                        kcirct, freq
 5124 call mover ( p(1), yd(1), kp )
      go to 2980
 5600 if ( metrik .eq. 1 )  go to 2610
      go to 4612
 2610 distm = dist / fmipkm
 4612 if ( idist .eq. 1 ) go to 1603
      go to 9800
 1603 ip = 0
      d1 = 1.d+20
      do 2604  k=1, kcirct
      ip = ip + k
      h1 = valu6 * bd(ip) / yd(ip)
      if ( dabs ( h1 ) .lt. d1 ) d1 = dabs ( h1 )
 2604 continue
      d1 = dsqrt ( d1 * 2.0 )
      i1 = dist / d1 + onehaf
      i2 = 1
      do 4606  isec=1, 34
      if ( i2 .gt. i1 )  go to 5608
 4606 i2 = i2 * 2
      go to 9800
 5608 x1 = i2
      i1 = isec - 1
      deltad = dist / x1
 3615 f1 = unity / deltad
      f2 = deltad * onehaf
      kp = kcirct * ( kcirct + 1 ) / 2
      kcir2 = 2 * kcirct
      if ( i1 .eq. 0 )  go to 2670
      do 4621  i=1, kp
      r1 = f1 * gd(i)
      x1 = f1 * bd(i)
      g1 = f2 * yd(i)
      d1 = x1 + g1
      p(i) = r1
      z(i) = d1
      gd(i) = r1 + r1
 4621 bd(i) = x1 + d1
      icount = 0
 2622 icount = icount + 1
      if ( icount .eq. isec )  go to 1650
      ip = 0
      i3 = kp
      do 3623  k=1, kcirct
      i2 = i3 + kcirct
      l4 = kp + k
      do 2624  i=1, k
      l1 = ip + i
      l2 = i2 + i
      l3 = i3 + i
      r1 = p(l1)
      x1 = z(l1)
      h1 = r1 - gd(l1)
      h2 = x1 - bd(l1)
      p(l2) = r1 * 2.0
      z(l2) = x1 * 2.0
      p(l3) = h1
      z(l3) = h2
      gd(l1) = r1
      bd(l1) = x1
      if ( i .eq. k ) go to 4625
      p(l4) = h1
      z(l4) = h2
      l4 = l4 + i + kcirct
 2624 continue
 4625 ip = ip + k
      i3 = i2 + k
 3623 continue
      call cxredu ( p(1), z(1),  workr1(1), workr2(1),  kcir2,  kcirct )
      go to 2622
 1650 do 3651  i=1, kp
      gd(i) = gd(i) - p(i)
      bd(i) = bd(i) - z(i)
      p(i) = ( p(i) - gd(i) ) * 2.0
 3651 z(i) = ( z(i) - bd(i) ) * 2.0
 4673 go to 1660
 2652 call lcsym1 ( gd(1), bd(1) )
      if ( iprsup .ge. 1)
     &   write (lunit6, '(a, 6e12.5)') ' GD(1:6) AND BD(1:6) =',
     &     (gd(i),bd(i), i=1,6)
      call lcsym1 ( p(1), z(1) )
      if ( iprsup .ge. 1)
     &   write (lunit6, '(a, 6e12.5)') ' P(1:6) AND Z(1:6)=',
     &    (p(i),z(i), i=1,6)
      d99 = basekv ** 2 / basmva
      zout(3) = p(5) * d99              ! half of pos-seq shunt adm.,
      zout(4) = z(5) * d99              ! in p.u., real & imag. parts

      temp1 = p(5)     !  Shunt admittance in mhos
      temp2 = z(5)     !

 5654 do 2655  i=1, kp
      n1 = 2 * nthalf + 1 + i
      n2 = i + nthalf
      gd(i) = -p(n2)
      bd(i) = -z(n2)
      p(i) = -p(n1)
 2655 z(i) = -z(n1)
      call cxredu ( gd(1), bd(1), workr1(1), workr2(1), kcirct, ll0 )
      call cxredu ( p(1), z(1), workr1(1), workr2(1), kcirct, ll0 )
      call lcsym1 ( gd(1), bd(1) )
      d89 = basmva / (basekv ** 2)
      if ( iprsup .ge. 1) then
         write (lunit6,'(a, 6e12.5)') ' GD(1:6) AND BD(1:6) =',
     &     (gd(i),bd(i), i=1,6)
      endif
      zout(1) = gd(5) * d89           ! pos-seq transfer imp, in
      zout(2) = bd(5) * d89           ! p.u., real and imag. parts
      zout(5) = gd(1) * d89           ! zerp-seq transfer imp, in
      zout(6) = bd(1) * d89           ! p.u., real and imag. parts
      write (lunit6, '(a, 6f10.3)') ' ZOUT(1:6) IN PHYSICAL UNIT:' ,
     1   gd(5), bd(5), temp1, temp2, gd(1), bd(1)
      write (lunit6, '(a, 6f10.5)') ' ZOUT(1:6) IN P.U. ARE:',
     &   ( zout(i), i=1,6)
      go to 9800
 1660 i = nthalf + 1
      call mover ( gd(1), p(i), kp )
      call mover ( bd(1), z(i), kp )
      i = 2 * i
      call mover ( p(1), p(i), kp )
      call mover ( z(1), z(i), kp )
      go to 2652
 2670 f2 = f2 * 2.0
      do 3671  i=1, kp
      p(i) = 0.0
      z(i) = f2 * yd(i)
      gd(i) = f1 * gd(i)
 3671 bd(i) = f1 * bd(i)
      go to 4673
 9800 if ( iprsup .ge. 1 )
     1 write (lunit6, 9818)   ierr
 9818 format ( ' Exit  "LINIMP".   IERR =',  i8  )
      return
      end