! -*- f95 -*-

! Copyright (c) 2021. Pfizer Inc. All rights reserved.

module axivity
    use, intrinsic :: iso_c_binding
    implicit none

    type :: metadata
        character(2) :: header                      ! @1  [2] "MD" metadata block
        integer(c_int16_t) :: blockSize             ! @3  [2] Packet size (should be 508 - 512 less first 4 bytes)
        integer(c_int8_t) :: performClear           ! @5  [1]
        integer(c_int16_t) :: deviceID              ! @6  [2] device identifier
        integer(c_int32_t) :: sessionID             ! @8  [4] session identifier
        integer(c_int16_t) :: upperDeviceID         ! @12 [2] upper word of device ID (treat 0xffff as 0x0000)
        integer(c_int32_t) :: loggingStartTime      ! @14 [4]
        integer(c_int32_t) :: loggingEndTime        ! @18 [4]
        integer(c_int32_t) :: loggingCapacity       ! @22 [4] deprecated, should be 0
        integer(c_int8_t)  :: reserved1             ! @26 [1]
        integer(c_int8_t)  :: flashLED              ! @27 [1]
        integer(c_int8_t)  :: reserved2(8)          ! @28 [8]
        integer(c_int8_t)  :: sensorConfig          ! @36 [1] Fixed rate sensor config. 0x00 or 0xff=>accel only, otherwise bottom nibble is gyro range, top nibble non-zero is magnetometer enabled
        integer(c_int8_t)  :: samplingRate          ! @37 [1] Sampling rate/accelerometer range/scale
    end type metadata

    type :: datapacket
        integer(c_int16_t) :: header                  ! @1  [2] ASCII "AX", little endian (0x5841)
        integer(c_int16_t) :: length            ! @3  [2] Packet length, 508 bytes, with header (4) = 512 bytes
        integer(c_int16_t) :: deviceID          ! @5  [2] Top bit set, 15-bit fraction of a second for the time stamp, the timestampOffset was already adjusted to minimize this assuming ideal sample rate; top bit clear: 15-bit device identifier, 0=unknown
        integer(c_int32_t) :: sessionID         ! @7  [4] Unique session identifier, 0 = unkonwn
        integer(c_int32_t) :: sequenceID        ! @11 [4] Sequence number, 0 indexed
        integer(c_int32_t) :: timestamp         ! @15 [4] last reported RTC value, 0 = unknown
        integer(c_int16_t) :: light             ! @19 [2] AAAGGGLLLLLLLLLL bottom 10 is light, top 3 are unpacked accel scale (1/2^(8+n) g), next 3 are gyro range (8000/(2^n) dps)
        integer(c_int16_t) :: temperature       ! @21 [2] Last recorded temperature value (bottom 10 bits)
        integer(c_int8_t) :: events             ! @23 [1] event flags since last packet
        integer(c_int8_t) :: battery            ! @24 [1] last recorded battery level in scaled/cropped raw units (double and add 512 for 10-bit ADC value)
        integer(c_int8_t) :: sampleRate         ! @25 [1] sample rate code, frequency
        integer(c_int8_t) :: numAxesBPS         ! @26 [1] 0x32 top nibble: number of axes, bottom: packing format - 2=3x 16 bit signed, 0=3x 10bit signed + 2 bit exponent
        integer(c_int16_t) :: timestampOffset   ! @27 [2] Relativ esample index from the start of the buffer where the whole second timestamp is valid
        integer(c_int16_t) :: sampleCount       ! @29 [2] Number of sensor samples (if this sector is full -- Axyz: 80 or 120 samples, Gxyz/Axyz: 40 samples)
    end type datapacket

    type, bind(c) :: FileInfo_t
        integer(c_long) :: deviceID
        integer(c_long) :: sessionID
        integer(c_int) :: nblocks
        integer(c_int8_t) :: axes
        integer(c_int16_t) :: count
        real(c_double) :: tLast
        integer(c_int) :: N
        real(c_double) :: frequency
        integer(c_long) :: Nwin
        integer(c_long) :: max_days
        integer(c_long) :: n_bad_blocks
    end type FileInfo_t

    ! converted from hex representations
    integer(c_int16_t), parameter :: HEADER_UNDEFINED = -1
    integer(c_int16_t), parameter :: HEADER_METADATA = 17485
    integer(c_int16_t), parameter :: HEADER_USAGEBLOCK = 16981
    integer(c_int16_t), parameter :: HEADER_ACCEL = 22593
    integer(c_int16_t), parameter :: HEADER_GYRO = 22855
    integer(c_int16_t), parameter :: HEADER_SESSIONINFO = 18771

    ! matching enum from read_binary_imu.h
    integer(c_int), parameter :: AX_READ_E_NONE = 0
    integer(c_int), parameter :: AX_READ_E_BAD_HEADER = 1
    integer(c_int), parameter :: AX_READ_E_MISMATCH_N_AXES = 2
    integer(c_int), parameter :: AX_READ_E_INVALID_BLOCK_SAMPLES = 3
    integer(c_int), parameter :: AX_READ_E_BAD_AXES_PACKED = 4
    integer(c_int), parameter :: AX_READ_E_BAD_PACKING_CODE = 5
    integer(c_int), parameter :: AX_READ_E_BAD_CHECKSUM = 6

contains

    ! =============================================================================================
    ! axivity_close : close an open axivity file. Needed to be able to close from C
    ! =============================================================================================
    subroutine axivity_close(info) bind(C, name="axivity_close")
        type(FileInfo_t), intent(in) :: info

        close(info%N)
    end subroutine

    ! =============================================================================================
    ! axivity_read_header : read the header (first 1024 bytes) plus a little bit for error checking
    ! =============================================================================================
    subroutine axivity_read_header(flen, file, finfo, ierr) bind(C, name="axivity_read_header")
        integer(c_long), intent(in) :: flen  ! length of the file name string
        character(kind=c_char), intent(in) :: file(flen)  ! file name
        type(FileInfo_t), intent(inout) :: finfo  ! file info storage structure
        integer(c_int), intent(inout) :: ierr  ! error tracking/returning
        ! local
        type(metadata) :: hdr
        integer(c_long) :: itmp, i
        character(960) :: annotation_block
        character(flen) :: file_
        integer(c_int8_t) :: numAxesBps
        ! for file size
        integer(4) :: fstat_vals(13), fstat_err

        ! needed for converting c strings
        do i=1_c_long, flen
            file_(i:i + 1) = file(i)
        end do

        ! initialize
        finfo%N = 17_c_int
        finfo%tLast = -1000._c_double
        finfo%n_bad_blocks = 0_c_long

        open(unit=finfo%N, file=file_, access="stream", action="read")

        ! get file information
        call fstat(finfo%N, fstat_vals, fstat_err)

        if (fstat_err == 0) then
            finfo%nblocks = int(fstat_vals(8), c_int) / 512_c_int
            ! if errors, taken care of by c program which will error with unset nblocks value
        end if

        ! read the whole header
        read(finfo%N, pos=1) hdr
        ! read the annotation block
        read(finfo%N, pos=65) annotation_block

        if (hdr%header /= "MD") then
            ierr = AX_READ_E_BAD_HEADER
            return
        end if

        ! create device ID with unsigned conversion if necessary
        if (hdr%deviceID < 0) then
            finfo%deviceID = int(hdr%deviceID, c_long) + 2_c_long**16_c_long
        else
            finfo%deviceID = int(hdr%deviceID, c_long)
        end if
        if (hdr%upperDeviceID /= -1) then
            if (hdr%upperDeviceID < 0) then
                itmp = int(hdr%upperDeviceID, c_long) + 2_c_long**16_c_long
            else
                itmp = int(hdr%upperDeviceID, c_long)
            end if
            finfo%deviceID = ior(finfo%deviceID, ishft(itmp, 16))
        end if

        ! number of axes
        if ((hdr%sensorConfig == 0) .or. (hdr%sensorConfig == -1)) then
            finfo%axes = 3_c_int8_t  ! accel only
        else
            if (iand(ishft(hdr%sensorConfig, -4), z"0f") /= 0) then
                finfo%axes = 9_c_int8_t  ! magnetometer enabled
            else
                finfo%axes = 6_c_int8_t
            end if
        end if

        ! read ahead into the data block to check number of axes and get samples per block
        read(finfo%N, pos=1025 + 25) numAxesBps
        read(finfo%N, pos=1025 + 28) finfo%count

        if (finfo%axes /= iand(ishft(numAxesBps, -4), z"0f")) then
            ierr = AX_READ_E_MISMATCH_N_AXES
            return
        end if
        if ((finfo%axes == 3) .and. ((finfo%count /= 80) .and. (finfo%count /= 120))) then
            ierr = AX_READ_E_INVALID_BLOCK_SAMPLES
            return
        else if ((finfo%axes == 6) .and. (finfo%count /= 40)) then
            ierr = AX_READ_E_INVALID_BLOCK_SAMPLES
            return
        else if ((finfo%axes == 9) .and. (finfo%count > 26)) then
            ierr = AX_READ_E_INVALID_BLOCK_SAMPLES
            return
        end if

        ! sampling frequency
        finfo%frequency = 3200. / shiftl(1, 15 - iand(hdr%samplingRate, z'0f'))
    end subroutine

    ! =============================================================================================
    ! axivity_read_block : read a single block (512 bytes) of data from an axivity file and
    !   put the data into its respective storage arrays
    ! =============================================================================================
    subroutine axivity_read_block(info, pos, imudata, timestamps, temp, bases, periods, starts, &
        i_start, stops, i_stop, ierr) bind(C, name="axivity_read_block")
        type(FileInfo_t), intent(inout) :: info  ! file information storage structure
        ! position of the file to read from. should be a multiple of 512
        integer(c_int), intent(in) :: pos
        ! imu data array. shape(3/6/9, # samples). Order is [Gy]Ax[Mag]
        real(c_double), intent(out) :: imudata(info%axes, info%count * (info%nblocks - 2))
        ! timestamp data array
        real(c_double), intent(out) :: timestamps(info%count * (info%nblocks - 2))
        real(c_double), intent(out) :: temp(info%count * (info%nblocks - 2))  ! light data array
        ! bases (starts) of windows in 24 hour format
        integer(c_long), intent(in) :: bases(info%Nwin)
        integer(c_long), intent(in) :: periods(info%Nwin)  ! periods (durations) of windows
        integer(c_long), intent(out) :: starts(info%Nwin, info%max_days)  ! Start indices of windows
        ! keeps track of where in `starts` we are
        integer(c_long), intent(out) :: i_start(info%Nwin)
        integer(c_long), intent(out) :: stops(info%Nwin, info%max_days)  ! stop indices of windows
        ! keeps track of where in `stops` we are
        integer(c_long), intent(out) :: i_stop(info%Nwin)
        integer(c_int), intent(out) :: ierr  ! error recording and returning to calling function
        ! local
        type(datapacket) :: pkt
        real(c_double) :: accelScale, gyroScale, magScale
        real(c_double) :: block_temp
        integer(c_short) :: wordsum
        integer(c_int32_t) :: i1, i2
        integer(c_int16_t) :: rawData(info%axes, info%count), k, checksum
        integer(c_int8_t) :: bps, expnt
        integer(c_int32_t), allocatable :: packedData(:)

        read(info%N, pos=pos) pkt
        if ((pkt%header /= HEADER_ACCEL) .or. (pkt%length /= 508_c_int16_t)) then
            ierr = AX_READ_E_BAD_HEADER
            return
        end if

        ! initialize for later
        wordsum = 0_c_short

        accelScale = 256._c_double  ! 1g = 256
        gyroScale = 2000._c_double  ! 32768 = 2000dps
        magScale = 16._c_double     ! 1uT = 16
        ! light is LS 10 bits, accel scale 3 msb, gyro scale next 3
        ! light(pkt%sequenceID + 1) = iand(pkt%light, z"3ff")
        accelScale = real(2**(8 + iand(ishft(pkt%light, -13), z"07")), c_double)
        gyroScale = real(8000 / (2**iand(ishft(pkt%light, -10), z"07")), c_double)

        gyroScale = 32768. / gyroScale

        ! get the temperature
        block_temp = iand(pkt%temperature, z"3ff")

        ! check bytes per sample
        if (iand(pkt%numAxesBPS, z"0f") == 0) then
            ! check # of axes
            if (info%axes /= 3) then
                ierr = AX_READ_E_BAD_AXES_PACKED
                return
            end if
            bps = 4_c_int8_t
        else if (iand(pkt%numAxesBPS, z"0f") == 2) then
            bps = info%axes * 2_c_int8_t
        else
            ierr = AX_READ_E_BAD_PACKING_CODE
            return
        end if

        ! extract the data values
        if (bps == 4) then
            if (info%count /= 120) then
                ierr = AX_READ_E_INVALID_BLOCK_SAMPLES
                return
            end if

            allocate(packedData(info%count))

            read(info%N, pos=pos+30) packedData
            ! read the checksum
            read(info%N, pos=pos + 510) checksum

            ! make sure the checksum is good
            call data_packet_sum_packed(pkt, packedData, checksum, wordsum)

            if (wordsum /= 0) then
                info%n_bad_blocks = info%n_bad_blocks + 1_c_long
                ierr = AX_READ_E_NONE  ! no error, just skip populating the block with data
                return
            end if

            do k=1, info%count
                expnt = int(ishft(packedData(k), -30), c_int8_t)
                if (expnt < 0) expnt = expnt + 4_c_int8_t
                ! unpack data
                rawData(1, k) = int(iand(ishft(packedData(k), 6), z"ffc0"), c_int16_t)
                rawData(2, k) = int(iand(ishft(packedData(k), -4), z"ffc0"), c_int16_t)
                rawData(3, k) = int(iand(ishft(packedData(k), -14), z"ffc0"), c_int16_t)

                rawData(:, k) = shifta(rawData(:, k), 6 - expnt)
            end do

            deallocate(packedData)
        else  ! 16 bit signed values
            info%count = min(info%count, 80_c_int16_t)
            if (info%count < 0) then
                ierr = AX_READ_E_INVALID_BLOCK_SAMPLES
                return
            end if

            read(info%N, pos=pos+30) rawData
            read(info%N, pos=pos+510) checksum

            ! make sure block checksum is good
            call data_packet_sum_unpacked(pkt, rawData, checksum, wordsum)
            if (wordsum /= 0) then
                info%n_bad_blocks = info%n_bad_blocks + 1_c_long
                ierr = AX_READ_E_NONE  ! no error, just skip populating the block with data
                return
            end if
        end if

        i1 = (pkt%sequenceID - info%n_bad_blocks) * info%count + 1_c_int16_t
        i2 = i1 + info%count

        ! set the temperature for the block, and convert to deg C
        temp(i1:i2) = (block_temp - 171.0) / 3.142

        ! get the data into its final storage
        if (info%axes == 3) then
            imudata(:, i1:i2) = rawData / accelScale
        else if (info%axes == 6) then
            imudata(1:3, i1:i2) = rawData(1:3, :) / gyroScale
            imudata(4:6, i1:i2) = rawData(4:6, :) / accelScale
        else if (info%axes == 9) then
            imudata(1:3, i1:i2) = rawData(1:3, :) / gyroScale
            imudata(4:6, i1:i2) = rawData(4:6, :) / accelScale
            imudata(7:9, i1:i2) = rawData(7:9, :) / magScale
        end if

        ! convert and create the timestamps
        call get_time(info, pkt, timestamps(i1:i2), bases, periods, starts, i_start, stops, i_stop)

        ierr = AX_READ_E_NONE
    end subroutine

    ! =============================================================================================
    ! get_time : creates the timestamps from the singular timestamp and offsets provided per data
    ! block.
    ! =============================================================================================
    subroutine get_time(info, pkt, time, bases, periods, starts, i_start, stops, i_stop)
        use custom_time
        type(FileInfo_t), intent(inout) :: info  ! file info storage structure
        type(datapacket), intent(in) :: pkt  ! data block info storage structure
        ! part of time array corresponding to current block
        real(c_double), intent(out) :: time(info%count)
        integer(c_long), intent(in) :: bases(info%Nwin)  ! bases (starts) of windows in hours
        integer(c_long), intent(in) :: periods(info%Nwin)  ! periods (durations) of windows
        integer(c_long), intent(out) :: starts(info%Nwin, info%max_days)  ! start indices of windows
        integer(c_long), intent(out) :: i_start(info%Nwin)  ! tracks of where we are in `starts`
        integer(c_long), intent(out) :: stops(info%Nwin, info%max_days)  ! stop indices of windows
        integer(c_long), intent(out) :: i_stop(info%Nwin)  ! track of where we are in `stops`
        ! local
        integer(c_long), parameter :: EPOCH = 2440588_c_long
        integer(c_long) :: i, days, year, month, day
        type(time_t) :: t
        real(c_double) :: freq, t0, t1, tDelta

        year  = iand(shifta(pkt%timestamp, 26), z'3f') + 2000_c_long  ! since 0 CE
        month = iand(shifta(pkt%timestamp, 22), z'0f')
        day   = iand(shifta(pkt%timestamp, 17), z'1f')
        t%hour  = iand(shifta(pkt%timestamp, 12), z'1f')
        t%min   = iand(shifta(pkt%timestamp, 6), z'3f')
        t%sec   = iand(pkt%timestamp, z'3f')
        t%msec  = 0_c_long

        ! compute days
        days = day - 32075_c_long + 1461_c_long * (year + 4800_c_long + (month - 14_c_long) / 12_c_long) / 4_c_long &
            + 367_c_long * (month - 2_c_long - (month - 14_c_long) / 12_c_long * 12_c_long) / 12_c_long &
            - 3_c_long * ((year + 4900_c_long + (month - 14_c_long) / 12_c_long) / 100_c_long) / 4_c_long

        ! remove days to 1970
        days = days - EPOCH
        ! convert to seconds
        t0 = days * DAY_SEC
        ! add hours, minutes, seconds
        t0 = t0 + (t%hour * SEC_HOUR) + (t%min * SEC_MIN) + real(t%sec, c_double)

        freq = 3200. / shiftl(1, 15 - iand(pkt%sampleRate, z'0f'))
        if (freq <= 0.) freq = 1.

        t0 = t0 - pkt%timestampOffset / freq
        t1 = t0 + pkt%sampleCount / freq
        ! for indexing. Can be negative, as it just gets added into the current timestamp
        t%msec = int(-pkt%timestampOffset / freq * 1000, c_long)

        if ((info%tLast > 0.) .and. ((t0 - info%tLast) < 1.)) then
            t%msec = t%msec - int((t0 - info%tLast) * 1000, c_long)  ! convert to microseconds
            t0 = info%tLast
        end if
        info%tLast = t1

        tDelta = (t1 - t0) / pkt%sampleCount
        time = (/ (t0 + i * tDelta, i=0, info%count - 1) /)

        ! subtract 2 from nblocks for 2 header blocks included in total
        call get_day_indexing(freq, t, info%max_days, info%Nwin, bases, periods, &
            int(pkt%sequenceID, c_long), int(info%nblocks, c_long) - 2, int(info%count, c_long), &
            starts, i_start, stops, i_stop)
    end subroutine

    ! =============================================================================================
    ! data_packet_sum_unpacked : computes the total checksum calculation for a data block if the
    !   data is in the unpacked format (ie 2bytes per sample)
    ! =============================================================================================
    subroutine data_packet_sum_unpacked(pkt, raw_data, checksum, val)
        type(datapacket), intent(inout) :: pkt  ! data block info storage structure
        integer(c_int16_t), intent(in) :: raw_data(:, :)  ! read in raw data
        integer(c_int16_t), intent(in) :: checksum  ! checksum value from the block
        integer(c_short), intent(out) :: val  ! checksum storage
        ! local
        integer :: i, j

        val = 0

        call plus16(pkt%header, val)
        call plus16(pkt%length, val)
        call plus16(pkt%deviceID, val)
        call plus32(pkt%sessionID, val)
        call plus32(pkt%sequenceId, val)
        call plus32(pkt%timestamp, val)
        call plus16(pkt%light, val)
        call plus16(pkt%temperature, val)
        call plus8(pkt%events, pkt%battery, val)
        call plus8(pkt%sampleRate, pkt%numAxesBPS, val)
        call plus16(pkt%timestampOffset, val)
        call plus16(pkt%sampleCount, val)

        do j=1, size(raw_data, 2)
            do i=1, size(raw_data, 1)
                call plus16(raw_data(i, j), val)
            end do
        end do

        val = val + checksum

        val = not(val) + 1_c_short
    end subroutine

    ! =============================================================================================
    ! data_packet_sum_unpacked : computes the total checksum calculation for a data block if the
    !   data is in the packed format (accel data only, 4 bytes per 3 samples)
    ! =============================================================================================
    subroutine data_packet_sum_packed(pkt, raw_packed, checksum, val)
        type(datapacket), intent(inout) :: pkt  ! data block info storage structure
        integer(c_int32_t), intent(in) :: raw_packed(120)  ! raw packed data samples
        integer(c_int16_t), intent(in) :: checksum  ! checksum value from the block
        integer(c_short), intent(out) :: val  ! checksum storage
        ! local
        integer :: i

        val = 0

        call plus16(pkt%header, val)
        call plus16(pkt%length, val)
        call plus16(pkt%deviceID, val)
        call plus32(pkt%sessionID, val)
        call plus32(pkt%sequenceId, val)
        call plus32(pkt%timestamp, val)
        call plus16(pkt%light, val)
        call plus16(pkt%temperature, val)
        call plus8(pkt%events, pkt%battery, val)
        call plus8(pkt%sampleRate, pkt%numAxesBPS, val)
        call plus16(pkt%timestampOffset, val)
        call plus16(pkt%sampleCount, val)

        do i=1, 120  ! packed data will always be 120
            call plus32(raw_packed(i), val)
        end do

        val = val + checksum

        val = not(val) + 1_c_short  ! bitwise not and add 1

    end subroutine

    ! =============================================================================================
    ! plus16 : subroutine for adding a 2byte word to the checksum value
    ! =============================================================================================
    subroutine plus16(x, val)
        integer(c_int16_t), intent(in) :: x
        integer(c_short), intent(inout) :: val

        ! don't need to account for unsigned, because it is taken care of by the truncation/swapping
        ! around the max value for signed.
        ! ie - bits are same even if representation isn't
        val = val + int(x, c_short)
    end subroutine

    ! =============================================================================================
    ! plus8 : subroutine for adding 2 1-byte values to the checksum value
    ! =============================================================================================
    subroutine plus8(x, y, val)
        integer(c_int8_t), intent(in) :: x, y
        integer(c_short), intent(inout) :: val

        val = val + int(x, c_short)
        val = val + ishft(int(y, c_short), 8)
    end subroutine

    ! =============================================================================================
    ! plus32 : subroutine for adding 1 4-byte value to the checksum value
    ! =============================================================================================
    subroutine plus32(x, val)
        integer(c_int32_t), intent(in) :: x
        integer(c_short), intent(inout) :: val

        val = val + int(iand(x, z"ffff"), c_short)
        val = val + int(iand(ishft(x, -16), z"ffff"), c_short)

    end subroutine

end module axivity


        SUBROUTINE ZRCCR1(CCR1,DET,L0,A,ISTAT)
*
*  Module number:
*
*  Module name: ZRCCR1
*
*  Keyphrase:
*  ----------
*       Read table CCR1 (GHRS line mapping function coefficients)
*
*  Description:
*  ------------
*       This routine reads table CCR1 and extracts the parameters
*       for the specified detector.
*
*  FORTRAN name: ZRCCR1.FOR
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       CCR1                    I       Line mapping function coef.
*
*  Subroutines Called:
*  -------------------
*  SDAS:
*       ZMSPUT, uttopn, utpgti, utcfnd, utrgt*, uttclo
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       APR 89  D. Lindler      Designed and coded
*-------------------------------------------------------------------------------
*
* Input parameters
*
*       CCR1 - table name (character*64)
*       det - detector number (integer)
*
* Output parameters
*
*       L0 - constant term in line mapping function coef. (real*4)
*       A - linear term (real*4)
*       istat - ERROR status (integer)
**************************************************************************
        CHARACTER*64 CCR1
        INTEGER ISTAT,DET
        REAL L0,A
C
C     FILE I/O ACCESS MODES
C
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C     THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O.
C
C
C     THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET:
C
C                                       NUMBER OF ROWS WRITTEN TO
      INTEGER   TBNROW
      PARAMETER (TBNROW = 21)
C     END IRAF77.INC
C
C LOCAL VARIABLES -------------------------------------------
C
        INTEGER IDIN,NROWS,COLIDS(16),ROW,IDET,I,ISTATS(4)
        CHARACTER*80 CONTXT
        CHARACTER*15 COLNAM(3)
        LOGICAL NULL
        DATA COLNAM/'DETECTOR','L0','A'/
C
C--------------------------------------------------------------------------
C
C Open table
C
        CALL UTTOPN(CCR1,RDONLY,IDIN,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR opening CCR1 table '//CCR1
                GO TO 998
        ENDIF
C
C get number of rows
C
        CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR reading CCR1 table '//CCR1
                GO TO 999
        ENDIF
C
C Get column ids.
C
        CALL UTCFND(IDIN,COLNAM,3,COLIDS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR locating needed columns in CCR1 table '//
     *                  CCR1
                GO TO 999
        ENDIF
C
C Locate row with correct detector number
C
        DO 10 ROW=1,NROWS
                CALL UTRGTI(IDIN,COLIDS(1),1,ROW,IDET,NULL,ISTAT)
                IF(ISTAT.NE.0)THEN
                        CONTXT='ERROR reading CCR1 table '//CCR1
                        GO TO 999
                ENDIF
                IF(DET.EQ.IDET)GO TO 20
10      CONTINUE
C
C if we made it here, we did not find a correct row
C
        WRITE(CONTXT,99)DET
99      FORMAT('ERROR no row in CCR1 table found for detector ',I2)
        GO TO 999
C
C read values
C
20      CALL UTRGTR(IDIN,COLIDS(2),1,ROW,L0,NULL,ISTATS(1))
        CALL UTRGTR(IDIN,COLIDS(3),1,ROW,A,NULL,ISTATS(2))
        DO 30 I=1,2
            IF(ISTATS(I).NE.0)THEN
                CONTXT='ERROR reading CCR1 table '//CCR1
                GO TO 999
            ENDIF
30      CONTINUE
        ISTAT=0
        GO TO 1000
999     CALL UTTCLO(IDIN,ISTAT)
998     CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END


*deck wtint2
      subroutine wtint2( h4,      il,     iprst,  iscm,
     & buffer, values, labels, ibitv )
c
c  assign orbital labels and write records of 2-e integrals.
c
c  01-dec-90 SIFS version. ls(2,*) used as a 2d array. -rls
c
      implicit logical(a-z)
c
      integer    ilfact
      parameter( ilfact=1024 )
c
c     # /bufout/ holds some output integral file parameters.
      integer
     & info,     ifmt1,   ifmt2,   itypea,  itypeb,
     & ibuf,     numout,  nrec,    ntape
      common /bufout/
     & info(10), ifmt1,   ifmt2,   itypea,  itypeb,
     & ibuf,     numout,  nrec,    ntape
c
      integer       l2rec
      equivalence ( l2rec, info(4) )
      integer       n2max
      equivalence ( n2max, info(5) )
c
      integer   nunits
      parameter(nunits=4)
      integer        iunits
      common /units/ iunits(nunits)
      integer                  nlist
      equivalence ( iunits(1), nlist )
c
      real*8         cutoff, tol
      common /parmr/ cutoff, tol
c
      integer
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
      common /parmi/
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
c
      logical       eprsf,    esfi,    esfk
      common /lgcl/ eprsf(3), esfi(3), esfk(3)
c
      integer
     & itl,    itu,    jtl,    jtu,    ktl,    ktu,    ltl,    ltu,
     & jcu,    kcu,    lcu,    inx,    jnx,    knx,    lnx,    nwt,
     & nwt1,           ijsf,           klsf,           icxs,
     & kcxs,           npri,           nprk,           iesfbx, kesfbx,
     & ircrux, jrcrux, krcrux, lrcrux
      common /ntgr/
     & itl,    itu,    jtl,    jtu,    ktl,    ktu,    ltl,    ltu,
     & jcu,    kcu,    lcu,    inx,    jnx,    knx,    lnx,    nwt,
     & nwt1(3),        ijsf(3),        klsf(3),        icxs(2,3),
     & kcxs(2,3),      npri(2,3),      nprk(2,3),      iesfbx, kesfbx,
     & ircrux, jrcrux, krcrux, lrcrux
c
      integer       npriri,        nprirk
      common /ikpr/ npriri(2,3,8), nprirk(2,3,8)
c
      real*8
     & xij,    xijm,   yij,    yijm,   zij,    zijm,   xkl,    xklm,
     & ykl,    yklm,   zkl,    zklm
      integer
     & icons,  ircru,  jcons,  jrcru,  kcons,  krcru,  lcons,  lrcru
      logical
     & esfc,   esfcij, esfckl
      common /misc/
     & xij,    xijm,   yij,    yijm,   zij,    zijm,   xkl,    xklm,
     & ykl,    yklm,   zkl,    zklm,
     & icons,  ircru,  jcons,  jrcru,  kcons,  krcru,  lcons,  lrcru,
     & esfc,   esfcij, esfckl
c
      integer    nipv
      parameter( nipv=4 )
c
c     # dummy:
      integer iscm
      integer il(*), iprst(*), labels(nipv,*), ibitv(*)
      real*8 h4(*), buffer(*), values(*)
c     # ibm+convex f77 bug; actual:
c     # integer labels(nipv,n2max), ibitv( ((n2max+63)/64)*64 )
c     # real*8 buffer(l2rec), values(n2max)
c
c     # local:
      integer ibl, ipr, kprib, ircr, jrcr, iesfb, iprkb, kpr, krcr,
     & lrcr, kesfb, ist, npairi, npairk, kpri, ipair, kpair
      integer    msame
      parameter( msame=0 )
c
      ibl = 0
      ipr = iprst(ijsf(iscm))
      if ( eprsf(iscm) ) then
        kprib = ipr
      else
        kprib = iprst(klsf(iscm))
      endif
      do 176 ircr = 1, ircru
        if ( esfi(iscm) ) jrcru = ircr
        do 174 jrcr = 1, jrcru
          if ( esfi(iscm) .and. (ircr .eq. jrcr) ) then
            iesfb = 1
          else
            iesfb = 2
          endif
          iprkb = ipr
          kpr = kprib
          if ( eprsf(iscm) ) krcru = ircr
          do 172 krcr = 1, krcru
            if ( eprsf(iscm) ) then
              if ( ircr .eq. krcr ) then
                lrcru = jrcr
              elseif ( esfk(iscm) ) then
                lrcru = krcr
              else
                lrcru = jrcru
              endif
            else
              if ( esfk(iscm) ) lrcru = krcr
            endif
            do 170 lrcr = 1,lrcru
              if ( esfk(iscm) .and. (krcr .eq. lrcr) ) then
                kesfb = 1
              else
                kesfb = 2
              endif
              ipr = iprkb
              do 160 ist = 1, nst
                npairi = npriri(iesfb,iscm,ist)
                npairk = nprirk(kesfb,iscm,ist)
                if ( npairi .eq. 0 ) then
                  kpr = kpr + npairk
                  go to 160
                elseif ( npairk .eq. 0 ) then
                  ipr = ipr + npairi
                  go to 160
                endif
                kpri = kpr
                do 150 ipair = 1, npairi
                  ipr = ipr + 1
                  if ( eprsf(iscm) .and. (ircr .eq. krcr)
     &             .and. (jrcr .eq. lrcr) ) npairk = ipair
                  kpr = kpri
                  do 140 kpair = 1, npairk
                    kpr = kpr + 1
                    ibl = ibl + 1
                    if ( abs(h4(ibl)) .gt. cutoff ) then
                      if ( ibuf .eq. n2max ) then
                        call wtlab2( msame, buffer, values, labels,
     &                   ibitv )
                      endif
                      ibuf           = ibuf + 1
                      labels(1,ibuf) = il(ipr) / ilfact
                      labels(2,ibuf) = mod( il(ipr), ilfact )
                      labels(3,ibuf) = il(kpr) / ilfact
                      labels(4,ibuf) = mod( il(kpr), ilfact )
                      values(ibuf)   = h4(ibl)
                    endif
140               continue
150             continue
160           continue
170         continue
172       continue
174     continue
176   continue
c
      return
      end


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine sedim  ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Sedimentation routine used for IMx

!
!     Description of the module :
!
!        General water quality module for DELWAQ:
!        SEDIMENTATION FORMULATIONS
!        MODULE VALID FOR IM, IM2, IM3
!
! Name    T   L I/O   Description                                    Units
! ----    --- -  -    -------------------                            -----
! CONC    R*4 1 I  concentration sedimenting material water        [gX/m3]
! DEPTH   R*4 1 I  DELWAQ depth                                        [m]
! FL (1)  R*4 1 O  sedimentation flux (water->mixinglayer)       [gX/m3/d]
! MINDEP  R*4 1 I  minimal depth for sedimentation                     [m]
! PSED    R*4 1 L  sedimentaion probability (0 - 1)                    [-]
! POTSED  R*4 1 L  potential sedimentation flux                  [gX/m2/d]
! TAU     R*4 1 I  calculated sheerstress                        [kg/m/s2]
! TAUVEL  R*4 1 I  total velocity calcualted from tau                [m/s]
! TCRSED  R*4 1 I  critical sheerstress sedimentation            [kg/m/s2]
! VCRSED  R*4 1 I  critical velocity sedimentation                   [m/s]
! VSED    R*4 1 O  first order sedimentaion rate (calculated)        [m/d]
! ZERSED  R*4 1 I  zeroth order sedimentation flux               [gX/m2/d]

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------

      USE BottomSet     !  Module with definition of the waterbottom segments

      IMPLICIT REAL (A-H,J-Z)

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4

      REAL     MINDEP, MINDE2, DEPTH , DEPTH2

      LOGICAL, SAVE :: FIRST = .TRUE.
      LOGICAL       :: SW_PSEDMIN
      INTEGER       :: IDUMMY
      REAL   , SAVE :: PSEDMIN
      CHARACTER     :: CDUMMY
      INTEGER       :: IERR2
      INTEGER       :: LUNREP

      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
      IP11 = IPOINT(11)
      IP12 = IPOINT(12)
      IP13 = IPOINT(13)
      IP14 = IPOINT(14)
      IP15 = IPOINT(15)
      IP16 = IPOINT(16)
      IP17 = IPOINT(17)

      IN1  = INCREM(1 )
      IN2  = INCREM(2 )
      IN3  = INCREM(3 )
      IN4  = INCREM(4 )
      IN5  = INCREM(5 )
      IN6  = INCREM(6 )
      IN7  = INCREM(7 )
      IN8  = INCREM(8 )
      IN9  = INCREM(9 )
      IN10 = INCREM(10)
      IN11 = INCREM(11)
      IN12 = INCREM(12)
      IN13 = INCREM(13)
      IN14 = INCREM(14)
      IN15 = INCREM(15)
      IN16 = INCREM(16)
      IN17 = INCREM(17)

      IFLUX = 0
      DO 9000 ISEG = 1 , NOSEG

!     zero output

      PMSA (IP14) = 0.0
      PMSA (IP15) = 0.0
      PMSA (IP16) = 0.0

!     sedimentation towards the bottom

      CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
      IF (IKMRK1.EQ.1) THEN
      CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2)
      IF ((IKMRK2.EQ.0).OR.(IKMRK2.EQ.3)) THEN
!
      CONC    = MAX (0.0, PMSA(IP1) )
      ZERSED  = PMSA(IP2 )
      VSED    = PMSA(IP3 )
      TAU     = PMSA(IP4 )
      TCRSED  = PMSA(IP5 )
      DEPTH   = PMSA(IP6 )
      DELT    = PMSA(IP7 )
      MINDEP  = PMSA(IP8 )
      ALPHA   = PMSA(IP9 )
      P       = PMSA(IP10)
      PMAX    = PMSA(IP11)
      PSEDMIN = PMSA(IP12)

!***********************************************************************
!**** Processes connected to the SEDIMENTATION
!***********************************************************************

!     if fraction IM1 in second layer P > PMAX then ALPHA = 0 meaning no sedimentations towards S2

      IF ( P .GE. PMAX ) THEN
         ALPHA = 0.0
      ENDIF

!     Calculate sedimenation probability

      IF (TAU .EQ. -1.0) THEN
          PSED = 1.0
      ELSEIF (TCRSED .LT. 1E-20 )  THEN
          PSED = 0.0
      ELSE
!         vergelijking met critische schuifspanning
          PSED = MAX ( 0.0, (1.0 - TAU/TCRSED) )
      ENDIF
      PSED = MAX( PSEDMIN, PSED )

!     Calculate potential sedimentation fluxes
!     No sedimentation when depth below min depth

      IF ( DEPTH .LT. MINDEP) THEN
         MAXSED       = 0.0
         FL( 1+IFLUX) = 0.0
         FL( 2+IFLUX) = 0.0
      ELSE
         POTSED = ZERSED + ( VSED * CONC ) * PSED

!        limit sedimentation to available mass (M/L2/DAY)
         MAXSED = MIN (POTSED, CONC / DELT * DEPTH)

!        convert sedimentation to flux in M/L3/DAY
         FL( 1+IFLUX) =  MAXSED*(1.-ALPHA) / DEPTH
         FL( 2+IFLUX) =  MAXSED*ALPHA      / DEPTH
      ENDIF

!     Output of calculated sedimentation rate
      PMSA (IP14) = PSED
      PMSA (IP15) = MAXSED*(1.-ALPHA)
      PMSA (IP16) = MAXSED*ALPHA
!
      ENDIF
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP1   = IP1   + IN1
      IP2   = IP2   + IN2
      IP3   = IP3   + IN3
      IP4   = IP4   + IN4
      IP5   = IP5   + IN5
      IP6   = IP6   + IN6
      IP7   = IP7   + IN7
      IP8   = IP8   + IN8
      IP9   = IP9   + IN9
      IP10  = IP10  + IN10
      IP11  = IP11  + IN11
      IP12  = IP12  + IN12
      IP14  = IP14  + IN14
      IP15  = IP15  + IN15
      IP16  = IP16  + IN16
 9000 CONTINUE
!
      IP1  = IPOINT(1 )
      IP6  = IPOINT(6 )
      IP8  = IPOINT(8 )
      IP15 = IPOINT(15)

!.....Exchangeloop over de horizontale richting
      DO 8000 IQ=1,NOQ1+NOQ2

         PMSA(IP17) = 0.0

         IP17 = IP17 + IN17

 8000 CONTINUE

      IP13= IP13+ ( NOQ1+NOQ2 ) * IN13

!.....Exchangeloop over de verticale richting
      DO 7000 IQ = NOQ1+NOQ2+1 , NOQ1+NOQ2+NOQ3+NOQ4

         IVAN  = IEXPNT(1,IQ)
         INAAR = IEXPNT(2,IQ)

         IF ( IVAN .GT. 0 .AND. INAAR .GT. 0 ) THEN

!           Zoek eerste kenmerk van- en naar-segmenten

            CALL DHKMRK(1,IKNMRK(IVAN ),IKMRKV)
            CALL DHKMRK(1,IKNMRK(INAAR),IKMRKN)
            IF (IKMRKV.EQ.1.AND.IKMRKN.EQ.3) THEN

!               Bodem-water uitwisseling: NUL FLUX OM OOK OUDE PDF's
!                                         TE KUNNEN GEBRUIKEN
!               Snelheid behoeft niet gezet (gebeurt in TRASED)

!               MAXSED = PMSA (IP11+(IVAN-1)*IN11)
!               CONC   = MAX (1E-20, PMSA(IP1+(IVAN-1)*IN1) )
!               PMSA(IP17) = MAXSED/86400./CONC
                FL ( 1 + (IVAN-1)*NOFLUX ) = 0.0

            ELSEIF (IKMRKV.EQ.1.AND.IKMRKN.EQ.1) THEN
!           IF (IKMRKV.EQ.1.AND.IKMRKN.EQ.1) THEN

!               Water-water uitwisseling
!rs             merk op: sedimentatie tussen waterlagen: geen taucr correctie,
!rs             alleen conversie van 1/d naar 1/s. Ten overvloede:
!rs             scu (s) en aux-timer (d) liggen dus vast!

                DEPTH  = PMSA(IP6+(IVAN -1)*IN6)
                DEPTH2 = PMSA(IP6+(INAAR-1)*IN6)
                MINDEP = PMSA(IP8+(IVAN -1)*IN8)
                MINDE2 = PMSA(IP8+(INAAR-1)*IN8)
                IF ( DEPTH .GT. MINDEP .AND. DEPTH2 .GT. MINDE2 ) THEN
                    PMSA(IP17) = PMSA(IP13)/86400.
                ELSE
                    PMSA(IP17) = 0.0
                ENDIF
            ELSE
                PMSA(IP17) = 0.0
            ENDIF

         ENDIF

         IP13= IP13+ IN13
         IP17= IP17+ IN17

 7000 CONTINUE

!     Handle velocity to the delwaq-g bottom

      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
      IP11 = IPOINT(11)
      IP12 = IPOINT(12)
      IP13 = IPOINT(13)
      IP14 = IPOINT(14)
      IP15 = IPOINT(15)
      IP16 = IPOINT(16)
      IP17 = IPOINT(17)

      DO IK = 1 , Coll%cursize

         IWA1 = Coll%set(IK)%fstwatsed
         IWA2 = Coll%set(IK)%lstwatsed

         DO IQ = IWA1,IWA2
            IWATER  = IEXPNT(1,IQ)

            CONC    = MAX (0.0, PMSA(IP1+(IWATER-1)*IN1) )
            ZERSED  = PMSA(IP2+(IWATER-1)*IN2)
            VSED    = PMSA(IP3+(IWATER-1)*IN3)
            TAU     = PMSA(IP4+(IWATER-1)*IN4)
            TCRSED  = PMSA(IP5+(IWATER-1)*IN5)
            DEPTH   = PMSA(IP6+(IWATER-1)*IN6)
            DELT    = PMSA(IP7+(IWATER-1)*IN7)
            MINDEP  = PMSA(IP8+(IWATER-1)*IN8)

!           Calculate sedimenation probability

            IF (TAU .EQ. -1.0) THEN
                PSED = 1.0
            ELSEIF (TCRSED .LT. 1E-20 )  THEN
                PSED = 0.0
            ELSE
!               vergelijking met critische schuifspanning
                PSED = MAX ( 0.0, (1.0 - TAU/TCRSED) )
            ENDIF

!           Bereken de potentiele sedimentatie fluxen
!           Geen sedimentatie onder een minimale diepte

            IF ( DEPTH .LT. MINDEP) THEN
               MAXSED       = 0.0
            ELSE
               POTSED = ZERSED + ( VSED * CONC ) * PSED

!              sedimenteer maximaal de aanwezige hoeveelheid (M/L2/DAY)
               MAXSED = MIN (POTSED, CONC / DELT * DEPTH)

            ENDIF

            IF ( CONC .GT. 1.E-10 ) THEN
               PMSA(IP17+(IQ-1)*IN17) = MAXSED/86400./CONC
            ENDIF

         ENDDO

      ENDDO
!
      RETURN
      END


*----------------------------------------------------------------------*
      subroutine leqc_init(xrsnrm,iroute,
     &       me_opt,me_trv,me_mvp,me_rhs,me_dia,me_met,me_scr,
     &       me_special,nspecial,
     &       nincore,lenbuf,
     &       xbuf1,xbuf2,xbuf3,
     &       flist,depend,use_s,
     &       fspc,nspcfrm,
     &       opti_info,opti_stat,
     &       orb_info,op_info,str_info,strmap_info)
*----------------------------------------------------------------------*
*     initialization of LEQ solver
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
c      include 'def_filinf.h'
      include 'mdef_operator_info.h'
      include 'def_file_array.h'
      include 'def_optimize_info.h'
      include 'def_optimize_status.h'
      include 'ifc_memman.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_orbinf.h'
      include 'opdim.h'
      include 'def_contraction.h'
      include 'def_formula_item.h'
      include 'def_dependency_info.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     iroute, nincore, lenbuf, nspecial, nspcfrm

      type(me_list_array), intent(inout) ::
     &     me_opt(*), me_dia(*),
     &     me_trv(*), me_mvp(*), me_rhs(*), me_scr(*),
     &     me_special(nspecial)
      type(me_list_array), intent(inout) ::
     &     me_met(*)
c      type(file_array), intent(in) ::
c     &     ffopt(*), fftrv(*), ffmvp(*), ffrhs(*), ffdia(*)

      type(formula_item), intent(inout) ::
     &     flist, fspc(nspcfrm)
      type(dependency_info) ::
     &     depend

      type(optimize_info), intent(in) ::
     &     opti_info
      type(optimize_status), intent(inout), target ::
     &     opti_stat

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

      real(8), intent(inout) ::
     &     xrsnrm(opti_info%nroot,opti_info%nopt)
      real(8), intent(inout) ::
     &     xbuf1(*), xbuf2(*), xbuf3(*)

      logical, intent(in) ::
     &     use_s(*)

* local
      logical ::
     &     zero_vec(opti_stat%ndim_vsbsp), trafo
      integer ::
     &     idx, jdx, kdx, iroot, irhs,  nred, nadd, nnew, irecscr,
     &     imet, idamp, nopt, nroot, mxsub, lenmat, job, jopt,
     &     ndim_save, ndel, iopt, lenscr, ifree, restart_mode, nselect
      real(8) ::
     &     cond, xdum, xnrm
      real(8), pointer ::
     &     gred(:), vred(:), mred(:),
     &     xmat1(:), xmat2(:), xvec(:), xret(:)
      integer, pointer ::
     &     ndim_rsbsp, ndim_vsbsp, ndim_ssbsp,
     &     iord_rsbsp(:), iord_vsbsp(:), iord_ssbsp(:),
     &     nwfpar(:),
     &     ipiv(:), iconv(:), idxroot(:), idxselect(:)
      type(file_array), pointer ::
     &     ffvsbsp(:), ffscr(:), ffmet(:)
      type(filinf), target ::
     &     fdum

      integer, external ::
     &     ioptc_get_sbsp_rec
      real(8), external ::
     &     dnrm2

      trafo = .false.

      nopt = opti_info%nopt
      nroot = opti_info%nroot
      mxsub = opti_stat%mxdim_sbsp
c      mred => opti_stat%sbspmat(1:)
c      gred => opti_stat%sbspmat(mxsub**2+1:)
c      vred => opti_stat%sbspmat(2*mxsub**2+1:)
      ndim_rsbsp => opti_stat%ndim_rsbsp
      ndim_vsbsp => opti_stat%ndim_vsbsp
      ndim_ssbsp => opti_stat%ndim_ssbsp
      iord_rsbsp => opti_stat%iord_rsbsp
      iord_vsbsp => opti_stat%iord_vsbsp
      iord_ssbsp => opti_stat%iord_ssbsp
      ffscr => opti_stat%ffscr
      ffvsbsp => opti_stat%ffvsbsp
      nwfpar => opti_info%nwfpar
      zero_vec = .false.

      allocate(ffmet(nopt))

c      if (nopt.gt.1)
c     &     call quit(1,'leqc_init','not yet adapted for nopt>1')
      if (nroot.gt.mxsub)
     &     call quit(1,'leqc_init','?? nroot>mxsub ??')

      if (nincore.ge.2) then

        do iopt = 1, nopt

         !select case(opti_info%typ_prc(iopt))
         if (opti_info%typ_prc(iopt).eq.optinf_prc_file.or.
     &       opti_info%typ_prc(iopt).eq.optinf_prc_mixed.or.
     &       opti_info%typ_prc(iopt).eq.optinf_prc_traf) then
         !case(optinf_prc_file,optinf_prc_mixed,optinf_prc_traf)

          trafo = opti_info%typ_prc(iopt).eq.optinf_prc_traf

          ! read diagonal pre-conditioner
          if (ntest.ge.100) then
            write(lulog,*) 'current ME-list: ',
     &            trim(me_dia(iopt)%mel%label)
          end if
          call vec_from_da(me_dia(iopt)%mel%fhand,1,xbuf2,nwfpar(iopt))
          if (ntest.ge.100)
     &        write(lulog,*) 'xbuf2 norm = ',
     &                       dnrm2(nwfpar(iopt),xbuf2,1)
          do iroot = 1, nroot
            if (trafo) then
              ! the present version works only, if we do this for root
              ! number 1; this is, because we modify the norm below
              ! => we have to switch around the loops
              if (iopt.ne.1)
     &             call quit(1,'leqc_init','route with trafo: problem')
              call optc_traf(me_special(2)%mel,1,xrsnrm(iroot,iopt),
     &                    me_rhs(iopt)%mel,iroot,
     &                    fspc(1),'B',me_special,nspecial,
     &                    nwfpar(iopt),xbuf1,
     &                    orb_info,op_info,str_info,strmap_info)
              call vec_from_da(me_special(2)%mel%fhand,1,xbuf1,
     &                       nwfpar(iopt))
            else
              call vec_from_da(me_rhs(iopt)%mel%fhand,iroot,xbuf1,
     &                       nwfpar(iopt))
            end if
            ! divide rhs's by preconditioner
            if (ntest.ge.100)
     &           write(lulog,*) 'xbuf1 norm = ',
     &                          dnrm2(nwfpar(iopt),xbuf1,1)
c            xnrm = dnrm2(nwfpar(iopt),xbuf1,1)
c            xrsnrm(iroot,iopt) = xnrm
            xnrm = 0d0
            do jopt = 1, nopt
              xnrm = xnrm+xrsnrm(iroot,jopt)**2
            end do
            xnrm = sqrt(xnrm)
            ! %shift is for shifted LEQ
C            call diavc(xbuf1,xbuf1,1d0/xnrm,xbuf2,opti_info%shift,
            call diavc(xbuf1,xbuf1,1d0,xbuf2,opti_info%shift,
     &                 nwfpar(iopt))
            if (ntest.ge.100)
     &           write(lulog,*) 'xbuf1 after division: ' //
     &                          ' norm = ', dnrm2(nwfpar(iopt),xbuf1,1)
            if (trafo) then
              call vec_to_da(me_special(2)%mel%fhand,1,
     &                       xbuf1,nwfpar(iopt))
              call optc_traf(me_opt(iopt)%mel,iroot,xdum,
     &                    me_special(2)%mel,1,
     &                    fspc(1),'F',me_special,nspecial,
     &                    nwfpar(iopt),xbuf1,
     &                    orb_info,op_info,str_info,strmap_info)
              ! copy to scr list
              ! original list was used to ensure spin symmetry if needed
              call switch_mel_record(me_scr(iopt)%mel,iroot)
              call list_copy(me_opt(iopt)%mel,me_scr(iopt)%mel,.false.)
            else
              call vec_to_da(ffscr(iopt)%fhand,iroot,xbuf1,nwfpar(iopt))
            end if
          end do ! iroot
         !case(optinf_prc_blocked)
         else if (opti_info%typ_prc(iopt).eq.optinf_prc_blocked) then
          if (nincore.lt.3)
     &         call quit(1,'leqc_init',
     &         'I need at least 3 incore vectors (prc_blocked)')
          do iroot = 1, nroot
            call vec_from_da(me_rhs(iopt)%mel%fhand,iroot,xbuf1,
     &                       nwfpar(iopt))
c            xnrm = dnrm2(nwfpar(iopt),xbuf1,1)
c            xrsnrm(iroot,iopt) = xnrm
            xnrm = 0d0
            do jopt = 1, nopt
              xnrm = xnrm+xrsnrm(iroot,jopt)**2
            end do
            xnrm = sqrt(xnrm)
            call dscal(nwfpar(iopt),1d0/xnrm,xbuf1,1)
            call optc_prc_special2(me_rhs(iopt)%mel,me_special,
     &                                                      nspecial,
     &                         me_opt(iopt)%mel%op%name,
     &                         opti_info%shift,
     &                         nincore,xbuf1,xbuf2,xbuf3,lenbuf,
     &                         orb_info,op_info,str_info,strmap_info)
            call vec_to_da(ffscr(iopt)%fhand,iroot,xbuf1,nwfpar(iopt))
          end do
         !case default
         else
           call quit(1,'leqc_init','unknown preconditioner type')
         end if
         !end select
        end do
      else

        call quit(1,'leqc_init','incore<2: do the programming')

        ! ... something using:
            call da_diavec(ffscr(iopt)%fhand,iroot,1,0d0,
     &                     ffscr(iopt)%fhand,iroot,1,1d0/xnrm,
     &                      me_dia(iopt)%mel%fhand,1,1,0d0,-1d0,
     &                      nwfpar(iopt),xbuf1,xbuf2,lenbuf)

      end if

      if (ndim_vsbsp.ne.0)
     &     call quit(1,'leqc_init','ndim_vsbsp.ne.0 ???')

      do iopt = 1, nopt
        if (use_s(iopt)) then
          ! assign op. with list containing the scratch trial vector
          call assign_me_list(me_scr(iopt)%mel%label,
     &                        me_opt(iopt)%mel%op%name,op_info)

          ! calculate metric * scratch trial vector
          allocate(xret(depend%ntargets),idxselect(depend%ntargets))
          nselect = 0
          call select_formula_target(idxselect,nselect,
     &                me_met(iopt)%mel%label,depend,op_info)
          do iroot = 1, nroot
            call switch_mel_record(me_met(iopt)%mel,iroot)
            call switch_mel_record(me_scr(iopt)%mel,iroot)
            call frm_sched(xret,flist,depend,idxselect,nselect,
     &             .true.,.false.,op_info,str_info,strmap_info,orb_info)
            me_met(iopt)%mel%fhand%last_mod(iroot) = -1
          end do
          deallocate(xret,idxselect)

          ! reassign op. with list containing trial vector
          call assign_me_list(me_trv(iopt)%mel%label,
     &                        me_opt(iopt)%mel%op%name,op_info)
          ffmet(iopt)%fhand => me_met(iopt)%mel%fhand
        else
          ffmet(iopt)%fhand => fdum
        end if
      end do

      ! orthogonalize initial subspace
      call optc_orthvec(nadd,.false.,
     &                  opti_stat%ffssbsp,iord_ssbsp,1d0, !1d0:dummy
     &                  ffvsbsp,
     &                  iord_vsbsp,ndim_vsbsp,mxsub,zero_vec,
     &                  use_s,0,ffmet,ffscr,nroot,nopt,
     &                  nwfpar,nincore,xbuf1,xbuf2,xbuf3,lenbuf)

      ! set nadd
      if (nadd.eq.0)
     &       call quit(0,'leqc_init',
     &       'solver in problems: only linear dependent '//
     &       'new directions?')
      opti_stat%nadd = nadd

      ! |Mv> subspace organisation should be identical to |v> subsp.
      ndim_rsbsp = ndim_vsbsp
      iord_rsbsp = iord_vsbsp
      ! dto. for |Sv> subspace
      ndim_ssbsp = ndim_vsbsp
      iord_ssbsp = iord_vsbsp

      deallocate(ffmet)

      return
      end


!
! SRF_ASCII_IO
!
! Module containing routines to read and write ASCII "HMW" format
! SRF data files.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 27-Aug-2003
!                       paul.vandelst@ssec.wisc.edu
!
!       Modified by:    Yong Chen, CIRA/CSU/JCSDA 22-Aug-2008
!                       Yong.Chen@noaa.gov

MODULE SRF_ASCII_IO

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds,        ONLY: fp
  USE File_Utility,      ONLY: Get_Lun, File_Open
  USE Message_Handler,   ONLY: SUCCESS, FAILURE, WARNING, INFORMATION, &
                               Display_Message
  USE String_Utility,    ONLY: StrUpCase
  USE SRF_Define,        ONLY: N_SENSOR_TYPES    , &
                               INVALID_SENSOR    , &
                               MICROWAVE_SENSOR  , &
                               INFRARED_SENSOR   , &
                               VISIBLE_SENSOR    , &
                               ULTRAVIOLET_SENSOR, &
                               SENSOR_TYPE_NAME  , &
                               SRF_type        , &
                               Associated_SRF  , &
                               Destroy_SRF     , &
                               Allocate_SRF    , &
                               CheckRelease_SRF, &
                               Info_SRF, &
                               Frequency_SRF, &
                               Integrate_SRF
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Public parameters
  PUBLIC :: MAX_N_SRF_CHANNELS
  ! Public procedures
  PUBLIC :: Read_SRF_ASCII_Header
  PUBLIC :: Write_SRF_ASCII_Header
  PUBLIC :: Read_SRF_ASCII
  PUBLIC :: Write_SRF_ASCII

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_RCS_ID = &
  ! Keyword set value
  INTEGER, PARAMETER :: UNSET = 0
  INTEGER, PARAMETER ::   SET = 1
  ! Maximum message string length
  INTEGER, PARAMETER :: ML = 256
  ! Header field delimiter
  CHARACTER(*), PARAMETER :: DELIMITER = ':'
  ! Maximum number of channels in an ASCII SRF file
  INTEGER, PARAMETER :: MAX_N_CHANNELS = 500
  INTEGER, PARAMETER :: MAX_N_SRF_CHANNELS = MAX_N_CHANNELS
  ! The data formats *for writing only*
  CHARACTER(*), PARAMETER :: CH_HDR_FMT    = '(i5)'
  CHARACTER(*), PARAMETER :: SRF_HDR_FMT   = '(3(1x,i5))'
  CHARACTER(*), PARAMETER :: RESPONSE_FMT  = '(8(1x,f9.6))'
  CHARACTER(*), PARAMETER :: BANDS_FMT     = '(8(1x,i5))'
  CHARACTER(*), PARAMETER :: FREQUENCY_FMT = '(8(1x,f12.5))'

CONTAINS

!##################################################################################
!##################################################################################
!##                                                                              ##
!##                          ## PUBLIC MODULE ROUTINES ##                        ##
!##                                                                              ##
!##################################################################################
!##################################################################################

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Read_SRF_ASCII_Header
!
! PURPOSE:
!       Function to read the header information from an ASCII "HMW" format
!       SRF data file.
!
! CALLING SEQUENCE:
!       Error_Status = Read_SRF_ASCII_Header( Filename               , &  ! Input
!                                             FileID                 , &  ! In/Output
!                                             n_Channels             , &  ! Output
!                                             Channel_List           , &  ! Output
!                                             Sensor_Id              , &  ! Output
!                                             Title                  , &  ! Output
!                                             History                , &  ! Output
!                                             Comment                , &  ! Output
!                                             Message_Log=Message_Log  )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Filename:         Character string specifying the name of the
!                         ASCII format SRF data file to read.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       FileID:           ASCII file ID number. If file is not already opened,
!                         it is opened and this argument contains the unit
!                         number for the opened file upon output.
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUT ARGUMENTS:
!       n_Channels:       The number of channels of data in the ASCII SRF file
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(OUT)
!
!       Channel_List:     The list of channel numbers for which there is data
!                         in the ASCII SRF file.
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Rank-1, n_Channels or greater
!                         ATTRIBUTES: INTENT(OUT)
!
!       Sensor_Id:        Character string written into the SENSOR_ID
!                         global attribute field of the ASCII SRF
!                         file.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(OUT)
!
!       Title:            Character string written into the TITLE
!                         attribute field of the ASCII SRF file.
!                         Should contain a succinct one-line description
!                         of what is in the datafile.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(OUT)
!
!       History:          Character string written into the HISTORY
!                         attribute field of the ASCII SRF file.
!                         Should contain a succinct one-line description
!                         of the datafile history.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(OUT)
!
!       Comment:          Character string written into the COMMENT global
!                         attribute field of the ASCII SRF file.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:      Character string specifying a filename in which
!                         any msgs will be logged. If not specified,
!                         or if an error occurs opening the log file, the
!                         default action is to output msgs to standard
!                         output.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:     The return value is an integer defining the error
!                         status. The error codes are defined in the
!                         Message_Handler module.
!                         If == SUCCESS the header read was successful
!                            == FAILURE an error occurred
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!
! SIDE EFFECTS:
!       If an error occurs, the ASCII file is closed before exit.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 27-Aug-2003
!                       paul.vandelst@ssec.wisc.edu
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Read_SRF_ASCII_Header( Filename    , &  ! Input
                                  FileID      , &  ! In/Output
                                  n_Channels  , &  ! Output
                                  Channel_List, &  ! Output
                                  Sensor_Id   , &  ! Output
                                  Title       , &  ! Output
                                  History     , &  ! Output
                                  Comment     , &  ! Output
                                  Message_Log ) &  ! Error messaging
                                RESULT( Error_Status )
    ! Arguments
    CHARACTER(*),           INTENT(IN)     :: Filename
    INTEGER,                INTENT(IN OUT) :: FileID
    INTEGER,                INTENT(OUT)    :: n_Channels
    INTEGER,                INTENT(OUT)    :: Channel_List(:)
    CHARACTER(*),           INTENT(OUT)    :: Title
    CHARACTER(*),           INTENT(OUT)    :: History
    CHARACTER(*),           INTENT(OUT)    :: Sensor_Id
    CHARACTER(*),           INTENT(OUT)    :: Comment
    CHARACTER(*), OPTIONAL, INTENT(IN)     :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Read_SRF_ASCII_Header'
    INTEGER,      PARAMETER :: N_ATTRIBUTES = 4
    ! Local variables
    CHARACTER(ML)   :: msg
    CHARACTER(2000) :: Buffer
    CHARACTER(256)  :: Attribute_Name
    CHARACTER(2000) :: Attribute_Value
    INTEGER :: IO_Status
    INTEGER :: i, l, m, n

    ! Setup
    ! -----
    Error_Status = SUCCESS

    ! Open the file if required
    !--------------------------
    IF ( .NOT. File_Open( TRIM(Filename) ) ) THEN

      ! Get a file unit number
      FileID = Get_Lun()
      IF ( FileID < 0 ) THEN
        msg = 'Error obtianing file unit number'
        CALL ReadHdr_Cleanup(); RETURN
      END IF

      ! Open the file
      OPEN( FileID, FILE   = TRIM(Filename), &
                    STATUS = 'OLD', &
                    FORM   = 'FORMATTED', &
                    ACCESS = 'SEQUENTIAL', &
                    ACTION = 'READ', &
                    IOSTAT = IO_Status )
      IF ( IO_Status /= 0 ) THEN
        WRITE( msg,'("Error opening ASCII SRF file ",a,". IOSTAT = ",i0)' ) &
                   TRIM(Filename), IO_Status
        CALL ReadHdr_Cleanup(); RETURN
      END IF

    ELSE

      ! File is already open, so rewind it
      REWIND( FileID )

    END IF

    ! Read the number of channels dimension
    ! -------------------------------------
    READ( FileID,FMT=CH_HDR_FMT,IOSTAT=IO_Status ) n_Channels
    IF ( IO_Status /= 0 ) THEN
      WRITE( msg,'("Error reading number of channels from ",a,". IOSTAT = ",i0)' ) &
                 TRIM(Filename), IO_Status
      CALL ReadHdr_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! Check the size of the channel list argument
    ! -------------------------------------------
    IF ( SIZE(Channel_List) < n_Channels ) THEN
      WRITE( msg,'("CHANNEL_LIST argument not large enough to hold ",i0," channels.")' ) &
                 n_Channels
      CALL ReadHdr_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! Read the channel list
    ! ---------------------
    DO l = 1, n_Channels
      READ( FileID,FMT=CH_HDR_FMT,IOSTAT=IO_Status ) Channel_List(l)
      IF ( IO_Status /= 0 ) THEN
        WRITE( msg,'("Error reading channel index ",i0," from ",a,". IOSTAT = ",i0)' ) &
                   l, TRIM(Filename), IO_Status
        CALL ReadHdr_Cleanup(Close_File=.TRUE.); RETURN
      END IF
    END DO

    ! Read the data attributes
    !-------------------------
    Attribute_Read_Loop: DO i = 1, N_ATTRIBUTES

      ! Buffer in the input
      ! -------------------
      READ( FileID,FMT='(a)',IOSTAT=IO_Status ) Buffer
      IF ( IO_Status /= 0 ) THEN
        WRITE( msg,'("Error reading attribute #",i0," from ",a,". IOSTAT = ",i0)' ) &
                   i, TRIM(Filename), IO_Status
        CALL ReadHdr_Cleanup(Close_File=.TRUE.); RETURN
      END IF

      ! Extract the attribute name and value
      ! ------------------------------------
      ! Get the string length and ensure it's not empty
      n = LEN_TRIM(Buffer)
      IF ( n == 0 ) THEN
        WRITE( msg,'("Attribute #",i0," from ",a," is empty.")' ) i, TRIM(Filename)
        CALL ReadHdr_Cleanup(Close_File=.TRUE.); RETURN
      END IF

      ! Search for the delimiter and check
      m = SCAN(Buffer,DELIMITER)
      IF ( m  == 0 .OR. &        ! No delimiter
           m  == 1 .OR. &        ! No attribute name
           m+1 > n      ) THEN   ! No attribute value
        WRITE( msg,'("Attribute #",i0," from ",a," delimiter scan failed.")' ) i, TRIM(Filename)
        CALL ReadHdr_Cleanup(Close_File=.TRUE.); RETURN
      END IF

      ! Extract the data from the buffer string
      Attribute_Name  = ADJUSTL(StrUpCase( Buffer(1:m-1) ))
      Attribute_Value = Buffer(m+1:n)

      ! Match the attribute by name and save
      ! ------------------------------------
      SELECT CASE( TRIM(Attribute_Name) )
        CASE('TITLE')
          Title = TRIM(Attribute_Value)
        CASE('HISTORY')
          History = TRIM(Attribute_Value)
        CASE('SENSOR_ID')
          Sensor_Id = TRIM(Attribute_Value)
        CASE('COMMENT')
          Comment = TRIM(Attribute_Value)
        CASE DEFAULT
          msg = 'Unrecognised attribute name: '//TRIM(Attribute_Name)
          CALL ReadHdr_Cleanup(Close_File=.TRUE.); RETURN
      END SELECT

    END DO Attribute_Read_Loop

  CONTAINS

    SUBROUTINE ReadHdr_CleanUp(Close_File)
      LOGICAL, OPTIONAL, INTENT(IN) :: Close_File
      ! Close file
      IF ( PRESENT(Close_File) ) THEN
        IF ( Close_File ) THEN
          CLOSE( FileId,IOSTAT=Error_Status )
          IF ( Error_Status /= 0 ) &
            msg = TRIM(msg)//'; Error closing input file during error cleanup'
        END IF
      END IF
      ! Set error status and print error message
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME,TRIM(msg),Error_Status,Message_Log=Message_Log )
    END SUBROUTINE ReadHdr_CleanUp

  END FUNCTION Read_SRF_ASCII_Header

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Write_SRF_ASCII_Header
!
! PURPOSE:
!       Function to write the header information to an ASCII "HMW" format
!       SRF data file.
!
! CALLING SEQUENCE:
!       Error_Status = Write_SRF_ASCII_Header( Filename               , &  ! Input
!                                              FileID                 , &  ! In/Output
!                                              n_Channels             , &  ! Input
!                                              Channel_List           , &  ! Input
!                                              Title                  , &  ! Input
!                                              History                , &  ! Input
!                                              Sensor_Id              , &  ! Input
!                                              Comment                , &  ! Input
!                                              Message_Log=Message_Log  )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Filename:         Character string specifying the name of the
!                         ASCII format SRF data file to read.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       FileID:           ASCII file ID number. If file is not already opened,
!                         it is opened and this argument contains the unit
!                         number for the opened file upon output.
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN OUT)
!
!       n_Channels:       The number of channels of data to be written to
!                         the ASCII SRF file
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       Channel_List:     The list of channel numbers to be written to
!                         the ASCII SRF file.
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Rank-1, n_Channels or greater
!                         ATTRIBUTES: INTENT(IN)
!
!       Title:            Character string written into the TITLE
!                         attribute field of the ASCII SRF file.
!                         Should contain a succinct one-line description
!                         of what is in the datafile.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       History:          Character string written into the HISTORY
!                         attribute field of the ASCII SRF file.
!                         Should contain a succinct one-line description
!                         of the datafile history.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       Sensor_Id:        Character string written into the SENSOR_ID
!                         global attribute field of the ASCII SRF
!                         file.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       Comment:          Character string written into the COMMENT global
!                         attribute field of the ASCII SRF file.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:      Character string specifying a filename in which
!                         any msgs will be logged. If not specified,
!                         or if an error occurs opening the log file, the
!                         default action is to output msgs to standard
!                         output.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:     The return value is an integer defining the error
!                         status. The error codes are defined in the
!                         Message_Handler module.
!                         If == SUCCESS the header write was successful
!                            == FAILURE an error occurred
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!
! SIDE EFFECTS:
!       If an error occurs, the ASCII file is closed.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 27-Aug-2003
!                       paul.vandelst@ssec.wisc.edu
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Write_SRF_ASCII_Header( Filename    , &  ! Input
                                   FileID      , &  ! In/Output
                                   n_Channels  , &  ! Input
                                   Channel_List, &  ! Input
                                   Title       , &  ! Input
                                   History     , &  ! Input
                                   Sensor_Id   , &  ! Input
                                   Comment     , &  ! Input
                                   Message_Log ) &  ! Error messaging
                                 RESULT( Error_Status )
    ! Arguments
    CHARACTER(*),           INTENT(IN)     :: Filename
    INTEGER,                INTENT(IN OUT) :: FileID
    INTEGER,                INTENT(IN)     :: n_Channels
    INTEGER,                INTENT(IN)     :: Channel_List(:)
    CHARACTER(*),           INTENT(IN)     :: Title
    CHARACTER(*),           INTENT(IN)     :: History
    CHARACTER(*),           INTENT(IN)     :: Sensor_Id
    CHARACTER(*),           INTENT(IN)     :: Comment
    CHARACTER(*), OPTIONAL, INTENT(IN)     :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Write_SRF_ASCII_Header'
    ! Local variables
    CHARACTER(ML) :: msg
    CHARACTER(80) :: Action
    INTEGER :: IO_Status
    INTEGER :: l

    ! Setup
    ! -----
    Error_Status = SUCCESS

    ! Open the file if required
    !--------------------------
    IF ( .NOT. File_Open( TRIM(Filename) ) ) THEN

      ! Get a file unit number
      FileID = Get_Lun()
      IF ( FileID < 0 ) THEN
        msg = 'Error obtianing file unit number'
        CALL WriteHdr_Cleanup(); RETURN
      END IF

      ! Open the file
      OPEN( FileID, FILE   = TRIM(Filename), &
                    STATUS = 'REPLACE', &
                    FORM   = 'FORMATTED', &
                    ACCESS = 'SEQUENTIAL', &
                    ACTION = 'WRITE', &
                    IOSTAT = IO_Status )
      IF ( IO_Status /= 0 ) THEN
        WRITE( msg,'("Error opening ASCII SRF file ",a,". IOSTAT = ",i0)' ) &
                   TRIM(Filename), IO_Status
        CALL WriteHdr_Cleanup(); RETURN
      END IF

    ELSE

      ! File is already open, so rewind it
      REWIND( FileID )

      ! Check that the file can be written to
      INQUIRE( UNIT=FileID,ACTION=Action )
      IF ( INDEX(Action,'WRITE') == 0 ) THEN
        msg = 'ASCII SRF file '//TRIM(Filename)//' is not opened for writing.'
        CALL WriteHdr_Cleanup(Close_File=.TRUE.); RETURN
      END IF

    END IF

    ! Check the size of the channel list argument
    ! -------------------------------------------
    IF ( SIZE(Channel_List) < n_Channels ) THEN
      WRITE( msg,'("CHANNEL_LIST argument smaller than N_CHANNELS dimension: ",i0)' ) n_Channels
      CALL WriteHdr_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! Write the channel dimension
    ! ---------------------------
    WRITE( FileID,FMT=CH_HDR_FMT,IOSTAT=IO_Status ) n_Channels
    IF ( IO_Status /= 0 ) THEN
      WRITE( msg,'("Error writing channel dimension to ",a,". IOSTAT = ",i0)' ) &
                 TRIM(Filename), IO_Status
      CALL WriteHdr_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! Write the channel list
    ! ----------------------
    DO l = 1, n_Channels
      WRITE( FileID,FMT=CH_HDR_FMT,IOSTAT=IO_Status ) Channel_List(l)
      IF ( IO_Status /= 0 ) THEN
        WRITE( msg,'("Error writing channel index ",i0," to ",a,". IOSTAT = ",i0)' ) &
                   l, TRIM(Filename), IO_Status
        CALL WriteHdr_Cleanup(Close_File=.TRUE.); RETURN
      END IF
    END DO

    ! Write the data attributes
    !--------------------------
    ! The Title
    WRITE( FileID,FMT='("Title:",a)',IOSTAT=IO_Status) TRIM(Title)
    IF ( IO_Status /= 0 ) THEN
      WRITE( msg,'("Error writing Title attribute to ",a,". IOSTAT = ",i0 )' ) &
                 TRIM(Filename), IO_Status
      CALL WriteHdr_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! The History
    WRITE( FileID,FMT='("History:",a)',IOSTAT=IO_Status) TRIM(History)
    IF ( IO_Status /= 0 ) THEN
      WRITE( msg,'("Error writing History attribute to ",a,". IOSTAT = ",i0 )' ) &
                 TRIM(Filename), IO_Status
      CALL WriteHdr_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! The Sensor_Id
    WRITE( FileID,FMT='("Sensor_Id:",a)',IOSTAT=IO_Status) TRIM(Sensor_Id)
    IF ( IO_Status /= 0 ) THEN
      WRITE( msg,'("Error writing Sensor_Id attribute to ",a,". IOSTAT = ",i0 )' ) &
                 TRIM(Filename), IO_Status
      CALL WriteHdr_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! The Comment
    WRITE( FileID,FMT='("Comment:",a)',IOSTAT=IO_Status) TRIM(Comment)
    IF ( IO_Status /= 0 ) THEN
      WRITE( msg,'("Error writing Comment attribute to ",a,". IOSTAT = ",i0 )' ) &
                 TRIM(Filename), IO_Status
      CALL WriteHdr_Cleanup(Close_File=.TRUE.); RETURN
    END IF

  CONTAINS

    SUBROUTINE WriteHdr_CleanUp(Close_File)
      LOGICAL, OPTIONAL, INTENT(IN) :: Close_File
      ! Close file
      IF ( PRESENT(Close_File) ) THEN
        IF ( Close_File ) THEN
          CLOSE( FileId,IOSTAT=Error_Status )
          IF ( Error_Status /= 0 ) &
            msg = TRIM(msg)//'; Error closing input file during error cleanup'
        END IF
      END IF
      ! Set error status and print error message
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME,TRIM(msg),Error_Status,Message_Log=Message_Log )
    END SUBROUTINE WriteHdr_CleanUp

  END FUNCTION Write_SRF_ASCII_Header

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Read_SRF_ASCII
!
! PURPOSE:
!       Function to read a channel SRF from an ASCII "HMW" format SRF file.
!
! CALLING SEQUENCE:
!       Error_Status = Read_SRF_ASCII( Filename               , &  ! Input
!                                      FileID                 , &  ! Input
!                                      Channel                , &  ! Input
!                                      SRF                    , &  ! Output
!                                      Quiet      =Quiet      , &  ! Optional Input
!                                      RCS_Id     =RCS_Id     , &  ! Revision control
!                                      Message_Log=Message_Log  )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Filename:         Character string specifying the name of the
!                         ASCII format SRF data file to inquire.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       FileID:           ASCII file ID number.
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       Channel:          Channel number for which the SRF response and frequency
!                         are required.
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       SRF:              Data structure containing the requested channel SRF data.
!                         UNITS:      N/A
!                         TYPE:       TYPE(SRF_type)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUT ARGUMENTS:
!       Quiet:            Use this argument to suppress information msgs being
!                         printed to standard output (or the msg log file if
!                         the Message_Log optional argument is used.) By default,
!                         information msgs are printed.
!                         If QUIET = 0, information msgs are OUTPUT (default)
!                            QUIET = 1, information msgs are *SUPPRESSED*.
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN), OPTIONAL
!       Message_Log:      Character string specifying a filename in which any
!                         msgs will be logged. If not specified, or if an
!                         error occurs opening the log file, the default action
!                         is to output msgs to standard output.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN), OPTIONAL
!
! OPTIONAL OUTPUT ARGUMENTS:
!       RCS_Id:           Character string containing the Revision Control
!                         System Id field for the module.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:     The return value is an integer defining the error
!                         status. The error codes are defined in the
!                         Message_Handler module.
!                         If == SUCCESS the file read was successful
!                            == FAILURE an error occurred reading the file
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!
! SIDE EFFECTS:
!       File is closed if an error occurs.
!
! RESTRICTIONS:
!       The SRF header must be read before this function can be called.
!
! COMMENTS:
!       Note the INTENT on the output SRF argument is IN OUT rather
!       than just OUT. This is necessary because the argument may be defined on
!       input. To prevent memory leaks, the IN OUT INTENT is a must.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 27-Aug-2003
!                       paul.vandelst@ssec.wisc.edu
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Read_SRF_ASCII( Filename    , &  ! Input
                           FileID      , &  ! Input
                           Channel     , &  ! Input
                           SRF         , &  ! Output
                           Quiet       , &  ! Optional input
                           RCS_Id      , &  ! Revision control
                           Message_Log ) &  ! Error messaging
                         RESULT( Error_Status )
    ! Arguments
    CHARACTER(*),           INTENT(IN)     :: Filename
    INTEGER,                INTENT(IN)     :: FileID
    INTEGER,                INTENT(IN)     :: Channel
    TYPE(SRF_type),         INTENT(IN OUT) :: SRF
    INTEGER,      OPTIONAL, INTENT(IN)     :: Quiet
    CHARACTER(*), OPTIONAL, INTENT(OUT)    :: RCS_Id
    CHARACTER(*), OPTIONAL, INTENT(IN)     :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Read_SRF_ASCII'
    ! Function variables
    CHARACTER(ML) :: msg
    LOGICAL :: Noisy
    INTEGER :: IO_Status(4)
    INTEGER :: ch
    INTEGER :: n_Points, n_Bands, i
    REAL(fp) :: rdummy
    INTEGER  :: idummy

    ! Set up
    ! ------
    Error_Status = SUCCESS
    IF ( PRESENT(RCS_Id) ) RCS_Id = MODULE_RCS_ID

    ! Is the file open?
    IF ( .NOT. File_Open( FileID ) ) THEN
      msg = 'ASCII SRF file '//TRIM(Filename)//' is not open.'
      CALL Read_Cleanup(); RETURN
    END IF

    ! Output information messages...
    Noisy = .TRUE.
    ! ...unless the QUIET keyword is set
    IF ( PRESENT(Quiet) ) THEN
      IF ( Quiet == SET ) Noisy = .FALSE.
    END IF

    ! Begin loop to skip over unwanted channels
    !------------------------------------------
    Channel_Skip_Loop: DO

      ! Read the current channel SRF header
      ! -----------------------------------
      READ( FileID,FMT=SRF_HDR_FMT,IOSTAT=IO_Status(1) ) ch, n_Points, n_Bands

      ! End of file? EOF is most likely to occur
      ! here if there is a channel number mixup
      IF ( IO_Status(1) < 0 ) THEN
        WRITE( msg,'("End of file reached reading SRF header from ",a,". IOSTAT = ",i0)' ) &
                   TRIM(Filename), IO_Status(1)
        CALL Read_Cleanup(Close_File=.TRUE.); RETURN
      END IF
      ! Error?
      IF ( IO_Status(1) > 0 ) THEN
        Error_Status = FAILURE
        WRITE( msg,'("Error reading SRF header from ",a,". IOSTAT = ",i0)' ) &
                   TRIM(Filename), IO_Status(1)
        CALL Read_Cleanup(Close_File=.TRUE.); RETURN
      END IF

      ! Exit loop if this is the required channel...
      ! --------------------------------------------
      IF ( ch == Channel ) EXIT Channel_Skip_Loop

      ! Otherwise, skip over the current channel's data
      ! -----------------------------------------------
      READ( FileID,FMT=FREQUENCY_FMT,IOSTAT=IO_Status(1) ) ( rdummy,i=1,n_Bands )
      READ( FileID,FMT=FREQUENCY_FMT,IOSTAT=IO_Status(2) ) ( rdummy,i=1,n_Bands )
      READ( FileID,FMT=BANDS_FMT    ,IOSTAT=IO_Status(3) ) ( idummy,i=1,n_Bands )
      READ( FileID,FMT=RESPONSE_FMT ,IOSTAT=IO_Status(4) ) ( rdummy,i=1,n_Points )
      IF ( ANY(IO_Status /= 0) ) THEN
        WRITE( msg,'("Error skipping over channel ",i0," SRF data in ",a,". IOSTAT = ",4(1x,i0))' ) &
                   ch, TRIM(Filename), IO_Status
        CALL Read_Cleanup(Close_File=.TRUE.); RETURN
      END IF

    END DO Channel_Skip_Loop

    ! Allocate the SRF data structure arrays
    ! --------------------------------------
    Error_Status = Allocate_SRF( n_Points,SRF,n_Bands=n_Bands,Message_Log=Message_Log )
    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( msg,'("Error allocating SRF structure for channel #",i0)' ) Channel
      CALL Read_Cleanup(Close_File=.TRUE.); RETURN
    END IF
    ! Set the channel number
    SRF%Channel = Channel

    ! Read the required instrument response data
    ! ------------------------------------------
    READ( FileID,FMT=FREQUENCY_FMT,IOSTAT=IO_Status(1) ) SRF%f1_Band
    READ( FileID,FMT=FREQUENCY_FMT,IOSTAT=IO_Status(2) ) SRF%f2_Band
    READ( FileID,FMT=BANDS_FMT    ,IOSTAT=IO_Status(3) ) SRF%npts_Band
    READ( FileID,FMT=RESPONSE_FMT ,IOSTAT=IO_Status(4) ) SRF%Response
    IF ( ANY(IO_Status /= 0) ) THEN
      WRITE( msg,'("Error reading channel ",i0," SRF data from ",a,". IOSTAT = ",4(1x,i0))' ) &
                 SRF%Channel, TRIM(Filename), IO_Status
      CALL Read_Cleanup(Close_File=.TRUE.,Destroy_Structure=.TRUE.); RETURN
    END IF

    ! Compute the SRF frequency grid
    !-------------------------------
    Error_Status = Frequency_SRF( SRF,Message_Log=Message_Log )
    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( msg,'("Error computing frequency grid for channel ",i0," SRF from ",a)' ) &
                 Channel, TRIM(Filename)
      CALL Read_Cleanup(Close_File=.TRUE.,Destroy_Structure=.TRUE.); RETURN
    END IF

    ! Compute the integrated SRF values
    ! ---------------------------------
    Error_Status = Integrate_SRF( SRF,Message_Log=Message_Log )

    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( msg,'("Error integrating channel ",i0," SRF from ",a)' ) &
                 Channel, TRIM(Filename)
      CALL Read_Cleanup(Close_File=.TRUE.,Destroy_Structure=.TRUE.); RETURN
    END IF

    ! Output an info message
    ! ----------------------
    IF ( Noisy ) THEN
      CALL Info_SRF( SRF, msg )
      CALL Display_Message( ROUTINE_NAME, &
                            'FILE: '//TRIM(Filename)//'; '//TRIM(msg), &
                            INFORMATION, &
                            Message_Log=Message_Log )
    END IF

  CONTAINS

    SUBROUTINE Read_CleanUp( Close_File, Destroy_Structure )
      LOGICAL, OPTIONAL, INTENT(IN) :: Close_File
      LOGICAL, OPTIONAL, INTENT(IN) :: Destroy_Structure
      ! Close file
      IF ( PRESENT(Close_File) ) THEN
        IF ( Close_File ) THEN
          CLOSE( FileId,IOSTAT=Error_Status )
          IF ( Error_Status /= 0 ) &
            msg = TRIM(msg)//'; Error closing input file during error cleanup'
        END IF
      END IF
      ! Destroy the structure if necessary
      IF ( PRESENT(Destroy_Structure) ) THEN
        IF ( Destroy_Structure ) THEN
          Error_Status = Destroy_SRF(SRF, Message_Log=Message_Log)
          IF ( Error_Status /= SUCCESS ) &
            msg = TRIM(msg)//'; Error destroying SRF structure during error cleanup.'
        END IF
      END IF
      ! Set error status and print error message
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            TRIM(msg), &
                            Error_Status, &
                            Message_Log=Message_Log )
    END SUBROUTINE Read_CleanUp

  END FUNCTION Read_SRF_ASCII

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Write_SRF_ASCII
!
! PURPOSE:
!       Function to write a channel SRF to an ASCII format SRF file.
!
! CALLING SEQUENCE:
!       Error_Status = Write_SRF_ASCII( Filename               , &  ! Input
!                                       FileID                 , &  ! Input
!                                       SRF                    , &  ! Output
!                                       Quiet      =Quiet      , &  ! Optional Input
!                                       RCS_Id     =RCS_Id     , &  ! Revision control
!                                       Message_Log=Message_Log  )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Filename:         Character string specifying the name of the
!                         ASCII format SRF data file to inquire.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       FileID:           ASCII file ID number.
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       SRF:              Data structure containing the requested channel SRF data.
!                         UNITS:      N/A
!                         TYPE:       TYPE(SRF_type)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:      Character string specifying a filename in which any
!                         msgs will be logged. If not specified, or if an
!                         error occurs opening the log file, the default action
!                         is to output msgs to standard output.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN), OPTIONAL
!
! OPTIONAL OUTPUT ARGUMENTS:
!       RCS_Id:           Character string containing the Revision Control
!                         System Id field for the module.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(OUT), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:     The return value is an integer defining the error
!                         status. The error codes are defined in the
!                         Message_Handler module.
!                         If == SUCCESS the file write was successful
!                            == FAILURE an error occurred writing to file
!                         UNITS:      N/A
!                         TYPE:       INTEGER
!                         DIMENSION:  Scalar
!
! SIDE EFFECTS:
!       Output file is closed if an I/O error occurs.
!
! RESTRICTIONS:
!       The SRF header must be written before this function can be called.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 27-Aug-2003
!                       paul.vandelst@ssec.wisc.edu
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Write_SRF_ASCII( Filename    , &  ! Input
                            FileID      , &  ! Input
                            SRF         , &  ! Input
                            Quiet       , &  ! Optional input
                            RCS_Id      , &  ! Revision control
                            Message_Log ) &  ! Error messaging
                          RESULT( Error_Status )
    ! Arguments
    CHARACTER(*),           INTENT(IN)  :: Filename
    INTEGER,                INTENT(IN)  :: FileID
    TYPE(SRF_type),         INTENT(IN)  :: SRF
    INTEGER,      OPTIONAL, INTENT(IN)  :: Quiet
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Function parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Write_SRF_ASCII'
    ! Function variables
    CHARACTER(ML) :: msg
    LOGICAL :: Noisy
    INTEGER :: IO_Status(4)

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

    ! Check structure pointer association status
    ! ALL structure pointers must be associated
    IF ( .NOT. Associated_SRF( SRF ) ) THEN
      msg = 'Some or all INPUT SRF pointer members are NOT associated.'
      CALL Write_Cleanup(); RETURN
    END IF

    ! Check SRF channel is valid
    IF ( SRF%Channel < 1 ) THEN
      WRITE( msg,'("Invalid SRF channel, ",i0,". Must be > 0.")' ) SRF%Channel
      CALL Write_CleanUp(); RETURN
    END IF

    ! Check SRF array sizes
    IF ( SRF%n_Points < 1 ) THEN
      WRITE( msg,'("Invalid no. of SRF points, ",i0,". Must be > 0.")' ) SRF%n_Points
      CALL Write_CleanUp(); RETURN
    END IF
    IF ( SRF%n_Bands < 1 ) THEN
      WRITE( msg,'("Invalid no. of SRF bands, ",i0,". Must be > 0.")' ) SRF%n_Bands
      CALL Write_CleanUp(); RETURN
    END IF

    ! Is the file open?
    IF ( .NOT. File_Open( FileID ) ) THEN
      msg = 'ASCII SRF file '//TRIM(Filename)//' is not open.'
      CALL Write_Cleanup(); RETURN
    END IF

    ! Output information messages...
    Noisy = .TRUE.
    ! ...unless the QUIET keyword is set
    IF ( PRESENT(Quiet) ) THEN
      IF ( Quiet == SET ) Noisy = .FALSE.
    END IF

    ! Write the current channel SRF header
    ! ------------------------------------
    WRITE( FileID,FMT=SRF_HDR_FMT,IOSTAT=IO_Status(1) ) SRF%Channel,SRF%n_Points,SRF%n_Bands
    IF ( IO_Status(1) /= 0 ) THEN
      WRITE( msg,'("Error writing channel ",i0," SRF header to ",a,". IOSTAT = ",i0)' ) &
                 SRF%Channel, TRIM(Filename), IO_Status(1)
      CALL Write_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! Write the SRF data
    ! ------------------
    WRITE( FileID,FMT=FREQUENCY_FMT,IOSTAT=IO_Status(1) ) SRF%f1_Band
    WRITE( FileID,FMT=FREQUENCY_FMT,IOSTAT=IO_Status(2) ) SRF%f2_Band
    WRITE( FileID,FMT=BANDS_FMT    ,IOSTAT=IO_Status(3) ) SRF%npts_Band
    WRITE( FileID,FMT=RESPONSE_FMT ,IOSTAT=IO_Status(4) ) SRF%Response
    IF ( ANY(IO_Status /= 0) ) THEN
      WRITE( msg,'("Error writing channel ",i0," SRF data to ",a,". IOSTAT = ",4(1x,i0))' ) &
                 SRF%Channel, TRIM(Filename), IO_Status
      CALL Write_Cleanup(Close_File=.TRUE.); RETURN
    END IF

    ! Output an info message
    ! ----------------------
    IF ( Noisy ) THEN
      CALL Info_SRF( SRF, msg )
      CALL Display_Message( ROUTINE_NAME, &
                            'FILE: '//TRIM(Filename)//'; '//TRIM(msg), &
                            INFORMATION, &
                            Message_Log=Message_Log )
    END IF

  CONTAINS

    SUBROUTINE Write_CleanUp( Close_File )
      LOGICAL, OPTIONAL, INTENT(IN) :: Close_File
      ! Close file
      IF ( PRESENT(Close_File) ) THEN
        IF ( Close_File ) THEN
          CLOSE( FileId,IOSTAT=Error_Status )
          IF ( Error_Status /= 0 ) &
            msg = TRIM(msg)//'; Error closing output file during error cleanup'
        END IF
      END IF
      ! Set error status and print error message
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            TRIM(msg), &
                            Error_Status, &
                            Message_Log=Message_Log )
    END SUBROUTINE Write_CleanUp

  END FUNCTION Write_SRF_ASCII

END MODULE SRF_ASCII_IO