SUBROUTINE W3FA06 (P,T,RH,T5,TLI)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FA06         CALCULATION OF THE LIFTED INDEX
C   AUTHOR: HOWCROFT,J.      ORG: W/NMC342   DATE: 78-07-01
C
C ABSTRACT: GIVEN THE PRESSURE,TEMPERATURE AND RELATIVE HUMIDITY OF
C   AN AIR PARCEL AT SOME POINT IN THE ATMOSPHERE, CALCULATE THE
C   LIFTED INDEX OF THE PARCEL. LIFTED INDEX IS DEFINED AS THE
C   TEMPERATURE DIFFERENCE BETWEEN THE OBSERVED 500MB TEMPERATURE AND
C   THE SUPPOSED TEMPERATURE THAT THE PARCEL WOULD OBTAIN IF IT WERE
C   LIFTED DRY-ADIABATICALLY TO SATURATION AND THEN MOVED MOIST
C   ADIABATICALLY TO THE 500MB LEVEL.
C
C PROGRAM HISTORY LOG:
C   78-07-01  J.HOWCROFT
C   89-01-24  R.E.JONES   CHANGE TO MICROSOFT FORTRAN 4.10
C   90-06-08  R.E.JONES   CHANGE TO SUN FORTRAN 1.3
C   91-03-29  R.E.JONES   CONVERT TO SiliconGraphics FORTRAN
C   93-03-29  R.E.JONES   ADD SAVE STATEMENT
C   95-09-25  R.E.JONES   PUT IN W3 LIBRARY ON CRAY
C
C USAGE: CALL W3FA06(P,T,RH,T5,TLI)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     P      ARG LIST   PARCEL PRESSURE IN MILLIBARS
C     T      ARG LIST   PARCEL TEMPERATAURE IN DEGREES CELSIUS
C     RH     ARG LIST   PARCEL RELATIVE HUMIDITY IN PERCENT
C     T5     ARG LIST   TEMPERATURE AT THE 500MB LEVEL IN DEG. CELSIUS
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     TLI    ARG LIST  LIFTED INDEX IN DEGREES CELSIUS
C                      TLI = 9.9999  ITERATION DIVERGES;
C                      RETURN TO USER PROGRAM
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     EXP    ABS    SIGN                                      SYSLIB
C     W3FA01                                                  W3LIB
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916/256, J916/2048
C
C$$$
C
       SAVE
C
       DATA            EPS   /0.5/
       DATA            KOUT  /  6/
C
  300  FORMAT ('  *** ITERATION NOT CONVERGING IN W3FA06 ***')
  350  FORMAT ('      INPUT PARAMS ARE:',4F15.8,/
     1         '      CALCULATIONS ARE',7E15.8)
C
       POTEMP(T,P) = (T+273.16)*((1000./P)**0.2857)
C
       EEP(T,P,ES) = EXP((596.73-0.601*T)*((0.622*ES)/(P-ES))
     1                / (0.24*(T+273.16)))
C
       UNPOT(TE,P) = (((P/1000.)**0.2857)*TE)-273.16
C
       VAPRES(T)   = 6.11*EXP(17.2694*T/(T+237.3))
C
       CALL W3FA01 (P,T,RH,TD,PLCL,TLCL)
       IF (PLCL .GT. 500.)  GO TO 30
       IF (PLCL .LT. 500.)  GO TO 20
         TLI = T5 - TLCL
         GO TO 80
   20  CONTINUE
C        LCL IS ABOVE THE 500MB LVL
         TLI = T5 - UNPOT((POTEMP(TLCL,PLCL)),500.)
         GO TO 80
   30  CONTINUE
C        USE STACKPOLE ALGORITHM (JAM VOL 6/1967 PP 464-7) TO FIND TGES
C        SO THAT (TGES,500) IS ON SAME MOIST ADIABAT AS (TLCL,PLCL).
         ES     = VAPRES(TLCL)
         THD    = POTEMP(TLCL,(PLCL-ES))
         THETA  = THD * EEP(TLCL,PLCL,ES)
C          THETA IS THE PSEUDO-EQUIV POTENTIAL TEMP THRU (PLCL,TLCL).
C      NOW FIND TEMP WHERE THETA INTERSECTS 500MB SFC.
C          INITIALIZE FOR STACKPOLIAN ITERATION
         TGES = T5
         DTT  = 10.
         PIIN = 1./(0.5**0.2857)
         A    = 0.
         ISTP = 0
C          START ITERATION.
   40  CONTINUE
         ISTP = ISTP + 1
         IF (ISTP .GT. 200)  GO TO 50
         SVA = VAPRES(TGES)
         AX  = A
         A   = (TGES+273.16)*PIIN * EEP(TGES,500.,SVA) - THETA
         IF (ABS(A) .LT. EPS)  GO TO 70
         DTT = DTT * 0.5
         IF (A*AX.LT.0.0)  DTT = -DTT
         TP   = TGES + DTT
         SVA  = VAPRES(TP)
         AP   = (TP+273.16)*PIIN * EEP(TP,500.,SVA) - THETA
         IF (ABS(AP) .LT. EPS)  GO TO 60
C          FIND NEXT ESTIMATE, DTT IS ADJUSTMENT FROM OLD TO NEW TGES.
           DTT  = A*DTT/(A-AP)
           IF (ABS(DTT).LT.0.01)  DTT = SIGN(0.01,DTT)
           TGES = TGES + DTT
           IF (TGES .GT. 50)  TGES = 50.
           GO TO 40
C
   50  CONTINUE
C        DISASTER SECTION
         WRITE (KOUT,300)
         WRITE (KOUT,350) P,T,RH,T5,THETA,AX,A,AP,TGES,TP,SVA
           TLI = 9.9999
           GO TO 80
   60  CONTINUE
         TGES = TP
   70  CONTINUE
         TLI  = T5 - TGES
   80  CONTINUE
       RETURN
       END