!WRF:MODEL_LAYER:DYNAMICS ! #if ( defined(ADVECT_KERNEL) ) ! cpp -traditional-cpp -P -DADVECT_KERNEL module_advect_em.F > advection_kernel.f90 ! gfortran -ffree-form -ffree-line-length-none advection_kernel.f90 ! ./a.out MODULE advection_kernel TYPE grid_config_rec_type INTEGER :: scalar_adv_opt = 0 INTEGER :: h_sca_adv_order = 5 INTEGER :: v_sca_adv_order = 3 LOGICAL :: periodic_x = .false. LOGICAL :: periodic_y = .false. LOGICAL :: symmetric_xs = .false. LOGICAL :: symmetric_xe = .false. LOGICAL :: symmetric_ys = .false. LOGICAL :: symmetric_ye = .false. LOGICAL :: open_xs = .false. LOGICAL :: open_xe = .false. LOGICAL :: open_ys = .false. LOGICAL :: open_ye = .false. LOGICAL :: specified = .true. LOGICAL :: nested = .false. LOGICAL :: polar = .false. END TYPE grid_config_rec_type CHARACTER (LEN=256) :: wrf_err_message CONTAINS !---------------------------------------------------------------- SUBROUTINE wrf_error_fatal ( message ) IMPLICIT NONE CHARACTER(LEN=*) , INTENT(IN) :: message PRINT *,'advect_scalar_pd: FATAL MESSAGE = ',TRIM(message) STOP 12345 END SUBROUTINE wrf_error_fatal !---------------------------------------------------------------- SUBROUTINE init ( config_flags ) IMPLICIT NONE TYPE (grid_config_rec_type) :: config_flags config_flags%h_sca_adv_order = 5 config_flags%v_sca_adv_order = 3 config_flags%periodic_x = .true. config_flags%periodic_y = .true. config_flags%symmetric_xs = .false. config_flags%symmetric_xe = .false. config_flags%symmetric_ys = .false. config_flags%symmetric_ye = .false. config_flags%open_xs = .false. config_flags%open_xe = .false. config_flags%open_ys = .false. config_flags%open_ye = .false. config_flags%specified = .false. config_flags%nested = .false. END SUBROUTINE init !---------------------------------------------------------------- SUBROUTINE tophat ( field, num_scalars , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) IMPLICIT NONE INTEGER , INTENT(IN ) :: num_scalars , ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme , num_scalars ) , INTENT(OUT) :: field INTEGER :: i, j, k , n field = 0 DO n = 1 , num_scalars DO j = jts , jte DO k = kts , kte DO i = its , ite IF ( i .gt. 35 .and. i.lt. 55 ) THEN field (i,k,j,n) = 1. END IF END DO END DO END DO END DO END SUBROUTINE tophat !---------------------------------------------------------------- SUBROUTINE column (loop , data_list, its,ite) IMPLICIT NONE INTEGER , INTENT(IN) :: loop, its, ite REAL , INTENT(IN) , DIMENSION(its:ite) :: data_list INTEGER , DIMENSION(its:ite) :: data_int INTEGER :: i CHARACTER (len = 10 ) :: filename IF ( loop.EQ.0 ) THEN OPEN (unit=7,file = "x_locations.txt" , & form = "formatted" , & access = "sequential" ) DO i = its,ite write (7,*) i END DO close (7) END IF WRITE(filename,fmt='(i6.6,".txt")') loop OPEN (unit=7,file = filename , & form = "formatted" , & access = "sequential" ) data_int = NINT(data_list * 100 ) DO i = its,ite write (7,*) data_int(i) END DO close (7) END SUBROUTINE column !---------------------------------------------------------------- #elif ( ! defined(ADVECT_KERNEL) ) MODULE module_advect_em USE module_bc USE module_model_constants USE module_wrf_error CONTAINS !------------------------------------------------------------------------------- SUBROUTINE advect_u ( u, u_old, tendency, & ru, rv, rom, & c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: u, & u_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip INTEGER :: jp1, jp0, jtmp INTEGER :: horz_order, vert_order REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp REAL , DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION( its-1:ite+1, kts:kte ) :: fqx REAL, DIMENSION( its:ite, kts:kte, 2) :: fqy LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & +(q_ip2+q_im3) )/60.0 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 LOGICAL :: specified specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. ! set order for vertical and horzontal flux operators horz_order = config_flags%h_mom_adv_order vert_order = config_flags%v_mom_adv_order ktf=MIN(kte,kde-1) ! begin with horizontal flux divergence horizontal_order_test : IF( horz_order == 6 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = ite IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_6 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux6( & u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), & u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel ) ENDDO ENDDO ! we must be close to some boundary where we need to reduce the order of the stencil ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & *(u(i,k,j)+u(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux4( & u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & *(u(i,k,j)+u(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux4( & u(i,k,j-2),u(i,k,j-1), & u(i,k,j),u(i,k,j+1),vel ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ! This would be seen by (j > j_start) but we need to zero out the NP tendency ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_6 ! next, x - flux divergence i_start = its i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) i_start_f = ids+3 ENDIF IF(degrade_xe) then i_end = MIN(ide-1,ite) i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i,k ) = vel*flux6( u(i-3,k,j), u(i-2,k,j), & u(i-1,k,j), u(i ,k,j), & u(i+1,k,j), u(i+2,k,j), & vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF( degrade_xs ) THEN IF( i_start == ids+1 ) THEN ! second order flux next to the boundary i = ids+1 DO k=kts,ktf ub = u(i-1,k,j) IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i,k,j)+ub) ENDDO END IF i = ids+2 DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), & u(i ,k,j), u(i+1,k,j), & vel ) ENDDO ENDIF IF( degrade_xe ) THEN IF( i_end == ide-1 ) THEN ! second order flux next to the boundary i = ide DO k=kts,ktf ub = u(i,k,j) IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i-1,k,j)+ub) ENDDO ENDIF DO k=kts,ktf i = ide-1 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i,k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), & u(i ,k,j), u(i+1,k,j), & vel ) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF( horz_order == 5 ) THEN ! 5th order horizontal flux calculation ! This code is EXACTLY the same as the 6th order code ! EXCEPT the 5th order and 3rd operators are used in ! place of the 6th and 4th order operators ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = ite IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux5( & u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), & u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel ) ENDDO ENDDO ! we must be close to some boundary where we need to reduce the order of the stencil ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & *(u(i,k,j)+u(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux3( & u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & *(u(i,k,j)+u(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux3( & u(i,k,j-2),u(i,k,j-1), & u(i,k,j),u(i,k,j+1),vel ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ! This would be seen by (j > j_start) but we need to zero out the NP tendency ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_5 ! next, x - flux divergence i_start = its i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) i_start_f = ids+3 ENDIF IF(degrade_xe) then i_end = MIN(ide-1,ite) i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j), & u(i-1,k,j), u(i ,k,j), & u(i+1,k,j), u(i+2,k,j), & vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF( degrade_xs ) THEN IF( i_start == ids+1 ) THEN ! second order flux next to the boundary i = ids+1 DO k=kts,ktf ub = u(i-1,k,j) IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i,k,j)+ub) ENDDO END IF i = ids+2 DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), & u(i ,k,j), u(i+1,k,j), & vel ) ENDDO ENDIF IF( degrade_xe ) THEN IF( i_end == ide-1 ) THEN ! second order flux next to the boundary i = ide DO k=kts,ktf ub = u(i,k,j) IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i-1,k,j)+ub) ENDDO ENDIF DO k=kts,ktf i = ide-1 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), & u(i ,k,j), u(i+1,k,j), & vel ) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF( horz_order == 4 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-1) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. !--------------- x - advection first i_start = its i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = ids+1 i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = ide-1 i_end_f = ide-1 ENDIF ! compute fluxes DO j = j_start, j_end DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), & u(i ,k,j), u(i+1,k,j), vel ) ENDDO ENDDO ! second order flux close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF( degrade_xs ) THEN i = i_start DO k=kts,ktf ub = u(i-1,k,j) IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i,k,j)+ub) ENDDO ENDIF IF( degrade_xe ) THEN i = i_end+1 DO k=kts,ktf ub = u(i,k,j) IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i-1,k,j)+ub) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! y flux divergence i_start = its i_end = ite IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 !CJM these may not work with tiling because they define j_start and end in terms of domain dim IF(degrade_ys) then j_start = jds+1 j_start_f = j_start+1 ENDIF IF(degrade_ye) then j_end = jde-2 j_end_f = jde-2 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! j flux loop for v flux of u momentum jp1 = 2 jp0 = 1 DO j = j_start, j_end+1 IF ( (j < j_start_f) .and. degrade_ys) THEN DO k = kts, ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start)) & *(u(i,k,j_start)+u(i,k,j_start-1)) ENDDO ENDDO ELSE IF ((j > j_end_f) .and. degrade_ye) THEN DO k = kts, ktf DO i = i_start, i_end ! Assumes j>j_end_f is ONLY j_end+1 ... ! fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1)) & ! *(u(i,k,j_end+1)+u(i,k,j_end)) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & *(u(i,k,j)+u(i,k,j-1)) ENDDO ENDDO ELSE ! 3rd or 4th order flux DO k = kts, ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux4( u(i,k,j-2), u(i,k,j-1), & u(i,k,j ), u(i,k,j+1), & vel ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ! This would be seen by (j > j_start) but we need to zero out the NP tendency ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF (j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO END IF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO ELSE IF ( horz_order == 3 ) THEN ! As with the 5th and 6th order flux chioces, the 3rd and 4th order ! code is EXACTLY the same EXCEPT for the flux operator. ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-1) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. !--------------- x - advection first i_start = its i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = ids+1 i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = ide-1 i_end_f = ide-1 ENDIF ! compute fluxes DO j = j_start, j_end DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), & u(i ,k,j), u(i+1,k,j), vel ) ENDDO ENDDO ! second order flux close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF( degrade_xs ) THEN i = i_start DO k=kts,ktf ub = u(i-1,k,j) IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i,k,j)+ub) ENDDO ENDIF IF( degrade_xe ) THEN i = i_end+1 DO k=kts,ktf ub = u(i,k,j) IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i-1,k,j)+ub) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! y flux divergence i_start = its i_end = ite IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 !CJM these may not work with tiling because they define j_start and end in terms of domain dim IF(degrade_ys) then j_start = jds+1 j_start_f = j_start+1 ENDIF IF(degrade_ye) then j_end = jde-2 j_end_f = jde-2 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! j flux loop for v flux of u momentum jp1 = 2 jp0 = 1 DO j = j_start, j_end+1 IF ( (j < j_start_f) .and. degrade_ys) THEN DO k = kts, ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start)) & *(u(i,k,j_start)+u(i,k,j_start-1)) ENDDO ENDDO ELSE IF ((j > j_end_f) .and. degrade_ye) THEN DO k = kts, ktf DO i = i_start, i_end ! Assumes j>j_end_f is ONLY j_end+1 ... ! fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1)) & ! *(u(i,k,j_end+1)+u(i,k,j_end)) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & *(u(i,k,j)+u(i,k,j-1)) ENDDO ENDDO ELSE ! 3rd or 4th order flux DO k = kts, ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux3( u(i,k,j-2), u(i,k,j-1), & u(i,k,j ), u(i,k,j+1), & vel ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ! This would be seen by (j > j_start) but we need to zero out the NP tendency ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF (j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO END IF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO ELSE IF ( horz_order == 2 ) THEN i_start = its i_end = ite j_start = jts j_end = MIN(jte,jde-1) IF ( config_flags%open_xs ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite) IF ( specified ) i_start = MAX(ids+2,its) IF ( specified ) i_end = MIN(ide-2,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite DO j = j_start, j_end DO k=kts,ktf DO i = i_start, i_end mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 & *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) & -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j))) ENDDO ENDDO ENDDO IF ( specified .AND. its .LE. ids+1 .AND. .NOT. config_flags%periodic_x ) THEN DO j = j_start, j_end DO k=kts,ktf i = ids+1 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS ub = u(i-1,k,j) IF (u(i,k,j) .LT. 0.) ub = u(i,k,j) tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 & *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) & -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+ub)) ENDDO ENDDO ENDIF IF ( specified .AND. ite .GE. ide-1 .AND. .NOT. config_flags%periodic_x ) THEN DO j = j_start, j_end DO k=kts,ktf i = ide-1 mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS ub = u(i+1,k,j) IF (u(i,k,j) .GT. 0.) ub = u(i,k,j) tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 & *((ru(i+1,k,j)+ru(i,k,j))*(ub+u(i,k,j)) & -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j))) ENDDO ENDDO ENDIF IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte) DO j = j_start, j_end DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j)*rdy ! ADT eqn 44, 1st term on RHS ! Comments for polar boundary condition ! Flow is only from one side for points next to poles IF ( (config_flags%polar) .AND. (j == jds) ) THEN tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 & *(rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j)) ELSE IF ( (config_flags%polar) .AND. (j == jde-1) ) THEN tendency(i,k,j)=tendency(i,k,j)+mrdy*0.25 & *(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1)) ELSE ! Normal code tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 & *((rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j)) & -(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1))) ENDIF ENDDO ENDDO ENDDO ELSE IF ( horz_order == 0 ) THEN ! Just in case we want to turn horizontal advection off, we can do it ELSE WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: h_order not known ',horz_order CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ENDIF horizontal_order_test ! radiative lateral boundary condition in x for normal velocity (u) IF ( (config_flags%open_xs) .and. its == ids ) THEN j_start = jts j_end = MIN(jte,jde-1) DO j = j_start, j_end DO k = kts, ktf ub = MIN(ru(its,k,j)-cb*(c1(k)*mut(its,j)+c2(k)), 0.) tendency(its,k,j) = tendency(its,k,j) & - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j)) ENDDO ENDDO ENDIF IF ( (config_flags%open_xe) .and. ite == ide ) THEN j_start = jts j_end = MIN(jte,jde-1) DO j = j_start, j_end DO k = kts, ktf ub = MAX(ru(ite,k,j)+cb*(c1(k)*mut(ite-1,j)+c2(k)), 0.) tendency(ite,k,j) = tendency(ite,k,j) & - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j)) ENDDO ENDDO ENDIF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb') ! first, set to index ranges i_start = its i_end = MIN(ite,ide) imin = ids imax = ide-1 IF (config_flags%open_xs) THEN i_start = MAX(ids+1, its) imin = ids ENDIF IF (config_flags%open_xe) THEN i_end = MIN(ite,ide-1) imax = ide-1 ENDIF IF( (config_flags%open_ys) .and. (jts == jds)) THEN DO i = i_start, i_end mrdy=msfux(i,jts)*rdy ! ADT eqn 44, 2nd term on RHS ip = MIN( imax, i ) im = MAX( imin, i-1 ) DO k=kts,ktf vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts)) vb = MIN( vw, 0. ) dvm = rv(ip,k,jts+1)-rv(ip,k,jts) dvp = rv(im,k,jts+1)-rv(im,k,jts) tendency(i,k,jts)=tendency(i,k,jts)-mrdy*( & vb*(u_old(i,k,jts+1)-u_old(i,k,jts)) & +0.5*u(i,k,jts)*(dvm+dvp)) ENDDO ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde)) THEN DO i = i_start, i_end mrdy=msfux(i,jte-1)*rdy ! ADT eqn 44, 2nd term on RHS ip = MIN( imax, i ) im = MAX( imin, i-1 ) DO k=kts,ktf vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte)) vb = MAX( vw, 0. ) dvm = rv(ip,k,jte)-rv(ip,k,jte-1) dvp = rv(im,k,jte)-rv(im,k,jte-1) tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*( & vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2)) & +0.5*u(i,k,jte-1)*(dvm+dvp)) ENDDO ENDDO ENDIF !-------------------- vertical advection ! ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w) ! Here we have: - partial d/dz (u*rom) = - partial d/dz (u rho w / my) ! Since 'my' (map scale factor in y-direction) isn't a function of z, ! this is what we need, so leave unchanged in advect_u i_start = its i_end = ite j_start = jts j_end = min(jte,jde-1) ! IF ( config_flags%open_xs ) i_start = MAX(ids+1,its) ! IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite) IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_ye .or. specified ) i_end = MIN(ide-1,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite DO i = i_start, i_end vflux(i,kts)=0. vflux(i,kte)=0. ENDDO vert_order_test : IF (vert_order == 6) THEN DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) vflux(i,k) = vel*flux6( & u(i,k-3,j), u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), u(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) vflux(i,k) = vel*flux4( & u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), -vel ) k = ktf-1 vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) vflux(i,k) = vel*flux4( & u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), -vel ) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) vflux(i,k) = vel*flux5( & u(i,k-3,j), u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), u(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) vflux(i,k) = vel*flux3( & u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), -vel ) k = ktf-1 vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) vflux(i,k) = vel*flux3( & u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), -vel ) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE IF (vert_order == 4) THEN DO j = j_start, j_end DO k=kts+2,ktf-1 DO i = i_start, i_end vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) vflux(i,k) = vel*flux4( & u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE IF (vert_order == 3) THEN DO j = j_start, j_end DO k=kts+2,ktf-1 DO i = i_start, i_end vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) vflux(i,k) = vel*flux3( & u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE IF (vert_order == 2) THEN DO j = j_start, j_end DO k=kts+1,ktf DO i = i_start, i_end vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) ENDDO ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: v_order not known ',vert_order CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ENDIF vert_order_test END SUBROUTINE advect_u !------------------------------------------------------------------------------- SUBROUTINE advect_v ( v, v_old, tendency, & ru, rv, rom, & c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: v, & v_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum REAL , DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy INTEGER :: horz_order INTEGER :: vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & +(q_ip2+q_im3) )/60.0 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 LOGICAL :: specified specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. ! set order for the advection schemes ktf=MIN(kte,kde-1) horz_order = config_flags%h_mom_adv_order vert_order = config_flags%v_mom_adv_order ! here is the choice of flux operators horizontal_order_test : IF( horz_order == 6 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-1) j_end_f = jde-2 ENDIF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_6 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i, k, jp1 ) = vel*flux6( & v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), & v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel ) ENDDO ENDDO ! we must be close to some boundary where we need to reduce the order of the stencil ! specified uses upstream normal wind at boundaries ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end vb = v(i,k,j-1) IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(v(i,k,j)+vb) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i, k, jp1 ) = vel*flux4( & v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end vb = v(i,k,j) IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(vb+v(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i, k, jp1 ) = vel*flux4( & v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ELSE ! Normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_6 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i, k ) = vel*flux6( v(i-3,k,j), v(i-2,k,j), & v(i-1,k,j), v(i ,k,j), & v(i+1,k,j), v(i+2,k,j), & vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) & *(v(i,k,j)+v(i-1,k,j)) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), & v(i ,k,j), v(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & *(v(i_end+1,k,j)+v(i_end,k,j)) ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), & v(i ,k,j), v(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF( horz_order == 5 ) THEN ! 5th order horizontal flux calculation ! This code is EXACTLY the same as the 6th order code ! EXCEPT the 5th order and 3rd operators are used in ! place of the 6th and 4th order operators ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-1) j_end_f = jde-2 ENDIF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i, k, jp1 ) = vel*flux5( & v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), & v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel ) ENDDO ENDDO ! we must be close to some boundary where we need to reduce the order of the stencil ! specified uses upstream normal wind at boundaries ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end vb = v(i,k,j-1) IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(v(i,k,j)+vb) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i, k, jp1 ) = vel*flux3( & v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end vb = v(i,k,j) IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(vb+v(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i, k, jp1 ) = vel*flux3( & v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ELSE ! Normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_5 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j), & v(i-1,k,j), v(i ,k,j), & v(i+1,k,j), v(i+2,k,j), & vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) & *(v(i,k,j)+v(i-1,k,j)) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), & v(i ,k,j), v(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & *(v(i_end+1,k,j)+v(i_end,k,j)) ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), & v(i ,k,j), v(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF( horz_order == 4 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-2) ) degrade_ye = .false. !--------------- y - advection first ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 !CJM May not work with tiling because defined in terms of domain dims IF(degrade_ys) then j_start = jds+1 j_start_f = j_start+1 ENDIF IF(degrade_ye) then j_end = jde-1 j_end_f = jde-1 ENDIF ! compute fluxes ! specified uses upstream normal wind at boundaries jp0 = 1 jp1 = 2 DO j = j_start, j_end+1 IF ((j == j_start) .and. degrade_ys) THEN DO k = kts,ktf DO i = i_start, i_end vb = v(i,k,j-1) IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(v(i,k,j)+vb) ENDDO ENDDO ELSE IF ((j == j_end+1) .and. degrade_ye) THEN DO k = kts, ktf DO i = i_start, i_end vb = v(i,k,j) IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(vb+v(i,k,j-1)) ENDDO ENDDO ELSE DO k = kts, ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i,k,jp1 ) = vel*flux4( v(i,k,j-2), v(i,k,j-1), & v(i,k,j ), v(i,k,j+1), & vel ) ENDDO ENDDO END IF ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ELSE ! Normal code IF( j > j_start) THEN DO k = kts, ktf DO i = i_start, i_end mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO END IF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = ids+1 i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = ide-2 i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 3rd or 4th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i, k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), & v(i ,k,j), v(i+1,k,j), & vel ) ENDDO ENDDO ! second order flux close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO k=kts,ktf fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) & *(v(i_start,k,j)+v(i_start-1,k,j)) ENDDO ENDIF IF( degrade_xe ) THEN DO k=kts,ktf fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & *(v(i_end+1,k,j)+v(i_end,k,j)) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF( horz_order == 3 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-2) ) degrade_ye = .false. !--------------- y - advection first ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 !CJM May not work with tiling because defined in terms of domain dims IF(degrade_ys) then j_start = jds+1 j_start_f = j_start+1 ENDIF IF(degrade_ye) then j_end = jde-1 j_end_f = jde-1 ENDIF ! compute fluxes ! specified uses upstream normal wind at boundaries jp0 = 1 jp1 = 2 DO j = j_start, j_end+1 IF ((j == j_start) .and. degrade_ys) THEN DO k = kts,ktf DO i = i_start, i_end vb = v(i,k,j-1) IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(v(i,k,j)+vb) ENDDO ENDDO ELSE IF ((j == j_end+1) .and. degrade_ye) THEN DO k = kts, ktf DO i = i_start, i_end vb = v(i,k,j) IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(vb+v(i,k,j-1)) ENDDO ENDDO ELSE DO k = kts, ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i,k,jp1 ) = vel*flux3( v(i,k,j-2), v(i,k,j-1), & v(i,k,j ), v(i,k,j+1), & vel ) ENDDO ENDDO END IF ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ELSE ! Normal code IF( j > j_start) THEN DO k = kts, ktf DO i = i_start, i_end mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO END IF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = ids+1 i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = ide-2 i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 3rd or 4th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i, k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), & v(i ,k,j), v(i+1,k,j), & vel ) ENDDO ENDDO ! second order flux close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO k=kts,ktf fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) & *(v(i_start,k,j)+v(i_start-1,k,j)) ENDDO ENDIF IF( degrade_xe ) THEN DO k=kts,ktf fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & *(v(i_end+1,k,j)+v(i_end,k,j)) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF( horz_order == 2 ) THEN i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte IF ( config_flags%open_ys ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye ) j_end = MIN(jde-1,jte) IF ( specified ) j_start = MAX(jds+2,jts) IF ( specified ) j_end = MIN(jde-2,jte) IF ( config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%polar ) j_end = MIN(jde-1,jte) DO j = j_start, j_end DO k=kts,ktf DO i = i_start, i_end mrdy=msfvy(i,j)*rdy ! ADT eqn 45, 2nd term on RHS tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 & *((rv(i,k,j+1)+rv(i,k,j ))*(v(i,k,j+1)+v(i,k,j )) & -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+v(i,k,j-1))) ENDDO ENDDO ENDDO ! Comments on polar boundary conditions ! tendencies = 0 at poles, and polar points do not contribute at points ! next to poles IF (config_flags%polar) THEN IF (jts == jds) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,jds) = 0. END DO END DO END IF IF (jte == jde) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,jde) = 0. END DO END DO END IF END IF ! specified uses upstream normal wind at boundaries IF ( specified .AND. jts .LE. jds+1 ) THEN j = jds+1 DO k=kts,ktf DO i = i_start, i_end mrdy=msfvy(i,j)*rdy ! ADT eqn 45, 2nd term on RHS vb = v(i,k,j-1) IF (v(i,k,j) .LT. 0.) vb = v(i,k,j) tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 & *((rv(i,k,j+1)+rv(i,k,j ))*(v(i,k,j+1)+v(i,k,j )) & -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+vb)) ENDDO ENDDO ENDIF IF ( specified .AND. jte .GE. jde-1 ) THEN j = jde-1 DO k=kts,ktf DO i = i_start, i_end mrdy=msfvy(i,j)*rdy ! ADT eqn 45, 2nd term on RHS vb = v(i,k,j+1) IF (v(i,k,j) .GT. 0.) vb = v(i,k,j) tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 & *((rv(i,k,j+1)+rv(i,k,j ))*(vb+v(i,k,j )) & -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+v(i,k,j-1))) ENDDO ENDDO ENDIF IF ( .NOT. config_flags%periodic_x ) THEN IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) ENDIF IF ( config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%polar ) j_end = MIN(jde-1,jte) DO j = j_start, j_end DO k=kts,ktf DO i = i_start, i_end mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 & *((ru(i+1,k,j)+ru(i+1,k,j-1))*(v(i+1,k,j)+v(i ,k,j)) & -(ru(i ,k,j)+ru(i ,k,j-1))*(v(i ,k,j)+v(i-1,k,j))) ENDDO ENDDO ENDDO ELSE IF ( horz_order == 0 ) THEN ! Just in case we want to turn horizontal advection off, we can do it ELSE WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: h_order not known ',horz_order CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ENDIF horizontal_order_test ! Comments on polar boundary condition ! Force tendency=0 at NP and SP ! We keep setting this everywhere, but it can't hurt... IF ( config_flags%polar .AND. (jts == jds) ) THEN DO i=its,ite DO k=kts,ktf tendency(i,k,jts)=0. END DO END DO END IF IF ( config_flags%polar .AND. (jte == jde) ) THEN DO i=its,ite DO k=kts,ktf tendency(i,k,jte)=0. END DO END DO END IF ! radiative lateral boundary condition in y for normal velocity (v) IF ( (config_flags%open_ys) .and. jts == jds ) THEN i_start = its i_end = MIN(ite,ide-1) DO i = i_start, i_end DO k = kts, ktf vb = MIN(rv(i,k,jts)-cb*(c1(k)*mut(i,jts)+c2(k)), 0.) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts)) ENDDO ENDDO ENDIF IF ( (config_flags%open_ye) .and. jte == jde ) THEN i_start = its i_end = MIN(ite,ide-1) DO i = i_start, i_end DO k = kts, ktf vb = MAX(rv(i,k,jte)+cb*(c1(k)*mut(i,jte-1)+c2(k)), 0.) tendency(i,k,jte) = tendency(i,k,jte) & - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1)) ENDDO ENDDO ENDIF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges j_start = jts j_end = MIN(jte,jde) jmin = jds jmax = jde-1 IF (config_flags%open_ys) THEN j_start = MAX(jds+1, jts) jmin = jds ENDIF IF (config_flags%open_ye) THEN j_end = MIN(jte,jde-1) jmax = jde-1 ENDIF ! compute x (u) conditions for v, w, or scalar IF( (config_flags%open_xs) .and. (its == ids)) THEN DO j = j_start, j_end mrdx=msfvy(its,j)*rdx ! ADT eqn 45, 1st term on RHS jp = MIN( jmax, j ) jm = MAX( jmin, j-1 ) DO k=kts,ktf uw = 0.5*(ru(its,k,jp)+ru(its,k,jm)) ub = MIN( uw, 0. ) dup = ru(its+1,k,jp)-ru(its,k,jp) dum = ru(its+1,k,jm)-ru(its,k,jm) tendency(its,k,j)=tendency(its,k,j)-mrdx*( & ub*(v_old(its+1,k,j)-v_old(its,k,j)) & +0.5*v(its,k,j)*(dup+dum)) ENDDO ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide) ) THEN DO j = j_start, j_end mrdx=msfvy(ite-1,j)*rdx ! ADT eqn 45, 1st term on RHS jp = MIN( jmax, j ) jm = MAX( jmin, j-1 ) DO k=kts,ktf uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm)) ub = MAX( uw, 0. ) dup = ru(ite,k,jp)-ru(ite-1,k,jp) dum = ru(ite,k,jm)-ru(ite-1,k,jm) ! tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( & ! ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) & ! +0.5*v(ite-1,k,j)* & ! ( ru(ite,k,jp)-ru(ite-1,k,jp) & ! +ru(ite,k,jm)-ru(ite-1,k,jm)) ) tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( & ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) & +0.5*v(ite-1,k,j)*(dup+dum)) ENDDO ENDDO ENDIF !-------------------- vertical advection ! ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w) ! Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my) ! We therefore need to make a correction for advect_v ! since 'my' (map scale factor in y direction) isn't a function of z, ! we can do this using *(my/mx) (see eqn. 45 for example) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte DO i = i_start, i_end vflux(i,kts)=0. vflux(i,kte)=0. ENDDO ! Polar boundary conditions are like open or specified ! We don't want to calculate vertical v tendencies at the N or S pole IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte) vert_order_test : IF (vert_order == 6) THEN DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux6( & v(i,k-3,j), v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), v(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux4( & v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), -vel ) k = ktf-1 vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux4( & v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), -vel ) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end ! We are calculating vertical fluxes on v points, ! so we must mean msf_v_x/y variables tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS ENDDO ENDDO ENDDO ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux5( & v(i,k-3,j), v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), v(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux3( & v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), -vel ) k = ktf-1 vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux3( & v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), -vel ) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end ! We are calculating vertical fluxes on v points, ! so we must mean msf_v_x/y variables tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS ENDDO ENDDO ENDDO ELSE IF (vert_order == 4) THEN DO j = j_start, j_end DO k=kts+2,ktf-1 DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux4( & v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end ! We are calculating vertical fluxes on v points, ! so we must mean msf_v_x/y variables tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS ENDDO ENDDO ENDDO ELSE IF (vert_order == 3) THEN DO j = j_start, j_end DO k=kts+2,ktf-1 DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux3( & v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end ! We are calculating vertical fluxes on v points, ! so we must mean msf_v_x/y variables tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS ENDDO ENDDO ENDDO ELSE IF (vert_order == 2) THEN DO j = j_start, j_end DO k=kts+1,ktf DO i = i_start, i_end vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) ENDDO ENDDO DO k=kts,ktf DO i = i_start, i_end ! We are calculating vertical fluxes on v points, ! so we must mean msf_v_x/y variables tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS ENDDO ENDDO ENDDO ELSE WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: v_order not known ',vert_order CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ENDIF vert_order_test END SUBROUTINE advect_v !------------------------------------------------------------------- #endif SUBROUTINE advect_scalar ( field, field_old, tendency, & ru, rv, rom, & c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & field_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw REAL , DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & +(q_ip2+q_im3) )/60.0 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 LOGICAL :: specified specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. ! set order for the advection schemes ktf=MIN(kte,kde-1) horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order ! begin with horizontal flux divergence ! here is the choice of flux operators horizontal_order_test : IF( horz_order == 6 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_6 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) fqy( i, k, jp1 ) = vel*flux6( & field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end fqy(i,k, jp1) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) fqy( i, k, jp1 ) = vel*flux4( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) fqy( i, k, jp1) = vel*flux4( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) ENDDO ENDDO ENDIF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_6 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = ru(i,k,j) fqx( i,k ) = vel*flux6( field(i-3,k,j), field(i-2,k,j), & field(i-1,k,j), field(i ,k,j), & field(i+1,k,j), field(i+2,k,j), & vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf fqx(i,k) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf vel = ru(i,k,j) fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) ENDDO END IF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf fqx(i,k) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf vel = ru(i,k,j) fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF( horz_order == 5 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) fqy( i, k, jp1 ) = vel*flux5( & field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end fqy(i,k, jp1) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) fqy( i, k, jp1 ) = vel*flux3( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) fqy( i, k, jp1) = vel*flux3( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) ENDDO ENDDO ENDIF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_5 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = ru(i,k,j) fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & field(i-1,k,j), field(i ,k,j), & field(i+1,k,j), field(i+2,k,j), & vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf fqx(i,k) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf vel = ru(i,k,j) fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) ENDDO END IF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf fqx(i,k) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf vel = ru(i,k,j) fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF( horz_order == 4 ) THEN degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. ! begin flux computations ! start with x flux divergence ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = ids+1 i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = ide-2 i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 3rd or 4th order flux DO k=kts,ktf DO i = i_start_f, i_end_f fqx( i, k) = ru(i,k,j)*flux4( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & ru(i,k,j) ) ENDDO ENDDO ! second order flux close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO k=kts,ktf fqx(i_start, k) = 0.5*ru(i_start,k,j) & *(field(i_start,k,j)+field(i_start-1,k,j)) ENDDO ENDIF IF( degrade_xe ) THEN DO k=kts,ktf fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j) & *(field(i_end+1,k,j)+field(i_end,k,j)) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! next -> y flux divergence calculation i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = jds+1 j_start_f = j_start+1 ENDIF IF(degrade_ye) then j_end = jde-2 j_end_f = jde-2 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) jp1 = 2 jp0 = 1 DO j = j_start, j_end+1 IF ((j < j_start_f) .and. degrade_ys) THEN DO k = kts, ktf DO i = i_start, i_end fqy(i,k,jp1) = 0.5*rv(i,k,j_start) & *(field(i,k,j_start)+field(i,k,j_start-1)) ENDDO ENDDO ELSE IF ((j > j_end_f) .and. degrade_ye) THEN DO k = kts, ktf DO i = i_start, i_end ! Assumes j>j_end_f is ONLY j_end+1 ... ! fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1) & ! *(field(i,k,j_end+1)+field(i,k,j_end)) fqy(i,k,jp1) = 0.5*rv(i,k,j) & *(field(i,k,j)+field(i,k,j-1)) ENDDO ENDDO ELSE ! 3rd or 4th order flux DO k = kts, ktf DO i = i_start, i_end fqy( i, k, jp1 ) = rv(i,k,j)*flux4( field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), & rv(i,k,j) ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF ( j > j_start ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO END IF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO ELSE IF( horz_order == 3 ) THEN degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. ! begin flux computations ! start with x flux divergence ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = ids+1 i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = ide-2 i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 3rd or 4th order flux DO k=kts,ktf DO i = i_start_f, i_end_f fqx( i, k) = ru(i,k,j)*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & ru(i,k,j) ) ENDDO ENDDO ! second order flux close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO k=kts,ktf fqx(i_start, k) = 0.5*ru(i_start,k,j) & *(field(i_start,k,j)+field(i_start-1,k,j)) ENDDO ENDIF IF( degrade_xe ) THEN DO k=kts,ktf fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j) & *(field(i_end+1,k,j)+field(i_end,k,j)) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! next -> y flux divergence calculation i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = jds+1 j_start_f = j_start+1 ENDIF IF(degrade_ye) then j_end = jde-2 j_end_f = jde-2 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) jp1 = 2 jp0 = 1 DO j = j_start, j_end+1 IF ((j < j_start_f) .and. degrade_ys) THEN DO k = kts, ktf DO i = i_start, i_end fqy(i,k,jp1) = 0.5*rv(i,k,j_start) & *(field(i,k,j_start)+field(i,k,j_start-1)) ENDDO ENDDO ELSE IF ((j > j_end_f) .and. degrade_ye) THEN DO k = kts, ktf DO i = i_start, i_end ! Assumes j>j_end_f is ONLY j_end+1 ... ! fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1) & ! *(field(i,k,j_end+1)+field(i,k,j_end)) fqy(i,k,jp1) = 0.5*rv(i,k,j) & *(field(i,k,j)+field(i,k,j-1)) ENDDO ENDDO ELSE ! 3rd or 4th order flux DO k = kts, ktf DO i = i_start, i_end fqy( i, k, jp1 ) = rv(i,k,j)*flux3( field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), & rv(i,k,j) ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF ( j > j_start ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO END IF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO ELSE IF( horz_order == 2 ) THEN i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) IF ( .NOT. config_flags%periodic_x ) THEN IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) ENDIF DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 & *(ru(i+1,k,j)*(field(i+1,k,j)+field(i ,k,j)) & -ru(i ,k,j)*(field(i ,k,j)+field(i-1,k,j))) ENDDO ENDDO ENDDO i_start = its i_end = MIN(ite,ide-1) ! Polar boundary conditions are like open or specified IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-2,jte) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end mrdy=msftx(i,j)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 & *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j )) & -rv(i,k,j )*(field(i,k,j )+field(i,k,j-1))) ENDDO ENDDO ENDDO ! Polar boundary condtions ! These won't be covered in the loop above... IF (config_flags%polar) THEN IF (jts == jds) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,jds)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 & *rv(i,k,jds+1)*(field(i,k,jds+1)+field(i,k,jds)) END DO END DO END IF IF (jte == jde) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 & *rv(i,k,jde-1)*(field(i,k,jde-1)+field(i,k,jde-2)) END DO END DO END IF END IF ELSE IF ( horz_order == 0 ) THEN ! Just in case we want to turn horizontal advection off, we can do it ELSE WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_6a, h_order not known ',horz_order CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ENDIF horizontal_order_test ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! compute x (u) conditions for v, w, or scalar IF( (config_flags%open_xs) .and. (its == ids) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*( field_old(its+1,k,j) & - field_old(its ,k,j) ) + & field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*( field_old(i_end ,k,j) & - field_old(i_end-1,k,j) ) + & field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ys) .and. (jts == jds) ) THEN DO i = i_start, i_end DO k = kts, ktf vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*( field_old(i,k,jts+1) & - field_old(i,k,jts ) ) + & field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde)) THEN DO i = i_start, i_end DO k = kts, ktf vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*( field_old(i,k,j_end ) & - field_old(i,k,j_end-1) ) + & field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) & ) ENDDO ENDDO ENDIF !-------------------- vertical advection ! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my) ! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my) ! So we don't need to make a correction for advect_scalar i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) DO i = i_start, i_end vflux(i,kts)=0. vflux(i,kte)=0. ENDDO vert_order_test : IF (vert_order == 6) THEN DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end vel=rom(i,k,j) vflux(i,k) = vel*flux6( & field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) k = kts+2 vel=rom(i,k,j) vflux(i,k) = vel*flux4( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) k = ktf-1 vel=rom(i,k,j) vflux(i,k) = vel*flux4( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) k=ktf vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end vel=rom(i,k,j) vflux(i,k) = vel*flux5( & field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) k = kts+2 vel=rom(i,k,j) vflux(i,k) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) k = ktf-1 vel=rom(i,k,j) vflux(i,k) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) k=ktf vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE IF (vert_order == 4) THEN DO j = j_start, j_end DO k=kts+2,ktf-1 DO i = i_start, i_end vel=rom(i,k,j) vflux(i,k) = vel*flux4( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) k=ktf vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE IF (vert_order == 3) THEN DO j = j_start, j_end DO k=kts+2,ktf-1 DO i = i_start, i_end vel=rom(i,k,j) vflux(i,k) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) k=ktf vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE IF (vert_order == 2) THEN DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) ENDDO ENDDO DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO ELSE WRITE (wrf_err_message,*) ' advect_scalar_6a, v_order not known ',vert_order CALL wrf_error_fatal ( wrf_err_message ) ENDIF vert_order_test END SUBROUTINE advect_scalar #if ( ! defined(ADVECT_KERNEL) ) !--------------------------------------------------------------------------------- SUBROUTINE advect_w ( w, w_old, tendency, & ru, rv, rom, & c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzu, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: w, & w_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzu, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw REAL , DIMENSION(its:ite, kts:kte) :: vflux INTEGER :: horz_order, vert_order REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & +(q_ip2+q_im3) )/60.0 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 LOGICAL :: specified specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. ! set order for the advection scheme ktf=MIN(kte,kde-1) horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order ! here is the choice of flux operators ! begin with horizontal flux divergence horizontal_order_test : IF( horz_order == 6 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_6 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux6( & w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux6( & w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts+1,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux4( & w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux4( & w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts+1,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux4( & w(i,k,j-2),w(i,k,j-1), & w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux4( & w(i,k,j-2),w(i,k,j-1), & w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDIF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_6 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts+1,ktf DO i = i_start_f, i_end_f vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j), & w(i-1,k,j), w(i ,k,j), & w(i+1,k,j), w(i+2,k,j), & vel ) ENDDO ENDDO k = ktf+1 DO i = i_start_f, i_end_f vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j), & w(i-1,k,j), w(i ,k,j), & w(i+1,k,j), w(i+2,k,j), & vel ) ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts+1,ktf fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDDO k = ktf+1 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDIF IF(i == ids+2) THEN ! third order DO k=kts+1,ktf vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO k = ktf+1 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) END IF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts+1,ktf fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDDO k = ktf+1 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts+1,ktf vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO k = ktf+1 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDIF ENDDO ENDIF ! x flux-divergence into tendency DO k=kts+1,ktf+1 DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF (horz_order == 5 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux5( & w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux5( & w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts+1,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux3( & w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux3( & w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts+1,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux3( & w(i,k,j-2),w(i,k,j-1), & w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux3( & w(i,k,j-2),w(i,k,j-1), & w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDIF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_5 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts+1,ktf DO i = i_start_f, i_end_f vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), & w(i-1,k,j), w(i ,k,j), & w(i+1,k,j), w(i+2,k,j), & vel ) ENDDO ENDDO k = ktf+1 DO i = i_start_f, i_end_f vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), & w(i-1,k,j), w(i ,k,j), & w(i+1,k,j), w(i+2,k,j), & vel ) ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts+1,ktf fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDDO k = ktf+1 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDIF IF(i == ids+2) THEN ! third order DO k=kts+1,ktf vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO k = ktf+1 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) END IF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts+1,ktf fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDDO k = ktf+1 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts+1,ktf vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO k = ktf+1 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDIF ENDDO ENDIF ! x flux-divergence into tendency DO k=kts+1,ktf+1 DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ELSE IF ( horz_order == 4 ) THEN degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. ! begin flux computations ! start with x flux divergence !--------------- ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = ids+1 i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = ide-2 i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end DO k=kts+1,ktf DO i = i_start_f, i_end_f vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO ENDDO k = ktf+1 DO i = i_start_f, i_end_f vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO ! second order flux close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO k=kts+1,ktf fqx(i_start, k) = & 0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j)) & *(w(i_start,k,j)+w(i_start-1,k,j)) ENDDO k = ktf+1 fqx(i_start, k) = & 0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j)) & *(w(i_start,k,j)+w(i_start-1,k,j)) ENDIF IF( degrade_xe ) THEN DO k=kts+1,ktf fqx(i_end+1, k) = & 0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j)) & *(w(i_end+1,k,j)+w(i_end,k,j)) ENDDO k = ktf+1 fqx(i_end+1, k) = & 0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j)) & *(w(i_end+1,k,j)+w(i_end,k,j)) ENDIF ! x flux-divergence into tendency DO k=kts+1,ktf+1 DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! next -> y flux divergence calculation i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = jds+1 j_start_f = j_start+1 ENDIF IF(degrade_ye) then j_end = jde-2 j_end_f = jde-2 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) jp1 = 2 jp0 = 1 DO j = j_start, j_end+1 IF ((j < j_start_f) .and. degrade_ys) THEN DO k = kts+1, ktf DO i = i_start, i_end fqy(i, k, jp1) = & 0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start)) & *(w(i,k,j_start)+w(i,k,j_start-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end fqy(i, k, jp1) = & 0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start)) & *(w(i,k,j_start)+w(i,k,j_start-1)) ENDDO ELSE IF ((j > j_end_f) .and. degrade_ye) THEN DO k = kts+1, ktf DO i = i_start, i_end ! Assumes j>j_end_f is ONLY j_end+1 ... ! fqy(i, k, jp1) = & ! 0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1)) & ! *(w(i,k,j_end+1)+w(i,k,j_end)) fqy(i, k, jp1) = & 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)) & *(w(i,k,j)+w(i,k,j-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end ! Assumes j>j_end_f is ONLY j_end+1 ... ! fqy(i, k, jp1) = & ! 0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1)) & ! *(w(i,k,j_end+1)+w(i,k,j_end)) fqy(i, k, jp1) = & 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)) & *(w(i,k,j)+w(i,k,j-1)) ENDDO ELSE ! 3rd or 4th order flux DO k = kts+1, ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1), & w(i,k,j ), w(i,k,j+1), & vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1), & w(i,k,j ), w(i,k,j+1), & vel ) ENDDO END IF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF( j > j_start ) THEN DO k = kts+1, ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO END IF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO ELSE IF ( horz_order == 3 ) THEN degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. ! begin flux computations ! start with x flux divergence !--------------- ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = ids+1 i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = ide-2 i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end DO k=kts+1,ktf DO i = i_start_f, i_end_f vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO ENDDO k = ktf+1 DO i = i_start_f, i_end_f vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO ! second order flux close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO k=kts+1,ktf fqx(i_start, k) = & 0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j)) & *(w(i_start,k,j)+w(i_start-1,k,j)) ENDDO k = ktf+1 fqx(i_start, k) = & 0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j)) & *(w(i_start,k,j)+w(i_start-1,k,j)) ENDIF IF( degrade_xe ) THEN DO k=kts+1,ktf fqx(i_end+1, k) = & 0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j)) & *(w(i_end+1,k,j)+w(i_end,k,j)) ENDDO k = ktf+1 fqx(i_end+1, k) = & 0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j)) & *(w(i_end+1,k,j)+w(i_end,k,j)) ENDIF ! x flux-divergence into tendency DO k=kts+1,ktf+1 DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! next -> y flux divergence calculation i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = jds+1 j_start_f = j_start+1 ENDIF IF(degrade_ye) then j_end = jde-2 j_end_f = jde-2 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) jp1 = 2 jp0 = 1 DO j = j_start, j_end+1 IF ((j < j_start_f) .and. degrade_ys) THEN DO k = kts+1, ktf DO i = i_start, i_end fqy(i, k, jp1) = & 0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start)) & *(w(i,k,j_start)+w(i,k,j_start-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end fqy(i, k, jp1) = & 0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start)) & *(w(i,k,j_start)+w(i,k,j_start-1)) ENDDO ELSE IF ((j > j_end_f) .and. degrade_ye) THEN DO k = kts+1, ktf DO i = i_start, i_end ! Assumes j>j_end_f is ONLY j_end+1 ... ! fqy(i, k, jp1) = & ! 0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1)) & ! *(w(i,k,j_end+1)+w(i,k,j_end)) fqy(i, k, jp1) = & 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)) & *(w(i,k,j)+w(i,k,j-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end ! Assumes j>j_end_f is ONLY j_end+1 ... ! fqy(i, k, jp1) = & ! 0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1)) & ! *(w(i,k,j_end+1)+w(i,k,j_end)) fqy(i, k, jp1) = & 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)) & *(w(i,k,j)+w(i,k,j-1)) ENDDO ELSE ! 3rd or 4th order flux DO k = kts+1, ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1), & w(i,k,j ), w(i,k,j+1), & vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1), & w(i,k,j ), w(i,k,j+1), & vel ) ENDDO END IF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF( j > j_start ) THEN DO k = kts+1, ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO END IF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO ELSE IF (horz_order == 2 ) THEN i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) IF ( .NOT. config_flags%periodic_x ) THEN IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) ENDIF DO j = j_start, j_end DO k=kts+1,ktf DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 & *((fzm(k)*ru(i+1,k,j)+fzp(k)*ru(i+1,k-1,j)) & *(w(i+1,k,j)+w(i,k,j)) & -(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & *(w(i,k,j)+w(i-1,k,j))) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 & *(((2.-fzm(k-1))*ru(i+1,k-1,j)-fzp(k-1)*ru(i+1,k-2,j)) & *(w(i+1,k,j)+w(i,k,j)) & -((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & *(w(i,k,j)+w(i-1,k,j))) ENDDO ENDDO i_start = its i_end = MIN(ite,ide-1) ! Polar boundary conditions are like open or specified IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-2,jte) DO j = j_start, j_end DO k=kts+1,ktf DO i = i_start, i_end mrdy=msftx(i,j)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 & *((fzm(k)*rv(i,k,j+1)+fzp(k)*rv(i,k-1,j+1))* & (w(i,k,j+1)+w(i,k,j)) & -(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)) & *(w(i,k,j)+w(i,k,j-1))) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end mrdy=msftx(i,j)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 & *(((2.-fzm(k-1))*rv(i,k-1,j+1)-fzp(k-1)*rv(i,k-2,j+1))* & (w(i,k,j+1)+w(i,k,j)) & -((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)) & *(w(i,k,j)+w(i,k,j-1))) ENDDO ENDDO ! Polar boundary condition ... not covered in above j-loop IF (config_flags%polar) THEN IF (jts == jds) THEN DO k=kts+1,ktf DO i = i_start, i_end mrdy=msftx(i,jds)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 & *((fzm(k)*rv(i,k,jds+1)+fzp(k)*rv(i,k-1,jds+1))* & (w(i,k,jds+1)+w(i,k,jds))) END DO END DO k = ktf+1 DO i = i_start, i_end mrdy=msftx(i,jds)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 & *((2.-fzm(k-1))*rv(i,k-1,jds+1)-fzp(k-1)*rv(i,k-2,jds+1))* & (w(i,k,jds+1)+w(i,k,jds)) ENDDO END IF IF (jte == jde) THEN DO k=kts+1,ktf DO i = i_start, i_end mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 & *((fzm(k)*rv(i,k,jde-1)+fzp(k)*rv(i,k-1,jde-1))* & (w(i,k,jde-1)+w(i,k,jde-2))) END DO END DO k = ktf+1 DO i = i_start, i_end mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 & *((2.-fzm(k-1))*rv(i,k-1,jde-1)-fzp(k-1)*rv(i,k-2,jde-1)) & *(w(i,k,jde-1)+w(i,k,jde-2)) ENDDO END IF END IF ELSE IF ( horz_order == 0 ) THEN ! Just in case we want to turn horizontal advection off, we can do it ELSE WRITE ( wrf_err_message ,*) ' advect_w_6a, h_order not known ',horz_order CALL wrf_error_fatal ( wrf_err_message ) ENDIF horizontal_order_test ! pick up the the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) IF( (config_flags%open_xs) .and. (its == ids)) THEN DO j = j_start, j_end DO k = kts+1, ktf uw = 0.5*(fzm(k)*(ru(its,k ,j)+ru(its+1,k ,j)) + & fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j)) ) ub = MIN( uw, 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*(w_old(its+1,k,j) - w_old(its,k,j)) + & w(its,k,j)*( & fzm(k)*(ru(its+1,k ,j)-ru(its,k ,j))+ & fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j))) & ) ENDDO ENDDO k = ktf+1 DO j = j_start, j_end uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j)) & -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j)) ) ub = MIN( uw, 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*(w_old(its+1,k,j) - w_old(its,k,j)) + & w(its,k,j)*( & (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))- & fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j))) & ) ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide)) THEN DO j = j_start, j_end DO k = kts+1, ktf uw = 0.5*(fzm(k)*(ru(ite-1,k ,j)+ru(ite,k ,j)) + & fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j)) ) ub = MAX( uw, 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) + & w(i_end,k,j)*( & fzm(k)*(ru(ite,k ,j)-ru(ite-1,k ,j)) + & fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j))) & ) ENDDO ENDDO k = ktf+1 DO j = j_start, j_end uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j)) & -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j)) ) ub = MAX( uw, 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) + & w(i_end,k,j)*( & (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) - & fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j))) & ) ENDDO ENDIF IF( (config_flags%open_ys) .and. (jts == jds)) THEN DO i = i_start, i_end DO k = kts+1, ktf vw = 0.5*( fzm(k)*(rv(i,k ,jts)+rv(i,k ,jts+1)) + & fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1)) ) vb = MIN( vw, 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) + & w(i,k,jts)*( & fzm(k)*(rv(i,k ,jts+1)-rv(i,k ,jts))+ & fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts))) & ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1)) & -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1)) ) vb = MIN( vw, 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) + & w(i,k,jts)*( & (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))- & fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts))) & ) ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde) ) THEN DO i = i_start, i_end DO k = kts+1, ktf vw = 0.5*( fzm(k)*(rv(i,k ,jte-1)+rv(i,k ,jte)) + & fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte)) ) vb = MAX( vw, 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) + & w(i,k,j_end)*( & fzm(k)*(rv(i,k ,jte)-rv(i,k ,jte-1))+ & fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1))) & ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte)) & -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte)) ) vb = MAX( vw, 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) + & w(i,k,j_end)*( & (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))- & fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1))) & ) ENDDO ENDIF !-------------------- vertical advection ! ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my) ! Here we have: - partial d/dz (w*rom) = - partial d/dz (w rho w / my) ! Therefore we don't need to make a correction for advect_w i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) DO i = i_start, i_end vflux(i,kts)=0. vflux(i,kte)=0. ENDDO vert_order_test : IF (vert_order == 6) THEN DO j = j_start, j_end DO k=kts+3,ktf-1 DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux6( & w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux4( & w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), -vel ) k = ktf vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux4( & w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), -vel ) k=ktf+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) ENDDO DO k=kts+1,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ! pick up flux contribution for w at the lid. wcs, 13 march 2004 k = ktf+1 DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) ENDDO ENDDO ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO k=kts+3,ktf-1 DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux5( & w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux3( & w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), -vel ) k = ktf vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux3( & w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), -vel ) k=ktf+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) ENDDO DO k=kts+1,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf+1 DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) ENDDO ENDDO ELSE IF (vert_order == 4) THEN DO j = j_start, j_end DO k=kts+2,ktf DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux4( & w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) k=ktf+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) ENDDO DO k=kts+1,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf+1 DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) ENDDO ENDDO ELSE IF (vert_order == 3) THEN DO j = j_start, j_end DO k=kts+2,ktf !DEC$ vector always DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux3( & w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) k=ktf+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) ENDDO DO k=kts+1,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf+1 DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) ENDDO ENDDO ELSE IF (vert_order == 2) THEN DO j = j_start, j_end DO k=kts+1,ktf+1 DO i = i_start, i_end vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) ENDDO ENDDO DO k=kts+1,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf+1 DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) ENDDO ENDDO ELSE WRITE (wrf_err_message ,*) ' advect_w, v_order not known ',vert_order CALL wrf_error_fatal ( wrf_err_message ) ENDIF vert_order_test END SUBROUTINE advect_w !---------------------------------------------------------------- #endif SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & h_tendency, z_tendency, & ru, rv, rom, & c1, c2, & mut, mub, mu_old, & time_step, config_flags, & tenddec, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! this is a first cut at a positive definite advection option ! for scalars in WRF. This version is memory intensive -> ! we save 3d arrays of x, y and z both high and low order fluxes ! (six in all). Alternatively, we could sweep in a direction ! and lower the cost considerably. ! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order ! fluxes initially ! WCS, 3 December 2002, 24 February 2003 IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags LOGICAL , INTENT(IN ) :: tenddec ! tendency flag INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & field_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT( OUT) :: h_tendency, z_tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy, & dt INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw, mu ! storage for high and low order fluxes REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqx, fqy, fqz REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqxl, fqyl, fqzl INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp REAL,DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: flux_out, ph_low REAL :: scale !REAL :: flux_out, ph_low, scale REAL, PARAMETER :: eps=1.e-20 ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6, flux_upwind REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr flux4(q_im2, q_im1, q_i, q_ip1, ua) = & (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2) flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) & +(1./60.)*(q_ip2+q_im3) flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*(1./60.)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 & +0.5*max(-1.0,(cr-abs(cr)))*q_i ! flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & ! +0.5*(1.-sign(1.,cr))*q_i ! flux_upwind(q_im1, q_i, cr ) = 0. REAL :: dx,dy,dz LOGICAL, PARAMETER :: pd_limit = .true. ! set order for the advection schemes ! write(6,*) ' in pd advection routine ' ! Empty arrays just in case: IF (config_flags%polar) THEN fqx(:,:,:) = 0. fqy(:,:,:) = 0. fqz(:,:,:) = 0. fqxl(:,:,:) = 0. fqyl(:,:,:) = 0. fqzl(:,:,:) = 0. END IF ktf=MIN(kte,kde-1) horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. ! begin with horizontal flux divergence ! here is the choice of flux operators horizontal_order_test : IF( horz_order == 6 ) THEN IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-4) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first !-- y flux compute; these bounds are for periodic and sym b.c. ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 j_start_f = j_start j_end_f = j_end+1 !-- modify loop bounds if open or specified ! IF(degrade_xs) i_start = MAX(its-1,ids-1) ! IF(degrade_xe) i_end = MIN(ite+1,ide-2) IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) then j_start = MAX(jts-1,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte+1,jde-2) j_end_f = jde-3 ENDIF ! compute fluxes, 6th order j_loop_y_flux_6 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux6( & field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux4( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i, k, j ) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j) = vel*flux4( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ENDIF ENDDO j_loop_y_flux_6 ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 i_start_f = i_start i_end_f = i_end+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- modify loop bounds for open and specified b.c ! IF(degrade_ys) j_start = MAX(jts-1,jds+1) ! IF(degrade_ye) j_end = MIN(jte+1,jde-2) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) IF(degrade_xs) then i_start = MAX(ids+1,its-1) i_start_f = ids+3 ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite+1) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th order flux DO k=kts,ktf DO i = i_start_f, i_end_f dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux6( field(i-3,k,j), field(i-2,k,j), & field(i-1,k,j), field(i ,k,j), & field(i+1,k,j), field(i+2,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j)/mu cr = vel*dt/dx fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF IF(i == ids+2) THEN ! fourth order DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF IF( i == ide-2 ) THEN ! fourth order flux one in from the boundary DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDDO ENDIF ENDDO ! enddo for outer J loop !--- end of 6th order horizontal flux calculation ELSE IF( horz_order == 5 ) THEN IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-4) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first !-- y flux compute; these bounds are for periodic and sym b.c. ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 j_start_f = j_start j_end_f = j_end+1 !-- modify loop bounds if open or specified ! IF(degrade_xs) i_start = MAX(its-1,ids-1) ! IF(degrade_xe) i_end = MIN(ite+1,ide-2) IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) then j_start = MAX(jts-1,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte+1,jde-2) j_end_f = jde-3 ENDIF ! compute fluxes, 5th order j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux5( & field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux3( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i, k, j ) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j) = vel*flux3( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ENDIF ENDDO j_loop_y_flux_5 ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 i_start_f = i_start i_end_f = i_end+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- modify loop bounds for open and specified b.c ! IF(degrade_ys) j_start = MAX(jts-1,jds+1) ! IF(degrade_ye) j_end = MIN(jte+1,jde-2) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) IF(degrade_xs) then i_start = MAX(ids+1,its-1) i_start_f = ids+3 ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite+1) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th order flux DO k=kts,ktf DO i = i_start_f, i_end_f dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & field(i-1,k,j), field(i ,k,j), & field(i+1,k,j), field(i+2,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j)/mu cr = vel*dt/dx fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDDO ENDIF ENDDO ! enddo for outer J loop !--- end of 5th order horizontal flux calculation ELSE IF( horz_order == 4 ) THEN IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+1) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+1) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-2) ) degrade_ye = .false. !--------------- y - advection first !-- y flux compute; these bounds are for periodic and sym b.c. ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 j_start_f = j_start j_end_f = j_end+1 !-- modify loop bounds if open or specified IF(degrade_xs) i_start = its IF(degrade_xe) i_end = MIN(ite,ide-1) IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+2 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-2 ENDIF ! compute fluxes, 4th order j_loop_y_flux_4 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux4( field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i, k, j ) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ENDIF ENDDO j_loop_y_flux_4 ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 i_start_f = i_start i_end_f = i_end+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- modify loop bounds for open and specified b.c IF(degrade_ys) j_start = jts IF(degrade_ye) j_end = MIN(jte,jde-1) IF(degrade_xs) then i_start = MAX(ids+1,its) i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 4th order flux DO k=kts,ktf DO i = i_start_f, i_end_f dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN IF( i_start == ids+1 ) THEN ! second order flux next to the boundary i = ids+1 DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j)/mu cr = vel*dt/dx fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDIF IF( degrade_xe ) THEN IF( i_end == ide-2 ) THEN ! second order flux next to the boundary i = ide-1 DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDIF ENDDO ! enddo for outer J loop !--- end of 4th order horizontal flux calculation ELSE IF( horz_order == 3 ) THEN IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+2) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-1) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+2) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-1) ) degrade_ye = .false. !--------------- y - advection first !-- y flux compute; these bounds are for periodic and sym b.c. ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 j_start_f = j_start j_end_f = j_end+1 !-- modify loop bounds if open or specified IF(degrade_xs) i_start = its IF(degrade_xe) i_end = MIN(ite,ide-1) IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+2 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-2 ENDIF ! compute fluxes, 3rd order j_loop_y_flux_3 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux3( field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i, k, j ) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ENDIF ENDDO j_loop_y_flux_3 ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 i_start_f = i_start i_end_f = i_end+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- modify loop bounds for open and specified b.c IF(degrade_ys) j_start = jts IF(degrade_ye) j_end = MIN(jte,jde-1) IF(degrade_xs) then i_start = MAX(ids+1,its) i_start_f = i_start+1 ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 4th order flux DO k=kts,ktf DO i = i_start_f, i_end_f dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN IF( i_start == ids+1 ) THEN ! second order flux next to the boundary i = ids+1 DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j)/mu cr = vel*dt/dx fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDIF IF( degrade_xe ) THEN IF( i_end == ide-2 ) THEN ! second order flux next to the boundary i = ide-1 DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDIF ENDDO ! enddo for outer J loop !--- end of 3rd order horizontal flux calculation ELSE IF( horz_order == 2 ) THEN IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+1) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+1) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-2) ) degrade_ye = .false. !-- y flux compute; these bounds are for periodic and sym b.c. ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- modify loop bounds if open or specified IF(degrade_xs) i_start = its IF(degrade_xe) i_end = MIN(ite,ide-1) IF(degrade_ys) j_start = MAX(jts,jds+1) IF(degrade_ye) j_end = MIN(jte,jde-2) ! compute fluxes, 2nd order, y flux DO j = j_start, j_end+1 DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ENDDO ! next, x flux DO j = j_start, j_end DO k=kts,ktf DO i = i_start, i_end+1 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = 0.5*ru(i,k,j)* & (field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDDO ENDDO !--- end of 2nd order horizontal flux calculation ELSE WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ENDIF horizontal_order_test ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! compute x (u) conditions for v, w, or scalar IF( (config_flags%open_xs) .and. (its == ids) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*( field_old(its+1,k,j) & - field_old(its ,k,j) ) + & field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*( field_old(i_end ,k,j) & - field_old(i_end-1,k,j) ) + & field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ys) .and. (jts == jds) ) THEN DO i = i_start, i_end DO k = kts, ktf vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*( field_old(i,k,jts+1) & - field_old(i,k,jts ) ) + & field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde)) THEN DO i = i_start, i_end DO k = kts, ktf vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*( field_old(i,k,j_end ) & - field_old(i,k,j_end-1) ) + & field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) & ) ENDDO ENDDO ENDIF IF( (config_flags%polar) .and. (jts == jds) ) THEN ! Assuming rv(i,k,jds) = 0. DO i = i_start, i_end DO k = kts, ktf vb = MIN( 0.5*rv(i,k,jts+1), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*( field_old(i,k,jts+1) & - field_old(i,k,jts ) ) + & field(i,k,jts)*rv(i,k,jts+1) & ) ENDDO ENDDO ENDIF IF( (config_flags%polar) .and. (jte == jde)) THEN ! Assuming rv(i,k,jde) = 0. DO i = i_start, i_end DO k = kts, ktf vb = MAX( 0.5*rv(i,k,jte-1), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*( field_old(i,k,j_end ) & - field_old(i,k,j_end-1) ) + & field(i,k,j_end)*(-rv(i,k,jte-1)) & ) ENDDO ENDDO ENDIF !-------------------- vertical advection !-- loop bounds for periodic or sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- loop bounds for open or specified conditions IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) vert_order_test : IF (vert_order == 6) THEN DO j = j_start, j_end DO i = i_start, i_end fqz(i,1,j) = 0. fqzl(i,1,j) = 0. fqz(i,kde,j) = 0. fqzl(i,kde,j) = 0. ENDDO DO k=kts+3,ktf-2 DO i = i_start, i_end dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux6( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO DO i = i_start, i_end k=kts+1 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux4( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux4( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO i = i_start, i_end fqz(i,1,j) = 0. fqzl(i,1,j) = 0. fqz(i,kde,j) = 0. fqzl(i,kde,j) = 0. ENDDO DO k=kts+3,ktf-2 DO i = i_start, i_end dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO DO i = i_start, i_end k=kts+1 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO ELSE IF (vert_order == 4) THEN DO j = j_start, j_end DO i = i_start, i_end fqz(i,1,j) = 0. fqzl(i,1,j) = 0. fqz(i,kde,j) = 0. fqzl(i,kde,j) = 0. ENDDO DO k=kts+2,ktf-1 DO i = i_start, i_end dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux4( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO DO i = i_start, i_end k=kts+1 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO ELSE IF (vert_order == 3) THEN DO j = j_start, j_end DO i = i_start, i_end fqz(i,1,j) = 0. fqzl(i,1,j) = 0. fqz(i,kde,j) = 0. fqzl(i,kde,j) = 0. ENDDO DO k=kts+2,ktf-1 !DEC$ vector always DO i = i_start, i_end dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO DO i = i_start, i_end k=kts+1 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO ELSE IF (vert_order == 2) THEN DO j = j_start, j_end DO i = i_start, i_end fqz(i,1,j) = 0. fqzl(i,1,j) = 0. fqz(i,kde,j) = 0. fqzl(i,kde,j) = 0. ENDDO DO k=kts+1,ktf DO i = i_start, i_end dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO ENDDO ELSE WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order CALL wrf_error_fatal ( wrf_err_message ) ENDIF vert_order_test IF (pd_limit) THEN ! positive definite filter i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- loop bounds for open or specified conditions IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) IF(config_flags%specified .or. config_flags%nested) THEN IF (degrade_xs) i_start = MAX(its-1,ids+1) IF (degrade_xe) i_end = MIN(ite+1,ide-2) IF (degrade_ys) j_start = MAX(jts-1,jds+1) IF (degrade_ye) j_end = MIN(jte+1,jde-2) END IF IF(config_flags%open_xs) THEN IF (degrade_xs) i_start = MAX(its-1,ids+1) END IF IF(config_flags%open_xe) THEN IF (degrade_xe) i_end = MIN(ite+1,ide-2) END IF IF(config_flags%open_ys) THEN IF (degrade_ys) j_start = MAX(jts-1,jds+1) END IF IF(config_flags%open_ye) THEN IF (degrade_ye) j_end = MIN(jte+1,jde-2) END IF ! ADT note: ! We don't want to change j_start and j_end ! for polar BC's since we want to calculate ! fluxes for directions other than y at the ! edge !-- here is the limiter... DO j=j_start, j_end DO k=kts, ktf #ifdef XEON_SIMD !DIR$ simd #else !DIR$ vector always #endif DO i=i_start, i_end ph_low(i,k,j) = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j) & - dt*( msftx(i,j)*msfty(i,j)*( & rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) + & rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=kts, ktf !DIR$ vector always DO i=i_start, i_end flux_out(i,k,j) = dt*( (msftx(i,j)*msfty(i,j))*( & rdx*( max(0.,fqx (i+1,k,j)) & -min(0.,fqx (i ,k,j)) ) & +rdy*( max(0.,fqy (i,k,j+1)) & -min(0.,fqy (i,k,j )) ) ) & +msfty(i,j)*rdzw(k)*( min(0.,fqz (i,k+1,j)) & -max(0.,fqz (i,k ,j)) ) ) ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=kts, ktf !DIR$ vector always DO i=i_start, i_end IF( flux_out(i,k,j) .gt. ph_low(i,k,j) ) THEN scale = max(0.,ph_low(i,k,j)/(flux_out(i,k,j)+eps)) IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j) IF( fqx (i ,k,j) .lt. 0.) fqx(i ,k,j) = scale*fqx(i ,k,j) IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1) IF( fqy (i,k,j ) .lt. 0.) fqy(i,k,j ) = scale*fqy(i,k,j ) ! note: z flux is opposite sign in mass coordinate because ! vertical coordinate decreases with increasing k IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j) IF( fqz (i,k ,j) .gt. 0.) fqz(i,k ,j) = scale*fqz(i,k ,j) END IF ENDDO ENDDO ENDDO END IF ! add in the pd-limited flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) DO j = j_start, j_end DO k = kts, ktf !DEC$ vector always DO i = i_start, i_end tendency (i,k,j) = tendency(i,k,j) & -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & +fqzl(i,k+1,j)-fqzl(i,k,j)) ENDDO ENDDO ENDDO IF(tenddec) THEN DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & +fqzl(i,k+1,j)-fqzl(i,k,j)) ENDDO ENDDO ENDDO END IF ! x flux divergence ! IF(degrade_xs) i_start = MAX(its,ids+1) IF(degrade_xe) i_end = MIN(ite,ide-2) DO j = j_start, j_end DO k = kts, ktf !DEC$ vector always DO i = i_start, i_end ! Un-"canceled" map scale factor, ADT Eq. 48 tendency (i,k,j) = tendency(i,k,j) & - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & +fqxl(i+1,k,j)-fqxl(i,k,j)) ) ENDDO ENDDO ENDDO IF(tenddec) THEN DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end h_tendency (i,k,j) = 0. & - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & +fqxl(i+1,k,j)-fqxl(i,k,j)) ) ENDDO ENDDO ENDDO END IF ! y flux divergence ! i_start = its i_end = MIN(ite,ide-1) IF(degrade_ys) j_start = MAX(jts,jds+1) IF(degrade_ye) j_end = MIN(jte,jde-2) DO j = j_start, j_end DO k = kts, ktf !DEC$ vector always DO i = i_start, i_end ! Un-"canceled" map scale factor, ADT Eq. 48 ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606 tendency (i,k,j) = tendency(i,k,j) & - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & +fqyl(i,k,j+1)-fqyl(i,k,j)) ) ENDDO ENDDO ENDDO IF(tenddec) THEN DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end h_tendency (i,k,j) = h_tendency (i,k,j) & - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & +fqyl(i,k,j+1)-fqyl(i,k,j)) ) ENDDO ENDDO ENDDO END IF END SUBROUTINE advect_scalar_pd !---------------------------------------------------------------- SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & ru, rv, rom, & c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS. ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; Also used by Bryan 2005, Mon. Wea. Rev. ! IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & field_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax INTEGER , PARAMETER :: is=0, js=0, ks=0 REAL :: mrdx, mrdy, ub, vb, vw REAL , DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION( its-is:ite+1, kts:kte ) :: fqx ! REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp real :: dir, vv real :: ue,uw,vs,vn,wb,wt real, parameter :: f30 = 7./12., f31 = 1./12. real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. integer kt,kb real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-28 integer, parameter :: pw = 2 ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2) flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) & +(1./60.)*(q_ip2+q_im3) flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*(1./60.)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) LOGICAL :: specified specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. ! set order for the advection schemes ktf=MIN(kte,kde-1) horz_order = 5 ! config_flags%h_sca_adv_order vert_order = 5 ! config_flags%v_sca_adv_order ! begin with horizontal flux divergence ! here is the choice of flux operators IF( horz_order == 5 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first ktf=MIN(kte,kde-1) i_start = its i_end = MIN(ite,ide-1) ! check for U IF ( is == 1 ) THEN i_start = its i_end = ite IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite ENDIF j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end ! vel = rv(i,k,j) vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i,k,j+1) qip1 = field(i,k,j ) qi = field(i,k,j-1) qim1 = field(i,k,j-2) qim2 = field(i,k,j-3) ELSE qip2 = field(i,k,j-2) qip1 = field(i,k,j-1) qi = field(i,k,j ) qim1 = field(i,k,j+1) qim2 = field(i,k,j+2) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqy( i, k, jp1 ) = vel*flux5( & ! field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & ! field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end fqy(i,k, jp1) = 0.5*rv(i,k,j)* & ! fqy(i,k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )* & (field(i,k,j)+field(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end ! vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) vel = rv(i,k,j) fqy( i, k, jp1 ) = vel*flux3( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end ! fqy(i, k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )* & fqy(i, k, jp1) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) ! vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) fqy( i, k, jp1) = vel*flux3( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) ENDDO ENDDO ENDIF ! y flux-divergence into tendency IF ( is == 0 ) THEN ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF ENDIF ELSEIF ( is == 1 ) THEN ! (j > j_start) will miss the u(,,jds) tendency IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ! This would be seen by (j > j_start) but we need to zero out the NP tendency ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF ENDIF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_5 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f ! vel = ru(i,k,j) vel = 0.5*( ru(i,k,j) + ru(i-is,k-ks,j-js) ) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i+1,k,j) qip1 = field(i, k,j) qi = field(i-1,k,j) qim1 = field(i-2,k,j) qim2 = field(i-3,k,j) ELSE qip2 = field(i-2,k,j) qip1 = field(i-1,k,j) qi = field(i, k,j) qim1 = field(i+1,k,j) qim2 = field(i+2,k,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & ! field(i-1,k,j), field(i ,k,j), & ! field(i+1,k,j), field(i+2,k,j), & ! vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf fqx(i,k) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf vel = ru(i,k,j) fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) ENDDO END IF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf fqx(i,k) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf vel = ru(i,k,j) fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF ! x flux-divergence into tendency IF ( is == 0 ) THEN DO k=kts,ktf DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ELSEIF ( is == 1 ) THEN DO k=kts,ktf DO i = i_start, i_end mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDIF ENDDO ENDIF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! compute x (u) conditions for v, w, or scalar IF( (config_flags%open_xs) .and. (its == ids) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*( field_old(its+1,k,j) & - field_old(its ,k,j) ) + & field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*( field_old(i_end ,k,j) & - field_old(i_end-1,k,j) ) + & field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ys) .and. (jts == jds) ) THEN DO i = i_start, i_end DO k = kts, ktf vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*( field_old(i,k,jts+1) & - field_old(i,k,jts ) ) + & field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde)) THEN DO i = i_start, i_end DO k = kts, ktf vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*( field_old(i,k,j_end ) & - field_old(i,k,j_end-1) ) + & field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) & ) ENDDO ENDDO ENDIF !-------------------- vertical advection ! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my) ! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my) ! So we don't need to make a correction for advect_scalar i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) DO i = i_start, i_end vflux(i,kts)=0. vflux(i,kte)=0. ENDDO DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end ! vel = rom(i,k,j) vel = 0.5*( rom(i,k,j) + rom(i-is,k-ks,j-js) ) IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i,k+1,j) qip1 = field(i,k ,j) qi = field(i,k-1,j) qim1 = field(i,k-2,j) qim2 = field(i,k-3,j) ELSE qip2 = field(i,k-2,j) qip1 = field(i,k-1,j) qi = field(i,k ,j) qim1 = field(i,k+1,j) qim2 = field(i,k+2,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! vflux(i,k) = vel*flux5( & ! field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & ! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) k = kts+2 vel=rom(i,k,j) vflux(i,k) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) k = ktf-1 vel=rom(i,k,j) vflux(i,k) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) k=ktf vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO END SUBROUTINE advect_scalar_weno !--------------------------------------------------------------------------------- SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & ru, rv, rom, & c1, c2, & mut, mub, mu_old, & time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! this is a first cut at a positive definite advection option ! for scalars in WRF. This version is memory intensive -> ! we save 3d arrays of x, y and z both high and low order fluxes ! (six in all). Alternatively, we could sweep in a direction ! and lower the cost considerably. ! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order ! fluxes initially ! WCS, 3 December 2002, 24 February 2003 ! ! ERM Dec. 2011: replaced 5th-order fluxes with 5th-order WENO (Weighted ! Essentially Non-Oscillatory) scheme ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; ! IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & field_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy, & dt INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw, mu ! storage for high and low order fluxes REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqx, fqy, fqz REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqxl, fqyl, fqzl INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp REAL,DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: flux_out, ph_low REAL :: scale REAL, PARAMETER :: eps=1.e-20 real :: dir, vv real :: ue,vs,vn,wb,wt real, parameter :: f30 = 7./12., f31 = 1./12. real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-28 integer, parameter :: pw = 2 ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6, flux_upwind REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr flux4(q_im2, q_im1, q_i, q_ip1, ua) = & (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2) flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) & +(1./60.)*(q_ip2+q_im3) flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*(1./60.)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 & +0.5*max(-1.0,(cr-abs(cr)))*q_i ! flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & ! +0.5*(1.-sign(1.,cr))*q_i ! flux_upwind(q_im1, q_i, cr ) = 0. REAL :: dx,dy,dz LOGICAL, PARAMETER :: pd_limit = .true. ! set order for the advection schemes ! write(6,*) ' in pd advection routine ' ! Empty arrays just in case: IF (config_flags%polar) THEN fqx(:,:,:) = 0. fqy(:,:,:) = 0. fqz(:,:,:) = 0. fqxl(:,:,:) = 0. fqyl(:,:,:) = 0. fqzl(:,:,:) = 0. END IF ktf=MIN(kte,kde-1) horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. ! begin with horizontal flux divergence ! here is the choice of flux operators ! horizontal_order_test : IF( horz_order == 6 ) THEN ! ELSE IF( horz_order == 5 ) THEN IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-4) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first !-- y flux compute; these bounds are for periodic and sym b.c. ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 j_start_f = j_start j_end_f = j_end+1 !-- modify loop bounds if open or specified ! IF(degrade_xs) i_start = MAX(its-1,ids-1) ! IF(degrade_xe) i_end = MIN(ite+1,ide-2) IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) then j_start = MAX(jts-1,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte+1,jde-2) j_end_f = jde-3 ENDIF ! compute fluxes, 5th order j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i,k,j+1) qip1 = field(i,k,j ) qi = field(i,k,j-1) qim1 = field(i,k,j-2) qim2 = field(i,k,j-3) ELSE qip2 = field(i,k,j-2) qip1 = field(i,k,j-1) qi = field(i,k,j ) qim1 = field(i,k,j+1) qim2 = field(i,k,j+2) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps1 + beta0)**pw wi1 = gi1 / (eps1 + beta1)**pw wi2 = gi2 / (eps1 + beta2)**pw sumwk = wi0 + wi1 + wi2 fqy( i, k, j ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqy( i, k, j ) = vel*flux5( & ! field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & ! field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux3( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i, k, j ) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k))) vel = rv(i,k,j) cr = vel*dt/dy/mu fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j) = vel*flux3( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) ENDDO ENDDO ENDIF ENDDO j_loop_y_flux_5 ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 i_start_f = i_start i_end_f = i_end+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- modify loop bounds for open and specified b.c ! IF(degrade_ys) j_start = MAX(jts-1,jds+1) ! IF(degrade_ye) j_end = MIN(jte+1,jde-2) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) IF(degrade_xs) then i_start = MAX(ids+1,its-1) i_start_f = ids+3 ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite+1) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th order flux DO k=kts,ktf DO i = i_start_f, i_end_f dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i+1,k,j) qip1 = field(i, k,j) qi = field(i-1,k,j) qim1 = field(i-2,k,j) qim2 = field(i-3,k,j) ELSE qip2 = field(i-2,k,j) qip1 = field(i-1,k,j) qi = field(i, k,j) qim1 = field(i+1,k,j) qim2 = field(i+2,k,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps1 + beta0)**pw wi1 = gi1 / (eps1 + beta1)**pw wi2 = gi2 / (eps1 + beta2)**pw sumwk = wi0 + wi1 + wi2 fqx(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & ! field(i-1,k,j), field(i ,k,j), & ! field(i+1,k,j), field(i+2,k,j), & ! vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j)/mu cr = vel*dt/dx fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k))) vel = ru(i,k,j) cr = vel*dt/dx/mu fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF ENDDO ENDIF ENDDO ! enddo for outer J loop !--- end of 5th order horizontal flux calculation ! ELSE ! WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ! ENDIF horizontal_order_test ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! compute x (u) conditions for v, w, or scalar IF( (config_flags%open_xs) .and. (its == ids) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*( field_old(its+1,k,j) & - field_old(its ,k,j) ) + & field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*( field_old(i_end ,k,j) & - field_old(i_end-1,k,j) ) + & field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ys) .and. (jts == jds) ) THEN DO i = i_start, i_end DO k = kts, ktf vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*( field_old(i,k,jts+1) & - field_old(i,k,jts ) ) + & field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde)) THEN DO i = i_start, i_end DO k = kts, ktf vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*( field_old(i,k,j_end ) & - field_old(i,k,j_end-1) ) + & field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) & ) ENDDO ENDDO ENDIF IF( (config_flags%polar) .and. (jts == jds) ) THEN ! Assuming rv(i,k,jds) = 0. DO i = i_start, i_end DO k = kts, ktf vb = MIN( 0.5*rv(i,k,jts+1), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*( field_old(i,k,jts+1) & - field_old(i,k,jts ) ) + & field(i,k,jts)*rv(i,k,jts+1) & ) ENDDO ENDDO ENDIF IF( (config_flags%polar) .and. (jte == jde)) THEN ! Assuming rv(i,k,jde) = 0. DO i = i_start, i_end DO k = kts, ktf vb = MAX( 0.5*rv(i,k,jte-1), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*( field_old(i,k,j_end ) & - field_old(i,k,j_end-1) ) + & field(i,k,j_end)*(-rv(i,k,jte-1)) & ) ENDDO ENDDO ENDIF !-------------------- vertical advection !-- loop bounds for periodic or sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- loop bounds for open or specified conditions IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) ! vert_order_test : IF (vert_order == 6) THEN ! ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO i = i_start, i_end fqz(i,1,j) = 0. fqzl(i,1,j) = 0. fqz(i,kde,j) = 0. fqzl(i,kde,j) = 0. ENDDO DO k=kts+3,ktf-2 DO i = i_start, i_end dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i,k+1,j) qip1 = field(i,k ,j) qi = field(i,k-1,j) qim1 = field(i,k-2,j) qim2 = field(i,k-3,j) ELSE qip2 = field(i,k-2,j) qip1 = field(i,k-1,j) qi = field(i,k ,j) qim1 = field(i,k+1,j) qim2 = field(i,k+2,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps1 + beta0)**pw wi1 = gi1 / (eps1 + beta1)**pw wi2 = gi2 / (eps1 + beta2)**pw sumwk = wi0 + wi1 + wi2 fqz(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & ! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO DO i = i_start, i_end k=kts+1 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k))) vel = rom(i,k,j) cr = vel*dt/dz/mu fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO ! ELSE ! WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order ! CALL wrf_error_fatal ( wrf_err_message ) ! ENDIF vert_order_test IF (pd_limit) THEN ! positive definite filter i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- loop bounds for open or specified conditions IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) IF(config_flags%specified .or. config_flags%nested) THEN IF (degrade_xs) i_start = MAX(its-1,ids+1) IF (degrade_xe) i_end = MIN(ite+1,ide-2) IF (degrade_ys) j_start = MAX(jts-1,jds+1) IF (degrade_ye) j_end = MIN(jte+1,jde-2) END IF IF(config_flags%open_xs) THEN IF (degrade_xs) i_start = MAX(its-1,ids+1) END IF IF(config_flags%open_xe) THEN IF (degrade_xe) i_end = MIN(ite+1,ide-2) END IF IF(config_flags%open_ys) THEN IF (degrade_ys) j_start = MAX(jts-1,jds+1) END IF IF(config_flags%open_ye) THEN IF (degrade_ye) j_end = MIN(jte+1,jde-2) END IF ! ADT note: ! We don't want to change j_start and j_end ! for polar BC's since we want to calculate ! fluxes for directions other than y at the ! edge !-- here is the limiter... DO j=j_start, j_end DO k=kts, ktf #ifdef XEON_SIMD !DIR$ simd #else !DIR$ vector always #endif DO i=i_start, i_end ph_low(i,k,j) = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j) & - dt*( msftx(i,j)*msfty(i,j)*( & rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) + & rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=kts, ktf !DIR$ vector always DO i=i_start, i_end flux_out(i,k,j) = dt*( (msftx(i,j)*msfty(i,j))*( & rdx*( max(0.,fqx (i+1,k,j)) & -min(0.,fqx (i ,k,j)) ) & +rdy*( max(0.,fqy (i,k,j+1)) & -min(0.,fqy (i,k,j )) ) ) & +msfty(i,j)*rdzw(k)*( min(0.,fqz (i,k+1,j)) & -max(0.,fqz (i,k ,j)) ) ) ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=kts, ktf !DIR$ vector always DO i=i_start, i_end IF( flux_out(i,k,j) .gt. ph_low(i,k,j) ) THEN scale = max(0.,ph_low(i,k,j)/(flux_out(i,k,j)+eps)) IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j) IF( fqx (i ,k,j) .lt. 0.) fqx(i ,k,j) = scale*fqx(i ,k,j) IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1) IF( fqy (i,k,j ) .lt. 0.) fqy(i,k,j ) = scale*fqy(i,k,j ) ! note: z flux is opposite sign in mass coordinate because ! vertical coordinate decreases with increasing k IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j) IF( fqz (i,k ,j) .gt. 0.) fqz(i,k ,j) = scale*fqz(i,k ,j) END IF ENDDO ENDDO ENDDO END IF ! add in the pd-limited flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency (i,k,j) = tendency(i,k,j) & -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & +fqzl(i,k+1,j)-fqzl(i,k,j)) ENDDO ENDDO ENDDO ! x flux divergence ! IF(degrade_xs) i_start = MAX(its,ids+1) IF(degrade_xe) i_end = MIN(ite,ide-2) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end ! Un-"canceled" map scale factor, ADT Eq. 48 tendency (i,k,j) = tendency(i,k,j) & - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & +fqxl(i+1,k,j)-fqxl(i,k,j)) ) ENDDO ENDDO ENDDO ! y flux divergence ! i_start = its i_end = MIN(ite,ide-1) IF(degrade_ys) j_start = MAX(jts,jds+1) IF(degrade_ye) j_end = MIN(jte,jde-2) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end ! Un-"canceled" map scale factor, ADT Eq. 48 ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606 tendency (i,k,j) = tendency(i,k,j) & - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & +fqyl(i,k,j+1)-fqyl(i,k,j)) ) ENDDO ENDDO ENDDO END SUBROUTINE advect_scalar_wenopd !---------------------------------------------------------------- SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & h_tendency, z_tendency, & ru, rv, rom, & c1, c2, & mut, mub, mu_old, & config_flags, & tenddec, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! monotonic advection option ! for scalars in WRF RK3 advection. This version is memory intensive -> ! we save 3d arrays of x, y and z both high and low order fluxes ! (six in all). Alternatively, we could sweep in a direction ! and lower the cost considerably. ! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order ! fluxes initially IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags LOGICAL , INTENT(IN ) :: tenddec ! tendency flag INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & field_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT( OUT) :: h_tendency, z_tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy, & dt ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw, mu REAL , DIMENSION(its:ite, kts:kte) :: vflux ! storage for high and low order fluxes REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: fqx, fqy, fqz REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: fqxl, fqyl, fqzl REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: qmin, qmax REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: scale_in, scale_out REAL :: ph_upwind INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp REAL :: flux_out, ph_low, flux_in, ph_hi, scale REAL, PARAMETER :: eps=1.e-20 ! definition of flux operators, 3rd, 4rth, 5th or 6th order REAL :: flux3, flux4, flux5, flux6, flux_upwind REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr flux4(q_im2, q_im1, q_i, q_ip1, ua) = & (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2) flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) & +(1./60.)*(q_ip2+q_im3) flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1.,ua)*(1./60.)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) ! flux_upwind(q_im1, q_i, cr ) = 0. flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & +0.5*(1.-sign(1.,cr))*q_i LOGICAL, PARAMETER :: mono_limit = .true. ! set order for the advection schemes ktf=MIN(kte,kde-1) horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order do j=jts-2,jte+2 do k=kts,kte do i=its-2,ite+2 qmin(i,k,j) = field_old(i,k,j) qmax(i,k,j) = field_old(i,k,j) scale_in(i,k,j) = 1. scale_out(i,k,j) = 1. fqx(i,k,j) = 0. fqy(i,k,j) = 0. fqz(i,k,j) = 0. fqxl(i,k,j) = 0. fqyl(i,k,j) = 0. fqzl(i,k,j) = 0. enddo enddo enddo ! begin with horizontal flux divergence ! here is the choice of flux operators horizontal_order_test : IF( horz_order == 5 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4rth order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-4) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first !-- y flux compute; these bounds are for periodic and sym b.c. ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 j_start_f = j_start j_end_f = j_end+1 !-- modify loop bounds if open or specified ! WCS 20090218 ! IF(degrade_xs) i_start = its ! IF(degrade_xe) i_end = MIN(ite,ide-1) IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) ! WCS 20090218 ! IF(degrade_ys) then ! j_start = MAX(jts,jds+1) ! j_start_f = jds+3 ! ENDIF ! ! IF(degrade_ye) then ! j_end = MIN(jte,jde-2) ! j_end_f = jde-3 ! ENDIF IF(degrade_ys) then j_start = MAX(jts-1,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte+1,jde-2) j_end_f = jde-3 ENDIF ! compute fluxes, 5th order j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) cr = vel fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), vel) fqy( i, k, j ) = vel*flux5( & field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) else qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) end if ENDDO ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) cr = vel fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) else qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) end if ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4rth order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) cr = vel fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux3( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) else qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) end if ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) cr = vel fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i, k, j ) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) else qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) end if ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4rth order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = rv(i,k,j) cr = vel fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j) = vel*flux3( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) else qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) end if ENDDO ENDDO ENDIF ENDDO j_loop_y_flux_5 ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 i_start_f = i_start i_end_f = i_end+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- modify loop bounds for open and specified b.c ! WCS 20090218 ! IF(degrade_ys) j_start = jts ! IF(degrade_ye) j_end = MIN(jte,jde-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) ! WCS 20090218 ! IF(degrade_xs) then ! i_start = MAX(ids+1,its) ! i_start_f = i_start+2 ! ENDIF ! IF(degrade_xe) then ! i_end = MIN(ide-2,ite) ! i_end_f = ide-3 ! ENDIF IF(degrade_xs) then i_start = MAX(ids+1,its-1) i_start_f = ids+3 ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite+1) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = ru(i,k,j) cr = vel fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & field(i-1,k,j), field(i ,k,j), & field(i+1,k,j), field(i+2,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) else qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) end if ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) ! WCS 20090218 degrade_xs and xe recoded IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf vel = ru(i,k,j) cr = vel fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) else qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) end if ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf vel = ru(i,k,j) cr = vel fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) else qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) end if ENDDO ENDIF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf vel = ru(i,k,j) cr = vel fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) else qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) end if ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf vel = ru(i,k,j) cr = vel fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) else qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) end if ENDDO ENDIF ENDDO ENDIF ENDDO ! enddo for outer J loop ELSE WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_mono, h_order not known ',horz_order CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ENDIF horizontal_order_test ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! compute x (u) conditions for v, w, or scalar IF( (config_flags%open_xs) .and. (its == ids) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*( field_old(its+1,k,j) & - field_old(its ,k,j) ) + & field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide) ) THEN DO j = j_start, j_end DO k = kts, ktf ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*( field_old(i_end ,k,j) & - field_old(i_end-1,k,j) ) + & field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ys) .and. (jts == jds) ) THEN DO i = i_start, i_end DO k = kts, ktf vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*( field_old(i,k,jts+1) & - field_old(i,k,jts ) ) + & field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) & ) ENDDO ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde)) THEN DO i = i_start, i_end DO k = kts, ktf vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*( field_old(i,k,j_end ) & - field_old(i,k,j_end-1) ) + & field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) & ) ENDDO ENDDO ENDIF !-------------------- vertical advection !-- loop bounds for periodic or sym conditions i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 !-- loop bounds for open or specified conditions ! WCS 20090218 ! IF(degrade_xs) i_start = its ! IF(degrade_xe) i_end = MIN(ite,ide-1) ! IF(degrade_ys) j_start = jts ! IF(degrade_ye) j_end = MIN(jte,jde-1) IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) vert_order_test : IF (vert_order == 3) THEN DO j = j_start, j_end DO i = i_start, i_end fqz(i,1,j) = 0. fqzl(i,1,j) = 0. fqz(i,kde,j) = 0. fqzl(i,kde,j) = 0. ENDDO DO k=kts+2,ktf-1 DO i = i_start, i_end vel = rom(i,k,j) cr = -vel fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux3( & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) else qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) end if ENDDO ENDDO DO i = i_start, i_end k=kts+1 vel = rom(i,k,j) cr = -vel fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) else qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) end if k=ktf vel = rom(i,k,j) cr = -vel fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) else qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) end if ENDDO ENDDO ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO i = i_start, i_end fqz(i,1,j) = 0. fqzl(i,1,j) = 0. fqz(i,kde,j) = 0. fqzl(i,kde,j) = 0. ENDDO DO k=kts+3,ktf-2 DO i = i_start, i_end vel = rom(i,k,j) cr = -vel fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j) = vel*flux5( & field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) else qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) end if ENDDO ENDDO DO i = i_start, i_end k=kts+1 vel = rom(i,k,j) cr = -vel fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) else qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) end if k=kts+2 vel = rom(i,k,j) cr = -vel fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)= vel*flux3(field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) else qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) end if k=ktf-1 vel = rom(i,k,j) cr = -vel fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)= vel*flux3( field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) else qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) end if k=ktf vel = rom(i,k,j) cr = -vel fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) if(cr.gt. 0) then qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) else qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) end if ENDDO ENDDO ELSE WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order CALL wrf_error_fatal ( wrf_err_message ) ENDIF vert_order_test IF (mono_limit) THEN ! montonic filter i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 ! WCS 20090218 !-- loop bounds for open or specified conditions ! ! IF(degrade_xs) i_start = its ! IF(degrade_xe) i_end = MIN(ite,ide-1) ! IF(degrade_ys) j_start = jts ! IF(degrade_ye) j_end = MIN(jte,jde-1) ! ! IF(config_flags%specified .or. config_flags%nested) THEN ! IF (degrade_xs) i_start = MAX(its,ids+1) ! IF (degrade_xe) i_end = MIN(ite,ide-2) ! IF (degrade_ys) j_start = MAX(jts,jds+1) ! IF (degrade_ye) j_end = MIN(jte,jde-2) ! END IF ! ! IF(config_flags%open_xs) THEN ! IF (degrade_xs) i_start = MAX(its,ids+1) ! END IF ! IF(config_flags%open_xe) THEN ! IF (degrade_xe) i_end = MIN(ite,ide-2) ! END IF ! IF(config_flags%open_ys) THEN ! IF (degrade_ys) j_start = MAX(jts,jds+1) ! END IF ! IF(config_flags%open_ye) THEN ! IF (degrade_ye) j_end = MIN(jte,jde-2) ! END IF IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) IF(config_flags%specified .or. config_flags%nested) THEN IF (degrade_xs) i_start = MAX(its-1,ids+1) IF (degrade_xe) i_end = MIN(ite+1,ide-2) IF (degrade_ys) j_start = MAX(jts-1,jds+1) IF (degrade_ye) j_end = MIN(jte+1,jde-2) END IF IF(config_flags%open_xs) THEN IF (degrade_xs) i_start = MAX(its-1,ids+1) END IF IF(config_flags%open_xe) THEN IF (degrade_xe) i_end = MIN(ite+1,ide-2) END IF IF(config_flags%open_ys) THEN IF (degrade_ys) j_start = MAX(jts-1,jds+1) END IF IF(config_flags%open_ye) THEN IF (degrade_ye) j_end = MIN(jte+1,jde-2) END IF !-- here is the limiter... DO j=j_start, j_end DO k=kts, ktf DO i=i_start, i_end ph_upwind = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j) & - dt*( msftx(i,j)*msfty(i,j)*( & rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) + & rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) flux_in = -dt*( (msftx(i,j)*msfty(i,j))*( & rdx*( min(0.,fqx (i+1,k,j)) & -max(0.,fqx (i ,k,j)) ) & +rdy*( min(0.,fqy (i,k,j+1)) & -max(0.,fqy (i,k,j )) ) ) & +msfty(i,j)*rdzw(k)*( max(0.,fqz (i,k+1,j)) & -min(0.,fqz (i,k ,j)) ) ) ph_hi = (c1(k)*mut(i,j)+c2(k))*qmax(i,k,j) - ph_upwind IF( flux_in .gt. ph_hi ) scale_in(i,k,j) = max(0.,ph_hi/(flux_in+eps)) flux_out = dt*( (msftx(i,j)*msfty(i,j))*( & rdx*( max(0.,fqx (i+1,k,j)) & -min(0.,fqx (i ,k,j)) ) & +rdy*( max(0.,fqy (i,k,j+1)) & -min(0.,fqy (i,k,j )) ) ) & +msfty(i,j)*rdzw(k)*( min(0.,fqz (i,k+1,j)) & -max(0.,fqz (i,k ,j)) ) ) ph_low = ph_upwind - (c1(k)*mut(i,j)+c2(k))*qmin(i,k,j) IF( flux_out .gt. ph_low ) scale_out(i,k,j) = max(0.,ph_low/(flux_out+eps)) ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=kts, ktf DO i=i_start, i_end+1 IF( fqx (i,k,j) .gt. 0.) then fqx(i,k,j) = min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j) ELSE fqx(i,k,j) = min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j) ENDIF ENDDO ENDDO ENDDO DO j=j_start, j_end+1 DO k=kts, ktf DO i=i_start, i_end IF( fqy (i,k,j) .gt. 0.) then fqy(i,k,j) = min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j) ELSE fqy(i,k,j) = min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j) ENDIF ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=kts+1, ktf DO i=i_start, i_end IF( fqz (i,k,j) .lt. 0.) then fqz(i,k,j) = min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j) ELSE fqz(i,k,j) = min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j) ENDIF ENDDO ENDDO ENDDO END IF ! add in the mono-limited flux divergence ! we need to fix this for open b.c set *********** i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency (i,k,j) = tendency(i,k,j) & -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & +fqzl(i,k+1,j)-fqzl(i,k,j)) ENDDO ENDDO ENDDO IF(tenddec) THEN DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & +fqzl(i,k+1,j)-fqzl(i,k,j)) ENDDO ENDDO ENDDO END IF ! x flux divergence ! ! WCS 20090218 ! IF(degrade_xs) i_start = i_start + 1 ! IF(degrade_xe) i_end = i_end - 1 IF(degrade_xs) i_start = MAX(its,ids+1) IF(degrade_xe) i_end = MIN(ite,ide-2) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end ! Un-"canceled" map scale factor, ADT Eq. 48 tendency (i,k,j) = tendency(i,k,j) & - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & +fqxl(i+1,k,j)-fqxl(i,k,j)) ) ENDDO ENDDO ENDDO IF(tenddec) THEN DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end h_tendency (i,k,j) = 0. & - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & +fqxl(i+1,k,j)-fqxl(i,k,j)) ) ENDDO ENDDO ENDDO END IF ! y flux divergence ! i_start = its i_end = MIN(ite,ide-1) ! WCS 20090218 ! IF(degrade_ys) j_start = j_start + 1 ! IF(degrade_ye) j_end = j_end - 1 IF(degrade_ys) j_start = MAX(jts,jds+1) IF(degrade_ye) j_end = MIN(jte,jde-2) DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end ! Un-"canceled" map scale factor, ADT Eq. 48 tendency (i,k,j) = tendency(i,k,j) & - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & +fqyl(i,k,j+1)-fqyl(i,k,j)) ) ENDDO ENDDO ENDDO IF(tenddec) THEN DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end h_tendency (i,k,j) = h_tendency (i,k,j) & - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & +fqyl(i,k,j+1)-fqyl(i,k,j)) ) ENDDO ENDDO ENDDO END IF END SUBROUTINE advect_scalar_mono !----------------------------------------------------------- #if ( defined(ADVECT_KERNEL) ) END MODULE advection_kernel !================================================================ !================================================================ PROGRAM feeder USE advection_kernel IMPLICIT NONE INTEGER , PARAMETER :: MAX_SCALARS = 1 TYPE(grid_config_rec_type) :: config_flags LOGICAL :: tenddec = .false. INTEGER :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( :,:,:,: ) , ALLOCATABLE :: field, & field_old REAL , DIMENSION( :,:,: ) , ALLOCATABLE :: ru, & rv, & rom REAL , DIMENSION( :,: ), ALLOCATABLE :: mut, mub, mu_old REAL , DIMENSION( :,:,: ), ALLOCATABLE :: tendency REAL , DIMENSION( :,:,: ), ALLOCATABLE :: h_tendency, z_tendency REAL , DIMENSION( :,: ), ALLOCATABLE :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( : ), ALLOCATABLE :: fzm, & fzp, & rdzw, znw,dnw, rdnw, dn, rdn, & c1, c2 REAL :: rdx, & rdy, & dt INTEGER :: time_step, im INTEGER :: i, j, k, n, loop config_flags%scalar_adv_opt = 2 PRINT *,'Init dimensions' ids = 1; ide = 91; jds = 1; jde = 3; kds = 1; kde =10 ims = -5; ime = 96; jms = -5; jme = 8; kms = 1; kme = 10 its = 1; ite = 91; jts = 1; jte = 3; kts = 1; kte = 10 PRINT *,'ALLOCATE two 4d fields' PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)*MAX_SCALARS ALLOCATE ( field(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) ) ALLOCATE ( field_old(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) ) PRINT *,'ALLOCATE three 3d fields U, V, W' PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1) ALLOCATE ( ru(ims:ime , kms:kme , jms:jme ) ) ALLOCATE ( rv(ims:ime , kms:kme , jms:jme ) ) ALLOCATE ( rom(ims:ime , kms:kme , jms:jme ) ) PRINT *,'ALLOCATE three 2d MU fields' PRINT *,(ime-ims+1)*(jme-jms+1) ALLOCATE ( mut(ims:ime , jms:jme) ) ALLOCATE ( mub(ims:ime , jms:jme) ) ALLOCATE ( mu_old(ims:ime , jms:jme) ) PRINT *,'ALLOCATE three 3d tendency' PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1) ALLOCATE ( tendency( ims:ime , kms:kme , jms:jme ) ) ALLOCATE ( h_tendency( ims:ime , kms:kme , jms:jme ) ) ALLOCATE ( z_tendency( ims:ime , kms:kme , jms:jme ) ) PRINT *,'ALLOCATE six 2d map factors' PRINT *,(ime-ims+1)*(jme-jms+1) ALLOCATE ( msfux( ims:ime , jms:jme ) ) ALLOCATE ( msfuy( ims:ime , jms:jme ) ) ALLOCATE ( msfvx( ims:ime , jms:jme ) ) ALLOCATE ( msfvy( ims:ime , jms:jme ) ) ALLOCATE ( msftx( ims:ime , jms:jme ) ) ALLOCATE ( msfty( ims:ime , jms:jme ) ) PRINT *,'ALLOCATE 1d arrays' ALLOCATE ( fzm( kms:kme ) ) ALLOCATE ( fzp( kms:kme ) ) ALLOCATE ( rdzw( kms:kme ) ) ALLOCATE ( znw( kms:kme ) ) ALLOCATE ( dnw( kms:kme ) ) ALLOCATE (rdnw( kms:kme ) ) ALLOCATE ( dn ( kms:kme ) ) ALLOCATE (rdn ( kms:kme ) ) ALLOCATE ( c1 ( kms:kme ) ) ALLOCATE ( c2 ( kms:kme ) ) PRINT *,'CALL init' CALL init ( config_flags) CALL tophat ( field , MAX_SCALARS ,& ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL tophat ( field_old , MAX_SCALARS , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) h_tendency = 0 z_tendency = 0 mub = 1 mut = 1 mu_old = 0 ru = 90 rv = 0 rom = 0 msfux = 1 msfuy = 1 msfvx = 1 msfvy = 1 msftx = 1 msfty = 1 rdx = 1/1000. rdy = 1/1000. DO k = kts, kte znw(k) = 1 - (real(k)-kts)/(real(kte)-kts) END DO DO k = kts, kte-1 rdzw(k) = 1./(znw(k)-znw(k+1)) END DO DO k=1, kde-1 dnw(k) = znw(k+1) - znw(k) rdnw(k) = 1./dnw(k) ENDDO DO k=2, kde-1 dn(k) = 0.5*(dnw(k)+dnw(k-1)) rdn(k) = 1./dn(k) fzp(k) = .5* dnw(k )/dn(k) fzm(k) = .5* dnw(k-1)/dn(k) ENDDO DO k = kts,kte c1(k) = 1. ! This is d(B)/d(eta), so assuming no hyb coord c2(k) = 0. ! This (1 - c1)*(p00 - ptop) ENDDO time_step = 5 dt = time_step field = field_old ! Loop over advection enough times to get some meaningful timings. CALL column ( 0 , field(:,1,2,1) , its, ite ) DO loop = 1 , 2000 ! A representative number of times to call the advection in a time period. IF ( loop .EQ. ((loop)/200)*200 )THEN PRINT *,'LOOP over scalars',loop END IF DO im = 1 , MAX_SCALARS tendency = 0 CALL advect_scalar ( field(ims,kms,jms,im), & field_old(ims,kms,jms,im), & tendency(ims,kms,jms), & ru, rv, rom, c1, c2, & mut, time_step/3, config_flags,& msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) DO n = 1 , MAX_SCALARS field(:,:,:,n) = field_old(:,:,:,n) + dt * tendency(:,:,:) / 3. END DO tendency = 0 CALL advect_scalar ( field(ims,kms,jms,im), & field_old(ims,kms,jms,im), & tendency(ims,kms,jms), & ru, rv, rom, c1, c2, & mut, time_step/2, config_flags,& msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) DO n = 1 , MAX_SCALARS field(:,:,:,n) = field_old(:,:,:,n) + dt * tendency(:,:,:) / 2. END DO tendency = 0 IF (config_flags%scalar_adv_opt .EQ. 0 ) THEN CALL advect_scalar ( field(ims,kms,jms,im), & field_old(ims,kms,jms,im), & tendency(ims,kms,jms), & ru, rv, rom, c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ELSE IF (config_flags%scalar_adv_opt .EQ. 1 ) THEN CALL advect_scalar_pd ( field(ims,kms,jms,im), & field_old(ims,kms,jms,im), & tendency(ims,kms,jms), & h_tendency(ims,kms,jms), & z_tendency(ims,kms,jms), & ru, rv, rom, c1, c2, & mut, mub, mu_old, & time_step, config_flags, tenddec, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fzm, fzp, & rdx, rdy, rdzw,dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ELSE IF (config_flags%scalar_adv_opt .EQ. 2 ) THEN CALL advect_scalar_mono ( field(ims,kms,jms,im), & field_old(ims,kms,jms,im), & tendency(ims,kms,jms), & h_tendency(ims,kms,jms), & z_tendency(ims,kms,jms), & ru, rv, rom, c1, c2, & mut, mub, mu_old, & config_flags, tenddec, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fzm, fzp, & rdx, rdy, rdzw,dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN CALL advect_scalar_weno ( field(ims,kms,jms,im), & field_old(ims,kms,jms,im), & tendency(ims,kms,jms), & ru, rv, rom, c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ELSE IF (config_flags%scalar_adv_opt .EQ. 4 ) THEN CALL advect_scalar_wenopd ( field(ims,kms,jms,im), & field_old(ims,kms,jms,im), & tendency(ims,kms,jms), & ru, rv, rom, c1, c2, & mut, mub, mu_old, & time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) END IF DO n = 1 , MAX_SCALARS field(:,:,:,n) = field_old(:,:,:,n) + dt * ( tendency(:,:,:) ) END DO DO k = 1 , kde field (:,k,:,:) = field (:,2,:,:) END DO field (:,:,2,:) = field (:,:,1,:) field (:,:,3,:) = field (:,:,1,:) field (ite+0,:,:,:) = field(ids+0,:,:,:) field (ite+1,:,:,:) = field(ids+1,:,:,:) field (ite+2,:,:,:) = field(ids+2,:,:,:) field (ite+3,:,:,:) = field(ids+3,:,:,:) field (ite+4,:,:,:) = field(ids+4,:,:,:) field (ids-0,:,:,:) = field(ite-0,:,:,:) field (ids-1,:,:,:) = field(ite-1,:,:,:) field (ids-2,:,:,:) = field(ite-2,:,:,:) field (ids-3,:,:,:) = field(ite-3,:,:,:) field (ids-4,:,:,:) = field(ite-4,:,:,:) field_old = field IF ( loop .EQ. (loop/200)*200 ) THEN CALL column ( loop , field(:,1,2,1) , its, ite ) END IF END DO END DO print *,' ' print *,'=============================== ' print *,' ' print *,'Lines to input to gnuplot' print *,' ' print *,"set terminal x11" IF (config_flags%scalar_adv_opt .EQ. 0 ) THEN print *,'set title "Scalar Advection" font ",20"' ELSE IF (config_flags%scalar_adv_opt .EQ. 1 ) THEN print *,'set title "PD Advection" font ",20"' ELSE IF (config_flags%scalar_adv_opt .EQ. 2 ) THEN print *,'set title "Mono Advection" font ",20"' ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN print *,'set title "WENO Advection" font ",20"' ELSE IF (config_flags%scalar_adv_opt .EQ. 4 ) THEN print *,'set title "WENO PD Advection" font ",20"' END IF print *,"set yrange[-20:120]" print *,"plot [0:90] '000000.txt' with lines , '000200.txt' with lines , '000400.txt' with lines , '000600.txt' with lines , '000800.txt' with lines , '001000.txt' with lines " print *,"plot [0:90] '000000.txt' with lines , '001200.txt' with lines , '001400.txt' with lines , '001600.txt' with lines , '001800.txt' with lines , '002000.txt' with lines " END PROGRAM feeder #endif #if ( !defined(ADVECT_KERNEL) ) !--------------------------------------------------------------------------------- SUBROUTINE advect_weno_u ( u, u_old, tendency, & ru, rv, rom, & c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS. ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; Also used by Bryan 2005, Mon. Wea. Rev. ! IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: u, & u_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip INTEGER :: jp1, jp0, jtmp real :: dir, vv real :: ue,vs,vn,wb,wt real, parameter :: f30 = 7./12., f31 = 1./12. real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. integer kt,kb real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18 integer, parameter :: pw = 2 INTEGER :: horz_order, vert_order REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp REAL , DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION( its-1:ite+1, kts:kte ) :: fqx REAL, DIMENSION( its:ite, kts:kte, 2) :: fqy LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & +(q_ip2+q_im3) )/60.0 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 LOGICAL :: specified specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. ! set order for vertical and horzontal flux operators horz_order = config_flags%h_mom_adv_order vert_order = config_flags%v_mom_adv_order ktf=MIN(kte,kde-1) ! begin with horizontal flux divergence ! horizontal_order_test : IF( horz_order == 6 ) THEN ! ELSE IF( horz_order == 5 ) THEN ! 5th order horizontal flux calculation ! This code is EXACTLY the same as the 6th order code ! EXCEPT the 5th order and 3rd operators are used in ! place of the 6th and 4th order operators ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-2) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = ite IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = u(i,k,j+1) qip1 = u(i,k,j ) qi = u(i,k,j-1) qim1 = u(i,k,j-2) qim2 = u(i,k,j-3) ELSE qip2 = u(i,k,j-2) qip1 = u(i,k,j-1) qi = u(i,k,j ) qim1 = u(i,k,j+1) qim2 = u(i,k,j+2) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqy( i, k, jp1 ) = vel*flux5( & ! u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), & ! u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel ) ENDDO ENDDO ! we must be close to some boundary where we need to reduce the order of the stencil ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & *(u(i,k,j)+u(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux3( & u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & *(u(i,k,j)+u(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) fqy( i, k, jp1 ) = vel*flux3( & u(i,k,j-2),u(i,k,j-1), & u(i,k,j),u(i,k,j+1),vel ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ! This would be seen by (j > j_start) but we need to zero out the NP tendency ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_5 ! next, x - flux divergence i_start = its i_end = ite j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) i_start_f = ids+3 ENDIF IF(degrade_xe) then i_end = MIN(ide-1,ite) i_end_f = ide-2 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = u(i+1,k,j) qip1 = u(i, k,j) qi = u(i-1,k,j) qim1 = u(i-2,k,j) qim2 = u(i-3,k,j) ELSE qip2 = u(i-2,k,j) qip1 = u(i-1,k,j) qi = u(i, k,j) qim1 = u(i+1,k,j) qim2 = u(i+2,k,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j), & ! u(i-1,k,j), u(i ,k,j), & ! u(i+1,k,j), u(i+2,k,j), & ! vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF( degrade_xs ) THEN IF( i_start == ids+1 ) THEN ! second order flux next to the boundary i = ids+1 DO k=kts,ktf ub = u(i-1,k,j) IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i,k,j)+ub) ENDDO END IF i = ids+2 DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), & u(i ,k,j), u(i+1,k,j), & vel ) ENDDO ENDIF IF( degrade_xe ) THEN IF( i_end == ide-1 ) THEN ! second order flux next to the boundary i = ide DO k=kts,ktf ub = u(i,k,j) IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & *(u(i-1,k,j)+ub) ENDDO ENDIF DO k=kts,ktf i = ide-1 vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), & u(i ,k,j), u(i+1,k,j), & vel ) ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! radiative lateral boundary condition in x for normal velocity (u) IF ( (config_flags%open_xs) .and. its == ids ) THEN j_start = jts j_end = MIN(jte,jde-1) DO j = j_start, j_end DO k = kts, ktf ub = MIN(ru(its,k,j)-cb*(c1(k)*mut(its,j)+c2(k)), 0.) tendency(its,k,j) = tendency(its,k,j) & - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j)) ENDDO ENDDO ENDIF IF ( (config_flags%open_xe) .and. ite == ide ) THEN j_start = jts j_end = MIN(jte,jde-1) DO j = j_start, j_end DO k = kts, ktf ub = MAX(ru(ite,k,j)+cb*(c1(k)*mut(ite-1,j)+c2(k)), 0.) tendency(ite,k,j) = tendency(ite,k,j) & - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j)) ENDDO ENDDO ENDIF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb') ! first, set to index ranges i_start = its i_end = MIN(ite,ide) imin = ids imax = ide-1 IF (config_flags%open_xs) THEN i_start = MAX(ids+1, its) imin = ids ENDIF IF (config_flags%open_xe) THEN i_end = MIN(ite,ide-1) imax = ide-1 ENDIF IF( (config_flags%open_ys) .and. (jts == jds)) THEN DO i = i_start, i_end mrdy=msfux(i,jts)*rdy ! ADT eqn 44, 2nd term on RHS ip = MIN( imax, i ) im = MAX( imin, i-1 ) DO k=kts,ktf vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts)) vb = MIN( vw, 0. ) dvm = rv(ip,k,jts+1)-rv(ip,k,jts) dvp = rv(im,k,jts+1)-rv(im,k,jts) tendency(i,k,jts)=tendency(i,k,jts)-mrdy*( & vb*(u_old(i,k,jts+1)-u_old(i,k,jts)) & +0.5*u(i,k,jts)*(dvm+dvp)) ENDDO ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde)) THEN DO i = i_start, i_end mrdy=msfux(i,jte-1)*rdy ! ADT eqn 44, 2nd term on RHS ip = MIN( imax, i ) im = MAX( imin, i-1 ) DO k=kts,ktf vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte)) vb = MAX( vw, 0. ) dvm = rv(ip,k,jte)-rv(ip,k,jte-1) dvp = rv(im,k,jte)-rv(im,k,jte-1) tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*( & vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2)) & +0.5*u(i,k,jte-1)*(dvm+dvp)) ENDDO ENDDO ENDIF !-------------------- vertical advection ! ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w) ! Here we have: - partial d/dz (u*rom) = - partial d/dz (u rho w / my) ! Since 'my' (map scale factor in y-direction) isn't a function of z, ! this is what we need, so leave unchanged in advect_u i_start = its i_end = ite j_start = jts j_end = min(jte,jde-1) ! IF ( config_flags%open_xs ) i_start = MAX(ids+1,its) ! IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite) IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its) IF ( config_flags%open_ye .or. specified ) i_end = MIN(ide-1,ite) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite DO i = i_start, i_end vflux(i,kts)=0. vflux(i,kte)=0. ENDDO ! vert_order_test : IF (vert_order == 6) THEN ! ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = u(i,k+1,j) qip1 = u(i,k ,j) qi = u(i,k-1,j) qim1 = u(i,k-2,j) qim2 = u(i,k-3,j) ELSE qip2 = u(i,k-2,j) qip1 = u(i,k-1,j) qi = u(i,k ,j) qim1 = u(i,k+1,j) qim2 = u(i,k+2,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! vflux(i,k) = vel*flux5( & ! u(i,k-3,j), u(i,k-2,j), u(i,k-1,j), & ! u(i,k ,j), u(i,k+1,j), u(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) vflux(i,k) = vel*flux3( & u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), -vel ) k = ktf-1 vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) vflux(i,k) = vel*flux3( & u(i,k-2,j), u(i,k-1,j), & u(i,k ,j), u(i,k+1,j), -vel ) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ENDDO END SUBROUTINE advect_weno_u !------------------------------------------------------------------------------- SUBROUTINE advect_weno_v ( v, v_old, tendency, & ru, rv, rom, & c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzw, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS. ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; Also used by Bryan 2005, Mon. Wea. Rev. ! IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: v, & v_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzw, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax real :: dir, vv real :: ue,vs,vn,wb,wt real, parameter :: f30 = 7./12., f31 = 1./12. real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. integer kt,kb real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18 integer, parameter :: pw = 2 REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum REAL , DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy INTEGER :: horz_order INTEGER :: vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & +(q_ip2+q_im3) )/60.0 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 LOGICAL :: specified specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. ! set order for the advection schemes ktf=MIN(kte,kde-1) horz_order = config_flags%h_mom_adv_order vert_order = config_flags%v_mom_adv_order ! here is the choice of flux operators ! horizontal_order_test : IF( horz_order == 6 ) THEN ! ELSE IF( horz_order == 5 ) THEN ! 5th order horizontal flux calculation ! This code is EXACTLY the same as the 6th order code ! EXCEPT the 5th order and 3rd operators are used in ! place of the 6th and 4th order operators ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-3) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-1) j_end_f = jde-2 ENDIF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = v(i,k,j+1) qip1 = v(i,k,j ) qi = v(i,k,j-1) qim1 = v(i,k,j-2) qim2 = v(i,k,j-3) ELSE qip2 = v(i,k,j-2) qip1 = v(i,k,j-1) qi = v(i,k,j ) qim1 = v(i,k,j+1) qim2 = v(i,k,j+2) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqy( i, k, jp1 ) = vel*flux5( & ! v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), & ! v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel ) ENDDO ENDDO ! we must be close to some boundary where we need to reduce the order of the stencil ! specified uses upstream normal wind at boundaries ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end vb = v(i,k,j-1) IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(v(i,k,j)+vb) ENDDO ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i, k, jp1 ) = vel*flux3( & v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) ENDDO ENDDO ELSE IF ( j == jde ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end vb = v(i,k,j) IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & *(vb+v(i,k,j-1)) ENDDO ENDDO ELSE IF ( j == jde-1 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) fqy( i, k, jp1 ) = vel*flux3( & v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) ENDDO ENDDO END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN DO k=kts,ktf DO i = i_start, i_end tendency(i,k,j-1) = 0. END DO END DO ELSE ! Normal code IF(j > j_start) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_5 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = v(i+1,k,j) qip1 = v(i, k,j) qi = v(i-1,k,j) qim1 = v(i-2,k,j) qim2 = v(i-3,k,j) ELSE qip2 = v(i-2,k,j) qip1 = v(i-1,k,j) qi = v(i, k,j) qim1 = v(i+1,k,j) qim2 = v(i+2,k,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j), & ! v(i-1,k,j), v(i ,k,j), & ! v(i+1,k,j), v(i+2,k,j), & ! vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) & *(v(i,k,j)+v(i-1,k,j)) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), & v(i ,k,j), v(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & *(v(i_end+1,k,j)+v(i_end,k,j)) ENDDO ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), & v(i ,k,j), v(i+1,k,j), & vel ) ENDDO ENDIF ENDDO ENDIF ! x flux-divergence into tendency DO k=kts,ktf DO i = i_start, i_end mrdx=msfvy(i,j)*rdx ! ADT eqn 45, 1st term on RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! Comments on polar boundary condition ! Force tendency=0 at NP and SP ! We keep setting this everywhere, but it can't hurt... IF ( config_flags%polar .AND. (jts == jds) ) THEN DO i=its,ite DO k=kts,ktf tendency(i,k,jts)=0. END DO END DO END IF IF ( config_flags%polar .AND. (jte == jde) ) THEN DO i=its,ite DO k=kts,ktf tendency(i,k,jte)=0. END DO END DO END IF ! radiative lateral boundary condition in y for normal velocity (v) IF ( (config_flags%open_ys) .and. jts == jds ) THEN i_start = its i_end = MIN(ite,ide-1) DO i = i_start, i_end DO k = kts, ktf vb = MIN(rv(i,k,jts)-cb*(c1(k)*mut(i,jts)+c2(k)), 0.) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts)) ENDDO ENDDO ENDIF IF ( (config_flags%open_ye) .and. jte == jde ) THEN i_start = its i_end = MIN(ite,ide-1) DO i = i_start, i_end DO k = kts, ktf vb = MAX(rv(i,k,jte)+cb*(c1(k)*mut(i,jte-1)+c2(k)), 0.) tendency(i,k,jte) = tendency(i,k,jte) & - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1)) ENDDO ENDDO ENDIF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges j_start = jts j_end = MIN(jte,jde) jmin = jds jmax = jde-1 IF (config_flags%open_ys) THEN j_start = MAX(jds+1, jts) jmin = jds ENDIF IF (config_flags%open_ye) THEN j_end = MIN(jte,jde-1) jmax = jde-1 ENDIF ! compute x (u) conditions for v, w, or scalar IF( (config_flags%open_xs) .and. (its == ids)) THEN DO j = j_start, j_end mrdx=msfvy(its,j)*rdx ! ADT eqn 45, 1st term on RHS jp = MIN( jmax, j ) jm = MAX( jmin, j-1 ) DO k=kts,ktf uw = 0.5*(ru(its,k,jp)+ru(its,k,jm)) ub = MIN( uw, 0. ) dup = ru(its+1,k,jp)-ru(its,k,jp) dum = ru(its+1,k,jm)-ru(its,k,jm) tendency(its,k,j)=tendency(its,k,j)-mrdx*( & ub*(v_old(its+1,k,j)-v_old(its,k,j)) & +0.5*v(its,k,j)*(dup+dum)) ENDDO ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide) ) THEN DO j = j_start, j_end mrdx=msfvy(ite-1,j)*rdx ! ADT eqn 45, 1st term on RHS jp = MIN( jmax, j ) jm = MAX( jmin, j-1 ) DO k=kts,ktf uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm)) ub = MAX( uw, 0. ) dup = ru(ite,k,jp)-ru(ite-1,k,jp) dum = ru(ite,k,jm)-ru(ite-1,k,jm) ! tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( & ! ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) & ! +0.5*v(ite-1,k,j)* & ! ( ru(ite,k,jp)-ru(ite-1,k,jp) & ! +ru(ite,k,jm)-ru(ite-1,k,jm)) ) tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( & ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) & +0.5*v(ite-1,k,j)*(dup+dum)) ENDDO ENDDO ENDIF !-------------------- vertical advection ! ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w) ! Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my) ! We therefore need to make a correction for advect_v ! since 'my' (map scale factor in y direction) isn't a function of z, ! we can do this using *(my/mx) (see eqn. 45 for example) i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = jte DO i = i_start, i_end vflux(i,kts)=0. vflux(i,kte)=0. ENDDO ! Polar boundary conditions are like open or specified ! We don't want to calculate vertical v tendencies at the N or S pole IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts) IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end = MIN(jde-1,jte) ! vert_order_test : IF (vert_order == 6) THEN ! ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO k=kts+3,ktf-2 DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = v(i,k+1,j) qip1 = v(i,k ,j) qi = v(i,k-1,j) qim1 = v(i,k-2,j) qim2 = v(i,k-3,j) ELSE qip2 = v(i,k-2,j) qip1 = v(i,k-1,j) qi = v(i,k ,j) qim1 = v(i,k+1,j) qim2 = v(i,k+2,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! vflux(i,k) = vel*flux5( & ! v(i,k-3,j), v(i,k-2,j), v(i,k-1,j), & ! v(i,k ,j), v(i,k+1,j), v(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux3( & v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), -vel ) k = ktf-1 vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) vflux(i,k) = vel*flux3( & v(i,k-2,j), v(i,k-1,j), & v(i,k ,j), v(i,k+1,j), -vel ) k=ktf vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) ENDDO DO k=kts,ktf DO i = i_start, i_end ! We are calculating vertical fluxes on v points, ! so we must mean msf_v_x/y variables tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS ENDDO ENDDO ENDDO END SUBROUTINE advect_weno_v !--------------------------------------------------------------------------------- SUBROUTINE advect_weno_w ( w, w_old, tendency, & ru, rv, rom, & c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & rdx, rdy, rdzu, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS. ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; Also used by Bryan 2005, Mon. Wea. Rev. ! IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: w, & w_old, & ru, & rv, & rom REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & msfty REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & rdzu, & c1, & c2 REAL , INTENT(IN ) :: rdx, & rdy INTEGER , INTENT(IN ) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw REAL , DIMENSION(its:ite, kts:kte) :: vflux real :: dir, vv real :: ue,vs,vn,wb,wt real, parameter :: f30 = 7./12., f31 = 1./12. real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. integer kt,kb real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18 integer, parameter :: pw = 2 INTEGER :: horz_order, vert_order REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & +(q_ip2+q_im3) )/60.0 flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & -sign(1,time_step)*sign(1.,ua)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 LOGICAL :: specified specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. ! set order for the advection scheme ktf=MIN(kte,kde-1) horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order ! here is the choice of flux operators ! begin with horizontal flux divergence ! horizontal_order_test : IF( horz_order == 6 ) THEN ! ELSE IF (horz_order == 5 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end+1 IF(degrade_ys) then j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF IF(config_flags%polar) j_end = MIN(jte,jde-1) ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i,k,j+1) qip1 = w(i,k,j ) qi = w(i,k,j-1) qim1 = w(i,k,j-2) qim2 = w(i,k,j-3) ELSE qip2 = w(i,k,j-2) qip1 = w(i,k,j-1) qi = w(i,k,j ) qim1 = w(i,k,j+1) qim2 = w(i,k,j+2) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqy( i, k, jp1 ) = vel*flux5( & ! w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & ! w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i,k,j+1) qip1 = w(i,k,j ) qi = w(i,k,j-1) qim1 = w(i,k,j-2) qim2 = w(i,k,j-3) ELSE qip2 = w(i,k,j-2) qip1 = w(i,k,j-1) qi = w(i,k,j ) qim1 = w(i,k,j+1) qim2 = w(i,k,j+2) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqy( i, k, jp1 ) = vel*flux5( & ! w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & ! w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts+1,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux3( & w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux3( & w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) ENDDO ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts+1,ktf DO i = i_start, i_end fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & (w(i,k,j)+w(i,k,j-1)) ENDDO ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts+1,ktf DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) fqy( i, k, jp1 ) = vel*flux3( & w(i,k,j-2),w(i,k,j-1), & w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) fqy( i, k, jp1 ) = vel*flux3( & w(i,k,j-2),w(i,k,j-1), & w(i,k,j),w(i,k,j+1),vel ) ENDDO ENDIF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN DO k=kts,ktf DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) END DO END DO ELSE ! normal code IF(j > j_start) THEN DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) ENDDO ENDDO ENDIF END IF jtmp = jp1 jp1 = jp0 jp0 = jtmp ENDDO j_loop_y_flux_5 ! next, x - flux divergence i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end+1 IF(degrade_xs) then i_start = MAX(ids+1,its) ! i_start_f = i_start+2 i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF ! compute fluxes DO j = j_start, j_end ! 5th or 6th order flux DO k=kts+1,ktf DO i = i_start_f, i_end_f vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i+1,k,j) qip1 = w(i, k,j) qi = w(i-1,k,j) qim1 = w(i-2,k,j) qim2 = w(i-3,k,j) ELSE qip2 = w(i-2,k,j) qip1 = w(i-1,k,j) qi = w(i, k,j) qim1 = w(i+1,k,j) qim2 = w(i+2,k,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), & ! w(i-1,k,j), w(i ,k,j), & ! w(i+1,k,j), w(i+2,k,j), & ! vel ) ENDDO ENDDO k = ktf+1 DO i = i_start_f, i_end_f vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i+1,k,j) qip1 = w(i, k,j) qi = w(i-1,k,j) qim1 = w(i-2,k,j) qim2 = w(i-3,k,j) ELSE qip2 = w(i-2,k,j) qip1 = w(i-1,k,j) qi = w(i, k,j) qim1 = w(i+1,k,j) qim2 = w(i+2,k,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), & ! w(i-1,k,j), w(i ,k,j), & ! w(i+1,k,j), w(i+2,k,j), & ! vel ) ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts+1,ktf fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDDO k = ktf+1 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDIF IF(i == ids+2) THEN ! third order DO k=kts+1,ktf vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO k = ktf+1 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) END IF ENDDO ENDIF IF( degrade_xe ) THEN DO i = i_end_f+1, i_end+1 IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts+1,ktf fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDDO k = ktf+1 fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & *(w(i,k,j)+w(i-1,k,j)) ENDIF IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts+1,ktf vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDDO k = ktf+1 vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & w(i ,k,j), w(i+1,k,j), & vel ) ENDIF ENDDO ENDIF ! x flux-divergence into tendency DO k=kts+1,ktf+1 DO i = i_start, i_end mrdx=msftx(i,j)*rdx ! see ADT eqn 46 dividing by my, 1st term RHS tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) ENDDO ENDDO ENDDO ! pick up the the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) IF( (config_flags%open_xs) .and. (its == ids)) THEN DO j = j_start, j_end DO k = kts+1, ktf uw = 0.5*(fzm(k)*(ru(its,k ,j)+ru(its+1,k ,j)) + & fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j)) ) ub = MIN( uw, 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*(w_old(its+1,k,j) - w_old(its,k,j)) + & w(its,k,j)*( & fzm(k)*(ru(its+1,k ,j)-ru(its,k ,j))+ & fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j))) & ) ENDDO ENDDO k = ktf+1 DO j = j_start, j_end uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j)) & -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j)) ) ub = MIN( uw, 0. ) tendency(its,k,j) = tendency(its,k,j) & - rdx*( & ub*(w_old(its+1,k,j) - w_old(its,k,j)) + & w(its,k,j)*( & (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))- & fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j))) & ) ENDDO ENDIF IF( (config_flags%open_xe) .and. (ite == ide)) THEN DO j = j_start, j_end DO k = kts+1, ktf uw = 0.5*(fzm(k)*(ru(ite-1,k ,j)+ru(ite,k ,j)) + & fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j)) ) ub = MAX( uw, 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) + & w(i_end,k,j)*( & fzm(k)*(ru(ite,k ,j)-ru(ite-1,k ,j)) + & fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j))) & ) ENDDO ENDDO k = ktf+1 DO j = j_start, j_end uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j)) & -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j)) ) ub = MAX( uw, 0. ) tendency(i_end,k,j) = tendency(i_end,k,j) & - rdx*( & ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) + & w(i_end,k,j)*( & (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) - & fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j))) & ) ENDDO ENDIF IF( (config_flags%open_ys) .and. (jts == jds)) THEN DO i = i_start, i_end DO k = kts+1, ktf vw = 0.5*( fzm(k)*(rv(i,k ,jts)+rv(i,k ,jts+1)) + & fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1)) ) vb = MIN( vw, 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) + & w(i,k,jts)*( & fzm(k)*(rv(i,k ,jts+1)-rv(i,k ,jts))+ & fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts))) & ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1)) & -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1)) ) vb = MIN( vw, 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) + & w(i,k,jts)*( & (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))- & fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts))) & ) ENDDO ENDIF IF( (config_flags%open_ye) .and. (jte == jde) ) THEN DO i = i_start, i_end DO k = kts+1, ktf vw = 0.5*( fzm(k)*(rv(i,k ,jte-1)+rv(i,k ,jte)) + & fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte)) ) vb = MAX( vw, 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) + & w(i,k,j_end)*( & fzm(k)*(rv(i,k ,jte)-rv(i,k ,jte-1))+ & fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1))) & ) ENDDO ENDDO k = ktf+1 DO i = i_start, i_end vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte)) & -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte)) ) vb = MAX( vw, 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) + & w(i,k,j_end)*( & (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))- & fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1))) & ) ENDDO ENDIF !-------------------- vertical advection ! ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my) ! Here we have: - partial d/dz (w*rom) = - partial d/dz (w rho w / my) ! Therefore we don't need to make a correction for advect_w i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) DO i = i_start, i_end vflux(i,kts)=0. vflux(i,kte)=0. ENDDO ! vert_order_test : IF (vert_order == 6) THEN ! ELSE IF (vert_order == 5) THEN DO j = j_start, j_end DO k=kts+3,ktf-1 DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i,k+1,j) qip1 = w(i,k ,j) qi = w(i,k-1,j) qim1 = w(i,k-2,j) qim2 = w(i,k-3,j) ELSE qip2 = w(i,k-2,j) qip1 = w(i,k-1,j) qi = w(i,k ,j) qim1 = w(i,k+1,j) qim2 = w(i,k+2,j) ENDIF f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 wi0 = gi0 / (eps + beta0)**pw wi1 = gi1 / (eps + beta1)**pw wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk ! vflux(i,k) = vel*flux5( & ! w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), & ! w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) k = kts+2 vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux3( & w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), -vel ) k = ktf vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) vflux(i,k) = vel*flux3( & w(i,k-2,j), w(i,k-1,j), & w(i,k ,j), w(i,k+1,j), -vel ) k=ktf+1 vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) ENDDO DO k=kts+1,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf+1 DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) ENDDO ENDDO END SUBROUTINE advect_weno_w END MODULE module_advect_em #endif