c c------------------------------------------------------------------ c subroutine pltloc(fields,utc,iglbm,ihtsc) c c Make line plots at selected locations, zp or ht on y-axis, field on x-axis: c include 'timesproc.h' dimension pltcol(kmx),htcol(kmx),hts(kmx),vp(4) dimension fields(imx,kmx,jmx,nfget) pointer(pplt,plt(1)) character*40 histlab character*56 fieldlab,toplab character*80 rec80,rangelab data vp/.12,.87,.2,.92/ c if (ihtsc.le.0) then call hpalloc(pplt,kmx,ier,1) else call hpalloc(pplt,nhtscale,ier,1) endif c c Location loop: c call aggetf('FR.',frsave) nnloc = nloc if (iglbm.gt.0) nnloc = 1 xmid = 0.5*(vp(1)+vp(2)) if (labels.gt.1) then call clearstr(histlab) write(histlab,"('HISTORY=',a)") + histvol(ivol)(1:lenstr(histvol(ivol))) lenhist = lenstr(histlab) endif c c Field loop: c getloc will return global means if ilat=ilon=0, c or zonal means if ilon=ifix(zmflag) (999) c nzp = izprange(2)-izprange(1)+1 nip = 0 do 100 ip=1,nftot if (ifplt(ip).le.0) goto 100 ilog = 0 if (itimelog(ip).gt.0.and.logvert.gt.0) ilog = 1 do 200 l=1,nnloc call clearstr(toplab) c c Find indices to desired locations. Locations may be a valid lat,lon pair, c or if iglbm=1 then will find global means, or if the lon (rloc(2,l)) is c zmflag, then find zonal means at the desired latitude (note parameters c passed to getloc will determine lat/lon, global means, or zonal means): c if (iglbm.le.0) then ixlat = ixfind(gcmlat,jmx,rloc(1,l),dlat) if (ixlat.le.0) then write(6,"('>>> pltloc: bad lat=',f10.3,' l=',i3, + ' skipping this location')") rloc(1,l),l goto 100 endif rlat = gcmlat(ixlat) if (rloc(2,l).ne.zmflag) then ixlon = ixfind(gcmlon,imx,rloc(2,l),dlon) if (ixlon.le.0) then write(6,"('>>> pltloc: bad lon=',f10.3,' l=',i3, + ' skipping this location')") rloc(2,l),l goto 100 endif rlon = gcmlon(ixlon) write(toplab,"('UT = ',f5.2,' LAT,LON = ',f8.2,',',f8.2)") + utc,rlat,rlon else ! zonal means at selected latitude ixlon = ifix(zmflag) rlon = zmflag write(toplab,"('UT = ',f5.2,' LAT=',f6.2, + ' (ZONAL MEANS)')") utc,rlat endif else write(toplab,"('UT = ',f5.2,' GLOBAL MEANS')") utc endif call clearstr(rec80) write(rec80,"(a)") toplab(1:lenstr(toplab)) c c Get heights for altyax: c if (ihtsc.le.0) then if (iglbm.le.0) then call getloc(fields,htcol,ixlat,ixlon,0,itxz) else call getloc(fields,htcol,0,0,0,itxz) endif do k=izprange(1),izprange(2) hts(k-izprange(1)+1) = htcol(k) enddo endif c if (ip.lt.ixe5577.or.ip.gt.ixeo200) then if (iglbm.le.0) then call getloc(fields,pltcol,ixlat,ixlon,0,ip) if (ihtsc.gt.0) call getloc(fields,htcol,ixlat,ixlon,0, + itxz) else call getloc(fields,pltcol,0,0,0,ip) if (ihtsc.gt.0) call getloc(fields,htcol,0,0,0,itxz) endif if (ihtsc.le.0) then do k=izprange(1),izprange(2) plt(k-izprange(1)+1) = pltcol(k) enddo else call intloc(pltcol,htcol,kmx,htscale,nhtscale, + ilog,plt,1,1,nhtscale,ier,cpspval,0) endif c c Emissions: for ht scale separate components must be interpolated c before used to calculate the emission itself c else if (ihtsc.le.0) then if (iglbm.le.0) then call getloc(fields,pltcol,ixlat,ixlon,0,ip) ny = izprange(2)-izprange(1)+1 else call getloc(fields,pltcol,0,0,0,ip) endif do k=izprange(1),izprange(2) plt(k-izprange(1)+1) = pltcol(k) enddo ny = izprange(2)-izprange(1)+1 else if (iglbm.le.0) then call geteloch(fields,plt,ixlat,ixlon,ip) else call geteloch(fields,plt,0,0,ip) endif endif endif if (ihtsc.le.0) then ny = izprange(2)-izprange(1)+1 else ny = nhtscale endif c c linetyp = 1 -> x-linear, y-linear c linetyp = 3 -> x-log, y-linear c linetyp = 1 if (ilog.gt.0) linetyp = 3 c c Check for low values anyway (e.g., no.dens mix ratio of ox from c a source history can go to 0): c if (linetyp.eq.3) then do k=1,ny if (plt(k).le.1.e-20) linetyp = 1 enddo endif c c LSET=2 (4th arg to anotat) means AG will use only 1st 4 (and 9th) c args of last set call (i.e., the fractional coords, and lin/log) c call set(vp(1),vp(2),vp(3),vp(4),.1,.9,.1,.9, linetyp) call displa(2,1,linetyp) if (ihtsc.le.0) then call anotat(flab(ip),'ZP',0,2,-1,L) call fminmax(plt,nzp,rmin,rmax,cpspval) call ezxy(plt,gcmzp(izprange(1)),nzp, + toplab(1:lenstr(toplab))) else call anotat(flab(ip),'HEIGHT (KM)',0,2,-1,L) call fminmax(plt,nhtscale,rmin,rmax,cpspval) call ezxy(plt,htscale,nhtscale,toplab(1:lenstr(toplab))) endif if (labels.gt.1) then call clearstr(rangelab) write(rangelab,"('MIN, MAX = ',e12.4,', ',e12.4)") + rmin,rmax lenran = lenstr(rangelab) call wrlab(rangelab(1:lenran),xmid,vp(3)-.11,.012) call wrlab(histlab(1:lenhist),xmid,vp(3)-.15,.012) endif c c Add right hand y-axis with height: c if (ihtsc.le.0) then rnd = 10. if (gcmzp(izprange(2))-gcmzp(izprange(1)).le.5.) rnd = 5. call altyax(nzp,hts,gcmzp(izprange(1)),rnd,6) endif c c Wrap it up, including ascii data file if needed: c call frame iframe = iframe+1 c c Pressure on y-axis: if (ihtsc.le.0) then if (iwrascii.gt.0) then call clearstr(fieldlab) write(fieldlab,"(a)") flab(ip) call wrascii(iwrascii,luascii,plt,1,ny,dum, + gcmzp(izprange(1)),' ','LN(P0/P)', + histvol(ivol),fieldlab,iframe,rec80,'timesproc', + dirascii) endif if (iglbm.le.0) then if (ixlon.ne.ifix(zmflag)) then write(6,"('pltloc: frame ',i4,' lat,lon=', + f6.2,f7.2,' field ',a,' zp=',f5.1,' to ',f5.1)") + iframe,rlat,rlon,flab(ip)(1:8),zprange else write(6,"('pltloc: frame ',i4,' lat=', + f6.2,' (zonal means) field ',a,' zp=',f5.1,' to ', + f5.1)") iframe,rlat,flab(ip)(1:8),zprange endif else write(6,"('pltloc: frame ',i4,' (global means)', + ' field ',a,' zprange = ',2f5.1)") + iframe,flab(ip)(1:8),zprange endif c c Height on y-axis: else if (iwrascii.gt.0) then call clearstr(fieldlab) write(fieldlab,"(a)") flab(ip) call wrascii(iwrascii,luascii,plt,1,ny,dum, + htscale,' ','HEIGHT (KM)',histvol(ivol),fieldlab, + iframe,rec80,'timesproc',dirascii) endif if (iglbm.le.0) then if (ixlon.ne.ifix(zmflag)) then write(6,"('pltloc: frame ',i4,' lat,lon=', + f6.2,f7.2,' field ',a,' htscale=',f6.1,' to ',f6.1)") + iframe,rlat,rlon,flab(ip)(1:8),htscale(1), + htscale(nhtscale) else write(6,"('pltloc: frame ',i4,' lat=', + f6.2,' (zonal means) field ',a,' htscale=',f6.1, + ' to ',f6.1)") iframe,rlat,flab(ip)(1:8), + htscale(1),htscale(nhtscale) endif else write(6,"('pltloc: frame ',i4,' (global means)', + ' field ',a,' htscale=',f6.1,' to ',f6.1)") + iframe,flab(ip)(1:8),htscale(1),htscale(nhtscale) endif endif 200 continue 100 continue call agsetf('FR.',frsave) call agsetf('SET.',1.) return end c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine geteloch(fields,pltht,ixlat,ixlon,ip) include 'timesproc.h' dimension pltht(nhtscale),fields(imx,kmx,jmx,nfget), + rkmx(kmx),hts(kmx) pointer(pfht,fht(1)) c call getloc(fields,hts,ixlat,ixlon,0,itxz) c c subroutine intloc(gcmin,gcmht,kmx,hts,nhts,loght, c + gcmout,idim1,ndim1,idim2,ier,spval,iprnt) c c Greenline (5577A): c if (ip.eq.ixe5577) then ! need t,o2,o,n2 call hpalloc(pfht,nhtscale*5,ier,1) call getloc(fields,rkmx,ixlat,ixlon,0,itxt) call intloc(rkmx,hts,kmx,htscale,nhtscale,0,fht, + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,ixlon,0,itxo2) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,ixlon,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,ixlon,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) call hpdeallc(pfht,ier,1) do k=1,nhtscale pltht(k) = fht(nhtscale*4+k) enddo c c Redline (6300A): c elseif (ip.eq.ixe6300) then call hpalloc(pfht,nhtscale*8,ier,1) call getloc(fields,rkmx,ixlat,ixlon,0,itxt) call intloc(rkmx,hts,kmx,htscale,nhtscale,0,fht, + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,ixlon,0,itxte) call intloc(rkmx,hts,kmx,htscale,nhtscale,0,fht(nhtscale+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,ixlon,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,ixlon,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,ixlon,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,ixlon,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,ixlon,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),nhtscale,fht(nhtscale*7+1),cpspval) call hpdeallc(pfht,ier,1) do k=1,nhtscale pltht(k) = fht(nhtscale*7+k) enddo c c O2 (0-0) band: c elseif (ip.eq.ixeo200) then call hpalloc(pfht,nhtscale*5,ier,1) call getloc(fields,rkmx,ixlat,ixlon,0,itxt) call intloc(rkmx,hts,kmx,htscale,nhtscale,0,fht, + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,ixlon,0,itxo2) call intloc(rkmx,hts,kmx,htscale,nhtscale,1,fht(nhtscale+1), + 1,1,nhtscale,ier,cpspval,0) call getloc(fields,rkmx,ixlat,ixlon,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,ixlon,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) call hpdeallc(pfht,ier,1) do k=1,nhtscale pltht(k) = fht(nhtscale*4+k) enddo endif return end