#include "dims.h" SUBROUTINE TUVBND use cons_module,only: len1,kmax,kmaxp1,expz,imax,imaxp2,cor,tn, | shapiro,dtx2inv,re_inv,gask use input_module,only: ncep,nmc implicit none C **** C **** CALCULATE LOWER BOUNDARY CONDITIONS FOR T, U AND V IN C **** T1, T2 AND T3 RESPECTIVELY C **** #include "params.h" #include "fcom.h" #include "index.h" #include "buff.h" #include "phys.h" #include "vscr.h" #include "bndz.h" real :: rayk COMMON/RAYFRIC/RAYK(ZKMX) ! ! Local: real :: rlat,hlat,eqfric integer :: i integer :: nx,ntk,nwk,ncpk,nmsk,ntjm2k,ntjm1k,ntnmk,ntjp1k, | ntjp2k,nqk,nqdhk,ngwvtk,nuk,nvk,nwtek,nwtik,nflhk,nfphk, | ngwvuk,ngwvvk,nujm2k,nujm1k,nunmk,nujp1k,nujp2k,nvjm2k,nvjm1k, | nvnmk,nvjp1k,nvjp2k C **** C **** EQUATORIAL RAYLEIGH FRICTION ADDITION C **** rlat = (-87.5+(j-1)*5.)*3.14159/180. hlat = 20./57.295 eqfric = 30.E-7*exp(-(rlat/hlat)**2) C eqfric = 0. C **** C **** C **** C **** S1 = ADVEC(T), ( K=0 ) C **** NX = NT+KMAX CALL ADVECL(NX,S1,KMAXP1) NTK = NJ+NT NWK = NJ+NW NCPK = NCP NMSK = NJ+NMS NTJM2K = NJM2+NTNM+KMAX NTJM1K = NJM1+NTNM+KMAX NTNMK = NJ+NTNM+KMAX NTJP1K = NJP1+NTNM+KMAX NTJP2K = NJP2+NTNM+KMAX NQK = NQ NQDHK = NQDH NGWVTK = NGWVT NUK = NJ+NU+KMAX NVK = NJ+NV+KMAX NWTEK = NWTE NWTIK = NWTI DO 1 I = 1,LEN1 C **** C **** ADD IN VERTICAL ADVECTION C **** S1(I,1) = S1(I,1)+2.*F(I,NWK)*(F(I,NTK)-F(I,NTK+KMAX))/dz C **** C **** S9 = CP*MBAR ( K = 0 ) C **** S9(I,1) = F(I,NCPK)*F(I,NMSK) C **** C **** SHAPIRO SMOOTHER ( 1ST STAGE ) C **** S2(I,1) = F(I,NTNMK)-shapiro*(F(I,NTJP2K)+F(I,NTJM2K)-4.* 1 (F(I,NTJP1K)+F(I,NTJM1K))+6.*F(I,NTNMK)) 1 CONTINUE C **** C **** SHAPIRO SMOOTHER ( 2ND STAGE ) C **** DO 2 I = 3,LEN1-2 S3(I,1) = S2(I,1)-shapiro*(S2(I+2,1)+S2(I-2,1)-4.*(S2(I+1,1)+ 1 S2(I-1,1))+6.*S2(I,1)) 2 CONTINUE C **** C **** PERIODIC POINTS C **** DO 3 I = 1,2 S3(I,1) = S3(I+IMAX,1) S3(IMAXP2+I,1) = S3(I+2,1) 3 CONTINUE DO 4 I = 1,LEN1 C **** C **** S1 = 1./(2.*DT)*T(N-1)-S1(I,1) C **** S1(I,1) = dtx2inv*S3(I,1)-S1(I,1) C **** C **** COLLECT HEATING TERMS IN S5 C **** S5(I,1) = F(I,NQK) C **** C **** ADD HEATING HEATING FROM FOURTH ORDER DIFFUSION C **** AND GRAVITY WAVWS C **** S5(I,1) = S5(I,1)+1.5*(F(I,NQDHK)+F(I,NGWVTK))-.5*(F(I,NQDHK+1) 1 +F(I,NGWVTK+1)) C **** C **** ADD EXPLICIT NEWTONIAN COOLING C **** S5(I,1) = S5(I,1)-(1.5*F(I,NWTEK)/expz(1)-.5*F(I,NWTEK+1)/ 1 expz(2)) C **** C **** S1 = S1+Q/CP C **** S1(I,1) = S1(I,1)+S5(I,1)/F(I,NCPK) 4 CONTINUE DO 9 I = 1,LEN1 C **** C **** S5 = W*R/(CP*MBAR), K = 0 C **** S5(I,1) = F(I,NWK)*gask/S9(I,1) C **** C **** S5 = 1./(2.*DT)+NEWTI+S5 C **** S5(I,1) = dtx2inv+1.5*F(I,NWTIK)-0.5*F(I,NWTIK+1)+S5(I,1) C **** C **** AND FINALLY, TBND = S1/S5 C **** if (ncep <= 0 .and. nmc <= 0) TBND(I) = S1(I,1)/S5(I,1) 9 CONTINUE C **** C **** NOW DERIVE BOUNDARY CONDITIONS FOR FOR U AND V C **** IN UBND AND VBND C **** C **** S1 = ADVEC(U), K = 0 C **** S2 = ADVEC(V), K = 0 C **** NX = NU+KMAX CALL ADVECL(NX,S1,KMAXP1) NX = NV+KMAX CALL ADVECL(NX,S2,KMAXP1) C **** C **** S4 = G/(RAD*COS(PHI))*DZ/DLAMDA C **** S5 = G/RA*DZ/DPHI C **** CALL GLPL(S4,S5) NUK = NJ+NU NVK = NJ+NV NWK = NJ+NW NFLHK = NFLH NFPHK = NFPH NGWVUK = NGWVU NGWVVK = NGWVV NUJM2K = NJM2+NUNM+KMAX NUJM1K = NJM1+NUNM+KMAX NUNMK = NJ+NUNM+KMAX NUJP1K = NJP1+NUNM+KMAX NUJP2K = NJP2+NUNM+KMAX NVJM2K = NJM2+NVNM+KMAX NVJM1K = NJM1+NVNM+KMAX NVNMK = NJ+NVNM+KMAX NVJP1K = NJP1+NVNM+KMAX NVJP2K = NJP2+NVNM+KMAX DO 5 I = 1,LEN1 C **** C **** ADD IN VERTICAL ADVECTION C **** S1(I,1) = S1(I,1)+2.*F(I,NWK)*(F(I,NUK)-F(I,NUK+KMAX))/dz S2(I,1) = S2(I,1)+2.*F(I,NWK)*(F(I,NVK)-F(I,NVK+KMAX))/dz C **** C **** ADD IN HORIZONTAL DERIVATIVES OF GEOPOTENTIAL C **** S1(I,1) = S1(I,1)+S4(I,1) S2(I,1) = S2(I,1)+S5(I,1) C **** C **** FOURTH ORDER HORIZONTAL DIFFUSION C **** S1(I,1) = S1(I,1)-1.5*(F(I,NFLHK)+F(I,NGWVUK))+0.5* 1 (F(I,NFLHK+1)+F(I,NGWVUK+1)) S2(I,1) = S2(I,1)-1.5*(F(I,NFPHK)+F(I,NGWVVK))+0.5* 1 (F(I,NFPHK+1)+F(I,NGWVVK+1)) C **** C **** SHAPIRO SMOOTHER (1ST STAGE) C **** S6(I,1) = F(I,NUNMK)-shapiro*(F(I,NUJP2K)+F(I,NUJM2K)-4.* 1 (F(I,NUJP1K)+F(I,NUJM1K))+6.*F(I,NUNMK)) S7(I,1) = F(I,NVNMK)-shapiro*(F(I,NVJP2K)+F(I,NVJM2K)-4.* 1 (F(I,NVJP1K)+F(I,NVJM1K))+6.*F(I,NVNMK)) 5 CONTINUE C **** C **** SHAPIRO SMOOTHER (2ND PHASE) C **** DO 6 I = 3,LEN1-2 S8(I,1) = S6(I,1)-shapiro*(S6(I+2,1)+S6(I-2,1)-4.* 1 (S6(I-1,1)+S6(I+1,1))+6.*S6(I,1)) S9(I,1) = S7(I,1)-shapiro*(S7(I+2,1)+S7(I-2,1)-4.* 1 (S7(I-1,1)+S7(I+1,1))+6.*S7(I,1)) 6 CONTINUE C **** C **** PERIODIC POINTS C **** DO 7 I = 1,2 S8(I,1) = S8(I+IMAX,1) S8(IMAXP2+I,1) = S8(I+2,1) S9(I,1) = S9(I+IMAX,1) S9(IMAXP2+I,1) = S9(I+2,1) 7 CONTINUE DO 8 I = 1,LEN1 C **** C **** S1 = U(N-1)/(2.*DT)-S1 C **** S2 = V(N-1)/(2.*DT)-S2 C **** S1(I,1) = S8(I,1)*dtx2inv-S1(I,1) S2(I,1) = S9(I,1)*dtx2inv-S2(I,1) 8 CONTINUE DO 11 I = 1,LEN1 C **** C **** S3 = A11, S4 = A12 C **** S5 = A21, S6 = A22 C **** S3(I,1) = dtx2inv+(RAYK(1)+EQFRIC)**1.5/(RAYK(2)+EQFRIC)**0.5 S4(I,1) = -(COR(J)+F(I,NUK+KMAX)*TN(J)*re_inv) S5(I,1) = -S4(I,1) S6(I,1) = dtx2inv+(RAYK(1)+EQFRIC)**1.5/(RAYK(2)+EQFRIC)**0.5 C **** C **** S7 = DET(A) = A11*A22-A12*A21 C **** S7(I,1) = S3(I,1)*S6(I,1)-S4(I,1)*S5(I,1) C **** C **** SOLVE FOR UB AND VB IN UBND AND VBND C **** UBND(I) = (S6(I,1)*S1(I,1)-S4(I,1)*S2(I,1))/S7(I,1) VBND(I) = (-S5(I,1)*S1(I,1)+S3(I,1)*S2(I,1))/S7(I,1) 11 CONTINUE C **** C **** PERIODIC POINTS C **** DO I = 1,2 if (ncep <= 0 .and. nmc <= 0) then TBND(I) = TBND(I+IMAX) TBND(I+IMAXP2) = TBND(I+2) endif UBND(I) = UBND(I+IMAX) UBND(I+IMAXP2) = UBND(I+2) VBND(I) = VBND(I+IMAX) VBND(I+IMAXP2) = VBND(I+2) ENDDO C***************************************************** C IF(J.EQ.1)THEN C TMEAN = 0. C WT = 0. C ENDIF C TMEAN = TMEAN + SSUM(IMAX,TBND(3),1)*CS(J) C WT = WT + CS(J) C **** C **** REMOVE ZONAL MEANS FROM BOUNDARY CONDITIONS C **** C DO 12 I = 1,LEN1 C TBND(I) = TBND(I)-TMNOLD+TBOUND C 12 CONTINUE C IF(J.EQ.JMAX)THEN C TMNOLD = TMEAN/(WT*FLOAT(IMAX)) C ENDIF C***************************************************** RETURN END