A ROTINA DA ESQUERDA É A VERSÃO ANTIGA DE 2012 E A ROTINA DA DIREITA É A VERSÃO MODULAR DO Eta1km C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& | SUBROUTINE VTADV SUBROUTINE VTADV | !>---------------------------------------------------------------------------------------------- C ****************************************************************** | !> SUBROUTINE VTADV C$$$ SUBPROGRAM DOCUMENTATION BLOCK | !> C . . . | !> SUBPROGRAM: VTADV - VERTICAL ADVECTION C SUBPROGRAM: VTADV VERTICAL ADVECTION | !> PROGRAMMER: JANJIC C PRGRMMR: JANJIC ORG: W/NP22 DATE: 93-11-17 | !> ORG: W/NP22 C | !> DATE: 93-11-17 C ABSTRACT: | !> C VTADV CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION | !> ABSTRACT: C TO THE TENDENCIES OF TEMPERATURE, SPECIFIC HUMIDITY, WIND | !> VTADV CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION TO THE TENDENCIES OF TEMPERATURE, C COMPONENTS, AND TURBULENT KINETIC ENERGY AND THEN UPDATES THOSE | !> SPECIFIC HUMIDITY, WIND COMPONENTS, AND TURBULENT KINETIC ENERGY AND THEN UPDATES THOSE C VARIABLES. FOR ALL VARIABLES EXCEPT SPECIFIC HUMIDITY A | !> VARIABLES. FOR ALL VARIABLES EXCEPT SPECIFIC HUMIDITY A SIMPLE CENTERED DIFFERENCE SCHEME IN C SIMPLE CENTERED DIFFERENCE SCHEME IN SPACE IS USED IN | !> SPACE IS USED IN CONJUNCTION WITH THE PURE EULER-BACKWARD TIME SCHEME. C CONJUNCTION WITH THE PURE EULER-BACKWARD TIME SCHEME. | !> A PIECEWISE LINEAR SCHEME IS USED TO CALCULATE THE VERTICAL ADVECTION OF SPECIFIC HUMIDITY SO C A PIECEWISE LINEAR SCHEME IS USED TO CALCULATE THE VERTICAL | !> THAT NO FALSE MAXIMA OR MINIMA ARE PRODUCED. C ADVECTION OF SPECIFIC HUMIDITY SO THAT NO FALSE MAXIMA OR | !> C MINIMA ARE PRODUCED. | !> PIECEWISE LINEAR SCHEME (MESINGER AND JOVIC, NCEP OFFICE NOTE #439) HERE USED FOR ALL VARIABL C | !> AVOIDING FALSE ADVECTION FROM BELOW GROUND, AND AT THE SAME TIME MAKING THE ETA VERY NEARLY A C PIECEWISE LINEAR SCHEME (MESINGER AND JOVIC, NCEP OFFICE NOTE | !> FINITE VOLUME MODEL. C #439) HERE USED FOR ALL VARIABLES, AVOIDING FALSE ADVECTION | !> C FROM BELOW GROUND, AND AT THE SAME TIME MAKING THE ETA | !> PROGRAM HISTORY LOG: C VERY NEARLY A FINITE VOLUME MODEL | !> 87-06-?? JANJIC - ORIGINATOR C | !> 90-??-?? MESINGER - INSERTED PIECEWISE LINEAR SCHEME FOR SPECIFIC HUMIDITY C PROGRAM HISTORY LOG: | !> 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL C 87-06-?? JANJIC - ORIGINATOR | !> 95-11-20 ABELES - PARALLEL OPTIMIZATION C 90-??-?? MESINGER - INSERTED PIECEWISE LINEAR SCHEME FOR | !> 96-03-29 BLACK - ADDED EXTERNAL EDGE; REMOVED SCRCH COMMON C SPECIFIC HUMIDITY | !> 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY C 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL | !> 00-02-04 BLACK - ADDED CLOUD WATER/ICE C 95-11-20 ABELES - PARALLEL OPTIMIZATION | !> 01-12-11 BLACK - SMOOTHING FOR CFL VIOLATION C 96-03-29 BLACK - ADDED EXTERNAL EDGE; REMOVED SCRCH COMMON | !> 18-01-15 LUCCI - MODERNIZATION OF THE CODE, INCLUDING: C 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY | !> * F77 TO F90/F95 C 00-02-04 BLACK - ADDED CLOUD WATER/ICE | !> * INDENTATION & UNIFORMIZATION CODE C 01-12-11 BLACK - SMOOTHING FOR CFL VIOLATION | !> * REPLACEMENT OF COMMONS BLOCK FOR MODULES C | !> * DOCUMENTATION WITH DOXYGEN C This is the code as e-mailed April 10, 07, but with bugs corrected: | !> * OPENMP FUNCTIONALITY C 1) FFD1, twice, 1 is removed, | !> C 2) F4D, in loop 1320, the second pair changed into F4Q; | !> INPUT ARGUMENT LIST: C 3) ..TEND1.. 2nd time in loop 1330 repl. by ..TEND2.. | !> NONE C and also: | !> C a) dead pieces of the code - abandoned finite difference vertical | !> OUTPUT ARGUMENT LIST: C advection of T and u,v (twice "GO TO ..." segments) - deleted; | !> NONE C b) Switching to calls every time step commented out, as this | !> C takes non-negligible time, and in the Eta horizontal advection | !> INPUT/OUTPUT ARGUMENT LIST: C is called every second time step also (consistency) | !> NONE C | !> C USAGE: CALL VTADV FROM MAIN PROGRAM EBU | !> OUTPUT FILES: C INPUT ARGUMENT LIST: | !> NONE C NONE | !> C | !> USE MODULES: CLDWTR C OUTPUT ARGUMENT LIST: | !> CONTIN C NONE | !> CTLBLK C | !> DYNAM C OUTPUT FILES: | !> F77KINDS C NONE | !> GLB_TABLE C | !> INDX C SUBPROGRAMS CALLED: | !> LOOPS C | !> MAPPINGS C UNIQUE: NONE | !> MASKS C | !> MPPCOM C LIBRARY: NONE | !> NHYDRO C | !> PARMETA C COMMON BLOCKS: CTLBLK | !> PVRBLS C MASKS | !> TEMPCOM C DYNAM | !> TOPO C VRBLS | !> TEMPCOM C CONTIN | !> TOPO C PVRBLS | !> VRBLS C CLDWTR | !v C INDX | !> DRIVER : EBU C | !> NEWFLT C ATTRIBUTES: | !> C LANGUAGE: FORTRAN 90 | !> CALLS : ----- C MACHINE : IBM SP | !>---------------------------------------------------------------------------------------------- C$$$ | ! C*********************************************************************** | !-------------------------------------------------------------------------------------------- P A R A M E T E R | ! THIS IS THE CODE AS E-MAILED APRIL 10, 07, BUT WITH BUGS CORRECTED: & (EDQMX=2.E-5,EDQMN=-2.E-5,EPSQ=1.E-12,EPSQ2=0.2,KSMUD=0) | ! 1) FFD1, TWICE, 1 IS REMOVED, C | ! 2) F4D, IN LOOP 1320, THE SECOND PAIR CHANGED INTO F4Q; P A R A M E T E R | ! 3) ..TEND1.. 2ND TIME IN LOOP 1330 REPL. BY ..TEND2.. & (CFL_MAX=0.97) | ! AND ALSO: C----------------------------------------------------------------------- | ! A) DEAD PIECES OF THE CODE - ABANDONED FINITE DIFFERENCE VERTICAL ADVECTION OF T AND U, V INCLUDE "parmeta" | ! (TWICE "GO TO ..." SEGMENTS) - DELETED; INCLUDE "mpp.h" | ! B) SWITCHING TO CALLS EVERY TIME STEP COMMENTED OUT, AS THIS TAKES NON-NEGLIGIBLE TIME, AND #include "sp.h" | ! IN THE ETA HORIZONTAL ADVECTION IS CALLED EVERY SECOND TIME STEP ALSO (CONSISTENCY) C----------------------------------------------------------------------- | !-------------------------------------------------------------------------------------------- P A R A M E T E R | USE CLDWTR & (IMJM=IM*JM-JM/2,JAM=6+2*(JM-10) | USE CONTIN &, LM1=LM-1,LM2=LM-2,LP1=LM+1) | USE CTLBLK C----------------------------------------------------------------------- | USE DYNAM L O G I C A L | USE F77KINDS & RUN,FIRST,RESTRT,SIGMA,NOSLA,NOSLAW | USE GLB_TABLE C---------------------------------------------------------------------- | USE INDX INCLUDE "CTLBLK.comm" | USE LOOPS , ONLY : JAM C----------------------------------------------------------------------- | USE MAPPINGS INCLUDE "MASKS.comm" | USE MASKS C----------------------------------------------------------------------- | USE MPPCOM INCLUDE "DYNAM.comm" | USE NHYDRO C----------------------------------------------------------------------- | USE PARMETA INCLUDE "VRBLS.comm" | USE PVRBLS C----------------------------------------------------------------------- | USE TEMPCOM INCLUDE "CONTIN.comm" | USE TOPO C----------------------------------------------------------------------- | USE VRBLS INCLUDE "PVRBLS.comm" | ! C----------------------------------------------------------------------- | IMPLICIT NONE INCLUDE "CLDWTR.comm" | ! C----------------------------------------------------------------------- | REAL (KIND=R4KIND), PARAMETER :: EDQMX = 2.E-5 INCLUDE "INDX.comm" | REAL (KIND=R4KIND), PARAMETER :: EDQMN = -2.E-5 C----------------------------------------------------------------------- | REAL (KIND=R4KIND), PARAMETER :: EPSQ = 1.E-12 INCLUDE "NHYDRO.comm" | REAL (KIND=R4KIND), PARAMETER :: EPSQ2 = 0.2 C----------------------------------------------------------------------- | REAL (KIND=R4KIND), PARAMETER :: CFL_MAX = 0.97 D I M E N S I O N | ! & WFA ( LM1),WFB ( LM1) | INTEGER(KIND=I4KIND), PARAMETER :: KSMUD = 0 C | ! D I M E N S I O N | #include "sp.h" & ETADTL(IDIM1:IDIM2,JDIM1:JDIM2) | ! &, TQ2B (IDIM1:IDIM2,JDIM1:JDIM2) | INTEGER(KIND=I4KIND), PARAMETER :: IMJM = IM * JM - JM / 2 &,DQTI (IDIM1:IDIM2,JDIM1:JDIM2),DQBI (IDIM1:IDIM2,JDIM1:JDIM2) | ! &,RPDX (IDIM1:IDIM2,JDIM1:JDIM2),RPDY (IDIM1:IDIM2,JDIM1:JDIM2) | LOGICAL(KIND=L4KIND) &,QDEDB (IDIM1:IDIM2,JDIM1:JDIM2),QDEUB (IDIM1:IDIM2,JDIM1:JDIM2) | & NOSLA , NOSLAW &, EDBD (IDIM1:IDIM2,JDIM1:JDIM2) | ! &, DQDEB (IDIM1:IDIM2,JDIM1:JDIM2) | REAL (KIND=R4KIND), DIMENSION(LM1) C | & WFA , WFB &,DUTI (IDIM1:IDIM2,JDIM1:JDIM2),DUBI (IDIM1:IDIM2,JDIM1:JDIM2) | ! &,DVTI (IDIM1:IDIM2,JDIM1:JDIM2),DVBI (IDIM1:IDIM2,JDIM1:JDIM2) | REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2) &,UDEDB (IDIM1:IDIM2,JDIM1:JDIM2),UDEUB (IDIM1:IDIM2,JDIM1:JDIM2) | & ETADTL , &,VDEDB (IDIM1:IDIM2,JDIM1:JDIM2),VDEUB (IDIM1:IDIM2,JDIM1:JDIM2) | & TQ2B , &,EDBDU (IDIM1:IDIM2,JDIM1:JDIM2),EDBDV (IDIM1:IDIM2,JDIM1:JDIM2) | & DQTI , DQBI , &,DUDEB (IDIM1:IDIM2,JDIM1:JDIM2),DVDEB (IDIM1:IDIM2,JDIM1:JDIM2) | & RPDX , RPDY , | & QDEDB , QDEUB , D I M E N S I O N | & EDBD , & FNE (IDIM1:IDIM2,JDIM1:JDIM2),FSE (IDIM1:IDIM2,JDIM1:JDIM2) | & DQDEB , C | & DUTI , DUBI , D I M E N S I O N | & DVTI , DVBI , & SAM (IDIM1:IDIM2,JDIM1:JDIM2,LM) | & UDEDB , UDEUB , &,QBI (IDIM1:IDIM2,JDIM1:JDIM2,LM) | & VDEDB , VDEUB , &,Q2ST (IDIM1:IDIM2,JDIM1:JDIM2,LM) | & EDBDU , EDBDV , &,ARRAY1(IDIM1:IDIM2,JDIM1:JDIM2,LM1) | & DUDEB , DVDEB , &,ARRAY2(IDIM1:IDIM2,JDIM1:JDIM2,LM1) | & FNE , FSE C | ! &,SAMU (IDIM1:IDIM2,JDIM1:JDIM2,LM) | REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2, LM) &,UBI (IDIM1:IDIM2,JDIM1:JDIM2,LM) | & SAM , &,SAMV (IDIM1:IDIM2,JDIM1:JDIM2,LM) | & QBI , &,VBI (IDIM1:IDIM2,JDIM1:JDIM2,LM) | & Q2ST , &,ARRAYU1(IDIM1:IDIM2,JDIM1:JDIM2,LM1) | & SAMU , &,ARRAYU2(IDIM1:IDIM2,JDIM1:JDIM2,LM1) | & UBI , &,ARRAYV1(IDIM1:IDIM2,JDIM1:JDIM2,LM1) | & SAMV , &,ARRAYV2(IDIM1:IDIM2,JDIM1:JDIM2,LM1) | & VBI C----------------------------------------------------------------------- | ! R E A L | REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2, LM1) &,ALLOCATABLE,DIMENSION(:,:,:) :: S | & ARRAY1 , C----------------------------------------------------------------------- | & ARRAY2 , R E A L | & ARRAYU1 , & VAD_TEND1(IDIM1:IDIM2,JDIM1:JDIM2,LM) | & ARRAYU2 , &,VAD_TEND2(IDIM1:IDIM2,JDIM1:JDIM2,LM) | & ARRAYV1 , &,VAD_TNDX1(LM),VAD_TNDX2(LM) | & ARRAYV2 ! | ! I N T E G E R | REAL (KIND=R4KIND), DIMENSION(:,:,:), ALLOCATABLE & LBOT_CFL_T(IDIM1:IDIM2,JDIM1:JDIM2) | & S &,LTOP_CFL_T(IDIM1:IDIM2,JDIM1:JDIM2) | ! &,LBOT_CFL_U(IDIM1:IDIM2,JDIM1:JDIM2) | REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2, LM) &,LTOP_CFL_U(IDIM1:IDIM2,JDIM1:JDIM2) | & VAD_TEND1 , VAD_TEND2 &,LBOT_CFL_V(IDIM1:IDIM2,JDIM1:JDIM2) | ! &,LTOP_CFL_V(IDIM1:IDIM2,JDIM1:JDIM2) | REAL (KIND=R4KIND), DIMENSION(LM) C----------------------------------------------------------------------- | & VAD_TNDX1 , VAD_TNDX2 C----------------------------------------------------------------------- | ! DTAD=IDTAD*DT | INTEGER(KIND=I4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2) Cpazi | & LBOT_CFL_T , LTOP_CFL_T , Cpazi (constants change to call VTADV every time step, commented out) | & LBOT_CFL_U , LTOP_CFL_U , C DTAD=DTAD*0.5 | & LBOT_CFL_V , LTOP_CFL_V C F4D=F4D*0.5 | !------------------------ C F4Q=F4Q*0.5 | ! IMPLICIT NONE VARIABLES C DO L=1,LM | !------------------------ C F4Q2(L)=F4Q2(L)*0.5 | INTEGER(KIND=I4KIND) C END DO | & K , NMSAP , NMSAPW , I , J , NSMUD , KS , NS , MSA , Cpazi | & IER , LSTART , LSTOP C----------------------------------------------------------------------- | ! C--------------DEFINE ADDED UPSTREAM ADVECTION CONSTANTS---------------- | REAL (KIND=R4KIND) C----------------------------------------------------------------------- | & DTAD , CFL , EXTREM , DQTIK , ASTIK , ASBIK , QDEDTK , QDEUTK , SEDBK , DO 25 L=1,LM1 | & DQDEK , EDBFK , EDTDK , TQ2AK , EXTREMU , EXTREMV , DUTIK , DVTIK , ASTIKU , WFA(L)=DETA(L )/(DETA(L)+DETA(L+1)) | & ASTIKV , ASBIKU , ASBIKV , VMIJ , UDEDTK , VDEDTK , VDEUTK , UDEUTK , SEDBKU , WFB(L)=DETA(L+1)/(DETA(L)+DETA(L+1)) | & SEDBKV , DUDEK , DVDEK , EDBFKU , EDBFKV , EDTDKU , EDTDKV 25 CONTINUE | ! C--------------NO MOISTURE SLOPE ADJUSTMENT IF NOT WANTED--------------- | DTAD = IDTAD * DT NOSLA=.FALSE. | !------------------------------------------ NOSLAW=.FALSE. | ! DEFINE ADDED UPSTREAM ADVECTION CONSTANTS C IF FALSE, NUMBER OF MOISTURE SLOPE ADJUSTMENT PASSES | !------------------------------------------ NMSAP=3 | DO 25 K=1,LM1 NMSAPW=3 | WFA(K) = DETA(K ) / (DETA(K) + DETA(K+1)) C--------------SMOOTHING VERTICAL VELOCITY AT H POINTS------------------ | WFB(K) = DETA(K+1) / (DETA(K) + DETA(K+1)) IF(KSMUD.GT.0)THEN | 25 END DO !$omp parallel do | !------------------------------------------- DO 90 L=1,LM1 | ! NO MOISTURE SLOPE ADJUSTMENT IF NOT WANTED DO 50 J=MYJS_P4,MYJE_P4 | !------------------------------------------- DO 50 I=MYIS_P4,MYIE_P4 | NOSLA = .FALSE. ETADT(I,J,L)=ETADT(I,J,L)*HBM2(I,J) | NOSLAW = .FALSE. 50 CONTINUE | !----------------------------------------------------- C----------------------------------------------------------------------- | ! IF FALSE, NUMBER OF MOISTURE SLOPE ADJUSTMENT PASSES NSMUD=KSMUD | !----------------------------------------------------- C*** | NMSAP = 3 C*** THE FNE, FSE, ETADTL, AND ETADT ARRAYS | NMSAPW = 3 C*** ARE ON OR ASSOCIATED WITH H POINTS | !---------------------------------------- C*** | ! SMOOTHING VERTICAL VELOCITY AT H POINTS DO 90 KS=1,NSMUD | !---------------------------------------- DO 80 J=MYJS_P3,MYJE1_P3 | IF (KSMUD > 0) THEN DO 80 I=MYIS_P3,MYIE_P3 | ! FNE(I,J)=(ETADT(I+IHE(J),J+1,L)-ETADT(I,J,L)) | !$omp parallel do 1 *HTM(I,J,L+1)*HTM(I+IHE(J),J+1,L+1) | ! 80 CONTINUE | DO 90 K=1,LM1 DO 82 J=MYJS1_P3,MYJE_P3 | DO 50 J=MYJS_P4,MYJE_P4 DO 82 I=MYIS_P3,MYIE_P3 | DO 50 I=MYIS_P4,MYIE_P4 FSE(I,J)=(ETADT(I+IHE(J),J-1,L)-ETADT(I,J,L)) | ETADT(I,J,K) = ETADT(I,J,K) * HBM2(I,J) 1 *HTM(I+IHE(J),J-1,L+1)*HTM(I,J,L+1) | 50 END DO 82 CONTINUE | ! DO 84 J=MYJS2_P1,MYJE2_P1 | NSMUD = KSMUD DO 84 I=MYIS_P1,MYIE_P1 | !------------------------------------------------------------------------- ETADTL(I,J)=(FNE(I,J)-FNE(I+IHW(J),J-1) | ! HE FNE, FSE, ETADTL, AND ETADT ARRAYS ARE ON OR ASSOCIATED WITH H POINTS 1 +FSE(I,J)-FSE(I+IHW(J),J+1))*HBM2(I,J) | !------------------------------------------------------------------------- 84 CONTINUE | DO 90 KS=1,NSMUD DO 86 J=MYJS2_P1,MYJE2_P1 | DO 80 J=MYJS_P3,MYJE1_P3 DO 86 I=MYIS_P1,MYIE_P1 | DO 80 I=MYIS_P3,MYIE_P3 ETADT(I,J,L)=ETADTL(I,J)*0.125+ETADT(I,J,L) | FNE(I,J) = (ETADT(I+IHE(J),J+1,K ) - ETADT(I ,J ,K )) 86 CONTINUE | & * HTM(I ,J ,K+1) * HTM(I+IHE(J),J+1,K+1) 90 CONTINUE | 80 END DO C----------------------------------------------------------------------- | ! ENDIF | DO 82 J=MYJS1_P3,MYJE_P3 !----------------------------------------------------------------------- | DO 82 I=MYIS_P3,MYIE_P3 ! | FSE(I,J) = (ETADT(I+IHE(J),J-1,K ) - ETADT(I,J,K )) !*** IF THE CFL CRITERION IS VIOLATED THEN LOCATE VERTICAL LIMITS | & * HTM(I+IHE(J),J-1,K+1) * HTM(I,J,K+1) !*** BETWEEN WHICH TO SMOOTH THE TENDENCIES | 82 END DO ! | ! !----------------------------------------------------------------------- | DO 84 J=MYJS2_P1,MYJE2_P1 !$omp parallel do | DO 84 I=MYIS_P1,MYIE_P1 DO J=MYJS,MYJE | ETADTL(I,J) = (FNE(I,J) - FNE(I+IHW(J),J-1) DO I=MYIS,MYIE | & + FSE(I,J) - FSE(I+IHW(J),J+1)) LTOP_CFL_T(I,J)=0 | & * HBM2(I,J) LBOT_CFL_T(I,J)=0 | 84 END DO LTOP_CFL_U(I,J)=0 | ! LBOT_CFL_U(I,J)=0 | DO 86 J=MYJS2_P1,MYJE2_P1 LTOP_CFL_V(I,J)=0 | DO 86 I=MYIS_P1,MYIE_P1 LBOT_CFL_V(I,J)=0 | ETADT(I,J,K) = ETADTL(I,J) * 0.125 + ETADT(I,J,K) ENDDO | 86 END DO ENDDO | ! ! | 90 END DO DO L=1,LM1 | ! ! | END IF !$omp parallel do private(cfl) | !------------------------------------------------------------------------------------------ DO J=MYJS2,MYJE2 | ! IF THE CFL CRITERION IS VIOLATED THEN LOCATE VERTICAL LIMITS BETWEEN WHICH TO SMOOTH THE DO I=MYIS,MYIE | ! TENDENCIES ! | !------------------------------------------------------------------------------------------ !*** MASS POINTS | ! ! | !$omp parallel do CFL=ETADT(I,J,L)*DTAD*HBM2(I,J)/(0.5*(DETA(L)+DETA(L+1))) | ! IF(ABS(CFL).GT.CFL_MAX)THEN | DO J=MYJS,MYJE IF(LTOP_CFL_T(I,J).EQ.0)LTOP_CFL_T(I,J)=MAX(L,2) | DO I=MYIS,MYIE IF(LBOT_CFL_T(I,J).LT.L)LBOT_CFL_T(I,J)=MAX(L,2) | LTOP_CFL_T(I,J) = 0 ENDIF | LBOT_CFL_T(I,J) = 0 ! | LTOP_CFL_U(I,J) = 0 !*** U COMPONENT | LBOT_CFL_U(I,J) = 0 ! | LTOP_CFL_V(I,J) = 0 CFL=(ETADT(I+IVW(J),J,L)+ETADT(I+IVE(J),J,L))*DTAD*VBM2(I,J) | LBOT_CFL_V(I,J) = 0 1 /(DETA(L)+DETA(L+1)) | END DO ! | END DO IF(ABS(CFL).GT.CFL_MAX)THEN | ! IF(LTOP_CFL_U(I,J).EQ.0)LTOP_CFL_U(I,J)=MAX(L,2) | DO K=1,LM1 IF(LBOT_CFL_U(I,J).LT.L)LBOT_CFL_U(I,J)=MAX(L,2) | ! ENDIF | !$omp parallel do private (CFL) ! | ! !*** V COMPONENT | DO J=MYJS2,MYJE2 ! | DO I=MYIS,MYIE CFL=(ETADT(I,J-1,L)+ETADT(I,J+1,L))*DTAD*VBM2(I,J) | !------------ 1 /(DETA(L)+DETA(L+1)) | ! MASS POINTS ! | !------------ IF(ABS(CFL).GT.CFL_MAX)THEN | CFL = ETADT(I,J,K) * DTAD * HBM2(I,J)/(0.5*(DETA(K)+DETA(K+1))) IF(LTOP_CFL_V(I,J).EQ.0)LTOP_CFL_V(I,J)=MAX(L,2) | IF (ABS(CFL) > CFL_MAX) THEN IF(LBOT_CFL_V(I,J).LT.L)LBOT_CFL_V(I,J)=MAX(L,2) | IF (LTOP_CFL_T(I,J) == 0) LTOP_CFL_T(I,J) = MAX(K,2) ENDIF | IF (LBOT_CFL_T(I,J) < K ) LBOT_CFL_T(I,J) = MAX(K,2) ! | END IF ENDDO | !------------ ENDDO | ! U COMPONENT ! | !------------ ENDDO | CFL = (ETADT(I+IVW(J),J,K) + ETADT(I+IVE(J),J,K)) ! | & * DTAD * VBM2(I,J) / (DETA(K)+DETA(K+1)) C----------------------------------------------------------------------- | ! C--------------PIECEWISE LINEAR UPSTREAM VERTICAL ADVECTION ------------ | IF (ABS(CFL) > CFL_MAX) THEN C-------------------------- OF Q AND CLOUD ----------------------------- | IF (LTOP_CFL_U(I,J) == 0) LTOP_CFL_U(I,J) = MAX(K,2) C----------------------------------------------------------------------- | IF (LBOT_CFL_U(I,J) < K ) LBOT_CFL_U(I,J) = MAX(K,2) ALLOCATE(S(IDIM1:IDIM2,JDIM1:JDIM2,LM),STAT=I) | END IF C----------------------------------------------------------------------- | !------------ C INTIALIZE Q AT THE BOTTOM INTERFACE AND THE SLOPE ADJUSTMENT | ! V COMPONENT C MASK (SAM=1 FOR SA PERMITTED, 0 FOR NOT PERMITTED) | !------------ C----------------------------------------------------------------------- | CFL = (ETADT(I,J-1,K) + ETADT(I,J+1,K)) * DTAD * VBM2(I,J) / (DETA(K) + DETA(K+1 C | ! C*** LOOP OVER S VARIABLES (Q,CWM,T) | IF (ABS(CFL) > CFL_MAX) THEN C | IF (LTOP_CFL_V(I,J) == 0) LTOP_CFL_V(I,J) = MAX(K,2) DO 400 NS=1,3 | IF (LBOT_CFL_V(I,J) < K ) LBOT_CFL_V(I,J) = MAX(K,2) C----------------------------------------------------------------------- | END IF IF(NS.EQ.1)THEN | ! !$omp parallel do | END DO DO L=1,LM | END DO DO J=JDIM1,JDIM2 | ! DO I=IDIM1,IDIM2 | END DO S(I,J,L)=Q(I,J,L) | !------------------------------------------------------------ ENDDO | ! PIECEWISE LINEAR UPSTREAM VERTICAL ADVECTION OF Q AND CLOUD ENDDO | !------------------------------------------------------------ ENDDO | ALLOCATE(S(IDIM1:IDIM2, JDIM1:JDIM2,LM), STAT=I) ELSE IF (NS.EQ.2) THEN | !----------------------------------------------------------------------------------------------- !$omp parallel do | ! INTIALIZE Q AT THE BOTTOM INTERFACE AND THE SLOPE ADJUSTMENT MASK (SAM=1 FOR SA PERMITTED, 0 F DO L=1,LM | ! NOT PERMITTED) DO J=JDIM1,JDIM2 | !----------------------------------------------------------------------------------------------- DO I=IDIM1,IDIM2 | ! S(I,J,L)=CWM(I,J,L) | !-------------------------------- ENDDO | ! LOOP OVER S VARIABLES (Q,CWM,T) ENDDO | !-------------------------------- ENDDO | DO 400 NS=1,3 ELSE IF (NS.EQ.3) THEN | ! !$omp parallel do | IF (NS == 1) THEN DO L=1,LM | ! DO J=JDIM1,JDIM2 | !$omp parallel do DO I=IDIM1,IDIM2 | ! S(I,J,L)=T(I,J,L) | DO K=1,LM ENDDO | DO J=JDIM1,JDIM2 ENDDO | DO I=IDIM1,IDIM2 ENDDO | S(I,J,K) = Q(I,J,K) ELSE | END DO WRITE(0,*)'ERROR in VTADV. Will stop now.' | END DO STOP | END DO ENDIF | ELSE IF (NS == 2) THEN C----------------------------------------------------------------------- | ! C | !$omp parallel do !$omp parallel do | ! DO 175 L=1,LM | DO K=1,LM DO 175 J=MYJS2,MYJE2 | DO J=JDIM1,JDIM2 DO 175 I=MYIS,MYIE | DO I=IDIM1,IDIM2 QBI(I,J,L)=S(I,J,L) | S(I,J,K) = CWM(I,J,K) SAM(I,J,L)=1. | END DO 175 CONTINUE | END DO IF(NOSLA) GO TO 290 | END DO C--------------THE SLOPE ADJUSTMENT CODE-------------------------------- | ELSE IF (NS == 3) THEN C NO SLOPE PERMITTED AT THE TOP AND AT THE BOTTOM LAYER | ! C----------------------------------------------------------------------- | !$omp parallel do !$omp parallel do | ! DO 190 J=MYJS2,MYJE2 | DO K=1,LM DO 190 I=MYIS,MYIE | DO J=JDIM1,JDIM2 SAM(I,J, 1)=0. | DO I=IDIM1,IDIM2 SAM(I,J,LM)=0. | S(I,J,K) = T(I,J,K) 190 CONTINUE | END DO C | END DO !$omp parallel do | END DO DO 200 L=1,LM1 | ELSE DO 200 J=MYJS2,MYJE2 | WRITE(0,*)'ERROR IN VTADV. WILL STOP NOW.' DO 200 I=MYIS,MYIE | STOP SAM(I,J,L)=SAM(I,J,L)*HTM(I,J,L+1) | END IF 200 CONTINUE | ! C----------------------------------------------------------------------- | !$omp parallel do C NOW, SEARCH FOR THE MAXIMA AND MINIMA OF Q (AT THE FIRST | ! C PASS) AND FOR LAYERS WHICH HAD OVERADJUSTED (AT SUBSEQUENT | DO 175 K=1,LM C PASSES) DUE TO ROUND-OFF ERRORS | DO 175 J=MYJS2,MYJE2 C----------------------------------------------------------------------- | DO 175 I=MYIS,MYIE !$omp parallel do private(dqbi,dqti,extrem) | QBI(I,J,K) = S(I,J,K) DO 220 L=2,LM1 | SAM(I,J,K) = 1. DO 220 J=MYJS2,MYJE2 | 175 END DO DO 220 I=MYIS,MYIE | ! DQTI(I,J)=S(I,J,L)-S(I,J,L-1) | IF (NOSLA) GOTO 290 DQBI(I,J)=S(I,J,L+1)-S(I,J,L) | !------------------------------------------------------ EXTREM=DQTI(I,J)*DQBI(I,J) | ! THE SLOPE ADJUSTMENT CODE IF(EXTREM.LE.0.)SAM(I,J,L)=0. | ! NO SLOPE PERMITTED AT THE TOP AND AT THE BOTTOM LAYER 220 CONTINUE | !------------------------------------------------------ C | ! !$omp parallel do | !$omp parallel do DO 230 L=2,LM1 | ! DO 230 J=MYJS2,MYJE2 | DO 190 J=MYJS2,MYJE2 DO 230 I=MYIS,MYIE | DO 190 I=MYIS,MYIE ARRAY1(I,J,L)=WFA(L-1)*(1.-SAM(I,J,L-1))+WFB(L-1) | SAM(I,J, 1) = 0. ARRAY2(I,J,L)=WFA(L)+WFB(L)*(1.-SAM(I,J,L+1)) | SAM(I,J,LM) = 0. 230 CONTINUE | 190 END DO DO 260 MSA=1,NMSAP | ! C----------------------------------------------------------------------- | !$omp parallel do C CALCULATE DQ AT INTERFACES AND ADJUST THE SLOPES WHERE | ! C AND TO THE EXTENT PERMITTED OBSERVING THE MONOTONICITY | DO 200 K=1,LM1 C CONDITION (E.G. VAN LEER, J. COMP. PHYS. 1977, 276-299) | DO 200 J=MYJS2,MYJE2 C----------------------------------------------------------------------- | DO 200 I=MYIS,MYIE !$omp parallel do | SAM(I,J,K) = SAM(I,J,K) * HTM(I,J,K+1) DO 240 J=MYJS2,MYJE2 | 200 END DO DO 240 I=MYIS,MYIE | !---------------------------------------------------------------------------------------- DQBI(I,J)=2.*S(I,J,2)-QBI(I,J,2) -QBI(I,J,1) | ! NOW, SEARCH FOR THE MAXIMA AND MINIMA OF Q (AT THE FIRST PASS) AND FOR LAYERS WHICH HAD 240 CONTINUE | ! OVERADJUSTED (AT SUBSEQUENT PASSES) DUE TO ROUND-OFF ERRORS C | !---------------------------------------------------------------------------------------- DO 250 L=2,LM1 | ! !$omp parallel do private(asbik,astik,dqtik) | !$omp parallel do private (DQBI, DQTI, EXTREM) DO 250 J=MYJS2,MYJE2 | ! DO 250 I=MYIS,MYIE | DO 220 K=2,LM1 DQTIK =DQBI(I,J) | DO 220 J=MYJS2,MYJE2 ASTIK =ARRAY1(I,J,L)*DQTIK | DO 220 I=MYIS,MYIE DQBI(I,J)=2.*S(I,J,L+1)-QBI(I,J,L+1)-QBI(I,J,L) | DQTI(I,J) = S(I,J,K ) - S(I,J,K-1) ASBIK =ARRAY2(I,J,L)*DQBI(I,J) | DQBI(I,J) = S(I,J,K+1) - S(I,J,K ) QBI(I,J,L)=QBI(I,J,L) | ! 1 +(ASTIK-SIGN(1.,ASTIK) | EXTREM = DQTI(I,J) * DQBI(I,J) 2 *DIM(ABS(ASTIK),ABS(ASBIK)))*SAM(I,J,L) | ! 250 CONTINUE | IF (EXTREM <= 0.) SAM(I,J,K) = 0. 260 CONTINUE | 220 END DO C----------------------------------------------------------------------- | ! C SLOPE ADJUSTMENT OF THE LAYERS ABOVE THAT NEXT TO THE SURFACE | !$omp parallel do C IS DONE; NOW ADJUST THE LOWERMOST LAYER | ! C----------------------------------------------------------------------- | DO 230 K=2,LM1 DO 270 L=9,LM1 | DO 230 J=MYJS2,MYJE2 !$omp parallel do | DO 230 I=MYIS,MYIE DO 270 J=MYJS2,MYJE2 | ARRAY1(I,J,K) = WFA(K-1) * (1.-SAM(I,J,K-1)) + WFB(K-1) DO 270 I=MYIS,MYIE | ARRAY2(I,J,K) = WFA(K ) + WFB(K) * (1.-SAM(I,J,K+1)) IF(HTM(I,J,L+1).EQ.0.)QBI(I,J,L)=2.*S(I,J,L)-QBI(I,J,L-1) | 230 END DO 270 CONTINUE | ! C | DO 260 MSA=1,NMSAP !$omp parallel do | !----------------------------------------------------------------------------------------------- DO 280 J=MYJS2,MYJE2 | ! CALCULATE DQ AT INTERFACES AND ADJUST THE SLOPES WHERE AND TO THE EXTENT PERMITTED OBSERVING T DO 280 I=MYIS,MYIE | ! MONOTONICITY CONDITION (E.G. VAN LEER, J. COMP. PHYS. 1977, 276-299) QBI(I,J,LM)=2.*S(I,J,LM)-QBI(I,J,LM1) | !----------------------------------------------------------------------------------------------- 280 CONTINUE | ! C----------------------------------------------------------------------- | !$omp parallel do C--------------END OF THE SLOPE ADJUSTMENT CODE------------------------- | ! C----------------------------------------------------------------------- | DO 240 J=MYJS2,MYJE2 290 CONTINUE | DO 240 I=MYIS,MYIE !$omp parallel do | DQBI(I,J) = 2. * S(I,J,2) - QBI(I,J,2) - QBI(I,J,1) DO 300 J=MYJS2,MYJE2 | 240 END DO DO 300 I=MYIS,MYIE | ! QDEDB(I,J)=0. | DO 250 K=2,LM1 QDEUB(I,J)=0. | ! DQDEB(I,J)=2.*(QBI(I,J,1)-S(I,J,1))*RDETA(1) | !$omp parallel do private (ASBIK, ASTIK, DQTIK) EDBD (I,J)=0. | ! 300 CONTINUE | DO 250 J=MYJS2,MYJE2 C | DO 250 I=MYIS,MYIE DO 320 L=1,LM1 | DQTIK = DQBI(I,J) !$omp parallel do private(dqdek,edbfk,edtdk,qdedtk,qdeutk,sedbk) | ASTIK = ARRAY1(I,J,K) * DQTIK DO 320 J=MYJS2,MYJE2 | DQBI(I,J) = 2. * S(I,J,K+1) - QBI(I,J,K+1) - QBI(I,J,K) DO 320 I=MYIS,MYIE | ASBIK = ARRAY2(I,J,K) * DQBI(I,J) QDEDTK =QDEDB(I,J) | QBI(I,J,K) = QBI(I,J,K) QDEUTK =QDEUB(I,J) | & + (ASTIK-SIGN(1.,ASTIK) * DIM(ABS(ASTIK), ABS(ASBIK))) SEDBK =SIGN(1.,ETADT(I,J,L)) | & * SAM(I,J,K) DQDEK =DQDEB(I,J) | 250 END DO DQDEB(I,J)=2.*(QBI(I,J,L+1)-S(I,J,L+1))*RDETA(L+1) | ! EDBFK =ETADT(I,J,L)*F4D | 260 END DO QDEDB(I,J)=(1.+SEDBK)*(QBI(I,J,L)+DQDEK*EDBFK)*(-EDBFK) | !----------------------------------------------------------------------------------------------- QDEUB(I,J)=(1.-SEDBK)*(2.*S(I,J,L+1)-QBI(I,J,L+1) | ! SLOPE ADJUSTMENT OF THE LAYERS ABOVE THAT NEXT TO THE SURFACE IS DONE; NOW ADJUST THE LOWERMOS 1 +DQDEB(I,J)*EDBFK)*EDBFK | ! LAYER EDTDK =EDBD(I,J) | !----------------------------------------------------------------------------------------------- EDBD (I,J)=ETADT(I,J,L)*(-F4Q) | DO 270 K=9,LM1 S(I,J,L)=S(I,J,L)+(QDEDTK-QDEUTK-QDEDB(I,J)+QDEUB(I,J) | ! 1 +S(I,J,L)*(EDBD(I,J)-EDTDK))*RDETA(L) | !$omp parallel do 320 CONTINUE | ! C | DO 270 J=MYJS2,MYJE2 !$omp parallel do | DO 270 I=MYIS,MYIE DO 330 J=MYJS2,MYJE2 | IF (HTM(I,J,K+1) == 0.) QBI(I,J,K) = 2. * S(I,J,K) - QBI(I,J,K-1) DO 330 I=MYIS,MYIE | 270 END DO S(I,J,LM)=S(I,J,LM)+(QDEDB(I,J)-QDEUB(I,J) | ! 1 +S(I,J,LM)*(-EDBD(I,J)))*RDETA(LM) | !$omp parallel do 330 CONTINUE | ! C-------NEGATIVE MOISTURE MAY OCCUR DUE TO VIOLATION OF THE CFL--------- | DO 280 J=MYJS2,MYJE2 DO 350 L=1,LM1 | DO 280 I=MYIS,MYIE !$omp parallel do | QBI(I,J,LM) = 2. * S(I,J,LM) - QBI(I,J,LM1) DO 350 J=MYJS2,MYJE2 | 280 END DO DO 350 I=MYIS,MYIE | !--------------------------------- IF(S(I,J,L).LT.EPSQ)THEN | ! END OF THE SLOPE ADJUSTMENT CODE DQBI(I,J)=S(I,J,L) | !--------------------------------- S(I,J,L)=EPSQ | 290 CONTINUE S(I,J,L+1)=S(I,J,L+1)+DETA(L)*RDETA(L+1)*DQBI(I,J) | ! ENDIF | !$omp parallel do 350 CONTINUE | ! C | DO 300 J=MYJS2,MYJE2 !$omp parallel do | DO 300 I=MYIS,MYIE DO 360 J=MYJS2,MYJE2 | QDEDB(I,J) = 0. DO 360 I=MYIS,MYIE | QDEUB(I,J) = 0. IF(S(I,J,LM).LT.EPSQ)S(I,J,LM)=EPSQ | DQDEB(I,J) = 2. * (QBI(I,J,1) - S(I,J,1)) * RDETA(1) 360 CONTINUE | EDBD (I,J) = 0. C----------------------------------------------------------------------- | 300 END DO IF(NS.EQ.1)THEN | ! !$omp parallel do | DO 320 K=1,LM1 DO L=1,LM | ! DO J=JDIM1,JDIM2 | !$omp parallel do private (DQDEK, EDBFK, EDTDK, QDEDTK, QDEUTK, SEDBK) DO I=IDIM1,IDIM2 | ! Q(I,J,L)=S(I,J,L) | DO 320 J=MYJS2,MYJE2 ENDDO | DO 320 I=MYIS,MYIE ENDDO | QDEDTK = QDEDB(I,J) ENDDO | QDEUTK = QDEUB(I,J) ELSE IF (NS.EQ.2) THEN | SEDBK = SIGN(1.,ETADT(I,J,K)) !$omp parallel do | DQDEK = DQDEB(I,J) DO L=1,LM | DQDEB(I,J) = 2. * (QBI(I,J,K+1) - S(I,J,K+1)) * RDETA(K+1) DO J=JDIM1,JDIM2 | EDBFK = ETADT(I,J,K) * F4D DO I=IDIM1,IDIM2 | QDEDB(I,J) = (1.+SEDBK) * (QBI(I,J,K) + DQDEK * EDBFK) * (-EDBFK) CWM(I,J,L)=S(I,J,L) | QDEUB(I,J) = (1.-SEDBK) * (2.*S(I,J,K+1) - QBI(I,J,K+1) + DQDEB(I,J)*EDBFK) ENDDO | & * EDBFK ENDDO | ! ENDDO | EDTDK = EDBD(I,J) ELSE IF (NS.EQ.3) THEN | EDBD (I,J) = ETADT(I,J,K) * (-F4Q) !$omp parallel do | S(I,J,K) = S(I,J,K) + (QDEDTK - QDEUTK - QDEDB(I,J) + QDEUB(I,J) DO L=1,LM | & + S(I,J,K) * (EDBD(I,J)-EDTDK)) * RDETA(K) DO J=JDIM1,JDIM2 | 320 END DO DO I=IDIM1,IDIM2 | ! T(I,J,L)=S(I,J,L) | !$omp parallel do ENDDO | ! ENDDO | DO 330 J=MYJS2,MYJE2 ENDDO | DO 330 I=MYIS,MYIE ELSE | S(I,J,LM) = S(I,J,LM) + (QDEDB(I,J) - QDEUB(I,J) WRITE(0,*)'ERROR in VTADV. Will stop now.' | & + S(I,J,LM) * (-EDBD(I,J))) * RDETA(LM) STOP | 330 END DO ENDIF | !-------------------------------------------------------- C----------------------------------------------------------------------- | ! NEGATIVE MOISTURE MAY OCCUR DUE TO VIOLATION OF THE CFL 400 CONTINUE | !-------------------------------------------------------- C | DO 350 K=1,LM1 DEALLOCATE(S,STAT=IER) | ! C----------------------------------------------------------------------- | !$omp parallel do C--------------VERTICAL (MATSUNO) ADVECTION OF Q2----------------------- | ! C----------------------------------------------------------------------- | DO 350 J=MYJS2,MYJE2 !$omp parallel do | DO 350 I=MYIS,MYIE DO 420 J=MYJS2,MYJE2 | IF (S(I,J,K) < EPSQ) THEN DO 420 I=MYIS,MYIE | DQBI(I,J) = S(I,J,K ) TQ2B(I,J)=Q2(I,J,1)*ETADT(I,J,1)*F4Q2(1) | S(I,J,K ) = EPSQ 420 CONTINUE | S(I,J,K+1) = S(I,J,K+1) + DETA(K) * RDETA(K+1) * DQBI(I,J) C | END IF DO 425 L=1,LM2 | 350 END DO !$omp parallel do private(tq2ak) | ! DO 425 J=MYJS2,MYJE2 | !$omp parallel do DO 425 I=MYIS,MYIE | ! TQ2AK=(Q2(I,J,L+1)-Q2(I,J,L))*(ETADT(I,J,L)+ETADT(I,J,L+1)) | DO 360 J=MYJS2,MYJE2 1 *F4Q2(L+1) | DO 360 I=MYIS,MYIE Q2ST(I,J,L)=TQ2AK+TQ2B(I,J)+Q2(I,J,L) | IF (S(I,J,LM) < EPSQ) S(I,J,LM) = EPSQ TQ2B(I,J)=TQ2AK | 360 END DO 425 CONTINUE | ! C | IF (NS == 1) THEN !$omp parallel do private(tq2ak) | ! DO 440 J=MYJS2,MYJE2 | !$omp parallel do DO 440 I=MYIS,MYIE | ! TQ2AK=(Q2(I,J,LM)-Q2(I,J,LM1))*ETADT(I,J,LM1)*F4Q2(LM) | DO K=1,LM Q2ST(I,J,LM1)=TQ2AK+TQ2B(I,J)+Q2(I,J,LM1) | DO J=JDIM1,JDIM2 Q2ST(I,J,LM )=Q2(I,J,LM) | DO I=IDIM1,IDIM2 440 CONTINUE | Q(I,J,K) = S(I,J,K) C----------------------------------------------------------------------- | END DO C--------------SECOND (BACKWARD) MATSUNO STEP--------------------------- | END DO C----------------------------------------------------------------------- | END DO !$omp parallel do | ELSE IF (NS == 2) THEN DO 450 J=MYJS2,MYJE2 | ! DO 450 I=MYIS,MYIE | !$omp parallel do TQ2B(I,J)=Q2ST(I,J,1)*ETADT(I,J,1)*F4Q2(1) | ! 450 CONTINUE | DO K=1,LM C | DO J=JDIM1,JDIM2 DO L=1,LM2 | DO I=IDIM1,IDIM2 !$omp parallel do private(tq2ak) | CWM(I,J,K) = S(I,J,K) DO J=MYJS2,MYJE2 | END DO DO I=MYIS,MYIE | END DO TQ2AK =(Q2ST(I,J,L+1)-Q2ST(I,J,L)) | END DO 1 *(ETADT(I,J,L)+ETADT(I,J,L+1))*F4Q2(L+1) | ELSE IF (NS == 3) THEN VAD_TEND1(I,J,L)=TQ2AK+TQ2B(I,J) | ! TQ2B(I,J)=TQ2AK | !$omp parallel do ENDDO | ! ENDDO | DO K=1,LM ENDDO | DO J=JDIM1,JDIM2 ! | DO I=IDIM1,IDIM2 DO J=MYJS2,MYJE2 | T(I,J,K) = S(I,J,K) DO I=MYIS,MYIE | END DO TQ2AK =(Q2ST(I,J,LM)-Q2ST(I,J,LM1))*ETADT(I,J,LM1)*F4Q2(LM) | END DO VAD_TEND1(I,J,LM1)=TQ2AK+TQ2B(I,J) | END DO ENDDO | ELSE ENDDO | WRITE(0,*)'ERROR IN VTADV. WILL STOP NOW.' !----------------------------------------------------------------------- | STOP ! | END IF !*** IF THE CFL CRITERION IS VIOLATED THEN VERTICALLY SMOOTH | ! !*** THE TENDENCY | 400 END DO ! | ! !----------------------------------------------------------------------- | DEALLOCATE(S,STAT=IER) ! | !----------------------------------- !$omp parallel do | ! VERTICAL (MATSUNO) ADVECTION OF Q2 !$omp& private(cfl,lbot_cfl,lstart,lstop,ltop_cfl,vad_tend1,vad_tndx1) | !----------------------------------- DO J=MYJS2,MYJE2 | ! DO I=MYIS,MYIE | !$omp parallel do ! | ! IF(LTOP_CFL_T(I,J).GT.0)THEN | DO 420 J=MYJS2,MYJE2 LSTART=LTOP_CFL_T(I,J) | DO 420 I=MYIS,MYIE LSTOP =MIN(LBOT_CFL_T(I,J),LM-2) | TQ2B(I,J) = Q2(I,J,1) * ETADT(I,J,1) * F4Q2(1) ! | 420 END DO DO L=LSTART,LSTOP | ! VAD_TNDX1(L)=(VAD_TEND1(I,J,L-1)+VAD_TEND1(I,J,L+1) | DO 425 K=1,LM2 1 +2.*VAD_TEND1(I,J,L))*0.25 | ! ENDDO | !$omp parallel do private (TQ2AK) DO L=LSTART,LSTOP | ! VAD_TEND1(I,J,L)=VAD_TNDX1(L) | DO 425 J=MYJS2,MYJE2 ENDDO | DO 425 I=MYIS,MYIE ENDIF | TQ2AK = (Q2(I,J,K+1) - Q2(I,J,K)) * (ETADT(I,J,K) + ETADT(I,J,K+1)) * F4Q2(K+1) ! | Q2ST(I,J,K) = TQ2AK + TQ2B(I,J) + Q2(I,J,K) ENDDO | TQ2B(I,J) = TQ2AK ENDDO | 425 END DO C | ! DO 470 L=1,LM2 | !$omp parallel do private (TQ2AK) !$omp parallel do | ! DO 470 J=MYJS2,MYJE2 | DO 440 J=MYJS2,MYJE2 DO 470 I=MYIS,MYIE | DO 440 I=MYIS,MYIE Q2(I,J,L)=VAD_TEND1(I,J,L)+Q2(I,J,L) | TQ2AK = (Q2(I,J,LM) - Q2(I,J,LM1)) * ETADT(I,J,LM1) * F4Q2(LM) Q2(I,J,L)=AMAX1(Q2(I,J,L),EPSQ2) | Q2ST(I,J,LM1) = TQ2AK + TQ2B(I,J) + Q2(I,J,LM1) 470 CONTINUE | Q2ST(I,J,LM ) = Q2(I,J,LM) C | 440 END DO !$omp parallel do | !------------------------------- DO 480 J=MYJS2,MYJE2 | ! SECOND (BACKWARD) MATSUNO STEP DO 480 I=MYIS,MYIE | !------------------------------- Q2(I,J,LM1)=VAD_TEND1(I,J,LM1)+Q2(I,J,LM1) | ! Q2(I,J,LM1)=AMAX1(Q2(I,J,LM1),EPSQ2) | !$omp parallel do 480 CONTINUE | ! C----------------------------------------------------------------------- | DO 450 J=MYJS2,MYJE2 C--------------DEFINITION OF VARIABLES NEEDED AT V POINTS--------------- | DO 450 I=MYIS,MYIE C----------------------------------------------------------------------- | TQ2B(I,J) = Q2ST(I,J,1) * ETADT(I,J,1) * F4Q2(1) !$omp parallel do | 450 END DO DO 500 L=1,LM1 | ! DO 500 J=MYJS_P1,MYJE_P1 | DO K=1,LM2 DO 500 I=MYIS_P1,MYIE_P1 | ! ETADT(I,J,L)=ETADT(I,J,L)*PDSL(I,J)*HBM2(I,J) | !$omp parallel do private (TQ2AK) 500 CONTINUE | ! C | DO J=MYJS2,MYJE2 !$omp parallel do | DO I=MYIS,MYIE DO 510 J=MYJS2,MYJE2 | TQ2AK = (Q2ST(I,J,K+1) - Q2ST(I,J,K)) * (ETADT(I,J,K) + ETADT(I,J,K+1)) * F4Q2(K DO 510 I=MYIS,MYIE | VAD_TEND1(I,J,K) = TQ2AK + TQ2B(I,J) RPDX(I,J)=1./(PDSL(I+IVW(J),J)+PDSL(I+IVE(J),J)) | TQ2B(I,J) = TQ2AK RPDY(I,J)=1./(PDSL(I,J-1)+PDSL(I,J+1)) | END DO 510 CONTINUE | END DO | ! C---------- PIECEWISE LINEAR UPSTREAM VERTICAL ADVECTION OF U & V ------ | END DO C INTIALIZE U & V AT THE BOTTOM INTERFACE AND THE SLOPE ADJUSTMENT | ! C MASK (SAMU=1 AND SAMV=1 FOR SA PERMITTED, 0 FOR NOT PERMITTED) | DO J=MYJS2,MYJE2 C----------------------------------------------------------------------- | DO I=MYIS,MYIE !$omp parallel do | TQ2AK = (Q2ST(I,J,LM) - Q2ST(I,J,LM1)) * ETADT(I,J,LM1) * F4Q2(LM) DO 1175 L=1,LM | VAD_TEND1(I,J,LM1) = TQ2AK + TQ2B(I,J) DO 1175 J=MYJS2,MYJE2 | END DO DO 1175 I=MYIS,MYIE | END DO UBI(I,J,L)=U(I,J,L) | !--------------------------------------------------------------------- VBI(I,J,L)=V(I,J,L) | ! IF THE CFL CRITERION IS VIOLATED THEN VERTICALLY SMOOTH THE TENDENCY SAMU(I,J,L)=1. | !--------------------------------------------------------------------- SAMV(I,J,L)=1. | ! 1175 CONTINUE | !$omp parallel do private (CFL, LBOT_CFL, LSTART, LSTOP, LTOP_CFL, VAD_TEND1, VAD_TNDX1) C----------------------------------------------------------------------- | ! IF(NOSLAW) GO TO 1290 | DO J=MYJS2,MYJE2 C--------------THE SLOPE ADJUSTMENT CODE-------------------------------- | DO I=MYIS,MYIE C NO SLOPE PERMITTED AT THE TOP AND AT THE BOTTOM LAYER | ! C----------------------------------------------------------------------- | IF (LTOP_CFL_T(I,J) > 0) THEN !$omp parallel do | LSTART = LTOP_CFL_T(I,J) DO 1190 J=MYJS2,MYJE2 | LSTOP = MIN(LBOT_CFL_T(I,J),LM-2) DO 1190 I=MYIS,MYIE | ! SAMU(I,J, 1)=0. | DO K=LSTART,LSTOP SAMU(I,J,LM)=0. | VAD_TNDX1(K) = (VAD_TEND1(I,J,K-1) + VAD_TEND1(I,J,K+1) + 2. SAMV(I,J, 1)=0. | & * VAD_TEND1(I,J,K )) * 0.25 SAMV(I,J,LM)=0. | END DO 1190 CONTINUE | DO K=LSTART,LSTOP C | VAD_TEND1(I,J,K) = VAD_TNDX1(K) !$omp parallel do | END DO DO 1200 L=1,LM1 | END IF DO 1200 J=MYJS2,MYJE2 | ! DO 1200 I=MYIS,MYIE | END DO SAMU(I,J,L)=SAMU(I,J,L)*VTM(I,J,L+1) | END DO SAMV(I,J,L)=SAMV(I,J,L)*VTM(I,J,L+1) | ! 1200 CONTINUE | DO 470 K=1,LM2 C----------------------------------------------------------------------- | ! C NOW, SEARCH FOR THE MAXIMA AND MINIMA OF U & V (AT THE FIRST | !$omp parallel do C PASS) AND FOR LAYERS WHICH HAD OVERADJUSTED (AT SUBSEQUENT | ! C PASSES) DUE TO ROUND-OFF ERRORS | DO 470 J=MYJS2,MYJE2 C----------------------------------------------------------------------- | DO 470 I=MYIS,MYIE !$omp parallel do private(dubi, dvbi, duti, dvti, extremu, extremv) | Q2(I,J,K) = VAD_TEND1(I,J,K) + Q2(I,J,K) DO 1220 L=2,LM1 | Q2(I,J,K) = AMAX1(Q2(I,J,K), EPSQ2) DO 1220 J=MYJS2,MYJE2 | 470 END DO DO 1220 I=MYIS,MYIE | ! DUTI(I,J)=U(I,J,L)-U(I,J,L-1) | !$omp parallel do DVTI(I,J)=V(I,J,L)-V(I,J,L-1) | ! DUBI(I,J)=U(I,J,L+1)-U(I,J,L) | DO 480 J=MYJS2,MYJE2 DVBI(I,J)=V(I,J,L+1)-V(I,J,L) | DO 480 I=MYIS,MYIE EXTREMU=DUTI(I,J)*DUBI(I,J) | Q2(I,J,LM1) = VAD_TEND1(I,J,LM1) + Q2(I,J,LM1) EXTREMV=DVTI(I,J)*DVBI(I,J) | Q2(I,J,LM1) = AMAX1(Q2(I,J,LM1), EPSQ2) IF(EXTREMU.LT.0.) SAMU(I,J,L)=0. | 480 END DO IF(EXTREMV.LT.0.) SAMV(I,J,L)=0. | !------------------------------------------- 1220 CONTINUE | ! DEFINITION OF VARIABLES NEEDED AT V POINTS C | !------------------------------------------- !$omp parallel do | ! DO 1230 L=2,LM1 | !$omp parallel do DO 1230 J=MYJS2,MYJE2 | ! DO 1230 I=MYIS,MYIE | DO 500 K=1,LM1 ARRAYU1(I,J,L)=WFA(L-1)*(1.-SAMU(I,J,L-1))+WFB(L-1) | DO 500 J=MYJS_P1,MYJE_P1 ARRAYV1(I,J,L)=WFA(L-1)*(1.-SAMV(I,J,L-1))+WFB(L-1) | DO 500 I=MYIS_P1,MYIE_P1 ARRAYU2(I,J,L)=WFA(L)+WFB(L)*(1.-SAMU(I,J,L+1)) | ETADT(I,J,K) = ETADT(I,J,K) * PDSL(I,J) * HBM2(I,J) ARRAYV2(I,J,L)=WFA(L)+WFB(L)*(1.-SAMV(I,J,L+1)) | 500 END DO 1230 CONTINUE | ! C----------------------------------------------------------------------- | !$omp parallel do DO 1260 MSA=1,NMSAPW | ! C----------------------------------------------------------------------- | DO 510 J=MYJS2,MYJE2 C CALCULATE DU & DV AT INTERFACES AND ADJUST THE SLOPES WHERE | DO 510 I=MYIS,MYIE C AND TO THE EXTENT PERMITTED OBSERVING THE MONOTONICITY | RPDX(I,J) = 1. / (PDSL(I+IVW(J),J ) + PDSL(I+IVE(J),J )) C CONDITION (E.G. VAN LEER, J. COMP. PHYS. 1977, 276-299, | RPDY(I,J) = 1. / (PDSL(I ,J-1) + PDSL(I ,J+1)) C scheme used here of MESINGER AND JOVIC, NCEP OFFICE NOTE #439) | 510 END DO C----------------------------------------------------------------------- | !----------------------------------------------------------------------------------------------- !$omp parallel do | ! PIECEWISE LINEAR UPSTREAM VERTICAL ADVECTION OF U AND V DO 1240 J=MYJS2,MYJE2 | ! INTIALIZE U AND V AT THE BOTTOM INTERFACE AND THE SLOPE ADJUSTMENT MASK (SAMU=1 AND SAMV=1 FOR DO 1240 I=MYIS,MYIE | ! PERMITTED, 0 FOR NOT PERMITTED) DUBI(I,J)=2.*U(I,J,2)-UBI(I,J,2) -UBI(I,J,1) | !----------------------------------------------------------------------------------------------- DVBI(I,J)=2.*V(I,J,2)-VBI(I,J,2) -VBI(I,J,1) | ! 1240 CONTINUE | !$omp parallel do C----------------------------------------------------------------------- | ! !$omp parallel do private(asbiku, asbikv, astiku, astikv, dutik, dvtik) | DO 999 K=1,LM DO 1250 L=2,LM1 | DO 999 J=MYJS2,MYJE2 DO 1250 J=MYJS2,MYJE2 | DO 999 I=MYIS,MYIE DO 1250 I=MYIS,MYIE | UBI(I,J,K) = U(I,J,K) DUTIK =DUBI(I,J) | VBI(I,J,K) = V(I,J,K) DVTIK =DVBI(I,J) | SAMU(I,J,K) = 1. ASTIKU =ARRAYU1(I,J,L)*DUTIK | SAMV(I,J,K) = 1. ASTIKV =ARRAYV1(I,J,L)*DVTIK | 999 END DO DUBI(I,J)=2.0*U(I,J,L+1)-UBI(I,J,L+1)-UBI(I,J,L) | ! DVBI(I,J)=2.0*V(I,J,L+1)-VBI(I,J,L+1)-VBI(I,J,L) | IF (NOSLAW) GOTO 998 ASBIKU =ARRAYU2(I,J,L)*DUBI(I,J) | !------------------------------------------------------ ASBIKV =ARRAYV2(I,J,L)*DVBI(I,J) | ! THE SLOPE ADJUSTMENT CODE UBI(I,J,L)=UBI(I,J,L) | ! NO SLOPE PERMITTED AT THE TOP AND AT THE BOTTOM LAYER 1 +(ASTIKU-SIGN(1.,ASTIKU) | !------------------------------------------------------ 2 *DIM(ABS(ASTIKU),ABS(ASBIKU)))*SAMU(I,J,L) | ! VBI(I,J,L)=VBI(I,J,L) | !$omp parallel do 1 +(ASTIKV-SIGN(1.,ASTIKV) | ! 2 *DIM(ABS(ASTIKV),ABS(ASBIKV)))*SAMV(I,J,L) | DO 997 J=MYJS2,MYJE2 1250 CONTINUE | DO 997 I=MYIS,MYIE 1260 CONTINUE | SAMU(I,J, 1) = 0. C----------------------------------------------------------------------- | SAMU(I,J,LM) = 0. C SLOPE ADJUSTMENT OF THE LAYERS ABOVE THAT NEXT TO THE SURFACE | SAMV(I,J, 1) = 0. C IS DONE; NOW ADJUST THE LOWERMOST LAYER | SAMV(I,J,LM) = 0. C----------------------------------------------------------------------- | 997 END DO DO 1270 L=9,LM1 | ! !$omp parallel do | !$omp parallel do DO 1270 J=MYJS2,MYJE2 | ! DO 1270 I=MYIS,MYIE | DO 996 K=1,LM1 IF(VTM(I,J,L+1).EQ.0.) UBI(I,J,L)=2.*U(I,J,L)-UBI(I,J,L-1) | DO 996 J=MYJS2,MYJE2 IF(VTM(I,J,L+1).EQ.0.) VBI(I,J,L)=2.*V(I,J,L)-VBI(I,J,L-1) | DO 996 I=MYIS,MYIE 1270 CONTINUE | SAMU(I,J,K) = SAMU(I,J,K) * VTM(I,J,K+1) C | SAMV(I,J,K) = SAMV(I,J,K) * VTM(I,J,K+1) !$omp parallel do | 996 END DO DO 1280 J=MYJS2,MYJE2 | !-------------------------------------------------------------------------------------------- DO 1280 I=MYIS,MYIE | ! NOW, SEARCH FOR THE MAXIMA AND MINIMA OF U & V (AT THE FIRST PASS) AND FOR LAYERS WHICH HAD UBI(I,J,LM)=2.*U(I,J,LM)-UBI(I,J,LM1) | ! OVERADJUSTED (AT SUBSEQUENT PASSES) DUE TO ROUND-OFF ERRORS VBI(I,J,LM)=2.*V(I,J,LM)-VBI(I,J,LM1) | !-------------------------------------------------------------------------------------------- 1280 CONTINUE | ! C----------------------------------------------------------------------- | !$omp parallel do private (DUBI, DVBI, DUTI, DVTI, EXTREMU, EXTREMV) C--------------END OF THE SLOPE ADJUSTMENT CODE------------------------- | ! C----------------------------------------------------------------------- | DO 995 K=2,LM1 1290 CONTINUE | DO 995 J=MYJS2,MYJE2 C----------------------------------------------------------------------- | DO 995 I=MYIS,MYIE !$omp parallel do | DUTI(I,J) = U(I,J,K ) - U(I,J,K-1) DO 1300 J=MYJS2,MYJE2 | DVTI(I,J) = V(I,J,K ) - V(I,J,K-1) DO 1300 I=MYIS,MYIE | DUBI(I,J) = U(I,J,K+1) - U(I,J,K ) UDEDB(I,J)=0. | DVBI(I,J) = V(I,J,K+1) - V(I,J,K ) VDEDB(I,J)=0. | ! UDEUB(I,J)=0. | EXTREMU = DUTI(I,J) * DUBI(I,J) VDEUB(I,J)=0. | EXTREMV = DVTI(I,J) * DVBI(I,J) DUDEB(I,J)=2.*(UBI(I,J,1)-U(I,J,1))*RDETA(1) | ! DVDEB(I,J)=2.*(VBI(I,J,1)-V(I,J,1))*RDETA(1) | IF (EXTREMU < 0.) SAMU(I,J,K) = 0. EDBDU (I,J)=0. | IF (EXTREMV < 0.) SAMV(I,J,K) = 0. EDBDV(I,J)=0. | 995 END DO 1300 CONTINUE | ! DO 1320 L=1,LM1 | !$omp parallel do !$omp parallel do private(dqdek,edbfk,edtdk,qdedtk,qdeutk,sedbk) | ! DO 1320 J=MYJS2,MYJE2 | DO 994 K=2,LM1 DO 1320 I=MYIS,MYIE | DO 994 J=MYJS2,MYJE2 VMIJ=VTM(I,J,L)*VBM2(I,J) | DO 994 I=MYIS,MYIE UDEDTK =UDEDB(I,J) | ARRAYU1(I,J,K) = WFA(K-1) * (1.-SAMU(I,J,K-1)) + WFB(K-1) VDEDTK =VDEDB(I,J) | ARRAYV1(I,J,K) = WFA(K-1) * (1.-SAMV(I,J,K-1)) + WFB(K-1) UDEUTK =UDEUB(I,J) | ARRAYU2(I,J,K) = WFA(K ) + WFB(K) * (1.-SAMU(I,J,K+1)) VDEUTK =VDEUB(I,J) | ARRAYV2(I,J,K) = WFA(K ) + WFB(K) * (1.-SAMV(I,J,K+1)) SEDBKU =SIGN(1.,(ETADT(I+IVW(J),J,L)+ETADT(I+IVE(J),J,L))) | 994 END DO SEDBKV =SIGN(1.,(ETADT(I,J-1,L)+ETADT(I,J+1,L))) | ! DUDEK =DUDEB(I,J) | DO 993 MSA=1,NMSAPW DVDEK =DVDEB(I,J) | !----------------------------------------------------------------------------------------------- DUDEB(I,J)=2.*(UBI(I,J,L+1)-U(I,J,L+1))*RDETA(L+1) | ! CALCULATE DU & DV AT INTERFACES AND ADJUST THE SLOPES WHERE AND TO THE EXTENT PERMITTED OBSERV DVDEB(I,J)=2.*(VBI(I,J,L+1)-V(I,J,L+1))*RDETA(L+1) | ! THE MONOTONICITY CONDITION (E.G. VAN LEER, J. COMP. PHYS. 1977, 276-299, SCHEME USED HERE OF C | ! MESINGER AND JOVIC, NCEP OFFICE NOTE #439) EDBFKU =(ETADT(I+IVW(J),J,L)+ETADT(I+IVE(J),J,L)) | !----------------------------------------------------------------------------------------------- 1 *RPDX(I,J)*F4D | ! EDBFKV =(ETADT(I,J-1,L)+ETADT(I,J+1,L))*RPDY(I,J)*F4D | !$omp parallel do C | ! UDEDB(I,J)=(1.+SEDBKU)*(UBI(I,J,L)+DUDEK*EDBFKU)*(-EDBFKU) | DO 992 J=MYJS2,MYJE2 VDEDB(I,J)=(1.+SEDBKV)*(VBI(I,J,L)+DVDEK*EDBFKV)*(-EDBFKV) | DO 992 I=MYIS,MYIE UDEUB(I,J)=(1.-SEDBKU)*(U(I,J,L+1)+U(I,J,L+1)-UBI(I,J,L+1) | DUBI(I,J) = 2. * U(I,J,2) - UBI(I,J,2) - UBI(I,J,1) 1 +DUDEB(I,J)*EDBFKU)*EDBFKU | DVBI(I,J) = 2. * V(I,J,2) - VBI(I,J,2) - VBI(I,J,1) VDEUB(I,J)=(1.-SEDBKV)*(V(I,J,L+1)+V(I,J,L+1)-VBI(I,J,L+1) | 992 END DO 1 +DVDEB(I,J)*EDBFKV)*EDBFKV | ! EDTDKU =EDBDU(I,J) | !$omp parallel do private (ASBIKU, ASBIKV, ASTIKU, ASTIKV, DUTIK, DVTIK) EDTDKV =EDBDV(I,J) | ! C | DO 991 K=2,LM1 EDBDU(I,J)=(ETADT(I+IVW(J),J,L)+ETADT(I+IVE(J),J,L)) | DO 991 J=MYJS2,MYJE2 1 *RPDX(I,J)*(-F4Q) | DO 991 I=MYIS,MYIE EDBDV(I,J)=(ETADT(I,J-1,L)+ETADT(I,J+1,L))*RPDY(I,J)*(-F4Q) | DUTIK = DUBI(I,J) C | DVTIK = DVBI(I,J) VAD_TEND1(I,J,L)=(UDEDTK-UDEUTK-UDEDB(I,J)+UDEUB(I,J) | ASTIKU = ARRAYU1(I,J,K) * DUTIK 1 +U(I,J,L)*(EDBDU(I,J)-EDTDKU))*RDETA(L)*VMIJ | ASTIKV = ARRAYV1(I,J,K) * DVTIK VAD_TEND2(I,J,L)=(VDEDTK-VDEUTK-VDEDB(I,J)+VDEUB(I,J) | ! 1 +V(I,J,L)*(EDBDV(I,J)-EDTDKV))*RDETA(L)*VMIJ | DUBI(I,J) = 2.0 * U(I,J,K+1) - UBI(I,J,K+1) - UBI(I,J,K) 1320 CONTINUE | DVBI(I,J) = 2.0 * V(I,J,K+1) - VBI(I,J,K+1) - VBI(I,J,K) C----------------------------------------------------------------------- | ! !$omp parallel do | ASBIKU = ARRAYU2(I,J,K) * DUBI(I,J) DO 1330 J=MYJS2,MYJE2 | ASBIKV = ARRAYV2(I,J,K) * DVBI(I,J) DO 1330 I=MYIS,MYIE | ! VMIJ=VTM(I,J,LM)*VBM2(I,J) | UBI(I,J,K) = UBI(I,J,K) + (ASTIKU-SIGN(1.,ASTIKU) VAD_TEND1(I,J,LM)=(UDEDB(I,J)-UDEUB(I,J) | & * DIM(ABS(ASTIKU),ABS(ASBIKU))) * SAMU(I,J,K) 1 +U(I,J,LM)*(-EDBDU(I,J)))*RDETA(LM)*VMIJ | ! VAD_TEND2(I,J,LM)=(VDEDB(I,J)-VDEUB(I,J) | VBI(I,J,K) = VBI(I,J,K) + (ASTIKV-SIGN(1.,ASTIKV) 1 +V(I,J,LM)*(-EDBDV(I,J)))*RDETA(LM)*VMIJ | & * DIM(ABS(ASTIKV),ABS(ASBIKV))) * SAMV(I,J,K) 1330 CONTINUE | 991 END DO ! | 993 END DO !----------------------------------------------------------------------- | !----------------------------------------------------------------------------------------------- ! | ! SLOPE ADJUSTMENT OF THE LAYERS ABOVE THAT NEXT TO THE SURFACE IS DONE; NOW ADJUST THE LOWERMOS !*** IF THE CFL CRITERION IS VIOLATED THEN VERTICALLY SMOOTH | ! LAYER !*** THE TENDENCIES | !----------------------------------------------------------------------------------------------- ! | DO 990 K=9,LM1 !----------------------------------------------------------------------- | ! ! | !$omp parallel do !$omp parallel do | ! !$omp& private(lstart,lstop,vad_tndx1,vad_tndx2) | DO 990 J=MYJS2,MYJE2 DO J=MYJS2,MYJE2 | DO 990 I=MYIS,MYIE DO I=MYIS,MYIE | IF (VTM(I,J,K+1) == 0.) UBI(I,J,K) = 2. * U(I,J,K) - UBI(I,J,K-1) ! | IF (VTM(I,J,K+1) == 0.) VBI(I,J,K) = 2. * V(I,J,K) - VBI(I,J,K-1) !*** U COMPONENT | 990 END DO ! | ! IF(LTOP_CFL_U(I,J).GT.0)THEN | !$omp parallel do LSTART=LTOP_CFL_U(I,J) | ! LSTOP =MIN(LBOT_CFL_U(I,J),LM-1) | DO 989 J=MYJS2,MYJE2 ! | DO 989 I=MYIS,MYIE DO L=LSTART,LSTOP | UBI(I,J,LM) = 2. * U(I,J,LM) - UBI(I,J,LM1) VAD_TNDX1(L)=(VAD_TEND1(I,J,L-1)+VAD_TEND1(I,J,L+1) | VBI(I,J,LM) = 2. * V(I,J,LM) - VBI(I,J,LM1) 1 +2.*VAD_TEND1(I,J,L))*0.25 | 989 END DO ENDDO | !--------------------------------- DO L=LSTART,LSTOP | ! END OF THE SLOPE ADJUSTMENT CODE VAD_TEND1(I,J,L)=VAD_TNDX1(L) | !--------------------------------- ENDDO | 998 CONTINUE ENDIF | ! ! | !$omp parallel do !*** V COMPONENT | ! ! | DO 988 J=MYJS2,MYJE2 IF(LTOP_CFL_V(I,J).GT.0)THEN | DO 988 I=MYIS,MYIE LSTART=LTOP_CFL_V(I,J) | UDEDB(I,J) = 0. LSTOP =MIN(LBOT_CFL_V(I,J),LM-1) | VDEDB(I,J) = 0. ! | UDEUB(I,J) = 0. DO L=LSTART,LSTOP | VDEUB(I,J) = 0. VAD_TNDX2(L)=(VAD_TEND2(I,J,L-1)+VAD_TEND2(I,J,L+1) | DUDEB(I,J) = 2. * (UBI(I,J,1) - U(I,J,1)) * RDETA(1) 1 +2.*VAD_TEND2(I,J,L))*0.25 | DVDEB(I,J) = 2. * (VBI(I,J,1) - V(I,J,1)) * RDETA(1) ENDDO | EDBDU(I,J) = 0. DO L=LSTART,LSTOP | EDBDV(I,J) = 0. VAD_TEND2(I,J,L)=VAD_TNDX2(L) | 988 END DO ENDDO | ! ENDIF | DO 987 K=1,LM1 ! | ! ENDDO | !$omp parallel do private (DQDEK, EDBFK, EDTDK, QDEDTK, QDEUTK, SEDBK) ENDDO | ! C | DO 987 J=MYJS2,MYJE2 DO 580 L=1,LM | DO 987 I=MYIS,MYIE !$omp parallel do | VMIJ = VTM(I,J,K) * VBM2(I,J) DO 580 J=MYJS2,MYJE2 | ! DO 580 I=MYIS,MYIE | UDEDTK = UDEDB(I,J) U(I,J,L)=U(I,J,L)+VAD_TEND1(I,J,L) | VDEDTK = VDEDB(I,J) V(I,J,L)=V(I,J,L)+VAD_TEND2(I,J,L) | UDEUTK = UDEUB(I,J) 580 CONTINUE | VDEUTK = VDEUB(I,J) C | ! C----------------------------------------------------------------------- | SEDBKU = SIGN(1.,(ETADT(I+IVW(J),J ,K) + ETADT(I+IVE(J),J ,K))) IF(.NOT.HYDRO)THEN | SEDBKV = SIGN(1.,(ETADT(I ,J-1,K) + ETADT(I ,J+1,K))) !$omp parallel do | ! DO L=1,LM1 | DUDEK = DUDEB(I,J) DO J=MYJS_P1,MYJE_P1 | DVDEK = DVDEB(I,J) DO I=MYIS_P1,MYIE_P1 | ! ETADT(I,J,L)=ETADT(I,J,L)/PDSL(I,J) | DUDEB(I,J) = 2. * (UBI(I,J,K+1) - U(I,J,K+1)) * RDETA(K+1) ENDDO | DVDEB(I,J) = 2. * (VBI(I,J,K+1) - V(I,J,K+1)) * RDETA(K+1) ENDDO | ! ENDDO | EDBFKU = (ETADT(I+IVW(J),J ,K) + ETADT(I+IVE(J),J ,K)) * RPDX(I,J) * F4D ENDIF | EDBFKV = (ETADT(I ,J-1,K) + ETADT(I ,J+1,K)) * RPDY(I,J) * F4D C | ! C----------------------------------------------------------------------- | UDEDB(I,J) = (1.+SEDBKU) * (UBI(I,J,K) + DUDEK * EDBFKU) * (-EDBFKU) Cpazi | VDEDB(I,J) = (1.+SEDBKV) * (VBI(I,J,K) + DVDEK * EDBFKV) * (-EDBFKV) Cpazi (Changing constats back to what they were) | ! C DTAD=DTAD*2.0 | UDEUB(I,J) = (1.-SEDBKU) * (U(I,J,K+1) + U(I,J,K+1) C F4D=F4D*2.0 | & - UBI(I,J,K+1) + DUDEB(I,J) C F4Q=F4Q*2.0 | & * EDBFKU) * EDBFKU C DO L=1,LM | ! C F4Q2(L)=F4Q2(L)*2.0 | VDEUB(I,J) = (1.-SEDBKV) * (V(I,J,K+1) + V(I,J,K+1) C END DO | & - VBI(I,J,K+1) + DVDEB(I,J) Cpazi | & * EDBFKV) * EDBFKV RETURN | EDTDKU = EDBDU(I,J) END | EDTDKV = EDBDV(I,J) > ! > EDBDU(I,J) = (ETADT(I+IVW(J),J ,K) + ETADT(I+IVE(J),J ,K)) * RPDX(I,J) * (-F4Q > EDBDV(I,J) = (ETADT(I ,J-1,K) + ETADT(I ,J+1,K)) * RPDY(I,J) * (-F4Q > ! > VAD_TEND1(I,J,K) = (UDEDTK - UDEUTK - UDEDB(I,J) + UDEUB(I,J) + U(I,J,K) > & * (EDBDU(I,J) - EDTDKU)) * RDETA(K) * VMIJ > ! > VAD_TEND2(I,J,K) = (VDEDTK - VDEUTK - VDEDB(I,J) + VDEUB(I,J) + V(I,J,K) > & * (EDBDV(I,J) - EDTDKV)) * RDETA(K) * VMIJ > 987 END DO > ! > !$omp parallel do > ! > DO 986 J=MYJS2,MYJE2 > DO 986 I=MYIS,MYIE > VMIJ = VTM(I,J,LM) * VBM2(I,J) > VAD_TEND1(I,J,LM) = (UDEDB(I,J) - UDEUB(I,J) + U(I,J,LM) * (-EDBDU(I,J))) > & * RDETA(LM) * VMIJ > VAD_TEND2(I,J,LM) = (VDEDB(I,J) - VDEUB(I,J) + V(I,J,LM) * (-EDBDV(I,J))) > & * RDETA(LM) * VMIJ > 986 END DO > !----------------------------------------------------------------------- > ! IF THE CFL CRITERION IS VIOLATED THEN VERTICALLY SMOOTH THE TENDENCIES > !----------------------------------------------------------------------- > ! > !$omp parallel do private (LSTART, LSTOP, VAD_TNDX1, VAD_TNDX2) > ! > DO J=MYJS2,MYJE2 > DO I=MYIS,MYIE > !---------- > ! COMPONENT > !---------- > IF (LTOP_CFL_U(I,J) > 0) THEN > LSTART = LTOP_CFL_U(I,J) > LSTOP = MIN(LBOT_CFL_U(I,J), LM-1) > ! > DO K=LSTART,LSTOP > VAD_TNDX1(K) = (VAD_TEND1(I,J,K-1) + VAD_TEND1(I,J,K+1) + 2. > & * VAD_TEND1(I,J,K )) * 0.25 > END DO > ! > DO K=LSTART,LSTOP > VAD_TEND1(I,J,K) = VAD_TNDX1(K) > END DO > ! > END IF > !------------ > ! V COMPONENT > !------------ > IF (LTOP_CFL_V(I,J) > 0) THEN > LSTART = LTOP_CFL_V(I,J) > LSTOP = MIN(LBOT_CFL_V(I,J),LM-1) > ! > DO K=LSTART,LSTOP > VAD_TNDX2(K) = (VAD_TEND2(I,J,K-1) + VAD_TEND2(I,J,K+1) + 2. > & * VAD_TEND2(I,J,K )) * 0.25 > END DO > DO K=LSTART,LSTOP > VAD_TEND2(I,J,K) = VAD_TNDX2(K) > END DO > ! > END IF > ! > END DO > END DO > ! > DO 580 K=1,LM > ! > !$omp parallel do > ! > DO 580 J=MYJS2,MYJE2 > DO 580 I=MYIS,MYIE > U(I,J,K) = U(I,J,K) + VAD_TEND1(I,J,K) > V(I,J,K) = V(I,J,K) + VAD_TEND2(I,J,K) > 580 END DO > ! > IF (.NOT. HYDRO) THEN > ! > !$omp parallel do > ! > DO K=1,LM1 > DO J=MYJS_P1,MYJE_P1 > DO I=MYIS_P1,MYIE_P1 > ETADT(I,J,K) = ETADT(I,J,K) / PDSL(I,J) > END DO > END DO > END DO > ! > END IF > ! > RETURN > ! > END SUBROUTINE VTADV