! ==============================================================================
! Subroutine: TINT12 (LIST,EB)
!
! Purpose: Performs a table lookup for the internal energy for an asymmetric
!          mismatch pair between two basepairs in a helix.
!
! Method: Uses the MFOLD 3.0 energy function table for RNA @ T=37.
!
! Arguments:
!
!          LIST - Array of length 4 containing the nucleotides in
!                 numerical code (A=1,C=2,G=3,U=4) for the
!                 following locations:
!
!                         (3)
!                 5' (1) A .    X (6) 3'
!                 3' (2) U .  . Y (7) 5'
!                         (4)(5)
!
!                 where LIST(1) = letter code for position 1 etc.
!
!            EB - (OUTPUT) MFOLD 3.0 internal loop energy of the sequence
!                 provided in LIST.
!
! History:
!
! Version    Date         Comment
! --------   ----------   -----------------------
!            01/01/2015   Original Code
!
! Dependencies:
!
! Modules -
! Functions -
! Subroutines -
!
! Author(s): Eric Dykeman
!            Copyright (c) 2015 (Please Refer to LICENCE)
!
! ==============================================================================

      SUBROUTINE TINT12 (LIST,EB)

        IMPLICIT NONE

        !=== ARGUMENTS ===!

        INTEGER, INTENT(IN) :: list(7)
        REAL, INTENT(INOUT) :: eb

        !=== VARIABLES ===!

        INTEGER :: i,j,k,i1,i2,i3,i4,i5,i6,i7
        REAL :: au(16,24),cg(16,24),gc(16,24)
        REAL :: ua(16,24),gu(16,24),ug(16,24)

        DATA (au(1,i),i=1,24) / 3.90, 3.70, 3.10, 5.50, 3.20, 3.00, &
            & 2.40, 4.80, 3.20, 3.00, 2.40, 4.80, 3.90, 3.70, 3.10, &
            & 5.50, 3.90, 3.70, 3.10, 5.50, 3.90, 3.70, 3.10, 5.50 /
        DATA (au(2,i),i=1,24) / 3.80, 3.70, 5.50, 3.70, 3.10, 3.00, &
            & 4.80, 3.00, 3.10, 3.00, 4.80, 3.00, 3.80, 3.70, 5.50, &
            & 3.70, 3.80, 3.70, 5.50, 3.70, 3.80, 3.70, 5.50, 3.70 /
        DATA (au(3,i),i=1,24) / 3.20, 5.50, 2.30, 5.50, 2.50, 4.80, &
            & 1.60, 4.80, 2.50, 4.80, 1.60, 4.80, 3.20, 5.50, 2.30, &
            & 5.50, 3.20, 5.50, 2.30, 5.50, 3.20, 5.50, 2.30, 5.50 /
        DATA (au(4,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
            & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (au(5,i),i=1,24) / 3.60, 3.20, 3.10, 5.50, 2.90, 2.50, &
            & 2.40, 4.80, 2.90, 2.50, 2.40, 4.80, 3.60, 3.20, 3.10, &
            & 5.50, 3.60, 3.20, 3.10, 5.50, 3.60, 3.20, 3.10, 5.50 /
        DATA (au(6,i),i=1,24) / 3.70, 4.00, 5.50, 3.70, 3.00, 3.30, &
            & 4.80, 3.00, 3.00, 3.30, 4.80, 3.00, 3.70, 4.00, 5.50, &
            & 3.70, 3.70, 4.00, 5.50, 3.70, 3.70, 4.00, 5.50, 3.70 /
        DATA (au(7,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
            & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (au(8,i),i=1,24) / 5.50, 3.70, 5.50, 2.80, 4.80, 3.00, &
            & 4.80, 2.10, 4.80, 3.00, 4.80, 2.10, 5.50, 3.70, 5.50, &
            & 2.80, 5.50, 3.70, 5.50, 2.80, 5.50, 3.70, 5.50, 2.80 /
        DATA (au(9,i),i=1,24) / 2.50, 2.10, 1.90, 5.50, 1.80, 1.40, &
            & 1.20, 4.80, 1.80, 1.40, 1.20, 4.80, 2.50, 2.10, 1.90, &
            & 5.50, 2.50, 2.10, 1.90, 5.50, 2.50, 2.10, 1.90, 5.50 /
        DATA (au(10,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (au(11,i),i=1,24) / 2.30, 5.50, 3.70, 5.50, 1.60, 4.80, &
             & 3.00, 4.80, 1.60, 4.80, 3.00, 4.80, 2.30, 5.50, 3.70, &
             & 5.50, 2.30, 5.50, 3.70, 5.50, 2.30, 5.50, 3.70, 5.50 /
        DATA (au(12,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (au(13,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (au(14,i),i=1,24) / 4.00, 3.40, 5.50, 3.70, 3.30, 2.70, &
             & 4.80, 3.00, 3.30, 2.70, 4.80, 3.00, 4.00, 3.40, 5.50, &
             & 3.70, 4.00, 3.40, 5.50, 3.70, 4.00, 3.40, 5.50, 3.70 /
        DATA (au(15,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (au(16,i),i=1,24) / 5.50, 3.20, 5.50, 2.70, 4.80, 2.50, &
             & 4.80, 2.00, 4.80, 2.50, 4.80, 2.00, 5.50, 3.20, 5.50, &
             & 2.70, 5.50, 3.20, 5.50, 2.70, 5.50, 3.20, 5.50, 2.70 /

        DATA (cg(1,i),i=1,24) / 3.20, 3.00, 2.40, 4.80, 2.30, 2.20, &
            & 1.10, 4.00, 2.40, 2.20, 1.60, 4.00, 3.20, 3.00, 2.40, &
            & 4.80, 3.20, 3.00, 2.40, 4.80, 3.20, 3.00, 2.40, 4.80 /
        DATA (cg(2,i),i=1,24) / 3.10, 3.00, 4.80, 3.00, 2.30, 2.20, &
            & 4.00, 2.20, 2.30, 2.20, 4.00, 2.20, 3.10, 3.00, 4.80, &
            & 3.00, 3.10, 3.00, 4.80, 3.00, 3.10, 3.00, 4.80, 3.00 /
        DATA (cg(3,i),i=1,24) / 2.50, 4.80, 1.60, 4.80, 1.70, 4.00, &
            & 0.80, 4.00, 1.70, 4.00, 0.80, 4.00, 2.50, 4.80, 1.60, &
            & 4.80, 2.50, 4.80, 1.60, 4.80, 2.50, 4.80, 1.60, 4.80 /
        DATA (cg(4,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
            & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (cg(5,i),i=1,24) / 2.90, 2.50, 2.40, 4.80, 2.10, 1.70, &
            & 1.60, 4.00, 2.10, 1.70, 1.60, 4.00, 2.90, 2.50, 2.40, &
            & 4.80, 2.90, 2.50, 2.40, 4.80, 2.90, 2.50, 2.40, 4.80 /
        DATA (cg(6,i),i=1,24) / 3.00, 3.30, 4.80, 3.00, 2.20, 2.50, &
            & 4.00, 2.20, 2.20, 2.50, 4.00, 2.20, 3.00, 3.30, 4.80, &
            & 3.00, 3.00, 3.30, 4.80, 3.00, 3.00, 3.30, 4.80, 3.00 /
        DATA (cg(7,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
            & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (cg(8,i),i=1,24) / 4.80, 3.00, 4.80, 2.10, 4.00, 2.20, &
            & 4.00, 1.50, 4.00, 2.20, 4.00, 1.30, 4.80, 3.00, 4.80, &
            & 2.10, 4.80, 3.00, 4.80, 2.10, 4.80, 3.00, 4.80, 2.10 /
        DATA (cg(9,i),i=1,24) / 1.80, 1.40, 1.20, 4.80, 0.80, 0.60, &
            & 0.40, 4.00, 1.00, 0.60, 0.40, 4.00, 1.80, 1.40, 1.20, &
            & 4.80, 1.80, 1.40, 1.20, 4.80, 1.80, 1.40, 1.20, 4.80 /
        DATA (cg(10,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
             & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (cg(11,i),i=1,24) / 1.60, 4.80, 3.00, 4.80, 0.80, 4.00, &
             & 2.20, 4.00, 0.80, 4.00, 2.20, 4.00, 1.60, 4.80, 3.00, &
             & 4.80, 1.60, 4.80, 3.00, 4.80, 1.60, 4.80, 3.00, 4.80 /
        DATA (cg(12,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
             & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (cg(13,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
             & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (cg(14,i),i=1,24) / 3.30, 2.70, 4.80, 3.00, 2.50, 1.90, &
             & 4.00, 2.20, 2.50, 1.90, 4.00, 2.20, 3.30, 2.70, 4.80, &
             & 3.00, 3.30, 2.70, 4.80, 3.00, 3.30, 2.70, 4.80, 3.00 /
        DATA (cg(15,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
             & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (cg(16,i),i=1,24) / 4.80, 2.50, 4.80, 2.00, 4.00, 1.70, &
             & 4.00, 1.20, 4.00, 1.70, 4.00, 1.20, 4.80, 2.50, 4.80, &
             & 2.00, 4.80, 2.50, 4.80, 2.00, 4.80, 2.50, 4.80, 2.00 /

        DATA (gc(1,i),i=1,24) / 3.20, 3.00, 2.40, 4.80, 2.40, 2.20, &
            & 1.60, 4.00, 2.50, 2.20, 2.10, 4.00, 3.20, 3.00, 2.40, &
            & 4.80, 3.20, 3.00, 2.40, 4.80, 3.20, 3.00, 2.40, 4.80 /
        DATA (gc(2,i),i=1,24) / 3.10, 3.00, 4.80, 3.00, 2.30, 2.20, &
            & 4.00, 2.20, 2.30, 2.20, 4.00, 2.20, 3.10, 3.00, 4.80, &
            & 3.00, 3.10, 3.00, 4.80, 3.00, 3.10, 3.00, 4.80, 3.00 /
        DATA (gc(3,i),i=1,24) / 2.50, 4.80, 1.60, 4.80, 1.70, 4.00, &
            & 0.80, 4.00, 1.70, 4.00, 0.80, 4.00, 2.50, 4.80, 1.60, &
            & 4.80, 2.50, 4.80, 1.60, 4.80, 2.50, 4.80, 1.60, 4.80 /
        DATA (gc(4,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
            & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (gc(5,i),i=1,24) / 2.90, 2.50, 2.40, 4.80, 2.10, 1.70, &
            & 1.60, 4.00, 2.10, 1.70, 1.60, 4.00, 2.90, 2.50, 2.40, &
            & 4.80, 2.90, 2.50, 2.40, 4.80, 2.90, 2.50, 2.40, 4.80 /
        DATA (gc(6,i),i=1,24) / 3.00, 3.30, 4.80, 3.00, 2.20, 2.50, &
            & 4.00, 2.20, 2.20, 2.50, 4.00, 2.20, 3.00, 3.30, 4.80, &
            & 3.00, 3.00, 3.30, 4.80, 3.00, 3.00, 3.30, 4.80, 3.00 /
        DATA (gc(7,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
            & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (gc(8,i),i=1,24) / 4.80, 3.00, 4.80, 2.10, 4.00, 2.20, &
            & 4.00, 1.30, 4.00, 2.20, 4.00, 1.20, 4.80, 3.00, 4.80, &
            & 2.10, 4.80, 3.00, 4.80, 2.10, 4.80, 3.00, 4.80, 2.10 /
        DATA (gc(9,i),i=1,24) / 1.80, 1.40, 1.20, 4.80, 1.00, 0.60, &
            & 0.40, 4.00, 1.20, 0.60, 0.40, 4.00, 1.80, 1.40, 1.20, &
            & 4.80, 1.80, 1.40, 1.20, 4.80, 1.80, 1.40, 1.20, 4.80 /
        DATA (gc(10,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
             & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (gc(11,i),i=1,24) / 1.60, 4.80, 3.00, 4.80, 0.80, 4.00, &
             & 2.20, 4.00, 0.80, 4.00, 2.20, 4.00, 1.60, 4.80, 3.00, &
             & 4.80, 1.60, 4.80, 3.00, 4.80, 1.60, 4.80, 3.00, 4.80 /
        DATA (gc(12,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
             & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (gc(13,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
             & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (gc(14,i),i=1,24) / 3.30, 2.70, 4.80, 3.00, 2.50, 1.90, &
             & 4.00, 2.20, 2.50, 1.90, 4.00, 2.20, 3.30, 2.70, 4.80, &
             & 3.00, 3.30, 2.70, 4.80, 3.00, 3.30, 2.70, 4.80, 3.00 /
        DATA (gc(15,i),i=1,24) / 4.80, 4.80, 4.80, 4.80, 4.00, 4.00, &
             & 4.00, 4.00, 4.00, 4.00, 4.00, 4.00, 4.80, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 4.80 /
        DATA (gc(16,i),i=1,24) / 4.80, 2.50, 4.80, 2.00, 4.00, 1.70, &
             & 4.00, 1.20, 4.00, 1.70, 4.00, 1.20, 4.80, 2.50, 4.80, &
             & 2.00, 4.80, 2.50, 4.80, 2.00, 4.80, 2.50, 4.80, 2.00 /

        DATA (ua(1,i),i=1,24) / 3.90, 3.70, 3.10, 5.50, 3.20, 3.00, &
            & 2.40, 4.80, 3.20, 3.00, 2.40, 4.80, 3.90, 3.70, 3.10, &
            & 5.50, 3.90, 3.70, 3.10, 5.50, 3.90, 3.70, 3.10, 5.50 /
        DATA (ua(2,i),i=1,24) / 3.80, 3.70, 5.50, 3.70, 3.10, 3.00, &
            & 4.80, 3.00, 3.10, 3.00, 4.80, 3.00, 3.80, 3.70, 5.50, &
            & 3.70, 3.80, 3.70, 5.50, 3.70, 3.80, 3.70, 5.50, 3.70 /
        DATA (ua(3,i),i=1,24) / 3.20, 5.50, 2.30, 5.50, 2.50, 4.80, &
            & 1.60, 4.80, 2.50, 4.80, 1.60, 4.80, 3.20, 5.50, 2.30, &
            & 5.50, 3.20, 5.50, 2.30, 5.50, 3.20, 5.50, 2.30, 5.50 /
        DATA (ua(4,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
            & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ua(5,i),i=1,24) / 3.60, 3.20, 3.10, 5.50, 2.90, 2.50, &
            & 2.40, 4.80, 2.90, 2.50, 2.40, 4.80, 3.60, 3.20, 3.10, &
            & 5.50, 3.60, 3.20, 3.10, 5.50, 3.60, 3.20, 3.10, 5.50 /
        DATA (ua(6,i),i=1,24) / 3.70, 4.00, 5.50, 3.70, 3.00, 3.30, &
            & 4.80, 3.00, 3.00, 3.30, 4.80, 3.00, 3.70, 4.00, 5.50, &
            & 3.70, 3.70, 4.00, 5.50, 3.70, 3.70, 4.00, 5.50, 3.70 /
        DATA (ua(7,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
            & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ua(8,i),i=1,24) / 5.50, 3.70, 5.50, 2.80, 4.80, 3.00, &
            & 4.80, 2.10, 4.80, 3.00, 4.80, 2.10, 5.50, 3.70, 5.50, &
            & 2.80, 5.50, 3.70, 5.50, 2.80, 5.50, 3.70, 5.50, 2.80 /
        DATA (ua(9,i),i=1,24) / 2.50, 2.10, 1.90, 5.50, 1.80, 1.40, &
            & 1.20, 4.80, 1.80, 1.40, 1.20, 4.80, 2.50, 2.10, 1.90, &
            & 5.50, 2.50, 2.10, 1.90, 5.50, 2.50, 2.10, 1.90, 5.50 /
        DATA (ua(10,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ua(11,i),i=1,24) / 2.30, 5.50, 3.70, 5.50, 1.60, 4.80, &
             & 3.00, 4.80, 1.60, 4.80, 3.00, 4.80, 2.30, 5.50, 3.70, &
             & 5.50, 2.30, 5.50, 3.70, 5.50, 2.30, 5.50, 3.70, 5.50 /
        DATA (ua(12,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ua(13,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ua(14,i),i=1,24) / 4.00, 3.40, 5.50, 3.70, 3.30, 2.70, &
             & 4.80, 3.00, 3.30, 2.70, 4.80, 3.00, 4.00, 3.40, 5.50, &
             & 3.70, 4.00, 3.40, 5.50, 3.70, 4.00, 3.40, 5.50, 3.70 /
        DATA (ua(15,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ua(16,i),i=1,24) / 5.50, 3.20, 5.50, 2.70, 4.80, 2.50, &
             & 4.80, 2.00, 4.80, 2.50, 4.80, 2.00, 5.50, 3.20, 5.50, &
             & 2.70, 5.50, 3.20, 5.50, 2.70, 5.50, 3.20, 5.50, 2.70 /

        DATA (gu(1,i),i=1,24) / 3.90, 3.70, 3.10, 5.50, 3.20, 3.00, &
            & 2.40, 4.80, 3.20, 3.00, 2.40, 4.80, 3.90, 3.70, 3.10, &
            & 5.50, 3.90, 3.70, 3.10, 5.50, 3.90, 3.70, 3.10, 5.50 /
        DATA (gu(2,i),i=1,24) / 3.80, 3.70, 5.50, 3.70, 3.10, 3.00, &
            & 4.80, 3.00, 3.10, 3.00, 4.80, 3.00, 3.80, 3.70, 5.50, &
            & 3.70, 3.80, 3.70, 5.50, 3.70, 3.80, 3.70, 5.50, 3.70 /
        DATA (gu(3,i),i=1,24) / 3.20, 5.50, 2.30, 5.50, 2.50, 4.80, &
            & 1.60, 4.80, 2.50, 4.80, 1.60, 4.80, 3.20, 5.50, 2.30, &
            & 5.50, 3.20, 5.50, 2.30, 5.50, 3.20, 5.50, 2.30, 5.50 /
        DATA (gu(4,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
            & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (gu(5,i),i=1,24) / 3.60, 3.20, 3.10, 5.50, 2.90, 2.50, &
            & 2.40, 4.80, 2.90, 2.50, 2.40, 4.80, 3.60, 3.20, 3.10, &
            & 5.50, 3.60, 3.20, 3.10, 5.50, 3.60, 3.20, 3.10, 5.50 /
        DATA (gu(6,i),i=1,24) / 3.70, 4.00, 5.50, 3.70, 3.00, 3.30, &
            & 4.80, 3.00, 3.00, 3.30, 4.80, 3.00, 3.70, 4.00, 5.50, &
            & 3.70, 3.70, 4.00, 5.50, 3.70, 3.70, 4.00, 5.50, 3.70 /
        DATA (gu(7,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
            & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (gu(8,i),i=1,24) / 5.50, 3.70, 5.50, 2.80, 4.80, 3.00, &
            & 4.80, 2.10, 4.80, 3.00, 4.80, 2.10, 5.50, 3.70, 5.50, &
            & 2.80, 5.50, 3.70, 5.50, 2.80, 5.50, 3.70, 5.50, 2.80 /
        DATA (gu(9,i),i=1,24) / 2.50, 2.10, 1.90, 5.50, 1.80, 1.40, &
            & 1.20, 4.80, 1.80, 1.40, 1.20, 4.80, 2.50, 2.10, 1.90, &
            & 5.50, 2.50, 2.10, 1.90, 5.50, 2.50, 2.10, 1.90, 5.50 /
        DATA (gu(10,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (gu(11,i),i=1,24) / 2.30, 5.50, 3.70, 5.50, 1.60, 4.80, &
             & 3.00, 4.80, 1.60, 4.80, 3.00, 4.80, 2.30, 5.50, 3.70, &
             & 5.50, 2.30, 5.50, 3.70, 5.50, 2.30, 5.50, 3.70, 5.50 /
        DATA (gu(12,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (gu(13,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (gu(14,i),i=1,24) / 4.00, 3.40, 5.50, 3.70, 3.30, 2.70, &
             & 4.80, 3.00, 3.30, 2.70, 4.80, 3.00, 4.00, 3.40, 5.50, &
             & 3.70, 4.00, 3.40, 5.50, 3.70, 4.00, 3.40, 5.50, 3.70 /
        DATA (gu(15,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (gu(16,i),i=1,24) / 5.50, 3.20, 5.50, 2.70, 4.80, 2.50, &
             & 4.80, 2.00, 4.80, 2.50, 4.80, 2.00, 5.50, 3.20, 5.50, &
             & 2.70, 5.50, 3.20, 5.50, 2.70, 5.50, 3.20, 5.50, 2.70 /

        DATA (ug(1,i),i=1,24) / 3.90, 3.70, 3.10, 5.50, 3.20, 3.00, &
            & 2.40, 4.80, 3.20, 3.00, 2.40, 4.80, 3.90, 3.70, 3.10, &
            & 5.50, 3.90, 3.70, 3.10, 5.50, 3.90, 3.70, 3.10, 5.50 /
        DATA (ug(2,i),i=1,24) / 3.80, 3.70, 5.50, 3.70, 3.10, 3.00, &
            & 4.80, 3.00, 3.10, 3.00, 4.80, 3.00, 3.80, 3.70, 5.50, &
            & 3.70, 3.80, 3.70, 5.50, 3.70, 3.80, 3.70, 5.50, 3.70 /
        DATA (ug(3,i),i=1,24) / 3.20, 5.50, 2.30, 5.50, 2.50, 4.80, &
            & 1.60, 4.80, 2.50, 4.80, 1.60, 4.80, 3.20, 5.50, 2.30, &
            & 5.50, 3.20, 5.50, 2.30, 5.50, 3.20, 5.50, 2.30, 5.50 /
        DATA (ug(4,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
            & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ug(5,i),i=1,24) / 3.60, 3.20, 3.10, 5.50, 2.90, 2.50, &
            & 2.40, 4.80, 2.90, 2.50, 2.40, 4.80, 3.60, 3.20, 3.10, &
            & 5.50, 3.60, 3.20, 3.10, 5.50, 3.60, 3.20, 3.10, 5.50 /
        DATA (ug(6,i),i=1,24) / 3.70, 4.00, 5.50, 3.70, 3.00, 3.30, &
            & 4.80, 3.00, 3.00, 3.30, 4.80, 3.00, 3.70, 4.00, 5.50, &
            & 3.70, 3.70, 4.00, 5.50, 3.70, 3.70, 4.00, 5.50, 3.70 /
        DATA (ug(7,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
            & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
            & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ug(8,i),i=1,24) / 5.50, 3.70, 5.50, 2.80, 4.80, 3.00, &
            & 4.80, 2.10, 4.80, 3.00, 4.80, 2.10, 5.50, 3.70, 5.50, &
            & 2.80, 5.50, 3.70, 5.50, 2.80, 5.50, 3.70, 5.50, 2.80 /
        DATA (ug(9,i),i=1,24) / 2.50, 2.10, 1.90, 5.50, 1.80, 1.40, &
            & 1.20, 4.80, 1.80, 1.40, 1.20, 4.80, 2.50, 2.10, 1.90, &
            & 5.50, 2.50, 2.10, 1.90, 5.50, 2.50, 2.10, 1.90, 5.50 /
        DATA (ug(10,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ug(11,i),i=1,24) / 2.30, 5.50, 3.70, 5.50, 1.60, 4.80, &
             & 3.00, 4.80, 1.60, 4.80, 3.00, 4.80, 2.30, 5.50, 3.70, &
             & 5.50, 2.30, 5.50, 3.70, 5.50, 2.30, 5.50, 3.70, 5.50 /
        DATA (ug(12,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ug(13,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ug(14,i),i=1,24) / 4.00, 3.40, 5.50, 3.70, 3.30, 2.70, &
             & 4.80, 3.00, 3.30, 2.70, 4.80, 3.00, 4.00, 3.40, 5.50, &
             & 3.70, 4.00, 3.40, 5.50, 3.70, 4.00, 3.40, 5.50, 3.70 /
        DATA (ug(15,i),i=1,24) / 5.50, 5.50, 5.50, 5.50, 4.80, 4.80, &
             & 4.80, 4.80, 4.80, 4.80, 4.80, 4.80, 5.50, 5.50, 5.50, &
             & 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50, 5.50 /
        DATA (ug(16,i),i=1,24) / 5.50, 3.20, 5.50, 2.70, 4.80, 2.50, &
             & 4.80, 2.00, 4.80, 2.50, 4.80, 2.00, 5.50, 3.20, 5.50, &
             & 2.70, 5.50, 3.20, 5.50, 2.70, 5.50, 3.20, 5.50, 2.70 /

        !         (3)            !
        ! 5' (1) A .    X (6) 3' !
        ! 3' (2) U .  . Y (7) 5' !
        !         (4)(5)         !

        i1 = list(1)
        i2 = list(2)
        i3 = list(3)
        i4 = list(4)
        i5 = list(5)
        i6 = list(6)
        i7 = list(7)

        IF ( i5 == 1 ) j = 0 + i3
        IF ( i5 == 2 ) j = 4 + i3
        IF ( i5 == 3 ) j = 8 + i3
        IF ( i5 == 4 ) j =12 + i3

        IF ( i6 == 1 .and. i7 == 4 ) k = 0 + i4
        IF ( i6 == 2 .and. i7 == 3 ) k = 4 + i4
        IF ( i6 == 3 .and. i7 == 2 ) k = 8 + i4
        IF ( i6 == 4 .and. i7 == 1 ) k =12 + i4
        IF ( i6 == 3 .and. i7 == 4 ) k =16 + i4
        IF ( i6 == 4 .and. i7 == 3 ) k =20 + i4

        IF ( i1 == 1 .and. i2 == 4 ) eb = eb + au(j,k)
        IF ( i1 == 2 .and. i2 == 3 ) eb = eb + cg(j,k)
        IF ( i1 == 3 .and. i2 == 2 ) eb = eb + gc(j,k)
        IF ( i1 == 4 .and. i2 == 1 ) eb = eb + ua(j,k)
        IF ( i1 == 3 .and. i2 == 4 ) eb = eb + gu(j,k)
        IF ( i1 == 4 .and. i2 == 3 ) eb = eb + ug(j,k)

        RETURN

      END SUBROUTINE TINT12


	SUBROUTINE IMARK ( ix, iy, marker, size, iret )
C************************************************************************
C* IMARK								*
C*									*
C* This subroutine computes the line segments necessary to draw an	*
C* marker.								*
C*									*
C* IMARK ( IX, IY, MARKER, SIZE, IRET )					*
C*									*
C* Input parameters:							*
C*	IX		INTEGER		X coordinate in device units	*
C*	IY		INTEGER		Y coordinate in device units	*
C*	MARKER		INTEGER		Marker number			*
C*	SIZE		REAL		Marker size			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. Vilardo/RDS	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 6/88	Cleaned up				*
C* M. Linda/GSC		 8/96	Added markers 17 - 21, changed 12 & 14	*
C* M. Linda/GSC		 8/96	Fixed a bug in MRKTBL dimension		*
C* M. Linda/GSC		12/96	Added inbnds test, removed aspect	*
C* S. Jacobs/NCEP	 9/97	Added call to DSFILL to set solid fill	*
C* S. Jacobs/NCEP	 3/98	Changed value of solid fill in DSFILL	*
C* D.W.Plummer/NCEP      2/99   Added blank background capability       *
C* D. Kidwell/NCEP      12/99   Restored saved line width, added mrkr 22*
C************************************************************************
	INCLUDE		'DVWNDW.CMN'
	INCLUDE		'DEVACT.CMN'
	INCLUDE		'DEVCHR.CMN'
	INCLUDE		'ERROR.PRM'
C*
	INTEGER		ixp (12), iyp (12)
C*
	LOGICAL		inbnds
C------------------------------------------------------------------------
C*	Declare the marker table.
C
	INTEGER mrktbl(0:12,22)
C
C*	Declare the marker matrix arrays.
C
	INTEGER mark01(0:4),  mark02(0:9),  mark03(0:4),  mark04(0:5)
	INTEGER mark05(0:4),  mark06(0:5),  mark07(0:6),  mark08(0:4)
	INTEGER mark09(0:6),  mark10(0:5),  mark11(0:12), mark12(0:8)
	INTEGER mark13(0:5),  mark14(0:11), mark15(0:2),  mark16(0:4)
	INTEGER mark17(0:9),  mark18(0:4),  mark19(0:5),  mark20(0:5)
	INTEGER mark21(0:11), mark22(0:2)
C
C*	Equivalence individual marker matrix arrays to marker table array.
C
	EQUIVALENCE ( mrktbl(0,1),  mark01(0) )
	EQUIVALENCE ( mrktbl(0,2),  mark02(0) )
	EQUIVALENCE ( mrktbl(0,3),  mark03(0) )
	EQUIVALENCE ( mrktbl(0,4),  mark04(0) )
	EQUIVALENCE ( mrktbl(0,5),  mark05(0) )
	EQUIVALENCE ( mrktbl(0,6),  mark06(0) )
	EQUIVALENCE ( mrktbl(0,7),  mark07(0) )
	EQUIVALENCE ( mrktbl(0,8),  mark08(0) )
	EQUIVALENCE ( mrktbl(0,9),  mark09(0) )
	EQUIVALENCE ( mrktbl(0,10), mark10(0) )
	EQUIVALENCE ( mrktbl(0,11), mark11(0) )
	EQUIVALENCE ( mrktbl(0,12), mark12(0) )
	EQUIVALENCE ( mrktbl(0,13), mark13(0) )
	EQUIVALENCE ( mrktbl(0,14), mark14(0) )
	EQUIVALENCE ( mrktbl(0,15), mark15(0) )
	EQUIVALENCE ( mrktbl(0,16), mark16(0) )
	EQUIVALENCE ( mrktbl(0,17), mark17(0) )
	EQUIVALENCE ( mrktbl(0,18), mark18(0) )
	EQUIVALENCE ( mrktbl(0,19), mark19(0) )
	EQUIVALENCE ( mrktbl(0,20), mark20(0) )
	EQUIVALENCE ( mrktbl(0,21), mark21(0) )
	EQUIVALENCE ( mrktbl(0,22), mark22(0) )
C
C*	Define marker matrices.
C
C*	Element 0 is the number of points in the matrix.
C
C*	Elements 1-12 are a 2 digit number representing the x coordinate and
C*	y coordinate, ten's digit and unit's digit respectively, of points
C*	that will will be used to generate the marker on a 7 x 7 matrix.
C*	Coordinates on the matrix range from 11 to 77.  The origin of the
C*	matrix, ie. coordinate 11, is located in the lower left corner.
C*	Values less than zero result in a move to the specfied coordinate with
C*	the pen up, values greater than zero result in a move with the pen down.
C
C*	 1 = Plus, 2 = Octagon, 3 = Triangle, 4 = Box, 5 = Small x
C*	 6 = Diamond, 7 = Up arrow, 8 = Bar X, 9 = Z, 10 = Y,
C*	11 = Box X, 12 = Asterisk, 13 = Hourglass, 14 = Star, 15 = Dot,
C*	16 = Large X, 17 = Filled octagon, 18 = Filled triangle,
C*	19 = Filled box, 20 = Filled diamond, 21 = Filled star,
C*	22 = Minus
C
	DATA mark01 /  4, -14,  74, -41,  47			      /
	DATA mark02 /  9, -31,  51,  73,  75,  57,  37,  15,  13,  31 /
	DATA mark03 /  4, -11,  71,  47,  11			      /
	DATA mark04 /  5, -11,  71,  77,  17,  11		      /
	DATA mark05 /  4, -22,  66, -62,  26			      /
	DATA mark06 /  5, -41,  14,  47,  74,  41		      /
	DATA mark07 /  6, -41,  44,  14,  47,  74,  44		      /
	DATA mark08 /  4, -11,  77,  17,  71			      /
	DATA mark09 /  6, -17,  77,  11,  71, -34,  64		      /
	DATA mark10 /  5, -17,  44,  41, -44,  77		      /
	DATA mark11 / 12, -33,  53,  55,  35,  33,  11, -53,  71, -55,
     +	                   77, -35,  17				      /
	DATA mark12 /  8, -22,  66, -62,  26, -14,  74, -41,  47      /
	DATA mark13 /  5, -11,  77,  17,  71,  11		      /
	DATA mark14 / 11, -47, 35, 15, 34, 22, 43, 62, 54, 75, 55, 47 /
	DATA mark15 /  2, -44, 44				      /
	DATA mark16 /  4, -11,  77, -71,  17			      /
	DATA mark17 /  9, -31,  51,  73,  75,  57,  37,  15,  13,  31 /
	DATA mark18 /  4, -11,  71,  47,  11			      /
	DATA mark19 /  5, -11,  71,  77,  17,  11		      /
	DATA mark20 /  5, -41,  14,  47,  74,  41		      /
	DATA mark21 / 11, -47, 35, 15, 34, 22, 43, 62, 54, 75, 55, 47 /
	DATA mark22 /  2, -14,  74                                    /
C-------------------------------------------------------------------------
C*	Define functions to extract X and Y coordinates from marker matrices.
C*	Subtracting 4 in X and Y translates the origin of the marker matrix
C*	from the lower left corner, the origin in the marker digitization,
C*	to the center of the matrix.
C
	ixm(ipoint,marker) = ABS ( mrktbl(ipoint,marker) / 10 )  - 4
	iym(ipoint,marker) = ABS (MOD(mrktbl(ipoint,marker),10)) - 4
C-------------------------------------------------------------------------
C*	Statement function to check a point to be within clipping bounds.
C
	inbnds ( jx, jy ) = ( ( ispanx * (jx  - icleft) .ge. 0 ) .and.
     +			      ( ispanx * (icrght - jx ) .ge. 0 ) .and.
     +			      ( ispany * (jy  - icbot ) .ge. 0 ) .and.
     +			      ( ispany * (ictop  - jy ) .ge. 0 ))
C-------------------------------------------------------------------------
	iret = NORMAL
C
C*	Verify that a valid marker number has been specified.
C
	IF  ( marker .ge. 1 .and. marker .le. 22 ) THEN
C
C*	    Check center against clipping area; also checks if missing.
C
	    IF ( .not. inbnds ( ix, iy ) ) RETURN
C
C*	    Get the number of points required to define requested marker.
C
	    npnts = mrktbl(0,marker)
C
C*	    Set dot multiplication
C
	    dotmul = bscald / bscalm * size
C
C*          Save width and color; setup for background and foreground.
C
            lwidsv = mmkwid
            iclrsv = mcolr
	    iwidsv = mlwid
C
C*          Split up mmkwid into foreground and background components.
C
            IF  ( mmkwid .gt. 99 )  THEN
                kfgwid = MOD ( mmkwid, 100 )
                IF  ( kfgwid .le. 0 )  kfgwid = 1
                kbgwid = ( mmkwid / 100 ) + kfgwid
                nx = 2
              ELSE
                kfgwid = mmkwid
                kbgwid = 0
                nx = 1
            END IF
C
C*          Loop over foreground and background.
C
            DO  ibf = 1, nx
C
C*            Depending on background or foreground, set line width, and color.
C
              IF ( nx .eq. 2 .and. ibf .eq. 1 )  THEN
                iwidth = kbgwid
                CALL DSCOLR ( 101, imclr, ier )
		dotexp = kbgwid - kfgwid
              ELSE
                iwidth = kfgwid
                CALL DSCOLR ( iclrsv, imclr, ier )
		dotexp = 0.0
              END IF
C
              CALL DSLINE ( 0, 0, iwidth, 0, i1, i2, i3, i4, ier)
C
C*	      Loop over the points.
C
	      np = 0
C
	      DO  ip = 1, npnts
C
C*		If this point requires the pen up
C*		then draw the current line first.
C
		IF  ( mrktbl(ip,marker) .lt. 0 .and. np .gt. 0 ) THEN
		    CALL ILINE ( np, ixp, iyp, ier )
		    np = 0
		END IF
C
C*		Compute the x and y coordinates for this point.
C
C*		Coordinates are computed to be the sum of the requested
C*		coordinate and the nearest integer to the product of the
C*		marker matrix coordinate, size multiplier, and a factor
C*		which accounts for direction of increasing or decreasing
C*		X or Y coordinate.
C
		np      = np + 1
		ixp(np) = ix + NINT( ixm(ip,marker) * size * ispanx )
		iyp(np) = iy + NINT( iym(ip,marker) * size * ispany )
	      END DO
C
C*	      Draw the last line.
C
	      IF  ( ( marker .ge. 17 ) .and. ( marker .le. 21 ) ) THEN
                IF ( nx .eq. 2 .and. ibf .eq. 1 )  THEN
		    iwidth = iwidth - kfgwid
		    CALL DSLINE ( 0, 0, iwidth, 0, i1,i2,i3,i4, ier)
		    CALL ILINE ( np, ixp, iyp, ier )
		ELSE
		    msvft = mfltyp
		    svfsz = tfilsz
		    CALL DSFILL ( 1.0, 1, fsize, itype, ier )
		    CALL IFILL ( np, ixp, iyp, ier )
		    CALL DSFILL ( svfsz, msvft, fsize, itype, ier )
		END IF
	      ELSE
		IF ( marker .eq. 15 )  THEN
		    idotwd = NINT ( dotmul + dotexp )
		    CALL DSLINE ( 0, 0, idotwd, 0, i1,i2,i3,i4, ier)
		END IF
		CALL ILINE ( np, ixp, iyp, ier )
	      END IF
C
	    END DO
	    CALL DSLINE ( 0, 0, iwidsv, 0, i1, i2, i3, i4, ier )
C
	END IF
C
        mmkwid = lwidsv
C*
	RETURN
	END


module chemmod

!   prgmmr: pagowski                date: 2010-09-13
! module contains functions
! 1) to convert units between obs and model function
!obs2model_anowbufr_pm
! 2) allocate and assign initial values to pm2_5 guess
!init_pm2_5_guess
! 3) declare/assign &CHEM namelist parameters
!init_chem
! subroutine oneobschem
! for testing one observation assimilation

! NB: keep aerosol names capital for consistency with cmaq output names
! 2011-09-09 pagowski - add codes for PM2.5 for prepbufr and bufr dump files
! 2013-11-01 pagowski - add code for PM2.5 assimilation with wrf-chem
! 2019-03-21 Wei/Martin - logical if to read in aerosols from ext. file (default F)

  use kinds, only : i_kind, r_kind, r_single
  use gridmod, only: cmaq_regional,wrf_mass_regional,lat2,lon2,nsig
  use constants, only : tiny_single,max_varname_length

  implicit none

  private

  public :: obs2model_anowbufr_pm,cmaq_pm,wrf_chem_pm,&
        cmaq_o3,wrf_chem_o3
  public :: iconc,ierror,ilat,ilon,itime,iid,ielev,isite,iikx,ilate,ilone

  public :: elev_tolerance,elev_missing,pm2_5_teom_max,pm10_teom_max
  public :: ngrid1d_cmaq,ngrid2d_cmaq,nmet2d_cmaq,nmet3d_cmaq,&
        naero_cmaq,aeronames_cmaq,naero_gocart_wrf,aeronames_gocart_wrf

  public :: pm2_5_guess,init_pm2_5_guess,&
       aerotot_guess,init_aerotot_guess
  public :: init_chem
  public :: berror_chem,oneobtest_chem,maginnov_chem,magoberr_chem,oneob_type_chem,conconeobs
  public :: oblat_chem,oblon_chem,obpres_chem,diag_incr,oneobschem
  public :: site_scale,nsites
  public :: tunable_error
  public :: in_fname,out_fname,incr_fname,maxstr
  public :: code_pm25_ncbufr,code_pm25_anowbufr
  public :: code_pm10_ncbufr,code_pm10_anowbufr

  public :: l_aoderr_table
  public :: laeroana_gocart
  public :: ppmv_conv
  public :: aod_qa_limit
  public :: luse_deepblue

  public :: wrf_pm2_5

  public :: lread_ext_aerosol
  public :: aero_ratios
  public :: upper2lower,lower2upper

  public :: s_2_5,d_2_5,d_10,nh4_mfac,oc_mfac

  logical :: l_aoderr_table
  logical :: laeroana_gocart
  logical :: luse_deepblue
  integer(i_kind) :: aod_qa_limit  ! qa >=  aod_qa_limit will be retained
  real(r_kind)    :: ppmv_conv = 96.06_r_kind/28.964_r_kind*1.0e+3_r_kind
  logical :: wrf_pm2_5

  logical :: lread_ext_aerosol ! if true, will read in aerosols from aerfXX rather than from sigfXX

  real(r_kind),parameter :: s_2_5=0.942_r_kind,d_2_5=0.286_r_kind,&
       d_10=0.87_r_kind,nh4_mfac=1.375_r_kind,oc_mfac=1.8_r_kind

  logical :: aero_ratios

  logical :: oneobtest_chem,diag_incr,berror_chem
  character(len=max_varname_length) :: oneob_type_chem
  integer(i_kind), parameter :: maxstr=256
  real(r_kind) :: maginnov_chem,magoberr_chem,conconeobs,&
        oblon_chem,oblat_chem,obpres_chem,elev_tolerance,tunable_error

  integer(i_kind), parameter :: code_pm25_ncbufr=11, &
       code_pm25_anowbufr=102,code_pm10_ncbufr=code_pm25_ncbufr,&
       code_pm10_anowbufr=code_pm25_anowbufr

  real(r_kind),parameter :: pm2_5_teom_max=100.0_r_kind !ug/m3
!some parameters need to be put here since convinfo file won't
!accomodate, stands for maximum realistic value of surface pm2.5
  real(r_kind),parameter :: pm10_teom_max=150.0_r_kind !ug/m3

  real(r_kind),parameter :: elev_missing=-9999.0_r_kind
!when elevation of the obs site is missing assign that

  integer(i_kind), parameter :: nsites=4

!character of sites:
! 1 - unknown
! 2 - urban
! 3 - suburban
! 4 - rural
! depending on the character of measurement site  observation
! error is assigned - see read_anowbufr.f90 for error calculation
!error_2=tunable_error*error_1*sqrt(dx/site_scale)

  real(r_kind), dimension (nsites), parameter:: &
        site_scale= (/3000._r_kind,2000._r_kind,&
        4000._r_kind,10000._r_kind/)

!conversion ratios between obs and model units
  real(r_kind),parameter :: kg2ug=1.e+9_r_kind,ppbv2ppmv=0.001_r_kind
  real(r_kind),parameter :: cmaq_pm=kg2ug,wrf_chem_pm=kg2ug,&
        cmaq_o3=ppbv2ppmv,wrf_chem_o3=ppbv2ppmv

!position of obs parameters in obs output file record
  integer(i_kind), parameter :: &
        iconc = 1,ierror= 2,&
        ilat  = 3,ilon  = 4,&
        itime = 5,iid=6,&
        ielev = 7,isite = 8,&
        iikx  = 9,ilate = 10,&
        ilone =11

!parameters for erading cmaq input file
  integer(i_kind), parameter :: &
        ngrid1d_cmaq=2,  &     !aeta1,eta1
        ngrid2d_cmaq=4,  &     !lat,lon,dx_mc,dy_mc
        nmet2d_cmaq=2, &       !ht,psfc
        nmet3d_cmaq=4,  &  !t,qv,u,v
        naero_cmaq=33,&  !number of cmaq aerosol species
        naero_gocart_wrf=15  !number of gocart aerosol species

  character(len=max_varname_length), dimension(naero_cmaq), parameter :: &
        aeronames_cmaq=(/ character(len=max_varname_length) :: &
        'ASO4I',  'ANO3I',  'ANH4I',  'AORGPAI',  'AECI',   'ACLI', &
        'ASO4J',  'ANO3J',  'ANH4J',  'AORGPAJ',  'AECJ',   'ANAJ',&
        'ACLJ',   'A25J',   'AXYL1J', 'AXYL2J',   'AXYL3J', 'ATOL1J',&
        'ATOL2J', 'ATOL3J', 'ABNZ1J', 'ABNZ2J',   'ABNZ3J', 'AALKJ',&
        'AOLGAJ', 'AISO1J', 'AISO2J', 'AISO3J',   'ATRP1J', 'ATRP2J',&
        'ASQTJ',  'AOLGBJ', 'AORGCJ'/)

  character(len=max_varname_length), dimension(naero_gocart_wrf), parameter :: &
        aeronames_gocart_wrf=(/&
        'sulf      ','BC1       ','BC2       ','OC1       ',&
        'OC2       ','DUST1     ','DUST2     ','DUST3     ',&
        'DUST4     ','DUST5     ','SEAS1     ','SEAS2     ',&
        'SEAS3     ','SEAS4     ','P25       '/)

  real(r_single), allocatable, dimension(:,:,:) :: pm2_5_guess,&
       aerotot_guess

  character(len=maxstr) :: in_fname,out_fname,incr_fname

contains

  function obs2model_anowbufr_pm()

!   prgmmr: pagowski                date: 2010-09-13

! assigns conversion factors between AIRNow pm units and model units

    real(r_kind) :: obs2model_anowbufr_pm

    if (cmaq_regional) then
       obs2model_anowbufr_pm=cmaq_pm
    elseif (wrf_mass_regional) then
       obs2model_anowbufr_pm=wrf_chem_pm
    else
       write(6,*)'unknown chem model. stopping'
       call stop2(414)
    endif

  end function obs2model_anowbufr_pm

  subroutine init_pm2_5_guess

!   prgmmr: pagowski                date: 2010-09-13
!   allocates and assigns initial values to pm2_5_guess
    integer(i_kind) :: i,j,k

    allocate(pm2_5_guess(lat2,lon2,nsig))

    do i=1,lon2
       do j=1,lat2
          do k=1,nsig
             pm2_5_guess(j,i,k)=tiny_single
          enddo
       enddo
    enddo

  end subroutine init_pm2_5_guess

  subroutine init_aerotot_guess

!   prgmmr: pagowski                date: 2010-09-13
!   allocates and assigns initial values to aerotot_guess
    integer(i_kind) :: i,j,k

    allocate(aerotot_guess(lat2,lon2,nsig))

    do i=1,lon2
       do j=1,lat2
          do k=1,nsig
             aerotot_guess(j,i,k)=tiny_single
          enddo
       enddo
    enddo

  end subroutine init_aerotot_guess

  subroutine init_chem

!   prgmmr: pagowski                date: 2010-09-13
! program history log:
!  2019-03-21 Martin  - cleaned up contribution from S-W Wei at UAlbany

!initialiazes default values to &CHEM namelist parameters

    berror_chem=.false.
    oneobtest_chem=.false.
    maginnov_chem=30_r_kind
    magoberr_chem=2_r_kind
    oneob_type_chem='pm2_5'
    oblat_chem=45_r_kind
    oblon_chem=270_r_kind
    obpres_chem=1000_r_kind
    diag_incr=.false.
    elev_tolerance=500_r_kind
    tunable_error=0.5_r_kind
    in_fname='cmaq_input.bin'
    out_fname='cmaq_output.bin'
    incr_fname='chem_increment.bin'

    laeroana_gocart = .false.
    l_aoderr_table = .false.
    aod_qa_limit = 3
    luse_deepblue = .false.

    wrf_pm2_5=.false.
    aero_ratios=.false.
    lread_ext_aerosol = .false.

  end subroutine init_chem

  subroutine oneobschem(nread,ndata,nodata,gstime,&
        infile,obstype,lunout,sis,nobs)

!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:  one obs test for in-situ chem
!   prgmmr: pagowski                date: 2010-11-18
!
! program history log:
!   2010-11-18  pagowski
!   2013-01-23  parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS)
!
!   input argument list:
!     obstype  - observation type to process
!     lunout   - unit to which to write data for further processing
!
!   output argument list:
!     nread    - number of type "obstype" observations read
!     ndata    - number of type "obstype" observations retained for further processing
!     nodata   - number of individual "obstype" observations retained for !further processing
!     sis      - satellite/instrument/sensor indicator
!     nobs     - array of observations on each subdomain for each processor
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$

    use constants, only: zero,one,deg2rad,rad2deg
    use gridmod, only: diagnostic_reg,regional,nlon,nlat,&
         tll2xy,txy2ll,rlats,rlons
    use convinfo, only: nconvtype,icuse,ioctype
    use mpimod, only: npe

    implicit none

! declare passed variables
    character(len=*),intent(in   ) :: obstype
    character(len=*),intent(out) :: infile
    integer(i_kind) ,intent(in   ) :: lunout
    integer(i_kind) ,intent(inout) :: nread,ndata,nodata
    real(r_kind)    ,intent(in   ) :: gstime
    character(len=*),intent(in   ) :: sis
    integer(i_kind),dimension(npe) ,intent(inout) :: nobs

! declare local parameters

    integer(i_kind), parameter :: nsid=1,nxob=2,&
          nyob=3,ndhr=4,ntyp=5,ncopopm=6
!see headr input format below

    integer(i_kind), parameter:: nchanl=0,nreal=ilone

    real(r_kind),parameter :: r100 = 100.0_r_kind
    real(r_kind),parameter :: r360 = 360.0_r_kind

! declare local variables
    logical outside

    integer(i_kind) i
    integer(i_kind) ikx

    real(r_kind) :: tdiff,obstime
    real(r_kind) :: dlat,dlon,obserror,dlat_earth,dlon_earth

    real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00
    integer(i_kind) ntest

    integer(i_kind) k,site_char,site_id
    real(r_kind) :: conc,site_elev
    real(r_kind), dimension(nreal,1):: cdata_all

    site_id=123456789
    site_char=1 ! set unknown site character
    site_elev=elev_missing ! set unknown site elevation

!**************************************************************************
! initialize variables
    infile='namelist'
    disterrmax=zero
    ntest=1
    nread=1
    ndata = 1
    nodata = 1

    if(oblon_chem >= r360)  oblon_chem = oblon_chem - r360
    if(oblon_chem <  zero)  oblon_chem = oblon_chem + r360

    dlon_earth=oblon_chem*deg2rad
    dlat_earth=oblat_chem*deg2rad
    obstime=gstime
    tdiff=zero
    conc=zero ! this is unimportant since only innovation counts

    if(regional)then

       call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)    ! convert to rotated coordinate

       if(diagnostic_reg) then

          call txy2ll(dlon,dlat,rlon00,rlat00)
          cdist=sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* &
               (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00))
          cdist=max(-one,min(cdist,one))
          disterr=acos(cdist)*rad2deg
          disterrmax=max(disterrmax,disterr)
       end if

       if(outside) then
          write(6,*)'oneobtest_chem outside domain - stopping'
          call stop2(511)
       endif

    else
       dlat = dlat_earth
       dlon = dlon_earth
       call grdcrd1(dlat,rlats,nlat,1)
       call grdcrd1(dlon,rlons,nlon,1)
    endif

    do i = 1, nconvtype
       if (obstype == ioctype(i) .and. abs(icuse(i))== 1) ikx=i
    end do

    obserror=magoberr_chem

    cdata_all(iconc,ndata)  = conc                    ! pm2_5 obs
    cdata_all(ierror,ndata) = obserror                ! pm2_5 obs error
    cdata_all(ilat,ndata)   = dlat                    ! grid relative latitude

    cdata_all(ilon,ndata)   = dlon                    ! grid relative longitude
    cdata_all(itime,ndata)  = obstime                 ! time of obs
    cdata_all(iid,ndata)    = site_id                 ! site id
    cdata_all(ielev,ndata)  = site_elev               ! elevation
    cdata_all(isite,ndata)  = site_char               ! site character
    cdata_all(iikx,ndata)   = ikx                     ! ordered number in convinfo table
    cdata_all(ilate,ndata)  = dlat_earth*rad2deg      ! earth relative latitude (degrees)
    cdata_all(ilone,ndata)  = dlon_earth*rad2deg      ! earth relative longitude (degrees)

! write header record and data to output file for further processing
    call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
    write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
    write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)

    return

  end subroutine oneobschem

  function upper2lower(str) result(string)

    implicit none

    character(*), intent(in) :: str
    character(len(str))      :: string

    integer :: ic, i

    character(26), parameter :: upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
    character(26), parameter :: lower = 'abcdefghijklmnopqrstuvwxyz'

!   lowcase each letter if it is lowecase
    string = str
    do i = 1, len_trim(str)
        ic = index(upper, str(i:i))
        if (ic > 0) string(i:i) = lower(ic:ic)
    end do

  end function upper2lower

  function lower2upper(str) result (string)

    implicit none

    character(*), intent(in) :: str
    character(len(str))      :: string

    integer :: ic, i

    character(26), parameter :: upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
    character(26), parameter :: lower = 'abcdefghijklmnopqrstuvwxyz'

!   lowcase each letter if it is lowecase
    string = str
    do i = 1, len_trim(str)
        ic = index(lower, str(i:i))
        if (ic > 0) string(i:i) = upper(ic:ic)
    end do

  end function lower2upper

end module chemmod


Subroutine pystfu(kf, x, q2, xpq, jbt)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Save /hparnt/
  Common /hjcrdn/yp(3, 300), yt(3, 300)
  Save /hjcrdn/
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  Common /pypars/mstp(200), parp(200), msti(200), pari(200)
  Save /pypars/
  Common /pyint1/mint(400), vint(400)
  Save /pyint1/
  Dimension xpq(-6:6), xq(6), tx(6), tt(6), ts(6), nehlq(8, 2), cehlq(6, 6, 2, 8, 2), cdo(3, 6, 5, 2), cow(3, 5, 4, 2)
  Data nehlq/3, 4, 7, 5, 7, 7, 7, 7, 3, 4, 7, 6, 7, 7, 7, 7/
  Data (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6), nx=1, 2)/7.677E-01, -2.087E-01, -3.303E-01, -2.517E-02, -1.570E-02, -1.000E-04, -5.326E-01, -2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03, 2.162E-01, 1.881E-01, -8.375E-02, -6.515E-02, -1.743E-02, -5.040E-03, -9.211E-02, -9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03, 3.670E-02, 4.409E-02, 9.600E-04, -7.960E-03, -3.420E-03, -1.050E-03, -1.549E-02, -2.026E-02, -3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04, 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04, 1.751E-02, -6.090E-03, -2.687E-02, -1.916E-02, -7.970E-03, -2.750E-03, -5.760E-03, -5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04, 1.740E-03, 1.960E-03, 3.000E-04, -3.400E-04, -2.900E-04, -1.800E-04, -5.300E-04, -6.400E-04, -1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05, 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05, -1.000E-05, -1.000E-05/
  Data (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6), nx=1, 2)/7.237E-01, -2.189E-01, -2.995E-01, -1.909E-02, -1.477E-02, 2.500E-04, -5.314E-01, -2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03, 2.289E-01, 1.890E-01, -9.859E-02, -6.900E-02, -1.747E-02, -5.080E-03, -1.041E-01, -1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03, 4.394E-02, 5.116E-02, -1.410E-03, -1.055E-02, -4.230E-03, -1.270E-03, -1.991E-02, -2.539E-02, -2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04, 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04, 1.765E-02, -9.220E-03, -3.037E-02, -2.085E-02, -8.440E-03, -2.810E-03, -6.450E-03, -5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04, 2.120E-03, 2.320E-03, 2.600E-04, -4.900E-04, -3.900E-04, -2.300E-04, -6.900E-04, -8.200E-04, -2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05, 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00, -2.000E-05, -2.000E-05/
  Data (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6), nx=1, 2)/3.813E-01, -8.090E-02, -1.634E-01, -2.185E-02, -8.430E-03, -6.200E-04, -2.948E-01, -1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03, 1.252E-01, 1.042E-01, -4.722E-02, -3.683E-02, -1.038E-02, -2.860E-03, -5.478E-02, -5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03, 2.220E-02, 2.567E-02, -3.000E-05, -4.970E-03, -2.160E-03, -6.500E-04, -9.530E-03, -1.204E-02, -1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04, 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04, 3.890E-03, -1.159E-02, -1.625E-02, -9.610E-03, -3.710E-03, -1.260E-03, -1.910E-03, -5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04, 6.400E-04, 4.900E-04, -1.500E-04, -2.900E-04, -1.800E-04, -1.000E-04, -2.000E-04, -1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05, 7.000E-05, 8.000E-05, 2.000E-05, -1.000E-05, -1.000E-05, -1.000E-05/
  Data (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6), nx=1, 2)/3.578E-01, -8.622E-02, -1.480E-01, -1.840E-02, -7.820E-03, -4.500E-04, -2.925E-01, -1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03, 1.318E-01, 1.041E-01, -5.486E-02, -3.872E-02, -1.038E-02, -2.850E-03, -6.162E-02, -6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03, 2.643E-02, 2.957E-02, -1.490E-03, -6.450E-03, -2.630E-03, -7.700E-04, -1.218E-02, -1.497E-02, -1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04, 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04, 3.660E-03, -1.357E-02, -1.795E-02, -1.031E-02, -3.880E-03, -1.280E-03, -2.100E-03, -3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04, 7.700E-04, 5.400E-04, -2.400E-04, -3.900E-04, -2.400E-04, -1.300E-04, -2.600E-04, -2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05, 9.000E-05, 1.000E-04, 2.000E-05, -2.000E-05, -2.000E-05, -1.000E-05/
  Data (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6), nx=1, 2)/6.870E-02, -6.861E-02, 2.973E-02, -5.400E-03, 3.780E-03, -9.700E-04, -1.802E-02, 1.400E-04, 6.490E-03, -8.540E-03, 1.220E-03, -1.750E-03, -4.650E-03, 1.480E-03, -5.930E-03, 6.000E-04, -1.030E-03, -8.000E-05, 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04, -3.930E-03, -2.540E-03, -1.160E-03, -7.700E-04, -3.600E-04, -1.900E-04, 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05, 1.014E+00, -1.106E+00, 3.374E-01, -7.444E-02, 8.850E-03, -8.700E-04, 9.233E-01, -1.285E+00, 4.475E-01, -9.786E-02, 1.419E-02, -1.120E-03, 4.888E-02, -1.271E-01, 8.606E-02, -2.608E-02, 4.780E-03, -6.000E-04, -2.691E-02, 4.887E-02, -1.771E-02, 1.620E-03, 2.500E-04, -6.000E-05, 7.040E-03, -1.113E-02, 1.590E-03, 7.000E-04, -2.000E-04, 0.000E+00, -1.710E-03, 2.290E-03, 3.800E-04, -3.500E-04, 4.000E-05, 1.000E-05/
  Data (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6), nx=1, 2)/1.008E-01, -7.100E-02, 1.973E-02, -5.710E-03, 2.930E-03, -9.900E-04, -5.271E-02, -1.823E-02, 1.792E-02, -6.580E-03, 1.750E-03, -1.550E-03, 1.220E-02, 1.763E-02, -8.690E-03, -8.800E-04, -1.160E-03, -2.100E-04, -1.190E-03, -7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04, -9.100E-04, 2.040E-03, -3.100E-04, -1.050E-03, -4.000E-04, -2.400E-04, 1.190E-03, -1.700E-04, -2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04, 1.081E+00, -1.189E+00, 3.868E-01, -8.617E-02, 1.115E-02, -1.180E-03, 9.917E-01, -1.396E+00, 4.998E-01, -1.159E-01, 1.674E-02, -1.720E-03, 5.099E-02, -1.338E-01, 9.173E-02, -2.885E-02, 5.890E-03, -6.500E-04, -3.178E-02, 5.703E-02, -2.070E-02, 2.440E-03, 1.100E-04, -9.000E-05, 8.970E-03, -1.392E-02, 2.050E-03, 6.500E-04, -2.300E-04, 2.000E-05, -2.340E-03, 3.010E-03, 5.000E-04, -3.900E-04, 6.000E-05, 1.000E-05/
  Data (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6), nx=1, 2)/9.482E-01, -9.578E-01, 1.009E-01, -1.051E-01, 3.456E-02, -3.054E-02, -9.627E-01, 5.379E-01, 3.368E-01, -9.525E-02, 1.488E-02, -2.051E-02, 4.300E-01, -8.306E-02, -3.372E-01, 4.902E-02, -9.160E-03, 1.041E-02, -1.925E-01, -1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03, -1.860E-03, 8.183E-02, 1.926E-02, -1.072E-01, -1.944E-02, -2.770E-03, -5.200E-04, -3.884E-02, -1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03, 2.948E+01, -3.902E+01, 1.464E+01, -3.335E+00, 5.054E-01, -5.915E-02, 2.559E+01, -3.955E+01, 1.661E+01, -4.299E+00, 6.904E-01, -8.243E-02, -1.663E+00, 1.176E+00, 1.118E+00, -7.099E-01, 1.948E-01, -2.404E-02, -2.168E-01, 8.170E-01, -7.169E-01, 1.851E-01, -1.924E-02, -3.250E-03, 2.088E-01, -4.355E-01, 2.239E-01, -2.446E-02, -3.620E-03, 1.910E-03, -9.097E-02, 1.601E-01, -5.681E-02, -2.500E-03, 2.580E-03, -4.700E-04/
  Data (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6), nx=1, 2)/2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02, -3.170E+00, -1.795E+00, 3.313E-02, -2.874E-01, -9.827E-02, -7.119E-02, 1.823E+00, 1.457E+00, -2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02, -1.033E+00, -9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02, 5.133E-01, 5.259E-01, -1.173E-01, -1.139E-01, -4.988E-02, -2.021E-02, -2.881E-01, -3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02, 3.036E+01, -4.062E+01, 1.578E+01, -3.699E+00, 6.020E-01, -7.031E-02, 2.700E+01, -4.167E+01, 1.770E+01, -4.804E+00, 7.862E-01, -1.060E-01, -1.909E+00, 1.357E+00, 1.127E+00, -7.181E-01, 2.232E-01, -2.481E-02, -2.488E-01, 9.781E-01, -8.127E-01, 2.094E-01, -2.997E-02, -4.710E-03, 2.506E-01, -5.427E-01, 2.672E-01, -3.103E-02, -1.800E-03, 2.870E-03, -1.128E-01, 2.087E-01, -6.972E-02, -2.480E-03, 2.630E-03, -8.400E-04/
  Data (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6), nx=1, 2)/4.968E-02, -4.173E-02, 2.102E-02, -3.270E-03, 3.240E-03, -6.700E-04, -6.150E-03, -1.294E-02, 6.740E-03, -6.890E-03, 9.000E-04, -1.510E-03, -8.580E-03, 5.050E-03, -4.900E-03, -1.600E-04, -9.400E-04, -1.500E-04, 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04, -4.410E-03, -2.220E-03, -8.900E-04, -8.500E-04, -3.600E-04, -2.000E-04, 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05, 9.235E-01, -1.085E+00, 3.464E-01, -7.210E-02, 9.140E-03, -9.100E-04, 9.315E-01, -1.274E+00, 4.512E-01, -9.775E-02, 1.380E-02, -1.310E-03, 4.739E-02, -1.296E-01, 8.482E-02, -2.642E-02, 4.760E-03, -5.700E-04, -2.653E-02, 4.953E-02, -1.735E-02, 1.750E-03, 2.800E-04, -6.000E-05, 6.940E-03, -1.132E-02, 1.480E-03, 6.500E-04, -2.100E-04, 0.000E+00, -1.680E-03, 2.340E-03, 4.200E-04, -3.400E-04, 5.000E-05, 1.000E-05/
  Data (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6), nx=1, 2)/6.478E-02, -4.537E-02, 1.643E-02, -3.490E-03, 2.710E-03, -6.700E-04, -2.223E-02, -2.126E-02, 1.247E-02, -6.290E-03, 1.120E-03, -1.440E-03, -1.340E-03, 1.362E-02, -6.130E-03, -7.900E-04, -9.000E-04, -2.000E-04, 5.080E-03, -3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04, -3.580E-03, 6.000E-05, -2.600E-04, -1.050E-03, -3.800E-04, -2.300E-04, 2.420E-03, 9.300E-04, -1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04, 9.868E-01, -1.171E+00, 3.940E-01, -8.459E-02, 1.124E-02, -1.250E-03, 1.001E+00, -1.383E+00, 5.044E-01, -1.152E-01, 1.658E-02, -1.830E-03, 4.928E-02, -1.368E-01, 9.021E-02, -2.935E-02, 5.800E-03, -6.600E-04, -3.133E-02, 5.785E-02, -2.023E-02, 2.630E-03, 1.600E-04, -8.000E-05, 8.840E-03, -1.416E-02, 1.900E-03, 5.800E-04, -2.500E-04, 1.000E-05, -2.300E-03, 3.080E-03, 5.500E-04, -3.700E-04, 7.000E-05, 1.000E-05/
  Data (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6), nx=1, 2)/9.270E-03, -1.817E-02, 9.590E-03, -6.390E-03, 1.690E-03, -1.540E-03, 5.710E-03, -1.188E-02, 6.090E-03, -4.650E-03, 1.240E-03, -1.310E-03, -3.960E-03, 7.100E-03, -3.590E-03, 1.840E-03, -3.900E-04, 3.400E-04, 1.120E-03, -1.960E-03, 1.120E-03, -4.800E-04, 1.000E-04, -4.000E-05, 4.000E-05, -3.000E-05, -1.800E-04, 9.000E-05, -5.000E-05, -2.000E-05, -4.200E-04, 7.300E-04, -1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05, 8.098E-01, -1.042E+00, 3.398E-01, -6.824E-02, 8.760E-03, -9.000E-04, 8.961E-01, -1.217E+00, 4.339E-01, -9.287E-02, 1.304E-02, -1.290E-03, 3.058E-02, -1.040E-01, 7.604E-02, -2.415E-02, 4.600E-03, -5.000E-04, -2.451E-02, 4.432E-02, -1.651E-02, 1.430E-03, 1.200E-04, -1.000E-04, 1.122E-02, -1.457E-02, 2.680E-03, 5.800E-04, -1.200E-04, 3.000E-05, -7.730E-03, 7.330E-03, -7.600E-04, -2.400E-04, 1.000E-05, 0.000E+00/
  Data (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6), nx=1, 2)/9.980E-03, -1.945E-02, 1.055E-02, -6.870E-03, 1.860E-03, -1.560E-03, 5.700E-03, -1.203E-02, 6.250E-03, -4.860E-03, 1.310E-03, -1.370E-03, -4.490E-03, 7.990E-03, -4.170E-03, 2.050E-03, -4.400E-04, 3.300E-04, 1.470E-03, -2.480E-03, 1.460E-03, -5.700E-04, 1.200E-04, -1.000E-05, -9.000E-05, 1.500E-04, -3.200E-04, 1.200E-04, -6.000E-05, -4.000E-05, -4.200E-04, 7.600E-04, -1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05, 8.698E-01, -1.131E+00, 3.836E-01, -8.111E-02, 1.048E-02, -1.300E-03, 9.626E-01, -1.321E+00, 4.854E-01, -1.091E-01, 1.583E-02, -1.700E-03, 3.057E-02, -1.088E-01, 8.022E-02, -2.676E-02, 5.590E-03, -5.600E-04, -2.845E-02, 5.164E-02, -1.918E-02, 2.210E-03, -4.000E-05, -1.500E-04, 1.311E-02, -1.751E-02, 3.310E-03, 5.100E-04, -1.200E-04, 5.000E-05, -8.590E-03, 8.380E-03, -9.200E-04, -2.600E-04, 1.000E-05, -1.000E-05/
  Data (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6), nx=1, 2)/9.010E-03, -1.401E-02, 7.150E-03, -4.130E-03, 1.260E-03, -1.040E-03, 6.280E-03, -9.320E-03, 4.780E-03, -2.890E-03, 9.100E-04, -8.200E-04, -2.930E-03, 4.090E-03, -1.890E-03, 7.600E-04, -2.300E-04, 1.400E-04, 3.900E-04, -1.200E-03, 4.400E-04, -2.500E-04, 2.000E-05, -2.000E-05, 2.600E-04, 1.400E-04, -8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05, -2.600E-04, 3.200E-04, 1.000E-05, -1.000E-05, 1.000E-05, -1.000E-05, 8.029E-01, -1.075E+00, 3.792E-01, -7.843E-02, 1.007E-02, -1.090E-03, 7.903E-01, -1.099E+00, 4.153E-01, -9.301E-02, 1.317E-02, -1.410E-03, -1.704E-02, -1.130E-02, 2.882E-02, -1.341E-02, 3.040E-03, -3.600E-04, -7.200E-04, 7.230E-03, -5.160E-03, 1.080E-03, -5.000E-05, -4.000E-05, 3.050E-03, -4.610E-03, 1.660E-03, -1.300E-04, -1.000E-05, 1.000E-05, -4.360E-03, 5.230E-03, -1.610E-03, 2.000E-04, -2.000E-05, 0.000E+00/
  Data (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6), nx=1, 2)/8.980E-03, -1.459E-02, 7.510E-03, -4.410E-03, 1.310E-03, -1.070E-03, 5.970E-03, -9.440E-03, 4.800E-03, -3.020E-03, 9.100E-04, -8.500E-04, -3.050E-03, 4.440E-03, -2.100E-03, 8.500E-04, -2.400E-04, 1.400E-04, 5.300E-04, -1.300E-03, 5.600E-04, -2.700E-04, 3.000E-05, -2.000E-05, 2.000E-04, 1.400E-04, -1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00, -2.600E-04, 3.200E-04, 0.000E+00, -3.000E-05, 1.000E-05, -1.000E-05, 8.672E-01, -1.174E+00, 4.265E-01, -9.252E-02, 1.244E-02, -1.460E-03, 8.500E-01, -1.194E+00, 4.630E-01, -1.083E-01, 1.614E-02, -1.830E-03, -2.241E-02, -5.630E-03, 2.815E-02, -1.425E-02, 3.520E-03, -4.300E-04, -7.300E-04, 8.030E-03, -5.780E-03, 1.380E-03, -1.300E-04, -4.000E-05, 3.460E-03, -5.380E-03, 1.960E-03, -2.100E-04, 1.000E-05, 1.000E-05, -4.850E-03, 5.950E-03, -1.890E-03, 2.600E-04, -3.000E-05, 0.000E+00/
  Data (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6), nx=1, 2)/4.410E-03, -7.480E-03, 3.770E-03, -2.580E-03, 7.300E-04, -7.100E-04, 3.840E-03, -6.050E-03, 3.030E-03, -2.030E-03, 5.800E-04, -5.900E-04, -8.800E-04, 1.660E-03, -7.500E-04, 4.700E-04, -1.000E-04, 1.000E-04, -8.000E-05, -1.500E-04, 1.200E-04, -9.000E-05, 3.000E-05, 0.000E+00, 1.300E-04, -2.200E-04, -2.000E-05, -2.000E-05, -2.000E-05, -2.000E-05, -7.000E-05, 1.900E-04, -4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00, 6.623E-01, -9.248E-01, 3.519E-01, -7.930E-02, 1.110E-02, -1.180E-03, 6.380E-01, -9.062E-01, 3.582E-01, -8.479E-02, 1.265E-02, -1.390E-03, -2.581E-02, 2.125E-02, 4.190E-03, -4.980E-03, 1.490E-03, -2.100E-04, 7.100E-04, 5.300E-04, -1.270E-03, 3.900E-04, -5.000E-05, -1.000E-05, 3.850E-03, -5.060E-03, 1.860E-03, -3.500E-04, 4.000E-05, 0.000E+00, -3.530E-03, 4.460E-03, -1.500E-03, 2.700E-04, -3.000E-05, 0.000E+00/
  Data (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6), nx=1, 2)/4.260E-03, -7.530E-03, 3.830E-03, -2.680E-03, 7.600E-04, -7.300E-04, 3.640E-03, -6.050E-03, 3.030E-03, -2.090E-03, 5.900E-04, -6.000E-04, -9.200E-04, 1.710E-03, -8.200E-04, 5.000E-04, -1.200E-04, 1.000E-04, -5.000E-05, -1.600E-04, 1.300E-04, -9.000E-05, 3.000E-05, 0.000E+00, 1.300E-04, -2.100E-04, -1.000E-05, -2.000E-05, -2.000E-05, -1.000E-05, -8.000E-05, 1.800E-04, -5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00, 7.146E-01, -1.007E+00, 3.932E-01, -9.246E-02, 1.366E-02, -1.540E-03, 6.856E-01, -9.828E-01, 3.977E-01, -9.795E-02, 1.540E-02, -1.790E-03, -3.053E-02, 2.758E-02, 2.150E-03, -4.880E-03, 1.640E-03, -2.500E-04, 9.200E-04, 4.200E-04, -1.340E-03, 4.600E-04, -8.000E-05, -1.000E-05, 4.230E-03, -5.660E-03, 2.140E-03, -4.300E-04, 6.000E-05, 0.000E+00, -3.890E-03, 5.000E-03, -1.740E-03, 3.300E-04, -4.000E-05, 0.000E+00/
  Data ((cdo(ip,is,1,1),is=1,6), ip=1, 3)/4.190E-01, 3.460E+00, 4.400E+00, 0.000E+00, 0.000E+00, 0.000E+00, 4.000E-03, 7.240E-01, -4.860E+00, 0.000E+00, 0.000E+00, 0.000E+00, -7.000E-03, -6.600E-02, 1.330E+00, 0.000E+00, 0.000E+00, 0.000E+00/
  Data ((cdo(ip,is,1,2),is=1,6), ip=1, 3)/3.740E-01, 3.330E+00, 6.030E+00, 0.000E+00, 0.000E+00, 0.000E+00, 1.400E-02, 7.530E-01, -6.220E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, -7.600E-02, 1.560E+00, 0.000E+00, 0.000E+00, 0.000E+00/
  Data ((cdo(ip,is,2,1),is=1,6), ip=1, 3)/7.630E-01, 4.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, -2.370E-01, 6.270E-01, -4.210E-01, 0.000E+00, 0.000E+00, 0.000E+00, 2.600E-02, -1.900E-02, 3.300E-02, 0.000E+00, 0.000E+00, 0.000E+00/
  Data ((cdo(ip,is,2,2),is=1,6), ip=1, 3)/7.610E-01, 3.830E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, -2.320E-01, 6.270E-01, -4.180E-01, 0.000E+00, 0.000E+00, 0.000E+00, 2.300E-02, -1.900E-02, 3.600E-02, 0.000E+00, 0.000E+00, 0.000E+00/
  Data ((cdo(ip,is,3,1),is=1,6), ip=1, 3)/1.265E+00, 0.000E+00, 8.050E+00, 0.000E+00, 0.000E+00, 0.000E+00, -1.132E+00, -3.720E-01, 1.590E+00, 6.310E+00, -1.050E+01, 1.470E+01, 2.930E-01, -2.900E-02, -1.530E-01, -2.730E-01, -3.170E+00, 9.800E+00/
  Data ((cdo(ip,is,3,2),is=1,6), ip=1, 3)/1.670E+00, 0.000E+00, 9.150E+00, 0.000E+00, 0.000E+00, 0.000E+00, -1.920E+00, -2.730E-01, 5.300E-01, 1.570E+01, -1.010E+02, 2.230E+02, 5.820E-01, -1.640E-01, -7.630E-01, -2.830E+00, 4.470E+01, -1.170E+02/
  Data ((cdo(ip,is,4,1),is=1,6), ip=1, 3)/0.000E+00, -3.600E-02, 6.350E+00, 0.000E+00, 0.000E+00, 0.000E+00, 1.350E-01, -2.220E-01, 3.260E+00, -3.030E+00, 1.740E+01, -1.790E+01, -7.500E-02, -5.800E-02, -9.090E-01, 1.500E+00, -1.130E+01, 1.560E+01/
  Data ((cdo(ip,is,4,2),is=1,6), ip=1, 3)/0.000E+00, -1.200E-01, 3.510E+00, 0.000E+00, 0.000E+00, 0.000E+00, 6.700E-02, -2.330E-01, 3.660E+00, -4.740E-01, 9.500E+00, -1.660E+01, -3.100E-02, -2.300E-02, -4.530E-01, 3.580E-01, -5.430E+00, 1.550E+01/
  Data ((cdo(ip,is,5,1),is=1,6), ip=1, 3)/1.560E+00, 0.000E+00, 6.000E+00, 9.000E+00, 0.000E+00, 0.000E+00, -1.710E+00, -9.490E-01, 1.440E+00, -7.190E+00, -1.650E+01, 1.530E+01, 6.380E-01, 3.250E-01, -1.050E+00, 2.550E-01, 1.090E+01, -1.010E+01/
  Data ((cdo(ip,is,5,2),is=1,6), ip=1, 3)/8.790E-01, 0.000E+00, 4.000E+00, 9.000E+00, 0.000E+00, 0.000E+00, -9.710E-01, -1.160E+00, 1.230E+00, -5.640E+00, -7.540E+00, -5.960E-01, 4.340E-01, 4.760E-01, -2.540E-01, -8.170E-01, 5.500E+00, 1.260E-01/
  Data ((cow(ip,is,1,1),is=1,5), ip=1, 3)/4.0000E-01, 7.0000E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00, -6.2120E-02, 6.4780E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00, -7.1090E-03, 1.3350E-02, 0.0000E+00, 0.0000E+00, 0.0000E+00/
  Data ((cow(ip,is,1,2),is=1,5), ip=1, 3)/4.0000E-01, 6.2800E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00, -5.9090E-02, 6.4360E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00, -6.5240E-03, 1.4510E-02, 0.0000E+00, 0.0000E+00, 0.0000E+00/
  Data ((cow(ip,is,2,1),is=1,5), ip=1, 3)/8.8800E-01, 0.0000E+00, 3.1100E+00, 6.0000E+00, 0.0000E+00, -1.8020E+00, -1.5760E+00, -1.3170E-01, 2.8010E+00, -1.7280E+01, 1.8120E+00, 1.2000E+00, 5.0680E-01, -1.2160E+01, 2.0490E+01/
  Data ((cow(ip,is,2,2),is=1,5), ip=1, 3)/7.9400E-01, 0.0000E+00, 2.8900E+00, 6.0000E+00, 0.0000E+00, -9.1440E-01, -1.2370E+00, 5.9660E-01, -3.6710E+00, -8.1910E+00, 5.9660E-01, 6.5820E-01, -2.5500E-01, -2.3040E+00, 7.7580E+00/
  Data ((cow(ip,is,3,1),is=1,5), ip=1, 3)/9.0000E-01, 0.0000E+00, 5.0000E+00, 0.0000E+00, 0.0000E+00, -2.4280E-01, -2.1200E-01, 8.6730E-01, 1.2660E+00, 2.3820E+00, 1.3860E-01, 3.6710E-03, 4.7470E-02, -2.2150E+00, 3.4820E-01/
  Data ((cow(ip,is,3,2),is=1,5), ip=1, 3)/9.0000E-01, 0.0000E+00, 5.0000E+00, 0.0000E+00, 0.0000E+00, -1.4170E-01, -1.6970E-01, -2.4740E+00, -2.5340E+00, 5.6210E-01, -1.7400E-01, -9.6230E-02, 1.5750E+00, 1.3780E+00, -2.7010E-01/
  Data ((cow(ip,is,4,1),is=1,5), ip=1, 3)/0.0000E+00, -2.2120E-02, 2.8940E+00, 0.0000E+00, 0.0000E+00, 7.9280E-02, -3.7850E-01, 9.4330E+00, 5.2480E+00, 8.3880E+00, -6.1340E-02, -1.0880E-01, -1.0852E+01, -7.1870E+00, -1.1610E+01/
  Data ((cow(ip,is,4,2),is=1,5), ip=1, 3)/0.0000E+00, -8.8200E-02, 1.9240E+00, 0.0000E+00, 0.0000E+00, 6.2290E-02, -2.8920E-01, 2.4240E-01, -4.4630E+00, -8.3670E-01, -4.0990E-02, -1.0820E-01, 2.0360E+00, 5.2090E+00, -4.8400E-02/
  alam = 0.
  Do kfl = -6, 6
    xpq(kfl) = 0.
  End Do
  If (x<0. .Or. x>1.) Then
    Write (mstu(11), 1000) x
    Return
  End If
  kfa = iabs(kf)
  If (kfa/=211 .And. kfa/=2212 .And. kfa/=2112) Then
    Write (mstu(11), 1100) kf
    Return
  End If
  If (mstp(51)==0 .Or. mstp(52)>=2) Then
    kfe = kfa
    If (kfa==2112) kfe = 2212
    Call pystfe(kfe, x, q2, xpq)
    Goto 230
  End If
  If (kfa==211) Goto 200
  If (mstp(51)==1 .Or. mstp(51)==2) Then
    nset = mstp(51)
    If (nset==1) alam = 0.2
    If (nset==2) alam = 0.29
    tmin = log(5./alam**2)
    tmax = log(1E8/alam**2)
    If (mstp(52)==0) Then
      t = tmin
    Else
      t = log(q2/alam**2)
    End If
    vt = max(-1., min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
    nx = 1
    If (x<=0.1) nx = 2
    If (nx==1) vx = (2.*x-1.1)/0.9
    If (nx==2) vx = max(-1., (2.*log(x)+11.51293)/6.90776)
    cxs = 1.
    If (x<1E-4 .And. abs(parp(51)-1.)>0.01) cxs = (1E-4/x)**(parp(51)-1.)
    tx(1) = 1.
    tx(2) = vx
    tx(3) = 2.*vx**2 - 1.
    tx(4) = 4.*vx**3 - 3.*vx
    tx(5) = 8.*vx**4 - 8.*vx**2 + 1.
    tx(6) = 16.*vx**5 - 20.*vx**3 + 5.*vx
    tt(1) = 1.
    tt(2) = vt
    tt(3) = 2.*vt**2 - 1.
    tt(4) = 4.*vt**3 - 3.*vt
    tt(5) = 8.*vt**4 - 8.*vt**2 + 1.
    tt(6) = 16.*vt**5 - 20.*vt**3 + 5.*vt
    Do kfl = 1, 6
      xqsum = 0.
      Do it = 1, 6
        Do ix = 1, 6
          xqsum = xqsum + cehlq(ix, it, nx, kfl, nset)*tx(ix)*tt(it)
        End Do
      End Do
      xq(kfl) = xqsum*(1.-x)**nehlq(kfl, nset)*cxs
    End Do
    xpq(0) = xq(4)
    xpq(1) = xq(2) + xq(3)
    xpq(2) = xq(1) + xq(3)
    xpq(3) = xq(5)
    xpq(4) = xq(6)
    xpq(-1) = xq(3)
    xpq(-2) = xq(3)
    xpq(-3) = xq(5)
    xpq(-4) = xq(6)
    If (mstp(54)>=5) Then
      If (nset==1) tmin = 8.1905
      If (nset==2) tmin = 7.4474
      If (t<=tmin) Goto 140
      vt = max(-1., min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
      tt(1) = 1.
      tt(2) = vt
      tt(3) = 2.*vt**2 - 1.
      tt(4) = 4.*vt**3 - 3.*vt
      tt(5) = 8.*vt**4 - 8.*vt**2 + 1.
      tt(6) = 16.*vt**5 - 20.*vt**3 + 5.*vt
      xqsum = 0.
      Do it = 1, 6
        Do ix = 1, 6
          xqsum = xqsum + cehlq(ix, it, nx, 7, nset)*tx(ix)*tt(it)
        End Do
      End Do
      xpq(5) = xqsum*(1.-x)**nehlq(7, nset)
      xpq(-5) = xpq(5)
      140 Continue
    End If
    If (mstp(54)>=6) Then
      If (nset==1) tmin = 11.5528
      If (nset==2) tmin = 10.8097
      tmin = tmin + 2.*log(pmas(6,1)/30.)
      tmax = tmax + 2.*log(pmas(6,1)/30.)
      If (t<=tmin) Goto 160
      vt = max(-1., min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
      tt(1) = 1.
      tt(2) = vt
      tt(3) = 2.*vt**2 - 1.
      tt(4) = 4.*vt**3 - 3.*vt
      tt(5) = 8.*vt**4 - 8.*vt**2 + 1.
      tt(6) = 16.*vt**5 - 20.*vt**3 + 5.*vt
      xqsum = 0.
      Do it = 1, 6
        Do ix = 1, 6
          xqsum = xqsum + cehlq(ix, it, nx, 8, nset)*tx(ix)*tt(it)
        End Do
      End Do
      xpq(6) = xqsum*(1.-x)**nehlq(8, nset)
      xpq(-6) = xpq(6)
      160 Continue
    End If
  Else If (mstp(51)==3 .Or. mstp(51)==4) Then
    nset = mstp(51) - 2
    If (nset==1) alam = 0.2
    If (nset==2) alam = 0.4
    If (mstp(52)<=0) Then
      sd = 0.
    Else
      sd = log(log(max(q2,4.)/alam**2)/log(4./alam**2))
    End If
    Do kfl = 1, 5
      Do is = 1, 6
        ts(is) = cdo(1, is, kfl, nset) + cdo(2, is, kfl, nset)*sd + cdo(3, is, kfl, nset)*sd**2
      End Do
      If (kfl<=2) Then
        eulbt1 = pygamm(ts(1))*pygamm(ts(2)+1.)/pygamm(ts(1)+ts(2)+1.)
        xq(kfl) = x**ts(1)*(1.-x)**ts(2)*(1.+ts(3)*x)/(eulbt1*(1.+ts(3)*ts(1)/(ts(1)+ts(2)+1.)))
      Else
        xq(kfl) = ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**2+ts(6)*x**3)
      End If
    End Do
    xpq(0) = xq(5)
    xpq(1) = xq(2) + xq(3)/6.
    xpq(2) = 3.*xq(1) - xq(2) + xq(3)/6.
    xpq(3) = xq(3)/6.
    xpq(4) = xq(4)
    xpq(-1) = xq(3)/6.
    xpq(-2) = xq(3)/6.
    xpq(-3) = xq(3)/6.
    xpq(-4) = xq(4)
  Else If (mstp(51)>=11 .And. mstp(51)<=13) Then
    Call pystfe(2212, x, q2, xpq)
  Else
    Write (mstu(11), 1200) mstp(51)
  End If
  Goto 230
  200 If ((mstp(51)>=1 .And. mstp(51)<=4) .Or. (mstp(51)>=11 .And. mstp(51)<=13)) Then
    nset = 1
    If (mstp(51)==2 .Or. mstp(51)==4 .Or. mstp(51)==13) nset = 2
    If (nset==1) alam = 0.2
    If (nset==2) alam = 0.4
    If (mstp(52)<=0) Then
      sd = 0.
    Else
      sd = log(log(max(q2,4.)/alam**2)/log(4./alam**2))
    End If
    Do kfl = 1, 4
      Do is = 1, 5
        ts(is) = cow(1, is, kfl, nset) + cow(2, is, kfl, nset)*sd + cow(3, is, kfl, nset)*sd**2
      End Do
      If (kfl==1) Then
        eulbt2 = pygamm(ts(1))*pygamm(ts(2)+1.)/pygamm(ts(1)+ts(2)+1.)
        xq(kfl) = x**ts(1)*(1.-x)**ts(2)/eulbt2
      Else
        xq(kfl) = ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**2)
      End If
    End Do
    xpq(0) = xq(2)
    xpq(1) = xq(3)/6.
    xpq(2) = xq(1) + xq(3)/6.
    xpq(3) = xq(3)/6.
    xpq(4) = xq(4)
    xpq(-1) = xq(1) + xq(3)/6.
    xpq(-2) = xq(3)/6.
    xpq(-3) = xq(3)/6.
    xpq(-4) = xq(4)
  Else
    Write (mstu(11), 1200) mstp(51)
  End If
  230 If (kfa==2112) Then
    xps = xpq(1)
    xpq(1) = xpq(2)
    xpq(2) = xps
    xps = xpq(-1)
    xpq(-1) = xpq(-2)
    xpq(-2) = xps
  End If
  If (kf<0) Then
    Do kfl = 1, 4
      xps = xpq(kfl)
      xpq(kfl) = xpq(-kfl)
      xpq(-kfl) = xps
    End Do
  End If
  Do kfl = -6, 6
    xpq(kfl) = max(0., xpq(kfl))
    If (iabs(kfl)>mstp(54)) xpq(kfl) = 0.
  End Do
  If ((jbt/=1 .And. jbt/=2) .Or. ihpr2(6)==0 .Or. ihnt2(16)==1) Goto 400
  atnm = ihnt2(2*jbt-1)
  If (atnm<=1.0) Goto 400
  If (jbt==1) Then
    bbr2 = (yp(1,ihnt2(11))**2+yp(2,ihnt2(11))**2)/1.44/atnm**0.66666
  Else If (jbt==2) Then
    bbr2 = (yt(1,ihnt2(12))**2+yt(2,ihnt2(12))**2)/1.44/atnm**0.66666
  End If
  bbr2 = min(1.0, bbr2)
  abx = (atnm**0.33333333-1.0)
  apx = hipr1(6)*4.0/3.0*abx*sqrt(1.0-bbr2)
  aax = 1.192*alog(atnm)**0.1666666
  rrx = aax*(x**3-1.2*x**2+0.21*x) + 1.0 - (apx-1.079*abx*sqrt(x)/alog(atnm+1.0))*exp(-x**2.0/0.01)
  Do kfl = -6, 6
    xpq(kfl) = xpq(kfl)*rrx
  End Do
  400 Continue
  Return
  1000 Format (' Error: x value outside physical range, x =', 1P, E12.3)
  1100 Format (' Error: illegal particle code for structure function,', ' KF =', I5)
  1200 Format (' Error: bad value of parameter MSTP(51) in PYSTFU,', ' MSTP(51) =', I5)
End Subroutine pystfu


! converts a restart file from CICE 4.1 to 5.0 format
! single processor (not parallelized)
! core restarts only (not including tracers except Tsfc)

! search for "modify as needed" to find potential configuration changes.
! NB: restarts will likely work only for exactly the same configuration
!     (BL99 thermo in particular).

! intel compiler:
! ifort convert_restarts.f90 -o convert_restarts -i4 -r8 -convert big_endian -assume byterecl

      program convert_restarts

      implicit none

      integer, parameter :: char_len_long  = 256, &
                            log_kind  = kind(.true.), &
                            int_kind  = selected_int_kind(6), &
                            dbl_kind  = selected_real_kind(13)

!!!!!!! modify as needed (begin)
      ! these values are for the standard gx1 configuration
      integer (kind=int_kind), parameter :: &
                            ncat = 5, &       ! number of thickness cats
                            nilyr = 4, &      ! number of ice layers
                            nslyr = 1, &      ! number of snow layers
                            nx_block = 320, & ! global grid size
                            ny_block = 384

      ! these values are for the standard gx3 configuration
!      integer (kind=int_kind), parameter :: &
!                            ncat = 5, &       ! number of thickness cats
!                            nilyr = 4, &      ! number of ice layers
!                            nslyr = 1, &      ! number of snow layers
!                            nx_block = 100, & ! global grid size
!                            ny_block = 116

      ! flags
      logical (kind=log_kind), parameter :: &
         oceanmixed_ice = .true., & ! if true, read/write ocean mixed layer fields
         heat_capacity  = .true., & ! if true, ice has nonzero heat capacity
                                    ! if false, use zero-layer thermodynamics
         diag = .true.              ! write min/max diagnostics for fields

      ! file names
      character (len=char_len_long), parameter :: &
         iced_4_1 = '/scratch/eclare/tmp/restarts/iced_gx1_v4.0_kcatbound0', &  ! gx1
         iced_5_0 = '/scratch/eclare/tmp/restarts/iced_gx1_v4.0_kcatbound0_converted'
!         iced_4_1 = 'iced_gx3_v4.0_kcatbound0', &  ! gx3
!         iced_5_0 = 'iced_gx3_v4.0_kcatbound0_converted''

!!!!!!! modify as needed (end)

      ! array sizes
      integer (kind=int_kind), parameter :: &
         ntilyr    = ncat*nilyr, & ! number of ice layers in all categories
         ntslyr    = ncat*nslyr, & ! number of snow layers in all categories
         max_ntrcr =   1         & ! 1 = surface temperature
                   + nilyr       & ! ice salinity
                   + nilyr       & ! ice enthalpy
                   + nslyr         ! snow enthalpy

      integer (kind=int_kind), dimension(ncat) :: &
         ilyr1          , & ! starting ice layer number for each category
         slyr1              ! starting snow layer number for each category

      integer (kind=int_kind) :: &
         ntrcr          , & ! number of required tracers
         i,j,n,k,m          ! indices

      ! tracer indices
      integer (kind=int_kind) :: &
         nt_Tsfc  , & ! ice/snow temperature
         nt_qice  , & ! volume-weighted ice enthalpy (in layers)
         nt_qsno  , & ! volume-weighted snow enthalpy (in layers)
         nt_sice      ! volume-weighted ice bulk salinity (CICE grid layers)

      ! time info
      integer (kind=int_kind) :: &
         istep1    ! counter, number of steps at current timestep

      real (kind=dbl_kind) :: &
         time           , & ! total elapsed time (s)
         time_forc          ! time of last forcing update (s)

      ! restart fields
      real (kind=dbl_kind), &
         dimension (nx_block,ny_block,ncat) :: &
         aicen , & ! concentration of ice
         vicen , & ! volume per unit area of ice          (m)
         vsnon     ! volume per unit area of snow         (m)

      real (kind=dbl_kind), &
         dimension (nx_block,ny_block,max_ntrcr,ncat) :: &
         trcrn     ! tracers
                   ! 1: surface temperature of ice/snow (C)

      real (kind=dbl_kind), &
         dimension (nx_block,ny_block,ntilyr) :: &
         eicen     ! energy of melting for each ice layer  (J/m^2)

      real (kind=dbl_kind), &
         dimension (nx_block,ny_block,ntslyr) :: &
         esnon     ! energy of melting for each snow layer (J/m^2)

      real (kind=dbl_kind), dimension(nx_block,ny_block) :: &
         uvel    , & ! x-component of velocity (m/s)
         vvel    , & ! y-component of velocity (m/s)
         swvdr   , & ! sw down, visible, direct  (W/m^2)
         swvdf   , & ! sw down, visible, diffuse (W/m^2)
         swidr   , & ! sw down, near IR, direct  (W/m^2)
         swidf   , & ! sw down, near IR, diffuse (W/m^2)
         scale_factor, &! scaling factor for shortwave components
         strocnxT, & ! ice-ocean stress, x-direction
         strocnyT, & ! ice-ocean stress, y-direction
         stressp_1, stressp_2, stressp_3, stressp_4 , & ! sigma11+sigma22
         stressm_1, stressm_2, stressm_3, stressm_4 , & ! sigma11-sigma22
         stress12_1,stress12_2,stress12_3,stress12_4, & ! sigma12
         sst     , & ! sea surface temperature (C)
         frzmlt  , & ! freezing/melting potential (W/m^2)
         iceumask    ! ice extent mask (U-cell)

      ! flags
      logical (kind=log_kind) :: &
         l_brine     ! if true, treat brine pocket effects

      ! numbers
      real (kind=dbl_kind), parameter :: &
         spval_dbl = 1.0e30_dbl_kind, & ! special value (double precision)
         puny = 1.0e-11_dbl_kind, &
         pi   = 3.14159265358979323846_dbl_kind,&! pi
         c0   = 0.0_dbl_kind, &
         c1   = 1.0_dbl_kind, &
         c2   = 2.0_dbl_kind, &
         p5   = 0.5_dbl_kind

      ! physical parameters
      real (kind=dbl_kind), parameter :: &
         Lsub      = 2.835e6_dbl_kind ,&! latent heat, sublimation freshwater (J/kg)
         Lvap      = 2.501e6_dbl_kind ,&! latent heat, vaporization freshwater (J/kg)
         Lfresh    = Lsub-Lvap        ,&! latent heat of melting of fresh ice (J/kg)
         cp_ice    = 2106._dbl_kind   ,&! specific heat of fresh ice (J/kg/K)
         rhos      = 330.0_dbl_kind   ,&! density of snow (kg/m^3)
         hs_min  = 1.e-4_dbl_kind, &  ! min snow thickness for computing Tsno (m)
         nsal    = 0.407_dbl_kind, &
         msal    = 0.573_dbl_kind, &
         min_salin = 0.1_dbl_kind, &  ! threshold for brine pocket treatment
         saltmax = 3.2_dbl_kind       ! max salinity at ice base (ppt)

      ! useful temps
      real (kind=dbl_kind), dimension(nilyr+1) :: &
         salin       ! initial salinity  profile (ppt)

      real (kind=dbl_kind)    :: &
         Tmin, Tmax,    & ! min and max snow temperature
         zTsn,          & ! snow temperature
         zn,            & ! thickness
         rnslyr,        & ! real(nslyr)
         rnilyr           ! real(nilyr)

      ! count tracers
         nt_Tsfc = 1           ! index tracers, starting with Tsfc = 1
         ntrcr = 1             ! count tracers, starting with Tsfc = 1
         nt_qice = ntrcr + 1
         ntrcr = ntrcr + nilyr ! qice in nilyr layers
         nt_qsno = ntrcr + 1
         ntrcr = ntrcr + nslyr ! qsno in nslyr layers
         nt_sice = ntrcr + 1
         ntrcr = ntrcr + nilyr ! sice in nilyr layers
         if (ntrcr /= max_ntrcr) write (*,*) 'Tracer number mismatch'

      ! ice salinity profile
      if (saltmax > min_salin .and. heat_capacity) then
         l_brine = .true.
      else
         l_brine = .false.
      endif

      if (l_brine) then
         do k = 1, nilyr
            zn = (real(k,kind=dbl_kind)-p5) /  &
                  real(nilyr,kind=dbl_kind)
            salin(k)=(saltmax/c2)*(c1-cos(pi*zn**(nsal/(msal+zn))))
!            salin(k)=saltmax ! for isosaline ice ! modify as needed
         enddo
         salin(nilyr+1) = saltmax
      else
         do k = 1, nilyr+1
            salin(k) = c0
         enddo
      endif
      do k = 1, nilyr
         trcrn(:,:,nt_sice+k-1,:) = salin(k)
      enddo

      ! read cice 4.1 restart data
      call restartfile_4_1 (iced_4_1)

      ! convert eicen, esnon to qicen, qsnon
      ilyr1(1) = 1
      slyr1(1) = 1
      do n = 2, ncat
         ilyr1(n) = ilyr1(n-1) + nilyr
         slyr1(n) = slyr1(n-1) + nslyr
      enddo

      rnslyr = real(nslyr, kind=dbl_kind)
      rnilyr = real(nilyr, kind=dbl_kind)
      Tmin = -100.  ! minimum allowed snow temperature
      do j = 1, ny_block
      do i = 1, nx_block
      do n = 1, ncat
      if (aicen(i,j,n) > puny) then
      if (vsnon(i,j,n)/aicen(i,j,n) > hs_min) then
         do k = 1, nslyr
            ! qsn, esnon < 0
            trcrn(i,j,nt_qsno+k-1,n) = &
               min(esnon(i,j,slyr1(n)+k-1)*rnslyr/vsnon(i,j,n),-rhos*Lfresh)
            Tmax = -trcrn(i,j,nt_qsno+k-1,n)*puny*rnslyr/(rhos*cp_ice*vsnon(i,j,n))
            if (.not. heat_capacity) then
               trcrn(i,j,nt_qsno+k-1,n) = -rhos * Lfresh
               Tmax = puny
            endif
!!!!!!! modify as needed (begin)
! if your restarts do not work, try uncommenting this section
!            ! snow temperature
!            zTsn = (Lfresh + trcrn(i,j,nt_qsno+k-1,n)/rhos)/cp_ice
!            ! zap entire snow volume if temperature is out of bounds
!            if (zTsn < Tmin .or. zTsn > Tmax) then
!               print*, 'zapping snow volume ', i,j,n,vsnon(i,j,n)
!               vsnon(i,j,n) = c0
!               do m = 1, nslyr
!                  trcrn(i,j,nt_qsno+m-1,n) = c0
!               enddo
!            endif
!!!!!!! modify as needed (begin)
         enddo
      else
         vsnon(i,j,n) = c0
         do k = 1, nslyr
            trcrn(i,j,nt_qsno+k-1,n) = c0
         enddo
      endif
      endif
      do k = 1, nilyr
!         if (vicen(i,j,n) > puny) then
         if (aicen(i,j,n) > puny) then  ! matches v4.1
            trcrn(i,j,nt_qice+k-1,n) = eicen(i,j,ilyr1(n)+k-1)*rnilyr/vicen(i,j,n)
         else
            trcrn(i,j,nt_qice+k-1,n) = c0
         endif
      enddo
      enddo
      enddo
      enddo

      ! write cice 5.0 restart data
      call dumpfile_5_0 (iced_5_0)

!=======================================================================

      contains

!=======================================================================
!---! these subroutines write/read Fortran unformatted data files
!=======================================================================

      subroutine restartfile_4_1 (ice_ic)

      character (*) :: ice_ic

      integer (kind=int_kind) :: i, j, k, n

      character(len=char_len_long) :: &
         filename

      integer (kind=int_kind), parameter :: nu_restart = 20

         filename = ice_ic
         open(nu_restart,file=filename,form='unformatted')

         write(*,*) 'Using restart dump=', trim(filename)
         read (nu_restart) istep1,time,time_forc
         write(*,*) 'Restart read at istep=',istep1,time,time_forc

      !-----------------------------------------------------------------
      ! state variables
      ! Tsfc is the only tracer read in this file.  All other
      ! tracers are in their own dump/restart files.
      !-----------------------------------------------------------------
      do n=1,ncat
              write(*,*) 'cat ',n, &
                               ' min/max area, vol ice, vol snow, Tsfc'

         call ice_read(nu_restart,aicen(:,:,n),diag)
         call ice_read(nu_restart,vicen(:,:,n),diag)
         call ice_read(nu_restart,vsnon(:,:,n),diag)
         call ice_read(nu_restart,trcrn(:,:,nt_Tsfc,n),diag)
      enddo

           write(*,*) 'min/max eicen for each layer'
      do k=1,ntilyr
         call ice_read(nu_restart,eicen(:,:,k),diag)
      enddo

           write(*,*) 'min/max esnon for each layer'
      do k=1,ntslyr
         call ice_read(nu_restart,esnon(:,:,k),diag)
      enddo

      !-----------------------------------------------------------------
      ! velocity
      !-----------------------------------------------------------------
           write(*,*) 'min/max velocity components'

      call ice_read(nu_restart,uvel,diag)
      call ice_read(nu_restart,vvel,diag)

      !-----------------------------------------------------------------
      ! radiation fields
      !-----------------------------------------------------------------
         write(*,*) 'radiation fields'

      call ice_read(nu_restart,scale_factor,diag)
      call ice_read(nu_restart,swvdr,diag)
      call ice_read(nu_restart,swvdf,diag)
      call ice_read(nu_restart,swidr,diag)
      call ice_read(nu_restart,swidf,diag)

      !-----------------------------------------------------------------
      ! ocean stress
      !-----------------------------------------------------------------
           write(*,*) 'min/max ocean stress components'

      call ice_read(nu_restart,strocnxT,diag)
      call ice_read(nu_restart,strocnyT,diag)

      !-----------------------------------------------------------------
      ! internal stress
      !-----------------------------------------------------------------
           write(*,*) 'internal stress components'

      call ice_read(nu_restart,stressp_1,diag) ! stressp_1
      call ice_read(nu_restart,stressp_3,diag) ! stressp_3

      call ice_read(nu_restart,stressp_2,diag) ! stressp_2
      call ice_read(nu_restart,stressp_4,diag) ! stressp_4

      call ice_read(nu_restart,stressm_1,diag) ! stressm_1
      call ice_read(nu_restart,stressm_3,diag) ! stressm_3

      call ice_read(nu_restart,stressm_2,diag) ! stressm_2
      call ice_read(nu_restart,stressm_4,diag) ! stressm_4

      call ice_read(nu_restart,stress12_1,diag) ! stress12_1
      call ice_read(nu_restart,stress12_3,diag) ! stress12_3

      call ice_read(nu_restart,stress12_2,diag) ! stress12_2
      call ice_read(nu_restart,stress12_4,diag) ! stress12_4

      !-----------------------------------------------------------------
      ! ice mask for dynamics
      !-----------------------------------------------------------------
           write(*,*) 'ice mask for dynamics'

      call ice_read(nu_restart,iceumask,diag)

      ! for mixed layer model
      if (oceanmixed_ice) then
              write(*,*) 'min/max sst, frzmlt'

         call ice_read(nu_restart,sst,diag)
         call ice_read(nu_restart,frzmlt,diag)
      endif

      !-----------------------------------------------------------------
      ! mask out all-land blocks
      !-----------------------------------------------------------------
      where (aicen        > 0.5*spval_dbl) aicen        = c0
      where (vicen        > 0.5*spval_dbl) vicen        = c0
      where (vsnon        > 0.5*spval_dbl) vsnon        = c0
      where (trcrn        > 0.5*spval_dbl) trcrn        = c0
      where (eicen        > 0.5*spval_dbl) eicen        = c0
      where (esnon        > 0.5*spval_dbl) esnon        = c0
      where (uvel         > 0.5*spval_dbl) uvel         = c0
      where (vvel         > 0.5*spval_dbl) vvel         = c0
      where (scale_factor > 0.5*spval_dbl) scale_factor = c0
      where (swvdr        > 0.5*spval_dbl) swvdr        = c0
      where (swvdf        > 0.5*spval_dbl) swvdf        = c0
      where (swidr        > 0.5*spval_dbl) swidr        = c0
      where (swidf        > 0.5*spval_dbl) swidf        = c0
      where (strocnxT     > 0.5*spval_dbl) strocnxT     = c0
      where (strocnyT     > 0.5*spval_dbl) strocnyT     = c0
      where (stressp_1    > 0.5*spval_dbl) stressp_1    = c0
      where (stressp_2    > 0.5*spval_dbl) stressp_2    = c0
      where (stressp_3    > 0.5*spval_dbl) stressp_3    = c0
      where (stressp_4    > 0.5*spval_dbl) stressp_4    = c0
      where (stressm_1    > 0.5*spval_dbl) stressm_1    = c0
      where (stressm_2    > 0.5*spval_dbl) stressm_2    = c0
      where (stressm_3    > 0.5*spval_dbl) stressm_3    = c0
      where (stressm_4    > 0.5*spval_dbl) stressm_4    = c0
      where (stress12_1   > 0.5*spval_dbl) stress12_1   = c0
      where (stress12_2   > 0.5*spval_dbl) stress12_2   = c0
      where (stress12_3   > 0.5*spval_dbl) stress12_3   = c0
      where (stress12_4   > 0.5*spval_dbl) stress12_4   = c0
      where (iceumask     > 0.5*spval_dbl) iceumask     = c0
      if (oceanmixed_ice) then
         where (sst       > 0.5*spval_dbl) sst          = c0
         where (frzmlt    > 0.5*spval_dbl) frzmlt       = c0
      endif

      close(nu_restart)

      end subroutine restartfile_4_1

!=======================================================================

      subroutine dumpfile_5_0(filename_spec)

      character(len=char_len_long), intent(in) :: filename_spec

      integer (kind=int_kind) :: i, j, k, n

      character(len=char_len_long) :: filename

      integer (kind=int_kind), parameter :: nu_dump = 21

        filename = trim(filename_spec)
        open(nu_dump,file=filename,form='unformatted')

        write(nu_dump) istep1,time,time_forc
        write(*,*) 'Writing ',trim(filename)
        write(*,*) 'Restart written ',istep1,time,time_forc

      !-----------------------------------------------------------------
      ! state variables
      ! Tsfc is the only tracer written to this file.  All other
      ! tracers are written to their own dump/restart files.
      !-----------------------------------------------------------------

      do n=1,ncat
              write(*,*) 'cat ',n, &
                               ' min/max area, vol ice, vol snow, Tsfc'

         call ice_write(nu_dump,aicen(:,:,n),diag)
         call ice_write(nu_dump,vicen(:,:,n),diag)
         call ice_write(nu_dump,vsnon(:,:,n),diag)
         call ice_write(nu_dump,trcrn(:,:,nt_Tsfc,n),diag)

           write(*,*) 'min/max sicen for each layer'
         do k=1,nilyr
            call ice_write(nu_dump,trcrn(:,:,nt_sice+k-1,n),diag)
         enddo

           write(*,*) 'min/max qicen for each layer'
         do k=1,nilyr
            call ice_write(nu_dump,trcrn(:,:,nt_qice+k-1,n),diag)
         enddo

           write(*,*) 'min/max qsnon for each layer'
         do k=1,nslyr
            call ice_write(nu_dump,trcrn(:,:,nt_qsno+k-1,n),diag)
         enddo
      enddo ! ncat

      !-----------------------------------------------------------------
      ! velocity
      !-----------------------------------------------------------------
           write(*,*) 'min/max velocity components'

      call ice_write(nu_dump,uvel,diag)
      call ice_write(nu_dump,vvel,diag)

      !-----------------------------------------------------------------
      ! radiation fields
      !-----------------------------------------------------------------
         write(*,*) 'radiation fields'

      call ice_write(nu_dump,scale_factor,diag)
      call ice_write(nu_dump,swvdr,diag)
      call ice_write(nu_dump,swvdf,diag)
      call ice_write(nu_dump,swidr,diag)
      call ice_write(nu_dump,swidf,diag)

      !-----------------------------------------------------------------
      ! ocean stress (for bottom heat flux in thermo)
      !-----------------------------------------------------------------
           write(*,*) 'min/max ocean stress components'

      call ice_write(nu_dump,strocnxT,diag)
      call ice_write(nu_dump,strocnyT,diag)

      !-----------------------------------------------------------------
      ! internal stress
      !-----------------------------------------------------------------
           write(*,*) 'internal stress components'

      call ice_write(nu_dump,stressp_1,diag)
      call ice_write(nu_dump,stressp_3,diag)
      call ice_write(nu_dump,stressp_2,diag)
      call ice_write(nu_dump,stressp_4,diag)

      call ice_write(nu_dump,stressm_1,diag)
      call ice_write(nu_dump,stressm_3,diag)
      call ice_write(nu_dump,stressm_2,diag)
      call ice_write(nu_dump,stressm_4,diag)

      call ice_write(nu_dump,stress12_1,diag)
      call ice_write(nu_dump,stress12_3,diag)
      call ice_write(nu_dump,stress12_2,diag)
      call ice_write(nu_dump,stress12_4,diag)

      !-----------------------------------------------------------------
      ! ice mask for dynamics
      !-----------------------------------------------------------------
           write(*,*) 'ice mask for dynamics'

      call ice_write(nu_dump,iceumask,diag)

      ! for mixed layer model
      if (oceanmixed_ice) then
              write(*,*) 'min/max sst, frzmlt'

         call ice_write(nu_dump,sst,diag)
         call ice_write(nu_dump,frzmlt,diag)
      endif

      close(nu_dump)

      end subroutine dumpfile_5_0

!=======================================================================

      subroutine ice_read(nu, work_g1, diag)

      integer (kind=int_kind), intent(in) :: &
           nu                ! unit number

      real (kind=dbl_kind), dimension(nx_block,ny_block), &
           intent(out) :: &
           work_g1           ! output array (real, 8-byte)

      logical (kind=log_kind), intent(in) :: &
           diag              ! if true, write diagnostic output

      integer (kind=int_kind) :: i, j

      real (kind=dbl_kind) :: &
         amin, amax         ! min and max values of input array

               read(nu) ((work_g1(i,j),i=1,nx_block),j=1,ny_block)

      if (diag) then
         amin = minval(work_g1)
         amax = maxval(work_g1, mask = work_g1 /= spval_dbl)
         write(*,*) ' read_global ',nu, amin, amax
      endif

      end subroutine ice_read

!=======================================================================

      subroutine ice_write(nu, work_g1, diag)

      integer (kind=int_kind), intent(in) :: &
           nu                ! unit number

      real (kind=dbl_kind), dimension(nx_block,ny_block), &
           intent(in) :: &
           work_g1           ! input array (real, 8-byte)

      logical (kind=log_kind), intent(in) :: &
           diag              ! if true, write diagnostic output
!
      integer (kind=int_kind) :: i, j

      real (kind=dbl_kind) :: &
         amin, amax     ! min and max values of ouput array

            write(nu) ((work_g1(i,j),i=1,nx_block),j=1,ny_block)

         if (diag) then
            amin = minval(work_g1)
            amax = maxval(work_g1)
            write(*,*) ' write_global ', nu, amin, amax
         endif

      end subroutine ice_write

!=======================================================================

      end program convert_restarts

!=======================================================================