subroutine htoper(zs,ds,hs,qs,ps,u,v,vort,t,p,plon,plat,q, * bhalf,bhalfp,nsig,jcap,nlon,nlath,del2, * pln,qln,rln,trigs,ifax, * agvz,wgvz,bvz,nmdszh,vz,vd,vh,vq,in,baln) c$$$ subprogram documentation block c . . . . c subprogram: htoper transpose of hoper c prgmmr: parrish org: w/nmc22 date: 90-10-06 c c abstract: apply transpose of hoper, going from grid to spectral. c c program history log: c 90-10-06 parrish c c input argument list: c u,v,vort,t,p,plon,plat,q - u,v,etc on gaussian grid c bhalf - background error stats c bhalfp - background error stats surface pressure c nsig - number of sigma levels c jcap - triangular truncation c nlon - number of longitudes c nlath - number of gaussian lats in one hemisphere c del2 - n*(n+1)/a**2 c trigs,ifax - used by fft c agvz - mass-variable modes to temperature conversion c wgvz - mass-variable modes to log(psfc) conversion c bvz - mass-variable modes to divergence conversion c nmdszh - number of modes used in balance eqn. c vz - vertical mode matrix - z c vd - vertical mode matrix - d c vh - vertical mode matrix - temps c vq - vertical mode matrix - q c in - total wavenumber index array c baln - spectral balance operator constants c c c output argument list: c zs,ds,hs,qs,ps - coefs of vort, div, unbal t, unbal log(ps), q c c attributes: c language: cft77 c machine: cray ymp c c$$$ c C-CRA dimension agvz(0:jcap,nsig,nmdszh) C-CRA dimension wgvz(0:jcap,nmdszh) C-CRA dimension bvz(0:jcap,nsig,nmdszh) C-CRA dimension bhalf((jcap+1)*(jcap+2),nsig,4) C-CRA dimension bhalfp((jcap+1)*(jcap+2)) C-CRA dimension zs((jcap+1)*(jcap+2),nsig) C-CRA dimension ds((jcap+1)*(jcap+2),nsig) C-CRA dimension hs((jcap+1)*(jcap+2),nsig) C-CRA dimension qs((jcap+1)*(jcap+2),nsig) C-CRA dimension ps((jcap+1)*(jcap+2)) C-CRA dimension u(2*nlath+1,nlon+2,nsig) C-CRA dimension v(2*nlath+1,nlon+2,nsig) C-CRA dimension vort(2*nlath+1,nlon+2,nsig) C-CRA dimension q(2*nlath+1,nlon+2,nsig) C-CRA dimension vz(nsig,nsig),vd(nsig,nsig) C-CRA dimension vq(nsig,nsig),vh(nsig,nsig) C-CRA dimension del2((jcap+1)*(jcap+2)) C-CRA dimension trigs(nlon*2),ifax(10) C-CRA dimension pln((jcap+1)*(jcap+2),nlath) C-CRA dimension qln((jcap+1)*(jcap+2),nlath) C-CRA dimension rln((jcap+1)*(jcap+2),nlath) C-CRA dimension in((jcap+1)*(jcap+2)) C-CRA dimension baln((jcap+1)*(jcap+2)) C-CRA dimension psd((jcap+1)*(jcap+2)) C-CRA dimension zsf((jcap+1)*(jcap+2),nmdszh) C-CRA dimension work((jcap+1)*(jcap+2),nsig) C-CRA real t(2*nlath+1,nlon+2,nsig),p(2*nlath+1,nlon+2) C-CRA real plon(2*nlath+1,nlon+2),plat(2*nlath+1,nlon+2) dimension agvz(0:62,28,28) dimension wgvz(0:62,28) dimension bvz(0:62,28,28) dimension bhalf((62+1)*(62+2),28,4) dimension bhalfp((62+1)*(62+2)) dimension zs((62+1)*(62+2),28) dimension ds((62+1)*(62+2),28) dimension hs((62+1)*(62+2),28) dimension qs((62+1)*(62+2),28) dimension ps((62+1)*(62+2)) dimension u(2*48+1,192+2,28) dimension v(2*48+1,192+2,28) dimension vort(2*48+1,192+2,28) dimension q(2*48+1,192+2,28) dimension vz(28,28),vd(28,28) dimension vq(28,28),vh(28,28) dimension del2((62+1)*(62+2)) dimension trigs(192*2),ifax(10) dimension pln((62+1)*(62+2),48) dimension qln((62+1)*(62+2),48) dimension rln((62+1)*(62+2),48) dimension in((62+1)*(62+2)) dimension baln((62+1)*(62+2)) dimension psd((62+1)*(62+2)) dimension zsf((62+1)*(62+2),28) dimension work((62+1)*(62+2),28) real t(2*48+1,192+2,28),p(2*48+1,192+2) real plon(2*48+1,192+2),plat(2*48+1,192+2) c-------- c-------- internal scratch dynamic space follows: c-------- c-------- nc=(jcap+1)*(jcap+2) ng=(2*nlath+1)*(nlon+2) cmic$ do all shared (nsig,psd,plon,plat,jcap,nlon,nlath,qln,rln,work) cmic$* shared (trigs,ifax,ps,p,zs,vort,hs,t,qs,q,zs,ds,u,v,nc,pln) cmic$* private(kk,k,i) do kk=1,nsig*3+2 if(kk.eq.3*nsig+1) * call ts2grad(psd,plon,plat,jcap,nlon,nlath,qln,rln, * trigs,ifax) if(kk.eq.3*nsig+2) * call ts2g0(ps,p,jcap,nlon,nlath,pln,trigs,ifax) k=mod(kk-1,nsig)+1 if(kk.ge.1.and.kk.le.nsig) then call ts2g0(zs(1,k),vort(1,1,k),jcap,nlon,nlath,pln, * trigs,ifax) call ts2gvec(work(1,k),ds(1,k),u(1,1,k),v(1,1,k), * jcap,nlon,nlath,qln,rln,trigs,ifax) do i=1,nc zs(i,k)=zs(i,k)+work(i,k) end do end if if(kk.ge.nsig+1.and.kk.le.2*nsig) * call ts2g0(hs(1,k),t(1,1,k),jcap,nlon,nlath,pln, * trigs,ifax) if(kk.ge.2*nsig+1.and.kk.le.3*nsig) * call ts2g0(qs(1,k),q(1,1,k),jcap,nlon,nlath,pln, * trigs,ifax) end do C-CRA ps=ps-del2*psd c dimension ps((jcap+1)*(jcap+2)) DO ITMP=1,(jcap+1)*(jcap+2) ps(ITMP)=ps(ITMP)-del2(ITMP)*psd(ITMP) ENDDO c-------- c-------- next do vertical transforms c-------- c-------- tsum in vertical zs do j=1,nsig do i=1,nc work(i,j)=vz(1,j)*zs(i,1) end do do k=2,nsig do i=1,nc work(i,j)=vz(k,j)*zs(i,k) * +work(i,j) end do end do end do c-------- c-------- tsum in vertical qs do j=1,nsig do i=1,nc zs(i,j)=work(i,j) end do do i=1,nc work(i,j)=vq(1,j)*qs(i,1) end do do k=2,nsig do i=1,nc work(i,j)=vq(k,j)*qs(i,k) * +work(i,j) end do end do end do C-CRA qs=work c dimension qs((jcap+1)*(jcap+2),nsig) DO ITMP=1,((jcap+1)*(jcap+2))*nsig qs(ITMP,1)=work(ITMP,1) ENDDO C-CRA work=ds c dimension work((jcap+1)*(jcap+2),nsig) DO ITMP=1,((jcap+1)*(jcap+2))*nsig work(ITMP,1)=ds(ITMP,1) ENDDO C-CRA ds=0. c dimension ds((jcap+1)*(jcap+2),nsig) DO ITMP=1,((jcap+1)*(jcap+2))*nsig ds(ITMP,1)=0. ENDDO C-CRA zsf=0. c dimension zsf((jcap+1)*(jcap+2),nmdszh) DO ITMP=1,((jcap+1)*(jcap+2))*nmdszh zsf(ITMP,1)=0. ENDDO c--------------- tsum in vertical ds do j=1,nsig do k=1,nsig do i=1,nc ds(i,j)=ds(i,j)+work(i,k)*vd(k,j) end do end do if(j.le.nmdszh) then do k=1,nsig do i=1,nc zsf(i,j)=zsf(i,j)+bvz(in(i),k,j)*work(i,k) end do end do end if end do c---------------do ttemp and tpsfc C-CRA work=hs c dimension work((jcap+1)*(jcap+2),nsig) DO ITMP=1,((jcap+1)*(jcap+2))*nsig work(ITMP,1)=hs(ITMP,1) ENDDO C-CRA hs=0. c dimension hs((jcap+1)*(jcap+2),nsig) DO ITMP=1,((jcap+1)*(jcap+2))*nsig hs(ITMP,1)=0. ENDDO do j=1,nsig if(j.le.nmdszh) then do i=1,nc zsf(i,j)=zsf(i,j)+wgvz(in(i),j)*ps(i) end do do k=1,nsig do i=1,nc zsf(i,j)=zsf(i,j)+agvz(in(i),k,j)*work(i,k) end do end do end if do k=1,nsig do i=1,nc hs(i,j)=hs(i,j)+work(i,k)*vh(k,j) end do end do end do c------------------------tapply spectral balance operator c------------------------to zs do k=1,nmdszh ii0=2*(jcap+1) im0=0 do m=1,jcap do ll=1,2*(jcap+1-m) zs(im0+ll,k)=zs(im0+ll,k)+baln(ii0+ll)*zsf(ii0+ll,k) end do ii0=ii0+2*(jcap+1-m) im0=im0+2*(jcap+2-m) end do ii0=0 ip0=2*(jcap+1) do m=0,jcap-1 do ll=1,2*(jcap-m) zs(ip0+ll,k)=zs(ip0+ll,k)+baln(ip0+ll)*zsf(ii0+ll,k) end do ii0=ii0+2*(jcap+1-m) ip0=ip0+2*(jcap-m) end do end do do j=1,nsig if(j .eq. 1)then do i=1,nc ps(i)=ps(i)*bhalfp(i) end do end if do i=1,nc zs(i,j)=zs(i,j)*bhalf(i,j,1) ds(i,j)=ds(i,j)*bhalf(i,j,2) hs(i,j)=hs(i,j)*bhalf(i,j,3) qs(i,j)=qs(i,j)*bhalf(i,j,4) end do end do return end