      SUBROUTINE W3XTOVSMND (IBUFTN,JFLAG)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  W3XTOVSMND
C   PRGMMR: KEYSER           ORG: NP22        DATE: 2013-02-14
C
C ABSTRACT: COMPUTES MANDATORY LEVEL HEIGHTS (ACTUALLY THICKNESSES TO
C   1000 MB) AND TEMPERATURES FROM RTOVS OR ATOVS MEAN-LAYER VIRTUAL
C   TEMPERATURE INFORMATION FOR A REPORT PRESENTED IN UNPACKED NMCEDS
C   FORMAT. THE UNPACKED NMCEDS FORMAT IS FILLED ONLY WITH THOSE
C   VALUES NEEDED FOR RTOVS OR ATOVS PROCESSING BY THE PREPDATA
C   PROGRAM.
C
C PROGRAM HISTORY LOG:
C 1979-05-01  D. G. MARKS ---- W/NMC421
C 1988-11-16  R. A. PETERSEN - W/NMC22 - CORRECTED AN ERROR WHICH LED
C        TO SYSTEMATIC WARM BIAS IN LAYERS BETWEEN 300 AND 100 MB.
C 1988-11-23  M. FARLEY      - W/NMC42 - INCORPORATED PETERSEN CHANGES
C        INTO FORTRAN77 VERSION OF W3FA07.
C 1990-01-16  D. A. KEYSER --- W/NMC22 - STREAMLINED; CORRECTED ERRORS
C        IN DO-LOOP INDEXING IN FORTRAN77; GENERALIZED FOR DMSP.
C 1992-05-01  D. A. KEYSER --- W/NMC22 - CONVERT TO CRAY CFT77 FORTRAN
C 1998-02-17  D. A. KEYSER --- NP22 ---- INPUT ARGUMENT CONTAINING
C        UNPACKED NMCEDS FORMAT FOR A REPORT NOW FULL INTEGER WORDS
C        RATHER THAN PACKED 16-BIT WORDS (THIS HAD BEEN NEEDED TO
C        ALLOW THIS SUBR. TO BE HDS/CRAY PORTABLE)
C 1998-06-15  D. A. KEYSER -- RENAMED FROM W3FA07 TO AVOID CONFUSION
C        WITH EXISTING W3LIB ROUTINE; ADAPTED FOR USE ONLY WITH RTOVS
C        DATA (AFTER TOVS DEMISE) (I.E., NO TROP DATA PROCESSED);
C        OTHERWISE STREAMLINED
C 1998-09-21  D. A. KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90
C        COMPLIANT
C 1999-01-20 D. A. KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED
C        TO PORT THE CODE TO THE IBM SP
C 1999-11-19  D. A. KEYSER -- INCLUDES NOAA-15 ATOVS DATA (AS WELL AS
C        RTOVS DATA); RENAMED SUBROUTINE
C 2012-11-30  J. WOOLLEN  INITIAL PORT TO WCOSS 
C 2013-02-14  D. A. KEYSER -- FINAL CHANGES TO RUN ON WCOSS
C
C USAGE:    CALL W3XTOVSMND(IBUFTN,JFLAG)
C   INPUT ARGUMENT LIST:
C     IBUFTN   - ADDRESS HOLDING A SINGLE RTOVS OR ATOVS REPORT
C              - (140 FULL - INTEGER WORDS) IN UNPACKED NMCEDS FORMAT 
C              - (THE - UNPACKED NMCEDS FORMAT IS FILLED ONLY WITH THOSE
C              - VALUES NEEDED FOR RTOVS OR ATOVS PROCESSING BY THE
C              - PREPDATA PROGRAM)
C
C   OUTPUT ARGUMENT LIST:
C     JFLAG    - INTEGER RETURN CODE:
C                  = 0 ==> REPORT PROCESSED
C                  > 0 ==> REPORT NOT PROCESSED DUE TO:
C                     = 1 ==> ALL PRESSURE VALUES ARE MISSING
C                     = 2 ==> THERE ARE NO VALID PRESSURE LAYERS
C                     = 3 ==> A PRESSURE VALUE FAILED GROSS CHECK
C                     = 4 ==> A MEAN LAYER V. TEMP FAILED GROSS CHECK
C                     = 5 ==> FIRST VALID PRESS. LVL ON OR ABOVE 10 MB
C                     = 6 ==> THERE ARE NO VALID PRESSURE LEVELS
C                     = 7 ==> AT LEAST 1 MISSING OR INCONSISTENT LAYER
C                             BETWEEN THE BOTTOM & TOP SPANNING P-LVLS
C
C REMARKS: CURRENTLY CALLED ONLY BY PROGRAM PREPDATA.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C
      REAL  SLNP(20),EXNS(20),XLVLS(21),EXNER(20),XLNP(20),Q(15),
     $ TXXX(20),ZZ(20),TBARX(19),TBAR(15),SPMID(15),PMID(19)
C
      INTEGER  IP1(15),IP2(15),LVLS(15),IZFX(5),ISLRPT(20),IBUFTN(140)
C
      COMMON/FA07AA/TM(20),Z(20),MLVLS
C
      SAVE
C
      DATA XLVLS/1000.,850.,700.,500.,400.,300.,250.,200.,150.,100.,70.,
     $             50., 30., 20., 10.,  7.,  5.,  3.,  2.,  1., 0.4/
      DATA  LVLS/1000,850,700,500,400,300,200,100,70,50,30,10,5,2,1/
      DATA  ISLRPT/1,1,1,1,1,2,0,2,0,1,1,1,2,0,2,0,2,0,2,0/
      DATA  XMISS/99999./,IZFX/6,8,13,15,17/
C
C FUNCTION...
      XTM(T1,T2,XM,XP1,XP2)=(T2*(ALOG(XP1/XM))+T1*(ALOG(XM/XP2)))
     $        /(ALOG(XP1/XP2))

      G     = 9.80655
      R     = 287.055
      ROG   = R/G
      CP    = 1005.0
      XKAP  = R/CP
      XKAPR = 1.0/XKAP
      ROG   = R/G
      JFLAG = 0
C TSFC IS THE SKIN TEMPERATURE
      TSFC  = IBUFTN(9)/10.0
C SFCEL IS Z(SFC) MINUS Z(1000), WHERE Z(1000) IS SET TO 111.0 METERS
      SFCEL = IBUFTN(8) - 111.0
C ENTER MEAN LAYER VIRT. TEMP (TBAR), BOTTOM PRESSURE (IP1) AND TOP
C  PRESSURE (IP2) VALUES FOR THE LAYER, AND TEMPERATURE QUALITY MARK (Q)
      IP1  = IBUFTN(23:79:4)/10
      IP2  = IBUFTN(24:80:4)/10
      TBAR = IBUFTN(25:81:4)/10.
      Q    = IBUFTN(26:82:4)/10.
C-----------------------------------------------------------------------
C DETERMINE THE LOWEST AND HIGHEST VALID PRESSURE LAYERS FOR THE REPORT
C LL IS FIRST VALID PRESSURE LAYER (0=SFC-850 MB, 1=850-700 MB, ETC.)
C MM IS LAST  VALID PRESSURE LAYER (15=1-.4 MB, 14=2-1 MB, ETC.)
      LL = 0
      DO I = 1,15
         IF(IP1(I).NE.777.AND.IP2(I).NE.777)  GO TO 112
            LL = LL + 1
      ENDDO
C THERE ARE NO VALID PRESSURE LEVELS IN THE REPORT, EXIT WITH JFLAG=1
      JFLAG = 1
      RETURN
  112 CONTINUE
      DO I = 1,15
         MM = 16 - I
         IF(IP1(MM).NE.777.AND.IP2(MM).NE.777)  GO TO 114
      ENDDO
C THERE ARE NO VALID PRESSURE LEVELS IN THE REPORT, EXIT WITH JFLAG=1
      JFLAG = 1
      RETURN
  114 CONTINUE
C-----------------------------------------------------------------------
C ISLP IS THE NUMBER OF VALID PRESSURE LAYERS FOR THE REPORT
      ISLP = MM - LL
      IF(ISLP.GE.1)  GO TO 101
C THERE ARE VALID LAYERS IN THE REPORT, EXIT WITH JFLAG=2
      JFLAG = 2
      RETURN
  101 CONTINUE
      IF(LL.LE.0)  GO TO 78
C IF FIRST VALID LAYER IS ABOVE BASE LAYER (SFC-850 MB), RESET ARRAY
C  ELEMENTS IN IP1, IP2, TBAR, & Q SUCH THAT LVL1 IS THE FIRST VALID LVL
      DO I = 1,ISLP
         IP1(I) = IP1(LL+I)
         IP2(I) = IP2(LL+I)
         TBAR(I) = TBAR(LL+I)
         Q(I) = Q(LL+I)
      ENDDO
   78 CONTINUE
C GROSS CHECK THE PRESSURE AND TEMP, IF FAILS EXIT WITH JFLAG=3 OR 4
      DO I = 1,ISLP
              IF((IP1(I).GT.1000.OR.IP1(I).LT.0).OR.
     $           (IP2(I).GT.1000.OR.IP2(I).LT.0))  JFLAG = 3
              IF(JFLAG.EQ.3)  RETURN
              IF(TBAR(I).GT.500..OR.TBAR(I).LT.100.)  JFLAG = 4
              IF(JFLAG.EQ.4)  RETURN
      ENDDO
C-----------------------------------------------------------------------
C DETERMINE LOWEST (BOTTOM) & HIGHEST (TOP) MAND. PRESS. LVLS FOR WHICH
C  A VALID PRESSURE LAYER WITH V. TEMP EXIST IN THE REPORT
C NL INDEX IS 1ST VALID MAND. PRESSURE LVL (1-SFC/1000 MB,2-850 MB,ETC.)
C MLVLS IS LAST VALID MAND. PRESSURE LEVEL (20-1 MB, 19-2 MB, ETC.)
      DO L = 1,15
         IF(IP1(1).GT.INT(XLVLS(L)))  GO TO 200
      ENDDO
C IF FIRST VALID PRESSURE LEVEL IS AT OR ABOVE 10 MB EXIT WITH JFLAG=5
      JFLAG = 5
      RETURN
  200 CONTINUE
      NL = L - 1
      IF(L.EQ.1)  NL = 1
C KLVLS IS NO. OF MAND. PRESS LVLS UP TO 1 MB BEGINNING AT LVL NL
C  (MAX. IS 20 IF 1000/SFC MB LEVEL IS VALID)
      KLVLS = 21 - NL
      LLVLS = KLVLS - 1
C NLVLS IS NO. OF VALID LAYERS IN RPT (MAX IS 14,1-.4 MB LAYER NOT USED)
      NLVLS = ISLP
      IF(MM.EQ.15)  NLVLS = NLVLS - 1
      MLVLS = 0
      DO MLV = 1,20
         MLVLS = MLVLS + 1
         IF(IP2(NLVLS).GE.INT(XLVLS(MLV)))  GO TO 210
      ENDDO
C IF NO VALID PRESSURE LEVELS FOUND, EXIT WITH JFLAG=6
      JFLAG = 6
      RETURN
  210 CONTINUE
      JLVLS = MLVLS - 1
C-----------------------------------------------------------------------
C VERIFY THAT ALL LVLS BETWEEN THE TWO VALID SPANNING LEVELS ARE PRESENT
      DO I = 2,NLVLS
         J = I + LL
         ICK = IP1(I) - LVLS(J)
         JCK = IP2(I) - LVLS(J+1)
C IF THERE ARE ANY MISSING LEVELS IN HERE, EXIT WITH JFLAG=7
         IF(ICK.EQ.0.AND.JCK.EQ.0)  CYCLE
         JFLAG = 7
         RETURN
      ENDDO
C-----------------------------------------------------------------------
C COMPUTE THE EXNER FUNCTION AND ALOG (HIGHER PRESSURE/LOWER PRESSURE)
C  AT THE MANDATORY LEVELS -- DEFINE LOWEST LEVEL FIRST
      EXNER(1)  = (IP1(1)/1000.)**XKAP
      EXNER(20) = (    1./1000.)** XKAP
      XLNP(1) = ALOG(REAL(IP1(1))/XLVLS(NL+1))
      DO K = 2,KLVLS
         I = (NL - 1) + K
         EXNER(K) = (XLVLS(I)/1000.)**XKAP
         XLNP(K)  = ALOG(XLVLS(I)/XLVLS(I+1))
      ENDDO
C COMPUTE THE MID-LAYER EXNER FUNCTION AND 'COLLINS PRESSURE'
      DO K = 1,LLVLS
         XMID = XKAPR * ((EXNER(K+1) - EXNER(K))/(-XLNP(K)))
         XPON = XKAPR * ALOG(XMID) + ALOG(1000.)
         PMID(K) = EXP(XPON)
      ENDDO
C-----------------------------------------------------------------------
C CHECK TO SEE IF SKIN TEMP IS GOOD; CORRECT IF NECESSARY

C  Note: For previous TOVS processing, the obsolete subr. W3TOVEDS
C        could never return a value greater than 64 -- thus the test
C        .NOT.(BTEST(ITEMP,7)) was always be true since the bit in the
C        7'th position of IBUFTN(11) was always 0 (7'th pos. is from
C        right, where rightmost bit is in position 0)
C        This may not have been the case in the old HDS/true NMCEDS
C        file days - NMCEDS documentation, however, appears to support
C        the fact that bit 7 can ONLY have the value of ZERO.
C        For current RTOVS/ATOVS processing, IBUFTN(11) is set to 7777
C        (missing) in subr. W3XTOVSEDS, while IBUFTN(9) is also set to
C        7777.  This should allow the logic to be the same as for
C        TOVS - as to whether the logic is correct, I do not know
C        (Keyser - 5/7/98)

      ITEMP = IBUFTN(11)
      IF(.NOT.(BTEST(ITEMP,7)).OR.IBUFTN(9).EQ.7777)
     $ TSFC = TBAR(1) + (.0555 * (IP1(1) - PMID(1)))
      TSFC = (TSFC + TBAR(1) + (.0555 * (IP1(1) - PMID(1))))/2
C ESTIMATE MEAN TEMP IN SFC TO 1000 MB LAYER
      TMEAN = TSFC + ((0.0065 * SFCEL)/2.0)
C ESTIMATE SFC PRESSURE USING HYPSOMETRIC EQN. (1000 HGHT SET TO 111 M)
C           Z(1000) - Z(SFC) = - (R/G) * T * (LN(P1000) - LN(PSFC))
      ALNP = ALOG(1000.) - (SFCEL/(ROG * TMEAN))
      PSFC = EXP(ALNP)
C-----------------------------------------------------------------------
C INITIALIZE MANDATORY LEVEL TEMPS AND HEIGHTS(THICKNESSES) TO MISSING
      XVAL = (XMISS/10.) + 273.16
      TM = XVAL
      Z  = XMISS
      ZZ = XMISS
C COMPUTE PRESSURES FOR SATELLITE LEVELS
      SLNP(1:NLVLS) = ALOG(REAL(IP1(1:NLVLS))/IP2(1:NLVLS))
      EXNS(1:NLVLS) = (IP1(1:NLVLS)/1000.)**XKAP
      EXNS(NLVLS+1) = (IP2(NLVLS)/1000.)**XKAP
      DO I = 1,NLVLS
         XMID = XKAPR * ((EXNS(I+1) - EXNS(I))/(-SLNP(I)))
         XPON = (XKAPR * ALOG(XMID)) + ALOG(1000.)
         SPMID(I) = EXP(XPON)
      ENDDO
      ISL = 1
C-----------------------------------------------------------------------
C NOW COMPUTE LAYER TEMPERATURES FOR MANDATORY LAYERS (TBARX)
      LOOP1: DO K = 1,LLVLS
         LOOP1n1: DO JJ = ISL,ISLP
            J = JJ
            IF((PMID(K)-SPMID(J)).GT.-0.001)  EXIT LOOP1n1
         ENDDO LOOP1n1
         ISL = J
      IF(J.EQ.1.OR.(ABS(PMID(K)-SPMID(J)).LE.0.001))  TBARX(K) = TBAR(J)
         IF(J.EQ.1.OR.(ABS(PMID(K)-SPMID(J)).LE.0.001))  CYCLE LOOP1
         TBARX(K) = XTM(TBAR(J-1),TBAR(J),PMID(K),SPMID(J-1),SPMID(J))
      ENDDO LOOP1
      J = 1 - LL
      DO I = 1,JLVLS
         JJ = J
         IF(JJ.LT.1)  JJ = 1
         IF(ISLRPT(I).EQ.0)  CYCLE
         TXXX(I) = TBAR(JJ)
         IF(ISLRPT(I).EQ.2)  TXXX(I+1) = TBAR(JJ)
         J = J + 1
         J = MIN(J,MM-LL)
      ENDDO
C-----------------------------------------------------------------------
C COMPUTE TEMPERATURE AT MANDATORY LEVELS ABOVE GROUND
      ML = NL + 1
      K = 0
      DO I = ML,JLVLS
         K = K + 1
         TM(I) = (TBARX(K+1) * (ALOG(PMID(K) / XLVLS(I)))
     $         + TBARX(K) * (ALOG(XLVLS(I) / PMID(K+1))))
     $         / (ALOG(PMID(K) / PMID(K+1)))
      ENDDO
C-----------------------------------------------------------------------
C HEIGHTS(THICKNESSES TO 1000 MB) WILL NOT BE CALCULATED IF FIRST
C  VALID PRESSURE IS TOO HIGH ABOVE THE SURFACE
      IF(ABS(PSFC-IP1(1)).GT.100.)  GO TO 900
      T1000 = TSFC + (0.0065 * SFCEL)
C SINCE HGHT REALLY THICKNESS TO 1000 MB, 1000 MB HGHT ALWAYS = 0
      Z(1) = 0.0
      IF(NL.LE.1)  GO TO 750
C COMPUTE Z UNDERGROUND USING HYPSOMETRIC EQUATION, ASSUMING STD TEMP
C  LAPSE UNDERGROUND (.0065DEG/M) -- NL = NO. OF MAND. LVLS UNDER GROUND
C  (IF SFC AT OR BELOW 1000 MB, NL = 1 AND NO LEVELS ARE UNDERGROUND)
      Z(2:NL) = ROG * (T1000 * ALOG(1000./XLVLS(2:NL)))/
     $          (1. + (ROG * .0065/2.) * ALOG(1000./XLVLS(2:NL)))
  750 CONTINUE
C ELEVATION IS 0 METERS (OVER WATER), THEN 1000 MB TEMP DETERMINED
      IF(SFCEL.LE.0.0)  TM(1) = T1000
C COMPUTE THE HEIGHTS AT MANDATORY LEVELS
      J = 1
      Z(NL+1) = ROG * TBARX(1) * XLNP(1)
      IF(IP1(1).EQ.1000)  GO TO 755
      Z(NL+1) = Z(NL+1) + SFCEL + ROG * TSFC * ALOG(PSFC/REAL(IP1(1)))
     $ /(1 + (ROG * .0065/2.) * ALOG(PSFC/REAL(IP1(1))))
  755 CONTINUE
      ZZ = Z
      DO I = ML,JLVLS
         J = J + 1
         ZLY = ROG * TBARX(J) * XLNP(J)
         Z(I+1) = Z(I) + ZLY
         ZLYX = ROG * TXXX(I) * XLNP(J)
         ZZ(I+1) = ZZ(I) + ZLYX
      ENDDO
      DO II = 1,5
         I = IZFX(II)
         IF(I+1.LE.JLVLS)  ZZ(I+1) = ZZ(I) + (ZZ(I+2) - ZZ(I)) *
     $    (Z(I+1) - Z(I))/(Z(I+2) - Z(I))
      ENDDO
      Z = ZZ
  900 CONTINUE
      RETURN
      END
