!
! ECMWF5K_Profile_Set
!
! Module containing the ECMWF5K atmospheric profile set data
! definitions and access routines
!
!
! CREATION HISTORY:
!       Written by:     David N. Groff, 29-Jul2009
!                       david.groff@noaa.gov
!
MODULE ECMWF5K_Profile_Set

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds           , ONLY: fp
  USE File_Utility         , ONLY: Get_Lun
  USE Message_Handler      , ONLY: SUCCESS, FAILURE, WARNING, INFORMATION, &
                                   Display_Message
  USE Fundamental_Constants, ONLY: STANDARD_GRAVITY
  USE Units_Conversion     , ONLY: SA_to_MR, &
                                   MR_to_PPMV
  USE ECMWF5K_Parameters   , ONLY: ECMWF5K_BINARY_FILE, &
                                   ECMWF5K_RECLEN     , &
                                   N_ECMWF5K_LEVELS   , &
                                   N_ECMWF5K_LAYERS   , &
                                   N_ECMWF5K_ABSORBERS, &
                                   N_ECMWF5K_PROFILES , &
                                   ECMWF5K_ABSORBER_ID  , &
                                   ECMWF5K_ABSORBER_UNITS_ID, &
                                   H2O_ID, O3_ID
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  ! Parameters
  PUBLIC :: N_ECMWF5K_LEVELS
  PUBLIC :: N_ECMWF5K_LAYERS
  PUBLIC :: N_ECMWF5K_ABSORBERS
  PUBLIC :: N_ECMWF5K_PROFILES
  ! Procedures
  PUBLIC :: Load_ECMWF5K_Profile

  ! ----------
  ! Parameters
  ! ----------
  ! Module RCS Id string
  CHARACTER(*), PARAMETER :: MODULE_RCS_ID = &
  ! Message string length
  INTEGER,  PARAMETER :: ML = 512
  ! The ECMWF data file name
  CHARACTER(*), PARAMETER :: ECMWF_DATA_FILE = './ECMWF5K_Profile_Set/'//ECMWF5K_BINARY_FILE

CONTAINS

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Load_ECMWF5K_Profile
!
! PURPOSE:
!       Function to return the requested profile from the ECMWF5K set of
!       atmospheric profiles.
!
! CALLING SEQUENCE:
!       Error_Status = Load_ECMWF5K_Profile( Profile,                               &  ! Input
!                                            Level_Pressure,                        &  ! Output
!                                            Level_Temperature,                     &  ! Output
!                                            Level_Absorber,                        &  ! Output
!                                            Absorber_ID       = Absorber_ID,       &  ! Optional output
!                                            Absorber_Units_ID = Absorber_Units_ID, &  ! Optional output
!                                            Description       = Description,       &  ! Optional output
!                                            Climatology_Model = Climatology_Model, &  ! Optional output
!                                            Year              = Year,              &  ! Optional output
!                                            Month             = Month,             &  ! Optional output
!                                            Day               = Day,               &  ! Optional output
!                                            Hour              = Hour,              &  ! Optional output
!                                            Latitude          = Latitude,          &  ! Optional output
!                                            Longitude         = Longitude,         &  ! Optional output
!                                            Surface_Altitude  = Surface_Altitude,  &  ! Optional output
!                                            RCS_Id            = RCS_Id,            &  ! Revision control
!                                            Message_Log       = Message_Log        )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Profile:            The requested atmospheric profile number from the
!                           ECMWF set.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       Level_Pressure:     Pressure profile for the requested
!                           atmospheric profile.
!                           UNITS:      hectoPascals, hPa
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Rank-1, n_levels
!                           ATTRIBUTES: POINTER
!
!       Level_Temperature:  Temperature profile for the requested
!                           atmospheric profile.
!                           UNITS:      Kelvin, K
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Rank-1, n_levels
!                           ATTRIBUTES: POINTER
!
!       Level_Absorber:     Absorber profiles for the requested atmospheric
!                           profile.
!                           UNITS:      Variable. See ABSORBER_UNITS_ID argument
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Rank-2, n_levels x n_absorbers
!                           ATTRIBUTES: POINTER
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:        Character string specifying a filename in which any
!                           messages will be logged. If not specified, or if an
!                           error occurs opening the log file, the default action
!                           is to output messages to standard output.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: INTENT(IN), OPTIONAL
!
! OPTIONAL OUTPUT ARGUMENTS:
!       Absorber_ID:        The list of the HITRAN absorber numbers for the
!                           molecular absorbers in the profile set.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Rank-1, n_absorbers
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Absorber_Units_ID:  The list of the absorber units ID numbers for
!                           the molecular absorbers in the profile set.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Rank-1, n_absorbers
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Description:        Description of the requested profile.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Climatology_Model:  Climatology model for the requested profile.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Year:               Year in which the requested profile sonde was launched.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Month:              Month in which the requested profile sonde was launched.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Day:                Day on which the requested profile sonde was launched.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Hour:               Hour in which the requested profile sonde was launched.
!                           UNITS:      UTC
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Latitude:           Latitude for the requested profile.
!                           UNITS:      Degrees North (-90 -> +90).
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Longitude:          Longitude for the requested profile.
!                           UNITS:      Degrees East (0 -> 360).
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       Surface_Altitude:   Surface altitude for the requested profile.
!                           UNITS:      Metres, m.
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
!       RCS_Id:             Character string containing the Revision Control
!                           System Id field for the module.
!                           UNITS:      N/A
!                           TYPE:       CHARACTER(*)
!                           DIMENSION:  Scalar
!                           ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
!       Error_Status:       The return value is an integer defining the error
!                           status. The error codes are defined in the
!                           ERROR_HANDLER module.
!                           If == SUCCESS the profile data load was successful.
!                              == FAILURE an unrecoverable error occurred.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Load_ECMWF5K_Profile( Profile,           &  ! Input
                                 Level_Pressure,    &  ! Output
                                 Level_Temperature, &  ! Output
                                 Level_Absorber,    &  ! Output
                                 Absorber_ID,       &  ! Optional output
                                 Absorber_Units_ID, &  ! Optional output
                                 Description,       &  ! Optional output
                                 Climatology_Model, &  ! Optional output
                                 Year,              &  ! Optional output
                                 Month,             &  ! Optional output
                                 Day,               &  ! Optional output
                                 Hour,              &  ! Optional output
                                 Latitude,          &  ! Optional output
                                 Longitude,         &  ! Optional output
                                 Surface_Altitude,  &  ! Optional output
                                 RCS_Id,            &  ! Revision control
                                 Message_Log )      &  ! Error messaging
                               RESULT( Error_Status )

    ! Arguments
    INTEGER     ,            INTENT(IN)  :: Profile
    REAL(fp)    ,            POINTER     :: Level_Pressure(:)
    REAL(fp)    ,            POINTER     :: Level_Temperature(:)
    REAL(fp)    ,            POINTER     :: Level_Absorber(:,:)
    INTEGER     , OPTIONAL,  INTENT(OUT) :: Absorber_ID(:)
    INTEGER     , OPTIONAL,  INTENT(OUT) :: Absorber_Units_ID(:)
    CHARACTER(*), OPTIONAL,  INTENT(OUT) :: Description
    INTEGER     , OPTIONAL,  INTENT(OUT) :: Climatology_Model
    INTEGER     , OPTIONAL,  INTENT(OUT) :: Year
    INTEGER     , OPTIONAL,  INTENT(OUT) :: Month
    INTEGER     , OPTIONAL,  INTENT(OUT) :: Day
    INTEGER     , OPTIONAL,  INTENT(OUT) :: Hour
    REAL(fp)    , OPTIONAL,  INTENT(OUT) :: Latitude
    REAL(fp)    , OPTIONAL,  INTENT(OUT) :: Longitude
    REAL(fp)    , OPTIONAL,  INTENT(OUT) :: Surface_Altitude
    CHARACTER(*), OPTIONAL,  INTENT(OUT) :: RCS_Id
    CHARACTER(*), OPTIONAL,  INTENT(IN)  :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Load_ECMWF5K_Profile'

    ! Local variables
    CHARACTER(ML) :: Message
    INTEGER :: Allocate_Status
    INTEGER :: IO_Status
    CHARACTER(ML) :: io_msg
    INTEGER :: FileID
    INTEGER :: m
    INTEGER :: H2O_Idx
    INTEGER :: O3_Idx

    REAL(fp) :: ECMWF_Latitude
    REAL(fp) :: ECMWF_Longitude
    INTEGER  :: ECMWF_Year
    INTEGER  :: ECMWF_Month
    INTEGER  :: ECMWF_Day

    REAL(fp), DIMENSION(N_ECMWF5K_LEVELS) :: hum, ozo, ozomr, cc, clw, ciw
    REAL(fp), DIMENSION(N_ECMWF5K_LEVELS) :: rain, snow, w
    REAL(fp) :: lsm, t2m, td2m, hum2m, u10, v10
    REAL(fp) :: stratrsrf, convrsrf, snowsurf, NLog_Surface_Pressure, Surface_Pressure
    REAL(fp) :: tsurf, z0
    INTEGER  :: Grid_Point, Ind, Step
    REAL(fp) :: Half_Level_Pressure(N_ECMWF5K_LEVELS+1)

    ! Setup
    ! -----
    Error_Status = SUCCESS
    IF ( PRESENT(RCS_Id) ) RCS_Id = MODULE_RCS_ID

    ! Is requested profile valid?
    IF ( Profile < 1 .OR. Profile > N_ECMWF5K_PROFILES ) THEN
      Error_Status = FAILURE
      WRITE( Message,'("Invalid model profile number ",i0," specified.")' ) Profile
      CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
      RETURN
    END IF

    ! Check output pointers
    IF ( ASSOCIATED(Level_Pressure) ) THEN
      DEALLOCATE( Level_Pressure, STAT=Allocate_Status )
      IF ( Allocate_Status /= 0 ) THEN
        Error_Status = FAILURE
        WRITE( Message,'("Error deallocating Level_Pressure output array. STAT = ",i0)' ) &
                       Allocate_Status
        CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
        RETURN
      END IF
    END IF
    IF ( ASSOCIATED(Level_Temperature) ) THEN
      DEALLOCATE( Level_Temperature, STAT=Allocate_Status )
      IF ( Allocate_Status /= 0 ) THEN
        Error_Status = FAILURE
        WRITE( Message,'("Error deallocating Level_Temperature output array. STAT = ",i0)' ) &
                       Allocate_Status
        CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
        RETURN
      END IF
    END IF
    IF ( ASSOCIATED(Level_Absorber) ) THEN
      DEALLOCATE( Level_Absorber, STAT=Allocate_Status )
      IF ( Allocate_Status /= 0 ) THEN
        Error_Status = FAILURE
        WRITE( Message,'("Error deallocating Level_Absorber output array. STAT = ",i0)' ) &
                       Allocate_Status
        CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
        RETURN
      END IF
    END IF

    ! Check output array sizes
    IF ( PRESENT(Absorber_ID) ) THEN
      IF ( SIZE(Absorber_ID) /= N_ECMWF5K_ABSORBERS ) THEN
        Error_Status = FAILURE
        WRITE( Message,'("Size of output Absorber_ID array must be ",i0," elements.")' ) &
                       N_ECMWF5K_ABSORBERS
        CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
        RETURN
      END IF
    END IF
    IF ( PRESENT(Absorber_Units_ID) ) THEN
      IF ( SIZE(Absorber_Units_ID) /= N_ECMWF5K_ABSORBERS ) THEN
        Error_Status = FAILURE
        WRITE( Message,'("Size of output Absorber_Units_ID array must be ",i0," elements.")' ) &
                        N_ECMWF5K_ABSORBERS
        CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
        RETURN
      END IF
    END IF

    ! Allocate output pointer arrays
    ALLOCATE( Level_Pressure( N_ECMWF5K_LEVELS ), &
              Level_Temperature( N_ECMWF5K_LEVELS ), &
              Level_Absorber( N_ECMWF5K_LEVELS, N_ECMWF5K_ABSORBERS ), &
              STAT = Allocate_Status )
    IF ( Allocate_Status /= 0 ) THEN
      Error_Status = FAILURE
      WRITE( Message,'("Error allocating output arrays. STATs = ",i0)' ) Allocate_Status
      CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
      RETURN
    END IF

    ! Determine the absorber array indices for H2O and O3
    H2O_Idx = Get_Absorber_Index( ECMWF5K_ABSORBER_ID, H2O_ID )
    IF ( H2O_Idx < 0 ) THEN
      Error_Status = FAILURE
      Message = 'No H2O in absorber list'
      CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
      RETURN
    END IF
    O3_Idx = Get_Absorber_Index( ECMWF5K_ABSORBER_ID, O3_ID )
    IF ( O3_Idx < 0 ) THEN
      Error_Status = FAILURE
      Message = 'No O3 in absorber list'
      CALL Display_Message( ROUTINE_NAME,TRIM(Message),Error_Status,Message_Log=Message_Log )
      RETURN
    END IF

    ! Open the data file
    FileID = Get_Lun()
    OPEN( FileID, FILE   = ECMWF_DATA_FILE, &
                  STATUS = 'OLD'          , &
                  ACCESS = 'DIRECT'       , &
                  FORM   = 'UNFORMATTED'  , &
                  ACTION = 'READ'         , &
                  RECL   = ECMWF5K_RECLEN , &
                  IOSTAT = io_status      , &
                  IOMSG  = io_msg           )
    IF ( io_status /= 0 ) THEN
      Error_Status = FAILURE
      Message = 'Error opening '//ECMWF_DATA_FILE//' - '//TRIM(io_msg)
      CALL Display_Message( ROUTINE_NAME, TRIM(Message), Error_Status, Message_Log = Message_Log )
      CLOSE( FileID )
      RETURN
    END IF

    ! Read the requested profile
    READ( FileID, REC    = Profile  , &
                  IOSTAT = io_status, &
                  IOMSG  = io_msg   ) &
      Level_Temperature,     &! 1) Temperature [K]                          (1-91)
      hum,                   &! 2) Humidity [kg/kg]                         (92-182)
      ozo,                   &! 3) Ozone [kg/kg]                            (183-273)
      cc,                    &! 4) Cloud Cover [0-1]                        (274-364)
      clw,                   &! 5) C Liquid W [kg/kg]                       (365-455)
      ciw,                   &! 6) C Ice W [kg/kg]                          (456-546)
      rain,                  &! 7) Rain [kg/(m2 *s)]                        (547-637)
      snow,                  &! 8) Snow [kg/(m2 *s)]                        (638-728)
      w,                     &! 9) Vertical Velocity [Pa/s]                 (729-819)
      NLog_Surface_Pressure, &!10) Ln of Surf Pressure in [Pa]              (820)
      z0,                    &!11) Surface geopotential [m2/s2]             (821)
      tsurf,                 &!12) Surface Skin Temperature [K]             (822)
      t2m,                   &!13) 2m Temperature [K]                       (823)
      td2m,                  &!14) 2m Dew point temperature [K]             (824)
      hum2m,                 &!15) 2m Specific Humidity [kg/kg]             (825)
      u10,                   &!16) 10m wind speed U component [m/s]         (826)
      v10,                   &!17) 10m wind speed V component [m/s]         (827)
      stratrsrf,             &!18) Stratiform rain at surface [kg/(m2 *s)]  (828)
      convrsrf,              &!19) Convective rain at surface [kg/(m2 *s)]  (829)
      snowsurf,              &!20) Snow at surface [kg/(m2 *s)]             (830)
      lsm,                   &!21) Land/sea Mask [0-1]                      (831)
      ECMWF_Latitude,        &!22) Latitude [deg]                           (832)
      ECMWF_Longitude,       &!23) Longitude [deg]                          (833)
      ECMWF_Year,            &!24) Year                                     (834)
      ECMWF_Month,           &!25) Month                                    (835)
      ECMWF_Day,             &!26) Day                                      (836)
      step,                  &!27) Step                                     (837)
      Grid_Point,            &!28) Grid point [1-843490]                    (838)
      Ind                     !29) Index (rank-sorted)                      (839)
    IF ( io_status /= 0 ) THEN
      Error_Status = FAILURE
      WRITE( Message,'("Error reading profile # ",i0," - ",a)' ) m, TRIM(io_msg)
      CALL Display_Message( ROUTINE_NAME, TRIM(Message), Error_Status, Message_Log=Message_Log )
      CLOSE( FileID )
      RETURN
    END IF
    CLOSE( FileId )

    ! Create pressure profile
    ! ...Compute surface pressure [Pa]
    Surface_Pressure = EXP(NLog_Surface_Pressure)
    ! ...Compute full-level pressure and half-level pressures [Pa]
    call ec_p91l(Surface_Pressure,Level_Pressure,Half_Level_Pressure)

    ! Put all arrays in required order
    CALL Reverse( Level_Pressure )
    CALL Reverse( Level_Temperature )
    CALL Reverse( hum )
    CALL Reverse( ozo )

    ! Perform units conversions
    ! ...Convert Level_Pressure from Pa to hPa
    CALL Convert_Pa_to_hPA( Level_Pressure )
    ! ...Convert specific amounts from g/g to g/Kg
    CALL Convert_GpG_TO_GpKG( hum )
    CALL Convert_GpG_TO_GpKG( ozo )
    ! ...Convert the specific amount of water vapor to mixing ratio
    CALL SA_to_MR( hum, Level_Absorber(:,H2O_Idx) )

    ! ...Convert the specific amount of ozone to mixing ratio
    CALL SA_to_MR( ozo, ozomr, Water_Vapor=Level_Absorber(:,H2O_Idx) )
    ! ...and now convert ozone from mixing ratio to ppmv
    CALL MR_to_PPMV( ozomr, Level_Absorber(:,O3_Idx), Molecule_ID=O3_ID )

    ! Set optional arguments
    IF ( PRESENT(Absorber_ID      ) ) Absorber_ID       = ECMWF5K_ABSORBER_ID
    IF ( PRESENT(Absorber_Units_ID) ) Absorber_Units_ID = ECMWF5K_ABSORBER_UNITS_ID
    IF ( PRESENT(Description      ) ) WRITE( Description,'("ECMWF5K profiles on 91L. Profile #",i0)' ) Profile
    IF ( PRESENT(Climatology_Model) ) Climatology_Model = Get_Climatology( ECMWF_Month, ECMWF_Latitude )
    IF ( PRESENT(Year             ) ) Year  = ECMWF_Year
    IF ( PRESENT(Month            ) ) Month = ECMWF_Month
    IF ( PRESENT(Day              ) ) Day   = ECMWF_Day
    IF ( PRESENT(Hour             ) ) Hour  = 0
    IF ( PRESENT(Latitude         ) ) Longitude        = ECMWF_Longitude
    IF ( PRESENT(Longitude        ) ) Latitude         = ECMWF_Latitude
    IF ( PRESENT(Surface_Altitude ) ) Surface_Altitude = Geopotential_to_Altitude( z0 )

  END FUNCTION Load_ECMWF5K_Profile

  FUNCTION Get_Absorber_Index(Absorber_Id_List, Absorber_Id) RESULT(Absorber_Index)
    INTEGER, INTENT(IN) :: Absorber_Id_List(:)
    INTEGER, INTENT(IN) :: Absorber_Id
    ! Function result
    INTEGER :: Absorber_Index
    ! Local variables
    INTEGER :: j, Idx(1)
    ! Initialise result to "not found"
    Absorber_Index = -1
    ! Return if absorber not present
    IF ( COUNT(Absorber_Id == Absorber_Id_List) /= 1 ) RETURN
    ! Find the location
    Idx = PACK( (/(j,j=1,SIZE(Absorber_Id_List))/), &
                Absorber_Id == Absorber_Id_List )
    Absorber_Index = Idx(1)
  END FUNCTION Get_Absorber_Index

  FUNCTION Get_Climatology( Month, Latitude ) RESULT( Climatology )
    INTEGER , INTENT(IN) :: Month
    REAL(fp), INTENT(IN) :: Latitude
    INTEGER              :: Climatology
    ! Local parameters
    ! ...The climatologies
    INTEGER, PARAMETER :: TROPICAL           = 1
    INTEGER, PARAMETER :: MIDLATITUDE_SUMMER = 2
    INTEGER, PARAMETER :: MIDLATITUDE_WINTER = 3
    INTEGER, PARAMETER :: SUBARCTIC_SUMMER   = 4
    INTEGER, PARAMETER :: SUBARCTIC_WINTER   = 5
    INTEGER, PARAMETER :: US_STD_ATM         = 6
    ! ...The months of the year
    INTEGER, PARAMETER :: JANUARY   =  1
    INTEGER, PARAMETER :: FEBRUARY  =  2
    INTEGER, PARAMETER :: MARCH     =  3
    INTEGER, PARAMETER :: APRIL     =  4
    INTEGER, PARAMETER :: MAY       =  5
    INTEGER, PARAMETER :: JUNE      =  6
    INTEGER, PARAMETER :: JULY      =  7
    INTEGER, PARAMETER :: AUGUST    =  8
    INTEGER, PARAMETER :: SEPTEMBER =  9
    INTEGER, PARAMETER :: OCTOBER   = 10
    INTEGER, PARAMETER :: NOVEMBER  = 11
    INTEGER, PARAMETER :: DECEMBER  = 12
    ! Local variables
    LOGICAL :: Region, Winter, Summer

    ! Topical
    IF ( ABS(Latitude) < 30.0_fp ) THEN
      Climatology = TROPICAL
      RETURN
    END IF

    ! Midlatitude - NORTHERN HEMISPHERE
    Region = ( Latitude >= 30.0_fp .AND. Latitude <= 60.0_fp )
    Summer = ( Month >= JUNE     .AND. Month <= AUGUST   )
    Winter = ( Month >= DECEMBER .AND. Month <= FEBRUARY )
    ! ...Northern hemisphere default to US STD ATM for spring/autumn
    IF ( Region ) Climatology = US_STD_ATM
    ! ...SUMMER
    IF ( Region .AND. Summer ) Climatology = MIDLATITUDE_SUMMER
    ! ...WINTER
    IF ( Region .AND. Winter ) Climatology = MIDLATITUDE_WINTER

    ! Midlatitude - SOUTHERN HEMISPHERE
    Region = ( Latitude <= -30.0_fp .AND. Latitude >= -60.0_fp )
    Winter = ( Month >= JUNE     .AND. Month <= AUGUST   )
    Summer = ( Month >= DECEMBER .AND. Month <= FEBRUARY )
    ! ...Southern hemisphere default to US STD ATM for spring/autumn
    IF ( Region ) Climatology = US_STD_ATM
    ! ...SUMMER
    IF ( Region .AND. Summer ) Climatology = MIDLATITUDE_SUMMER
    ! ...WINTER
    IF ( Region .AND. Winter ) Climatology = MIDLATITUDE_WINTER

    ! SUBARCTIC - NORTHERN HEMISPHERE
    Region = ( Latitude > 60.0_fp )
    Summer = ( Month >= MAY .AND. Month <= OCTOBER )
    ! ...Northern hemisphere default to SUBARCTIC_WINTER
    IF ( Region ) Climatology = SUBARCTIC_WINTER
    ! ...SUMMER
    IF ( Region .AND. Summer ) Climatology = SUBARCTIC_SUMMER

    ! SUBARCTIC - SOUTHERN HEMISPHERE
    Region = ( Latitude < -60.0_fp )
    Winter = ( Month >= MAY .AND. Month <= OCTOBER )
    ! ...Southern hemisphere default to SUBARCTIC_SUMMER
    IF ( Region ) Climatology = SUBARCTIC_SUMMER
    ! ...WINTER
    IF ( Region .AND. Winter ) Climatology = SUBARCTIC_WINTER

  END FUNCTION Get_Climatology

  SUBROUTINE Reverse( array )
    REAL(fp), INTENT(IN OUT) :: array(:)
    INTEGER :: n
    n = SIZE(array)
    array = array(n:1:-1)
  END SUBROUTINE Reverse

  SUBROUTINE Convert_Pa_to_hPa( Pressure )
    REAL(fp), INTENT(IN OUT) :: Pressure(:)
    REAL(fp), PARAMETER :: PA_TO_HPA  = 1.0e-02_fp
    Pressure = Pressure * PA_TO_HPA
  END SUBROUTINE Convert_Pa_to_hPa

  SUBROUTINE Convert_GpG_TO_GpKG( Absorber )
    REAL(fp), INTENT(IN OUT) :: Absorber(:)
    REAL(fp), PARAMETER :: GpG_TO_GpKG = 1000.0_fp
    Absorber = Absorber * GpG_TO_GpKG
  END SUBROUTINE Convert_GpG_TO_GpKG

  FUNCTION Geopotential_to_Altitude( Geopotential ) RESULT( Altitude )
    REAL(fp), INTENT(IN) :: Geopotential
    REAL(fp)             :: Altitude
    Altitude = Geopotential/STANDARD_GRAVITY
  END FUNCTION Geopotential_to_Altitude

  SUBROUTINE EC_P91l(spres,pap,paph)
  !
  !    This software was developed within the context of
  !    the EUMETSAT Satellite Application Facility on
  !    Numerical Weather Prediction (NWP SAF), under the
  !    Cooperation Agreement dated 25 November 1998, between
  !    EUMETSAT and the Met Office, UK, by one or more partners
  !    within the NWP SAF. The partners in the NWP SAF are
  !    the Met Office, ECMWF, KNMI and MeteoFrance.
  !
  !    Copyright 2006, EUMETSAT, All Rights Reserved.
  !
  !     Description:
  !     Computes the 91-level vertical pressure grid
  !       associated to the input surface pressure
  !     All pressures are in Pa

    implicit none
    integer, parameter    :: nlev=91
    integer               :: jk
    real(fp)      :: spres
    real(fp)      :: aam(nlev+1), bbm(nlev+1)
    real(fp)      :: pap(nlev), paph(nlev+1)

    data aam / &
       0.000000_fp, &
       2.000040_fp, &
       3.980832_fp, &
       7.387186_fp, &
      12.908319_fp, &
      21.413612_fp, &
      33.952858_fp, &
      51.746601_fp, &
      76.167656_fp, &
     108.715561_fp, &
     150.986023_fp, &
     204.637451_fp, &
     271.356506_fp, &
     352.824493_fp, &
     450.685791_fp, &
     566.519226_fp, &
     701.813354_fp, &
     857.945801_fp, &
    1036.166504_fp, &
    1237.585449_fp, &
    1463.163940_fp, &
    1713.709595_fp, &
    1989.874390_fp, &
    2292.155518_fp, &
    2620.898438_fp, &
    2976.302246_fp, &
    3358.425781_fp, &
    3767.196045_fp, &
    4202.416504_fp, &
    4663.776367_fp, &
    5150.859863_fp, &
    5663.156250_fp, &
    6199.839355_fp, &
    6759.727051_fp, &
    7341.469727_fp, &
    7942.926270_fp, &
    8564.624023_fp, &
    9208.305664_fp, &
    9873.560547_fp, &
   10558.881836_fp, &
   11262.484375_fp, &
   11982.662109_fp, &
   12713.897461_fp, &
   13453.225586_fp, &
   14192.009766_fp, &
   14922.685547_fp, &
   15638.053711_fp, &
   16329.560547_fp, &
   16990.623047_fp, &
   17613.281250_fp, &
   18191.029297_fp, &
   18716.968750_fp, &
   19184.544922_fp, &
   19587.513672_fp, &
   19919.796875_fp, &
   20175.394531_fp, &
   20348.916016_fp, &
   20434.158203_fp, &
   20426.218750_fp, &
   20319.011719_fp, &
   20107.031250_fp, &
   19785.357422_fp, &
   19348.775391_fp, &
   18798.822266_fp, &
   18141.296875_fp, &
   17385.595703_fp, &
   16544.585938_fp, &
   15633.566406_fp, &
   14665.645508_fp, &
   13653.219727_fp, &
   12608.383789_fp, &
   11543.166992_fp, &
   10471.310547_fp, &
    9405.222656_fp, &
    8356.252930_fp, &
    7335.164551_fp, &
    6353.920898_fp, &
    5422.802734_fp, &
    4550.215820_fp, &
    3743.464355_fp, &
    3010.146973_fp, &
    2356.202637_fp, &
    1784.854614_fp, &
    1297.656128_fp, &
     895.193542_fp, &
     576.314148_fp, &
     336.772369_fp, &
     162.043427_fp, &
      54.208336_fp, &
       6.575628_fp, &
       0.003160_fp, &
       0.000000_fp /

    data bbm / &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000000_fp, &
   0.000014_fp, &
   0.000055_fp, &
   0.000131_fp, &
   0.000279_fp, &
   0.000548_fp, &
   0.001000_fp, &
   0.001701_fp, &
   0.002765_fp, &
   0.004267_fp, &
   0.006322_fp, &
   0.009035_fp, &
   0.012508_fp, &
   0.016860_fp, &
   0.022189_fp, &
   0.028610_fp, &
   0.036227_fp, &
   0.045146_fp, &
   0.055474_fp, &
   0.067316_fp, &
   0.080777_fp, &
   0.095964_fp, &
   0.112979_fp, &
   0.131935_fp, &
   0.152934_fp, &
   0.176091_fp, &
   0.201520_fp, &
   0.229315_fp, &
   0.259554_fp, &
   0.291993_fp, &
   0.326329_fp, &
   0.362203_fp, &
   0.399205_fp, &
   0.436906_fp, &
   0.475016_fp, &
   0.513280_fp, &
   0.551458_fp, &
   0.589317_fp, &
   0.626559_fp, &
   0.662934_fp, &
   0.698224_fp, &
   0.732224_fp, &
   0.764679_fp, &
   0.795385_fp, &
   0.824185_fp, &
   0.850950_fp, &
   0.875518_fp, &
   0.897767_fp, &
   0.917651_fp, &
   0.935157_fp, &
   0.950274_fp, &
   0.963007_fp, &
   0.973466_fp, &
   0.982238_fp, &
   0.989153_fp, &
   0.994204_fp, &
   0.997630_fp, &
   1.000000_fp /

   do jk=1,nlev+1
     paph(jk)=aam(jk)+bbm(jk)*spres
   end do
   do jk=1,nlev
     pap(jk)=0.5*(paph(jk)+paph(jk+1))
   end do

   return
   end subroutine ec_p91l

END MODULE ECMWF5K_Profile_Set


! --------------- BEGIN a_ts_drvr ---------------------------------
      Program a_ts_drvr

!  Driver to calculate and save a suite of acceleration time series.
!  This program obtains input parameters, calls the time domain simulation
!  program smsimacc.for, and saves each simulation in smc format.

! Sample control file:
!!Control file for program a_ts_drvr
!!Comment:
! Test case for program a_ts_drvr
!!Name of Summary File:
! a_tsdrvr.sum
!!Name of File with Input Parameters:
! ofr4.dat
!!Stem name for smc files.
! m7r20_
!! M, R:
! 7.0 20.0
!!Total number of simulations (overrides value in input parameter file):
!!Number of first simulation to save and number of simulations to save:
! 12 2 10

! Notes regarding modification of driver:
!  1. All "include" statements assume all subprograms are in the same folder
!     as this program.
!  2. The logical variable "new_mr" must be explicitly set (= .true. for a
!     new value of magnitude and distance); its value is passed through the
!     block common /misc/ (see SMSIM.FI).
!  3. If values of stress other than those in the input parameter file are
!     to be used, set "stressc" equal to the new value, rather than "stress"
!     (and also set the other parameters if the stress changes with moment).
! Dates: 05/29/02 - Written by D. M. Boore
!        06/13/02 - Changed name from "acc_drvr" to "a_tsdrvr" to indicate that
!                   acceleration time series are being computed (in contrast
!                   to "gmtddrvr" which computes various ground motion
!                   measures.
!        02/06/03 - removed new_mr from logical statement; it is
!                   declared in smsim.fi
!        02/09/03 - Make sure that leading and trailing blanks are removed
!                   from the input file names (because LF95 allows file names
!                   with blanks).
!        08/15/05 - No longer any restriction on the length of the stem name,
!                   except restrict number of simulations to <1000
!        01/24/06 - Remove limitation on nsims
!        05/11/07 - Removed "\smsim\" from include statements
!        02/20/09 - ntaper was not being passed out of get_npts and into acc_ts.
!                   I caught this only when I compiled the program using the -chk
!                   switch.  This probably means that all of my time-domain runs
!                   up till now used ntaper = 0, even if a nonzero taper was
!                   specified (the standard being 0.05).
!        02/26/09 - Updated calls to get date and time.
!        12/04/09 - Change subroutine name Get_Npts to Get_Npts_for_TD_Calcs
!        04/06/11 - I replaced "h_eff" with "f_ff" (because the finite-fault factor is not
!                   really a pseudo-depth).
!                 - Call rmod_calc to compute rmod (rmod = rmod_calc(r, m, iflag, c1, c2, f_ff) )
!        06/29/11 - Add name of params file to smc header
!        12/02/11 - Add computation of am0 right after specification of amag (previously, it
!                   was contained in spect_scale, but it was not clear from where that routine was
!                   called--it was in get_npts_for_td_calcs, called from the driver program.
!        06/04/13 - Add fa, fb, dursource, durpath to headers in SMC file
!        01/06/14 - Increase length of filenames
!        02/07/14 - Add a sorted list of PGAs and mean PGA to summary file
!                   Change "nsims" to "nsims2save"
!                   Change index in output file name to correspond to the actual isim
!        10/13/14 - Allow for f_ff being defined by two lines
!        12/21/14 - Allow for f_ff being defined by a transition curve between two lines; this
!                   required a change to the calling arguments of rmod_calc

      character f_ctl*200, f_params*200, f_sum*200, stem*200
      character f_smc*200, cmmnt_hdrs(20)*80
      character message*80
      character date*8, time_start*10, time_stop*10
      logical tdflag, fparam_exist, f_ctl_exist

      character char_head(11)*80, comments(30)*80
      character precision*20
      integer int_head(48)
      real real_head(50)

      real pga(3000), rindex(3000)

      real acc(:)
      allocatable :: acc

      include 'smsim.fi'

! pi, twopi now computed in smsim.fi
!      pi = 4.0 * atan(1.0)
!      twopi = 2.0 * pi

      call banner(6)

      f_ctl_exist = .false.
      do while (.not. f_ctl_exist)
        f_ctl = ' '
        write(*, '(a\)')
     :    ' Enter name of control file '//
     :    '(cr = a_ts_drvr.ctl; ctl_brk to quit): '
        read(*, '(a)') f_ctl
        if (f_ctl .eq. ' ') f_ctl = 'a_ts_drvr.ctl'
        inquire(file=f_ctl, exist=f_ctl_exist)
        if (.not. f_ctl_exist) then
          write(*,'(a)') ' ******* FILE DOES NOT EXIST ******* '
        end if
      end do

      call trim_c(f_ctl, nc_f_ctl)
      call get_lun(nu_ctl)
      open(unit=nu_ctl,file=f_ctl,status='unknown')

      call skipcmnt(nu_ctl,cmmnt_hdrs, nc_hc)
      message = ' '
      read(nu_ctl,'(a)') message

      call skipcmnt(nu_ctl,cmmnt_hdrs, nc_hc)
      f_sum = ' '
      read(nu_ctl, '(a)') f_sum
      call trim_c(f_sum, nc_f_sum)
      call get_lun(nu_sum)
      open(unit=nu_sum,file=f_sum(1:nc_f_sum),status='unknown')
      write(nu_sum,'(a)') ' Summary file for program a_ts_drvr'
      write(nu_sum,'(a)') '   Using control file: '//f_ctl
      write(nu_sum, '(a)')
     :    ' *** Results computed using A_TS_DRVR ***'
      call banner(nu_sum)
      write(nu_sum, '(a)') message

! Standard Fortran 90 intrinsic Subroutine DATE_AND_TIME
      call DATE_AND_TIME( date, time_start )
! Date is returned as 'CCYYMMDD' (character date*8)
! Time is returned as 'hhmmss.sss' (character time*10)
!     character datx*8, time_start*10
      write(nu_sum, *)
      write(nu_sum, '(a)')
     :   ' Date: '//date(1:4)//'/'//date(5:6)//'/'//date(7:8)
      write(nu_sum, '(a)')
     : ' Time Start: '//
     : time_start(1:2)//':'//time_start(3:4)//':'//time_start(5:10)
      write(nu_sum, *)

      call skipcmnt(nu_ctl,cmmnt_hdrs, nc_hc)
      f_params = ' '
      read(nu_ctl, '(a)') f_params
      call trim_c(f_params, nc_f_params)
      inquire(file=f_params(1:nc_f_params), exist=fparam_exist)
      if (.not. fparam_exist) then
        write(*,'(a)') ' ******* Parameter file '//
     :                 f_params(1:nc_f_params)//
     :                 ' does not exist; QUITTING!!! ******* '
        close(nu_ctl)
        stop
      end if

      write(nu_sum, '(2a)') ' file with parameters: ',
     :   f_params(1:nc_f_params)

      tdflag = .true.  ! controls extent of the input file read and written
      call get_params( f_params(1:nc_f_params), tdflag )
      call write_params(nu_sum, tdflag)

      call skipcmnt(nu_ctl,cmmnt_hdrs, nc_hc)
      stem = ' '
      read(nu_ctl, '(a)') stem
      call trim_c(stem, nc_stem)
      write(nu_sum,'(a)') ' Stem = '//stem(1:nc_stem)

      call skipcmnt(nu_ctl,cmmnt_hdrs, nc_hc)
      read(nu_ctl,*) amag, r
      write(nu_sum, '(a)') ' amag    r ='
      write(nu_sum,'(2x,f4.2, 1x,f7.2)' ) amag, r
      write(*, '(a)') ' amag    r ='
      write(*,'(2x,f4.2, 1x,f7.2)' ) amag, r

      am0 = 10.**(1.5*amag + 16.05)

! replace h_eff with f_ff
      rmod = rmod_calc(r, amag,
     :                  iflag_f_ff, nlines_f_ff,
     :                  c1_log10_f_ff, c2_log10_f_ff, mh_f_ff,
     :                  c3_log10_f_ff, c4_log10_f_ff,
     :                  m1t_f_ff, m2t_f_ff,
     :                  c0t_f_ff, c1t_f_ff, c2t_f_ff, c3t_f_ff,
     :                                                          f_ff)

      new_mr = .true.

      call skipcmnt(nu_ctl,cmmnt_hdrs, nc_hc)
      read(nu_ctl,*) nsims_total, nsims_start, nsims2save
      write(nu_sum, '(a)') ' nsims_total, nsims_start, nsims2save = '
      write(nu_sum,*) nsims_total, nsims_start, nsims2save

!      if (nsims2save .gt. 999) nsims2save = 999

      close(nu_ctl)

      call Get_Npts_for_TD_Calcs(nstart, nstop, npw2, te, ntaper)  ! included in td_subs
      write(nu_sum,'(a, 1x,i6, 1x,i6)')
     :      ' nstart, nstop = ', nstart, nstop
      write(nu_sum,'(a, 1x,i6, 1x, f8.2)') ' npw2, te = ', npw2, te

      ndimen = npw2
      allocate (acc(ndimen))

! Initialize seed:
      iseed = -abs(seed)

! Loop over simulations:

      write(*,*)
      jsim = 0
      loop over simulations: do isim = 1, nsims_total
        write(*,'(3(a,i6),a)')
     :    '+ Patience! Computing accelerogram # ', isim,
     :    ' of ', nsims_total

        call acc_ts(acc, nstart, nstop, npw2, te, ntaper)

        call mnmax(acc,1,npw2,1,amin,amax)

        pga(isim) = max(abs(amin), abs(amax))
        rindex(isim) = real(isim)

!DEBUG
!        write(nu_sum,'(1x,a, 1x,i5, 1x,es10.3)')
!     :   ' index, pga = ', int(rindex(isim)), pga(isim)
!DEBUG

        if (isim .ge. nsims_start .and. jsim .lt. nsims2save) then

          jsim = jsim + 1

! Now write it:

          f_smc = ' '
          f_smc(1:nc_stem) = stem(1:nc_stem)
          write(f_smc(nc_stem+1:nc_stem+5),'(i5.5)') isim

!          if (nc_stem .lt. 6) then
!            f_smc(1:nc_stem) = stem(1:nc_stem)
!            write(f_smc(nc_stem+1:nc_stem+3),'(i3.3)') jsim
!          else if (nc_stem .eq. 6) then
!            f_smc(1:6) = stem(1:6)
!            write(f_smc(7:8),'(i2.2)') jsim
!          else
!            f_smc(1:7) = stem(1:7)
!            write(f_smc(8:8),'(i1)') jsim
!          end if

          call trim_c(f_smc,nc_f_smc)
          f_smc = f_smc(1:nc_f_smc)//'.smc'
          nc_f_smc = nc_f_smc + 4

! set default values for int_head = -32768
!                    real_head = 1.7e+38

          do i = 1, 48
            int_head(i) = -32768
          end do

          do i = 1, 50
            real_head(i) = 1.7e+38
          end do

          int_head(17) = npw2
          real_head(2) = 1.0/dt
          write(nu_sum,'(a, 1x,i6, 1x,es12.5, 1x,es12.5)')
     :         ' jsim, real_head(2), dt = ', jsim, real_head(2), dt

          ncomments = 0
          ncomments = ncomments + 1
          comments(ncomments) = '|'
          ncomments = ncomments + 1
          comments(ncomments) = '| File made using program a_ts_drvr'
          ncomments = ncomments + 1
          comments(ncomments) =
     :      '|   on '//
     :           date(1:4)//'/'//date(5:6)//'/'//date(7:8)//
     :      ' at time '//
     :    time_start(1:2)//':'//time_start(3:4)//':'//time_start(5:10)
          ncomments = ncomments + 1
          write(comments(ncomments),'(a,1x,i6,a,1x,i6)')
     :      '|   simulation ', jsim, ' of ', nsims
          ncomments = ncomments + 1
          write(comments(ncomments),'(a,1x,i6,a,1x,i6)')
     :      '|   starting at simulation ', nsims_start
          ncomments = ncomments + 1
          comments(ncomments) = '|    using control file '//
     :                        f_ctl(1:nc_f_ctl)
          ncomments = ncomments + 1
          comments(ncomments) = '|    and params file '//
     :                        f_params(1:nc_f_params)
          ncomments = ncomments + 1
          write(comments(ncomments),'(a,1x,f4.2,a,1x,f7.2,1x,f7.2)')
     :      '|   for M = ', amag, ' and R, Rmod = ', r, rmod
          ncomments = ncomments + 1
          write(comments(ncomments),'(a, 1x,es11.4, 1x,es11.4)')
     :      '|   fa, fb = ', fa, fb
          ncomments = ncomments + 1
          write(comments(ncomments),'(a, 1x,es11.4, 1x,es11.4)')
     :      '|   and dursource, durpath = ',
     :             dursource_calc, durpath_calc
          ncomments = ncomments + 1
          write(comments(ncomments),'(a, 1x,es11.4)')
     :      '|   and dursource + durpath = ',
     :               dursource_calc + durpath_calc
          ncomments = ncomments + 1
          comments(ncomments) = '|'

          int_head(16) = ncomments

          do i = 1, 11
            char_head(i) = '*'
          end do

          if (fcut .eq. 0.0) then
            itype = 1
          else
            itype = 2
          end if

          precision = 'standard'
          call SMCWrite(f_smc(1:nc_f_smc), precision, acc,
     :                    char_head, itype,
     :                    int_head, real_head, comments)

        end if

      end do  loop over simulations

      deallocate (acc)

      call sort2(nsims_total,pga,rindex)
      write(nu_sum,*)
      write(nu_sum,'(1x,a, 7x,a)') 'index', 'pga'
      do i = 1, nsims_total
        write(nu_sum,'(1x,i5, 1x,es10.3)') int(rindex(i)), pga(i)
      end do
      write(nu_sum,*)

      itype = 1
      call avg_std(pga,nsims_total,arith_mean,std,itype)
      itype = 2
      call avg_std(pga,nsims_total,geom_mean,std,itype)
      write(nu_sum,'(1x,a, 1x,es10.3)')
     :         ' arithmetic mean = ', arith_mean
      write(nu_sum,'(1x,a, 1x,es10.3)')
     :         ' geometric mean = ', geom_mean
      write(nu_sum,*)

      write(nu_sum, *)
      call DATE_AND_TIME( date, time_stop )
      write(nu_sum, '(a)')
     : ' Time Stop: '//
     : time_stop(1:2)//':'//time_stop(3:4)//':'//time_stop(5:10)
      call time_diff(time_start, time_stop, time_elapsed)
      write(nu_sum, '(a,1x,1pe10.3)')
     :     ' Elapsed time (sec): ', time_elapsed

      close(unit=nu_sum)

      stop
      end
! --------------- END a_ts_drvr ---------------------------------

!      include 'acc_ts.for'
!      include 'td_subs.for'
!      include 'rv_td_subs.for'
!      include 'recipes.for'
      include 'td_subs.for'
      include 'smsim_util_subs.for'


module writeEnkF
integer :: iwENKF
end module writeEnkF

!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
subroutine filterUpNS(dPRData,dPRRet, Xens,Yens,Yobs,Xup,tb,&
     dprRain,sfcRain,nmemb1,ic,i,j,&
     nxu,nyu,wfractm,s0KuVar,s0KaVar,s0Cov,hFreqTb)
!  SFM  end    07/29/2014
  use f90DataTypes
  use f90Types
  use writeEnKF
  implicit none
  type (dPRDataType)     :: dPRData
  type (dPRRetType)     :: dPRRet
  real :: Xens(nxu,nmemb1),Yens(nyu,nmemb1),Yobs(nyu), Xup(nxu)
  integer :: nmemb1,ic
  integer :: nxu,nyu
  integer :: ink,nx, ny, i, j, k
  integer :: ipias(2)
  integer :: ipol(15), ifreq(15), iobs(15)
  real :: tb(49,300,15), dprrain(49,300)!, tbRgrid(9,49,9300),
  real :: sfcRain(49,300),sfcRainStd(49,300)
  real :: s0KuVar(49,300), s0KaVar(49,300), s0Cov(49,300), hFreqTb(4)
!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
  real :: ymean, ystd, wfractm
  integer :: imemb, ifreqS2(4), ipolS2(4), iprint
  real ::  stddev, spia1, spia2
!  SFM  end    07/29/2014

!!  integer*4 :: ob_flag(100)
!!  ob_flag = -9

  ink=0

  Xens(1,1:1*nMemb1)=(dPRRet%sfcRainEns(i,j,1:1*nmemb1))
  nx=1
  do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
!  SFM  begin  06/22/2014; for M.Grecu (unknonw justification)
!begin  WSO 9/11/4 change zka1c21 to zku1c21
     if( dPRData%zku1c21(k,i,j)>12 .and. dPRRet%rrate(1,k,i,j)>0) then
!end    WSO 9/11/14
!  SFM  end    06/22/2014
!  SFM  end    07/29/2014
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%rrate(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%pwc(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%d0(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%log10dNw(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%z13c(1:nmemb1,k,i,j)
     endif
  enddo
  !Start SJM  12/4/2014
  nx=nx+1
  Xens(nx,1:nMemb1)=dPRRet%pia13mod(i,j,1:nmemb1)
  if(wfractm .gt. 99) then
    nx=nx+1
    Xens(nx,1:nMemb1)=dPRRet%simSigmaZeroKu(i,j,1:nmemb1)
    nx=nx+1
    Xens(nx,1:nMemb1)=dPRRet%sfcWindEns(i,j,1:nmemb1)
  endif
  !end SJM 12/4/2014
  do k=1,10
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%cldwcoeff(i,j,k,1:nmemb1)
  enddo
  !print*, 'nx1=',nx
  do k=1,8
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%tb(i,j,1,k,1:1*nmemb1)
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%tb(i,j,2,k,1:1*nmemb1)
  enddo
120 format(8(F6.2,1x))

  ny=ink+2

  if(dPRData%snrRatioku(i, j) > 2.) then! .and. dPRData%srtrelPIAku(i,j) > 2.9) then  !SJM 12/8/2014 should not need to filter by relPIA if wind variance is accounted for
     if(wfractm .le. 99) then
       Yobs(ink+1) = dPRData%srtPIAku(i,j)
       Yens(ink+1,1:1*nMemb1)=1*dPRRet%pia13mod(i,j,1:nmemb1)
       if(dPRData%NSRelibFlag(i,j)==1 .or. dPRData%NSRelibFlag(i,j)==2) then
         s0Kuvar(i,j)=16
       else
         s0Kuvar(i,j)=1.e4
       endif
     else
       !Start SJM  12/4/2014
       Yobs(ink+1) = dPRData%sigmaZeroKu(i,j)
       Yens(ink+1,1:1*nMemb1)=dPRRet%simSigmaZeroKu(i,j,1:nmemb1)
       !Yobs(ink+1) = dPRData%srtPIAku(i,j)
       !Yens(ink+1,1:1*nMemb1)=1*dPRRet%pia13mod(i,j,1:nmemb1)

     endif

   else
     Yobs(ink+1) = 0
     Yens(ink+1,1:1*nMemb1)=0
     !end SJM 12/4/2014
  endif
  Yobs(ink+2)=0.
  Yens(ink+2,:)=0.

!end    WSO 9/10/13

  ipias=(/ink+1,ink+2/)
  ink=ink+2
!-------------------------------------------------------------------
  Yobs(ink+2)=0.
  Yens(ink+2,1:1*nMemb1)=0.
  Yobs(ink+1)=0.             ! set SRT_PIA(ku) and SRT_PIA(Ka) =0
  Yens(ink+1,1:1*nMemb1)=0.  ! set SRT_PIA(ku) and SRT_PIA(Ka) =0

  Yobs(ink+1) = dPRData%srtPIAku(i, j)
  Yens(ink+1,1:1*nMemb1) = 1*dPRRet%pia13mod(i, j, 1:nmemb1)
  if(Yobs(ink+1)<0) then
     Yobs(ink+1)=0
     Yens(ink+1,1:1*nMemb1) = 0.
  endif
  if(Yobs(ink+2)<0) then
     Yobs(ink+2)=0
     Yens(ink+2,1:1*nMemb1) = 0.
  endif
  ink=ink+2
!-----------------------------------------------------------------------

  ifreq(1:9)=(/1,1,2,2,3,4,4,5,5/)
!begin  MG 9/18/13
  ipol(1:9)=(/1,2,1,2,1,1,2,1,2/)
!end    MG 9/18/13
  iobs(1:9)=(/1,2,3,4,5,6,7,8,9/)  !SJm 12/8/2014 - fixed 6->7 in 5th element (should be 37H not 37V)

  do k=1,9!noTb
     if( dPRRet%tb(i,j,ipol(k),ifreq(k),nmemb1)>50 .and. &
          tb(i,j,iobs(k))>0  ) then
        ymean=sum(dPRRet%tb(i,j,ipol(k),ifreq(k),1:1*nmemb1))/nmemb1
        ystd=sqrt(sum((dPRRet%tb(i,j,ipol(k),ifreq(k),1:1*nmemb1)-&
             ymean)**2)/nmemb1)
        if(wfractm>80) then
           if(abs(tb(i,j,iobs(k))-ymean) .lt. 3.5*ystd) then
              ink=ink+1
              Yens(ink,1:1*nMemb1) = dPRRet%tb(i,j,ipol(k),ifreq(k),&
                   1:1*nmemb1)
              Yobs(ink)=tb(i,j,iobs(k))
           endif
        else
           if(abs(tb(i,j,iobs(k))-ymean) .lt. 3.5*ystd) then
              ink=ink+1
              Yens(ink,1:1*nMemb1) = dPRRet%tb(i,j,ipol(k),ifreq(k),&
                   1:1*nmemb1)
              Yobs(ink)=tb(i,j,iobs(k))
           endif
        endif
     endif
  enddo
  ipolS2=(/1,2,1,1/)
  ifreqS2=(/6,6,7,8/)
  do k=1,4!noTb
     if(hFreqTb(k)>0 .and. dPRRet%tb(i,j,ipolS2(k),ifreqS2(k),1)>0) then
        ink=ink+1
        Yobs(ink)=hFreqTb(k)
        Yens(ink,1:nMemb1)=dPRRet%tb(i,j,ipolS2(k),ifreqS2(k),1:1*nmemb1)
     endif
  enddo
  ny=ink
  !tbout(10)=sum(dPRRet%tb(i,j,1,6,1:1*nmemb1))/(nmemb1)
  !tbout(11)=sum(dPRRet%tb(i,j,2,6,1:1*nmemb1))/(nmemb1)
  !tbout(12)=sum(dPRRet%tb(i,j,1,7,1:1*nmemb1))/(nmemb1)
  !tbout(13)=sum(dPRRet%tb(i,j,1,8,1:1*nmemb1))/(nmemb1)
  !do k=10,13
  !   tbout(k)=hFreqPRg(i,j,k-9)
  !enddo
  !s0kaVar(i,j)=1.e4
  !if(dPRData%NSRelibFlag(i,j)==1 .or. &
  !     dPRData%NSRelibFlag(i,j)==2) then
  !   s0Kuvar(i,j)=16
  !else
  !   s0Kuvar(i,j)=1.e4
  !endif
  Yens(2,:)=0.
  Yobs(2)=0.
  !s0kaVar(i,j)=0.
  !ink=ink-4
  !ny=ny-4
  spia2=1.e5
  spia1=9
  if(ink>=2) then
     if(dPRData%NSRelibFlag(i,j)==1 .or. &
          dPRData%NSRelibFlag(i,j)==2) then
        spia1=9
     else
        spia1=1.e5
     endif
     call enkF1d(Xens(1:nx,1:nmemb1-1),Yens(1:ink,1:nmemb1-1),&
          Yobs(1:ink),nx,ny,nMemb1-1,xup,ipias,s0KuVar(i,j),s0KaVar(i,j),&
          s0Cov(i,j),spia1,spia2)
     if(wfractm>98) then
        sfcRain(i,j)=sum(dPRRet%sfcRainEns(i,j,1:1*nmemb1))/nmemb1
        !print*, sfcRain(i,j)/xup(1), ink,ny, hfreqTb
        if(sfcRain(i,j)/xup(1)<0) then
           !print*, Yobs(1:ink)
           !print*, xup(1)
           !print*, sfcRain(i,j)
           !print*, 'negative'
        endif
     endif
     sfcRain(i,j)=xup(1)
     dPRRet%sfcRainEns(i,j,1:1*nmemb1)=Xens(1,1:1*nMemb1)
  endif

  nx=0
  nx=nx+1
  dPRRet%sfcRainEns(i,j,1:1*nmemb1)=Xens(1,1:1*nMemb1)

!begin  MG 9/18/13 remove spurious minus sign
  do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
!end    MG 9/18/13
!  SFM  begin  07/29/2014; for M.Grecu eliminate NANs
!  SFM  begin  06/22/2014; for M.Grecu (unknown justification)
!begin  WSO 9/11/4 change zka1c21 to zku1c21
     if( dPRData%zku1c21(k,i,j)>12 .and. dPRRet%rrate(1,k,i,j)>0) then
!end    WSO 9/11/14
!  SFM  end    06/22/2014
!  SFM  end    07/29/2014
        nx=nx+1
        dPRRet%rrate(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%pwc(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%d0(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%log10dNw(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%z13c(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
     endif
  enddo
  !Start SJM  12/4/2014
  nx=nx+1
  dPRRet%pia13mod(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
  if(wfractm .gt. 99) then
     !prints*, dPRData%srtPIAku(i,j), sum(dPRRet%pia13mod(i,j,1:nmemb1))/nmemb1
  endif
  if(wfractm .gt. 99) then
    nx=nx+1
    dPRRet%simSigmaZeroKu(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
    nx=nx+1
    !print*, stddev(dPRRet%sfcWindEns(i,j,1:nmemb1),nmemb1)
    !print*, i, j,  sum(dPRRet%sfcWindEns(i,j,1:nmemb1)-Xens(nx,1:nMemb1))/nmemb1
    dPRRet%sfcWindEns(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
    do k=1,nmemb1
      if(dPRRet%sfcWindEns(i,j,k) .lt. 0.) dPRRet%sfcWindEns(i,j,k) = 0.
      if(dPRRet%sfcWindEns(i,j,k) .gt. 50.) dPRRet%sfcWindEns(i,j,k) = 50.
    end do
  endif
  !end SJM 12/4/2014
  !nx=nx+1
  !dPRRet%pia13mod(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
  do k=1,10
     nx=nx+1
     dPRRet%cldwcoeff(i,j,k,1:nmemb1)=Xens(nx,1:nmemb1)
  enddo
  !print*, 'nx2=',nx
  do k=1,8
     nx=nx+1
     !print*,  i,j,k,1,&
     !     sum(dPRRet%tb(i,j,1,k,1:1*nmemb1)-Xens(nx,1:nmemb1))/nmemb1
     if(k==7) then
        !print*,  sum(dPRRet%tb(i,j,1,k,1:1*nmemb1))/nmemb1, &
        !     sum(Xens(nx,1:nmemb1))/nmemb1, hFreqTb(3)
     endif
     dPRRet%tb(i,j,1,k,1:1*nmemb1)= Xens(nx,1:nmemb1)

     nx=nx+1
     dPRRet%tb(i,j,2,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
  enddo
50 format(20(F8.3,1x))

end subroutine filterUpNS

subroutine filterUpNSLand(dPRData,dPRRet, Xens,Yens,Yobs,Xup,tb,dprRain,sfcRain,nmemb1,ic,i,j,&
     nxu,nyu,wfractm,s0KuVar,s0KaVar,s0Cov, hfreqTb)
!  SFM  end    07/29/2014
  use f90DataTypes
  use f90Types
  implicit none
  type (dPRDataType)     :: dPRData
  type (dPRRetType)     :: dPRRet
  real :: Xens(nxu,nmemb1),Yens(nyu,nmemb1),Yobs(nyu), Xup(nxu)
  integer :: nmemb1,ic
  integer :: nxu,nyu
  integer :: ink,nx, ny, i, j, k
  integer :: ipias(2)
  integer :: ipol(15), ifreq(15), iobs(15)
  real :: tb(49,300,15), dprrain(49,300)!, tbRgrid(9,49,9300),
  real :: sfcRain(49,300),sfcRainStd(49,300)
  real :: s0KuVar(49,300), s0KaVar(49,300), s0Cov(49,300), hFreqTb(4)
!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
  real :: ymean, ystd, wfractm
  integer :: imemb, ifreqS2(4), k1, ipolS2(4)
  real ::  stddev,spia,ssig
!  SFM  end    07/29/2014

!!  integer*4 :: ob_flag(100)
!!  ob_flag = -9

  ink=0

  Xens(1,1:1*nMemb1)=(dPRRet%sfcRainEns(i,j,1:1*nmemb1))
  nx=1
  do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
!  SFM  begin  06/22/2014; for M.Grecu (unknonw justification)
!begin  WSO 9/11/4 change zka1c21 to zku1c21
     if( dPRData%zku1c21(k,i,j)>12 .and. dPRRet%rrate(1,k,i,j)>0) then
!end    WSO 9/11/14
!  SFM  end    06/22/2014
!  SFM  end    07/29/2014
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%rrate(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%pwc(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%d0(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%log10dNw(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%z13c(1:nmemb1,k,i,j)
     endif
  enddo
  !Start SJM  12/4/2014
  nx=nx+1
  Xens(nx,1:nMemb1)=dPRRet%pia13mod(i,j,1:nmemb1)

  do k=1,10
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%cldwcoeff(i,j,k,1:nmemb1)
  enddo
  !print*, 'nx1=',nx
  do k=1,8
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%tb(i,j,1,k,1:1*nmemb1)
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%tb(i,j,2,k,1:1*nmemb1)
  enddo
  do k=1,8
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%emis(i,j,1,k,1:1*nmemb1)
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%emis(i,j,2,k,1:1*nmemb1)
  enddo
120 format(8(F6.2,1x))

  ny=ink+2
  Yobs(ink+2)=0
  Yens(ink+2,:)=0.
  ssig=1e5
  if(dPRData%NSRelibFlag(i,j)==1 .or. &
       dPRData%NSRelibFlag(i,j)==2) then
     !Yobs(ink+1) = dPRData%srtPIAKu(i,j)
     !Yens(ink+1,1:1*nMemb1)=dPRRet%pia13mod(i,j,1:nmemb1)
     Yobs(ink+1) = dPRData%sigmaZeroKu(i,j)
     Yens(ink+1,1:1*nMemb1)=dPRRet%simSigmaZeroKu(i,j,1:nmemb1)
     if(i==32 .or. i==33) then
        !print*, i, j,  dPRData%sigmaZeroKu(i,j), sum(dPRRet%simSigmaZeroKu(i,j,1:nmemb1))/nmemb1
     endif
     ssig = s0KuVar(i,j)
     if(ssig<16) ssig=16.
  else
     Yobs(ink+1) = 0            ! set SRT_PIA(ku) =0
     Yens(ink+1,1:1*nMemb1)=0   ! set SRT_PIA_SIM(ku) =0
     !end SJM 12/4/2014
  endif

!end    WSO 9/10/13

  ipias=(/ink+1,ink+2/)
!------------------------------------------------------------------
  ink=ink+2
  Yobs(ink+2)=0.
  Yens(ink+2,1:1*nMemb1)=0.
  if(dPRData%NSRelibFlag(i,j)==1 .or. &
       dPRData%NSRelibFlag(i,j)==2) then
     Yobs(ink+1) = dPRData%srtPIAku(i, j)
     Yens(ink+1,1:1*nMemb1) = 1*dPRRet%pia13mod(i, j, 1:nmemb1)
     if(i==32 .or. i==33) then
        !print*, i, j,  'srt',dPRData%srtPIAKu(i,j), sum(dPRRet%pia13mod(i,j,1:nmemb1))/nmemb1
     end if
  else
     Yobs(ink+1)=0
     Yens(ink+1,:)=0
  endif
  if(Yobs(ink+1)<0) then
     Yobs(ink+1)=0
     Yens(ink+1,1:1*nMemb1) = 0.
  endif
  if(Yobs(ink+2)<0) then
     Yobs(ink+2)=0
     Yens(ink+2,1:1*nMemb1) = 0.
  endif
  Yobs(ink+2)=-0.
  Yens(ink+2,:)=-0.

  ink=ink+2
!-------------------------------------------------------------------

  ifreq(1:9)=(/1,1,2,2,3,4,4,5,5/)
!begin  MG 9/18/13
  ipol(1:9)=(/1,2,1,2,1,1,2,1,2/)
!end    MG 9/18/13
  iobs(1:9)=(/1,2,3,4,5,6,7,8,9/)  !SJm 12/8/2014 - fixed 6->7 in 5th element (should be 37H not 37V)

!!write(unit=98,fmt=*) ' =================== '
!!write(unit=98,fmt=*) ' index ',j+ic
!!write(unit=98,fmt=2211) tbRgrid(:,:,j+ic)
!!2211 format(10f11.4)
!!write(unit=98,fmt=*) ' =================== '
 ! print*, i, j, ink
  do k=1,9 !noTb
     if( dPRRet%tb(i,j,ipol(k),ifreq(k),nmemb1)>50 .and. &
          tb(i,j,iobs(k))>0  ) then
!  SFM  begin  07/29/2014; for M.Grecu eliminate NANs
        ymean=sum(dPRRet%tb(i,j,ipol(k),ifreq(k),1:1*nmemb1))/nmemb1
        ystd=sqrt(sum((dPRRet%tb(i,j,ipol(k),ifreq(k),1:1*nmemb1)-&
             ymean)**2)/nmemb1)

        if(wfractm>80) then
           if(abs(tb(i,j,iobs(k))-ymean) .lt. 3.5*ystd) then
              ink=ink+1
              Yens(ink,1:1*nMemb1) = dPRRet%tb(i,j,ipol(k),ifreq(k),&
                   1:1*nmemb1)
              Yobs(ink)=tb(i,j,iobs(k))
           endif
        else
           if(abs(tb(i,j,iobs(k))-ymean) .lt. 3.5*ystd) then
              ink=ink+1
              Yens(ink,1:1*nMemb1) = dPRRet%tb(i,j,ipol(k),ifreq(k),&
                   1:1*nmemb1)
              Yobs(ink)=tb(i,j,iobs(k))
           endif
        endif
!  SFM  end  07/29/2014
     endif
  enddo

  ipolS2=(/1,2,1,1/)
  ifreqS2=(/6,6,7,8/)
  if(1==2) then
     call enkfwi1(i)
     call enkfwi1(j)
     do k1=1,nmemb1
        call enkfwf(dPRRet%sfcRainEns(i,j,k1))
     enddo

     do k1=1,nmemb1
        call enkfwf(dPRRet%pia13mod(i, j, k1))
     enddo
     call enkfwf(dPRData%srtPIAku(i, j))
     call enkfwi1(dPRData%NSRelibFlag(i,j))

     do k1=1,nmemb1
        call enkfwf(dPRRet%simSigmaZeroKu(i,j,k1))
     enddo
     call enkfwf(dPRData%sigmaZeroKu(i,j))

     call enkfwf(ssig)
     call enkfwf(spia)

     do k=1,9
        call enkfwf(tb(i,j,k))
     enddo
     do k=1,4
        call enkfwf(hFreqTb(k))
     enddo

     do k=1,9
        do k1=1,nmemb1
           call enkfwf(dPRRet%tb(i,j,ipol(k),ifreq(k),k1))
        enddo
     enddo
     do k=1,4
        do k1=1,nmemb1
           call enkfwf(dPRRet%tb(i,j,ipolS2(k),ifreqS2(k),k1))
        enddo
     enddo

  end if

  do k=1,4!noTb
     if(hFreqTb(k)>0 .and. dPRRet%tb(i,j,ipolS2(k),ifreqS2(k),1)>0 ) then
        ink=ink+1
        Yobs(ink)=hFreqTb(k)
        Yens(ink,1:nMemb1)=dPRRet%tb(i,j,ipolS2(k),ifreqS2(k),1:1*nmemb1)
     endif
  enddo
  ny=ink
  !print*, 'tbInc ',i, j, ink, ny
  !print*, ny

  !print*, Xens(1,1), ink
  if(ink>=2) then
      if(dPRData%NSRelibFlag(i,j)==1 .or. &
           dPRData%NSRelibFlag(i,j)==2) then
         spia=9.
      else
         spia=1.e4
      endif

     call enkF1d(Xens(1:nx,1:nmemb1-1),Yens(1:ink,1:nmemb1-1),&
          Yobs(1:ink),nx,ny,nMemb1-1,xup,ipias,ssig,1e5,0.,spia,1e5)
     sfcRain(i,j)=xup(1)
     dPRRet%sfcRainEns(i,j,1:1*nmemb1)=Xens(1,1:1*nMemb1)
  endif

  nx=0
  nx=nx+1
  dPRRet%sfcRainEns(i,j,1:1*nmemb1)=Xens(1,1:1*nMemb1)

  if(1==2) then
     call enkfwi1(ipias(1))
     call enkfwi1(ipias(2))
     call enkfwf(sum(Xens(1,1:nmemb1)/nMemb1))
     call enkfwi1(ny)
     do k=1,ny
        call enkfwf(yobs(k))
     enddo
     do k=1,ny
        do k1=1,nmemb1
           call enkfwf(yens(k,k1))
        enddo
     enddo
  endif

!begin  MG 9/18/13 remove spurious minus sign
  do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
!end    MG 9/18/13
!  SFM  begin  07/29/2014; for M.Grecu eliminate NANs
!  SFM  begin  06/22/2014; for M.Grecu (unknown justification)
!begin  WSO 9/11/4 change zka1c21 to zku1c21
     if( dPRData%zku1c21(k,i,j)>12 .and. dPRRet%rrate(1,k,i,j)>0) then
        !end    WSO 9/11/14
        !  SFM  end    06/22/2014
        !  SFM  end    07/29/2014
        nx=nx+1
        dPRRet%rrate(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%pwc(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%d0(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%log10dNw(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%z13c(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
     endif
  enddo
  !Start SJM  12/4/2014
  nx=nx+1
  dPRRet%pia13mod(i,j,1:nmemb1)=Xens(nx,1:nMemb1)

  do k=1,10
     nx=nx+1
     dPRRet%cldwcoeff(i,j,k,1:nmemb1)=Xens(nx,1:nmemb1)
  enddo
  !print*, 'nx2=',nx
  do k=1,8
     nx=nx+1
     dPRRet%tb(i,j,1,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
     nx=nx+1
     dPRRet%tb(i,j,2,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
  enddo
  do k=1,8
     nx=nx+1
     dPRRet%emis(i,j,1,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
     nx=nx+1
     dPRRet%emis(i,j,2,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
  enddo

50 format(20(F8.3,1x))

end subroutine filterUpNSLand

!    Medium Swath filtering

!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
subroutine filterUpMS(dPRData,dPRRet, Xens,Yens,Yobs,Xup,tb,&
     dprRain,sfcRain,nmemb1,ic,i,j,&
     nxu,nyu,wfractm,s0KuVar,s0KaVar,s0Cov, hFreqTb, nubfc)
!  SFM  end    07/29/2014
  use f90DataTypes
  use f90Types
  use writeENKF
  implicit none
  type (dPRDataType)     :: dPRData
  type (dPRRetType)     :: dPRRet
  real :: Xens(nxu,nmemb1),Yens(nyu,nmemb1),Yobs(nyu), Xup(nxu)
  integer :: nmemb1,ic
  integer :: nxu,nyu
  integer :: ink,nx, ny, i, j, k, iprint
  integer :: ipias(2)
  integer :: ipol(15), ifreq(15), iobs(15)
  real :: tb(49,300,15), dprrain(49,300)
  real :: sfcRain(49,300),sfcRainStd(49,300)
  real :: s0KuVar(49,300), s0KaVar(49,300), s0Cov(49,300), hFreqTb(4)
!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
  real :: ymean, ystd, wfractm
  integer :: imemb, ifreqS2(4), ipolS2(4)
  integer :: nZKa, iZKa(88),k1
  real    :: spia1,spia2, nubfc, ssig1, ssig2, piacov
  integer :: check
!  SFM  end    07/29/2014

!!  integer*4 :: ob_flag(100)
!!  ob_flag = -9

  ink=0
  if(iwENKF==1) then
     call enkfwi1(nmemb1)
     call enkfwi1(dPRData%rainType(i,j))
     call enkfwi5(dPRData%node(:,i,j))
     call enkfwi1(i)
     call enkfwi1(j)
  endif
  nZKa=0
  do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
!  SFM  begin  06/22/2014; for M.Grecu (unknown justification)
     !print*, dPRData%zka1c21(k,i,j), dPRRet%z35mod0(1,k,i,j)
     if( dPRData%zka1c21(k,i,j)>15 .and. minval( dPRRet%z35mod0(1:1*nmemb1,k,i,j))>0) then
!  SFM  end    06/22/2014
        ink=ink+1
        Yens(ink,1:1*nMemb1) = dPRRet%z35mod0(1:1*nmemb1,k,i,j)
        Yobs(ink)=dPRData%zka1c21(k,i,j)
        iZKa(ink)=k
!!        ob_flag(ink) = 5
     endif
  enddo
  nZKa=ink
  if(iwENKF==1) then
     call enkfwi1(nZka)
     call enkfwf(wfractm)
     call enkfwf(dPRData%freezH(i,j) /1000.)
     do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
        call enkfwf(dPRData%zku1c21(k,i,j))
     enddo
     do k=1,nZka
        call enkfwi1(iZka(k))
        do k1=1,nmemb1
           call enkfwf(Yens(k,k1))
        enddo
        call enkfwf(Yobs(k))
     enddo
     do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
        do k1=1,nmemb1
           call enkfwf(dPRRet%MS%zKuEns(k1,k,i,j))
        enddo
        do k1=1,nmemb1
           call enkfwf(dPRRet%MS%log10dnw(k1,k,i,j))
        enddo
        do k1=1,nmemb1
           call enkfwf(dPRRet%MS%rrate(k1,k,i,j))
        enddo
     enddo
     do k1=1,nmemb1
        call enkfwf(dPRRet%MS%sfcRainEns(i,j,k1))
     enddo
     call enkfwf(dPRData%dsrtPIAku(i, j))
     call enkfwf(dPRData%dsrtPIAka(i, j))

     do k1=1,nmemb1
        call enkfwf(dPRRet%MS%pia13mod(i, j, k1))
        call enkfwf(dPRRet%MS%pia35mod(i, j, k1))
     enddo

     do k1=1,nmemb1
         call enkfwf(dPRRet%simSigmaZeroKu(i,j,k1))
         call enkfwf(dPRRet%simSigmaZeroKa(i,j,k1))
     enddo

     call enkfwf(dPRData%srtPIAku(i, j))
     call enkfwi1(dPRData%MSRelibFlag(i,j))
     call enkfwi1(dPRData%NSRelibFlag(i,j))
     call enkfwf(dPRData%sigmaZeroKu(i,j))
     call enkfwf(dPRData%sigmaZeroKa(i,j))
     call enkfwf(s0KuVar(i,j))
     call enkfwf(s0KaVar(i,j))
     call enkfwf(s0cov(i,j))
  endif

  nx=0

  nx=nx+1
  Xens(1,1:1*nMemb1)=(dPRRet%MS%sfcRainEns(i,j,1:1*nmemb1))
  !print*, dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
  if(dPRData%node(1,i,j)+1==1) then
     !print*,i,j
     do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
        !print*, dPRData%zku1c21(k,i,j),  dPRRet%MS%rrate(1,k,i,j)
     end do
  end if
  do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
!  SFM  begin  06/22/2014; for M.Grecu (unknown justification)
     if( dPRData%zku1c21(k,i,j)>12 .and. dPRRet%MS%rrate(1,k,i,j)>0) then
!  SFM  end    06/22/2014
!  SFM  end    07/29/2014
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%MS%rrate(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%MS%pwc(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%MS%d0(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%MS%log10dNw(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%MS%zKuEns(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%MS%zKaEns(1:nmemb1,k,i,j)
        nx=nx+1
        Xens(nx,1:nMemb1)=dPRRet%z35mod0(1:nmemb1,k,i,j)
     endif
  enddo
  !Start SJM  12/9/2014
  nx=nx+1
  Xens(nx,1:nMemb1)=dPRRet%MS%pia13mod(i,j,1:nmemb1)
  nx=nx+1
  Xens(nx,1:nMemb1)=dPRRet%MS%pia35mod(i,j,1:nmemb1)
  if(wfractm .gt. 99) then
    nx=nx+1
    Xens(nx,1:nMemb1)=dPRRet%MS%simSigmaZeroKu(i,j,1:nmemb1)
    nx=nx+1
    Xens(nx,1:nMemb1)=dPRRet%MS%simSigmaZeroKa(i,j,1:nmemb1)
    nx=nx+1
    Xens(nx,1:nMemb1)=dPRRet%MS%sfcWindEns(i,j,1:nmemb1)
  endif
  !end SJM 12/9/2014
  !nx=nx+1
  !Xens(nx,1:nMemb1)=dPRRet%MS%pia13mod(i,j,1:nmemb1)
  !nx=nx+1
  !Xens(nx,1:nMemb1)=dPRRet%MS%pia35mod(i,j,1:nmemb1)

!begin  MG 9/18/13 addition
!  do k=1,10
!     nx=nx+1
!     Xens(nx,1:nmemb1)=dPRRet%MS%cldwcoeff(i,j,k,1:nmemb1)
!  enddo
  do k=1,8
     !print*, nx, ' in'
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%MS%tb(i,j,1,k,1:1*nmemb1)
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%MS%tb(i,j,2,k,1:1*nmemb1)
  enddo
  do k=1,8
     !print*, nx, ' in'
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%MS%emis(i,j,1,k,1:1*nmemb1)
     nx=nx+1
     Xens(nx,1:nmemb1)=dPRRet%MS%emis(i,j,2,k,1:1*nmemb1)
  enddo
!end    MG 9/18/13 addition
120 format(8(F6.2,1x))
  Yobs(ink+1:ink+2)=0
  Yens(ink+1:ink+2,:)=0.
  ny=ink+2

  if(dPRData%MSRelibFlag(i,j)==1 .or. &
       dPRData%MSRelibFlag(i,j)==2) then
     spia1=4.0
  else
     spia1=1e7
  endif
  if(dPRData%NSRelibFlag(i,j)==1 .or. &
       dPRData%NSRelibFlag(i,j)==2) then
     spia2=9.0
  else
     spia2=1e7
  endif

  if(wfractm .gt. 99) then
    Yobs(ink+1) = dPRData%sigmaZeroKu(i,j)
    Yens(ink+1,1:1*nMemb1)=dPRRet%simSigmaZeroKu(i,j,1:nmemb1)
    Yobs(ink+2) = dPRData%sigmaZeroKa(i,j)
    Yens(ink+2,1:1*nMemb1)=dPRRet%simSigmaZeroKa(i,j,1:nmemb1)
    ssig1 = s0Kuvar(i,j)
    ssig2 = s0Kavar(i,j)
    piacov = s0cov(i,j)
  else
    !Yobs(ink+1)=dPRData%dsrtPIAka(i, j)-dPRData%dsrtPIAku(i, j)
    !Yens(ink+1,1:1*nMemb1)=dPRRet%MS%pia35mod(i, j, 1:nmemb1)/nubfc-&
    !   dPRRet%MS%pia13mod(i, j, 1:nmemb1)
    !Yobs(ink+2) = dPRData%srtPIAku(i, j)
    !Yens(ink+2,1:1*nMemb1) = 1*dPRRet%MS%pia13mod(i, j, 1:nmemb1)
    Yobs(ink+1) = dPRData%sigmaZeroKu(i,j)
    Yens(ink+1,1:1*nMemb1)=dPRRet%simSigmaZeroKu(i,j,1:nmemb1)
    Yobs(ink+2) = dPRData%sigmaZeroKa(i,j)
    Yens(ink+2,1:1*nMemb1)=dPRRet%simSigmaZeroKa(i,j,1:nmemb1)
    !print*, s0kuvar(i,j),s0kavar(i,j),sum(dPRRet%MS%pia35mod(i,j,1:nmemb1))/&
    !     nmemb1, nubfc
    ssig1 = s0Kuvar(i,j)
    if(ssig1<4.and.wfractm<90) ssig1=4
    ssig2 = s0Kavar(i,j)
    if(ssig2<16.and.wfractm<90) ssig2=16
    piacov = s0cov(i,j)

!     if(Yobs(ink+1)<0) then
!        Yobs(ink+1)=0
!        Yens(ink+1,1:1*nMemb1) = 0.
!     endif
!     if(Yobs(ink+2)<0) then
!        Yobs(ink+2)=0
!        Yens(ink+2,1:1*nMemb1) = 0.
!     endif

!      if(dPRData%NSRelibFlag(i,j)==1 .or. &
!           dPRData%NSRelibFlag(i,j)==2) then
!         spia2=16
!      else
!         spia2=1e7
!      endif
!      piacov=0.
  endif
!print*, Yobs(ink+1), dPRData%MSRelibFlag(i,j)
!end    WSO 9/10/13
!this code zeros out the delta-PIA constraint in MS mode

  ipias=(/ink+1,ink+2/)
  ink=ink+2

  Yobs(ink+1:ink+2)=0
  Yens(ink+1:ink+2,:)=0.
  !ny=ink+2
!---------------------------------------------------------------------
  Yobs(ink+1)=dPRData%dsrtPIAka(i, j)-dPRData%dsrtPIAku(i, j)
  Yens(ink+1,1:1*nMemb1)=dPRRet%MS%pia35mod(i, j, 1:nmemb1)/nubfc-&
       dPRRet%MS%pia13mod(i, j, 1:nmemb1)
  Yobs(ink+2) = dPRData%srtPIAku(i, j)
  Yens(ink+2,1:1*nMemb1) = 1*dPRRet%MS%pia13mod(i, j, 1:nmemb1)

  if(Yobs(ink+1)<0) then
     Yobs(ink+1)=0
     Yens(ink+1,1:1*nMemb1) = 0.
  endif
  if(Yobs(ink+2)<0) then
     Yobs(ink+2)=0
     Yens(ink+2,1:1*nMemb1) = 0.
  endif
!-------------------------------------------------------------------------
  ink=ink+2
  ifreq(1:9)=(/1,1,2,2,3,4,4,5,5/)
!begin  MG 9/18/13
  ipol(1:9)=(/1,2,1,2,1,1,2,1,2/)
!end    MG 9/18/13
  iobs(1:9)=(/1,2,3,4,5,6,7,8,9/)  !SJm 12/8/2014 - fixed 6->7 in 5th element (should be 37H not 37V)

!!write(unit=99,fmt=*) ' =================== '
!!write(unit=99,fmt=*) ' index ',j+ic
!!write(unit=99,fmt=2211) tbRgrid(:,:,j+ic)
!!2211 format(10f11.4)
!!write(unit=99,fmt=*) ' =================== '
  if(iwEnkF==1) then
     do k=1,9
        call enkfwf(tb(i,j,k))
     enddo
     do k=1,4
        call enkfwf(hFreqTb(k))
     enddo
  endif

  do k=1,9 !noTb
     if( dPRRet%MS%tb(i,j,ipol(k),ifreq(k),nmemb1)>0 .and. &
          tb(i,j,iobs(k))>0  ) then
        ymean=sum(dPRRet%MS%tb(i,j,ipol(k),ifreq(k),1:1*nmemb1))/nmemb1
        ystd=sqrt(sum((dPRRet%MS%tb(i,j,ipol(k),ifreq(k),1:1*nmemb1)-&
             ymean)**2)/nmemb1)
!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
        if(wfractm>80) then
           if(abs(tb(i,j,iobs(k))-ymean) .lt. 5.5*ystd) then
              ink=ink+1
              Yens(ink,1:1*nMemb1) = dPRRet%MS%tb(i,j,ipol(k),ifreq(k),1:1*nmemb1)
              Yobs(ink)=tb(i,j,iobs(k))
           endif
        else
           if(abs(tb(i,j,iobs(k))-ymean) .lt. 3.5*ystd) then
              ink=ink+1
              Yens(ink,1:1*nMemb1) = dPRRet%MS%tb(i,j,&
                   ipol(k),ifreq(k),1:1*nmemb1)
              Yobs(ink)=tb(i,j,iobs(k))
           endif
!  SFM  end    07/29/2014
        endif
     endif
  enddo
  ipolS2=(/1,2,1,1/)
  ifreqS2=(/6,6,7,8/)
  do k=1,4!noTb
     if(hFreqTb(k)>0 .and. dPRRet%tb(i,j,ipolS2(k),ifreqS2(k),1)>0) then
        ink=ink+1
        Yobs(ink)=hFreqTb(k)
        Yens(ink,1:nMemb1)=dPRRet%MS%tb(i,j,ipolS2(k),ifreqS2(k),1:1*nmemb1)
     endif
  enddo

  if(iwEnkF==1)then
     do k=1,9
        do k1=1,nmemb1
           call enkfwf(dPRRet%MS%tb(i,j,ipol(k),ifreq(k),k1))
        enddo
     enddo
     do k=1,4
        do k1=1,nmemb1
           call enkfwf(dPRRet%MS%tb(i,j,ipolS2(k),ifreqS2(k),k1))
        enddo
     enddo
  endif
  ny=ink
  !Yens(1:2,:)=log(0.)
  !print*, j, i
  if((i==-12+12 .or. i==13+12) .and. j==115) then
     print*, 'before'
     print*,  ipias
     print*, dPRData%srtPIAku(i,j)
     print*, sum(Yens(2,1:nMemb1))/nMemb1
     print*, dPRData%dsrtPIAka(i,j)
     print*, sum(Yens(1,1:nMemb1))/nMemb1
     print*, sum(Xens(1,1:1*nMemb1))/nMemb1
     print*, 'ms&&ns= ',dPRData%MSRelibFlag(i,j), dPRData%NSRelibFlag(i,j)
     print*, i, j
  endif
  if(Xens(1,1)>-5 .and. ink>=2) then
     if(dPRData%MSRelibFlag(i,j)==1 .or. &
          dPRData%MSRelibFlag(i,j)==2) then
        spia1=4.0
     else
        spia1=1e5
     endif
     if(dPRData%NSRelibFlag(i,j)==1 .or. &
          dPRData%NSRelibFlag(i,j)==2) then
        spia2=9
     else
        spia2=1e5
     endif

     call enkF1d(Xens(1:nx,1:nmemb1-1),Yens(1:ink,1:nmemb1-1),&
          Yobs(1:ink),nx,ny,nMemb1-1,xup,ipias,ssig1,ssig2,piacov,&
          spia1,spia2)
  endif
  if((i==-12+12 .or. i==13+12) .and. j==115) then
     print*, dPRData%srtPIAku(i,j),dPRData%dsrtPIAka(i,j)
     print*, sum(Xens(1,1:1*nMemb1))/nMemb1
     print*, yObs(3:14)
     print*, spia1,spia2
!     print*,
     print*, 'after'
  endif
  nx=0
  nx=nx+1
  dPRRet%MS%sfcRainEns(i,j,1:1*nmemb1)=Xens(1,1:1*nMemb1)
  iprint=0
  do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
!  SFM  begin  07/29/2014; for M.Grecu  eliminate NANs
!  SFM  begin  06/22/2014; for M.Grecu (unknown justification)
     if( dPRData%zku1c21(k,i,j)>12 .and. dPRRet%MS%rrate(1,k,i,j)>0) then
!  SFM  end    06/22/2014
        nx=nx+1
        if(sum(Xens(nx,1:nMemb1))/nMemb1>300) then
          iprint=1
        endif
        dPRRet%MS%rrate(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)

        do imemb=1,nmemb1
           if(dPRRet%MS%rrate(imemb,k,i,j)<0) dPRRet%MS%rrate(imemb,k,i,j)=0
        enddo
        nx=nx+1
        dPRRet%MS%pwc(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        do imemb=1,nmemb1
           if(dPRRet%MS%pwc(imemb,k,i,j)<0) dPRRet%MS%pwc(imemb,k,i,j)=0
        enddo
!  SFM  end    07/29/2014
        nx=nx+1
        dPRRet%MS%d0(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%MS%log10dNw(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%MS%zKuEns(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%MS%zKaEns(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
        nx=nx+1
        dPRRet%z35mod0(1:nmemb1,k,i,j)=Xens(nx,1:nMemb1)
     endif
  enddo
  if(iprint==11) then
     do k=dPRData%node(1,i,j)+1,dPRData%node(5,i,j)+1
        if( dPRData%zku1c21(k,i,j)>12) then
           !print*, dPRData%zku1c21(k,i,j), dPRData%zka1c21(k,i,j)
        endif

     enddo
     print*, dPRData%dsrtPIAku(i, j), dPRData%dsrtPIAka(i, j)
     print*, Yobs(ipias)
     print*, dPRData%srtrelPIAku(i, j)
     print*, dPRData%srtrelPIAku(i, j)
     print*, dprdata%snrRatioku(i,j)
     print*, dprdata%snrRatioka(i,j)
  endif
  !Start SJM  12/4/2014
  nx=nx+1
  dPRRet%MS%pia13mod(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
  nx=nx+1
  dPRRet%MS%pia35mod(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
  if(wfractm .gt. 99) then
    nx=nx+1
    dPRRet%MS%simSigmaZeroKu(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
    nx=nx+1
    dPRRet%MS%simSigmaZeroKa(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
    nx=nx+1
    dPRRet%MS%sfcWindEns(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
    do k=1,nmemb1
      if(dPRRet%MS%sfcWindEns(i,j,k) .lt. 0.) dPRRet%MS%sfcWindEns(i,j,k) = 0.
      if(dPRRet%MS%sfcWindEns(i,j,k) .gt. 50.) dPRRet%MS%sfcWindEns(i,j,k) = 50.
    end do
  endif
  !end SJM 12/4/2014
  !nx=nx+1
  !dPRRet%MS%pia13mod(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
  !nx=nx+1
  !dPRRet%MS%pia35mod(i,j,1:nmemb1)=Xens(nx,1:nMemb1)
!begin  MG 9/18/13 addition
!  do k=1,10
!     nx=nx+1
!     dPRRet%MS%cldwcoeff(i,j,k,1:nmemb1)=Xens(nx,1:nmemb1)
!  enddo

  do k=1,8
     !print*, nx, ' out'
     nx=nx+1
     dPRRet%MS%tb(i,j,1,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
     nx=nx+1
     dPRRet%MS%tb(i,j,2,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
  enddo
  do k=1,8
     !print*, nx, ' out'
     nx=nx+1
     dPRRet%MS%emis(i,j,1,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
     nx=nx+1
     dPRRet%MS%emis(i,j,2,k,1:1*nmemb1)= Xens(nx,1:nmemb1)
  enddo
!end MG 9/18/13

!!50 format(20(F8.3,1x))
!!if (ny .ge. 1) write(unit=99,fmt=1234) 'MS YOBS ',ic+j, ny, Yobs(1:ny)
!!1234 format(a8,2i5,100f11.4)
!!if (ny .ge. 1) write(unit=99,fmt=1235) 'MS FLGS ',ob_flag(1:ny)
!1235 format(a8,10x,100i11)
end subroutine filterUpMS


      SUBROUTINE setsd(iseed1,iseed2)
C**********************************************************************
C
C     SUBROUTINE SETSD(ISEED1,ISEED2)
C               SET S-ee-D of current generator
C
C     Resets the initial  seed of  the current  generator to  ISEED1 and
C     ISEED2. The seeds of the other generators remain unchanged.
C
C     This is a transcription from Pascal to Fortran of routine
C     Set_Seed from the paper
C
C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
C     with Splitting Facilities." ACM Transactions on Mathematical
C     Software, 17:98-111 (1991)
C
C
C                              Arguments
C
C
C     ISEED1 -> First integer seed
C                                   INTEGER ISEED1
C
C     ISEED2 -> Second integer seed
C                                   INTEGER ISEED1
C
C**********************************************************************
C     .. Parameters ..
      INTEGER numg
      PARAMETER (numg=32)
C     ..
C     .. Scalar Arguments ..
      INTEGER iseed1,iseed2
C     ..
C     .. Scalars in Common ..
      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
C     ..
C     .. Arrays in Common ..
      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
     +        lg2(numg)
      LOGICAL qanti(numg)
C     ..
C     .. Local Scalars ..
      INTEGER g
C     ..
C     .. External Functions ..
      LOGICAL qrgnin
      EXTERNAL qrgnin
C     ..
C     .. External Subroutines ..
      EXTERNAL getcgn,initgn
C     ..
C     .. Common blocks ..
      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
     +       cg2,qanti
C     ..
C     .. Save statement ..
      SAVE /globe/
C     ..
C     .. Executable Statements ..
C     Abort unless random number generator initialized
      IF (qrgnin()) GO TO 10
      WRITE (*,*) ' SETSD called before random number generator ',
     +  ' initialized -- abort!'
      STOP ' SETSD called before random number generator initialized'

   10 CALL getcgn(g)
      ig1(g) = iseed1
      ig2(g) = iseed2
      CALL initgn(-1)
      RETURN

      END


*dk,try2to2b
      subroutine try2to2b(nface,n2to2,
     *                    npoints,ntets)
C ######################################################################
C
C     PURPOSE -
C
C        This routine attempts to flip connections on boundaries.
C
C     INPUT ARGUMENTS -
C
C        nface   - the number of faces in the "irclst" array
C
C     OUTPUT ARGUMENTS -
C
C        n2to2   - the number of boundary flips performed
C
C     CHANGE HISTORY -
C
C        $Log: try2to2b.f,v $
C        Revision 2.00  2007/11/09 20:04:05  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.15   05 Jan 2001 12:58:14   dcg
CPVCS    use dble in place of float so as not to lose digits
CPVCS
CPVCS       Rev 1.14   Thu Jan 21 20:24:18 1999   nnc
CPVCS    Correct typo in pointer statement for ICONTAB.
CPVCS
CPVCS       Rev 1.13   Mon Dec 01 16:34:10 1997   dcg
CPVCS    comment out loc call
CPVCS
CPVCS       Rev 1.12   Mon Apr 14 17:05:00 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.11   Mon Jun 03 15:11:54 1996   dcg
CPVCS    hp changes
CPVCS
CPVCS       Rev 1.10   Wed May 22 10:29:02 1996   dcg
CPVCS     get nconbnd from mesh object
CPVCS
CPVCS       Rev 1.9   Thu May 16 10:32:06 1996   dcg
CPVCS    changes for new interface type 3 and for new icontab, xcontab
CPVCS
CPVCS       Rev 1.8   Mon May 06 12:26:58 1996   dcg
CPVCS    use itsttp to test for point types
CPVCS
CPVCS       Rev 1.7   Thu May 02 11:22:10 1996   dcg
CPVCS    fix call to vorfclst
CPVCS
CPVCS       Rev 1.6   Tue Apr 16 14:38:22 1996   dcg
CPVCS    replace pointer ipitets with array itets
CPVCS
CPVCS       Rev 1.5   03/23/95 22:59:36   het
CPVCS    Add the model routines and add the cmo name into the idsbs
CPVCS
CPVCS       Rev 1.4   02/10/95 08:27:46   het
CPVCS    Change the nfaces variable to nface because of cmo.h
CPVCS
CPVCS       Rev 1.3   12/02/94 15:07:04   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:49:34   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:55:22   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:19:36   pvcs
CPVCS    Original version.
C
C ######################################################################
C
      implicit none
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"
      include "cmerge.h"

C arguments (nface,n2to2,npoints,ntets)
      integer nface,n2to2,npoints,ntets

C variables
      integer id(8),jd(8),itets(301)

      pointer (ipicontab,icontab)
      integer icontab(50,*)

      integer i,j,k,i1,i2,i3,i4,i5,ip1,ip2,it,it2
      integer ierror,length,icmotype,nconbnd,lenitp1,lenicr1,
     *        lenxic,lenyic,lenzic,lenitetclr,ier,lenitet,
     *        lenjtet,ilen,itwo,iface,n1,n2,n3,volit,n2to0,
     *        volit2,m,idup,icrnbr1,icrnbr2,icrnbr4,
     *        icrnbr5,j1,j2,j4,j5,irb1,irb2,irb4,irb5,
     *        iepos,iofs,ipos2,iflag,ntet,ibndflg,ivorerr,
     *        itlast,itest1,itest2,idum,ierrwrt,nflips,itx

      real*8  xn,yn,zn,sn,xnorm1,ynorm1,znorm1,snorm1,
     *        xnorm2,ynorm2,znorm2,snorm2,dot1,dot2,xst

      logical itsttp
C
      real*8 crosx1,crosy1,crosz1,volume
      crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
     *              (yic(k)-yic(i))*(zic(j)-zic(i))
      crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
     *              (xic(j)-xic(i))*(zic(k)-zic(i))
      crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
     *              (xic(k)-xic(i))*(yic(j)-yic(i))
      volume(i1,i2,i3,i4)=(xic(i4)-xic(i1))*crosx1(i1,i2,i3)+
     *                    (yic(i4)-yic(i1))*crosy1(i1,i2,i3)+
     *                    (zic(i4)-zic(i1))*crosz1(i1,i2,i3)

C
      character*132 logmess
C
C ######################################################################
C BEGIN begin
C
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
      call cmo_get_info('nconbnd',cmo,nconbnd,length,icmotype,ierror)
      call cmo_get_info('itp1',cmo,ipitp1,lenitp1,icmotype,ierror)
      call cmo_get_info('icr1',cmo,ipicr1,lenicr1,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,lenxic,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,lenyic,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,lenzic,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,ipitetclr,lenitetclr,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,lenitet,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,lenjtet,icmotype,ierror)
      call cmo_get_info('icontab',cmo,ipicontab,ilen,icmotype,ierror)
C
      endif
C
C     ******************************************************************
C
C
C     ipitets=loc(itets)
C
      itwo=2
      xst=1.0e-11
      n2to2=0
C
C     ******************************************************************
C
C     ATTEMPT RECONNECTIONS ACROSS THE FACES
C
      do 100 i=1,nface
         iface=irclst(i)
C
C        _______________________________________________________________
C
C        CONSIDER BOUNDARY CONNECTIONS THAT ARE COMMON TO EXACTLY TWO
C        TETS. CONSIDER POTENTIAL FLIPS BETWEEN BOUNDARY POINTS ONLY.
C
         ip2=jtet1(iface)
         if(ip2.ge.mbndry) goto 100
         i5=itet1(ip2)
         if(jtet1(ip2).ge.mbndry) goto 100
         i4=itet1(jtet1(ip2))
Cdcg     if(itp1(i4).ne.ifitpini.and.itp1(i4).ne.ifitprfl.and.
Cdcg *      itp1(i4).ne.ifitpfre.and.itp1(i4).ne.ifitpinb.and.
Cdcg *      itp1(i5).ne.ifitpini.and.itp1(i5).ne.ifitprfl.and.
Cdcg *      itp1(i5).ne.ifitpfre.and.itp1(i5).ne.ifitpinb) goto 100
         if (.not.itsttp('boundary',itp1(i4)).and.
     *       .not.itsttp('intrface',itp1(i4)))    go to 100
         if (.not.itsttp('boundary',itp1(i5)).and.
     *       .not.itsttp('intrface',itp1(i5)))    go to 100
C           **SKIP FACE UNLESS BOTH POINTS ARE BOUNDARY POINTS
         call face(iface,ip1,it,n2,n1,n3)
         if(kfix(1,it).ge.1.or.itet(1,it).le.0) goto 100
         volit=volume(itet(1,it),itet(2,it),itet(3,it),itet(4,it))
         if(volit.le.0) goto 100
C           **SKIP FACE IF TETRAHEDRON IS INVERTED
         it2=0.25*dble(jtet1(iface))+0.9
         volit2=volume(itet(1,it2),itet(2,it2),itet(3,it2),itet(4,it2))
         if(volit2.le.0) goto 100
C           **SKIP FACE IF TETRAHEDRON IS INVERTED
C
C        _______________________________________________________________
C
C        TEST FOR GEOMETRY RESTRICTIONS
C
         do 50 m=1,3
            idup=0
            if(m.eq.1) then
               i1=n1
               i2=n2
               i3=n3
            elseif(m.eq.2) then
               i1=n2
               i2=n3
               i3=n1
            elseif(m.eq.3) then
               i1=n3
               i2=n1
               i3=n2
            endif
C
Cdcg        if(itp1(i1).eq.ifitpint.or.itp1(i2).eq.ifitpint) goto 50
            if (itsttp('interior',itp1(i1)).or.
     *            itsttp('interior',itp1(i2))) go to 50
C              **SKIP IF EITHER POINT IS NOT BOUNDARY POINT
Cdcg        if(itp1(i1).eq.ifitpinb.and.itp1(i1).eq.ifitpinb) goto 50
            if (itsttp('intrface',itp1(i1)).and.
     *            itsttp('intrface',itp1(i2))) go to 50
C              **DO NOT BREAK AN EXTERNAL INTERFACE CONNECTION
Cdcg        if(itp1(i1).eq.ifitpfre.and.itp1(i2).eq.ifitpfre) goto 50
            if (itsttp('free',itp1(i1)).and.
     *            itsttp('free',itp1(i2))) go to 50
C              **DO NOT BREAK A FREE SURFACE BOUNDARY CONNECTION
C
C           ............................................................
C
C           FLIP ON REFLECTING SURFACE ONLY IF ALL FOUR POINTS LIE IN
C           SAME PLANE.
C
            icrnbr1=icr1(i1)
            icrnbr2=icr1(i2)
            if(icrnbr1.ne.0.and.icrnbr2.ne.0) then
               icrnbr4=icr1(i4)
               icrnbr5=icr1(i5)
               if(icrnbr4.ne.0.and.icrnbr5.ne.0) then
                  if(icrnbr2.ne.icrnbr1.or.icrnbr4.ne.icrnbr1.or.
     *               icrnbr5.ne.icrnbr1) then
                     if(nconbnd.le.0) then
                        do 300 j1=3,5
                           irb1=icrnbr1
                           do 310 j2=3,5
                              irb2=icrnbr2
                              if(irb2.eq.irb1) then
                                 do 320 j4=3,5
                                    irb4=icrnbr4
                                    if(irb4.eq.irb1) then
                                       do 330 j5=3,5
                                          irb5=icrnbr5
                                          if(irb5.eq.irb1) goto 340
  330                                  continue
                                    endif
  320                            continue
                              endif
  310                      continue
  300                   continue
                        goto 50
  340                   continue
                        if(irb1.eq.0) goto 50
                     else
                        do 200 j1=3,icontab(1,icrnbr1)
                           irb1=icontab(j1,icrnbr1)
                           do 210 j2=3,icontab(1,icrnbr2)
                              irb2=icontab(j2,icrnbr2)
                              if(irb2.eq.irb1) then
                                 do 220 j4=3,icontab(1,icrnbr4)
                                    irb4=icontab(j4,icrnbr4)
                                    if(irb4.eq.irb1) then
                                       do 230 j5=3,icontab(1,icrnbr5)
                                          irb5=icontab(j5,icrnbr5)
                                          if(irb5.eq.irb1) goto 240
  230                                  continue
                                    endif
  220                            continue
                              endif
  210                      continue
  200                   continue
                        goto 50
  240                   continue
                        if(irb1.eq.0) goto 50
                     endif
                  endif
               else
                  goto 50
               endif
            endif
C
            do 10 j=1,6
               ip1=ielist(4*(j-1)+1)
               ip2=ielist(4*(j-1)+2)
               if( (itet(ip1,it).eq.i1.and.itet(ip2,it).eq.i2).or.
     *             (itet(ip1,it).eq.i2.and.itet(ip2,it).eq.i1))then
                      iepos=j
                      goto 11
               endif
 10         continue
 11         continue
            iofs=4*(iepos-1)
            if(i3.eq.itet(ielist(iofs+3),it)) then
               if(jtet(ielist(iofs+3),it).lt.mbndry) goto 50
               if(jtet(ielist(iofs+4),it).ge.mbndry) goto 50
               it2=0.25*dble(jtet(ielist(iofs+4),it))+0.9
               if(kfix(1,it2).ge.1) goto 50
C
               ipos2=4
               if(itet(1,it2).eq.i3) ipos2=1
               if(itet(2,it2).eq.i3) ipos2=2
               if(itet(3,it2).eq.i3) ipos2=3
               if(jtet(ipos2,it2).lt.mbndry) goto 50
            elseif(i3.eq.itet(ielist(iofs+4),it)) then
               if(jtet(ielist(iofs+4),it).lt.mbndry) goto 50
               if(jtet(ielist(iofs+3),it).ge.mbndry) goto 50
               it2=0.25*dble(jtet(ielist(iofs+3),it))+0.9
               if(kfix(1,it2).ge.1) goto 50
C
               ipos2=4
               if(itet(1,it2).eq.i3) ipos2=1
               if(itet(2,it2).eq.i3) ipos2=2
               if(itet(3,it2).eq.i3) ipos2=3
               if(jtet(ipos2,it2).lt.mbndry) goto 50
            endif
C
            xn=xic(i5)-xic(i4)
            yn=yic(i5)-yic(i4)
            zn=zic(i5)-zic(i4)
            sn=sqrt(xn*xn+yn*yn+zn*zn)
            xnorm1=crosx1(i4,i1,i3)
            ynorm1=crosy1(i4,i1,i3)
            znorm1=crosz1(i4,i1,i3)
            snorm1=sqrt(xnorm1**2+ynorm1**2+znorm1**2)
            xnorm2=crosx1(i4,i3,i2)
            ynorm2=crosy1(i4,i3,i2)
            znorm2=crosz1(i4,i3,i2)
            snorm2=sqrt(xnorm2**2+ynorm2**2+znorm2**2)
            dot1=xn*xnorm1+yn*ynorm1+zn*znorm1
            dot2=xn*xnorm2+yn*ynorm2+zn*znorm2
            iflag=0
            if(dot1.ge.xst*sn*snorm1.and.
     *         dot2.ge.xst*sn*snorm2) iflag=1
            if(iflag.eq.0) goto 50
C
C           ............................................................
C           Make sure that the potentially new boundary faces do
C           not lie on top of already existing faces.
C
            do 30 j=1,6
               if(iepos.eq.j) goto 30
               ip1=itet(ielist(4*(j-1)+1),it)
               ip2=itet(ielist(4*(j-1)+2),it)
               if(ip1.eq.i3.or.ip2.eq.i3) goto 30
               call vorfclst(it,j,itets,0,ntet,ibndflg,ivorerr)
               if(ibndflg.ne.2) goto 30
               itlast=itets(ntet)
               itest1=min0(iabs(itet(1,itlast)-i5),
     *                     iabs(itet(2,itlast)-i5),
     *                     iabs(itet(3,itlast)-i5),
     *                     iabs(itet(4,itlast)-i5))
               if(itest1.eq.0) then
                  idup=j
                  goto 50
               endif
 30         continue
            do 40 j=1,6
               ip1=itet(ielist(4*(j-1)+1),it2)
               ip2=itet(ielist(4*(j-1)+2),it2)
               if(ip1.eq.i3.or.ip2.eq.i3) goto 40
              if((ip1.eq.i1.and.ip2.eq.i2).or.(ip1.eq.i2.and.ip2.eq.i1))
     *            goto 40
               call vorfclst(it2,j,itets,0,ntet,ibndflg,ivorerr)
               if(ibndflg.ne.2) goto 40
               itlast=itets(ntet)
               itest2=min0(iabs(itet(1,itlast)-i4),
     *                     iabs(itet(2,itlast)-i4),
     *                     iabs(itet(3,itlast)-i4),
     *                     iabs(itet(4,itlast)-i4))
               if(itest2.eq.0) then
                  idup=j
                  goto 50
               endif
 40         continue
C
C           ____________________________________________________________
C
C
 45         continue
            if(idebug.gt.1.and.(itest1.eq.0.or.itest2.eq.0)) then
               write(logmess,9000) i,it,(itet(idum,it),idum=1,4)
               call writloga("default",0,logmess,0,ierrwrt)
 9000          format("try2to2b: i=",i5," it=",5i9)
               write(logmess,9010) idup,it2,(itet(idum,it2),idum=1,4)
               call writloga("default",0,logmess,0,ierrwrt)
 9010          format("           ",i5," it=",5i9)
               write(logmess,9010) 0,itlast,(itet(idum,itlast),idum=1,4)
               call writloga("default",0,logmess,0,ierrwrt)
               write(logmess,9010) 0,i1,i2,i3,i4,i5
               call writloga("default",0,logmess,0,ierrwrt)
            endif
C
C           ____________________________________________________________
C
C           PERFORM THE FLIP
C
            call find2to2(it,it2,i1,i2,i3,i4,i5,id(1),jd(1),
     *                    npoints,ntets)
            call flip2to2(it,it2,id(1),jd(1),
     *                    npoints,ntets)
            n2to2=n2to2+1
            kfix(1,it)=it
            kfix(1,it2)=it2
C
C           ...........................................................
C           ATTEMPT A 2-TO-0 FLIP.
C
            itets(1)=it
            itets(2)=it2
            call try2to0(itets,itwo,nflips,itx,
     *                   npoints,ntets)
            n2to0=n2to0+nflips
C
C           ...........................................................
C
            goto 100
 50      continue
C
 100  continue
C
      goto 9999
 9999 continue
      return
      end


*----------------------------------------------------------------------*
      subroutine fs_add_drv(xret_blk,type_xret,idx_tgt,me_tgt,
     &         fl_item,update,
     &         op_info,str_info,strmap_info,orb_info)
*----------------------------------------------------------------------*
*     driver for [ADD] operation in frm_schedX() (X>=2)
*     ... and [COPY] as well ...
*----------------------------------------------------------------------*
      implicit none

      include 'opdim.h'
      include 'stdunit.h'
      include 'ioparam.h'
      include 'def_orbinf.h'
      include 'mdef_operator_info.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_contraction.h'
      include 'def_formula_item.h'
      include 'par_opnames_gen.h'

      real(8), intent(inout), target ::
     &     xret_blk(*)
      logical, intent(in) ::
     &     update
      integer, intent(in) ::
     &     type_xret, idx_tgt
      type(me_list), intent(inout), target ::
     &     me_tgt
      type(formula_item), intent(in) ::
     &     fl_item

      type(operator_info), intent(inout) ::
     &     op_info
      type(strinf), intent(inout) ::
     &     str_info
      type(strmapinf), intent(inout) ::
     &     strmap_info
      type(orbinf), intent(in) ::
     &     orb_info

      character(maxlen_bc_label) ::
     &     label_res, label_op
      integer ::
     &     idx_res, idx_op, iblk_res, iblk_op, idxme, type_xret_loc
      real(8) ::
     &     fact
      logical ::
     &     tra_res, tra_op, copy_only
      real(8), target ::
     &     xret_dummy(1)

      integer, pointer ::
     &     op2list(:)
      type(me_list_array), pointer ::
     &     mel_arr(:)
      type(me_list), pointer ::
     &     me_op, me_res
      type(binary_contr), pointer ::
     &     add_info
      real(8), pointer ::
     &     xret_pnt(:)

      integer, external ::
     &     idx_oplist2

      mel_arr => op_info%mel_arr
      op2list => op_info%op2list

      add_info => fl_item%bcontr

      copy_only = fl_item%command.eq.command_cp_intm

      if (add_info%n_operands.ne.1.or.add_info%n_cnt.ne.0) then
        write(lulog,*) '[ADD]: something is wrong:'
        call prt_bcontr(lulog,add_info)
        call quit(1,'fs_add_drv','something is wrong')
      end if

      label_res = add_info%label_res
      label_op  = add_info%label_op1

      idx_res = idx_oplist2(label_res,op_info)
      if (update.and.idx_res.ne.idx_tgt) then
        write(lulog,*) 'formula target: ',
     &       trim(op_info%op_arr(idx_tgt)%op%name)
        write(lulog,*) '[ADD] result: ',trim(label_res)
        call quit(1,'fs_add_drv','inconsistency: target<>result')
      end if
      idx_op = idx_oplist2(label_op,op_info)

      iblk_res = add_info%iblk_res
      iblk_op  = add_info%iblk_op1
      tra_res = add_info%tra_res
      tra_op  = add_info%tra_op1

      if (update) then
        me_res => me_tgt
        type_xret_loc = type_xret
        xret_pnt => xret_blk(iblk_res:iblk_res)
      else
        idxme = op2list(idx_res)
        me_res => mel_arr(idxme)%mel
        if (me_res%fhand%unit.lt.0)
     &       call file_open(me_res%fhand)
        type_xret_loc = 0
        xret_pnt => xret_dummy
      end if

      fact = add_info%fact

      ! special: unit operator
      if (label_op.eq.op_unity) then
        call quit(1,'fs_add_drv',
     &       'add_unity still misses update of xret')
        call add_unity(fact,1,me_res,iblk_res,orb_info,str_info)
      else
        idxme = op2list(idx_op)
        me_op => mel_arr(idxme)%mel
        if (me_op%fhand%unit.le.0)
     &       call file_open(me_op%fhand)
c?        njoined = add_info%nj_op1
c?        ! iblkop fix:
c?        iblkop  = (iblkop-1)/njoined + 1
        if (.not.tra_op.and.     tra_res .or.
     &           tra_op.and..not.tra_res) then
          call add_opblk_transp(xret_pnt,type_xret_loc,fact,
     &             me_op,me_res,tra_op,tra_res,
     &             iblk_op,iblk_res,
     &             op_info,str_info,orb_info,copy_only)
        else
          call add_opblk(xret_pnt,type_xret_loc,fact,
     &             me_op,me_res,
     &             iblk_op,iblk_res,orb_info,copy_only)
        end if

      end if

      return
      end