      SUBROUTINE PTSH 
     1           (NFC,NF1,NF2,T,U,V,ES,GZS,SP,LA,NPL,PR,NSL,
     2            AG,BG,AH,BH,NPL1,FPCOL,DFDLNP ,DLNP , 
     3            LP,LG,LH,SIG,PRLOG, IBUF,MAXP8,MOIST) 

C     * NOV 6/95  - M.LAZARE. - ADD "MOIST=4HQHYB" OPTION.  
C     * MAR 17/93 - E.CHAN.   - SKIP OVER SECOND RECORD OF CONTROL FILE.
C     * JAN 19/93 - E.CHAN.   - REMOVE CALCULATION OF LP FROM PR.
C     * AUG 13/90 - M.LAZARE. - ADD ADDITIONAL MOISTURE VARIABLE 4HQHYB.
C     * AUG 25/89 - M.LAZARE. - ADD ADDITIONAL MOISTURE VARIABLE 4H LNQ.
C     * MAY 17/88 - R.LAPRISE.
C 
C     * CONVERTS NPL PRESSURE LEVELS OF GAUSSIAN GRIDS (ILG1,ILAT)
C     * ON FILE NF1 TO NSL ETA LEVELS ON FILE NF2 FOR HYBRID MODEL. 
C     * CONVERT ES=T-TD TO MODEL MOISTURE VARIABLE, CONTROLLED BY MOIST.
C     * ETAG FOR MOMENTUM MID LAYER, ETAH FOR THERMODYNAMIC MID LAYER.
C     * PRESSURE LEVELS IN PR ARE ORDERED TOP DOWN. 
C     * (U,T),(V,ES) MAY BE EQUIVALENCED. 
  
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N)
      LOGICAL OK
  
      REAL T(LA,NPL), U(LA,NPL), V(LA,NPL), ES(LA,NPL), GZS(LA), SP(LA) 
  
      REAL AG    (NSL),BG    (NSL),AH     (NSL) ,BH   (NSL) 
      REAL PR    (NPL ),FPCOL (NPL ),DFDLNP (NPL1),DLNP (NPL) 
      REAL SIG   (NSL ),PRLOG (NPL )
      INTEGER LP (NPL ),LG    (NSL ),LH     (NSL )
      INTEGER IBUF(MAXP8) 
  
      DATA AA,BB,EPS1,EPS2/21.656E0, 5423.E0, 0.622E0, 0.378E0/ 
C-------------------------------------------------------------------- 
      MAXX = MAXP8-8 
  
C     * SET NPL TO PRESSURE VALUES. SET PRLOG TO LN(PR).
  
      DO 110 L=1,NPL
         PRLOG(L) = LOG(PR(L)) 
  110 CONTINUE
C---------------------------------------------------------------------
C     * READ MOUNTAIN GEOPOTENTIAL (M/SEC)**2.
C 
C      READ(NFC)
C      INSTEAD USE RDSKIP TO SKIP RECORDS.
      CALL RDSKIP(NFC,NSKIP,OK)
      CALL GETFLD2(NFC,GZS,NC4TO8("GRID"),-1,NC4TO8("PHIS"),1,
     1                                           IBUF,MAXX,OK)
      IF(.NOT.OK) CALL XIT('PTS',-1)
      WRITE(6,6025) (IBUF(IND),IND=1,8) 
C 
C     * READ MEAN SEA LEVEL PRESSURE. 
C 
      REWIND NF1
      CALL GETFLD2(NF1,SP,NC4TO8("GRID"),-1,NC4TO8("PMSL"),1,
     1                                          IBUF,MAXX,OK)
      IF(.NOT.OK) CALL XIT('PTS',-2)
      WRITE(6,6025) (IBUF(IND),IND=1,8) 
C 
C     * READ GEOPOTENTIALS INTO T ARRAY. COMPUTE LN(SF PRES). 
C 
      REWIND NF1
      DO 210 L=1,NPL
         CALL GETFLD2(NF1, T(1,L),NC4TO8("GRID"),-1,NC4TO8(" PHI"),
     1                                         LP (L),IBUF,MAXX,OK)
         IF(.NOT.OK) CALL XIT('PTS',-25)
         WRITE(6,6025) (IBUF(IND),IND=1,8)
  210 CONTINUE
      CALL GZASFP2(SP,T,GZS,SP,LA,NPL,PR) 
      DO 215 I=1,LA 
  215 SP(I)=LOG(SP(I)) 
  
C     * READ TEMPERATURES (DEG K).
  
      REWIND NF1
      DO 220 L=1,NPL
         CALL GETFLD2(NF1, T(1,L),NC4TO8("GRID"),-1,NC4TO8("TEMP"),
     1                                         LP (L),IBUF,MAXX,OK)
         IF(.NOT.OK) CALL XIT('PTS',-3) 
         WRITE(6,6025) (IBUF(IND),IND=1,8)
  220 CONTINUE
  
C     * FROM DT/DP=(R*T)/(P*CP),  R/CP=2./7.,  AND T=280. 
C     * WE GET RLDN = DT/D(LN P) = 80.
C     * LTES = (0,1) TO PUT TEMP,ES ON (HALF,FULL) LEVELS.
  
      RLUP =  0.E0
      RLDN = 80.E0
      CALL PAEL  (T,LA,SIG,NSL, T,PRLOG,NPL,SP,RLUP,RLDN, 
     1            AH,BH,NPL+1,FPCOL,DFDLNP ,DLNP )
  
C     * OUTPUT PHIS,LNSP AND TEMPERATURES.
  
      IBUF(2)=0 
      IBUF(4)=1 
      IBUF(3)=NC4TO8("PHIS")
      CALL PUTFLD2(NF2, GZS,IBUF,MAXX) 
      WRITE(6,6026) (IBUF(IND),IND=1,8) 
      IBUF(3)=NC4TO8("LNSP")
      CALL PUTFLD2(NF2, SP ,IBUF,MAXX) 
      WRITE(6,6026) (IBUF(IND),IND=1,8) 
      DO 280 K=1,NSL
         IBUF(3)=NC4TO8("TEMP")
         IBUF(4)=LH(K)
         CALL PUTFLD2(NF2,  T(1,K),IBUF,MAXX)
         WRITE(6,6026) (IBUF(IND),IND=1,8)
  280 CONTINUE
C---------------------------------------------------------------------
C     * READ DEW POINT DEPRESSIONS (DEG C) FROM FILE NF1. 
C     * LTES = (0,1) TO PUT TEMP,ES ON (HALF,FULL) LEVELS.
  
      REWIND NF1
      DO 410 L=1,NPL
         CALL GETFLD2(NF1,ES(1,L),NC4TO8("GRID"),-1,NC4TO8("  ES"),
     1                                         LP (L),IBUF,MAXX,OK)
         IF(.NOT.OK) CALL XIT('PTS',-6) 
         WRITE(6,6025) (IBUF(IND),IND=1,8)
  410 CONTINUE
  
C     * INTERPOLATE TO ETA LEVELS. ES MUST BE POSITIVE EVERYWHERE.
  
      RLUP = 0.E0 
      RLDN = 0.E0 
      CALL PAEL  (ES,LA,SIG,NSL, ES,PRLOG,NPL,SP,RLUP,RLDN, 
     1            AH,BH,NPL+1,FPCOL,DFDLNP ,DLNP )
      DO 425 N=1,NSL
      DO 425 I=1,LA 
         ES(I,N)=MAX(ES(I,N),0.E0)
  425 CONTINUE
  
C     * CONVERT ES=T-TD TO MODEL VARIABLE.
  
      DO 470 N=1,NSL
       IF(MOIST.EQ.NC4TO8("RLNQ")) THEN
        DO 430 I=1,LA 
         PSPA   = 100.E0*EXP(SP(I)) 
         CALL NIVCAL (SIGMA,AH(N),BH(N),PSPA,1,1,1) 
         PRES   = 0.01E0*PSPA*SIGMA 
         TD     = T(I,N)-ES(I,N)
         E      = EXP(AA-BB/TD) 
         SHUM   = EPS1*E/(PRES-EPS2*E)
         ES(I,N)= -1.E0/LOG(SHUM)
  430   CONTINUE
  
       ELSEIF(MOIST.EQ.NC4TO8("SQRT")) THEN
        DO 435 I=1,LA 
         PSPA   = 100.E0*EXP(SP(I)) 
         CALL NIVCAL (SIGMA,AH(N),BH(N),PSPA,1,1,1) 
         PRES   = 0.01E0*PSPA*SIGMA 
         TD     = T(I,N)-ES(I,N)
         E      = EXP(AA-BB/TD) 
         SHUM   = EPS1*E/(PRES-EPS2*E)
         ES(I,N)= SQRT(SHUM)
  435   CONTINUE
  
       ELSEIF(MOIST.EQ.NC4TO8("   Q") .OR. MOIST.EQ.NC4TO8("SL3D")) THEN
        DO 440 I=1,LA 
         PSPA   = 100.E0*EXP(SP(I)) 
         CALL NIVCAL (SIGMA,AH(N),BH(N),PSPA,1,1,1) 
         PRES   = 0.01E0*PSPA*SIGMA 
         TD     = T(I,N)-ES(I,N)
         E      = EXP(AA-BB/TD) 
         SHUM   = EPS1*E/(PRES-EPS2*E)
         ES(I,N)= SHUM
  440   CONTINUE
  
       ELSEIF(MOIST.EQ.NC4TO8("  TD")) THEN
        DO 445 I=1,LA 
         TD     = T(I,N)-ES(I,N)
         ES(I,N)= TD
  445   CONTINUE
  
       ELSEIF(MOIST.EQ.NC4TO8(" LNQ")) THEN
        DO 450 I=1,LA 
         PSPA   = 100.E0*EXP(SP(I)) 
         CALL NIVCAL (SIGMA,AH(N),BH(N),PSPA,1,1,1) 
         PRES   = 0.01E0*PSPA*SIGMA 
         TD     = T(I,N)-ES(I,N)
         E      = EXP(AA-BB/TD) 
         SHUM   = EPS1*E/(PRES-EPS2*E)
         SHUM   = MAX(SHUM, 1.0E-10)
         ES(I,N)= LOG(SHUM)
  450   CONTINUE
       ELSEIF(MOIST.EQ.NC4TO8("QHYB")) THEN
        SHUMREF=10.E-3
        DO 460 I=1,LA 
         PSPA   = 100.E0*EXP(SP(I)) 
         CALL NIVCAL (SIGMA,AH(N),BH(N),PSPA,1,1,1) 
         PRES   = 0.01E0*PSPA*SIGMA 
         TD     = T(I,N)-ES(I,N)
         E      = EXP(AA-BB/TD) 
         SHUM   = EPS1*E/(PRES-EPS2*E)
         IF(SHUM.GE.SHUMREF) THEN 
           ES(I,N)= SHUM
         ELSE 
           ES(I,N)= SHUMREF/(1.E0+LOG(SHUMREF/SHUM)) 
         ENDIF
  460   CONTINUE
  
       ELSEIF(MOIST.EQ.NC4TO8("T-TD")) THEN
        CONTINUE
       ELSE 
                               CALL XIT('INITGSH',-50)
       ENDIF
  
  470 CONTINUE
  
C     * OUTPUT ES ON FILE NF2.
  
      IBUF(2)=0 
      DO 480 K=1,NSL
         IBUF(3)=NC4TO8("  ES")
         IBUF(4)=LH(K)
         CALL PUTFLD2(NF2, ES(1,K),IBUF,MAXX)
         WRITE(6,6026) (IBUF(IND),IND=1,8)
  480 CONTINUE
C---------------------------------------------------------------------
C     * READ MODEL WINDS (U,V)*COS(LAT)/(EARTH RADIUS). 
  
      REWIND NF1
      DO 510 L=1,NPL
         CALL GETFLD2(NF1, U(1,L),NC4TO8("GRID"),-1,NC4TO8("   U"),
     1                                         LP (L),IBUF,MAXX,OK)
         IF(.NOT.OK) CALL XIT('PTS',-4) 
         WRITE(6,6025) (IBUF(IND),IND=1,8)
  510 CONTINUE
      REWIND NF1
      DO 520 L=1,NPL
         CALL GETFLD2(NF1, V(1,L),NC4TO8("GRID"),-1,NC4TO8("   V"),
     1                                         LP (L),IBUF,MAXX,OK)
         IF(.NOT.OK) CALL XIT('PTS',-5) 
         WRITE(6,6025) (IBUF(IND),IND=1,8)
  520 CONTINUE
  
C     * INTERPOLATE TO ETA LEVELS.
  
      RLUP = 0.E0 
      RLDN = 0.E0 
      CALL PAEL ( U,LA, SIG,NSL, U,PRLOG,NPL,SP,RLUP,RLDN,
     1            AG,BG,NPL+1,FPCOL,DFDLNP ,DLNP )
      CALL PAEL ( V,LA, SIG,NSL, V,PRLOG,NPL,SP,RLUP,RLDN,
     1            AG,BG,NPL+1,FPCOL,DFDLNP ,DLNP )
  
C     * OUTPUT PAIRS OF U,V ON FILE NF2.
  
      IBUF(2)=0 
      DO 580 K=1,NSL
         IBUF(4)=LG(K)
  
         IBUF(3)=NC4TO8("   U")
         CALL PUTFLD2(NF2,  U(1,K),IBUF,MAXX)
         WRITE(6,6026) (IBUF(IND),IND=1,8)
  
         IBUF(3)=NC4TO8("   V")
         CALL PUTFLD2(NF2,  V(1,K),IBUF,MAXX)
         WRITE(6,6026) (IBUF(IND),IND=1,8)
  580 CONTINUE
C-------------------------------------------------------------------- 
 6025 FORMAT(' ',A4,I10,1X,A4,5I6)
 6026 FORMAT(' ',60X,A4,I6,1X,A4,5I6) 
      END
