subroutine shapbal (task,fld,level,tracer) c c======================================================================= c === c This routine accounts for the Shapiro filter balance terms. === c === c ------ === c Input: === c ------ === c === c TASK Instruction. (string) === c "Save" Save current values. === c "Balance" Compute/write Shapiro term. === c FLD Tracer field. (real array)=== c LEVEL Model level for output. (integer) === c TRACER Tracer index for output. (integer) === c === c Common Blocks: === c === #if defined bndy_rlx & defined imp_bnd_rlx c /BNDYRLX/ === c === c TFACBRLX Boundary relaxation coeff. at T-points. (real array)=== c === #endif #ifdef coast c /FULLWD/ === c === c LANDT land/sea mask at tracer points. (integer array) === c === #endif c /IOUNITS/ === c === c STDOUT standard output logical unit. (integer)=== c === c /PE_NETCDF/ === c === c NCNRGID NetCDF ID for energy/diagnostics file. (integer) === c TNRGINDX counter for time dimension. (integer) === c TRMTVID identifiers for tracer term balances. (integer) === c === c /SCALAR/ === c === c C2DTTS twice the length of timestep on tracers. (real; s) === c === c ------ === c Calls: === c ------ === c === c HOPS: ALL_UC, EXITUS, LENGTH === c NETCDF: NCVGT, NCVPT === c === c======================================================================= c c----------------------------------------------------------------------- c Define global data. c----------------------------------------------------------------------- c #include #include #ifdef coast # include #endif #include #include #include #if defined bndy_rlx & defined imp_bnd_rlx # include # include #endif c c----------------------------------------------------------------------- c Define local data. c----------------------------------------------------------------------- c integer err,i,j,level,sbgn,send,slen,tracer integer count(5),start(5) FLOAT & fld(imt,jmt),wk(imt,jmt),wk1(imt) character*128 wkstr character*(*) task c save count,start,wk c data count,start /2*1,imt,2*1,5,4*1/ c c======================================================================= c Begin executable code. c======================================================================= c c----------------------------------------------------------------------- c Make task string all upper case (remove case-dependency of input). c----------------------------------------------------------------------- c call all_uc (task,wkstr) call length (wkstr,slen,sbgn,send) c c----------------------------------------------------------------------- c Hold onto current value of field. c----------------------------------------------------------------------- c if (wkstr(sbgn:send).eq.'SAVE') then do 10 j = 2, jmtm2 do 10 i = 1, imt wk(i,j) = fld(i,j) 10 continue c c----------------------------------------------------------------------- c Compute & write Shapiro filter contribution to tracer balance terms. c----------------------------------------------------------------------- c elseif (wkstr(sbgn:send).eq.'BALANCE') then c c Compute change to to Shapiro filter. c do 20 j = 2, jmtm2 do 20 i = 1, imt wk(i,j) = (fld(i,j)-wk(i,j))/c2dtts #ifdef coast & *FLoaT(landt(i,j)) #endif #if defined bndy_rlx & defined imp_bnd_rlx & *(c1+p5*c2dtts*tfacbrlx(i,j)) #endif 20 continue c c Record change due to Shapiro filter. c start(1) = 5 start(2) = level start(5) = tnrgindx c do 30 j = 2, jmtm2 start(4) = j call ncvpt (ncnrgid,trmtvid(tracer),start,count,wk(1,j),err) if (err.ne.0) then write (stdout,900) tracer,j,level call exitus ('SHAPBAL') endif 30 continue c c Update total change. File was already synchronized in DIAG.F c start(1) = 1 c do 50 j = 2, jmtm2 start(4) = j c call ncvgt (ncnrgid,trmtvid(tracer),start,count,wk1,err) if (err.ne.0) then write (stdout,910) 'read',tracer,j,level call exitus ('SHAPBAL') endif c do 40 i = 1, imt wk1(i) = wk1(i) + wk(i,j) 40 continue c call ncvpt (ncnrgid,trmtvid(tracer),start,count,wk1,err) if (err.ne.0) then write (stdout,910) 'update',tracer,j,level call exitus ('SHAPBAL') endif 50 continue c end if c return c 900 format (/'***Error: SHAPBAL - unable to write Shapiro balance ', & 'term for:'/13x,'tracer=',i4,' slab=',i4,' level=',i4) 910 format (/'***Error: SHAPBAL - unable to ',a,' total balance ', & 'term for:'/13x,'tracer=',i4,' slab=',i4,' level=',i4) c end