SUBROUTINE SLADVT C*********************************************************************** C----------------------------------------------------------------------- INCLUDE "parmeta" C----------------------------------------------------------------------- P A R A M E T E R & (IM1=IM-1 &, LP1=LM+1 &, JAM=6+2*(JM-10) &, JAMD=(JAM*2-10)*3) C----------------------------------------------------------------------- L O G I C A L & RUN,FIRST,RESTRT,ITER2,SIGMA C---------------------------------------------------------------------- INCLUDE "CTLBLK.comm" C----------------------------------------------------------------------- INCLUDE "LOOPS.comm" C----------------------------------------------------------------------- INCLUDE "MASKS.comm" C----------------------------------------------------------------------- INCLUDE "DYNAM.comm" C----------------------------------------------------------------------- INCLUDE "VRBLS.comm" C----------------------------------------------------------------------- INCLUDE "CONTIN.comm" C----------------------------------------------------------------------- INCLUDE "PVRBLS.comm" C----------------------------------------------------------------------- INCLUDE "INDX.comm" C----------------------------------------------------------------------- INCLUDE "SLOPES.comm" C----------------------------------------------------------------------- D I M E N S I O N & ETADTX(IDIM1:IDIM2,JDIM1:JDIM2),ETADTY(IDIM1:IDIM2,JDIM1:JDIM2) &,ETADTXP(IDIM1:IDIM2,JDIM1:JDIM2),ETADTYP(IDIM1:IDIM2,JDIM1:JDIM2) &,TST(IDIM1:IDIM2,JDIM1:JDIM2,LM),SADT(IDIM1:IDIM2,JDIM1:JDIM2,LM) C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- DO L=2,LM DO J=MYJS,MYJE DO I=MYIS,MYIE IF (VTMS(I,J,L).EQ.1) THEN UVTMS=U(I,J,L-1) VVTMS=V(I,J,L-1) ETADTX (I,J)=-UVTMS*DETA(L)*0.5/DX(I,J) ETADTY (I,J)=-VVTMS*DETA(L)*0.5/DY ETADTXP(I,J)=-( UVTMS+VVTMS)*DETA(L)/ & (SQRT(2.0)*SQRT(DX(I,J)*DX(I,J)+DY*DY)) ETADTYP(I,J)=-(-UVTMS+VVTMS)*DETA(L)/ & (SQRT(2.0)*SQRT(DX(I,J)*DX(I,J)+DY*DY)) END IF END DO END DO END DO C----------------------------------------------------------------------- C*** C*** INITIALIZE TST (T star) and SADT (Slantwise ADv. of T increment) C*** DO L=1,LM DO J=MYJS,MYJE DO I=MYIS,MYIE TST(I,J,L)=T(I,J,L) SADT(I,J,L)=0.0 END DO END DO END DO C----------------------------------------------------------------------- DO 600 ITER=1,2 C----------------------------------------------------------------------- C*** C*** LOOP 130 is a v points loop C*** DO 130 J=MYJS_P1,MYJE_P1 DO 130 I=MYIS_P1,MYIE_P1 C L below of the two layers involved: LB=LMV(I,J)+1 DTFC=-DT/24.0 IF (ISLD(I,J).NE.0) THEN IF (ISLD(I,J).EQ.1) THEN T1=TST(I+IVE(J),J, LB-1) T2=TST(I, J+1,LB) T3=TST(I+IVW(J),J, LB) T4=TST(I, J-1,LB) TT21=-ETADTYP(I,J)*(T2-T1) TT31= ETADTX (I,J)*(T3-T1) TT41= ETADTXP(I,J)*(T4-T1) SADT(I+IVE(J),J, LB-1)=(TT21+TT31+TT41)*DTFC/DETA(LB-1) SADT(I, J+1,LB )= TT21*DTFC/DETA(LB) SADT(I+IVW(J),J, LB )= TT31*DTFC/DETA(LB) SADT(I, J-1,LB )= TT41*DTFC/DETA(LB) ELSE IF (ISLD(I,J).EQ.3) THEN T1=TST(I+IVE(J),J, LB) T2=TST(I, J+1,LB-1) T3=TST(I+IVW(J),J, LB) T4=TST(I, J-1,LB) TT12= ETADTYP(I,J)*(T1-T2) TT32= ETADTXP(I,J)*(T3-T2) TT42= ETADTY (I,J)*(T4-T2) SADT(I+IVE(J),J, LB )= TT12*DTFC/DETA(LB) SADT(I, J+1,LB-1)=(TT12+TT32+TT42)*DTFC/DETA(LB-1) SADT(I+IVW(J),J, LB )= TT32*DTFC/DETA(LB) SADT(I, J-1,LB )= TT42*DTFC/DETA(LB) ELSE IF (ISLD(I,J).EQ.5) THEN T1=TST(I+IVE(J),J, LB) T2=TST(I, J+1,LB) T3=TST(I+IVW(J),J, LB-1) T4=TST(I, J-1,LB) TT13=-ETADTX (I,J)*(T1-T3) TT23=-ETADTXP(I,J)*(T2-T3) TT43= ETADTYP(I,J)*(T4-T3) SADT(I+IVE(J),J, LB )= TT13*DTFC/DETA(LB) SADT(I, J+1,LB )= TT23*DTFC/DETA(LB) SADT(I+IVW(J),J, LB-1)=(TT13+TT23+TT43)*DTFC/DETA(LB-1) SADT(I, J-1,LB )= TT43*DTFC/DETA(LB) ELSE IF (ISLD(I,J).EQ.7) THEN T1=TST(I+IVE(J),J, LB) T2=TST(I, J+1,LB) T3=TST(I+IVW(J),J, LB) T4=TST(I, J-1,LB-1) TT14=-ETADTXP(I,J)*(T1-T4) TT24=-ETADTY (I,J)*(T2-T4) TT34=-ETADTYP(I,J)*(T3-T4) SADT(I+IVE(J),J, LB )= TT14*DTFC/DETA(LB) SADT(I, J+1,LB )= TT24*DTFC/DETA(LB) SADT(I+IVW(J),J, LB )= TT34*DTFC/DETA(LB) SADT(I, J-1,LB-1)=(TT14+TT24+TT34)*DTFC/DETA(LB-1) ELSE IF (ISLD(I,J).EQ.2 .OR. ISLD(I,J).EQ.6 ) THEN C Generate an L increment to be used for stepping slantwise up as C necessary, -1 for slope 2, and 0 for slope 6 LSL=(ISLD(I,J)-6)/4 T1=TST(I+IVE(J),J, LB+LSL ) T2=TST(I, J+1,LB+LSL ) T3=TST(I+IVW(J),J, LB-LSL-1) T4=TST(I, J-1,LB-LSL-1) TT31=ETADTX (I,J)*(T3-T1) TT41=ETADTXP(I,J)*(T4-T1) TT42=ETADTY (I,J)*(T4-T2) TT32=ETADTXP(I,J)*(T3-T2) SADT(I+IVE(J),J, LB+LSL )=(TT31+TT41)*DTFC/DETA(LB+LSL) SADT(I, J+1,LB+LSL )=(TT42+TT32)*DTFC/DETA(LB+LSL) SADT(I+IVW(J),J, LB-LSL-1)=(TT31+TT32)*DTFC/DETA(LB-LSL-1) SADT(I, J-1,LB-LSL-1)=(TT42+TT41)*DTFC/DETA(LB-LSL-1) ELSE IF (ISLD(I,J).EQ.4) THEN T1=TST(I+IVE(J),J, LB) T2=TST(I, J+1,LB-1) T3=TST(I+IVW(J),J, LB-1) T4=TST(I, J-1,LB) TT12= ETADTYP(I,J)*(T1-T2) TT13=-ETADTX (I,J)*(T1-T3) TT42= ETADTY (I,J)*(T4-T2) TT43= ETADTYP(I,J)*(T4-T3) SADT(I+IVE(J),J, LB )=(TT12+TT13)*DTFC/DETA(LB) SADT(I, J+1,LB-1)=(TT12+TT42)*DTFC/DETA(LB-1) SADT(I+IVW(J),J, LB-1)=(TT13+TT43)*DTFC/DETA(LB-1) SADT(I, J-1,LB )=(TT42+TT43)*DTFC/DETA(LB) ELSE IF (ISLD(I,J).EQ.8) THEN T1=TST(I+IVE(J),J, LB-1) T2=TST(I, J+1,LB ) T3=TST(I+IVW(J),J, LB ) T4=TST(I, J-1,LB-1) TT21=-ETADTYP(I,J)*(T2-T1) TT31= ETADTX (I,J)*(T3-T1) TT24=-ETADTY (I,J)*(T2-T4) TT34=-ETADTYP(I,J)*(T3-T4) SADT(I+IVE(J),J, LB-1)=(TT21+TT31)*DTFC/DETA(LB-1) SADT(I, J+1,LB )=(TT24+TT21)*DTFC/DETA(LB) SADT(I+IVW(J),J, LB )=(TT34+TT31)*DTFC/DETA(LB) SADT(I, J-1,LB-1)=(TT24+TT34)*DTFC/DETA(LB-1) ELSE write(*,*) "What went wrong for Christ’s sake?" write(*,*) "I,J,ISLD(I,J) ",I,J,ISLD(I,J) STOP END IF END IF 130 CONTINUE IF (ITER.EQ.1) THEN DO L=1,LM DO J=MYJS,MYJE DO I=MYIS,MYIE TST(I,J,L)=TST(I,J,L)+SADT(I,J,L) END DO END DO END DO ELSE DO L=1,LM DO J=MYJS,MYJE DO I=MYIS,MYIE T(I,J,L)=T(I,J,L)+SADT(I,J,L) END DO END DO END DO ENDIF C----------------------------------------------------------------------- 600 CONTINUE C----------------------------------------------------------------------- RETURN END