!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE HZADV2 ! ****************************************************************** !$$$ SUBPROGRAM DOCUMENTATION BLOCK ! . . . ! SUBPROGRAM: HZADV2 HORIZONTAL ADVECTION OF VAPOR AND CLOUD ! PRGRMMR: 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 ! USAGE: CALL HZADV1 FROM MAIN PROGRAM EBU ! INPUT ARGUMENT LIST: ! NONE ! OUTPUT ARGUMENT LIST ! NONE ! OUTPUT FILES: ! NONE ! SUBPROGRAMS CALLED: ! UNIQUE: NONE ! LIBRARY: NONE ! COMMON BLOCKS: CTLBLK ! LOOPS ! MASKS ! DYNAM ! CONTIN ! VRBLS ! PVRBLS ! CLDWTR ! INDX ! ATTRIBUTES: ! LANGUAGE: FORTRAN 90 ! MACHINE : IBM SP !$$$ !*********************************************************************** PARAMETER & (EPSQ=2.E-12,CLIMIT=1.E-20 & ,FF1=0.52500,FF2=-0.64813,FF3=0.24520,FF4=-0.12189) !----------------------------------------------------------------------- INCLUDE "parmeta.f90" INCLUDE "mpp.h" INCLUDE "mpif.h" #include "sp.h" !----------------------------------------------------------------------- PARAMETER & (IM1=IM-1,JAM=6+2*(JM-10) & , IMJM=IM*JM-JM/2 & , JAMD=(JAM*2-10)*3,LP1=LM+1) !----------------------------------------------------------------------- LOGICAL :: & RUN,FIRST,RESTRT,SIGMA !----------------------------------------------------------------------- INCLUDE "COMM_CTLBLK.f90" !----------------------------------------------------------------------- INCLUDE "COMM_LOOPS.f90" !----------------------------------------------------------------------- INCLUDE "COMM_MASKS.f90" !----------------------------------------------------------------------- INCLUDE "COMM_DYNAM.f90" !----------------------------------------------------------------------- INCLUDE "COMM_CONTIN.f90" !----------------------------------------------------------------------- INCLUDE "COMM_VRBLS.f90" !----------------------------------------------------------------------- INCLUDE "COMM_PVRBLS.f90" !----------------------------------------------------------------------- INCLUDE "COMM_CLDWTR.f90" !----------------------------------------------------------------------- INCLUDE "COMM_INDX.f90" !----------------------------------------------------------------------- DIMENSION & IFPA(IDIM1:IDIM2,JDIM1:JDIM2,LM),IFQA(IDIM1:IDIM2,JDIM1:JDIM2,LM) & ,IFPF(IDIM1:IDIM2,JDIM1:JDIM2,LM),IFQF(IDIM1:IDIM2,JDIM1:JDIM2,LM) & ,JFPA(IDIM1:IDIM2,JDIM1:JDIM2,LM),JFQA(IDIM1:IDIM2,JDIM1:JDIM2,LM) & ,JFPF(IDIM1:IDIM2,JDIM1:JDIM2,LM),JFQF(IDIM1:IDIM2,JDIM1:JDIM2,LM) & ,AFP (IDIM1:IDIM2,JDIM1:JDIM2,LM),AFQ (IDIM1:IDIM2,JDIM1:JDIM2,LM) & ,Q1 (IDIM1:IDIM2,JDIM1:JDIM2,LM),DQST(IDIM1:IDIM2,JDIM1:JDIM2,LM) & ,W1 (IDIM1:IDIM2,JDIM1:JDIM2,LM),DWST(IDIM1:IDIM2,JDIM1:JDIM2,LM) & ,DARE(IDIM1:IDIM2,JDIM1:JDIM2), DVOL(IDIM1:IDIM2,JDIM1:JDIM2,LM) & ,EMH (IDIM1:IDIM2,JDIM1:JDIM2) ! &,QLIM(IDIM1:IDIM2,JDIM1:JDIM2),WLIM (IDIM1:IDIM2,JDIM1:JDIM2) !----------------------------------------------------------------------- REAL :: & GSUMS(4,LM),XSUMS(4,LM) !----------------------------------------------------------------------- INTEGER :: & ISTAT(MPI_STATUS_SIZE) !*********************************************************************** 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 ENDDO ENDDO !*********************************************************************** !----------------------------------------------------------------------- ! omp parallel do ! omp& private(dqstij,dvolp,dwstij,htmijl,jfp,jfq,pp,qp, ! omp& sumnq,sumnw,sumpq,sumpw,tta,ttb) !----------------------------------------------------------------------- DO L=1,LM !----------------------------------------------------------------------- !*********************************************************************** DO 200 J=MYJS_P2,MYJE_P2 DO 200 I=MYIS_P1,MYIE_P1 DVOL(I,J,L)=DARE(I,J)*PDSL(I,J)*DETA(L) HTMIJL=HTM(I,J,L) Q (I,J,L)=AMAX1(Q (I,J,L),EPSQ)*HTMIJL CWM(I,J,L)=AMAX1(CWM(I,J,L),CLIMIT)*HTMIJL Q1 (I,J,L)=Q (I,J,L) W1 (I,J,L)=CWM(I,J,L) 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,L)*HBM3(I,J) TTA=(U(I,J-1,L)+U(I+IHW(J),J,L)+U(I+IHE(J),J,L)+U(I,J+1,L)) & *HBM2(I,J)*EMH(I,J) TTB=(V(I,J-1,L)+V(I+IHW(J),J,L)+V(I+IHE(J),J,L)+V(I,J+1,L)) & *HBM2(I,J)*ENH PP=-TTA-TTB QP= TTA-TTB JFP=INT(SIGN(1.,PP)) JFQ=INT(SIGN(1.,QP)) IFPA(I,J,L)=IHE(J)+I+( JFP-1 )/2 IFQA(I,J,L)=IHE(J)+I+(-JFQ-1 )/2 JFPA(I,J,L)= J+JFP JFQA(I,J,L)= J+JFQ IFPF(I,J,L)=IHE(J)+I+(-JFP-1 )/2 IFQF(I,J,L)=IHE(J)+I+( JFQ-1 )/2 JFPF(I,J,L)= J-JFP JFQF(I,J,L)= J-JFQ PP=ABS(PP)*HTM(I,J,L)*HTM(IFPA(I,J,L),JFPA(I,J,L),L) QP=ABS(QP)*HTM(I,J,L)*HTM(IFQA(I,J,L),JFQA(I,J,L),L) AFP (I,J,L)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP AFQ (I,J,L)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP DQSTIJ=(Q (IFPA(I,J,L),JFPA(I,J,L),L)-Q (I,J,L))*PP & +(Q (IFQA(I,J,L),JFQA(I,J,L),L)-Q (I,J,L))*QP DWSTIJ=(CWM(IFPA(I,J,L),JFPA(I,J,L),L)-CWM(I,J,L))*PP & +(CWM(IFQA(I,J,L),JFQA(I,J,L),L)-CWM(I,J,L))*QP DQST(I,J,L)=DQSTIJ DWST(I,J,L)=DWSTIJ 300 END DO !*** !*** GLOBAL SUM FOR CONSERVATION !*** DO 310 J=MYJS2,MYJE2 DO 310 I=MYIS1,MYIE1 DVOLP=DVOL(I,J,L)*HBM3(I,J) DQSTIJ=DQST(I,J,L)*DVOLP DWSTIJ=DWST(I,J,L)*DVOLP IF(DQSTIJ > 0.)THEN SUMPQ=SUMPQ+DQSTIJ ELSE SUMNQ=SUMNQ+DQSTIJ ENDIF IF(DWSTIJ > 0.)THEN SUMPW=SUMPW+DWSTIJ ELSE SUMNW=SUMNW+DWSTIJ ENDIF 310 END DO !----------------------------------------------------------------------- XSUMS(1,L)=SUMPQ XSUMS(2,L)=SUMNQ XSUMS(3,L)=SUMPW XSUMS(4,L)=SUMNW ENDDO ! END OF LM LOOP !----------------------------------------------------------------------- !*** 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, ! omp& q00,q0q,q1ij,qp0,qstij,rfacq,rfacw, ! omp& rfqij,rfwij,sumnq,sumnw,sumpq,sumpw, ! omp& w00,w0q,w1ij,wp0,wstij) !----------------------------------------------------------------------- DO L=1,LM !----------------------------------------------------------------------- SUMPQ=GSUMS(1,L) SUMNQ=GSUMS(2,L) SUMPW=GSUMS(3,L) SUMNW=GSUMS(4,L) !--------------FIRST MOMENT CONSERVING FACTOR--------------------------- IF(SUMPQ > 1.)THEN RFACQ=-SUMNQ/SUMPQ ELSE RFACQ=1. ENDIF IF(SUMPW > 1.)THEN RFACW=-SUMNW/SUMPW ELSE RFACW=1. ENDIF 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,L) RFQIJ=HBM3(I,J)*(RFACQ-1.)+1. IF(DQSTIJ < 0.)DQSTIJ=DQSTIJ/RFQIJ Q1(I,J,L)=Q(I,J,L)+DQSTIJ ENDDO ENDDO ELSE DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS1_P1,MYIE1_P1 DQSTIJ=DQST(I,J,L) RFQIJ=HBM3(I,J)*(RFACQ-1.)+1. IF(DQSTIJ >= 0.)DQSTIJ=DQSTIJ*RFQIJ Q1(I,J,L)=Q(I,J,L)+DQSTIJ ENDDO ENDDO ENDIF !----------------------------------------------------------------------- IF(RFACW < 1.)THEN DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS1_P1,MYIE1_P1 DWSTIJ=DWST(I,J,L) RFWIJ=HBM3(I,J)*(RFACW-1.)+1. IF(DWSTIJ < 0.)DWSTIJ=DWSTIJ/RFWIJ W1(I,J,L)=CWM(I,J,L)+DWSTIJ ENDDO ENDDO ELSE DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS1_P1,MYIE1_P1 DWSTIJ=DWST(I,J,L) RFWIJ=HBM3(I,J)*(RFACW-1.)+1. IF(DWSTIJ >= 0.)DWSTIJ=DWSTIJ*RFWIJ W1(I,J,L)=CWM(I,J,L)+DWSTIJ ENDDO ENDDO ENDIF !--------------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,L) Q1IJ =Q1(I,J,L) W1IJ =W1(I,J,L) D2PQQ=((Q1(IFPA(I,J,L),JFPA(I,J,L),L)-Q1IJ ) & -(Q1IJ -Q1(IFPF(I,J,L),JFPF(I,J,L),L)) & *HTM(IFPF(I,J,L),JFPF(I,J,L),L))*AFP(I,J,L) & +((Q1(IFQA(I,J,L),JFQA(I,J,L),L)-Q1IJ ) & -(Q1IJ -Q1(IFQF(I,J,L),JFQF(I,J,L),L)) & *HTM(IFQF(I,J,L),JFQF(I,J,L),L))*AFQ(I,J,L) D2PQW=((W1(IFPA(I,J,L),JFPA(I,J,L),L)-W1IJ ) & -(W1IJ -W1(IFPF(I,J,L),JFPF(I,J,L),L)) & *HTM(IFPF(I,J,L),JFPF(I,J,L),L))*AFP(I,J,L) & +((W1(IFQA(I,J,L),JFQA(I,J,L),L)-W1IJ ) & -(W1IJ -W1(IFQF(I,J,L),JFQF(I,J,L),L)) & *HTM(IFQF(I,J,L),JFQF(I,J,L),L))*AFQ(I,J,L) QSTIJ=Q1IJ-D2PQQ WSTIJ=W1IJ-D2PQW Q00=Q (I ,J ,L) QP0=Q (IFPA(I,J,L),JFPA(I,J,L),L) Q0Q=Q (IFQA(I,J,L),JFQA(I,J,L),L) W00=CWM(I ,J ,L) WP0=CWM(IFPA(I,J,L),JFPA(I,J,L),L) W0Q=CWM(IFQA(I,J,L),JFQA(I,J,L),L) 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,L)=DQSTIJ DWST(I,J,L)=DWSTIJ DQSTIJ=DQSTIJ*DVOLP DWSTIJ=DWSTIJ*DVOLP IF(DQSTIJ > 0.)THEN SUMPQ =SUMPQ+DQSTIJ ELSE SUMNQ =SUMNQ+DQSTIJ ENDIF IF(DWSTIJ > 0.)THEN SUMPW =SUMPW+DWSTIJ ELSE SUMNW =SUMNW+DWSTIJ ENDIF 330 END DO !----------------------------------------------------------------------- XSUMS(1,L)=SUMPQ XSUMS(2,L)=SUMNQ XSUMS(3,L)=SUMPW XSUMS(4,L)=SUMNW ENDDO ! END OF LM LOOP !----------------------------------------------------------------------- !*** 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, ! omp& sumnw,sumnq,sumpq,sumpw) !----------------------------------------------------------------------- DO L=1,LM SUMPQ=GSUMS(1,L) SUMNQ=GSUMS(2,L) SUMPW=GSUMS(3,L) SUMNW=GSUMS(4,L) !--------------FIRST MOMENT CONSERVING FACTOR--------------------------- IF(SUMPQ > 1.)THEN RFACQ=-SUMNQ/SUMPQ ELSE RFACQ=1. ENDIF IF(SUMPW > 1.)THEN RFACW=-SUMNW/SUMPW ELSE RFACW=1. ENDIF 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,L) RFQIJ=HBM2(I,J)*(RFACQ-1.)+1. IF(DQSTIJ >= 0.) DQSTIJ=DQSTIJ*RFQIJ Q (I,J,L)=Q1(I,J,L)+DQSTIJ ENDDO ENDDO ELSE DO J=MYJS2,MYJE2 DO I=MYIS1,MYIE1 DQSTIJ=DQST(I,J,L) RFQIJ=HBM2(I,J)*(RFACQ-1.)+1. IF(DQSTIJ < 0.) DQSTIJ=DQSTIJ/RFQIJ Q (I,J,L)=Q1(I,J,L)+DQSTIJ ENDDO ENDDO ENDIF !----------------------------------------------------------------------- IF(RFACW < 1.)THEN DO J=MYJS2,MYJE2 DO I=MYIS1,MYIE1 DWSTIJ=DWST(I,J,L) RFWIJ=HBM2(I,J)*(RFACW-1.)+1. IF(DWSTIJ >= 0.) DWSTIJ=DWSTIJ*RFWIJ CWM(I,J,L)=W1(I,J,L)+DWSTIJ ENDDO ENDDO ELSE DO J=MYJS2,MYJE2 DO I=MYIS1,MYIE1 DWSTIJ=DWST(I,J,L) RFWIJ=HBM2(I,J)*(RFACW-1.)+1. IF(DWSTIJ < 0.) DWSTIJ=DWSTIJ/RFWIJ CWM(I,J,L)=W1(I,J,L)+DWSTIJ ENDDO ENDDO ENDIF !----------------------------------------------------------------------- DO J=MYJS,MYJE DO I=MYIS,MYIE HTMIJL=HTM(I,J,L) Q (I,J,L)=AMAX1(Q (I,J,L),EPSQ)*HTMIJL CWM(I,J,L)=AMAX1(CWM(I,J,L),CLIMIT)*HTMIJL ENDDO ENDDO !----------------------------------------------------------------------- ENDDO ! END OF LM LOOP !----------------------------------------------------------------------- RETURN END SUBROUTINE HZADV2