    SUBROUTINE PRECPD
!>--------------------------------------------------------------------------------------------------
!> SUBROUTINE PRECPD
!>
!> SUBROUTINE: PRECPD - LARGE SCALE PRECIPITATION
!> PROGRAMMER: ZHAO
!> ORG: W/NP22
!> DATE: ??-??-??
!>
!> ABSTRACT:
!> PRECPD COMPUTES THE GRID SCALE PRECIPITATION.
!>
!> PROGRAM HISTORY LOG:
!> 94-??-??  ZHAO       - ORIGINATOR
!> 95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
!> 95-11-20  ABELES     - PARALLEL OPTIMIZATION
!> 96-03-29  BLACK      - REMOVED SCRCH COMMON
!> 96-07-18  ZHAO       - NEW WMIN CALCULATION
!> 06-09-25  BALDWIN    - NEW SR CALCULATION
!> 98-11-02  BLACK      - MODIFICATION FOR DISTRIBUTED MEMORY
!> 18-01-15  LUCCI      - MODERNIZATION OF THE CODE, INCLUDING:
!>                        * F77 TO F90/F95
!>                        * INDENTATION & UNIFORMIZATION CODE
!>                        * REPLACEMENT OF COMMONS BLOCK FOR MODULES
!>                        * DOCUMENTATION WITH DOXYGEN
!>                        * OPENMP FUNCTIONALITY
!>
!> INPUT ARGUMENT LIST:
!> NONE
!>
!> OUTPUT ARGUMENT LIST:
!> NONE
!>
!> INPUT/OUTPUT ARGUMENT LIST:
!> NONE
!>
!> OUTPUT FILES:
!> NONE
!>
!> USE MODULES: ACMCLH 
!>              CLDWTR
!>              CTLBLK
!>              DYNAM
!>              F77KINDS
!>              GLB_TABLE
!>              LOOPS
!>              MAPPINGS
!>              MASKS
!>              MPPCOM
!>              PARMETA
!>              PARM_TBL
!>              PHYS
!>              PPTASM
!>              PVRBLS
!>              TEMPCOM
!>              TOPO     
!>              VRBLS     
!>
!> DRIVER     : EBU
!>              NEWFLT   
!>
!> CALLS      : SGETMO           
!>--------------------------------------------------------------------------------------------------
    USE ACMCLH
    USE CLDWTR
    USE CTLBLK
    USE DYNAM    , ONLY: DETA, AETA, PT
    USE F77KINDS
    USE GLB_TABLE
    USE LOOPS
    USE MAPPINGS
    USE MASKS
    USE MPPCOM
    USE PARMETA
    USE PARM_TBL
    USE PHYS
    USE PPTASM
    USE PVRBLS
    USE TEMPCOM
    USE TOPO
    USE VRBLS
!
    IMPLICIT NONE
!
    REAL   (KIND=R4KIND), PARAMETER :: A1    =  610.78
    REAL   (KIND=R4KIND), PARAMETER :: A2    =   17.2693882
    REAL   (KIND=R4KIND), PARAMETER :: A3    =  273.16  
    REAL   (KIND=R4KIND), PARAMETER :: A4    =   35.86
    REAL   (KIND=R4KIND), PARAMETER :: PQ0   =  379.90516
    REAL   (KIND=R4KIND), PARAMETER :: TRESH =     .95
    REAL   (KIND=R4KIND), PARAMETER :: R     =  287.04 
    REAL   (KIND=R4KIND), PARAMETER :: C0    =    0.15 
    REAL   (KIND=R4KIND), PARAMETER :: CP    = 1004.6
    REAL   (KIND=R4KIND), PARAMETER :: ELWV  =    2.50E6 
    REAL   (KIND=R4KIND), PARAMETER :: ELIV  =    2.834E6 
    REAL   (KIND=R4KIND), PARAMETER :: ROW   =    1.E3 
    REAL   (KIND=R4KIND), PARAMETER :: G     =    9.8    
    REAL   (KIND=R4KIND), PARAMETER :: EPSQ  =    2.E-12  
    REAL   (KIND=R4KIND), PARAMETER :: DLDT  = 2274.0
    REAL   (KIND=R4KIND), PARAMETER :: ELIW  = ELIV - ELWV 
!
    REAL   (KIND=R4KIND), PARAMETER :: ARCP  = A2  * (A3 - A4) / CP
    REAL   (KIND=R4KIND), PARAMETER :: RCP   = 1.  / CP
    REAL   (KIND=R4KIND), PARAMETER :: PQ0C  = PQ0 * TRESH
    REAL   (KIND=R4KIND), PARAMETER :: RROG  = 1.  / (ROW * G)
    REAL   (KIND=R4KIND), PARAMETER :: RROW  = 1.  / ROW
!
#include "sp.h"
!
    INTEGER(KIND=I4KIND), PARAMETER :: IMJM = IM * JM - JM / 2
    INTEGER(KIND=I4KIND), PARAMETER :: LTOP = 1
    INTEGER(KIND=I4KIND), PARAMETER :: LBOT = LM
!
    INTEGER(KIND=I4KIND), PARAMETER :: IMJM_LOC = IDIM2 * JDIM2
    INTEGER(KIND=I4KIND), PARAMETER :: LDA      = (IDIM2 - IDIM1 + 1) * (JDIM2 - JDIM1 + 1)
!
    LOGICAL(KIND=L4KIND)                                                                        ::&
    & NOZ
!
    INTEGER(KIND=I4KIND), DIMENSION(IMJM_LOC)                                                   ::&
    & IPREC   , JPREC
!
    REAL   (KIND=R4KIND), DIMENSION(LM,IDIM1:IDIM2, JDIM1:JDIM2)                                ::&
    &     T_T ,    Q_T  ,                                                                         &
    & TRAIN_T ,  HTM_T  ,                                                                         &
    &   CWM_T , TLAT_T
!
    REAL   (KIND=R4KIND), DIMENSION(IMJM_LOC)                                                   ::&
    & PRECRL1 , PRECSL1   
!
    INTEGER(KIND=I4KIND), DIMENSION(IMJM_LOC)                                                   ::&
    & IWL1
!
    REAL   (KIND=R4KIND)                                                                        ::&
    & KE      , INIT    , MI0
!------------------------
! IMPLICIT NONE VARIABLES
!------------------------
    INTEGER(KIND=I4KIND)                                                                        ::&
    & I       , J       , K       , N       , NPRE    , LML     , IWL     , IWK 

    REAL   (KIND=R4KIND)                                                                        ::&  
    & DTPH    , RDTPH   , TWODT   , RTWODT  , US      , EPS     , CCLIMIT , CWS     , CSM1    ,   &
    & CRS1    , CRS2    , CR      , AA2     , UTIM    , TTEMP   , WFIX    , WMIN    , HBM2K   ,   &
    & PDSL    , CLIMIT  , CONSTA  , U00IJ   , DETAL   , ULL     , AETAL   , PRECRL  , PRECSL  ,   &
    & PRAUT   , PSAUT   , PRACW   , PSACI   , ERR     , ERS     , PSM     , PSM1    , PSM2    ,   &
    & PPR     , PPS     , CPDR    , HH      , PID     , CONDE   , RCONDE  , TT      , QQ      ,   &
    & WW      , HTMK    , TTLAT   , U00KL   , WMINK   , PRECRK  , PRECSK  , TK      , QK      ,   &
    & TMT0    , TMT15   , AI      , BI      , QW      , QI      , QINT    , FI      , FIW     ,   &
    & QC      , RQ      , CCR     , RQKLL   , CWMK    , EXPF    , AA1     , AMAXCM  , TMT0K   ,   &
    & U00KLT  , AMAXRQ  , HHT     , QTEMP   , TMT0T   , TMT15T  , QWT     , QIT     , QINTT   ,   &
    & QCT     , RQT     , RQTT    , ERK     , RPRS    , ERRT    , ERST    , AMAXPS  , PRECRS  ,   &
    & PRECSS  , TOTPPT

!------------------------- 
! PREPARATORY CALCULATIONS 
!------------------------- 
    DTPH    = NPHS * DT
    RDTPH   = 1. / DTPH
    TWODT   = DTPH
    RTWODT  = 1. / TWODT
    KE      = 2.0E-5
    US      = 1.
    EPS     = 0.622E0
    CCLIMIT = 1.0E-3
    CLIMIT  = 1.0E-20
    CWS     = 0.025
    CSM1    = 5.00000E-8
    CRS1    = 5.00000E-6
    CRS2    = 6.66600E-10
    CR      = 5.0E-4
    MI0     = 5.0E-4
    AA2     = 1.25E-3
!
    AVRAIN = AVRAIN + 1.
    ARATIM = ARATIM + 1
!---------------------------------------- 
! PADDING CLOUD MIXING RATIO IF TOO SMALL
!----------------------------------------
!
!$omp parallel do
!
    DO 20 K=1,LM
        DO J=MYJS,MYJE
            DO I=MYIS,MYIE
                CWM(I,J,K) = CWM(I,J,K) * HTM(I,J,K) * HBM2(I,J)
!
                IF (CWM(I,J,K) < 0.) CWM(I,J,K) = 0.
!---------------------------------------                  
! PADDING SPECIFIC HUMIDITY IF TOO SMALL
!---------------------------------------
                IF (Q(I,J,K) < EPSQ) Q(I,J,K) = EPSQ * HTM(I,J,K)
            END DO
        END DO
 20 END DO
!
    UTIM = 1.
!
!$omp parallel do 
!
    DO N=1,IMJM_LOC
           IWL1(N) = 0
        PRECRL1(N) = 0.
        PRECSL1(N) = 0.
    END DO
!----------------------------------------------
! CHOOSE THE COLUMNS WHERE PREC CAN BE PRODUCED
!----------------------------------------------
    NPRE = 0
!
    DO 35 J=MYJS2,MYJE2
        DO 35 I=MYIS,MYIE
!        
            DO K=2,LM
                TTEMP = 0.025  * (T(I,J,K) - 273.16)
                WFIX  = 0.9814 * EXP(0.01873 * K)
                WMIN  = 0.1E-3 * EXP(TTEMP) * WFIX
!
                IF (CWM(I,J,K) > WMIN) GOTO 33
!
            END DO
!        
            GOTO 35
!
         33 NPRE = NPRE + 1
!
            IPREC(NPRE) = I
            JPREC(NPRE) = J
 35 END DO
!----------------- 
! TRANSPOSE ARRAYS
!-----------------
!
!$omp parallel sections
!
!$omp section
!
    CALL SGETMO(T     , LDA, LDA, LM, T_T    ,LM)
!
!$omp section
!
    CALL SGETMO(Q     , LDA, LDA, LM, Q_T    ,LM)
!
!$omp section
!
    CALL SGETMO(CWM   , LDA, LDA, LM, CWM_T  ,LM)
!
!$omp section
!
    CALL SGETMO(HTM   , LDA, LDA, LM, HTM_T  ,LM)
!
!$omp section
!
    CALL SGETMO(TRAIN , LDA, LDA, LM, TRAIN_T,LM)
!
!$omp section
!
    CALL SGETMO(TLATGS, LDA, LDA, LM, TLAT_T ,LM)
!
!$omp end parallel sections
!
!-------------------------------------- 
! BEGINING OF PRECIPITATION CALCULATION 
!-------------------------------------- 
!
!-------------------------------------------- 
! LOOP OVER ALL POSSIBLE PRECIPITATION POINTS
!-------------------------------------------- 
!
!$omp parallel do
!$omp private (AAI      , AETAL   , AI      , AMAXCM  , AMAXPS  , AMAXRQ  , BI      , CCR     ,   &
!$omp          CONDE    , CONSTA  , CPDR    , CS      , CWMK    , DETAL   , ERK     , ERR     ,   &
!$omp          ERRT     , ERS     , ERST    , EXPF    , FI      , FIW     , HBM2K   , HH      ,   &
!$omp          HTMK     , I       , IWL     , J       , LML     , MI0     , PDSL    , PID     ,   &
!$omp          PPR      , PPS     , PRACW   , PRAUT   , PRECRK  , PRECRL  , PRECSK  , PRECSL  ,   &
!$omp          PRECSS   , PSACI   , PSAUT   , PSM     , PSM1    , PSM2    , QC      , QCT     ,   &
!$omp          QI       , QINT    , QINTT   , QIT     , QK      , QQ      , QTEMP   , QW      ,   &
!$omp          QWT      , RCONDE  , RPRS    , RQ      , RQKLL   , RQT     , RQTT    , TK      ,   &
!$omp          TMT0     , TMT0K   , TMT0T   , TMT15   , TMT15T  , TOTPPT  , TT      , TTEMP   ,   &
!$omp          TTLAT    , U00IJ   , U00KL   , U00KLT  , ULL     , WFIX    , WMINK   , WW      )
!
    DO 300 N=1,NPRE
!    
        I = IPREC(N)
        J = JPREC(N)
!
        HBM2K  = HBM2(I,J)
        PDSL   =  RES(I,J) * PD(I,J)
!
        CONSTA = PDSL / G * TWODT
        LML    = LM - LMH(I,J)
        U00IJ  = U00(I,J)
!    
        DO 180 K=2,LM
!        
            DETAL = DETA(K)
            ULL   =   UL(K)
            AETAL = AETA(K)
!
            WFIX = 0.9814 * EXP(0.01873 * K)
!        
            PRECRL = 0.
            PRECSL = 0.
            PRAUT  = 0.
            PSAUT  = 0.
            PRACW  = 0.
            PSACI  = 0.
            ERR    = 0.
            ERS    = 0.
            PSM    = 0.
            PSM1   = 0.
            PSM2   = 0.
            PPR    = 0.
            PPS    = 0.
            CPDR   = 0.
            HH     = 0.
            PID    = 0.
            IWL    = 0.
            CONDE  = 0.
            RCONDE = 0.
!
            TT    =    T_T(K,I,J)
            QQ    =    Q_T(K,I,J)
            WW    =  CWM_T(K,I,J)
            HTMK  =  HTM_T(K,I,J)
            TTLAT = TLAT_T(K,I,J)
!
            U00KL = U00IJ  + UL(K + LML) * (0.95 - U00IJ) * UTIM
            TTEMP = 0.025  * (TT - 273.16)
            WMINK = 0.1E-3 * EXP(TTEMP)  * WFIX
!------------------------------------------------------ 
! CHOOSE THE POINTS WHERE PRECIPITATION CAN BE PRODUCED 
!------------------------------------------------------ 
            PRECRK = AMAX1(0., PRECRL1(N))
            PRECSK = AMAX1(0., PRECSL1(N))
!
            HH = HTMK * HBM2K
!
            IF (WW < WMINK .AND. (PRECRK+PRECSK) == 0.) THEN
                PID = 0.
            ELSE
                PID = HH
            END IF
!---------------- 
! QW, QI AND QINT
!----------------
            IF (PID == 1.) THEN
                CONDE  = CONSTA * DETAL
                RCONDE = 1. / CONDE
                TK     = TT
                QK     = QQ
                TMT0   = (TK - 273.16)     * HH
                TMT15  = AMIN1(TMT0, -15.) * HH
                AI     = 0.008855
                BI     = 1.
!
                IF (TMT0 < -20.) THEN
                    AI = 0.007225
                    BI = 0.9674
                END IF
!            
                QW   = HH *  PQ0 / (PDSL * AETAL + PT) * EXP(HH * A2 * (TK - A3) / (TK - A4))
                QI   = QW * (BI  + AI * AMIN1(TMT0, 0.))
                QINT = QW * (1. - 0.00032 * TMT15 * (TMT15 + 15.))
!
                IF (TMT0 <= -40.) QINT = QI
!-----------------------
! ICE-WATER ID NUMBER IW 
!-----------------------
                IF (TMT0 < -15.) THEN
                    FI = QK - U00KL * QI
                    IF (FI > 0. .OR. WW > CLIMIT) THEN
                        IWL = 1
                    ELSE
                        IWL = 0
                    END IF
                END IF
!            
                IF (TMT0 < 0.0 .AND. TMT0 >= -15.0) THEN
                    IWL = 0
                    IF (IWL1(N) == 1 .AND. WW > CLIMIT) IWL = 1
                END IF
!            
                IF (TMT0 >= 0.) THEN
                    IWL = 0
                END IF
!--------------------------------
! THE SATUATION SPECIFIC HUMIDITY 
!--------------------------------
                FIW = FLOAT(IWL)
                QC  = (1. - FIW) * QINT + FIW * QI
!---------------------- 
! THE RELATIVE HUMIDITY 
!---------------------- 
                IF (QC <= 0.) THEN
                    RQ = 1.E-10
                ELSE
                    RQ = QK / QC
                END IF
!---------------------- 
! CLOUD COVER RATIO CCR
!---------------------- 
                IF (RQ <= U00KL) THEN
                    CCR = 0.
                ELSE
                    RQKLL = AMIN1(US, RQ)
                    CCR   = 1. - SQRT((US - RQKLL) / (US - U00KL))
                END IF
!---------------------------------------------------- 
! CORRECT CCR IF IT IS TOO SMALL IN LARGE CWM REGIONS
!---------------------------------------------------- 
                IF (CCR >= 0.01 .AND. CCR <= 0.2 .AND. WW >= 0.2E-3) THEN
                    CCR = AMIN1(1., WW * 1.0E3)
                END IF
            END IF
!
         60 CONTINUE
!------------------------------- 
! PRECIPITATION PRODUCTION RATES 
!       AUTO-CONVERT RATES 
!------------------------------- 
            IF (PID == 1.) THEN
                IWK  = IWL
                CWMK = AMAX1(0., WW - CLIMIT)
                MI0  = WMINK
!            
                IF (IWK == 1) THEN
                    EXPF  = EXP(0.025 * TMT0)
                    AA1   = 1.E-3 * EXPF
                    PSAUT = AA1 * AMAX1(0., CWMK - MI0)
                    CPDR  = -PSAUT * TWODT
!
                    IF (-CPDR >= CWMK) THEN
                        CPDR  = -CWMK
                        PSAUT = -CPDR * RTWODT
                    END IF
                ELSE
                    AMAXCM = AMAX1(0., CWMK - MI0)
                    PRAUT  = C0 * AMAXCM * AMAXCM
                    CPDR   = -PRAUT * TWODT
!
                    IF (-CPDR >= CWMK) THEN
                        CPDR  = -CWMK
                        PRAUT = -CPDR * RTWODT
                    END IF
                END IF
                PPR = PRAUT * CONDE
                PPS = PSAUT * CONDE
            END IF
!        
            IF (PID == 1.) THEN
                WW = CPDR * HH + WW
!
                PRECRL = PRECRL1(N) + PPR * HH
                PRECSL = PRECSL1(N) + PPS * HH
            END IF
!----------- 
! ACCRETIONS 
!-----------  
            IF (PID == 1.) THEN
                IWK  = IWL
                CWMK = WW
!
                PRECRK = AMAX1(0., PRECRL1(N))
                PRECSK = AMAX1(0., PRECSL1(N))
!
                IF (IWK == 1) THEN
                    EXPF  = EXP(0.025 * TMT0)
                    CS    = AA2    * EXPF
                    PSACI = CS     * AMAX1(0., CWMK) * PRECSK
                    CPDR  = -PSACI * TWODT
!
                    IF (-CPDR >= CWMK) THEN
                        CPDR  = -CWMK
                        PSACI = -CPDR * RTWODT
                    END IF
                ELSE
                    PRACW = CR     * AMAX1(0., CWMK) * (PRECRK + PRECSK)
                    CPDR  = -PRACW * TWODT
!
                    IF (-CPDR >= CWMK) THEN
                        CPDR  = -CWMK
                        PRACW = -CPDR * RTWODT
                    END IF
                END IF
                PPR = PRACW * CONDE
                PPS = PSACI * CONDE
            END IF
!        
            IF (PID == 1.) THEN
                WW = CPDR * HH + WW
                PRECRL = PRECRL + PPR * HH
                PRECSL = PRECSL + PPS * HH
            END IF
!------------------------------------------  
! EVAPORATION/CONDENSATION OF PRECIPITATION 
! ERR AND ERS POSITIVE--EVAPORATION
! ERR AND ERS NEGTIVE---CONDENSATION
!------------------------------------------
            IF (PID == 1.0) THEN
                QK    = QQ
                TMT0K = TMT0
!
                IF (TMT0K < -30.) TMT0K = -30.
                PRECRK = AMAX1(0., PRECRL)
                PRECSK = AMAX1(0., PRECSL)
!------------------------------------------------------------ 
! INCREASE THE EVAPORATION/CONDENSATION FOR STRONG/LIGHT PREC
!------------------------------------------------------------ 
                U00KLT = U00KL
                AMAXRQ = AMAX1(0., U00KL - RQ)
                ERR    = KE * AMAXRQ * PRECRK ** 0.5
!            
                IF (TMT0 >= 0.) THEN
                    ERS = 0.
                ELSE
                    ERS = (CRS1 + CRS2 * TMT0K) * AMAXRQ * PRECSK / U00KLT
                END IF
!            
                IF (ERR + ERS <= 1.E-20) GO TO 125
!------------------------------------  
! CORRECT IF OVER-EVAPO./COND. OCCURS
!------------------------------------ 
                HHT   = HH * TWODT
                TTEMP = TT - RCP * (ELWV * ERR + ELIV * ERS) * HHT
                QTEMP = QQ + HHT * (       ERR        + ERS)
!
                TMT0T = (TTEMP - 273.16) * HH
!
                IF (TMT0T < -30.) TMT0T = -30.
!
                TMT15T = AMIN1(TMT0T, -15.) * HH
                AI = 0.008855
                BI = 1.
!            
                IF (TMT0T < -20.) THEN
                    AI = 0.007225
                    BI = 0.9674
                END IF
!            
                QWT = HH  * PQ0 / (PDSL * AETAL + PT) * EXP(HH * A2 * (TTEMP - A3) / (TTEMP - A4))
                QIT = QWT * (BI + AI * AMIN1(TMT0T, 0.))
                QINTT=QWT * (1. - 0.00032 * TMT15T * (TMT15T + 15.))
!
                IF (TMT0T <= -40.) QINTT = QIT
                FIW = FLOAT(IWL)
                QCT = (1. - FIW) * QINTT + FIW * QIT
!            
                IF (QCT <= 1.E-10) THEN
                     RQT = 1.E-10
                    RQTT = 1.E-10
                ELSE
                    RQT  = QTEMP / QCT
                    RQTT = QQ    / QCT
                END IF
!            
                IF (RQT <= U00KL) GO TO 125
!            
                ERK  = (U00KL - RQTT) * QCT * RTWODT
                RPRS = ERK / (PRECRK + PRECSK)
!
                ERRT =PRECRK  * RPRS
                ERST = PRECSK * RPRS
!
                ERR = AMAX1(0., 0.5 * (ERR + ERRT))
                ERS = AMAX1(0., 0.5 * (ERS + ERST))
!            
            125 CONTINUE
!            
                PPR = -ERR * CONDE
                PPS = -ERS * CONDE
!            
                IF (-PPR >= PRECRK) THEN
                    PPR = -PRECRK
                    ERR = -PPR * RCONDE
                END IF
!            
                IF (-PPS >= PRECSK) THEN
                    PPS = -PRECSK
                    ERS = -PPS * RCONDE
                END IF
!            
            END IF
!        
            IF (PID == 1.) THEN
                PRECRL = PRECRL + PPR * HH
                PRECSL = PRECSL + PPS * HH
            END IF
!-------------------- 
! MELTING OF THE SNOW 
!-------------------- 
            IF (PID == 1.) THEN
                CWMK   = WW
                AMAXPS = AMAX1(0., PRECSL)
!            
                IF (TMT0 > 0.) THEN
                    PSM1 = CSM1 * TMT0 * TMT0 * AMAXPS
                    PSM2 = CWS  * CR   * CWMK * AMAXPS
                    PSM  = PSM1 + PSM2
                ELSE
                    PSM1 = 0.
                    PSM2 = 0.
                    PSM  = 0.
                END IF
!            
                PPR =  PSM * CONDE
                PPS = -PSM * CONDE
!            
                IF (-PPS >= AMAXPS) THEN
                    PPS  = -AMAXPS
                    PPR  =  AMAXPS
!
                    PSM1 = -PPS * RCONDE
                    PSM2 = 0.
                    PSM  = PSM1
                END IF
!            
            END IF
!        
            IF (PID == 1.) THEN
                PRECRL = PRECRL + PPR * HH
                PRECSL = PRECSL + PPS * HH
            END IF
!--------------- 
! UPDATE T AND Q 
!---------------
            IF (PID == 1.) THEN
                HHT= HH * TWODT
                TT = -RCP * (ELWV * ERR + ELIV * ERS + ELIW * PSM1) * HHT + TT
                QQ = (ERR + ERS) * HHT + QQ
!
                TTLAT = -RCP  * (ELWV  * ERR + ELIV * ERS + ELIW * PSM1 - ELWV * (PRAUT + PRACW)    &
    &                 -  ELIV * (PSAUT + PSACI))    * HHT + TTLAT
            END IF
!        
            IF (HH == 1.) THEN
                   IWL1(N) = IWL
                PRECRL1(N) = PRECRL
                PRECSL1(N) = PRECSL
            END IF
!--------------------------------------------------------------------------------------------------        
! ACCUMULATE LATENT HEATING DUE TO GRID-SCALE PRECIP/EVAP. SCALE BY THE RECIPROCAL OF THE PERIOD AT
! WHICH THIS ROUTINE IS CALLED.
! THIS PERIOD IS THE PHYSICS TIMESTEP.
!-------------------------------------------------------------------------------------------------- 
            TRAIN_T(K,I,J) = TRAIN_T(K,I,J) + (TT-T_T(K,I,J)) * RDTPH
                T_T(K,I,J) = TT
                Q_T(K,I,J) = QQ
              CWM_T(K,I,J) = WW
             TLAT_T(K,I,J) = TTLAT
    180 END DO
!------------------------- 
! THE PRECIPITATION ON SFC 
!------------------------- 
        PRECRS = PRECRL1(N) * RROW
        PRECSS = PRECSL1(N) * RROW
!    
         APREC(I,J) = PRECRS + PRECSS
          PREC(I,J) =   PREC(I,J) + PRECRS + PRECSS
        ACPREC(I,J) = ACPREC(I,J) + APREC(I,J)
!-------------------------------------------- 
! THE SNOW AND RAIN RATIO OF SFC PREC 
! SR IS THE RATIO OF SNOW TO THE TOTAL PRECIP 
! IF TOTAL PRECIP IS ZERO, SR IS ZERO- 
!-------------------------------------------- 
        TOTPPT = PRECRS + PRECSS
        IF (TOTPPT > 1.E-8) THEN
            SR(I,J) = PRECSS / TOTPPT
        ELSE
            SR(I,J) = 0.
        END IF
!
300 END DO
!--------------- 
! TRANSPOSE BACK
!--------------- 
!
!$omp parallel sections
!$omp section
!
    CALL SGETMO(T_T    , LM, LM, LDA, T     , LDA)
!
!$omp section 
!
    CALL SGETMO(Q_T    , LM, LM, LDA, Q     , LDA)
!
!$omp section
!
    CALL SGETMO(CWM_T  , LM, LM, LDA, CWM   , LDA)
!
!$omp section
!
    CALL SGETMO(TRAIN_T, LM, LM, LDA, TRAIN , LDA)
!
!$omp section
!
    CALL SGETMO(TLAT_T , LM, LM, LDA, TLATGS, LDA)
!
!$omp end parallel sections
!
    RETURN
!
    END SUBROUTINE PRECPD
