    SUBROUTINE CUCNVC
!     ******************************************************************
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .
! SUBPROGRAM:    CUCNVC      CONVECTIVE PRECIPITATION PARAMETERIZATION
!   PRGRMMR: JANJIC          ORG: W/NP2      DATE: 93-11-02

! ABSTRACT:
!     CUCNVC CALCULATES THE SUB-GRID SCALE CONVECTION INCLUDING
!     DEEP AND SHALLOW CONVECTIVE CLOUDS FOLLOWING THE SCHEME DESCRIBED
!     BY JANJIC (1994) BUT WITH SIGNIFICANT MODIFICATIONS.  IN ADDITION,
!     THE LATENT HEAT RELEASE AND MOISTURE CHANGE DUE TO PRECIPITATING
!     AND NON-PRECIPITATING CLOUDS ARE COMPUTED.


! PROGRAM HISTORY LOG:
!   87-09-??  JANJIC     - ORIGINATOR
!   90-11-21  JANJIC     - TWO SETS OF DSP PROFILES (FAST AND SLOW)
!                          REPLACE THE ORIGINAL ONE SET
!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
!   96-03-28  BLACK      - ADDED EXTERNAL EDGE
!   98-11-02  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY

! USAGE: CALL CUCNVC FROM MAIN PROGRAM EBU

!   INPUT ARGUMENT LIST:
!     NONE

!   OUTPUT ARGUMENT LIST:
!     NONE

!   OUTPUT FILES:
!     NONE

!   SUBPROGRAMS CALLED:

!     UNIQUE:
!        TTBLEX

!     LIBRARY:
!        NONE

!   COMMON BLOCKS: CTLBLK
!                  LOOPS
!                  MASKS
!                  PHYS
!                  VRBLS
!                  CNVCLD
!                  PVRBLS
!                  ACMCLH
!                  INDX

! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!   MACHINE : IBM SP
!$$$
!     ******************************************************************
!     *                                                                *
!     *  REFERENCES:                                                   *
!     *                                                                *
!     *  JANJIC, Z.I., 1994:  THE STEP-MOUNTAIN ETA COORDINATE MODEL:  *
!     *    FURTHER DEVELOPMENTS OF THE CONVECTION, VISCOUS SUBLAYER    *
!     *    AND TURBULENCE CLOSURE SCHEMES.  MONTHLY WEATHER REVIEW,    *
!     *    VOL. 122, 927-945.                                          *
!     *                                                                *
!     ******************************************************************
! *** WARNING: THIS SUBROUTINE WILL NOT WORK IF LM.LT.12;
!              MUST BE CALLED IN THE SAME STEP WITH PROFQ2 BECAUSE PROFQ
!              DEFINES APE;

!     ==================================================================
    INCLUDE "cuparm.f90" !isr: modified cuparm
    LOGICAL :: UNIS,UNIL,OCT90

    NAMELIST/CUPARMDATA/ &
    STABS,STABD,STABFC,DTTOP &
    ,RHF,EPSUP,EPSDN,EPSTH &
    ,PBM,PQM,PNO,PONE,PSH &
    ,PFRZ,PSHU &
    ,UNIS,UNIL,OCT90 &
    ,FSS,EFIMN,EFMNT,FCC &
    ,DSPBFL,DSP0FL,DSPTFL,FSL &
    ,DSPBFS,DSP0FS,DSPTFS &
    ,TREL,EPSNTP,EFIFC &
    ,DSPC,EPSP &
    ,STEFI
!     ==================================================================

    INCLUDE "parmeta.f90"
    INCLUDE "parm.tbl.f90"
    INCLUDE "mpp.h"
!----------------------------------------------------------------------
    PARAMETER &
! VVVVVVVVV INSTABILITY FOR TOO LARGE LSH VVVVVVVVVVVVVVVVVVVVVVVVVVVVV
    (KSMUD=0,NROW= 0)
!    & (KSMUD=0,NROW= 5)
! AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    PARAMETER &
    (IMJM=IM*JM-JM/2,JAM=6+2*(JM-10) &
    , IMJM_LOC=IDIM2*JDIM2 &
! VVVVVVVVV INSTABILITY FOR TOO LARGE LSH VVVVVVVVVVVVVVVVVVVVVVVVVVVVV
!    &, LP1=LM+1,LM1=LM-1,LNO=1,LSH=LM/3-1,LSHU=LM/2-1,LQM=LM/5,KBM=3
!    &, LP1=LM+1,LM1=LM-1,LNO=1,LSH=LM/3  ,LSHU=LM/2-1,LQM=LM/5,KBM=3
!    &, LP1=LM+1,LM1=LM-1,LNO=3,LSH=LM/3  ,LSHU=LM/2-1,LQM=LM/5,KBM=3
!    &, LP1=LM+1,LM1=LM-1,LNO=2,LSH=LM/3-1,LSHU=LM/2-1,LQM=LM/5,KBM=3
!    &, LP1=LM+1,LM1=LM-1,LNO=2,LSH=LM/3-2,LSHU=LM/2-1,LQM=LM/5,KBM=3
    , LP1=LM+1,LM1=LM-1)
! AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
!----------------------------------------------------------------------
    LOGICAL :: &
    RUN,FIRST,RESTRT,SIGMA
!----------------------------------------------------------------------
    INCLUDE "COMM_CTLBLK.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_LOOPS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_MASKS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_PHYS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_VRBLS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_CNVCLD.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_PVRBLS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_ACMCLH.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_INDX.f90"
! L---------------------------------------------------------------------
    INCLUDE "COMM_PPTASM.f90"
! L---------------------------------------------------------------------
    DIMENSION &
    TREFK (LM),QREFK (LM),PK    (LM),APEK  (LM),TK    (LM) &
    ,THSK  (LM),PSK   (LM),APESK (LM),QK    (LM),THERK (LM) &
    ,THVREF(LM),THEVRF(LM),THVMOD(LM),DIFT  (LM),DIFQ  (LM) &
    ,QSATK (LM),FPK   (LM) &
    ,NTOPD (LM),NBOTD (LM),NTOPS (LM),NBOTS (LM) &
    ,NDPTHD(LM),NDPTHS(LM)

    DIMENSION &
    LTOP  (IDIM1:IDIM2,JDIM1:JDIM2),LBOT  (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,PTOP  (IDIM1:IDIM2,JDIM1:JDIM2),PBOT  (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,IPTB  (IDIM1:IDIM2,JDIM1:JDIM2),ITHTB (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,PDSL  (IDIM1:IDIM2,JDIM1:JDIM2),APEBT (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,TBT   (IDIM1:IDIM2,JDIM1:JDIM2),Q2BT  (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,QQ    (IDIM1:IDIM2,JDIM1:JDIM2),PP    (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,PSP   (IDIM1:IDIM2,JDIM1:JDIM2),THBT  (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,THESP (IDIM1:IDIM2,JDIM1:JDIM2),P     (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,BTH   (IDIM1:IDIM2,JDIM1:JDIM2),STH   (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,T00   (IDIM1:IDIM2,JDIM1:JDIM2),T10   (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,T01   (IDIM1:IDIM2,JDIM1:JDIM2),T11   (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,WF1   (IDIM1:IDIM2,JDIM1:JDIM2),WF2   (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,WF3   (IDIM1:IDIM2,JDIM1:JDIM2),WF4   (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,PRECOL(IDIM1:IDIM2,JDIM1:JDIM2) &

    ,IBUOY (IMJM_LOC),JBUOY (IMJM_LOC) &
    ,IDEEP (IMJM_LOC),JDEEP (IMJM_LOC) &
    ,ISHAL (IMJM_LOC),JSHAL (IMJM_LOC) &
    ,ILRES (IMJM_LOC),JLRES (IMJM_LOC) &
    ,IHRES (IMJM_LOC),JHRES (IMJM_LOC) &

    ,APE   (IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,TREF  (IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,TMOD  (IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,QMOD  (IDIM1:IDIM2,JDIM1:JDIM2,LM)

    DIMENSION &
    DSPB  (IDIM1:IDIM2,JDIM1:JDIM2),DSP0  (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,DSPT  (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,TL    (IDIM1:IDIM2,JDIM1:JDIM2),QL    (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,TNE   (IDIM1:IDIM2,JDIM1:JDIM2),TSE   (IDIM1:IDIM2,JDIM1:JDIM2) &
    ,QNE   (IDIM1:IDIM2,JDIM1:JDIM2),QSE   (IDIM1:IDIM2,JDIM1:JDIM2)

!     ==================================================================
    OPEN(11,FILE='cuparmdata.dat',STATUS='OLD') !isr
    REWIND 11
    READ(11,CUPARMDATA)
    CLOSE(11)

    FCB=1.-FCC
    DSPBSL=DSPBFL*FSL
    DSP0SL=DSP0FL*FSL
    DSPTSL=DSPTFL*FSL
    DSPBSS=DSPBFS*FSS
    DSP0SS=DSP0FS*FSS
    DSPTSS=DSPTFS*FSS
    AVGEFI=(EFIMN+1.)*.5
    SLOPBL=(DSPBFL-DSPBSL)/(1.-EFIMN)
    SLOP0L=(DSP0FL-DSP0SL)/(1.-EFIMN)
    SLOPTL=(DSPTFL-DSPTSL)/(1.-EFIMN)
    SLOPBS=(DSPBFS-DSPBSS)/(1.-EFIMN)
    SLOP0S=(DSP0FS-DSP0SS)/(1.-EFIMN)
    SLOPTS=(DSPTFS-DSPTSS)/(1.-EFIMN)
    SLOPE=(1.-EFMNT)/(1.-EFIMN)
    A23M4L=A2*(A3-A4)*ELWV
    ELOCP=ELIVW/CP
    CPRLG=CP/(ROW*G*ELWV)
    RCP=1./CP
!     ==================================================================
    CALL ZERO2(DSP0)
    CALL ZERO2(DSPB)
    CALL ZERO2(DSPT)
    CALL ZERO2(PSP)
!----------------------------------------------------------------------
    AVCNVC=AVCNVC+1.
    ACUTIM=ACUTIM+1.
    DTCNVC=NCNVC*DT
    RDTCNVC=1./DTCNVC
    TAUK=DTCNVC/TREL
! possible future change for shallow convection
!      TAUKSC=DTCNVC/(5.*TREL)
!-----------------------------------------------------------------------
!************************** DIAGNOSTICS ********************************
!-----------------------------------------------------------------------
    DO L=1,LM
        NTOPD (L)=0
        NBOTD (L)=0
        NTOPS (L)=0
        NBOTS (L)=0
        NDPTHS(L)=0
        NDPTHD(L)=0
    ENDDO
!***********************************************************************
!---------------------------PREPARATIONS--------------------------------
!-----------------------------------------------------------------------
! omp parallel do
    DO 120 J=MYJS,MYJE
        DO 120 I=MYIS,MYIE
            LBOT (I,J)=LMH(I,J)
            THESP(I,J)=0.
            PDSL (I,J)=RES(I,J)*PD(I,J)
            PRECOL(I,J)=0.
            TREF(I,J,1)=T(I,J,1)
    120 END DO
!-----------------------------------------------------------------------
!--------------PADDING SPECIFIC HUMIDITY IF TOO SMALL-------------------
!                  RESTORE APE TO SCRATCH ARRAY
!-----------------------------------------------------------------------
! omp parallel do private(apests)
    DO 130 L=1,LM
        DO J=MYJS,MYJE
            DO I=MYIS,MYIE
                APESTS=PDSL(I,J)*AETA(L)+PT
                APE(I,J,L)=(1.E5/APESTS)**CAPA
                IF(Q(I,J,L) < EPSQ)Q(I,J,L)=HTM(I,J,L)*EPSQ
            ENDDO
        ENDDO
    130 END DO
!-----------------------------------------------------------------------
!--------------SEARCH FOR MAXIMUM BUOYANCY LEVEL------------------------
!-----------------------------------------------------------------------
    DO 170 KB=1,LM
    !-----------------------------------------------------------------------
    !--------------TRIAL MAXIMUM BUOYANCY LEVEL VARIABLES-------------------
    !-----------------------------------------------------------------------
    ! omp parallel do
    ! omp&  private(apesp,bq,bqs00k,bqs10k,iq,it,ittb,ittbk,iqtb,
    ! omp&          lmhk,p00k,p01k,p10k,p11k,pkl,pp1,psfck,qbt,qq1,
    ! omp&          sq,sqs00k,sqs10k,tpsp,tq,tth,tthbt,tthes)
        DO 155 J=MYJS2,MYJE2
            DO 150 I=MYIS1,MYIE1
            
                PKL=AETA(KB)*PDSL(I,J)+PT
                LMHK=LMH(I,J)
                PSFCK=AETA(LMHK)*PDSL(I,J)+PT
            ! now searching over a scaled depth in finding the parcel
            !   with the max theta-e instead of the old 130 mb
            !     IF(PKL.LT.PSFCK-PBM)GO TO 150
            !     IF(KB.GT.LMHK)GO TO 150
                IF(KB <= LMHK .AND. PKL >= 0.80*PSFCK) THEN
                    QBT=Q(I,J,KB)
                    TTHBT=T(I,J,KB)*APE(I,J,KB)
                    TTH=(TTHBT-THL)*RDTH
                    QQ1=TTH-AINT(TTH)
                    ITTB=INT(TTH)+1
                !--------------KEEPING INDICES WITHIN THE TABLE-------------------------
                    IF(ITTB < 1)THEN
                        ITTB=1
                        QQ1=0.
                    ENDIF
                    IF(ITTB >= JTB)THEN
                        ITTB=JTB-1
                        QQ1=0.
                    ENDIF
                    CONTINUE
                !--------------BASE AND SCALING FACTOR FOR SPEC. HUMIDITY---------------
                    ITTBK=ITTB
                    BQS00K=QS0(ITTBK)
                    SQS00K=SQS(ITTBK)
                    BQS10K=QS0(ITTBK+1)
                    SQS10K=SQS(ITTBK+1)
                !--------------SCALING SPEC. HUMIDITY & TABLE INDEX---------------------
                    BQ  = (BQS10K-BQS00K)*QQ1+BQS00K
                    SQ  = (SQS10K-SQS00K)*QQ1+SQS00K
                    TQ  = (QBT-BQ)/SQ*RDQ
                    PP1  =TQ - AINT(TQ)
                    IQTB=INT(TQ)+1
                !--------------KEEPING INDICES WITHIN THE TABLE-------------------------
                    IF(IQTB < 1)THEN
                        IQTB=1
                        PP1=0.
                    ENDIF
                    IF(IQTB >= ITB)THEN
                        IQTB=ITB-1
                        PP1=0.
                    ENDIF
                !--------------SATURATION PRESSURE AT FOUR SURROUNDING TABLE PTS.-------
                    IQ=IQTB
                    IT=ITTB
                    P00K=PTBL(IQ  ,IT  )
                    P10K=PTBL(IQ+1,IT  )
                    P01K=PTBL(IQ  ,IT+1)
                    P11K=PTBL(IQ+1,IT+1)
                !--------------SATURATION POINT VARIABLES AT THE BOTTOM-----------------
                    TPSP=P00K+(P10K-P00K)*PP1+(P01K-P00K)*QQ1 &
                    +(P00K-P10K-P01K+P11K)*PP1*QQ1
                    APESP=(1.E5/TPSP)**CAPA
                    TTHES=TTHBT*EXP(ELOCP*QBT*APESP/TTHBT)
                !--------------CHECK FOR MAXIMUM BUOYANCY-------------------------------
                    IF(TTHES > THESP(I,J))THEN
                        PSP  (I,J)=TPSP
                        THBT (I,J)=TTHBT
                        THESP(I,J)=TTHES
                    ENDIF
                ENDIF
            150 END DO
        155 END DO
    !-----------------------------------------------------------------------
    170 END DO
!-----------------------------------------------------------------------
!---------CHOOSE CLOUD BASE AS MODEL LEVEL JUST BELOW PSP--------------
!-----------------------------------------------------------------------
    DO 240 L=1,LM1
        AETAL=AETA(L)
    
    ! omp parallel do
        DO J=MYJS2,MYJE2
            DO I=MYIS,MYIE
                P(I,J)=PDSL(I,J)*AETAL+PT
                IF(P(I,J) < PSP(I,J) .AND. P(I,J) >= PQM)LBOT(I,J)=L+1
            ENDDO
        ENDDO
    
    240 END DO
!***
!*** WARNING: LBOT MUST NOT BE GT LMH(I,J)-1 IN SHALLOW CONVECTION
!*** MAKE SURE CLOUD BASE IS AT LEAST PONE ABOVE THE SURFACE
!***
! omp parallel do private(lmhij,psfck)
    DO 250 J=MYJS2,MYJE2
        DO 250 I=MYIS,MYIE
            LMHIJ=LMH(I,J)
            PBOT(I,J)=AETA(LBOT(I,J))*PDSL(I,J)+PT
            PSFCK=AETA(LMHIJ)*PDSL(I,J)+PT
            IF(PBOT(I,J) >= PSFCK-PONE .OR. LBOT(I,J) >= LMHIJ)THEN
            
                DO L=1,LMHIJ-1
                    P(I,J)=AETA(L)*PDSL(I,J)+PT
                    IF(P(I,J) < PSFCK-PONE)LBOT(I,J)=L
                ENDDO
            
                PBOT(I,J)=AETA(LBOT(I,J))*PDSL(I,J)+PT
            ENDIF
    250 END DO
!--------------CLOUD TOP COMPUTATION------------------------------------
! omp parallel do
    DO J=MYJS,MYJE
        DO I=MYIS,MYIE
            LTOP(I,J)=LBOT(I,J)
            PTOP(I,J)=PBOT(I,J)
        ENDDO
    ENDDO
!-----------------------------------------------------------------------
! omp parallel do
! omp&  private(ihres,ilres,iptb,ithtb,jhres,jlres,
! omp&          knumh,knuml,pp,presk,qq)

    DO 290 L=LM,1,-1
    
    !--------------SCALING PRESSURE & TT TABLE INDEX------------------------
        KNUML=0
        KNUMH=0
    
        DO 270 J=MYJS2,MYJE2
            DO 270 I=MYIS1,MYIE1
                PRESK=PDSL(I,J)*AETA(L)+PT
                IF(PRESK < PLQ)THEN
                    KNUML=KNUML+1
                    ILRES(KNUML)=I
                    JLRES(KNUML)=J
                ELSE
                    KNUMH=KNUMH+1
                    IHRES(KNUMH)=I
                    JHRES(KNUMH)=J
                ENDIF
        270 END DO
    !***
    !***  COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE<PL
    !**
        IF(KNUML > 0)THEN
            CALL TTBLEX(TREF(IDIM1,JDIM1,L),TTBL,ITB,JTB,KNUML &
            ,             ILRES,JLRES,PDSL,AETA(L),HTM(IDIM1,JDIM1,L) &
            ,             PT,PL,QQ(IDIM1,JDIM1),PP(IDIM1,JDIM1) &
            ,             RDP,THE0,STHE,RDTHE &
            ,             THESP(IDIM1,JDIM1),IPTB(IDIM1,JDIM1) &
            ,             ITHTB(IDIM1,JDIM1))
        ENDIF
    !***
    !***  COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PL
    !**
        IF(KNUMH > 0)THEN
            CALL TTBLEX(TREF(IDIM1,JDIM1,L),TTBLQ,ITBQ,JTBQ,KNUMH &
            ,             IHRES,JHRES,PDSL,AETA(L),HTM(IDIM1,JDIM1,L) &
            ,             PT,PLQ,QQ(IDIM1,JDIM1),PP(IDIM1,JDIM1) &
            ,             RDPQ,THE0Q,STHEQ,RDTHEQ &
            ,             THESP(IDIM1,JDIM1),IPTB(IDIM1,JDIM1) &
            ,             ITHTB(IDIM1,JDIM1))
        ENDIF
    290 END DO
!--------------BUOYANCY CHECK-------------------------------------------
    DO 295 L=LM,1,-1
    ! omp parallel do
        DO J=MYJS2,MYJE2
            DO I=MYIS1,MYIE1
                IF(TREF(I,J,L) > T(I,J,L)-DTTOP)LTOP(I,J)=L
            ENDDO
        ENDDO
    !-----------------------------------------------------------------------
    295 END DO
!-----------------CLOUD TOP PRESSURE------------------------------------
! omp parallel do
    DO J=MYJS2,MYJE2
        DO I=MYIS1,MYIE1
            PTOP(I,J)=AETA(LTOP(I,J))*PDSL(I,J)+PT
        ENDDO
    ENDDO
!-----------------------------------------------------------------------
!--------------DEFINE AND SMOOTH DSPS AND CLDEFI------------------------
! ************ UNIFIED OR SEPARATE LAND/SEA CONV ***********************
!-----------------------------------------------------------------------

    IF(UNIS)THEN
    ! omp parallel do private(efi)
        DO J=MYJS,MYJE
            DO I=MYIS,MYIE
                EFI=CLDEFI(I,J)
                DSPB(I,J)=(EFI-EFIMN)*SLOPBS+DSPBSS
                DSP0(I,J)=(EFI-EFIMN)*SLOP0S+DSP0SS
                DSPT(I,J)=(EFI-EFIMN)*SLOPTS+DSPTSS
            ENDDO
        ENDDO
    ELSEIF( .NOT. UNIL)THEN
    ! omp parallel do private(efi)
        DO J=MYJS,MYJE
            DO I=MYIS,MYIE
                EFI=CLDEFI(I,J)
                DSPB(I,J)=((EFI-EFIMN)*SLOPBS+DSPBSS)*SM(I,J) &
                +((EFI-EFIMN)*SLOPBL+DSPBSL)*(1.-SM(I,J))
                DSP0(I,J)=((EFI-EFIMN)*SLOP0S+DSP0SS)*SM(I,J) &
                +((EFI-EFIMN)*SLOP0L+DSP0SL)*(1.-SM(I,J))
                DSPT(I,J)=((EFI-EFIMN)*SLOPTS+DSPTSS)*SM(I,J) &
                +((EFI-EFIMN)*SLOPTL+DSPTSL)*(1.-SM(I,J))
            ENDDO
        ENDDO
    ELSE
    ! omp parallel do private(efi)
        DO J=MYJS,MYJE
            DO I=MYIS,MYIE
                EFI=CLDEFI(I,J)
                DSPB(I,J)=((EFI-EFIMN)*SLOPBL+DSPBSL)
                DSP0(I,J)=((EFI-EFIMN)*SLOP0L+DSP0SL)
                DSPT(I,J)=((EFI-EFIMN)*SLOPTL+DSPTSL)
            ENDDO
        ENDDO
    ENDIF

!--------------EXTENDING SEA STRUCTURES INLAND ALONG COASTLINE----------
    IF(NROW > 0 .AND. .NOT. UNIS .AND. .NOT. UNIL)THEN
    ! omp parallel do
        DO J=MYJS,MYJE
            DO I=MYIS,MYIE
                WF1(I,J)=0.
                WF2(I,J)=0.
                WF3(I,J)=0.
                WF4(I,J)=0.
            ENDDO
        ENDDO
    
        KROW=NROW
    
        DO 350 KOUNT=1,KROW
        ! omp parallel do
            DO 345 J=MYJS2,MYJE2
                DO 345 I=MYIS1,MYIE1
                    WF1(I,J)=(DSPB(I+IHW(J),J-1)+DSPB(I+IHE(J),J-1) &
                    +DSPB(I+IHW(J),J+1)+DSPB(I+IHE(J),J+1)+4.*DSPB(I,J)) &
                    *HBM2(I,J)*0.125
                    WF2(I,J)=(DSP0(I+IHW(J),J-1)+DSP0(I+IHE(J),J-1) &
                    +DSP0(I+IHW(J),J+1)+DSP0(I+IHE(J),J+1)+4.*DSP0(I,J)) &
                    *HBM2(I,J)*0.125
                    WF3(I,J)=(DSPT(I+IHW(J),J-1)+DSPT(I+IHE(J),J-1) &
                    +DSPT(I+IHW(J),J+1)+DSPT(I+IHE(J),J+1)+4.*DSPT(I,J)) &
                    *HBM2(I,J)*0.125
                    WF4(I,J)=(CLDEFI(I+IHW(J),J-1)+CLDEFI(I+IHE(J),J-1) &
                    +CLDEFI(I+IHW(J),J+1)+CLDEFI(I+IHE(J),J+1)+4.*CLDEFI(I,J)) &
                    *HBM2(I,J)*0.125
            345 END DO
        
        ! omp parallel do private(rsmk,smk)
            DO J=MYJS,MYJE
                DO I=MYIS,MYIE
                    SMK =SM(I,J)
                    RSMK=1.-SMK
                    DSPB  (I,J)=DSPB  (I,J)*SMK+WF1(I,J)*RSMK
                    DSP0  (I,J)=DSP0  (I,J)*SMK+WF2(I,J)*RSMK
                    DSPT  (I,J)=DSPT  (I,J)*SMK+WF3(I,J)*RSMK
                    CLDEFI(I,J)=CLDEFI(I,J)*SMK+WF4(I,J)*RSMK
                ENDDO
            ENDDO
        
        350 END DO
    !-----------------------------------------------------------------------
    ENDIF
!--------------INITIALIZE CHANGES OF T AND Q DUE TO CONVECTION----------
! omp parallel do
    DO 360 L=1,LM
        DO J=MYJS,MYJE
            DO I=MYIS,MYIE
                TMOD(I,J,L)=0.
                QMOD(I,J,L)=0.
            ENDDO
        ENDDO
    360 END DO
!--------------CLEAN UP AND GATHER DEEP CONVECTION POINTS---------------
! omp parallel do
    DO 380 J=MYJS2,MYJE2
        DO 380 I=MYIS1,MYIE1
            IF(LTOP(I,J) >= LBOT(I,J))THEN
                LBOT(I,J)=0
                LTOP(I,J)=LBOT(I,J)
                PTOP(I,J)=PBOT(I,J)
            ENDIF
            IF(HBM2(I,J) < 0.90)THEN
                LBOT(I,J)=0
                LTOP(I,J)=LBOT(I,J)
                PTOP(I,J)=PBOT(I,J)
            ENDIF
            IF(PTOP(I,J) > PBOT(I,J)-PNO .OR. LTOP(I,J) > LBOT(I,J)-2) &
            CLDEFI(I,J)=AVGEFI*SM(I,J)+STEFI*(1.-SM(I,J))
    380 END DO

    KHDEEP=0
    PSHNEW=20000.
    DO J=MYJS2,MYJE2
        DO I=MYIS1,MYIE1
            PSFCIJ=PD(I,J)+PT
        ! depth of cloud required to make the point a deep convection point
        !  is now a scaled value of the PSFC instead of 290 mb everywhere
            DEPMIN=PSHNEW*PSFCIJ*1.E-5
            DEPTH=PBOT(I,J)-PTOP(I,J)
            IF(DEPTH >= DEPMIN) THEN
            !        IF(PTOP(I,J).LT.PBOT(I,J)-PSH)THEN
                KHDEEP=KHDEEP+1
                IDEEP(KHDEEP)=I
                JDEEP(KHDEEP)=J
            ENDIF
        ENDDO
    ENDDO
!************* HORIZONTAL LOOP FOR DEEP CONVECTION *********************
! omp parallel do
! omp&  private(apek,apekl,apekxx,apekxy,apesk,avrgt,avtgtl,dentpy,
! omp&          depmin,depth,depwl,dhdt,difq,difql,dift,diftl,drheat,
! omp&          drhdp,dsp,dsp0k,dspbk,dsptk,dthem,efi,fefi,hcorr,
! omp&          i,j,l0,l0m1,lb,lbm1,lbtk,lcor,lqm,lshu,ltp1,ltp2,
! omp&          ltpk,ltsh,pbtk,pk,pk0,pkb,pkl,pkt,preck,psfcij,psk,
! omp&          pthrs,ptpk,qk,qkl,qrefk,qsatk,rdp0t,rhh,rhl,rhmax,
! omp&          sumde,sumdp,therk,therkx,therky,thsk,thskl,tk,tkl,
! omp&          trefk,trefkx,tskl)
!***********************************************************************
    DO 600 N=1,KHDEEP
    !***********************************************************************
        I=IDEEP(N)
        J=JDEEP(N)
        PSFCIJ=PD(I,J)+PT
        LTPK=LTOP(I,J)
        LBTK=LBOT(I,J)
    ! CDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
    ! CDCDCDCDCDC  DEEP CONVECTION   DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
    ! CDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
        LB   =LBTK
        EFI  =CLDEFI(I,J)
        DSPBK=DSPB  (I,J)
        DSP0K=DSP0  (I,J)
        DSPTK=DSPT  (I,J)
    !--------------INITIALIZE VARIABLES IN THE CONVECTIVE COLUMN------------
    !***
    !***  ONE SHOULD NOTE THAT THE VALUES ASSIGNED TO THE ARRAY TREFK
    !***  IN THE 410 LOOP ARE REALLY ONLY RELEVANT IN ANCHORING THE
    !***  REFERENCE TEMPERATURE PROFILE AT LEVEL LB.  WHEN BUILDING THE
    !***  REFERENCE PROFILE FROM CLOUD BASE, THEN ASSIGNING THE
    !***  AMBIENT TEMPERATURE TO TREFK IS ACCEPTABLE.  HOWEVER, WHEN
    !***  BUILDING THE REFERENCE PROFILE FROM SOME OTHER LEVEL (SUCH AS
    !***  ONE LEVEL ABOVE THE GROUND), THEN TREFK SHOULD BE FILLED WITH
    !***  THE TEMPERATURES IN TREF(I,J,L) WHICH ARE THE TEMPERATURES OF
    !***  THE MOIST ADIABAT THROUGH CLOUD BASE.  BY THE TIME THE LINE
    !***  NUMBERED 450 HAS BEEN REACHED, TREFK ACTUALLY DOES HOLD THE
    !***  REFERENCE TEMPERATURE PROFILE.
    !***
        DO 410 L=1,LM
            DIFT  (L)=0.
            DIFQ  (L)=0.
            TKL      =T(I,J,L)
            TK    (L)=TKL
            TREFK (L)=TKL
            QKL      =Q(I,J,L)
            QK    (L)=QKL
            QREFK (L)=QKL
            PKL      =AETA(L)*PDSL(I,J)+PT
            PK    (L)=PKL
            PSK   (L)=PKL
            APEKL    =APE(I,J,L)
            APEK  (L)=APEKL
            THERK (L)=TREF(I,J,L)*APEKL
        ! 410 THVMOD(L)=(QKL*0.608+1.)*TKL*APEKL
        410 END DO
    !--------------DEEP CONVECTION REFERENCE TEMPERATURE PROFILE------------
        LTP1=LTPK+1
        LBM1=LB-1
        PKB=PK(LB)
        PKT=PK(LTPK)
    !--------------TEMPERATURE REFERENCE PROFILE BELOW FREEZING LEVEL-------
        L0=LB
        PK0=PK(LB)
        TREFKX=TREFK(LB)
        THERKX=THERK(LB)
        APEKXX=APEK(LB)
        THERKY=THERK(LBM1)
        APEKXY=APEK(LBM1)
    
        DO 420 L=LBM1,LTPK,-1
            IF(T(I,J,L+1) < TFRZ)GO TO 430
            STABDL=STABD
            TREFKX=((THERKY-THERKX)*STABDL &
            +TREFKX*APEKXX)/APEKXY
            TREFK(L)=TREFKX
            APEKXX=APEKXY
            THERKX=THERKY
            APEKXY=APEK(L-1)
            THERKY=THERK(L-1)
            L0=L
            PK0=PK(L0)
        420 END DO
    !--------------FREEZING LEVEL AT OR ABOVE THE CLOUD TOP-----------------
        L0M1=L0-1
        GO TO 450
    !--------------TEMPERATURE REFERENCE PROFILE ABOVE FREEZING LEVEL-------
        430 L0M1=L0-1
        RDP0T=1./(PK0-PKT)
        DTHEM=THERK(L0)-TREFK(L0)*APEK(L0)
    
        DO L=LTPK,L0M1
            TREFK(L)=(THERK(L)-(PK(L)-PKT)*DTHEM*RDP0T)/APEK(L)
        ENDDO
    !-----------------------------------------------------------------------
    !--------------DEEP CONVECTION REFERENCE HUMIDITY PROFILE---------------
    !-----------------------------------------------------------------------
    !  reference profile had been too dry in the case where the cloud
    !   base was close to the freezing level - this is now changed
        450 DEPTH=PFRZ*PSFCIJ*1.E-5
        DEPWL=PKB-PK0
        DO 460 L=LTPK,LB
        !-----------------------------------------------------------------------
        !--------------SATURATION PRESSURE DIFFERENCE---------------------------
        !-----------------------------------------------------------------------
        !     IF(PKB-PK0.GE.PFRZ)THEN
            IF(DEPWL >= DEPTH) THEN
                IF(L < L0)THEN
                    DSP=((PK0-PK(L))*DSPTK+(PK(L)-PKT)*DSP0K)/(PK0-PKT)
                ELSE
                    DSP=((PKB-PK(L))*DSP0K+(PK(L)-PK0)*DSPBK)/(PKB-PK0)
                ENDIF
            ELSE
            !       DSP=DSPC
                DSP=DSP0K
                IF(L < L0) &
                DSP=( (PK0-PK(L))*DSPTK+(PK(L)-PKT)*DSP0K)/(PK0-PKT)
            ENDIF

        !--------------HUMIDITY PROFILE-----------------------------------------
            IF(PK(L) > PQM)THEN
                PSK(L)=PK(L)+DSP
                APESK(L)=(1.E5/PSK(L))**CAPA
                THSK(L)=TREFK(L)*APEK(L)
                QREFK(L)=PQ0/PSK(L)*EXP(A2*(THSK(L)-A3*APESK(L)) &
                /(THSK(L)-A4*APESK(L)))
            ELSE
                QREFK(L)=Q(I,J,L)
            ENDIF
        460 END DO
    !--------------ENTHALPY CONSERVATION INTEGRAL--------------------------
        DO 520 ITER=1,2
        !-----------------------------------------------------------------------
            SUMDE=0.
            SUMDP=0.
        
            DO L=LTPK,LB
                SUMDE=((TK(L)-TREFK(L))*CP+(QK(L)-QREFK(L))*ELWV)*DETA(L) &
                +SUMDE
                SUMDP=SUMDP+DETA(L)
            ENDDO
        
            HCORR=SUMDE/(SUMDP-DETA(LTPK))
            LCOR=LTPK+1
        !-----------------------FIND LQM----------------------------------------
            DO L=1,LB
                IF(PK(L) <= PQM)LQM=L
            ENDDO
        !--------------ABOVE LQM CORRECT TEMPERATURE ONLY-----------------------
            IF(LCOR <= LQM)THEN
                DO L=LCOR,LQM
                    TREFK(L)=TREFK(L)+HCORR*RCP
                ENDDO
                LCOR=LQM+1
            ENDIF
        !--------------BELOW LQM CORRECT BOTH TEMPERATURE AND MOISTURE----------
        
            DO 510 L=LCOR,LB
                TSKL=TREFK(L)*APEK(L)/APESK(L)
                DHDT=QREFK(L)*A23M4L/(TSKL-A4)**2+CP
                TREFK(L)=HCORR/DHDT+TREFK(L)
                THSKL=TREFK(L)*APEK(L)
                QREFK(L)=PQ0/PSK(L)*EXP(A2*(THSKL-A3*APESK(L)) &
                /(THSKL-A4*APESK(L)))
            510 END DO
        !-----------------------------------------------------------------------
        520 END DO
    !--------------HEATING, MOISTENING, PRECIPITATION-----------------------
        DENTPY=0.
        AVRGT =0.
        PRECK =0.
    
        DO 530 L=LTPK,LB
            TKL    =TK(L)
            DIFTL  =(TREFK(L)-TKL  )*TAUK
            DIFQL  =(QREFK(L)-QK(L))*TAUK
            AVRGTL =(TKL+TKL+DIFTL)
            DENTPY =(DIFTL*CP+DIFQL*ELWV)*DETA(L)/AVRGTL+DENTPY
            AVRGT  =AVRGTL*DETA(L)+AVRGT
            PRECK  =DETA(L)*DIFTL+PRECK
            DIFT(L)=DIFTL
            DIFQ(L)=DIFQL
        530 END DO
    
        DENTPY=DENTPY+DENTPY
        AVRGT =AVRGT/(SUMDP+SUMDP)
    !-------------SWAP IF ENTROPY AND/OR PRECIP .LT. 0 ...------------------
        IF(DENTPY < EPSNTP .OR. PRECK < 0.)THEN
            IF(OCT90)THEN
                CLDEFI(I,J)=EFIMN
            ELSE
                CLDEFI(I,J)=EFIMN*SM(I,J)+STEFI*(1.-SM(I,J))
            ENDIF
        
        !--------------SEARCH FOR SHALLOW CLOUD TOP-----------------------------
            LBTK=LBOT(I,J)
            LTSH=LBTK
            LBM1=LBTK-1
            PBTK=PK(LBTK)
        ! use new threshold for cloud depth
        !        PTPK=PBTK-PSH
            PSFCIJ=PD(I,J)+PT
            DEPMIN=PSHNEW*PSFCIJ*1.E-5
            PTPK=PBTK-DEPMIN
        !-------------CLOUD TOP IS THE LEVEL JUST BELOW PBTK-PSH----------------
            DO L=1,LM
                IF(PK(L) <= PTPK)LTPK=L+1
            ENDDO
            PTPK=PK(LTPK)
        !--------------HIGHEST LEVEL ALLOWED IS LEVEL JUST BELOW PSHU-----------
            IF(PTPK <= PSHU)THEN
                DO L=1,LM
                    IF(PK(L) <= PSHU)LSHU=L+1
                ENDDO
                LTPK=LSHU
                PTPK=PK(LTPK)
            ENDIF
        
            LTP1=LTPK+1
            LTP2=LTPK+2
        !-----------------------------------------------------------------------
            DO L=LTPK,LBTK
                QSATK(L)=PQ0/PK(L)*EXP(A2*(TK(L)-A3)/(TK(L)-A4))
            ENDDO
        !-----------------------------------------------------------------------
            RHH=QK(LTPK)/QSATK(LTPK)
            RHMAX=0.
        
            DO 570 L=LTP1,LBM1
                RHL=QK(L)/QSATK(L)
                DRHDP=(RHH-RHL)/(PK(L-1)-PK(L))
                IF(DRHDP > RHMAX)THEN
                    LTSH=L-1
                    RHMAX=DRHDP
                ENDIF
                RHH=RHL
            570 END DO
        
            LTOP(I,J)=LTSH
        !---------------CLOUD MUST BE AT LEAST TWO LAYERS THICK-----------------
            IF(LBOT(I,J)-LTOP(I,J) < 2)LTOP(I,J)=LBOT(I,J)-2
        
            PTOP(I,J)=PK(LTOP(I,J))
            GO TO 600
        ENDIF
    !-----------------------------------------------------------------------
    !--------------... DEEP CONVECTION OTHERWISE----------------------------
    !-----------------------------------------------------------------------
        DRHEAT=(PRECK*SM(I,J)+AMAX1(EPSP,PRECK)*(1.-SM(I,J))) &
        *CP/AVRGT
        EFI=EFIFC*DENTPY/DRHEAT
    
    !************** UNIFIED OR SEPARATE LAND/SEA CONV. **************
    
        IF(OCT90)THEN
            IF(UNIS)THEN
                EFI=CLDEFI(I,J)*FCB+EFI*FCC
            ELSEIF( .NOT. UNIL)THEN
                EFI=(CLDEFI(I,J)*FCB+EFI*FCC)*SM(I,J)+1.-SM(I,J)
            ELSE
                EFI=1.
            ENDIF
        ELSE
            EFI=CLDEFI(I,J)*FCB+EFI*FCC
        ENDIF
    
        IF(EFI > 1.   )    EFI=1.
        IF(EFI < EFIMN)    EFI=EFIMN
        IF(PRECK == 0.)     EFI=1.
        CLDEFI(I,J)=EFI
    
        FEFI=EFMNT+SLOPE*(EFI-EFIMN)
    ! ctp2008      FEFI=1.
        FEFI=2.-FEFI
    !     FEFI=AMAX1(EFI,EFMNT)
    
        PRECK=PRECK*FEFI
    
    !--------------UPDATE PRECIPITATION, TEMPERATURE & MOISTURE-------------
    
        PRECOL(I,J)=PDSL(I,J)*PRECK*CPRLG
        PREC  (I,J)=PDSL(I,J)*PRECK*CPRLG+PREC  (I,J)
        CUPREC(I,J)=PDSL(I,J)*PRECK*CPRLG+CUPREC(I,J)
        ACPREC(I,J)=PDSL(I,J)*PRECK*CPRLG+ACPREC(I,J)
        CUPPT(I,J) =PDSL(I,J)*PRECK*CPRLG+CUPPT(I,J)
    
        DO L=LTPK,LB
            TMOD(I,J,L)=DIFT(L)*FEFI
            QMOD(I,J,L)=DIFQ(L)*FEFI
            TLATCU(I,J,L)=DIFT(L)*FEFI
        ENDDO
    
    ! CDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
    ! CDCDCDCDCDC          END OF DEEP CONVECTION            DCDCDCDCDCDCDCD
    ! CDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
    
    !-----------------------------------------------------------------------
    600 END DO
!-----------------------------------------------------------------------
    NDEEP=0

    DO 620 J=MYJS2,MYJE2
        DO 620 I=MYIS,MYIE
            LTPK=LTOP(I,J)
            LBTK=LBOT(I,J)
            LB  =LMH(I,J)-1
            PSFCIJ=PD(I,J)+PT
            DEPMIN=PSHNEW*PSFCIJ*1.E-5
            IF(PTOP(I,J) < PBOT(I,J)-DEPMIN)THEN
                NDEEP=NDEEP+1
                NDEPTH=LB-LTPK
                NTOPD (LTPK  )=NTOPD (LTPK  )+1
                NBOTD (LB    )=NBOTD (LB    )+1
                NDPTHD(NDEPTH)=NDPTHD(NDEPTH)+1
            ENDIF
    620 END DO
    NNEG=KHDEEP-NDEEP

!--------------GATHER SHALLOW CONVECTION POINTS-------------------------

    KHSHAL=0
    NDSTN =0
    NDSTP =0

    DO 630 J=MYJS2,MYJE2
        DO 630 I=MYIS,MYIE
            IF(PTOP(I,J) > PBOT(I,J)-PNO .OR. &
            LTOP(I,J) > LBOT(I,J)-2)GO TO 630
            PSFCIJ=PD(I,J)+PT
            DEPMIN=PSHNEW*PSFCIJ*1.E-5
            IF(PTOP(I,J)+1. >= PBOT(I,J)-DEPMIN)THEN
                KHSHAL=KHSHAL+1
                ISHAL(KHSHAL)=I
                JSHAL(KHSHAL)=J
            ENDIF
    630 END DO

!************* HORIZONTAL LOOP FOR SHALLOW CONVECTION ******************
! omp parallel do
! omp&  private(apek,apekl,apekxx,apekxy,bqk,bqs00k,bqs10k,den,dentpy,
! omp&           dpkl,dpmix,dqref,dst,dstq,dtdeta,fpk,fptk,i,iq,it,j,
! omp&           lbm1,lbtk,ltp1,ltpk,otsum,part1,part2,part3,pk,pkl,
! omp&           pkxxxx,pkxxxy,potsum,ppk,psum,ptpk,pz0,qk,qkl,qnew,
! omp&           qotsum,qqk,qrefk,qrfkl,qrftp,qsatk,qsum,rdpsum,rtbar,
! omp&           smix,sqk,sqs00k,sqs10k,sumdp,sumdt,tcorr,thvmkl,
! omp&           thvref,tk,tkl,tqk,trefk,trefkx,trfkl,tthk)

    DO 800 N=1,KHSHAL
    !***********************************************************************
        I=ISHAL(N)
        J=JSHAL(N)
    !-----------------------------------------------------------------------
    ! CSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
    ! CSCSCSCSCSC         SHALLOW CONVECTION          CSCSCSCSCSCSCSCSCSCSCS
    ! CSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
    !-----------------------------------------------------------------------
        PZ0=PD(I,J)+PT
        LLMH=LMH(I,J)
    
        DO 650 L=1,LLMH
            TKL      =T  (I,J,L)
            TK   (L) =TKL
            TREFK(L) =TKL
            QKL      =Q  (I,J,L)
            QK   (L) =QKL
            QREFK(L) =QKL
            PKL      =AETA(L)*PDSL(I,J)+PT
            PK   (L) =PKL
            QSATK(L) =PQ0/PK(L)*EXP(A2*(TK(L)-A3)/(TK(L)-A4))
            APEKL    =APE(I,J,L)
        ! VVVVVVVVVVV CHOOSE THE PRESSURE FUNCTION VVVVVVVVVVVVVVVVVVVVVVVVVVVVV
        !         FPK  (L) =ALOG(PKL)
        !         FPK  (L) =PKL
        !         FPK  (L) =-1./PKL
        ! AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            APEK (L) =APEKL
            THVMKL   =TKL*APEKL*(QKL*0.608+1.)
        !     THVMOD(L)=THVMKL
            THVREF(L)=THVMKL
        650 END DO
    !--------------SHALLOW CLOUD TOP-----------------------------
        LBTK=LBOT(I,J)
        LBM1=LBTK-1
        PTPK=PTOP(I,J)
        LTP1=LTOP(I,J)
        LTPK=LTOP(I,J)-1
    !-----------------------------------------------------------------------
        IF(PTOP(I,J) > PBOT(I,J)-PNO .OR. LTOP(I,J) > LBOT(I,J)-2)THEN
            LBOT(I,J)=0
            LTOP(I,J)=LBOT(I,J)
            PTOP(I,J)=PBOT(I,J)
            GO TO 800
        ENDIF
    !--------------SCALING POTENTIAL TEMPERATURE & TABLE INDEX AT TOP-------
    
    !     THTPK=T(I,J,LTP1)*APE(I,J,LTP1)
        THTPK=T(I,J,LTPK)*APE(I,J,LTPK)
    
        TTHK =(THTPK-THL)*RDTH
        QQK  =TTHK-AINT(TTHK)
        IT   =INT(TTHK)+1
        IF(IT < 1)THEN
            IT=1
            QQK=0.
        ENDIF
        IF(IT >= JTB)THEN
            IT=JTB-1
            QQK=0.
        ENDIF
    !--------------BASE AND SCALING FACTOR FOR SPEC. HUMIDITY AT TOP--------
        BQS00K=QS0(IT)
        SQS00K=SQS(IT)
        BQS10K=QS0(IT+1)
        SQS10K=SQS(IT+1)
    !--------------SCALING SPEC. HUMIDITY & TABLE INDEX AT TOP--------------
        BQK=(BQS10K-BQS00K)*QQK+BQS00K
        SQK=(SQS10K-SQS00K)*QQK+SQS00K
    
    !     TQK=(Q(I,J,LTP1)-BQK)/SQK*RDQ
        TQK=(Q(I,J,LTPK)-BQK)/SQK*RDQ
    
        PPK=TQK-AINT(TQK)
        IQ =INT(TQK)+1
        IF(IQ < 1)THEN
            IQ=1
            PPK=0.
        ENDIF
        IF(IQ >= ITB)THEN
            IQ=ITB-1
            PPK=0.
        ENDIF
    !--------------CLOUD TOP SATURATION POINT PRESSURE----------------------
        PART1=(PTBL(IQ+1,IT)-PTBL(IQ,IT))*PPK
        PART2=(PTBL(IQ,IT+1)-PTBL(IQ,IT))*QQK
        PART3=(PTBL(IQ  ,IT  )-PTBL(IQ+1,IT  ) &
        -PTBL(IQ  ,IT+1)+PTBL(IQ+1,IT+1))*PPK*QQK
        PTPK=PTBL(IQ,IT)+PART1+PART2+PART3
    !-----------------------------------------------------------------------
        DPMIX=PTPK-PSP(I,J)
        IF(ABS(DPMIX) < 3000.)DPMIX=-3000.
    !--------------TEMPERATURE PROFILE SLOPE--------------------------------
        SMIX=(THTPK-THBT(I,J))/DPMIX*STABS
    
        TREFKX=TREFK(LBTK+1)
        PKXXXX=PK(LBTK+1)
        PKXXXY=PK(LBTK)
        APEKXX=APEK(LBTK+1)
        APEKXY=APEK(LBTK)
    
        DO 670 L=LBTK,LTP1,-1
            TREFKX=((PKXXXY-PKXXXX)*SMIX &
            +TREFKX*APEKXX)/APEKXY
            TREFK(L)=TREFKX
            APEKXX=APEKXY
            PKXXXX=PKXXXY
            APEKXY=APEK(L-1)
            PKXXXY=PK(L-1)
        670 END DO
    !--------------TEMPERATURE REFERENCE PROFILE CORRECTION-----------------
        SUMDT=0.
        SUMDP=0.
    
        DO L=LTP1,LBTK
            SUMDT=(TK(L)-TREFK(L))*DETA(L)+SUMDT
            SUMDP=SUMDP+DETA(L)
        ENDDO
    
        RDPSUM=1./SUMDP
        FPK(LBTK)=TREFK(LBTK)
    
        TCORR=SUMDT*RDPSUM
    
        DO L=LTP1,LBTK
        !     TCORR=SUMDT/(SUMDP-DETA(LBTK))
        !     DO L=LTP1,LBM1
        
            TRFKL   =TREFK(L)+TCORR
            TREFK(L)=TRFKL
            FPK  (L)=TRFKL
        ENDDO
    !--------------HUMIDITY PROFILE EQUATIONS-------------------------------
        PSUM  =0.
        QSUM  =0.
        POTSUM=0.
        QOTSUM=0.
        OTSUM =0.
        DST   =0.
        FPTK  =FPK(LTP1)
    
        DO 700 L=LTP1,LBTK
            DPKL  =FPK(L)-FPTK
            PSUM  =DPKL *DETA(L)+PSUM
            QSUM  =QK(L)*DETA(L)+QSUM
            RTBAR =2./(TREFK(L)+TK(L))
            OTSUM =DETA(L)*RTBAR+OTSUM
            POTSUM=DPKL   *RTBAR*DETA(L)+POTSUM
            QOTSUM=QK(L)  *RTBAR*DETA(L)+QOTSUM
            DST   =(TREFK(L)-TK(L))*RTBAR*DETA(L)+DST
        700 END DO
    
        PSUM  =PSUM*RDPSUM
        QSUM  =QSUM*RDPSUM
        ROTSUM=1./OTSUM
        POTSUM=POTSUM*ROTSUM
        QOTSUM=QOTSUM*ROTSUM
        DST   =DST   *ROTSUM*CP/ELWV
    !--------------ENSURE POSITIVE ENTROPY CHANGE---------------------------
        IF(DST > 0.)THEN
        
        !       DSTQ=DST*EPSUP
            LBOT(I,J)=0
            LTOP(I,J)=LBOT(I,J)
            PTOP(I,J)=PBOT(I,J)
        ! cc    NDSTP=NDSTP+1
            GO TO 800
        
        ELSE
            DSTQ=DST*EPSDN
        ENDIF
    !--------------CHECK FOR ISOTHERMAL ATMOSPHERE--------------------------
        DEN=POTSUM-PSUM
    
        IF(-DEN/PSUM < 5.E-5)THEN
            LBOT(I,J)=0
            LTOP(I,J)=LBOT(I,J)
            PTOP(I,J)=PBOT(I,J)
            GO TO 800
        
        !--------------SLOPE OF THE REFERENCE HUMIDITY PROFILE------------------
        ELSE
            DQREF=(QOTSUM-DSTQ-QSUM)/DEN
        ENDIF
    !------------ HUMIDITY DOES NOT INCREASE WITH HEIGHT--------------------
        IF(DQREF < 0.)THEN
            LBOT(I,J)=0
            LTOP(I,J)=LBOT(I,J)
            PTOP(I,J)=PBOT(I,J)
            GO TO 800
        ENDIF
    !--------------HUMIDITY AT THE CLOUD TOP--------------------------------
        QRFTP=QSUM-DQREF*PSUM
    !--------------HUMIDITY PROFILE-----------------------------------------
    
        DO 720 L=LTP1,LBTK
            QRFKL=(FPK(L)-FPTK)*DQREF+QRFTP
        
        !--------------SUPERSATURATION OR NEGATIVE Q NOT ALLOWED----------------
        
            QNEW =(QRFKL-QK(L))*TAUK+QK(L)
            IF(QNEW > QSATK(L)*STRESH .OR. QNEW < 0.)THEN
                LBOT(I,J)=0
                LTOP(I,J)=LBOT(I,J)
                PTOP(I,J)=PBOT(I,J)
                GO TO 800
            ENDIF
        
        !-----------------------------------------------------------------------
            THVREF(L)=TREFK(L)*APEK(L)*(QRFKL*0.608+1.)
            QREFK(L)=QRFKL
        720 END DO
    !--------------ELIMINATE IMPOSSIBLE SLOPES (BETTS, DTHETA/DQ)-----------
        DO 730 L=LTP1,LBTK
            DTDETA=(THVREF(L-1)-THVREF(L))/(AETA(L)-AETA(L-1))
            IF(DTDETA < EPSTH)THEN
                LBOT(I,J)=0
                LTOP(I,J)=LBOT(I,J)
                PTOP(I,J)=PBOT(I,J)
                GO TO 800
            ENDIF
        730 END DO
    !*************************** DIAGNOSTICS ******************************
    ! cc  IF(DST.GT.0.)THEN
    ! cc    NDSTP=NDSTP+1
    ! cc  ELSE
    ! cc    NDSTN=NDSTN+1
    ! cc  ENDIF
    !**********************************************************************
        DENTPY=0.
    
        DO L=LTP1,LBTK
            DENTPY=((TREFK(L)-TK(L))*CP+(QREFK(L)-QK(L))*ELWV) &
            /(TK(L)+TREFK(L))*DETA(L)+DENTPY
        ENDDO
    
    !-----------------------------------------------------------------------
    !--------------RELAXATION TOWARDS REFERENCE PROFILES--------------------
    !-----------------------------------------------------------------------
    
    
        DO 750 L=LTP1,LBTK
            TMOD(I,J,L)=(TREFK(L)-TK(L))*TAUK
            QMOD(I,J,L)=(QREFK(L)-QK(L))*TAUK
        750 END DO
    !-----------------------------------------------------------------------
    ! CSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
    ! CSCSCSCSCSC         END OF SHALLOW CONVECTION        SCSCSCSCSCSCSCSCS
    ! CSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
    !-----------------------------------------------------------------------
    800 END DO
!-----------------------------------------------------------------------

!************************** DIAGNOSTICS ********************************
    NSHAL=0

    DO 820 J=MYJS2,MYJE2
        DO 820 I=MYIS,MYIE
            LTPK=LTOP(I,J)
            LBTK=LBOT(I,J)
            PTPK=PTOP(I,J)
            PBTK=PBOT(I,J)
            IF(PTPK > PBTK-PNO .OR. LTPK > LBTK-2)GO TO 820
            PSFCIJ=PD(I,J)+PT
            DEPMIN=PSHNEW*PSFCIJ*1.E-5
        !      IF(PTPK.GE.PBTK-PSH)THEN
            IF(PTPK >= PBTK-DEPMIN)THEN
                NSHAL=NSHAL+1
                NTOPS(LTPK)=NTOPS(LTPK)+1
                NBOTS(LBTK)=NBOTS(LBTK)+1
                NDEPTH=LBTK-LTPK
                NDPTHS(NDEPTH)=NDPTHS(NDEPTH)+1
            ENDIF
    820 END DO
    NEGDS=KHSHAL-NSHAL
!***********************************************************************

!--------------SMOOTHING TEMPERATURE & HUMIDITY CORRECTIONS-------------
    IF(KSMUD == 0)THEN
    ! omp parallel do
    
        DO 900 L=1,LM
        !***
        !***  UPDATE THE FUNDAMENTAL PROGNOSTIC ARRAYS
        !***
            DO 830 J=MYJS,MYJE
                DO 830 I=MYIS,MYIE
                    T(I,J,L)=T(I,J,L)+TMOD(I,J,L)
                    Q(I,J,L)=Q(I,J,L)+QMOD(I,J,L)
                !***
                !***  ACCUMULATE LATENT HEATING DUE TO CONVECTION.
                !***  SCALE BY THE RECIPROCAL OF THE PERIOD AT WHICH THIS ROUTINE
                !***  IS CALLED.  THIS PERIOD IS THE CONVECTION TIMESTEP.
                !***
                    TCUCN(I,J,L)=TCUCN(I,J,L)+TMOD(I,J,L)*RDTCNVC
            830 END DO
        900 END DO
    ELSE
    ! omp parallel do private(ql,qne,qse,tl,tne,tse)
    
        DO 910 L=1,LM
        
            CALL ZERO2(QL)
            CALL ZERO2(QNE)
            CALL ZERO2(QSE)
            CALL ZERO2(TL)
            CALL ZERO2(TNE)
            CALL ZERO2(TSE)
        !-----------------------------------------------------------------------
            DO J=MYJS,MYJE
                DO I=MYIS,MYIE
                    TL(I,J)=TMOD(I,J,L)
                    QL(I,J)=QMOD(I,J,L)
                ENDDO
            ENDDO
        !-----------------------------------------------------------------------
        !-----------------------------------------------------------------------
            NSMUD=KSMUD
        
            DO 870 KS=1,NSMUD
            
                DO J=MYJS,MYJE1
                    DO I=MYIS,MYIE
                        TNE(I,J)=(TL(I+IHE(J),J+1)-TL(I,J)) &
                        *HTM(I,J,L)*HTM(I+IHE(J),J+1,L)
                        QNE(I,J)=(QL(I+IHE(J),J+1)-QL(I,J)) &
                        *HTM(I,J,L)*HTM(I+IHE(J),J+1,L)
                    ENDDO
                ENDDO
            
                DO J=MYJS1,MYJE
                    DO I=MYIS,MYIE
                        TSE(I,J)=(TL(I+IHE(J),J-1)-TL(I,J)) &
                        *HTM(I+IHE(J),J-1,L)*HTM(I,J,L)
                        QSE(I,J)=(QL(I+IHE(J),J-1)-QL(I,J)) &
                        *HTM(I+IHE(J),J-1,L)*HTM(I,J,L)
                    ENDDO
                ENDDO
            
                DO J=MYJS2,MYJE2
                    DO I=MYIS,MYIE
                        TL(I,J)=(TNE(I,J)-TNE(I+IHW(J),J-1)+TSE(I,J)-TSE(I+IHW(J),J+1)) &
                        *HBM2(I,J)*0.125+TL(I,J)
                        QL(I,J)=(QNE(I,J)-QNE(I+IHW(J),J-1)+QSE(I,J)-QSE(I+IHW(J),J+1)) &
                        *HBM2(I,J)*0.125+QL(I,J)
                    ENDDO
                ENDDO
            
            870 END DO
        !-----------------------------------------------------------------------
        !***
        !***  UPDATE THE FUNDAMENTAL PROGNOSTIC ARRAYS
        !***
            DO J=MYJS,MYJE
                DO I=MYIS,MYIE
                    T(I,J,L)=T(I,J,L)+TL(I,J)
                    Q(I,J,L)=Q(I,J,L)+QL(I,J)
                ENDDO
            ENDDO
        !***
        !***  ACCUMULATE LATENT HEATING DUE TO CONVECTION.
        !***  SCALE BY THE RECIPROCAL OF THE PERIOD AT WHICH THIS ROUTINE
        !***  IS CALLED.  THIS PERIOD IS THE CONVECTION TIMESTEP.
        !***
            DO J=MYJS,MYJE
                DO I=MYIS,MYIE
                    TCUCN(I,J,L)=TCUCN(I,J,L)+TL(I,J)*RDTCNVC
                ENDDO
            ENDDO
        
        910 END DO
    
    ENDIF
!--------------SAVE CLOUD TOP AND BOTTOM FOR RADIATION------------------
! omp parallel do
    DO J=MYJS,MYJE
        DO I=MYIS,MYIE
            IF (LTOP(I,J) > 0 .AND. LTOP(I,J) < LBOT(I,J)) THEN
                CUtop=FLOAT(LTOP(I,J))
                CUbot=FLOAT(LBOT(I,J))
                HTOP(I,J)=MIN(CUtop,HTOP(I,J))
                HBOT(I,J)=MAX(CUbot,HBOT(I,J))
                CNVTOP(I,J)=MIN(CUtop,CNVTOP(I,J))
                CNVBOT(I,J)=MAX(CUbot,CNVBOT(I,J))
            ENDIF
        ENDDO
    ENDDO
!-----------------------------------------------------------------------
!************************* DIAGNOSTICS *********************************

!     WRITE(LIST,950)NTSD,NSHAL,NDEEP,NNEG,NEGDS,NDSTN,NDSTP
!         DO 940 L=1,LM
!     WRITE(LIST,952)L
!     WRITE(LIST,954)NBOTS(L),NTOPS(L),NDPTHS(L)
!    1,              NBOTD(L),NTOPD(L),NDPTHD(L)
! 940 CONTINUE
! 950 FORMAT(' NTSD=',I3,I8,' SHALLOW, ',I4,' DEEP, ',
!    1 I4,' NEG., ',I4,' NEG. SHALL.,',I4,' DST.LT.0, ',I4,' DST.GT.0')
! 952 FORMAT(' LAYER (FROM TOP),',I2)
! 954 FORMAT('     NBOTS=',I4,'     NTOPS=',I4,'     NDPTHS=',I4,
!    1       '     NBOTD=',I4,'     NTOPD=',I4,'     NDPTHD=',I4)
!***********************************************************************
    RETURN
    END SUBROUTINE CUCNVC
    			           
