c c------------------------------------------------------------------ c Begin file /home/sting/foster/timegcm/pltpol.f c------------------------------------------------------------------ c subroutine pltpol(fields,utc) c include 'timesproc.h' character*56 toplab,fieldlab character*80 rec80 character*1 hem dimension fields(imx,kmx,jmx,nfget) dimension plt0(imx,jmx),plt(imx,jmx),viewport(4),ylat(jmx) data viewport /.125,.875,.150,.900/, dum/0./ c c ispvec = special value flag for velvct c spvec = specil value for velvct data ispvec/0/, spvec/1.e36/ c xmid = 0.5*(viewport(1)+viewport(2)) call cpseti('SET',0) call cpseti('MAP',1) call cpsetr('XC1',gcmlon(1)) call cpsetr('XCM',gcmlon(imx)) call cpsetr('ILX',0.5) call cpsetr('ILY',-.12) call cpsetr('ILS',.016) call cpseti('ILP',0) if (labels.le.1) call cpsetr('ILS',.02) c c Field loop: do 100 ip=1,nftot if (ifplt(ip).le.0) goto 100 c c Perimeter latitude loop: c do 200 ih=1,npollat nlats = (90.-abs(perimlat(ih))+dlat/2.)/dlat if (perimlat(ih).ge.0.) then hem = 'N' yc1 = perimlat(ih) ycn = gcmlat(jmx) iskip = jmx-nlats rot = -utc*15. plat = 90. else hem = 'S' yc1 = gcmlat(1) ycn = perimlat(ih) iskip = 0 rot = utc*15.-180. plat = -90. endif call mkproj('ST',viewport,plat,0.,rot,perimlat(ih),dum) do j=iskip+1,jmx ylat(j-iskip) = gcmlat(j) enddo c c Selected pressure loop: do 300 izp = 1,npls+nhts ixpl = 0 ht = 0. if (izp.le.npls) then ixpl = ixfind(gcmzp,kmx,spls(izp),dzp) if (ixpl.le.0) then write(6,"('>>> pltglb: bad selected pressure=',f10.3, + ' izp=',i3)") spls(izp),izp goto 300 endif else ht = shts(izp-npls) endif c c Get global snapshot and contour: call getglb(fields,plt0,ixpl,ht,ip) do j=iskip+1,jmx plt(:,j-iskip) = plt0(:,j) enddo call cpsetr('YC1',yc1) call cpsetr('YCN',ycn) if (labels.gt.1) then if (icolor.le.0) then call contour(plt,imx,imx,nlats,cint(ip),cmin(ip), + cmax(ip)) else call conclr(plt,imx,imx,nlats,cint(ip),cmin(ip), + cmax(ip)) call sflush call gsplci(0) call gspmci(0) endif else call cpcnrc(plt,imx,imx,nlats,0.,0.,finc,1,-1,-1634B) endif if (icont.gt.0) call maplot if (icolor.gt.0) then call sflush call gsplci(1) call gspmci(1) endif call labpolar(viewport(1),viewport(2),viewport(3), + viewport(4),hem) c c Add wind vectors: if ((ip.eq.itxt.and.ituv.gt.0).or. + (ip.eq.itxz.and.izuv.gt.0)) then call getglb(fields,plt0,ixpl,ht,itxu) do j=iskip+1,jmx udat(:,j-iskip) = plt0(:,j) enddo call getglb(fields,plt0,ixpl,ht,itxv) do j=iskip+1,jmx vdat(:,j-iskip) = plt0(:,j) enddo c uvmax = 0. m = 2 if (hem.eq.'N') m = 3 ixcolor = 1 if (icolor.gt.0) then call sflush call gsplci(0) call gspmci(0) ixcolor = 0 endif call getset(vl,vr,vb,vt,wl,wr,wb,wt,l) call pltvec(udat,vdat,uvmax,imx,jmx,nlats,iskip,yc1,ycn, + m,ispvec,spvec,ixcolor) call set(vl,vr,vb,vt,wl,wr,wb,wt,l) if (icolor.gt.0) then call sflush call gsplci(1) call gspmci(1) endif endif c c Add ui+vi vectors if plotting poten (black if color): c if (ip.eq.itxpot.and.ipuv.gt.0) then call getglb(fields,plt0,ixpl,ht,itxui) do j=iskip+1,jmx udat(:,j-iskip) = plt0(:,j) enddo call getglb(fields,plt0,ixpl,ht,itxvi) do j=iskip+1,jmx vdat(:,j-iskip) = plt0(:,j) enddo c uvmax = 0. m = 2 if (hem.eq.'N') m = 3 ispvec = 0 spvec = 1.e36 ixcolor = 1 if (icolor.gt.0) then call sflush call gsplci(0) call gspmci(0) ixcolor = 0 endif call getset(vl,vr,vb,vt,wl,wr,wb,wt,l) call pltvec(udat,vdat,uvmax,imx,jmx,nlats,iskip,yc1,ycn, + m,ispvec,spvec,ixcolor) call set(vl,vr,vb,vt,wl,wr,wb,wt,l) if (icolor.gt.0) then call sflush call gsplci(1) call gspmci(1) endif endif c c Top labels: c call clearstr(toplab) if (izp.le.npls) then if (log10map.gt.0.and.itimelog(ip).gt.0) then write(toplab,"('LOG10 ',a8,' ZP=',f5.1,' UT= ',f5.2, + ' PERIMLAT=',f5.1)") flab(ip),spls(izp), + utc,perimlat(ih) else write(toplab,"(a8,' ZP=',f5.1,' UT= ',f5.2, + ' PERIMLAT=',f5.1)") flab(ip),spls(izp), + utc,perimlat(ih) endif else if (log10map.gt.0.and.itimelog(ip).gt.0) then write(toplab,"('LOG10 ',a8,' HT=',f5.1,' UT= ',f5.2, + ' PERIMLAT=',f5.1)") flab(ip),ht,utc, + perimlat(ih) else write(toplab,"(a8,' HT=',f5.1,' UT= ',f5.2,' PERIMLAT=', + f5.1)") flab(ip),ht,utc,perimlat(ih) endif endif if (iwrascii.gt.0) then call clearstr(rec80) write(rec80,"(a)") toplab(1:lenstr(toplab)) call clearstr(fieldlab) write(fieldlab,"(a)") flab(ip) endif if (labels.gt.1) then call wrlab(toplab(1:lenstr(toplab)),xmid, + viewport(4)+0.07,0.) call clearstr(toplab) write(toplab,"('HISTORY=',a)") histvol(ivol) call wrlab(toplab(1:lenstr(toplab)),xmid, + viewport(3)-0.13,.012) else call wrlablq(toplab(1:lenstr(toplab)),xmid, + viewport(4)+0.07,.02) endif call frame iframe = iframe+1 c c Write ascii data file if desired: if (iwrascii.gt.0) then call wrascii(iwrascii,luascii,plt,imx,nlats,gcmlon, + ylat,'LONGITUDE','LATITUDE',histvol(ivol),fieldlab, + iframe,rec80,'timesproc',dirascii) endif if (izp.le.npls) then write(6,"('pltpol: frame ',i4,' field ',a8, + ' zp=',f5.1,' perimlat=',f6.2)") + iframe,flab(ip),spls(izp),perimlat(ih) else write(6,"('pltpol: frame ',i4,' field ',a8, + ' ht=',f5.1,' perimlat=',f6.2)") + iframe,flab(ip),ht,perimlat(ih) endif c c End selected pressure loop: izp=1,npls 300 continue c c End hemisphere loop 200 continue c c End field loop: ip=1,nftot 100 continue c return end