SUBROUTINE HZADV2 !>-------------------------------------------------------------------------------------------------- !> SUBROUTINE HZADV2 !> !> SUBPROGRAM: HZADV2 - HORIZONTAL ADVECTION OF VAPOR AND CLOUD !> PROGRAMMER: JANJIC !> ORG: W/NP22 !> DATE: 96-07-19 !> !> ABSTRACT: !> HZADV2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION TO THE TENDENCIES OF SPECIFIC !> HUMIDITY AND CLOUD WATER AND THEN UPDATES THOSE VARIABLES. AN ANTI-FILTERING TECHNIQUE IS USED. !> !> PROGRAM HISTORY LOG: !> 96-07-19 JANJIC - ORIGINATOR !> 98-11-02 BLACK - MODIFIED FOR DISTRIBUTED MEMORY !> 99-03-17 TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM !> 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 !> !> USE MODULES: CLDWTR !> CONTIN !> CTLBLK !> DYNAM !> F77KINDS !> GLB_TABLE !> INDX !> LOOPS !> MAPPINGS !> MASKS !> MPPCOM !> PARMETA !> PVRBLS !> VRBLS !> TEMPCOM !> TOPO !> !> DRIVER : EBU !> NEWFLT !> !> CALLS : MPI_ALLREDUCE !>-------------------------------------------------------------------------------------------------- USE CLDWTR USE CONTIN USE CTLBLK USE DYNAM USE F77KINDS USE GLB_TABLE USE INDX USE LOOPS USE MAPPINGS USE MASKS USE MPPCOM USE PARMETA USE PVRBLS USE VRBLS USE TEMPCOM USE TOPO ! IMPLICIT NONE ! REAL (KIND=R4KIND), PARAMETER :: EPSQ = 2.E-12 REAL (KIND=R4KIND), PARAMETER :: CLIMIT = 1.E-20 REAL (KIND=R4KIND), PARAMETER :: FF1 = 0.52500 REAL (KIND=R4KIND), PARAMETER :: FF2 = -0.64813 REAL (KIND=R4KIND), PARAMETER :: FF3 = 0.24520 REAL (KIND=R4KIND), PARAMETER :: FF4 = -0.12189 ! INCLUDE "mpif.h" ! #include "sp.h" ! INTEGER(KIND=I4KIND), PARAMETER :: IM1 = IM - 1 INTEGER(KIND=I4KIND), PARAMETER :: IMJM = IM * JM - JM / 2 INTEGER(KIND=I4KIND), PARAMETER :: JAMD = (JAM * 2 - 10) * 3 ! INTEGER(KIND=I4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2, LM) ::& & IFPA , IFQA , & & IFPF , IFQF , & & JFPA , JFQA , & & JFPF , JFQF ! REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2, LM) ::& & AFP , AFQ , & & Q1 , DQST , & & W1 , DWST , & & DVOL ! REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2) ::& & DARE , EMH ! REAL (KIND=R4KIND), DIMENSION(4,LM) ::& & GSUMS , XSUMS ! INTEGER(KIND=I4KIND), DIMENSION(MPI_STATUS_SIZE) ::& & ISTAT !------------------------ ! IMPLICIT NONE VARIABLES !------------------------ INTEGER(KIND=I4KIND) ::& & I , J , K , JFP , JFQ , IRECV ! REAL(KIND=R4KIND) ::& & HTMIJL , SUMPQ , SUMNQ , SUMPW , SUMNW , DVOLP , TTA , TTB , PP , & & QP , DQSTIJ , DWSTIJ , RFACQ , RFACW , RFQIJ , RFWIJ , Q1IJ , W1IJ , & & ENH , D2PQQ , D2PQW , QSTIJ , WSTIJ , Q00 , QP0 , Q0Q , W00 , & & WP0 , W0Q ! ENH = FLOAT(IDTAD) * DT / (08. * DY) ! DO J=MYJS_P2,MYJE_P2 DO I=MYIS_P1,MYIE_P1 EMH (I,J) = FLOAT(IDTAD) * DT / (08. * DX(I,J)) DARE(I,J) = HBM2(I,J) * DX(I,J) * DY END DO END DO ! !$omp parallel do !$omp private (DQSTIJ , DVOLP , DWSTIJ , HTMIJL , JFP , JFQ , PP , QP , & !$omp SUMNQ , SUMNW , SUMPQ , SUMPW , TTA , TTB ) ! DO K=1,LM ! DO 200 J=MYJS_P2,MYJE_P2 DO 200 I=MYIS_P1,MYIE_P1 DVOL(I,J,K) = DARE(I,J) * PDSL(I,J) * DETA(K) HTMIJL = HTM(I,J,K) ! Q (I,J,K) = AMAX1(Q (I,J,K), EPSQ ) * HTMIJL CWM(I,J,K) = AMAX1(CWM(I,J,K), CLIMIT) * HTMIJL Q1 (I,J,K) = Q (I,J,K) W1 (I,J,K) = CWM(I,J,K) 200 END DO ! SUMPQ = 0. SUMNQ = 0. SUMPW = 0. SUMNW = 0. ! DO 300 J=MYJS2_P1,MYJE2_P1 DO 300 I=MYIS1_P1,MYIE1_P1 ! DVOLP = DVOL(I,J,K) * HBM3(I,J) TTA = (U(I ,J-1,K) + U(I+IHW(J),J ,K) & & + U(I+IHE(J),J ,K) + U(I ,J+1,K)) * HBM2(I,J) * EMH(I,J) ! TTB = (V(I ,J-1,K) + V(I+IHW(J),J ,K) & & + V(I+IHE(J),J ,K) + V(I ,J+1,K)) * HBM2(I,J) * ENH ! PP = - TTA - TTB QP = TTA - TTB ! JFP = INT(SIGN(1.,PP)) JFQ = INT(SIGN(1.,QP)) ! IFPA(I,J,K) = IHE(J) + I + ( JFP-1) / 2 IFQA(I,J,K) = IHE(J) + I + (-JFQ-1) / 2 ! JFPA(I,J,K) = J + JFP JFQA(I,J,K) = J + JFQ ! IFPF(I,J,K) = IHE(J) + I + (-JFP-1) / 2 IFQF(I,J,K) = IHE(J) + I + ( JFQ-1) / 2 ! JFPF(I,J,K) = J - JFP JFQF(I,J,K) = J - JFQ ! PP = ABS(PP) * HTM(I,J,K) * HTM(IFPA(I,J,K),JFPA(I,J,K),K) QP = ABS(QP) * HTM(I,J,K) * HTM(IFQA(I,J,K),JFQA(I,J,K),K) ! AFP (I,J,K) = (((FF4*PP+FF3) * PP + FF2) * PP + FF1) * PP AFQ (I,J,K) = (((FF4*QP+FF3) * QP + FF2) * QP + FF1) * QP ! DQSTIJ = (Q (IFPA(I,J,K),JFPA(I,J,K),K) - Q (I,J,K)) * PP & & + (Q (IFQA(I,J,K),JFQA(I,J,K),K) - Q (I,J,K)) * QP ! DWSTIJ = (CWM(IFPA(I,J,K),JFPA(I,J,K),K) - CWM(I,J,K)) * PP & & + (CWM(IFQA(I,J,K),JFQA(I,J,K),K) - CWM(I,J,K)) * QP ! DQST(I,J,K) = DQSTIJ DWST(I,J,K) = DWSTIJ ! 300 END DO !---------------------------- ! GLOBAL SUM FOR CONSERVATION !---------------------------- DO 310 J=MYJS2,MYJE2 DO 310 I=MYIS1,MYIE1 ! DVOLP = DVOL(I,J,K) * HBM3(I,J) DQSTIJ = DQST(I,J,K) * DVOLP DWSTIJ = DWST(I,J,K) * DVOLP ! IF (DQSTIJ > 0.) THEN SUMPQ = SUMPQ + DQSTIJ ELSE SUMNQ = SUMNQ + DQSTIJ END IF ! IF (DWSTIJ > 0.) THEN SUMPW = SUMPW + DWSTIJ ELSE SUMNW = SUMNW + DWSTIJ END IF ! 310 END DO ! XSUMS(1,K) = SUMPQ XSUMS(2,K) = SUMNQ XSUMS(3,K) = SUMPW XSUMS(4,K) = SUMNW !--------------- ! END OF LM LOOP !--------------- END DO !----------------- ! GLOBAL REDUCTION !----------------- CALL MPI_ALLREDUCE(XSUMS, GSUMS, 4*LM, MPI_REAL, MPI_SUM, MPI_COMM_COMP, IRECV) !------------------------ ! END OF GLOBAL REDUCTION !------------------------ ! !$omp parallel do !$omp private (D2PQQ , D2PQW , DQSTIJ , DVOLP , DWSTIJ , Q00 , Q0Q , Q1IJ , & !$omp QP0 , QSTIJ , RFACQ , RFACW , RFQIJ , RFWIJ , SUMNQ , SUMNW , & !$omp SUMPQ , SUMPW , W00 , W0Q , W1IJ , WP0 , WSTIJ ) ! DO K=1,LM ! SUMPQ = GSUMS(1,K) SUMNQ = GSUMS(2,K) SUMPW = GSUMS(3,K) SUMNW = GSUMS(4,K) !------------------------------- ! FIRST MOMENT CONSERVING FACTOR !------------------------------- IF (SUMPQ > 1.) THEN RFACQ = -SUMNQ / SUMPQ ELSE RFACQ = 1. END IF ! IF (SUMPW > 1.) THEN RFACW = -SUMNW / SUMPW ELSE RFACW = 1. END IF ! IF (RFACQ < 0.9 .OR. RFACQ > 1.1) RFACQ = 1. IF (RFACW < 0.9 .OR. RFACW > 1.1 )RFACW = 1. !--------------------------------- ! IMPOSE CONSERVATION ON ADVECTION !--------------------------------- IF (RFACQ < 1.) THEN DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS1_P1,MYIE1_P1 DQSTIJ = DQST(I,J,K) RFQIJ = HBM3(I,J) * (RFACQ-1.) + 1. IF (DQSTIJ < 0.) DQSTIJ = DQSTIJ / RFQIJ Q1(I,J,K) = Q(I,J,K) + DQSTIJ END DO END DO ELSE DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS1_P1,MYIE1_P1 DQSTIJ = DQST(I,J,K) RFQIJ = HBM3(I,J) * (RFACQ-1.) + 1. IF (DQSTIJ >= 0.) DQSTIJ = DQSTIJ * RFQIJ Q1(I,J,K) = Q(I,J,K) + DQSTIJ END DO END DO END IF ! IF (RFACW < 1.) THEN DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS1_P1,MYIE1_P1 DWSTIJ = DWST(I,J,K) RFWIJ = HBM3(I,J) * (RFACW-1.) + 1. IF (DWSTIJ < 0.) DWSTIJ = DWSTIJ / RFWIJ W1(I,J,K) = CWM(I,J,K) + DWSTIJ END DO END DO ELSE DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS1_P1,MYIE1_P1 DWSTIJ = DWST(I,J,K) RFWIJ = HBM3(I,J) * (RFACW-1.) + 1. IF (DWSTIJ >= 0.) DWSTIJ = DWSTIJ * RFWIJ W1(I,J,K) = CWM(I,J,K) + DWSTIJ END DO END DO END IF !-------------------- ! ANTI-FILTERING STEP !-------------------- SUMPQ = 0. SUMNQ = 0. SUMPW = 0. SUMNW = 0. !------------------------ ! ANTI-FILTERING LIMITERS !------------------------ DO 330 J=MYJS2,MYJE2 DO 330 I=MYIS1,MYIE1 ! DVOLP = DVOL(I,J,K) Q1IJ = Q1(I,J,K) W1IJ = W1(I,J,K) ! D2PQQ = ( (Q1(IFPA(I,J,K),JFPA(I,J,K),K)-Q1IJ) & & - (Q1IJ - Q1(IFPF(I,J,K),JFPF(I,J,K),K)) & & * HTM(IFPF(I,J,K),JFPF(I,J,K),K)) * AFP(I,J,K) & & + ((Q1(IFQA(I,J,K),JFQA(I,J,K),K)-Q1IJ) & & - (Q1IJ - Q1(IFQF(I,J,K),JFQF(I,J,K),K)) & & * HTM(IFQF(I,J,K),JFQF(I,J,K),K)) * AFQ(I,J,K) ! D2PQW = ( (W1(IFPA(I,J,K),JFPA(I,J,K),K)-W1IJ) & & - (W1IJ-W1(IFPF(I,J,K),JFPF(I,J,K),K)) & & * HTM(IFPF(I,J,K),JFPF(I,J,K),K)) * AFP(I,J,K) & & + ((W1(IFQA(I,J,K),JFQA(I,J,K),K)-W1IJ) & & - (W1IJ-W1(IFQF(I,J,K),JFQF(I,J,K),K)) & & * HTM(IFQF(I,J,K),JFQF(I,J,K),K)) * AFQ(I,J,K) ! QSTIJ = Q1IJ - D2PQQ WSTIJ = W1IJ - D2PQW ! Q00 = Q(I ,J ,K) QP0 = Q(IFPA(I,J,K),JFPA(I,J,K),K) Q0Q = Q(IFQA(I,J,K),JFQA(I,J,K),K) ! W00 = CWM(I ,J ,K) WP0 = CWM(IFPA(I,J,K),JFPA(I,J,K),K) W0Q = CWM(IFQA(I,J,K),JFQA(I,J,K),K) ! QSTIJ = AMAX1(QSTIJ, AMIN1(Q00,QP0,Q0Q)) QSTIJ = AMIN1(QSTIJ, AMAX1(Q00,QP0,Q0Q)) WSTIJ = AMAX1(WSTIJ, AMIN1(W00,WP0,W0Q)) WSTIJ = AMIN1(WSTIJ, AMAX1(W00,WP0,W0Q)) ! DQSTIJ = QSTIJ - Q1IJ DWSTIJ = WSTIJ - W1IJ ! DQST(I,J,K) = DQSTIJ DWST(I,J,K) = DWSTIJ ! DQSTIJ = DQSTIJ * DVOLP DWSTIJ = DWSTIJ * DVOLP ! IF (DQSTIJ > 0.) THEN SUMPQ = SUMPQ + DQSTIJ ELSE SUMNQ = SUMNQ + DQSTIJ END IF ! IF (DWSTIJ > 0.) THEN SUMPW = SUMPW + DWSTIJ ELSE SUMNW = SUMNW + DWSTIJ END IF ! 330 END DO ! XSUMS(1,K) = SUMPQ XSUMS(2,K) = SUMNQ XSUMS(3,K) = SUMPW XSUMS(4,K) = SUMNW !--------------- ! END OF LM LOOP !--------------- END DO !----------------- ! GLOBAL REDUCTION !----------------- CALL MPI_ALLREDUCE(XSUMS, GSUMS, 4*LM, MPI_REAL, MPI_SUM, MPI_COMM_COMP, IRECV) !------------------------ ! END OF GLOBAL REDUCTION !------------------------ ! !$omp parallel do !$omp private (DQSTIJ , DWSTIJ , HTMIJL , RFACQ , RFACW , RFQIJ , RFWIJ , SUMNW , & !$omp SUMNQ , SUMPQ , SUMPW ) ! DO K=1,LM ! SUMPQ = GSUMS(1,K) SUMNQ = GSUMS(2,K) SUMPW = GSUMS(3,K) SUMNW = GSUMS(4,K) !------------------------------- ! FIRST MOMENT CONSERVING FACTOR !------------------------------- IF (SUMPQ > 1.) THEN RFACQ = -SUMNQ / SUMPQ ELSE RFACQ = 1. END IF ! IF (SUMPW > 1.) THEN RFACW = -SUMNW / SUMPW ELSE RFACW = 1. END IF ! IF (RFACQ < 0.9 .OR. RFACQ > 1.1) RFACQ = 1. IF (RFACW < 0.9 .OR. RFACW > 1.1) RFACW = 1. !-------------------------------------- ! IMPOSE CONSERVATION ON ANTI-FILTERING !-------------------------------------- IF (RFACQ < 1.) THEN DO J=MYJS2,MYJE2 DO I=MYIS1,MYIE1 DQSTIJ = DQST(I,J,K) RFQIJ = HBM2(I,J) * (RFACQ-1.) + 1. IF (DQSTIJ >= 0.) DQSTIJ = DQSTIJ * RFQIJ Q(I,J,K) = Q1(I,J,K) + DQSTIJ END DO END DO ELSE DO J=MYJS2,MYJE2 DO I=MYIS1,MYIE1 DQSTIJ = DQST(I,J,K) RFQIJ = HBM2(I,J) * (RFACQ-1.) + 1. IF (DQSTIJ < 0.) DQSTIJ = DQSTIJ / RFQIJ Q(I,J,K) = Q1(I,J,K) + DQSTIJ END DO END DO END IF ! IF (RFACW < 1.) THEN DO J=MYJS2,MYJE2 DO I=MYIS1,MYIE1 DWSTIJ = DWST(I,J,K) RFWIJ = HBM2(I,J) * (RFACW-1.) + 1. IF (DWSTIJ >= 0.) DWSTIJ = DWSTIJ * RFWIJ CWM(I,J,K) = W1(I,J,K) + DWSTIJ END DO END DO ELSE DO J=MYJS2,MYJE2 DO I=MYIS1,MYIE1 DWSTIJ = DWST(I,J,K) RFWIJ = HBM2(I,J) * (RFACW-1.) + 1. IF (DWSTIJ < 0.) DWSTIJ = DWSTIJ / RFWIJ CWM(I,J,K) = W1(I,J,K) + DWSTIJ END DO END DO END IF ! DO J=MYJS,MYJE DO I=MYIS,MYIE HTMIJL = HTM(I,J,K) Q(I,J,K) = AMAX1( Q(I,J,K), EPSQ) * HTMIJL CWM(I,J,K) = AMAX1(CWM(I,J,K), CLIMIT) * HTMIJL END DO END DO !--------------- ! END OF LM LOOP !--------------- END DO ! RETURN ! END SUBROUTINE HZADV2