c program flxproc c c Coupled processor -- plots tgcm/t21 or tgcm/maccm2 c include "flxproc.h" include "ccm.h" character*16 modelstr real fglb(imx,jmx) c c Initialization: c call preset c c User proc input: c call getinp c c Set up gks: c call setncgm(appid,ncgmwid,'./flxproc.cgm',gkswid) call setplt(ibox_clabs,spval) c c Time (history) loop: c istart = 1 iprint = 1 do it=1,ntms c c Get selected tgcm fields: c if (ixfhist(ixz).gt.0.and.modelhts.gt.0) ixfhist(ixz) = 2 call rdtgcm(histvols,nhvols,tmpdir,istart,mtimes(1,it),pfhist, + ixfhist,mxflds,imx,kmx,jmx,nfhist,zp1,dzp,iden,ionvel,luhist, + iprint,ivol,isdyn,istimes,issech,iier) if (dzp.gt..5-.0001.and.dzp.lt..5+.0001) dzp = .50 if (iier.eq.1) then ! history not found ier = 1 goto 100 endif if (ier.ne.0) then write(6,"('>>> flxproc: Error ',i3,' from rdtgcm')") ier stop 'rdtgcm' endif model = 'TIGCM ' if (.not.istimes.and.isdyn) model = 'TIEGCM ' if (istimes) model = 'TIME-GCM ' ! should always be true ut = float(mtimes(2,it)) + float(mtimes(3,it))/60. c c Get all ccm fields at tgcm horizontal grid and ccm2 zp levels: c ccmf(ngcmlon,ngcmlat,nccmlev,nccmfld) (pointer pccmf is in common) c call rdlsd(imx,gcmlon,jmx,gcmlat,p0) write(6,"(/'flxproc: nccmlev=',i2,' ccmlev_mb=',/(5e13.5))") + nccmlev,(ccmlev_mb(kk),kk=1,nccmlev) c c Now have p0, so set up gcmpmb (also defind gcmzp): c call alloc(pgcmzp,kmx) call alloc(pgcmpmb,kmx) do k=1,kmx gcmzp(k) = zp1+(k-1)*dzp gcmpmb(k) = p0*exp(-gcmzp(k))*1.e-3 enddo c c Now we know t21 or maccm (ccmres). Use kmx to confirm that the tgcm c history read at least has the vertical dimension of a history that c was coupled with the determined ccm version: c tgcm history from a tgcm/t21 coupled run: gcmzp = -16 to +5 (kmx=43) c tgcm history from a tgcm/maccm coupled run: gcmzp = -11 to +5 (kmx=33) c if (ccmres.eq.'CCM2-T21 ') then if (kmx.ne.43) then write(6,"(/'>>> ccm model = ',a,' but tgcm kmx=',i2, + ' --> wrong type of tgcm history? (kmx should = 43)')") + ccmres(1:lenstr(ccmres)),kmx write(6,"('nccmlev=',i2,' ccmlev_zp=',/(8f8.2))") + nccmlev,(ccmlev_zp(k),k=1,nccmlev) write(6,"('kmx=',i2,' gcmzp=',/(8f8.2))") + kmx,(gcmzp(k),k=1,kmx) stop 'tgcmhist' endif elseif (ccmres.eq.'CCM2-MACCM ') then if (kmx.ne.33) then write(6,"(/'>>> ccm model = ',a,' but tgcm kmx=',i2, + ' --> wrong type of tgcm history? (kmx should = 43)')") + ccmres(1:lenstr(ccmres)),kmx write(6,"('nccmlev=',i2,' ccmlev_zp=',/(8f8.2))") + nccmlev,(ccmlev_zp(k),k=1,nccmlev) write(6,"('kmx=',i2,' gcmzp=',/(8f8.2))") + kmx,(gcmzp(k),k=1,kmx) stop 'tgcmhist' endif else write(6,"('>>> Unknown ccmres = ',a)") ccmres stop 'ccmres' endif c c Define coupled zp levels: c ncplzp = nccmlev+(kmx-1) call alloc(pcplzp,ncplzp) do k=1,nccmlev cplzp(k) = ccmlev_zp(k) enddo do k=nccmlev+1,ncplzp cplzp(k) = gcmzp(k-nccmlev+1) enddo write(6,"(/'Interface between ',a,' and ',a,' is ', + 'at zp = ',f7.2)") ccmres(1:lenstr(ccmres)), + model(1:lenstr(model)),cplzp(nccmlev) write(6,"('Number of vertical levels=',i2, + ' (nccmlev=',i2,' kmx=',i2,' p0=',1pe13.6,')')") + ncplzp,nccmlev,kmx,p0 write(6,"(/'LEVEL ZP(LN(P0/P)) PRESS(Mb) AVE HT (KM)', + ' MODEL')") write(6,"(60('-'))") c c fhist(imx,kmx,jmx,nfhist) was returned by rdtgcm c ccmf(imx,jmx,nccmlev,nccmfld) was returned by rdlsd c do k=ncplzp,1,-1 if (k.le.nccmlev) then ix = (ixz2-1)*nccmlev*imx*jmx+(k-1)*imx*jmx+1 aveht = fglbm(ccmf(ix),imx,jmx,gcmlat,dlat,dlon,spval) modelstr = ccmres else kk = k-nccmlev+1 do j=1,jmx do i=1,imx fglb(i,j) = fhist((ixfhist(ixz)-1)*jmx*kmx*imx+ + (j-1)*kmx*imx+(kk-1)*imx+i) enddo enddo aveht = fglbm(fglb,imx,jmx,gcmlat,dlat,dlon,spval) modelstr = model endif pmb = p0*exp(-cplzp(k))*1.e-3 write(6,"(i3,f11.2,4x,1pe15.6,0pf10.2,8x,a)") + k,cplzp(k),pmb,aveht,modelstr(1:lenstr(modelstr)) enddo write(6,"(' ')") c c Determine indices to coupled fields: c ixfcpl(mxflds): if ixfcpl(i) > 0, then field i is coupled, and c ixfcpl(i) is field index in ccmf. c (All ccm fields are coupled fields) c tgcm TN = ccm T c tgcm UN = ccm U c tgcm VN = ccm V c tgcm H2O = ccm Q c tgcm W = ccm OMEGA c tgcm Z = ccm Z2 c do ip=1,mxccmf if (lenstr(ccmflab8(ip)).gt.0) then do iip=1,mxflds if ((flab8(iip).eq.'TN '.and. + ccmflab8(ip).eq.'T ').or. + (flab8(iip).eq.'UN '.and. + ccmflab8(ip).eq.'U ').or. + (flab8(iip).eq.'VN '.and. + ccmflab8(ip).eq.'V ').or. + (flab8(iip).eq.'H2O '.and. + ccmflab8(ip).eq.'Q ').or. + (flab8(iip).eq.'Z '.and. + ccmflab8(ip).eq.'Z2 ').or. + (flab8(iip).eq.'W '.and. + ccmflab8(ip).eq.'OMEGA ')) then ixfcpl(iip) = ip endif enddo ! iip=1,mxflds endif enddo ! ip=1,mxccmf c write(6,"('Coupled fields (and ccmf indices) ixfcpl=', c + /(10i5))") ixfcpl c c Make latitude slices: c call gacwk(gkswid) ! activate gks workstation if (ipltlat.gt.0) call mklats(it) c c Make longitude slices: c if (ipltlon.gt.0) call mklons(it) call gdawk(gkswid) ! deactivate gks workstation c c Release ccm space: c call hpdeallc(pccmf,ier,1) call hpdeallc(pccmlev_mb,ier,1) call hpdeallc(pccmlev_zp,ier,1) call hpdeallc(pccmlon,ier,1) call hpdeallc(pccmlat,ier,1) c c Release tgcm space: c call hpdeallc(pfhist,ier,1) call hpdeallc(pgcmzp,ier,1) call hpdeallc(pgcmpmb,ier,1) c c Release coupled space: c call hpdeallc(pcplzp,ier,1) c c End time loop: c 100 continue enddo c c Retire HLU package: c call NhlFDestroy(ncgmwid,ier) call NhlFDestroy(appid,ier) call NhlFClose c c Send cgm file to remote: c if (lenstr(sendcgm).gt.0) + call rcpfile(0,'flxproc.cgm',sendcgm) c stop end