c c------------------------------------------------------------------ c Begin file /home/sting/foster/timegcm/pltlat.f c------------------------------------------------------------------ c subroutine pltlat(fields,utc,ihtsc) c c Contour latitude slices (lon on x-axis, zp or ht on y-axis) c include 'timesproc.h' character*56 toplab,fieldlab character*80 rec80 dimension plt(imx,kmx),viewport(4),yaxht(kmx),plt0(imx,kmx), + fields(imx,kmx,jmx,nfget),hts(imx,kmx) pointer(ppltht,pltht(1)),(pht,ht(1)) data viewport /.15,.89,.26,.91/ c isltxax = 0 if (labels.gt.1) isltxax = 1 if (nlat.le.0) then write(6,"('pltlat: no selected latitudes -- returning')") return endif xmid = 0.5*(viewport(1)+viewport(2)) call cpseti('SET',0) call cpseti('MAP',0) call cpsetr('XC1',gcmlon(1)) call cpsetr('XCM',gcmlon(imx)) call cpsetr('ILX',xmid) rily = -.28 if (isltxax.le.0) rily = -.16 call cpsetr('ILY',rily) call cpseti('ILP',0) call cpsetr('ILS',.016) if (labels.le.1) call cpsetr('ILS',.02) if (ihtsc.le.0) then call cpsetr('YC1',zprange(1)) call cpsetr('YCN',zprange(2)) call set(viewport(1),viewport(2),viewport(3),viewport(4), + gcmlon(1),gcmlon(imx),gcmzp(izprange(1)), + gcmzp(izprange(2)),1) else call cpsetr('YC1',htscale(1)) call cpsetr('YCN',htscale(nhtscale)) call set(viewport(1),viewport(2),viewport(3),viewport(4), + gcmlon(1),gcmlon(imx),htscale(1),htscale(nhtscale),1) call hpalloc(ppltht,imx*nhtscale,ier,1) call hpalloc(pht,nhtscale,ier,1) if (ier.ne.0) then write(6,"('pltlat: hpalloc error = ',i6,' for pltht')") ier stop 'ppltht' endif endif c c Field loop: nzp = izprange(2)-izprange(1)+1 do 200 ip=1,nftot if (ifplt(ip).le.0) goto 200 ilog = 0 if (itimelog(ip).gt.0.and.logvert.gt.0) ilog = 1 c c Selected latitude loop: c do 100 j=1,nlat ixlat = ixfind(gcmlat,jmx,slat(j),dlat) if (ixlat.le.0) then write(6,"('>>> pltlatzp: bad latitude=',f10.3,' j=',i3, + ' skipping this lat')") slat(j),j goto 100 endif rlat = gcmlat(ixlat) if (ihtsc.le.0) then call getlat(fields,plt0,ixlat,ilog,ip) do k=izprange(1),izprange(2) plt(:,k-izprange(1)+1) = plt0(:,k) enddo ny = izprange(2)-izprange(1)+1 else if (ip.lt.ixe5577.or.ip.gt.ixeo200) then call getlat(fields,plt0,ixlat,0,ip) call getlat(fields,hts,ixlat,0,itxz) call cuthtint(plt0,hts,imx,kmx,pltht,htscale,nhtscale, + ilog,cpspval,ier,0) else call getelath(fields,pltht,ixlat,ip) endif if (ilog.gt.0)call log10f(pltht,imx*nhtscale,1.e-20,cpspval) ny = nhtscale endif c c Contour: c if (labels.gt.1) then if (icolor.le.0) then if (ihtsc.le.0) then call contour(plt,imx,imx,ny,cint(ip),cmin(ip),cmax(ip)) else call contour(pltht,imx,imx,ny,cint(ip),cmin(ip), + cmax(ip)) endif else if (ihtsc.le.0) then call conclr(plt,imx,imx,ny,cint(ip),cmin(ip),cmax(ip)) else call conclr(pltht,imx,imx,ny,cint(ip),cmin(ip),cmax(ip)) endif endif if (ihtsc.le.0) then call labrect(gcmlon,imx,gcmzp(izprange(1)),ny, + 'LONGITUDE','ZP',0.) else call labrect(gcmlon,imx,htscale(1),ny,'LONGITUDE', + 'HEIGHT (KM)',0.) endif c c Simple contour and labels: else if (ihtsc.le.0) then call cpcnrc(plt,imx,imx,ny,0.,0.,finc,1,-1,-1634B) call labrect(gcmlon,imx,gcmzp(izprange(1)),ny, + 'LON','ZP',0.) else call cpcnrc(pltht,imx,imx,ny,0.,0.,finc,1,-1,-1634B) call labrect(gcmlon,imx,htscale,ny,'LON','HT',0.) endif endif c c Local time axis: c if (isltxax.gt.0) call sltxax(utc) c c Field label at top: c call clearstr(fieldlab) if (ilog.le.0) then write(toplab,"(a8,' LAT=',f8.2,' UT=',f6.2,24x)") + flab(ip),rlat,utc write(fieldlab,"(a)") flab(ip) else write(toplab,"('LOG10 ',a8,' LAT=',f8.2,' UT=',f6.2,18x)") + flab(ip),rlat,utc write(fieldlab,"('LOG10 ',a)") flab(ip) endif call clearstr(rec80) write(rec80,"(a)") toplab(1:lenstr(toplab)) if (labels.gt.1) then call wrlab(toplab(1:lenstr(toplab)),xmid,viewport(4)+0.05, + 0.) c write(toplab,"('HISTORY=',a)") histvol(ivol) c call wrlab(toplab(1:lenstr(toplab)),xmid,viewport(3)-0.22, c + .012) else call wrlablq(toplab(1:lenstr(toplab)),xmid, + viewport(4)+0.05,.02) endif c c Put height axis on right (use zonally averaged heights): if (ihtsc.le.0) then yaxht(:) = 0. do k=izprange(1),izprange(2) izp = k-izprange(1)+1 do i=1,imx-1 yaxht(izp) = yaxht(izp) + fields(i,k,ixlat,ifget(itxz)) enddo yaxht(izp) = yaxht(izp) / float(imx-1) enddo rnd = 10. if (gcmzp(izprange(2))-gcmzp(izprange(1)).le.5.) rnd = 5. call altyax(nzp,yaxht,gcmzp(izprange(1)),rnd,6) endif c c Wrap up, including ascii file if needed: c call frame iframe = iframe+1 if (ihtsc.le.0) then call wrascii(iwrascii,luascii,plt,imx,ny,gcmlon, + gcmzp(izprange(1)),'LONGITUDE','LN(P0/P)', + histvol(ivol),fieldlab,iframe,rec80,'timesproc', + dirascii) write(6,"('pltlat: frame ',i4,' field ',a8,' lat=',f8.2, + ' zprange=',2f8.2)") iframe,flab(ip),rlat,zprange else if (iwrascii.gt.0) + call wrascii(iwrascii,luascii,pltht,imx,ny,gcmlon, + htscale,'LONGITUDE','HEIGHT (KM)',histvol(ivol), + fieldlab,iframe,rec80,'timesproc',dirascii) write(6,"('pltlat: frame ',i4,' field ',a8,' lat=',f8.2, + ' htscale=',f6.1,' to ',f6.1)") iframe,flab(ip), + rlat,htscale(1),htscale(nhtscale) endif c c End selected latitude loop 100 continue c c End field loop: ip=1,nftot 200 continue if (ihtsc.gt.0) call hpdeallc(ppltht,ier,0) return end c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine getelath(fields,pltht,ixlat,ip) include 'timesproc.h' dimension pltht(imx,nhtscale),fields(imx,kmx,jmx,nfget), + rkmx(kmx),hts(kmx) pointer(pfht,fht(1)) c c subroutine intloc(gcmin,gcmht,kmx,hts,nhts,loght, c + gcmout,idim1,ndim1,idim2,ier,spval,iprnt) c if (ip.eq.ixe5577) then ! need t,o2,o,n2 call hpalloc(pfht,nhtscale*5,ier,1) do i=1,imx call getloc(fields,hts,ixlat,i,0,itxz) call getloc(fields,rkmx,ixlat,i,0,itxt) call intloc(rkmx,hts,kmx,htscale,nhtscale,0,fht,1,1, + nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxo2) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxo1) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*2+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxn2) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*3+1), + 1,1,nhtscale,ier,cpspval,0) call mke5577(fht,fht(nhtscale+1),fht(nhtscale*2+1), + fht(nhtscale*3+1),nhtscale,fht(nhtscale*4+1),cpspval) do k=1,nhtscale pltht(i,k) = fht(nhtscale*4+k) enddo enddo call hpdeallc(pfht,ier,1) elseif (ip.eq.ixe6300) then call hpalloc(pfht,nhtscale*8,ier,1) do i=1,imx call getloc(fields,hts,ixlat,i,0,itxz) call getloc(fields,rkmx,ixlat,i,0,itxt) call intloc(rkmx,hts,kmx,htscale,nhtscale,0,fht,1,1, + nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxte) call intloc(rkmx,hts,kmx,htscale,nhtscale,0,fht(nhtscale+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxo2) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*2+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxo1) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*3+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxn2) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*4+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxo2p) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*5+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxne) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*6+1), + 1,1,nhtscale,ier,cpspval,0) call mke6300(fht,fht(nhtscale+1),fht(nhtscale*2+1), + fht(nhtscale*3+1),fht(nhtscale*4+1),fht(nhtscale*5+1), + fht(nhtscale*6+1),nhtscale,fht(nhtscale*7+1),cpspval) do k=1,nhtscale pltht(i,k) = fht(nhtscale*7+k) enddo enddo call hpdeallc(pfht,ier,1) elseif (ip.eq.ixeo200) then call hpalloc(pfht,nhtscale*5,ier,1) do i=1,imx call getloc(fields,hts,ixlat,i,0,itxz) call getloc(fields,rkmx,ixlat,i,0,itxt) call intloc(rkmx,hts,kmx,htscale,nhtscale,0,fht,1,1, + nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxo2) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxo1) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*2+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,i,0,itxn2) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale*3+1), + 1,1,nhtscale,ier,cpspval,0) call mkeo200(fht,fht(nhtscale+1),fht(nhtscale*2+1), + fht(nhtscale*3+1),nhtscale,fht(nhtscale*4+1),cpspval) do k=1,nhtscale pltht(i,k) = fht(nhtscale*4+k) enddo enddo call hpdeallc(pfht,ier,1) endif return end