subroutine lap_lev (j,no_lv,fjm1,fj,fjp1,mskm,msk,mskp, * lap_xx,lap_yy,lap_ug) c c======================================================================= c === c This routine computes the Laplacian of the given field in the === c specified slab. The finite differencing is done along constant === c sigma levels. Also used for filtering barotropic fields. === c === c On input: === c === c FJ The field in the slab J (real array). === c FJM1 The field in the slab max(J-1,1) (real array). === c FJP1 The field in the slab min(J+1,JMT) (real array). === c J The current slab number (integer). === c MSK Land mask in the slab J (real array). === c MSKM Land mask in the slab max(J-1,1) (real array). === c MSKP Land mask in the slab min(J+1,JMT) (real array). === c NO_LV The number of vertical levels (integer). === c === c On output: === c === c LAP_UG The zonal gradient of the given velocity component. === c Used for velocity metric terms (real array) === c LAP_XX The zonal component of the Laplacian of the given === c field in the current slab (real array) === c LAP_YY The merdional component of the Laplacian of the === c given field in the current slab (real array) === c === c Calls: none. === c === c Common Blocks: (only relevant variables documented) === c === c /ONEDIM/ === c === c CS Cosine metric factors at velocity points (real array;=== c input). === c CSR Reciprocal of CS (real array; input). === c CST Cosine metric factors at tracer points (real array; === c input). === c CSTR Reciprocal of CST (real array; input) === c DXTR Reciprocal of X-width of tracer boxes (real array; === c input). === c DXUR Reciprocal of X-width of velocity boxes (real array; === c input). === c DYTR Reciprocal of X-width of tracer boxes (real array; === c input). === c DYUR Reciprocal of X-width of velocity boxes (real array; === c input). === c LPMTGD Metric factors for gradient metric term in velocity. === c (real array; input) === c === c======================================================================= c c----------------------------------------------------------------------- c Define global data. c----------------------------------------------------------------------- c #include #include #include #include c c----------------------------------------------------------------------- c Define local data. c----------------------------------------------------------------------- c integer i,j,k,no_lv FLOAT * dyinn,dyins,dyout FLOAT * dxin(imt),dxout(imt),fj(imt,km),fjm1(imt,km),fjp1(imt,km), * lap_ug(imt,km),lap_xx(imt,km),lap_yy(imt,km),msk(imt,km), * mskm(imt,km),mskp(imt,km) c c======================================================================= c Compute Laplacian of field at velocty points. c======================================================================= c entry lapv_lev(j,no_lv,fjm1,fj,fjp1,lap_xx,lap_yy,lap_ug) c c----------------------------------------------------------------------- c Grab correct grid spacings. c----------------------------------------------------------------------- c do 10 i=1,imum1 dxin(i)=dxtr(i+1)*csr(j) dxout(i)=dxur(i)*csr(j) 10 continue dxout(imu)=dxur(imu)*csr(j) dyout=dyur(j)*csr(j) dyins=dytr(j)*cst(j) dyinn=dytr(j+1)*cst(j+1) c c----------------------------------------------------------------------- c Compute the laplacian in the slab. c----------------------------------------------------------------------- c do 20 k=1,no_lv do 20 i=2,imum1 lap_xx(i,k)=dxout(i)*(dxin(i)*(fj(i+1,k)-fj(i,k))- * dxin(i-1)*(fj(i,k)-fj(i-1,k))) lap_yy(i,k)=dyout*(dyinn*(fjp1(i,k)-fj (i,k))- * dyins*(fj (i,k)-fjm1(i,k))) lap_ug(i,k)=lpmtgd(j)*dxu2r(i)*(fj(i+1,k)-fj(i-1,k)) 20 continue #ifdef cyclic c c----------------------------------------------------------------------- c Set Cyclic boundary conditions. c----------------------------------------------------------------------- c do 30 k=1,no_lv lap_xx(1 ,k)=lap_xx(imum1,k) lap_yy(1 ,k)=lap_yy(imum1,k) lap_ug(1 ,k)=lap_ug(imum1,k) lap_xx(imu,k)=lap_xx(2 ,k) lap_yy(imu,k)=lap_yy(2 ,k) lap_ug(imu,k)=lap_ug(2 ,k) 30 continue #endif c c======================================================================= c Compute Laplacian of field at tracer points using their mask. c======================================================================= c entry lapt_lev(j,no_lv,fjm1,fj,fjp1,mskm,msk,mskp,lap_xx,lap_yy) c c----------------------------------------------------------------------- c Grab correct grid spacings. c----------------------------------------------------------------------- c do 110 i=1,imt dxin(i)=dxur(i)*cstr(j) dxout(i)=dxtr(i)*cstr(j) 110 continue dyout=dytr(j)*cstr(j) dyins=dyur(j-1)*cs(j-1) dyinn=dyur(j)*cs(j) c c----------------------------------------------------------------------- c Compute the laplacian in the slab. Note: boundaries are set to c give a no-flux boundary condition. c----------------------------------------------------------------------- c do 120 k=1,no_lv do 120 i=2,imtm1 lap_xx(i,k)=dxout(i)*(dxin(i)*msk(i+1,k)*(fj(i+1,k)-fj(i,k))- * dxin(i-1)*msk(i-1,k)*(fj(i,k)-fj(i-1,k))) lap_yy(i,k)=dyout*(dyinn*mskp(i,k)*(fjp1(i,k)-fj (i,k))- * dyins*mskm(i,k)*(fj (i,k)-fjm1(i,k))) 120 continue #ifdef cyclic c c----------------------------------------------------------------------- c Set Cyclic boundary conditions. c----------------------------------------------------------------------- c do 130 k=1,no_lv lap_xx(1 ,k)=lap_xx(imtm1,k) lap_yy(1 ,k)=lap_yy(imtm1,k) lap_xx(imt,k)=lap_xx(2 ,k) lap_yy(imt,k)=lap_yy(2 ,k) 130 continue #endif return end