c subroutine pltutloc(futloc,futlocht,htutpert,htutcntr,ihtsc) c c Contour ut on x-axis, zp or ht on y-axis (ht on y-axis if ihtsc > 0): c include 'tigcmdif.h' dimension futloc(ntms,kmx,nfplt,nloc),plt(ntms,kmx), + htutpert(ntms,kmx,nloc),htutcntr(ntms,kmx,nloc),yaxht(kmx), + futlocht(ntms,nhtscale,nfplt,nloc) character*56 toplab,fieldlab character*80 rec80,histlab character*24 flnm0,flnm1 dimension vp(4) data vp /.12,.86,.26,.91/ c if (ihtsc.le.0.and.nzprange.le.0) then write(6,"('>>> pltutloc: ihtsc=',i2,' but nzprange=',i2, + ' -- returning')") ihtsc,nzprange return endif if (ihtsc.gt.0.and.nhtscale.le.0) then write(6,"('>>> pltutloc: ihtsc=',i2,' but nhtscale=',i2, + ' -- returning')") ihtsc,nhtscale return endif xmid = 0.5*(vp(1)+vp(2)) call cpseti('SET',0) call cpseti('MAP',0) call cpsetr('XC1',utinc(1)) call cpsetr('XCM',utinc(ntms)) call cpsetr('ILX',xmid) call cpseti('ILP',0) call cpsetr('ILS',.016) if (ihtsc.le.0) then call cpsetr('YC1',gcmzp(izprange(1))) call cpsetr('YCN',gcmzp(izprange(2))) call set(vp(1),vp(2),vp(3),vp(4),utinc(1),utinc(ntms), + gcmzp(izprange(1)),gcmzp(izprange(2)),1) else call cpsetr('YC1',htscale(1)) call cpsetr('YCN',htscale(nhtscale)) call set(vp(1),vp(2),vp(3),vp(4),utinc(1),utinc(ntms), + htscale(1),htscale(nhtscale),1) endif call agsetr("AXIS/BOTTOM/CONTROL.",-1.) c c Field loop: c iip = 0 do 200 ip=1,nftot if (ifplt(ip).le.0) goto 200 if (ip.eq.ixuivi.or.ip.eq.ixunvn) goto 200 iip = iip+1 if (ip.eq.ixfof2.or.ip.eq.ixhmf2) goto 200 ipercent = 0 if (idif.eq.1.and.iperc(ip).eq.1) ipercent = 1 do 100 l=1,nloc rily = -.17 if (gloc(1,l).ne.gmflag.and.gloc(2,l).ne.gmflag) rily = -.34 call cpsetr('ILY',rily) if (ihtsc.le.0) then ny = izprange(2)-izprange(1)+1 do k=izprange(1),izprange(2) kk = k-izprange(1)+1 plt(:,kk) = futloc(:,k,iip,l) enddo else ny = nhtscale endif isltax = 0 if (gloc(1,l).ne.gmflag.and.gloc(2,l).ne.gmflag) isltax = 1 c c Contour: c if (ihtsc.le.0) then if (icolor.le.0) then call contour(plt,ntms,ntms,ny,cint(ip),cmin(ip),cmax(ip)) else call conclr(plt,ntms,ntms,ny,cint(ip),cmin(ip),cmax(ip)) endif call labutxy(mtcntr,ntms,gcmzp(izprange(1)),ny,'ZP', + 0.,isltax,gloc(2,l)) else if (icolor.le.0) then call contour(futlocht(1,1,iip,l),ntms,ntms,ny, + cint(ip),cmin(ip),cmax(ip)) else call conclr(futlocht(1,1,iip,l),ntms,ntms,ny, + cint(ip),cmin(ip),cmax(ip)) endif call labutxy(mtcntr,ntms,htscale,ny,'HEIGHT (KM)',0., + isltax,gloc(2,l)) endif call clearstr(toplab) if (ipercent.eq.0) then write(toplab,"(a,' (RAW DIFFERENCE)')") + flab(ip)(1:lenstr(flab(ip))) else write(toplab,"(a,' (% DIFFERENCE)')") + flab(ip)(1:lenstr(flab(ip))) endif call wrlab(toplab(1:lenstr(toplab)),xmid,vp(4)+.07,0.) fieldlab = toplab c call clearstr(toplab) if (gloc(1,l).eq.gmflag.and.gloc(2,l).eq.gmflag) then write(toplab,"('GLOBAL MEANS')") xoff = .15 elseif (gloc(1,l).ne.gmflag.and.gloc(2,l).eq.gmflag) then write(toplab,"('LAT= ',f6.2,' LON=ZONAL MEANS')") gloc(1,l) xoff = .15 else write(toplab,"('LAT,LON = ',f6.2,f7.2)") gloc(1,l),gloc(2,l) xoff = .25 endif if (locname(1).ne.'xxxxxxxxxxxxxxxx') then lentop = lenstr(toplab) lenlab = lenstr(locname(l)) write(toplab(lentop+1:lentop+lenlab+3),"(' (',a,')')") + locname(l)(1:lenlab) endif call wrlab(toplab(1:lenstr(toplab)),xmid,vp(4)+0.03,0.) call clearstr(rec80) write(rec80,"(a)") toplab(1:lenstr(toplab)) c call clearstr(toplab) call tail(pertvol(ipvol),flnm0) call tail(cntrvol(icvol),flnm1) write(toplab,"('DIFFS OF ',a,' MINUS ',a)") + flnm0(1:lenstr(flnm0)),flnm1(1:lenstr(flnm1)) call wrlab(toplab(1:lenstr(toplab)),xmid,vp(3)-xoff, + .010) call clearstr(histlab) write(histlab,"(a)") toplab(1:lenstr(toplab)) c c Use average of perturbed and control heights for righthand side axis: c if (ihtsc.le.0) then yaxht(:) = 0. do k=izprange(1),izprange(2) izp = k-izprange(1)+1 do i=1,ntms yaxht(izp) = yaxht(izp) + 0.5*(htutpert(i,izp,l)+ + htutcntr(i,izp,l)) enddo yaxht(izp) = yaxht(izp) / float(ntms) enddo rnd = 10. if (gcmzp(izprange(2))-gcmzp(izprange(1)).le.5.) rnd = 5. call altyax(ny,yaxht,gcmzp(izprange(1)),rnd,6) endif c c Wrap it up: c call frame iframe = iframe+1 if (ihtsc.le.0) then if (iwrascii.gt.0) + call wrascii(iwrascii,luascii,plt,ntms,ny,utinc,gcmzp, + 'UT (HRS)','LN(P0/P)',histlab,fieldlab,iframe, + rec80,'tigcmdif',dirascii) if (gloc(1,l).eq.gmflag.and.gloc(2,l).eq.gmflag) then write(6,"('utloc frame ',i4,' field ',a8, + ' (GLOBAL MEANS) zprange=',2f8.2)") iframe, + labshort(ip),zprange elseif (gloc(1,l).ne.gmflag.and.gloc(2,l).eq.gmflag) then write(6,"('utloc frame ',i4,' field ',a8, + ' lat=',f6.1,' zonal means zprange=',2f8.2)") + iframe,labshort(ip),gloc(1,l),zprange else write(6,"('utloc frame ',i4,' field ',a8, + ' lat,lon=',f6.1,',',f7.1,' zprange=',2f8.2)") + iframe,labshort(ip),gloc(1,l),gloc(2,l),zprange endif else if (iwrascii.gt.0) + call wrascii(iwrascii,luascii,futlocht(1,1,iip,l),ntms, + ny,utinc,htscale,'UT (HRS)','HEIGHT (KM)',histlab, + fieldlab,iframe,rec80,'tigcmdif',dirascii) if (gloc(1,l).eq.gmflag.and.gloc(2,l).eq.gmflag) then write(6,"('utloc frame ',i4,' field ',a8, + ' (GLOBAL MEANS) (ht on y-axis)')") iframe,labshort(ip) elseif (gloc(1,l).ne.gmflag.and.gloc(2,l).eq.gmflag) then write(6,"('utloc frame ',i4,' field ',a8, + ' lat=',f6.1,' zonal means (ht on y-axis)')") + iframe,labshort(ip),gloc(1,l) else write(6,"('utloc frame ',i4,' field ',a8, + ' lat,lon=',f6.1,',',f7.1,' (ht on y-axis)')") + iframe,labshort(ip),gloc(1,l),gloc(2,l) endif endif 100 continue ! l=1,nloc 200 continue ! ip=1,nftot return end c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine getutloc(it,pert,cntr,futloc,futlocht, + htutpert,htutcntr) c c Update futloc and/or futlocht diffs at current ut for pltutloc contours c and pltutlin line plots. Also define heights for pert and cntr: c include 'tigcmdif.h' dimension futloc(ntms,kmx,nfplt,nloc), + futlocht(ntms,nhtscale,nfplt,nloc), + pert(imx,kmx,jmx,nfget),cntr(imx,kmx,jmx,nfget), + pltcol(kmx),pltcol0(kmx),htutpert(ntms,kmx,nloc), + htutcntr(ntms,kmx,nloc),difcol(kmx),htcol(kmx), + fhtscal(nhtscale),fhtscal0(nhtscale) c do 100 l=1,nloc iglbm = 0 if (gloc(1,l).eq.gmflag.and.gloc(2,l).eq.gmflag) iglbm = 1 c c Update perturbed and control heights: c if (iglbm.le.0) then call getloc(pert,pltcol,gloc(1,l),gloc(2,l),0,ixz,1) call getloc(cntr,pltcol0,gloc(1,l),gloc(2,l),0,ixz,0) else call getloc(pert,pltcol,gmflag,gmflag,0,ixz,1) call getloc(cntr,pltcol0,gmflag,gmflag,0,ixz,0) endif htutpert(it,:,l) = pltcol(:) htutcntr(it,:,l) = pltcol0(:) c c Field loop: c iip = 0 do 200 ip=1,nftot if (ifplt(ip).le.0) goto 200 if (ip.eq.ixuivi.or.ip.eq.ixunvn) goto 200 c if (iutline.le.0.and.(ip.eq.ixfof2.or.ip.eq.ixhmf2)) goto 200 iip = iip+1 ipercent = 0 if (idif.eq.1.and.iperc(ip).eq.1) ipercent = 1 if (iglbm.le.0) then call getloc(pert,pltcol,gloc(1,l),gloc(2,l),0,ip,1) call getloc(cntr,pltcol0,gloc(1,l),gloc(2,l),0,ip,0) else call getloc(pert,pltcol,gmflag,gmflag,0,ip,1) call getloc(cntr,pltcol0,gmflag,gmflag,0,ip,0) endif c c Define futloc(it,1-kmx,iip,l) for zp on y-axis: c if ((iutloc.gt.0.and.nzprange.gt.0).or. + (iutline.gt.0.and.npls.gt.0)) then difcol(:) = pltcol(:) call mkdifs(difcol,pltcol0,kmx,ipercent,cpspval) futloc(it,:,iip,l) = difcol(:) endif c c Define futlocht(it,1-nhtscale,iip,l) for linear height y-axis: c if ((iutloc.gt.0.and.nhtscale.gt.0).or. + (iutline.gt.0.and.nhts.gt.0)) then htcol(:) = htutpert(it,:,l) call intloc(pltcol,htcol,kmx,htscale,nhtscale,ilog(ip), + fhtscal,1,1,nhtscale,ier,cpspval,0) htcol(:) = htutcntr(it,:,l) call intloc(pltcol0,htcol,kmx,htscale,nhtscale,ilog(ip), + fhtscal0,1,1,nhtscale,ier,cpspval,0) call mkdifs(fhtscal,fhtscal0,nhtscale,ipercent,cpspval) futlocht(it,:,iip,l) = fhtscal(:) endif 200 continue ! field loop 100 continue ! loc loop return end