SUBROUTINE GSCOND !>-------------------------------------------------------------------------------------------------- !> SUBROUTINE GSCOND !> !> SUBPROGRAM: GSCOND - GRID SCALE CONDENSATION AND EVAPORATION !> PROGRAMMER: ZHAO !> ORG: W/NP22 !> DATE: ??-??-?? !> !> ABSTRACT: !> GSCOND COMPUTES THE GRID SCALE EVAPORATION AND CONDENSATION !> !> PROGRAM HISTORY LOG: !> 94-??-?? ZHAO - ORIGINATOR !> 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL !> 95-03-28 BLACK - ADDED EXTERNAL EDGE !> 98-11-02 BLACK - MODIFIED 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 !> !> OUTPUT FILES: !> NONE !> !> USE MODULES: ACMCLH !> CLDWTR !> CTLBLK !> DYNAM !> F77KINDS !> GLB_TABLE !> LOOPS !> MAPPINGS !> MASKS !> MPPCOM !> PARMETA !> PARM_TBL !> PHYS !> PVRBLS !> TEMPCOM !> TEMPV !> TOPO !> VRBLS !> !> DRIVER : EBU !> NEWFLT !> !> CALLS : SGETMO !>-------------------------------------------------------------------------------------------------- USE ACMCLH USE CLDWTR USE CTLBLK USE DYNAM , ONLY: AETA, PT USE F77KINDS USE GLB_TABLE USE LOOPS USE MAPPINGS USE MASKS USE MPPCOM USE PARMETA USE PARM_TBL USE PHYS USE PVRBLS USE TEMPCOM USE TEMPV 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 :: 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 :: TM10 = 263.16 REAL (KIND=R4KIND), PARAMETER :: R = 287.04 REAL (KIND=R4KIND), PARAMETER :: CPR = CP * R REAL (KIND=R4KIND), PARAMETER :: RCPR = 1. / CPR ! 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) ! INTEGER(KIND=R4KIND), PARAMETER :: IMJM = IM * JM - JM / 2 INTEGER(KIND=R4KIND), PARAMETER :: LTOP = 1 INTEGER(KIND=R4KIND), PARAMETER :: LBOT = LM INTEGER(KIND=R4KIND), PARAMETER :: LDA = (IDIM2 - IDIM1 + 1) * (JDIM2 - JDIM1 + 1) ! LOGICAL(KIND=L4KIND) ::& & NOZ ! INTEGER(KIND=I4KIND), DIMENSION(LM) ::& & IW ! REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2) ::& & PDSL ! REAL (KIND=R4KIND), DIMENSION(LM, IDIM1:IDIM2, JDIM1:JDIM2) ::& & T_T , T0_T , Q_T , Q0_T , TRAIN_T , CWM_T , HTM_T ! REAL (KIND=R4KIND) ::& & MR , KE , INIT !------------------------ ! IMPLICIT NONE VARIABLES !------------------------ REAL (KIND=R4KIND) ::& & DTPH , RDTPH , TWODT , RTWODT , C0 , C1 , C2 , US , EPS , & & CCLIMIT , UTIM , HBM2IJ , U00IJ , P0IJ , RESIJ , PDSLIJ , TKL , QKL , & & CWMKL , COND , CLIMIT , E0 , HH , TMT0 , TMT15 , AI , BI , & & QW , QI , QINT , U00KL , FI , THH , PP , PP0 , AT , & & AQ , AP , FIW , ELV , QC , RQKL , CCR , RQKLL , CCRKL , & & EC , US00 , CCRKL1 , AA , AB , AC , AD , AE , AF , & & AG , CONDK , QTEMP , RQTMP , CONE0 ! INTEGER(KIND=I4KIND) ::& & I , J , K , LMHIJ , IWKL , LML #include "sp.h" !------------------------- ! PREPARATORY CALCULATIONS !------------------------- DTPH = NPHS * DT RDTPH = 1. / DTPH TWODT = DTPH RTWODT = 1. / TWODT C0 = 1.5E-4 C1 = 300. C2 = 0.5 MR = 3.0E-4 KE = 2.0E-5 US = 1. EPS = 0.622 CCLIMIT = 1.0E-3 CLIMIT = 1.0E-20 !----------------------------------------------- ! PADDING SPECIFIC HUMIDITY AND CWM IF TOO SMALL !----------------------------------------------- !------- ! OPENMP !------- ! !$omp parallel do ! DO 30 K=1,LM DO J=MYJS,MYJE DO I=MYIS,MYIE IF (Q(I,J,K) < EPSQ) Q(I,J,K) = EPSQ*HTM(I,J,K) IF (CWM(I,J,K) < CLIMIT) CWM(I,J,K) = CLIMIT*HTM(I,J,K) END DO END DO 30 END DO ! DO J=MYJS,MYJE DO I=MYIS,MYIE PDSL(I,J) = RES(I,J) * PD(I,J) END DO END DO ! IW(1) = 0 UTIM = 1. !------------------------------------------------ ! BEGINNING OF GRID-SCALE CONDENSATION/EVAP. LOOP !------------------------------------------------ ! !----------------- ! TRANSPOSE ARRAYS !----------------- !------- ! OPENMP !------- ! !$omp parallel sections !$omp section ! CALL SGETMO(T , LDA, LDA, LM, T_T , LM) CALL SGETMO(Q , LDA, LDA, LM, Q_T , LM) CALL SGETMO(HTM , LDA, LDA, LM, HTM_T , LM) CALL SGETMO(CWM , LDA, LDA, LM, CWM_T , LM) ! !$omp section ! CALL SGETMO(T0 , LDA, LDA, LM, T0_T , LM) CALL SGETMO(Q0 , LDA, LDA, LM, Q0_T , LM) CALL SGETMO(TRAIN, LDA, LDA, LM, TRAIN_T , LM) ! !$omp end parallel sections ! !---------------- ! QW, QI AND QINT !---------------- !------- ! OPENMP !------- ! !$omp parallel do !$omp private (AA , AB , AC , AD , AE , AF , AG , AI , & !$omp AP , AQ , AT , BI , CCR , CCRKL , CCRKL1 , COND , & !$omp CONDK , CONE0 , CWMKL , E0 , EC , ELV , FI , FIW , & !$omp HBM2IJ , HH , IWKL , LMHIJ , LML , P0IJ , PDSLIJ , PP , & !$omp PP0 , QC , QI , QINT , QKL , QTEMP , QW , RESIJ , & !$omp RQKL , RQKLL , RQTMP , THH , TKL , TMT0 , TMT15 , U00IJ , & !$omp U00KL , US00 ) !$omp firstprivate (IW) ! IF (MYPE == 1) THEN PRINT*,'MYIS, MYIE, MYJS2, MYJE2=', MYIS, MYIE, MYJS2, MYJE2 END IF ! DO 100 J=MYJS2,MYJE2 DO 100 I=MYIS,MYIE LMHIJ = LMH(I,J) HBM2IJ = HBM2(I,J) U00IJ = U00(I,J) P0IJ = P0(I,J) RESIJ = RES(I,J) PDSLIJ = PDSL(I,J) ! DO 90 K=2,LM TKL = T_T(K,I,J) QKL = Q_T(K,I,J) CWMKL = CWM_T(K,I,J) ! COND = 0. E0 = 0. LML = LM-LMHIJ HH = HTM_T(K,I,J) * HBM2IJ TMT0 = (TKL-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 / (PDSLIJ * AETA(K) + PT) * EXP(HH*A2 * (T(I,J,K) - A3) & & / (T(I,J,K) - 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 U00KL = U00IJ + UL(K+LML) * (0.95-U00IJ) * UTIM FI = Q(I,J,K) - U00KL * QI IF (FI > 0. .OR. CWMKL > CLIMIT) THEN IW(K) = 1 ELSE IW(K) = 0 END IF END IF ! IF (TMT0 >= 0.) THEN IW(K) = 0 END IF ! IF (TMT0 < 0.0 .AND. TMT0 >= -15.) THEN IW(K) = 0 IF (IW(K-1) == 1 .AND. CWMKL > CLIMIT) IW(K) = 1 END IF !------------------------------------------------------- ! CONDENSATION AND EVAPORATION OF CLOUD AT, AQ AND DP/DT !------------------------------------------------------- THH = TWODT * HH PP = PDSLIJ * AETA(K) + PT PP0 = P0IJ * RESIJ * AETA(K) + PT AT = (TKL-T0_T(K,I,J)) * RTWODT AQ = (QKL-Q0_T(K,I,J)) * RTWODT AP = (PP-PP0) * RTWODT IWKL = IW(K) U00KL = U00IJ + UL(K+LML) * (0.95-U00IJ) * UTIM !-------------------------------- ! THE SATUATION SPECIFIC HUMIDITY !-------------------------------- FIW = FLOAT(IWKL) ELV = (1.-FIW) * ELWV + FIW * ELIV QC = (1.-FIW) * QINT + FIW * QI !---------------------- ! THE RELATIVE HUMIDITY !---------------------- IF (QC <= 0.) THEN RQKL = 0. ELSE RQKL = QKL / QC END IF !---------------------- ! CLOUD COVER RATIO CCR !---------------------- IF (RQKL <= U00KL) THEN CCR = 0. ELSE RQKLL = AMIN1(US,RQKL) 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. CWMKL >= 0.2E-3) THEN CCR = AMIN1(1.,CWMKL*1.E3) END IF ! CCRKL = CCR !------------------------------------------------------- ! GIVE UP THIS POINT IF NO CLOUD NOR CONDENSATION EXIST !------------------------------------------------------- IF (CCRKL <= CCLIMIT .AND. CWMKL <= CLIMIT) GOTO 90 !--------------------------- ! EVAPORATION OF CLOUD WATER !--------------------------- EC = 0. ! IF (CCRKL <= CCLIMIT .AND. CWMKL > CLIMIT) THEN EC = QC * (U00KL-RQKL) * RTWODT E0 = AMAX1(EC,0.0) E0 = AMIN1(CWMKL*RTWODT,E0) * HH E0 = AMAX1(0.,E0) END IF !---------------------- ! CONDENSATION OF CLOUD !---------------------- IF (CCRKL <= 0.20 .OR. QC <= EPSQ) THEN COND = 0. GOTO 80 END IF !------------------------------------------------------ ! THE EQS. FOR COND. HAS BEEN REORGANIZED TO REDUCE CPU !------------------------------------------------------ US00 = US - U00KL CCRKL1 = 1. - CCRKL ! AA = EPS * ELV * PP * QKL AB = CCRKL * CCRKL1 * QC * US00 AC = AB + 0.5 * CWMKL AD = AB * CCRKL1 AE = CPR * TKL * TKL AF = AE * PP AG = AA * ELV AI = CP * AA ! COND = (AC - AD) * (AF * AQ - AI * AT + AE * QKL * AP) / (AC * (AF + AG)) !---------------------------------------------- ! CHECK AND CORRECT IF OVER CONDENSATION OCCURS !---------------------------------------------- CONDK = (QKL - U00KL * QC * 0.1) * RTWODT ! IF (COND > CONDK) THEN COND = CONDK END IF !------------------------------------------------ ! CHECK AND CORRECT IF SUPERSATUATION IS TOO HIGH !------------------------------------------------ QTEMP = QKL - AMAX1(0.,(COND-E0)) * THH RQTMP = QTEMP / QC ! IF (RQTMP >= 1.10) THEN COND = (QKL-1.10*QC) * RTWODT END IF ! IF (COND < 0.) THEN COND = 0. END IF !----------------------- ! UPDATE OF T, Q AND CWM !----------------------- 80 CONTINUE ! IF (MYPE == 1 .AND. I == 25 .AND. J == 31 .AND. K == 31) THEN PRINT*,'COND, E0=', COND, E0 END IF ! CONE0 = COND - E0 ! CWM_T(K,I,J) = CONE0 * THH + CWMKL !-------------------------------------------------------------------------------------------------- ! 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. !-------------------------------------------------------------------------------------------------- T_T(K,I,J) = ELV * RCP * CONE0 * THH + TKL TRAIN_T(K,I,J) = ELV * RCP * CONE0 * THH * RDTPH + TRAIN_T(K,I,J) Q_T(K,I,J) = -CONE0 * THH + QKL ! IF (CWM_T(K,I,J) <= 0.) CWM_T(K,I,J) = 0. 90 END DO 100 END DO !------------------------------ ! SAVE T, Q AND P FOR THIS STEP !------------------------------ ! !--------------------------------- ! TRANSPOSE BACK THE NEEDED ARRAYS !--------------------------------- !------- ! OPENMP !------- ! !$omp parallel sections !$omp section ! CALL SGETMO(T_T , LM, LM, LDA, T , LDA) CALL SGETMO(Q_T , LM, LM, LDA, Q , LDA) ! !$omp section ! CALL SGETMO(TRAIN_T, LM, LM, LDA, TRAIN, LDA) CALL SGETMO(CWM_T , LM, LM, LDA, CWM , LDA) ! !$omp end parallel sections ! !$omp parallel do ! DO 125 K=1,LM DO J=MYJS,MYJE DO I=MYIS,MYIE Q0(I,J,K) = Q(I,J,K) T0(I,J,K) = T(I,J,K) END DO END DO 125 END DO ! DO J=MYJS,MYJE DO I=MYIS,MYIE P0(I,J) = PD(I,J) END DO END DO ! RETURN ! END SUBROUTINE GSCOND