c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c file alf.f contains subroutines alfk,lfim,lfim1,lfin,lfin1,lfpt c for computing normalized associated legendre polynomials c c subroutine alfk (n,m,cp) c c dimension of real cp(n/2 + 1) c arguments c c purpose routine alfk computes single precision fourier c coefficients in the trigonometric series c representation of the normalized associated c legendre function pbar(n,m,theta) for use by c routines lfp and lfpt in calculating single c precision pbar(n,m,theta). c c first define the normalized associated c legendre functions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m) c /(2*factorial(n+m)))*sin(theta)**m/(2**n* c factorial(n)) times the (n+m)th derivative of c (x**2-1)**n with respect to x=cos(theta) c c where theta is colatitude. c c then subroutine alfk computes the coefficients c cp(k) in the following trigonometric c expansion of pbar(m,n,theta). c c 1) for n even and m even, pbar(m,n,theta) = c .5*cp(1) plus the sum from k=1 to k=n/2 c of cp(k+1)*cos(2*k*th) c c 2) for n even and m odd, pbar(m,n,theta) = c the sum from k=1 to k=n/2 of c cp(k)*sin(2*k*th) c c 3) for n odd and m even, pbar(m,n,theta) = c the sum from k=1 to k=(n+1)/2 of c cp(k)*cos((2*k-1)*th) c c 4) for n odd and m odd, pbar(m,n,theta) = c the sum from k=1 to k=(n+1)/2 of c cp(k)*sin((2*k-1)*th) c c c usage call alfk(n,m,cp) c c arguments c c on input n c nonnegative integer specifying the degree of c pbar(n,m,theta) c c m c is the order of pbar(n,m,theta). m can be c any integer however cp is computed such that c pbar(n,m,theta) = 0 if abs(m) is greater c than n and pbar(n,m,theta) = (-1)**m* c pbar(n,-m,theta) for negative m. c c on output cp c single precision array of length (n/2)+1 c which contains the fourier coefficients in c the trigonometric series representation of c pbar(n,m,theta) c c c special conditions none c c precision single c c algorithm the highest order coefficient is determined in c closed form and the remainig coefficients are c determined as the solution of a backward c recurrence relation. c c accuracy comparison between routines alfk and double c precision dalfk on the cray1 indicates c greater accuracy for smaller values c of input parameter n. agreement to 14 c places was obtained for n=10 and to 13 c places for n=100. c subroutine alfk (n,m,cp) dimension cp(n/2+1) parameter (sc10=1024.) parameter (sc20=sc10*sc10) parameter (sc40=sc20*sc20) c cp(1) = 0. ma = iabs(m) if(ma .gt. n) return if(n-1) 2,3,5 2 cp(1) = sqrt(2.) return 3 if(ma .ne. 0) go to 4 cp(1) = sqrt(1.5) return 4 cp(1) = sqrt(.75) if(m .eq. -1) cp(1) = -cp(1) return 5 if(mod(n+ma,2) .ne. 0) go to 10 nmms2 = (n-ma)/2 fnum = n+ma+1 fnmh = n-ma+1 pm1 = 1. go to 15 10 nmms2 = (n-ma-1)/2 fnum = n+ma+2 fnmh = n-ma+2 pm1 = -1. 15 t1 = 1./sc20 nex = 20 fden = 2. if(nmms2 .lt. 1) go to 20 do 18 i=1,nmms2 t1 = fnum*t1/fden if(t1 .gt. sc20) then t1 = t1/sc40 nex = nex+40 end if fnum = fnum+2. fden = fden+2. 18 continue 20 t1 = t1/2.**(n-1-nex) if(mod(ma/2,2) .ne. 0) t1 = -t1 t2 = 1. if(ma .eq. 0) go to 26 do 25 i=1,ma t2 = fnmh*t2/(fnmh+pm1) fnmh = fnmh+2. 25 continue 26 cp2 = t1*sqrt((n+.5)*t2) fnnp1 = n*(n+1) fnmsq = fnnp1-2.*ma*ma l = (n+1)/2 if(mod(n,2) .eq. 0 .and. mod(ma,2) .eq. 0) l = l+1 cp(l) = cp2 if(m .ge. 0) go to 29 if(mod(ma,2) .ne. 0) cp(l) = -cp(l) 29 if(l .le. 1) return fk = n a1 = (fk-2.)*(fk-1.)-fnnp1 b1 = 2.*(fk*fk-fnmsq) cp(l-1) = b1*cp(l)/a1 30 l = l-1 if(l .le. 1) return fk = fk-2. a1 = (fk-2.)*(fk-1.)-fnnp1 b1 = -2.*(fk*fk-fnmsq) c1 = (fk+1.)*(fk+2.)-fnnp1 cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1 go to 30 end subroutine alin (isym,nlat,nlon,m,p,i3,walin) dimension p(1) ,walin(1) imid = (nlat+1)/2 lim = nlat*imid mmax = min0(nlat,nlon/2+1) labc = ((mmax-2)*(nlat+nlat-mmax-1))/2 iw1 = lim+1 iw2 = iw1+lim iw3 = iw2+labc iw4 = iw3+labc c c the length of walin is ((5*l-7)*l+6)/2 c call alin1 (isym,nlat,m,p,imid,i3,walin,walin(iw1),walin(iw2), 1 walin(iw3),walin(iw4)) return end subroutine alin1 (isym,nlat,m,p,imid,i3,pz,p1,a,b,c) dimension p(imid,nlat,3),pz(imid,1),p1(imid,1), 1 a(1),b(1),c(1) save i1,i2 ihold = i1 i1 = i2 i2 = i3 i3 = ihold if(m-1)25,30,35 25 i1 = 1 i2 = 2 i3 = 3 do 45 np1=1,nlat do 45 i=1,imid p(i,np1,i3) = pz(i,np1) 45 continue return 30 do 50 np1=2,nlat do 50 i=1,imid p(i,np1,i3) = p1(i,np1) 50 continue return 35 ns = ((m-2)*(nlat+nlat-m-1))/2+1 if(isym .eq. 1) go to 36 do 85 i=1,imid p(i,m+1,i3) = a(ns)*p(i,m-1,i1)-c(ns)*p(i,m+1,i1) 85 continue 36 if(m .eq. nlat-1) return if(isym .eq. 2) go to 71 ns = ns+1 do 70 i=1,imid p(i,m+2,i3) = a(ns)*p(i,m,i1)-c(ns)*p(i,m+2,i1) 70 continue 71 nstrt = m+3 if(isym .eq. 1) nstrt = m+4 if(nstrt .gt. nlat) go to 80 nstp = 2 if(isym .eq. 0) nstp = 1 do 75 np1=nstrt,nlat,nstp ns = ns+nstp do 75 i=1,imid p(i,np1,i3) = a(ns)*p(i,np1-2,i1)+b(ns)*p(i,np1-2,i3) 1 -c(ns)*p(i,np1,i1) 75 continue 80 return end subroutine alini1 (nlat,nlon,imid,p,abc,cp) dimension p(imid,nlat,2),abc(1),cp(1) double precision pi,dt,th,cp,ph pi = 4.*datan(1.d0) dt = pi/(nlat-1) do 160 mp1=1,2 m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dnlfk (m,n,cp) do 160 i=1,imid th = (i-1)*dt call dnlft (m,n,th,cp,ph) p(i,np1,mp1) = ph 160 continue call rabcp(nlat,nlon,abc) return end subroutine alinit (nlat,nlon,walin,dwork) dimension walin(*) double precision dwork(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c the length of walin is 3*((l-3)*l+2)/2 + 2*l*imid c the length of work is nlat+1 c call alini1 (nlat,nlon,imid,walin,walin(iw1),dwork) return end subroutine box(isd,istart,next,l,list) dimension istart(isd,isd),next(1),list(1) do 30 jd=1,isd do 10 id=1,isd idx = istart(id,jd) istart(id,jd) = l+1 if(idx .eq. 0) go to 10 20 l = l+1 list(l) = idx if(next(idx) .eq. 0) go to 10 idx = next(idx) go to 20 10 continue 30 continue return end subroutine coe(moe,n,x,dmax) double precision x(n),dmax nh = (n+1)/2 dmax = 0. if(moe.ne.0) go to 1 do i=1,nh dmax = max(dmax,dabs(x(i)-x(n-i+1))) x(i) = .5*(x(i)+x(n-i+1)) x(n-i+1) = x(i) end do return 1 do i=1,nh dmax = max(dmax,dabs(x(i)+x(n-i+1))) x(i) = .5*(x(i)-x(n-i+1)) x(n-i+1) = -x(i) end do if(mod(n,2).ne.0) x(nh) = 0. return end subroutine convlat(nlat,nlon,data) c c reverse order of latitude (colatitude) grids c implicit none integer nlat,nlon,nlat2,i,ib,j real data(nlat,nlon),temp nlat2 = nlat/2 do i=1,nlat2 ib = nlat-i+1 do j=1,nlon temp = data(i,j) data(i,j) = data(ib,j) data(ib,j) = temp end do end do return end subroutine covlat(nlat,nlon,data) c c reverse order of latitude (colatitude) grids c implicit none integer nlat,nlon,nlat2,i,ib,j real data(nlat,nlon),temp nlat2 = nlat/2 do i=1,nlat2 ib = nlat-i+1 do j=1,nlon temp = data(i,j) data(i,j) = data(ib,j) data(ib,j) = temp end do end do return end subroutine cpdp(n,cz,cp,dcp) c c computes the fourier coefficients of the legendre c polynomial p_n^0 and its derivative. c n is the degree and n/2 or (n+1)/2 c coefficients are returned in cp depending on whether c n is even or odd. The same number of coefficients c are returned in dcp. For n even the constant c coefficient is returned in cz. c double precision cp(n/2+1),dcp(n/2+1), 1 t1,t2,t3,t4,cz ncp = (n+1)/2 t1 = -1.0d0 t2 = n+1.0d0 t3 = 0.0d0 t4 = n+n+1.0d0 if(mod(n,2).eq.0) then cp(ncp) = 1.0d0 do j = ncp,2,-1 t1 = t1+2.0d0 t2 = t2-1.0d0 t3 = t3+1.0d0 t4 = t4-2.0d0 cp(j-1) = (t1*t2)/(t3*t4)*cp(j) end do t1 = t1+2.0d0 t2 = t2-1.0d0 t3 = t3+1.0d0 t4 = t4-2.0d0 cz = (t1*t2)/(t3*t4)*cp(1) do j=1,ncp dcp(j) = (j+j)*cp(j) end do else cp(ncp) = 1.0d0 do j = ncp-1,1,-1 t1 = t1+2.0d0 t2 = t2-1.0d0 t3 = t3+1.0d0 t4 = t4-2.0d0 cp(j) = (t1*t2)/(t3*t4)*cp(j+1) end do do j=1,ncp dcp(j) = (j+j-1)*cp(j) end do end if return end subroutine cpdp1(n,cz,cp,dcp) c c computes the fourier coefficients of the legendre c polynomial p_n^0 and its derivative. c n is the degree and n/2 or (n+1)/2 c coefficients are returned in cp depending on whether c n is even or odd. The same number of coefficients c are returned in dcp. For n even the constant c coefficient is returned in cz. c double precision cp(n/2+1),dcp(n/2+1), 1 t1,t2,t3,t4,cz ncp = (n+1)/2 t1 = -1.0d0 t2 = n+1.0d0 t3 = 0.0d0 t4 = n+n+1.0d0 if(mod(n,2).eq.0) then cp(ncp) = 1.0d0 do j = ncp,2,-1 t1 = t1+2.0d0 t2 = t2-1.0d0 t3 = t3+1.0d0 t4 = t4-2.0d0 cp(j-1) = (t1*t2)/(t3*t4)*cp(j) end do t1 = t1+2.0d0 t2 = t2-1.0d0 t3 = t3+1.0d0 t4 = t4-2.0d0 cz = (t1*t2)/(t3*t4)*cp(1) do j=1,ncp dcp(j) = (j+j)*cp(j) end do else cp(ncp) = 1.0d0 do j = ncp-1,1,-1 t1 = t1+2.0d0 t2 = t2-1.0d0 t3 = t3+1.0d0 t4 = t4-2.0d0 cp(j) = (t1*t2)/(t3*t4)*cp(j+1) end do do j=1,ncp dcp(j) = (j+j-1)*cp(j) end do end if return end subroutine ctos(x,y,z,r,theta,phi) r1 = x*x+y*y if(r1 .ne. 0.) go to 10 phi = 0. theta = 0. if(z .lt. 0.) theta = 4.*atan(1.) return 10 r = sqrt(r1+z*z) r1 = sqrt(r1) phi = atan2(y,x) theta = atan2(r1,z) return end subroutine daxpy(n,da,dx,incx,dy,incy) c c constant times a vector plus a vector. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),da integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (da .eq. 0.0d0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dy(i) + da*dx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i + 1) = dy(i + 1) + da*dx(i + 1) dy(i + 2) = dy(i + 2) + da*dx(i + 2) dy(i + 3) = dy(i + 3) + da*dx(i + 3) 50 continue return end double precision function ddot(n,dx,incx,dy,incy) c c forms the dot product of two vectors. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n c ddot = 0.0d0 dtemp = 0.0d0 if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dtemp = dtemp + dx(ix)*dy(iy) ix = ix + incx iy = iy + incy 10 continue ddot = dtemp return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dtemp + dx(i)*dy(i) 30 continue if( n .lt. 5 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,5 dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) 50 continue 60 ddot = dtemp return end subroutine diag(m,n,xp,yp,iflag) c c **** label visibility of cell sides c c north side corresponds to j c south side corresponds to j+1 c west side corresponds to i c east side corresponds to i+1 c c let iflag = b4 b3 b2 b1 b0 (in binary) then b0 through b3 are c either o or 1 depeending on whether the east, south, north c or west side is either invisible or visible, respectively. c c b4 is o if the diagonal is from (i,j) to (i+1,j+1) and 1 if c the diagonal is from (i,j+1) to (i+1,j). c dimension xp(n,m),yp(n,m),iflag(n,m) c **** arithmetic statement function cp(j1,i1,j2,i2,j3,i3)=((xp(j1,i1)-xp(j2,i2))*(yp(j3,i3)-yp(j2,i2)) 1-(xp(j3,i3)-xp(j2,i2))*(yp(j1,i1)-yp(j2,i2))) do 100 j=2,n-2 do 100 i=1,m-1 if(iflag(j,i) .ge. 16) go to 20 if(cp(j+1,i+1,j+1,i,j,i) .le. 0) go to 10 c west and south are visible iflag(j,i) = iflag(j,i)+10 10 if(cp(j,i,j,i+1,j+1,i+1) .le. 0) go to 100 c east and north are visible iflag(j,i) = iflag(j,i)+5 go to 100 20 if(cp(j+1,i,j,i,j,i+1) .le. 0) go to 30 c west and north are visible iflag(j,i) = iflag(j,i)+12 30 if(cp(j,i+1,j+1,i+1,j+1,i) .le. 0) go to 100 c east and south are visible iflag(j,i) = iflag(j,i)+3 100 continue c c classify the poles c do 200 i=1,m-1 iflag(1,i) = 0 if(cp(2,i+1,2,i,1,i) .gt. 0) iflag(1,i) = 15 iflag(n-1,i) = 0 if(cp(n,i,n-1,i,n-1,i+1) .gt. 0) iflag(n-1,i) = 31 200 continue do 250 j=1,n-1 iflag(j,m) = iflag(j,1) 250 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file divec.f c c this file includes documentation and code for c subroutine divec i c c ... files which must be loaded with divec.f c c sphcom.f, hrfft.f, vhaec.f,shsec.f c c c subroutine divec(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, c + wshsec,lshsec,work,lwork,ierror) c c given the vector spherical harmonic coefficients br and bi, precomputed c by subroutine vhaec for a vector field (v,w), subroutine divec c computes the divergence of the vector field in the scalar array dv. c dv(i,j) is the divergence at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. i.e. c c dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ] c c where sint = sin(theta(i)). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c br,bi were precomputed. required associated legendre polynomials c are recomputed rather than stored as they are in subroutine dives. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the divergence is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case the c divergence is neither symmetric nor antisymmetric about c the equator. the divergence is computed on the entire c sphere. i.e., in the array dv(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case the divergence is antisymmetyric about c the equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the divergence is computed c in the array dv(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the divergence is computed c in the array dv(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c w is symmetric and v is antisymmetric about the equator c in this case the divergence is symmetyric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the divergence is computed c in the array dv(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the divergence is computed c in the array dv(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute the divergence for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the array dv as it appears in c the program that calls divec. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the array dv as it appears in c the program that calls divec. jdv must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaec. c *** br and bi must be computed by vhaec prior to calling c divec. c c mdb the first dimension of the arrays br and bi as it c appears in the program that calls divec. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br and bi as it c appears in the program that calls divec. ndb must be at c least nlat. c c c wshsec an array which must be initialized by subroutine shseci. c once initialized, c wshsec can be used repeatedly by divec as long as nlon c and nlat remain unchanged. wshsec must not be altered c between calls of divec. c c c lshsec the dimension of the array wshsec as it appears in the c program that calls divec. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsec must be at least c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls divec. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) c c if isym is not zero then lwork must be at least c c l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c dv a two or three dimensional array (see input parameter nt) c that contains the divergence of the vector field (v,w) c whose coefficients br,bi where computed by subroutine c vhaec. dv(i,j) is the divergence at the colatitude point c theta(i) = (i-1)*pi/(nlat-1) and longitude point c lambda(j) = (j-1)*2*pi/nlon. the index ranges are defined c above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsec c = 10 error in the specification of lwork c ********************************************************************** c subroutine divec(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, + wshsec,lshsec,work,lwork,ierror) dimension dv(idv,jdv,nt),br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension wshsec(lshsec),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. 1 (isym.gt.0 .and. idv.lt.imid)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 if(mdb .lt. min0(nlat,(nlon+1)/2)) return mmax = min0(nlat,(nlon+2)/2) ierror = 8 if(ndb .lt. nlat) return ierror = 9 c c verify saved work space (same as shsec) c imid = (nlat+1)/2 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 lwmin = lzz1+labc+nlon+15 if(lshsec .lt. lwmin) return c c verify unsaved work space (add to what shec requires) c ierror = 10 ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shsec) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt c if(lwork .lt. nln+max0(ls*nlon,3*nlat*imid)+2*mn+nlat) return l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 if (isym .eq. 0) then lwkmin = nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call divec1(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, +work(ia),work(ib),mab,work(is),wshsec,lshsec,work(iwk),lwk, +ierror) return end subroutine divec1(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, + a,b,mab,sqnn,wshsec,lshsec,wk,lwk,ierror) dimension dv(idv,jdv,nt),br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension a(mab,nlat,nt),b(mab,nlat,nt),sqnn(nlat) dimension wshsec(lshsec),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute divergence scalar coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = -sqnn(n)*br(1,n,k) b(1,n,k) = -sqnn(n)*bi(1,n,k) 5 continue c c compute m>0 coefficients using vector spherepack value for mmax c mmax = min0(nlat,(nlon+1)/2) do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = -sqnn(n)*br(m,n,k) b(m,n,k) = -sqnn(n)*bi(m,n,k) 7 continue 6 continue 2 continue c c synthesize a,b into dv c call shsec(nlat,nlon,isym,nt,dv,idv,jdv,a,b, + mab,nlat,wshsec,lshsec,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file dives.f c c this file includes documentation and code for c subroutine dives i c c ... files which must be loaded with dives.f c c sphcom.f, hrfft.f, vhaes.f,shses.f c c c subroutine dives(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, c + wshses,lshses,work,lwork,ierror) c c given the vector spherical harmonic coefficients br and bi, precomputed c by subroutine vhaes for a vector field (v,w), subroutine dives c computes the divergence of the vector field in the scalar array dv. c dv(i,j) is the divergence at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. i.e. c c dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ] c c where sint = sin(theta(i)). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c br,bi were precomputed. required associated legendre polynomials c are stored rather than recomputed as they are in subroutine divec. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the divergence is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case the c divergence is neither symmetric nor antisymmetric about c the equator. the divergence is computed on the entire c sphere. i.e., in the array dv(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case the divergence is antisymmetyric about c the equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the divergence is computed c in the array dv(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the divergence is computed c in the array dv(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c w is symmetric and v is antisymmetric about the equator c in this case the divergence is symmetyric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the divergence is computed c in the array dv(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the divergence is computed c in the array dv(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute the divergence for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the array dv as it appears in c the program that calls dives. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the array dv as it appears in c the program that calls dives. jdv must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaes. c *** br and bi must be computed by vhaes prior to calling c dives. c c mdb the first dimension of the arrays br and bi as it c appears in the program that calls dives. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br and bi as it c appears in the program that calls dives. ndb must be at c least nlat. c c c wshses an array which must be initialized by subroutine shsesi c once initialized, c wshses can be used repeatedly by dives as long as nlon c and nlat remain unchanged. wshses must not be altered c between calls of dives. wdives is identical to the saved c work space initialized by subroutine shsesi and can be c set by calling that subroutine instead of divesi. c c c lshses the dimension of the array wshses as it appears in the c program that calls dives. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshses must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls dives. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*((nt+1)*nlon+2*nt*l1+1) c c if isym > 0 then lwork must be at least c c (nt+1)*l2*nlon+nlat*(2*nt*l1+1) c c ************************************************************** c c output parameters c c c dv a two or three dimensional array (see input parameter nt) c that contains the divergence of the vector field (v,w) c whose coefficients br,bi where computed by subroutine c vhaes. dv(i,j) is the divergence at the colatitude point c theta(i) = (i-1)*pi/(nlat-1) and longitude point c lambda(j) = (j-1)*2*pi/nlon. the index ranges are defined c above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshses c = 10 error in the specification of lwork c ********************************************************************** c c subroutine dives(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, + wshses,lshses,work,lwork,ierror) dimension dv(idv,jdv,nt),br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension wshses(lshses),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. 1 (isym.gt.0 .and. idv.lt.imid)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 if(mdb .lt. min0(nlat,(nlon+1)/2)) return mmax = min0(nlat,(nlon+2)/2) ierror = 8 if(ndb .lt. nlat) return ierror = 9 c c verify save work space (same as shes, file f3) c imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshses .lt. lpimn+nlon+15) return ierror = 10 c c verify unsaved work space (add to what shses requires, file f3) c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shses) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt if(lwork.lt. nln+ls*nlon+2*mn+nlat) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call dives1(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, +work(ia),work(ib),mab,work(is),wshses,lshses,work(iwk),lwk, +ierror) return end subroutine dives1(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, + a,b,mab,sqnn,wshses,lshses,wk,lwk,ierror) dimension dv(idv,jdv,nt),br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension a(mab,nlat,nt),b(mab,nlat,nt),sqnn(nlat) dimension wshses(lshses),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute divergence scalar coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = -sqnn(n)*br(1,n,k) b(1,n,k) = -sqnn(n)*bi(1,n,k) 5 continue c c compute m>0 coefficients using vector spherepack value for mmax c mmax = min0(nlat,(nlon+1)/2) do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = -sqnn(n)*br(m,n,k) b(m,n,k) = -sqnn(n)*bi(m,n,k) 7 continue 6 continue 2 continue c c synthesize a,b into dv c call shses(nlat,nlon,isym,nt,dv,idv,jdv,a,b, + mab,nlat,wshses,lshses,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file divgc.f c c this file includes documentation and code for c subroutine divgc i c c ... files which must be loaded with divgc.f c c sphcom.f, hrfft.f, vhagc.f, shsgc.f, gaqd.f c c c subroutine divgc(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, c + wshsgc,lshsgc,work,lwork,ierror) c c given the vector spherical harmonic coefficients br and bi, precomputed c by subroutine vhagc for a vector field (v,w), subroutine divgc c computes the divergence of the vector field in the scalar array dv. c dv(i,j) is the divergence at the gaussian colatitude point theta(i) c (see nlat as input parameter) and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. i.e. c c dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ] c c where sint = sin(theta(i)). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c br,bi were precomputed. required associated legendre polynomials c are recomputed rather than stored as they are in subroutine divgs. c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the divergence is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case the c divergence is neither symmetric nor antisymmetric about c the equator. the divergence is computed on the entire c sphere. i.e., in the array dv(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case the divergence is antisymmetyric about c the equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the divergence is computed c in the array dv(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the divergence is computed c in the array dv(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c w is symmetric and v is antisymmetric about the equator c in this case the divergence is symmetyric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the divergence is computed c in the array dv(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the divergence is computed c in the array dv(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c in the program that calls divgc, the arrays br,bi, and dv c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute the divergence for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the array dv as it appears in c the program that calls divgc. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the array dv as it appears in c the program that calls divgc. jdv must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhagc. c *** br and bi must be computed by vhagc prior to calling c divgc. c c mdb the first dimension of the arrays br and bi as it c appears in the program that calls divgc. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br and bi as it c appears in the program that calls divgc. ndb must be at c least nlat. c c c wshsgc an array which must be initialized by subroutine shsgci c once initialized, wshsgc can be used repeatedly by divgc c as long as nlon and nlat remain unchanged. wshsgc must c not be altered between calls of divgc. c c c lshsgc the dimension of the array wshsgc as it appears in the c program that calls divgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls divgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c c if isym is zero then lwork must be at least c c nlat*(nlon*nt+max0(3*l2,nlon) + 2*nt*l1+1) c c if isym is not zero then lwork must be at least c c l2*(nlon*nt+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c dv a two or three dimensional array (see input parameter nt) c that contains the divergence of the vector field (v,w) c whose coefficients br,bi where computed by subroutine c vhagc. dv(i,j) is the divergence at the gaussian colatitude c point theta(i) and longitude point lambda(j) = (j-1)*2*pi/nlon. c the index ranges are defined above at the input parameter c isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsgc c = 10 error in the specification of lwork c ********************************************************************** c c subroutine divgc(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, + wshsgc,lshsgc,work,lwork,ierror) dimension dv(idv,jdv,nt),br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension wshsgc(lshsgc),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. 1 (isym.gt.0 .and. idv.lt.imid)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 if(mdb .lt. min0(nlat,(nlon+1)/2)) return mmax = min0(nlat,(nlon+2)/2) ierror = 8 if(ndb .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 c check permanent work space length l2 = (nlat+1)/2 l1 = min0((nlon+2)/2,nlat) if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 10 c c verify unsaved work space (add to what shsgc requires) c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shsgc) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt c if(lwork.lt. nln+ls*nlon+2*mn+nlat) return l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 if (isym .eq. 0) then lwkmin = nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call divgc1(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, +work(ia),work(ib),mab,work(is),wshsgc,lshsgc,work(iwk),lwk, +ierror) return end subroutine divgc1(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb, + a,b,mab,sqnn,wshsgc,lshsgc,wk,lwk,ierror) dimension dv(idv,jdv,nt),br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension a(mab,nlat,nt),b(mab,nlat,nt),sqnn(nlat) dimension wshsgc(lshsgc),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute divergence scalar coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = -sqnn(n)*br(1,n,k) b(1,n,k) = -sqnn(n)*bi(1,n,k) 5 continue c c compute m>0 coefficients using vector spherepack value for mmax c mmax = min0(nlat,(nlon+1)/2) do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = -sqnn(n)*br(m,n,k) b(m,n,k) = -sqnn(n)*bi(m,n,k) 7 continue 6 continue 2 continue c c synthesize a,b into dv c call shsgc(nlat,nlon,isym,nt,dv,idv,jdv,a,b, + mab,nlat,wshsgc,lshsgc,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c c ... file divgs.f c c this file includes documentation and code for c subroutine divgs i c c ... files which must be loaded with divgs.f c c sphcom.f, hrfft.f, vhags.f, shsgs.f, gaqd.f c c c subroutine divgs(nlat,nlon,isym,nt,divg,idiv,jdiv,br,bi,mdb,ndb, c + wshsgs,lshsgs,work,lwork,ierror) c c given the vector spherical harmonic coefficients br and bi, precomputed c by subroutine vhags for a vector field (v,w), subroutine divgs c computes the divergence of the vector field in the scalar array divg. c divg(i,j) is the divergence at the gaussian colatitude point theta(i) c (see nlat as input parameter) and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. i.e. c c dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ] c c where sint = sin(theta(i)). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c br,bi were precomputed c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the divergence is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case the c divergence is neither symmetric nor antisymmetric about c the equator. the divergence is computed on the entire c sphere. i.e., in the array divg(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case the divergence is antisymmetyric about c the equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the divergence is computed c in the array divg(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the divergence is computed c in the array divg(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c w is symmetric and v is antisymmetric about the equator c in this case the divergence is symmetyric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the divergence is computed c in the array divg(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the divergence is computed c in the array divg(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c in the program that calls divgs, the arrays br,bi, and divg c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute the divergence for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idiv the first dimension of the array divg as it appears in c the program that calls divgs. if isym = 0 then idiv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idiv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idiv must be at least (nlat+1)/2. c c jdiv the second dimension of the array divg as it appears in c the program that calls divgs. jdiv must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhags. c *** br and bi must be computed by vhags prior to calling c divgs. c c mdb the first dimension of the arrays br and bi as it c appears in the program that calls divgs. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br and bi as it c appears in the program that calls divgs. ndb must be at c least nlat. c c c wshsgs an array which must be intialized by subroutine shsgsi. c once initialized, c wshsgs can be used repeatedly by divgs as long as nlon c and nlat remain unchanged. wshsgs must not be altered c between calls of divgs. c c c lshsgs the dimension of the array wshsgs as it appears in the c program that calls divgs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgs must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls divgs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*((nt+1)*nlon+2*nt*l1+1) c c if isym > 0 then lwork must be at least c c (nt+1)*l2*nlon+nlat*(2*nt*l1+1) c c ************************************************************** c c output parameters c c c divg a two or three dimensional array (see input parameter nt) c that contains the divergence of the vector field (v,w) c whose coefficients br,bi where computed by subroutine c vhags. divg(i,j) is the divergence at the gaussian colatitude c point theta(i) and longitude point lambda(j) = (j-1)*2*pi/nlon. c the index ranges are defined above at the input parameter c isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idiv c = 6 error in the specification of jdiv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsgs c = 10 error in the specification of lwork c ********************************************************************** c c subroutine divgs(nlat,nlon,isym,nt,divg,idiv,jdiv,br,bi,mdb,ndb, + wshsgs,lshsgs,work,lwork,ierror) dimension divg(idiv,jdiv,nt),br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension wshsgs(lshsgs),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idiv.lt.nlat) .or. 1 (isym.gt.0 .and. idiv.lt.imid)) return ierror = 6 if(jdiv .lt. nlon) return ierror = 7 if(mdb .lt. min0(nlat,(nlon+1)/2)) return mmax = min0(nlat,(nlon+2)/2) ierror = 8 if(ndb .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 c check permanent work space length l2 = (nlat+1)/2 l1 = min0((nlon+2)/2,nlat) lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshsgs.lt.lp) return ierror = 10 c c verify unsaved work space (add to what shses requires, file f3) c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shses) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt if(lwork.lt. nln+ls*nlon+2*mn+nlat) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call divgs1(nlat,nlon,isym,nt,divg,idiv,jdiv,br,bi,mdb,ndb, +work(ia),work(ib),mab,work(is),wshsgs,lshsgs,work(iwk),lwk, +ierror) return end subroutine divgs1(nlat,nlon,isym,nt,divg,idiv,jdiv,br,bi,mdb,ndb, + a,b,mab,sqnn,wshsgs,lshsgs,wk,lwk,ierror) dimension divg(idiv,jdiv,nt),br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension a(mab,nlat,nt),b(mab,nlat,nt),sqnn(nlat) dimension wshsgs(lshsgs),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute divergence scalar coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = -sqnn(n)*br(1,n,k) b(1,n,k) = -sqnn(n)*bi(1,n,k) 5 continue c c compute m>0 coefficients using vector spherepack value for mmax c mmax = min0(nlat,(nlon+1)/2) do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = -sqnn(n)*br(m,n,k) b(m,n,k) = -sqnn(n)*bi(m,n,k) 7 continue 6 continue 2 continue c c synthesize a,b into divg c call shsgs(nlat,nlon,isym,nt,divg,idiv,jdiv,a,b, + mab,nlat,wshsgs,lshsgs,wk,lwk,ierror) return end c subroutine dlfkg(m,n,cp) c c subroutine dlfkg computes the coefficients in the trigonometric c expansion of the normalized associated legendre functions: c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta) c c where theta is colatitude. c c subroutine dlfkg computes the coefficients cp(k) in the c following trigonometric expansion of pbar(m,n,theta). c c 1) for n even and m even, pbar(m,n,theta) = c .5*cp(1) plus the sum from k=1 to k=n/2 c of cp(k)*cos(2*k*th) c c 2) for n even and m odd, pbar(m,n,theta) = c the sum from k=1 to k=n/2 of c cp(k)*sin(2*k*th) c c 3) for n odd and m even, pbar(m,n,theta) = c the sum from k=1 to k=(n+1)/2 of c cp(k)*cos((2*k-1)*th) c c 4) for n odd and m odd, pbar(m,n,theta) = c the sum from k=1 to k=(n+1)/2 of c cp(k)*sin((2*k-1)*th) c c input parameters c c m is the order of pbar(n,m,theta). m can be any integer c however pbar(n,m,theta) = 0 if abs(m) is greater than c n and pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta) for c negative m. c c n nonnegative integer specifying the degree of c pbar(n,m,theta) c c output parameters c c cp a double precision array that contains the fourier c coefficients for pbar(m,n,theta). the length of the c array depends on the parity of m and n c c parity length of cp c c n even m even n/2+1 c n even m odd n/2 c n odd m even (n+1)/2 c n odd m odd (n+1)/2 c c c **************************************************************** subroutine dlfkg (m,n,cp) c double precision cp,fnum,fden,fnmh,a1,b1,c1,cp2,fnnp1,fnmsq,fk, 1 t1,t2,pm1,sc10,sc20,sc40 dimension cp(1) parameter (sc10=1024.d0) parameter (sc20=sc10*sc10) parameter (sc40=sc20*sc20) c cp(1) = 0. ma = iabs(m) if(ma .gt. n) return if(n-1) 2,3,5 2 cp(1) = dsqrt(2.d0) return 3 if(ma .ne. 0) go to 4 cp(1) = dsqrt(1.5d0) return 4 cp(1) = dsqrt(.75d0) if(m .eq. -1) cp(1) = -cp(1) return 5 if(mod(n+ma,2) .ne. 0) go to 10 nmms2 = (n-ma)/2 fnum = n+ma+1 fnmh = n-ma+1 pm1 = 1.d0 go to 15 10 nmms2 = (n-ma-1)/2 fnum = n+ma+2 fnmh = n-ma+2 pm1 = -1.d0 15 t1 = 1.d0/sc20 nex = 20 fden = 2.d0 if(nmms2 .lt. 1) go to 20 do 18 i=1,nmms2 t1 = fnum*t1/fden if(t1 .gt. sc20) then t1 = t1/sc40 nex = nex+40 end if fnum = fnum+2. fden = fden+2. 18 continue 20 t1 = t1/2.d0**(n-1-nex) if(mod(ma/2,2) .ne. 0) t1 = -t1 t2 = 1. if(ma .eq. 0) go to 26 do 25 i=1,ma t2 = fnmh*t2/(fnmh+pm1) fnmh = fnmh+2. 25 continue 26 cp2 = t1*dsqrt((n+.5d0)*t2) fnnp1 = n*(n+1) fnmsq = fnnp1-2.d0*ma*ma l = (n+1)/2 if(mod(n,2) .eq. 0 .and. mod(ma,2) .eq. 0) l = l+1 cp(l) = cp2 if(m .ge. 0) go to 29 if(mod(ma,2) .ne. 0) cp(l) = -cp(l) 29 if(l .le. 1) return fk = n a1 = (fk-2.)*(fk-1.)-fnnp1 b1 = 2.*(fk*fk-fnmsq) cp(l-1) = b1*cp(l)/a1 30 l = l-1 if(l .le. 1) return fk = fk-2. a1 = (fk-2.)*(fk-1.)-fnnp1 b1 = -2.*(fk*fk-fnmsq) c1 = (fk+1.)*(fk+2.)-fnnp1 cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1 go to 30 end c subroutine dlfkp(m,n,cp) c c subroutine dlfkp computes the coefficients in the trigonometric c expansion of the normalized associated legendre functions: c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta) c c where theta is colatitude. c c subroutine dlfkp computes the coefficients cp(k) in the c following trigonometric expansion of pbar(m,n,theta). c c 1) for n even and m even, pbar(m,n,theta) = c .5*cp(1) plus the sum from k=1 to k=n/2 c of cp(k)*cos(2*k*th) c c 2) for n even and m odd, pbar(m,n,theta) = c the sum from k=1 to k=n/2 of c cp(k)*sin(2*k*th) c c 3) for n odd and m even, pbar(m,n,theta) = c the sum from k=1 to k=(n+1)/2 of c cp(k)*cos((2*k-1)*th) c c 4) for n odd and m odd, pbar(m,n,theta) = c the sum from k=1 to k=(n+1)/2 of c cp(k)*sin((2*k-1)*th) c c input parameters c c m is the order of pbar(n,m,theta). m can be any integer c however pbar(n,m,theta) = 0 if abs(m) is greater than c n and pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta) for c negative m. c c n nonnegative integer specifying the degree of c pbar(n,m,theta) c c output parameters c c cp a double precision array that contains the fourier c coefficients for pbar(m,n,theta). the length of the c array depends on the parity of m and n c c parity length of cp c c n even m even n/2+1 c n even m odd n/2 c n odd m even (n+1)/2 c n odd m odd (n+1)/2 c c c **************************************************************** subroutine dlfkp (m,n,cp) c double precision cp,fnum,fden,fnmh,a1,b1,c1,cp2,fnnp1,fnmsq,fk, 1 t1,t2,pm1,sc10,sc20,sc40 dimension cp(1) parameter (sc10=1024.d0) parameter (sc20=sc10*sc10) parameter (sc40=sc20*sc20) c cp(1) = 0. ma = iabs(m) if(ma .gt. n) return if(n-1) 2,3,5 2 cp(1) = dsqrt(2.d0) return 3 if(ma .ne. 0) go to 4 cp(1) = dsqrt(1.5d0) return 4 cp(1) = dsqrt(.75d0) if(m .eq. -1) cp(1) = -cp(1) return 5 if(mod(n+ma,2) .ne. 0) go to 10 nmms2 = (n-ma)/2 fnum = n+ma+1 fnmh = n-ma+1 pm1 = 1.d0 go to 15 10 nmms2 = (n-ma-1)/2 fnum = n+ma+2 fnmh = n-ma+2 pm1 = -1.d0 c t1 = 1. c t1 = 2.d0**(n-1) c t1 = 1.d0/t1 15 t1 = 1.d0/sc20 nex = 20 fden = 2.d0 if(nmms2 .lt. 1) go to 20 do 18 i=1,nmms2 t1 = fnum*t1/fden if(t1 .gt. sc20) then t1 = t1/sc40 nex = nex+40 end if fnum = fnum+2. fden = fden+2. 18 continue 20 t1 = t1/2.d0**(n-1-nex) if(mod(ma/2,2) .ne. 0) t1 = -t1 t2 = 1. if(ma .eq. 0) go to 26 do 25 i=1,ma t2 = fnmh*t2/(fnmh+pm1) fnmh = fnmh+2. 25 continue 26 cp2 = t1*dsqrt((n+.5d0)*t2) fnnp1 = n*(n+1) fnmsq = fnnp1-2.d0*ma*ma l = (n+1)/2 if(mod(n,2) .eq. 0 .and. mod(ma,2) .eq. 0) l = l+1 cp(l) = cp2 if(m .ge. 0) go to 29 if(mod(ma,2) .ne. 0) cp(l) = -cp(l) 29 if(l .le. 1) return fk = n a1 = (fk-2.)*(fk-1.)-fnnp1 b1 = 2.*(fk*fk-fnmsq) cp(l-1) = b1*cp(l)/a1 30 l = l-1 if(l .le. 1) return fk = fk-2. a1 = (fk-2.)*(fk-1.)-fnnp1 b1 = -2.*(fk*fk-fnmsq) c1 = (fk+1.)*(fk+2.)-fnnp1 cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1 go to 30 end subroutine dlftg (m,n,theta,cp,pb) dimension cp(1) double precision cp,pb,theta,cdt,sdt,cth,sth,chh cdt = dcos(theta+theta) sdt = dsin(theta+theta) nmod=mod(n,2) mmod=mod(abs(m),2) if(nmod)1,1,2 1 if(mmod)3,3,4 c c n even, m even c 3 kdo=n/2 pb = .5*cp(1) if(n .eq. 0) return cth = cdt sth = sdt do 170 k=1,kdo c pb = pb+cp(k+1)*dcos(2*k*theta) pb = pb+cp(k+1)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 170 continue return c c n even, m odd c 4 kdo = n/2 pb = 0. cth = cdt sth = sdt do 180 k=1,kdo c pb = pb+cp(k)*dsin(2*k*theta) pb = pb+cp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 180 continue return 2 if(mmod)13,13,14 c c n odd, m even c 13 kdo = (n+1)/2 pb = 0. cth = dcos(theta) sth = dsin(theta) do 190 k=1,kdo c pb = pb+cp(k)*dcos((2*k-1)*theta) pb = pb+cp(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 190 continue return c c n odd, m odd c 14 kdo = (n+1)/2 pb = 0. cth = dcos(theta) sth = dsin(theta) do 200 k=1,kdo c pb = pb+cp(k)*dsin((2*k-1)*theta) pb = pb+cp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 200 continue return end subroutine dlftp (m,n,theta,cp,pb) dimension cp(1) double precision cp,pb,theta,cdt,sdt,cth,sth,chh cdt = dcos(theta+theta) sdt = dsin(theta+theta) nmod=mod(n,2) mmod=mod(abs(m),2) if(nmod)1,1,2 1 if(mmod)3,3,4 c c n even, m even c 3 kdo=n/2 pb = .5*cp(1) if(n .eq. 0) return cth = cdt sth = sdt do 170 k=1,kdo c pb = pb+cp(k+1)*dcos(2*k*theta) pb = pb+cp(k+1)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 170 continue return c c n even, m odd c 4 kdo = n/2 pb = 0. cth = cdt sth = sdt do 180 k=1,kdo c pb = pb+cp(k)*dsin(2*k*theta) pb = pb+cp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 180 continue return 2 if(mmod)13,13,14 c c n odd, m even c 13 kdo = (n+1)/2 pb = 0. cth = dcos(theta) sth = dsin(theta) do 190 k=1,kdo c pb = pb+cp(k)*dcos((2*k-1)*theta) pb = pb+cp(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 190 continue return c c n odd, m odd c 14 kdo = (n+1)/2 pb = 0. cth = dcos(theta) sth = dsin(theta) do 200 k=1,kdo c pb = pb+cp(k)*dsin((2*k-1)*theta) pb = pb+cp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 200 continue return end subroutine dmxmx(lr,lc,ld,a,mc,md,b,x,y) double precision a(ld,*),b(md,*),x(ld,2),y(ld,2), 1 sum1,sum2 do k=1,lr y(k,1) = 0. y(k,2) = 0. end do c if(lc.le.0) return do i=1,lc sum1 = 0. sum2 = 0. do j=1,mc sum1 = sum1 + b(i,j)*x(j,1) sum2 = sum2 + b(i,j)*x(j,2) end do do k=1,lr y(k,1) = y(k,1)+sum1*a(k,i) y(k,2) = y(k,2)+sum2*a(k,i) end do end do return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file sphcom.f c c this file must be loaded with all driver level files c in spherepack3.0. it includes undocumented subroutines c called by some or all of the drivers c subroutine dnlfk (m,n,cp) c c cp requires n/2+1 double precision locations c double precision cp,fnum,fden,fnmh,a1,b1,c1,cp2,fnnp1,fnmsq,fk, 1 t1,t2,pm1,sc10,sc20,sc40 dimension cp(1) parameter (sc10=1024.d0) parameter (sc20=sc10*sc10) parameter (sc40=sc20*sc20) c cp(1) = 0. ma = iabs(m) if(ma .gt. n) return if(n-1) 2,3,5 2 cp(1) = dsqrt(2.d0) return 3 if(ma .ne. 0) go to 4 cp(1) = dsqrt(1.5d0) return 4 cp(1) = dsqrt(.75d0) if(m .eq. -1) cp(1) = -cp(1) return 5 if(mod(n+ma,2) .ne. 0) go to 10 nmms2 = (n-ma)/2 fnum = n+ma+1 fnmh = n-ma+1 pm1 = 1.d0 go to 15 10 nmms2 = (n-ma-1)/2 fnum = n+ma+2 fnmh = n-ma+2 pm1 = -1.d0 c t1 = 1. c t1 = 2.d0**(n-1) c t1 = 1.d0/t1 15 t1 = 1.d0/sc20 nex = 20 fden = 2.d0 if(nmms2 .lt. 1) go to 20 do 18 i=1,nmms2 t1 = fnum*t1/fden if(t1 .gt. sc20) then t1 = t1/sc40 nex = nex+40 end if fnum = fnum+2. fden = fden+2. 18 continue 20 t1 = t1/2.d0**(n-1-nex) if(mod(ma/2,2) .ne. 0) t1 = -t1 t2 = 1. if(ma .eq. 0) go to 26 do 25 i=1,ma t2 = fnmh*t2/(fnmh+pm1) fnmh = fnmh+2. 25 continue 26 cp2 = t1*dsqrt((n+.5d0)*t2) fnnp1 = n*(n+1) fnmsq = fnnp1-2.d0*ma*ma l = (n+1)/2 if(mod(n,2) .eq. 0 .and. mod(ma,2) .eq. 0) l = l+1 cp(l) = cp2 if(m .ge. 0) go to 29 if(mod(ma,2) .ne. 0) cp(l) = -cp(l) 29 if(l .le. 1) return fk = n a1 = (fk-2.)*(fk-1.)-fnnp1 b1 = 2.*(fk*fk-fnmsq) cp(l-1) = b1*cp(l)/a1 30 l = l-1 if(l .le. 1) return fk = fk-2. a1 = (fk-2.)*(fk-1.)-fnnp1 b1 = -2.*(fk*fk-fnmsq) c1 = (fk+1.)*(fk+2.)-fnnp1 cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1 go to 30 end subroutine dnlft (m,n,theta,cp,pb) double precision cp(*),pb,theta,cdt,sdt,cth,sth,chh cdt = dcos(theta+theta) sdt = dsin(theta+theta) nmod=mod(n,2) mmod=mod(m,2) if(nmod)1,1,2 1 if(mmod)3,3,4 c c n even, m even c 3 kdo=n/2 pb = .5*cp(1) if(n .eq. 0) return cth = cdt sth = sdt do 170 k=1,kdo c pb = pb+cp(k+1)*dcos(2*k*theta) pb = pb+cp(k+1)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 170 continue return c c n even, m odd c 4 kdo = n/2 pb = 0. cth = cdt sth = sdt do 180 k=1,kdo c pb = pb+cp(k)*dsin(2*k*theta) pb = pb+cp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 180 continue return 2 if(mmod)13,13,14 c c n odd, m even c 13 kdo = (n+1)/2 pb = 0. cth = dcos(theta) sth = dsin(theta) do 190 k=1,kdo c pb = pb+cp(k)*dcos((2*k-1)*theta) pb = pb+cp(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 190 continue return c c n odd, m odd c 14 kdo = (n+1)/2 pb = 0. cth = dcos(theta) sth = dsin(theta) do 200 k=1,kdo c pb = pb+cp(k)*dsin((2*k-1)*theta) pb = pb+cp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 200 continue return end subroutine dnlftd (m,n,theta,cp,pb) c c computes the derivative of pmn(theta) with respect to theta c dimension cp(1) double precision cp,pb,theta,cdt,sdt,cth,sth,chh cdt = dcos(theta+theta) sdt = dsin(theta+theta) nmod=mod(n,2) mmod=mod(abs(m),2) if(nmod)1,1,2 1 if(mmod)3,3,4 c c n even, m even c 3 kdo=n/2 pb = 0.d0 if(n .eq. 0) return cth = cdt sth = sdt do 170 k=1,kdo c pb = pb+cp(k+1)*dcos(2*k*theta) pb = pb-2.d0*k*cp(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 170 continue return c c n even, m odd c 4 kdo = n/2 pb = 0. cth = cdt sth = sdt do 180 k=1,kdo c pb = pb+cp(k)*dsin(2*k*theta) pb = pb+2.d0*k*cp(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 180 continue return 2 if(mmod)13,13,14 c c n odd, m even c 13 kdo = (n+1)/2 pb = 0. cth = dcos(theta) sth = dsin(theta) do 190 k=1,kdo c pb = pb+cp(k)*dcos((2*k-1)*theta) pb = pb-(2.d0*k-1)*cp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 190 continue return c c n odd, m odd c 14 kdo = (n+1)/2 pb = 0. cth = dcos(theta) sth = dsin(theta) do 200 k=1,kdo c pb = pb+cp(k)*dsin((2*k-1)*theta) pb = pb+(2.d0*k-1)*cp(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 200 continue return end DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, N * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * DNRM2 returns the euclidean norm of a vector via the function * name, so that * * DNRM2 := sqrt( x'*x ) * * * * -- This version written on 25-October-1982. * Modified on 14-October-1993 to inline the call to DLASSQ. * Sven Hammarling, Nag Ltd. * * * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. Local Scalars .. INTEGER IX DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. IF( N.LT.1 .OR. INCX.LT.1 )THEN NORM = ZERO ELSE IF( N.EQ.1 )THEN NORM = ABS( X( 1 ) ) ELSE SCALE = ZERO SSQ = ONE * The following loop is equivalent to this call to the LAPACK * auxiliary routine: * CALL DLASSQ( N, X, INCX, SCALE, SSQ ) * DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX IF( X( IX ).NE.ZERO )THEN ABSXI = ABS( X( IX ) ) IF( SCALE.LT.ABSXI )THEN SSQ = ONE + SSQ*( SCALE/ABSXI )**2 SCALE = ABSXI ELSE SSQ = SSQ + ( ABSXI/SCALE )**2 END IF END IF 10 CONTINUE NORM = SCALE * SQRT( SSQ ) END IF * DNRM2 = NORM RETURN * * End of DNRM2. * END subroutine dnzfk(nlat,m,n,cz,work) c c dnzfk computes the coefficients in the trigonometric c expansion of the z functions that are used in spherical c harmonic analysis. c dimension cz(1),work(1) c c cz and work must both have nlat/2+1 locations c double precision sum,sc1,t1,t2,work,cz lc = (nlat+1)/2 sc1 = 2.d0/float(nlat-1) call dnlfk(m,n,work) nmod = mod(n,2) mmod = mod(m,2) if(nmod)1,1,2 1 if(mmod)3,3,4 c c n even, m even c 3 kdo = n/2+1 do 5 idx=1,lc i = idx+idx-2 sum = work(1)/(1.d0-i*i) if(kdo.lt.2) go to 29 do 6 kp1=2,kdo k = kp1-1 t1 = 1.d0-(k+k+i)**2 t2 = 1.d0-(k+k-i)**2 8 sum = sum+work(kp1)*(t1+t2)/(t1*t2) 6 continue 29 cz(idx) = sc1*sum 5 continue return c c n even, m odd c 4 kdo = n/2 do 9 idx=1,lc i = idx+idx-2 sum = 0. do 101 k=1,kdo t1 = 1.d0-(k+k+i)**2 t2 = 1.d0-(k+k-i)**2 12 sum=sum+work(k)*(t1-t2)/(t1*t2) 101 continue cz(idx) = sc1*sum 9 continue return 2 if(mmod)13,13,14 c c n odd, m even c 13 kdo = (n+1)/2 do 15 idx=1,lc i = idx+idx-1 sum = 0. do 16 k=1,kdo t1 = 1.d0-(k+k-1+i)**2 t2 = 1.d0-(k+k-1-i)**2 18 sum=sum+work(k)*(t1+t2)/(t1*t2) 16 continue cz(idx)=sc1*sum 15 continue return c c n odd, m odd c 14 kdo = (n+1)/2 do 19 idx=1,lc i = idx+idx-3 sum=0. do 20 k=1,kdo t1 = 1.d0-(k+k-1+i)**2 t2 = 1.d0-(k+k-1-i)**2 22 sum=sum+work(k)*(t1-t2)/(t1*t2) 20 continue cz(idx)=sc1*sum 19 continue return end subroutine dnzft(nlat,m,n,th,cz,zh) dimension cz(1) double precision cz,zh,th,cdt,sdt,cth,sth,chh zh = 0. cdt = dcos(th+th) sdt = dsin(th+th) lmod = mod(nlat,2) mmod = mod(m,2) nmod = mod(n,2) if(lmod)20,20,10 10 lc = (nlat+1)/2 lq = lc-1 ls = lc-2 if(nmod)1,1,2 1 if(mmod)3,3,4 c c nlat odd n even m even c 3 zh = .5*(cz(1)+cz(lc)*dcos(2*lq*th)) cth = cdt sth = sdt do 201 k=2,lq c zh = zh+cz(k)*dcos(2*(k-1)*th) zh = zh+cz(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 201 continue return c c nlat odd n even m odd c 4 cth = cdt sth = sdt do 202 k=1,ls c zh = zh+cz(k+1)*dsin(2*k*th) zh = zh+cz(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 202 continue return c c nlat odd n odd, m even c 2 if(mmod)5,5,6 5 cth = dcos(th) sth = dsin(th) do 203 k=1,lq c zh = zh+cz(k)*dcos((2*k-1)*th) zh = zh+cz(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 203 continue return c c nlat odd n odd m odd c 6 cth = dcos(th) sth = dsin(th) do 204 k=1,lq c zh = zh+cz(k+1)*dsin((2*k-1)*th) zh = zh+cz(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 204 continue return 20 lc = nlat/2 lq = lc-1 if(nmod)30,30,80 30 if(mmod)40,40,60 c c nlat even n even m even c 40 zh = .5*cz(1) cth = cdt sth = sdt do 50 k=2,lc c zh = zh+cz(k)*dcos(2*(k-1)*th) zh = zh+cz(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 50 continue return c c nlat even n even m odd c 60 cth = cdt sth = sdt do 70 k=1,lq c zh = zh+cz(k+1)*dsin(2*k*th) zh = zh+cz(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 70 continue return c c nlat even n odd m even c 80 if(mmod)90,90,110 90 zh = .5*cz(lc)*dcos((nlat-1)*th) cth = dcos(th) sth = dsin(th) do 100 k=1,lq c zh = zh+cz(k)*dcos((2*k-1)*th) zh = zh+cz(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 100 continue return c c nlat even n odd m odd c 110 cth = dcos(th) sth = dsin(th) do 120 k=1,lq c zh = zh+cz(k+1)*dsin((2*k-1)*th) zh = zh+cz(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 120 continue return end subroutine drot (n,dx,incx,dy,incy,c,s) c c applies a plane rotation. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),dtemp,c,s integer i,incx,incy,ix,iy,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dtemp = c*dx(ix) + s*dy(iy) dy(iy) = c*dy(iy) - s*dx(ix) dx(ix) = dtemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n dtemp = c*dx(i) + s*dy(i) dy(i) = c*dy(i) - s*dx(i) dx(i) = dtemp 30 continue return end subroutine drotg(da,db,c,s) c c construct givens plane rotation. c jack dongarra, linpack, 3/11/78. c double precision da,db,c,s,roe,scale,r,z c roe = db if( dabs(da) .gt. dabs(db) ) roe = da scale = dabs(da) + dabs(db) if( scale .ne. 0.0d0 ) go to 10 c = 1.0d0 s = 0.0d0 r = 0.0d0 z = 0.0d0 go to 20 10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2) r = dsign(1.0d0,roe)*r c = da/r s = db/r z = 1.0d0 if( dabs(da) .gt. dabs(db) ) z = s if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c 20 da = r db = z return end subroutine dscal(n,da,dx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to one. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double precision da,dx(*) integer i,incx,m,mp1,n,nincx c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dx(i) = da*dx(i) 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da*dx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da*dx(i) dx(i + 1) = da*dx(i + 1) dx(i + 2) = da*dx(i + 2) dx(i + 3) = da*dx(i + 3) dx(i + 4) = da*dx(i + 4) 50 continue return end c subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) integer ldx,n,p,ldu,ldv,job,info double precision x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1) c c c dsvdc is a subroutine to reduce a double precision nxp matrix x c by orthogonal transformations u and v to diagonal form. the c diagonal elements s(i) are the singular values of x. the c columns of u are the corresponding left singular vectors, c and the columns of v the right singular vectors. c c on entry c c x double precision(ldx,p), where ldx.ge.n. c x contains the matrix whose singular value c decomposition is to be computed. x is c destroyed by dsvdc. c c ldx integer. c ldx is the leading dimension of the array x. c c n integer. c n is the number of rows of the matrix x. c c p integer. c p is the number of columns of the matrix x. c c ldu integer. c ldu is the leading dimension of the array u. c (see below). c c ldv integer. c ldv is the leading dimension of the array v. c (see below). c c work double precision(n). c work is a scratch array. c c job integer. c job controls the computation of the singular c vectors. it has the decimal expansion ab c with the following meaning c c a.eq.0 do not compute the left singular c vectors. c a.eq.1 return the n left singular vectors c in u. c a.ge.2 return the first min(n,p) singular c vectors in u. c b.eq.0 do not compute the right singular c vectors. c b.eq.1 return the right singular vectors c in v. c c on return c c s double precision(mm), where mm=min(n+1,p). c the first min(n,p) entries of s contain the c singular values of x arranged in descending c order of magnitude. c c e double precision(p), c e ordinarily contains zeros. however see the c discussion of info for exceptions. c c u double precision(ldu,k), where ldu.ge.n. if c joba.eq.1 then k.eq.n, if joba.ge.2 c then k.eq.min(n,p). c u contains the matrix of left singular vectors. c u is not referenced if joba.eq.0. if n.le.p c or if joba.eq.2, then u may be identified with x c in the subroutine call. c c v double precision(ldv,p), where ldv.ge.p. c v contains the matrix of right singular vectors. c v is not referenced if job.eq.0. if p.le.n, c then v may be identified with x in the c subroutine call. c c info integer. c the singular values (and their corresponding c singular vectors) s(info+1),s(info+2),...,s(m) c are correct (here m=min(n,p)). thus if c info.eq.0, all the singular values and their c vectors are correct. in any event, the matrix c b = trans(u)*x*v is the bidiagonal matrix c with the elements of s on its diagonal and the c elements of e on its super-diagonal (trans(u) c is the transpose of u). thus the singular c values of x and b are the same. c c linpack. this version dated 08/14/78 . c correction made to shift 2/84. c g.w. stewart, university of maryland, argonne national lab. c c dsvdc uses the following functions and subprograms. c c external drot c blas daxpy,ddot,dscal,dswap,dnrm2,drotg c fortran dabs,dmax1,max0,min0,mod,dsqrt c c internal variables c integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit, * mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1 c double precision ddot,t,r double precision ddot,t double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn, * smm1,t1,test,ztest logical wantu,wantv c c c set the maximum number of iterations. c maxit = 30 c c determine what is to be computed. c wantu = .false. wantv = .false. jobu = mod(job,100)/10 ncu = n if (jobu .gt. 1) ncu = min0(n,p) if (jobu .ne. 0) wantu = .true. if (mod(job,10) .ne. 0) wantv = .true. c c reduce x to bidiagonal form, storing the diagonal elements c in s and the super-diagonal elements in e. c info = 0 nct = min0(n-1,p) nrt = max0(0,min0(p-2,n)) lu = max0(nct,nrt) if (lu .lt. 1) go to 170 do 160 l = 1, lu lp1 = l + 1 if (l .gt. nct) go to 20 c c compute the transformation for the l-th column and c place the l-th diagonal in s(l). c s(l) = dnrm2(n-l+1,x(l,l),1) if (s(l) .eq. 0.0d0) go to 10 if (x(l,l) .ne. 0.0d0) s(l) = dsign(s(l),x(l,l)) call dscal(n-l+1,1.0d0/s(l),x(l,l),1) x(l,l) = 1.0d0 + x(l,l) 10 continue s(l) = -s(l) 20 continue if (p .lt. lp1) go to 50 do 40 j = lp1, p if (l .gt. nct) go to 30 if (s(l) .eq. 0.0d0) go to 30 c c apply the transformation. c t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) 30 continue c c place the l-th row of x into e for the c subsequent calculation of the row transformation. c e(j) = x(l,j) 40 continue 50 continue if (.not.wantu .or. l .gt. nct) go to 70 c c place the transformation in u for subsequent back c multiplication. c do 60 i = l, n u(i,l) = x(i,l) 60 continue 70 continue if (l .gt. nrt) go to 150 c c compute the l-th row transformation and place the c l-th super-diagonal in e(l). c e(l) = dnrm2(p-l,e(lp1),1) if (e(l) .eq. 0.0d0) go to 80 if (e(lp1) .ne. 0.0d0) e(l) = dsign(e(l),e(lp1)) call dscal(p-l,1.0d0/e(l),e(lp1),1) e(lp1) = 1.0d0 + e(lp1) 80 continue e(l) = -e(l) if (lp1 .gt. n .or. e(l) .eq. 0.0d0) go to 120 c c apply the transformation. c do 90 i = lp1, n work(i) = 0.0d0 90 continue do 100 j = lp1, p call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) 100 continue do 110 j = lp1, p call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1) 110 continue 120 continue if (.not.wantv) go to 140 c c place the transformation in v for subsequent c back multiplication. c do 130 i = lp1, p v(i,l) = e(i) 130 continue 140 continue 150 continue 160 continue 170 continue c c set up the final bidiagonal matrix or order m. c m = min0(p,n+1) nctp1 = nct + 1 nrtp1 = nrt + 1 if (nct .lt. p) s(nctp1) = x(nctp1,nctp1) if (n .lt. m) s(m) = 0.0d0 if (nrtp1 .lt. m) e(nrtp1) = x(nrtp1,m) e(m) = 0.0d0 c c if required, generate u. c if (.not.wantu) go to 300 if (ncu .lt. nctp1) go to 200 do 190 j = nctp1, ncu do 180 i = 1, n u(i,j) = 0.0d0 180 continue u(j,j) = 1.0d0 190 continue 200 continue if (nct .lt. 1) go to 290 do 280 ll = 1, nct l = nct - ll + 1 if (s(l) .eq. 0.0d0) go to 250 lp1 = l + 1 if (ncu .lt. lp1) go to 220 do 210 j = lp1, ncu t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) call daxpy(n-l+1,t,u(l,l),1,u(l,j),1) 210 continue 220 continue call dscal(n-l+1,-1.0d0,u(l,l),1) u(l,l) = 1.0d0 + u(l,l) lm1 = l - 1 if (lm1 .lt. 1) go to 240 do 230 i = 1, lm1 u(i,l) = 0.0d0 230 continue 240 continue go to 270 250 continue do 260 i = 1, n u(i,l) = 0.0d0 260 continue u(l,l) = 1.0d0 270 continue 280 continue 290 continue 300 continue c c if it is required, generate v. c if (.not.wantv) go to 350 do 340 ll = 1, p l = p - ll + 1 lp1 = l + 1 if (l .gt. nrt) go to 320 if (e(l) .eq. 0.0d0) go to 320 do 310 j = lp1, p t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) 310 continue 320 continue do 330 i = 1, p v(i,l) = 0.0d0 330 continue v(l,l) = 1.0d0 340 continue 350 continue c c main iteration loop for the singular values. c mm = m iter = 0 360 continue c c quit if all the singular values have been found. c c ...exit if (m .eq. 0) go to 620 c c if too many iterations have been performed, set c flag and return. c if (iter .lt. maxit) go to 370 info = m c ......exit go to 620 370 continue c c this section of the program inspects for c negligible elements in the s and e arrays. on c completion the variables kase and l are set as follows. c c kase = 1 if s(m) and e(l-1) are negligible and l.lt.m c kase = 2 if s(l) is negligible and l.lt.m c kase = 3 if e(l-1) is negligible, l.lt.m, and c s(l), ..., s(m) are not negligible (qr step). c kase = 4 if e(m-1) is negligible (convergence). c do 390 ll = 1, m l = m - ll c ...exit if (l .eq. 0) go to 400 test = dabs(s(l)) + dabs(s(l+1)) ztest = test + dabs(e(l)) if (ztest .ne. test) go to 380 e(l) = 0.0d0 c ......exit go to 400 380 continue 390 continue 400 continue if (l .ne. m - 1) go to 410 kase = 4 go to 480 410 continue lp1 = l + 1 mp1 = m + 1 do 430 lls = lp1, mp1 ls = m - lls + lp1 c ...exit if (ls .eq. l) go to 440 test = 0.0d0 if (ls .ne. m) test = test + dabs(e(ls)) if (ls .ne. l + 1) test = test + dabs(e(ls-1)) ztest = test + dabs(s(ls)) if (ztest .ne. test) go to 420 s(ls) = 0.0d0 c ......exit go to 440 420 continue 430 continue 440 continue if (ls .ne. l) go to 450 kase = 3 go to 470 450 continue if (ls .ne. m) go to 460 kase = 1 go to 470 460 continue kase = 2 l = ls 470 continue 480 continue l = l + 1 c c perform the task indicated by kase. c go to (490,520,540,570), kase c c deflate negligible s(m). c 490 continue mm1 = m - 1 f = e(m-1) e(m-1) = 0.0d0 do 510 kk = l, mm1 k = mm1 - kk + l t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 if (k .eq. l) go to 500 f = -sn*e(k-1) e(k-1) = cs*e(k-1) 500 continue if (wantv) call drot(p,v(1,k),1,v(1,m),1,cs,sn) 510 continue go to 610 c c split at negligible s(l). c 520 continue f = e(l-1) e(l-1) = 0.0d0 do 530 k = l, m t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 f = -sn*e(k) e(k) = cs*e(k) if (wantu) call drot(n,u(1,k),1,u(1,l-1),1,cs,sn) 530 continue go to 610 c c perform one qr step. c 540 continue c c calculate the shift. c scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)), * dabs(s(l)),dabs(e(l))) sm = s(m)/scale smm1 = s(m-1)/scale emm1 = e(m-1)/scale sl = s(l)/scale el = e(l)/scale b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0d0 c = (sm*emm1)**2 shift = 0.0d0 if (b .eq. 0.0d0 .and. c .eq. 0.0d0) go to 550 shift = dsqrt(b**2+c) if (b .lt. 0.0d0) shift = -shift shift = c/(b + shift) 550 continue f = (sl + sm)*(sl - sm) + shift g = sl*el c c chase zeros. c mm1 = m - 1 do 560 k = l, mm1 call drotg(f,g,cs,sn) if (k .ne. l) e(k-1) = f f = cs*s(k) + sn*e(k) e(k) = cs*e(k) - sn*s(k) g = sn*s(k+1) s(k+1) = cs*s(k+1) if (wantv) call drot(p,v(1,k),1,v(1,k+1),1,cs,sn) call drotg(f,g,cs,sn) s(k) = f f = cs*e(k) + sn*s(k+1) s(k+1) = -sn*e(k) + cs*s(k+1) g = sn*e(k+1) e(k+1) = cs*e(k+1) if (wantu .and. k .lt. n) * call drot(n,u(1,k),1,u(1,k+1),1,cs,sn) 560 continue e(m-1) = f iter = iter + 1 go to 610 c c convergence. c 570 continue c c make the singular value positive. c if (s(l) .ge. 0.0d0) go to 580 s(l) = -s(l) if (wantv) call dscal(p,-1.0d0,v(1,l),1) 580 continue c c order the singular value. c 590 if (l .eq. mm) go to 600 c ...exit if (s(l) .ge. s(l+1)) go to 600 t = s(l) s(l) = s(l+1) s(l+1) = t if (wantv .and. l .lt. p) * call dswap(p,v(1,l),1,v(1,l+1),1) if (wantu .and. l .lt. n) * call dswap(n,u(1,l),1,u(1,l+1),1) l = l + 1 go to 590 600 continue iter = 0 m = m - 1 610 continue go to 360 620 continue return end subroutine dswap (n,dx,incx,dy,incy) c c interchanges two vectors. c uses unrolled loops for increments equal one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dtemp = dx(ix) dx(ix) = dy(iy) dy(iy) = dtemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,3) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp 30 continue if( n .lt. 3 ) return 40 mp1 = m + 1 do 50 i = mp1,n,3 dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp dtemp = dx(i + 1) dx(i + 1) = dy(i + 1) dy(i + 1) = dtemp dtemp = dx(i + 2) dx(i + 2) = dy(i + 2) dy(i + 2) = dtemp 50 continue return end subroutine dvbk(m,n,cv,work) double precision cv(1),work(1),fn,fk,cf cv(1) = 0. if(n .le. 0) return fn = n srnp1 = dsqrt(fn*(fn+1.)) cf = 2.*m/srnp1 modn = mod(n,2) modm = mod(m,2) call dnlfk(m,n,work) if(modn .ne. 0) go to 70 ncv = n/2 if(ncv .eq. 0) return fk = 0. if(modm .ne. 0) go to 60 c c n even m even c do 55 l=1,ncv fk = fk+2. cv(l) = -fk*work(l+1)/srnp1 55 continue return c c n even m odd c 60 do 65 l=1,ncv fk = fk+2. cv(l) = fk*work(l)/srnp1 65 continue return 70 ncv = (n+1)/2 fk = -1. if(modm .ne. 0) go to 80 c c n odd m even c do 75 l=1,ncv fk = fk+2. cv(l) = -fk*work(l)/srnp1 75 continue return c c n odd m odd c 80 do 85 l=1,ncv fk = fk+2. cv(l) = fk*work(l)/srnp1 85 continue return end subroutine dvbt(m,n,theta,cv,vh) dimension cv(1) double precision cv,vh,theta,cth,sth,cdt,sdt,chh vh = 0. if(n.eq.0) return cth = dcos(theta) sth = dsin(theta) cdt = cth*cth-sth*sth sdt = 2.*sth*cth mmod = mod(m,2) nmod = mod(n,2) if(nmod .ne. 0) go to 1 cth = cdt sth = sdt if(mmod .ne. 0) go to 2 c c n even m even c ncv = n/2 do 10 k=1,ncv vh = vh+cv(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 10 continue return c c n even m odd c 2 ncv = n/2 do 15 k=1,ncv vh = vh+cv(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 15 continue return 1 if(mmod .ne. 0) go to 3 c c n odd m even c ncv = (n+1)/2 do 20 k=1,ncv vh = vh+cv(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 20 continue return c c case m odd and n odd c 3 ncv = (n+1)/2 do 25 k=1,ncv vh = vh+cv(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 25 continue return end subroutine dvtk(m,n,cv,work) double precision cv(*),work(*),fn,fk,cf,srnp1 cv(1) = 0. if(n .le. 0) return fn = n srnp1 = dsqrt(fn*(fn+1.)) cf = 2.*m/srnp1 modn = mod(n,2) modm = mod(m,2) call dnlfk(m,n,work) if(modn .ne. 0) go to 70 ncv = n/2 if(ncv .eq. 0) return fk = 0. if(modm .ne. 0) go to 60 c c n even m even c do 55 l=1,ncv fk = fk+2. cv(l) = -fk*fk*work(l+1)/srnp1 55 continue return c c n even m odd c 60 do 65 l=1,ncv fk = fk+2. cv(l) = -fk*fk*work(l)/srnp1 65 continue return 70 ncv = (n+1)/2 fk = -1. if(modm .ne. 0) go to 80 c c n odd m even c do 75 l=1,ncv fk = fk+2. cv(l) = -fk*fk*work(l)/srnp1 75 continue return c c n odd m odd c 80 do 85 l=1,ncv fk = fk+2. cv(l) = -fk*fk*work(l)/srnp1 85 continue return end subroutine dvtt(m,n,theta,cv,vh) dimension cv(1) double precision cv,vh,theta,cth,sth,cdt,sdt,chh vh = 0. if(n.eq.0) return cth = dcos(theta) sth = dsin(theta) cdt = cth*cth-sth*sth sdt = 2.*sth*cth mmod = mod(m,2) nmod = mod(n,2) if(nmod .ne. 0) go to 1 cth = cdt sth = sdt if(mmod .ne. 0) go to 2 c c n even m even c ncv = n/2 do 10 k=1,ncv vh = vh+cv(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 10 continue return c c n even m odd c 2 ncv = n/2 do 15 k=1,ncv vh = vh+cv(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 15 continue return 1 if(mmod .ne. 0) go to 3 c c n odd m even c ncv = (n+1)/2 do 20 k=1,ncv vh = vh+cv(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 20 continue return c c case m odd and n odd c 3 ncv = (n+1)/2 do 25 k=1,ncv vh = vh+cv(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 25 continue return end subroutine dwbk(m,n,cw,work) double precision cw(1),work(1),fn,cf,srnp1 cw(1) = 0. if(n.le.0 .or. m.le.0) return fn = n srnp1 = dsqrt(fn*(fn+1.)) cf = 2.*m/srnp1 modn = mod(n,2) modm = mod(m,2) call dnlfk(m,n,work) if(m .eq. 0) go to 50 if(modn .ne. 0) go to 30 l = n/2 if(l .eq. 0) go to 50 if(modm .ne. 0) go to 20 c c n even m even c cw(l) = -cf*work(l+1) 10 l = l-1 if(l .le. 0) go to 50 cw(l) = cw(l+1)-cf*work(l+1) go to 10 c c n even m odd c 20 cw(l) = cf*work(l) 25 l = l-1 if(l .le. 0) go to 50 cw(l) = cw(l+1)+cf*work(l) go to 25 30 if(modm .ne. 0) go to 40 l = (n-1)/2 if(l .eq. 0) go to 50 c c n odd m even c cw(l) = -cf*work(l+1) 35 l = l-1 if(l .le. 0) go to 50 cw(l) = cw(l+1)-cf*work(l+1) go to 35 c c n odd m odd c 40 l = (n+1)/2 cw(l) = cf*work(l) 45 l = l-1 if(l .le. 0) go to 50 cw(l) = cw(l+1)+cf*work(l) go to 45 50 return end subroutine dwbt(m,n,theta,cw,wh) dimension cw(1) double precision theta,cw,wh,cth,sth,cdt,sdt,chh wh = 0. if(n.le.0 .or. m.le.0) return cth = dcos(theta) sth = dsin(theta) cdt = cth*cth-sth*sth sdt = 2.*sth*cth mmod=mod(m,2) nmod=mod(n,2) if(nmod .ne. 0) go to 1 if(mmod .ne. 0) go to 2 c c n even m even c ncw = n/2 do 10 k=1,ncw wh = wh+cw(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 10 continue return c c n even m odd c 2 ncw = n/2 do 8 k=1,ncw wh = wh+cw(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 8 continue return 1 cth = cdt sth = sdt if(mmod .ne. 0) go to 3 c c n odd m even c ncw = (n-1)/2 do 20 k=1,ncw wh = wh+cw(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 20 continue return c c case m odd and n odd c 3 ncw = (n+1)/2 wh = .5*cw(1) if(ncw.lt.2) return do 25 k=2,ncw wh = wh+cw(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 25 continue return end subroutine dwtk(m,n,cw,work) double precision cw(*),work(*),fn,cf,srnp1 cw(1) = 0. if(n.le.0 .or. m.le.0) return fn = n srnp1 = dsqrt(fn*(fn+1.)) cf = 2.*m/srnp1 modn = mod(n,2) modm = mod(m,2) call dnlfk(m,n,work) if(m .eq. 0) go to 50 if(modn .ne. 0) go to 30 l = n/2 if(l .eq. 0) go to 50 if(modm .ne. 0) go to 20 c c n even m even c cw(l) = -cf*work(l+1) 10 l = l-1 if(l .le. 0) go to 50 cw(l) = cw(l+1)-cf*work(l+1) cw(l+1) = (l+l+1)*cw(l+1) go to 10 c c n even m odd c 20 cw(l) = cf*work(l) 25 l = l-1 if(l) 50,27,26 26 cw(l) = cw(l+1)+cf*work(l) 27 cw(l+1) = -(l+l+1)*cw(l+1) go to 25 30 if(modm .ne. 0) go to 40 l = (n-1)/2 if(l .eq. 0) go to 50 c c n odd m even c cw(l) = -cf*work(l+1) 35 l = l-1 if(l) 50,37,36 36 cw(l) = cw(l+1)-cf*work(l+1) 37 cw(l+1) = (l+l+2)*cw(l+1) go to 35 c c n odd m odd c 40 l = (n+1)/2 cw(l) = cf*work(l) 45 l = l-1 if(l) 50,47,46 46 cw(l) = cw(l+1)+cf*work(l) 47 cw(l+1) = -(l+l)*cw(l+1) go to 45 50 return end subroutine dwtt(m,n,theta,cw,wh) dimension cw(1) double precision theta,cw,wh,cth,sth,cdt,sdt,chh wh = 0. if(n.le.0 .or. m.le.0) return cth = dcos(theta) sth = dsin(theta) cdt = cth*cth-sth*sth sdt = 2.*sth*cth mmod=mod(m,2) nmod=mod(n,2) if(nmod .ne. 0) go to 1 if(mmod .ne. 0) go to 2 c c n even m even c ncw = n/2 do 10 k=1,ncw wh = wh+cw(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 10 continue return c c n even m odd c 2 ncw = n/2 do 8 k=1,ncw wh = wh+cw(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 8 continue return 1 cth = cdt sth = sdt if(mmod .ne. 0) go to 3 c c n odd m even c ncw = (n-1)/2 do 20 k=1,ncw wh = wh+cw(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 20 continue return c c case m odd and n odd c 3 ncw = (n+1)/2 wh = 0. if(ncw.lt.2) return do 25 k=2,ncw wh = wh+cw(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 25 continue return end real function dzepp (x) double precision x c c estimate unit roundoff in quantities of size x. c double precision a,b,c,eps c c this program should function properly on all systems c satisfying the following two assumptions, c 1. the base used in representing floating point c numbers is not a power of three. c 2. the quantity a in statement 10 is represented to c the accuracy used in floating point variables c that are stored in memory. c the statement number 10 and the go to 10 are intended to c force optimizing compilers to generate code satisfying c assumption 2. c under these assumptions, it should be true that, c a is not exactly equal to four-thirds, c b has a zero for its last bit or digit, c c is not exactly equal to one, c eps measures the separation of 1.0 from c the next larger floating point number. c the developers of eispack would appreciate being informed c about any systems where these assumptions do not hold. c c this version dated 4/6/83. c a = 4.0d0/3.0d0 10 b = a - 1.0d0 c = b + b + b eps = abs(c-1.0d0) if (eps .eq. 0.0d0) go to 10 dzepp = eps*dabs(x) return end real function dzeps (x) double precision x c c estimate unit roundoff in quantities of size x. c double precision a,b,c,eps c c this program should function properly on all systems c satisfying the following two assumptions, c 1. the base used in representing floating point c numbers is not a power of three. c 2. the quantity a in statement 10 is represented to c the accuracy used in floating point variables c that are stored in memory. c the statement number 10 and the go to 10 are intended to c force optimizing compilers to generate code satisfying c assumption 2. c under these assumptions, it should be true that, c a is not exactly equal to four-thirds, c b has a zero for its last bit or digit, c c is not exactly equal to one, c eps measures the separation of 1.0 from c the next larger floating point number. c the developers of eispack would appreciate being informed c about any systems where these assumptions do not hold. c c this version dated 4/6/83. c a = 4.0d0/3.0d0 10 b = a - 1.0d0 c = b + b + b eps = abs(c-1.0d0) if (eps .eq. 0.0d0) go to 10 dzeps = eps*dabs(x) return end subroutine dzvk(nlat,m,n,czv,work) c c subroutine dzvk computes the coefficients in the trigonometric c expansion of the quadrature function zvbar(n,m,theta) c c input parameters c c nlat the number of colatitudes including the poles. c c n the degree (subscript) of wbarv(n,m,theta) c c m the order (superscript) of wbarv(n,m,theta) c c work a work array with at least nlat/2+1 locations c c output parameter c c czv the fourier coefficients of zvbar(n,m,theta). c dimension czv(1),work(1) double precision czv,sc1,sum,work,t1,t2 if(n .le. 0) return lc = (nlat+1)/2 sc1 = 2.d0/float(nlat-1) call dvbk(m,n,work,czv) nmod = mod(n,2) mmod = mod(m,2) if(nmod .ne. 0) go to 1 if(mmod .ne. 0) go to 2 c c n even, m even c kdo = n/2 do 9 id=1,lc i = id+id-2 sum = 0. do 10 k=1,kdo t1 = 1.d0-(k+k+i)**2 t2 = 1.d0-(k+k-i)**2 sum = sum+work(k)*(t1-t2)/(t1*t2) 10 continue czv(id) = sc1*sum 9 continue return c c n even, m odd c 2 kdo = n/2 do 5 id=1,lc i = id+id-2 sum = 0. do 6 k=1,kdo t1 = 1.d0-(k+k+i)**2 t2 = 1.d0-(k+k-i)**2 sum = sum+work(k)*(t1+t2)/(t1*t2) 6 continue czv(id) = sc1*sum 5 continue return 1 if(mmod .ne. 0) go to 3 c c n odd, m even c kdo = (n+1)/2 do 19 id=1,lc i = id+id-3 sum = 0. do 20 k=1,kdo t1 = 1.d0-(k+k-1+i)**2 t2 = 1.d0-(k+k-1-i)**2 sum = sum+work(k)*(t1-t2)/(t1*t2) 20 continue czv(id) = sc1*sum 19 continue return c c n odd, m odd c 3 kdo = (n+1)/2 do 15 id=1,lc i = id+id-1 sum = 0. do 16 k=1,kdo t1 = 1.d0-(k+k-1+i)**2 t2 = 1.d0-(k+k-1-i)**2 sum = sum+work(k)*(t1+t2)/(t1*t2) 16 continue czv(id) = sc1*sum 15 continue return end subroutine dzvt(nlat,m,n,th,czv,zvh) c c subroutine dzvt tabulates the function zvbar(n,m,theta) c at theta = th in double precision c c input parameters c c nlat the number of colatitudes including the poles. c c n the degree (subscript) of zvbar(n,m,theta) c c m the order (superscript) of zvbar(n,m,theta) c c czv the fourier coefficients of zvbar(n,m,theta) c as computed by subroutine zwk. c c output parameter c c zvh zvbar(m,n,theta) evaluated at theta = th c dimension czv(1) double precision th,czv,zvh,cth,sth,cdt,sdt,chh zvh = 0. if(n .le. 0) return lc = (nlat+1)/2 lq = lc-1 ls = lc-2 cth = dcos(th) sth = dsin(th) cdt = cth*cth-sth*sth sdt = 2.*sth*cth lmod = mod(nlat,2) mmod = mod(m,2) nmod = mod(n,2) if(lmod .eq. 0) go to 50 if(nmod .ne. 0) go to 1 cth = cdt sth = sdt if(mmod .ne. 0) go to 2 c c nlat odd n even m even c do 10 k=1,ls zvh = zvh+czv(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 10 continue return c c nlat odd n even m odd c 2 zvh = .5*czv(1) do 20 k=2,lq zvh = zvh+czv(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 20 continue zvh = zvh+.5*czv(lc)*dcos((nlat-1)*th) return 1 if(mmod .ne. 0) go to 3 c c nlat odd n odd m even c do 30 k=1,lq zvh = zvh+czv(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 30 continue return c c nlat odd n odd m odd c 3 do 40 k=1,lq zvh = zvh+czv(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 40 continue return 50 if(nmod .ne. 0) go to 51 cth = cdt sth = sdt if(mmod .ne. 0) go to 52 c c nlat even n even m even c do 55 k=1,lq zvh = zvh+czv(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 55 continue return c c nlat even n even m odd c 52 zvh = .5*czv(1) do 57 k=2,lc zvh = zvh+czv(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 57 continue return 51 if(mmod .ne. 0) go to 53 c c nlat even n odd m even c do 58 k=1,lq zvh = zvh+czv(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 58 continue return c c nlat even n odd m odd c 53 zvh = .5*czv(lc)*dcos((nlat-1)*th) do 60 k=1,lq zvh = zvh+czv(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 60 continue return end subroutine dzwk(nlat,m,n,czw,work) c c subroutine dzwk computes the coefficients in the trigonometric c expansion of the quadrature function zwbar(n,m,theta) c c input parameters c c nlat the number of colatitudes including the poles. c c n the degree (subscript) of zwbar(n,m,theta) c c m the order (superscript) of zwbar(n,m,theta) c c work a work array with at least nlat/2+1 locations c c output parameter c c czw the fourier coefficients of zwbar(n,m,theta). c dimension czw(1),work(1) double precision czw,work,sc1,sum,t1,t2 if(n .le. 0) return lc = (nlat+1)/2 sc1 = 2.d0/float(nlat-1) call dwbk(m,n,work,czw) nmod = mod(n,2) mmod = mod(m,2) if(nmod .ne. 0) go to 1 if(mmod .ne. 0) go to 2 c c n even, m even c kdo = n/2 do 19 id=1,lc i = id+id-3 sum = 0. do 20 k=1,kdo t1 = 1.d0-(k+k-1+i)**2 t2 = 1.d0-(k+k-1-i)**2 sum = sum+work(k)*(t1-t2)/(t1*t2) 20 continue czw(id) = sc1*sum 19 continue return c c n even, m odd c 2 kdo = n/2 do 15 id=1,lc i = id+id-1 sum = 0. do 16 k=1,kdo t1 = 1.d0-(k+k-1+i)**2 t2 = 1.d0-(k+k-1-i)**2 sum = sum+work(k)*(t1+t2)/(t1*t2) 16 continue czw(id) = sc1*sum 15 continue return 1 if(mmod .ne. 0) go to 3 c c n odd, m even c kdo = (n-1)/2 do 9 id=1,lc i = id+id-2 sum = 0. do 10 k=1,kdo t1 = 1.d0-(k+k+i)**2 t2 = 1.d0-(k+k-i)**2 sum = sum+work(k)*(t1-t2)/(t1*t2) 10 continue czw(id) = sc1*sum 9 continue return c c n odd, m odd c 3 kdo = (n+1)/2 do 5 id=1,lc i = id+id-2 sum = work(1)/(1.d0-i*i) if(kdo .lt. 2) go to 29 do 6 kp1=2,kdo k = kp1-1 t1 = 1.d0-(k+k+i)**2 t2 = 1.d0-(k+k-i)**2 sum = sum+work(kp1)*(t1+t2)/(t1*t2) 6 continue 29 czw(id) = sc1*sum 5 continue return end subroutine dzwt(nlat,m,n,th,czw,zwh) c c subroutine dzwt tabulates the function zwbar(n,m,theta) c at theta = th in double precision c c input parameters c c nlat the number of colatitudes including the poles. c nlat must be an odd integer c c n the degree (subscript) of zwbar(n,m,theta) c c m the order (superscript) of zwbar(n,m,theta) c c czw the fourier coefficients of zwbar(n,m,theta) c as computed by subroutine zwk. c c output parameter c c zwh zwbar(m,n,theta) evaluated at theta = th c dimension czw(1) double precision czw,zwh,th,cth,sth,cdt,sdt,chh zwh = 0. if(n .le. 0) return lc = (nlat+1)/2 lq = lc-1 ls = lc-2 cth = dcos(th) sth = dsin(th) cdt = cth*cth-sth*sth sdt = 2.*sth*cth lmod = mod(nlat,2) mmod = mod(m,2) nmod = mod(n,2) if(lmod .eq. 0) go to 50 if(nmod .ne. 0) go to 1 if(mmod .ne. 0) go to 2 c c nlat odd n even m even c do 30 k=1,lq zwh = zwh+czw(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 30 continue return c c nlat odd n even m odd c 2 do 40 k=1,lq zwh = zwh+czw(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 40 continue return 1 cth = cdt sth = sdt if(mmod .ne. 0) go to 3 c c nlat odd n odd m even c do 10 k=1,ls zwh = zwh+czw(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 10 continue return c c nlat odd n odd m odd c 3 zwh = .5*czw(1) do 20 k=2,lq zwh = zwh+czw(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 20 continue zwh = zwh+.5*czw(lc)*dcos((nlat-1)*th) return 50 if(nmod .ne. 0) go to 51 if(mmod .ne. 0) go to 52 c c nlat even n even m even c do 55 k=1,lq zwh = zwh+czw(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 55 continue return c c nlat even n even m odd c 52 zwh = .5*czw(lc)*dcos((nlat-1)*th) do 60 k=1,lq zwh = zwh+czw(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 60 continue return 51 cth = cdt sth = sdt if(mmod .ne. 0) go to 53 c c nlat even n odd m even c do 65 k=1,lq zwh = zwh+czw(k+1)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 65 continue return c c nlat even n odd m odd c 53 zwh = .5*czw(1) do 70 k=2,lc zwh = zwh+czw(k)*cth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 70 continue return end subroutine embed(nlat,nlon,h,len,hg) dimension h(len,nlon),hg(nlat+2,nlon+1) do 10 i=1,nlat do 10 j=1,nlon hg(i+1,j) = h(i,j) 10 continue sumn = 0. sums = 0. do 15 j=1,nlon sumn = sumn+h(1,j) sums = sums+h(nlat,j) 15 continue sumn = sumn/nlon sums = sums/nlon do 20 j=1,nlon hg(1,j) = sumn hg(nlat+2,j) = sums 20 continue do 25 i=1,nlat+2 hg(i,nlon+1) = hg(i,1) 25 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c August 2003 c c c This version of gaqd implements the method presented in: c P. N. swarztrauber, Computing the points and weights for c Gauss-Legendre quadrature, SIAM J. Sci. Comput., c 24(2002) pp. 945-954. c c It the version that is new to spherepack 3.1 c The w and lwork arrays are dummy and included only to c permit a simple pluggable exchange with the c old gaqd in spherepack 3.0. c c c subroutine gaqd(nlat,theta,wts,w,lwork,ierror) c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 2001 by ucar . c . . c . university corporation for atmospheric research . c . . c . all rights reserved . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c February 2002 c c gauss points and weights are computed using the fourier-newton c described in "on computing the points and weights for c gauss-legendre quadrature", paul n. swarztrauber, siam journal c on scientific computing that has been accepted for publication. c This routine is faster and more accurate than older program c with the same name. c c subroutine gaqd computes the nlat gaussian colatitudes and weights c in double precision. the colatitudes are in radians and lie in the c in the interval (0,pi). c c input parameters c c nlat the number of gaussian colatitudes in the interval (0,pi) c (between the two poles). nlat must be greater than zero. c c w unused double precision variable that permits a simple c exchange with the old routine with the same name c in spherepack. c c lwork unused variable that permits a simple exchange with the c old routine with the same name in spherepack. c c output parameters c c theta a double precision array with length nlat c containing the gaussian colatitudes in c increasing radians on the interval (0,pi). c c wts a double precision array with lenght nlat c containing the gaussian weights. c c ierror = 0 no errors c = 1 if nlat.le.0 c c ***************************************************************** c double precision theta(nlat),wts(nlat),w, 1 x,pi,pis2,dtheta,dthalf,cmax,zprev,zlast,zero, 2 zhold,pb,dpb,dcor,sum,cz c c check work space length c ierror = 1 if (nlat.le.0) return ierror = 0 c c compute weights and points analytically when nlat=1,2 c if (nlat.eq.1) then theta(1) = dacos(0.0d0) wts(1) = 2.0d0 return end if if (nlat.eq.2) then x = dsqrt(1.0d0/3.0d0) theta(1) = dacos(x) theta(2) = dacos(-x) wts(1) = 1.0d0 wts(2) = 1.0d0 return end if eps = sqrt(dzeps(1.0d0)) eps = eps*sqrt(eps) pis2 = 2.0d0*datan(1.0d0) pi = pis2+pis2 mnlat = mod(nlat,2) ns2 = nlat/2 nhalf = (nlat+1)/2 idx = ns2+2 c call cpdp (nlat,cz,theta(ns2+1),wts(ns2+1)) c dtheta = pis2/nhalf dthalf = dtheta/2.0d0 cmax = .2d0*dtheta c c estimate first point next to theta = pi/2 c if(mnlat.ne.0) then zero = pis2-dtheta zprev = pis2 nix = nhalf-1 else zero = pis2-dthalf nix = nhalf end if 9 it = 0 10 it = it+1 zlast = zero c c newton iterations c call tpdp (nlat,zero,cz,theta(ns2+1),wts(ns2+1),pb,dpb) dcor = pb/dpb sgnd = 1.0 if(dcor .ne. 0.0d0) sgnd = dcor/dabs(dcor) dcor = sgnd*min(dabs(dcor),cmax) zero = zero-dcor if(dabs(zero-zlast).gt.eps*dabs(zero)) go to 10 theta(nix) = zero zhold = zero c wts(nix) = (nlat+nlat+1)/(dpb*dpb) c c yakimiw's formula permits using old pb and dpb c wts(nix) = (nlat+nlat+1)/(dpb+pb*dcos(zlast)/dsin(zlast))**2 nix = nix-1 if(nix.eq.0) go to 30 if(nix.eq.nhalf-1) zero = 3.0*zero-pi if(nix.lt.nhalf-1) zero = zero+zero-zprev zprev = zhold go to 9 c c extend points and weights via symmetries c 30 if(mnlat.ne.0) then theta(nhalf) = pis2 call tpdp (nlat,pis2,cz,theta(ns2+1),wts(ns2+1),pb,dpb) wts(nhalf) = (nlat+nlat+1)/(dpb*dpb) end if do i=1,ns2 wts(nlat-i+1) = wts(i) theta(nlat-i+1) = pi-theta(i) end do sum = 0.0d0 do i=1,nlat sum = sum+wts(i) end do do i=1,nlat wts(i) = 2.0d0*wts(i)/sum end do return end c subroutine gaqdp(nlat,theta,wts,w,lwork,ierror) c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 2001 by ucar . c . . c . university corporation for atmospheric research . c . . c . all rights reserved . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c April 2002 c c gauss points and weights are computed using the fourier-newton c described in "on computing the points and weights for c gauss-legendre quadrature", paul n. swarztrauber, siam journal c on scientific computing that has been accepted for publication. c This routine is faster and more accurate than older program c with the same name. c c subroutine gaqdp computes the nlat gaussian colatitudes and weights c in double precision. the colatitudes are in radians and lie in the c in the interval (0,pi). c c input parameters c c nlat the number of gaussian colatitudes in the interval (0,pi) c (between the two poles). nlat must be greater than zero. c c w unused variable that permits a simple exchange with the c old routine with the same name in spherepack. c c lwork unused variable that permits a simple exchange with the c old routine with the same name in spherepack. c c output parameters c c theta a double precision array with length nlat c containing the gaussian colatitudes in c increasing radians on the interval (0,pi). c c wts a double precision array with lenght nlat c containing the gaussian weights. c c ierror = 0 no errors c = 1 if nlat.le.0 c c ***************************************************************** c double precision theta(nlat),wts(nlat), 1 x,pi,pis2,dtheta,dthalf,cmax,zprev,zlast,zero, 2 zhold,pb,dpb,dcor,sum,w,cz c c check work space length c ierror = 1 if (nlat.le.0) return ierror = 0 c c compute weights and points analytically when nlat=1,2 c if (nlat.eq.1) then theta(1) = dacos(0.0d0) wts(1) = 2.0d0 return end if if (nlat.eq.2) then x = dsqrt(1.0d0/3.0d0) theta(1) = dacos(x) theta(2) = dacos(-x) wts(1) = 1.0d0 wts(2) = 1.0d0 return end if eps = sqrt(dzepp(1.0d0)) eps = eps*sqrt(eps) pis2 = 2.0d0*datan(1.0d0) pi = pis2+pis2 mnlat = mod(nlat,2) ns2 = nlat/2 nhalf = (nlat+1)/2 idx = ns2+2 c call cpdp1 (nlat,cz,theta(ns2+1),wts(ns2+1)) c dtheta = pis2/nhalf dthalf = dtheta/2.0d0 cmax = .2d0*dtheta c c estimate first point next to theta = pi/2 c if(mnlat.ne.0) then zero = pis2-dtheta zprev = pis2 nix = nhalf-1 else zero = pis2-dthalf nix = nhalf end if 9 it = 0 10 it = it+1 zlast = zero c c newton iterations c call tpdp1 (nlat,zero,cz,theta(ns2+1),wts(ns2+1),pb,dpb) dcor = pb/dpb sgnd = 1.0 if(dcor .ne. 0.0d0) sgnd = dcor/dabs(dcor) dcor = sgnd*min(dabs(dcor),cmax) zero = zero-dcor if(dabs(zero-zlast).gt.eps*dabs(zero)) go to 10 theta(nix) = zero zhold = zero c wts(nix) = (nlat+nlat+1)/(dpb*dpb) c c yakimiw's formula permits using old pb and dpb c wts(nix) = (nlat+nlat+1)/(dpb+pb*dcos(zlast)/dsin(zlast))**2 nix = nix-1 if(nix.eq.0) go to 30 if(nix.eq.nhalf-1) zero = 3.0*zero-pi if(nix.lt.nhalf-1) zero = zero+zero-zprev zprev = zhold go to 9 c c extend points and weights via symmetries c 30 if(mnlat.ne.0) then theta(nhalf) = pis2 call tpdp1 (nlat,pis2,cz,theta(ns2+1),wts(ns2+1),pb,dpb) wts(nhalf) = (nlat+nlat+1)/(dpb*dpb) end if do i=1,ns2 wts(nlat-i+1) = wts(i) theta(nlat-i+1) = pi-theta(i) end do sum = 0.0d0 do i=1,nlat sum = sum+wts(i) end do do i=1,nlat wts(i) = 2.0d0*wts(i)/sum end do return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... geo2math.f c c file geo2math.f contains subroutines for converting scalar and c vector fields between geophysical and mathematical spherical c coordinates. The latter is required when using most spherepack c software. The four main subroutines in geo2math.f are described c as follows: c c (1) subroutine geo2maths(ig,nlon,nlat,sg,sm,work) c c converts the nlon by nlat scalar field sg given in c geophysical coordinates to the nlat by nlon scalar c field sm given in mathematical coordinates. sg and sm c can be identical in the program calling geo2maths. c c (2) subroutine math2geos(ig,nlat,nlon,sm,sg,work) c c converts the nlat by nlon scalar field sm given in c mathematical coordinates to the nlon by nlat scalar c field sg given in geophysical coordinates. sm and c sg can be identical in the program calling math2geos. c c (3) subroutine geo2mathv(ig,nlon,nlat,ug,vg,vm,wm,work) c c converts the nlon by nlat vector field (ug,vg) given c in geophysical coordinates to the nlat by nlon vector c field (vm,wm) in mathematical coordinates. ug and wm c can be identical in the program calling geo2mathv. vg c and vm can be identical in the program calling geo2mathv. c c (4) subroutine math2geov(ig,nlat,nlon,vm,wm,ug,vg,work) c c converts the nlat by nlon vector field (vm,wm) given c in mathematical coordinates to the nlon by nlat vector c field (ug,vg) in spherical coordinates. vm and vg can c be identical in the program calling math2geov. wm and c ug can be identical in the program calling math2geov. c c *** (1),(2),(3),(4) argument description. c c ... ig c c = 0 if the latitude values in the geophysical arrays sg,ug,vg are c ordered south to north with increasing latitude subscript c i=1,2,...,nlat. c c = 1 if the latitude values in the geophysical arrays sg,ug,vg are c ordered north to south with increasing latitude subscript c i=1,2,...,nlat. c c ... nlon c c the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. nlon is the first c dimension of the geophysical arrays sg,ug,vg and the second c dimension of the mathematical arrays sm,vm,wm. The longitude c grid is given by phi(j) = (j-1)*2*pi/nlon j=1,...,nlon. c c ... nlat c c the number of distinct latitude and colatitude points and the c first dimension of sm,vm,wm and second dimension of sg,ug,vg. c If the (co)latitude grid is equally spaced then the grid increment c is dlat=pi/(nlat-1). In this case the south to north latitude grid c underlying is c c lat(i) = -0.5*pi + (i-1)*dlat (i=1,...,nlat) c c and the north to south colatitude grid underlying sm,vm,wm is c c colat(i) = (i-1)*dlat (i=1,...,nlat) c c If the grid is Gaussian let thetag(i) be the north to south colatitude c grid (as computed by the spherepack routine gaqd). In this case c c colat(i) = thetag(i) (i=1,...,nlat) c c and c c lat(i) = -0.5*pi + thetag(i) (i=1,...,nlat) c c In either case lat(i) = colat(nlat-i+1) for all i. c If nlat is odd the equator is located at the (nlat+1)/2 c latitude or colatitude point. If nlat is even the equator is c half way between the nlat/2 and nlat/2+1 latitude or colatitude c points. The equally spaced (co)latitude grid includes the poles. c The Gaussian grid excludes the poles. c c ... sg,sm c c In (1),(2) sg is a nlon by nlat array containing the scalar field c in geophysical coordinates. Latitude values in sg are ordered from c the southern to the northern hemisphere with increasing latitude c subscript if ig = 0 or ordered from the northern hemisphere to the c southern hemisphere if ig = 1. sm is a nlat by nlon array containing c the scalar field in mathematical coordinates. Colatitude values in sm c are ordered from the north to the south hemisphere with increasing c colatitude subscript (i=1,...,nlat). The (co)latitude grid for sg and c sm can be equally spaced or Gaussian. sg and sm can be equivalenced or c be identical in the routine calling geo2maths or math2geos. sg and c sm are related by c c sm(nlat-i+1,j) = sg(j,i) (if ig = 0) c c or c c sm(i,j) = sg(j,i) (if ig = 1) c c for i=1,...,nlat and j=1,...,nlon. This formula is not used because c the two arrays can be equivalenced or identical arguments in the c program calling geo2maths or math2geos. c c ... ug,vg,vm,wm c c In (3),(4) ug is a nlon by nlat array containing the longitudinal c vector component. vg is a nlon by nlat array containing the c latitudinal vector component. Values in (ug,vg) are ordered c from the southern to the northern hemisphere with increasing c latitude subscript if ig = 0 or from the northern to southern c hemisphere if ig = 1. vm is a nlat by nlon array containing the c the colatitudinal vector component. wm is a nlat by nlon array c containing the east longitudinal vector component. Values in c (vm,wm) are ordered from the northern to the southern hemisphere c with increasing colatitude subscript. The (co)latitude grid for c both vector fields can be equally spaced or Gaussian. ug,wm and c vg,vm can be equivalenced or be identical in the program calling c geo2mathv or math2geov. They are related by c c ug(j,nlat-i+1) = wm(i,j) c (ig = 0) c vg(j,nlat-i+1) = -vm(i,j) c c or c c ug(j,i) = wm(i,j) c (ig = 1) c vg(j,i) = -vm(i,j) c c c for i=1,...,nlat and j=1,...,nlon. These formulas are not c used because ug,wm and vg,vm can be equivalenced or identical c arguments in the program calling math2geov or geo2mathv. c c Let ib = nlat-i+1 for i=1,...,nlat. Summarizing: c sg(j,i) or ug(j,i),vg(j,i) are values at (phi(j),lat(i)) if ig = 0 c sg(j,i) or ug(j,i),vg(j,i) are values at (phi(j),lat(ib)) if ig = 1 c sm(i,j) or vm(i,j),wm(i,j) are values at (colat(i),phi(j)) c c ... work is an unsaved real work space of length at least nlon*nlat c in the routine calling (1),(2),(3), or (4). It is used to simplify c a nonsquare array transposition in case it is required. c c *** example (1) c c suppose you wish to compute the divergence of (ug,vg) on a Gaussian c grid in geophysical coordinates using the stored Legendre polynomial c routines on SPHEREPACK 2.0. c c (1) call geo2mathv to set vm,wm from ug,vg c c (2) call vhags to compute the vector harmonic coefficients of vm,wm c c (3) call divgs with the coefficients from (2) to compute the divergence c dv in mathematical spherical coordinates on the UNIT sphere. c c (4) call math2geos to convert the scalar divergence dv back to c geophysical spherical coordinates. c c (5) divide dv by R (the radius of the earth) to compute divergence c on the earth (scaling from unit sphere computation in (3)). c c *** example (2) c c suppose you wish to compute a vector field (ug,vg) corresponding c to a given divergence dvg and vorticity vtg (all in geophysical c coordinates) on an equally spaced (co)latitude grid using the c computed Legendre polynomial software. c c (1) call geo2maths to set dvm from dvg c c (2) call geo2maths to set vtm from vts c c (3) call shaec to compute the scalar harmonic coefficients of dvm c c (4) call shaec to compute the scalar harmonic coefficients of vtm c c (5) call idvtec to compute (vm,wm) using the coefficients from (3),(4). c c (6) call math2geov to set (ug,vg) from (vm,wm) c c (7) multiply (ug,vg) by the earth's radius R for scaling c from the unit sphere computation in (5) c c *** END OF DOCUMENTATION ... CODE FOLLOWS: c c subroutine geo2maths(ig,nlon,nlat,sg,sm,work) implicit none integer ig,nlon,nlat,i,j,ij real sg(nlon,nlat),sm(nlat,nlon),work(*) c c transpose sg into sm and reverse colatitude subscript order c if necessary c do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = sg(j,i) end do end do if (ig.eq.0) then do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i sm(nlat-i+1,j) = work(ij) end do end do else do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i sm(i,j) = work(ij) end do end do end if return end subroutine geo2mathv(ig,nlon,nlat,ug,vg,vm,wm,work) implicit none integer ig,nlon,nlat,i,j,ij real ug(nlon,nlat),vg(nlon,nlat),work(*) real vm(nlat,nlon),wm(nlat,nlon) c c convert vg to vm, ug to wm c if (ig.eq.0) then do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = vg(j,i) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i vm(nlat-i+1,j) = -work(ij) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = ug(j,i) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i wm(nlat-i+1,j) = work(ij) end do end do else do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = vg(j,i) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i vm(i,j) = -work(ij) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = ug(j,i) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i wm(i,j) = work(ij) end do end do end if return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file gradec.f c c this file includes documentation and code for c subroutine gradec i c c ... files which must be loaded with gradec.f c c sphcom.f, hrfft.f, shaec.f,vhsec.f c c subroutine gradec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsec,lvhsec,work,lwork,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shaec for a scalar field sf, subroutine gradec computes c an irrotational vector field (v,w) such that c c gradient(sf) = (v,w). c c v is the colatitudinal and w is the east longitudinal component c of the gradient. i.e., c c v(i,j) = d(sf(i,j))/dtheta c c and c c w(i,j) = 1/sint*d(sf(i,j))/dlambda c c at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon. c c where sint = sin(theta(i)). required associated legendre polynomials c are recomputed rather than stored as they are in subroutine grades. this c saves storage (compare wvhsec here and wvhses in grades) but increases c computational requirements. c c c input parameters c c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shaec to compute the arrays a and b from the c scalar field sf. isym determines whether (v,w) are c computed on the full or half sphere as follows: c c = 0 c c sf is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c sf is antisymmetric about the equator. in this case w is c antisymmetric and v is symmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c sf is symmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays a,b,v, and w can be three dimensional corresponding c to an indexed multiple array sf. in this case, multiple c vector synthesis will be performed to compute each vector c field. the third index for a,b,v, and w is the synthesis c index which assumes the values k = 1,...,nt. for a single c synthesis set nt = 1. the description of the remaining c parameters is simplified by assuming that nt=1 or that a,b,v, c and w are two dimensional arrays. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls gradec. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls gradec. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field array sf as computed by subroutine shaec. c *** a,b must be computed by shaec prior to calling gradec. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls gradec (and shaec). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls gradec (and shaec). ndab must be at c least nlat. c c c wvhsec an array which must be initialized by subroutine vhseci. c once initialized, c wvhsec can be used repeatedly by gradec as long as nlon c and nlat remain unchanged. wvhsec must not be altered c between calls of gradec. c c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls gradec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c then lvhsec must be greater than or equal to c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls gradec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(2*l1*nt+1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*l1*nt+1) c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain an irrotational vector field such that the gradient of c the scalar field sf is (v,w). w(i,j) is the east longitude c component and v(i,j) is the colatitudinal component of velocity c at colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude c lambda(j) = (j-1)*2*pi/nlon. the indices for v and w are defined c at the input parameter isym. the vorticity of (v,w) is zero. c note that any nonzero vector field on the sphere will be c multiple valued at the poles [reference swarztrauber]. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsec c = 10 error in the specification of lwork c ********************************************************************** c c subroutine gradec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, +wvhsec,lvhsec,work,lwork,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsec(lvhsec),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c verify minimum saved work space length c idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin = 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 if(lvhsec .lt. lwmin) return ierror = 10 c c verify minimum unsaved work space length c mn = mmax*nlat*nt if (isym .eq. 0) then lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(2*l1*nt+1) else lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*l1*nt+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr + mn is = ibi + mn iwk = is + nlat liwk = lwork-2*mn-nlat call gradec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),work(ibi), +mmax,work(is),mdab,ndab,a,b,wvhsec,lvhsec,work(iwk),liwk, +ierror) return end subroutine gradec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,mmax, +sqnn,mdab,ndab,a,b,wvhsec,lvhsec,wk,lwk,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsec(lvhsec),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = sqnn(n)*a(1,n,k) bi(1,n,k) = sqnn(n)*b(1,n,k) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = sqnn(n)*a(m,n,k) bi(m,n,k) = sqnn(n)*b(m,n,k) 7 continue 6 continue 2 continue c c set ityp for irrotational vector synthesis to compute gradient c if (isym.eq.0) then ityp = 1 else if (isym.eq.1) then ityp = 4 else if (isym.eq.2) then ityp = 7 end if c c vector sythesize br,bi into (v,w) (cr,ci are dummy variables) c call vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wvhsec,lvhsec,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file gradges.f c c this file includes documentation and code for c subroutine grades i c c ... files which must be loaded with gradges.f c c sphcom.f, hrfft.f, shaes.f,vhses.f c c subroutine grades(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhses,lvhses,work,lwork,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shaes for a scalar field sf, subroutine grades computes c an irrotational vector field (v,w) such that c c gradient(sf) = (v,w). c c v is the colatitudinal and w is the east longitudinal component c of the gradient. i.e., c c v(i,j) = d(sf(i,j))/dtheta c c and c c w(i,j) = 1/sint*d(sf(i,j))/dlambda c c at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon. c c where sint = sin(theta(i)). required associated legendre polynomials c are stored rather than recomputed as they are in subroutine gradec c c c input parameters c c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shaes to compute the arrays a and b from the c scalar field sf. isym determines whether (v,w) are c computed on the full or half sphere as follows: c c = 0 c c sf is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c sf is antisymmetric about the equator. in this case w is c antisymmetric and v is symmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c sf is symmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays a,b,v, and w can be three dimensional corresponding c to an indexed multiple array sf. in this case, multiple c vector synthesis will be performed to compute each vector c field. the third index for a,b,v, and w is the synthesis c index which assumes the values k = 1,...,nt. for a single c synthesis set nt = 1. the description of the remaining c parameters is simplified by assuming that nt=1 or that a,b,v, c and w are two dimensional arrays. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls grades. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls grades. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field array sf as computed by subroutine shaes. c *** a,b must be computed by shaes prior to calling grades. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls grades (and shaes). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls grades (and shaes). ndab must be at c least nlat. c c c wvhses an array which must be initialized by subroutine gradesi c (or equivalently by subroutine vhsesi). once initialized, c wsav can be used repeatedly by grades as long as nlon c and nlat remain unchanged. wvhses must not be altered c between calls of grades. c c c lvhses the dimension of the array wvhses as it appears in the c program that calls grades. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c then lvhses must be greater than or equal to c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls grades. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0, lwork must be greater than or equal to c c nlat*((2*nt+1)*nlon+2*l1*nt+1). c c if isym = 1 or 2, lwork must be greater than or equal to c c (2*nt+1)*l2*nlon+nlat*(2*l1*nt+1). c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain an irrotational vector field such that the gradient of c the scalar field sf is (v,w). w(i,j) is the east longitude c component and v(i,j) is the colatitudinal component of velocity c at colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude c lambda(j) = (j-1)*2*pi/nlon. the indices for v and w are defined c at the input parameter isym. the vorticity of (v,w) is zero. c note that any nonzero vector field on the sphere will be c multiple valued at the poles [reference swarztrauber]. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhses c = 10 error in the specification of lwork c ********************************************************************** c c subroutine grades(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, +wvhses,lvhses,work,lwork,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhses(lvhses),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c verify minimum saved work space length c idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid lgdmin = lzimn+lzimn+nlon+15 if(lvhses .lt. lgdmin) return ierror = 10 c c verify minimum unsaved work space length c mn = mmax*nlat*nt idv = nlat if (isym.ne.0) idv = imid lnl = nt*idv*nlon lwkmin = lnl+lnl+idv*nlon+2*mn+nlat if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr + mn is = ibi + mn iwk = is + nlat liwk = lwork-2*mn-nlat call grades1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),work(ibi), +mmax,work(is),mdab,ndab,a,b,wvhses,lvhses,work(iwk),liwk, +ierror) return end subroutine grades1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,mmax, +sqnn,mdab,ndab,a,b,wvhses,lvhses,wk,lwk,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhses(lvhses),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = sqnn(n)*a(1,n,k) bi(1,n,k) = sqnn(n)*b(1,n,k) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = sqnn(n)*a(m,n,k) bi(m,n,k) = sqnn(n)*b(m,n,k) 7 continue 6 continue 2 continue c c set ityp for irrotational vector synthesis to compute gradient c if (isym.eq.0) then ityp = 1 else if (isym.eq.1) then ityp = 4 else if (isym.eq.2) then ityp = 7 end if c c vector sythesize br,bi into (v,w) (cr,ci are dummy variables) c call vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wvhses,lvhses,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file gradgc.f c c this file includes documentation and code for c subroutine gradgc i c c ... files which must be loaded with gradgc.f c c sphcom.f, hrfft.f, shagc.f,vhsgc.f c c subroutine gradgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsgc,lvhsgc,work,lwork,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shagc for a scalar field sf, subroutine gradgc computes c an irrotational vector field (v,w) such that c c gradient(sf) = (v,w). c c v is the colatitudinal and w is the east longitudinal component c of the gradient. i.e., c c v(i,j) = d(sf(i,j))/dtheta c c and c c w(i,j) = 1/sint*d(sf(i,j))/dlambda c c at the gaussian colatitude point theta(i) (see nlat as input c parameter) and longitude lambda(j) = (j-1)*2*pi/nlon where c where sint = sin(theta(i)). required associated legendre polynomials c are recomputed rather than stored as they are in subroutine gradgs. this c saves storage (compare lsav with lsav in gradgs) but increases c computational requirements. c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shagc to compute the arrays a and b from the c scalar field sf. isym determines whether (v,w) are c computed on the full or half sphere as follows: c c = 0 c c sf is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c sf is antisymmetric about the equator. in this case w is c antisymmetric and v is symmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c sf is symmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays a,b,v, and w can be three dimensional corresponding c to an indexed multiple array sf. in this case, multiple c vector synthesis will be performed to compute each vector c field. the third index for a,b,v, and w is the synthesis c index which assumes the values k = 1,...,nt. for a single c synthesis set nt = 1. the description of the remaining c parameters is simplified by assuming that nt=1 or that a,b,v, c and w are two dimensional arrays. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls gradgc. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls gradgc. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field array sf as computed by subroutine shagc. c *** a,b must be computed by shagc prior to calling gradgc. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls gradgc (and shagc). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls gradgc (and shagc). ndab must be at c least nlat. c c c wvhsgc an array which must be initialized by subroutine vhsgci. c once initialized, c wvhsgc can be used repeatedly by gradgc as long as nlon c and nlat remain unchanged. wvhsgc must not be altered c between calls of gradgc. c c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls gradgc. Let c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c lvhsgc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls gradgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(2*l1*nt+1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*l1*nt+1) c c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain an irrotational vector field such that the gradient of c the scalar field sf is (v,w). w(i,j) is the east longitude c component and v(i,j) is the colatitudinal component of velocity c at gaussian colatitude and longitude lambda(j) = (j-1)*2*pi/nlon c the indices for v and w are defined at the input parameter c isym. the vorticity of (v,w) is zero. note that any nonzero c vector field on the sphere will be multiple valued at the poles c [reference swarztrauber]. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgc c = 10 error in the specification of lwork c ********************************************************************** c c subroutine gradgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, +wvhsgc,lvhsgc,work,lwork,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsgc(lvhsgc),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c verify minimum saved work space length c l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin = 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 if (lvhsgc .lt. lwmin) return ierror = 10 c c verify minimum unsaved work space length c if (isym .eq. 0) then lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*l1*nt+1) else lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*l1*nt+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c mn = mmax*nlat*nt ibr = 1 ibi = ibr + mn is = ibi + mn iwk = is + nlat liwk = lwork-2*mn-nlat call gradgc1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),work(ibi), +mmax,work(is),mdab,ndab,a,b,wvhsgc,lvhsgc,work(iwk),liwk, +ierror) return end subroutine gradgc1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,mmax, +sqnn,mdab,ndab,a,b,wvhsgc,lvhsgc,wk,lwk,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsgc(lvhsgc),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = sqnn(n)*a(1,n,k) bi(1,n,k) = sqnn(n)*b(1,n,k) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = sqnn(n)*a(m,n,k) bi(m,n,k) = sqnn(n)*b(m,n,k) 7 continue 6 continue 2 continue c c set ityp for irrotational vector synthesis to compute gradient c if (isym.eq.0) then ityp = 1 else if (isym.eq.1) then ityp = 4 else if (isym.eq.2) then ityp = 7 end if c c vector sythesize br,bi into (v,w) (cr,ci are dummy variables) c call vhsgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wvhsgc,lvhsgc,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file gradgs.f c c this file includes documentation and code for c subroutine gradgs i c c ... files which must be loaded with gradgec.f c c sphcom.f, hrfft.f, shags.f,vhsgs.f c c subroutine gradgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsgs,lvhsgs,work,lwork,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shags for a scalar field sf, subroutine gradgs computes c an irrotational vector field (v,w) such that c c gradient(sf) = (v,w). c c v is the colatitudinal and w is the east longitudinal component c of the gradient. i.e., c c v(i,j) = d(sf(i,j))/dtheta c c and c c w(i,j) = 1/sint*d(sf(i,j))/dlambda c c at the gaussian colatitude point theta(i) (see nlat as input c parameter) and longitude lambda(j) = (j-1)*2*pi/nlon where c sint = sin(theta(i)). c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shags to compute the arrays a and b from the c scalar field sf. isym determines whether (v,w) are c computed on the full or half sphere as follows: c c = 0 c c sf is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c sf is antisymmetric about the equator. in this case w is c antisymmetric and v is symmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c sf is symmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays a,b,v, and w can be three dimensional corresponding c to an indexed multiple array sf. in this case, multiple c vector synthesis will be performed to compute each vector c field. the third index for a,b,v, and w is the synthesis c index which assumes the values k = 1,...,nt. for a single c synthesis set nt = 1. the description of the remaining c parameters is simplified by assuming that nt=1 or that a,b,v, c and w are two dimensional arrays. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls gradgs. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls gradgs. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field array sf as computed by subroutine shags. c *** a,b must be computed by shags prior to calling gradgs. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls gradgs (and shags). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls gradgs (and shags). ndab must be at c least nlat. c c c wvhsgs an array which must be initialized by subroutine vhsgsi. c once initialized, c wvhsgs can be used repeatedly by gradgs as long as nlon c and nlat remain unchanged. wvhsgs must not be altered c between calls of gradgs. c c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls grradgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgs must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls gradgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0, lwork must be greater than or equal to c c nlat*((2*nt+1)*nlon+2*l1*nt+1). c c if isym = 1 or 2, lwork must be greater than or equal to c c (2*nt+1)*l2*nlon+nlat*(2*l1*nt+1). c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain an irrotational vector field such that the gradient of c the scalar field sf is (v,w). w(i,j) is the east longitude c component and v(i,j) is the colatitudinal component of velocity c at gaussian colatitude and longitude lambda(j) = (j-1)*2*pi/nlon c the indices for v and w are defined at the input parameter c isym. the vorticity of (v,w) is zero. note that any nonzero c vector field on the sphere will be multiple valued at the poles c [reference swarztrauber]. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgs c = 10 error in the specification of lwork c ********************************************************************** c c subroutine gradgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, +wvhsgs,lvhsgs,work,lwork,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsgs(lvhsgs),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c verify minimum saved work space length c idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid lgdmin = lzimn+lzimn+nlon+15 if(lvhsgs .lt. lgdmin) return ierror = 10 c c verify minimum unsaved work space length c mn = mmax*nlat*nt idv = nlat if (isym.ne.0) idv = imid lnl = nt*idv*nlon lwkmin = lnl+lnl+idv*nlon+2*mn+nlat if(lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr + mn is = ibi + mn iwk = is + nlat liwk = lwork-2*mn-nlat call gradgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),work(ibi), +mmax,work(is),mdab,ndab,a,b,wvhsgs,lvhsgs,work(iwk),liwk, +ierror) return end subroutine gradgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,mmax, +sqnn,mdab,ndab,a,b,wvhsgs,lvhsgs,wk,lwk,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsgs(lvhsgs),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = sqnn(n)*a(1,n,k) bi(1,n,k) = sqnn(n)*b(1,n,k) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = sqnn(n)*a(m,n,k) bi(m,n,k) = sqnn(n)*b(m,n,k) 7 continue 6 continue 2 continue c c set ityp for irrotational vector synthesis to compute gradient c if (isym.eq.0) then ityp = 1 else if (isym.eq.1) then ityp = 4 else if (isym.eq.2) then ityp = 7 end if c c vector sythesize br,bi into (v,w) (cr,ci are dummy variables) c call vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wvhsgs,lvhsgs,wk,lwk,ierror) return end subroutine gs(n,x,y,z) dimension x(n),y(n),z(n) double precision x,y,z,sum c c accumulate innerproducts of x with respect to y. c sum = 0. do i=1,n sum = sum+x(i)*y(i) end do do i=1,n z(i) = z(i)+sum*y(i) end do return end subroutine hradb2 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1) c c a multiple fft package for spherepack c dimension cc(mdimcc,ido,2,l1) ,ch(mdimch,ido,l1,2), 1 wa1(ido) do 101 k=1,l1 do 1001 m=1,mp ch(m,1,k,1) = cc(m,1,1,k)+cc(m,ido,2,k) ch(m,1,k,2) = cc(m,1,1,k)-cc(m,ido,2,k) 1001 continue 101 continue if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k=1,l1 do 103 i=3,ido,2 ic = idp2-i do 1002 m=1,mp ch(m,i-1,k,1) = cc(m,i-1,1,k)+cc(m,ic-1,2,k) ch(m,i,k,1) = cc(m,i,1,k)-cc(m,ic,2,k) ch(m,i-1,k,2) = wa1(i-2)*(cc(m,i-1,1,k)-cc(m,ic-1,2,k)) 1 -wa1(i-1)*(cc(m,i,1,k)+cc(m,ic,2,k)) ch(m,i,k,2) = wa1(i-2)*(cc(m,i,1,k)+cc(m,ic,2,k))+wa1(i-1) 1 *(cc(m,i-1,1,k)-cc(m,ic-1,2,k)) 1002 continue 103 continue 104 continue if (mod(ido,2) .eq. 1) return 105 do 106 k=1,l1 do 1003 m=1,mp ch(m,ido,k,1) = cc(m,ido,1,k)+cc(m,ido,1,k) ch(m,ido,k,2) = -(cc(m,1,2,k)+cc(m,1,2,k)) 1003 continue 106 continue 107 return end subroutine hradb3 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1,wa2) c c a multiple fft package for spherepack c dimension cc(mdimcc,ido,3,l1) ,ch(mdimch,ido,l1,3), 1 wa1(ido) ,wa2(ido) arg=2.*pimach()/3. taur=cos(arg) taui=sin(arg) do 101 k=1,l1 do 1001 m=1,mp ch(m,1,k,1) = cc(m,1,1,k)+2.*cc(m,ido,2,k) ch(m,1,k,2) = cc(m,1,1,k)+(2.*taur)*cc(m,ido,2,k) 1 -(2.*taui)*cc(m,1,3,k) ch(m,1,k,3) = cc(m,1,1,k)+(2.*taur)*cc(m,ido,2,k) 1 +2.*taui*cc(m,1,3,k) 1001 continue 101 continue if (ido .eq. 1) return idp2 = ido+2 do 103 k=1,l1 do 102 i=3,ido,2 ic = idp2-i do 1002 m=1,mp ch(m,i-1,k,1) = cc(m,i-1,1,k)+(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) ch(m,i,k,1) = cc(m,i,1,k)+(cc(m,i,3,k)-cc(m,ic,2,k)) ch(m,i-1,k,2) = wa1(i-2)* 1 ((cc(m,i-1,1,k)+taur*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))- * (taui*(cc(m,i,3,k)+cc(m,ic,2,k)))) 2 -wa1(i-1)* 3 ((cc(m,i,1,k)+taur*(cc(m,i,3,k)-cc(m,ic,2,k)))+ * (taui*(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))) ch(m,i,k,2) = wa1(i-2)* 4 ((cc(m,i,1,k)+taur*(cc(m,i,3,k)-cc(m,ic,2,k)))+ 8 (taui*(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))) 5 +wa1(i-1)* 6 ((cc(m,i-1,1,k)+taur*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))- 8 (taui*(cc(m,i,3,k)+cc(m,ic,2,k)))) ch(m,i-1,k,3) = wa2(i-2)* 7 ((cc(m,i-1,1,k)+taur*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))+ 8 (taui*(cc(m,i,3,k)+cc(m,ic,2,k)))) 8 -wa2(i-1)* 9 ((cc(m,i,1,k)+taur*(cc(m,i,3,k)-cc(m,ic,2,k)))- 8 (taui*(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))) ch(m,i,k,3) = wa2(i-2)* 1 ((cc(m,i,1,k)+taur*(cc(m,i,3,k)-cc(m,ic,2,k)))- 8 (taui*(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))) 2 +wa2(i-1)* 3 ((cc(m,i-1,1,k)+taur*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))+ 8 (taui*(cc(m,i,3,k)+cc(m,ic,2,k)))) 1002 continue 102 continue 103 continue return end subroutine hradb4 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1,wa2,wa3) c c a multiple fft package for spherepack c dimension cc(mdimcc,ido,4,l1) ,ch(mdimch,ido,l1,4) , 1 wa1(ido) ,wa2(ido) ,wa3(ido) sqrt2=sqrt(2.) do 101 k=1,l1 do 1001 m=1,mp ch(m,1,k,3) = (cc(m,1,1,k)+cc(m,ido,4,k)) 1 -(cc(m,ido,2,k)+cc(m,ido,2,k)) ch(m,1,k,1) = (cc(m,1,1,k)+cc(m,ido,4,k)) 1 +(cc(m,ido,2,k)+cc(m,ido,2,k)) ch(m,1,k,4) = (cc(m,1,1,k)-cc(m,ido,4,k)) 1 +(cc(m,1,3,k)+cc(m,1,3,k)) ch(m,1,k,2) = (cc(m,1,1,k)-cc(m,ido,4,k)) 1 -(cc(m,1,3,k)+cc(m,1,3,k)) 1001 continue 101 continue if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k=1,l1 do 103 i=3,ido,2 ic = idp2-i do 1002 m=1,mp ch(m,i-1,k,1) = (cc(m,i-1,1,k)+cc(m,ic-1,4,k)) 1 +(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) ch(m,i,k,1) = (cc(m,i,1,k)-cc(m,ic,4,k)) 1 +(cc(m,i,3,k)-cc(m,ic,2,k)) ch(m,i-1,k,2)=wa1(i-2)*((cc(m,i-1,1,k)-cc(m,ic-1,4,k)) 1 -(cc(m,i,3,k)+cc(m,ic,2,k)))-wa1(i-1) 1 *((cc(m,i,1,k)+cc(m,ic,4,k))+(cc(m,i-1,3,k)-cc(m,ic-1,2,k))) ch(m,i,k,2)=wa1(i-2)*((cc(m,i,1,k)+cc(m,ic,4,k)) 1 +(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))+wa1(i-1) 1 *((cc(m,i-1,1,k)-cc(m,ic-1,4,k))-(cc(m,i,3,k)+cc(m,ic,2,k))) ch(m,i-1,k,3)=wa2(i-2)*((cc(m,i-1,1,k)+cc(m,ic-1,4,k)) 1 -(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))-wa2(i-1) 1 *((cc(m,i,1,k)-cc(m,ic,4,k))-(cc(m,i,3,k)-cc(m,ic,2,k))) ch(m,i,k,3)=wa2(i-2)*((cc(m,i,1,k)-cc(m,ic,4,k)) 1 -(cc(m,i,3,k)-cc(m,ic,2,k)))+wa2(i-1) 1 *((cc(m,i-1,1,k)+cc(m,ic-1,4,k))-(cc(m,i-1,3,k) 1 +cc(m,ic-1,2,k))) ch(m,i-1,k,4)=wa3(i-2)*((cc(m,i-1,1,k)-cc(m,ic-1,4,k)) 1 +(cc(m,i,3,k)+cc(m,ic,2,k)))-wa3(i-1) 1 *((cc(m,i,1,k)+cc(m,ic,4,k))-(cc(m,i-1,3,k)-cc(m,ic-1,2,k))) ch(m,i,k,4)=wa3(i-2)*((cc(m,i,1,k)+cc(m,ic,4,k)) 1 -(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))+wa3(i-1) 1 *((cc(m,i-1,1,k)-cc(m,ic-1,4,k))+(cc(m,i,3,k)+cc(m,ic,2,k))) 1002 continue 103 continue 104 continue if (mod(ido,2) .eq. 1) return 105 continue do 106 k=1,l1 do 1003 m=1,mp ch(m,ido,k,1) = (cc(m,ido,1,k)+cc(m,ido,3,k)) 1 +(cc(m,ido,1,k)+cc(m,ido,3,k)) ch(m,ido,k,2) = sqrt2*((cc(m,ido,1,k)-cc(m,ido,3,k)) 1 -(cc(m,1,2,k)+cc(m,1,4,k))) ch(m,ido,k,3) = (cc(m,1,4,k)-cc(m,1,2,k)) 1 +(cc(m,1,4,k)-cc(m,1,2,k)) ch(m,ido,k,4) = -sqrt2*((cc(m,ido,1,k)-cc(m,ido,3,k)) 1 +(cc(m,1,2,k)+cc(m,1,4,k))) 1003 continue 106 continue 107 return end subroutine hradb5 (mp,ido,l1,cc,mdimcc,ch,mdimch, 1 wa1,wa2,wa3,wa4) c c a multiple fft package for spherepack c dimension cc(mdimcc,ido,5,l1) ,ch(mdimch,ido,l1,5), 1 wa1(ido) ,wa2(ido) ,wa3(ido) ,wa4(ido) arg=2.*pimach()/5. tr11=cos(arg) ti11=sin(arg) tr12=cos(2.*arg) ti12=sin(2.*arg) do 101 k=1,l1 do 1001 m=1,mp ch(m,1,k,1) = cc(m,1,1,k)+2.*cc(m,ido,2,k)+2.*cc(m,ido,4,k) ch(m,1,k,2) = (cc(m,1,1,k)+tr11*2.*cc(m,ido,2,k) 1 +tr12*2.*cc(m,ido,4,k))-(ti11*2.*cc(m,1,3,k) 1 +ti12*2.*cc(m,1,5,k)) ch(m,1,k,3) = (cc(m,1,1,k)+tr12*2.*cc(m,ido,2,k) 1 +tr11*2.*cc(m,ido,4,k))-(ti12*2.*cc(m,1,3,k) 1 -ti11*2.*cc(m,1,5,k)) ch(m,1,k,4) = (cc(m,1,1,k)+tr12*2.*cc(m,ido,2,k) 1 +tr11*2.*cc(m,ido,4,k))+(ti12*2.*cc(m,1,3,k) 1 -ti11*2.*cc(m,1,5,k)) ch(m,1,k,5) = (cc(m,1,1,k)+tr11*2.*cc(m,ido,2,k) 1 +tr12*2.*cc(m,ido,4,k))+(ti11*2.*cc(m,1,3,k) 1 +ti12*2.*cc(m,1,5,k)) 1001 continue 101 continue if (ido .eq. 1) return idp2 = ido+2 do 103 k=1,l1 do 102 i=3,ido,2 ic = idp2-i do 1002 m=1,mp ch(m,i-1,k,1) = cc(m,i-1,1,k)+(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) 1 +(cc(m,i-1,5,k)+cc(m,ic-1,4,k)) ch(m,i,k,1) = cc(m,i,1,k)+(cc(m,i,3,k)-cc(m,ic,2,k)) 1 +(cc(m,i,5,k)-cc(m,ic,4,k)) ch(m,i-1,k,2) = wa1(i-2)*((cc(m,i-1,1,k)+tr11* 1 (cc(m,i-1,3,k)+cc(m,ic-1,2,k))+tr12 1 *(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))-(ti11*(cc(m,i,3,k) 1 +cc(m,ic,2,k))+ti12*(cc(m,i,5,k)+cc(m,ic,4,k)))) 1 -wa1(i-1)*((cc(m,i,1,k)+tr11*(cc(m,i,3,k)-cc(m,ic,2,k)) 1 +tr12*(cc(m,i,5,k)-cc(m,ic,4,k)))+(ti11*(cc(m,i-1,3,k) 1 -cc(m,ic-1,2,k))+ti12*(cc(m,i-1,5,k)-cc(m,ic-1,4,k)))) ch(m,i,k,2) = wa1(i-2)*((cc(m,i,1,k)+tr11*(cc(m,i,3,k) 1 -cc(m,ic,2,k))+tr12*(cc(m,i,5,k)-cc(m,ic,4,k))) 1 +(ti11*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))+ti12 1 *(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))+wa1(i-1) 1 *((cc(m,i-1,1,k)+tr11*(cc(m,i-1,3,k) 1 +cc(m,ic-1,2,k))+tr12*(cc(m,i-1,5,k)+cc(m,ic-1,4,k))) 1 -(ti11*(cc(m,i,3,k)+cc(m,ic,2,k))+ti12 1 *(cc(m,i,5,k)+cc(m,ic,4,k)))) ch(m,i-1,k,3) = wa2(i-2) 1 *((cc(m,i-1,1,k)+tr12*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) 1 +tr11*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))-(ti12*(cc(m,i,3,k) 1 +cc(m,ic,2,k))-ti11*(cc(m,i,5,k)+cc(m,ic,4,k)))) 1 -wa2(i-1) 1 *((cc(m,i,1,k)+tr12*(cc(m,i,3,k)- 1 cc(m,ic,2,k))+tr11*(cc(m,i,5,k)-cc(m,ic,4,k))) 1 +(ti12*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))-ti11 1 *(cc(m,i-1,5,k)-cc(m,ic-1,4,k)))) ch(m,i,k,3) = wa2(i-2) 1 *((cc(m,i,1,k)+tr12*(cc(m,i,3,k)- 1 cc(m,ic,2,k))+tr11*(cc(m,i,5,k)-cc(m,ic,4,k))) 1 +(ti12*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))-ti11 1 *(cc(m,i-1,5,k)-cc(m,ic-1,4,k)))) 1 +wa2(i-1) 1 *((cc(m,i-1,1,k)+tr12*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) 1 +tr11*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))-(ti12*(cc(m,i,3,k) 1 +cc(m,ic,2,k))-ti11*(cc(m,i,5,k)+cc(m,ic,4,k)))) ch(m,i-1,k,4) = wa3(i-2) 1 *((cc(m,i-1,1,k)+tr12*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) 1 +tr11*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))+(ti12*(cc(m,i,3,k) 1 +cc(m,ic,2,k))-ti11*(cc(m,i,5,k)+cc(m,ic,4,k)))) 1 -wa3(i-1) 1 *((cc(m,i,1,k)+tr12*(cc(m,i,3,k)- 1 cc(m,ic,2,k))+tr11*(cc(m,i,5,k)-cc(m,ic,4,k))) 1 -(ti12*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))-ti11 1 *(cc(m,i-1,5,k)-cc(m,ic-1,4,k)))) ch(m,i,k,4) = wa3(i-2) 1 *((cc(m,i,1,k)+tr12*(cc(m,i,3,k)- 1 cc(m,ic,2,k))+tr11*(cc(m,i,5,k)-cc(m,ic,4,k))) 1 -(ti12*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))-ti11 1 *(cc(m,i-1,5,k)-cc(m,ic-1,4,k)))) 1 +wa3(i-1) 1 *((cc(m,i-1,1,k)+tr12*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) 1 +tr11*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))+(ti12*(cc(m,i,3,k) 1 +cc(m,ic,2,k))-ti11*(cc(m,i,5,k)+cc(m,ic,4,k)))) ch(m,i-1,k,5) = wa4(i-2) 1 *((cc(m,i-1,1,k)+tr11*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) 1 +tr12*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))+(ti11*(cc(m,i,3,k) 1 +cc(m,ic,2,k))+ti12*(cc(m,i,5,k)+cc(m,ic,4,k)))) 1 -wa4(i-1) 1 *((cc(m,i,1,k)+tr11*(cc(m,i,3,k)-cc(m,ic,2,k)) 1 +tr12*(cc(m,i,5,k)-cc(m,ic,4,k)))-(ti11*(cc(m,i-1,3,k) 1 -cc(m,ic-1,2,k))+ti12*(cc(m,i-1,5,k)-cc(m,ic-1,4,k)))) ch(m,i,k,5) = wa4(i-2) 1 *((cc(m,i,1,k)+tr11*(cc(m,i,3,k)-cc(m,ic,2,k)) 1 +tr12*(cc(m,i,5,k)-cc(m,ic,4,k)))-(ti11*(cc(m,i-1,3,k) 1 -cc(m,ic-1,2,k))+ti12*(cc(m,i-1,5,k)-cc(m,ic-1,4,k)))) 1 +wa4(i-1) 1 *((cc(m,i-1,1,k)+tr11*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)) 1 +tr12*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))+(ti11*(cc(m,i,3,k) 1 +cc(m,ic,2,k))+ti12*(cc(m,i,5,k)+cc(m,ic,4,k)))) 1002 continue 102 continue 103 continue return end subroutine hradbg (mp,ido,ip,l1,idl1,cc,c1,c2,mdimcc, 1 ch,ch2,mdimch,wa) c c a multiple fft package for spherepack c dimension ch(mdimch,ido,l1,ip) ,cc(mdimcc,ido,ip,l1) , 1 c1(mdimcc,ido,l1,ip) ,c2(mdimcc,idl1,ip), 2 ch2(mdimch,idl1,ip) ,wa(ido) tpi=2.*pimach() arg = tpi/float(ip) dcp = cos(arg) dsp = sin(arg) idp2 = ido+2 nbd = (ido-1)/2 ipp2 = ip+2 ipph = (ip+1)/2 if (ido .lt. l1) go to 103 do 102 k=1,l1 do 101 i=1,ido do 1001 m=1,mp ch(m,i,k,1) = cc(m,i,1,k) 1001 continue 101 continue 102 continue go to 106 103 do 105 i=1,ido do 104 k=1,l1 do 1004 m=1,mp ch(m,i,k,1) = cc(m,i,1,k) 1004 continue 104 continue 105 continue 106 do 108 j=2,ipph jc = ipp2-j j2 = j+j do 107 k=1,l1 do 1007 m=1,mp ch(m,1,k,j) = cc(m,ido,j2-2,k)+cc(m,ido,j2-2,k) ch(m,1,k,jc) = cc(m,1,j2-1,k)+cc(m,1,j2-1,k) 1007 continue 107 continue 108 continue if (ido .eq. 1) go to 116 if (nbd .lt. l1) go to 112 do 111 j=2,ipph jc = ipp2-j do 110 k=1,l1 do 109 i=3,ido,2 ic = idp2-i do 1009 m=1,mp ch(m,i-1,k,j) = cc(m,i-1,2*j-1,k)+cc(m,ic-1,2*j-2,k) ch(m,i-1,k,jc) = cc(m,i-1,2*j-1,k)-cc(m,ic-1,2*j-2,k) ch(m,i,k,j) = cc(m,i,2*j-1,k)-cc(m,ic,2*j-2,k) ch(m,i,k,jc) = cc(m,i,2*j-1,k)+cc(m,ic,2*j-2,k) 1009 continue 109 continue 110 continue 111 continue go to 116 112 do 115 j=2,ipph jc = ipp2-j do 114 i=3,ido,2 ic = idp2-i do 113 k=1,l1 do 1013 m=1,mp ch(m,i-1,k,j) = cc(m,i-1,2*j-1,k)+cc(m,ic-1,2*j-2,k) ch(m,i-1,k,jc) = cc(m,i-1,2*j-1,k)-cc(m,ic-1,2*j-2,k) ch(m,i,k,j) = cc(m,i,2*j-1,k)-cc(m,ic,2*j-2,k) ch(m,i,k,jc) = cc(m,i,2*j-1,k)+cc(m,ic,2*j-2,k) 1013 continue 113 continue 114 continue 115 continue 116 ar1 = 1. ai1 = 0. do 120 l=2,ipph lc = ipp2-l ar1h = dcp*ar1-dsp*ai1 ai1 = dcp*ai1+dsp*ar1 ar1 = ar1h do 117 ik=1,idl1 do 1017 m=1,mp c2(m,ik,l) = ch2(m,ik,1)+ar1*ch2(m,ik,2) c2(m,ik,lc) = ai1*ch2(m,ik,ip) 1017 continue 117 continue dc2 = ar1 ds2 = ai1 ar2 = ar1 ai2 = ai1 do 119 j=3,ipph jc = ipp2-j ar2h = dc2*ar2-ds2*ai2 ai2 = dc2*ai2+ds2*ar2 ar2 = ar2h do 118 ik=1,idl1 do 1018 m=1,mp c2(m,ik,l) = c2(m,ik,l)+ar2*ch2(m,ik,j) c2(m,ik,lc) = c2(m,ik,lc)+ai2*ch2(m,ik,jc) 1018 continue 118 continue 119 continue 120 continue do 122 j=2,ipph do 121 ik=1,idl1 do 1021 m=1,mp ch2(m,ik,1) = ch2(m,ik,1)+ch2(m,ik,j) 1021 continue 121 continue 122 continue do 124 j=2,ipph jc = ipp2-j do 123 k=1,l1 do 1023 m=1,mp ch(m,1,k,j) = c1(m,1,k,j)-c1(m,1,k,jc) ch(m,1,k,jc) = c1(m,1,k,j)+c1(m,1,k,jc) 1023 continue 123 continue 124 continue if (ido .eq. 1) go to 132 if (nbd .lt. l1) go to 128 do 127 j=2,ipph jc = ipp2-j do 126 k=1,l1 do 125 i=3,ido,2 do 1025 m=1,mp ch(m,i-1,k,j) = c1(m,i-1,k,j)-c1(m,i,k,jc) ch(m,i-1,k,jc) = c1(m,i-1,k,j)+c1(m,i,k,jc) ch(m,i,k,j) = c1(m,i,k,j)+c1(m,i-1,k,jc) ch(m,i,k,jc) = c1(m,i,k,j)-c1(m,i-1,k,jc) 1025 continue 125 continue 126 continue 127 continue go to 132 128 do 131 j=2,ipph jc = ipp2-j do 130 i=3,ido,2 do 129 k=1,l1 do 1029 m=1,mp ch(m,i-1,k,j) = c1(m,i-1,k,j)-c1(m,i,k,jc) ch(m,i-1,k,jc) = c1(m,i-1,k,j)+c1(m,i,k,jc) ch(m,i,k,j) = c1(m,i,k,j)+c1(m,i-1,k,jc) ch(m,i,k,jc) = c1(m,i,k,j)-c1(m,i-1,k,jc) 1029 continue 129 continue 130 continue 131 continue 132 continue if (ido .eq. 1) return do 133 ik=1,idl1 do 1033 m=1,mp c2(m,ik,1) = ch2(m,ik,1) 1033 continue 133 continue do 135 j=2,ip do 134 k=1,l1 do 1034 m=1,mp c1(m,1,k,j) = ch(m,1,k,j) 1034 continue 134 continue 135 continue if (nbd .gt. l1) go to 139 is = -ido do 138 j=2,ip is = is+ido idij = is do 137 i=3,ido,2 idij = idij+2 do 136 k=1,l1 do 1036 m=1,mp c1(m,i-1,k,j) = wa(idij-1)*ch(m,i-1,k,j)-wa(idij)* 1 ch(m,i,k,j) c1(m,i,k,j) = wa(idij-1)*ch(m,i,k,j)+wa(idij)* 1 ch(m,i-1,k,j) 1036 continue 136 continue 137 continue 138 continue go to 143 139 is = -ido do 142 j=2,ip is = is+ido do 141 k=1,l1 idij = is do 140 i=3,ido,2 idij = idij+2 do 1040 m=1,mp c1(m,i-1,k,j) = wa(idij-1)*ch(m,i-1,k,j)-wa(idij)* 1 ch(m,i,k,j) c1(m,i,k,j) = wa(idij-1)*ch(m,i,k,j)+wa(idij)* 1 ch(m,i-1,k,j) 1040 continue 140 continue 141 continue 142 continue 143 return end subroutine hradf2 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1) c c a multiple fft package for spherepack c dimension ch(mdimch,ido,2,l1) ,cc(mdimcc,ido,l1,2) , 1 wa1(ido) do 101 k=1,l1 do 1001 m=1,mp ch(m,1,1,k) = cc(m,1,k,1)+cc(m,1,k,2) ch(m,ido,2,k) = cc(m,1,k,1)-cc(m,1,k,2) 1001 continue 101 continue if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k=1,l1 do 103 i=3,ido,2 ic = idp2-i do 1003 m=1,mp ch(m,i,1,k) = cc(m,i,k,1)+(wa1(i-2)*cc(m,i,k,2)- 1 wa1(i-1)*cc(m,i-1,k,2)) ch(m,ic,2,k) = (wa1(i-2)*cc(m,i,k,2)-wa1(i-1)* 1 cc(m,i-1,k,2))-cc(m,i,k,1) ch(m,i-1,1,k) = cc(m,i-1,k,1)+(wa1(i-2)*cc(m,i-1,k,2)+ 1 wa1(i-1)*cc(m,i,k,2)) ch(m,ic-1,2,k) = cc(m,i-1,k,1)-(wa1(i-2)*cc(m,i-1,k,2)+ 1 wa1(i-1)*cc(m,i,k,2)) 1003 continue 103 continue 104 continue if (mod(ido,2) .eq. 1) return 105 do 106 k=1,l1 do 1006 m=1,mp ch(m,1,2,k) = -cc(m,ido,k,2) ch(m,ido,1,k) = cc(m,ido,k,1) 1006 continue 106 continue 107 return end subroutine hradf3 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1,wa2) c c a multiple fft package for spherepack c dimension ch(mdimch,ido,3,l1) ,cc(mdimcc,ido,l1,3) , 1 wa1(ido) ,wa2(ido) arg=2.*pimach()/3. taur=cos(arg) taui=sin(arg) do 101 k=1,l1 do 1001 m=1,mp ch(m,1,1,k) = cc(m,1,k,1)+(cc(m,1,k,2)+cc(m,1,k,3)) ch(m,1,3,k) = taui*(cc(m,1,k,3)-cc(m,1,k,2)) ch(m,ido,2,k) = cc(m,1,k,1)+taur* 1 (cc(m,1,k,2)+cc(m,1,k,3)) 1001 continue 101 continue if (ido .eq. 1) return idp2 = ido+2 do 103 k=1,l1 do 102 i=3,ido,2 ic = idp2-i do 1002 m=1,mp ch(m,i-1,1,k) = cc(m,i-1,k,1)+((wa1(i-2)*cc(m,i-1,k,2)+ 1 wa1(i-1)*cc(m,i,k,2))+(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)* 1 cc(m,i,k,3))) ch(m,i,1,k) = cc(m,i,k,1)+((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)* 1 cc(m,i-1,k,2))+(wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3))) ch(m,i-1,3,k) = (cc(m,i-1,k,1)+taur*((wa1(i-2)* 1 cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2))+(wa2(i-2)* 1 cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3))))+(taui*((wa1(i-2)* 1 cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2))-(wa2(i-2)* 1 cc(m,i,k,3)-wa2(i-1)*cc(m,i-1,k,3)))) ch(m,ic-1,2,k) = (cc(m,i-1,k,1)+taur*((wa1(i-2)* 1 cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2))+(wa2(i-2)* 1 cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3))))-(taui*((wa1(i-2)* 1 cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2))-(wa2(i-2)* 1 cc(m,i,k,3)-wa2(i-1)*cc(m,i-1,k,3)))) ch(m,i,3,k) = (cc(m,i,k,1)+taur*((wa1(i-2)*cc(m,i,k,2)- 1 wa1(i-1)*cc(m,i-1,k,2))+(wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3))))+(taui*((wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)* 1 cc(m,i,k,3))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2)))) ch(m,ic,2,k) = (taui*((wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)* 1 cc(m,i,k,3))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2))))-(cc(m,i,k,1)+taur*((wa1(i-2)*cc(m,i,k,2)- 1 wa1(i-1)*cc(m,i-1,k,2))+(wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3)))) 1002 continue 102 continue 103 continue return end subroutine hradf4 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1,wa2,wa3) c c a multiple fft package for spherepack c dimension cc(mdimcc,ido,l1,4) ,ch(mdimch,ido,4,l1) , 1 wa1(ido) ,wa2(ido) ,wa3(ido) hsqt2=sqrt(2.)/2. do 101 k=1,l1 do 1001 m=1,mp ch(m,1,1,k) = (cc(m,1,k,2)+cc(m,1,k,4)) 1 +(cc(m,1,k,1)+cc(m,1,k,3)) ch(m,ido,4,k) = (cc(m,1,k,1)+cc(m,1,k,3)) 1 -(cc(m,1,k,2)+cc(m,1,k,4)) ch(m,ido,2,k) = cc(m,1,k,1)-cc(m,1,k,3) ch(m,1,3,k) = cc(m,1,k,4)-cc(m,1,k,2) 1001 continue 101 continue if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k=1,l1 do 103 i=3,ido,2 ic = idp2-i do 1003 m=1,mp ch(m,i-1,1,k) = ((wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2))+(wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)* 1 cc(m,i,k,4)))+(cc(m,i-1,k,1)+(wa2(i-2)*cc(m,i-1,k,3)+ 1 wa2(i-1)*cc(m,i,k,3))) ch(m,ic-1,4,k) = (cc(m,i-1,k,1)+(wa2(i-2)*cc(m,i-1,k,3)+ 1 wa2(i-1)*cc(m,i,k,3)))-((wa1(i-2)*cc(m,i-1,k,2)+ 1 wa1(i-1)*cc(m,i,k,2))+(wa3(i-2)*cc(m,i-1,k,4)+ 1 wa3(i-1)*cc(m,i,k,4))) ch(m,i,1,k) = ((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)* 1 cc(m,i-1,k,2))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4)))+(cc(m,i,k,1)+(wa2(i-2)*cc(m,i,k,3)- 1 wa2(i-1)*cc(m,i-1,k,3))) ch(m,ic,4,k) = ((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)* 1 cc(m,i-1,k,2))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4)))-(cc(m,i,k,1)+(wa2(i-2)*cc(m,i,k,3)- 1 wa2(i-1)*cc(m,i-1,k,3))) ch(m,i-1,3,k) = ((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)* 1 cc(m,i-1,k,2))-(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4)))+(cc(m,i-1,k,1)-(wa2(i-2)*cc(m,i-1,k,3)+ 1 wa2(i-1)*cc(m,i,k,3))) ch(m,ic-1,2,k) = (cc(m,i-1,k,1)-(wa2(i-2)*cc(m,i-1,k,3)+ 1 wa2(i-1)*cc(m,i,k,3)))-((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)* 1 cc(m,i-1,k,2))-(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4))) ch(m,i,3,k) = ((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)* 1 cc(m,i,k,4))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2)))+(cc(m,i,k,1)-(wa2(i-2)*cc(m,i,k,3)- 1 wa2(i-1)*cc(m,i-1,k,3))) ch(m,ic,2,k) = ((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)* 1 cc(m,i,k,4))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2)))-(cc(m,i,k,1)-(wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3))) 1003 continue 103 continue 104 continue if (mod(ido,2) .eq. 1) return 105 continue do 106 k=1,l1 do 1006 m=1,mp ch(m,ido,1,k) = (hsqt2*(cc(m,ido,k,2)-cc(m,ido,k,4)))+ 1 cc(m,ido,k,1) ch(m,ido,3,k) = cc(m,ido,k,1)-(hsqt2*(cc(m,ido,k,2)- 1 cc(m,ido,k,4))) ch(m,1,2,k) = (-hsqt2*(cc(m,ido,k,2)+cc(m,ido,k,4)))- 1 cc(m,ido,k,3) ch(m,1,4,k) = (-hsqt2*(cc(m,ido,k,2)+cc(m,ido,k,4)))+ 1 cc(m,ido,k,3) 1006 continue 106 continue 107 return end subroutine hradf5 (mp,ido,l1,cc,mdimcc,ch,mdimch, 1 wa1,wa2,wa3,wa4) c c a multiple fft package for spherepack c dimension cc(mdimcc,ido,l1,5) ,ch(mdimch,ido,5,l1) , 1 wa1(ido) ,wa2(ido) ,wa3(ido) ,wa4(ido) arg=2.*pimach()/5. tr11=cos(arg) ti11=sin(arg) tr12=cos(2.*arg) ti12=sin(2.*arg) do 101 k=1,l1 do 1001 m=1,mp ch(m,1,1,k) = cc(m,1,k,1)+(cc(m,1,k,5)+cc(m,1,k,2))+ 1 (cc(m,1,k,4)+cc(m,1,k,3)) ch(m,ido,2,k) = cc(m,1,k,1)+tr11*(cc(m,1,k,5)+cc(m,1,k,2))+ 1 tr12*(cc(m,1,k,4)+cc(m,1,k,3)) ch(m,1,3,k) = ti11*(cc(m,1,k,5)-cc(m,1,k,2))+ti12* 1 (cc(m,1,k,4)-cc(m,1,k,3)) ch(m,ido,4,k) = cc(m,1,k,1)+tr12*(cc(m,1,k,5)+cc(m,1,k,2))+ 1 tr11*(cc(m,1,k,4)+cc(m,1,k,3)) ch(m,1,5,k) = ti12*(cc(m,1,k,5)-cc(m,1,k,2))-ti11* 1 (cc(m,1,k,4)-cc(m,1,k,3)) 1001 continue 101 continue if (ido .eq. 1) return idp2 = ido+2 do 103 k=1,l1 do 102 i=3,ido,2 ic = idp2-i do 1002 m=1,mp ch(m,i-1,1,k) = cc(m,i-1,k,1)+((wa1(i-2)*cc(m,i-1,k,2)+ 1 wa1(i-1)*cc(m,i,k,2))+(wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)* 1 cc(m,i,k,5)))+((wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)* 1 cc(m,i,k,3))+(wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))) ch(m,i,1,k) = cc(m,i,k,1)+((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)* 1 cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)* 1 cc(m,i-1,k,5)))+((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4))) ch(m,i-1,3,k) = cc(m,i-1,k,1)+tr11* 1 ( wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2) 1 +wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)*cc(m,i,k,5))+tr12* 1 ( wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3) 1 +wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))+ti11* 1 ( wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2) 1 -(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*cc(m,i-1,k,5)))+ti12* 1 ( wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*cc(m,i-1,k,3) 1 -(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*cc(m,i-1,k,4))) ch(m,ic-1,2,k) = cc(m,i-1,k,1)+tr11* 1 ( wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2) 1 +wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)*cc(m,i,k,5))+tr12* 1 ( wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3) 1 +wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))-(ti11* 1 ( wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2) 1 -(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*cc(m,i-1,k,5)))+ti12* 1 ( wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*cc(m,i-1,k,3) 1 -(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*cc(m,i-1,k,4)))) ch(m,i,3,k) = (cc(m,i,k,1)+tr11*((wa1(i-2)*cc(m,i,k,2)- 1 wa1(i-1)*cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)* 1 cc(m,i-1,k,5)))+tr12*((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4))))+(ti11*((wa4(i-2)*cc(m,i-1,k,5)+ 1 wa4(i-1)*cc(m,i,k,5))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2)))+ti12*((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)* 1 cc(m,i,k,4))-(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)* 1 cc(m,i,k,3)))) ch(m,ic,2,k) = (ti11*((wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)* 1 cc(m,i,k,5))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2)))+ti12*((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)* 1 cc(m,i,k,4))-(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)* 1 cc(m,i,k,3))))-(cc(m,i,k,1)+tr11*((wa1(i-2)*cc(m,i,k,2)- 1 wa1(i-1)*cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)* 1 cc(m,i-1,k,5)))+tr12*((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4)))) ch(m,i-1,5,k) = (cc(m,i-1,k,1)+tr12*((wa1(i-2)* 1 cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2))+(wa4(i-2)* 1 cc(m,i-1,k,5)+wa4(i-1)*cc(m,i,k,5)))+tr11*((wa2(i-2)* 1 cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3))+(wa3(i-2)* 1 cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))))+(ti12*((wa1(i-2)* 1 cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2))-(wa4(i-2)*cc(m,i,k,5)- 1 wa4(i-1)*cc(m,i-1,k,5)))-ti11*((wa2(i-2)*cc(m,i,k,3)- 1 wa2(i-1)*cc(m,i-1,k,3))-(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4)))) ch(m,ic-1,4,k) = (cc(m,i-1,k,1)+tr12*((wa1(i-2)* 1 cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2))+(wa4(i-2)* 1 cc(m,i-1,k,5)+wa4(i-1)*cc(m,i,k,5)))+tr11*((wa2(i-2)* 1 cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3))+(wa3(i-2)* 1 cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))))-(ti12*((wa1(i-2)* 1 cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2))-(wa4(i-2)*cc(m,i,k,5)- 1 wa4(i-1)*cc(m,i-1,k,5)))-ti11*((wa2(i-2)*cc(m,i,k,3)- 1 wa2(i-1)*cc(m,i-1,k,3))-(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4)))) ch(m,i,5,k) = (cc(m,i,k,1)+tr12*((wa1(i-2)*cc(m,i,k,2)- 1 wa1(i-1)*cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)* 1 cc(m,i-1,k,5)))+tr11*((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4))))+(ti12*((wa4(i-2)*cc(m,i-1,k,5)+ 1 wa4(i-1)*cc(m,i,k,5))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2)))-ti11*((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)* 1 cc(m,i,k,4))-(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)* 1 cc(m,i,k,3)))) ch(m,ic,4,k) = (ti12*((wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)* 1 cc(m,i,k,5))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)* 1 cc(m,i,k,2)))-ti11*((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)* 1 cc(m,i,k,4))-(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)* 1 cc(m,i,k,3))))-(cc(m,i,k,1)+tr12*((wa1(i-2)*cc(m,i,k,2)- 1 wa1(i-1)*cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)* 1 cc(m,i-1,k,5)))+tr11*((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)* 1 cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)* 1 cc(m,i-1,k,4)))) 1002 continue 102 continue 103 continue return end subroutine hradfg (mp,ido,ip,l1,idl1,cc,c1,c2,mdimcc, 1 ch,ch2,mdimch,wa) c c a multiple fft package for spherepack c dimension ch(mdimch,ido,l1,ip) ,cc(mdimcc,ido,ip,l1) , 1 c1(mdimcc,ido,l1,ip) ,c2(mdimcc,idl1,ip), 2 ch2(mdimch,idl1,ip) ,wa(ido) tpi=2.*pimach() arg = tpi/float(ip) dcp = cos(arg) dsp = sin(arg) ipph = (ip+1)/2 ipp2 = ip+2 idp2 = ido+2 nbd = (ido-1)/2 if (ido .eq. 1) go to 119 do 101 ik=1,idl1 do 1001 m=1,mp ch2(m,ik,1) = c2(m,ik,1) 1001 continue 101 continue do 103 j=2,ip do 102 k=1,l1 do 1002 m=1,mp ch(m,1,k,j) = c1(m,1,k,j) 1002 continue 102 continue 103 continue if (nbd .gt. l1) go to 107 is = -ido do 106 j=2,ip is = is+ido idij = is do 105 i=3,ido,2 idij = idij+2 do 104 k=1,l1 do 1004 m=1,mp ch(m,i-1,k,j) = wa(idij-1)*c1(m,i-1,k,j)+wa(idij) 1 *c1(m,i,k,j) ch(m,i,k,j) = wa(idij-1)*c1(m,i,k,j)-wa(idij) 1 *c1(m,i-1,k,j) 1004 continue 104 continue 105 continue 106 continue go to 111 107 is = -ido do 110 j=2,ip is = is+ido do 109 k=1,l1 idij = is do 108 i=3,ido,2 idij = idij+2 do 1008 m=1,mp ch(m,i-1,k,j) = wa(idij-1)*c1(m,i-1,k,j)+wa(idij) 1 *c1(m,i,k,j) ch(m,i,k,j) = wa(idij-1)*c1(m,i,k,j)-wa(idij) 1 *c1(m,i-1,k,j) 1008 continue 108 continue 109 continue 110 continue 111 if (nbd .lt. l1) go to 115 do 114 j=2,ipph jc = ipp2-j do 113 k=1,l1 do 112 i=3,ido,2 do 1012 m=1,mp c1(m,i-1,k,j) = ch(m,i-1,k,j)+ch(m,i-1,k,jc) c1(m,i-1,k,jc) = ch(m,i,k,j)-ch(m,i,k,jc) c1(m,i,k,j) = ch(m,i,k,j)+ch(m,i,k,jc) c1(m,i,k,jc) = ch(m,i-1,k,jc)-ch(m,i-1,k,j) 1012 continue 112 continue 113 continue 114 continue go to 121 115 do 118 j=2,ipph jc = ipp2-j do 117 i=3,ido,2 do 116 k=1,l1 do 1016 m=1,mp c1(m,i-1,k,j) = ch(m,i-1,k,j)+ch(m,i-1,k,jc) c1(m,i-1,k,jc) = ch(m,i,k,j)-ch(m,i,k,jc) c1(m,i,k,j) = ch(m,i,k,j)+ch(m,i,k,jc) c1(m,i,k,jc) = ch(m,i-1,k,jc)-ch(m,i-1,k,j) 1016 continue 116 continue 117 continue 118 continue go to 121 119 do 120 ik=1,idl1 do 1020 m=1,mp c2(m,ik,1) = ch2(m,ik,1) 1020 continue 120 continue 121 do 123 j=2,ipph jc = ipp2-j do 122 k=1,l1 do 1022 m=1,mp c1(m,1,k,j) = ch(m,1,k,j)+ch(m,1,k,jc) c1(m,1,k,jc) = ch(m,1,k,jc)-ch(m,1,k,j) 1022 continue 122 continue 123 continue c ar1 = 1. ai1 = 0. do 127 l=2,ipph lc = ipp2-l ar1h = dcp*ar1-dsp*ai1 ai1 = dcp*ai1+dsp*ar1 ar1 = ar1h do 124 ik=1,idl1 do 1024 m=1,mp ch2(m,ik,l) = c2(m,ik,1)+ar1*c2(m,ik,2) ch2(m,ik,lc) = ai1*c2(m,ik,ip) 1024 continue 124 continue dc2 = ar1 ds2 = ai1 ar2 = ar1 ai2 = ai1 do 126 j=3,ipph jc = ipp2-j ar2h = dc2*ar2-ds2*ai2 ai2 = dc2*ai2+ds2*ar2 ar2 = ar2h do 125 ik=1,idl1 do 1025 m=1,mp ch2(m,ik,l) = ch2(m,ik,l)+ar2*c2(m,ik,j) ch2(m,ik,lc) = ch2(m,ik,lc)+ai2*c2(m,ik,jc) 1025 continue 125 continue 126 continue 127 continue do 129 j=2,ipph do 128 ik=1,idl1 do 1028 m=1,mp ch2(m,ik,1) = ch2(m,ik,1)+c2(m,ik,j) 1028 continue 128 continue 129 continue c if (ido .lt. l1) go to 132 do 131 k=1,l1 do 130 i=1,ido do 1030 m=1,mp cc(m,i,1,k) = ch(m,i,k,1) 1030 continue 130 continue 131 continue go to 135 132 do 134 i=1,ido do 133 k=1,l1 do 1033 m=1,mp cc(m,i,1,k) = ch(m,i,k,1) 1033 continue 133 continue 134 continue 135 do 137 j=2,ipph jc = ipp2-j j2 = j+j do 136 k=1,l1 do 1036 m=1,mp cc(m,ido,j2-2,k) = ch(m,1,k,j) cc(m,1,j2-1,k) = ch(m,1,k,jc) 1036 continue 136 continue 137 continue if (ido .eq. 1) return if (nbd .lt. l1) go to 141 do 140 j=2,ipph jc = ipp2-j j2 = j+j do 139 k=1,l1 do 138 i=3,ido,2 ic = idp2-i do 1038 m=1,mp cc(m,i-1,j2-1,k) = ch(m,i-1,k,j)+ch(m,i-1,k,jc) cc(m,ic-1,j2-2,k) = ch(m,i-1,k,j)-ch(m,i-1,k,jc) cc(m,i,j2-1,k) = ch(m,i,k,j)+ch(m,i,k,jc) cc(m,ic,j2-2,k) = ch(m,i,k,jc)-ch(m,i,k,j) 1038 continue 138 continue 139 continue 140 continue return 141 do 144 j=2,ipph jc = ipp2-j j2 = j+j do 143 i=3,ido,2 ic = idp2-i do 142 k=1,l1 do 1042 m=1,mp cc(m,i-1,j2-1,k) = ch(m,i-1,k,j)+ch(m,i-1,k,jc) cc(m,ic-1,j2-2,k) = ch(m,i-1,k,j)-ch(m,i-1,k,jc) cc(m,i,j2-1,k) = ch(m,i,k,j)+ch(m,i,k,jc) cc(m,ic,j2-2,k) = ch(m,i,k,jc)-ch(m,i,k,j) 1042 continue 142 continue 143 continue 144 continue return end subroutine hrfftb(m,n,r,mdimr,whrfft,work) c c a multiple fft package for spherepack c dimension r(mdimr,n) ,work(1) ,whrfft(n+15) common /hrf/ tfft if (n .eq. 1) return c tstart = second(dum) call hrftb1 (m,n,r,mdimr,work,whrfft,whrfft(n+1)) c tfft = tfft+second(dum)-tstart return end subroutine hrfftf (m,n,r,mdimr,whrfft,work) c c a multiple fft package for spherepack c dimension r(mdimr,n) ,work(1) ,whrfft(n+15) common /hrf/ tfft if (n .eq. 1) return c tstart = second(dum) call hrftf1 (m,n,r,mdimr,work,whrfft,whrfft(n+1)) c tfft = tfft+second(dum)-tstart return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file hrfft.f c c this file contains a multiple fft package for spherepack3.0. c it includes code and documentation for performing fast fourier c transforms (see subroutines hrffti,hrfftf and hrfftb) c c ********************************************************************** c c subroutine hrffti(n,wsave) c c subroutine hrffti initializes the array wsave which is used in c both hrfftf and hrfftb. the prime factorization of n together c with a tabulation of the trigonometric functions are computed and c stored in wsave. c c input parameter c c n the length of the sequence to be transformed. c c output parameter c c wsave a work array which must be dimensioned at least 2*n+15. c the same work array can be used for both hrfftf and c hrfftb as long as n remains unchanged. different wsave c arrays are required for different values of n. the c contents of wsave must not be changed between calls c of hrfftf or hrfftb. c c ********************************************************************** c c subroutine hrfftf(m,n,r,mdimr,wsave,work) c c subroutine hrfftf computes the fourier coefficients of m real c perodic sequences (fourier analysis); i.e. hrfftf computes the c real fft of m sequences each with length n. the transform is c defined below at output parameter r. c c input parameters c c m the number of sequences. c c n the length of all m sequences. the method is most c efficient when n is a product of small primes. n may c change as long as different work arrays are provided c c r r(m,n) is a two dimensional real array that contains m c sequences each with length n. c c mdimr the first dimension of the r array as it appears c in the program that calls hrfftf. mdimr must be c greater than or equal to m. c c c wsave a work array with at least least 2*n+15 locations c in the program that calls hrfftf. the wsave array must be c initialized by calling subroutine hrffti(n,wsave) and a c different wsave array must be used for each different c value of n. this initialization does not have to be c repeated so long as n remains unchanged thus subsequent c transforms can be obtained faster than the first. c the same wsave array can be used by hrfftf and hrfftb. c c work a real work array with m*n locations. c c c output parameters c c r for all j=1,...,m c c r(j,1) = the sum from i=1 to i=n of r(j,i) c c if n is even set l =n/2 , if n is odd set l = (n+1)/2 c c then for k = 2,...,l c c r(j,2*k-2) = the sum from i = 1 to i = n of c c r(j,i)*cos((k-1)*(i-1)*2*pi/n) c c r(j,2*k-1) = the sum from i = 1 to i = n of c c -r(j,i)*sin((k-1)*(i-1)*2*pi/n) c c if n is even c c r(j,n) = the sum from i = 1 to i = n of c c (-1)**(i-1)*r(j,i) c c ***** note c this transform is unnormalized since a call of hrfftf c followed by a call of hrfftb will multiply the input c sequence by n. c c wsave contains results which must not be destroyed between c calls of hrfftf or hrfftb. c c work a real work array with m*n locations that does c not have to be saved. c c ********************************************************************** c c subroutine hrfftb(m,n,r,mdimr,wsave,work) c c subroutine hrfftb computes the real perodic sequence of m c sequences from their fourier coefficients (fourier synthesis). c the transform is defined below at output parameter r. c c input parameters c c m the number of sequences. c c n the length of all m sequences. the method is most c efficient when n is a product of small primes. n may c change as long as different work arrays are provided c c r r(m,n) is a two dimensional real array that contains c the fourier coefficients of m sequences each with c length n. c c mdimr the first dimension of the r array as it appears c in the program that calls hrfftb. mdimr must be c greater than or equal to m. c c wsave a work array which must be dimensioned at least 2*n+15. c in the program that calls hrfftb. the wsave array must be c initialized by calling subroutine hrffti(n,wsave) and a c different wsave array must be used for each different c value of n. this initialization does not have to be c repeated so long as n remains unchanged thus subsequent c transforms can be obtained faster than the first. c the same wsave array can be used by hrfftf and hrfftb. c c work a real work array with m*n locations. c c c output parameters c c r for all j=1,...,m c c for n even and for i = 1,...,n c c r(j,i) = r(j,1)+(-1)**(i-1)*r(j,n) c c plus the sum from k=2 to k=n/2 of c c 2.*r(j,2*k-2)*cos((k-1)*(i-1)*2*pi/n) c c -2.*r(j,2*k-1)*sin((k-1)*(i-1)*2*pi/n) c c for n odd and for i = 1,...,n c c r(j,i) = r(j,1) plus the sum from k=2 to k=(n+1)/2 of c c 2.*r(j,2*k-2)*cos((k-1)*(i-1)*2*pi/n) c c -2.*r(j,2*k-1)*sin((k-1)*(i-1)*2*pi/n) c c ***** note c this transform is unnormalized since a call of hrfftf c followed by a call of hrfftb will multiply the input c sequence by n. c c wsave contains results which must not be destroyed between c calls of hrfftb or hrfftf. c c work a real work array with m*n locations that does not c have to be saved c c ********************************************************************** c c c subroutine hrffti (n,wsave) dimension wsave(n+15) common /hrf/ tfft tfft = 0. if (n .eq. 1) return call hrfti1 (n,wsave(1),wsave(n+1)) return end subroutine hrftb1 (m,n,c,mdimc,ch,wa,fac) c c a multiple fft package for spherepack c dimension ch(m,n), c(mdimc,n), wa(n) ,fac(15) nf = fac(2) na = 0 l1 = 1 iw = 1 do 116 k1=1,nf ip = fac(k1+2) l2 = ip*l1 ido = n/l2 idl1 = ido*l1 if (ip .ne. 4) go to 103 ix2 = iw+ido ix3 = ix2+ido if (na .ne. 0) go to 101 call hradb4 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2),wa(ix3)) go to 102 101 call hradb4 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2),wa(ix3)) 102 na = 1-na go to 115 103 if (ip .ne. 2) go to 106 if (na .ne. 0) go to 104 call hradb2 (m,ido,l1,c,mdimc,ch,m,wa(iw)) go to 105 104 call hradb2 (m,ido,l1,ch,m,c,mdimc,wa(iw)) 105 na = 1-na go to 115 106 if (ip .ne. 3) go to 109 ix2 = iw+ido if (na .ne. 0) go to 107 call hradb3 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2)) go to 108 107 call hradb3 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2)) 108 na = 1-na go to 115 109 if (ip .ne. 5) go to 112 ix2 = iw+ido ix3 = ix2+ido ix4 = ix3+ido if (na .ne. 0) go to 110 call hradb5 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 111 110 call hradb5 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2),wa(ix3),wa(ix4)) 111 na = 1-na go to 115 112 if (na .ne. 0) go to 113 call hradbg (m,ido,ip,l1,idl1,c,c,c,mdimc,ch,ch,m,wa(iw)) go to 114 113 call hradbg (m,ido,ip,l1,idl1,ch,ch,ch,m,c,c,mdimc,wa(iw)) 114 if (ido .eq. 1) na = 1-na 115 l1 = l2 iw = iw+(ip-1)*ido 116 continue if (na .eq. 0) return do 117 j=1,n do 117 i=1,m c(i,j) = ch(i,j) 117 continue return end subroutine hrftf1 (m,n,c,mdimc,ch,wa,fac) c c a multiple fft package for spherepack c dimension ch(m,n) ,c(mdimc,n) ,wa(n) ,fac(15) nf = fac(2) na = 1 l2 = n iw = n do 111 k1=1,nf kh = nf-k1 ip = fac(kh+3) l1 = l2/ip ido = n/l2 idl1 = ido*l1 iw = iw-(ip-1)*ido na = 1-na if (ip .ne. 4) go to 102 ix2 = iw+ido ix3 = ix2+ido if (na .ne. 0) go to 101 call hradf4 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2),wa(ix3)) go to 110 101 call hradf4 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2),wa(ix3)) go to 110 102 if (ip .ne. 2) go to 104 if (na .ne. 0) go to 103 call hradf2 (m,ido,l1,c,mdimc,ch,m,wa(iw)) go to 110 103 call hradf2 (m,ido,l1,ch,m,c,mdimc,wa(iw)) go to 110 104 if (ip .ne. 3) go to 106 ix2 = iw+ido if (na .ne. 0) go to 105 call hradf3 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2)) go to 110 105 call hradf3 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2)) go to 110 106 if (ip .ne. 5) go to 108 ix2 = iw+ido ix3 = ix2+ido ix4 = ix3+ido if (na .ne. 0) go to 107 call hradf5(m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 110 107 call hradf5(m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 110 108 if (ido .eq. 1) na = 1-na if (na .ne. 0) go to 109 call hradfg (m,ido,ip,l1,idl1,c,c,c,mdimc,ch,ch,m,wa(iw)) na = 1 go to 110 109 call hradfg (m,ido,ip,l1,idl1,ch,ch,ch,m,c,c,mdimc,wa(iw)) na = 0 110 l2 = l1 111 continue if (na .eq. 1) return do 112 j=1,n do 112 i=1,m c(i,j) = ch(i,j) 112 continue return end subroutine hrfti1 (n,wa,fac) c c a multiple fft package for spherepack c dimension wa(n) ,fac(15) ,ntryh(4) double precision tpi,argh,argld,arg data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/4,2,3,5/ nl = n nf = 0 j = 0 101 j = j+1 if (j-4) 102,102,103 102 ntry = ntryh(j) go to 104 103 ntry = ntry+2 104 nq = nl/ntry nr = nl-ntry*nq if (nr) 101,105,101 105 nf = nf+1 fac(nf+2) = ntry nl = nq if (ntry .ne. 2) go to 107 if (nf .eq. 1) go to 107 do 106 i=2,nf ib = nf-i+2 fac(ib+2) = fac(ib+1) 106 continue fac(3) = 2 107 if (nl .ne. 1) go to 104 fac(1) = n fac(2) = nf tpi = 8.d0*datan(1.d0) argh = tpi/float(n) is = 0 nfm1 = nf-1 l1 = 1 if (nfm1 .eq. 0) return do 110 k1=1,nfm1 ip = fac(k1+2) ld = 0 l2 = l1*ip ido = n/l2 ipm = ip-1 do 109 j=1,ipm ld = ld+l1 i = is argld = float(ld)*argh fi = 0. do 108 ii=3,ido,2 i = i+2 fi = fi+1. arg = fi*argld wa(i-1) = dcos(arg) wa(i) = dsin(arg) 108 continue is = is+ido 109 continue l1 = l2 110 continue return end integer function icvmg(i1,i2,r) integer i1,i2 real r c c returns i1 if i3.ge.0 and returns i2 if i3.lt.0 . c icvmg = i1 if (r .lt. 0.) icvmg = i2 return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file idivec.f c c this file includes documentation and code for c subroutine idivec i c c ... files which must be loaded with idivec.f c c sphcom.f, hrfft.f, vhsec.f,shaec.f c c c c subroutine idivec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsec,lvhsec,work,lwork,pertrb,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shaec for a scalar array dv, subroutine idivec computes c an irrotational vector field (v,w) whose divergence is dv - pertrb. c w is the east longitude component and v is the colatitudinal component. c pertrb is a constant which must be subtracted from dv for (v,w) to c exist (see the description of pertrb below). usually pertrb is zero c or small relative to dv. the vorticity of (v,w), as computed by c vortec, is the zero scalar field. v(i,j) and w(i,j) are the c velocity components at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon. c c the c c divergence[v(i,j),w(i,j)] c c = [d(w(i,j)/dlambda + d(sint*v(i,j))/dtheta]/sint c c = dv(i,j) - pertrb c c and c c vorticity(v(i,j),w(i,j)) c c = [dv/dlambda - d(sint*w)/dtheta]/sint c c = 0.0 c c where sint = sin(theta(i)). required associated legendre polynomials c are recomputed rather than stored as they are in subroutine idives. c c input parameters c c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shaec to compute the arrays a and b from the c scalar field dv. isym determines whether (v,w) are c computed on the full or half sphere as follows: c c = 0 c c dv is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c dv is antisymmetric about the equator. in this case w is c antisymmetric and v is symmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c dv is symmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of divergence and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays a,b,v, and w can be three dimensional and pertrb c can be one dimensional corresponding to an indexed multiple c array dv. in this case, multiple vector synthesis will be c performed to compute each vector field. the third index for c a,b,v,w and first for pertrb is the synthesis index which c assumes the values k = 1,...,nt. for a single synthesis set c nt = 1. the description of the remaining parameters is c simplified by assuming that nt=1 or that a,b,v,w are two c dimensional and pertrb is a constant. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls idivec. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls idivec. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the divergence array dv as computed by subroutine shaec. c *** a,b must be computed by shaec prior to calling idivec. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls idivec (and shaec). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls idivec (and shaec). ndab must be at c least nlat. c c c wvhsec an array which must be initialized by subroutine vhseci. c once initialized, c wvhsec can be used repeatedly by idivec as long as nlon c and nlat remain unchanged. wvhsec must not be altered c between calls of idivec. c c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls idivec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls idivec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon) + 2*nt*l1 + 1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*l1*nt+1) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain an irrotational vector field whose divergence is c dv-pertrb at the colatitude point theta(i)=(i-1)*pi/(nlat-1) c and longitude point lambda(j)=(j-1)*2*pi/nlon. w is the east c longitude component and v is the colatitudinal component. the c indices for w and v are defined at the input parameter isym. c the curl or vorticity of (v,w) is the zero vector field. note c that any nonzero vector field on the sphere will be multiple c valued at the poles [reference swarztrauber]. c c pertrb a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). dv - pertrb is a scalar c field which can be the divergence of a vector field (v,w). c pertrb is related to the scalar harmonic coefficients a,b c of dv (computed by shaec) by the formula c c pertrb = a(1,1)/(2.*sqrt(2.)) c c c c the unperturbed scalar field dv can be the divergence of a c vector field only if a(1,1) is zero. if a(1,1) is nonzero c (flagged by pertrb nonzero) then subtracting pertrb from c dv yields a scalar field for which a(1,1) is zero. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsec c = 10 error in the specification of lwork c ********************************************************************** c c subroutine idivec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, + wvhsec,lvhsec,work,lwork,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsec(lvhsec),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin=4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 if(lvhsec .lt. lwmin) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr + mn is = ibi + mn iwk = is + nlat liwk = lwork-2*mn-nlat call idvec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),work(ibi), + mmax,work(is),mdab,ndab,a,b,wvhsec,lvhsec,work(iwk), + liwk,pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file idives.f c c this file includes documentation and code for c subroutine idives i c c ... files which must be loaded with idivec.f c c sphcom.f, hrfft.f, vhses.f,shaes.f c c c subroutine idives(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhses,lvhses,work,lwork,pertrb,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shaes for a scalar array dv, subroutine idives computes c an irrotational vector field (v,w) whose divergence is dv - pertrb. c w is the east longitude component and v is the colatitudinal component. c pertrb is a constant which must be subtracted from dv for (v,w) to c exist (see the description of pertrb below). usually pertrb is zero c or small relative to dv. the vorticity of (v,w), as computed by c vortes, is the zero scalar field. i.e., v(i,j) and w(i,j) are the c velocity components at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon. c c the c c divergence[v(i,j),w(i,j)] c c = [d(w(i,j)/dlambda + d(sint*v(i,j))/dtheta]/sint c c = dv(i,j) - pertrb c c and c c vorticity(v(i,j),w(i,j)) c c = [dv/dlambda - d(sint*w)/dtheta]/sint c c = 0.0 c c where sint = sin(theta(i)). required associated legendre polynomials c are stored rather than recomputed as they are in subroutine idivec. c c input parameters c c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shaes to compute the arrays a and b from the c scalar field dv. isym determines whether (v,w) are c computed on the full or half sphere as follows: c c = 0 c c dv is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c dv is antisymmetric about the equator. in this case w is c antisymmetric and v is symmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c dv is symmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of divergence and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays a,b,v, and w can be three dimensional and pertrb c can be one dimensional corresponding to an indexed multiple c array dv. in this case, multiple vector synthesis will be c performed to compute each vector field. the third index for c a,b,v,w and first for pertrb is the synthesis index which c assumes the values k = 1,...,nt. for a single synthesis set c nt = 1. the description of the remaining parameters is c simplified by assuming that nt=1 or that a,b,v,w are two c dimensional and pertrb is a constant. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls idives. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls idives. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the divergence array dv as computed by subroutine shaes. c *** a,b must be computed by shaes prior to calling idives. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls idives (and shaes). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls idives (and shaes). ndab must be at c least nlat. c c c wvhses an array which must be initialized by subroutine vhesesi. c once initialized, c wvhses can be used repeatedly by idives as long as nlon c and nlat remain unchanged. wvhses must not be altered c between calls of idives. c c c lvhses the dimension of the array wvhses as it appears in the c program that calls idives. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhses must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls idives. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*((2*nt+1)*nlon+2*nt*l1+1) c c if isym = 1 or 2 then lwork must be at least c c (2*nt+1)*l2*nlon+nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain an irrotational vector field whose divergence is c dv-pertrb at the colatitude point theta(i)=(i-1)*pi/(nlat-1) c and longitude point lambda(j)=(j-1)*2*pi/nlon. w is the east c longitude component and v is the colatitudinal component. the c indices for w and v are defined at the input parameter isym. c the curl or vorticity of (v,w) is the zero vector field. note c that any nonzero vector field on the sphere will be multiple c valued at the poles [reference swarztrauber]. c c pertrb a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). dv - pertrb is a scalar c field which can be the divergence of a vector field (v,w). c pertrb is related to the scalar harmonic coefficients a,b c of dv (computed by shaes) by the formula c c pertrb = a(1,1)/(2.*sqrt(2.)) c c c c the unperturbed scalar field dv can be the divergence of a c vector field only if a(1,1) is zero. if a(1,1) is nonzero c (flagged by pertrb nonzero) then subtracting pertrb from c dv yields a scalar field for which a(1,1) is zero. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhses c = 10 error in the specification of lwork c ********************************************************************** c c subroutine idives(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, + wvhses,lvhses,work,lwork,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhses(lvhses),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lvhses .lt. lzimn+lzimn+nlon+15) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr + mn is = ibi + mn iwk = is + nlat liwk = lwork-2*mn-nlat call idves1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),work(ibi), + mmax,work(is),mdab,ndab,a,b,wvhses,lvhses,work(iwk), + liwk,pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file idivgc.f c c this file includes documentation and code for c subroutine idivgc i c c ... files which must be loaded with idivec.f c c sphcom.f, hrfft.f, vhsgc.f,shagc.f c c subroutine idivgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsgc,lvhsgc,work,lwork,pertrb,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shagc for a scalar array dv, subroutine idivgc computes c an irrotational vector field (v,w) whose divergence is dv - pertrb. c w is the east longitude component and v is the colatitudinal component. c pertrb is a constant which must be subtracted from dv for (v,w) to c exist (see the description of pertrb below). usually pertrb is zero c or small relative to dv. the vorticity of (v,w) is the zero scalar c field. v(i,j) and w(i,j) are the velocity components at the gaussian c colatitude theta(i) (see nlat) and longitude lambda(j)=(j-1)*2*pi/nlon. c the c c divergence[v(i,j),w(i,j)] c c = [d(w(i,j)/dlambda + d(sint*v(i,j))/dtheta]/sint c c = dv(i,j) - pertrb c c and c c vorticity(v(i,j),w(i,j)) c c = [dv/dlambda - d(sint*w)/dtheta]/sint c c = 0.0 c c where sint = sin(theta(i)). c c input parameters c c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shagc to compute the arrays a and b from the c scalar field dv. isym determines whether (v,w) are c computed on the full or half sphere as follows: c c = 0 c c dv is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c dv is antisymmetric about the equator. in this case w is c antisymmetric and v is symmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c dv is symmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of divergence and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays a,b,v, and w can be three dimensional and pertrb c can be one dimensional corresponding to an indexed multiple c array dv. in this case, multiple vector synthesis will be c performed to compute each vector field. the third index for c a,b,v,w and first for pertrb is the synthesis index which c assumes the values k = 1,...,nt. for a single synthesis set c nt = 1. the description of the remaining parameters is c simplified by assuming that nt=1 or that a,b,v,w are two c dimensional and pertrb is a constant. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls idivgc. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls idivgc. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the divergence array dv as computed by subroutine shagc. c *** a,b must be computed by shagc prior to calling idivgc. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls idivgc (and shagc). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls idivgc (and shagc). ndab must be at c least nlat. c c c wvhsgc an array which must be initialized by subroutine vhsgci. c once initialized, c wvhsgc can be used repeatedly by idivgc as long as nlon c and nlat remain unchanged. wvhsgc must not be altered c between calls of idivgc. c c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls idivgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls idivgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon) + 2*nt*l1 + 1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain an irrotational vector field whose divergence is c dv-pertrb at the guassian colatitude point theta(i) and c longitude point lambda(j)=(j-1)*2*pi/nlon. w is the east c longitude component and v is the colatitudinal component. the c indices for w and v are defined at the input parameter isym. c the curl or vorticity of (v,w) is the zero vector field. note c that any nonzero vector field on the sphere will be multiple c valued at the poles [reference swarztrauber]. c c pertrb a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). dv - pertrb is a scalar c field which can be the divergence of a vector field (v,w). c pertrb is related to the scalar harmonic coefficients a,b c of dv (computed by shagc) by the formula c c pertrb = a(1,1)/(2.*sqrt(2.)) c c c c the unperturbed scalar field dv can be the divergence of a c vector field only if a(1,1) is zero. if a(1,1) is nonzero c (flagged by pertrb nonzero) then subtracting pertrb from c dv yields a scalar field for which a(1,1) is zero. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgc c = 10 error in the specification of lwork c ********************************************************************** c c subroutine idivgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, + wvhsgc,lvhsgc,work,lwork,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsgc(lvhsgc),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin = 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 if(lvhsgc .lt. lwmin) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr + mn is = ibi + mn iwk = is + nlat liwk = lwork-2*mn-nlat call idvgc1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),work(ibi), + mmax,work(is),mdab,ndab,a,b,wvhsgc,lvhsgc,work(iwk), + liwk,pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file idivec.f c c this file includes documentation and code for c subroutine idivgs i c c ... files which must be loaded with idivgs.f c c sphcom.f, hrfft.f, vhsgs.f,shags.f c c c subroutine idivgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsgs,lvhsgs,work,lwork,pertrb,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shags for a scalar array divg, subroutine idivgs computes c an irrotational vector field (v,w) whose divergence is divg - pertrb. c w is the east longitude component and v is the colatitudinal component. c pertrb is a constant which must be subtracted from divg for (v,w) to c exist (see the description of pertrb below). usually pertrb is zero c or small relative to divg. the vorticity of (v,w) is the zero scalar c field. v(i,j) and w(i,j) are the velocity components at the gaussian c colatitude theta(i) (see nlat) and longitude lambda(j)=(j-1)*2*pi/nlon. c the c c divergence[v(i,j),w(i,j)] c c = [d(w(i,j)/dlambda + d(sint*v(i,j))/dtheta]/sint c c = divg(i,j) - pertrb c c and c c vorticity(v(i,j),w(i,j)) c c = [dv/dlambda - d(sint*w)/dtheta]/sint c c = 0.0 c c where sint = sin(theta(i)). c c input parameters c c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shags to compute the arrays a and b from the c scalar field divg. isym determines whether (v,w) are c computed on the full or half sphere as follows: c c = 0 c c divg is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c divg is antisymmetric about the equator. in this case w is c antisymmetric and v is symmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c divg is symmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of divergence and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays a,b,v, and w can be three dimensional and pertrb c can be one dimensional corresponding to an indexed multiple c array divg. in this case, multiple vector synthesis will be c performed to compute each vector field. the third index for c a,b,v,w and first for pertrb is the synthesis index which c assumes the values k = 1,...,nt. for a single synthesis set c nt = 1. the description of the remaining parameters is c simplified by assuming that nt=1 or that a,b,v,w are two c dimensional and pertrb is a constant. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls idivgs. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls idivgs. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the divergence array divg as computed by subroutine shags. c *** a,b must be computed by shags prior to calling idivgs. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls idivgs (and shags). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls idivgs (and shags). ndab must be at c least nlat. c c c wvhsgs an array which must be initialized by subroutine vhsgsi. c once initialized, c wvhsgs can be used repeatedly by idivgs as long as nlon c and nlat remain unchanged. wvhsgs must not be altered c between calls of idivgs. c c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls idivgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgs must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls idivgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c (2*nt+1)*nlat*nlon + nlat*(2*nt*l1+1) c c if isym = 1 or 2 then lwork must be at least c c (2*nt+1)*l2*nlon + nlat*(2*nt*l1+1) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain an irrotational vector field whose divergence is c divg-pertrb at the guassian colatitude point theta(i) and c longitude point lambda(j)=(j-1)*2*pi/nlon. w is the east c longitude component and v is the colatitudinal component. the c indices for w and v are defined at the input parameter isym. c the curl or vorticity of (v,w) is the zero vector field. note c that any nonzero vector field on the sphere will be multiple c valued at the poles [reference swarztrauber]. c c pertrb a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). divg - pertrb is a scalar c field which can be the divergence of a vector field (v,w). c pertrb is related to the scalar harmonic coefficients a,b c of divg (computed by shags) by the formula c c pertrb = a(1,1)/(2.*sqrt(2.)) c c c c the unperturbed scalar field divg can be the divergence of a c vector field only if a(1,1) is zero. if a(1,1) is nonzero c (flagged by pertrb nonzero) then subtracting pertrb from c divg yields a scalar field for which a(1,1) is zero. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgs c = 10 error in the specification of lwork c ********************************************************************** c c subroutine idivgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, + wvhsgs,lvhsgs,work,lwork,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsgs(lvhsgs),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin = l1*l2*(nlat+nlat-l1+1)+nlon+15 if(lvhsgs .lt. lwmin) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr + mn is = ibi + mn iwk = is + nlat liwk = lwork-2*mn-nlat call idvgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr),work(ibi), + mmax,work(is),mdab,ndab,a,b,wvhsgs,lvhsgs,work(iwk), + liwk,pertrb,ierror) return end subroutine idvec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,mmax, +sqnn,mdab,ndab,a,b,wvhsec,lvhsec,wk,lwk,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsec(lvhsec),wk(lwk) c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set divergence field perturbation adjustment c pertrb(k) = a(1,1,k)/(2.*sqrt(2.)) c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = -a(1,n,k)/sqnn(n) bi(1,n,k) = -b(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = -a(m,n,k)/sqnn(n) bi(m,n,k) = -b(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis with curl=0 c if (isym.eq.0) then ityp = 1 else if (isym.eq.1) then ityp = 4 else if (isym.eq.2) then ityp = 7 end if c c vector sythesize br,bi into irrotational (v,w) c call vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wvhsec,lvhsec,wk,lwk,ierror) return end subroutine idves1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,mmax, +sqnn,mdab,ndab,a,b,wsav,lwsav,wk,lwk,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wsav(lwsav),wk(lwk) c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set divergence field perturbation adjustment c pertrb(k) = a(1,1,k)/(2.*sqrt(2.)) c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = -a(1,n,k)/sqnn(n) bi(1,n,k) = -b(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = -a(m,n,k)/sqnn(n) bi(m,n,k) = -b(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis with curl=0 c if (isym.eq.0) then ityp = 1 else if (isym.eq.1) then ityp = 4 else if (isym.eq.2) then ityp = 7 end if c c vector sythesize br,bi into irrotational (v,w) c call vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wsav,lwsav,wk,lwk,ierror) return end subroutine idvgc1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,mmax, +sqnn,mdab,ndab,a,b,wsav,lwsav,wk,lwk,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wsav(lwsav),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set divergence field perturbation adjustment c pertrb(k) = a(1,1,k)/(2.*sqrt(2.)) c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = -a(1,n,k)/sqnn(n) bi(1,n,k) = -b(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = -a(m,n,k)/sqnn(n) bi(m,n,k) = -b(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis with curl=0 c if (isym.eq.0) then ityp = 1 else if (isym.eq.1) then ityp = 4 else if (isym.eq.2) then ityp = 7 end if c c vector sythesize br,bi into irrotational (v,w) c call vhsgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wsav,lwsav,wk,lwk,ierror) return end subroutine idvgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi,mmax, +sqnn,mdab,ndab,a,b,wsav,lwsav,wk,lwk,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wsav(lwsav),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set divergence field perturbation adjustment c pertrb(k) = a(1,1,k)/(2.*sqrt(2.)) c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = -a(1,n,k)/sqnn(n) bi(1,n,k) = -b(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = -a(m,n,k)/sqnn(n) bi(m,n,k) = -b(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis with curl=0 c if (isym.eq.0) then ityp = 1 else if (isym.eq.1) then ityp = 4 else if (isym.eq.2) then ityp = 7 end if c c vector sythesize br,bi into irrotational (v,w) c call vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wsav,lwsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file idvtec.f c c this file includes documentation and code for c subroutine idvtec i c c ... files which must be loaded with idvtec.f c c sphcom.f, hrfft.f, vhsec.f,shaec.f c c c subroutine idvtec(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv, c +mdab,ndab,wvhsec,lvhsec,work,lwork,pertbd,pertbv,ierror) c c given the scalar spherical harmonic coefficients ad,bd precomputed c by subroutine shaec for the scalar field divg and coefficients av,bv c precomputed by subroutine shaec for the scalar field vort, subroutine c idvtec computes a vector field (v,w) whose divergence is divg - pertbd c and whose vorticity is vort - pertbv. w the is east longitude component c and v is the colatitudinal component of the velocity. if nt=1 (see nt c below) pertrbd and pertbv are constants which must be subtracted from c divg and vort for (v,w) to exist (see the description of pertbd and c pertrbv below). usually pertbd and pertbv are zero or small relative c to divg and vort. w(i,j) and v(i,j) are the velocity components at c colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c the c c divergence(v(i,j),w(i,j)) c c = [d(sint*v)/dtheta + dw/dlambda]/sint c c = divg(i,j) - pertbd c c and c c vorticity(v(i,j),w(i,j)) c c = [-dv/dlambda + d(sint*w)/dtheta]/sint c c = vort(i,j) - pertbv c c where c c sint = cos(theta(i)). c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym isym determines whether (v,w) are computed on the full or half c sphere as follows: c c = 0 c divg,vort are neither pairwise symmetric/antisymmetric nor c antisymmetric/symmetric about the equator as described for c isym = 1 or isym = 2 below. in this case, the vector field c (v,w) is computed on the entire sphere. i.e., in the arrays c w(i,j) and v(i,j) i=1,...,nlat and j=1,...,nlon. c c = 1 c c divg is antisymmetric and vort is symmetric about the equator. c in this case w is antisymmetric and v is symmetric about the c equator. w and v are computed on the northern hemisphere only. c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c divg is symmetric and vort is antisymmetric about the equator. c in this case w is symmetric and v is antisymmetric about the c equator. w and v are computed on the northern hemisphere only. c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt in the program that calls idvtec, nt is the number of scalar c and vector fields. some computational efficiency is obtained c for multiple fields. the arrays ad,bd,av,bv,u, and v can be c three dimensional and pertbd,pertbv can be one dimensional c corresponding to indexed multiple arrays divg, vort. in this c case, multiple synthesis will be performed to compute each c vector field. the third index for ad,bd,av,bv,v,w and first c pertrbd,pertbv is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the description of c remaining parameters is simplified by assuming that nt=1 or that c ad,bd,av,bv,v,w are two dimensional and pertbd,pertbv are c constants. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls idvtec. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls idvtec. jdvw must be at least nlon. c c ad,bd two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the divergence array divg as computed by subroutine shaec. c c av,bv two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the vorticity array vort as computed by subroutine shaec. c *** ad,bd,av,bv must be computed by shaec prior to calling idvtec. c c mdab the first dimension of the arrays ad,bd,av,bv as it appears c in the program that calls idvtec (and shaec). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays ad,bd,av,bv as it appears in c the program that calls idvtec (and shaec). ndab must be at c least nlat. c c wvhsec an array which must be initialized by subroutine vhseci. c wvhsec can be used repeatedly by idvtec as long as nlon c and nlat remain unchanged. wvhsec must not be altered c between calls of idvtec. c c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls idvtec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls idvtec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(4*l1*nt+1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(4*l1*nt+1) c c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a vector field whose divergence is divg - pertbd and c whose vorticity is vort - pertbv. w(i,j) is the east longitude c component and v(i,j) is the colatitudinal component of velocity c at the colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude c lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon. c c pertbd a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). divg - pertbd is a scalar c field which can be the divergence of a vector field (v,w). c pertbd is related to the scalar harmonic coefficients ad,bd c of divg (computed by shaec) by the formula c c pertbd = ad(1,1)/(2.*sqrt(2.)) c c an unperturbed divg can be the divergence of a vector field c only if ad(1,1) is zero. if ad(1,1) is nonzero (flagged by c pertbd nonzero) then subtracting pertbd from divg yields a c scalar field for which ad(1,1) is zero. usually pertbd is c zero or small relative to divg. c c pertbv a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). vort - pertbv is a scalar c field which can be the vorticity of a vector field (v,w). c pertbv is related to the scalar harmonic coefficients av,bv c of vort (computed by shaec) by the formula c c pertbv = av(1,1)/(2.*sqrt(2.)) c c an unperturbed vort can be the vorticity of a vector field c only if av(1,1) is zero. if av(1,1) is nonzero (flagged by c pertbv nonzero) then subtracting pertbv from vort yields a c scalar field for which av(1,1) is zero. usually pertbv is c zero or small relative to vort. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsec c = 10 error in the specification of lwork c ********************************************************************** c c subroutine idvtec(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv, +mdab,ndab,wvhsec,lvhsec,work,lwork,pertbd,pertbv,ierror) dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt),pertbd(nt),pertbv(nt) dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt) dimension av(mdab,ndab,nt),bv(mdab,ndab,nt) dimension wvhsec(lvhsec),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhsec .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+4*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr + mn is = ici + mn iwk = is + nlat liwk = lwork-4*mn-nlat call idvtec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(is),mdab,ndab,ad,bd, +av,bv,wvhsec,lvhsec,work(iwk),liwk,pertbd,pertbv,ierror) return end subroutine idvtec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi, +cr,ci,mmax,sqnn,mdab,ndab,ad,bd,av,bv,wvhsec,lvhsec,wk,lwk, +pertbd,pertbv,ierror) dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt) dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt) dimension av(mdab,ndab,nt),bv(mdab,ndab,nt) dimension wvhsec(lvhsec),wk(lwk) dimension pertbd(nt),pertbv(nt) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set divergence,vorticity perturbation constants c pertbd(k) = ad(1,1,k)/(2.*sqrt(2.)) pertbv(k) = av(1,1,k)/(2.*sqrt(2.)) c c preset br,bi,cr,ci to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = -ad(1,n,k)/sqnn(n) bi(1,n,k) = -bd(1,n,k)/sqnn(n) cr(1,n,k) = av(1,n,k)/sqnn(n) ci(1,n,k) = bv(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = -ad(m,n,k)/sqnn(n) bi(m,n,k) = -bd(m,n,k)/sqnn(n) cr(m,n,k) = av(m,n,k)/sqnn(n) ci(m,n,k) = bv(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis without assuming div=0 or curl=0 c if (isym.eq.0) then ityp = 0 else if (isym.eq.1) then ityp = 3 else if (isym.eq.2) then ityp = 6 end if c c sythesize br,bi,cr,ci into the vector field (v,w) c call vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wvhsec,lvhsec,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file idvtes.f c c this file includes documentation and code for c subroutine idvtes i c c ... files which must be loaded with idvtes.f c c sphcom.f, hrfft.f, vhses.f,shaes.f c c c subroutine idvtes(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv, c +mdab,ndab,wvhses,lvhses,work,lwork,pertbd,pertbv,ierror) c c given the scalar spherical harmonic coefficients ad,bd precomputed c by subroutine shaes for the scalar field divg and coefficients av,bv c precomputed by subroutine shaes for the scalar field vort, subroutine c idvtes computes a vector field (v,w) whose divergence is divg - pertbd c and whose vorticity is vort - pertbv. w the is east longitude component c and v is the colatitudinal component of the velocity. if nt=1 (see nt c below) pertrbd and pertbv are constants which must be subtracted from c divg and vort for (v,w) to exist (see the description of pertbd and c pertrbv below). usually pertbd and pertbv are zero or small relative c to divg and vort. w(i,j) and v(i,j) are the velocity components at c colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c the c c divergence(v(i,j),w(i,j)) c c = [d(sint*v)/dtheta + dw/dlambda]/sint c c = divg(i,j) - pertbd c c and c c vorticity(v(i,j),w(i,j)) c c = [-dv/dlambda + d(sint*w)/dtheta]/sint c c = vort(i,j) - pertbv c c where c c sint = cos(theta(i)). c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym isym determines whether (v,w) are computed on the full or half c sphere as follows: c c = 0 c divg,vort are neither pairwise symmetric/antisymmetric nor c antisymmetric/symmetric about the equator as described for c isym = 1 or isym = 2 below. in this case, the vector field c (v,w) is computed on the entire sphere. i.e., in the arrays c w(i,j) and v(i,j) i=1,...,nlat and j=1,...,nlon. c c = 1 c c divg is antisymmetric and vort is symmetric about the equator. c in this case w is antisymmetric and v is symmetric about the c equator. w and v are computed on the northern hemisphere only. c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c divg is symmetric and vort is antisymmetric about the equator. c in this case w is symmetric and v is antisymmetric about the c equator. w and v are computed on the northern hemisphere only. c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt in the program that calls idvtes, nt is the number of scalar c and vector fields. some computational efficiency is obtained c for multiple fields. the arrays ad,bd,av,bv,u, and v can be c three dimensional and pertbd,pertbv can be one dimensional c corresponding to indexed multiple arrays divg, vort. in this c case, multiple synthesis will be performed to compute each c vector field. the third index for ad,bd,av,bv,v,w and first c pertrbd,pertbv is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the description of c remaining parameters is simplified by assuming that nt=1 or that c ad,bd,av,bv,v,w are two dimensional and pertbd,pertbv are c constants. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls idvtes. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls idvtes. jdvw must be at least nlon. c c ad,bd two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the divergence array divg as computed by subroutine shaes. c c av,bv two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the vorticity array vort as computed by subroutine shaes. c *** ad,bd,av,bv must be computed by shaes prior to calling idvtes. c c mdab the first dimension of the arrays ad,bd,av,bv as it appears c in the program that calls idvtes (and shaes). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays ad,bd,av,bv as it appears in c the program that calls idvtes (and shaes). ndab must be at c least nlat. c c wvhses an array which must be initialized by subroutine vhsesi. c wvhses can be used repeatedly by idvtes as long as nlon c and nlat remain unchanged. wvhses must not be altered c between calls of idvtes. c c c lvhses the dimension of the array wvhses as it appears in the c program that calls idvtes. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhses must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls idvtes. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 then lwork must be at least c c nlat*((2*nt+1)*nlon+4*nt*l1+1) c c if isym = 1 or 2 then lwork must be at least c c (2*nt+1)*l2*nlon+nlat*(4*nt*l1+1) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a vector field whose divergence is divg - pertbd and c whose vorticity is vort - pertbv. w(i,j) is the east longitude c component and v(i,j) is the colatitudinal component of velocity c at the colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude c lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon. c c pertbd a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). divg - pertbd is a scalar c field which can be the divergence of a vector field (v,w). c pertbd is related to the scalar harmonic coefficients ad,bd c of divg (computed by shaes) by the formula c c pertbd = ad(1,1)/(2.*sqrt(2.)) c c an unperturbed divg can be the divergence of a vector field c only if ad(1,1) is zero. if ad(1,1) is nonzero (flagged by c pertbd nonzero) then subtracting pertbd from divg yields a c scalar field for which ad(1,1) is zero. usually pertbd is c zero or small relative to divg. c c pertbv a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). vort - pertbv is a scalar c field which can be the vorticity of a vector field (v,w). c pertbv is related to the scalar harmonic coefficients av,bv c of vort (computed by shaes) by the formula c c pertbv = av(1,1)/(2.*sqrt(2.)) c c an unperturbed vort can be the vorticity of a vector field c only if av(1,1) is zero. if av(1,1) is nonzero (flagged by c pertbv nonzero) then subtracting pertbv from vort yields a c scalar field for which av(1,1) is zero. usually pertbv is c zero or small relative to vort. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhses c = 10 error in the specification of lwork c ********************************************************************** c c subroutine idvtes(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv, +mdab,ndab,wvhses,lvhses,work,lwork,pertbd,pertbv,ierror) dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt),pertbd(nt),pertbv(nt) dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt) dimension av(mdab,ndab,nt),bv(mdab,ndab,nt) dimension wvhses(lvhses),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lvhses .lt. lzimn+lzimn+nlon+15) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+4*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr + mn is = ici + mn iwk = is + nlat liwk = lwork-4*mn-nlat call idvtes1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(is),mdab,ndab,ad,bd, +av,bv,wvhses,lvhses,work(iwk),liwk,pertbd,pertbv,ierror) return end subroutine idvtes1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi, +cr,ci,mmax,sqnn,mdab,ndab,ad,bd,av,bv,widvtes,lidvtes,wk,lwk, +pertbd,pertbv,ierror) dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt) dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt) dimension av(mdab,ndab,nt),bv(mdab,ndab,nt) dimension widvtes(lidvtes),wk(lwk) dimension pertbd(nt),pertbv(nt) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set divergence,vorticity perturbation constants c pertbd(k) = ad(1,1,k)/(2.*sqrt(2.)) pertbv(k) = av(1,1,k)/(2.*sqrt(2.)) c c preset br,bi,cr,ci to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = -ad(1,n,k)/sqnn(n) bi(1,n,k) = -bd(1,n,k)/sqnn(n) cr(1,n,k) = av(1,n,k)/sqnn(n) ci(1,n,k) = bv(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = -ad(m,n,k)/sqnn(n) bi(m,n,k) = -bd(m,n,k)/sqnn(n) cr(m,n,k) = av(m,n,k)/sqnn(n) ci(m,n,k) = bv(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis without assuming div=0 or curl=0 c if (isym.eq.0) then ityp = 0 else if (isym.eq.1) then ityp = 3 else if (isym.eq.2) then ityp = 6 end if c c sythesize br,bi,cr,ci into the vector field (v,w) c call vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,widvtes,lidvtes,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file idvtgc.f c c this file includes documentation and code for c subroutine idvtgc i c c ... files which must be loaded with idvtgc.f c c sphcom.f, hrfft.f, vhsgc.f,shagc.f, gaqd.f c c c subroutine idvtgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv, c +mdab,ndab,wvhsgc,lvhsgc,work,lwork,pertbd,pertbv,ierror) c c given the scalar spherical harmonic coefficients ad,bd precomputed c by subroutine shagc for the scalar field divg and coefficients av,bv c precomputed by subroutine shagc for the scalar field vort, subroutine c idvtgc computes a vector field (v,w) whose divergence is divg - pertbd c and whose vorticity is vort - pertbv. w the is east longitude component c and v is the colatitudinal component of the velocity. if nt=1 (see nt c below) pertrbd and pertbv are constants which must be subtracted from c divg and vort for (v,w) to exist (see the description of pertbd and c pertrbv below). usually pertbd and pertbv are zero or small relative c to divg and vort. w(i,j) and v(i,j) are the velocity components at c gaussian colatitude theta(i) (see nlat as input argument) and longitude c lambda(j) = (j-1)*2*pi/nlon c c the c c divergence(v(i,j),w(i,j)) c c = [d(sint*v)/dtheta + dw/dlambda]/sint c c = divg(i,j) - pertbd c c and c c vorticity(v(i,j),w(i,j)) c c = [-dv/dlambda + d(sint*w)/dtheta]/sint c c = vort(i,j) - pertbv c c where c c sint = cos(theta(i)). c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym isym determines whether (v,w) are computed on the full or half c sphere as follows: c c = 0 c divg,vort are neither pairwise symmetric/antisymmetric nor c antisymmetric/symmetric about the equator as described for c isym = 1 or isym = 2 below. in this case, the vector field c (v,w) is computed on the entire sphere. i.e., in the arrays c w(i,j) and v(i,j) i=1,...,nlat and j=1,...,nlon. c c = 1 c c divg is antisymmetric and vort is symmetric about the equator. c in this case w is antisymmetric and v is symmetric about the c equator. w and v are computed on the northern hemisphere only. c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c divg is symmetric and vort is antisymmetric about the equator. c in this case w is symmetric and v is antisymmetric about the c equator. w and v are computed on the northern hemisphere only. c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt in the program that calls idvtgc, nt is the number of scalar c and vector fields. some computational efficiency is obtained c for multiple fields. the arrays ad,bd,av,bv,u, and v can be c three dimensional and pertbd,pertbv can be one dimensional c corresponding to indexed multiple arrays divg, vort. in this c case, multiple synthesis will be performed to compute each c vector field. the third index for ad,bd,av,bv,v,w and first c pertrbd,pertbv is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the description of c remaining parameters is simplified by assuming that nt=1 or that c ad,bd,av,bv,v,w are two dimensional and pertbd,pertbv are c constants. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls idvtgc. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls idvtgc. jdvw must be at least nlon. c c ad,bd two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the divergence array divg as computed by subroutine shagc. c c av,bv two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the vorticity array vort as computed by subroutine shagc. c *** ad,bd,av,bv must be computed by shagc prior to calling idvtgc. c c mdab the first dimension of the arrays ad,bd,av,bv as it appears c in the program that calls idvtgc (and shagc). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays ad,bd,av,bv as it appears in c the program that calls idvtgc (and shagc). ndab must be at c least nlat. c c wvhsgc an array which must be initialized by subroutine vhsgci. c wvhsgc can be used repeatedly by idvtgc as long as nlon c and nlat remain unchanged. wvhsgc must not be altered c between calls of idvtgc. c c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls idvtgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls idvtgc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c c if isym = 0 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(4*nt*l1+1) c c if isym = 1 or 2 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)+4*nt*l1+1) c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a vector field whose divergence is divg - pertbd and c whose vorticity is vort - pertbv. w(i,j) is the east longitude c component and v(i,j) is the colatitudinal component of velocity c at the colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude c lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon. c c pertbd a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). divg - pertbd is a scalar c field which can be the divergence of a vector field (v,w). c pertbd is related to the scalar harmonic coefficients ad,bd c of divg (computed by shagc) by the formula c c pertbd = ad(1,1)/(2.*sqrt(2.)) c c an unperturbed divg can be the divergence of a vector field c only if ad(1,1) is zero. if ad(1,1) is nonzero (flagged by c pertbd nonzero) then subtracting pertbd from divg yields a c scalar field for which ad(1,1) is zero. usually pertbd is c zero or small relative to divg. c c pertbv a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). vort - pertbv is a scalar c field which can be the vorticity of a vector field (v,w). c pertbv is related to the scalar harmonic coefficients av,bv c of vort (computed by shagc) by the formula c c pertbv = av(1,1)/(2.*sqrt(2.)) c c an unperturbed vort can be the vorticity of a vector field c only if av(1,1) is zero. if av(1,1) is nonzero (flagged by c pertbv nonzero) then subtracting pertbv from vort yields a c scalar field for which av(1,1) is zero. usually pertbv is c zero or small relative to vort. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgc c = 10 error in the specification of lwork c ********************************************************************** c c subroutine idvtgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv, +mdab,ndab,wvhsgc,lvhsgc,work,lwork,pertbd,pertbv,ierror) dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt),pertbd(nt),pertbv(nt) dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt) dimension av(mdab,ndab,nt),bv(mdab,ndab,nt) dimension wvhsgc(lvhsgc),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhsgc .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+4*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr + mn is = ici + mn iwk = is + nlat liwk = lwork-4*mn-nlat call idvtgc1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(is),mdab,ndab,ad,bd, +av,bv,wvhsgc,lvhsgc,work(iwk),liwk,pertbd,pertbv,ierror) return end subroutine idvtgc1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi, +cr,ci,mmax,sqnn,mdab,ndab,ad,bd,av,bv,wvhsgc,lvhsgc,wk,lwk, +pertbd,pertbv,ierror) dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt) dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt) dimension av(mdab,ndab,nt),bv(mdab,ndab,nt) dimension wvhsgc(lvhsgc),wk(lwk) dimension pertbd(nt),pertbv(nt) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set divergence,vorticity perturbation constants c pertbd(k) = ad(1,1,k)/(2.*sqrt(2.)) pertbv(k) = av(1,1,k)/(2.*sqrt(2.)) c c preset br,bi,cr,ci to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = -ad(1,n,k)/sqnn(n) bi(1,n,k) = -bd(1,n,k)/sqnn(n) cr(1,n,k) = av(1,n,k)/sqnn(n) ci(1,n,k) = bv(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = -ad(m,n,k)/sqnn(n) bi(m,n,k) = -bd(m,n,k)/sqnn(n) cr(m,n,k) = av(m,n,k)/sqnn(n) ci(m,n,k) = bv(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis without assuming div=0 or curl=0 c if (isym.eq.0) then ityp = 0 else if (isym.eq.1) then ityp = 3 else if (isym.eq.2) then ityp = 6 end if c c sythesize br,bi,cr,ci into the vector field (v,w) c call vhsgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wvhsgc,lvhsgc,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file idvtgs.f c c this file includes documentation and code for c subroutine idvtgs i c c ... files which must be loaded with idvtgs.f c c sphcom.f, hrfft.f, vhsgs.f,shags.f, gaqd.f c c c subroutine idvtgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv, c +mdab,ndab,wvhsgs,lvhsgs,work,lwork,pertbd,pertbv,ierror) c c given the scalar spherical harmonic coefficients ad,bd precomputed c by subroutine shags for the scalar field divg and coefficients av,bv c precomputed by subroutine shags for the scalar field vort, subroutine c idvtgs computes a vector field (v,w) whose divergence is divg - pertbd c and whose vorticity is vort - pertbv. w the is east longitude component c and v is the colatitudinal component of the velocity. if nt=1 (see nt c below) pertrbd and pertbv are constants which must be subtracted from c divg and vort for (v,w) to exist (see the description of pertbd and c pertrbv below). usually pertbd and pertbv are zero or small relative c to divg and vort. w(i,j) and v(i,j) are the velocity components at c gaussian colatitude theta(i) (see nlat as input argument) and longitude c lambda(j) = (j-1)*2*pi/nlon c c the c c divergence(v(i,j),w(i,j)) c c = [d(sint*v)/dtheta + dw/dlambda]/sint c c = divg(i,j) - pertbd c c and c c vorticity(v(i,j),w(i,j)) c c = [-dv/dlambda + d(sint*w)/dtheta]/sint c c = vort(i,j) - pertbv c c where c c sint = cos(theta(i)). c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym isym determines whether (v,w) are computed on the full or half c sphere as follows: c c = 0 c divg,vort are neither pairwise symmetric/antisymmetric nor c antisymmetric/symmetric about the equator as described for c isym = 1 or isym = 2 below. in this case, the vector field c (v,w) is computed on the entire sphere. i.e., in the arrays c w(i,j) and v(i,j) i=1,...,nlat and j=1,...,nlon. c c = 1 c c divg is antisymmetric and vort is symmetric about the equator. c in this case w is antisymmetric and v is symmetric about the c equator. w and v are computed on the northern hemisphere only. c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c divg is symmetric and vort is antisymmetric about the equator. c in this case w is symmetric and v is antisymmetric about the c equator. w and v are computed on the northern hemisphere only. c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt in the program that calls idvtgs, nt is the number of scalar c and vector fields. some computational efficiency is obtained c for multiple fields. the arrays ad,bd,av,bv,u, and v can be c three dimensional and pertbd,pertbv can be one dimensional c corresponding to indexed multiple arrays divg, vort. in this c case, multiple synthesis will be performed to compute each c vector field. the third index for ad,bd,av,bv,v,w and first c pertrbd,pertbv is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the description of c remaining parameters is simplified by assuming that nt=1 or that c ad,bd,av,bv,v,w are two dimensional and pertbd,pertbv are c constants. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls idvtgs. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls idvtgs. jdvw must be at least nlon. c c ad,bd two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the divergence array divg as computed by subroutine shags. c c av,bv two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the vorticity array vort as computed by subroutine shags. c *** ad,bd,av,bv must be computed by shags prior to calling idvtgs. c c mdab the first dimension of the arrays ad,bd,av,bv as it appears c in the program that calls idvtgs (and shags). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays ad,bd,av,bv as it appears in c the program that calls idvtgs (and shags). ndab must be at c least nlat. c c wvhsgs an array which must be initialized by subroutine vhsgsi. c wvhsgs can be used repeatedly by idvtgs as long as nlon c and nlat remain unchanged. wvhsgs must not be altered c between calls of idvtgs. c c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls idvtgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgs must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls idvtgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min(nlat,nlon/2+1) if nlon is even or c l1 = min(nlat,(nlon+1)/2) if nlon is odd c c c if isym = 0 then lwork must be at least c c nlat*((2*nt+1)*nlon+4*nt*l1+1) c c if isym = 1 or 2 then lwork must be at least c c (2*nt+1)*l2*nlon+nlat*(4*nt*l1+1) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a vector field whose divergence is divg - pertbd and c whose vorticity is vort - pertbv. w(i,j) is the east longitude c component and v(i,j) is the colatitudinal component of velocity c at the colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude c lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon. c c pertbd a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). divg - pertbd is a scalar c field which can be the divergence of a vector field (v,w). c pertbd is related to the scalar harmonic coefficients ad,bd c of divg (computed by shags) by the formula c c pertbd = ad(1,1)/(2.*sqrt(2.)) c c an unperturbed divg can be the divergence of a vector field c only if ad(1,1) is zero. if ad(1,1) is nonzero (flagged by c pertbd nonzero) then subtracting pertbd from divg yields a c scalar field for which ad(1,1) is zero. usually pertbd is c zero or small relative to divg. c c pertbv a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). vort - pertbv is a scalar c field which can be the vorticity of a vector field (v,w). c pertbv is related to the scalar harmonic coefficients av,bv c of vort (computed by shags) by the formula c c pertbv = av(1,1)/(2.*sqrt(2.)) c c an unperturbed vort can be the vorticity of a vector field c only if av(1,1) is zero. if av(1,1) is nonzero (flagged by c pertbv nonzero) then subtracting pertbv from vort yields a c scalar field for which av(1,1) is zero. usually pertbv is c zero or small relative to vort. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgs c = 10 error in the specification of lwork c ********************************************************************** c c subroutine idvtgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv, +mdab,ndab,wvhsgs,lvhsgs,work,lwork,pertbd,pertbv,ierror) dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt),pertbd(nt),pertbv(nt) dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt) dimension av(mdab,ndab,nt),bv(mdab,ndab,nt) dimension wvhsgs(lvhsgs),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lvhsgs .lt. lzimn+lzimn+nlon+15) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +(2*nt+1)*imid*nlon+4*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +(2*nt+1)*nlat*nlon+4*mn+nlat) return ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr + mn is = ici + mn iwk = is + nlat liwk = lwork-4*mn-nlat call idvtgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(is),mdab,ndab,ad,bd, +av,bv,wvhsgs,lvhsgs,work(iwk),liwk,pertbd,pertbv,ierror) return end subroutine idvtgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,br,bi, +cr,ci,mmax,sqnn,mdab,ndab,ad,bd,av,bv,wvhsgs,lvhsgs,wk,lwk, +pertbd,pertbv,ierror) dimension w(idvw,jdvw,nt),v(idvw,jdvw,nt) dimension br(mmax,nlat,nt),bi(mmax,nlat,nt),sqnn(nlat) dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt) dimension ad(mdab,ndab,nt),bd(mdab,ndab,nt) dimension av(mdab,ndab,nt),bv(mdab,ndab,nt) dimension wvhsgs(lvhsgs),wk(lwk) dimension pertbd(nt),pertbv(nt) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set divergence,vorticity perturbation constants c pertbd(k) = ad(1,1,k)/(2.*sqrt(2.)) pertbv(k) = av(1,1,k)/(2.*sqrt(2.)) c c preset br,bi,cr,ci to 0.0 c do 3 n=1,nlat do 4 m=1,mmax br(m,n,k) = 0.0 bi(m,n,k) = 0.0 cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat br(1,n,k) = -ad(1,n,k)/sqnn(n) bi(1,n,k) = -bd(1,n,k)/sqnn(n) cr(1,n,k) = av(1,n,k)/sqnn(n) ci(1,n,k) = bv(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat br(m,n,k) = -ad(m,n,k)/sqnn(n) bi(m,n,k) = -bd(m,n,k)/sqnn(n) cr(m,n,k) = av(m,n,k)/sqnn(n) ci(m,n,k) = bv(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis without assuming div=0 or curl=0 c if (isym.eq.0) then ityp = 0 else if (isym.eq.1) then ityp = 3 else if (isym.eq.2) then ityp = 6 end if c c sythesize br,bi,cr,ci into the vector field (v,w) c call vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wvhsgs,lvhsgs,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file igradec.f c c this file includes documentation and code for c subroutine igradec i c c ... files which must be loaded with igradec.f c c sphcom.f, hrfft.f, shsec.f,vhaec.f c c subroutine igradec(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb, c + wshsec,lshsec,work,lwork,ierror) c c let br,bi,cr,ci be the vector spherical harmonic coefficients c precomputed by vhaec for a vector field (v,w). let (v',w') be c the irrotational component of (v,w) (i.e., (v',w') is generated c by assuming cr,ci are zero and synthesizing br,bi with vhsec). c then subroutine igradec computes a scalar field sf such that c c gradient(sf) = (v',w'). c c i.e., c c v'(i,j) = d(sf(i,j))/dtheta (colatitudinal component of c the gradient) c and c c w'(i,j) = 1/sint*d(sf(i,j))/dlambda (east longitudinal component c of the gradient) c c at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c where sint = sin(theta(i)). required associated legendre polynomials c are recomputed rather than stored as they are in subroutine igrades. this c saves storage (compare lshsec and lshses in igrades) but increases c computational requirements. c c note: for an irrotational vector field (v,w), subroutine igradec c computes a scalar field whose gradient is (v,w). in ay case, c subroutine igradec "inverts" the gradient subroutine gradec. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the scalar field sf is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case sf c is neither symmetric nor antisymmetric about the equator. c sf is computed on the entire sphere. i.e., in the array c sf(i,j) for i=1,...,nlat and j=1,...,nlon c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case sf is antisymmetyric about the equator and c is computed for the northern hemisphere only. i.e., c if nlat is odd sf is computed in the array sf(i,j) for c i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is even c sf is computed in the array sf(i,j) for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c w is symmetric and v is antisymmetric about the equator. c in this case sf is symmetyric about the equator and c is computed for the northern hemisphere only. i.e., c if nlat is odd sf is computed in the array sf(i,j) for c i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is even c sf is computed in the array sf(i,j) for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays br,bi, and sf can be three dimensional corresponding c to an indexed multiple vector field (v,w). in this case, c multiple scalar synthesis will be performed to compute each c scalar field. the third index for br,bi, and sf is the synthesis c index which assumes the values k = 1,...,nt. for a single c synthesis set nt = 1. the description of the remaining c parameters is simplified by assuming that nt=1 or that br,bi, c and sf are two dimensional arrays. c c isf the first dimension of the array sf as it appears in c the program that calls igradec. if isym = 0 then isf c must be at least nlat. if isym = 1 or 2 and nlat is c even then isf must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then isf must be at least (nlat+1)/2. c c jsf the second dimension of the array sf as it appears in c the program that calls igradec. jsf must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaec. c *** br,bi must be computed by vhaec prior to calling igradec. c c mdb the first dimension of the arrays br and bi as it appears in c the program that calls igradec (and vhaec). mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br and bi as it appears in c the program that calls igradec (and vhaec). ndb must be at c least nlat. c c c wshsec an array which must be initialized by subroutine shseci. c once initialized, c wshsec can be used repeatedly by igradec as long as nlon c and nlat remain unchanged. wshsec must not be altered c between calls of igradec. c c c lshsec the dimension of the array wshsec as it appears in the c program that calls igradec. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c c then lshsec must be greater than or equal to c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls igradec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym is zero then lwork must be at least c c nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) c c if isym is not zero then lwork must be at least c c l2*(nt*nlon+max0(3*nlat,nlon))+nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c sf a two or three dimensional array (see input parameter nt) that c contain a scalar field whose gradient is the irrotational c component of the vector field (v,w). the vector spherical c harmonic coefficients br,bi were precomputed by subroutine c vhaec. sf(i,j) is given at the gaussian colatitude theta(i) c and longitude lambda(j) = (j-1)*2*pi/nlon. the index ranges c are defined at input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of isf c = 6 error in the specification of jsf c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsec c = 10 error in the specification of lwork c c ********************************************************************** c subroutine igradec(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb, +wshsec,lshsec,work,lwork,ierror) dimension sf(isf,jsf,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension wshsec(lshsec),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. isf.lt.nlat) .or. + (isym.ne.0 .and. isf.lt.imid)) return ierror = 6 if(jsf .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+2)/2) if(mdb .lt. min0(nlat,(nlon+1)/2)) return ierror = 8 if(ndb .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 c c verify saved work space length c l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 lwkmin=2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 if (lshsec .lt. lwkmin) return ierror = 10 c c set minimum and verify unsaved work space c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shsec) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt c lwkmin = nln+ls*nlon+2*mn+nlat if (isym .eq. 0) then lwkmin = nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(nt*nlon+max0(3*nlat,nlon))+nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia + mn is = ib + mn iwk = is + nlat liwk = lwork-2*mn-nlat call igrdec1(nlat,nlon,isym,nt,sf,isf,jsf,work(ia),work(ib),mab, +work(is),mdb,ndb,br,bi,wshsec,lshsec,work(iwk),liwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file igrades.f c c this file includes documentation and code for c subroutine igrades i c c ... files which must be loaded with igradec.f c c sphcom.f, hrfft.f, shses.f,vhaes.f c c subroutine igrades(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb, c + wshses,lshses,work,lwork,ierror) c c let br,bi,cr,ci be the vector spherical harmonic coefficients c precomputed by vhaes for a vector field (v,w). let (v',w') be c the irrotational component of (v,w) (i.e., (v',w') is generated c by assuming cr,ci are zero and synthesizing br,bi with vhses). c then subroutine igrades computes a scalar field sf such that c c gradient(sf) = (v',w'). c c i.e., c c v'(i,j) = d(sf(i,j))/dtheta (colatitudinal component of c the gradient) c and c c w'(i,j) = 1/sint*d(sf(i,j))/dlambda (east longitudinal component c of the gradient) c c at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c where sint = sin(theta(i)). required associated legendre polynomials c are stored rather than recomputed as they are in subroutine igradec. c c note: for an irrotational vector field (v,w), subroutine igrades c computes a scalar field whose gradient is (v,w). in ay case, c subroutine igrades "inverts" the gradient subroutine grades. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the scalar field sf is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case sf c is neither symmetric nor antisymmetric about the equator. c sf is computed on the entire sphere. i.e., in the array c sf(i,j) for i=1,...,nlat and j=1,...,nlon c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case sf is antisymmetyric about the equator and c is computed for the northern hemisphere only. i.e., c if nlat is odd sf is computed in the array sf(i,j) for c i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is even c sf is computed in the array sf(i,j) for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c w is symmetric and v is antisymmetric about the equator. c in this case sf is symmetyric about the equator and c is computed for the northern hemisphere only. i.e., c if nlat is odd sf is computed in the array sf(i,j) for c i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is even c sf is computed in the array sf(i,j) for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays br,bi, and sf can be three dimensional corresponding c to an indexed multiple vector field (v,w). in this case, c multiple scalar synthesis will be performed to compute each c scalar field. the third index for br,bi, and sf is the synthesis c index which assumes the values k = 1,...,nt. for a single c synthesis set nt = 1. the description of the remaining c parameters is simplified by assuming that nt=1 or that br,bi, c and sf are two dimensional arrays. c c isf the first dimension of the array sf as it appears in c the program that calls igrades. if isym = 0 then isf c must be at least nlat. if isym = 1 or 2 and nlat is c even then isf must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then isf must be at least (nlat+1)/2. c c jsf the second dimension of the array sf as it appears in c the program that calls igrades. jsf must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaes. c *** br,bi must be computed by vhaes prior to calling igrades. c c mdb the first dimension of the arrays br and bi as it appears in c the program that calls igrades (and vhaes). mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br and bi as it appears in c the program that calls igrades (and vhaes). ndb must be at c least nlat. c c c wshses an array which must be initialized by subroutine igradesi c (or equivalently by subroutine shsesi). once initialized, c wshses can be used repeatedly by igrades as long as nlon c and nlat remain unchanged. wshses must not be altered c between calls of igrades. c c c lshses the dimension of the array wshses as it appears in the c program that calls igrades. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c c then lshses must be greater than or equal to c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls igrades. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 lwork must be greater than or equal to c c nlat*((nt+1)*nlon+2*nt*l1+1) c c if isym > 0 lwork must be greater than or equal to c c (nt+1)*l2*nlon+nlat*(2*nt*l1+1) c c c c ************************************************************** c c output parameters c c c sf a two or three dimensional array (see input parameter nt) that c contain a scalar field whose gradient is the irrotational c component of the vector field (v,w). the vector spherical c harmonic coefficients br,bi were precomputed by subroutine c vhaes. sf(i,j) is given at the gaussian colatitude theta(i) c and longitude lambda(j) = (j-1)*2*pi/nlon. the index ranges c are defined at input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of isf c = 6 error in the specification of jsf c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshses c = 10 error in the specification of lwork c c ********************************************************************** c subroutine igrades(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb, +wshses,lshses,work,lwork,ierror) dimension sf(isf,jsf,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension wshses(lshses),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. isf.lt.nlat) .or. + (isym.ne.0 .and. isf.lt.imid)) return ierror = 6 if(jsf .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+2)/2) if(mdb .lt. min0(nlat,(nlon+1)/2)) return ierror = 8 if(ndb .lt. nlat) return ierror = 9 c c verify saved work space length c imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshses .lt. lpimn+nlon+15) return ierror = 10 c c set minimum and verify unsaved work space c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shses) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt lwkmin = nln+ls*nlon+2*mn+nlat if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia + mn is = ib + mn iwk = is + nlat liwk = lwork-2*mn-nlat call igrdes1(nlat,nlon,isym,nt,sf,isf,jsf,work(ia),work(ib),mab, +work(is),mdb,ndb,br,bi,wshses,lshses,work(iwk),liwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file igradgc.f c c this file includes documentation and code for c subroutine igradgc i c c ... files which must be loaded with igradgc.f c c sphcom.f, hrfft.f, shsgc.f,vhagc.f c c subroutine igradgc(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb, c + wshsgc,lshsgc,work,lwork,ierror) c c let br,bi,cr,ci be the vector spherical harmonic coefficients c precomputed by vhagc for a vector field (v,w). let (v',w') be c the irrotational component of (v,w) (i.e., (v',w') is generated c by assuming cr,ci are zero and synthesizing br,bi with vhsgs). c then subroutine igradgc computes a scalar field sf such that c c gradient(sf) = (v',w'). c c i.e., c c v'(i,j) = d(sf(i,j))/dtheta (colatitudinal component of c the gradient) c and c c w'(i,j) = 1/sint*d(sf(i,j))/dlambda (east longitudinal component c of the gradient) c c at the gaussian colatitude theta(i) (see nlat as input parameter) c and longitude lambda(j) = (j-1)*2*pi/nlon where sint = sin(theta(i)). c c note: for an irrotational vector field (v,w), subroutine igradgc c computes a scalar field whose gradient is (v,w). in ay case, c subroutine igradgc "inverts" the gradient subroutine gradgc. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the scalar field sf is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case sf c is neither symmetric nor antisymmetric about the equator. c sf is computed on the entire sphere. i.e., in the array c sf(i,j) for i=1,...,nlat and j=1,...,nlon c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case sf is antisymmetyric about the equator and c is computed for the northern hemisphere only. i.e., c if nlat is odd sf is computed in the array sf(i,j) for c i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is even c sf is computed in the array sf(i,j) for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c w is symmetric and v is antisymmetric about the equator. c in this case sf is symmetyric about the equator and c is computed for the northern hemisphere only. i.e., c if nlat is odd sf is computed in the array sf(i,j) for c i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is even c sf is computed in the array sf(i,j) for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays br,bi, and sf can be three dimensional corresponding c to an indexed multiple vector field (v,w). in this case, c multiple scalar synthesis will be performed to compute each c scalar field. the third index for br,bi, and sf is the synthesis c index which assumes the values k = 1,...,nt. for a single c synthesis set nt = 1. the description of the remaining c parameters is simplified by assuming that nt=1 or that br,bi, c and sf are two dimensional arrays. c c isf the first dimension of the array sf as it appears in c the program that calls igradgc. if isym = 0 then isf c must be at least nlat. if isym = 1 or 2 and nlat is c even then isf must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then isf must be at least (nlat+1)/2. c c jsf the second dimension of the array sf as it appears in c the program that calls igradgc. jsf must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhagc. c *** br,bi must be computed by vhagc prior to calling igradgc. c c mdb the first dimension of the arrays br and bi as it appears in c the program that calls igradgc (and vhagc). mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br and bi as it appears in c the program that calls igradgc (and vhagc). ndb must be at c least nlat. c c c wshsgc an array which must be initialized by subroutine shsgci. c once initialized, c wshsgc can be used repeatedly by igradgc as long as nlon c and nlat remain unchanged. wshsgc must not be altered c between calls of igradgc. c c c lshsgc the dimension of the array wshsgc as it appears in the c program that calls igradgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c c then lshsgc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls igradgc define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c if isym is zero then lwork must be at least c c nlat*(nlon*nt+max0(3*l2,nlon)+2*nt*l1+1) c c if isym is not zero then lwork must be at least c c l2*(nlon*nt+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) c c c c ************************************************************** c c output parameters c c c sf a two or three dimensional array (see input parameter nt) that c contain a scalar field whose gradient is the irrotational c component of the vector field (v,w). the vector spherical c harmonic coefficients br,bi were precomputed by subroutine c vhagc. sf(i,j) is given at the gaussian colatitude theta(i) c and longitude lambda(j) = (j-1)*2*pi/nlon. the index ranges c are defined at input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of isf c = 6 error in the specification of jsf c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsgc c = 10 error in the specification of lwork c c ********************************************************************** c subroutine igradgc(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb, +wshsgc,lshsgc,work,lwork,ierror) dimension sf(isf,jsf,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension wshsgc(lshsgc),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. isf.lt.nlat) .or. + (isym.ne.0 .and. isf.lt.imid)) return ierror = 6 if(jsf .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+2)/2) if(mdb .lt. min0(nlat,(nlon+1)/2)) return ierror = 8 if(ndb .lt. nlat) return ierror = 9 c c verify saved work space length c l2 = (nlat+mod(nlat,2))/2 l1 = min0((nlon+2)/2,nlat) if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 10 c c set minimum and verify unsaved work space c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shsgc) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt c lwkmin = nln+ls*nlon+2*mn+nlat if (isym .eq. 0) then lwkmin = nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(nt*nlon+max0(3*nlat,nlon))+nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia + mn is = ib + mn iwk = is + nlat liwk = lwork-2*mn-nlat call igrdgc1(nlat,nlon,isym,nt,sf,isf,jsf,work(ia),work(ib),mab, +work(is),mdb,ndb,br,bi,wshsgc,lshsgc,work(iwk),liwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file igradgs.f c c this file includes documentation and code for c subroutine igradgs i c c ... files which must be loaded with igradgs.f c c sphcom.f, hrfft.f, shsgs.f,vhags.f c c subroutine igradgs(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb, c + wshsgs,lshsgs,work,lwork,ierror) c c let br,bi,cr,ci be the vector spherical harmonic coefficients c precomputed by vhags for a vector field (v,w). let (v',w') be c the irrotational component of (v,w) (i.e., (v',w') is generated c by assuming cr,ci are zero and synthesizing br,bi with vhsgs). c then subroutine igradgs computes a scalar field sf such that c c gradient(sf) = (v',w'). c c i.e., c c v'(i,j) = d(sf(i,j))/dtheta (colatitudinal component of c the gradient) c and c c w'(i,j) = 1/sint*d(sf(i,j))/dlambda (east longitudinal component c of the gradient) c c at the gaussian colatitude theta(i) (see nlat as input parameter) c and longitude lambda(j) = (j-1)*2*pi/nlon where sint = sin(theta(i)). c c note: for an irrotational vector field (v,w), subroutine igradgs c computes a scalar field whose gradient is (v,w). in ay case, c subroutine igradgs "inverts" the gradient subroutine gradgs. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the scalar field sf is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case sf c is neither symmetric nor antisymmetric about the equator. c sf is computed on the entire sphere. i.e., in the array c sf(i,j) for i=1,...,nlat and j=1,...,nlon c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case sf is antisymmetyric about the equator and c is computed for the northern hemisphere only. i.e., c if nlat is odd sf is computed in the array sf(i,j) for c i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is even c sf is computed in the array sf(i,j) for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c w is symmetric and v is antisymmetric about the equator. c in this case sf is symmetyric about the equator and c is computed for the northern hemisphere only. i.e., c if nlat is odd sf is computed in the array sf(i,j) for c i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is even c sf is computed in the array sf(i,j) for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c the arrays br,bi, and sf can be three dimensional corresponding c to an indexed multiple vector field (v,w). in this case, c multiple scalar synthesis will be performed to compute each c scalar field. the third index for br,bi, and sf is the synthesis c index which assumes the values k = 1,...,nt. for a single c synthesis set nt = 1. the description of the remaining c parameters is simplified by assuming that nt=1 or that br,bi, c and sf are two dimensional arrays. c c isf the first dimension of the array sf as it appears in c the program that calls igradgs. if isym = 0 then isf c must be at least nlat. if isym = 1 or 2 and nlat is c even then isf must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then isf must be at least (nlat+1)/2. c c jsf the second dimension of the array sf as it appears in c the program that calls igradgs. jsf must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhags. c *** br,bi must be computed by vhags prior to calling igradgs. c c mdb the first dimension of the arrays br and bi as it appears in c the program that calls igradgs (and vhags). mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br and bi as it appears in c the program that calls igradgs (and vhags). ndb must be at c least nlat. c c c wshsgs an array which must be initialized by subroutine igradgsi c (or equivalently by subroutine shsesi). once initialized, c wshsgs can be used repeatedly by igradgs as long as nlon c and nlat remain unchanged. wshsgs must not be altered c between calls of igradgs. c c c lshsgs the dimension of the array wshsgs as it appears in the c program that calls igradgs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c c then lshsgs must be greater than or equal to c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls igradgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 lwork must be greater than or equal to c c nlat*((nt+1)*nlon+2*nt*l1+1) c c if isym > 0 lwork must be greater than or equal to c c (nt+1)*l2*nlon+nlat*(2*nt*l1+1) c c c c ************************************************************** c c output parameters c c c sf a two or three dimensional array (see input parameter nt) that c contain a scalar field whose gradient is the irrotational c component of the vector field (v,w). the vector spherical c harmonic coefficients br,bi were precomputed by subroutine c vhags. sf(i,j) is given at the gaussian colatitude theta(i) c and longitude lambda(j) = (j-1)*2*pi/nlon. the index ranges c are defined at input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of isf c = 6 error in the specification of jsf c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsgs c = 10 error in the specification of lwork c c ********************************************************************** c subroutine igradgs(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb, +wshsgs,lshsgs,work,lwork,ierror) dimension sf(isf,jsf,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension wshsgs(lshsgs),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. isf.lt.nlat) .or. + (isym.ne.0 .and. isf.lt.imid)) return ierror = 6 if(jsf .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+2)/2) if(mdb .lt. min0(nlat,(nlon+1)/2)) return ierror = 8 if(ndb .lt. nlat) return ierror = 9 c c verify saved work space length c l2 = (nlat+mod(nlat,2))/2 l1 = min0((nlon+2)/2,nlat) lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshsgs.lt.lp) return ierror = 10 c c set minimum and verify unsaved work space c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shses) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt lwkmin = nln+ls*nlon+2*mn+nlat if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia + mn is = ib + mn iwk = is + nlat liwk = lwork-2*mn-nlat call igrdgs1(nlat,nlon,isym,nt,sf,isf,jsf,work(ia),work(ib),mab, +work(is),mdb,ndb,br,bi,wshsgs,lshsgs,work(iwk),liwk,ierror) return end subroutine igrdec1(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab, +sqnn,mdb,ndb,br,bi,wshsec,lshsec,wk,lwk,ierror) dimension sf(isf,jsf,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt),sqnn(nlat) dimension a(mab,nlat,nt),b(mab,nlat,nt) dimension wshsec(lshsec),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = 1.0/sqrt(fn*(fn+1.)) 1 continue c c set upper limit for vector m subscript c mmax = min0(nlat,(nlon+1)/2) c c compute multiple scalar field coefficients c do 2 k=1,nt c c preset to 0.0 c do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = br(1,n,k)*sqnn(n) b(1,n,k)= bi(1,n,k)*sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = sqnn(n)*br(m,n,k) b(m,n,k) = sqnn(n)*bi(m,n,k) 7 continue 6 continue 2 continue c c scalar sythesize a,b into sf c call shsec(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab,nlat, +wshsec,lshsec,wk,lwk,ierror) return end subroutine igrdes1(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab, +sqnn,mdb,ndb,br,bi,wshses,lshses,wk,lwk,ierror) dimension sf(isf,jsf,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt),sqnn(nlat) dimension a(mab,nlat,nt),b(mab,nlat,nt) dimension wshses(lshses),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = 1.0/sqrt(fn*(fn+1.)) 1 continue c c set upper limit for vector m subscript c mmax = min0(nlat,(nlon+1)/2) c c compute multiple scalar field coefficients c do 2 k=1,nt c c preset to 0.0 c do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = br(1,n,k)*sqnn(n) b(1,n,k)= bi(1,n,k)*sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = sqnn(n)*br(m,n,k) b(m,n,k) = sqnn(n)*bi(m,n,k) 7 continue 6 continue 2 continue c c scalar sythesize a,b into sf c call shses(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab,nlat, +wshses,lshses,wk,lwk,ierror) return end subroutine igrdgc1(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab, +sqnn,mdb,ndb,br,bi,wsav,lsav,wk,lwk,ierror) dimension sf(isf,jsf,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt),sqnn(nlat) dimension a(mab,nlat,nt),b(mab,nlat,nt) dimension wsav(lsav),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = 1.0/sqrt(fn*(fn+1.)) 1 continue c c set upper limit for vector m subscript c mmax = min0(nlat,(nlon+1)/2) c c compute multiple scalar field coefficients c do 2 k=1,nt c c preset to 0.0 c do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = br(1,n,k)*sqnn(n) b(1,n,k)= bi(1,n,k)*sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = sqnn(n)*br(m,n,k) b(m,n,k) = sqnn(n)*bi(m,n,k) 7 continue 6 continue 2 continue c c scalar sythesize a,b into sf c call shsgc(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab,nlat,wsav, + lsav,wk,lwk,ierror) return end subroutine igrdgs1(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab, +sqnn,mdb,ndb,br,bi,wsav,lsav,wk,lwk,ierror) dimension sf(isf,jsf,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt),sqnn(nlat) dimension a(mab,nlat,nt),b(mab,nlat,nt) dimension wsav(lsav),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = 1.0/sqrt(fn*(fn+1.)) 1 continue c c set upper limit for vector m subscript c mmax = min0(nlat,(nlon+1)/2) c c compute multiple scalar field coefficients c do 2 k=1,nt c c preset to 0.0 c do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = br(1,n,k)*sqnn(n) b(1,n,k)= bi(1,n,k)*sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = sqnn(n)*br(m,n,k) b(m,n,k) = sqnn(n)*bi(m,n,k) 7 continue 6 continue 2 continue c c scalar sythesize a,b into sf c call shsgs(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab,nlat,wsav, + lsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c subroutine ihgeod(m,idp,jdp,x,y,z) dimension x(idp,jdp,5),y(idp,jdp,5),z(idp,jdp,5) c c m is the number of points on the edge of a c single geodesic triangle c c x,y,z the coordinates of the geodesic points on c the sphere are x(i,j,k), y(i,j,k), z(i,j,k) c where i=1,...,m+m-1; j=1,...,m; and k=1,...,5. c the indices are defined on the unfolded c icosahedron as follows for the case m=3 c c north pole c c (5,1) 0 l c i (4,1) (5,2) a (repeated for c (3,1) (4,2) (5,3) theta1 t k=2,3,4,5 in c (2,1) (3,2) (4,3) i --> c (1,1) (2,2) (3,3) theta2 t the longitudinal c (1,2) (2,3) u direction) c (1,3) pi d c j e c south pole c c total number of points is 10*(m-1)**2+2 c total number of triangles is 20*(m-1)**2 c total number of edges is 30*(m-1)**2 c pi = 4.*atan(1.) dphi = .4*pi beta = cos(dphi) theta1 = acos(beta/(1.-beta)) theta2 = pi-theta1 hdphi = dphi/2. tdphi = 3.*hdphi do k=1,5 phi = (k-1)*dphi call stoc(1.,theta2,phi,x1,y1,z1) call stoc(1.,pi,phi+hdphi,x2,y2,z2) call stoc(1.,theta2,phi+dphi,x3,y3,z3) dxi = (x2-x1)/(m-1) dyi = (y2-y1)/(m-1) dzi = (z2-z1)/(m-1) dxj = (x3-x2)/(m-1) dyj = (y3-y2)/(m-1) dzj = (z3-z2)/(m-1) do i=1,m xs = x1 + (i-1)*dxi ys = y1 + (i-1)*dyi zs = z1 + (i-1)*dzi do j=1,i x(j,i,k) = xs + (j-1)*dxj y(j,i,k) = ys + (j-1)*dyj z(j,i,k) = zs + (j-1)*dzj end do end do call stoc(1.,theta1,phi+hdphi,x4,y4,z4) dxi = (x3-x4)/(m-1) dyi = (y3-y4)/(m-1) dzi = (z3-z4)/(m-1) dxj = (x4-x1)/(m-1) dyj = (y4-y1)/(m-1) dzj = (z4-z1)/(m-1) do j=1,m xs = x1 + (j-1)*dxj ys = y1 + (j-1)*dyj zs = z1 + (j-1)*dzj do i=1,j x(j,i,k) = xs + (i-1)*dxi y(j,i,k) = ys + (i-1)*dyi z(j,i,k) = zs + (i-1)*dzi end do end do call stoc(1.,theta1,phi+tdphi,x5,y5,z5) dxj = (x5-x3)/(m-1) dyj = (y5-y3)/(m-1) dzj = (z5-z3)/(m-1) do i=1,m xs = x4 + (i-1)*dxi ys = y4 + (i-1)*dyi zs = z4 + (i-1)*dzi do j=1,i x(j+m-1,i,k) = xs + (j-1)*dxj y(j+m-1,i,k) = ys + (j-1)*dyj z(j+m-1,i,k) = zs + (j-1)*dzj end do end do call stoc(1.,0.,phi+dphi,x6,y6,z6) dxi = (x5-x6)/(m-1) dyi = (y5-y6)/(m-1) dzi = (z5-z6)/(m-1) dxj = (x6-x4)/(m-1) dyj = (y6-y4)/(m-1) dzj = (z6-z4)/(m-1) do j=1,m xs = x4 + (j-1)*dxj ys = y4 + (j-1)*dyj zs = z4 + (j-1)*dzj do i=1,j x(j+m-1,i,k) = xs + (i-1)*dxi y(j+m-1,i,k) = ys + (i-1)*dyi z(j+m-1,i,k) = zs + (i-1)*dzi end do end do end do do k=1,5 do j=1,m+m-1 do i=1,m call ctos(x(j,i,k),y(j,i,k),z(j,i,k),rad,theta,phi) call stoc(1.,theta,phi,x(j,i,k),y(j,i,k),z(j,i,k)) end do end do end do return end function indx(m,n,nlat) integer indx indx = m*nlat-(m*(m+1))/2+n+1 return end subroutine interp(h,len,m,n,w1,w2,iflag) c **** interpolates to mid points of grid cells using second c **** order formula dimension h(len,1),w1(n,m),w2(n+2,m+2),iflag(n,m),sten(4,4) data sten/.015625,2*-.078125,.015625,-.078125,2*.390625, 12*-.078125,2*.390625,-.078125,.015625,2*-.078125,.015625/ c **** copy h to w2 mm1 = m-1 do 1 i=1,mm1 do 1 j=1,n w2(j,i+1)=h(j,i) 1 continue c **** add periodic points do 2 j=1,n w2(j,1)=w2(j,m) w2(j,m+1)=w2(j,2) w2(j,m+2)=w2(j,3) 2 continue n1=2 n2=n-2 c **** perform interpolation c **** set w1 to zero do 7 i=1,m do 7 j=1,n w1(j,i)=0. 7 continue c **** interpolate do 8 k=1,4 do 8 l=1,4 do 8 i=1,m-1 do 8 j=n1,n2 w1(j,i)=w1(j,i)+w2(j+l-2,i+k-1)*sten(k,l) 8 continue c **** set up iflag array c **** iflag(j,i)=0 if diagonal is (j,i) to (j+1,i+1) c **** iflag(j,i)=16 if diagonal is (j+1,i), (j,i+1) do 9 i=1,m-1 do 9 j=n1,n2 iflag(j,i)=icvmg(16,0,abs(.5*(w2(j,i+1)+w2(j+1,i+2))-w1(j,i))- 1abs(.5*(w2(j,i+2)+w2(j+1,i+1))-w1(j,i))) 9 continue return end subroutine intrpg(h,m,n,w1,w2,iflag) c **** interpolates to mid points of grid cells using second c **** order formula dimension h(n,m),w1(n,m),w2(n,m+2),iflag(n,m),sten(4,4) data sten/.015625,2*-.078125,.015625,-.078125,2*.390625, 12*-.078125,2*.390625,-.078125,.015625,2*-.078125,.015625/ c **** copy h to w2 mm1 = m-1 do 1 i=1,mm1 do 1 j=1,n w2(j,i+1)=h(j,i) 1 continue c **** add periodic points do 2 j=1,n w2(j,1)=w2(j,m) w2(j,m+1)=w2(j,2) w2(j,m+2)=w2(j,3) 2 continue c **** perform interpolation c **** set w1 to zero do 7 i=1,m do 7 j=1,n w1(j,i)=0. 7 continue c **** interpolate do 8 k=1,4 do 8 l=1,4 do 8 i=1,m-1 do 8 j=2,n-2 w1(j,i)=w1(j,i)+w2(j+l-2,i+k-1)*sten(k,l) 8 continue c **** set up iflag array c **** iflag(j,i)=0 if diagonal is (j,i) to (j+1,i+1) c **** iflag(j,i)=16 if diagonal is (j+1,i), (j,i+1) do 9 i=1,m-1 do 9 j=2,n-2 iflag(j,i)=icvmg(16,0,abs(.5*(w2(j,i+1)+w2(j+1,i+2))-w1(j,i))- 1abs(.5*(w2(j,i+2)+w2(j+1,i+1))-w1(j,i))) 9 continue return end subroutine iout ( variable, name ) c*********************************************************************72 c cc IOUT prints an integer variable. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 30 November 2009 c c Author: c c John Burkardt c c Parameters: c c Input, integer VARIABLE, the value to be printed. c c Input, hollerith NAME, the name. c implicit none integer name integer variable write ( *, '(a4,'' = '', i8 )' ) name, variable return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c c ... file isfvpec.f c c this file includes documentation and code for c subroutine isfvpec i c c ... files which must be loaded with isfvpec.f c c sphcom.f, hrfft.f, vhsec.f,shaec.f c c c subroutine isfvpec(nlat,nlon,isym,nt,sf,vp,idv,jdv,as,bs,av,bv, c + mdb,ndb,wvhsec,lvhsec,work,lwork,ierror) c c given the scalar spherical harmonic coefficients as,bs precomputed c by shaec for the scalar stream function sf and av,bv precomputed by c shaec for the scalar velocity potenital vp, subroutine isfvpec computes c the vector field (v,w) corresponding to sf and vp. w is the east c longitudinal and v is the colatitudinal component of the vector field. c (v,w) is expressed in terms of sf,vp by the helmholtz relations (in c mathematical spherical coordinates): c c v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta c c w = 1/sin(theta)*d(st)/dlambda + d(vp)/dtheta c c required legendre functions are recomputed rather than stored as c they are in subroutine isfvpes. v(i,j) and w(i,j) are given at c colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere (pi=4.0*atan(1.0)). c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the vector field is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in sf,vp about the equator. in this case v c and w are not necessarily symmetric or antisymmetric about c equator. v and w are computed on the entire sphere. c i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c vp is antisymmetric and sf is symmetric about the equator. c in this case v is symmetric and w antisymmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the v(i,j),w(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then v(i,j),w(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c vp is symmetric and sf is antisymmetric about the equator. c in this case v is antisymmetric and w symmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the v(i,j),w(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then v(i,j),w(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. arrays c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple vector synthesis will c be performed to compute (v,w) for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the arrays v,w as it appears in c the program that calls isfvpec. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the arrays v,w as it appears in c the program that calls isfvpec. jdv must be at least nlon. c c as,bs two or three dimensional arrays (see input parameter nt) c that contain the spherical harmonic coefficients of c the scalar field sf as computed by subroutine shaec. c c av,bv two or three dimensional arrays (see input parameter nt) c that contain the spherical harmonic coefficients of c the scalar field vp as computed by subroutine shaec. c c mdb the first dimension of the arrays as,bs,av,bv as it c appears in the program that calls isfvpec. mdb must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays as,bs,av,bv as it c appears in the program that calls isfvpec. ndb must be at c least nlat. c c wvhsec an array which must be initialized by subroutine vhseci. c once initialized, wvhsec can be used repeatedly by isfvpec c as long as nlon and nlat remain unchanged. wvhsec must c not bel altered between calls of isfvpec. c c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls isfvpec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsec must be at least c c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls isfvpec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)+4*l1*nt+1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(4*l1*nt+1) c c ************************************************************** c c output parameters c c v,w two or three dimensional arrays (see input parameter nt) c that contains the vector field corresponding to the stream c function sf and velocity potential vp whose coefficients, c as,bs (for sf) and av,bv (for vp), were precomputed by c subroutine shaec. v(i,j) and w(i,j) are given at the c colatitude point c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude point c c lambda(j) = (j-1)*2*pi/nlon c c the index ranges are defined above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lvhsec c = 10 error in the specification of lwork c ********************************************************************** c subroutine isfvpec(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv, + mdb,ndb,wvhsec,lvhsec,work,lwork,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lvhsec,lwork,ierror real v(idv,jdv,nt),w(idv,jdv,nt) real as(mdb,ndb,nt),bs(mdb,ndb,nt) real av(mdb,ndb,nt),bv(mdb,ndb,nt) real wvhsec(lvhsec),work(lwork) integer mmax,l1,l2,lzz1,labc,mn,is,lwk,iwk,lwmin integer ibr,ibi,icr,ici c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if (nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if (nt .lt. 0) return ierror = 5 l2 = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. + (isym.gt.0 .and. idv.lt.l2)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 l1 = min0(nlat,(nlon+1)/2) if (mdb .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if (ndb .lt. nlat) return ierror = 9 lzz1 = 2*nlat*l2 labc = 3*(max0(l1-2,0)*(nlat+nlat-l1-1))/2 if (lvhsec .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 if (isym .eq. 0) then lwmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+4*l1*nt+1) else lwmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(4*l1*nt+1) end if if (lwork .lt. lwmin) return c c set first dimension for br,bi,cr,ci (as requried by vhsec) c mmax = min0(nlat,(nlon+1)/2) mn = mmax*nlat*nt ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn is = ici+mn iwk = is+nlat lwk = lwork-4*mn-nlat call isfvpec1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb, +ndb,work(ibr),work(ibi),work(icr),work(ici),l1,work(is), +wvhsec,lvhsec,work(iwk),lwk,ierror) return end subroutine isfvpec1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv, +mdb,ndb,br,bi,cr,ci,mab,fnn,wvhsec,lvhsec,wk,lwk,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lvhsec,lwk,ierror real v(idv,jdv,nt),w(idv,jdv,nt) real as(mdb,ndb,nt),bs(mdb,ndb,nt) real av(mdb,ndb,nt),bv(mdb,ndb,nt) real br(mab,nlat,nt),bi(mab,nlat,nt) real cr(mab,nlat,nt),ci(mab,nlat,nt) real wvhsec(lvhsec),wk(lwk),fnn(nlat) integer n,m,mmax,k,ityp c c set coefficient multiplyers c do n=2,nlat fnn(n) = -sqrt(float(n*(n-1))) end do mmax = min0(nlat,(nlon+1)/2) c c compute (v,w) coefficients from as,bs,av,bv c do k=1,nt do n=1,nlat do m=1,mab br(m,n,k) = 0.0 bi(m,n,k) = 0.0 cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat br(1,n,k) = -fnn(n)*av(1,n,k) bi(1,n,k) = -fnn(n)*bv(1,n,k) cr(1,n,k) = fnn(n)*as(1,n,k) ci(1,n,k) = fnn(n)*bs(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c do m=2,mmax do n=m,nlat br(m,n,k) = -fnn(n)*av(m,n,k) bi(m,n,k) = -fnn(n)*bv(m,n,k) cr(m,n,k) = fnn(n)*as(m,n,k) ci(m,n,k) = fnn(n)*bs(m,n,k) end do end do end do c c synthesize br,bi,cr,ci into (v,w) c if (isym .eq.0) then ityp = 0 else if (isym .eq.1) then ityp = 3 else if (isym .eq.2) then ityp = 6 end if call vhsec(nlat,nlon,ityp,nt,v,w,idv,jdv,br,bi,cr,ci, + mab,nlat,wvhsec,lvhsec,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file isfvpes.f c c this file includes documentation and code for c subroutine isfvpes i c c ... files which must be loaded with isfvpes.f c c sphcom.f, hrfft.f, vhses.f,shaes.f c c c subroutine isfvpes(nlat,nlon,isym,nt,sf,vp,idv,jdv,as,bs,av,bv, c + mdb,ndb,wvhses,lvhses,work,lwork,ierror) c c given the scalar spherical harmonic coefficients as,bs precomputed c by shaes for the scalar stream function sf and av,bv precomputed by c shaes for the scalar velocity potenital vp, subroutine isfvpes computes c the vector field (v,w) corresponding to sf and vp. w is the east c longitudinal and v is the colatitudinal component of the vector field. c (v,w) is expressed in terms of sf,vp by the helmholtz relations (in c mathematical spherical coordinates): c c v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta c c w = 1/sin(theta)*d(st)/dlambda + d(vp)/dtheta c c required legendre functions are stored rather than recomputed as c they are in subroutine isfvpes. v(i,j) and w(i,j) are given at c colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere (pi=4.0*atan(1.0)). c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the vector field is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in sf,vp about the equator. in this case v c and w are not necessarily symmetric or antisymmetric about c equator. v and w are computed on the entire sphere. c i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c vp is antisymmetric and sf is symmetric about the equator. c in this case v is symmetric and w antisymmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the v(i,j),w(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then v(i,j),w(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c vp is symmetric and sf is antisymmetric about the equator. c in this case v is antisymmetric and w symmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the v(i,j),w(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then v(i,j),w(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. arrays c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple vector synthesis will c be performed to compute (v,w) for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the arrays v,w as it appears in c the program that calls isfvpes. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the arrays v,w as it appears in c the program that calls isfvpes. jdv must be at least nlon. c c as,bs two or three dimensional arrays (see input parameter nt) c that contain the spherical harmonic coefficients of c the scalar field sf as computed by subroutine shaes. c c av,bv two or three dimensional arrays (see input parameter nt) c that contain the spherical harmonic coefficients of c the scalar field vp as computed by subroutine shaes. c c mdb the first dimension of the arrays as,bs,av,bv as it c appears in the program that calls isfvpes. mdb must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays as,bs,av,bv as it c appears in the program that calls isfvpes. ndb must be at c least nlat. c c wvhses an array which must be initialized by subroutine vhsesi. c once initialized, wvhses can be used repeatedly by isfvpes c as long as nlon and nlat remain unchanged. wvhses must c not bel altered between calls of isfvpes. c c c lvhses the dimension of the array wvhses as it appears in the c program that calls isfvpes. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhses must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls isfvpes. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym=0 then lwork must be at least c c nlat*((2*nt+1)*nlon + 4*l1*nt + 1) c c if isym=1 or 2 then lwork must be at least c c (2*nt+1)*l2*nlon + nlat*(4*l1*nt + 1) c c c ************************************************************** c c output parameters c c v,w two or three dimensional arrays (see input parameter nt) c that contains the vector field corresponding to the stream c function sf and velocity potential vp whose coefficients, c as,bs (for sf) and av,bv (for vp), were precomputed by c subroutine shaes. v(i,j) and w(i,j) are given at the c colatitude point c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude point c c lambda(j) = (j-1)*2*pi/nlon c c the index ranges are defined above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lvhses c = 10 error in the specification of lwork c ********************************************************************** c subroutine isfvpes(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv, + mdb,ndb,wvhses,lvhses,work,lwork,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lvhses,lwork,ierror real v(idv,jdv,nt),w(idv,jdv,nt) real as(mdb,ndb,nt),bs(mdb,ndb,nt) real av(mdb,ndb,nt),bv(mdb,ndb,nt) real wvhses(lvhses),work(lwork) integer l1,l2,mn,is,lwk,iwk integer ibr,ibi,icr,ici c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if (nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if (nt .lt. 0) return ierror = 5 l2 = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. + (isym.gt.0 .and. idv.lt.l2)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 l1 = min0(nlat,(nlon+1)/2) if (mdb .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if (ndb .lt. nlat) return ierror = 9 l1 = min0(nlat,(nlon+2)/2) if (lvhses .lt. l1*l2*(nlat+nlat-l1+1)+nlon+15) return ierror = 10 if (isym.eq.0) then if (lwork .lt. nlat*((2*nt+1)*nlon+4*l1*nt+1)) return else if (lwork .lt. (2*nt+1)*nlon+nlat*(4*l1*nt+1)) return end if c c set first dimension for br,bi,cr,ci (as requried by vhses) c mn = l1*nlat*nt ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn is = ici+mn iwk = is+nlat lwk = lwork-4*mn-nlat call isfvpes1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb, +ndb,work(ibr),work(ibi),work(icr),work(ici),l1,work(is), +wvhses,lvhses,work(iwk),lwk,ierror) return end subroutine isfvpes1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv, +mdb,ndb,br,bi,cr,ci,mab,fnn,wvhses,lvhses,wk,lwk,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lvhses,lwk,ierror real v(idv,jdv,nt),w(idv,jdv,nt) real as(mdb,ndb,nt),bs(mdb,ndb,nt) real av(mdb,ndb,nt),bv(mdb,ndb,nt) real br(mab,nlat,nt),bi(mab,nlat,nt) real cr(mab,nlat,nt),ci(mab,nlat,nt) real wvhses(lvhses),wk(lwk),fnn(nlat) integer n,m,mmax,k,ityp c c set coefficient multiplyers c do n=2,nlat fnn(n) = -sqrt(float(n*(n-1))) end do mmax = min0(nlat,(nlon+1)/2) c c compute (v,w) coefficients from as,bs,av,bv c do k=1,nt do n=1,nlat do m=1,mab br(m,n,k) = 0.0 bi(m,n,k) = 0.0 cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat br(1,n,k) = -fnn(n)*av(1,n,k) bi(1,n,k) = -fnn(n)*bv(1,n,k) cr(1,n,k) = fnn(n)*as(1,n,k) ci(1,n,k) = fnn(n)*bs(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c do m=2,mmax do n=m,nlat br(m,n,k) = -fnn(n)*av(m,n,k) bi(m,n,k) = -fnn(n)*bv(m,n,k) cr(m,n,k) = fnn(n)*as(m,n,k) ci(m,n,k) = fnn(n)*bs(m,n,k) end do end do end do c c synthesize br,bi,cr,ci into (v,w) c if (isym .eq.0) then ityp = 0 else if (isym .eq.1) then ityp = 3 else if (isym .eq.2) then ityp = 6 end if call vhses(nlat,nlon,ityp,nt,v,w,idv,jdv,br,bi,cr,ci, + mab,nlat,wvhses,lvhses,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file isfvpgc.f c c this file includes documentation and code for c subroutine isfvpgc i c c ... files which must be loaded with isfvpgc.f c c sphcom.f, hrfft.f, vhsgc.f, shagc.f, gaqd.f c c c subroutine isfvpgc(nlat,nlon,isym,nt,sf,vp,idv,jdv,as,bs,av,bv, c + mdb,ndb,wvhsgc,lvhsgc,work,lwork,ierror) c c given the scalar spherical harmonic coefficients as,bs precomputed c by shagc for the scalar stream function sf and av,bv precomputed by c shagc for the scalar velocity potenital vp, subroutine isfvpgc computes c the vector field (v,w) corresponding to sf and vp. w is the east c longitudinal and v is the colatitudinal component of the vector field. c (v,w) is expressed in terms of sf,vp by the helmholtz relations (in c mathematical spherical coordinates): c c v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta c c w = 1/sin(theta)*d(st)/dlambda + d(vp)/dtheta c c required legendre functions are recomputed rather than stored as c they are in subroutine isfvpgs. v(i,j) and w(i,j) are given at c the i(th) gaussian colatitude point (see gaqd) theta(i) and east c longitude lambda(j) = (j-1)*2.*pi/nlon on the sphere. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the vector field is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in sf,vp about the equator. in this case v c and w are not necessarily symmetric or antisymmetric about c equator. v and w are computed on the entire sphere. c i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c vp is antisymmetric and sf is symmetric about the equator. c in this case v is symmetric and w antisymmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the v(i,j),w(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then v(i,j),w(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c vp is symmetric and sf is antisymmetric about the equator. c in this case v is antisymmetric and w symmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the v(i,j),w(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then v(i,j),w(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. arrays c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple vector synthesis will c be performed to compute (v,w) for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the arrays v,w as it appears in c the program that calls isfvpgc. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the arrays v,w as it appears in c the program that calls isfvpgc. jdv must be at least nlon. c c as,bs two or three dimensional arrays (see input parameter nt) c that contain the spherical harmonic coefficients of c the scalar field sf as computed by subroutine shagc. c c av,bv two or three dimensional arrays (see input parameter nt) c that contain the spherical harmonic coefficients of c the scalar field vp as computed by subroutine shagc. c c mdb the first dimension of the arrays as,bs,av,bv as it c appears in the program that calls isfvpgc. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays as,bs,av,bv as it c appears in the program that calls isfvpgc. ndb must be at c least nlat. c c wvhsgc an array which must be initialized by subroutine vhsgci. c once initialized, wvhsgc can be used repeatedly by isfvpgc c as long as nlon and nlat remain unchanged. wvhsgc must c not bel altered between calls of isfvpgc. c c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls isfvpgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgc must be at least c c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls isfvpgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)+4*l1*nt+1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(4*l1*nt+1) c c ************************************************************** c c output parameters c c v,w two or three dimensional arrays (see input parameter nt) c that contains the vector field corresponding to the stream c function sf and velocity potential vp whose coefficients, c as,bs (for sf) and av,bv (for vp), were precomputed by c subroutine shagc. v(i,j) and w(i,j) are given at the c i(th) gaussian colatitude point theta(i) and east longitude c point lambda(j) = (j-1)*2*pi/nlon. the index ranges are c defined above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lvhsgc c = 10 error in the specification of lwork c ********************************************************************** c subroutine isfvpgc(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv, + mdb,ndb,wvhsgc,lvhsgc,work,lwork,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lvhsgc,lwork,ierror real v(idv,jdv,nt),w(idv,jdv,nt) real as(mdb,ndb,nt),bs(mdb,ndb,nt) real av(mdb,ndb,nt),bv(mdb,ndb,nt) real wvhsgc(lvhsgc),work(lwork) integer l1,l2,mn,is,lwk,iwk,lwmin integer ibr,ibi,icr,ici c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if (nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if (nt .lt. 0) return ierror = 5 l2 = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. + (isym.gt.0 .and. idv.lt.l2)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 l1 = min0(nlat,(nlon+1)/2) if (mdb .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if (ndb .lt. nlat) return ierror = 9 lwmin = 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1+1)+nlon+15 if (lvhsgc .lt. lwmin) return ierror = 10 if (isym .eq. 0) then lwmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+4*l1*nt+1) else lwmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(4*l1*nt+1) end if if (lwork .lt. lwmin) return c c set first dimension for br,bi,cr,ci (as requried by vhsgc) c mn = l1*nlat*nt ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn is = ici+mn iwk = is+nlat lwk = lwork-4*mn-nlat call isfvpgc1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb, +ndb,work(ibr),work(ibi),work(icr),work(ici),l1,work(is), +wvhsgc,lvhsgc,work(iwk),lwk,ierror) return end subroutine isfvpgc1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv, +mdb,ndb,br,bi,cr,ci,mab,fnn,wvhsgc,lvhsgc,wk,lwk,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lvhsgc,lwk,ierror real v(idv,jdv,nt),w(idv,jdv,nt) real as(mdb,ndb,nt),bs(mdb,ndb,nt) real av(mdb,ndb,nt),bv(mdb,ndb,nt) real br(mab,nlat,nt),bi(mab,nlat,nt) real cr(mab,nlat,nt),ci(mab,nlat,nt) real wvhsgc(lvhsgc),wk(lwk),fnn(nlat) integer n,m,mmax,k,ityp c c set coefficient multiplyers c do n=2,nlat fnn(n) = -sqrt(float(n*(n-1))) end do mmax = min0(nlat,(nlon+1)/2) c c compute (v,w) coefficients from as,bs,av,bv c do k=1,nt do n=1,nlat do m=1,mab br(m,n,k) = 0.0 bi(m,n,k) = 0.0 cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat br(1,n,k) = -fnn(n)*av(1,n,k) bi(1,n,k) = -fnn(n)*bv(1,n,k) cr(1,n,k) = fnn(n)*as(1,n,k) ci(1,n,k) = fnn(n)*bs(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c do m=2,mmax do n=m,nlat br(m,n,k) = -fnn(n)*av(m,n,k) bi(m,n,k) = -fnn(n)*bv(m,n,k) cr(m,n,k) = fnn(n)*as(m,n,k) ci(m,n,k) = fnn(n)*bs(m,n,k) end do end do end do c c synthesize br,bi,cr,ci into (v,w) c if (isym .eq.0) then ityp = 0 else if (isym .eq.1) then ityp = 3 else if (isym .eq.2) then ityp = 6 end if call vhsgc(nlat,nlon,ityp,nt,v,w,idv,jdv,br,bi,cr,ci, + mab,nlat,wvhsgc,lvhsgc,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file isfvpgs.f c c this file includes documentation and code for c subroutine isfvpgs i c c ... files which must be loaded with isfvpgs.f c c sphcom.f, hrfft.f, vhsgs.f, shags.f, gaqd.f c c c subroutine isfvpgs(nlat,nlon,isym,nt,sf,vp,idv,jdv,as,bs,av,bv, c + mdb,ndb,wvhsgs,lvhsgs,work,lwork,ierror) c c given the scalar spherical harmonic coefficients as,bs precomputed c by shags for the scalar stream function sf and av,bv precomputed by c shags for the scalar velocity potenital vp, subroutine isfvpgs computes c the vector field (v,w) corresponding to sf and vp. w is the east c longitudinal and v is the colatitudinal component of the vector field. c (v,w) is expressed in terms of sf,vp by the helmholtz relations (in c mathematical spherical coordinates): c c v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta c c w = 1/sin(theta)*d(st)/dlambda + d(vp)/dtheta c c required legendre functions are stored rather than recomputed as c they are in subroutine isfvpgc. v(i,j) and w(i,j) are given at c the i(th) gaussian colatitude point (see gaqd) theta(i) and east c longitude lambda(j) = (j-1)*2.*pi/nlon on the sphere. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the vector field is c computed on the full or half sphere as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in sf,vp about the equator. in this case v c and w are not necessarily symmetric or antisymmetric about c equator. v and w are computed on the entire sphere. c i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c vp is antisymmetric and sf is symmetric about the equator. c in this case v is symmetric and w antisymmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the v(i,j),w(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then v(i,j),w(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c vp is symmetric and sf is antisymmetric about the equator. c in this case v is antisymmetric and w symmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the v(i,j),w(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then v(i,j),w(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. arrays c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple vector synthesis will c be performed to compute (v,w) for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the arrays v,w as it appears in c the program that calls isfvpgs. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the arrays v,w as it appears in c the program that calls isfvpgs. jdv must be at least nlon. c c as,bs two or three dimensional arrays (see input parameter nt) c that contain the spherical harmonic coefficients of c the scalar field sf as computed by subroutine shags. c c av,bv two or three dimensional arrays (see input parameter nt) c that contain the spherical harmonic coefficients of c the scalar field vp as computed by subroutine shags. c c mdb the first dimension of the arrays as,bs,av,bv as it c appears in the program that calls isfvpgs. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays as,bs,av,bv as it c appears in the program that calls isfvpgs. ndb must be at c least nlat. c c wvhsgs an array which must be initialized by subroutine vhsgsi. c once initialized, wvhsgs can be used repeatedly by isfvpgs c as long as nlon and nlat remain unchanged. wvhsgs must c not bel altered between calls of isfvpgs. c c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls isfvpgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgs must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls isfvpgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym = 0 then lwork must be at least c c nlat*((2*nt+1)*nlon + 4*l1*nt + 1) c c if isym = 1 or 2 then lwork must be at least c c (2*nt+1)*l2*nlon + nlat*(4*l1*nt+1) c c ************************************************************** c c output parameters c c v,w two or three dimensional arrays (see input parameter nt) c that contains the vector field corresponding to the stream c function sf and velocity potential vp whose coefficients, c as,bs (for sf) and av,bv (for vp), were precomputed by c subroutine shags. v(i,j) and w(i,j) are given at the c i(th) gaussian colatitude point theta(i) and east longitude c point lambda(j) = (j-1)*2*pi/nlon. the index ranges are c defined above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lvhsgs c = 10 error in the specification of lwork c ********************************************************************** c subroutine isfvpgs(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv, + mdb,ndb,wvhsgs,lvhsgs,work,lwork,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lvhsgs,lwork,ierror real v(idv,jdv,nt),w(idv,jdv,nt) real as(mdb,ndb,nt),bs(mdb,ndb,nt) real av(mdb,ndb,nt),bv(mdb,ndb,nt) real wvhsgs(lvhsgs),work(lwork) integer l1,l2,mn,is,lwk,iwk,lwmin integer ibr,ibi,icr,ici c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if (nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if (nt .lt. 0) return ierror = 5 l2 = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. + (isym.gt.0 .and. idv.lt.l2)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 l1 = min0(nlat,(nlon+1)/2) if (mdb .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if (ndb .lt. nlat) return ierror = 9 lwmin = l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat if (lvhsgs .lt. lwmin) return ierror = 10 if (isym .eq. 0) then lwmin = nlat*((2*nt+1)*nlon+4*l1*nt+1) else lwmin = (2*nt+1)*l2*nlon + nlat*(4*l1*nt+1) end if if (lwork .lt. lwmin) return c c set first dimension for br,bi,cr,ci (as requried by vhsgs) c mn = l1*nlat*nt ierror = 0 c c set work space pointers c ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn is = ici+mn iwk = is+nlat lwk = lwork-4*mn-nlat call isfvpgs1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb, +ndb,work(ibr),work(ibi),work(icr),work(ici),l1,work(is), +wvhsgs,lvhsgs,work(iwk),lwk,ierror) return end subroutine isfvpgs1(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv, +mdb,ndb,br,bi,cr,ci,mab,fnn,wvhsgs,lvhsgs,wk,lwk,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lvhsgs,lwk,ierror real v(idv,jdv,nt),w(idv,jdv,nt) real as(mdb,ndb,nt),bs(mdb,ndb,nt) real av(mdb,ndb,nt),bv(mdb,ndb,nt) real br(mab,nlat,nt),bi(mab,nlat,nt) real cr(mab,nlat,nt),ci(mab,nlat,nt) real wvhsgs(lvhsgs),wk(lwk),fnn(nlat) integer n,m,mmax,k,ityp c c set coefficient multiplyers c do n=2,nlat fnn(n) = -sqrt(float(n*(n-1))) end do mmax = min0(nlat,(nlon+1)/2) c c compute (v,w) coefficients from as,bs,av,bv c do k=1,nt do n=1,nlat do m=1,mab br(m,n,k) = 0.0 bi(m,n,k) = 0.0 cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat br(1,n,k) = -fnn(n)*av(1,n,k) bi(1,n,k) = -fnn(n)*bv(1,n,k) cr(1,n,k) = fnn(n)*as(1,n,k) ci(1,n,k) = fnn(n)*bs(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c do m=2,mmax do n=m,nlat br(m,n,k) = -fnn(n)*av(m,n,k) bi(m,n,k) = -fnn(n)*bv(m,n,k) cr(m,n,k) = fnn(n)*as(m,n,k) ci(m,n,k) = fnn(n)*bs(m,n,k) end do end do end do c c synthesize br,bi,cr,ci into (v,w) c if (isym .eq.0) then ityp = 0 else if (isym .eq.1) then ityp = 3 else if (isym .eq.2) then ityp = 6 end if call vhsgs(nlat,nlon,ityp,nt,v,w,idv,jdv,br,bi,cr,ci, + mab,nlat,wvhsgs,lvhsgs,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file islapec.f c c this file includes documentation and code for c subroutine islapec i c c ... files which must be loaded with islapec.f c c sphcom.f, hrfft.f, shaec.f, shsec.f c c subroutine islapec(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, c +mdab,ndab,wshsec,lshsec,work,lwork,pertrb,ierror) c c islapec inverts the laplace or helmholz operator on an equally c spaced latitudinal grid using o(n**2) storage. given the c spherical harmonic coefficients a(m,n) and b(m,n) of the right c hand side slap(i,j), islapec computes a solution sf(i,j) to c the following helmhotz equation : c c 2 2 c [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint c c - xlmbda * sf(i,j) = slap(i,j) c c where sf(i,j) is computed at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c isym this parameter should have the same value input to subroutine c shaec to compute the coefficients a and b for the scalar field c slap. isym is set as follows: c c = 0 no symmetries exist in slap about the equator. scalar c synthesis is used to compute sf on the entire sphere. c i.e., in the array sf(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 sf and slap are antisymmetric about the equator. the c synthesis used to compute sf is performed on the c northern hemisphere only. if nlat is odd, sf(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, sf(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c = 2 sf and slap are symmetric about the equator. the c synthesis used to compute sf is performed on the c northern hemisphere only. if nlat is odd, sf(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, sf(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt the number of solutions. in the program that calls islapec c the arrays sf,a, and b can be three dimensional in which c case multiple solutions are computed. the third index c is the solution index with values k=1,...,nt. c for a single solution set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 c and sf,a,b are two dimensional. c c xlmbda a one dimensional array with nt elements. if xlmbda is c is identically zero islapec solves poisson's equation. c if xlmbda > 0.0 islapec solves the helmholtz equation. c if xlmbda < 0.0 the nonfatal error flag ierror=-1 is c returned. negative xlambda could result in a division c by zero. c c ids the first dimension of the array sf as it appears in the c program that calls islapec. if isym = 0 then ids must be at c least nlat. if isym > 0 and nlat is even then ids must be c at least nlat/2. if isym > 0 and nlat is odd then ids must c be at least (nlat+1)/2. c c jds the second dimension of the array sf as it appears in the c program that calls islapec. jds must be at least nlon. c c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field slap. a,b must be computed by shaec c prior to calling islapec. c c c mdab the first dimension of the arrays a and b as it appears c in the program that calls islapec. mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls islapec. ndab must be at least c least nlat. c c mdab,ndab should have the same values input to shaec to c compute the coefficients a and b. c c c wshsec an array which must be initialized by subroutine shseci. c once initialized, wshsec can be used repeatedly by c islapec as long as nlat and nlon remain unchanged. c wshsec must not be altered between calls of islapec. c c lshsec the dimension of the array wshsec as it appears in the c program that calls islapec. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lsave must be greater than or equal to c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls islapec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 let c c lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1). c c if isym > 0 let c c lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1) c c c then lwork must be greater than or equal to lwkmin (see ierror=10) c c ************************************************************** c c output parameters c c c sf two or three dimensional arrays (see input parameter nt) c that contain the solution to either the helmholtz c (xlmbda>0.0) or poisson's equation. sf(i,j) is computed c at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c pertrb a one dimensional array with nt elements (see input c parameter nt). in the discription that follows we assume c that nt=1. if xlmbda > 0.0 then pertrb=0.0 is always c returned because the helmholtz operator is invertible. c if xlmbda = 0.0 then a solution exists only if a(1,1) c is zero. islapec sets a(1,1) to zero. the resulting c solution sf(i,j) solves poisson's equation with c pertrb = a(1,1)/(2.*sqrt(2.)) subtracted from the c right side slap(i,j). c c c ierror a parameter which flags errors in input parameters as follows: c c =-1 xlmbda is input negative (nonfatal error) c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of ids c c = 6 error in the specification of jds c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lsave c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for islapec c c ********************************************************************** c subroutine islapec(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, +mdab,ndab,wshsec,lshsec,work,lwork,pertrb,ierror) dimension sf(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wshsec(lshsec),work(lwork),pertrb(nt),xlmbda(nt) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ids.lt.nlat) .or. 1 (isym.gt.0 .and. ids.lt.imid)) return ierror = 6 if(jds .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c set and verify saved work space length c c l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 lwmin = 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 if(lshsec .lt. lwmin) return ierror = 10 c c set and verify unsaved work space length c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon mn = mmax*nlat*nt c lwmin = nln+ls*nlon+2*mn+nlat c if (lwork .lt. lwmin) return l2 = (nlat+1)/2 l1 = min0(nlat,nlon/2+1) if (isym .eq. 0) then lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c check sign of xlmbda c do k=1,nt if (xlmbda(k).lt.0.0) then ierror = -1 end if end do c c set work space pointers c ia = 1 ib = ia+mn ifn = ib+mn iwk = ifn+nlat lwk = lwork-2*mn-nlat call islpec1(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,mdab,ndab, +work(ia),work(ib),mmax,work(ifn),wshsec,lshsec,work(iwk),lwk, +pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file islapes.f c c this file includes documentation and code for c subroutine islapes i c c ... files which must be loaded with islapes.f c c sphcom.f, hrfft.f, shaes.f, shses.f c c subroutine islapes(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, c +mdab,ndab,wshses,lshses,work,lwork,pertrb,ierror) c c islapes inverts the laplace or helmholz operator on an equally c spaced latitudinal grid using o(n**3) storage. given the c spherical harmonic coefficients a(m,n) and b(m,n) of the right c hand side slap(i,j), islapes computes a solution sf(i,j) to c the following helmhotz equation : c c 2 2 c [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint c c - xlmbda * sf(i,j) = slap(i,j) c c where sf(i,j) is computed at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c isym this parameter should have the same value input to subroutine c shaes to compute the coefficients a and b for the scalar field c slap. isym is set as follows: c c = 0 no symmetries exist in slap about the equator. scalar c synthesis is used to compute sf on the entire sphere. c i.e., in the array sf(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 sf and slap are antisymmetric about the equator. the c synthesis used to compute sf is performed on the c northern hemisphere only. if nlat is odd, sf(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, sf(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c = 2 sf and slap are symmetric about the equator. the c synthesis used to compute sf is performed on the c northern hemisphere only. if nlat is odd, sf(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, sf(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt the number of solutions. in the program that calls islapes c the arrays sf,a, and b can be three dimensional in which c case multiple solutions are computed. the third index c is the solution index with values k=1,...,nt. c for a single solution set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 c and sf,a,b are two dimensional. c c xlmbda a one dimensional array with nt elements. if xlmbda is c is identically zero islapes solves poisson's equation. c if xlmbda > 0.0 islapes solves the helmholtz equation. c if xlmbda < 0.0 the nonfatal error flag ierror=-1 is c returned. negative xlambda could result in a division c by zero. c c ids the first dimension of the array sf as it appears in the c program that calls islapes. if isym = 0 then ids must be at c least nlat. if isym > 0 and nlat is even then ids must be c at least nlat/2. if isym > 0 and nlat is odd then ids must c be at least (nlat+1)/2. c c jds the second dimension of the array sf as it appears in the c program that calls islapes. jds must be at least nlon. c c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field slap. a,b must be computed by shaes c prior to calling islapes. c c c mdab the first dimension of the arrays a and b as it appears c in the program that calls islapes. mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls islapes. ndbc must be at least c least nlat. c c mdab,ndab should have the same values input to shaes to c compute the coefficients a and b. c c c wshses an array which must be initialized by subroutine shsesi. c once initialized, wshses can be used repeatedly by c islapes as long as nlat and nlon remain unchanged. c wshses must not be altered between calls of islapes. c c lshses the dimension of the array wshses as it appears in the c program that calls islapes. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshses must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls islapes. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym is zero then lwork must be at least c c (nt+1)*nlat*nlon + nlat*(2*nt*l1+1) c c if isym is nonzero lwork must be at least c c (nt+1)*l2*nlon + nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c sf a two or three dimensional arrays (see input parameter nt) that c inverts the scalar laplacian in slap - pertrb. sf(i,j) is given c at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c pertrb a one dimensional array with nt elements (see input c parameter nt). in the discription that follows we assume c that nt=1. if xlmbda > 0.0 then pertrb=0.0 is always c returned because the helmholtz operator is invertible. c if xlmbda = 0.0 then a solution exists only if a(1,1) c is zero. islapec sets a(1,1) to zero. the resulting c solution sf(i,j) solves poisson's equation with c pertrb = a(1,1)/(2.*sqrt(2.)) subtracted from the c right side slap(i,j). c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of ids c c = 6 error in the specification of jds c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lshses c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for islapes c c ********************************************************************** c subroutine islapes(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, +mdab,ndab,wshses,lshses,work,lwork,pertrb,ierror) dimension sf(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wshses(lshses),work(lwork),xlmbda(nt),pertrb(nt) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ids.lt.nlat) .or. 1 (isym.gt.0 .and. ids.lt.imid)) return ierror = 6 if(jds .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c set and verify saved work space length c imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshses .lt. lpimn+nlon+15) return ierror = 10 c c set and verify unsaved work space length c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon mn = mmax*nlat*nt c lwkmin = nln+ls*nlon+2*mn+nlat c if (lwork .lt. lwkmin) return l2 = (nlat+1)/2 l1 = min0(nlat,nlon/2+1) if (isym.eq.0) then lwkmin = (nt+1)*nlat*nlon + nlat*(2*nt*l1+1) else lwkmin = (nt+1)*l2*nlon + nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c check sign of xlmbda c do k=1,nt if (xlmbda(k).lt.0.0) then ierror = -1 end if end do c c set work space pointers c ia = 1 ib = ia+mn ifn = ib+mn iwk = ifn+nlat lwk = lwork-2*mn-nlat call islpes1(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,mdab,ndab, +work(ia),work(ib),mmax,work(ifn),wshses,lshses,work(iwk),lwk, +pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file islapgc.f c c this file includes documentation and code for c subroutine islapgc i c c ... files which must be loaded with islapgc.f c c sphcom.f, hrfft.f, shagc.f, shsgc.f c c subroutine islapgc(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, c +mdab,ndab,wshsgc,lshsgc,work,lwork,pertrb,ierror) c c islapgc inverts the laplace or helmholz operator on a Gaussian c grid using o(n**2) storage. given the c spherical harmonic coefficients a(m,n) and b(m,n) of the right c hand side slap(i,j), islapgc computes a solution sf(i,j) to c the following helmhotz equation : c c 2 2 c [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint c c - xlmbda * sf(i,j) = slap(i,j) c c where sf(i,j) is computed at the Gaussian colatitude point theta(i) c (see nlat as an input argument) and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c isym this parameter should have the same value input to subroutine c shagc to compute the coefficients a and b for the scalar field c slap. isym is set as follows: c c = 0 no symmetries exist in slap about the equator. scalar c synthesis is used to compute sf on the entire sphere. c i.e., in the array sf(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 sf and slap are antisymmetric about the equator. the c synthesis used to compute sf is performed on the c northern hemisphere only. if nlat is odd, sf(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, sf(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c = 2 sf and slap are symmetric about the equator. the c synthesis used to compute sf is performed on the c northern hemisphere only. if nlat is odd, sf(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, sf(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt the number of solutions. in the program that calls islapgc c the arrays sf,a, and b can be three dimensional in which c case multiple solutions are computed. the third index c is the solution index with values k=1,...,nt. c for a single solution set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 c and sf,a,b are two dimensional. c c xlmbda a one dimensional array with nt elements. if xlmbda is c is identically zero islapgc solves poisson's equation. c if xlmbda > 0.0 islapgc solves the helmholtz equation. c if xlmbda < 0.0 the nonfatal error flag ierror=-1 is c returned. negative xlambda could result in a division c by zero. c c ids the first dimension of the array sf as it appears in the c program that calls islapgc. if isym = 0 then ids must be at c least nlat. if isym > 0 and nlat is even then ids must be c at least nlat/2. if isym > 0 and nlat is odd then ids must c be at least (nlat+1)/2. c c jds the second dimension of the array sf as it appears in the c program that calls islapgc. jds must be at least nlon. c c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field slap. a,b must be computed by shagc c prior to calling islapgc. c c c mdab the first dimension of the arrays a and b as it appears c in the program that calls islapgc. mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls islapgc. ndbc must be at least c least nlat. c c mdab,ndab should have the same values input to shagc to c compute the coefficients a and b. c c wshsgc an array which must be initialized by subroutine shsgci c once initialized, wshsgc can be used repeatedly by islapgc c as long as nlon and nlat remain unchanged. wshsgc must c not be altered between calls of islapgc. c c c lshsgc the dimension of the array wshsgc as it appears in the c program that calls islapgc. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls islapgc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 let c c lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1). c c if isym > 0 let c c lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1) c c c then lwork must be greater than or equal to lwkmin (see ierror=10) c c ************************************************************** c c output parameters c c c sf a two or three dimensional arrays (see input parameter nt) that c inverts the scalar laplacian in slap. sf(i,j) is given at c the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c pertrb a one dimensional array with nt elements (see input c parameter nt). in the discription that follows we assume c that nt=1. if xlmbda > 0.0 then pertrb=0.0 is always c returned because the helmholtz operator is invertible. c if xlmbda = 0.0 then a solution exists only if a(1,1) c is zero. islapgc sets a(1,1) to zero. the resulting c solution sf(i,j) solves poisson's equation with c pertrb = a(1,1)/(2.*sqrt(2.)) subtracted from the c right side slap(i,j). c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of ids c c = 6 error in the specification of jds c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lshsgc c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for islapgc c c ********************************************************************** c subroutine islapgc(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, +mdab,ndab,wshsgc,lshsgc,work,lwork,pertrb,ierror) dimension sf(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wshsgc(lshsgc),work(lwork),xlmbda(nt),pertrb(nt) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ids.lt.nlat) .or. 1 (isym.gt.0 .and. ids.lt.imid)) return ierror = 6 if(jds .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c set and verify saved work space length c c l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 lwmin = nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 if(lshsgc .lt. lwmin) return ierror = 10 c c set and verify unsaved work space length c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon mn = mmax*nlat*nt c lwmin = nln+ls*nlon+2*mn+nlat c if (lwork .lt. lwmin) return if (isym .eq. 0) then lwmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*l1*nt+1) else lwmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*l1*nt+1) end if if (lwork .lt. lwmin) return ierror = 0 c c check sign of xlmbda c do k=1,nt if (xlmbda(k).lt.0.0) then ierror = -1 end if end do c c set work space pointers c ia = 1 ib = ia+mn ifn = ib+mn iwk = ifn+nlat lwk = lwork-2*mn-nlat call islpgc1(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,mdab,ndab, +work(ia),work(ib),mmax,work(ifn),wshsgc,lshsgc,work(iwk),lwk, +pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file islapgs.f c c this file includes documentation and code for c subroutine islapgs i c c ... files which must be loaded with islapec.f c c sphcom.f, hrfft.f, shags.f, shsgs.f c c subroutine islapgs(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, c +mdab,ndab,wshsgs,lshsgs,work,lwork,pertrb,ierror) c c islapgs inverts the laplace or helmholz operator on a Gaussian grid. c Given the spherical harmonic coefficients a(m,n) and b(m,n) of the c right hand side slap(i,j), islapgc computes a solution sf(i,j) to c the following helmhotz equation : c c 2 2 c [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint c c - xlmbda * sf(i,j) = slap(i,j) c c where sf(i,j) is computed at the Gaussian colatitude point theta(i) c (see nlat as an input argument) and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c isym this parameter should have the same value input to subroutine c shags to compute the coefficients a and b for the scalar field c slap. isym is set as follows: c c = 0 no symmetries exist in slap about the equator. scalar c synthesis is used to compute sf on the entire sphere. c i.e., in the array sf(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 sf and slap are antisymmetric about the equator. the c synthesis used to compute sf is performed on the c northern hemisphere only. if nlat is odd, sf(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, sf(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c = 2 sf and slap are symmetric about the equator. the c synthesis used to compute sf is performed on the c northern hemisphere only. if nlat is odd, sf(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, sf(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt the number of analyses. in the program that calls islapgs c the arrays sf,a, and b can be three dimensional in which c case multiple synthesis will be performed. the third index c is the synthesis index which assumes the values k=1,...,nt. c k is also the index for the perturbation array pertrb. c for a single analysis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 c or that sf,a,b are two dimensional and pertrb is a constant. c c xlmbda a one dimensional array with nt elements. if xlmbda is c is identically zero islapgc solves poisson's equation. c if xlmbda > 0.0 islapgc solves the helmholtz equation. c if xlmbda < 0.0 the nonfatal error flag ierror=-1 is c returned. negative xlambda could result in a division c by zero. c c ids the first dimension of the array sf as it appears in the c program that calls islapgs. if isym = 0 then ids must be at c least nlat. if isym > 0 and nlat is even then ids must be c at least nlat/2. if isym > 0 and nlat is odd then ids must c be at least (nlat+1)/2. c c jds the second dimension of the array sf as it appears in the c program that calls islapgs. jds must be at least nlon. c c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field slap as computed by subroutine shags. c *** a,b must be computed by shags prior to calling islapgs. c c c mdab the first dimension of the arrays a and b as it appears c in the program that calls islapgs. mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls islapgs. ndbc must be at least c least nlat. c c mdab,ndab should have the same values input to shags to c compute the coefficients a and b. c c c wshsgs an array which must be initialized by subroutine islapgsi c (or equivalently by shsesi). once initialized, wshsgs c can be used repeatedly by islapgs as long as nlat and nlon c remain unchanged. wshsgs must not be altered between calls c of islapgs. c c lshsgs the dimension of the array wshsgs as it appears in the c program that calls islapgs. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgs must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls islapgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym is zero then lwork must be at least c c (nt+1)*nlat*nlon + nlat*(2*nt*l1+1) c c if isym is nonzero lwork must be at least c c (nt+1)*l2*nlon + nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c sf a two or three dimensional arrays (see input parameter nt) that c inverts the scalar laplacian in slap. sf(i,j) is given at c the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c pertrb a one dimensional array with nt elements (see input c parameter nt). in the discription that follows we assume c that nt=1. if xlmbda > 0.0 then pertrb=0.0 is always c returned because the helmholtz operator is invertible. c if xlmbda = 0.0 then a solution exists only if a(1,1) c is zero. islapec sets a(1,1) to zero. the resulting c solution sf(i,j) solves poisson's equation with c pertrb = a(1,1)/(2.*sqrt(2.)) subtracted from the c right side slap(i,j). c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of ids c c = 6 error in the specification of jds c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lshsgs c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for islapgs c c ********************************************************************** c c subroutine islapgs(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, +mdab,ndab,wshsgs,lshsgs,work,lwork,pertrb,ierror) dimension sf(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wshsgs(lshsgs),work(lwork),xlmbda(nt),pertrb(nt) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ids.lt.nlat) .or. 1 (isym.gt.0 .and. ids.lt.imid)) return ierror = 6 if(jds .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c set and verify saved work space length c imid = (nlat+1)/2 l2 = (nlat+mod(nlat,2))/2 l1 = min0((nlon+2)/2,nlat) lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshsgs.lt.lp) return ierror = 10 c c set and verify unsaved work space length c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon mn = mmax*nlat*nt c lwkmin = nln+ls*nlon+2*mn+nlat c if (lwork .lt. lwkmin) return l2 = (nlat+1)/2 l1 = min0(nlat,nlon/2+1) if (isym.eq.0) then lwkmin = (nt+1)*nlat*nlon + nlat*(2*nt*l1+1) else lwkmin = (nt+1)*l2*nlon + nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c check sign of xlmbda c do k=1,nt if (xlmbda(k).lt.0.0) then ierror = -1 end if end do c c set work space pointers c ia = 1 ib = ia+mn ifn = ib+mn iwk = ifn+nlat lwk = lwork-2*mn-nlat call islpgs1(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,mdab,ndab, +work(ia),work(ib),mmax,work(ifn),wshsgs,lshsgs,work(iwk),lwk, +pertrb,ierror) return end subroutine islpec1(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, +mdab,ndab,as,bs,mmax,fnn,wshsec,lshsec,wk,lwk,pertrb,ierror) dimension sf(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension as(mmax,nlat,nt),bs(mmax,nlat,nt),fnn(nlat) dimension wshsec(lshsec),wk(lwk),pertrb(nt),xlmbda(nt) c c set multipliers and preset synthesis coefficients to zero c do n=1,nlat fn = float(n-1) fnn(n) = fn*(fn+1.0) do m=1,mmax do k=1,nt as(m,n,k) = 0.0 bs(m,n,k) = 0.0 end do end do end do do k=1,nt c c compute synthesis coefficients for xlmbda zero or nonzero c if (xlmbda(k) .eq. 0.0) then do n=2,nlat as(1,n,k) = -a(1,n,k)/fnn(n) bs(1,n,k) = -b(1,n,k)/fnn(n) end do do m=2,mmax do n=m,nlat as(m,n,k) = -a(m,n,k)/fnn(n) bs(m,n,k) = -b(m,n,k)/fnn(n) end do end do else c c xlmbda nonzero so operator invertible unless c -n*(n-1) = xlmbda(k) < 0.0 for some n c pertrb(k) = 0.0 do n=1,nlat as(1,n,k) = -a(1,n,k)/(fnn(n)+xlmbda(k)) bs(1,n,k) = -b(1,n,k)/(fnn(n)+xlmbda(k)) end do do m=2,mmax do n=m,nlat as(m,n,k) = -a(m,n,k)/(fnn(n)+xlmbda(k)) bs(m,n,k) = -b(m,n,k)/(fnn(n)+xlmbda(k)) end do end do end if end do c c synthesize as,bs into sf c call shsec(nlat,nlon,isym,nt,sf,ids,jds,as,bs,mmax,nlat, + wshsec,lshsec,wk,lwk,ierror) return end subroutine islpes1(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, +mdab,ndab,as,bs,mmax,fnn,wshses,lshses,wk,lwk,pertrb,ierror) dimension sf(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension as(mmax,nlat,nt),bs(mmax,nlat,nt),fnn(nlat) dimension wshses(lshses),wk(lwk),pertrb(nt),xlmbda(nt) c c set multipliers and preset synthesis coefficients to zero c do n=1,nlat fn = float(n-1) fnn(n) = fn*(fn+1.0) do m=1,mmax do k=1,nt as(m,n,k) = 0.0 bs(m,n,k) = 0.0 end do end do end do do k=1,nt c c compute synthesis coefficients for xlmbda zero or nonzero c if (xlmbda(k) .eq. 0.0) then do n=2,nlat as(1,n,k) = -a(1,n,k)/fnn(n) bs(1,n,k) = -b(1,n,k)/fnn(n) end do do m=2,mmax do n=m,nlat as(m,n,k) = -a(m,n,k)/fnn(n) bs(m,n,k) = -b(m,n,k)/fnn(n) end do end do else c c xlmbda nonzero so operator invertible unless c -n*(n-1) = xlmbda(k) < 0.0 for some n c pertrb(k) = 0.0 do n=1,nlat as(1,n,k) = -a(1,n,k)/(fnn(n)+xlmbda(k)) bs(1,n,k) = -b(1,n,k)/(fnn(n)+xlmbda(k)) end do do m=2,mmax do n=m,nlat as(m,n,k) = -a(m,n,k)/(fnn(n)+xlmbda(k)) bs(m,n,k) = -b(m,n,k)/(fnn(n)+xlmbda(k)) end do end do end if end do c c synthesize as,bs into sf c call shses(nlat,nlon,isym,nt,sf,ids,jds,as,bs,mmax,nlat, + wshses,lshses,wk,lwk,ierror) return end subroutine islpgc1(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, +mdab,ndab,as,bs,mmax,fnn,wsav,lsav,wk,lwk,pertrb,ierror) dimension sf(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension as(mmax,nlat,nt),bs(mmax,nlat,nt),fnn(nlat) dimension wsav(lsav),wk(lwk),xlmbda(nt),pertrb(nt) c c set multipliers and preset synthesis coefficients to zero c do n=1,nlat fn = float(n-1) fnn(n) = fn*(fn+1.0) do m=1,mmax do k=1,nt as(m,n,k) = 0.0 bs(m,n,k) = 0.0 end do end do end do do k=1,nt c c compute synthesis coefficients for xlmbda zero or nonzero c if (xlmbda(k) .eq. 0.0) then do n=2,nlat as(1,n,k) = -a(1,n,k)/fnn(n) bs(1,n,k) = -b(1,n,k)/fnn(n) end do do m=2,mmax do n=m,nlat as(m,n,k) = -a(m,n,k)/fnn(n) bs(m,n,k) = -b(m,n,k)/fnn(n) end do end do else c c xlmbda nonzero so operator invertible unless c -n*(n-1) = xlmbda(k) < 0.0 for some n c pertrb(k) = 0.0 do n=1,nlat as(1,n,k) = -a(1,n,k)/(fnn(n)+xlmbda(k)) bs(1,n,k) = -b(1,n,k)/(fnn(n)+xlmbda(k)) end do do m=2,mmax do n=m,nlat as(m,n,k) = -a(m,n,k)/(fnn(n)+xlmbda(k)) bs(m,n,k) = -b(m,n,k)/(fnn(n)+xlmbda(k)) end do end do end if end do c c synthesize as,bs into sf c call shsgc(nlat,nlon,isym,nt,sf,ids,jds,as,bs,mmax,nlat, + wsav,lsav,wk,lwk,ierror) return end subroutine islpgs1(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b, +mdab,ndab,as,bs,mmax,fnn,wsav,lsav,wk,lwk,pertrb,ierror) dimension sf(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension as(mmax,nlat,nt),bs(mmax,nlat,nt),fnn(nlat) dimension wsav(lsav),wk(lwk),xlmbda(nt),pertrb(nt) c c set multipliers and preset synthesis coefficients to zero c do n=1,nlat fn = float(n-1) fnn(n) = fn*(fn+1.0) do m=1,mmax do k=1,nt as(m,n,k) = 0.0 bs(m,n,k) = 0.0 end do end do end do do k=1,nt c c compute synthesis coefficients for xlmbda zero or nonzero c if (xlmbda(k) .eq. 0.0) then do n=2,nlat as(1,n,k) = -a(1,n,k)/fnn(n) bs(1,n,k) = -b(1,n,k)/fnn(n) end do do m=2,mmax do n=m,nlat as(m,n,k) = -a(m,n,k)/fnn(n) bs(m,n,k) = -b(m,n,k)/fnn(n) end do end do else c c xlmbda nonzero so operator invertible unless c -n*(n-1) = xlmbda(k) < 0.0 for some n c pertrb(k) = 0.0 do n=1,nlat as(1,n,k) = -a(1,n,k)/(fnn(n)+xlmbda(k)) bs(1,n,k) = -b(1,n,k)/(fnn(n)+xlmbda(k)) end do do m=2,mmax do n=m,nlat as(m,n,k) = -a(m,n,k)/(fnn(n)+xlmbda(k)) bs(m,n,k) = -b(m,n,k)/(fnn(n)+xlmbda(k)) end do end do end if end do c c synthesize as,bs into sf c call shsgs(nlat,nlon,isym,nt,sf,ids,jds,as,bs,mmax,nlat, + wsav,lsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file ivlapec.f c c this file includes documentation and code for c subroutine ivlapec c c ... files which must be loaded with ivlapec.f c c sphcom.f, hrfft.f, vhaec.f, vhsec.f c c c c subroutine ivlapec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c +mdbc,ndbc,wvhsec,lvhsec,work,lwork,ierror) c c c subroutine ivlapec computes a the vector field (v,w) whose vector c laplacian is (vlap,wlap). w and wlap are east longitudinal c components of the vectors. v and vlap are colatitudinal components c of the vectors. br,bi,cr, and ci are the vector harmonic coefficients c of (vlap,wlap). these must be precomputed by vhaec and are input c parameters to ivlapec. (v,w) have the same symmetry or lack of c symmetry about the about the equator as (vlap,wlap). the input c parameters ityp,nt,mdbc,ndbc must have the same values used by c vhaec to compute br,bi,cr, and ci for (vlap,wlap). c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp this parameter should have the same value input to subroutine c vhaec to compute the coefficients br,bi,cr, and ci for the c vector field (vlap,wlap). ityp is set as follows: c c = 0 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c arrays v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon. c c = 1 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon. the c vorticity of (vlap,wlap) is zero so the coefficients cr and c ci are zero and are not used. the vorticity of (v,w) is c also zero. c c c = 2 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c w(i,j) and v(i,j) for i=1,...,nlat and j=1,...,nlon. the c divergence of (vlap,wlap) is zero so the coefficients br and c bi are zero and are not used. the divergence of (v,w) is c also zero. c c = 3 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays v(i,j), c w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays v(i,j),w(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. c c = 4 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays v(i,j), c w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays v(i,j),w(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the vorticity of (vlap, c wlap) is zero so the coefficients cr,ci are zero and c are not used. the vorticity of (v,w) is also zero. c c = 5 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the divergence of (vlap, c wlap) is zero so the coefficients br,bi are zero and c are not used. the divergence of (v,w) is also zero. c c c = 6 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. c c = 7 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the vorticity of (vlap, c wlap) is zero so the coefficients cr,ci are zero and c are not used. the vorticity of (v,w) is also zero. c c = 8 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the divergence of (vlap, c wlap) is zero so the coefficients br,bi are zero and c are not used. the divergence of (v,w) is also zero. c c c nt nt is the number of vector fields (vlap,wlap). some computational c efficiency is obtained for multiple fields. in the program c that calls ivlapec, the arrays v,w,br,bi,cr and ci can be c three dimensional corresponding to an indexed multiple vector c field. in this case multiple vector synthesis will be performed c to compute the (v,w) for each field (vlap,wlap). the third c index is the synthesis index which assumes the values k=1,...,nt. c for a single synthesis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 or c that all arrays are two dimensional. c c idvw the first dimension of the arrays w and v as it appears in c the program that calls ivlapec. if ityp=0,1, or 2 then idvw c must be at least nlat. if ityp > 2 and nlat is even then idvw c must be at least nlat/2. if ityp > 2 and nlat is odd then idvw c must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays w and v as it appears in c the program that calls ivlapec. jdvw must be at least nlon. c c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients of the c vector field (vlap,wlap) as computed by subroutine vhaec. c br,bi,cr and ci must be computed by vhaec prior to calling c ivlapec. if ityp=1,4, or 7 then cr,ci are not used and can c be dummy arguments. if ityp=2,5, or 8 then br,bi are not c used and can be dummy arguments. c c mdbc the first dimension of the arrays br,bi,cr and ci as it c appears in the program that calls ivlapec. mdbc must be c at least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndbc the second dimension of the arrays br,bi,cr and ci as it c appears in the program that calls ivlapec. ndbc must be at c least nlat. c c wvhsec an array which must be initialized by subroutine vhseci. c once initialized, wvhsec c can be used repeatedly by ivlapec as long as nlat and nlon c remain unchanged. wvhsec must not be altered between calls c of ivlapec. c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls ivlapec. let c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c then lvhsec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls ivlapec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if ityp .le. 2 then c c nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(4*nt*l1+1) c c or if ityp .gt. 2 let c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(4*nt*l1+1) c c will suffice as a minimum length for lwork c (see ierror=10 below) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a vector field whose vector laplacian is (vlap,wlap). c w(i,j) is the east longitude and v(i,j) is the colatitudinal c component of the vector. v(i,j) and w(i,j) are given on the c sphere at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c for i=1,...,nlat and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c for j=1,...,nlon. c c let cost and sint be the cosine and sine at colatitude theta. c let d( )/dlambda and d( )/dtheta be the first order partial c derivatives in longitude and colatitude. let sf be either v c or w. define: c c del2s(sf) = [d(sint*d(sf)/dtheta)/dtheta + c 2 2 c d (sf)/dlambda /sint]/sint c c then the vector laplacian of (v,w) in (vlap,wlap) satisfies c c vlap = del2s(v) + (2*cost*dw/dlambda - v)/sint**2 c c and c c wlap = del2s(w) - (2*cost*dv/dlambda + w)/sint**2 c c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of idvw c c = 6 error in the specification of jdvw c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lvhsec c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for ivlapec c c ********************************************************************** c subroutine ivlapec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, +mdbc,ndbc,wvhsec,lvhsec,work,lwork,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhsec(lvhsec),work(lwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdbc .lt. mmax) return ierror = 8 if(ndbc .lt. nlat) return ierror = 9 c c set minimum and verify saved workspace length c idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid c lsavmin = lzimn+lzimn+nlon+15 c if (lvhsec .lt. lsavmin) return lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhsec .lt. 2*(lzz1+labc)+nlon+15) return c c set minimum and verify unsaved work space length c ierror = 10 mn = mmax*nlat*nt if(ityp.lt.3) then c no symmetry if (ityp.eq.0) then c br,bi,cr,ci nonzero lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+4*mn else c br,bi or cr,ci zero lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+2*mn end if else c symmetry if (ityp.eq.3 .or. ityp.eq.6) then c br,bi,cr,ci nonzero lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat else c br,bi or cr,ci zero lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat end if end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers for vector laplacian coefficients c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr else ibr = 1 ibi = 1 icr = ibi+mn ici = icr+mn end if ifn = ici + mn iwk = ifn + nlat if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then liwk = lwork-4*mn-nlat else liwk = lwork-2*mn-nlat end if call ivlapec1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi, +cr,ci,wvhsec,lvhsec,work(iwk),liwk,ierror) return end subroutine ivlapec1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw, +bivw,crvw,civw,mmax,fnn,mdbc,ndbc,br,bi,cr,ci,wsave,lwsav, +wk,lwk,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension fnn(nlat),brvw(mmax,nlat,nt),bivw(mmax,nlat,nt) dimension crvw(mmax,nlat,nt),civw(mmax,nlat,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wsave(lwsav),wk(lwk) c c preset coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = -1.0/(fn*(fn+1.)) 1 continue c c set (v,w) coefficients from br,bi,cr,ci c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then c c all coefficients needed c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax brvw(m,n,k) = 0.0 bivw(m,n,k) = 0.0 crvw(m,n,k) = 0.0 civw(m,n,k) = 0.0 4 continue 3 continue do 5 n=2,nlat brvw(1,n,k) = fnn(n)*br(1,n,k) bivw(1,n,k) = fnn(n)*bi(1,n,k) crvw(1,n,k) = fnn(n)*cr(1,n,k) civw(1,n,k) = fnn(n)*ci(1,n,k) 5 continue do 6 m=2,mmax do 7 n=m,nlat brvw(m,n,k) = fnn(n)*br(m,n,k) bivw(m,n,k) = fnn(n)*bi(m,n,k) crvw(m,n,k) = fnn(n)*cr(m,n,k) civw(m,n,k) = fnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then c c vorticity is zero so cr,ci=0 not used c do 12 k=1,nt do 13 n=1,nlat do 14 m=1,mmax brvw(m,n,k) = 0.0 bivw(m,n,k) = 0.0 14 continue 13 continue do 15 n=2,nlat brvw(1,n,k) = fnn(n)*br(1,n,k) bivw(1,n,k) = fnn(n)*bi(1,n,k) 15 continue do 16 m=2,mmax do 17 n=m,nlat brvw(m,n,k) = fnn(n)*br(m,n,k) bivw(m,n,k) = fnn(n)*bi(m,n,k) 17 continue 16 continue 12 continue else c c divergence is zero so br,bi=0 not used c do 22 k=1,nt do 23 n=1,nlat do 24 m=1,mmax crvw(m,n,k) = 0.0 civw(m,n,k) = 0.0 24 continue 23 continue do 25 n=2,nlat crvw(1,n,k) = fnn(n)*cr(1,n,k) civw(1,n,k) = fnn(n)*ci(1,n,k) 25 continue do 26 m=2,mmax do 27 n=m,nlat crvw(m,n,k) = fnn(n)*cr(m,n,k) civw(m,n,k) = fnn(n)*ci(m,n,k) 27 continue 26 continue 22 continue end if c c sythesize coefs into vector field (v,w) c call vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw,bivw, + crvw,civw,mmax,nlat,wsave,lwsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c c ... file ivlapes.f c c this file includes documentation and code for c subroutine ivlapes c c ... files which must be loaded with ivlapes.f c c sphcom.f, hrfft.f, vhaes.f, vhses.f c c c c subroutine ivlapes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c +mdbc,ndbc,wvhses,lvhses,work,lwork,ierror) c c c subroutine ivlapes computes a the vector field (v,w) whose vector c laplacian is (vlap,wlap). w and wlap are east longitudinal c components of the vectors. v and vlap are colatitudinal components c of the vectors. br,bi,cr, and ci are the vector harmonic coefficients c of (vlap,wlap). these must be precomputed by vhaes and are input c parameters to ivlapes. (v,w) have the same symmetry or lack of c symmetry about the about the equator as (vlap,wlap). the input c parameters ityp,nt,mdbc,ndbc must have the same values used by c vhaes to compute br,bi,cr, and ci for (vlap,wlap). c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp this parameter should have the same value input to subroutine c vhaes to compute the coefficients br,bi,cr, and ci for the c vector field (vlap,wlap). ityp is set as follows: c c = 0 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c arrays v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon. c c = 1 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon. the c vorticity of (vlap,wlap) is zero so the coefficients cr and c ci are zero and are not used. the vorticity of (v,w) is c also zero. c c c = 2 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c w(i,j) and v(i,j) for i=1,...,nlat and j=1,...,nlon. the c divergence of (vlap,wlap) is zero so the coefficients br and c bi are zero and are not used. the divergence of (v,w) is c also zero. c c = 3 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays v(i,j), c w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays v(i,j),w(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. c c = 4 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays v(i,j), c w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays v(i,j),w(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the vorticity of (vlap, c wlap) is zero so the coefficients cr,ci are zero and c are not used. the vorticity of (v,w) is also zero. c c = 5 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the divergence of (vlap, c wlap) is zero so the coefficients br,bi are zero and c are not used. the divergence of (v,w) is also zero. c c c = 6 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. c c = 7 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the vorticity of (vlap, c wlap) is zero so the coefficients cr,ci are zero and c are not used. the vorticity of (v,w) is also zero. c c = 8 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the divergence of (vlap, c wlap) is zero so the coefficients br,bi are zero and c are not used. the divergence of (v,w) is also zero. c c c nt nt is the number of vector fields (vlap,wlap). some computational c efficiency is obtained for multiple fields. in the program c that calls ivlapes, the arrays v,w,br,bi,cr and ci can be c three dimensional corresponding to an indexed multiple vector c field. in this case multiple vector synthesis will be performed c to compute the (v,w) for each field (vlap,wlap). the third c index is the synthesis index which assumes the values k=1,...,nt. c for a single synthesis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 or c that all arrays are two dimensional. c c idvw the first dimension of the arrays w and v as it appears in c the program that calls ivlapes. if ityp=0,1, or 2 then idvw c must be at least nlat. if ityp > 2 and nlat is even then idvw c must be at least nlat/2. if ityp > 2 and nlat is odd then idvw c must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays w and v as it appears in c the program that calls ivlapes. jdvw must be at least nlon. c c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients of the c vector field (vlap,wlap) as computed by subroutine vhaes. c br,bi,cr and ci must be computed by vhaes prior to calling c ivlapes. if ityp=1,4, or 7 then cr,ci are not used and can c be dummy arguments. if ityp=2,5, or 8 then br,bi are not c used and can be dummy arguments. c c mdbc the first dimension of the arrays br,bi,cr and ci as it c appears in the program that calls ivlapes. mdbc must be c at least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndbc the second dimension of the arrays br,bi,cr and ci as it c appears in the program that calls ivlapes. ndbc must be at c least nlat. c c wvhses an array which must be initialized by subroutine vhsesi. c once initialized, wvhses c can be used repeatedly by ivlapes as long as nlat and nlon c remain unchanged. wvhses must not be altered between calls c of ivlapes. c c lvhses the dimension of the array wvhses as it appears in the c program that calls ivlapes. let c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c let c c lsavmin = (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c then lvhses must be greater than or equal to lsavmin c (see ierror=9 below). c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls ivlapes. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if ityp .le. 2 then c c (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1) c c or if ityp .gt. 2 then c c (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1) c c will suffice as a length for lwork. c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a vector field whose vector laplacian is (vlap,wlap). c w(i,j) is the east longitude and v(i,j) is the colatitudinal c component of the vector. v(i,j) and w(i,j) are given on the c sphere at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c for i=1,...,nlat and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c for j=1,...,nlon. c c let cost and sint be the cosine and sine at colatitude theta. c let d( )/dlambda and d( )/dtheta be the first order partial c derivatives in longitude and colatitude. let sf be either v c or w. define: c c del2s(sf) = [d(sint*d(sf)/dtheta)/dtheta + c 2 2 c d (sf)/dlambda /sint]/sint c c then the vector laplacian of (v,w) in (vlap,wlap) satisfies c c vlap = del2s(v) + (2*cost*dw/dlambda - v)/sint**2 c c and c c wlap = del2s(w) - (2*cost*dv/dlambda + w)/sint**2 c c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of idvw c c = 6 error in the specification of jdvw c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lvhses c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for ivlapes c c ********************************************************************** c subroutine ivlapes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, +mdbc,ndbc,wvhses,lvhses,work,lwork,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhses(lvhses),work(lwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdbc .lt. mmax) return ierror = 8 if(ndbc .lt. nlat) return ierror = 9 c c set minimum and verify saved workspace length c idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid lsavmin = lzimn+lzimn+nlon+15 if (lvhses .lt. lsavmin) return c c set minimum and verify unsaved work space length c mn = mmax*nlat*nt l2 = (nlat+1)/2 l1 = min0(nlat,(nlon+1)/2) if (ityp .le. 2) then lwkmin = (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1) else lwkmin = (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers for vector laplacian coefficients c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr else ibr = 1 ibi = 1 icr = ibi+mn ici = icr+mn end if ifn = ici + mn iwk = ifn + nlat if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then liwk = lwork-4*mn-nlat else liwk = lwork-2*mn-nlat end if call ivlapes1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi, +cr,ci,wvhses,lvhses,work(iwk),liwk,ierror) return end subroutine ivlapes1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw, +bivw,crvw,civw,mmax,fnn,mdbc,ndbc,br,bi,cr,ci,wsave,lsave, +wk,lwk,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension fnn(nlat),brvw(mmax,nlat,nt),bivw(mmax,nlat,nt) dimension crvw(mmax,nlat,nt),civw(mmax,nlat,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wsave(lsave),wk(lwk) c c preset coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = -1.0/(fn*(fn+1.)) 1 continue c c set (u,v) coefficients from br,bi,cr,ci c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then c c all coefficients needed c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax brvw(m,n,k) = 0.0 bivw(m,n,k) = 0.0 crvw(m,n,k) = 0.0 civw(m,n,k) = 0.0 4 continue 3 continue do 5 n=2,nlat brvw(1,n,k) = fnn(n)*br(1,n,k) bivw(1,n,k) = fnn(n)*bi(1,n,k) crvw(1,n,k) = fnn(n)*cr(1,n,k) civw(1,n,k) = fnn(n)*ci(1,n,k) 5 continue do 6 m=2,mmax do 7 n=m,nlat brvw(m,n,k) = fnn(n)*br(m,n,k) bivw(m,n,k) = fnn(n)*bi(m,n,k) crvw(m,n,k) = fnn(n)*cr(m,n,k) civw(m,n,k) = fnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then c c vorticity is zero so cr,ci=0 not used c do 12 k=1,nt do 13 n=1,nlat do 14 m=1,mmax brvw(m,n,k) = 0.0 bivw(m,n,k) = 0.0 14 continue 13 continue do 15 n=2,nlat brvw(1,n,k) = fnn(n)*br(1,n,k) bivw(1,n,k) = fnn(n)*bi(1,n,k) 15 continue do 16 m=2,mmax do 17 n=m,nlat brvw(m,n,k) = fnn(n)*br(m,n,k) bivw(m,n,k) = fnn(n)*bi(m,n,k) 17 continue 16 continue 12 continue else c c divergence is zero so br,bi=0 not used c do 22 k=1,nt do 23 n=1,nlat do 24 m=1,mmax crvw(m,n,k) = 0.0 civw(m,n,k) = 0.0 24 continue 23 continue do 25 n=2,nlat crvw(1,n,k) = fnn(n)*cr(1,n,k) civw(1,n,k) = fnn(n)*ci(1,n,k) 25 continue do 26 m=2,mmax do 27 n=m,nlat crvw(m,n,k) = fnn(n)*cr(m,n,k) civw(m,n,k) = fnn(n)*ci(m,n,k) 27 continue 26 continue 22 continue end if c c sythesize coefs into vector field (v,w) c call vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw,bivw, + crvw,civw,mmax,nlat,wsave,lsave,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file ivlapgc.f c c this file includes documentation and code for c subroutine ivlapgc c c ... files which must be loaded with ivlapgc.f c c sphcom.f, hrfft.f, vhagc.f, vhsgc.f, gaqd.f c c subroutine ivlapgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c +mdbc,ndbc,wvhsgc,lvhsgc,work,lwork,ierror) c c given the vector spherical harmonic coefficients (br,bi,cr,ci) c precomputed by subroutine vhagc for a vector field (vlap,wlap), c subroutine ivlapgc computes a vector field (v,w) whose vector c laplacian is (vlap,wlap). v,vlap are the colatitudinal c components and w,wlap are the east longitudinal components of c the vectors. (v,w) have the same symmetry or lack of symmetry c about the equator as (vlap,wlap). the input parameters ityp, c nt,mdbc,ndbc must have the same values used by vhagc to compute c br,bi,cr,ci for (vlap,wlap). c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp this parameter should have the same value input to subroutine c vhagc to compute the coefficients br,bi,cr, and ci for the c vector field (vlap,wlap). ityp is set as follows: c c = 0 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c arrays v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon. c c = 1 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon. the c vorticity of (vlap,wlap) is zero so the coefficients cr and c ci are zero and are not used. the vorticity of (v,w) is c also zero. c c c = 2 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c w(i,j) and v(i,j) for i=1,...,nlat and j=1,...,nlon. the c divergence of (vlap,wlap) is zero so the coefficients br and c bi are zero and are not used. the divergence of (v,w) is c also zero. c c = 3 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays v(i,j), c w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays v(i,j),w(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. c c = 4 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays v(i,j), c w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays v(i,j),w(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the vorticity of (vlap, c wlap) is zero so the coefficients cr,ci are zero and c are not used. the vorticity of (v,w) is also zero. c c = 5 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the divergence of (vlap, c wlap) is zero so the coefficients br,bi are zero and c are not used. the divergence of (v,w) is also zero. c c c = 6 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. c c = 7 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the vorticity of (vlap, c wlap) is zero so the coefficients cr,ci are zero and c are not used. the vorticity of (v,w) is also zero. c c = 8 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the divergence of (vlap, c wlap) is zero so the coefficients br,bi are zero and c are not used. the divergence of (v,w) is also zero. c c c nt nt is the number of vector fields (vlap,wlap). some computational c efficiency is obtained for multiple fields. in the program c that calls ivlapgc, the arrays v,w,br,bi,cr and ci can be c three dimensional corresponding to an indexed multiple vector c field. in this case multiple vector synthesis will be performed c to compute the (v,w) for each field (vlap,wlap). the third c index is the synthesis index which assumes the values k=1,...,nt. c for a single synthesis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 or c that all arrays are two dimensional. c c idvw the first dimension of the arrays w and v as it appears in c the program that calls ivlapgc. if ityp=0,1, or 2 then idvw c must be at least nlat. if ityp > 2 and nlat is even then idvw c must be at least nlat/2. if ityp > 2 and nlat is odd then idvw c must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays w and v as it appears in c the program that calls ivlapgc. jdvw must be at least nlon. c c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients of the c vector field (vlap,wlap) as computed by subroutine vhagc. c br,bi,cr and ci must be computed by vhagc prior to calling c ivlapgc. if ityp=1,4, or 7 then cr,ci are not used and can c be dummy arguments. if ityp=2,5, or 8 then br,bi are not c used and can be dummy arguments. c c mdbc the first dimension of the arrays br,bi,cr and ci as it c appears in the program that calls ivlapgc. mdbc must be c at least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndbc the second dimension of the arrays br,bi,cr and ci as it c appears in the program that calls ivlapgc. ndbc must be at c least nlat. c c wvhsgc an array which must be initialized by subroutine vhsgci. c once initialized, wvhsgc c can be used repeatedly by ivlapgc as long as nlat and nlon c remain unchanged. wvhsgc must not be altered between calls c of ivlapgc. c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls ivlapgc. let c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c then lvhsgc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 c c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls ivlapgc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if ityp .le. 2 then c c nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(4*nt*l1+1) c c or if ityp .gt. 2 let c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(4*nt*l1+1) c c will suffice as a minimum length for lwork c (see ierror=10 below) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a vector field whose vector laplacian is (vlap,wlap). c w(i,j) is the east longitude and v(i,j) is the colatitudinal c component of the vector. v(i,j) and w(i,j) are given on the c sphere at the guassian colatitude theta(i) for i=1,...,nlat c and east longitude lambda(j)=(j-1)*2*pi/nlon for j = 1,...,nlon. c let cost and sint be the cosine and sine at colatitude theta. c let d( )/dlambda and d( )/dtheta be the first order partial c derivatives in longitude and colatitude. let sf be either v c or w. define: c c del2s(sf) = [d(sint*d(sf)/dtheta)/dtheta + c 2 2 c d (sf)/dlambda /sint]/sint c c then the vector laplacian of (v,w) in (vlap,wlap) satisfies c c vlap = del2s(v) + (2*cost*dw/dlambda - v)/sint**2 c c and c c wlap = del2s(w) - (2*cost*dv/dlambda + w)/sint**2 c c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of idvw c c = 6 error in the specification of jdvw c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lvhsgc c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for ivlapgc c c ********************************************************************** c subroutine ivlapgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, +mdbc,ndbc,wvhsgc,lvhsgc,work,lwork,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhsgc(lvhsgc),work(lwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdbc .lt. mmax) return ierror = 8 if(ndbc .lt. nlat) return ierror = 9 c c set minimum and verify saved workspace length c idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid lsavmin = lzimn+lzimn+nlon+15 if (lvhsgc .lt. lsavmin) return c c set minimum and verify unsaved work space length c ierror = 10 mn = mmax*nlat*nt if(ityp.lt.3) then c no symmetry if (ityp.eq.0) then c br,bi,cr,ci nonzero lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+4*mn else c br,bi or cr,ci zero lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+2*mn end if else c symmetry if (ityp.eq.3 .or. ityp.eq.6) then c br,bi,cr,ci nonzero lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat else c br,bi or cr,ci zero lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat end if end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers for vector laplacian coefficients c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr else ibr = 1 ibi = 1 icr = ibi+mn ici = icr+mn end if ifn = ici + mn iwk = ifn + nlat if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then liwk = lwork-4*mn-nlat else liwk = lwork-2*mn-nlat end if call ivlapgc1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi, +cr,ci,wvhsgc,lvhsgc,work(iwk),liwk,ierror) return end subroutine ivlapgc1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw, +bivw,crvw,civw,mmax,fnn,mdbc,ndbc,br,bi,cr,ci,wvhsgc,lvhsgc, +wk,lwk,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension fnn(nlat),brvw(mmax,nlat,nt),bivw(mmax,nlat,nt) dimension crvw(mmax,nlat,nt),civw(mmax,nlat,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhsgc(lvhsgc),wk(lwk) c c preset coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = -1.0/(fn*(fn+1.)) 1 continue c c set (u,v) coefficients from br,bi,cr,ci c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then c c all coefficients needed c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax brvw(m,n,k) = 0.0 bivw(m,n,k) = 0.0 crvw(m,n,k) = 0.0 civw(m,n,k) = 0.0 4 continue 3 continue do 5 n=2,nlat brvw(1,n,k) = fnn(n)*br(1,n,k) bivw(1,n,k) = fnn(n)*bi(1,n,k) crvw(1,n,k) = fnn(n)*cr(1,n,k) civw(1,n,k) = fnn(n)*ci(1,n,k) 5 continue do 6 m=2,mmax do 7 n=m,nlat brvw(m,n,k) = fnn(n)*br(m,n,k) bivw(m,n,k) = fnn(n)*bi(m,n,k) crvw(m,n,k) = fnn(n)*cr(m,n,k) civw(m,n,k) = fnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then c c vorticity is zero so cr,ci=0 not used c do 12 k=1,nt do 13 n=1,nlat do 14 m=1,mmax brvw(m,n,k) = 0.0 bivw(m,n,k) = 0.0 14 continue 13 continue do 15 n=2,nlat brvw(1,n,k) = fnn(n)*br(1,n,k) bivw(1,n,k) = fnn(n)*bi(1,n,k) 15 continue do 16 m=2,mmax do 17 n=m,nlat brvw(m,n,k) = fnn(n)*br(m,n,k) bivw(m,n,k) = fnn(n)*bi(m,n,k) 17 continue 16 continue 12 continue else c c divergence is zero so br,bi=0 not used c do 22 k=1,nt do 23 n=1,nlat do 24 m=1,mmax crvw(m,n,k) = 0.0 civw(m,n,k) = 0.0 24 continue 23 continue do 25 n=2,nlat crvw(1,n,k) = fnn(n)*cr(1,n,k) civw(1,n,k) = fnn(n)*ci(1,n,k) 25 continue do 26 m=2,mmax do 27 n=m,nlat crvw(m,n,k) = fnn(n)*cr(m,n,k) civw(m,n,k) = fnn(n)*ci(m,n,k) 27 continue 26 continue 22 continue end if c c sythesize coefs into vector field (v,w) c call vhsgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw,bivw, + crvw,civw,mmax,nlat,wvhsgc,lvhsgc,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file ivlapgs.f c c this file includes documentation and code for c subroutine ivlapgs c c ... files which must be loaded with ivlapgs.f c c sphcom.f, hrfft.f, vhags.f, vhsgs.f, gaqd.f c c c subroutine ivlapgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c +mdbc,ndbc,wvhsgs,lvhsgs,work,lwork,ierror) c c given the vector spherical harmonic coefficients (br,bi,cr,ci) c precomputed by subroutine vhags for a vector field (vlap,wlap), c subroutine ivlapgs computes a vector field (v,w) whose vector c laplacian is (vlap,wlap). v,vlap are the colatitudinal c components and w,wlap are the east longitudinal components of c the vectors. (v,w) have the same symmetry or lack of symmetry c about the equator as (vlap,wlap). the input parameters ityp, c nt,mdbc,ndbc must have the same values used by vhags to compute c br,bi,cr,ci for (vlap,wlap). c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp this parameter should have the same value input to subroutine c vhags to compute the coefficients br,bi,cr, and ci for the c vector field (vlap,wlap). ityp is set as follows: c c = 0 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c arrays v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon. c c = 1 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon. the c vorticity of (vlap,wlap) is zero so the coefficients cr and c ci are zero and are not used. the vorticity of (v,w) is c also zero. c c c = 2 no symmetries exist in (vlap,wlap) about the equator. (v,w) c is computed and stored on the entire sphere in the arrays c w(i,j) and v(i,j) for i=1,...,nlat and j=1,...,nlon. the c divergence of (vlap,wlap) is zero so the coefficients br and c bi are zero and are not used. the divergence of (v,w) is c also zero. c c = 3 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays v(i,j), c w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays v(i,j),w(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. c c = 4 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays v(i,j), c w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays v(i,j),w(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the vorticity of (vlap, c wlap) is zero so the coefficients cr,ci are zero and c are not used. the vorticity of (v,w) is also zero. c c = 5 wlap is antisymmetric and vlap is symmetric about the c equator. consequently w is antisymmetric and v is symmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the divergence of (vlap, c wlap) is zero so the coefficients br,bi are zero and c are not used. the divergence of (v,w) is also zero. c c c = 6 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. c c = 7 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the vorticity of (vlap, c wlap) is zero so the coefficients cr,ci are zero and c are not used. the vorticity of (v,w) is also zero. c c = 8 wlap is symmetric and vlap is antisymmetric about the c equator. consequently w is symmetric and v is antisymmetric. c (v,w) is computed and stored on the northern hemisphere c only. if nlat is odd, storage is in the arrays w(i,j), c v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat c is even, storage is in the arrays w(i,j),v(i,j) for c i=1,...,nlat/2 and j=1,...,nlon. the divergence of (vlap, c wlap) is zero so the coefficients br,bi are zero and c are not used. the divergence of (v,w) is also zero. c c c nt nt is the number of vector fields (vlap,wlap). some computational c efficiency is obtained for multiple fields. in the program c that calls ivlapgs, the arrays v,w,br,bi,cr and ci can be c three dimensional corresponding to an indexed multiple vector c field. in this case multiple vector synthesis will be performed c to compute the (v,w) for each field (vlap,wlap). the third c index is the synthesis index which assumes the values k=1,...,nt. c for a single synthesis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 or c that all arrays are two dimensional. c c idvw the first dimension of the arrays w and v as it appears in c the program that calls ivlapgs. if ityp=0,1, or 2 then idvw c must be at least nlat. if ityp > 2 and nlat is even then idvw c must be at least nlat/2. if ityp > 2 and nlat is odd then idvw c must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays w and v as it appears in c the program that calls ivlapgs. jdvw must be at least nlon. c c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients of the c vector field (vlap,wlap) as computed by subroutine vhags. c br,bi,cr and ci must be computed by vhags prior to calling c ivlapgs. if ityp=1,4, or 7 then cr,ci are not used and can c be dummy arguments. if ityp=2,5, or 8 then br,bi are not c used and can be dummy arguments. c c mdbc the first dimension of the arrays br,bi,cr and ci as it c appears in the program that calls ivlapgs. mdbc must be c at least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndbc the second dimension of the arrays br,bi,cr and ci as it c appears in the program that calls ivlapgs. ndbc must be at c least nlat. c c wvhsgs an array which must be initialized by subroutine vhsgsi. c once initialized, wvhsgsi c can be used repeatedly by ivlapgs as long as nlat and nlon c remain unchanged. wvhsgs must not be altered between calls c of ivlapgs. c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls ivlapgs. let c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c let c c lsavmin = (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c then lvhsgs must be greater than or equal to lsavmin c (see ierror=9 below). c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls ivlapgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if ityp .le. 2 then c c (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1) c c or if ityp .gt. 2 then c c (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1) c c will suffice as a length for lwork. c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a vector field whose vector laplacian is (vlap,wlap). c w(i,j) is the east longitude and v(i,j) is the colatitudinal c component of the vector. v(i,j) and w(i,j) are given on the c sphere at the guassian colatitude theta(i) for i=1,...,nlat c and east longitude lambda(j)=(j-1)*2*pi/nlon for j = 1,...,nlon. c let cost and sint be the cosine and sine at colatitude theta. c let d( )/dlambda and d( )/dtheta be the first order partial c derivatives in longitude and colatitude. let sf be either v c or w. define: c c del2s(sf) = [d(sint*d(sf)/dtheta)/dtheta + c 2 2 c d (sf)/dlambda /sint]/sint c c then the vector laplacian of (v,w) in (vlap,wlap) satisfies c c vlap = del2s(v) + (2*cost*dw/dlambda - v)/sint**2 c c and c c wlap = del2s(w) - (2*cost*dv/dlambda + w)/sint**2 c c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of idvw c c = 6 error in the specification of jdvw c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lvhsgs c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for ivlapgs c c ********************************************************************** c subroutine ivlapgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, +mdbc,ndbc,wvhsgs,lvhsgs,work,lwork,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhsgs(lvhsgs),work(lwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdbc .lt. mmax) return ierror = 8 if(ndbc .lt. nlat) return ierror = 9 c c set minimum and verify saved workspace length c idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid lsavmin = lzimn+lzimn+nlon+15 if (lvhsgs .lt. lsavmin) return c c set minimum and verify unsaved work space length c mn = mmax*nlat*nt l2 = (nlat+1)/2 l1 = min0(nlat,(nlon+1)/2) if (ityp .le. 2) then lwkmin = (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1) else lwkmin = (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers for vector laplacian coefficients c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr else ibr = 1 ibi = 1 icr = ibi+mn ici = icr+mn end if ifn = ici + mn iwk = ifn + nlat if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then liwk = lwork-4*mn-nlat else liwk = lwork-2*mn-nlat end if call ivlapgs1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi, +cr,ci,wvhsgs,lvhsgs,work(iwk),liwk,ierror) return end subroutine ivlapgs1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw, +bivw,crvw,civw,mmax,fnn,mdbc,ndbc,br,bi,cr,ci,wsave,lsave, +wk,lwk,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt) dimension fnn(nlat),brvw(mmax,nlat,nt),bivw(mmax,nlat,nt) dimension crvw(mmax,nlat,nt),civw(mmax,nlat,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wsave(lsave),wk(lwk) c c preset coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = -1.0/(fn*(fn+1.)) 1 continue c c set (u,v) coefficients from br,bi,cr,ci c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then c c all coefficients needed c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax brvw(m,n,k) = 0.0 bivw(m,n,k) = 0.0 crvw(m,n,k) = 0.0 civw(m,n,k) = 0.0 4 continue 3 continue do 5 n=2,nlat brvw(1,n,k) = fnn(n)*br(1,n,k) bivw(1,n,k) = fnn(n)*bi(1,n,k) crvw(1,n,k) = fnn(n)*cr(1,n,k) civw(1,n,k) = fnn(n)*ci(1,n,k) 5 continue do 6 m=2,mmax do 7 n=m,nlat brvw(m,n,k) = fnn(n)*br(m,n,k) bivw(m,n,k) = fnn(n)*bi(m,n,k) crvw(m,n,k) = fnn(n)*cr(m,n,k) civw(m,n,k) = fnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then c c vorticity is zero so cr,ci=0 not used c do 12 k=1,nt do 13 n=1,nlat do 14 m=1,mmax brvw(m,n,k) = 0.0 bivw(m,n,k) = 0.0 14 continue 13 continue do 15 n=2,nlat brvw(1,n,k) = fnn(n)*br(1,n,k) bivw(1,n,k) = fnn(n)*bi(1,n,k) 15 continue do 16 m=2,mmax do 17 n=m,nlat brvw(m,n,k) = fnn(n)*br(m,n,k) bivw(m,n,k) = fnn(n)*bi(m,n,k) 17 continue 16 continue 12 continue else c c divergence is zero so br,bi=0 not used c do 22 k=1,nt do 23 n=1,nlat do 24 m=1,mmax crvw(m,n,k) = 0.0 civw(m,n,k) = 0.0 24 continue 23 continue do 25 n=2,nlat crvw(1,n,k) = fnn(n)*cr(1,n,k) civw(1,n,k) = fnn(n)*ci(1,n,k) 25 continue do 26 m=2,mmax do 27 n=m,nlat crvw(m,n,k) = fnn(n)*cr(m,n,k) civw(m,n,k) = fnn(n)*ci(m,n,k) 27 continue 26 continue 22 continue end if c c sythesize coefs into vector field (v,w) c call vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw,bivw, + crvw,civw,mmax,nlat,wsave,lsave,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file ivrtec.f c c this file includes documentation and code for c subroutine ivrtec i c c ... files which must be loaded with ivrtec.f c c sphcom.f, hrfft.f, vhsec.f,shaec.f c c subroutine ivrtec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsec,lvhsec,work,lwork,pertrb,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shaec for a scalar array vort, subroutine ivrtec computes c a divergence free vector field (v,w) whose vorticity is vt - pertrb. c w is the east longitude component and v is the colatitudinal component. c pertrb is a constant which must be subtracted from vort for (v,w) to c exist (see the description of pertrb below). usually pertrb is zero c or small relative to vort. the divergence of (v,w), as computed by c ivrtec, is the zero scalar field. i.e., v(i,j) and w(i,j) are the c colaatitudinal and east longitude velocity components at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon. c c the c c vorticity(v(i,j),w(i,j)) c c = [-dv/dlambda + d(sint*w)/dtheta]/sint c c = vort(i,j) - pertrb c c and c c divergence(v(i,j),w(i,j)) c c = [d(sint*v)/dtheta + dw/dlambda]/sint c c = 0.0 c c where sint = sin(theta(i)). required associated legendre polynomials c are recomputed rather than stored as they are in subroutine ivrtes. c c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shaec to compute the arrays a and b. isym c determines whether (v,w) are computed on the full or half c sphere as follows: c c = 0 c vort is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c vort is symmetric about the equator. in this case w is c antiymmetric and v is symmetric about the equator. v c and w are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c vort is antisymmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt in the program that calls ivrtec, nt is the number of vorticity c and vector fields. some computational efficiency is obtained c for multiple fields. the arrays a,b,v, and w can be three c dimensional and pertrb can be one dimensional corresponding c to an indexed multiple array vort. in this case, multiple vector c synthesis will be performed to compute each vector field. the c third index for a,b,v,w and first for pertrb is the synthesis c index which assumes the values k=1,...,nt. for a single c synthesis set nt=1. the description of the remaining parameters c is simplified by assuming that nt=1 or that a,b,v,w are two c dimensional and pertrb is a constant. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls ivrtec. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls ivrtec. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the vorticity array vort as computed by subroutine shaec. c *** a,b must be computed by shaec prior to calling ivrtec. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls ivrtec (and shaec). mdab must be at c least min0(nlat,(nlon+2/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls ivrtec (and shaec). ndab must be at c least nlat. c c c wvhsec an array which must be initialized by subroutine vhseci. c once initialized c wvhsec can be used repeatedly by ivrtec as long as nlon c and nlat remain unchanged. wvhsec must not be altered c between calls of ivrtec. c c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls ivrtec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls ivrtec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2 ) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon) + 2*nt*l1 + 1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*nt*l1+1) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a divergence free vector field whose vorticity is c vort - pertrb at the lattitude point theta(i)=pi/2-(i-1)*pi/(nlat-1) c and longitude point lambda(j)=(j-1)*2*pi/nlon. w is the east c longitude component and v is the colatitudinal component. the c indices for v and w are defined at the input parameter isym. c the divergence of (v,w) is the zero scalar field. c c pertrb a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). vort - pertrb is a scalar c field which can be the vorticity of a vector field (v,w). c pertrb is related to the scalar harmonic coefficients a,b c of vort (computed by shaec) by the formula c c pertrb = a(1,1)/(2.*sqrt(2.)) c c an unperturbed vort can be the vorticity of a vector field c only if a(1,1) is zero. if a(1,1) is nonzero (flagged by c pertrb nonzero) then subtracting pertrb from vort yields a c scalar field for which a(1,1) is zero. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsec c = 10 error in the specification of lwork c ********************************************************************** c c subroutine ivrtec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, + wvhsec,lvhsec,work,lwork,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsec(lvhsec),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhsec .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return ierror = 0 c c set work space pointers c icr = 1 ici = icr + mn is = ici + mn iwk = is + nlat liwk = lwork-2*mn-nlat call ivtec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(icr),work(ici), + mmax,work(is),mdab,ndab,a,b,wvhsec,lvhsec,work(iwk), + liwk,pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file ivrtes.f c c this file includes documentation and code for c subroutine ivrtes i c c ... files which must be loaded with ivrtes.f c c sphcom.f, hrfft.f, vhses.f,shaes.f c c c subroutine ivrtes(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhses,lvhses,work,lwork,pertrb,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shaes for a scalar array vort, subroutine ivrtes computes c a divergence free vector field (v,w) whose vorticity is vort - pertrb. c w is the east longitude component and v is the colatitudinal component. c pertrb is a constant which must be subtracted from vort for (v,w) to c exist (see the description of pertrb below). usually pertrb is zero c or small relative to vort. the divergence of (v,w), as computed by c ivrtes, is the zero scalar field. i.e., v(i,j) and w(i,j) are the c colaatitudinal and east longitude velocity components at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon. c c the c c vorticity(v(i,j),w(i,j)) c c = [-dv/dlambda + d(sint*w)/dtheta]/sint c c = vort(i,j) - pertrb c c and c c divergence(v(i,j),w(i,j)) c c = [d(sint*v)/dtheta + dw/dlambda]/sint c c = 0.0 c c where sint = sin(theta(i)). required associated legendre polynomials c are stored rather than recomputed as they are in subroutine ivrtec. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shaes to compute the arrays a and b. isym c determines whether (v,w) are computed on the full or half c sphere as follows: c c = 0 c vort is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c vort is symmetric about the equator. in this case w is c antiymmetric and v is symmetric about the equator. v c and w are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c vort is antisymmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt in the program that calls ivrtes, nt is the number of vorticity c and vector fields. some computational efficiency is obtained c for multiple fields. the arrays a,b,v, and w can be three c dimensional and pertrb can be one dimensional corresponding c to an indexed multiple array vort. in this case, multiple vector c synthesis will be performed to compute each vector field. the c third index for a,b,v,w and first for pertrb is the synthesis c index which assumes the values k=1,...,nt. for a single c synthesis set nt=1. the description of the remaining parameters c is simplified by assuming that nt=1 or that a,b,v,w are two c dimensional and pertrb is a constant. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls ivrtes. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls ivrtes. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the vorticity array vort as computed by subroutine shaes. c *** a,b must be computed by shaes prior to calling ivrtes. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls ivrtes (and shaes). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls ivrtes (and shaes). ndab must be at c least nlat. c c c wvhses an array which must be initialized by subroutine vhsesi. c once initialized c wvhses can be used repeatedly by ivrtes as long as nlon c and nlat remain unchanged. wvhses must not be altered c between calls of ivrtes. c c c lvhses the dimension of the array wvhses as it appears in the c program that calls ivrtes. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhses must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls ivrtes. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 then lwork must be at least c c nlat*((2*nt+1)*nlon+2*l1*nt+1) c c if isym = 1 or 2 then lwork must be at least c c (2*nt+1)*l2*nlon+nlat*(2*nt*l1+1) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a divergence free vector field whose vorticity is c vort - pertrb at the lattitude point theta(i)=pi/2-(i-1)*pi/(nlat-1) c and longitude point lambda(j)=(j-1)*2*pi/nlon. w is the east c longitude component and v is the colatitudinal component. the c indices for v and w are defined at the input parameter isym. c the divergence of (v,w) is the zero scalar field. c c pertrb a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). vort - pertrb is a scalar c field which can be the vorticity of a vector field (v,w). c pertrb is related to the scalar harmonic coefficients a,b c of vort (computed by shaes) by the formula c c pertrb = a(1,1)/(2.*sqrt(2.)) c c an unperturbed vort can be the vorticity of a vector field c only if a(1,1) is zero. if a(1,1) is nonzero (flagged by c pertrb nonzero) then subtracting pertrb from vort yields a c scalar field for which a(1,1) is zero. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhses c = 10 error in the specification of lwork c ********************************************************************** c c subroutine ivrtes(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, + wvhses,lvhses,work,lwork,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhses(lvhses),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 lwmin = (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return ierror = 0 c c set work space pointers c icr = 1 ici = icr + mn is = ici + mn iwk = is + nlat liwk = lwork-2*mn-nlat call ivtes1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(icr),work(ici), + mmax,work(is),mdab,ndab,a,b,wvhses,lvhses,work(iwk), + liwk,pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file ivrtgc.f c c this file includes documentation and code for c subroutine ivrtgc i c c ... files which must be loaded with ivrtgc.f c c sphcom.f, hrfft.f, vhsgc.f,shagc.f, gaqd.f c c c subroutine ivrtgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsgc,lvhsgc,work,lwork,pertrb,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shagc for a scalar array vt, subroutine ivrtgc computes c a divergence free vector field (v,w) whose vorticity is vt - pertrb. c w is the east longitude component and v is the colatitudinal component. c pertrb is a constant which must be subtracted from vt for (v,w) to c exist (see the description of pertrb below). usually pertrb is zero c or small relative to vort. the divergence of (v,w), as computed by c ivrtgc, is the zero scalar field. v(i,j) and w(i,j) are the c colatitudinal and east longitude velocity components at gaussian c colatitude theta(i) (see nlat as input parameter) and longitude c lambda(j) = (j-1)*2*pi/nlon. the c c vorticity(v(i,j),w(i,j)) c c = [-dv/dlambda + d(sint*w)/dtheta]/sint c c = vort(i,j) - pertrb c c and c c divergence(v(i,j),w(i,j)) c c = [d(sint*v)/dtheta + dw/dlambda]/sint c c = 0.0 c c where sint = sin(theta(i)). required associated legendre polynomials c are recomputed rather than stored as they are in subroutine ivrtgs. c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shagc to compute the arrays a and b. isym c determines whether (v,w) are computed on the full or half c sphere as follows: c c = 0 c vt is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c vt is symmetric about the equator. in this case w is c antiymmetric and v is symmetric about the equator. v c and w are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c vt is antisymmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt in the program that calls ivrtgc, nt is the number of vorticity c and vector fields. some computational efficiency is obtained c for multiple fields. the arrays a,b,v, and w can be three c dimensional and pertrb can be one dimensional corresponding c to an indexed multiple array vort. in this case, multiple vector c synthesis will be performed to compute each vector field. the c third index for a,b,v,w and first for pertrb is the synthesis c index which assumes the values k=1,...,nt. for a single c synthesis set nt=1. the description of the remaining parameters c is simplified by assuming that nt=1 or that a,b,v,w are two c dimensional and pertrb is a constant. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls ivrtgc. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls ivrtgc. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the vorticity array vt as computed by subroutine shagc. c *** a,b must be computed by shagc prior to calling ivrtgc. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls ivrtgcs (and shagc). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls ivrtgc (and shagc). ndab must be at c least nlat. c c c wvhsgc an array which must be initialized by subroutine vhsgci. c once initialized c wvhsgc can be used repeatedly by ivrtgc as long as nlon c and nlat remain unchanged. wvhsgs must not be altered c between calls of ivrtgc. c c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls ivrtgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgc be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls ivrtgc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon) + 2*nt*l1 + 1) c c if isym = 1 or 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(2*nt*l1+1) c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a divergence free vector field whose vorticity is c vt - pertrb at the gaussian colatitude point theta(i) c and longitude point lambda(j)=(j-1)*2*pi/nlon. w is the east c longitude component and v is the colatitudinal component. the c indices for v and w are defined at the input parameter isym. c the divergence of (v,w) is the zero scalar field. c c pertrb a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). vt - pertrb is a scalar c field which can be the vorticity of a vector field (v,w). c pertrb is related to the scalar harmonic coefficients a,b c of vt (computed by shagc) by the formula c c pertrb = a(1,1)/(2.*sqrt(2.)) c c an unperturbed vt can be the vorticity of a vector field c only if a(1,1) is zero. if a(1,1) is nonzero (flagged by c pertrb nonzero) then subtracting pertrb from vt yields a c scalar field for which a(1,1) is zero. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgc c = 10 error in the specification of lwork c ********************************************************************** c c subroutine ivrtgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, + wvhsgc,lvhsgc,work,lwork,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsgc(lvhsgc),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c c check save work space length c l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin = 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 if (lvhsgc .lt. lwmin) return c if(lvhsgc .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return ierror = 0 c c set work space pointers c icr = 1 ici = icr + mn is = ici + mn iwk = is + nlat liwk = lwork-2*mn-nlat call ivtgc1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(icr),work(ici), + mmax,work(is),mdab,ndab,a,b,wvhsgc,lvhsgc,work(iwk), + liwk,pertrb,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file ivrtgs.f c c this file includes documentation and code for c subroutine ivrtgs c c ... files which must be loaded with ivrtgs.f c c sphcom.f, hrfft.f, vhsgs.f,shags.f, gaqd.f c c c subroutine ivrtgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, c + wvhsgs,lvhsgs,work,lwork,pertrb,ierror) c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shags for a scalar array vt, subroutine ivrtgs computes c a divergence free vector field (v,w) whose vorticity is vt - pertrb. c w is the east longitude component and v is the colatitudinal component. c pertrb is a constant which must be subtracted from vt for (v,w) to c exist (see the description of pertrb below). usually pertrb is zero c or small relative to vt. the divergence of (v,w), as computed by c ivrtgs, is the zero scalar field. v(i,j) and w(i,j) are the c colatitudinal and east longitude velocity components at gaussian c colatitude theta(i) (see nlat as input parameter) and longitude c lambda(j) = (j-1)*2*pi/nlon. the c c vorticity(v(i,j),w(i,j)) c c = [-dv/dlambda + d(sint*w)/dtheta]/sint c c = vort(i,j) - pertrb c c and c c divergence(v(i,j),w(i,j)) c c = [d(sint*v)/dtheta + dw/dlambda]/sint c c = 0.0 c c where sint = sin(theta(i)). required associated legendre polynomials c are stored rather than recomputed as they are in subroutine ivrtgc. c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym this has the same value as the isym that was input to c subroutine shags to compute the arrays a and b. isym c determines whether (v,w) are computed on the full or half c sphere as follows: c c = 0 c vt is not symmetric about the equator. in this case c the vector field (v,w) is computed on the entire sphere. c i.e., in the arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c vt is symmetric about the equator. in this case w is c antiymmetric and v is symmetric about the equator. v c and w are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c c vt is antisymmetric about the equator. in this case w is c symmetric and v is antisymmetric about the equator. w c and v are computed on the northern hemisphere only. i.e., c if nlat is odd they are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even they are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c c nt in the program that calls ivrtgs, nt is the number of vorticity c and vector fields. some computational efficiency is obtained c for multiple fields. the arrays a,b,v, and w can be three c dimensional and pertrb can be one dimensional corresponding c to an indexed multiple array vt. in this case, multiple vector c synthesis will be performed to compute each vector field. the c third index for a,b,v,w and first for pertrb is the synthesis c index which assumes the values k=1,...,nt. for a single c synthesis set nt=1. the description of the remaining parameters c is simplified by assuming that nt=1 or that a,b,v,w are two c dimensional and pertrb is a constant. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls ivrtgs. if isym = 0 then idvw c must be at least nlat. if isym = 1 or 2 and nlat is c even then idvw must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls ivrtgs. jdvw must be at least nlon. c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the vorticity array vt as computed by subroutine shags. c *** a,b must be computed by shags prior to calling ivrtgs. c c mdab the first dimension of the arrays a and b as it appears in c the program that calls ivrtgs (and shags). mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears in c the program that calls ivrtgs (and shags). ndab must be at c least nlat. c c c wvhsgs an array which must be initialized by subroutine vhsgsi. c once initialized c wvhsgs can be used repeatedly by ivrtgs as long as nlon c and nlat remain unchanged. wvhsgs must not be altered c between calls of ivrtgs. c c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls ivrtgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgs must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls ivrtgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 then lwork must be at least c c (2*nt+1)*nlat*nlon + nlat*(2*nt*l1+1) c c if isym = 1 or 2 then lwork must be at least c c (2*nt+1)*l2*nlon + nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c v,w two or three dimensional arrays (see input parameter nt) that c contain a divergence free vector field whose vorticity is c vt - pertrb at the gaussian colatitude point theta(i) c and longitude point lambda(j)=(j-1)*2*pi/nlon. w is the east c longitude component and v is the colatitudinal component. the c indices for v and w are defined at the input parameter isym. c the divergence of (v,w) is the zero scalar field. c c pertrb a nt dimensional array (see input parameter nt and assume nt=1 c for the description that follows). vt - pertrb is a scalar c field which can be the vorticity of a vector field (v,w). c pertrb is related to the scalar harmonic coefficients a,b c of vt (computed by shags) by the formula c c pertrb = a(1,1)/(2.*sqrt(2.)) c c an unperturbed vt can be the vorticity of a vector field c only if a(1,1) is zero. if a(1,1) is nonzero (flagged by c pertrb nonzero) then subtracting pertrb from vt yields a c scalar field for which a(1,1) is zero. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgs c = 10 error in the specification of lwork c ********************************************************************** c c subroutine ivrtgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab, + wvhsgs,lvhsgs,work,lwork,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wvhsgs(lvhsgs),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idvw.lt.nlat) .or. + (isym.ne.0 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. min0(nlat,(nlon+2)/2)) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c lzz1 = 2*nlat*imid c labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c if(lvhsgs .lt. 2*(lzz1+labc)+nlon+15) return idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lvhsgs .lt. lzimn+lzimn+nlon+15) return ierror = 10 c c verify unsaved work space length c mn = mmax*nlat*nt if(isym.ne.0 .and. lwork .lt. +nlat*(2*nt*nlon+max0(6*imid,nlon))+2*mn+nlat) return if(isym.eq.0 .and. lwork .lt. +imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat) return ierror = 0 c c set work space pointers c icr = 1 ici = icr + mn is = ici + mn iwk = is + nlat liwk = lwork-2*mn-nlat call ivtgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,work(icr),work(ici), + mmax,work(is),mdab,ndab,a,b,wvhsgs,lvhsgs,work(iwk), + liwk,pertrb,ierror) return end subroutine ivtec1(nlat,nlon,isym,nt,v,w,idvw,jdvw,cr,ci,mmax, +sqnn,mdab,ndab,a,b,wsav,lwsav,wk,lwk,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wsav(lwsav),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set vorticity field perturbation adjustment c pertrb(k) = a(1,1,k)/(2.*sqrt(2.)) c c preset cr,ci to 0.0 c do 3 n=1,nlat do 4 m=1,mmax cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat cr(1,n,k) = a(1,n,k)/sqnn(n) ci(1,n,k) = b(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat cr(m,n,k) = a(m,n,k)/sqnn(n) ci(m,n,k) = b(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis with divergence=0 c if (isym.eq.0) then ityp = 2 else if (isym.eq.1) then ityp = 5 else if (isym.eq.2) then ityp = 8 end if c c vector sythesize cr,ci into divergence free vector field (v,w) c call vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wsav,lwsav,wk,lwk,ierror) return end subroutine ivtes1(nlat,nlon,isym,nt,v,w,idvw,jdvw,cr,ci,mmax, +sqnn,mdab,ndab,a,b,wsav,lwsav,wk,lwk,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wsav(lwsav),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set vorticity field perturbation adjustment c pertrb(k) = a(1,1,k)/(2.*sqrt(2.)) c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat cr(1,n,k) = a(1,n,k)/sqnn(n) ci(1,n,k) = b(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat cr(m,n,k) = a(m,n,k)/sqnn(n) ci(m,n,k) = b(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis with divergence=0 c if (isym.eq.0) then ityp = 2 else if (isym.eq.1) then ityp = 5 else if (isym.eq.2) then ityp = 8 end if c c vector sythesize cr,ci into divergence free vector field (v,w) c call vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wsav,lwsav,wk,lwk,ierror) return end subroutine ivtgc1(nlat,nlon,isym,nt,v,w,idvw,jdvw,cr,ci,mmax, +sqnn,mdab,ndab,a,b,wsav,lsav,wk,lwk,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wsav(lsav),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set vorticity field perturbation adjustment c pertrb(k) = a(1,1,k)/(2.*sqrt(2.)) c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat cr(1,n,k) = a(1,n,k)/sqnn(n) ci(1,n,k) = b(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat cr(m,n,k) = a(m,n,k)/sqnn(n) ci(m,n,k) = b(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis with divergence=0 c if (isym.eq.0) then ityp = 2 else if (isym.eq.1) then ityp = 5 else if (isym.eq.2) then ityp = 8 end if c c vector sythesize cr,ci into divergence free vector field (v,w) c call vhsgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wsav,lsav,wk,lwk,ierror) return end subroutine ivtgs1(nlat,nlon,isym,nt,v,w,idvw,jdvw,cr,ci,mmax, +sqnn,mdab,ndab,a,b,wsav,lsav,wk,lwk,pertrb,ierror) dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt),pertrb(nt) dimension cr(mmax,nlat,nt),ci(mmax,nlat,nt),sqnn(nlat) dimension a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wsav(lsav),wk(lwk) c c preset coefficient multiplyers in vector c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute multiple vector fields coefficients c do 2 k=1,nt c c set vorticity field perturbation adjustment c pertrb(k) = a(1,1,k)/(2.*sqrt(2.)) c c preset br,bi to 0.0 c do 3 n=1,nlat do 4 m=1,mmax cr(m,n,k) = 0.0 ci(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat cr(1,n,k) = a(1,n,k)/sqnn(n) ci(1,n,k) = b(1,n,k)/sqnn(n) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat cr(m,n,k) = a(m,n,k)/sqnn(n) ci(m,n,k) = b(m,n,k)/sqnn(n) 7 continue 6 continue 2 continue c c set ityp for vector synthesis with divergence=0 c if (isym.eq.0) then ityp = 2 else if (isym.eq.1) then ityp = 5 else if (isym.eq.2) then ityp = 8 end if c c vector sythesize cr,ci into divergence free vector field (v,w) c call vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mmax,nlat,wsav,lsav,wk,lwk,ierror) return end subroutine legin(mode,l,nlat,m,w,pmn,km) c this subroutine computes legendre polynomials for n=m,...,l-1 c and i=1,...,late (late=((nlat+mod(nlat,2))/2)gaussian grid c in pmn(n+1,i,km) using swarztrauber's recursion formula. c the vector w contains quantities precomputed in shigc. c legin must be called in the order m=0,1,...,l-1 c (e.g., if m=10 is sought it must be preceded by calls with c m=0,1,2,...,9 in that order) dimension w(1),pmn(1) c set size of pole to equator gaussian grid late = (nlat+mod(nlat,2))/2 c partition w (set pointers for p0n,p1n,abel,bbel,cbel,pmn) i1 = 1+nlat i2 = i1+nlat*late i3 = i2+nlat*late i4 = i3+(2*nlat-l)*(l-1)/2 i5 = i4+(2*nlat-l)*(l-1)/2 call legin1(mode,l,nlat,late,m,w(i1),w(i2),w(i3),w(i4), 1 w(i5),pmn,km) return end subroutine legin1(mode,l,nlat,late,m,p0n,p1n,abel,bbel,cbel, 1 pmn,km) dimension p0n(nlat,late),p1n(nlat,late) dimension abel(1),bbel(1),cbel(1),pmn(nlat,late,3) data km0,km1,km2/ 1,2,3/ save km0,km1,km2 c define index function used in storing triangular c arrays for recursion coefficients (functions of (m,n)) c for 2.le.m.le.n-1 and 2.le.n.le.l-1 indx(m,n) = (n-1)*(n-2)/2+m-1 c for l.le.n.le.nlat and 2.le.m.le.l imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1 c set do loop indices for full or half sphere ms = m+1 ninc = 1 if (mode.eq.1) then c only compute pmn for n-m odd ms = m+2 ninc = 2 else if (mode.eq.2) then c only compute pmn for n-m even ms = m+1 ninc = 2 end if if (m.gt.1) then do 100 np1=ms,nlat,ninc n = np1-1 imn = indx(m,n) if (n.ge.l) imn = imndx(m,n) do 100 i=1,late pmn(np1,i,km0) = abel(imn)*pmn(n-1,i,km2) 1 +bbel(imn)*pmn(n-1,i,km0) 2 -cbel(imn)*pmn(np1,i,km2) 100 continue else if (m.eq.0) then do 101 np1=ms,nlat,ninc do 101 i=1,late pmn(np1,i,km0) = p0n(np1,i) 101 continue else if (m.eq.1) then do 102 np1=ms,nlat,ninc do 102 i=1,late pmn(np1,i,km0) = p1n(np1,i) 102 continue end if c permute column indices c km0,km1,km2 store m,m-1,m-2 columns kmt = km0 km0 = km2 km2 = km1 km1 = kmt c set current m index in output param km km = kmt return end c subroutine lfim (init,theta,l,n,nm,pb,id,wlfim) c c dimension of theta(l), pb(id,nm+1), wlfim(4*l*(nm+1)) c arguments c c purpose given n and l, routine lfim calculates c the normalized associated legendre functions c pbar(n,m,theta) for m=0,...,n and theta(i) c for i=1,...,l where c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m) c /(2*factorial(n+m)))*sin(theta)**m/(2**n* c factorial(n)) times the (n+m)th derivative of c (x**2-1)**n with respect to x=cos(theta) c c usage call lfim (init,theta,l,n,nm,pb,id,wlfim) c c arguments c on input init c = 0 c initialization only - using parameters c l, nm and array theta, subroutine lfim c initializes array wlfim for subsequent c use in the computation of the associated c legendre functions pb. initialization c does not have to be repeated unless c l, nm, or array theta are changed. c = 1 c subroutine lfim uses the array wlfim that c was computed with init = 0 to compute pb. c c theta c an array that contains the colatitudes c at which the associated legendre functions c will be computed. the colatitudes must be c specified in radians. c c l c the length of the theta array. lfim is c vectorized with vector length l. c c n c nonnegative integer, less than nm, specifying c degree of pbar(n,m,theta). subroutine lfim c must be called starting with n=0. n must be c incremented by one in subsequent calls and c must not exceed nm. c c nm c the maximum value of n and m c c id c the first dimension of the two dimensional c array pb as it appears in the program that c calls lfim. (see output parameter pb) c c wlfim c an array with length 4*l*(nm+1) which c must be initialized by calling lfim c with init=0 (see parameter init) it c must not be altered between calls to c lfim. c c c on output pb c a two dimensional array with first c dimension id in the program that calls c lfim. the second dimension of pb must c be at least nm+1. starting with n=0 c lfim is called repeatedly with n being c increased by one between calls. on each c call, subroutine lfim computes c = pbar(m,n,theta(i)) for m=0,...,n and c i=1,...l. c c wlfim c array containing values which must not c be altered unless l, nm or the array theta c are changed in which case lfim must be c called with init=0 to reinitialize the c wlfim array. c c special conditions n must be increased by one between calls c of lfim in which n is not zero. c c precision single c c c algorithm routine lfim calculates pbar(n,m,theta) using c a four term recurrence relation. (unpublished c notes by paul n. swarztrauber) c subroutine lfim (init,theta,l,n,nm,pb,id,wlfim) dimension pb(1) ,wlfim(1) c c total length of wlfim is 4*l*(nm+1) c lnx = l*(nm+1) iw1 = lnx+1 iw2 = iw1+lnx iw3 = iw2+lnx call lfim1(init,theta,l,n,nm,id,pb,wlfim,wlfim(iw1), 1 wlfim(iw2),wlfim(iw3),wlfim(iw2)) return end subroutine lfim1(init,theta,l,n,nm,id,p3,phz,ph1,p1,p2,cp) dimension p1(l,1) ,p2(l,1) ,p3(id,1) ,phz(l,1) , 1 ph1(l,1) ,cp(1) ,theta(1) nmp1 = nm+1 if(init .ne. 0) go to 5 ssqrt2 = 1./sqrt(2.) do 10 i=1,l phz(i,1) = ssqrt2 10 continue do 15 np1=2,nmp1 nh = np1-1 call alfk(nh,0,cp) do 16 i=1,l call lfpt(nh,0,theta(i),cp,phz(i,np1)) 16 continue call alfk(nh,1,cp) do 17 i=1,l call lfpt(nh,1,theta(i),cp,ph1(i,np1)) 17 continue 15 continue return 5 if(n .gt. 2) go to 60 if(n-1)25,30,35 25 do 45 i=1,l p3(i,1)=phz(i,1) 45 continue return 30 do 50 i=1,l p3(i,1) = phz(i,2) p3(i,2) = ph1(i,2) 50 continue return 35 sq5s6 = sqrt(5./6.) sq1s6 = sqrt(1./6.) do 55 i=1,l p3(i,1) = phz(i,3) p3(i,2) = ph1(i,3) p3(i,3) = sq5s6*phz(i,1)-sq1s6*p3(i,1) p1(i,1) = phz(i,2) p1(i,2) = ph1(i,2) p2(i,1) = phz(i,3) p2(i,2) = ph1(i,3) p2(i,3) = p3(i,3) 55 continue return 60 nm1 = n-1 np1 = n+1 fn = float(n) tn = fn+fn cn = (tn+1.)/(tn-3.) do 65 i=1,l p3(i,1) = phz(i,np1) p3(i,2) = ph1(i,np1) 65 continue if(nm1 .lt. 3) go to 71 do 70 mp1=3,nm1 m = mp1-1 fm = float(m) fnpm = fn+fm fnmm = fn-fm temp = fnpm*(fnpm-1.) cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp) dd = sqrt(cn*fnmm*(fnmm-1.)/temp) ee = sqrt((fnmm+1.)*(fnmm+2.)/temp) do 70 i=1,l p3(i,mp1) = cc*p1(i,mp1-2)+dd*p1(i,mp1)-ee*p3(i,mp1-2) 70 continue 71 fnpm = fn+fn-1. temp = fnpm*(fnpm-1.) cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp) ee = sqrt(6./temp) do 75 i=1,l p3(i,n) = cc*p1(i,n-2)-ee*p3(i,n-2) 75 continue fnpm = fn+fn temp = fnpm*(fnpm-1.) cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp) ee = sqrt(2./temp) do 80 i=1,l p3(i,n+1) = cc*p1(i,n-1)-ee*p3(i,n-1) 80 continue do 90 mp1=1,np1 do 90 i=1,l p1(i,mp1) = p2(i,mp1) p2(i,mp1) = p3(i,mp1) 90 continue return end c subroutine lfin (init,theta,l,m,nm,pb,id,wlfin) c c dimension of theta(l), pb(id,nm+1), wlfin(4*l*(nm+1)) c arguments c c purpose given m and l, routine lfin calculates c the normalized associated legendre functions c pbar(n,m,theta) for n=m,...,nm and theta(i) c for i=1,...,l where c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m) c /(2*factorial(n+m)))*sin(theta)**m/(2**n* c factorial(n)) times the (n+m)th derivative of c (x**2-1)**n with respect to x=cos(theta) c c usage call lfin (init,theta,l,m,nm,pb,id,wlfin) c c arguments c on input init c = 0 c initialization only - using parameters c l, nm and the array theta, subroutine lfin c initializes the array wlfin for subsequent c use in the computation of the associated c legendre functions pb. initialization does c not have to be repeated unless l, nm or c the array theta are changed. c = 1 c subroutine lfin uses the array wlfin that c was computed with init = 0 to compute pb c c theta c an array that contains the colatitudes c at which the associated legendre functions c will be computed. the colatitudes must be c specified in radians. c c l c the length of the theta array. lfin is c vectorized with vector length l. c c m c nonnegative integer, less than nm, specifying c degree of pbar(n,m,theta). subroutine lfin c must be called starting with n=0. n must be c incremented by one in subsequent calls and c must not exceed nm. c c nm c the maximum value of n and m c c id c the first dimension of the two dimensional c array pb as it appears in the program that c calls lfin. (see output parameter pb) c c wlfin c an array with length 4*l*(nm+1) which c must be initialized by calling lfin c with init=0 (see parameter init) it c must not be altered between calls to c lfin. c c c on output pb c a two dimensional array with first c dimension id in the program that calls c lfin. the second dimension of pb must c be at least nm+1. starting with m=0 c lfin is called repeatedly with m being c increased by one between calls. on each c call, subroutine lfin computes pb(i,n+1) c = pbar(m,n,theta(i)) for n=m,...,nm and c i=1,...l. c c wlfin c array containing values which must not c be altered unless l, nm or the array theta c are changed in which case lfin must be c called with init=0 to reinitialize the c wlfin array. c c special conditions m must be increased by one between calls c of lfin in which m is not zero. c c precision single c c algorithm routine lfin calculates pbar(n,m,theta) using c a four term recurrence relation. (unpublished c notes by paul n. swarztrauber) c subroutine lfin (init,theta,l,m,nm,pb,id,wlfin) dimension pb(1) ,wlfin(1) c c total length of wlfin is 4*l*(nm+1) c lnx = l*(nm+1) iw1 = lnx+1 iw2 = iw1+lnx iw3 = iw2+lnx call lfin1(init,theta,l,m,nm,id,pb,wlfin,wlfin(iw1), 1 wlfin(iw2),wlfin(iw3),wlfin(iw2)) return end subroutine lfin1(init,theta,l,m,nm,id,p3,phz,ph1,p1,p2,cp) dimension p1(l,1) ,p2(l,1) ,p3(id,1) ,phz(l,1) , 1 ph1(l,1) ,cp(1) ,theta(1) nmp1 = nm+1 if(init .ne. 0) go to 5 ssqrt2 = 1./sqrt(2.) do 10 i=1,l phz(i,1) = ssqrt2 10 continue do 15 np1=2,nmp1 nh = np1-1 call alfk(nh,0,cp) do 16 i=1,l call lfpt(nh,0,theta(i),cp,phz(i,np1)) 16 continue call alfk(nh,1,cp) do 17 i=1,l call lfpt(nh,1,theta(i),cp,ph1(i,np1)) 17 continue 15 continue return 5 mp1 = m+1 fm = float(m) tm = fm+fm if(m-1)25,30,35 25 do 45 np1=1,nmp1 do 45 i=1,l p3(i,np1) = phz(i,np1) p1(i,np1) = phz(i,np1) 45 continue return 30 do 50 np1=2,nmp1 do 50 i=1,l p3(i,np1) = ph1(i,np1) p2(i,np1) = ph1(i,np1) 50 continue return 35 temp = tm*(tm-1.) cc = sqrt((tm+1.)*(tm-2.)/temp) ee = sqrt(2./temp) do 85 i=1,l p3(i,m+1) = cc*p1(i,m-1)-ee*p1(i,m+1) 85 continue if(m .eq. nm) return temp = tm*(tm+1.) cc = sqrt((tm+3.)*(tm-2.)/temp) ee = sqrt(6./temp) do 70 i=1,l p3(i,m+2) = cc*p1(i,m)-ee*p1(i,m+2) 70 continue mp3 = m+3 if(nmp1 .lt. mp3) go to 80 do 75 np1=mp3,nmp1 n = np1-1 fn = float(n) tn = fn+fn cn = (tn+1.)/(tn-3.) fnpm = fn+fm fnmm = fn-fm temp = fnpm*(fnpm-1.) cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp) dd = sqrt(cn*fnmm*(fnmm-1.)/temp) ee = sqrt((fnmm+1.)*(fnmm+2.)/temp) do 75 i=1,l p3(i,np1) = cc*p1(i,np1-2)+dd*p3(i,np1-2)-ee*p1(i,np1) 75 continue 80 do 90 np1=m,nmp1 do 90 i=1,l p1(i,np1) = p2(i,np1) p2(i,np1) = p3(i,np1) 90 continue return end c subroutine lfp (init,n,m,l,cp,pb,w) c c dimension of cp((n/2)+1), pb(l), w(5*l+41) c arguments c c purpose routine lfp uses coefficients computed by c routine alfk to calculate the single precision c normalized associated legendre function pbar(n, c m,theta) at colatitudes theta=(i-1)*pi/(l-1), c i=1,...,l. subroutine lfp evaluates pbar c using one of the following trigonometric c expansions c c 1) for n even and m even, pbar(m,n,theta) = c .5*cp(1) plus the sum from k=1 to k=n/2 c of cp(k)*cos(2*k*th) c c 2) for n even and m odd, pbar(m,n,theta) = c the sum from k=1 to k=n/2 of c cp(k)*sin(2*k*th) c c 3) for n odd and m even, pbar(m,n,theta) = c the sum from k=1 to k=(n+1)/2 of c cp(k)*cos((2*k-1)*th) c c 4) for n odd and m odd, pbar(m,n,theta) = c the sum from k=1 to k=(n+1)/2 of c cp(k)*sin((2*k-1)*th) c c c usage call lfp(init,n,m,l,cp,pb,w) c c arguments c c on input init c = 0 initialization only c = 1 compute pbar(n,m,theta) c c lfp call with init = 0 initializes array w; c no values of pbar(n,m,theta) are computed. c init=0 should be used on the first call, or c if l or w values differ from those in the c previous call. c c n c nonnegative integer, less than l, specifying c the degree of pbar(n,m,theta) c c m c is the order of pbar(n,m,theta). m can be c any integer however pbar(n,m,theta) = 0 c if abs(m) is greater than n and c pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta) c for negative m. c c l c number of colatitudes theta=(i-1)*pi/(l-1) c for i=1,...,l where l is greater than 1. c l must be an odd integer. c c cp c single precision array of length (n/2)+1 c containing coefficients computed by routine c alfk c c w c a single precision work array with at c least 5*l+41 locations c c on output pb c single precision array of length l containing c pbar(n,m,theta), theta=(i-1)*pi/(l-1) for i=1 c ,...,l. c c w c a single precision array containing values c which must not be destroyed if the next call c will have the same value of input parameter n c c special conditions calls to routine lfp must be preceded by an c appropriate call to routine alfk. c c precision single c c algorithm the trigonometric series formula used by c routine lfp to calculate pbar(n,m,theta) for c theta=(i-1)*pi/(l-1), i=1,...,n, depends on c m and n as follows: c c 1) for n even and m even, the formula is c .5*cp(1) plus the sum from k=1 to k=n/2 c of cp(k)*cos(2*k*theta) c 2) for n even and m odd. the formula is c the sum from k=1 to k=n/2 of c cp(k)*sin(2*k*theta) c 3) for n odd and m even, the formula is c the sum from k=1 to k=(n+1)/2 of c cp(k)*cos((2*k-1)*theta) c 4) for n odd and m odd, the formula is c the sum from k=1 to k=(n+1)/2 of c cp(k)*sin((2*k-1)*theta) c c accuracy comparison between routines lfp and double c precision dlfp on the cray1 indicates greater c accuracy for smaller values of input parameter c n. agreement to 12 places was obtained for c n=10 and to 11 places for n=100. c c timing time per call to routine lfp is dependent on c the input parameters l and n. c subroutine lfp (init,n,m,l,cp,pb,w) dimension cp(1) ,pb(1) ,w(1) c do 10 i=1,l pb(i) = 0. 10 continue ma = iabs(m) if(ma .gt. n) return iw1 = l+l+12 iw2 = iw1+3*(l+1)/2+15 call lfp1(init,n,ma,l,cp,pb,w,w(iw1),w(iw2)) return end subroutine lfp1(init,n,m,l,cp,p,wsave1,wsave2,wsave3) dimension cp(1),p(1),wsave1(1),wsave2(1),wsave3(1) save lc, lq, ls if(init.ne.0) go to 41 lc=(l+1)/2 ls=lc-2 lq=lc-1 call sinti(ls,wsave1) call costi(lc,wsave2) call cosqi(lq,wsave3) return 41 if (n) 10, 10, 40 10 if (m) 20, 20, 40 20 ssqrt2 = 1./sqrt(2.) do 30 i=1,l p(i) = ssqrt2 30 continue return 40 ls2 = (l+1)/2 lm1 = l-1 np1 = n+1 pi = 4.*atan(1.) dt = pi/lm1 nmod = mod(n,2) mmod = mod(m,2) if (nmod) 50, 50,120 50 if (mmod) 60, 60, 90 60 kdp = n/2+1 do 70 i=1,kdp p(i)=.5*cp(i) 70 continue p(lc)=p(lc)+p(lc) call cost(lc,p,wsave2) do 80 i=1,lc lmi=l-i p(lmi+1)=p(i) 80 continue go to 190 90 kdp=n/2 do 100 i=1,kdp p(i+1)=.5*cp(i) 100 continue p(ls+2)=0. call sint(ls,p(2),wsave1) do 110 i=1,ls lmi=l-i p(lmi)=-p(i+1) 110 continue p(l)=0. go to 190 120 kdp=(n+1)/2 if(mmod)140,140,160 140 do 130 i=1,kdp p(i)=.25*cp(i) 130 continue call cosqb(lq,p,wsave3) do 150 i=1,lq lmi=l-i p(lmi+1)=-p(i) 150 continue go to 190 160 do 180 i=1,kdp p(i+1)=.25*cp(i) 180 continue call sinqb(lq,p(2),wsave3) do 170 i=1,lq lmi=l-i p(lmi)=p(i+1) 170 continue p(l)=0. 190 return end c subroutine lfpt (n,m,theta,cp,pb) c c dimension of c arguments c cp((n/2)+1) c c purpose routine lfpt uses coefficients computed by c routine alfk to compute the single precision c normalized associated legendre function pbar(n, c m,theta) at colatitude theta. c c usage call lfpt(n,m,theta,cp,pb) c c arguments c c on input n c nonnegative integer specifying the degree of c pbar(n,m,theta) c m c is the order of pbar(n,m,theta). m can be c any integer however pbar(n,m,theta) = 0 c if abs(m) is greater than n and c pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta) c for negative m. c c theta c single precision colatitude in radians c c cp c single precision array of length (n/2)+1 c containing coefficients computed by routine c alfk c c on output pb c single precision variable containing c pbar(n,m,theta) c c special conditions calls to routine lfpt must be preceded by an c appropriate call to routine alfk. c c precision single c c algorithm the trigonometric series formula used by c routine lfpt to calculate pbar(n,m,th) at c colatitude th depends on m and n as follows: c c 1) for n even and m even, the formula is c .5*cp(1) plus the sum from k=1 to k=n/2 c of cp(k)*cos(2*k*th) c 2) for n even and m odd. the formula is c the sum from k=1 to k=n/2 of c cp(k)*sin(2*k*th) c 3) for n odd and m even, the formula is c the sum from k=1 to k=(n+1)/2 of c cp(k)*cos((2*k-1)*th) c 4) for n odd and m odd, the formula is c the sum from k=1 to k=(n+1)/2 of c cp(k)*sin((2*k-1)*th) c c accuracy comparison between routines lfpt and double c precision dlfpt on the cray1 indicates greater c accuracy for greater values on input parameter c n. agreement to 13 places was obtained for c n=10 and to 12 places for n=100. c c timing time per call to routine lfpt is dependent on c the input parameter n. c subroutine lfpt (n,m,theta,cp,pb) dimension cp(1) c pb = 0. ma = iabs(m) if(ma .gt. n) return if (n) 10, 10, 30 10 if (ma) 20, 20, 30 20 pb= sqrt(.5) go to 140 30 np1 = n+1 nmod = mod(n,2) mmod = mod(ma,2) if (nmod) 40, 40, 90 40 if (mmod) 50, 50, 70 50 kdo = n/2+1 cdt = cos(theta+theta) sdt = sin(theta+theta) ct = 1. st = 0. sum = .5*cp(1) do 60 kp1=2,kdo cth = cdt*ct-sdt*st st = sdt*ct+cdt*st ct = cth sum = sum+cp(kp1)*ct 60 continue pb= sum go to 140 70 kdo = n/2 cdt = cos(theta+theta) sdt = sin(theta+theta) ct = 1. st = 0. sum = 0. do 80 k=1,kdo cth = cdt*ct-sdt*st st = sdt*ct+cdt*st ct = cth sum = sum+cp(k)*st 80 continue pb= sum go to 140 90 kdo = (n+1)/2 if (mmod) 100,100,120 100 cdt = cos(theta+theta) sdt = sin(theta+theta) ct = cos(theta) st = -sin(theta) sum = 0. do 110 k=1,kdo cth = cdt*ct-sdt*st st = sdt*ct+cdt*st ct = cth sum = sum+cp(k)*ct 110 continue pb= sum go to 140 120 cdt = cos(theta+theta) sdt = sin(theta+theta) ct = cos(theta) st = -sin(theta) sum = 0. do 130 k=1,kdo cth = cdt*ct-sdt*st st = sdt*ct+cdt*st ct = cth sum = sum+cp(k)*st 130 continue pb= sum 140 return end subroutine math2geos(ig,nlat,nlon,sm,sg,work) c*********************************************************************72 c cc MATH2GEOS c implicit none integer ig,nlon,nlat,i,j,ij real sm(nlat,nlon),sg(nlon,nlat),work(*) c c transpose sm into sg and reverse colatitude subscript order c if necessary c do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = sm(i,j) end do end do if (ig.eq.0) then do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i sg(j,nlat-i+1) = work(ij) end do end do else do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i sg(j,i) = work(ij) end do end do end if return end subroutine math2geov(ig,nlat,nlon,vm,wm,ug,vg,work) c*********************************************************************72 c cc MATH2GEOV c implicit none integer ig,nlon,nlat,i,j,ij real vm(nlat,nlon),wm(nlat,nlon),work(*) real ug(nlon,nlat),vg(nlon,nlat) c c convert vm to vg, wm to ug c if (ig.eq.0) then do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = vm(i,j) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i vg(j,nlat-i+1) = -work(ij) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = wm(i,j) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i ug(j,nlat-i+1) = work(ij) end do end do else do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = vm(i,j) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i vg(j,i) = -work(ij) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i work(ij) = wm(i,j) end do end do do i=1,nlat do j=1,nlon ij = (j-1)*nlat+i ug(j,i) = work(ij) end do end do end if return end subroutine mxm(lr,lc,ld,a,mc,md,b,nd,c) c*********************************************************************72 c cc MXM c double precision a(ld,*),b(md,*),c(nd,*) do i=1,lr do j=1,mc c(i,j) = 0. do k=1,lc c(i,j) = c(i,j)+a(i,k)*b(k,j) end do end do end do return end subroutine mxmx(lr,lc,ld,a,mc,md,b,x,y) c*********************************************************************72 c cc MXMX c dimension a(ld,*),b(md,*),x(ld,2),y(ld,2) do k=1,lr y(k,1) = 0. y(k,2) = 0. end do c if(lc.le.0) return do i=1,lc sum1 = 0. sum2 = 0. do j=1,mc sum1 = sum1 + b(i,j)*x(j,1) sum2 = sum2 + b(i,j)*x(j,2) end do do k=1,lr y(k,1) = y(k,1)+sum1*a(k,i) y(k,2) = y(k,2)+sum2*a(k,i) end do end do return end subroutine name ( name2 ) c*********************************************************************72 c cc NAME sets an internal 4 character name. c c Discussion: c c This routine is simply a placeholder which does nothing with c the input, and simply keeps the loader happy. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 30 November 2009 c c Author: c c John Burkardt c c Parameters: c c Input, hollerith NAME2, the name. c implicit none character*(*) name2 return end subroutine negv(nlat,nlon,v) c*********************************************************************72 c cc NEGV negates (co)latitudinal vector component. c implicit none integer nlat,nlon,i,j real v(nlat,nlon) do j=1,nlon do i=1,nlat v(i,j) = -v(i,j) end do end do return end subroutine normal(n,x,id,q) c*********************************************************************72 c cc NORMAL normalizes a vector. c integer n integer i double precision q(n) double precision sqs double precision x(n) sqs = 0.0D+00 do i = 1, n sqs = sqs + q(i) * x(i) * x(i) end do if ( sqs .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NORMAL - Warning!' write ( *, '(a)' ) ' Vector to be normalized is zero.' return end if sqs = dsqrt ( sqs ) do i = 1, n x(i) = x(i) / sqs end do return end function pimach() c*********************************************************************72 c cc PIMACH c pimach=3.14159265358979 return end subroutine prjct(init,xeye,yeye,zeye,x,y,z,px,py) c*********************************************************************72 c cc PRJCT c c subroutine prjct projects the point x,y,z onto a plane through c the origin that is perpendicular to a line between the origin c and the eye. the projection is along the line between the eye c and the point x,y,z. px and py are the coordinates of the c projection in the plane. c (version 2 , 12-10-82) c save if(init.ne.0) go to 1 rads1 = xeye**2+yeye**2 rads2 = rads1+zeye**2 d1 = sqrt(rads1) d2 = sqrt(rads2) if(d1.ne.0.) go to 2 cx1 = 1. cy1 = 0. cx2 = 0. cy2 = 1. cz2 = 0. cx3 = 0. cy3 = 0. cz3 = 1. return 2 cx1 = -yeye/d1 cy1 = xeye/d1 cx2 = -xeye*zeye/(d1*d2) cy2 = -yeye*zeye/(d1*d2) cz2 = d1/d2 cx3 = xeye/d2 cy3 = yeye/d2 cz3 = zeye/d2 return 1 x1 = cx1*x+cy1*y y1 = cx2*x+cy2*y+cz2*z z1 = cx3*x+cy3*y+cz3*z ratio = d2/(d2-z1) px = ratio*x1 py = ratio*y1 return end subroutine projct(m,n,xeye,yeye,zeye,x,y,z,px,py) c **** projects point (x,y,z) onto plane thru origin and perp c **** to line joining origin and eye dimension x(n,m),y(n,m),z(n,m),px(n,m),py(n,m) call prjct(0,xeye,yeye,zeye,rdum1,rdum2,rdum3,rdum4,rdum5) do 100 i=1,m do 100 j=1,n call prjct(1,xeye,yeye,zeye,x(j,i),y(j,i),z(j,i),px(j,i),py(j,i)) 100 continue return end subroutine rabcp(nlat,nlon,abc) c c subroutine rabcp computes the coefficients in the recurrence c relation for the associated legendre fuctions. array abc c must have 3*((mmax-2)*(nlat+nlat-mmax-1))/2 locations. c dimension abc(1) mmax = min0(nlat,nlon/2+1) labc = ((mmax-2)*(nlat+nlat-mmax-1))/2 iw1 = labc+1 iw2 = iw1+labc call rabcp1(nlat,nlon,abc,abc(iw1),abc(iw2)) return end subroutine rabcp1(nlat,nlon,a,b,c) c c coefficients a, b, and c for computing pbar(m,n,theta) are c stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1 c dimension a(1),b(1),c(1) mmax = min0(nlat,nlon/2+1) do 215 mp1=3,mmax m = mp1-1 ns = ((m-2)*(nlat+nlat-m-1))/2+1 fm = float(m) tm = fm+fm temp = tm*(tm-1.) a(ns) = sqrt((tm+1.)*(tm-2.)/temp) c(ns) = sqrt(2./temp) if(m .eq. nlat-1) go to 215 ns = ns+1 temp = tm*(tm+1.) a(ns) = sqrt((tm+3.)*(tm-2.)/temp) c(ns) = sqrt(6./temp) mp3 = m+3 if(mp3 .gt. nlat) go to 215 do 210 np1=mp3,nlat n = np1-1 ns = ns+1 fn = float(n) tn = fn+fn cn = (tn+1.)/(tn-3.) fnpm = fn+fm fnmm = fn-fm temp = fnpm*(fnpm-1.) a(ns) = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp) b(ns) = sqrt(cn*fnmm*(fnmm-1.)/temp) c(ns) = sqrt((fnmm+1.)*(fnmm+2.)/temp) 210 continue 215 continue return end subroutine rabcv(nlat,nlon,abc) c c subroutine rabcp computes the coefficients in the recurrence c relation for the functions vbar(m,n,theta). array abc c must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 locations. c dimension abc(1) mmax = min0(nlat,(nlon+1)/2) labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 iw1 = labc+1 iw2 = iw1+labc call rabcv1(nlat,nlon,abc,abc(iw1),abc(iw2)) return end subroutine rabcv1(nlat,nlon,a,b,c) c c coefficients a, b, and c for computing vbar(m,n,theta) are c stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1 c dimension a(1),b(1),c(1) mmax = min0(nlat,(nlon+1)/2) if(mmax .lt. 3) return do 215 mp1=3,mmax m = mp1-1 ns = ((m-2)*(nlat+nlat-m-1))/2+1 fm = float(m) tm = fm+fm temp = tm*(tm-1.) tpn = (fm-2.)*(fm-1.)/(fm*(fm+1.)) a(ns) = sqrt(tpn*(tm+1.)*(tm-2.)/temp) c(ns) = sqrt(2./temp) if(m .eq. nlat-1) go to 215 ns = ns+1 temp = tm*(tm+1.) tpn = (fm-1.)*fm/((fm+1.)*(fm+2.)) a(ns) = sqrt(tpn*(tm+3.)*(tm-2.)/temp) c(ns) = sqrt(6./temp) mp3 = m+3 if(mp3 .gt. nlat) go to 215 do 210 np1=mp3,nlat n = np1-1 ns = ns+1 fn = float(n) tn = fn+fn cn = (tn+1.)/(tn-3.) tpn = (fn-2.)*(fn-1.)/(fn*(fn+1.)) fnpm = fn+fm fnmm = fn-fm temp = fnpm*(fnpm-1.) a(ns) = sqrt(tpn*cn*(fnpm-3.)*(fnpm-2.)/temp) b(ns) = sqrt(tpn*cn*fnmm*(fnmm-1.)/temp) c(ns) = sqrt((fnmm+1.)*(fnmm+2.)/temp) 210 continue 215 continue return end subroutine rabcw(nlat,nlon,abc) c c subroutine rabcw computes the coefficients in the recurrence c relation for the functions wbar(m,n,theta). array abc c must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 locations. c dimension abc(1) mmax = min0(nlat,(nlon+1)/2) labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 iw1 = labc+1 iw2 = iw1+labc call rabcw1(nlat,nlon,abc,abc(iw1),abc(iw2)) return end subroutine rabcw1(nlat,nlon,a,b,c) c c coefficients a, b, and c for computing wbar(m,n,theta) are c stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1 c dimension a(1),b(1),c(1) mmax = min0(nlat,(nlon+1)/2) if(mmax .lt. 4) return do 215 mp1=4,mmax m = mp1-1 ns = ((m-2)*(nlat+nlat-m-1))/2+1 fm = float(m) tm = fm+fm temp = tm*(tm-1.) tpn = (fm-2.)*(fm-1.)/(fm*(fm+1.)) tph = fm/(fm-2.) a(ns) = tph*sqrt(tpn*(tm+1.)*(tm-2.)/temp) c(ns) = tph*sqrt(2./temp) if(m .eq. nlat-1) go to 215 ns = ns+1 temp = tm*(tm+1.) tpn = (fm-1.)*fm/((fm+1.)*(fm+2.)) tph = fm/(fm-2.) a(ns) = tph*sqrt(tpn*(tm+3.)*(tm-2.)/temp) c(ns) = tph*sqrt(6./temp) mp3 = m+3 if(mp3 .gt. nlat) go to 215 do 210 np1=mp3,nlat n = np1-1 ns = ns+1 fn = float(n) tn = fn+fn cn = (tn+1.)/(tn-3.) fnpm = fn+fm fnmm = fn-fm temp = fnpm*(fnpm-1.) tpn = (fn-2.)*(fn-1.)/(fn*(fn+1.)) tph = fm/(fm-2.) a(ns) = tph*sqrt(tpn*cn*(fnpm-3.)*(fnpm-2.)/temp) b(ns) = sqrt(tpn*cn*fnmm*(fnmm-1.)/temp) c(ns) = tph*sqrt((fnmm+1.)*(fnmm+2.)/temp) 210 continue 215 continue return end subroutine sea1(nlat,nlon,imid,z,idz,zin,wzfin,dwork) dimension z(idz,*),zin(imid,nlat,3),wzfin(*) double precision dwork(*) call zfinit(nlat,nlon,wzfin,dwork) mmax = min0(nlat,nlon/2+1) do 33 mp1=1,mmax m = mp1-1 call zfin (0,nlat,nlon,m,zin,i3,wzfin) do 33 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 33 i=1,imid z(mn,i) = zin(i,np1,i3) 33 continue return end subroutine ses1(nlat,nlon,imid,p,pin,walin,dwork) dimension p(imid,*),pin(imid,nlat,3),walin(*) double precision dwork(*) call alinit (nlat,nlon,walin,dwork) mmax = min0(nlat,nlon/2+1) do 10 mp1=1,mmax m = mp1-1 call alin(0,nlat,nlon,m,pin,i3,walin) do 10 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 10 i=1,imid p(i,mn) = pin(i,np1,i3) 10 continue return end subroutine setwts(imid,dwts,wts) c c set first imid =(nlat+1)/2 of double precision weights in dwts c as single precision in wts c dimension dwts(imid),wts(imid) double precision dwts do 1 i=1,imid wts(i) = dwts(i) 1 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file sfvpec.f c c this file includes documentation and code for c subroutine sfvpec i c c ... files which must be loaded with sfvpec.f c c sphcom.f, hrfft.f, vhaec.f, shsec.f c c c subroutine sfvpec(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, c + mdb,ndb,wshsec,lshsec,work,lwork,ierror) c c given the vector spherical harmonic coefficients br,bi,cr,ci, c computed by subroutine vhaec for a vector field (v,w), sfvpec c computes a scalar stream function sf and scalar velocity potential c vp for (v,w). (v,w) is expressed in terms of sf and vp by the c helmholtz relations (in mathematical spherical coordinates): c c v = -1/sint*d(vp)/dlambda + d(st)/dtheta c c w = 1/sint*d(st)/dlambda + d(vp)/dtheta c c where sint = sin(theta). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c br,bi,cr,ci were precomputed. required associated legendre c polynomials are recomputed rather than stored as they are in c subroutine sfvpes. sf(i,j) and vp(i,j) are given at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the stream function and c velocity potential are computed on the full or half sphere c as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case sf c and vp are not necessarily symmetric or antisymmetric about c the equator. sf and vp are computed on the entire sphere. c i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case sf is symmetric and vp antisymmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the sf(i,j),vp(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c w is symmetric and v is antisymmetric about the equator. c in this case sf is antisymmetric and vp symmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the sf(i,j),vp(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. arrays c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute sf,vp for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the arrays sf,vp as it appears in c the program that calls sfvpec. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the arrays sf,vp as it appears in c the program that calls sfvpec. jdv must be at least nlon. c c br,bi, two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaec. c c mdb the first dimension of the arrays br,bi,cr,ci as it c appears in the program that calls sfvpec. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br,bi,cr,ci as it c appears in the program that calls sfvpec. ndb must be at c least nlat. c c wshsec an array which must be initialized by subroutine shseci. c once initialized, wshsec can be used repeatedly by sfvpec c as long as nlon and nlat remain unchanged. wshsec must c not bel altered between calls of sfvpec. c c c lshsec the dimension of the array wshsec as it appears in the c program that calls sfvpec. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsec must be at least c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls sfvpec. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*((nt*nlon+max0(3*l2,nlon)) + 2*l1*nt+1) c c if isym is not zero then lwork must be at least c c l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*l1*nt+1) c c ************************************************************** c c output parameters c c sf,vp two or three dimensional arrays (see input parameter nt) c that contains the stream function and velocity potential c of the vector field (v,w) whose coefficients br,bi,cr,ci c where precomputed by subroutine vhaec. sf(i,j),vp(i,j) c are given at the colatitude point c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude point c c lambda(j) = (j-1)*2*pi/nlon c c the index ranges are defined above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsec c = 10 error in the specification of lwork c ********************************************************************** c subroutine sfvpec(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, + mdb,ndb,wshsec,lshsec,work,lwork,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lshsec,lwork,ierror real sf(idv,jdv,nt),vp(idv,jdv,nt) real br(mdb,ndb,nt),bi(mdb,ndb,nt) real cr(mdb,ndb,nt),ci(mdb,ndb,nt) real wshsec(lshsec),work(lwork) integer imid,mmax,lzz1,labc,ls,nln,mab,mn,ia,ib,is,lwk,iwk,lwmin c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if (nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if (nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. + (isym.gt.0 .and. idv.lt.imid)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+2)/2) if(mdb .lt. min0(nlat,(nlon+1)/2)) return ierror = 8 if (ndb .lt. nlat) return ierror = 9 c c verify saved work space (same as shsec) c imid = (nlat+1)/2 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 lwmin = lzz1+labc+nlon+15 if(lshsec .lt. lwmin) return c c verify unsaved work space (add to what shec requires) c ierror = 10 ls = nlat if (isym.gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shsec) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt if(lwork .lt. nln+max0(ls*nlon,3*nlat*imid)+2*mn+nlat) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call sfvpec1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb, +work(ia),work(ib),mab,work(is),wshsec,lshsec,work(iwk),lwk, +ierror) return end subroutine sfvpec1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, +mdb,ndb,a,b,mab,fnn,wshsec,lshsec,wk,lwk,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lshsec,lwk,ierror real sf(idv,jdv,nt),vp(idv,jdv,nt) real br(mdb,ndb,nt),bi(mdb,ndb,nt),cr(mdb,ndb,nt),ci(mdb,ndb,nt) real a(mab,nlat,nt),b(mab,nlat,nt) real wshsec(lshsec),wk(lwk),fnn(nlat) integer n,m,mmax,k c c set coefficient multiplyers c do n=2,nlat fnn(n) = 1.0/sqrt(float(n*(n-1))) end do mmax = min0(nlat,(nlon+1)/2) c c compute sf scalar coefficients from cr,ci c do k=1,nt do n=1,nlat do m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat a(1,n,k) =-fnn(n)*cr(1,n,k) b(1,n,k) =-fnn(n)*ci(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c do m=2,mmax do n=m,nlat a(m,n,k) =-fnn(n)*cr(m,n,k) b(m,n,k) =-fnn(n)*ci(m,n,k) end do end do end do c c synthesize a,b into st c call shsec(nlat,nlon,isym,nt,sf,idv,jdv,a,b, + mab,nlat,wshsec,lshsec,wk,lwk,ierror) c c set coefficients for vp from br,bi c do k=1,nt do n=1,nlat do m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat a(1,n,k) = fnn(n)*br(1,n,k) b(1,n,k) = fnn(n)*bi(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c mmax = min0(nlat,(nlon+1)/2) do m=2,mmax do n=m,nlat a(m,n,k) = fnn(n)*br(m,n,k) b(m,n,k) = fnn(n)*bi(m,n,k) end do end do end do c c synthesize a,b into vp c call shsec(nlat,nlon,isym,nt,vp,idv,jdv,a,b, + mab,nlat,wshsec,lshsec,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file sfvpes.f c c this file includes documentation and code for c subroutine sfvpes i c c ... files which must be loaded with sfvpes.f c c sphcom.f, hrfft.f, vhaes.f, shses.f c c c subroutine sfvpes(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, c + mdb,ndb,wshses,lshses,work,lwork,ierror) c c given the vector spherical harmonic coefficients br,bi,cr,ci, c computed by subroutine vhaes for a vector field (v,w), sfvpes c computes a scalar stream function sf and scalar velocity potential c vp for (v,w). (v,w) is expressed in terms of sf and vp by the c helmholtz relations (in mathematical spherical coordinates): c c v = -1/sint*d(vp)/dlambda + d(st)/dtheta c c w = 1/sint*d(st)/dlambda + d(vp)/dtheta c c where sint = sin(theta). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c br,bi,cr,ci were precomputed. required associated legendre c polynomials are stored rather than recomputed as they are in c subroutine sfvpec. sf(i,j) and vp(i,j) are given at colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the stream function and c velocity potential are computed on the full or half sphere c as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case sf c and vp are not necessarily symmetric or antisymmetric about c the equator. sf and vp are computed on the entire sphere. c i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case sf is symmetric and vp antisymmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the sf(i,j),vp(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c w is symmetric and v is antisymmetric about the equator. c in this case sf is antisymmetric and vp symmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the sf(i,j),vp(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute sf,vp for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the arrays sf,vp as it appears in c the program that calls sfvpes. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the arrays sf,vp as it appears in c the program that calls sfvpes. jdv must be at least nlon. c c br,bi, two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaec. c c mdb the first dimension of the arrays br,bi,cr,ci as it c appears in the program that calls sfvpes. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br,bi,cr,ci as it c appears in the program that calls sfvpes. ndb must be at c least nlat. c c wshses an array which must be initialized by subroutine shsesi. c once initialized, wshses can be used repeatedly by sfvpes c as long as nlon and nlat remain unchanged. wshses must c not bel altered between calls of sfvpes. c c c lshses the dimension of the array wshses as it appears in the c program that calls sfrvpes. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshses must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls sfvpes. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*((nt+1)*nlon + 2*l2*nt+1) c c if isym is nonzero then lwork must be at least c c l2*((nt+1)*nlon + 2*nlat*nt) + nlat c c ************************************************************** c c output parameters c c sf,vp two or three dimensional arrays (see input parameter nt) c that contains the stream function and velocity potential c of the vector field (v,w) whose coefficients br,bi,cr,ci c where computed by subroutine vhaec. sf(i,j),vp(i,j) c are given at the colatitude point c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude point c c lambda(j) = (j-1)*2*pi/nlon c c the index ranges are defined above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshses c = 10 error in the specification of lwork c ********************************************************************** c subroutine sfvpes(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, + mdb,ndb,wshses,lshses,work,lwork,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lshses,lwork,ierror real sf(idv,jdv,nt),vp(idv,jdv,nt) real br(mdb,ndb,nt),bi(mdb,ndb,nt) real cr(mdb,ndb,nt),ci(mdb,ndb,nt) real wshses(lshses),work(lwork) integer imid,mmax,ls,mab,mn,ia,ib,is,lwk,iwk integer lpimn c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if (nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if (nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. + (isym.gt.0 .and. idv.lt.imid)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+2)/2) if(mdb .lt. min0(nlat,(nlon+1)/2)) return ierror = 8 if (ndb .lt. nlat) return ierror = 9 c c verify saved work space (same as shses) c imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshses .lt. lpimn+nlon+15) return c c verify unsaved work space (add to what shec requires) c ierror = 10 ls = nlat if (isym.gt. 0) ls = imid c c set first dimension for a,b (as requried by shses) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt if (lwork.lt. ls*(nt+1)*nlon +nlat*(2*imid+1)) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call sfvpes1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb, +work(ia),work(ib),mab,work(is),wshses,lshses,work(iwk),lwk, +ierror) return end subroutine sfvpes1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, +mdb,ndb,a,b,mab,fnn,wshses,lshses,wk,lwk,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lshses,lwk,ierror real sf(idv,jdv,nt),vp(idv,jdv,nt) real br(mdb,ndb,nt),bi(mdb,ndb,nt),cr(mdb,ndb,nt),ci(mdb,ndb,nt) real a(mab,nlat,nt),b(mab,nlat,nt) real wshses(lshses),wk(lwk),fnn(nlat) integer n,m,mmax,k c c set coefficient multiplyers c do n=2,nlat fnn(n) = 1.0/sqrt(float(n*(n-1))) end do mmax = min0(nlat,(nlon+1)/2) c c compute sf scalar coefficients from cr,ci c do k=1,nt do n=1,nlat do m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat a(1,n,k) =-fnn(n)*cr(1,n,k) b(1,n,k) =-fnn(n)*ci(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c do m=2,mmax do n=m,nlat a(m,n,k) =-fnn(n)*cr(m,n,k) b(m,n,k) =-fnn(n)*ci(m,n,k) end do end do end do c c synthesize a,b into st c call shses(nlat,nlon,isym,nt,sf,idv,jdv,a,b, + mab,nlat,wshses,lshses,wk,lwk,ierror) c c set coefficients for vp from br,bi c do k=1,nt do n=1,nlat do m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat a(1,n,k) = fnn(n)*br(1,n,k) b(1,n,k) = fnn(n)*bi(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c mmax = min0(nlat,(nlon+1)/2) do m=2,mmax do n=m,nlat a(m,n,k) = fnn(n)*br(m,n,k) b(m,n,k) = fnn(n)*bi(m,n,k) end do end do end do c c synthesize a,b into vp c call shses(nlat,nlon,isym,nt,vp,idv,jdv,a,b, + mab,nlat,wshses,lshses,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file sfvpgc.f c c this file includes documentation and code for c subroutine sfvpgc i c c ... files which must be loaded with sfvpgc.f c c sphcom.f, hrfft.f, vhagc.f, shsgc.f, gaqd.f c c c subroutine sfvpgc(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, c + mdb,ndb,wshsgc,lshsgc,work,lwork,ierror) c c given the vector spherical harmonic coefficients br,bi,cr,ci, c computed by subroutine vhagc for a vector field (v,w), sfvpgc c computes a scalar stream function sf and scalar velocity potential c vp for (v,w). (v,w) is expressed in terms of sf and vp by the c helmholtz relations (in mathematical spherical coordinates): c c v = -1/sint*d(vp)/dlambda + d(st)/dtheta c c w = 1/sint*d(st)/dlambda + d(vp)/dtheta c c where sint = sin(theta). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c br,bi,cr,ci were precomputed. required associated legendre c polynomials are recomputed rather than stored as they are in c subroutine sfvpgs. sf(i,j) and vp(i,j) are given at the i(th) c gaussian colatitude point theta(i) (see nlat description below) c and east longitude lambda(j) = (j-1)*2*pi/nlon on the sphere. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the stream function and c velocity potential are computed on the full or half sphere c as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case st c and vp are not necessarily symmetric or antisymmetric about c the equator. sf and vp are computed on the entire sphere. c i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case sf is symmetric and vp antisymmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the sf(i,j),vp(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c w is symmetric and v is antisymmetric about the equator. c in this case sf is antisymmetric and vp symmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the sf(i,j),vp(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. arrays c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute sf,vp for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the arrays sf,vp as it appears in c the program that calls sfvpgc. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the arrays sf,vp as it appears in c the program that calls sfvpgc. jdv must be at least nlon. c c br,bi, two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhagc. c c mdb the first dimension of the arrays br,bi,cr,ci as it c appears in the program that calls sfvpgc. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br,bi,cr,ci as it c appears in the program that calls sfvpgc. ndb must be at c least nlat. c c wshsgc an array which must be initialized by subroutine shsgci. c once initialized, wshsgc can be used repeatedly by sfvpgc c as long as nlon and nlat remain unchanged. wshsgc must c not bel altered between calls of sfvpgc. c c c lshsgc the dimension of the array wshsgc as it appears in the c program that calls sfvpgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls sfvpgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*((nt*nlon+max0(3*l2,nlon)) + 2*l1*nt+1) c c if isym is not zero then lwork must be at least c c l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*l1*nt+1) c c ************************************************************** c c output parameters c c sf,vp two or three dimensional arrays (see input parameter nt) c that contains the stream function and velocity potential c of the vector field (v,w) whose coefficients br,bi,cr,ci c where precomputed by subroutine vhagc. sf(i,j),vp(i,j) c are given at the i(th) gaussian colatitude point theta(i) c and longitude point lambda(j) = (j-1)*2*pi/nlon. the index c ranges are defined above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsgc c = 10 error in the specification of lwork c ********************************************************************** c subroutine sfvpgc(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, + mdb,ndb,wshsgc,lshsgc,work,lwork,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lshsgc,lwork,ierror real sf(idv,jdv,nt),vp(idv,jdv,nt) real br(mdb,ndb,nt),bi(mdb,ndb,nt) real cr(mdb,ndb,nt),ci(mdb,ndb,nt) real wshsgc(lshsgc),work(lwork) integer imid,mmax,lzz1,labc,ls,nln,mab,mn,ia,ib,is,lwk,iwk,lwmin integer l1,l2 c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if (nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if (nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. + (isym.gt.0 .and. idv.lt.imid)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+2)/2) if(mdb .lt. min0(nlat,(nlon+1)/2)) return ierror = 8 if (ndb .lt. nlat) return ierror = 9 c c verify saved work space (same as shsgc) c imid = (nlat+1)/2 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 lwmin = lzz1+labc+nlon+15 l2 = (nlat+1)/2 l1 = min0((nlon+2)/2,nlat) if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return c c verify unsaved work space (add to what shsgc requires) c ierror = 10 ls = nlat if (isym.gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shsgc) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt if(lwork .lt. nln+max0(ls*nlon,3*nlat*imid)+2*mn+nlat) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call sfvpgc1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb, +work(ia),work(ib),mab,work(is),wshsgc,lshsgc,work(iwk),lwk, +ierror) return end subroutine sfvpgc1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, +mdb,ndb,a,b,mab,fnn,wshsgc,lshsgc,wk,lwk,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lshsgc,lwk,ierror real sf(idv,jdv,nt),vp(idv,jdv,nt) real br(mdb,ndb,nt),bi(mdb,ndb,nt),cr(mdb,ndb,nt),ci(mdb,ndb,nt) real a(mab,nlat,nt),b(mab,nlat,nt) real wshsgc(lshsgc),wk(lwk),fnn(nlat) integer n,m,mmax,k c c set coefficient multiplyers c do n=2,nlat fnn(n) = 1.0/sqrt(float(n*(n-1))) end do mmax = min0(nlat,(nlon+1)/2) c c compute sf scalar coefficients from cr,ci c do k=1,nt do n=1,nlat do m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat a(1,n,k) =-fnn(n)*cr(1,n,k) b(1,n,k) =-fnn(n)*ci(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c do m=2,mmax do n=m,nlat a(m,n,k) =-fnn(n)*cr(m,n,k) b(m,n,k) =-fnn(n)*ci(m,n,k) end do end do end do c c synthesize a,b into st c call shsgc(nlat,nlon,isym,nt,sf,idv,jdv,a,b, + mab,nlat,wshsgc,lshsgc,wk,lwk,ierror) c c set coefficients for vp from br,bi c do k=1,nt do n=1,nlat do m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat a(1,n,k) = fnn(n)*br(1,n,k) b(1,n,k) = fnn(n)*bi(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c mmax = min0(nlat,(nlon+1)/2) do m=2,mmax do n=m,nlat a(m,n,k) = fnn(n)*br(m,n,k) b(m,n,k) = fnn(n)*bi(m,n,k) end do end do end do c c synthesize a,b into vp c call shsgc(nlat,nlon,isym,nt,vp,idv,jdv,a,b, + mab,nlat,wshsgc,lshsgc,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file sfvpgs.f c c this file includes documentation and code for c subroutine sfvpgs i c c ... files which must be loaded with sfvpgs.f c c sphcom.f, hrfft.f, vhags.f, shsgs.f, gaqd.f c c c subroutine sfvpgs(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, c + mdb,ndb,wshsgs,lshsgs,work,lwork,ierror) c c given the vector spherical harmonic coefficients br,bi,cr,ci, c computed by subroutine vhags for a vector field (v,w), sfvpgs c computes a scalar stream function sf and scalar velocity potential c vp for (v,w). (v,w) is expressed in terms of sf and vp by the c helmholtz relations (in mathematical spherical coordinates): c c v = -1/sint*d(vp)/dlambda + d(st)/dtheta c c w = 1/sint*d(st)/dlambda + d(vp)/dtheta c c where sint = sin(theta). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c br,bi,cr,ci were precomputed. required associated legendre c polynomials are stored rather than recomputed as they are in c subroutine sfvpgc. sf(i,j) and vp(i,j) are given at the i(th) c gaussian colatitude point theta(i) (see nlat description below) c and east longitude lambda(j) = (j-1)*2*pi/nlon on the sphere. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater than c 3. the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the stream function and c velocity potential are computed on the full or half sphere c as follows: c c = 0 c c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case st c and vp are not necessarily symmetric or antisymmetric about c the equator. sf and vp are computed on the entire sphere. c i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c c w is antisymmetric and v is symmetric about the equator. c in this case sf is symmetric and vp antisymmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the sf(i,j),vp(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c = 2 c c w is symmetric and v is antisymmetric about the equator. c in this case sf is antisymmetric and vp symmetric about c the equator and are computed for the northern hemisphere c only. i.e., if nlat is odd the sf(i,j),vp(i,j) are computed c for i=1,...,(nlat+1)/2 and for j=1,...,nlon. if nlat is c even then sf(i,j),vp(i,j) are computed for i=1,...,nlat/2 c and j=1,...,nlon. c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. arrays c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute sf,vp for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c idv the first dimension of the arrays sf,vp as it appears in c the program that calls sfvpgs. if isym = 0 then idv c must be at least nlat. if isym = 1 or 2 and nlat is c even then idv must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then idv must be at least (nlat+1)/2. c c jdv the second dimension of the arrays sf,vp as it appears in c the program that calls sfvpgs. jdv must be at least nlon. c c br,bi, two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhags. c c mdb the first dimension of the arrays br,bi,cr,ci as it c appears in the program that calls sfvpgs. mdb must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndb the second dimension of the arrays br,bi,cr,ci as it c appears in the program that calls sfvpgs. ndb must be at c least nlat. c c wshsgs an array which must be initialized by subroutine shsgsi. c once initialized, wshsgs can be used repeatedly by sfvpgs c as long as nlon and nlat remain unchanged. wshsgs must c not bel altered between calls of sfvpgs. c c c lshsgs the dimension of the array wshsgs as it appears in the c program that calls sfvpgs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgs must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls sfvpgs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*nlon*(nt+1) + nlat*(2*l1*nt + 1) c c if isym is nonzero then lwork must be at least c c l2*nlon*(nt+1) + nlat*(2*l1*nt + 1) c c ************************************************************** c c output parameters c c sf,vp two or three dimensional arrays (see input parameter nt) c that contains the stream function and velocity potential c of the vector field (v,w) whose coefficients br,bi,cr,ci c where precomputed by subroutine vhags. sf(i,j),vp(i,j) c are given at the i(th) gaussian colatitude point theta(i) c and longitude point lambda(j) = (j-1)*2*pi/nlon. the index c ranges are defined above at the input parameter isym. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idv c = 6 error in the specification of jdv c = 7 error in the specification of mdb c = 8 error in the specification of ndb c = 9 error in the specification of lshsgs c = 10 error in the specification of lwork c ********************************************************************** c subroutine sfvpgs(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, + mdb,ndb,wshsgs,lshsgs,work,lwork,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,lshsgs,lwork,ierror real sf(idv,jdv,nt),vp(idv,jdv,nt) real br(mdb,ndb,nt),bi(mdb,ndb,nt) real cr(mdb,ndb,nt),ci(mdb,ndb,nt) real wshsgs(lshsgs),work(lwork) integer imid,ls,mab,mn,ia,ib,is,lwk,iwk integer lat,late,l1,l2,lp c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if (nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if (nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. idv.lt.nlat) .or. + (isym.gt.0 .and. idv.lt.imid)) return ierror = 6 if(jdv .lt. nlon) return ierror = 7 if(mdb .lt. min0(nlat,(nlon+1)/2)) return ierror = 8 if (ndb .lt. nlat) return ierror = 9 l1 = min0((nlon+2)/2,nlat) late = (nlat+mod(nlat,2))/2 lat = nlat if (isym.ne.0) lat = late l2 = late c check permanent work space length l2 = (nlat+mod(nlat,2))/2 l1 = min0((nlon+2)/2,nlat) lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshsgs.lt.lp) return c c verify unsaved work space c ierror = 10 ls = nlat if (isym.gt. 0) ls = imid c c set first dimension for a,b (as requried by shsgs) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt if (lwork .lt. ls*nlon+(nt+1)+nlat*(2*l1*nt+1)) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call stvpgs1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb, +work(ia),work(ib),mab,work(is),wshsgs,lshsgs,work(iwk),lwk, +ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file shaec.f c c this file contains code and documentation for subroutines c shaec and shaeci c c ... files which must be loaded with shaec.f c c sphcom.f, hrfft.f c c subroutine shaec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, c + wshaec,lshaec,work,lwork,ierror) c c subroutine shaec performs the spherical harmonic analysis c on the array g and stores the result in the arrays a and b. c the analysis is performed on an equally spaced grid. the c associated legendre functions are recomputed rather than stored c as they are in subroutine shaes. the analysis is described c below at output parameters a,b. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c isym = 0 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c array g(i,j) for i=1,...,nlat and j=1,...,nlon. c (see description of g below) c c = 1 g is antisymmetric about the equator. the analysis c is performed on the northern hemisphere only. i.e. c if nlat is odd the analysis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the analysis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c = 2 g is symmetric about the equator. the analysis is c performed on the northern hemisphere only. i.e. c if nlat is odd the analysis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the analysis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of analyses. in the program that calls shaec, c the arrays g,a and b can be three dimensional in which c case multiple analyses will be performed. the third c index is the analysis index which assumes the values c k=1,...,nt. for a single analysis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that the arrays g,a and b c have only two dimensions. c c g a two or three dimensional array (see input parameter c nt) that contains the discrete function to be analyzed. c g(i,j) contains the value of the function at the colatitude c point theta(i) = (i-1)*pi/(nlat-1) and longitude point c phi(j) = (j-1)*2*pi/nlon. the index ranges are defined c above at the input parameter isym. c c c idg the first dimension of the array g as it appears in the c program that calls shaec. if isym equals zero then idg c must be at least nlat. if isym is nonzero then idg c must be at least nlat/2 if nlat is even or at least c (nlat+1)/2 if nlat is odd. c c jdg the second dimension of the array g as it appears in the c program that calls shaec. jdg must be at least nlon. c c mdab the first dimension of the arrays a and b as it appears c in the program that calls shaec. mdab must be at least c min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls shaec. ndab must be at least nlat c c wshaec an array which must be initialized by subroutine shaeci. c once initialized, wshaec can be used repeatedly by shaec c as long as nlon and nlat remain unchanged. wshaec must c not be altered between calls of shaec. c c lshaec the dimension of the array wshaec as it appears in the c program that calls shaec. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshaec must be at least c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shaec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*(nt*nlon+max0(3*l2,nlon)) c c if isym is not zero then lwork must be at least c c l2*(nt*nlon+max0(3*nlat,nlon)) c c ************************************************************** c c output parameters c c a,b both a,b are two or three dimensional arrays (see input c parameter nt) that contain the spherical harmonic c coefficients in the representation of g(i,j) given in the c discription of subroutine shsec. for isym=0, a(m,n) and c b(m,n) are given by the equations listed below. symmetric c versions are used when isym is greater than zero. c c c c definitions c c 1. the normalized associated legendre functions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta) c c 2. the normalized z functions for m even c c zbar(m,n,theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of c the integral from tau = 0 to tau = pi of c cos(k*theta)*cos(k*tau)*pbar(m,n,tau)*sin(tau) c (first and last terms in this sum are divided c by 2) c c 3. the normalized z functions for m odd c c zbar(m,n,theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of c of the integral from tau = 0 to tau = pi of c sin(k*theta)*sin(k*tau)*pbar(m,n,tau)*sin(tau) c c 4. the fourier transform of g(i,j). c c c(m,i) = 2/nlon times the sum from j=1 to j=nlon c of g(i,j)*cos((m-1)*(j-1)*2*pi/nlon) c (the first and last terms in this sum c are divided by 2) c c s(m,i) = 2/nlon times the sum from j=2 to j=nlon c of g(i,j)*sin((m-1)*(j-1)*2*pi/nlon) c c 5. the maximum (plus one) longitudinal wave number c c mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c c then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b c are given by c c a(m+1,n+1) = the sum from i=1 to i=nlat of c c(m+1,i)*zbar(m,n,theta(i)) c (first and last terms in this sum are c divided by 2) c c b(m+1,n+1) = the sum from i=1 to i=nlat of c s(m+1,i)*zbar(m,n,theta(i)) c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idg c = 6 error in the specification of jdg c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lshaec c = 10 error in the specification of lwork c c c **************************************************************** c subroutine shaeci(nlat,nlon,wshaec,lshaec,dwork,ldwork,ierror) c c subroutine shaeci initializes the array wshaec which can then c be used repeatedly by subroutine shaec. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c lshaec the dimension of the array wshaec as it appears in the c program that calls shaeci. the array wshaec is an output c parameter which is described below. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshaec must be at least c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c dwork a double precision dwork array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls shaeci. ldwork must be at least c nlat+1. c c c output parameters c c wshaec an array which is initialized for use by subroutine shaec. c once initialized, wshaec can be used repeatedly by shaec c as long as nlon and nlat remain unchanged. wshaec must c not be altered between calls of shaec. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshaec c = 4 error in the specification of ldwork c c c ******************************************************************* subroutine shaec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, 1 wshaec,lshaec,work,lwork,ierror) dimension g(idg,jdg,*),a(mdab,ndab,*),b(mdab,ndab,*),wshaec(*), 1 work(*) ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 if((isym.eq.0 .and. idg.lt.nlat) .or. 1 (isym.ne.0 .and. idg.lt.(nlat+1)/2)) return ierror = 6 if(jdg .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lzz1 = 2*nlat*imid labc = 3*((mmax-2)*(nlat+nlat-mmax-1))/2 if(lshaec .lt. lzz1+labc+nlon+15) return ierror = 10 ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon if(lwork .lt. nln+max0(ls*nlon,3*nlat*imid)) return ierror = 0 ist = 0 if(isym .eq. 0) ist = imid iw1 = lzz1+labc+1 call shaec1(nlat,isym,nt,g,idg,jdg,a,b,mdab,ndab,imid,ls,nlon, 1 work,work(ist+1),work(nln+1),work(nln+1),wshaec,wshaec(iw1)) return end subroutine shaec1(nlat,isym,nt,g,idgs,jdgs,a,b,mdab,ndab,imid, 1 idg,jdg,ge,go,work,zb,wzfin,whrfft) c c whrfft must have at least nlon+15 locations c wzfin must have 2*l*(nlat+1)/2 + ((l-3)*l+2)/2 locations c zb must have 3*l*(nlat+1)/2 locations c work must have ls*nlon locations c dimension g(idgs,jdgs,1),a(mdab,ndab,1),b(mdab,ndab,1), 1 ge(idg,jdg,1),go(idg,jdg,1),zb(imid,nlat,3),wzfin(1), 3 whrfft(1),work(1) ls = idg nlon = jdg mmax = min0(nlat,nlon/2+1) mdo = mmax if(mdo+mdo-1 .gt. nlon) mdo = mmax-1 nlp1 = nlat+1 tsn = 2./nlon fsn = 4./nlon modl = mod(nlat,2) imm1 = imid if(modl .ne. 0) imm1 = imid-1 if(isym .ne. 0) go to 15 do 5 k=1,nt do 5 i=1,imm1 do 5 j=1,nlon ge(i,j,k) = tsn*(g(i,j,k)+g(nlp1-i,j,k)) go(i,j,k) = tsn*(g(i,j,k)-g(nlp1-i,j,k)) 5 continue go to 30 15 do 20 k=1,nt do 20 i=1,imm1 do 20 j=1,nlon ge(i,j,k) = fsn*g(i,j,k) 20 continue if(isym .eq. 1) go to 27 30 if(modl .eq. 0) go to 27 do 25 k=1,nt do 25 j=1,nlon ge(imid,j,k) = tsn*g(imid,j,k) 25 continue 27 do 35 k=1,nt call hrfftf(ls,nlon,ge(1,1,k),ls,whrfft,work) if(mod(nlon,2) .ne. 0) go to 35 do 36 i=1,ls ge(i,nlon,k) = .5*ge(i,nlon,k) 36 continue 35 continue do 40 k=1,nt do 40 mp1=1,mmax do 40 np1=mp1,nlat a(mp1,np1,k) = 0. b(mp1,np1,k) = 0. 40 continue if(isym .eq. 1) go to 145 call zfin (2,nlat,nlon,0,zb,i3,wzfin) do 110 k=1,nt do 110 i=1,imid do 110 np1=1,nlat,2 a(1,np1,k) = a(1,np1,k)+zb(i,np1,i3)*ge(i,1,k) 110 continue ndo = nlat if(mod(nlat,2) .eq. 0) ndo = nlat-1 do 120 mp1=2,mdo m = mp1-1 call zfin (2,nlat,nlon,m,zb,i3,wzfin) do 120 k=1,nt do 120 i=1,imid do 120 np1=mp1,ndo,2 a(mp1,np1,k) = a(mp1,np1,k)+zb(i,np1,i3)*ge(i,2*mp1-2,k) b(mp1,np1,k) = b(mp1,np1,k)+zb(i,np1,i3)*ge(i,2*mp1-1,k) 120 continue if(mdo .eq. mmax .or. mmax .gt. ndo) go to 135 call zfin (2,nlat,nlon,mdo,zb,i3,wzfin) do 130 k=1,nt do 130 i=1,imid do 130 np1=mmax,ndo,2 a(mmax,np1,k) = a(mmax,np1,k)+zb(i,np1,i3)*ge(i,2*mmax-2,k) 130 continue 135 if(isym .eq. 2) return 145 call zfin (1,nlat,nlon,0,zb,i3,wzfin) do 150 k=1,nt do 150 i=1,imm1 do 150 np1=2,nlat,2 a(1,np1,k) = a(1,np1,k)+zb(i,np1,i3)*go(i,1,k) 150 continue ndo = nlat if(mod(nlat,2) .ne. 0) ndo = nlat-1 do 160 mp1=2,mdo m = mp1-1 mp2 = mp1+1 call zfin (1,nlat,nlon,m,zb,i3,wzfin) do 160 k=1,nt do 160 i=1,imm1 do 160 np1=mp2,ndo,2 a(mp1,np1,k) = a(mp1,np1,k)+zb(i,np1,i3)*go(i,2*mp1-2,k) b(mp1,np1,k) = b(mp1,np1,k)+zb(i,np1,i3)*go(i,2*mp1-1,k) 160 continue mp2 = mmax+1 if(mdo .eq. mmax .or. mp2 .gt. ndo) return call zfin (1,nlat,nlon,mdo,zb,i3,wzfin) do 170 k=1,nt do 170 i=1,imm1 do 170 np1=mp2,ndo,2 a(mmax,np1,k) = a(mmax,np1,k)+zb(i,np1,i3)*go(i,2*mmax-2,k) 170 continue return end subroutine shaeci(nlat,nlon,wshaec,lshaec,dwork,ldwork,ierror) dimension wshaec(lshaec) double precision dwork(ldwork) ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return ierror = 3 imid = (nlat+1)/2 mmax = min0(nlat,nlon/2+1) lzz1 = 2*nlat*imid labc = 3*((mmax-2)*(nlat+nlat-mmax-1))/2 if(lshaec .lt. lzz1+labc+nlon+15) return ierror = 4 if(ldwork .lt. nlat+1) return ierror = 0 call zfinit (nlat,nlon,wshaec,dwork) iw1 = lzz1+labc+1 call hrffti(nlon,wshaec(iw1)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file shaes.f c c this file contains code and documentation for subroutines c shaes and shaesi c c ... files which must be loaded with shaes.f c c sphcom.f, hrfft.f c c subroutine shaes(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, c + wshaes,lshaes,work,lwork,ierror) c c subroutine shaes performs the spherical harmonic analysis c on the array g and stores the result in the arrays a and b. c the analysis is performed on an equally spaced grid. the c associated legendre functions are stored rather than recomputed c as they are in subroutine shaec. the analysis is described c below at output parameters a,b. c c sphcom.f, hrfft.f c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c isym = 0 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c array g(i,j) for i=1,...,nlat and j=1,...,nlon. c (see description of g below) c c = 1 g is antisymmetric about the equator. the analysis c is performed on the northern hemisphere only. i.e. c if nlat is odd the analysis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the analysis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c = 2 g is symmetric about the equator. the analysis is c performed on the northern hemisphere only. i.e. c if nlat is odd the analysis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the analysis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of analyses. in the program that calls shaes, c the arrays g,a and b can be three dimensional in which c case multiple analyses will be performed. the third c index is the analysis index which assumes the values c k=1,...,nt. for a single analysis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that the arrays g,a and b c have only two dimensions. c c g a two or three dimensional array (see input parameter c nt) that contains the discrete function to be analyzed. c g(i,j) contains the value of the function at the colatitude c point theta(i) = (i-1)*pi/(nlat-1) and longitude point c phi(j) = (j-1)*2*pi/nlon. the index ranges are defined c above at the input parameter isym. c c c idg the first dimension of the array g as it appears in the c program that calls shaes. if isym equals zero then idg c must be at least nlat. if isym is nonzero then idg c must be at least nlat/2 if nlat is even or at least c (nlat+1)/2 if nlat is odd. c c jdg the second dimension of the array g as it appears in the c program that calls shaes. jdg must be at least nlon. c c mdab the first dimension of the arrays a and b as it appears c in the program that calls shaes. mdab must be at least c min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls shaes. ndab must be at least nlat c c wshaes an array which must be initialized by subroutine shaesi. c once initialized, wshaes can be used repeatedly by shaes c as long as nlon and nlat remain unchanged. wshaes must c not be altered between calls of shaes. c c lshaes the dimension of the array wshaes as it appears in the c program that calls shaes. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshaes must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shaes. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c (nt+1)*nlat*nlon. if isym is not zero then c lwork must be at least (nt+1)*l2*nlon. c c c ************************************************************** c c output parameters c c a,b both a,b are two or three dimensional arrays (see input c parameter nt) that contain the spherical harmonic c coefficients in the representation of g(i,j) given in the c discription of subroutine shses. for isym=0, a(m,n) and c b(m,n) are given by the equations listed below. symmetric c versions are used when isym is greater than zero. c c c c definitions c c 1. the normalized associated legendre functions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta) c c 2. the normalized z functions for m even c c zbar(m,n,theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of c the integral from tau = 0 to tau = pi of c cos(k*theta)*cos(k*tau)*pbar(m,n,tau)*sin(tau) c (first and last terms in this sum are divided c by 2) c c 3. the normalized z functions for m odd c c zbar(m,n,theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of c of the integral from tau = 0 to tau = pi of c sin(k*theta)*sin(k*tau)*pbar(m,n,tau)*sin(tau) c c 4. the fourier transform of g(i,j). c c c(m,i) = 2/nlon times the sum from j=1 to j=nlon c of g(i,j)*cos((m-1)*(j-1)*2*pi/nlon) c (the first and last terms in this sum c are divided by 2) c c s(m,i) = 2/nlon times the sum from j=2 to j=nlon c of g(i,j)*sin((m-1)*(j-1)*2*pi/nlon) c c 5. the maximum (plus one) longitudinal wave number c c mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b are c given by c c a(m+1,n+1) = the sum from i=1 to i=nlat of c c(m+1,i)*zbar(m,n,theta(i)) c (first and last terms in this sum are c divided by 2) c c b(m+1,n+1) = the sum from i=1 to i=nlat of c s(m+1,i)*zbar(m,n,theta(i)) c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idg c = 6 error in the specification of jdg c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lshaes c = 10 error in the specification of lwork c c c **************************************************************** c subroutine shaesi(nlat,nlon,wshaes,lshaes,work,lwork,dwork, c + ldwork,ierror) c c subroutine shaesi initializes the array wshaes which can then c be used repeatedly by subroutine shaes c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c lshaes the dimension of the array wshaes as it appears in the c program that calls shaesi. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshaes must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a real work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shaesi. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwork must be at least c c 5*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2 c c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls shaesi. ldwork must be at least nlat+1 c c c output parameters c c wshaes an array which is initialized for use by subroutine shaes. c once initialized, wshaes can be used repeatedly by shaes c as long as nlon and nlat remain unchanged. wshaes must c not be altered between calls of shaes. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshaes c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c c c **************************************************************** subroutine shaes(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, 1 wshaes,lshaes,work,lwork,ierror) dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1),wshaes(1), 1 work(1) ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 if((isym.eq.0 .and. idg.lt.nlat) .or. 1 (isym.ne.0 .and. idg.lt.(nlat+1)/2)) return ierror = 6 if(jdg .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 imid = (nlat+1)/2 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lshaes .lt. lzimn+nlon+15) return ierror = 10 ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon if(lwork .lt. nln+ls*nlon) return ierror = 0 ist = 0 if(isym .eq. 0) ist = imid call shaes1(nlat,isym,nt,g,idg,jdg,a,b,mdab,ndab,wshaes,idz, 1 ls,nlon,work,work(ist+1),work(nln+1),wshaes(lzimn+1)) return end subroutine shaes1(nlat,isym,nt,g,idgs,jdgs,a,b,mdab,ndab,z,idz, 1 idg,jdg,ge,go,work,whrfft) dimension g(idgs,jdgs,1),a(mdab,ndab,1),b(mdab,ndab,1),z(idz,1), 1 ge(idg,jdg,1),go(idg,jdg,1),work(1),whrfft(1) ls = idg nlon = jdg mmax = min0(nlat,nlon/2+1) mdo = mmax if(mdo+mdo-1 .gt. nlon) mdo = mmax-1 nlp1 = nlat+1 tsn = 2./nlon fsn = 4./nlon imid = (nlat+1)/2 modl = mod(nlat,2) imm1 = imid if(modl .ne. 0) imm1 = imid-1 if(isym .ne. 0) go to 15 do 5 k=1,nt do 5 i=1,imm1 do 5 j=1,nlon ge(i,j,k) = tsn*(g(i,j,k)+g(nlp1-i,j,k)) go(i,j,k) = tsn*(g(i,j,k)-g(nlp1-i,j,k)) 5 continue go to 30 15 do 20 k=1,nt do 20 i=1,imm1 do 20 j=1,nlon ge(i,j,k) = fsn*g(i,j,k) 20 continue if(isym .eq. 1) go to 27 30 if(modl .eq. 0) go to 27 do 25 k=1,nt do 25 j=1,nlon ge(imid,j,k) = tsn*g(imid,j,k) 25 continue 27 do 35 k=1,nt call hrfftf(ls,nlon,ge(1,1,k),ls,whrfft,work) if(mod(nlon,2) .ne. 0) go to 35 do 36 i=1,ls ge(i,nlon,k) = .5*ge(i,nlon,k) 36 continue 35 continue do 40 k=1,nt do 40 mp1=1,mmax do 40 np1=mp1,nlat a(mp1,np1,k) = 0. b(mp1,np1,k) = 0. 40 continue if(isym .eq. 1) go to 145 do 110 k=1,nt do 110 i=1,imid do 110 np1=1,nlat,2 a(1,np1,k) = a(1,np1,k)+z(np1,i)*ge(i,1,k) 110 continue ndo = nlat if(mod(nlat,2) .eq. 0) ndo = nlat-1 do 120 mp1=2,mdo m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 do 120 k=1,nt do 120 i=1,imid do 120 np1=mp1,ndo,2 a(mp1,np1,k) = a(mp1,np1,k)+z(np1+mb,i)*ge(i,2*mp1-2,k) b(mp1,np1,k) = b(mp1,np1,k)+z(np1+mb,i)*ge(i,2*mp1-1,k) 120 continue if(mdo .eq. mmax .or. mmax .gt. ndo) go to 135 mb = mdo*(nlat-1)-(mdo*(mdo-1))/2 do 130 k=1,nt do 130 i=1,imid do 130 np1=mmax,ndo,2 a(mmax,np1,k) = a(mmax,np1,k)+z(np1+mb,i)*ge(i,2*mmax-2,k) 130 continue 135 if(isym .eq. 2) return 145 do 150 k=1,nt do 150 i=1,imm1 do 150 np1=2,nlat,2 a(1,np1,k) = a(1,np1,k)+z(np1,i)*go(i,1,k) 150 continue ndo = nlat if(mod(nlat,2) .ne. 0) ndo = nlat-1 do 160 mp1=2,mdo m = mp1-1 mp2 = mp1+1 mb = m*(nlat-1)-(m*(m-1))/2 do 160 k=1,nt do 160 i=1,imm1 do 160 np1=mp2,ndo,2 a(mp1,np1,k) = a(mp1,np1,k)+z(np1+mb,i)*go(i,2*mp1-2,k) b(mp1,np1,k) = b(mp1,np1,k)+z(np1+mb,i)*go(i,2*mp1-1,k) 160 continue mp2 = mmax+1 if(mdo .eq. mmax .or. mp2 .gt. ndo) return mb = mdo*(nlat-1)-(mdo*(mdo-1))/2 do 170 k=1,nt do 170 i=1,imm1 do 170 np1=mp2,ndo,2 a(mmax,np1,k) = a(mmax,np1,k)+z(np1+mb,i)*go(i,2*mmax-2,k) 170 continue return end subroutine shaesi(nlat,nlon,wshaes,lshaes,work,lwork,dwork, + ldwork,ierror) dimension wshaes(*),work(*) double precision dwork(*) c c length of wshaes is (l*(l+1)*imid)/2+nlon+15 c length of work is 5*l*imid + 3*((l-3)*l+2)/2 c ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return ierror = 3 mmax = min0(nlat,nlon/2+1) imid = (nlat+1)/2 lzimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshaes .lt. lzimn+nlon+15) return ierror = 4 labc = 3*((mmax-2)*(nlat+nlat-mmax-1))/2 if(lwork .lt. 5*nlat*imid + labc) return ierror = 5 if (ldwork .lt. nlat+1) return ierror = 0 iw1 = 3*nlat*imid+1 idz = (mmax*(nlat+nlat-mmax+1))/2 call sea1(nlat,nlon,imid,wshaes,idz,work,work(iw1),dwork) call hrffti(nlon,wshaes(lzimn+1)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file shagc.f c c this file contains code and documentation for subroutines c shagc and shagci c c ... files which must be loaded with shagc.f c c sphcom.f, hrfft.f, gaqd.f c c c subroutine shagc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, c + wshagc,lshagc,work,lwork,ierror) c c subroutine shagc performs the spherical harmonic analysis c on the array g and stores the result in the arrays a and b. c the analysis is performed on a gaussian grid in colatitude c and an equally spaced grid in longitude. the associated c legendre functions are recomputed rather than stored as they c are in subroutine shags. the analysis is described below c at output parameters a,b. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c isym = 0 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c array g(i,j) for i=1,...,nlat and j=1,...,nlon. c (see description of g below) c c = 1 g is antisymmetric about the equator. the analysis c is performed on the northern hemisphere only. i.e. c if nlat is odd the analysis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the analysis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c = 2 g is symmetric about the equator. the analysis is c performed on the northern hemisphere only. i.e. c if nlat is odd the analysis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the analysis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of analyses. in the program that calls shagc, c the arrays g,a and b can be three dimensional in which c case multiple analyses will be performed. the third c index is the analysis index which assumes the values c k=1,...,nt. for a single analysis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that the arrays g,a and b c have only two dimensions. c c g a two or three dimensional array (see input parameter c nt) that contains the discrete function to be analyzed. c g(i,j) contains the value of the function at the gaussian c point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon c the index ranges are defined above at the input parameter c isym. c c idg the first dimension of the array g as it appears in the c program that calls shagc. if isym equals zero then idg c must be at least nlat. if isym is nonzero then idg must c be at least nlat/2 if nlat is even or at least (nlat+1)/2 c if nlat is odd. c c jdg the second dimension of the array g as it appears in the c program that calls shagc. jdg must be at least nlon. c c mdab the first dimension of the arrays a and b as it appears c in the program that calls shagc. mdab must be at least c min0((nlon+2)/2,nlat) if nlon is even or at least c min0((nlon+1)/2,nlat) if nlon is odd c c ndab the second dimension of the arrays a and b as it appears c in the program that calls shaec. ndab must be at least nlat c c wshagc an array which must be initialized by subroutine shagci. c once initialized, wshagc can be used repeatedly by shagc. c as long as nlat and nlon remain unchanged. wshagc must c not be altered between calls of shagc. c c lshagc the dimension of the array wshagc as it appears in the c program that calls shagc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshagc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shagc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*(nlon*nt+max0(3*l2,nlon)) c c if isym is not zero then lwork must be at least c c l2*(nlon*nt+max0(3*nlat,nlon)) c c ************************************************************** c c output parameters c c a,b both a,b are two or three dimensional arrays (see input c parameter nt) that contain the spherical harmonic c coefficients in the representation of g(i,j) given in the c discription of subroutine shagc. for isym=0, a(m,n) and c b(m,n) are given by the equations listed below. symmetric c versions are used when isym is greater than zero. c c definitions c c 1. the normalized associated legendre functions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta). c c 2. the fourier transform of g(i,j). c c c(m,i) = 2/nlon times the sum from j=1 to j=nlon of c g(i,j)*cos((m-1)*(j-1)*2*pi/nlon) c (the first and last terms in this sum c are divided by 2) c c s(m,i) = 2/nlon times the sum from j=2 to j=nlon of c g(i,j)*sin((m-1)*(j-1)*2*pi/nlon) c c c 3. the gaussian points and weights on the sphere c (computed by subroutine gaqd). c c theta(1),...,theta(nlat) (gaussian pts in radians) c wts(1),...,wts(nlat) (corresponding gaussian weights) c c 4. the maximum (plus one) longitudinal wave number c c mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c c then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b c are given by c c a(m+1,n+1) = the sum from i=1 to i=nlat of c c(m+1,i)*wts(i)*pbar(m,n,theta(i)) c c b(m+1,n+1) = the sum from i=1 to nlat of c s(m+1,i)*wts(i)*pbar(m,n,theta(i)) c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idg c = 6 error in the specification of jdg c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lshagc c = 10 error in the specification of lwork c c c **************************************************************** c c subroutine shagci(nlat,nlon,wshagc,lshagc,dwork,ldwork,ierror) c c subroutine shagci initializes the array wshagc which can then c be used repeatedly by subroutines shagc. it precomputes c and stores in wshagc quantities such as gaussian weights, c legendre polynomial coefficients, and fft trigonometric tables. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c wshagc an array which must be initialized by subroutine shagci. c once initialized, wshagc can be used repeatedly by shagc c as long as nlat and nlon remain unchanged. wshagc must c not be altered between calls of shagc. c c lshagc the dimension of the array wshagc as it appears in the c program that calls shagc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshagc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls shagci. ldwork must be at least c c nlat*(nlat+4) c c output parameter c c wshagc an array which must be initialized before calling shagc or c once initialized, wshagc can be used repeatedly by shagc or c as long as nlat and nlon remain unchanged. wshagc must not c altered between calls of shagc. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshagc c = 4 error in the specification of ldwork c = 5 failure in gaqd to compute gaussian points c (due to failure in eigenvalue routine) c c c **************************************************************** subroutine shagc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, 1 wshagc,lshagc,work,lwork,ierror) c subroutine shagc performs the spherical harmonic analysis on c a gaussian grid on the array(s) in g and returns the coefficients c in array(s) a,b. the necessary legendre polynomials are computed c as needed in this version. c dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1), 1 wshagc(lshagc),work(lwork) c check input parameters ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return ierror = 3 if (isym.lt.0 .or.isym.gt.2) return ierror = 4 if (nt.lt.1) return c set upper limit on m for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set gaussian point nearest equator pointer late = (nlat+mod(nlat,2))/2 c set number of grid points for analysis/synthesis lat = nlat if (isym.ne.0) lat = late ierror = 5 if (idg.lt.lat) return ierror = 6 if (jdg.lt.nlon) return ierror = 7 if(mdab .lt. l) return ierror = 8 if(ndab .lt. nlat) return l1 = l l2 = late ierror = 9 c check permanent work space length if (lshagc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 10 c check temporary work space length if (isym.eq.0) then if(lwork.lt.nlat*(nlon*nt+max0(3*l2,nlon))) return else c isym.ne.0 if(lwork.lt.l2*(nlon*nt+max0(3*nlat,nlon))) return end if ierror = 0 c starting address for gaussian wts in shigc and fft values iwts = 1 ifft = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+1 c set pointers for internal storage of g and legendre polys ipmn = lat*nlon*nt+1 call shagc1(nlat,nlon,l,lat,isym,g,idg,jdg,nt,a,b,mdab,ndab, 1wshagc,wshagc(iwts),wshagc(ifft),late,work(ipmn),work) return end subroutine shagc1(nlat,nlon,l,lat,mode,gs,idg,jdg,nt,a,b,mdab, 1 ndab,w,wts,wfft,late,pmn,g) dimension gs(idg,jdg,nt),a(mdab,ndab,nt), 1 b(mdab,ndab,nt),g(lat,nlon,nt) dimension w(1),wts(nlat),wfft(1),pmn(nlat,late,3) c set gs array internally in shagc1 do 100 k=1,nt do 100 j=1,nlon do 100 i=1,lat g(i,j,k) = gs(i,j,k) 100 continue c do fourier transform do 101 k=1,nt call hrfftf(lat,nlon,g(1,1,k),lat,wfft,pmn) 101 continue c scale result sfn = 2.0/float(nlon) do 102 k=1,nt do 102 j=1,nlon do 102 i=1,lat g(i,j,k) = sfn*g(i,j,k) 102 continue c compute using gaussian quadrature c a(n,m) = s (ga(theta,m)*pnm(theta)*sin(theta)*dtheta) c b(n,m) = s (gb(theta,m)*pnm(theta)*sin(theta)*dtheta) c here ga,gb are the cos(phi),sin(phi) coefficients of c the fourier expansion of g(theta,phi) in phi. as a result c of the above fourier transform they are stored in array c g as follows: c for each theta(i) and k= l-1 c ga(0),ga(1),gb(1),ga(2),gb(2),...,ga(k-1),gb(k-1),ga(k) c correspond to (in the case nlon=l+l-2) c g(i,1),g(i,2),g(i,3),g(i,4),g(i,5),...,g(i,2l-4),g(i,2l-3),g(i,2l- c initialize coefficients to zero do 103 k=1,nt do 103 np1=1,nlat do 103 mp1=1,l a(mp1,np1,k) = 0.0 b(mp1,np1,k) = 0.0 103 continue c set m+1 limit on b(m+1) calculation lm1 = l if (nlon .eq. l+l-2) lm1 = l-1 if (mode.eq.0) then c for full sphere (mode=0) and even/odd reduction: c overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i) c overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i) nl2 = nlat/2 do 104 k=1,nt do 104 j=1,nlon do 105 i=1,nl2 is = nlat-i+1 t1 = g(i,j,k) t2 = g(is,j,k) g(i,j,k) = wts(i)*(t1+t2) g(is,j,k) = wts(i)*(t1-t2) 105 continue c adjust equator if necessary(nlat odd) if (mod(nlat,2).ne.0) g(late,j,k) = wts(late)*g(late,j,k) 104 continue c set m = 0 coefficients first m = 0 call legin(mode,l,nlat,m,w,pmn,km) do 106 k=1,nt do 106 i=1,late is = nlat-i+1 do 107 np1=1,nlat,2 c n even a(1,np1,k) = a(1,np1,k)+g(i,1,k)*pmn(np1,i,km) 107 continue do 108 np1=2,nlat,2 c n odd a(1,np1,k) = a(1,np1,k)+g(is,1,k)*pmn(np1,i,km) 108 continue 106 continue c compute coefficients for which b(m,n) is available do 109 mp1=2,lm1 m = mp1-1 mp2 = m+2 c compute pmn for all i and n=m,...,l-1 call legin(mode,l,nlat,m,w,pmn,km) do 110 k=1,nt do 111 i=1,late is = nlat-i+1 c n-m even do 112 np1=mp1,nlat,2 a(mp1,np1,k) = a(mp1,np1,k)+g(i,2*m,k)*pmn(np1,i,km) b(mp1,np1,k) = b(mp1,np1,k)+g(i,2*m+1,k)*pmn(np1,i,km) 112 continue c n-m odd do 113 np1=mp2,nlat,2 a(mp1,np1,k) = a(mp1,np1,k)+g(is,2*m,k)*pmn(np1,i,km) b(mp1,np1,k) = b(mp1,np1,k)+g(is,2*m+1,k)*pmn(np1,i,km) 113 continue 111 continue 110 continue 109 continue if (nlon .eq. l+l-2) then c compute a(l,np1) coefficients only m = l-1 call legin(mode,l,nlat,m,w,pmn,km) do 114 k=1,nt do 114 i=1,late is = nlat-i+1 c n-m even do 124 np1=l,nlat,2 a(l,np1,k) = a(l,np1,k)+0.5*g(i,nlon,k)*pmn(np1,i,km) 124 continue lp1 = l+1 c n-m odd do 125 np1=lp1,nlat,2 a(l,np1,k) = a(l,np1,k)+0.5*g(is,nlon,k)*pmn(np1,i,km) 125 continue 114 continue end if else c half sphere c overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1,...,nlate/2 nl2 = nlat/2 do 116 k=1,nt do 116 j=1,nlon do 115 i=1,nl2 g(i,j,k) = wts(i)*(g(i,j,k)+g(i,j,k)) 115 continue c adjust equator separately if a grid point if (nl2.lt.late) g(late,j,k) = wts(late)*g(late,j,k) 116 continue c set m = 0 coefficients first m = 0 call legin(mode,l,nlat,m,w,pmn,km) ms = 1 if (mode.eq.1) ms = 2 do 117 k=1,nt do 117 i=1,late do 117 np1=ms,nlat,2 a(1,np1,k) = a(1,np1,k)+g(i,1,k)*pmn(np1,i,km) 117 continue c compute coefficients for which b(m,n) is available do 118 mp1=2,lm1 m = mp1-1 ms = mp1 if (mode.eq.1) ms = mp1+1 c compute pmn for all i and n=m,...,nlat-1 call legin(mode,l,nlat,m,w,pmn,km) do 119 k=1,nt do 119 i=1,late do 119 np1=ms,nlat,2 a(mp1,np1,k) = a(mp1,np1,k)+g(i,2*m,k)*pmn(np1,i,km) b(mp1,np1,k) = b(mp1,np1,k)+g(i,2*m+1,k)*pmn(np1,i,km) 119 continue 118 continue if (nlon.eq.l+l-2) then c compute coefficient a(l,np1) only m = l-1 call legin(mode,l,nlat,m,w,pmn,km) ns = l if (mode.eq.1) ns = l+1 do 120 k=1,nt do 120 i=1,late do 120 np1=ns,nlat,2 a(l,np1,k) = a(l,np1,k)+0.5*g(i,nlon,k)*pmn(np1,i,km) 120 continue end if end if return end subroutine shagci(nlat,nlon,wshagc,lshagc,dwork,ldwork,ierror) c this subroutine must be called before calling shagc with c fixed nlat,nlon. it precomputes quantites such as the gaussian c points and weights, m=0,m=1 legendre polynomials, recursion c recursion coefficients. dimension wshagc(lshagc) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+mod(nlat,2))/2 l1 = l l2 = late ierror = 3 c check permanent work space length if (lshagc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 4 if (ldwork.lt.nlat*(nlat+4))return ierror = 0 c set pointers i1 = 1 i2 = i1+nlat i3 = i2+nlat*late i4 = i3+nlat*late i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1) i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1) i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1) c set indices in temp work for double precision gaussian wts and pts idth = 1 idwts = idth+nlat iw = idwts+nlat call shagci1(nlat,nlon,l,late,wshagc(i1),wshagc(i2),wshagc(i3), 1wshagc(i4),wshagc(i5),wshagc(i6),wshagc(i7),dwork(idth), 2dwork(idwts),dwork(iw),ierror) if (ierror.ne.0) ierror = 5 return end subroutine shagci1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel, 1 wfft,dtheta,dwts,work,ier) dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1), 1 cbel(1),wfft(1) double precision pb,dtheta(nlat),dwts(nlat),work(*) c compute the nlat gaussian points and weights, the c m=0,1 legendre polys for gaussian points and all n, c and the legendre recursion coefficients c define index function used in storing c arrays for recursion coefficients (functions of (m,n)) c the index function indx(m,n) is defined so that c the pairs (m,n) map to [1,2,...,indx(l-1,l-1)] with no c "holes" as m varies from 2 to n and n varies from 2 to l-1. c (m=0,1 are set from p0n,p1n for all n) c define for 2.le.n.le.l-1 indx(m,n) = (n-1)*(n-2)/2+m-1 c define index function for l.le.n.le.nlat imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1 c preset quantites for fourier transform call hrffti(nlon,wfft) c compute double precision gaussian points and weights c lw = 4*nlat*(nlat+1)+2 lw = nlat*(nlat+2) call gaqd(nlat,dtheta,dwts,work,lw,ier) if (ier.ne.0) return c store gaussian weights single precision to save computation c in inner loops in analysis do 100 i=1,nlat wts(i) = dwts(i) 100 continue c initialize p0n,p1n using double precision dnlfk,dnlft do 101 np1=1,nlat do 101 i=1,late p0n(np1,i) = 0.0 p1n(np1,i) = 0.0 101 continue c compute m=n=0 legendre polynomials for all theta(i) np1 = 1 n = 0 m = 0 call dnlfk(m,n,work) do 103 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(1,i) = pb 103 continue c compute p0n,p1n for all theta(i) when n.gt.0 do 104 np1=2,nlat n = np1-1 m = 0 call dnlfk(m,n,work) do 105 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(np1,i) = pb 105 continue c compute m=1 legendre polynomials for all n and theta(i) m = 1 call dnlfk(m,n,work) do 106 i=1,late call dnlft(m,n,dtheta(i),work,pb) p1n(np1,i) = pb 106 continue 104 continue c compute and store swarztrauber recursion coefficients c for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel do 107 n=2,nlat mlim = min0(n,l) do 107 m=2,mlim imn = indx(m,n) if (n.ge.l) imn = imndx(m,n) abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/ 1 float(((n+m-1)*(n+m)))) 107 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file shags.f c c this file contains code and documentation for subroutines c shags and shagsi c c ... files which must be loaded with shags.f c c sphcom.f, hrfft.f, gaqd.f c c subroutine shags(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, c 1 wshags,lshags,work,lwork,ierror) c c subroutine shags performs the spherical harmonic analysis c on the array g and stores the result in the arrays a and b. c the analysis is performed on a gaussian grid in colatitude c and an equally spaced grid in longitude. the associated c legendre functions are stored rather than recomputed as they c are in subroutine shagc. the analysis is described below c at output parameters a,b. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c isym = 0 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c array g(i,j) for i=1,...,nlat and j=1,...,nlon. c (see description of g below) c c = 1 g is antisymmetric about the equator. the analysis c is performed on the northern hemisphere only. i.e. c if nlat is odd the analysis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the analysis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c = 2 g is symmetric about the equator. the analysis is c performed on the northern hemisphere only. i.e. c if nlat is odd the analysis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the analysis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of analyses. in the program that calls shags, c the arrays g,a and b can be three dimensional in which c case multiple analyses will be performed. the third c index is the analysis index which assumes the values c k=1,...,nt. for a single analysis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that the arrays g,a and b c have only two dimensions. c c g a two or three dimensional array (see input parameter c nt) that contains the discrete function to be analyzed. c g(i,j) contains the value of the function at the gaussian c point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon c the index ranges are defined above at the input parameter c isym. c c idg the first dimension of the array g as it appears in the c program that calls shags. if isym equals zero then idg c must be at least nlat. if isym is nonzero then idg must c be at least nlat/2 if nlat is even or at least (nlat+1)/2 c if nlat is odd. c c jdg the second dimension of the array g as it appears in the c program that calls shags. jdg must be at least nlon. c c mdab the first dimension of the arrays a and b as it appears c in the program that calls shags. mdab must be at least c min0((nlon+2)/2,nlat) if nlon is even or at least c min0((nlon+1)/2,nlat) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls shags. ndab must be at least nlat c c wshags an array which must be initialized by subroutine shagsi. c once initialized, wshags can be used repeatedly by shags c as long as nlat and nlon remain unchanged. wshags must c not be altered between calls of shags. c c lshags the dimension of the array wshags as it appears in the c program that calls shags. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshags must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c work a real work space which need not be saved c c c lwork the dimension of the array work as it appears in the c program that calls shags. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c c if isym is zero then lwork must be at least c c nlat*nlon*(nt+1) c c if isym is nonzero then lwork must be at least c c l2*nlon*(nt+1) c c ************************************************************** c c output parameters c c a,b both a,b are two or three dimensional arrays (see input c parameter nt) that contain the spherical harmonic c coefficients in the representation of g(i,j) given in the c discription of subroutine shags. for isym=0, a(m,n) and c b(m,n) are given by the equations listed below. symmetric c versions are used when isym is greater than zero. c c definitions c c 1. the normalized associated legendre functions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta). c c 2. the fourier transform of g(i,j). c c c(m,i) = 2/nlon times the sum from j=1 to j=nlon of c g(i,j)*cos((m-1)*(j-1)*2*pi/nlon) c (the first and last terms in this sum c are divided by 2) c c s(m,i) = 2/nlon times the sum from j=2 to j=nlon of c g(i,j)*sin((m-1)*(j-1)*2*pi/nlon) c c c 3. the gaussian points and weights on the sphere c (computed by subroutine gaqd). c c theta(1),...,theta(nlat) (gaussian pts in radians) c wts(1),...,wts(nlat) (corresponding gaussian weights) c c c 4. the maximum (plus one) longitudinal wave number c c mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c c then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b c are given by c c a(m+1,n+1) = the sum from i=1 to i=nlat of c c(m+1,i)*wts(i)*pbar(m,n,theta(i)) c c b(m+1,n+1) = the sum from i=1 to nlat of c s(m+1,i)*wts(i)*pbar(m,n,theta(i)) c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idg c = 6 error in the specification of jdg c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lshags c = 10 error in the specification of lwork c c c **************************************************************** c c subroutine shagsi(nlat,nlon,wshags,lshags,work,lwork,dwork,ldwork, c + ierror) c c subroutine shagsi initializes the array wshags which can then c be used repeatedly by subroutines shags. it precomputes c and stores in wshags quantities such as gaussian weights, c legendre polynomial coefficients, and fft trigonometric tables. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c wshags an array which must be initialized by subroutine shagsi. c once initialized, wshags can be used repeatedly by shags c as long as nlat and nlon remain unchanged. wshags must c not be altered between calls of shags. c c lshags the dimension of the array wshags as it appears in the c program that calls shags. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshags must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c work a real work space which need not be saved c c lwork the dimension of the array work as it appears in the c program that calls shagsi. lwork must be at least c 4*nlat*(nlat+2)+2 in the routine calling shagsi c c dwork a double precision work array that does not have to be saved. c c ldwork the length of dwork in the calling routine. ldwork must c be at least nlat*(nlat+4) c c output parameter c c wshags an array which must be initialized before calling shags or c once initialized, wshags can be used repeatedly by shags or c as long as nlat and nlon remain unchanged. wshags must not c altered between calls of shasc. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshags c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c = 6 failure in gaqd to compute gaussian points c (due to failure in eigenvalue routine) c c c **************************************************************** subroutine shags(nlat,nlon,mode,nt,g,idg,jdg,a,b,mdab,ndab, 1 wshags,lshags,work,lwork,ierror) c subroutine shags performs the spherical harmonic analysis on c a gaussian grid on the array(s) in g and returns the coefficients c in array(s) a,b. the necessary legendre polynomials are fully c stored in this version. c dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1), 1 wshags(lshags),work(lwork) c check input parameters ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return ierror = 3 if (mode.lt.0 .or.mode.gt.2) return c set m limit for pmn l = min0((nlon+2)/2,nlat) c set gaussian point nearest equator pointer late = (nlat+mod(nlat,2))/2 c set number of grid points for analysis/synthesis lat = nlat if (mode.ne.0) lat = late ierror = 4 if (nt.lt.1) return ierror = 5 if (idg.lt.lat) return ierror = 6 if (jdg.lt.nlon) return ierror = 7 if(mdab .lt. l) return ierror = 8 if(ndab .lt. nlat) return l1 = l l2 = late ierror = 9 c check permanent work space length c lp= nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshags.lt.lp) return ierror = 10 c check temporary work space length if (mode.eq.0 .and. lwork.lt.nlat*nlon*(nt+1)) return if (mode.ne.0 .and. lwork.lt.l2*nlon*(nt+1)) return ierror = 0 c set starting address for gaussian wts ,fft values, c and fully stored legendre polys in wshags iwts = 1 ifft = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+1 ipmn = ifft+nlon+15 c set pointer for internal storage of g iw = lat*nlon*nt+1 call shags1(nlat,nlon,l,lat,mode,g,idg,jdg,nt,a,b,mdab,ndab, 1wshags(iwts),wshags(ifft),wshags(ipmn),late,work,work(iw)) return end subroutine shags1(nlat,nlon,l,lat,mode,gs,idg,jdg,nt,a,b,mdab, 1 ndab,wts,wfft,pmn,late,g,work) dimension gs(idg,jdg,nt),a(mdab,ndab,nt), 1 b(mdab,ndab,nt),g(lat,nlon,nt) dimension wfft(1),pmn(late,1),wts(nlat),work(1) c set gs array internally in shags1 do 100 k=1,nt do 100 j=1,nlon do 100 i=1,lat g(i,j,k) = gs(i,j,k) 100 continue c do fourier transform do 101 k=1,nt call hrfftf(lat,nlon,g(1,1,k),lat,wfft,work) 101 continue c scale result sfn = 2.0/float(nlon) do 102 k=1,nt do 102 j=1,nlon do 102 i=1,lat g(i,j,k) = sfn*g(i,j,k) 102 continue c compute using gaussian quadrature c a(n,m) = s (ga(theta,m)*pnm(theta)*sin(theta)*dtheta) c b(n,m) = s (gb(theta,m)*pnm(theta)*sin(theta)*dtheta) c here ga,gb are the cos(phi),sin(phi) coefficients of c the fourier expansion of g(theta,phi) in phi. as a result c of the above fourier transform they are stored in array c g as follows: c for each theta(i) and k= l-1 c ga(0),ga(1),gb(1),ga(2),gb(2),...,ga(k-1),gb(k-1),ga(k) c correspond to c g(i,1),g(i,2),g(i,3),g(i,4),g(i,5),...,g(i,2l-4),g(i,2l-3),g(i,2l-2) c whenever 2*l-2 = nlon exactly c initialize coefficients to zero do 103 k=1,nt do 103 np1=1,nlat do 103 mp1=1,l a(mp1,np1,k) = 0.0 b(mp1,np1,k) = 0.0 103 continue c set mp1 limit on b(mp1) calculation lm1 = l if (nlon .eq. l+l-2) lm1 = l-1 if (mode.eq.0) then c for full sphere (mode=0) and even/odd reduction: c overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i) c overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i) nl2 = nlat/2 do 104 k=1,nt do 104 j=1,nlon do 105 i=1,nl2 is = nlat-i+1 t1 = g(i,j,k) t2 = g(is,j,k) g(i,j,k) = wts(i)*(t1+t2) g(is,j,k) = wts(i)*(t1-t2) 105 continue c adjust equator if necessary(nlat odd) if (mod(nlat,2).ne.0) g(late,j,k) = wts(late)*g(late,j,k) 104 continue c set m = 0 coefficients first mp1 = 1 m = 0 mml1 = m*(2*nlat-m-1)/2 do 106 k=1,nt do 106 i=1,late is = nlat-i+1 do 107 np1=1,nlat,2 c n even a(1,np1,k) = a(1,np1,k)+g(i,1,k)*pmn(i,mml1+np1) 107 continue do 108 np1=2,nlat,2 c n odd a(1,np1,k) = a(1,np1,k)+g(is,1,k)*pmn(i,mml1+np1) 108 continue 106 continue c compute m.ge.1 coefficients next do 109 mp1=2,lm1 m = mp1-1 mml1 = m*(2*nlat-m-1)/2 mp2 = mp1+1 do 110 k=1,nt do 111 i=1,late is = nlat-i+1 c n-m even do 112 np1=mp1,nlat,2 a(mp1,np1,k) = a(mp1,np1,k)+g(i,2*m,k)*pmn(i,mml1+np1) b(mp1,np1,k) = b(mp1,np1,k)+g(i,2*m+1,k)*pmn(i,mml1+np1) 112 continue c n-m odd do 113 np1=mp2,nlat,2 a(mp1,np1,k) = a(mp1,np1,k)+g(is,2*m,k)*pmn(i,mml1+np1) b(mp1,np1,k) = b(mp1,np1,k)+g(is,2*m+1,k)*pmn(i,mml1+np1) 113 continue 111 continue 110 continue 109 continue if (nlon .eq. l+l-2) then c compute m=l-1, n=l-1,l,...,nlat-1 coefficients m = l-1 mml1 = m*(2*nlat-m-1)/2 do 114 k=1,nt do 114 i=1,late is = nlat-i+1 do 124 np1=l,nlat,2 mn = mml1+np1 a(l,np1,k) = a(l,np1,k)+0.5*g(i,nlon,k)*pmn(i,mn) 124 continue c n-m odd lp1 = l+1 do 125 np1=lp1,nlat,2 mn = mml1+np1 a(l,np1,k) = a(l,np1,k)+0.5*g(is,nlon,k)*pmn(i,mn) 125 continue 114 continue end if else c half sphere c overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1,...,nlate/2 nl2 = nlat/2 do 116 k=1,nt do 116 j=1,nlon do 115 i=1,nl2 g(i,j,k) = wts(i)*(g(i,j,k)+g(i,j,k)) 115 continue c adjust equator separately if a grid point if (nl2.lt.late) g(late,j,k) = wts(late)*g(late,j,k) 116 continue c set m = 0 coefficients first mp1 = 1 m = 0 mml1 = m*(2*nlat-m-1)/2 ms = 1 if (mode.eq.1) ms = 2 do 117 k=1,nt do 117 i=1,late do 117 np1=ms,nlat,2 a(1,np1,k) = a(1,np1,k)+g(i,1,k)*pmn(i,mml1+np1) 117 continue c compute m.ge.1 coefficients next do 118 mp1=2,lm1 m = mp1-1 mml1 = m*(2*nlat-m-1)/2 ms = mp1 if (mode.eq.1) ms = mp1+1 do 119 k=1,nt do 119 i=1,late do 119 np1=ms,nlat,2 a(mp1,np1,k) = a(mp1,np1,k)+g(i,2*m,k)*pmn(i,mml1+np1) b(mp1,np1,k) = b(mp1,np1,k)+g(i,2*m+1,k)*pmn(i,mml1+np1) 119 continue 118 continue if (nlon.eq.l+l-2) then c compute n=m=l-1 coefficients last m = l-1 mml1 = m*(2*nlat-m-1)/2 c set starting n for mode even ns = l c set starting n for mode odd if (mode.eq.1) ns = l+1 do 120 k=1,nt do 120 i=1,late do 120 np1=ns,nlat,2 mn = mml1+np1 a(l,np1,k) = a(l,np1,k)+0.5*g(i,nlon,k)*pmn(i,mn) 120 continue end if end if return end subroutine shagsi(nlat,nlon,wshags,lshags,work,lwork,dwork,ldwork, + ierror) c c this subroutine must be called before calling shags or shsgs with c fixed nlat,nlon. it precomputes the gaussian weights, points c and all necessary legendre polys and stores them in wshags. c these quantities must be preserved when calling shags or shsgs c repeatedly with fixed nlat,nlon. dwork must be of length at c least nlat*(nlat+4) in the routine calling shagsi. This is c not checked. undetectable errors will result if dwork is c smaller than nlat*(nlat+4). c dimension wshags(lshags),work(lwork) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+1)/2 l1 = l l2 = late c check permanent work space length ierror = 3 lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshags.lt.lp) return ierror = 4 c check temporary work space if (lwork.lt.4*nlat*(nlat+2)+2) return ierror = 5 c check double precision temporary space if (ldwork .lt. nlat*(nlat+4)) return ierror = 0 c set preliminary quantites needed to compute and store legendre polys ldw = nlat*(nlat+4) call shagsp(nlat,nlon,wshags,lshags,dwork,ldwork,ierror) if (ierror.ne.0) return c set legendre poly pointer in wshags ipmnf = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+nlon+16 call shagss1(nlat,l,late,wshags,work,wshags(ipmnf)) return end subroutine shagsp(nlat,nlon,wshags,lshags,dwork,ldwork,ierror) dimension wshags(lshags) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+mod(nlat,2))/2 l1 = l l2 = late ierror = 3 c check permanent work space length if (lshags .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 4 c if (lwork.lt.4*nlat*(nlat+2)+2) return if (ldwork.lt.nlat*(nlat+4))return ierror = 0 c set pointers i1 = 1 i2 = i1+nlat i3 = i2+nlat*late i4 = i3+nlat*late i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1) i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1) i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1) c set indices in temp work for double precision gaussian wts and pts idth = 1 c idwts = idth+2*nlat c iw = idwts+2*nlat idwts = idth+nlat iw = idwts+nlat call shagsp1(nlat,nlon,l,late,wshags(i1),wshags(i2),wshags(i3), 1wshags(i4),wshags(i5),wshags(i6),wshags(i7),dwork(idth), 2dwork(idwts),dwork(iw),ierror) if (ierror.ne.0) ierror = 6 return end subroutine shagsp1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel, + wfft,dtheta,dwts,work,ier) dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1), 1 cbel(1),wfft(1),dtheta(nlat),dwts(nlat) double precision pb,dtheta,dwts,work(*) indx(m,n) = (n-1)*(n-2)/2+m-1 imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1 call hrffti(nlon,wfft) c compute double precision gaussian points and weights c lw = 4*nlat*(nlat+2) lw = nlat*(nlat+2) call gaqd(nlat,dtheta,dwts,work,lw,ier) if (ier.ne.0) return c store gaussian weights single precision to save computation c in inner loops in analysis do 100 i=1,nlat wts(i) = dwts(i) 100 continue c initialize p0n,p1n using double precision dnlfk,dnlft do 101 np1=1,nlat do 101 i=1,late p0n(np1,i) = 0.0 p1n(np1,i) = 0.0 101 continue c compute m=n=0 legendre polynomials for all theta(i) np1 = 1 n = 0 m = 0 call dnlfk(m,n,work) do 103 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(1,i) = pb 103 continue c compute p0n,p1n for all theta(i) when n.gt.0 do 104 np1=2,nlat n = np1-1 m = 0 call dnlfk(m,n,work) do 105 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(np1,i) = pb 105 continue c compute m=1 legendre polynomials for all n and theta(i) m = 1 call dnlfk(m,n,work) do 106 i=1,late call dnlft(m,n,dtheta(i),work,pb) p1n(np1,i) = pb 106 continue 104 continue c c compute and store swarztrauber recursion coefficients c for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel do 107 n=2,nlat mlim = min0(n,l) do 107 m=2,mlim imn = indx(m,n) if (n.ge.l) imn = imndx(m,n) abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/ 1 float(((n+m-1)*(n+m)))) 107 continue return end subroutine shagss1(nlat,l,late,w,pmn,pmnf) dimension w(1),pmn(nlat,late,3),pmnf(late,1) c compute and store legendre polys for i=1,...,late,m=0,...,l-1 c and n=m,...,l-1 do i=1,nlat do j=1,late do k=1,3 pmn(i,j,k) = 0.0 end do end do end do do 100 mp1=1,l m = mp1-1 mml1 = m*(2*nlat-m-1)/2 c compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2 mode = 0 call legin(mode,l,nlat,m,w,pmn,km) c store above in pmnf do 101 np1=mp1,nlat mn = mml1+np1 do 102 i=1,late pmnf(i,mn) = pmn(np1,i,km) 102 continue 101 continue 100 continue return end subroutine shftoff(nlon,nlat,goff,greg,wsav,nr,nlat2, + rlat,rlon,wrk) c c shift offset grid to regular grid, i.e., c goff is given, greg is to be generated c implicit none integer nlon,nlat,nlat2,n2,nr,j,i,js,isav real goff(nlon,nlat),greg(nlon,nlat+1) real rlat(nr,nlat2),rlon(nlat,nlon) real wsav(*),wrk(*) real gnorth,gsouth isav = 4*nlat+17 n2 = (nlon+1)/2 c c execute full circle latitude shifts for nlon odd or even c if (2*n2 .gt. nlon) then c c odd number of longitudes c do i=1,nlat do j=1,nlon rlon(i,j) = goff(j,i) end do end do c c half shift in longitude c call shifth(nlat,nlon,rlon,wsav(isav),wrk) c c set full 2*nlat circles in rlat using shifted values in rlon c do j=1,n2-1 js = j+n2 do i=1,nlat rlat(j,i) = goff(j,i) rlat(j,nlat+i) = rlon(nlat+1-i,js) end do end do do j=n2,nlon js = j-n2+1 do i=1,nlat rlat(j,i) = goff(j,i) rlat(j,nlat+i) = rlon(nlat+1-i,js) end do end do c c shift the nlon rlat vectors one half latitude grid c call shifth(nlon,nlat2,rlat,wsav,wrk) c c set nonpole values in greg and average for poles c gnorth = 0.0 gsouth = 0.0 do j=1,nlon gnorth = gnorth + rlat(j,1) gsouth = gsouth + rlat(j,nlat+1) do i=2,nlat greg(j,i) = rlat(j,i) end do end do gnorth = gnorth/nlon gsouth = gsouth/nlon else c c even number of longitudes (no initial longitude shift necessary) c set full 2*nlat circles (over poles) for each longitude pair (j,js) c do j=1,n2 js = n2+j do i=1,nlat rlat(j,i) = goff(j,i) rlat(j,nlat+i) = goff(js,nlat+1-i) end do end do c c shift the n2=(nlon+1)/2 rlat vectors one half latitude grid c call shifth(n2,nlat2,rlat,wsav,wrk) c c set nonpole values in greg and average poles c gnorth = 0.0 gsouth = 0.0 do j=1,n2 js = n2+j gnorth = gnorth + rlat(j,1) gsouth = gsouth + rlat(j,nlat+1) do i=2,nlat greg(j,i) = rlat(j,i) greg(js,i) = rlat(j,nlat2-i+2) end do end do gnorth = gnorth/n2 gsouth = gsouth/n2 end if c c set poles c do j=1,nlon greg(j,1) = gnorth greg(j,nlat+1) = gsouth end do c c execute full circle longitude shift c do j=1,nlon do i=1,nlat rlon(i,j) = greg(j,i) end do end do call shifth(nlat,nlon,rlon,wsav(isav),wrk) do j=1,nlon do i=2,nlat greg(j,i) = rlon(i,j) end do end do end subroutine shftreg(nlon,nlat,goff,greg,wsav,nr,nlat2,nlatp1, + rlat,rlon,wrk) c c shift regular grid to offset grid, i.e., c greg is given, goff is to be generated c implicit none integer nlon,nlat,nlat2,nlatp1,n2,nr,j,i,js,isav real goff(nlon,nlat),greg(nlon,nlatp1) real rlat(nr,nlat2),rlon(nlatp1,nlon) real wsav(*),wrk(*) isav = 4*nlat+17 n2 = (nlon+1)/2 c c execute full circle latitude shifts for nlon odd or even c if (2*n2 .gt. nlon) then c c odd number of longitudes c do i=1,nlat+1 do j=1,nlon rlon(i,j) = greg(j,i) end do end do c c half shift in longitude in rlon c call shifth(nlat+1,nlon,rlon,wsav(isav),wrk) c c set full 2*nlat circles in rlat using shifted values in rlon c do j=1,n2 js = j+n2-1 rlat(j,1) = greg(j,1) do i=2,nlat rlat(j,i) = greg(j,i) rlat(j,nlat+i) = rlon(nlat+2-i,js) end do rlat(j,nlat+1) = greg(j,nlat+1) end do do j=n2+1,nlon js = j-n2 rlat(j,1) = greg(j,1) do i=2,nlat rlat(j,i) = greg(j,i) rlat(j,nlat+i) = rlon(nlat+2-i,js) end do rlat(j,nlat+1) = greg(j,nlat+1) end do c c shift the nlon rlat vectors one halflatitude grid c call shifth(nlon,nlat2,rlat,wsav,wrk) c c set values in goff c do j=1,nlon do i=1,nlat goff(j,i) = rlat(j,i) end do end do else c c even number of longitudes (no initial longitude shift necessary) c set full 2*nlat circles (over poles) for each longitude pair (j,js) c do j=1,n2 js = n2+j rlat(j,1) = greg(j,1) do i=2,nlat rlat(j,i) = greg(j,i) rlat(j,nlat+i) = greg(js,nlat+2-i) end do rlat(j,nlat+1) = greg(j,nlat+1) end do c c shift the n2=(nlon+1)/2 rlat vectors one half latitude grid c call shifth(n2,nlat2,rlat,wsav,wrk) c c set values in goff c do j=1,n2 js = n2+j do i=1,nlat goff(j,i) = rlat(j,i) goff(js,i) = rlat(j,nlat2+1-i) end do end do end if c c execute full circle longitude shift for all latitude circles c do j=1,nlon do i=1,nlat rlon(i,j) = goff(j,i) end do end do call shifth(nlat+1,nlon,rlon,wsav(isav),wrk) do j=1,nlon do i=1,nlat goff(j,i) = rlon(i,j) end do end do end subroutine shifth(m,n,r,wsav,work) implicit none integer m,n,n2,k,l real r(m,n),wsav(*),work(*),r2km2,r2km1 n2 = (n+1)/2 c c compute fourier coefficients for r on shifted grid c call hrfftf(m,n,r,m,wsav(n+2),work) do l=1,m do k=2,n2 r2km2 = r(l,k+k-2) r2km1 = r(l,k+k-1) r(l,k+k-2) = r2km2*wsav(n2+k) - r2km1*wsav(k) r(l,k+k-1) = r2km2*wsav(k) + r2km1*wsav(n2+k) end do end do c c shift r with fourier synthesis and normalization c call hrfftb(m,n,r,m,wsav(n+2),work) do l=1,m do k=1,n r(l,k) = r(l,k)/n end do end do return end subroutine shifthi(n,dp,wsav) c c initialize wsav for subroutine shifth c implicit none integer n,n2,k real wsav(*),dp n2 = (n+1)/2 do k=2,n2 wsav(k) = sin((k-1)*dp) wsav(k+n2) = cos((k-1)*dp) end do call hrffti(n,wsav(n+2)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file shigc.f c c this file contains code and documentation for subroutine shigc c c ... files which must be loaded with shigc.f c c sphcom.f, hrfft.f, gaqd.f c c 3/6/98 c c *** shigc is functionally the same as shagci or shsgci. It c it included in spherepack3.0 because legacy codes, using c the older version of spherepack call shigc to initialize c the saved work space wshigc, for either shagc or shsgc c c subroutine shigc(nlat,nlon,wshigc,lshigc,dwork,ldwork,ierror) c c subroutine shigc initializes the array wshigc which can then c be used repeatedly by subroutines shsgc or shagc. it precomputes c and stores in wshigc quantities such as gaussian weights, c legendre polynomial coefficients, and fft trigonometric tables. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c wshigc an array which must be initialized by subroutine shigc. c once initialized, wshigc can be used repeatedly by shsgc c or shagc as long as nlat and nlon remain unchanged. wshigc c must not be altered between calls of shsgc or shagc. c c lshigc the dimension of the array wshigc as it appears in the c program that calls shsgc or shagc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshigc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls shigc. ldwork must be at least c c nlat*(nlat+4) c c output parameter c c wshigc an array which must be initialized before calling shsgc or shagc. c once initialized, wshigc can be used repeatedly by shsgc or shagc c as long as nlat and nlon remain unchanged. wshigc must not c altered between calls of shsgc or shagc c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshigc c = 4 error in the specification of ldwork c = 5 failure in gaqd to compute gaussian points c (due to failure in eigenvalue routine) c c c **************************************************************** subroutine shigc(nlat,nlon,wshigc,lshigc,dwork,ldwork,ierror) c this subroutine must be called before calling shsgc/shagc with c fixed nlat,nlon. it precomputes quantites such as the gaussian c points and weights, m=0,m=1 legendre polynomials, recursion c recursion coefficients. dimension wshigc(lshigc) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+mod(nlat,2))/2 l1 = l l2 = late ierror = 3 c check permanent work space length if (lshigc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 4 c if (lwork.lt.4*nlat*(nlat+2)+2) return if (ldwork .lt. nlat*(nlat+4)) return ierror = 0 c set pointers i1 = 1 i2 = i1+nlat i3 = i2+nlat*late i4 = i3+nlat*late i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1) i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1) i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1) c set indices in temp work for double precision gaussian wts and pts idth = 1 c idwts = idth+2*nlat c iw = idwts+2*nlat idwts = idth+nlat iw = idwts+nlat call shigc1(nlat,nlon,l,late,wshigc(i1),wshigc(i2),wshigc(i3), 1wshigc(i4),wshigc(i5),wshigc(i6),wshigc(i7),dwork(idth), 2dwork(idwts),dwork(iw),ierror) if (ierror.ne.0) ierror = 5 return end subroutine shigc1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel, 1 wfft,dtheta,dwts,work,ier) dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1), 1 cbel(1),wfft(1),dtheta(nlat),dwts(nlat) double precision pb,dtheta,dwts,work(*) c compute the nlat gaussian points and weights, the c m=0,1 legendre polys for gaussian points and all n, c and the legendre recursion coefficients c define index function used in storing c arrays for recursion coefficients (functions of (m,n)) c the index function indx(m,n) is defined so that c the pairs (m,n) map to [1,2,...,indx(l-1,l-1)] with no c "holes" as m varies from 2 to n and n varies from 2 to l-1. c (m=0,1 are set from p0n,p1n for all n) c define for 2.le.n.le.l-1 indx(m,n) = (n-1)*(n-2)/2+m-1 c define index function for l.le.n.le.nlat imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1 c preset quantites for fourier transform call hrffti(nlon,wfft) c compute double precision gaussian points and weights c lw = 4*nlat*(nlat+1)+2 lw = nlat*(nlat+2) call gaqd(nlat,dtheta,dwts,work,lw,ier) if (ier.ne.0) return c store gaussian weights single precision to save computation c in inner loops in analysis do 100 i=1,nlat wts(i) = dwts(i) 100 continue c initialize p0n,p1n using double precision dnlfk,dnlft do 101 np1=1,nlat do 101 i=1,late p0n(np1,i) = 0.0 p1n(np1,i) = 0.0 101 continue c compute m=n=0 legendre polynomials for all theta(i) np1 = 1 n = 0 m = 0 call dnlfk(m,n,work) do 103 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(1,i) = pb 103 continue c compute p0n,p1n for all theta(i) when n.gt.0 do 104 np1=2,nlat n = np1-1 m = 0 call dnlfk(m,n,work) do 105 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(np1,i) = pb 105 continue c compute m=1 legendre polynomials for all n and theta(i) m = 1 call dnlfk(m,n,work) do 106 i=1,late call dnlft(m,n,dtheta(i),work,pb) p1n(np1,i) = pb 106 continue 104 continue c compute and store swarztrauber recursion coefficients c for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel do 107 n=2,nlat mlim = min0(n,l) do 107 m=2,mlim imn = indx(m,n) if (n.ge.l) imn = imndx(m,n) abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/ 1 float(((n+m-1)*(n+m)))) 107 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file shigs.f c c this file contains code and documentation for subroutine shigs c c ... files which must be loaded with shigs.f c c sphcom.f, hrfft.f, gaqd.f c c 3/6/98 c c *** shigs is functionally the same as shagsi or shsgsi. It c it included in spherepack3.0 because legacy codes, using c the older version of spherepack, call shigs to initialize c the saved work space wshigs for either shags or shsgs c Its arguments are identical to those of shagsi or shsgsi. c c **************************************************************** c c subroutine shigs(nlat,nlon,wshigs,lshigs,work,lwork,dwork,ldwork, c + ierror) c c subroutine shigs initializes the array wshigs which can then c be used repeatedly by subroutines shags,shsgs. it precomputes c and stores in wshigs quantities such as gaussian weights, c legendre polynomial coefficients, and fft trigonometric tables. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c wshigs an array which must be initialized by subroutine shigs . c once initialized, wshigs can be used repeatedly by shigs c as long as nlat and nlon remain unchanged. wshigs must c not be altered between calls of shigs. c c lshigs the dimension of the array wshigs as it appears in the c program that calls shigs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshigs must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c work a real work space which need not be saved c c lwork the dimension of the array work as it appears in the c program that calls shigs. lwork must be at least c 4*nlat*(nlat+2)+2 in the routine calling shigs c c dwork a double precision work array that does not have to be saved. c c ldwork the length of dwork in the calling routine. ldwork must c be at least nlat*(nlat+4) c c output parameter c c wshags an array which must be initialized before calling shags or c once initialized, wshags can be used repeatedly by shags or c as long as nlat and nlon remain unchanged. wshags must not c altered between calls of shasc. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshags c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c = 6 failure in gaqd to compute gaussian points c (due to failure in eigenvalue routine) c c c **************************************************************** c subroutine shigs(nlat,nlon,wshigs,lshigs,work,lwork,dwork, + ldwork,ierror) c c this subroutine must be called before calling shags or shsgs with c fixed nlat,nlon. it precomputes the gaussian weights, points c and all necessary legendre polys and stores them in wshigs. c these quantities must be preserved when calling shsgs or shags c repeatedly with fixed nlat,nlon. c dimension wshigs(lshigs),work(lwork) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+1)/2 l1 = l l2 = late c check permanent work space length ierror = 3 lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshigs.lt.lp) return ierror = 4 c check temporary work space if (lwork.lt.4*nlat*(nlat+2)+2) return c check temp double precision space ierror = 5 if (ldwork .lt. nlat*(nlat+4)) return ierror = 0 c set preliminary quantites needed to compute and store legendre polys call shigsp(nlat,nlon,wshigs,lshigs,dwork,ldwork,ierror) if (ierror.ne.0) return c set legendre poly pointer in wshigs ipmnf = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+nlon+16 call shigss1(nlat,l,late,wshigs,work,wshigs(ipmnf)) return end subroutine shigsp(nlat,nlon,wshigs,lshigs,dwork,ldwork,ierror) dimension wshigs(lshigs) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+mod(nlat,2))/2 l1 = l l2 = late ierror = 3 c check permanent work space length if (lshigs .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 4 c if (lwork.lt.4*nlat*(nlat+2)+2) return if (ldwork .lt. nlat*(nlat+4)) return ierror = 0 c set pointers i1 = 1 i2 = i1+nlat i3 = i2+nlat*late i4 = i3+nlat*late i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1) i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1) i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1) c set indices in temp work for double precision gaussian wts and pts idth = 1 c idwts = idth+2*nlat c iw = idwts+2*nlat idwts = idth+nlat iw = idwts+nlat call shigsp1(nlat,nlon,l,late,wshigs(i1),wshigs(i2),wshigs(i3), 1wshigs(i4),wshigs(i5),wshigs(i6),wshigs(i7),dwork(idth), 2dwork(idwts),dwork(iw),ierror) if (ierror.ne.0) ierror = 5 return end subroutine shigsp1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel, + wfft,dtheta,dwts,work,ier) dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1), 1 cbel(1),wfft(1),dtheta(nlat),dwts(nlat) double precision pb,dtheta,dwts,work(*) indx(m,n) = (n-1)*(n-2)/2+m-1 imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1 call hrffti(nlon,wfft) c compute double precision gaussian points and weights c lw = 4*nlat*(nlat+2) lw = nlat*(nlat+2) call gaqd(nlat,dtheta,dwts,work,lw,ier) if (ier.ne.0) return c store gaussian weights single precision to save computation c in inner loops in analysis do 100 i=1,nlat wts(i) = dwts(i) 100 continue c initialize p0n,p1n using double precision dnlfk,dnlft do 101 np1=1,nlat do 101 i=1,late p0n(np1,i) = 0.0 p1n(np1,i) = 0.0 101 continue c compute m=n=0 legendre polynomials for all theta(i) np1 = 1 n = 0 m = 0 call dnlfk(m,n,work) do 103 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(1,i) = pb 103 continue c compute p0n,p1n for all theta(i) when n.gt.0 do 104 np1=2,nlat n = np1-1 m = 0 call dnlfk(m,n,work) do 105 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(np1,i) = pb 105 continue c compute m=1 legendre polynomials for all n and theta(i) m = 1 call dnlfk(m,n,work) do 106 i=1,late call dnlft(m,n,dtheta(i),work,pb) p1n(np1,i) = pb 106 continue 104 continue c c compute and store swarztrauber recursion coefficients c for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel do 107 n=2,nlat mlim = min0(n,l) do 107 m=2,mlim imn = indx(m,n) if (n.ge.l) imn = imndx(m,n) abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/ 1 float(((n+m-1)*(n+m)))) 107 continue return end subroutine shigss1(nlat,l,late,w,pmn,pmnf) dimension w(1),pmn(nlat,late,3),pmnf(late,1) c compute and store legendre polys for i=1,...,late,m=0,...,l-1 c and n=m,...,l-1 do i=1,nlat do j=1,late do k=1,3 pmn(i,j,k) = 0.0 end do end do end do do 100 mp1=1,l m = mp1-1 mml1 = m*(2*nlat-m-1)/2 c compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2 mode = 0 call legin(mode,l,nlat,m,w,pmn,km) c store above in pmnf do 101 np1=mp1,nlat mn = mml1+np1 do 102 i=1,late pmnf(i,mn) = pmn(np1,i,km) 102 continue 101 continue 100 continue return end c c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK3.0 . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c ... file shpe.f c c ... files which must be loaded with shpe.f c c sphcom.f, hrfft.f c c the n**2 projection with complement, odd/even c factorization and zero truncation on an c equally spaced grid as defined in the JCP paper c "Generalized discrete spherical harmonic transforms" c by Paul N. Swarztrauber and William F. Spotz c It is equivalent to a harmonic analysis followed c by a synthesis except faster and requires less memory. c c subroutine shpe(nlat,nlon,isym,mtrunc,x,y,idxy, c 1 wshp,lwshp,iwshp,liwshp,work,lwork,ierror) c c shpe projects the array x onto the set of functions represented c by a discrete set of spherical harmonics. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c nlon must beat least 4. c c isym currently not used. c c mtrunc the highest longitudinal wave number retained in the c projection. It must be less than or equal to c the minimum of nlat-1 and nlon/2. The first wave c number is zero. For example, if wave numbers 0 and c 1 are desired then mtrunc = 1. c zero. c c x a two dimensional array that contains the the nlat c by nlon array x(i,j) defined at the colatitude point c theta(i) = (i-1)*pi/(nlat-1) and longitude point phi(j) = c (j-1)*2*pi/nlon. c c idxy the first dimension of the arrays x and y as they c appear in the program that calls shpe. It must be c at least nlat. c c wshp a single precision array that must be saved for c repeated use by subroutine shpe. c c lwshp the dimension of the array wshp as it appears in the c program that calls shpei. It must be at least c 2*(nlat+1)**2+nlon+log2(nlon) c c iwshp an integer array that must be saved for repeated c use by subroutine shpe. c c c liwshp the dimension of the array iwshp as it appears in the c program that calls shpei. It must be at least c 4*(nlat+1). c c work a single precision work array that does c not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shpe. It must be at least c max(nlat*nlon,4*(nlat+1)). c c ************************************************************** c c output parameters c c y an nlat by nlon single precision array that contains c the projection of x onto the set of functions that c can be represented by the discrete set of spherical c harmonics. The arrays x(i,j) and y(i,j) are located c at colatitude point theta(i) = (i-1)*pi/(nlat-1) and c longitude point phi(j) = (j-1)*2*pi/nlon. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of mtrunc c = 5 error in the specification of lwshp c = 6 error in the specification of liwshp c = 7 error in the specification of lwork c subroutine shpe(nlat,nlon,isym,mtrunc,x,y,idxy, 1 wshp,lwshp,iwshp,liwshp,work,lwork,ierror) c dimension wshp(*),iwshp(*),work(*),x(idxy,nlon),y(idxy,nlon) c ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return c ierror = 3 c if(isym.lt.0 .or. isym.gt.2) return ierror = 4 mmax = min(nlat-1,nlon/2) if(mtrunc.lt.0 .or. mtrunc.gt.mmax) return ierror = 5 log2n = log(float(nlon))/log(2.0) lw1 = 2*(nlat+1)**2 if(lwshp.lt.lw1+nlon+log2n) return ierror = 6 if(liwshp.lt.4*(nlat+1)) return ierror = 7 mwrk = max(nlat*nlon,4*(nlat+1)) if(lwork.lt.mwrk) return ierror = 0 c do j=1,nlon do i=1,nlat y(i,j) = x(i,j) end do end do call hrfftf(nlat,nlon,y,idxy,wshp(lw1+1),work) c nte = (nlat+1)/2 nloc1 = 2*nte*nte nloc2 = nlat+1 iw1 = 1 iw2 = iw1+nloc1 iw3 = iw2+nloc1 iw4 = iw3+nloc1 jw1 = 1 jw2 = jw1+nloc2 jw3 = jw2+nloc2 jw4 = jw3+nloc2 c call shpe1(nlat,nlon,isym,mtrunc,y,y,idxy,ierror, 1 nte,wshp(iw1),wshp(iw2),wshp(iw3),wshp(iw4),iwshp(jw1), 2 iwshp(jw2),iwshp(jw3),iwshp(jw4),work(jw1), 3 work(jw2),work(jw3),work(jw4)) c call hrfftb(nlat,nlon,y,idxy,wshp(lw1+1),work) c sn = 1.0/nlon do j=1,nlon do i=1,nlat y(i,j) = sn*y(i,j) end do end do return end subroutine shpe1(nlat,nlon,isym,mtrunc,sx,sy,idxy,ierror, 1 idp,pe,po,ze,zo,ipse,jzse,ipso,jzso,xe,xo,ye,yo) c dimension sx(idxy,nlon),sy(idxy,nlon),nshe(2),nsho(2), 1 pe(idp,idp,2),po(idp,idp,2),ze(idp,idp,2),zo(idp,idp,2), 2 ipse(idp,2),jzse(idp,2),ipso(idp,2),jzso(idp,2), 3 xe(idp,2),xo(idp,2),ye(idp,2),yo(idp,2) c ns2 = nlat/2 modn = nlat-ns2-ns2 nte = (nlat+1)/2 nto = nlat-nte c if(modn.eq.0) then nshe(1) = (nlat-mtrunc-1)/2 nshe(2) = (nlat-mtrunc-2)/2 nsho(1) = (nlat-mtrunc)/2 nsho(2) = (nlat-mtrunc-1)/2 else nshe(1) = (nlat-mtrunc)/2 nshe(2) = (nlat-mtrunc-1)/2 nsho(1) = (nlat-mtrunc-1)/2 nsho(2) = (nlat-mtrunc-2)/2 end if mxtr = min(nlat-1,nlon/2,mtrunc) ip = 2 do 100 mp1=1,mxtr+1 ip = 3-ip if(mxtr.eq.nlat-1.and.mp1.le.2) then do i=1,nlat sy(i,mp1) = sx(i,mp1) end do if(mp1.eq.2) then sy(1,2) = 0. sy(nlat,2) = 0. end if if(nlon.ge.3) then sy(1,3) = 0. sy(nlat,3) = 0. do i=2,nlat-1 sy(i,3) = sx(i,3) end do end if go to 100 end if m = mp1-1 mpm = max(1,m+m) ms2 = mp1/2 mrank = min(nlat-m,nlat-ms2-ms2) c mrank = mxtr+1-ms2-ms2 nrank = nlat-mrank nem = (mrank+1)/2-nshe(ip) nom = mrank-(mrank+1)/2-nsho(ip) nec = nte-nem noc = nto-nom c do i=1,nte xe(i,1) = .5*(sx(i,mpm)+sx(nlat+1-i,mpm)) xo(i,1) = .5*(sx(i,mpm)-sx(nlat+1-i,mpm)) end do if(mpm.lt.nlon) then do i=1,nte xe(i,2) = .5*(sx(i,mpm+1)+sx(nlat+1-i,mpm+1)) xo(i,2) = .5*(sx(i,mpm+1)-sx(nlat+1-i,mpm+1)) end do end if if(3*nec.lt.2*nem.or.nem.eq.0) then call tmxmx(nte,nec,idp,pe(1,1,ip),nte,idp, 1 ze(1,1,ip),xe,ye,ipse(1,ip),jzse(1,ip)) do i=1,nte ye(i,1) = xe(i,1)-ye(i,1) end do if(mpm.lt.nlon.and.m.ne.0) then do i=1,nte ye(i,2) = xe(i,2)-ye(i,2) end do end if else call tmxmx(nte,nem,idp,pe(1,nec+1,ip),nte,idp, 1ze(1,nec+1,ip),xe,ye,ipse(nec+1,ip),jzse(nec+1,ip)) end if if(3*noc.lt.2*nom.or.nom.eq.0) then call tmxmx(nto,noc,idp,po(1,1,ip),nto,idp, 1 zo(1,1,ip),xo,yo,ipso(1,ip),jzso(1,ip)) do i=1,nte yo(i,1) = xo(i,1)-yo(i,1) end do if(mpm.lt.nlon.and.m.ne.0) then do i=1,nte yo(i,2) = xo(i,2)-yo(i,2) end do end if else call tmxmx(nto,nom,idp,po(1,noc+1,ip),nto,idp, 1zo(1,noc+1,ip),xo,yo,ipso(noc+1,ip),jzso(noc+1,ip)) end if do i=1,nte sy(i,mpm) = ye(i,1)+yo(i,1) sy(nlat+1-i,mpm) = ye(i,1)-yo(i,1) end do if(mpm.lt.nlon.and.m.ne.0) then do i=1,nte sy(i,mpm+1) = ye(i,2)+yo(i,2) sy(nlat+1-i,mpm+1) = ye(i,2)-yo(i,2) end do end if 100 continue js = mxtr+mxtr+2 do j=js,nlon do i=1,nlat sy(i,j) = 0. end do end do return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c August 2003 c c ... file shpe.f c c this file contains code and documentation for subroutines c shpei and shpe. c c ... files which must be loaded with shpe.f c c hrfft.f c c subroutine shpei initializes arrays wshp and iwshp for c subsequent repeated use by subroutine shpe, which c performs the harmonic projection equivalent to a c harmonic analysis followed by harmonic synthesis c but faster and with less memory. (see description of c subroutine shpe below) c c subroutine shpei(nlat,nlon,isym,mtrunc,wshp,lwshp,iwshp, c 1 liwshp,work,lwork,ierror) c c shpei initializes arrays wshp and iwshp for repeated use c by subroutine shpe .... c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c nlon must beat least 4. c c isym currently not used. c c mtrunc the highest longitudinal wave number retained in the c projection. It must be less than or equal to c the minimum of nlat-1 and nlon/2. The first wave c number is zero. For example, if wave numbers 0 and c 1 are desired then mtrunc = 1. c c lwshp the dimension of the array wshp as it appears in the c program that calls shpei. It must be at least c 2*(nlat+1)**2+nlon+log2(nlon) c c liwshp the dimension of the array iwshp as it appears in the c program that calls shpei. It must be at least c 4*(nlat+1). c c lwork the dimension of the array work as it appears in the c program that calls shpei. It must be at least c 1.25*(nlat+1)**2+7*nlat+8. c c ************************************************************** c c output parameters c c wshp a single precision array that must be saved for c repeated use by subroutine shpe. c c iwshp an integer array that must be saved for repeated c use by subroutine shpe. c c work a double precision work array that does c not have to be saved. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of mtrunc c = 5 error in the specification of lwshp c = 6 error in the specification of liwshp c = 7 error in the specification of lwork c subroutine shpei(nlat,nlon,isym,mtrunc,wshp,lwshp,iwshp, 1 liwshp,work,lwork,ierror) double precision work(*) dimension wshp(*),iwshp(*) c ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return c ierror = 3 c if(isym.lt.0 .or. isym.gt.2) return ierror = 4 mmax = min(nlat-1,nlon/2) if(mtrunc.lt.0 .or. mtrunc.gt.mmax) return ierror = 5 lw1 = 2*(nlat+1)**2 log2n = log(float(nlon))/log(2.0) if(lwshp.lt.lw1+nlon+log2n) return ierror = 6 if(liwshp.lt.4*(nlat+1)) return ierror = 7 mlwk = 1.25*(nlat+1)**2+7*nlat+8 if(lwork.lt.mlwk) return ierror = 0 c call hrffti(nlon,wshp(lw1+1)) c nte = (nlat+1)/2 nloc1 = 2*nte*nte nloc2 = nlat+1 iw1 = 1 iw2 = iw1+nloc1 iw3 = iw2+nloc1 iw4 = iw3+nloc1 jw1 = 1 jw2 = jw1+nloc2 jw3 = jw2+nloc2 jw4 = jw3+nloc2 kw1 = 1 kw2 = kw1+nte kw3 = kw2+nte kw4 = kw3+nte kw5 = kw4+nte+1 kw6 = kw5+nte kw7 = kw6+nte kw8 = kw7+nte kw9 = kw8+nte kw10 = kw9+nloc2+nloc2 kw11 = kw10+nloc2 kw12 = kw11+nloc1 kw13 = kw12+nloc1 call shpei1(nlat,nlon,isym,mtrunc,nte,ierror,wshp(iw1),wshp(iw2), 1 wshp(iw3),wshp(iw4),iwshp(jw1),iwshp(jw2),iwshp(jw3), 2 iwshp(jw4),work(kw1),work(kw2),work(kw3),work(kw4),work(kw5), 3 work(kw6),work(kw7),work(kw8),work(kw9),work(kw10),work(kw11), 4 work(kw12),work(kw11),work(kw12),work(kw13)) return end subroutine shpei1(nlat,nlon,isym,mtrunc,idp,ierror, 1 pe,po,ze,zo,ipse,jzse,ipso,jzso, 2 cp,work,wx,s,e,thet,xx,z,a,b,we,ped,wo,pod,u) c*********************************************************************72 c cc SHPEI1 c double precision sum,eps,pi,dthet,v,a1,b1,c1 parameter (eps=5.0d-8) double precision cp(idp),work(idp),wx(idp),s(idp+1), 1 e(idp),thet(idp),xx(idp),z(idp),u(idp,idp), 3 we(idp,idp,2),ped(idp,idp,2),a(4*idp),b(2*idp), 4 wo(idp,idp,2),pod(idp,idp,2) c dimension pe(idp,idp,2),po(idp,idp,2),ze(idp,idp,2), 1 zo(idp,idp,2), 2 ipse(idp,2),jzse(idp,2),ipso(idp,2),jzso(idp,2), 3 nshe(2),nsho(2) c ns2 = nlat/2 modn = nlat-ns2-ns2 nte = (nlat+1)/2 nto = nlat-nte tusl = 0. toe = 0. c c compute grid distribution c pi = 4.d0*datan(1.0d0) dthet = pi/(nlat-1) do i=1,nte thet(i) = (i-1)*dthet end do c c compute weight matrices for even functions c do 40 mp1=1,2 m = mp1-1 mrank = nlat-m-m nem = (mrank+1)/2 do j=1,nem n = j+j+m-2 call dlfkp(m,n,cp) do i=1,nte call dlftp (m,n,thet(i),cp,ped(i,j,mp1)) end do if(m.gt.0) ped(1,j,mp1) = 0.0d0 end do call dsvdc(ped(m+1,1,mp1),idp,nem,nem,s,e,u, 1 idp,v,idp,work,10,info) c do j=1,nem s(j) = 1.0d0/(s(j)*s(j)) end do c c compute weight matrix as u s sup -2 u transpose c do j=1,nte do i=1,nte we(i,j,mp1) = 0.0d0 end do end do do i=1,nem do j=1,nem sum = 0. do k=1,nem sum = sum+s(k)*u(i,k)*u(j,k) end do we(i+m,j+m,mp1) = sum end do end do 40 continue we(1,1,2) = 1.0d0 c c compute n**2 basis (even functions) c do n=1,nlat+nlat-2 dfn = n a(n) = dsqrt(dfn*(dfn+1.0d0)) end do do n=1,nlat-1 dfn = n b(n) = dsqrt((dfn+dfn+3.0d0)/(dfn+dfn-1.0d0)) end do c mxtr = min(nlat-1,nlon/2,mtrunc) ip = 2 do 200 mp1=1,mxtr+1 m = mp1-1 ip = 3-ip ms2 = mp1/2 nrank = ms2+ms2 mrank = nlat-nrank nem = (mrank+1)/2 c c compute associated legendre functions c if(m.le.1) then do 205 j=1,nem n = j+j+m-2 call dlfkp(m,n,cp) do i=1,nte call dlftp (m,n,thet(i),cp,ped(i,j+ms2,ip)) end do 202 if(m.gt.0) ped(1,j+ms2,ip) = 0.0d0 205 continue c else c do 207 j=1,nem n = j+j+m-2 if(m.gt.1.and.n.gt.mxtr) then do i=1,nte u(i,j+ms2) = ped(i,j+ms2,ip) end do go to 207 end if a1 = b(n-1)*a(n+m-3)/a(n+m-1) b1 = a(n-m+1)/a(n+m-1) if(n-m.le.1) then do i=1,nte u(i,j+ms2) = a1*ped(i,j+ms2-1,ip) 1 - b1*ped(i,j+ms2,ip) end do else c1 = b(n-1)*a(n-m-1)/a(n+m-1) do i=1,nte u(i,j+ms2) = a1*ped(i,j+ms2-1,ip) 1 - b1*ped(i,j+ms2,ip) + c1*u(i,j+ms2-1) end do end if 207 continue do j=1,nem do i=1,nte ped(i,j+ms2,ip) = u(i,j+ms2) end do end do end if c if(ms2.le.0.or.ms2.ge.nte) go to 200 do i=1,nte xx(i) = rand(0) end do it = 0 201 do i=1,nte z(i) = 0.0d0 wx(i) = 0.0d0 do j=1,nte wx(i) = wx(i)+we(i,j,ip)*xx(j) end do end do do 220 j=1,nte if(j.eq.ms2) go to 220 call gs(nte,wx,ped(1,j,ip),z) 220 continue c do i=1,nte xx(i) = xx(i)-z(i) end do call normal(nte,xx,idp,we(1,1,ip)) it = it+1 if(it.le.2) go to 201 do i=1,nte ped(i,ms2,ip) = xx(i) end do 200 continue c c reorder if mtrunc is less than nlat-1 c case of even functions c if(modn.eq.0) then nshe(1) = (nlat-mtrunc-1)/2 nshe(2) = (nlat-mtrunc-2)/2 else nshe(1) = (nlat-mtrunc)/2 nshe(2) = (nlat-mtrunc-1)/2 end if c do 210 mp1=1,2 do j=1,nte js = j+nshe(mp1) if(js.gt.nte) js = js-nte do i=1,nte u(i,js) = ped(i,j,mp1) end do end do do j=1,nte do i=1,nte ped(i,j,mp1) = u(i,j) end do end do 210 continue c call trunc(0,nte,idp,ped(1,1,1),nte,ipse(1,1)) call trunc(0,nte,idp,ped(1,1,2),nte,ipse(1,2)) c c compute the analysis matrices c do 250 ip=1,2 do i=1,nte lock = 0 do j=1,nte sum = 0.0d0 do k=1,nte sum = sum+ped(k,i,ip)*we(k,j,ip) end do pe(i,j,ip) = ped(i,j,ip) ze(j,i,ip) = sum if(dabs(sum).gt.eps .and. lock.eq.0) then lock = 1 jzse(i,ip) = j end if end do end do 250 continue c c compute weight matrices for odd functions c do 50 mp1=1,2 m = mp1-1 mrank = nlat-m-m nem = (mrank+1)/2 nom = mrank-nem do j=1,nom n = j+j+m-1 call dlfkp(m,n,cp) do i=1,nte call dlftp (m,n,thet(i),cp,pod(i,j,mp1)) end do if(modn.eq.1) pod(nte,j,mp1) = 0.0d0 end do call dsvdc(pod(m+1,1,mp1),idp,nom,nom,s,e,u, 1 idp,v,idp,work,10,info) c do j=1,nom s(j) = 1.0d0/(s(j)*s(j)) end do c c compute weight matrix as u s sup -2 u transpose c do j=1,nte do i=1,nte wo(i,j,mp1) = 0.0d0 end do end do do i=1,nom do j=1,nom sum = 0. do k=1,nom sum = sum+s(k)*u(i,k)*u(j,k) end do wo(i+m,j+m,mp1) = sum end do end do 50 continue wo(1,1,2) = 1.0d0 if(modn.eq.1) then wo(nte,nte,1) = 1.0d0 wo(nte,nte,2) = 1.0d0 end if c c compute n**2 basis (odd functions) c ip = 2 do 300 mp1=1,mxtr+1 ip = 3-ip m = mp1-1 ms2 = mp1/2 nrank = ms2+ms2 mrank = nlat-nrank nem = (mrank+1)/2 nom = mrank-nem c c compute associated legendre functions c if(m.le.1) then do 305 j=1,nom n = j+j+m-1 call dlfkp(m,n,cp) do i=1,nte call dlftp (m,n,thet(i),cp,pod(i,j+ms2,ip)) end do 302 if(modn.eq.1) pod(nte,j+ms2,ip) = 0.0d0 if(m.gt.0) pod(1,j+ms2,ip) = 0.0d0 305 continue c else c do 307 j=1,nom n = j+j+m-1 if(m.gt.1.and.n.gt.mxtr) then do i=1,nte u(i,j+ms2) = pod(i,j+ms2,ip) end do go to 304 end if a1 = b(n-1)*a(n+m-3)/a(n+m-1) b1 = a(n-m+1)/a(n+m-1) if(n-m.le.1) then do i=1,nte u(i,j+ms2) = a1*pod(i,j+ms2-1,ip) 1 - b1*pod(i,j+ms2,ip) end do else c1 = b(n-1)*a(n-m-1)/a(n+m-1) do i=1,nte u(i,j+ms2) = a1*pod(i,j+ms2-1,ip) 1 - b1*pod(i,j+ms2,ip) + c1*u(i,j+ms2-1) end do end if 304 if(modn.eq.1) u(nte,j+ms2) = 0.0d0 307 continue do j=1,nom do i=1,nte pod(i,j+ms2,ip) = u(i,j+ms2) end do end do end if c if(ms2.le.0.or.ms2.ge.nto) go to 300 do i=1,nte xx(i) = rand(0) end do if(modn.eq.1) xx(nte) = 0.0d0 it = 0 306 do i=1,nte z(i) = 0. wx(i) = 0. do j=1,nto wx(i) = wx(i)+wo(i,j,ip)*xx(j) end do end do do 330 j=1,nto if(j.eq.ms2) go to 330 call gs(nte,wx,pod(1,j,ip),z(1)) 330 continue c do i=1,nte xx(i) = xx(i)-z(i) end do call normal(nte,xx,idp,wo(1,1,ip)) it = it+1 if(it.le.2) go to 306 do i=1,nte pod(i,ms2,ip) = xx(i) end do if(modn.eq.1) pod(nte,ms2,ip) = 0.0d0 300 continue c c reorder if mtrunc is less than nlat-1 c case of odd functions c if(modn.eq.0) then nsho(1) = (nlat-mtrunc)/2 nsho(2) = (nlat-mtrunc-1)/2 else nsho(1) = (nlat-mtrunc-1)/2 nsho(2) = (nlat-mtrunc-2)/2 end if c do 310 mp1=1,2 do j=1,nto js = j+nsho(mp1) if(js.gt.nto) js = js-nto do i=1,nte u(i,js) = pod(i,j,mp1) end do end do do j=1,nto do i=1,nte pod(i,j,mp1) = u(i,j) end do end do 310 continue c call trunc(0,nte,idp,pod(1,1,1),nto,ipso(1,1)) call trunc(0,nte,idp,pod(1,1,2),nto,ipso(1,2)) c c compute the analysis matrices (odd functions) c do ip=1,2 do i=1,nto lock = 0 do j=1,nto sum = 0.0d0 do k=1,nte sum = sum+pod(k,i,ip)*wo(k,j,ip) end do po(i,j,ip) = pod(i,j,ip) zo(j,i,ip) = sum if(dabs(sum).gt.eps .and. lock.eq.0) then lock = 1 jzso(i,ip) = j end if end do end do end do return end c c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK3.0 . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c ... file shpg.f c c ... files which must be loaded with shpg.f c c hrfft.f c c shpg computes the harmonic projection, which is c equivalent to a harmonic analysis (forward) followed c by a harmonic synthesis (backward transform). c shpg uses the n**2 projection or complement when appropriate c as well as odd/even factorization and zero truncation on an c on a Gaussian distributed grid as defined in the JCP paper c "Generalized discrete spherical harmonic transforms" c by Paul N. Swarztrauber and William F. Spotz c J. Comp. Phys., 159(2000) pp. 213-230. c c subroutine shpg(nlat,nlon,isym,mtrunc,x,y,idxy, c 1 wshp,lwshp,iwshp,liwshp,work,lwork,ierror) c c shpg projects the array x onto the set of functions represented c by a discrete set of spherical harmonics. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c nlon must be at least 4. c c isym currently not used. c c mtrunc the highest longitudinal wave number retained in the c projection. It must be less than or equal to c the minimum of nlat-1 and nlon/2. The first wave c number is zero. For example, if wave numbers 0 and c 1 are desired then mtrunc = 1. c zero. c c x a two dimensional array that contains the the nlat c by nlon array x(i,j) defined at the colatitude point c theta(i) = (i-1)*pi/(nlat-1) and longitude point phi(j) = c (j-1)*2*pi/nlon. c c idxy the first dimension of the arrays x and y as they c appear in the program that calls shpg. It must be c at least nlat. c c wshp a single precision array that must be saved for c repeated use by subroutine shpg. c c lwshp the dimension of the array wshp as it appears in the c program that calls shpgi. It must be at least c 2*(nlat+1)**2+nlon+log2(nlon) c c iwshp an integer array that must be saved for repeated c use by subroutine shpg. c c c liwshp the dimension of the array iwshp as it appears in the c program that calls shpgi. It must be at least c 4*(nlat+1). c c work a single precision work array that does c not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shpg. It must be at least c max(nlat*nlon,4*(nlat+1)). c c ************************************************************** c c output parameters c c y an nlat by nlon single precision array that contains c the projection of x onto the set of functions that c can be represented by the discrete set of spherical c harmonics. The arrays x(i,j) and y(i,j) are located c at colatitude point theta(i) = (i-1)*pi/(nlat-1) and c longitude point phi(j) = (j-1)*2*pi/nlon. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of mtrunc c = 5 error in the specification of lwshp c = 6 error in the specification of liwshp c = 7 error in the specification of lwork c subroutine shpg(nlat,nlon,isym,mtrunc,x,y,idxy, 1 wshp,lwshp,iwshp,liwshp,work,lwork,ierror) c dimension wshp(*),iwshp(*),work(*),x(idxy,nlon),y(idxy,nlon) c ierror = 1 if(nlat.lt.1) return ierror = 2 if(nlon.lt.1) return c ierror = 3 c if(isym.lt.0 .or. isym.gt.2) return ierror = 4 mmax = min(nlat-1,nlon/2) if(mtrunc.lt.0 .or. mtrunc.gt.mmax) return ierror = 5 log2n = log(float(nlon))/log(2.0) lw1 = 2*(nlat+1)**2 if(lwshp.lt.lw1+nlon+log2n) return ierror = 6 if(liwshp.lt.4*(nlat+1)) return ierror = 7 mwrk = max(nlat*nlon,4*(nlat+1)) if(lwork.lt.mwrk) return ierror = 0 c do j=1,nlon do i=1,nlat y(i,j) = x(i,j) end do end do call hrfftf(nlat,nlon,y,idxy,wshp(lw1+1),work) c nte = (nlat+1)/2 nloc1 = 2*nte*nte nloc2 = nlat+1 iw1 = 1 iw2 = iw1+nloc1 iw3 = iw2+nloc1 iw4 = iw3+nloc1 jw1 = 1 jw2 = jw1+nloc2 jw3 = jw2+nloc2 jw4 = jw3+nloc2 c call shpg1(nlat,nlon,isym,mtrunc,y,y,idxy,ierror, 1 nte,wshp(iw1),wshp(iw2),wshp(iw3),wshp(iw4),iwshp(jw1), 2 iwshp(jw2),iwshp(jw3),iwshp(jw4),work(jw1), 3 work(jw2),work(jw3),work(jw4)) c call hrfftb(nlat,nlon,y,idxy,wshp(lw1+1),work) c sn = 1.0/nlon do j=1,nlon do i=1,nlat y(i,j) = sn*y(i,j) end do end do return end subroutine shpg1(nlat,nlon,isym,mtrunc,sx,sy,idxy,ierror, 1 idp,pe,po,ze,zo,ipse,jzse,ipso,jzso,xe,xo,ye,yo) c dimension sx(idxy,nlon),sy(idxy,nlon),nshe(2),nsho(2), 1 pe(idp,idp,2),po(idp,idp,2),ze(idp,idp,2),zo(idp,idp,2), 2 ipse(idp,2),jzse(idp,2),ipso(idp,2),jzso(idp,2), 3 xe(idp,2),xo(idp,2),ye(idp,2),yo(idp,2) c ns2 = nlat/2 modn = nlat-ns2-ns2 nte = (nlat+1)/2 nto = nlat-nte c mxtr = min(nlat-1,nlon/2,mtrunc) nmx = nlat-mxtr if(modn.eq.1) then nshe(1) = nmx/2 nshe(2) = (nmx-1)/2 nsho(1) = (nmx-1)/2 nsho(2) = nmx/2 else nshe(1) = (nmx-1)/2 nshe(2) = nmx/2 nsho(1) = nmx/2 nsho(2) = (nmx-1)/2 end if c ip = 2 do 100 mp1=1,mxtr+1 ip = 3-ip if(mxtr.eq.nlat-1.and.mp1.eq.1) then do i=1,nlat sy(i,mp1) = sx(i,mp1) end do c if(mp1.eq.2) then c sy(1,2) = 0. c sy(nlat,2) = 0. c end if c if(nlon.ge.3) then c sy(1,3) = 0. c sy(nlat,3) = 0. c do i=2,nlat-1 c sy(i,3) = sx(i,3) c end do c end if go to 100 end if m = mp1-1 mpm = max(1,m+m) ms2 = mp1/2 c mrank = min(nlat-m,nlat-ms2-ms2) c nrank = nlat-mrank c nem = (mrank+1)/2-nshe(ip) c nom = mrank-(mrank+1)/2-nsho(ip) nem = (nlat-m+1)/2-nshe(ip) nom = (nlat-m)/2-nsho(ip) nec = nte-nem noc = nto-nom do i=1,nte xe(i,1) = .5*(sx(i,mpm)+sx(nlat+1-i,mpm)) xo(i,1) = .5*(sx(i,mpm)-sx(nlat+1-i,mpm)) end do c if(modn.eq.1) then c xe(nte,1) = sx(nte,mpm) c xo(nte,1) = 0. c end if if(mpm.lt.nlon) then do i=1,nte xe(i,2) = .5*(sx(i,mpm+1)+sx(nlat+1-i,mpm+1)) xo(i,2) = .5*(sx(i,mpm+1)-sx(nlat+1-i,mpm+1)) end do c if(modn.eq.1) then c xe(nte,2) = sx(nte,mpm+1) c xo(nte,2) = 0. c end if end if lag = 0 if(m.eq.0.or.mpm.eq.nlon) lag = 1 if(3*nec.lt.2*nem.or.nem.eq.0) then call tmxmx(lag,nte,nec,idp,pe(1,1,ip),nte,idp, 1 ze(1,1,ip),xe,ye,ipse(1,ip),jzse(1,ip)) do i=1,nte ye(i,1) = xe(i,1)-ye(i,1) end do if(mpm.lt.nlon.and.m.ne.0) then do i=1,nte ye(i,2) = xe(i,2)-ye(i,2) end do end if else call tmxmx(lag,nte,nem,idp,pe(1,nec+1,ip),nte,idp, 1ze(1,nec+1,ip),xe,ye,ipse(nec+1,ip),jzse(nec+1,ip)) end if if(3*noc.lt.2*nom.or.nom.eq.0) then call tmxmx(lag,nto,noc,idp,po(1,1,ip),nto,idp, 1 zo(1,1,ip),xo,yo,ipso(1,ip),jzso(1,ip)) do i=1,nto yo(i,1) = xo(i,1)-yo(i,1) end do if(mpm.lt.nlon.and.m.ne.0) then do i=1,nto yo(i,2) = xo(i,2)-yo(i,2) end do end if else call tmxmx(lag,nto,nom,idp,po(1,noc+1,ip),nto,idp, 1zo(1,noc+1,ip),xo,yo,ipso(noc+1,ip),jzso(noc+1,ip)) end if do i=1,nto sy(i,mpm) = ye(i,1)+yo(i,1) sy(nlat+1-i,mpm) = ye(i,1)-yo(i,1) end do if(nte.gt.nto) sy(nte,mpm) = ye(nte,1) if(mpm.lt.nlon.and.m.ne.0) then do i=1,nto sy(i,mpm+1) = ye(i,2)+yo(i,2) sy(nlat+1-i,mpm+1) = ye(i,2)-yo(i,2) end do if(nte.gt.nto) sy(nte,mpm+1) = ye(nte,2) end if 100 continue c js = mxtr+mxtr+2 do j=js,nlon do i=1,nlat sy(i,j) = 0. end do end do return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c August 2003 c c ... in file shpg.f c c this file contains code and documentation for subroutines c shpgi and shpg. c c ... files which must be loaded with shpg.f c c hrfft.f c c shpgi initializes the arrays wshp and iwshp for subsequent c use in subroutine shpg, which performs the harmonic projection c which is equivalent to a harmonic analysis followed by c harmonic synthesis but faster and with less memory. c (see description of subroutine shpg below). c c subroutine shpgi(nlat,nlon,isym,mtrunc,wshp,lwshp,iwshp, c 1 liwshp,work,lwork,ierror) c c shpgi initializes arrays wshp and iwshp for repeated use c by subroutine shpg .... c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c nlon must be at least 4. c c isym currently not used, no equatorial symmetries assumed, c only whole sphere computations. c c mtrunc the highest longitudinal wave number retained in the c projection. It must be less than or equal to c the minimum of nlat-1 and nlon/2. The first wave c number is zero. For example, if wave numbers 0 and c 1 are desired then mtrunc = 1. c c lwshp the dimension of the array wshp as it appears in the c program that calls shpgi. It must be at least c 2*(nlat+1)**2+nlon+log2(nlon) c c liwshp the dimension of the array iwshp as it appears in the c program that calls shpgi. It must be at least c 4*(nlat+1). c c lwork the dimension of the array work as it appears in the c program that calls shpgi. It must be at least c 1.25*(nlat+1)**2+7*nlat+8. c c ************************************************************** c c output parameters c c wshp a single precision array that must be saved for c repeated use by subroutine shpg. c c iwshp an integer array that must be saved for repeated c use by subroutine shpg. c c work a double precision work array that does c not have to be saved. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of mtrunc c = 5 error in the specification of lwshp c = 6 error in the specification of liwshp c = 7 error in the specification of lwork c subroutine shpgi(nlat,nlon,isym,mtrunc,wshp,lwshp,iwshp, 1 liwshp,work,lwork,ierror) double precision work(*) dimension wshp(*),iwshp(*) c ierror = 1 if(nlat.lt.1) return ierror = 2 if(nlon.lt.1) return c ierror = 3 c if(isym.lt.0 .or. isym.gt.2) return ierror = 4 mmax = min(nlat-1,nlon/2) if(mtrunc.lt.0 .or. mtrunc.gt.mmax) return ierror = 5 lw1 = 2*(nlat+1)**2 log2n = log(float(nlon))/log(2.0) if(lwshp.lt.lw1+nlon+log2n) return ierror = 6 if(liwshp.lt.4*(nlat+1)) return ierror = 7 mlwk = 1.25*(nlat+1)**2+7*nlat+8 if(lwork.lt.mlwk) return ierror = 0 c call hrffti(nlon,wshp(lw1+1)) c nte = (nlat+1)/2 nloc1 = 2*nte*nte nloc2 = nlat+1 iw1 = 1 iw2 = iw1+nloc1 iw3 = iw2+nloc1 iw4 = iw3+nloc1 jw1 = 1 jw2 = jw1+nloc2 jw3 = jw2+nloc2 jw4 = jw3+nloc2 kw1 = 1 kw2 = kw1+nte kw3 = kw2+nte kw4 = kw3+2*nte kw5 = kw4+2*nte kw6 = kw5+nte kw7 = kw6+nte kw8 = kw7+4*nte kw9 = kw8+2*nte kw10 = kw9+nloc1 kw11 = kw10+nloc1 ktot = kw11+nte*nte c call shpgi1(nlat,nlon,isym,mtrunc,nte,ierror,wshp(iw1),wshp(iw2), 1 wshp(iw3),wshp(iw4),iwshp(jw1),iwshp(jw2),iwshp(jw3), 2 iwshp(jw4),work(kw1),work(kw2),work(kw3),work(kw4),work(kw5), 3 work(kw6),work(kw7),work(kw8),work(kw9),work(kw10),work(kw11)) return end subroutine shpgi1(nlat,nlon,isym,mtrunc,idp,ierror, 1 pe,po,ze,zo,ipse,jzse,ipso,jzso, 2 cp,wx,thet,gwts,xx,z,a,b,ped,pod,u) c*********************************************************************72 c cc SHPGI1 c double precision sum,eps,a1,b1,c1,work parameter (eps=5.0d-8) double precision cp(idp),wx(idp), 1 thet(nlat),gwts(nlat),xx(idp),z(idp),a(4*idp), 2 b(2*idp),ped(idp,idp,2),pod(idp,idp,2),u(idp,idp) c dimension pe(idp,idp,2),po(idp,idp,2),ze(idp,idp,2), 1 zo(idp,idp,2), 2 ipse(idp,2),jzse(idp,2),ipso(idp,2),jzso(idp,2), 3 nshe(2),nsho(2) dimension zort(64,64,2) c ns2 = nlat/2 modn = nlat-ns2-ns2 nte = (nlat+1)/2 nto = nlat-nte tusl = 0. toe = 0. c c compute gauss grid distribution c lwork = nlat+1 call gaqdp(nlat,thet,gwts,work,lwork,ierr) if(ierr .ne. 0) write(*,160) ierr 160 format(' error in gaqd =',i5) do i=1,nto gwts(i) = gwts(i)+gwts(i) end do c c compute n**2 basis (even functions) c do n=1,nlat+nlat-2 dfn = n a(n) = dsqrt(dfn*(dfn+1.0d0)) end do do n=1,nlat-1 dfn = n b(n) = dsqrt((dfn+dfn+3.0d0)/(dfn+dfn-1.0d0)) end do c mxtr = min(nlat-1,nlon/2,mtrunc) ip = 2 do 200 mp1=1,mxtr+1 m = mp1-1 ip = 3-ip ms2 = mp1/2 nem = (nlat-m+1)/2 nec = nte-nem c c compute associated legendre functions c if(m.le.1) then do 205 j=1,nem n = j+j+m-2 call dlfkg(m,n,cp) do i=1,nte call dlftg (m,n,thet(i),cp,ped(i,j+nec,ip)) end do 205 continue c else c do 207 j=1,nem n = j+j+m-2 if(m.gt.1.and.n.gt.mxtr) then do i=1,nte u(i,j+nec) = ped(i,j+nec,ip) end do go to 207 end if a1 = b(n-1)*a(n+m-3)/a(n+m-1) b1 = a(n-m+1)/a(n+m-1) if(n-m.le.1) then do i=1,nte u(i,j+nec) = a1*ped(i,j+nec-1,ip) 1 - b1*ped(i,j+nec,ip) end do else c1 = b(n-1)*a(n-m-1)/a(n+m-1) do i=1,nte u(i,j+nec) = a1*ped(i,j+nec-1,ip) 1 - b1*ped(i,j+nec,ip) + c1*u(i,j+nec-1) end do end if 207 continue do j=1,nem do i=1,nte ped(i,j+nec,ip) = u(i,j+nec) end do end do end if if(nec.le.0) go to 200 c c generate orthogonal vector c do i=1,nte xx(i) = rand(0) end do c it = 0 201 do i=1,nte z(i) = 0.0d0 wx(i) = gwts(i)*xx(i) end do do 220 j=1,nte if(j.eq.nec) go to 220 call gs(nte,wx,ped(1,j,ip),z) 220 continue c do i=1,nte xx(i) = xx(i)-z(i) end do call normal(nte,xx,idp,gwts) it = it+1 if(it.le.2) go to 201 do i=1,nte ped(i,nec,ip) = xx(i) end do 200 continue c c reorder if mtrunc is less than nlat-1 c case of even functions c nmx = nlat-mxtr if(modn.eq.1) then nshe(1) = nmx/2 nshe(2) = (nmx-1)/2 else nshe(1) = (nmx-1)/2 nshe(2) = nmx/2 end if c do 210 mp1=1,2 do j=1,nte js = j+nshe(mp1) if(js.gt.nte) js = js-nte do i=1,nte u(i,js) = ped(i,j,mp1) end do end do do j=1,nte do i=1,nte ped(i,j,mp1) = u(i,j) end do end do 210 continue c call trunc(0,nte,idp,ped(1,1,1),nte,ipse(1,1)) call trunc(0,nte,idp,ped(1,1,2),nte,ipse(1,2)) c c compute the analysis matrices c do 250 ip=1,2 do i=1,nte lock = 0 do j=1,nte sum = ped(j,i,ip)*gwts(j) ze(j,i,ip) = sum pe(i,j,ip) = ped(i,j,ip) if(dabs(sum).gt.eps .and. lock.eq.0) then lock = 1 jzse(i,ip) = j end if end do end do 250 continue c c check orthogonality of pe(i,j,mp1) mp1=1,2 c do ip=1,2 dmax = 0. do i=1,nte do j=1,nte sum1 = 0. do k=1,nte sum1 = sum1+ze(k,i,ip)*pe(k,j,ip) end do zo(i,j,ip) = sum1 if(i.ne.j) then dmax = max(dmax,abs(sum1)) else dmax = max(dmax,abs(sum1-1.0)) end if end do end do end do c c compute n**2 basis (odd functions) c ip = 2 do 300 mp1=1,mxtr+1 ip = 3-ip m = mp1-1 ms2 = mp1/2 nem = (nlat-m+1)/2 nom = nlat-m-nem noc = nto-nom c c compute associated legendre functions c if(m.le.1) then do 305 j=1,nom n = j+j+m-1 call dlfkg(m,n,cp) do i=1,nte call dlftg (m,n,thet(i),cp,pod(i,j+noc,ip)) end do if(modn.gt.0) pod(nte,j+noc,ip) = 0.0d0 305 continue c else c do 307 j=1,nom n = j+j+m-1 if(m.gt.1.and.n.gt.mxtr) then do i=1,nte u(i,j+noc) = pod(i,j+noc,ip) end do go to 304 end if a1 = b(n-1)*a(n+m-3)/a(n+m-1) b1 = a(n-m+1)/a(n+m-1) if(n-m.le.1) then do i=1,nte u(i,j+noc) = a1*pod(i,j+noc-1,ip) 1 - b1*pod(i,j+noc,ip) end do else c1 = b(n-1)*a(n-m-1)/a(n+m-1) do i=1,nte u(i,j+noc) = a1*pod(i,j+noc-1,ip) 1 - b1*pod(i,j+noc,ip) + c1*u(i,j+noc-1) end do end if 304 if(modn.eq.1) u(nte,j+noc) = 0.0d0 307 continue do j=1,nom do i=1,nte pod(i,j+noc,ip) = u(i,j+noc) end do end do end if c if(noc.le.0) go to 300 do i=1,nte xx(i) = rand(0) end do if(modn.eq.1) xx(nte) = 0.0d0 it = 0 306 do i=1,nte z(i) = 0. wx(i) = gwts(i)*xx(i) end do do 330 j=1,nto if(j.eq.noc) go to 330 call gs(nte,wx,pod(1,j,ip),z(1)) 330 continue c do i=1,nte xx(i) = xx(i)-z(i) end do call normal(nte,xx,idp,gwts) it = it+1 if(it.le.2) go to 306 do i=1,nte pod(i,noc,ip) = xx(i) end do if(modn.eq.1) pod(nte,noc,ip) = 0.0d0 300 continue c nmx = nlat-mxtr if(modn.eq.1) then nsho(1) = (nmx-1)/2 nsho(2) = nmx/2 else nsho(1) = nmx/2 nsho(2) = (nmx-1)/2 end if c do 310 mp1=1,2 do j=1,nto js = j+nsho(mp1) if(js.gt.nto) js = js-nto do i=1,nte u(i,js) = pod(i,j,mp1) end do end do do j=1,nto do i=1,nte pod(i,j,mp1) = u(i,j) end do end do 310 continue c call trunc(0,nte,idp,pod(1,1,1),nto,ipso(1,1)) call trunc(0,nte,idp,pod(1,1,2),nto,ipso(1,2)) c c compute the analysis matrices (odd functions) c do ip=1,2 do i=1,nto lock = 0 do j=1,nto sum = pod(j,i,ip)*gwts(j) zo(j,i,ip) = sum po(i,j,ip) = pod(i,j,ip) if(dabs(sum).gt.eps .and. lock.eq.0) then lock = 1 jzso(i,ip) = j end if end do end do end do c c check orthogonality of po(i,j,mp1) mp1=1,2 c do ip=1,2 dmax = 0. do i=1,nto do j=1,nto sum1 = 0. do k=1,nto sum1 = sum1+zo(k,i,ip)*po(k,j,ip) end do zort(i,j,ip) = sum1 if(i.ne.j) then dmax = max(dmax,abs(sum1)) else dmax = max(dmax,abs(sum1-1.0)) end if end do end do end do return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file shsec.f c c this file contains code and documentation for subroutines c shsec and shseci c c ... files which must be loaded with shsec.f c c sphcom.f, hrfft.f c c subroutine shsec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, c + wshsec,lshsec,work,lwork,ierror) c c subroutine shsec performs the spherical harmonic synthesis c on the arrays a and b and stores the result in the array g. c the synthesis is performed on an equally spaced grid. the c associated legendre functions are recomputed rather than stored c as they are in subroutine shses. the synthesis is described c below at output parameter g. c c required files from spherepack2 c c sphcom.f, hrfft.f c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c isym = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c array g(i,j) for i=1,...,nlat and j=1,...,nlon. c (see description of g below) c c = 1 g is antisymmetric about the equator. the synthesis c is performed on the northern hemisphere only. i.e. c if nlat is odd the synthesis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the synthesis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c = 2 g is symmetric about the equator. the synthesis is c performed on the northern hemisphere only. i.e. c if nlat is odd the synthesis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the synthesis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of syntheses. in the program that calls shsec, c the arrays g,a and b can be three dimensional in which c case multiple syntheses will be performed. the third c index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that the arrays g,a and b c have only two dimensions. c c idg the first dimension of the array g as it appears in the c program that calls shsec. if isym equals zero then idg c must be at least nlat. if isym is nonzero then idg c must be at least nlat/2 if nlat is even or at least c (nlat+1)/2 if nlat is odd. c c jdg the second dimension of the array g as it appears in the c program that calls shsec. jdg must be at least nlon. c c a,b two or three dimensional arrays (see the input parameter c nt) that contain the coefficients in the spherical harmonic c expansion of g(i,j) given below at the definition of the c output parameter g. a(m,n) and b(m,n) are defined for c indices m=1,...,mmax and n=m,...,nlat where mmax is the c maximum (plus one) longitudinal wave number given by c mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c mdab the first dimension of the arrays a and b as it appears c in the program that calls shsec. mdab must be at least c min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls shsec. ndab must be at least nlat c c wshsec an array which must be initialized by subroutine shseci. c once initialized, wshsec can be used repeatedly by shsec c as long as nlon and nlat remain unchanged. wshsec must c not be altered between calls of shsec. c c lshsec the dimension of the array wshsec as it appears in the c program that calls shsec. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsec must be at least c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shsec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*(nt*nlon+max0(3*l2,nlon)) c c if isym is not zero then lwork must be at least c c l2*(nt*nlon+max0(3*nlat,nlon)) c c ************************************************************** c c output parameters c c g a two or three dimensional array (see input parameter c nt) that contains the spherical harmonic synthesis of c the arrays a and b at the colatitude point theta(i) = c (i-1)*pi/(nlat-1) and longitude point phi(j) = c (j-1)*2*pi/nlon. the index ranges are defined above at c at the input parameter isym. for isym=0, g(i,j) is c given by the the equations listed below. symmetric c versions are used when isym is greater than zero. c c the normalized associated legendre functions are given by c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta) c c define the maximum (plus one) longitudinal wave number c as mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c then g(i,j) = the sum from n=0 to n=nlat-1 of c c .5*pbar(0,n,theta(i))*a(1,n+1) c c plus the sum from m=1 to m=mmax-1 of c c the sum from n=m to n=nlat-1 of c c pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j)) c -b(m+1,n+1)*sin(m*phi(j))) c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idg c = 6 error in the specification of jdg c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lshsec c = 10 error in the specification of lwork c c c **************************************************************** c subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror) c c subroutine shseci initializes the array wshsec which can then c be used repeatedly by subroutine shsec. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c lshsec the dimension of the array wshsec as it appears in the c program that calls shseci. the array wshsec is an output c parameter which is described below. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsec must be at least c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c dwork a double precision work array that does not have to be c saved. c c ldwork the dimension of array dwork as it appears in the program c that calls shseci. ldwork must be at least nlat+1. c c output parameters c c wshsec an array which is initialized for use by subroutine shsec. c once initialized, wshsec can be used repeatedly by shsec c as long as nlon and nlat remain unchanged. wshsec must c not be altered between calls of shsec. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshsec c = 4 error in the specification of ldwork c c c **************************************************************** subroutine shsec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, 1 wshsec,lshsec,work,lwork,ierror) dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1),wshsec(1), 1 work(1) ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 if((isym.eq.0 .and. idg.lt.nlat) .or. 1 (isym.ne.0 .and. idg.lt.(nlat+1)/2)) return ierror = 6 if(jdg .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lzz1 = 2*nlat*imid labc = 3*((mmax-2)*(nlat+nlat-mmax-1))/2 if(lshsec .lt. lzz1+labc+nlon+15) return ierror = 10 ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon if(lwork .lt. nln+max0(ls*nlon,3*nlat*imid)) return ierror = 0 ist = 0 if(isym .eq. 0) ist = imid iw1 = lzz1+labc+1 call shsec1(nlat,isym,nt,g,idg,jdg,a,b,mdab,ndab,imid,ls,nlon, 1 work,work(ist+1),work(nln+1),work(nln+1),wshsec,wshsec(iw1)) return end subroutine shsec1(nlat,isym,nt,g,idgs,jdgs,a,b,mdab,ndab,imid, 1 idg,jdg,ge,go,work,pb,walin,whrfft) c c whrfft must have at least nlon+15 locations c walin must have 3*l*imid + 3*((l-3)*l+2)/2 locations c zb must have 3*l*imid locations c dimension g(idgs,jdgs,1),a(mdab,ndab,1),b(mdab,ndab,1), 1 ge(idg,jdg,1),go(idg,jdg,1),pb(imid,nlat,3),walin(1), 3 whrfft(1),work(1) ls = idg nlon = jdg mmax = min0(nlat,nlon/2+1) mdo = mmax if(mdo+mdo-1 .gt. nlon) mdo = mmax-1 nlp1 = nlat+1 modl = mod(nlat,2) imm1 = imid if(modl .ne. 0) imm1 = imid-1 do 80 k=1,nt do 80 j=1,nlon do 80 i=1,ls ge(i,j,k)=0. 80 continue if(isym .eq. 1) go to 125 call alin (2,nlat,nlon,0,pb,i3,walin) do 100 k=1,nt do 100 np1=1,nlat,2 do 100 i=1,imid ge(i,1,k)=ge(i,1,k)+a(1,np1,k)*pb(i,np1,i3) 100 continue ndo = nlat if(mod(nlat,2) .eq. 0) ndo = nlat-1 do 110 mp1=2,mdo m = mp1-1 call alin (2,nlat,nlon,m,pb,i3,walin) do 110 np1=mp1,ndo,2 do 110 k=1,nt do 110 i=1,imid ge(i,2*mp1-2,k) = ge(i,2*mp1-2,k)+a(mp1,np1,k)*pb(i,np1,i3) ge(i,2*mp1-1,k) = ge(i,2*mp1-1,k)+b(mp1,np1,k)*pb(i,np1,i3) 110 continue if(mdo .eq. mmax .or. mmax .gt. ndo) go to 122 call alin (2,nlat,nlon,mdo,pb,i3,walin) do 120 np1=mmax,ndo,2 do 120 k=1,nt do 120 i=1,imid ge(i,2*mmax-2,k) = ge(i,2*mmax-2,k)+a(mmax,np1,k)*pb(i,np1,i3) 120 continue 122 if(isym .eq. 2) go to 155 125 call alin(1,nlat,nlon,0,pb,i3,walin) do 140 k=1,nt do 140 np1=2,nlat,2 do 140 i=1,imm1 go(i,1,k)=go(i,1,k)+a(1,np1,k)*pb(i,np1,i3) 140 continue ndo = nlat if(mod(nlat,2) .ne. 0) ndo = nlat-1 do 150 mp1=2,mdo mp2 = mp1+1 m = mp1-1 call alin(1,nlat,nlon,m,pb,i3,walin) do 150 np1=mp2,ndo,2 do 150 k=1,nt do 150 i=1,imm1 go(i,2*mp1-2,k) = go(i,2*mp1-2,k)+a(mp1,np1,k)*pb(i,np1,i3) go(i,2*mp1-1,k) = go(i,2*mp1-1,k)+b(mp1,np1,k)*pb(i,np1,i3) 150 continue mp2 = mmax+1 if(mdo .eq. mmax .or. mp2 .gt. ndo) go to 155 call alin(1,nlat,nlon,mdo,pb,i3,walin) do 152 np1=mp2,ndo,2 do 152 k=1,nt do 152 i=1,imm1 go(i,2*mmax-2,k) = go(i,2*mmax-2,k)+a(mmax,np1,k)*pb(i,np1,i3) 152 continue 155 do 160 k=1,nt if(mod(nlon,2) .ne. 0) go to 157 do 156 i=1,ls ge(i,nlon,k) = 2.*ge(i,nlon,k) 156 continue 157 call hrfftb(ls,nlon,ge(1,1,k),ls,whrfft,work) 160 continue if(isym .ne. 0) go to 180 do 170 k=1,nt do 170 j=1,nlon do 175 i=1,imm1 g(i,j,k) = .5*(ge(i,j,k)+go(i,j,k)) g(nlp1-i,j,k) = .5*(ge(i,j,k)-go(i,j,k)) 175 continue if(modl .eq. 0) go to 170 g(imid,j,k) = .5*ge(imid,j,k) 170 continue return 180 do 185 k=1,nt do 185 i=1,imid do 185 j=1,nlon g(i,j,k) = .5*ge(i,j,k) 185 continue return end c subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror) c c subroutine shseci initializes the array wshsec which can then c be used repeatedly by subroutine shsec. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c lshsec the dimension of the array wshsec as it appears in the c program that calls shseci. the array wshsec is an output c parameter which is described below. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsec must be at least c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c dwork a double precision work array that does not have to be c saved. c c ldwork the dimension of array dwork as it appears in the program c that calls shseci. ldwork must be at least nlat+1. c c output parameters c c wshsec an array which is initialized for use by subroutine shsec. c once initialized, wshsec can be used repeatedly by shsec c as long as nlon and nlat remain unchanged. wshsec must c not be altered between calls of shsec. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshsec c = 4 error in the specification of ldwork c c c **************************************************************** subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror) dimension wshsec(*) double precision dwork(ldwork) ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return ierror = 3 imid = (nlat+1)/2 mmax = min0(nlat,nlon/2+1) lzz1 = 2*nlat*imid labc = 3*((mmax-2)*(nlat+nlat-mmax-1))/2 if(lshsec .lt. lzz1+labc+nlon+15) return ierror = 4 if(ldwork .lt. nlat+1) return ierror = 0 call alinit(nlat,nlon,wshsec,dwork) iw1 = lzz1+labc+1 call hrffti(nlon,wshsec(iw1)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file shses.f c c this file contains code and documentation for subroutines c shses and shsesi c c ... files which must be loaded with shses.f c c sphcom.f, hrfft.f c c subroutine shses(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, c + wshses,lshses,work,lwork,ierror) c c subroutine shses performs the spherical harmonic synthesis c on the arrays a and b and stores the result in the array g. c the synthesis is performed on an equally spaced grid. the c associated legendre functions are stored rather than recomputed c as they are in subroutine shsec. the synthesis is described c below at output parameter g. c c *** required files from spherepack2 c c sphcom.f, hrfft.f c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c isym = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c array g(i,j) for i=1,...,nlat and j=1,...,nlon. c (see description of g below) c c = 1 g is antisymmetric about the equator. the synthesis c is performed on the northern hemisphere only. i.e. c if nlat is odd the synthesis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the synthesis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c = 2 g is symmetric about the equator. the synthesis is c performed on the northern hemisphere only. i.e. c if nlat is odd the synthesis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the synthesis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of syntheses. in the program that calls shses, c the arrays g,a and b can be three dimensional in which c case multiple syntheses will be performed. the third c index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that the arrays g,a and b c have only two dimensions. c c idg the first dimension of the array g as it appears in the c program that calls shses. if isym equals zero then idg c must be at least nlat. if isym is nonzero then idg c must be at least nlat/2 if nlat is even or at least c (nlat+1)/2 if nlat is odd. c c jdg the second dimension of the array g as it appears in the c program that calls shses. jdg must be at least nlon. c c a,b two or three dimensional arrays (see the input parameter c nt) that contain the coefficients in the spherical harmonic c expansion of g(i,j) given below at the definition of the c output parameter g. a(m,n) and b(m,n) are defined for c indices m=1,...,mmax and n=m,...,nlat where mmax is the c maximum (plus one) longitudinal wave number given by c mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c mdab the first dimension of the arrays a and b as it appears c in the program that calls shses. mdab must be at least c min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls shses. ndab must be at least nlat c c wshses an array which must be initialized by subroutine shsesi. c once initialized, wshses can be used repeatedly by shses c as long as nlon and nlat remain unchanged. wshses must c not be altered between calls of shses. c c lshses the dimension of the array wshses as it appears in the c program that calls shses. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshses must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shses. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c (nt+1)*nlat*nlon c c if isym is nonzero lwork must be at least c c (nt+1)*l2*nlon. c c ************************************************************** c c output parameters c c g a two or three dimensional array (see input parameter c nt) that contains the spherical harmonic synthesis of c the arrays a and b at the colatitude point theta(i) = c (i-1)*pi/(nlat-1) and longitude point phi(j) = c (j-1)*2*pi/nlon. the index ranges are defined above at c at the input parameter isym. for isym=0, g(i,j) is c given by the the equations listed below. symmetric c versions are used when isym is greater than zero. c c the normalized associated legendre functions are given by c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta) c c define the maximum (plus one) longitudinal wave number c as mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c then g(i,j) = the sum from n=0 to n=nlat-1 of c c .5*pbar(0,n,theta(i))*a(1,n+1) c c plus the sum from m=1 to m=mmax-1 of c c the sum from n=m to n=nlat-1 of c c pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j)) c -b(m+1,n+1)*sin(m*phi(j))) c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idg c = 6 error in the specification of jdg c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lshses c = 10 error in the specification of lwork c c c **************************************************************** c subroutine shsesi(nlat,nlon,wshses,lshses,work,lwork,dwork, c + ldwork,ierror) c c subroutine shsesi initializes the array wshses which can then c be used repeatedly by subroutine shses. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c lshses the dimension of the array wshses as it appears in the c program that calls shsesi. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshses must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a real work array that does not have to be saved. c c lwork the dimension of the array work as it appears in c the program that calls shsesi. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwork must be at least c c 5*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2 c c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls shsesi. ldwork must be at least nlat+1 c c c output parameters c c wshses an array which is initialized for use by subroutine shses. c once initialized, wshses can be used repeatedly by shses c as long as nlon and nlat remain unchanged. wshses must c not be altered between calls of shses. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshses c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c c **************************************************************** subroutine shses(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, 1 wshses,lshses,work,lwork,ierror) dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1),wshses(1), 1 work(1) ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return ierror = 3 if(isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 if((isym.eq.0 .and. idg.lt.nlat) .or. 1 (isym.ne.0 .and. idg.lt.(nlat+1)/2)) return ierror = 6 if(jdg .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshses .lt. lpimn+nlon+15) return ierror = 10 ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon if(lwork.lt. nln+ls*nlon) return ierror = 0 ist = 0 if(isym .eq. 0) ist = imid call shses1(nlat,isym,nt,g,idg,jdg,a,b,mdab,ndab,wshses,imid, 1 ls,nlon,work,work(ist+1),work(nln+1),wshses(lpimn+1)) return end subroutine shses1(nlat,isym,nt,g,idgs,jdgs,a,b,mdab,ndab,p,imid, 1 idg,jdg,ge,go,work,whrfft) dimension g(idgs,jdgs,1),a(mdab,ndab,1),b(mdab,ndab,1),p(imid,1), 1 ge(idg,jdg,1),go(idg,jdg,1),work(1),whrfft(1) ls = idg nlon = jdg mmax = min0(nlat,nlon/2+1) mdo = mmax if(mdo+mdo-1 .gt. nlon) mdo = mmax-1 nlp1 = nlat+1 modl = mod(nlat,2) imm1 = imid if(modl .ne. 0) imm1 = imid-1 do 80 k=1,nt do 80 j=1,nlon do 80 i=1,ls ge(i,j,k) = 0. 8000 continue 800 continue 80 continue if(isym .eq. 1) go to 125 do 100 k=1,nt do 100 np1=1,nlat,2 do 100 i=1,imid ge(i,1,k)=ge(i,1,k)+a(1,np1,k)*p(i,np1) 100 continue ndo = nlat if(mod(nlat,2) .eq. 0) ndo = nlat-1 do 110 mp1=2,mdo m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 do 110 np1=mp1,ndo,2 mn = mb+np1 do 110 k=1,nt do 110 i=1,imid ge(i,2*mp1-2,k) = ge(i,2*mp1-2,k)+a(mp1,np1,k)*p(i,mn) ge(i,2*mp1-1,k) = ge(i,2*mp1-1,k)+b(mp1,np1,k)*p(i,mn) 110 continue if(mdo .eq. mmax .or. mmax .gt. ndo) go to 122 mb = mdo*(nlat-1)-(mdo*(mdo-1))/2 do 120 np1=mmax,ndo,2 mn = mb+np1 do 120 k=1,nt do 120 i=1,imid ge(i,2*mmax-2,k) = ge(i,2*mmax-2,k)+a(mmax,np1,k)*p(i,mn) 120 continue 122 if(isym .eq. 2) go to 155 125 do 140 k=1,nt do 140 np1=2,nlat,2 do 140 i=1,imm1 go(i,1,k)=go(i,1,k)+a(1,np1,k)*p(i,np1) 140 continue ndo = nlat if(mod(nlat,2) .ne. 0) ndo = nlat-1 do 150 mp1=2,mdo mp2 = mp1+1 m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 do 150 np1=mp2,ndo,2 mn = mb+np1 do 150 k=1,nt do 150 i=1,imm1 go(i,2*mp1-2,k) = go(i,2*mp1-2,k)+a(mp1,np1,k)*p(i,mn) go(i,2*mp1-1,k) = go(i,2*mp1-1,k)+b(mp1,np1,k)*p(i,mn) 150 continue mp2 = mmax+1 if(mdo .eq. mmax .or. mp2 .gt. ndo) go to 155 mb = mdo*(nlat-1)-(mdo*(mdo-1))/2 do 152 np1=mp2,ndo,2 mn = mb+np1 do 152 k=1,nt do 152 i=1,imm1 go(i,2*mmax-2,k) = go(i,2*mmax-2,k)+a(mmax,np1,k)*p(i,mn) 152 continue 155 do 160 k=1,nt if(mod(nlon,2) .ne. 0) go to 157 do 156 i=1,ls ge(i,nlon,k) = 2.*ge(i,nlon,k) 156 continue 157 call hrfftb(ls,nlon,ge(1,1,k),ls,whrfft,work) 160 continue if(isym .ne. 0) go to 180 do 170 k=1,nt do 170 j=1,nlon do 175 i=1,imm1 g(i,j,k) = .5*(ge(i,j,k)+go(i,j,k)) g(nlp1-i,j,k) = .5*(ge(i,j,k)-go(i,j,k)) 175 continue if(modl .eq. 0) go to 170 g(imid,j,k) = .5*ge(imid,j,k) 170 continue return 180 do 185 k=1,nt do 185 i=1,imid do 185 j=1,nlon g(i,j,k) = .5*ge(i,j,k) 185 continue return end subroutine shsesi(nlat,nlon,wshses,lshses,work,lwork,dwork, + ldwork,ierror) dimension wshses(*),work(*) double precision dwork(*) ierror = 1 if(nlat.lt.3) return ierror = 2 if(nlon.lt.4) return ierror = 3 mmax = min0(nlat,nlon/2+1) imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshses .lt. lpimn+nlon+15) return ierror = 4 labc = 3*((mmax-2)*(nlat+nlat-mmax-1))/2 if(lwork .lt. 5*nlat*imid + labc) return ierror = 5 if (ldwork .lt. nlat+1) return ierror = 0 iw1 = 3*nlat*imid+1 CALL SES1(NLAT,NLON,IMID,WSHSES,WORK,WORK(IW1),DWORK) call hrffti(nlon,wshses(lpimn+1)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file shsgc.f c c this file contains code and documentation for subroutines c shsgc and shsgci c c ... files which must be loaded with shsgc.f c c sphcom.f, hrfft.f, gaqd.f c c subroutine shsgc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, c + wshsgc,lshsgc,work,lwork,ierror) c c subroutine shsgc performs the spherical harmonic synthesis c on the arrays a and b and stores the result in the array g. c the synthesis is performed on an equally spaced longitude grid c and a gaussian colatitude grid. the associated legendre functions c are recomputed rather than stored as they are in subroutine c shsgs. the synthesis is described below at output parameter c g. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c isym = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c array g(i,j) for i=1,...,nlat and j=1,...,nlon. c (see description of g below) c c = 1 g is antisymmetric about the equator. the synthesis c is performed on the northern hemisphere only. i.e. c if nlat is odd the synthesis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the synthesis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c = 2 g is symmetric about the equator. the synthesis is c performed on the northern hemisphere only. i.e. c if nlat is odd the synthesis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the synthesis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of syntheses. in the program that calls shsgc, c the arrays g,a and b can be three dimensional in which c case multiple synthesis will be performed. the third c index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that the arrays g,a and b c have only two dimensions. c c idg the first dimension of the array g as it appears in the c program that calls shsgc. if isym equals zero then idg c must be at least nlat. if isym is nonzero then idg must c be at least nlat/2 if nlat is even or at least (nlat+1)/2 c if nlat is odd. c c jdg the second dimension of the array g as it appears in the c program that calls shsgc. jdg must be at least nlon. c c mdab the first dimension of the arrays a and b as it appears c in the program that calls shsgc. mdab must be at least c min0((nlon+2)/2,nlat) if nlon is even or at least c min0((nlon+1)/2,nlat) if nlon is odd c c ndab the second dimension of the arrays a and b as it appears c in the program that calls shsgc. ndab must be at least nlat c c a,b two or three dimensional arrays (see the input parameter c nt) that contain the coefficients in the spherical harmonic c expansion of g(i,j) given below at the definition of the c output parameter g. a(m,n) and b(m,n) are defined for c indices m=1,...,mmax and n=m,...,nlat where mmax is the c maximum (plus one) longitudinal wave number given by c mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c wshsgc an array which must be initialized by subroutine shsgci. c once initialized, wshsgc can be used repeatedly by shsgc c as long as nlat and nlon remain unchanged. wshsgc must c not be altered between calls of shsgc. c c lshsgc the dimension of the array wshsgc as it appears in the c program that calls shsgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls shsgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if isym is zero then lwork must be at least c c nlat*(nlon*nt+max0(3*l2,nlon)) c c if isym is not zero then lwork must be at least c c l2*(nlon*nt+max0(3*nlat,nlon)) c c ************************************************************** c c output parameters c c g a two or three dimensional array (see input parameter nt) c that contains the discrete function which is synthesized. c g(i,j) contains the value of the function at the gaussian c colatitude point theta(i) and longitude point c phi(j) = (j-1)*2*pi/nlon. the index ranges are defined c above at the input parameter isym. for isym=0, g(i,j) c is given by the the equations listed below. symmetric c versions are used when isym is greater than zero. c c the normalized associated legendre functions are given by c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta) c c c define the maximum (plus one) longitudinal wave number c as mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c then g(i,j) = the sum from n=0 to n=nlat-1 of c c .5*pbar(0,n,theta(i))*a(1,n+1) c c plus the sum from m=1 to m=mmax-1 of c c the sum from n=m to n=nlat-1 of c c pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j)) c -b(m+1,n+1)*sin(m*phi(j))) c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idg c = 6 error in the specification of jdg c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lwshig c = 10 error in the specification of lwork c c c **************************************************************** c c subroutine shsgci(nlat,nlon,wshsgc,lshsgc,dwork,ldwork,ierror) c c subroutine shsgci initializes the array wshsgc which can then c be used repeatedly by subroutines shsgc. it precomputes c and stores in wshsgc quantities such as gaussian weights, c legendre polynomial coefficients, and fft trigonometric tables. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c wshsgc an array which must be initialized by subroutine shsgci. c once initialized, wshsgc can be used repeatedly by shsgc c as long as nlat and nlon remain unchanged. wshsgc must c not be altered between calls of shsgc. c c lshsgc the dimension of the array wshsgc as it appears in the c program that calls shsgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls shsgci. ldwork must be at least c c nlat*(nlat+4) c c output parameter c c wshsgc an array which must be initialized before calling shsgc. c once initialized, wshsgc can be used repeatedly by shsgc c as long as nlat and nlon remain unchanged. wshsgc must not c altered between calls of shsgc. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshsgc c = 4 error in the specification of ldwork c = 5 failure in gaqd to compute gaussian points c (due to failure in eigenvalue routine) c c c **************************************************************** subroutine shsgc(nlat,nlon,mode,nt,g,idg,jdg,a,b,mdab,ndab, 1 wshsgc,lshsgc,work,lwork,ierror) c subroutine shsgc performs the spherical harmonic synthesis on c a gaussian grid using the coefficients in array(s) a,b and returns c the results in array(s) g. the legendre polynomials are computed c as needed in this version. c dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1), 1 wshsgc(lshsgc),work(lwork) c check input parameters ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return ierror = 3 if (mode.lt.0 .or.mode.gt.2) return ierror = 4 if (nt.lt.1) return c set limit for m iin a(m,n),b(m,n) computation l = min0((nlon+2)/2,nlat) c set gaussian point nearest equator pointer late = (nlat+mod(nlat,2))/2 c set number of grid points for analysis/synthesis lat = nlat if (mode.ne.0) lat = late ierror = 5 if (idg.lt.lat) return ierror = 6 if (jdg.lt.nlon) return ierror = 7 if(mdab .lt. l) return ierror = 8 if(ndab .lt. nlat) return l1 = l l2 = late ierror = 9 c check permanent work space length if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 10 c check temporary work space length if (mode.eq.0) then if(lwork.lt.nlat*(nlon*nt+max0(3*l2,nlon)))return else c mode.ne.0 if(lwork.lt.l2*(nlon*nt+max0(3*nlat,nlon))) return end if ierror = 0 c starting address fft values ifft = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+1 c set pointers for internal storage of g and legendre polys ipmn = lat*nlon*nt+1 call shsgc1(nlat,nlon,l,lat,mode,g,idg,jdg,nt,a,b,mdab,ndab, 1wshsgc,wshsgc(ifft),late,work(ipmn),work) return end subroutine shsgc1(nlat,nlon,l,lat,mode,gs,idg,jdg,nt,a,b,mdab, 1 ndab,w,wfft,late,pmn,g) dimension gs(idg,jdg,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension w(1),pmn(nlat,late,3),g(lat,nlon,nt),wfft(1) c reconstruct fourier coefficients in g on gaussian grid c using coefficients in a,b c set m+1 limit for b coefficient calculation lm1 = l if (nlon .eq. l+l-2) lm1 = l-1 c initialize to zero do 100 k=1,nt do 100 j=1,nlon do 100 i=1,lat g(i,j,k) = 0.0 100 continue if (mode.eq.0) then c set first column in g m = 0 c compute pmn for all i and n=m,...,l-1 call legin(mode,l,nlat,m,w,pmn,km) do 101 k=1,nt c n even do 102 np1=1,nlat,2 do 102 i=1,late g(i,1,k) = g(i,1,k)+a(1,np1,k)*pmn(np1,i,km) 102 continue c n odd nl2 = nlat/2 do 103 np1=2,nlat,2 do 103 i=1,nl2 is = nlat-i+1 g(is,1,k) = g(is,1,k)+a(1,np1,k)*pmn(np1,i,km) 103 continue c restore m=0 coefficents (reverse implicit even/odd reduction) do 112 i=1,nl2 is = nlat-i+1 t1 = g(i,1,k) t3 = g(is,1,k) g(i,1,k) = t1+t3 g(is,1,k) = t1-t3 112 continue 101 continue c sweep columns of g for which b is available do 104 mp1=2,lm1 m = mp1-1 mp2 = m+2 c compute pmn for all i and n=m,...,l-1 call legin(mode,l,nlat,m,w,pmn,km) do 105 k=1,nt c for n-m even store (g(i,p,k)+g(nlat-i+1,p,k))/2 in g(i,p,k) p=2*m, c for i=1,...,late do 106 np1=mp1,nlat,2 do 107 i=1,late g(i,2*m,k) = g(i,2*m,k)+a(mp1,np1,k)*pmn(np1,i,km) g(i,2*m+1,k) = g(i,2*m+1,k)+b(mp1,np1,k)*pmn(np1,i,km) 107 continue 106 continue c for n-m odd store g(i,p,k)-g(nlat-i+1,p,k) in g(nlat-i+1,p,k) c for i=1,...,nlat/2 (p=2*m,p=2*m+1) do 108 np1=mp2,nlat,2 do 109 i=1,nl2 is = nlat-i+1 g(is,2*m,k) = g(is,2*m,k)+a(mp1,np1,k)*pmn(np1,i,km) g(is,2*m+1,k) = g(is,2*m+1,k)+b(mp1,np1,k)*pmn(np1,i,km) 109 continue 108 continue c now set fourier coefficients using even-odd reduction above do 110 i=1,nl2 is = nlat-i+1 t1 = g(i,2*m,k) t2 = g(i,2*m+1,k) t3 = g(is,2*m,k) t4 = g(is,2*m+1,k) g(i,2*m,k) = t1+t3 g(i,2*m+1,k) = t2+t4 g(is,2*m,k) = t1-t3 g(is,2*m+1,k) = t2-t4 110 continue 105 continue 104 continue c set last column (using a only) if (nlon.eq. l+l-2) then m = l-1 call legin(mode,l,nlat,m,w,pmn,km) do 111 k=1,nt c n-m even do 131 np1=l,nlat,2 do 131 i=1,late g(i,nlon,k) = g(i,nlon,k)+2.0*a(l,np1,k)*pmn(np1,i,km) 131 continue lp1 = l+1 c n-m odd do 132 np1=lp1,nlat,2 do 132 i=1,nl2 is = nlat-i+1 g(is,nlon,k) = g(is,nlon,k)+2.0*a(l,np1,k)*pmn(np1,i,km) 132 continue do 133 i=1,nl2 is = nlat-i+1 t1 = g(i,nlon,k) t3 = g(is,nlon,k) g(i,nlon,k)= t1+t3 g(is,nlon,k)= t1-t3 133 continue 111 continue end if else c half sphere (mode.ne.0) c set first column in g m = 0 meo = 1 if (mode.eq.1) meo = 2 ms = m+meo c compute pmn for all i and n=m,...,l-1 call legin(mode,l,nlat,m,w,pmn,km) do 113 k=1,nt do 113 np1=ms,nlat,2 do 113 i=1,late g(i,1,k) = g(i,1,k)+a(1,np1,k)*pmn(np1,i,km) 113 continue c sweep interior columns of g do 114 mp1=2,lm1 m = mp1-1 ms = m+meo c compute pmn for all i and n=m,...,l-1 call legin(mode,l,nlat,m,w,pmn,km) do 115 k=1,nt do 115 np1=ms,nlat,2 do 115 i=1,late g(i,2*m,k) = g(i,2*m,k)+a(mp1,np1,k)*pmn(np1,i,km) g(i,2*m+1,k) = g(i,2*m+1,k)+b(mp1,np1,k)*pmn(np1,i,km) 115 continue 114 continue if (nlon.eq.l+l-2) then c set last column m = l-1 call legin(mode,l,nlat,m,w,pmn,km) ns = l if (mode.eq.1) ns = l+1 do 116 k=1,nt do 116 i=1,late do 116 np1=ns,nlat,2 g(i,nlon,k) = g(i,nlon,k)+2.0*a(l,np1,k)*pmn(np1,i,km) 116 continue end if end if c do inverse fourier transform do 120 k=1,nt call hrfftb(lat,nlon,g(1,1,k),lat,wfft,pmn) 120 continue c scale output in gs do 122 k=1,nt do 122 j=1,nlon do 122 i=1,lat gs(i,j,k) = 0.5*g(i,j,k) 122 continue return end subroutine shsgci(nlat,nlon,wshsgc,lshsgc,dwork,ldwork,ierror) c this subroutine must be called before calling shsgc with c fixed nlat,nlon. it precomputes quantites such as the gaussian c points and weights, m=0,m=1 legendre polynomials, recursion c recursion coefficients. dimension wshsgc(lshsgc) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+mod(nlat,2))/2 l1 = l l2 = late ierror = 3 c check permanent work space length if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 4 if (ldwork .lt. nlat*(nlat+4)) return ierror = 0 c set pointers i1 = 1 i2 = i1+nlat i3 = i2+nlat*late i4 = i3+nlat*late i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1) i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1) i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1) c set indices in temp work for double precision gaussian wts and pts idth = 1 idwts = idth+nlat iw = idwts+nlat call shsgci1(nlat,nlon,l,late,wshsgc(i1),wshsgc(i2),wshsgc(i3), 1wshsgc(i4),wshsgc(i5),wshsgc(i6),wshsgc(i7),dwork(idth), 2dwork(idwts),dwork(iw),ierror) if (ierror.ne.0) ierror = 5 return end subroutine shsgci1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel, 1 wfft,dtheta,dwts,work,ier) dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1), 1 cbel(1),wfft(1),dtheta(nlat),dwts(nlat) double precision pb,dtheta,dwts,work(*) c compute the nlat gaussian points and weights, the c m=0,1 legendre polys for gaussian points and all n, c and the legendre recursion coefficients c define index function used in storing c arrays for recursion coefficients (functions of (m,n)) c the index function indx(m,n) is defined so that c the pairs (m,n) map to [1,2,...,indx(l-1,l-1)] with no c "holes" as m varies from 2 to n and n varies from 2 to l-1. c (m=0,1 are set from p0n,p1n for all n) c define for 2.le.n.le.l-1 indx(m,n) = (n-1)*(n-2)/2+m-1 c define index function for l.le.n.le.nlat imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1 c preset quantites for fourier transform call hrffti(nlon,wfft) c compute double precision gaussian points and weights c lw = 4*nlat*(nlat+1)+2 lw = nlat*(nlat+2) call gaqd(nlat,dtheta,dwts,work,lw,ier) if (ier.ne.0) return c store gaussian weights single precision to save computation c in inner loops in analysis do 100 i=1,nlat wts(i) = dwts(i) 100 continue c initialize p0n,p1n using double precision dnlfk,dnlft do 101 np1=1,nlat do 101 i=1,late p0n(np1,i) = 0.0 p1n(np1,i) = 0.0 101 continue c compute m=n=0 legendre polynomials for all theta(i) np1 = 1 n = 0 m = 0 call dnlfk(m,n,work) do 103 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(1,i) = pb 103 continue c compute p0n,p1n for all theta(i) when n.gt.0 do 104 np1=2,nlat n = np1-1 m = 0 call dnlfk(m,n,work) do 105 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(np1,i) = pb 105 continue c compute m=1 legendre polynomials for all n and theta(i) m = 1 call dnlfk(m,n,work) do 106 i=1,late call dnlft(m,n,dtheta(i),work,pb) p1n(np1,i) = pb 106 continue 104 continue c compute and store swarztrauber recursion coefficients c for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel do 107 n=2,nlat mlim = min0(n,l) do 107 m=2,mlim imn = indx(m,n) if (n.ge.l) imn = imndx(m,n) abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/ 1 float(((n+m-1)*(n+m)))) 107 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file shsgs.f c c this file contains code and documentation for subroutines c shsgs and shsgsi c c ... files which must be loaded with shsgs.f c c sphcom.f, hrfft.f, gaqd.f c c subroutine shsgs(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab, c 1 wshsgs,lshsgs,work,lwork,ierror) c c subroutine shsgs performs the spherical harmonic synthesis c on the arrays a and b and stores the result in the array g. c the synthesis is performed on an equally spaced longitude grid c and a gaussian colatitude grid. the associated legendre functions c are stored rather than recomputed as they are in subroutine c shsgc. the synthesis is described below at output parameter c g. c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c isym = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c array g(i,j) for i=1,...,nlat and j=1,...,nlon. c (see description of g below) c c = 1 g is antisymmetric about the equator. the synthesis c is performed on the northern hemisphere only. i.e. c if nlat is odd the synthesis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the synthesis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c = 2 g is symmetric about the equator. the synthesis is c performed on the northern hemisphere only. i.e. c if nlat is odd the synthesis is performed on the c array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the synthesis is performed on the c array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of syntheses. in the program that calls shsgs, c the arrays g,a and b can be three dimensional in which c case multiple synthesis will be performed. the third c index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that the arrays g,a and b c have only two dimensions. c c idg the first dimension of the array g as it appears in the c program that calls shagc. if isym equals zero then idg c must be at least nlat. if isym is nonzero then idg must c be at least nlat/2 if nlat is even or at least (nlat+1)/2 c if nlat is odd. c c jdg the second dimension of the array g as it appears in the c program that calls shagc. jdg must be at least nlon. c c a,b two or three dimensional arrays (see the input parameter c nt) that contain the coefficients in the spherical harmonic c expansion of g(i,j) given below at the definition of the c output parameter g. a(m,n) and b(m,n) are defined for c indices m=1,...,mmax and n=m,...,nlat where mmax is the c maximum (plus one) longitudinal wave number given by c mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c mdab the first dimension of the arrays a and b as it appears c in the program that calls shsgs. mdab must be at least c min0((nlon+2)/2,nlat) if nlon is even or at least c min0((nlon+1)/2,nlat) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls shsgs. ndab must be at least nlat c c wshsgs an array which must be initialized by subroutine shsgsi. c once initialized, wshsgs can be used repeatedly by shsgs c as long as nlat and nlon remain unchanged. wshsgs must c not be altered between calls of shsgs. c c lshsgs the dimension of the array wshsgs as it appears in the c program that calls shsgs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgs must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c c lwork the dimension of the array work as it appears in the c program that calls shsgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c c if isym is zero then lwork must be at least c c nlat*nlon*(nt+1) c c if isym is nonzero then lwork must be at least c c l2*nlon*(nt+1) c c c ************************************************************** c c output parameters c c g a two or three dimensional array (see input parameter nt) c that contains the discrete function which is synthesized. c g(i,j) contains the value of the function at the gaussian c colatitude point theta(i) and longitude point c phi(j) = (j-1)*2*pi/nlon. the index ranges are defined c above at the input parameter isym. for isym=0, g(i,j) c is given by the the equations listed below. symmetric c versions are used when isym is greater than zero. c c the normalized associated legendre functions are given by c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m))) c *sin(theta)**m/(2**n*factorial(n)) times the c (n+m)th derivative of (x**2-1)**n with respect c to x=cos(theta) c c define the maximum (plus one) longitudinal wave number c as mmax = min0(nlat,(nlon+2)/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c then g(i,j) = the sum from n=0 to n=nlat-1 of c c .5*pbar(0,n,theta(i))*a(1,n+1) c c plus the sum from m=1 to m=mmax-1 of c c the sum from n=m to n=nlat-1 of c c pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j)) c -b(m+1,n+1)*sin(m*phi(j))) c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of idg c = 6 error in the specification of jdg c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lshsgs c = 10 error in the specification of lwork c c c **************************************************************** c c subroutine shsgsi(nlat,nlon,wshsgs,lshsgs,work,lwork,dwork,ldwork, c + ierror) c c subroutine shsgsi initializes the array wshsgs which can then c be used repeatedly by subroutines shsgs. it precomputes c and stores in wshsgs quantities such as gaussian weights, c legendre polynomial coefficients, and fft trigonometric tables. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are compu c in radians in theta(1),...,theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid poi c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c wshsgs an array which must be initialized by subroutine shsgsi. c once initialized, wshsgs can be used repeatedly by shsgs c as long as nlat and nlon remain unchanged. wshsgs must c not be altered between calls of shsgs. c c lshsgs the dimension of the array wshsgs as it appears in the c program that calls shsgs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgs must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c work a real work space which need not be saved c c lwork the dimension of the array work as it appears in the c program that calls shsgsi. lwork must be at least c 4*nlat*(nlat+2)+2 in the routine calling shsgsi c c dwork a double precision work array that does not have to be saved. c c ldwork the length of dwork in the calling routine. ldwork must c be at least nlat*(nlat+4) c c output parameter c c wshsgs an array which must be initialized before calling shsgs or c once initialized, wshsgs can be used repeatedly by shsgs or c as long as nlat and nlon remain unchanged. wshsgs must not c altered between calls of shsgs. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lshsgs c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c = 5 failure in gaqd to compute gaussian points c (due to failure in eigenvalue routine) c c subroutine shsgs(nlat,nlon,mode,nt,g,idg,jdg,a,b,mdab,ndab, 1 wshsgs,lshsgs,work,lwork,ierror) dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1), 1 wshsgs(lshsgs),work(lwork) c check input parameters ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return ierror = 3 if (mode.lt.0 .or.mode.gt.2) return ierror = 4 if (nt.lt.1) return c set limit on m subscript l = min0((nlon+2)/2,nlat) c set gaussian point nearest equator pointer late = (nlat+mod(nlat,2))/2 c set number of grid points for analysis/synthesis lat = nlat if (mode.ne.0) lat = late ierror = 5 if (idg.lt.lat) return ierror = 6 if (jdg.lt.nlon) return ierror = 7 if(mdab .lt. l) return ierror = 8 if(ndab .lt. nlat) return l1 = l l2 = late ierror = 9 c check permanent work space length lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshsgs.lt.lp) return c check temporary work space length ierror = 10 if (mode.eq.0 .and. lwork.lt.nlat*nlon*(nt+1)) return if (mode.ne.0 .and. lwork.lt.l2*nlon*(nt+1)) return ierror = 0 c starting address for fft values and legendre polys in wshsgs ifft = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+1 ipmn = ifft+nlon+15 c set pointer for internal storage of g iw = lat*nlon*nt+1 call shsgs1(nlat,nlon,l,lat,mode,g,idg,jdg,nt,a,b,mdab,ndab, 1 wshsgs(ifft),wshsgs(ipmn),late,work,work(iw)) return end subroutine shsgs1(nlat,nlon,l,lat,mode,gs,idg,jdg,nt,a,b,mdab, 1 ndab,wfft,pmn,late,g,work) dimension gs(idg,jdg,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wfft(1),pmn(late,1),g(lat,nlon,nt),work(1) c reconstruct fourier coefficients in g on gaussian grid c using coefficients in a,b c initialize to zero do 100 k=1,nt do 100 j=1,nlon do 100 i=1,lat g(i,j,k) = 0.0 100 continue lm1 = l if (nlon .eq. l+l-2) lm1 = l-1 if (mode.eq.0) then c set first column in g m = 0 mml1 = m*(2*nlat-m-1)/2 do 101 k=1,nt c n even do 102 np1=1,nlat,2 mn = mml1+np1 do 102 i=1,late g(i,1,k) = g(i,1,k)+a(1,np1,k)*pmn(i,mn) 102 continue c n odd nl2 = nlat/2 do 103 np1=2,nlat,2 mn = mml1+np1 do 103 i=1,nl2 is = nlat-i+1 g(is,1,k) = g(is,1,k)+a(1,np1,k)*pmn(i,mn) 103 continue 101 continue c restore m=0 coefficients from odd/even do 112 k=1,nt do 112 i=1,nl2 is = nlat-i+1 t1 = g(i,1,k) t3 = g(is,1,k) g(i,1,k) = t1+t3 g(is,1,k) = t1-t3 112 continue c sweep interior columns of g do 104 mp1=2,lm1 m = mp1-1 mml1 = m*(2*nlat-m-1)/2 mp2 = m+2 do 105 k=1,nt c for n-m even store (g(i,p,k)+g(nlat-i+1,p,k))/2 in g(i,p,k) p=2*m,2*m+1 c for i=1,...,late do 106 np1=mp1,nlat,2 mn = mml1+np1 do 107 i=1,late g(i,2*m,k) = g(i,2*m,k)+a(mp1,np1,k)*pmn(i,mn) g(i,2*m+1,k) = g(i,2*m+1,k)+b(mp1,np1,k)*pmn(i,mn) 107 continue 106 continue c for n-m odd store g(i,p,k)-g(nlat-i+1,p,k) in g(nlat-i+1,p,k) c for i=1,...,nlat/2 (p=2*m,p=2*m+1) do 108 np1=mp2,nlat,2 mn = mml1+np1 do 109 i=1,nl2 is = nlat-i+1 g(is,2*m,k) = g(is,2*m,k)+a(mp1,np1,k)*pmn(i,mn) g(is,2*m+1,k) = g(is,2*m+1,k)+b(mp1,np1,k)*pmn(i,mn) 109 continue 108 continue c now set fourier coefficients using even-odd reduction above do 110 i=1,nl2 is = nlat-i+1 t1 = g(i,2*m,k) t2 = g(i,2*m+1,k) t3 = g(is,2*m,k) t4 = g(is,2*m+1,k) g(i,2*m,k) = t1+t3 g(i,2*m+1,k) = t2+t4 g(is,2*m,k) = t1-t3 g(is,2*m+1,k) = t2-t4 110 continue 105 continue 104 continue c set last column (using a only) if necessary if (nlon.eq. l+l-2) then m = l-1 mml1 = m*(2*nlat-m-1)/2 do 111 k=1,nt c n-m even do 131 np1=l,nlat,2 mn = mml1+np1 do 131 i=1,late g(i,nlon,k) = g(i,nlon,k)+2.0*a(l,np1,k)*pmn(i,mn) 131 continue lp1 = l+1 c n-m odd do 132 np1=lp1,nlat,2 mn = mml1+np1 do 132 i=1,nl2 is = nlat-i+1 g(is,nlon,k) = g(is,nlon,k)+2.0*a(l,np1,k)*pmn(i,mn) 132 continue do 133 i=1,nl2 is = nlat-i+1 t1 = g(i,nlon,k) t3 = g(is,nlon,k) g(i,nlon,k)= t1+t3 g(is,nlon,k)= t1-t3 133 continue 111 continue end if else c half sphere (mode.ne.0) c set first column in g m = 0 mml1 = m*(2*nlat-m-1)/2 meo = 1 if (mode.eq.1) meo = 2 ms = m+meo do 113 k=1,nt do 113 np1=ms,nlat,2 mn = mml1+np1 do 113 i=1,late g(i,1,k) = g(i,1,k)+a(1,np1,k)*pmn(i,mn) 113 continue c sweep interior columns of g do 114 mp1=2,lm1 m = mp1-1 mml1 = m*(2*nlat-m-1)/2 ms = m+meo do 115 k=1,nt do 115 np1=ms,nlat,2 mn = mml1+np1 do 115 i=1,late g(i,2*m,k) = g(i,2*m,k)+a(mp1,np1,k)*pmn(i,mn) g(i,2*m+1,k) = g(i,2*m+1,k)+b(mp1,np1,k)*pmn(i,mn) 115 continue 114 continue if (nlon.eq.l+l-2) then c set last column m = l-1 mml1 = m*(2*nlat-m-1)/2 ns = l if (mode.eq.1) ns = l+1 do 116 k=1,nt do 116 np1=ns,nlat,2 mn = mml1+np1 do 116 i=1,late g(i,nlon,k) = g(i,nlon,k)+2.0*a(l,np1,k)*pmn(i,mn) 116 continue end if end if c do inverse fourier transform do 120 k=1,nt call hrfftb(lat,nlon,g(1,1,k),lat,wfft,work) 120 continue c scale output in gs do 122 k=1,nt do 122 j=1,nlon do 122 i=1,lat gs(i,j,k) = 0.5*g(i,j,k) 122 continue return end subroutine shsgsi(nlat,nlon,wshsgs,lshsgs,work,lwork,dwork,ldwork, + ierror) c c this subroutine must be called before calling shags or shsgs with c fixed nlat,nlon. it precomputes the gaussian weights, points c and all necessary legendre polys and stores them in wshsgs. c these quantities must be preserved when calling shsgs c repeatedly with fixed nlat,nlon. c dimension wshsgs(lshsgs),work(lwork) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+1)/2 l1 = l l2 = late c check permanent work space length ierror = 3 lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshsgs.lt.lp) return ierror = 4 c check temporary work space if (lwork.lt.4*nlat*(nlat+2)+2) return ierror = 5 if (ldwork .lt. nlat*(nlat+4)) return ierror = 0 c set preliminary quantites needed to compute and store legendre polys ldw = nlat*(nlat+4) call shsgsp(nlat,nlon,wshsgs,lshsgs,dwork,ldwork,ierror) if (ierror.ne.0) return c set legendre poly pointer in wshsgs ipmnf = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+nlon+16 call shsgss1(nlat,l,late,wshsgs,work,wshsgs(ipmnf)) return end subroutine shsgsp(nlat,nlon,wshsgs,lshsgs,dwork,ldwork,ierror) dimension wshsgs(lshsgs) double precision dwork(ldwork) ierror = 1 if (nlat.lt.3) return ierror = 2 if (nlon.lt.4) return c set triangular truncation limit for spherical harmonic basis l = min0((nlon+2)/2,nlat) c set equator or nearest point (if excluded) pointer late = (nlat+mod(nlat,2))/2 l1 = l l2 = late ierror = 3 c check permanent work space length if (lshsgs .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 4 c if (lwork.lt.4*nlat*(nlat+2)+2) return if (ldwork .lt. nlat*(nlat+4)) return ierror = 0 c set pointers i1 = 1 i2 = i1+nlat i3 = i2+nlat*late i4 = i3+nlat*late i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1) i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1) i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1) c set indices in temp work for double precision gaussian wts and pts idth = 1 c idwts = idth+2*nlat c iw = idwts+2*nlat idwts = idth+nlat iw = idwts+nlat call shsgsp1(nlat,nlon,l,late,wshsgs(i1),wshsgs(i2),wshsgs(i3), 1wshsgs(i4),wshsgs(i5),wshsgs(i6),wshsgs(i7),dwork(idth), 2dwork(idwts),dwork(iw),ierror) if (ierror.ne.0) ierror = 6 return end subroutine shsgsp1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel, + wfft,dtheta,dwts,work,ier) dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1), 1 cbel(1),wfft(1),dtheta(nlat),dwts(nlat) double precision pb,dtheta,dwts,work(*) indx(m,n) = (n-1)*(n-2)/2+m-1 imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1 call hrffti(nlon,wfft) c c compute double precision gaussian points and weights c lw = nlat*(nlat+2) call gaqd(nlat,dtheta,dwts,work,lw,ier) if (ier.ne.0) return c store gaussian weights single precision to save computation c in inner loops in analysis do 100 i=1,nlat wts(i) = dwts(i) 100 continue c initialize p0n,p1n using double precision dnlfk,dnlft do 101 np1=1,nlat do 101 i=1,late p0n(np1,i) = 0.0 p1n(np1,i) = 0.0 101 continue c compute m=n=0 legendre polynomials for all theta(i) np1 = 1 n = 0 m = 0 call dnlfk(m,n,work) do 103 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(1,i) = pb 103 continue c compute p0n,p1n for all theta(i) when n.gt.0 do 104 np1=2,nlat n = np1-1 m = 0 call dnlfk(m,n,work) do 105 i=1,late call dnlft(m,n,dtheta(i),work,pb) p0n(np1,i) = pb 105 continue c compute m=1 legendre polynomials for all n and theta(i) m = 1 call dnlfk(m,n,work) do 106 i=1,late call dnlft(m,n,dtheta(i),work,pb) p1n(np1,i) = pb 106 continue 104 continue c c compute and store swarztrauber recursion coefficients c for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel do 107 n=2,nlat mlim = min0(n,l) do 107 m=2,mlim imn = indx(m,n) if (n.ge.l) imn = imndx(m,n) abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/ 1 float(((2*n-3)*(m+n-1)*(m+n)))) cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/ 1 float(((n+m-1)*(n+m)))) 107 continue return end subroutine shsgss1(nlat,l,late,w,pmn,pmnf) dimension w(1),pmn(nlat,late,3),pmnf(late,1) c compute and store legendre polys for i=1,...,late,m=0,...,l-1 c and n=m,...,l-1 do i=1,nlat do j=1,late do k=1,3 pmn(i,j,k) = 0.0 end do end do end do do 100 mp1=1,l m = mp1-1 mml1 = m*(2*nlat-m-1)/2 c compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2 mode = 0 call legin(mode,l,nlat,m,w,pmn,km) c store above in pmnf do 101 np1=mp1,nlat mn = mml1+np1 do 102 i=1,late pmnf(i,mn) = pmn(np1,i,km) 102 continue 101 continue 100 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c c ... file slapec.f c c this file includes documentation and code for c subroutine slapec i c c ... files which must be loaded with slapec.f c c sphcom.f, hrfft.f, shaec.f, shsec.f c c c c subroutine slapec(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, c + wshsec,lshsec,work,lwork,ierror) c c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shaec for a scalar field sf, subroutine slapec computes c the laplacian of sf in the scalar array slap. slap(i,j) is the c laplacian of sf at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. i.e. c c slap(i,j) = c c 2 2 c [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint c c c where sint = sin(theta(i)). the scalar laplacian in slap has the c same symmetry or absence of symmetry about the equator as the scalar c field sf. the input parameters isym,nt,mdab,ndab must have the c same values used by shaec to compute a and b for sf. the associated c legendre functions are recomputed rather than stored as they are c in subroutine slapes. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c isym this parameter should have the same value input to subroutine c shaec to compute the coefficients a and b for the scalar field c sf. isym is set as follows: c c = 0 no symmetries exist in sf about the equator. scalar c synthesis is used to compute slap on the entire sphere. c i.e., in the array slap(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 sf and slap are antisymmetric about the equator. the c synthesis used to compute slap is performed on the c northern hemisphere only. if nlat is odd, slap(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, slap(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c = 2 sf and slap are symmetric about the equator. the c synthesis used to compute slap is performed on the c northern hemisphere only. if nlat is odd, slap(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, slap(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt the number of analyses. in the program that calls slapec c the arrays slap,a, and b can be three dimensional in which c case multiple synthesis will be performed. the third index c is the synthesis index which assumes the values k=1,...,nt. c for a single analysis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 c or that all the arrays are two dimensional. c c ids the first dimension of the array slap as it appears in the c program that calls slapec. if isym = 0 then ids must be at c least nlat. if isym > 0 and nlat is even then ids must be c at least nlat/2. if isym > 0 and nlat is odd then ids must c be at least (nlat+1)/2. c c jds the second dimension of the array slap as it appears in the c program that calls slapec. jds must be at least nlon. c c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field sf as computed by subroutine shaec. c *** a,b must be computed by shaec prior to calling slapec. c c c mdab the first dimension of the arrays a and b as it appears c in the program that calls slapec. mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls slapec. ndbc must be at least c least nlat. c c mdab,ndab should have the same values input to shaec to c compute the coefficients a and b. c c c wshsec an array which must be initialized by subroutine shseci c before calling slapec. once initialized, wshsec c can be used repeatedly by slapec as long as nlat and nlon c remain unchanged. wshsec must not be altered between calls c of slapec. c c lshsec the dimension of the array wshsec as it appears in the c program that calls slapec. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsec must be greater than or equal to c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls slapec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 let c c lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1. c c if isym > 0 let c c lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1) c c c then lwork must be greater than or equal to lwkmin (see ierror=10) c c ************************************************************** c c output parameters c c c slap a two or three dimensional arrays (see input parameter nt) that c contain the scalar laplacian of the scalar field sf. slap(i,j) c is the scalar laplacian at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of ids c c = 6 error in the specification of jds c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lshsec c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for slapec c c ********************************************************************** c c subroutine slapec(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, + wshsec,lshsec,work,lwork,ierror) dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wshsec(lshsec),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ids.lt.nlat) .or. 1 (isym.gt.0 .and. ids.lt.imid)) return ierror = 6 if(jds .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c set and verify saved work space length c c l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 lwmin = 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 if(lshsec .lt. lwmin) return ierror = 10 c c set and verify unsaved work space length c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon mn = mmax*nlat*nt c lwmin = nln+ls*nlon+2*mn+nlat c if (lwork .lt. lwmin) return l2 = (nlat+1)/2 l1 = min0(nlat,nlon/2+1) if (isym .eq. 0) then lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn ifn = ib+mn iwk = ifn+nlat lwk = lwork-2*mn-nlat call slapec1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, +work(ia),work(ib),mmax,work(ifn),wshsec,lshsec,work(iwk),lwk, +ierror) return end subroutine slapec1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, + alap,blap,mmax,fnn,wshsec,lshsec,wk,lwk,ierror) dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension alap(mmax,nlat,nt),blap(mmax,nlat,nt),fnn(nlat) dimension wshsec(lshsec),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = fn*(fn+1.) 1 continue c c compute scalar laplacian coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax alap(m,n,k) = 0.0 blap(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat alap(1,n,k) = -fnn(n)*a(1,n,k) blap(1,n,k) = -fnn(n)*b(1,n,k) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat alap(m,n,k) = -fnn(n)*a(m,n,k) blap(m,n,k) = -fnn(n)*b(m,n,k) 7 continue 6 continue 2 continue c c synthesize alap,blap into slap c call shsec(nlat,nlon,isym,nt,slap,ids,jds,alap,blap, + mmax,nlat,wshsec,lshsec,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c c ... file slapes.f c c this file includes documentation and code for c subroutine slapes i c c ... files which must be loaded with slapec.f c c sphcom.f, hrfft.f, shaes.f, shses.f c c c c subroutine slapes(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, c + wshses,lshses,work,lwork,ierror) c c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shaes for a scalar field sf, subroutine slapes computes c the laplacian of sf in the scalar array slap. slap(i,j) is the c laplacian of sf at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. i.e. c c slap(i,j) = c c 2 2 c [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint c c c where sint = sin(theta(i)). the scalar laplacian in slap has the c same symmetry or absence of symmetry about the equator as the scalar c field sf. the input parameters isym,nt,mdab,ndab must have the c same values used by shaes to compute a and b for sf. the associated c legendre functions are stored rather than recomputed as they are c in subroutine slapec. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c isym this parameter should have the same value input to subroutine c shaes to compute the coefficients a and b for the scalar field c sf. isym is set as follows: c c = 0 no symmetries exist in sf about the equator. scalar c synthesis is used to compute slap on the entire sphere. c i.e., in the array slap(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 sf and slap are antisymmetric about the equator. the c synthesis used to compute slap is performed on the c northern hemisphere only. if nlat is odd, slap(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, slap(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c = 2 sf and slap are symmetric about the equator. the c synthesis used to compute slap is performed on the c northern hemisphere only. if nlat is odd, slap(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, slap(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt the number of analyses. in the program that calls slapes c the arrays slap,a, and b can be three dimensional in which c case multiple synthesis will be performed. the third index c is the synthesis index which assumes the values k=1,...,nt. c for a single analysis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 c or that all the arrays are two dimensional. c c ids the first dimension of the array slap as it appears in the c program that calls slapes. if isym = 0 then ids must be at c least nlat. if isym > 0 and nlat is even then ids must be c at least nlat/2. if isym > 0 and nlat is odd then ids must c be at least (nlat+1)/2. c c jds the second dimension of the array slap as it appears in the c program that calls slapes. jds must be at least nlon. c c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field sf as computed by subroutine shaes. c *** a,b must be computed by shaes prior to calling slapes. c c c mdab the first dimension of the arrays a and b as it appears c in the program that calls slapes. mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls slapes. ndbc must be at least c least nlat. c c mdab,ndab should have the same values input to shaes to c compute the coefficients a and b. c c c wshses an array which must be initialized by subroutine shsesi c before calling slapes. once initialized, wshses c can be used repeatedly by slapes as long as nlat and nlon c remain unchanged. wshses must not be altered between calls c of slapes. c c lshses the dimension of the array wshses as it appears in the c program that calls slapes. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshses must be greater than or equal to c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15. c c c work a work array that does not have to be saved. c c c lwork the dimension of the array work as it appears in the c program that calls slapes. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym is zero then lwork must be at least c c (nt+1)*nlat*nlon + nlat*(2*nt*l1+1) c c if isym is nonzero lwork must be at least c c (nt+1)*l2*nlon + nlat*(2*nt*l1+1) c c ************************************************************** c c output parameters c c c slap a two or three dimensional arrays (see input parameter nt) that c contain the scalar laplacian of the scalar field sf. slap(i,j) c is the scalar laplacian at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c for i=1,...,nlat and j=1,...,nlon. c c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of ids c c = 6 error in the specification of jds c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lshses c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for slapes c c ********************************************************************** c subroutine slapes(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, + wshses,lshses,work,lwork,ierror) dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wshses(lshses),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ids.lt.nlat) .or. 1 (isym.gt.0 .and. ids.lt.imid)) return ierror = 6 if(jds .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshses .lt. lpimn+nlon+15) return ierror = 10 c c set and verify unsaved work space length c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon mn = mmax*nlat*nt c lwkmin = nln+ls*nlon+2*mn+nlat c if (lwork .lt. lwkmin) return l2 = (nlat+1)/2 l1 = min0(nlat,nlon/2+1) if (isym.eq.0) then lwkmin = (nt+1)*nlat*nlon + nlat*(2*nt*l1+1) else lwkmin = (nt+1)*l2*nlon + nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn ifn = ib+mn iwk = ifn+nlat lwk = lwork-2*mn-nlat call slapes1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, +work(ia),work(ib),mmax,work(ifn),wshses,lshses,work(iwk),lwk, +ierror) return end subroutine slapes1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, + alap,blap,mmax,fnn,wsave,lsave,wk,lwk,ierror) dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension alap(mmax,nlat,nt),blap(mmax,nlat,nt),fnn(nlat) dimension wsave(lsave),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = fn*(fn+1.) 1 continue c c compute scalar laplacian coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax alap(m,n,k) = 0.0 blap(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat alap(1,n,k) = -fnn(n)*a(1,n,k) blap(1,n,k) = -fnn(n)*b(1,n,k) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat alap(m,n,k) = -fnn(n)*a(m,n,k) blap(m,n,k) = -fnn(n)*b(m,n,k) 7 continue 6 continue 2 continue c c synthesize alap,blap into slap c call shses(nlat,nlon,isym,nt,slap,ids,jds,alap,blap, + mmax,nlat,wsave,lsave,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c c ... file slapgc.f c c this file includes documentation and code for c subroutine slapgc i c c ... files which must be loaded with slapec.f c c sphcom.f, hrfft.f, shagc.f, shsgc.f c c c c subroutine slapgc(nlat,nlon,isym,nt,slap,ids,jds,a,b, c +mdab,ndab,wshsgc,lshsgc,work,lwork,ierror) c c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shagc for a scalar field sf, subroutine slapgc computes c the laplacian of sf in the scalar array slap. slap(i,j) is the c laplacian of sf at the gaussian colatitude theta(i) (see nlat as c an input parameter) and east longitude lambda(j) = (j-1)*2*pi/nlon c on the sphere. i.e. c c slap(i,j) = c c 2 2 c [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint c c c where sint = sin(theta(i)). the scalar laplacian in slap has the c same symmetry or absence of symmetry about the equator as the scalar c field sf. the input parameters isym,nt,mdab,ndab must have the c same values used by shagc to compute a and b for sf. the associated c legendre functions are stored rather than recomputed as they are c in subroutine slapgc. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c isym this parameter should have the same value input to subroutine c shagc to compute the coefficients a and b for the scalar field c sf. isym is set as follows: c c = 0 no symmetries exist in sf about the equator. scalar c synthesis is used to compute slap on the entire sphere. c i.e., in the array slap(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 sf and slap are antisymmetric about the equator. the c synthesis used to compute slap is performed on the c northern hemisphere only. if nlat is odd, slap(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, slap(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c = 2 sf and slap are symmetric about the equator. the c synthesis used to compute slap is performed on the c northern hemisphere only. if nlat is odd, slap(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, slap(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt the number of analyses. in the program that calls slapgc c the arrays slap,a, and b can be three dimensional in which c case multiple synthesis will be performed. the third index c is the synthesis index which assumes the values k=1,...,nt. c for a single analysis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 c or that all the arrays are two dimensional. c c ids the first dimension of the array slap as it appears in the c program that calls slapgc. if isym = 0 then ids must be at c least nlat. if isym > 0 and nlat is even then ids must be c at least nlat/2. if isym > 0 and nlat is odd then ids must c be at least (nlat+1)/2. c c jds the second dimension of the array slap as it appears in the c program that calls slapgc. jds must be at least nlon. c c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field sf as computed by subroutine shagc. c *** a,b must be computed by shagc prior to calling slapgc. c c c mdab the first dimension of the arrays a and b as it appears c in the program that calls slapgc. mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls slapgc. ndbc must be at least c least nlat. c c mdab,ndab should have the same values input to shagc to c compute the coefficients a and b. c c c wshsgc an array which must be initialized by subroutine shsgci. c once initialized, wshsgc c can be used repeatedly by slapgc as long as nlat and nlon c remain unchanged. wshsgc must not be altered between calls c of slapgc. c c lshsgc the dimension of the array wshsgc as it appears in the c program that calls slapgc. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls slapgc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym = 0 let c c lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1. c c if isym > 0 let c c lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1) c c c then lwork must be greater than or equal to lwkmin (see ierror=10) c c ************************************************************** c c output parameters c c c slap a two or three dimensional arrays (see input parameter nt) that c contain the scalar laplacian of the scalar field sf. slap(i,j) c is the scalar laplacian at the gaussian colatitude theta(i) c and longitude lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat c and j=1,...,nlon. c c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of ids c c = 6 error in the specification of jds c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lshsgc c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for slapgc c c ********************************************************************** c c subroutine slapgc(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, + wshsgc,lshsgc,work,lwork,ierror) dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wshsgc(lshsgc),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ids.lt.nlat) .or. 1 (isym.gt.0 .and. ids.lt.imid)) return ierror = 6 if(jds .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c set and verify saved work space length c c l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return ierror = 10 c c set and verify unsaved work space length c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon mn = mmax*nlat*nt c lwmin = nln+ls*nlon+2*mn+nlat c if (lwork .lt. lwmin) return l2 = (nlat+1)/2 l1 = min0(nlat,nlon/2+1) if (isym .eq. 0) then lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn ifn = ib+mn iwk = ifn+nlat lwk = lwork-2*mn-nlat call slapgc1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, +work(ia),work(ib),mmax,work(ifn),wshsgc,lshsgc,work(iwk),lwk, +ierror) return end subroutine slapgc1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, + alap,blap,mmax,fnn,wsave,lsave,wk,lwk,ierror) dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension alap(mmax,nlat,nt),blap(mmax,nlat,nt),fnn(nlat) dimension wsave(lsave),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = fn*(fn+1.) 1 continue c c compute scalar laplacian coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax alap(m,n,k) = 0.0 blap(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat alap(1,n,k) = -fnn(n)*a(1,n,k) blap(1,n,k) = -fnn(n)*b(1,n,k) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat alap(m,n,k) = -fnn(n)*a(m,n,k) blap(m,n,k) = -fnn(n)*b(m,n,k) 7 continue 6 continue 2 continue c c synthesize alap,blap into slap c call shsgc(nlat,nlon,isym,nt,slap,ids,jds,alap,blap, + mmax,nlat,wsave,lsave,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c c ... file slapgs.f c c this file includes documentation and code for c subroutine slapgs i c c ... files which must be loaded with slapgs.f c c sphcom.f, hrfft.f, shags.f, shsgs.f c c c c subroutine slapgs(nlat,nlon,isym,nt,slap,ids,jds,a,b, c +mdab,ndab,wshsgs,lshsgs,work,lwork,ierror) c c c given the scalar spherical harmonic coefficients a and b, precomputed c by subroutine shags for a scalar field sf, subroutine slapgs computes c the laplacian of sf in the scalar array slap. slap(i,j) is the c laplacian of sf at the gaussian colatitude theta(i) (see nlat as c an input parameter) and east longitude lambda(j) = (j-1)*2*pi/nlon c on the sphere. i.e. c c slap(i,j) = c c 2 2 c [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint c c c where sint = sin(theta(i)). the scalar laplacian in slap has the c same symmetry or absence of symmetry about the equator as the scalar c field sf. the input parameters isym,nt,mdab,ndab must have the c same values used by shags to compute a and b for sf. the associated c legendre functions are stored rather than recomputed as they are c in subroutine slapgc. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c isym this parameter should have the same value input to subroutine c shags to compute the coefficients a and b for the scalar field c sf. isym is set as follows: c c = 0 no symmetries exist in sf about the equator. scalar c synthesis is used to compute slap on the entire sphere. c i.e., in the array slap(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 sf and slap are antisymmetric about the equator. the c synthesis used to compute slap is performed on the c northern hemisphere only. if nlat is odd, slap(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, slap(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c = 2 sf and slap are symmetric about the equator. the c synthesis used to compute slap is performed on the c northern hemisphere only. if nlat is odd, slap(i,j) is c computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. if c nlat is even, slap(i,j) is computed for i=1,...,nlat/2 c and j=1,...,nlon. c c c nt the number of analyses. in the program that calls slapgs c the arrays slap,a, and b can be three dimensional in which c case multiple synthesis will be performed. the third index c is the synthesis index which assumes the values k=1,...,nt. c for a single analysis set nt=1. the description of the c remaining parameters is simplified by assuming that nt=1 c or that all the arrays are two dimensional. c c ids the first dimension of the array slap as it appears in the c program that calls slapgs. if isym = 0 then ids must be at c least nlat. if isym > 0 and nlat is even then ids must be c at least nlat/2. if isym > 0 and nlat is odd then ids must c be at least (nlat+1)/2. c c jds the second dimension of the array slap as it appears in the c program that calls slapgs. jds must be at least nlon. c c c a,b two or three dimensional arrays (see input parameter nt) c that contain scalar spherical harmonic coefficients c of the scalar field sf as computed by subroutine shags. c *** a,b must be computed by shags prior to calling slapgs. c c c mdab the first dimension of the arrays a and b as it appears c in the program that calls slapgs. mdab must be at c least min0(nlat,(nlon+2)/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays a and b as it appears c in the program that calls slapgs. ndbc must be at least c least nlat. c c mdab,ndab should have the same values input to shags to c compute the coefficients a and b. c c c wshsgs an array which must be initialized by subroutine slapgsi c (or equivalently by shsgsi). once initialized, wshsgs c can be used repeatedly by slapgs as long as nlat and nlon c remain unchanged. wshsgs must not be altered between calls c of slapgs. c c lshsgs the dimension of the array wshsgs as it appears in the c program that calls slapgs. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgs must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls slapgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if isym is zero then lwork must be at least c c (nt+1)*nlat*nlon + nlat*(2*nt*l1+1) c c if isym is nonzero lwork must be at least c c (nt+1)*l2*nlon + nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c slap a two or three dimensional arrays (see input parameter nt) that c contain the scalar laplacian of the scalar field sf. slap(i,j) c is the scalar laplacian at the gaussian colatitude theta(i) c and longitude lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat c and j=1,...,nlon. c c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of ids c c = 6 error in the specification of jds c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lshsgs c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for slapgs c c ********************************************************************** c c subroutine slapgs(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, + wshsgs,lshsgs,work,lwork,ierror) dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension wshsgs(lshsgs),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ids.lt.nlat) .or. 1 (isym.gt.0 .and. ids.lt.imid)) return ierror = 6 if(jds .lt. nlon) return ierror = 7 mmax = min0(nlat,nlon/2+1) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 c c set and verify saved work space length c imid = (nlat+1)/2 l2 = (nlat+mod(nlat,2))/2 l1 = min0((nlon+2)/2,nlat) lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshsgs.lt.lp) return ierror = 10 c c set and verify unsaved work space length c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon mn = mmax*nlat*nt c lwkmin = nln+ls*nlon+2*mn+nlat c if (lwork .lt. lwkmin) return l2 = (nlat+1)/2 l1 = min0(nlat,nlon/2+1) if (isym.eq.0) then lwkmin = (nt+1)*nlat*nlon + nlat*(2*nt*l1+1) else lwkmin = (nt+1)*l2*nlon + nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn ifn = ib+mn iwk = ifn+nlat lwk = lwork-2*mn-nlat call slapgs1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, +work(ia),work(ib),mmax,work(ifn),wshsgs,lshsgs,work(iwk),lwk, +ierror) return end subroutine slapgs1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab, + alap,blap,mmax,fnn,wsave,lsave,wk,lwk,ierror) dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt) dimension alap(mmax,nlat,nt),blap(mmax,nlat,nt),fnn(nlat) dimension wsave(lsave),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = fn*(fn+1.) 1 continue c c compute scalar laplacian coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax alap(m,n,k) = 0.0 blap(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat alap(1,n,k) = -fnn(n)*a(1,n,k) blap(1,n,k) = -fnn(n)*b(1,n,k) 5 continue c c compute m>0 coefficients c do 6 m=2,mmax do 7 n=m,nlat alap(m,n,k) = -fnn(n)*a(m,n,k) blap(m,n,k) = -fnn(n)*b(m,n,k) 7 continue 6 continue 2 continue c c synthesize alap,blap into slap c call shsgs(nlat,nlon,isym,nt,slap,ids,jds,alap,blap, + mmax,nlat,wsave,lsave,wk,lwk,ierror) return end subroutine smxm(lr,lc,ld,a,mc,md,b,nd,c) dimension a(ld,*),b(md,*),c(nd,*) do i=1,lr do j=1,mc c(i,j) = 0. do k=1,lc c(i,j) = c(i,j)+a(i,k)*b(k,j) end do end do end do return end subroutine sptc(r,len,m,n,clat,slat,x,y,z) c **** transforms from spherical to cartesian coordinates dimension r(len,1),clat(n),slat(n),x(n,m),y(n,m),z(n,m) pi = 4.*atan(1.) dt = pi/(n-1) dp = (pi+pi)/(m-1) do 10 j=1,n clat(j) = cos((j-1)*dt) slat(j) = sin((j-1)*dt) 10 continue do 20 i=1,m-1 clon = cos((i-1)*dp) slon = sin((i-1)*dp) do 20 j=1,n x(j,i)=r(j,i)*slat(j) y(j,i)=x(j,i)*slon x(j,i)=x(j,i)*clon z(j,i)=r(j,i)*clat(j) 20 continue do 30 j=1,n x(j,m)=x(j,1) y(j,m)=y(j,1) z(j,m)=z(j,1) 30 continue return end subroutine sptcg(r,m,n,theta,clat,slat,x,y,z) c **** transforms from spherical to cartesian coordinates dimension r(n,m),clat(n),slat(n),x(n,m),y(n,m),z(n,m) double precision theta(*) pi = 4.*atan(1.) dp = (pi+pi)/(m-1) clat(1) = 1. slat(1) = 0. do 10 j=2,n-1 thet = theta(j-1) clat(j) = cos(thet) slat(j) = sin(thet) 10 continue clat(n) = -1. slat(n) = 0. do 20 i=1,m-1 clon = cos((i-1)*dp) slon = sin((i-1)*dp) do 20 j=1,n x(j,i)=r(j,i)*slat(j) y(j,i)=x(j,i)*slon x(j,i)=x(j,i)*clon z(j,i)=r(j,i)*clat(j) 20 continue do 30 j=1,n x(j,m)=x(j,1) y(j,m)=y(j,1) z(j,m)=z(j,1) 30 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file sshifte.f contains code and documentation for subroutine sshifte c and its' initialization subroutine sshifti c c ... required files off spherepack3.0 c c hrfft.f c c subroutine sshifte(ioff,nlon,nlat,goff,greg,wsav,lsav,work,lwork,ier) c c *** purpose c c subroutine sshifte does a highly accurate 1/2 grid increment shift c in both longitude and latitude of equally spaced data on the sphere. c data is transferred between the nlon by nlat "offset grid" in goff c (which excludes poles) and the nlon by nlat+1 "regular grid" in greg c (which includes poles). the transfer can go from goff to greg or from c greg to goff (see ioff). the grids which underly goff and greg are c described below. the north and south poles are at latitude 0.5*pi and c -0.5*pi radians respectively where pi = 4.*atan(1.). c c *** grid descriptions c c let dlon = (pi+pi)/nlon and dlat = pi/nlat be the uniform grid c increments in longitude and latitude c c offset grid c c the "1/2 increment offset" grid (long(j),lat(i)) on which goff(j,i) c is given (ioff=0) or generated (ioff=1) is c c long(j) =0.5*dlon + (j-1)*dlon (j=1,...,nlon) c c and c c lat(i) = -0.5*pi + 0.5*dlat + (i-1)*dlat (i=1,...,nlat) c c the data in goff is "shifted" one half a grid increment in longitude c and latitude and excludes the poles. each goff(j,1) is given at c latitude -0.5*pi+0.5*dlat and goff(j,nlat) is given at 0.5*pi-0.5*dlat c (1/2 a grid increment away from the poles). each goff(1,i),goff(nlon,i) c is given at longitude 0.5*dlon and 2.*pi-0.5*dlon. c c regular grid c c let dlat,dlon be as above. then the nlon by nlat+1 grid on which c greg(j,i) is generated (ioff=0) or given (ioff=1) is given by c c lone(j) = (j-1)*dlon (j=1,...,nlon) c c and c c late(i) = -0.5*pi + (i-1)*dlat (i=1,...,nlat+1) c c values in greg include the poles and start at zero degrees longitude. c c *** remark c c subroutine sshifte can be used in conjunction with subroutine trssph c when transferring data from an equally spaced "1/2 increment offset" c grid to a gaussian or equally spaced grid (which includes poles) of c any resolution. this problem (personal communication with dennis c shea) is encountered in geophysical modeling and data analysis. c c *** method c c fast fourier transform software from spherepack2 and trigonometric c identities are used to accurately "shift" periodic vectors half a c grid increment in latitude and longitude. latitudinal shifts are c accomplished by setting periodic 2*nlat vectors over the pole for each c longitude. when nlon is odd, this requires an additional longitude c shift. longitudinal shifts are then executed for each shifted latitude. c when necessary (ioff=0) poles are obtained by averaging the nlon c shifted polar values. c c *** required files from spherepack3.0 c c hrfft.f c c *** argument description c c ... ioff c c ioff = 0 if values on the offset grid in goff are given and values c on the regular grid in greg are to be generated. c c ioff = 1 if values on the regular grid in greg are given and values c on the offset grid in goff are to be generated. c c ... nlon c c the number of longitude points on both the "offset" and "regular" c uniform grid in longitude (see "grid description" above). nlon c is also the first dimension of array goff and greg. nlon determines c the grid increment in longitude as dlon = 2.*pi/nlon. for example, c nlon = 144 for a 2.5 degree grid. nlon can be even or odd and must c be greater than or equal to 4. the efficiency of the computation c is improved when nlon is a product of small primes. c c ... nlat c c the number of latitude points on the "offset" uniform grid. nlat+1 c is the number of latitude points on the "regular" uniform grid (see c "grid description" above). nlat is the second dimension of array goff. c nlat+1 must be the second dimension of the array greg in the program c calling sshifte. nlat determines the grid in latitude as pi/nlat. c for example, nlat = 36 for a five degree grid. nlat must be at least 3. c c ... goff c c a nlon by nlat array that contains data on the offset grid c described above. goff is a given input argument if ioff=0. c goff is a generated output argument if ioff=1. c c ... greg c c a nlon by nlat+1 array that contains data on the regular grid c described above. greg is a given input argument if ioff=1. c greg is a generated output argument if ioff=0. c c ... wsav c c a real saved work space array that must be initialized by calling c subroutine sshifti(ioff,nlon,nlat,wsav,ier) before calling sshifte. c wsav can then be used repeatedly by sshifte as long as ioff, nlon, c and nlat do not change. this bypasses redundant computations and c saves time. undetectable errors will result if sshifte is called c without initializing wsav whenever ioff, nlon, or nlat change. c c ... lsav c c the length of the saved work space wsav in the routine calling sshifte c and sshifti. lsave must be greater than or equal to 2*(2*nlat+nlon+16). c c ... work c c a real unsaved work space c c ... lwork c c the length of the unsaved work space in the routine calling sshifte c lwork must be greater than or equal to 2*nlon*(nlat+1) if nlon is even. c lwork must be greater than or equal to nlon*(5*nlat+1) if nlon is odd. c c ... ier c c indicates errors in input parameters c c = 0 if no errors are detected c c = 1 if ioff is not equal to 0 or 1 c c = 1 if nlon < 4 c c = 2 if nlat < 3 c c = 3 if lsave < 2*(nlon+2*nlat+16) c c = 4 if lwork < 2*nlon*(nlat+1) for nlon even or c lwork < nlon*(5*nlat+1) for nlon odd c c *** end of sshifte documentation c c subroutine sshifti(ioff,nlon,nlat,lsav,wsav,ier) c c subroutine sshifti initializes the saved work space wsav c for ioff and nlon and nlat (see documentation for sshifte). c sshifti must be called before sshifte whenever ioff or nlon c or nlat change. c c ... ier c c = 0 if no errors with input arguments c c = 1 if ioff is not 0 or 1 c c = 2 if nlon < 4 c c = 3 if nlat < 3 c c = 4 if lsav < 2*(2*nlat+nlon+16) c c *** end of sshifti documentation c subroutine sshifte(ioff,nlon,nlat,goff,greg,wsav,lsav, + wrk,lwrk,ier) implicit none integer ioff,nlon,nlat,n2,nr,nlat2,nlatp1,lsav,lwrk,i1,i2,ier real goff(nlon,nlat),greg(nlon,*),wsav(lsav),wrk(lwrk) c c check input parameters c ier = 1 if (ioff*(ioff-1).ne.0) return ier = 2 if (nlon.lt.4) return ier = 3 if (nlat .lt. 3) return ier = 4 if (lsav .lt. 2*(2*nlat+nlon+16)) return ier = 5 n2 = (nlon+1)/2 if (2*n2 .eq. nlon) then if (lwrk .lt. 2*nlon*(nlat+1)) return i1 = 1 nr = n2 else if (lwrk .lt. nlon*(5*nlat+1)) return i1 = 1+2*nlat*nlon nr = nlon end if ier = 0 nlat2 = nlat+nlat i2 = i1 + (nlat+1)*nlon if (ioff.eq.0) then call shftoff(nlon,nlat,goff,greg,wsav,nr,nlat2, + wrk,wrk(i1),wrk(i2)) else nlatp1 = nlat+1 call shftreg(nlon,nlat,goff,greg,wsav,nr,nlat2,nlatp1, + wrk,wrk(i1),wrk(i2)) end if end subroutine sshifti(ioff,nlon,nlat,lsav,wsav,ier) integer ioff,nlat,nlon,nlat2,isav,ier real wsav(lsav) real pi,dlat,dlon,dp ier = 1 if (ioff*(ioff-1).ne.0) return ier = 2 if (nlon .lt. 4) return ier = 3 if (nlat .lt. 3) return ier = 4 if (lsav .lt. 2*(2*nlat+nlon+16)) return ier = 0 pi = 4.0*atan(1.0) c c set lat,long increments c dlat = pi/nlat dlon = (pi+pi)/nlon c c initialize wsav for left or right latitude shifts c if (ioff.eq.0) then dp = -0.5*dlat else dp = 0.5*dlat end if nlat2 = nlat+nlat call shifthi(nlat2,dp,wsav) c c initialize wsav for left or right longitude shifts c if (ioff.eq.0) then dp = -0.5*dlon else dp = 0.5*dlon end if isav = 4*nlat + 17 call shifthi(nlon,dp,wsav(isav)) return end subroutine stoc(r,theta,phi,x,y,z) st = sin(theta) x = r*st*cos(phi) y = r*st*sin(phi) z = r*cos(theta) return end subroutine stride(m,n,mst,mfac) dimension mfac(*),mtryh(3),mst(n),icl(8) data mtryh(1),mtryh(2),mtryh(3)/2,3,5/ data icl(1),icl(2),icl(3),icl(4),icl(5),icl(6),icl(7),icl(8) 1 /0,1,2,12,3,13,23,123/ c c find prime factors of m-1 c ml = m-1 nf = 0 j = 0 101 j = j+1 if (j-3) 102,102,103 102 mtry = mtryh(j) go to 104 103 mtry = mtry+2 104 mq = ml/mtry mr = ml-mtry*mq if (mr) 101,105,101 105 nf = nf+1 mfac(nf) = mtry ml = mq if (ml .ne. 1) go to 104 if(mfac(nf) .gt. 2) go to 106 nf = nf-1 mfac(nf) = 4 106 tphi = .707/float(m-1) ns2 = n/2 mf1 = mfac(nf) mst(1) = (m-1)/mf1 pi = 4.*atan(1.) dt = pi/float(n-1) jf = nf-1 do 110 jdo=2,ns2 j = jdo theta = (j-1)*dt st = sin(theta) mf2 = mf1*mfac(jf) if(abs(st/mf1-tphi) .gt. abs(st/mf2-tphi)) go to 115 mst(j) = mst(j-1) go to 110 115 mst(j) = (m-1)/mf2 mf1 = mf2 jf = jf-1 if(jf .eq. 0) go to 120 110 continue 120 do 125 jdo=j,ns2 mst(jdo) = 1 125 continue do 130 jdo=1,ns2 mst(n-jdo) = mst(jdo) 130 continue c write (6,135) (mst(j),j=1,n) 135 format(' colatitude strides'/(15i5)) c return end subroutine stvpgs1(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci, +mdb,ndb,a,b,mab,fnn,wshsgs,lshsgs,wk,lwk,ierror) implicit none integer nlat,nlon,isym,nt,idv,jdv,mdb,ndb,mab,lshsgs,lwk,ierror real sf(idv,jdv,nt),vp(idv,jdv,nt) real br(mdb,ndb,nt),bi(mdb,ndb,nt),cr(mdb,ndb,nt),ci(mdb,ndb,nt) real a(mab,nlat,nt),b(mab,nlat,nt) real wshsgs(lshsgs),wk(lwk),fnn(nlat) integer n,m,mmax,k c c set coefficient multiplyers c do n=2,nlat fnn(n) = 1.0/sqrt(float(n*(n-1))) end do mmax = min0(nlat,(nlon+1)/2) c c compute st scalar coefficients from cr,ci c do k=1,nt do n=1,nlat do m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat a(1,n,k) =-fnn(n)*cr(1,n,k) b(1,n,k) =-fnn(n)*ci(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c do m=2,mmax do n=m,nlat a(m,n,k) =-fnn(n)*cr(m,n,k) b(m,n,k) =-fnn(n)*ci(m,n,k) end do end do end do c c synthesize a,b into st c call shsgs(nlat,nlon,isym,nt,sf,idv,jdv,a,b, + mab,nlat,wshsgs,lshsgs,wk,lwk,ierror) c c set coefficients for vp from br,bi c do k=1,nt do n=1,nlat do m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 end do end do c c compute m=0 coefficients c do n=2,nlat a(1,n,k) = fnn(n)*br(1,n,k) b(1,n,k) = fnn(n)*bi(1,n,k) end do c c compute m>0 coefficients using vector spherepack value for mmax c mmax = min0(nlat,(nlon+1)/2) do m=2,mmax do n=m,nlat a(m,n,k) = fnn(n)*br(m,n,k) b(m,n,k) = fnn(n)*bi(m,n,k) end do end do end do c c synthesize a,b into vp c call shsgs(nlat,nlon,isym,nt,vp,idv,jdv,a,b, + mab,nlat,wshsgs,lshsgs,wk,lwk,ierror) return end subroutine tmxmx(lag,lr,lc,ld,a,mc,md,b,x,y,is,js) dimension a(ld,*),b(md,*),x(ld,2),y(ld,2), 1 is(*),js(*) c kmx = min(lr+1,ld) if(lag.eq.1) then do k=1,kmx y(k,1) = 0. end do c if(lc.eq.0) then c do k=1,lr c y(k,1) = x(k,1) c end do c return c end if if(lc.le.0) return do i=1,lc sum1 = 0. do j=js(i),mc sum1 = sum1 + b(j,i)*x(j,1) end do do k=is(i),lr y(k,1) = y(k,1)+sum1*a(k,i) end do end do return end if do k=1,kmx y(k,1) = 0. y(k,2) = 0. end do if(lc.le.0) return c do i=1,lc sum1 = 0. sum2 = 0. do j=js(i),mc sum1 = sum1 + b(j,i)*x(j,1) sum2 = sum2 + b(j,i)*x(j,2) end do do k=is(i),lr y(k,1) = y(k,1)+sum1*a(k,i) y(k,2) = y(k,2)+sum2*a(k,i) end do end do return end subroutine tpdp (n,theta,cz,cp,dcp,pb,dpb) c c computes pn(theta) and its derivative dpb(theta) with c respect to theta c double precision cp(n/2+1),dcp(n/2+1),cz, 1 pb,dpb,fn,theta,cdt,sdt,cth,sth,chh c fn = n cdt = dcos(theta+theta) sdt = dsin(theta+theta) if(mod(n,2) .eq.0) then c c n even c kdo = n/2 pb = .5d0*cz dpb = 0.0d0 if(n .gt. 0) then cth = cdt sth = sdt do 170 k=1,kdo c pb = pb+cp(k)*cos(2*k*theta) pb = pb+cp(k)*cth c dpb = dpb-(k+k)*cp(k)*sin(2*k*theta) dpb = dpb-dcp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 170 continue end if else c c n odd c kdo = (n+1)/2 pb = 0.0d0 dpb = 0.0d0 cth = dcos(theta) sth = dsin(theta) do 190 k=1,kdo c pb = pb+cp(k)*cos((2*k-1)*theta) pb = pb+cp(k)*cth c dpb = dpb-(k+k-1)*cp(k)*sin((2*k-1)*theta) dpb = dpb-dcp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 190 continue end if return end subroutine tpdp1 (n,theta,cz,cp,dcp,pb,dpb) c c computes pn(theta) and its derivative dpb(theta) with c respect to theta c double precision cp(n/2+1),dcp(n/2+1),cz, 1 pb,dpb,fn,theta,cdt,sdt,cth,sth,chh c fn = n cdt = dcos(theta+theta) sdt = dsin(theta+theta) if(mod(n,2) .eq.0) then c c n even c kdo = n/2 pb = .5d0*cz dpb = 0.0d0 if(n .gt. 0) then cth = cdt sth = sdt do 170 k=1,kdo c pb = pb+cp(k)*cos(2*k*theta) pb = pb+cp(k)*cth c dpb = dpb-(k+k)*cp(k)*sin(2*k*theta) dpb = dpb-dcp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 170 continue end if else c c n odd c kdo = (n+1)/2 pb = 0.0d0 dpb = 0.0d0 cth = dcos(theta) sth = dsin(theta) do 190 k=1,kdo c pb = pb+cp(k)*cos((2*k-1)*theta) pb = pb+cp(k)*cth c dpb = dpb-(k+k-1)*cp(k)*sin((2*k-1)*theta) dpb = dpb-dcp(k)*sth chh = cdt*cth-sdt*sth sth = sdt*cth+cdt*sth cth = chh 190 continue end if return end subroutine trab(ma,na,aa,ba,mb,nb,ab,bb) implicit none integer ma,na,mb,nb,i,j,m,n real aa(ma,na),ba(ma,na),ab(mb,nb),bb(mb,nb) c c set coefficients for b grid from coefficients for a grid c m = min0(ma,mb) n = min0(na,nb) do j=1,n do i=1,m ab(i,j) = aa(i,j) bb(i,j) = ba(i,j) end do end do c c set coefs outside triangle to zero c do i=m+1,mb do j=1,nb ab(i,j) = 0.0 bb(i,j) = 0.0 end do end do do j=n+1,nb do i=1,mb ab(i,j) = 0.0 bb(i,j) = 0.0 end do end do return end subroutine triang(m,n,x,y,z,itri,x1,y1,z1,x2,y2,z2,x3,y3,z3, 1 ityp,iflag,mst) c **** performs triangulation dimension x(n,m),y(n,m),z(n,m),x1(1),y1(1),z1(1), 1x2(1),y2(1),z2(1),x3(1),y3(1),z3(1),ityp(1),iflag(n,m), 2mst(n),icl(8) data icl(1),icl(2),icl(3),icl(4),icl(5),icl(6),icl(7),icl(8) 1 /0,1,2,12,3,13,23,123/ itri = 0 n1=2 n2=n-2 do 100 j=n1,n2 do 100 i=1,m-1 if(iflag(j,i) .ge. 16) go to 50 if(mod(iflag(j,i),16) .lt. 8) go to 70 itri = itri+1 x1(itri) = x(j,i) y1(itri) = y(j,i) z1(itri) = z(j,i) x2(itri) = x(j+1,i) y2(itri) = y(j+1,i) z2(itri) = z(j+1,i) x3(itri) = x(j+1,i+1) y3(itri) = y(j+1,i+1) z3(itri) = z(j+1,i+1) ityph = 3 if(mod(i-1,mst(j)) .eq. 0) go to 60 if(mod(iflag(j,i-1),2) .eq. 0) go to 60 ityph = ityph-1 60 if(mod(iflag(j,i),2) .eq. 0) ityph = ityph+4 ityp(itri) = icl(ityph+1) 70 if(mod(iflag(j,i),2) .eq. 0) go to 100 itri = itri+1 x1(itri) = x(j,i) y1(itri) = y(j,i) z1(itri) = z(j,i) x2(itri) = x(j+1,i+1) y2(itri) = y(j+1,i+1) z2(itri) = z(j+1,i+1) x3(itri) = x(j,i+1) y3(itri) = y(j,i+1) z3(itri) = z(j,i+1) ityph = 0 if(mod(iflag(j,i),16) .lt. 8) ityph = ityph+1 if(mod(iflag(j,i+1),16) .lt. 8) ityph = ityph+2 if(mod(iflag(j-1,i),4) .lt. 2) ityph = ityph+4 ityp(itri) = icl(ityph+1) go to 100 50 if(mod(iflag(j,i),16) .lt. 8) go to 20 itri = itri+1 x1(itri) = x(j,i) y1(itri) = y(j,i) z1(itri) = z(j,i) x2(itri) = x(j+1,i) y2(itri) = y(j+1,i) z2(itri) = z(j+1,i) x3(itri) = x(j,i+1) y3(itri) = y(j,i+1) z3(itri) = z(j,i+1) ityph = 1 if(mod(i-1,mst(j)) .eq. 0) go to 10 if(mod(iflag(j,i-1),2) .eq. 0) go to 10 ityph = 0 10 if(mod(iflag(j,i),2) .eq. 0) ityph = ityph+2 if(mod(iflag(j-1,i),4) .lt. 2) ityph = ityph+4 ityp(itri) = icl(ityph+1) 20 if(mod(iflag(j,i),2) .eq. 0) go to 100 itri = itri+1 x1(itri) = x(j+1,i) y1(itri) = y(j+1,i) z1(itri) = z(j+1,i) x2(itri) = x(j+1,i+1) y2(itri) = y(j+1,i+1) z2(itri) = z(j+1,i+1) x3(itri) = x(j,i+1) y3(itri) = y(j,i+1) z3(itri) = z(j,i+1) ityph = 1 if(mod(iflag(j,i+1),16) .lt. 8) ityph = ityph+2 if(mod(iflag(j,i),16) .lt. 8) ityph = ityph+4 ityp(itri) = icl(ityph+1) 100 continue c c **** triangles around north and south poles c do 200 i=1,m-1 if(mod(iflag(1,i),16) .lt. 8) go to 250 itri = itri+1 x1(itri) = x(1,i) y1(itri) = y(1,i) z1(itri) = z(1,i) x2(itri) = x(2,i) y2(itri) = y(2,i) z2(itri) = z(2,i) x3(itri) = x(2,i+1) y3(itri) = y(2,i+1) z3(itri) = z(2,i+1) ityph = 3 if(mod(i-1,mst(1)) .eq. 0) go to 260 if(mod(iflag(1,i-1),2) .eq. 0) go to 260 ityph = ityph-1 260 if(mod(iflag(1,i+1),16) .lt. 8) ityph = ityph+4 ityp(itri) = icl(ityph+1) 250 if(mod(iflag(n-1,i),16) .lt. 8) go to 200 itri = itri+1 x1(itri)=x(n-1,i) y1(itri)=y(n-1,i) z1(itri)=z(n-1,i) x2(itri)=x(n,i) y2(itri)=y(n,i) z2(itri)=z(n,i) x3(itri)=x(n-1,i+1) y3(itri)=y(n-1,i+1) z3(itri)=z(n-1,i+1) ityph = 1 if(mod(i-1,mst(n-1)) .eq. 0) go to 210 if(mod(iflag(n-1,i-1),2) .eq. 0) go to 210 ityph = 0 210 if(mod(iflag(n-1,i+1),16) .lt. 8) ityph = ityph+2 if(mod(iflag(n-2,i),4) .lt. 2) ityph = ityph+4 ityp(itri) = icl(ityph+1) 200 continue return end subroutine trigau(m,n,x,y,z,itri,x1,y1,z1,x2,y2,z2,x3,y3,z3, 1 ityp,iflag,mst) c **** performs triangulation dimension x(n,m),y(n,m),z(n,m),x1(1),y1(1),z1(1), 1x2(1),y2(1),z2(1),x3(1),y3(1),z3(1),ityp(1),iflag(n,m), 2mst(n),icl(8) data icl(1),icl(2),icl(3),icl(4),icl(5),icl(6),icl(7),icl(8) 1 /0,1,2,12,3,13,23,123/ itri = 0 n1=2 n2=n-2 do 100 j=n1,n2 do 100 i=1,m-1 if(iflag(j,i) .ge. 16) go to 50 if(mod(iflag(j,i),16) .lt. 8) go to 70 itri = itri+1 x1(itri) = x(j,i) y1(itri) = y(j,i) z1(itri) = z(j,i) x2(itri) = x(j+1,i) y2(itri) = y(j+1,i) z2(itri) = z(j+1,i) x3(itri) = x(j+1,i+1) y3(itri) = y(j+1,i+1) z3(itri) = z(j+1,i+1) ityph = 3 if(mod(i-1,mst(j)) .eq. 0) go to 60 if(mod(iflag(j,i-1),2) .eq. 0) go to 60 ityph = ityph-1 60 if(mod(iflag(j,i),2) .eq. 0) ityph = ityph+4 ityp(itri) = icl(ityph+1) 70 if(mod(iflag(j,i),2) .eq. 0) go to 100 itri = itri+1 x1(itri) = x(j,i) y1(itri) = y(j,i) z1(itri) = z(j,i) x2(itri) = x(j+1,i+1) y2(itri) = y(j+1,i+1) z2(itri) = z(j+1,i+1) x3(itri) = x(j,i+1) y3(itri) = y(j,i+1) z3(itri) = z(j,i+1) ityph = 0 if(mod(iflag(j,i),16) .lt. 8) ityph = ityph+1 if(mod(iflag(j,i+1),16) .lt. 8) ityph = ityph+2 if(mod(iflag(j-1,i),4) .lt. 2) ityph = ityph+4 ityp(itri) = icl(ityph+1) go to 100 50 if(mod(iflag(j,i),16) .lt. 8) go to 20 itri = itri+1 x1(itri) = x(j,i) y1(itri) = y(j,i) z1(itri) = z(j,i) x2(itri) = x(j+1,i) y2(itri) = y(j+1,i) z2(itri) = z(j+1,i) x3(itri) = x(j,i+1) y3(itri) = y(j,i+1) z3(itri) = z(j,i+1) ityph = 1 if(mod(i-1,mst(j)) .eq. 0) go to 10 if(mod(iflag(j,i-1),2) .eq. 0) go to 10 ityph = 0 10 if(mod(iflag(j,i),2) .eq. 0) ityph = ityph+2 if(mod(iflag(j-1,i),4) .lt. 2) ityph = ityph+4 ityp(itri) = icl(ityph+1) 20 if(mod(iflag(j,i),2) .eq. 0) go to 100 itri = itri+1 x1(itri) = x(j+1,i) y1(itri) = y(j+1,i) z1(itri) = z(j+1,i) x2(itri) = x(j+1,i+1) y2(itri) = y(j+1,i+1) z2(itri) = z(j+1,i+1) x3(itri) = x(j,i+1) y3(itri) = y(j,i+1) z3(itri) = z(j,i+1) ityph = 1 if(mod(iflag(j,i+1),16) .lt. 8) ityph = ityph+2 if(mod(iflag(j,i),16) .lt. 8) ityph = ityph+4 ityp(itri) = icl(ityph+1) 100 continue c c **** triangles around north and south poles c do 200 i=1,m-1 if(mod(iflag(1,i),16) .lt. 8) go to 250 itri = itri+1 x1(itri) = x(1,i) y1(itri) = y(1,i) z1(itri) = z(1,i) x2(itri) = x(2,i) y2(itri) = y(2,i) z2(itri) = z(2,i) x3(itri) = x(2,i+1) y3(itri) = y(2,i+1) z3(itri) = z(2,i+1) ityp(itri) = icl(3) 250 if(mod(iflag(n-1,i),16) .lt. 8) go to 200 itri = itri+1 x1(itri)=x(n-1,i) y1(itri)=y(n-1,i) z1(itri)=z(n-1,i) x2(itri)=x(n,i) y2(itri)=y(n,i) z2(itri)=z(n,i) x3(itri)=x(n-1,i+1) y3(itri)=y(n-1,i+1) z3(itri)=z(n-1,i+1) ityp(itri) = icl(1) 200 continue return end subroutine trsplat(n,m,data,work) c c transpose the n by m array data to a m by n array data c work must be at least n*m words long c implicit none integer n,m,i,j,ij,ji real data(*),work(*) do j=1,m do i=1,n ij = (j-1)*n+i work(ij) = data(ij) end do end do do i=1,n do j=1,m ji = (i-1)*m+j ij = (j-1)*n+i data(ji) = work(ij) end do end do return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file trssph.f c c contains documentation and code for subroutine trssph c c ... required files c c sphcom.f, hrfft.f, gaqd.f, shaec.f, shsec.f, shagc.f, shsgc.f c c c subroutine trssph(intl,igrida,nlona,nlata,da,igridb,nlonb,nlatb, c +db,wsave,lsave,lsvmin,work,lwork,lwkmin,dwork,ldwork,ier) c c *** purpose c c subroutine trssph transfers data given in array da on a grid on the c full sphere to data in array db on a grid on the full sphere. the c grids on which da is given and db is generated can be specified c independently of each other (see description below and the arguments c igrida,igridb). for transferring vector data on the sphere, use c subroutine trvsph. c notice that scalar and vector quantities are fundamentally different c on the sphere. for example, vectors are discontinuous and multiple c valued at the poles. scalars are continuous and single valued at the c poles. erroneous results would be produced if one attempted to transfer c vector fields between grids with subroutine trssph applied to each c component of the vector. c c c *** underlying grid assumptions and a description c c discussions with the ncar scd data support group and others indicate c there is no standard grid for storing observational or model generated c data on the sphere. subroutine trssph was designed to handle most c cases likely to be encountered when moving data from one grid format c to another. c c the grid on which da is given must be equally spaced in longitude c and either equally spaced or gaussian in latitude (or colatitude). c longitude, which can be either the first or second dimension of da, c subdivides [0,2pi) excluding the periodic point 2pi. (co)latitude, c which can be the second or first dimension of da, has south c to north or north to south orientation with increasing subscript c value in da (see the argument igrida). c c the grid on which db is generated must be equally spaced in longitude c and either equally spaced or gaussian in latitude (or colatitude). c longitude, which can be either the first or second dimension of db, c subdivides [0,2pi) excluding the periodic point 2pi. (co)latitude, c which can be the second or first dimension of db, has south c to north or north to south orientation with increasing subscript c value in db (see the argument igridb). c c let nlon be either nlona or nlonb (the number of grid points in c longitude. the longitude grid subdivides [0,2pi) into nlon spaced c points c c (j-1)*2.*pi/nlon (j=1,...,nlon). c c it is not necessary to communicate to subroutine trssph whether the c underlying grids are in latitude or colatitude. it is only necessary c to communicate whether they run south to north or north to south with c increasing subscripts. a brief discussion of latitude and colatitude c follows. equally spaced latitude grids are assumed to subdivide c [-pi/2,pi/2] with the south pole at -pi/2 and north pole at pi/2. c equally spaced colatitude grids subdivide [0,pi] with the north pole c at 0 and south pole at pi. equally spaced partitions on the sphere c include both poles. gaussian latitude grids subdivide (-pi/2,pi/2) c and gaussian colatitude grids subdivide (0,pi). gaussian grids do not c include the poles. the gaussian grid points are uniquely determined by c the size of the partition. they can be computed in colatitude in c (0,pi) (north to south) in double precision by the spherepack subroutine c gaqd. let nlat be nlata or nlatb if either the da or db grid is c gaussian. let c c north pole south pole c ---------- ---------- c 0.0 < cth(1) < ... < cth(nlat) < pi c c c be nlat gaussian colatitude points in the interval (0,pi) and let c c south pole north pole c ---------- ---------- c -pi/2 < th(1) < ... < th(nlat) < pi/2 c c be nlat gaussian latitude points in the open interval (-pi/2,pi/2). c these are related by c c th(i) = -pi/2 + cth(i) (i=1,...,nlat) c c if the da or db grid is equally spaced in (co)latitude then c c ctht(i) = (i-1)*pi/(nlat-1) c (i=1,...,nlat) c tht(i) = -pi/2 + (i-1)*pi/(nlat-1) c c define the equally spaced (north to south) colatitude and (south to c north) latitude grids. c c c *** method (simplified description) c c for simplicity, assume da is a nlat by nlon data tabulation and da(i,j) c is the value at latitude theta(i) and longitude phi(j). then c coefficients a(m,n) and b(m,n) can be determined so that da(i,j) is c approximated by the sum c c l-1 n c (a) sum sum pbar(m,n,theta(i))*(a(m,n)*cos(m*phi(j)+b(m,n)*sin(m*phi(j)) c n=0 m=0 c c here pbar(n,m,theta) are the normalized associated legendre functions c and l = min0(nlat,(nlon+2)/2). the determination of a(m,n) and b(m,n) c is called spherical harmonic analysis. a sum of this form can then be c used to regenerate the data in db on the new grid with the known c a(m,n) and b(m,n). this is referred to spherical harmonic synthesis. c analysis and synthesis subroutines from the software package spherepack, c are used for these purposes. c c if da or db is not in mathematical spherical coordinates then array c transposition and/or subscript reordering is used prior to harmonic c analysis and after harmonic synthesis. c c *** advantages c c the use of surface spherical harmonics to transfer spherical grid data c has advantages over pointwise grid interpolation schemes on the sphere. c it is highly accurate. if p(x,y,z) is any polynomial of degree n or c less in x,y,z cartesian coordinates which is restricted to the surface c of the sphere, then p is exactly represented by sums of the form (a) c whenever n = mino(nlat,nlon/2) (i.e., transfers with spherical harmonics c have n(th) order accuracy. by way of contrast, bilinear interpolation c schemes are exact for polynomials of degree one. bicubic interpolation c is exact only for polynomials of degree three or less. the method c also produces a weighted least squares fit to the data in which waves c are resolved uniformly on the full sphere. high frequencies, induced c by closeness of grid points near the poles (due to computational c or observational errors) are smoothed. finally, the method is c consistent with methods used to generate data in numerical spectral c models based on spherical harmonics. for more discussion of these and c related issues, see the article: "on the spectral approximation of c discrete scalar and vector functions on the sphere," siam j. numer. c anal., vol 16. dec 1979, pp. 934-949, by paul swarztrauber. c c c *** comment c c on a nlon by nlat or nlat by nlon grid (gaussian or equally spaced) c spherical harmonic analysis generates and synthesis utilizes c min0(nlat,(nlon+2)/2)) by nlat coefficients. consequently, for c da and db, if either c c min0(nlatb,(nlonb+2)/2) < min0(nlata,(nlona+2)/2) c c or if c c nlatb < nlata c c then all the coefficients generated by an analysis of da cannot be used c in the synthesis which generates db. in this case "information" can be c lost in generating db. more precisely, information will be lost if the c analysis of da yields nonzero coefficients which are outside the bounds c determined by the db grid. nevertheless, transference of values with c spherical harmonics will yield results consistent with grid resolution c and is highly accurate. c c c *** input arguments c c ... intl c c an initialization argument which should be zero on an initial call to c trssph. intl should be one if trssph is being recalled and c c igrida,nlona,nlata,igridb,nlonb,nlatb c c have not changed from the previous call. if any of these arguments c have changed, intl=0 must be used to avoid undetectable errors. calls c with intl=1 bypass redundant computation and save time. it can be used c when transferring multiple data sets with the same underlying grids. c c c ... igrida c c an integer vector dimensioned two which identifies the underlying grid c on the full sphere for the given data array da as follows: c c igrida(1) c c = -1 c if the latitude (or colatitude) grid for da is an equally spaced c partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which c runs north to south c c = +1 c if the latitude (or colatitude) grid for da is an equally spaced c partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which c runs south to north c c = -2 c if the latitude (or colatitude) grid for da is a gaussian partition c of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north c to south c c = +2 c if the latitude (or colatitude) grid for da is a gaussian partition c of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south c north c c igrida(2) c c = 0 if the underlying grid for da is a nlona by nlata c c = 1 if the underlying grid for da is a nlata by nlona c c c ... nlona c c the number of longitude points on the uniform grid which partitions c [0,2pi) for the given data array da. nlona is also the first or second c dimension of da (see igrida(2)) in the program which calls trssph. c nlona determines the grid increment in longitude as 2*pi/nlona. for c example nlona = 72 for a five degree grid. nlona must be greater than c or equal to 4. the efficiency of the computation is improved when c nlona is a product of small prime numbers c c ... nlata c c the number of points in the latitude (or colatitude) grid c for the given data array da. nlata is also the first or second c dimension of da (see igrida(2)) in the program which calls trssph. c if nlata is odd then the equator will be located at the (nlata+1)/2 c gaussian grid point. if nlata is even then the equator will be c located half way between the nlata/2 and nlata/2+1 grid points. c c *** note: c igrida(1)=-1 or igrida(1)=-2 and igrida(2)=1 corresponds to c the "usual" mathematical spherical coordinate system required c by most of the drivers in spherepack2. igrida(1)=1 or igrida(1)=2 c and igrida(2)=0 corresponds to the "usual" geophysical spherical c coordinate system. c c ... da c c a two dimensional array that contains the data to be transferred. c da must be dimensioned nlona by nlata in the program calling trssph if c igrida(2) = 0. da must be dimensioned nlata by nlona in the program c calling trssph if igrida(2) = 1. if da is not properly dimensioned c and if the latitude (colatitude) values do not run south to north or c north to south as flagged by igrida(1) (this cannot be checked!) then c incorrect results will be produced. c c ... igridb c c an integer vector dimensioned two which identifies the underlying grid c on the full sphere for the transformed data array db as follows: c c igridb(1) c c = -1 c if the latitude (or colatitude) grid for db is an equally spaced c partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which c north to south c c = +1 c if the latitude (or colatitude) grid for db is an equally spaced c partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which c south to north c c = -2 c if the latitude (or colatitude) grid for db is a gaussian partition c of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north to c south c c = +2 c if the latitude (or colatitude) grid for db is a gaussian partition c of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south to c north c c c igridb(2) c c = 0 if the underlying grid for db is a nlonb by nlatb c c = 1 if the underlying grid for db is a nlatb by nlonb c c c ... nlonb c c the number of longitude points on the uniform grid which partitions c [0,2pi) for the transformed data array db. nlonb is also the first or c second dimension of db (see igridb(2)) in the program which calls c trssph. nlonb determines the grid increment in longitude as 2*pi/nlonb. c for example nlonb = 72 for a five degree grid. nlonb must be greater c than or equal to 4. the efficiency of the computation is improved when c nlonb is a product of small prime numbers c c ... nlatb c c the number of points in the latitude (or colatitude) grid c for the transformed data array db. nlatb is also the first or second c dimension of db (see igridb(2)) in the program which calls trssph. c if nlatb is odd then the equator will be located at the (nlatb+1)/2 c gaussian grid point. if nlatb is even then the equator will be c located half way between the nlatb/2 and nlatb/2+1 grid points. c c ... wsave c c a saved work space array that can be utilized repeatedly by trssph c as long as the arguments nlata,nlona,nlatb,nlonb remain unchanged. c wsave is set by a intl=0 call to trssph. wsave must not be altered c when trssph is being recalled with intl=1. c c ... lsave c c the dimension of the work space wsave as it appears in the program c that calls trssph. the minimum required value of lsave for the c current set of input arguments is set in the output argument lsvmin. c it can be determined by calling trssph with lsave=0 and printing lsvmin. c let c c lwa = 2*nlata*la2+3*((la1-2)*(nlata+nlata-la1-1))/2+nlona+15 c c if the grid for da is equally spaced in (co)latitude. let c c lwa = nlata*(2*la2+3*la1-2)+3*la1*(1-la1)/2+nlona+15 c c if the grid for da is gaussian in (co)latitude. c let c c lwb = nlatb*(2*lb2+3*lb1-2)+3*lb1*(1-lb1)/2+nlonb+15 c c if the grid for db is gaussian in (co)latitude. let c c lwb = 2*nlatb*lb2+3*((lb1-2)*(nlatb+nlatb-lb1-1))/2+nlonb+15 c c if the grid for db is equally spaced in (co)latitude. then c the quantity c c lwa + lwb c c is the minimum required length of wsave. this value is returned c in the output argument lsvmin even if lsave is to small (ierror=10) c c ... work c c a real work array that does not have to be preserved c c ... lwork c c the dimension of the array work as it appears in the program c calling trssph. the minimum required value of lwork for the current c set of input arguments is set in the output argument lwkmin. c it can be determined by calling trssph with lwork=0 and printing c lwkmin. an estimate for lwork follows. let nlat,nlon,l1,l2 be c defined by c c nlat = max0(nlata,nlatb), nlon = nax0(nlona,nlonb), c l1 = min0(nlat,(nlon+2)/2), l2 = (nlat+1)/2 c c then the quantity c c nlat*(4*l1+nlon+2*nlat+4)+3*((l1-2)*2*(2*nlat-l1-1))/2 c c will suffice as a length for the unsaved work space. c c * both of the formulas above for lsave and lwork may overestimate the c required minimum values. they can be predetermined by calling trssph c with lsave=lwork=0 and printout of lsvmin and lwkmin. c c ... dwork c c a double precision work array that does not have to be preserved. c c ... ldwork c c The length of dwork in the routine calling trssph. c Let c c nlat = max0(nlata,nlatb) c c ldwork must be at least nlat*(nlat+4) c c *** output arguments c c c ... db c c a two dimensional array that contains the transformed data. db c must be dimensioned nlonb by nlatb in the program calling trssph if c igridb(2) = 0 or 1. db must be dimensioned nlatb by nlonb in the c program calling trssph if igridb(2) = 1. if db is not properly c dimensioned and if the latitude (colatitude) values do not run south c north or north to south as flagged by igrdb(1) (this cannot be checked!) c then incorrect results will be produced. c c ... lsvmin c c the minimum length of the saved work space in wsave. c lsvmin is computed even if lsave < lsvmin (ier = 10). c c ... lwkmin c c the minimum length of the unsaved work space in work. c lwkmin is computed even if lwork < lwkmin (ier = 11). c c *** error argument c c ... ier = 0 if no errors are detected c c = 1 if intl is not 0 or 1 c c = 2 if igrida(1) is not -1 or +1 or -2 or +2 c c = 3 if igrida(2) is not 0 or 1 c c = 4 if nlona is less than 4 c c = 5 if nlata is less than 3 c c = 6 if igridb(1) is not -1 or +1 or -2 or +2 c c = 7 if igridb(2) is not 0 or 1 c c = 8 if nlonb is less than 4 c c = 9 if nlatb is less than 3 c =10 if there is insufficient saved work space (lsave < lsvmin) c c =11 if there is insufficient unsaved work space (lwork < lwkmin) c c =12 indicates failure in an eigenvalue routine which computes c gaussian weights and points c c =13 if ldwork is too small (insufficient unsaved double precision c work space) c c ***************************************************** c ***************************************************** c c end of argument description ... code follows c c ***************************************************** c ***************************************************** c subroutine TRSSPH (INTL,IGRIDA,NLONA,NLATA,DA,IGRIDB,NLONB,NLATB, +DB,WSAVE,LSAVE,LSVMIN,WORK,LWORK,LWKMIN,DWORK,LDWORK,IER) implicit none integer intl,igrida(2),nlona,nlata,igridb(2),nlonb,nlatb integer lsave,lsvmin,lwork,lwkmin,ldwork,ier real da(*),db(*),wsave(*),work(*) double precision dwork(*) integer ig,igrda,igrdb,la1,la2,lb1,lb2,lwa,lwb,iaa,iab,iba,ibb integer lwk3,lwk4,lw,iw,jb,nt,isym,nlat c c include a save statement to ensure local variables in trssph, set during c an intl=0 call, are preserved if trssph is recalled with intl=1 c save c c check input arguments c ier = 1 if (intl*(intl-1).ne.0) return ier = 2 ig = igrida(1) if ((ig-1)*(ig+1)*(ig-2)*(ig+2).ne.0) return ier = 3 ig = igrida(2) if (ig*(ig-1).ne.0) return ier = 4 if (nlona .lt. 4) return ier = 5 if (nlata .lt.3) return ier = 6 ig = igridb(1) if ((ig-1)*(ig+1)*(ig-2)*(ig+2).ne.0) return ier = 7 ig = igridb(2) if (ig*(ig-1).ne.0) return ier = 8 if (nlonb .lt.4) return ier = 9 if (nlatb .lt.3) return ier = 0 igrda = iabs(igrida(1)) igrdb = iabs(igridb(1)) if (intl.eq.0) then la1 = min0(nlata,(nlona+2)/2) la2 = (nlata+1)/2 lb1 = min0(nlatb,(nlonb+2)/2) lb2 = (nlatb+1)/2 c c set saved work space length for analysis c if (igrda .eq. 1) then c c saved space for analysis on equally spaced grid c lwa = 2*nlata*la2+3*((la1-2)*(nlata+nlata-la1-1))/2+nlona+15 else c c saved space for analysis on gaussian grid c lwa = nlata*(2*la2+3*la1-2)+3*la1*(1-la1)/2+nlona+15 end if c c set wsave pointer c jb = 1+lwa c c set pointers for spherical harmonic coefs c iaa = 1 iba = iaa+la1*nlata iab = iba+la1*nlata if (igrdb .eq. 2) then c c set saved work space length for gaussian synthesis c lwb = nlatb*(2*lb2+3*lb1-2)+3*lb1*(1-lb1)/2+nlonb+15 else c c set saved work space length for equally spaced synthesis c lwb = 2*nlatb*lb2+3*((lb1-2)*(nlatb+nlatb-lb1-1))/2+nlonb+15 end if c c set minimum saved work space length c lsvmin = lwa + lwb c c set remaining harmonic pointer c ibb = iab+lb1*nlatb c c set pointers for remaining work c iw = ibb+lb1*nlatb c c set remaining work space length in lw c lw = lwork - iw lwk3 = nlata*nlona*2 lwk4 = nlatb*nlonb*2 c c set minimum unsaved work space required by trssph c lwkmin = iw + max0(lwk3,lwk4) c c set error flags if saved or unsaved work spaces are insufficient c ier = 10 if (lsave .lt. lsvmin) return ier = 11 if (lwork .lt. lwkmin) return ier = 13 nlat = max0(nlata,nlatb) if (ldwork .lt. nlat*(nlat+4)) return ier = 0 if (igrda .eq. 1) then c c initialize wsave for equally spaced analysis c call shaeci(nlata,nlona,wsave,lwa,dwork,ldwork,ier) else c c initialize wsave for gaussian analysis c call shagci(nlata,nlona,wsave,lwa,dwork,ldwork,ier) if (ier.ne.0) then c c flag failure in spherepack gaussian software c ier = 12 return end if end if if (igrdb .eq. 2) then c c initialize wsave for gaussian synthesis c call shsgci(nlatb,nlonb,wsave(jb),lwb,dwork,ldwork,ier) if (ier.ne.0) then c c flag failure in spherepack gaussian software c ier = 12 return end if else c c initialize wsave for equally spaced synthesis c call shseci(nlatb,nlonb,wsave(jb),lwb,dwork,ldwork,ier) end if c c end of initialization (intl=0) call c end if c c transpose and/or reorder (co)latitude if necessary for da c (arrays must have latitude (colatitude) as the first dimension c and run north to south for spherepack software) c if (igrida(2) .eq. 0) call trsplat(nlona,nlata,da,work) if (igrida(1) .gt. 0) call convlat(nlata,nlona,da) nt = 1 isym = 0 if (igrda .eq. 2) then c c do spherical harmonic analysis of "adjusted" da on gaussian grid c call shagc(nlata,nlona,isym,nt,da,nlata,nlona,work(iaa), +work(iba),la1,nlata,wsave,lwa,work(iw),lw,ier) else c c do spherical harmonic analysis of "adjusted" da on equally spaced grid c call shaec(nlata,nlona,isym,nt,da,nlata,nlona,work(iaa), +work(iba),la1,nlata,wsave,lwa,work(iw),lw,ier) end if c c transfer da grid coefficients to db grid coefficients c truncating to zero as necessary c call trab(la1,nlata,work(iaa),work(iba),lb1,nlatb,work(iab), + work(ibb)) if (igrdb .eq. 1) then c c do spherical harmonic synthesis on nlatb by nlonb equally spaced grid c call shsec(nlatb,nlonb,isym,nt,db,nlatb,nlonb,work(iab), +work(ibb),lb1,nlatb,wsave(jb),lwb,work(iw),lw,ier) else c c do spherical harmonic synthesis on nlatb by nlonb gaussian grid c call shsgc(nlatb,nlonb,isym,nt,db,nlatb,nlonb,work(iab), +work(ibb),lb1,nlatb,wsave(jb),lwb,work(iw),lw,ier) end if c c both da,db are currently latitude by longitude north to south arrays c restore da and set db to agree with flags in igrida and igridb c if (igrida(1) .gt. 0) call convlat(nlata,nlona,da) if (igridb(1) .gt. 0) call convlat(nlatb,nlonb,db) if (igrida(2) .eq. 0) call trsplat(nlata,nlona,da,work) if (igridb(2) .eq. 0) call trsplat(nlatb,nlonb,db,work) return end subroutine trunc(irc,n,idp,a,nrc,ijs) double precision a,eps parameter (eps=5.d-8) dimension a(idp,*),ijs(n) c c irc = 0 for columns , or irc = 1 for rows c if(irc.ne.0) go to 30 do 20 j=1,nrc do i=1,n ijs(j) = i if(dabs(a(i,j)) .gt. eps) go to 20 end do 20 continue return 30 do 50 i=1,nrc do j=1,n ijs(i) = j if(abs(a(i,j)) .gt. eps) go to 50 end do 50 continue return end subroutine trvab(ma,na,abr,abi,acr,aci,mb,nb,bbr,bbi,bcr,bci) implicit none integer ma,na,mb,nb,i,j,m,n real abr(ma,na),abi(ma,na),acr(ma,na),aci(ma,na) real bbr(mb,nb),bbi(mb,nb),bcr(mb,nb),bci(mb,nb) c c set coefficients for b grid from coefficients for a grid c m = min0(ma,mb) n = min0(na,nb) do j=1,n do i=1,m bbr(i,j) = abr(i,j) bbi(i,j) = abi(i,j) bcr(i,j) = acr(i,j) bci(i,j) = aci(i,j) end do end do c c set coefs outside triangle to zero c do i=m+1,mb do j=1,nb bbr(i,j) = 0.0 bbi(i,j) = 0.0 bcr(i,j) = 0.0 bci(i,j) = 0.0 end do end do do j=n+1,nb do i=1,mb bbr(i,j) = 0.0 bbi(i,j) = 0.0 bcr(i,j) = 0.0 bci(i,j) = 0.0 end do end do return end subroutine trvplat(n,m,data,work) c c transpose the n by m array data to a m by n array data c work must be at least n*m words long c implicit none integer n,m,i,j,ij,ji real data(*),work(*) do j=1,m do i=1,n ij = (j-1)*n+i work(ij) = data(ij) end do end do do i=1,n do j=1,m ji = (i-1)*m+j ij = (j-1)*n+i data(ji) = work(ij) end do end do return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file trvsph.f c c this file contains documentation and code for subroutine trvsph c c ... required files c c sphcom.f, hrfft.f, gaqd.f, vhaec.f, vhsec.f, vhagc.f, vhsgc.f c c subroutine trvsph (intl,igrida,nlona,nlata,iveca,ua,va, c +igridb,nlonb,nlatb,ivecb,ub,vb,wsave,lsave,lsvmin,work, c +lwork,lwkmin,dwork,ldwork,ier) c c *** author c c John C. Adams (NCAR 1997), email: johnad@ncar.ucar.edu c c *** purpose c c subroutine trvsph transfers vector data given in (ua,va) on a grid on c the full sphere to vector data in (ub,vb) on a grid on the full sphere. c the grids on which (ua,va) is given and (ub,vb) is generated can be c specified independently of each other (see the input arguments igrida, c igridb,iveca,ivecb). ua and ub are the east longitudinal components of c the given and transformed vector fields. va is either the latitudinal c or colatitudinal component of the given vector field (see iveca). c vb is either the latitudinal or colatitudinal component of the c transformed vector field (see ivecb). for transferring scalar data c on the sphere, use subroutine trssph. c c * notice that scalar and vector quantities are fundamentally different c on the sphere. for example, vectors are discontinuous and multiple c valued at the poles. scalars are continuous and single valued at the c poles. erroneous results would be produced if one attempted to transfer c vector fields between grids with subroutine trssph applied to each c component of the vector. c c *** underlying grid assumptions and a description c c discussions with the ncar scd data support group and others indicate c there is no standard grid for storing observational or model generated c data on the sphere. subroutine trvsph was designed to handle most c cases likely to be encountered when moving data from one grid format c to another. c c the grid on which (ua,va) is given must be equally spaced in longitude c and either equally spaced or gaussian in latitude (or colatitude). c longitude, which can be either the first or second dimension of ua,va c subdivides [0,2pi) excluding the periodic point 2pi. (co)latitude, c which can be the second or first dimension of ua,va, has south c to north or north to south orientation with increasing subscript c value in ua,va (see the argument igrida). c c the grid on which ub,vb is generated must be equally spaced in longitude c and either equally spaced or gaussian in latitude (or colatitude). c longitude, which can be either the first or second dimension of ub,vb c subdivides [0,2pi) excluding the periodic point 2pi. (co)latitude, c which can be the second or first dimension of ub,vb, has south c to north or north to south orientation with increasing subscript c value in db (see the argument igridb). c c let nlon be either nlona or nlonb (the number of grid points in c longitude. the longitude grid subdivides [0,2pi) into nlon spaced c points c c (j-1)*2.*pi/nlon (j=1,...,nlon). c c it is not necessary to communicate to subroutine trvsph whether the c underlying grids are in latitude or colatitude. it is only necessary c to communicate whether they run south to north or north to south with c increasing subscripts. a brief discussion of latitude and colatitude c follows. equally spaced latitude grids are assumed to subdivide c [-pi/2,pi/2] with the south pole at -pi/2 and north pole at pi/2. c equally spaced colatitude grids subdivide [0,pi] with the north pole c at 0 and south pole at pi. equally spaced partitions on the sphere c include both poles. gaussian latitude grids subdivide (-pi/2,pi/2) c and gaussian colatitude grids subdivide (0,pi). gaussian grids do not c include the poles. the gaussian grid points are uniquely determined by c the size of the partition. they can be computed in colatitude in c (0,pi) (north to south) in double precision by the spherepack subroutine c gaqd. let nlat be nlata or nlatb if either the ua,va or ub,vb grid is c gaussian. let c c north pole south pole c ---------- ---------- c 0.0 < cth(1) < ... < cth(nlat) < pi c c c be nlat gaussian colatitude points in the interval (0,pi) and let c c south pole north pole c ---------- ---------- c -pi/2 < th(1) < ... < th(nlat) < pi/2 c c be nlat gaussian latitude points in the open interval (-pi/2,pi/2). c these are related by c c th(i) = -pi/2 + cth(i) (i=1,...,nlat) c c if the (ua,va) or (ub,vb) grid is equally spaced in (co)latitude then c c ctht(i) = (i-1)*pi/(nlat-1) c (i=1,...,nlat) c tht(i) = -pi/2 + (i-1)*pi/(nlat-1) c c define the equally spaced (north to south) colatitude and (south to c north) latitude grids. c c *** method (simplified description) c c (1) c c the vector field (ua,va) is reformated to a vector field in mathematical c spherical coordinates using array transpositions, subscript reordering c and negation of va as necessary (see arguments igrida,iveca). c c (2) c c a vector harmonic analysis is performed on the result from (1) c c (3) c c a vector harmonic synthesis is performed on the (ub,vb) grid c using as many coefficients from (2) as possible (i.e., as c as is consistent with the size of the ub,vb grid). c c (4) c c the vector field generated in (3) is transformed from mathematical c spherical coordinates to the form flagged by ivecb and igridb in c (ub,vb) using array transpositions, subscript reordering and negation c as necessary c c c *** advantages c c the use of vector spherical harmonics to transfer vector data is c highly accurate and preserves properties of vectors on the sphere. c the method produces a weighted least squares fit to vector data in c which waves are resolved uniformly on the full sphere. high frequencies c induced by closeness of grid points near the poles (due to computational c or observational errors) are smoothed. the method is consistent with c methods used to generate vector data in numerical spectral models based c on spherical harmonics. for more discussion of these and related issues, c see "on the spectral approximation of discrete scalar and vector c functions on the sphere," siam j. numer. anal., vol. 16, december 1979, c pp. 934-949, by paul swarztrauber. c c c *** comment c c on a nlon by nlat or nlat by nlon grid (gaussian or equally spaced) c spherical harmonic analysis generates and synthesis utilizes c min0(nlat,(nlon+2)/2)) by nlat coefficients. consequently, for c ua,va and ub,vb, if either c c min0(nlatb,(nlonb+2)/2) < min0(nlata,(nlona+2)/2) c c or if c c nlatb < nlata c c then all the coefficients generated by an analysis of ua,va cannot be c used in the synthesis which generates ub,vb. in this case "information" c can be lost in generating ub,vb. more precisely, information will be c lost if the analysis of ua,va yields nonzero coefficients which are c outside the coefficient bounds determined by the ub,vb grid. still c transference with vector spherical harmonics will yield results c consistent with grid resolution and is highly accurate. c c *** input arguments c c ... intl c c an initialization argument which should be zero on an initial call to c trvsph. intl should be one if trvsph is being recalled and c c igrida,nlona,nlata,iveca,igridb,nlonb,nlatb,ivecb c c have not changed from the previous call. if any of these arguments have c changed intl=0 must be used to avoid undetectable errors. when allowed, c calls with intl=1 bypass redundant computation and save time. it can c be used when transferring multiple vector data sets with the same c underlying grids. c c ... igrida c c an integer vector dimensioned two which identifies the underlying grid c on the full sphere for the given vector data (ua,va) as follows: c c igrida(1) c c = -1 c if the latitude (or colatitude) grid for ua,va is an equally spaced c partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which c runs north to south with increasing subscript value c c = +1 c if the latitude (or colatitude) grid for ua,va is an equally spaced c partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which c runs south to north with increasing subscript value c c = -2 c if the latitude (or colatitude) grid for ua,va is a gaussian partition c of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north c to south with increasing subscript value c c = +2 c if the latitude (or colatitude) grid for ua,va is a gaussian partition c of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south c north with increasing subscript value c c igrida(2) c c = 0 if the underlying grid for ua,va is a nlona by nlata c c = 1 if the underlying grid for ua,va is a nlata by nlona c c c ... nlona c c the number of longitude points on the uniform grid which partitions c [0,2pi) for the given vector (ua,va). nlona is also the first or second c dimension of ua,va (see igrida(2)) in the program which calls trvsph. c nlona determines the grid increment in longitude as 2*pi/nlona. for c example nlona = 72 for a five degree grid. nlona must be greater than c or equal to 4. the efficiency of the computation is improved when c nlona is a product of small prime numbers c c ... nlata c c the number of points in the latitude (or colatitude) grid for the c given vector (ua,va). nlata is also the first or second dimension c of ua and va (see igrida(2)) in the program which calls trvsph. c if nlata is odd then the equator will be located at the (nlata+1)/2 c gaussian grid point. if nlata is even then the equator will be c located half way between the nlata/2 and nlata/2+1 grid points. c c ... iveca c c if iveca=0 is input then va is the latitudinal component of the c given vector field. if iveca=1 then va is the colatitudinal c compoenent of the given vector field. in either case, ua must c be the east longitudinal component of the given vector field. c c *** note: c igrida(1)=-1 or igrida(1)=-2, igrida(2)=1, and iveca=1 corresponds c to the "usual" mathematical spherical coordinate system required c by most of the drivers in spherepack2. igrida(1)=1 or igrida(1)=2, c igrida(2)=0, and iveca=0 corresponds to the "usual" geophysical c spherical coordinate system. c c c ... ua c c ua is the east longitudinal component of the given vector field. c ua must be dimensioned nlona by nlata in the program calling trvsph if c igrida(2) = 0. ua must be dimensioned nlata by nlona in the program c calling trvsph if igrida(2) = 1. if ua is not properly dimensioned c and if the latitude (colatitude) values do not run south to north or c north to south as flagged by igrida(1) (this cannot be checked!) then c incorrect results will be produced. c c c ... va c c va is either the latitudinal or colatitudinal componenet of the c given vector field (see iveca). va must be dimensioned nlona by c nlata in the program calling trvsph if igrida(2)=0. va must be c dimensioned nlata by nlona in the program calling trvsph if c igrida(2)=1. if va is not properly dimensioned or if the latitude c (colatitude) values do not run south to north or north to south c as flagged by igrida(1) (this cannot be checked!) then incorrect c results will be produced. c c ... igridb c c an integer vector dimensioned two which identifies the underlying grid c on the full sphere for the transformed vector (ub,vb) as follows: c c igridb(1) c c = -1 c if the latitude (or colatitude) grid for ub,vb is an equally spaced c partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which c north to south c c = +1 c if the latitude (or colatitude) grid for ub,vb is an equally spaced c partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which c south to north c c = -2 c if the latitude (or colatitude) grid for ub,vb is a gaussian partition c of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north to c south c c = +2 c if the latitude (or colatitude) grid for ub,vb is a gaussian partition c of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south to c north c c igridb(2) c c = 0 if the underlying grid for ub,vb is a nlonb by nlatb c c = 1 if the underlying grid for ub,vb is a nlatb by nlonb c c c ... nlonb c c the number of longitude points on the uniform grid which partitions c [0,2pi) for the transformed vector (ub,vb). nlonb is also the first or c second dimension of ub and vb (see igridb(2)) in the program which calls c trvsph. nlonb determines the grid increment in longitude as 2*pi/nlonb. c for example nlonb = 72 for a five degree grid. nlonb must be greater c than or equal to 4. the efficiency of the computation is improved when c nlonb is a product of small prime numbers c c ... nlatb c c the number of points in the latitude (or colatitude) grid for the c transformed vector (ub,vb). nlatb is also the first or second dimension c of ub and vb (see igridb(2)) in the program which calls trvsph. c if nlatb is odd then the equator will be located at the (nlatb+1)/2 c gaussian grid point. if nlatb is even then the equator will be c located half way between the nlatb/2 and nlatb/2+1 grid points. c c ... ivecb c c if ivecb=0 is input then vb is the latitudinal component of the c given vector field. if ivecb=1 then vb is the colatitudinal c compoenent of the given vector field. in either case, ub must c be the east longitudinal component of the given vector field. c c *** note: c igridb(1)=-1 or igridb(1)=-2, igridb(2)=1, and ivecb=1 corresponds c to the "usual" mathematical spherical coordinate system required c by most of the drivers in spherepack2. igridb(1)=1 or igridb(1)=2, c igridb(2)=0, and ivecb=0 corresponds to the "usual" geophysical c spherical coordinate system. c c ... wsave c c a saved work space array that can be utilized repeatedly by trvsph c as long as the arguments nlata,nlona,nlatb,nlonb remain unchanged. c wsave is set by a intl=0 call to trvsph. wsave must not be altered c when trvsph is being recalled with intl=1. c c ... lsave c c the dimension of the work space wsave as it appears in the program c that calls trvsph. the minimum required value of lsave for the c current set of input arguments is set in the output argument lsvmin. c it can be determined by calling trvsph with lsave=0 and printing lsvmin. c c la1 = min0(nlata,(nlona+1)/2), la2 = (nlata+1)/2 c c lb1 = min0(nlatb,(nlonb+1)/2), lb2 = (nlatb+1)/2 c c lwa = 4*nlata*la2+3*max0(la1-2,0)*(2*nlata-la1-1)+la2+nlona+15 c c lwb = 4*nlatb*lb2+3*max0(lb1-2,0)*(2*nlatb-lb1-1)+nlonb+15 c c then c c lsvmin = lwa + lwb c c is the minimal required work space length of wsave c c c ... work c c a work array that does not have to be preserved c c ... lwork c c the dimension of the array work as it appears in the program that c calls trvsph. the minimum required value of lwork for the current c set of input arguments is set in the output argument lwkmin. c it can be determined by calling trvsph with lwork=0 and printing c lwkmin. an estimate for lwork follows. let nlat = max0(nlata,nlatb), c nlon = max0(nlona,nlonb) and l1 = min0(nlat,(nlon+2)/2). with these c these definitions, the quantity c c 2*nlat*(8*l1 + 4*nlon + 3) c c will suffice as a length for the unsaved work space. this formula c may overestimate the required minimum value for lwork. the exact c minimum value can be predetermined by calling trvsph wtih lwork=0 c and printout of lwkmin. c c ... dwork c c a double precision work array that does not have to be preserved. c c ... ldwork c c the length of dwork in the routine calling trvsph c Let c c nlat = max0(nlata,nlatb) c c ldwork must be at least 2*nlat*(nlat+1)+1 c c c *** output arguments c c c ... ub c c a two dimensional array that contains the east longitudinal component c of the transformed vector data. ub c must be dimensioned nlonb by nlatb in the program calling trvsph if c igridb(2)=0. ub must be dimensioned nlatb by nlonb in the program c calling trvsph if igridb(2)=1. if ub is not properly dimensioned c and if the latitude (colatitude) values do not run south to north or c north to south as flagged by igrdb(1) (this cannot be checked!) then c incorrect results will be produced. c c c ... vb c c a two dimensional array that contains the latitudinal or colatitudinal c component of the transformed vector data (see ivecb). c vb must be dimensioned nlonb by nlatb in the program calling trvsph if c igridb(2)=0. vb must be dimensioned nlatb by nlonb in the program c calling trvsph if igridb(2)=1. if vb is not properly dimensioned c and if the latitude (colatitude) values do not run south to north or c north to south as flagged by igrdb(1) (this cannot be checked!) then c incorrect results will be produced. c c ... lsvmin c c the minimum length of the saved work space in wsave. c lsvmin is computed even if lsave < lsvmin (ier = 10). c c ... lwkmin c c the minimum length of the unsaved work space in work. c lwkmin is computed even if lwork < lwkmin (ier = 11). c c c *** error argument c c ... ier = 0 if no errors are detected c c = 1 if intl is not 0 or 1 c c = 2 if igrida(1) is not -1 or +1 or -2 or +2 c c = 3 if igrida(2) is not 0 or 1 c c = 4 if nlona is less than 4 c c = 5 if nlata is less than 3 c c = 6 if iveca is not 0 or 1 c c = 7 if igridb(1) is not -1 or +1 or -2 or +2 c c = 8 if igridb(2) is not 0 or 1 c c = 9 if nlonb is less than 4 c c =10 if nlatb is less than 3 c c =11 if ivecb is not 0 or 1 c c =12 if there is insufficient saved work space (lsave < lsvmin) c c =13 if there is insufficient unsaved work space (lwork < lwkmin) c c =14 indicates failure in an eigenvalue routine which computes c gaussian weights and points c c =15 if ldwork is too small (insufficient double precision c unsaved work space) c c ***************************************************** c ***************************************************** c c end of argument description ... code follows c c ***************************************************** c ***************************************************** c subroutine trvsph (intl,igrida,nlona,nlata,iveca,ua,va, +igridb,nlonb,nlatb,ivecb,ub,vb,wsave,lsave,lsvmin,work, +lwork,lwkmin,dwork,ldwork,ier) implicit none integer intl,igrida(2),nlona,nlata,igridb(2),nlonb,nlatb integer iveca,ivecb,lsave,lsvmin,lwork,lwkmin,ldwork,ier real ua(*),va(*),ub(*),vb(*),wsave(*),work(*) double precision dwork(*) integer ig,igrda,igrdb,la1,la2,lb1,lb2,lwa,lwb integer iabr,iabi,iacr,iaci,ibbr,ibbi,ibcr,ibci integer nlat,lwk1,lwk2,lw,iw,jb,nt,ityp c c include a save statement to ensure local variables in trvsph, set during c an intl=0 call, are preserved if trvsph is recalled with intl=1 c save c c check input arguments c ier = 1 if (intl*(intl-1).ne.0) return ier = 2 ig = igrida(1) if ((ig-1)*(ig+1)*(ig-2)*(ig+2).ne.0) return ier = 3 ig = igrida(2) if (ig*(ig-1).ne.0) return ier = 4 if (nlona .lt. 4) return ier = 5 if (nlata .lt.3) return ier = 6 if (iveca*(iveca-1).ne.0) return ier = 7 ig = igridb(1) if ((ig-1)*(ig+1)*(ig-2)*(ig+2).ne.0) return ier = 8 ig = igridb(2) if (ig*(ig-1).ne.0) return ier = 9 if (nlonb .lt.4) return ier = 10 if (nlatb .lt.3) return ier = 11 if (ivecb*(ivecb-1).ne.0) return ier = 0 igrda = iabs(igrida(1)) igrdb = iabs(igridb(1)) if (intl.eq.0) then la1 = min0(nlata,(nlona+1)/2) la2 = (nlata+1)/2 lb1 = min0(nlatb,(nlonb+1)/2) lb2 = (nlatb+1)/2 c c saved space for analysis on a grid c lwa = 4*nlata*la2+3*max0(la1-2,0)*(2*nlata-la1-1)+la2+nlona+15 c c set saved work space length for synthesis on b grid c lwb = 4*nlatb*lb2+3*max0(lb1-2,0)*(2*nlatb-lb1-1)+nlonb+15 c c set minimum required saved work space length c lsvmin = lwa + lwb c c set wsave pointer c jb = 1+lwa c c set pointers for vector spherical harmonic coefs in work c iabr = 1 iabi = iabr + la1*nlata iacr = iabi + la1*nlata iaci = iacr + la1*nlata ibbr = iaci + la1*nlata ibbi = ibbr + lb1*nlatb ibcr = ibbi + lb1*nlatb ibci = ibcr + lb1*nlatb c c set pointers for remaining work c iw = ibci + lb1*nlatb c c set remaining work space length in lw c lw = lwork - iw c c compute unsaved space for analysis and synthesis c lwk1 = 2*nlata*(2*nlona+max0(6*la2,nlona)) lwk2 = 2*nlatb*(2*nlonb+max0(6*lb2,nlonb)) c c set minimum unsaved work space required by trvsph c lwkmin = iw + max0(lwk1,lwk2) c c set error flags if saved or unsaved work space is insufficient c ier = 12 if (lsave .lt. lsvmin) return ier = 13 if (lwork .lt. lwkmin) return ier = 15 nlat = max0(nlata,nlatb) if (ldwork .lt. 2*nlat*(nlat+1)+1) return ier = 0 if (igrda .eq. 1) then c c initialize wsave for equally spaced analysis c call vhaeci(nlata,nlona,wsave,lwa,dwork,ldwork,ier) else c c initialize wsave for gaussian analysis c call vhagci(nlata,nlona,wsave,lwa,dwork,ldwork,ier) if (ier.ne.0) then c c flag failure in spherepack gaussian software c ier = 14 return end if end if if (igrdb .eq. 2) then c c initialize wsave for gaussian synthesis c call vhsgci(nlatb,nlonb,wsave(jb),lwb,dwork,ldwork,ier) if (ier.ne.0) then c c flag failure in spherepack gaussian software c ier = 14 return end if else c c initialize wsave for equally spaced synthesis c call vhseci(nlatb,nlonb,wsave(jb),lwb,dwork,ldwork,ier) end if c c end of initialization (intl=0) call c end if c c convert the vector field (ua,va) to mathematical spherical coordinates c if (igrida(2).eq.0) then call trvplat(nlona,nlata,ua,work) call trvplat(nlona,nlata,va,work) end if if (igrida(1) .gt. 0) then call covlat(nlata,nlona,ua) call covlat(nlata,nlona,va) end if if (iveca .eq. 0) then call negv(nlata,nlona,va) end if nt = 1 ityp = 0 c c analyze vector field c if (igrda .eq. 2) then call vhagc(nlata,nlona,ityp,nt,va,ua,nlata,nlona,work(iabr), + work(iabi),work(iacr),work(iaci),la1,nlata,wsave,lwa,work(iw), + lw,ier) else call vhaec(nlata,nlona,ityp,nt,va,ua,nlata,nlona,work(iabr), + work(iabi),work(iacr),work(iaci),la1,nlata,wsave,lwa,work(iw), + lw,ier) end if c c transfer a grid coefficients to b grid coefficients c call trvab(la1,nlata,work(iabr),work(iabi),work(iacr),work(iaci), + lb1,nlatb,work(ibbr),work(ibbi),work(ibcr),work(ibci)) c c synthesize on b grid c if (igrdb .eq. 1) then call vhsec(nlatb,nlonb,ityp,nt,vb,ub,nlatb,nlonb,work(ibbr), +work(ibbi),work(ibcr),work(ibci),lb1,nlatb,wsave(jb),lwb, +work(iw),lw,ier) else call vhsgc(nlatb,nlonb,ityp,nt,vb,ub,nlatb,nlonb,work(ibbr), +work(ibbi),work(ibcr),work(ibci),lb1,nlatb,wsave(jb),lwb,work(iw), +lw,ier) end if c c restore a grid and b grid vector fields (now in math coordinates) to c agree with grid flags in igrida,iveca,igridb,ivecb c if (iveca .eq. 0) then call negv(nlata,nlona,va) end if if (ivecb .eq. 0) then call negv(nlatb,nlonb,vb) end if if (igrida(1).gt. 0) then call covlat(nlata,nlona,ua) call covlat(nlata,nlona,va) end if if (igridb(1) .gt. 0) then call covlat(nlatb,nlonb,ub) call covlat(nlatb,nlonb,vb) end if if (igrida(2) .eq. 0) then call trvplat(nlata,nlona,ua,work) call trvplat(nlata,nlona,va,work) end if if (igridb(2) .eq. 0) then call trvplat(nlatb,nlonb,ub,work) call trvplat(nlatb,nlonb,vb,work) end if return end subroutine vbgint (nlat,nlon,theta,wvbin,work) dimension wvbin(1) double precision theta(*),work(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c theta is a double precision array with (nlat+1)/2 locations c nlat is the maximum value of n+1 c the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of work is nlat+2 c call vbgit1 (nlat,nlon,imid,theta,wvbin,wvbin(iw1), + work,work(nlat/2+2)) return end subroutine vbgit1 (nlat,nlon,imid,theta,vb,abc,cvb,work) c c abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c locations where mmax = min0(nlat,(nlon+1)/2) c cvb and work must each have nlat/2+1 locations c dimension vb(imid,nlat,2),abc(1) double precision cvb(1),theta(1),vbh,work(1) mdo = min0(2,nlat,(nlon+1)/2) do 160 mp1=1,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dvbk(m,n,cvb,work) do 165 i=1,imid call dvbt(m,n,theta(i),cvb,vbh) vb(i,np1,mp1) = vbh 165 continue 160 continue call rabcv(nlat,nlon,abc) return end subroutine vbin (ityp,nlat,nlon,m,vb,i3,wvbin) dimension vb(1) ,wvbin(1) imid = (nlat+1)/2 lim = nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 iw1 = lim+1 iw2 = iw1+lim iw3 = iw2+labc iw4 = iw3+labc c c the length of wvbin is 2*lim+3*labc c call vbin1 (ityp,nlat,m,vb,imid,i3,wvbin,wvbin(iw1),wvbin(iw2), 1 wvbin(iw3),wvbin(iw4)) return end subroutine vbin1 (ityp,nlat,m,vb,imid,i3,vbz,vb1,a,b,c) dimension vb(imid,nlat,3),vbz(imid,1),vb1(imid,1), 1 a(1),b(1),c(1) save i1,i2 ihold = i1 i1 = i2 i2 = i3 i3 = ihold if(m-1)25,30,35 25 i1 = 1 i2 = 2 i3 = 3 do 45 np1=1,nlat do 45 i=1,imid vb(i,np1,i3) = vbz(i,np1) 45 continue return 30 do 50 np1=2,nlat do 50 i=1,imid vb(i,np1,i3) = vb1(i,np1) 50 continue return 35 ns = ((m-2)*(nlat+nlat-m-1))/2+1 if(ityp .eq. 1) go to 36 do 85 i=1,imid vb(i,m+1,i3) = a(ns)*vb(i,m-1,i1)-c(ns)*vb(i,m+1,i1) 85 continue 36 if(m .eq. nlat-1) return if(ityp .eq. 2) go to 71 ns = ns+1 do 70 i=1,imid vb(i,m+2,i3) = a(ns)*vb(i,m,i1)-c(ns)*vb(i,m+2,i1) 70 continue 71 nstrt = m+3 if(ityp .eq. 1) nstrt = m+4 if(nstrt .gt. nlat) go to 80 nstp = 2 if(ityp .eq. 0) nstp = 1 do 75 np1=nstrt,nlat,nstp ns = ns+nstp do 75 i=1,imid vb(i,np1,i3) = a(ns)*vb(i,np1-2,i1)+b(ns)*vb(i,np1-2,i3) 1 -c(ns)*vb(i,np1,i1) 75 continue 80 return end subroutine vbini1 (nlat,nlon,imid,vb,abc,cvb,work) c c abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c locations where mmax = min0(nlat,(nlon+1)/2) c cvb and work must each have nlat+1 locations c dimension vb(imid,nlat,2),abc(1) double precision pi,dt,cvb(1),th,vbh,work(1) pi = 4.*datan(1.d0) dt = pi/(nlat-1) mdo = min0(2,nlat,(nlon+1)/2) do 160 mp1=1,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dvbk(m,n,cvb,work) do 165 i=1,imid th = (i-1)*dt call dvbt(m,n,th,cvb,vbh) vb(i,np1,mp1) = vbh 165 continue 160 continue call rabcv(nlat,nlon,abc) return end subroutine vbinit (nlat,nlon,wvbin,dwork) dimension wvbin(1) double precision dwork(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of dwork is nlat+2 c call vbini1 (nlat,nlon,imid,wvbin,wvbin(iw1),dwork, 1 dwork(nlat/2+2)) return end subroutine vea1(nlat,nlon,imid,zv,zw,idz,zin,wzvin,dwork) dimension zv(idz,1),zw(idz,1),zin(imid,nlat,3),wzvin(1) double precision dwork(*) mmax = min0(nlat,(nlon+1)/2) call zvinit (nlat,nlon,wzvin,dwork) do 33 mp1=1,mmax m = mp1-1 call zvin (0,nlat,nlon,m,zin,i3,wzvin) do 33 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 33 i=1,imid zv(mn,i) = zin(i,np1,i3) 33 continue call zwinit (nlat,nlon,wzvin,dwork) do 34 mp1=1,mmax m = mp1-1 call zwin (0,nlat,nlon,m,zin,i3,wzvin) do 34 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 34 i=1,imid zw(mn,i) = zin(i,np1,i3) 34 continue return end subroutine vecout ( variable, name, dim ) c*********************************************************************72 c cc VECOUT prints a real vector. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 30 November 2009 c c Author: c c John Burkardt c c Parameters: c c Input, real VARIABLE(DIM), the vector to be printed. c c Input, hollerith NAME, the name. c c Input, integer DIM, the dimension. c implicit none integer dim integer i character*(*) name real variable(dim) write ( *, '(a4,'' = '' )' ) name do i = 1, dim write ( *, '(7x,g14.6 )' ) variable(i) end do return end subroutine ves1(nlat,nlon,imid,vb,wb,idz,vin,wzvin,dwork) dimension vb(imid,*),wb(imid,*),vin(imid,nlat,3),wzvin(*) double precision dwork(*) mmax = min0(nlat,(nlon+1)/2) call vbinit (nlat,nlon,wzvin,dwork) do 33 mp1=1,mmax m = mp1-1 call vbin (0,nlat,nlon,m,vin,i3,wzvin) do 33 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 33 i=1,imid vb(i,mn) = vin(i,np1,i3) 33 continue call wbinit (nlat,nlon,wzvin,dwork) do 34 mp1=1,mmax m = mp1-1 call wbin (0,nlat,nlon,m,vin,i3,wzvin) do 34 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 34 i=1,imid wb(i,mn) = vin(i,np1,i3) 34 continue return end subroutine vet1(nlat,nlon,imid,vb,wb,idz,vin,wzvin,dwork) dimension vb(imid,*),wb(imid,*),vin(imid,nlat,3),wzvin(*) double precision dwork(*) mmax = min0(nlat,(nlon+1)/2) call vtinit (nlat,nlon,wzvin,dwork) do 33 mp1=1,mmax m = mp1-1 call vbin (0,nlat,nlon,m,vin,i3,wzvin) do 33 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 33 i=1,imid vb(i,mn) = vin(i,np1,i3) 33 continue call wtinit (nlat,nlon,wzvin,dwork) do 34 mp1=1,mmax m = mp1-1 call wbin (0,nlat,nlon,m,vin,i3,wzvin) do 34 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 34 i=1,imid wb(i,mn) = vin(i,np1,i3) 34 continue return end subroutine vetg1(nlat,nlon,imid,vb,wb,vin,wvbin, 1 theta,wts,dwork,ierror) dimension vb(imid,*),wb(imid,*),vin(imid,nlat,3),wvbin(*) double precision dwork(*),theta(*),wts(*) mmax = min0(nlat,nlon/2+1) ldwork = 1 call gaqd(nlat,theta,wts,dwork,ldwork,ierr) if(ierr .eq. 0) go to 10 ierror = 10+ierr return 10 call vtgint (nlat,nlon,theta,wvbin,dwork) do 33 mp1=1,mmax m = mp1-1 call vbin (0,nlat,nlon,m,vin,i3,wvbin) do 33 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 33 i=1,imid vb(i,mn) = vin(i,np1,i3) 33 continue call wtgint (nlat,nlon,theta,wvbin,dwork) do 34 mp1=1,mmax m = mp1-1 call wbin (0,nlat,nlon,m,vin,i3,wvbin) do 34 np1=mp1,nlat mn = m*(nlat-1)-(m*(m-1))/2+np1 do 34 i=1,imid wb(i,mn) = vin(i,np1,i3) 34 continue return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by ucar . c . . c . university corporation for atmospheric research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vhaec.f c c this file contains code and documentation for subroutines c vhaec and vhaeci c c ... files which must be loaded with vhaec.f c c sphcom.f, hrfft.f c c c subroutine vhaec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvhaec,lvhaec,work,lwork,ierror) c c subroutine vhaec performs the vector spherical harmonic analysis c on the vector field (v,w) and stores the result in the arrays c br, bi, cr, and ci. v(i,j) and w(i,j) are the colatitudinal c (measured from the north pole) and east longitudinal components c respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the spectral c representation of (v,w) is given at output parameters v,w in c subroutine vhsec. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 2 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 3 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 5 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 6 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 8 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c c nt the number of analyses. in the program that calls vhaec, c the arrays v,w,br,bi,cr, and ci can be three dimensional c in which case multiple analyses will be performed. c the third index is the analysis index which assumes the c values k=1,...,nt. for a single analysis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c v,w two or three dimensional arrays (see input parameter nt) c that contain the vector function to be analyzed. c v is the colatitudnal component and w is the east c longitudinal component. v(i,j),w(i,j) contain the c components at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges c are defined above at the input parameter ityp. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls vhaec. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls vhaec. jdvw must be at least nlon. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhaec. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhaec. ndab must be at c least nlat. c c wvhaec an array which must be initialized by subroutine vhaeci. c once initialized, wvhaec can be used repeatedly by vhaec c as long as nlon and nlat remain unchanged. wvhaec must c not be altered between calls of vhaec. c c lvhaec the dimension of the array wvhaec as it appears in the c program that calls vhaec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhaec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhaec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)) c c if ityp .gt. 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) c c ************************************************************** c c output parameters c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c in the spectral representation of v(i,j) and w(i,j) given c in the discription of subroutine vhsec. br(mp1,np1), c bi(mp1,np1),cr(mp1,np1), and ci(mp1,np1) are computed c for mp1=1,...,mmax and np1=mp1,...,nlat except for np1=nlat c and odd mp1. mmax=min0(nlat,nlon/2) if nlon is even or c mmax=min0(nlat,(nlon+1)/2) if nlon is odd. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhaec c = 10 error in the specification of lwork c c c ******************************************************************* c c subroutine vhaeci(nlat,nlon,wvhaec,lvhaec,dwork,ldwork,ierror) c c subroutine vhaeci initializes the array wvhaec which can then be c used repeatedly by subroutine vhaec until nlat or nlon is changed. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lvhaec the dimension of the array wvhaec as it appears in the c program that calls vhaec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhaec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls vhaec. ldwork must be at least c 2*(nlat+2) c c c ************************************************************** c c output parameters c c wvhaec an array which is initialized for use by subroutine vhaec. c once initialized, wvhaec can be used repeatedly by vhaec c as long as nlat or nlon remain unchanged. wvhaec must not c be altered between calls of vhaec. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lvhaec c = 4 error in the specification of ldwork c c c ********************************************************************** subroutine vhaec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvhaec,lvhaec,work,lwork,ierror) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvhaec(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhaec .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 if(ityp .le. 2 .and. 1 lwork .lt. nlat*(2*nt*nlon+max0(6*imid,nlon))) return if(ityp .gt. 2 .and. 1 lwork .lt. imid*(2*nt*nlon+max0(6*nlat,nlon))) return ierror = 0 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl iw5 = iw4+3*imid*nlat lwzvin = lzz1+labc jw1 = lwzvin+1 jw2 = jw1+lwzvin call vhaec1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),work(iw5),wvhaec,wvhaec(jw1),wvhaec(jw2)) return end subroutine vhaec1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab, 1 ndab,br,bi,cr,ci,idv,ve,vo,we,wo,zv,zw,wzvin,wzwin,wrfft) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1), 3 wo(idv,nlon,1),wzvin(1),wzwin(1),wrfft(1), 4 zv(imid,nlat,3),zw(imid,nlat,3) nlp1 = nlat+1 tsn = 2./nlon fsn = 4./nlon mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 if(ityp .gt. 2) go to 3 do 5 k=1,nt do 5 i=1,imm1 do 5 j=1,nlon ve(i,j,k) = tsn*(v(i,j,k)+v(nlp1-i,j,k)) vo(i,j,k) = tsn*(v(i,j,k)-v(nlp1-i,j,k)) we(i,j,k) = tsn*(w(i,j,k)+w(nlp1-i,j,k)) wo(i,j,k) = tsn*(w(i,j,k)-w(nlp1-i,j,k)) 5 continue go to 2 3 do 8 k=1,nt do 8 i=1,imm1 do 8 j=1,nlon ve(i,j,k) = fsn*v(i,j,k) vo(i,j,k) = fsn*v(i,j,k) we(i,j,k) = fsn*w(i,j,k) wo(i,j,k) = fsn*w(i,j,k) 8 continue 2 if(mlat .eq. 0) go to 7 do 6 k=1,nt do 6 j=1,nlon ve(imid,j,k) = tsn*v(imid,j,k) we(imid,j,k) = tsn*w(imid,j,k) 6 continue 7 do 9 k=1,nt call hrfftf(idv,nlon,ve(1,1,k),idv,wrfft,zv) call hrfftf(idv,nlon,we(1,1,k),idv,wrfft,zv) 9 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 if(ityp.eq.2 .or. ityp.eq.5 .or. ityp.eq.8) go to 11 do 10 k=1,nt do 10 mp1=1,mmax do 10 np1=mp1,nlat br(mp1,np1,k)=0. bi(mp1,np1,k)=0. 10 continue 11 if(ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) go to 13 do 12 k=1,nt do 12 mp1=1,mmax do 12 np1=mp1,nlat cr(mp1,np1,k)=0. ci(mp1,np1,k)=0. 12 continue 13 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 , no symmetries c 1 call zvin(0,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 15 k=1,nt do 15 i=1,imid do 15 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+zv(i,np1,iv)*ve(i,1,k) cr(1,np1,k) = cr(1,np1,k)-zv(i,np1,iv)*we(i,1,k) 15 continue do 16 k=1,nt do 16 i=1,imm1 do 16 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+zv(i,np1,iv)*vo(i,1,k) cr(1,np1,k) = cr(1,np1,k)-zv(i,np1,iv)*wo(i,1,k) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 20 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(0,nlat,nlon,m,zv,iv,wzvin) call zwin(0,nlat,nlon,m,zw,iw,wzwin) if(mp1 .gt. ndo1) go to 17 do 23 k=1,nt do 23 i=1,imm1 do 23 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(i,np1,iv)*vo(i,2*mp1-2,k) 1 +zw(i,np1,iw)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(i,np1,iv)*vo(i,2*mp1-1,k) 1 -zw(i,np1,iw)*we(i,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)-zv(i,np1,iv)*wo(i,2*mp1-2,k) 1 +zw(i,np1,iw)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(i,np1,iv)*wo(i,2*mp1-1,k) 1 -zw(i,np1,iw)*ve(i,2*mp1-2,k) 23 continue if(mlat .eq. 0) go to 17 do 24 k=1,nt do 24 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zw(imid,np1,iw)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-zw(imid,np1,iw)*we(imid,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)+zw(imid,np1,iw)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zw(imid,np1,iw)*ve(imid,2*mp1-2,k) 24 continue 17 if(mp2 .gt. ndo2) go to 20 do 21 k=1,nt do 21 i=1,imm1 do 21 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(i,np1,iv)*ve(i,2*mp1-2,k) 1 +zw(i,np1,iw)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(i,np1,iv)*ve(i,2*mp1-1,k) 1 -zw(i,np1,iw)*wo(i,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)-zv(i,np1,iv)*we(i,2*mp1-2,k) 1 +zw(i,np1,iw)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(i,np1,iv)*we(i,2*mp1-1,k) 1 -zw(i,np1,iw)*vo(i,2*mp1-2,k) 21 continue if(mlat .eq. 0) go to 20 do 22 k=1,nt do 22 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(imid,np1,iv)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(imid,np1,iv)*ve(imid,2*mp1-1,k) cr(mp1,np1,k) = cr(mp1,np1,k)-zv(imid,np1,iv)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(imid,np1,iv)*we(imid,2*mp1-1,k) 22 continue 20 continue return c c case ityp=1 , no symmetries but cr and ci equal zero c 100 call zvin(0,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 115 k=1,nt do 115 i=1,imid do 115 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+zv(i,np1,iv)*ve(i,1,k) 115 continue do 116 k=1,nt do 116 i=1,imm1 do 116 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+zv(i,np1,iv)*vo(i,1,k) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 120 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(0,nlat,nlon,m,zv,iv,wzvin) call zwin(0,nlat,nlon,m,zw,iw,wzwin) if(mp1 .gt. ndo1) go to 117 do 123 k=1,nt do 123 i=1,imm1 do 123 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(i,np1,iv)*vo(i,2*mp1-2,k) 1 +zw(i,np1,iw)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(i,np1,iv)*vo(i,2*mp1-1,k) 1 -zw(i,np1,iw)*we(i,2*mp1-2,k) 123 continue if(mlat .eq. 0) go to 117 do 124 k=1,nt do 124 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zw(imid,np1,iw)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-zw(imid,np1,iw)*we(imid,2*mp1-2,k) 124 continue 117 if(mp2 .gt. ndo2) go to 120 do 121 k=1,nt do 121 i=1,imm1 do 121 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(i,np1,iv)*ve(i,2*mp1-2,k) 1 +zw(i,np1,iw)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(i,np1,iv)*ve(i,2*mp1-1,k) 1 -zw(i,np1,iw)*wo(i,2*mp1-2,k) 121 continue if(mlat .eq. 0) go to 120 do 122 k=1,nt do 122 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(imid,np1,iv)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(imid,np1,iv)*ve(imid,2*mp1-1,k) 122 continue 120 continue return c c case ityp=2 , no symmetries but br and bi equal zero c 200 call zvin(0,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 215 k=1,nt do 215 i=1,imid do 215 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-zv(i,np1,iv)*we(i,1,k) 215 continue do 216 k=1,nt do 216 i=1,imm1 do 216 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-zv(i,np1,iv)*wo(i,1,k) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 220 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(0,nlat,nlon,m,zv,iv,wzvin) call zwin(0,nlat,nlon,m,zw,iw,wzwin) if(mp1 .gt. ndo1) go to 217 do 223 k=1,nt do 223 i=1,imm1 do 223 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(i,np1,iv)*wo(i,2*mp1-2,k) 1 +zw(i,np1,iw)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(i,np1,iv)*wo(i,2*mp1-1,k) 1 -zw(i,np1,iw)*ve(i,2*mp1-2,k) 223 continue if(mlat .eq. 0) go to 217 do 224 k=1,nt do 224 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+zw(imid,np1,iw)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zw(imid,np1,iw)*ve(imid,2*mp1-2,k) 224 continue 217 if(mp2 .gt. ndo2) go to 220 do 221 k=1,nt do 221 i=1,imm1 do 221 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(i,np1,iv)*we(i,2*mp1-2,k) 1 +zw(i,np1,iw)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(i,np1,iv)*we(i,2*mp1-1,k) 1 -zw(i,np1,iw)*vo(i,2*mp1-2,k) 221 continue if(mlat .eq. 0) go to 220 do 222 k=1,nt do 222 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(imid,np1,iv)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(imid,np1,iv)*we(imid,2*mp1-1,k) 222 continue 220 continue return c c case ityp=3 , v even , w odd c 300 call zvin(0,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 315 k=1,nt do 315 i=1,imid do 315 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+zv(i,np1,iv)*ve(i,1,k) 315 continue do 316 k=1,nt do 316 i=1,imm1 do 316 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-zv(i,np1,iv)*wo(i,1,k) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 320 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(0,nlat,nlon,m,zv,iv,wzvin) call zwin(0,nlat,nlon,m,zw,iw,wzwin) if(mp1 .gt. ndo1) go to 317 do 323 k=1,nt do 323 i=1,imm1 do 323 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(i,np1,iv)*wo(i,2*mp1-2,k) 1 +zw(i,np1,iw)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(i,np1,iv)*wo(i,2*mp1-1,k) 1 -zw(i,np1,iw)*ve(i,2*mp1-2,k) 323 continue if(mlat .eq. 0) go to 317 do 324 k=1,nt do 324 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+zw(imid,np1,iw)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zw(imid,np1,iw)*ve(imid,2*mp1-2,k) 324 continue 317 if(mp2 .gt. ndo2) go to 320 do 321 k=1,nt do 321 i=1,imm1 do 321 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(i,np1,iv)*ve(i,2*mp1-2,k) 1 +zw(i,np1,iw)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(i,np1,iv)*ve(i,2*mp1-1,k) 1 -zw(i,np1,iw)*wo(i,2*mp1-2,k) 321 continue if(mlat .eq. 0) go to 320 do 322 k=1,nt do 322 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(imid,np1,iv)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(imid,np1,iv)*ve(imid,2*mp1-1,k) 322 continue 320 continue return c c case ityp=4 , v even, w odd, and cr and ci equal 0. c 400 call zvin(1,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 415 k=1,nt do 415 i=1,imid do 415 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+zv(i,np1,iv)*ve(i,1,k) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 420 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(1,nlat,nlon,m,zv,iv,wzvin) call zwin(1,nlat,nlon,m,zw,iw,wzwin) if(mp2 .gt. ndo2) go to 420 do 421 k=1,nt do 421 i=1,imm1 do 421 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(i,np1,iv)*ve(i,2*mp1-2,k) 1 +zw(i,np1,iw)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(i,np1,iv)*ve(i,2*mp1-1,k) 1 -zw(i,np1,iw)*wo(i,2*mp1-2,k) 421 continue if(mlat .eq. 0) go to 420 do 422 k=1,nt do 422 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(imid,np1,iv)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(imid,np1,iv)*ve(imid,2*mp1-1,k) 422 continue 420 continue return c c case ityp=5 v even, w odd, and br and bi equal zero c 500 call zvin(2,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 516 k=1,nt do 516 i=1,imm1 do 516 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-zv(i,np1,iv)*wo(i,1,k) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 520 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(2,nlat,nlon,m,zv,iv,wzvin) call zwin(2,nlat,nlon,m,zw,iw,wzwin) if(mp1 .gt. ndo1) go to 520 do 523 k=1,nt do 523 i=1,imm1 do 523 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(i,np1,iv)*wo(i,2*mp1-2,k) 1 +zw(i,np1,iw)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(i,np1,iv)*wo(i,2*mp1-1,k) 1 -zw(i,np1,iw)*ve(i,2*mp1-2,k) 523 continue if(mlat .eq. 0) go to 520 do 524 k=1,nt do 524 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+zw(imid,np1,iw)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zw(imid,np1,iw)*ve(imid,2*mp1-2,k) 524 continue 520 continue return c c case ityp=6 , v odd , w even c 600 call zvin(0,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 615 k=1,nt do 615 i=1,imid do 615 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-zv(i,np1,iv)*we(i,1,k) 615 continue do 616 k=1,nt do 616 i=1,imm1 do 616 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+zv(i,np1,iv)*vo(i,1,k) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 620 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(0,nlat,nlon,m,zv,iv,wzvin) call zwin(0,nlat,nlon,m,zw,iw,wzwin) if(mp1 .gt. ndo1) go to 617 do 623 k=1,nt do 623 i=1,imm1 do 623 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(i,np1,iv)*vo(i,2*mp1-2,k) 1 +zw(i,np1,iw)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(i,np1,iv)*vo(i,2*mp1-1,k) 1 -zw(i,np1,iw)*we(i,2*mp1-2,k) 623 continue if(mlat .eq. 0) go to 617 do 624 k=1,nt do 624 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zw(imid,np1,iw)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-zw(imid,np1,iw)*we(imid,2*mp1-2,k) 624 continue 617 if(mp2 .gt. ndo2) go to 620 do 621 k=1,nt do 621 i=1,imm1 do 621 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(i,np1,iv)*we(i,2*mp1-2,k) 1 +zw(i,np1,iw)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(i,np1,iv)*we(i,2*mp1-1,k) 1 -zw(i,np1,iw)*vo(i,2*mp1-2,k) 621 continue if(mlat .eq. 0) go to 620 do 622 k=1,nt do 622 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(imid,np1,iv)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(imid,np1,iv)*we(imid,2*mp1-1,k) 622 continue 620 continue return c c case ityp=7 v odd, w even, and cr and ci equal zero c 700 call zvin(2,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 716 k=1,nt do 716 i=1,imm1 do 716 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+zv(i,np1,iv)*vo(i,1,k) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 720 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(2,nlat,nlon,m,zv,iv,wzvin) call zwin(2,nlat,nlon,m,zw,iw,wzwin) if(mp1 .gt. ndo1) go to 720 do 723 k=1,nt do 723 i=1,imm1 do 723 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(i,np1,iv)*vo(i,2*mp1-2,k) 1 +zw(i,np1,iw)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(i,np1,iv)*vo(i,2*mp1-1,k) 1 -zw(i,np1,iw)*we(i,2*mp1-2,k) 723 continue if(mlat .eq. 0) go to 720 do 724 k=1,nt do 724 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zw(imid,np1,iw)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-zw(imid,np1,iw)*we(imid,2*mp1-2,k) 724 continue 720 continue return c c case ityp=8 v odd, w even, and both br and bi equal zero c 800 call zvin(1,nlat,nlon,0,zv,iv,wzvin) c c case m=0 c do 815 k=1,nt do 815 i=1,imid do 815 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-zv(i,np1,iv)*we(i,1,k) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 820 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call zvin(1,nlat,nlon,m,zv,iv,wzvin) call zwin(1,nlat,nlon,m,zw,iw,wzwin) if(mp2 .gt. ndo2) go to 820 do 821 k=1,nt do 821 i=1,imm1 do 821 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(i,np1,iv)*we(i,2*mp1-2,k) 1 +zw(i,np1,iw)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(i,np1,iv)*we(i,2*mp1-1,k) 1 -zw(i,np1,iw)*vo(i,2*mp1-2,k) 821 continue if(mlat .eq. 0) go to 820 do 822 k=1,nt do 822 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(imid,np1,iv)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(imid,np1,iv)*we(imid,2*mp1-1,k) 822 continue 820 continue return end subroutine vhaeci(nlat,nlon,wvhaec,lvhaec,dwork,ldwork,ierror) dimension wvhaec(lvhaec) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 imid = (nlat+1)/2 lzz1 = 2*nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhaec .lt. 2*(lzz1+labc)+nlon+15) return ierror = 4 if(ldwork .lt. 2*nlat+2) return ierror = 0 call zvinit (nlat,nlon,wvhaec,dwork) lwzvin = lzz1+labc iw1 = lwzvin+1 call zwinit (nlat,nlon,wvhaec(iw1),dwork) iw2 = iw1+lwzvin call hrffti(nlon,wvhaec(iw2)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vhaes.f c c this file contains code and documentation for subroutines c vhaes and vhaesi c c ... files which must be loaded with vhaes.f c c sphcom.f, hrfft.f c c c subroutine vhaes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvhaes,lvhaes,work,lwork,ierror) c c subroutine vhaes performs the vector spherical harmonic analysis c on the vector field (v,w) and stores the result in the arrays c br, bi, cr, and ci. v(i,j) and w(i,j) are the colatitudinal c (measured from the north pole) and east longitudinal components c respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the spectral c representation of (v,w) is given at output parameters v,w in c subroutine vhses. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 2 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 3 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 5 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 6 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 8 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c c nt the number of analyses. in the program that calls vhaes, c the arrays v,w,br,bi,cr, and ci can be three dimensional c in which case multiple analyses will be performed. c the third index is the analysis index which assumes the c values k=1,...,nt. for a single analysis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c v,w two or three dimensional arrays (see input parameter nt) c that contain the vector function to be analyzed. c v is the colatitudnal component and w is the east c longitudinal component. v(i,j),w(i,j) contain the c components at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges c are defined above at the input parameter ityp. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls vhaes. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls vhaes. jdvw must be at least nlon. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhaes. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhaes. ndab must be at c least nlat. c c lvhaes an array which must be initialized by subroutine vhaesi. c once initialized, wvhaes can be used repeatedly by vhaes c as long as nlon and nlat remain unchanged. wvhaes must c not be altered between calls of vhaes. c c lvhaes the dimension of the array wvhaes as it appears in the c program that calls vhaes. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhaes must be at least c c l1*l2(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhaes. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c (2*nt+1)*nlat*nlon c c if ityp .gt. 2 then lwork must be at least c c (2*nt+1)*l2*nlon c c ************************************************************** c c output parameters c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c in the spectral representation of v(i,j) and w(i,j) given c in the discription of subroutine vhses. br(mp1,np1), c bi(mp1,np1),cr(mp1,np1), and ci(mp1,np1) are computed c for mp1=1,...,mmax and np1=mp1,...,nlat except for np1=nlat c and odd mp1. mmax=min0(nlat,nlon/2) if nlon is even or c mmax=min0(nlat,(nlon+1)/2) if nlon is odd. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhaes c = 10 error in the specification of lwork c c ******************************************************** c c subroutine vhaesi(nlat,nlon,wvhaes,lvhaes,work,lwork,dwork, c + ldwork,ierror) c c subroutine vhaesi initializes the array wvhaes which can then be c used repeatedly by subroutine vhaes until nlat or nlon is changed. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lvhaes the dimension of the array wvhaes as it appears in the c program that calls vhaes. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhaes must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhaes. lwork must be at least c c 3*(max0(l1-2,0)*(nlat+nlat-l1-1))/2+5*l2*nlat c c dwork an unsaved double precision work space c c ldwork the length of the array dwork as it appears in the c program that calls vhaesi. ldwork must be at least c 2*(nlat+1) c c c ************************************************************** c c output parameters c c wvhaes an array which is initialized for use by subroutine vhaes. c once initialized, wvhaes can be used repeatedly by vhaes c as long as nlat or nlon remain unchanged. wvhaes must not c be altered between calls of vhaes. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lvhaes c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c c subroutine vhaes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvhaes,lvhaes,work,lwork,ierror) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvhaes(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lvhaes .lt. lzimn+lzimn+nlon+15) return ierror = 10 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon if(lwork .lt. lnl+lnl+idv*nlon) return ierror = 0 ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl jw1 = lzimn+1 jw2 = jw1+lzimn call vhaes1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),idz,wvhaes,wvhaes(jw1),wvhaes(jw2)) return end subroutine vhaes1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab, 1 ndab,br,bi,cr,ci,idv,ve,vo,we,wo,work,idz,zv,zw,wrfft) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1), 3 wo(idv,nlon,1),work(1),wrfft(1), 4 zv(idz,1),zw(idz,1) nlp1 = nlat+1 tsn = 2./nlon fsn = 4./nlon mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 if(ityp .gt. 2) go to 3 do 5 k=1,nt do 5 i=1,imm1 do 5 j=1,nlon ve(i,j,k) = tsn*(v(i,j,k)+v(nlp1-i,j,k)) vo(i,j,k) = tsn*(v(i,j,k)-v(nlp1-i,j,k)) we(i,j,k) = tsn*(w(i,j,k)+w(nlp1-i,j,k)) wo(i,j,k) = tsn*(w(i,j,k)-w(nlp1-i,j,k)) 5 continue go to 2 3 do 8 k=1,nt do 8 i=1,imm1 do 8 j=1,nlon ve(i,j,k) = fsn*v(i,j,k) vo(i,j,k) = fsn*v(i,j,k) we(i,j,k) = fsn*w(i,j,k) wo(i,j,k) = fsn*w(i,j,k) 8 continue 2 if(mlat .eq. 0) go to 7 do 6 k=1,nt do 6 j=1,nlon ve(imid,j,k) = tsn*v(imid,j,k) we(imid,j,k) = tsn*w(imid,j,k) 6 continue 7 do 9 k=1,nt call hrfftf(idv,nlon,ve(1,1,k),idv,wrfft,work) call hrfftf(idv,nlon,we(1,1,k),idv,wrfft,work) 9 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 if(ityp.eq.2 .or. ityp.eq.5 .or. ityp.eq.8) go to 11 do 10 k=1,nt do 10 mp1=1,mmax do 10 np1=mp1,nlat br(mp1,np1,k)=0. bi(mp1,np1,k)=0. 10 continue 11 if(ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) go to 13 do 12 k=1,nt do 12 mp1=1,mmax do 12 np1=mp1,nlat cr(mp1,np1,k)=0. ci(mp1,np1,k)=0. 12 continue 13 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 , no symmetries c c case m=0 c 1 do 15 k=1,nt do 15 i=1,imid do 15 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+zv(np1,i)*ve(i,1,k) cr(1,np1,k) = cr(1,np1,k)-zv(np1,i)*we(i,1,k) 15 continue do 16 k=1,nt do 16 i=1,imm1 do 16 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+zv(np1,i)*vo(i,1,k) cr(1,np1,k) = cr(1,np1,k)-zv(np1,i)*wo(i,1,k) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 20 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 17 do 23 k=1,nt do 23 i=1,imm1 do 23 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,i)*vo(i,2*mp1-2,k) 1 +zw(np1+mb,i)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,i)*vo(i,2*mp1-1,k) 1 -zw(np1+mb,i)*we(i,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,i)*wo(i,2*mp1-2,k) 1 +zw(np1+mb,i)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,i)*wo(i,2*mp1-1,k) 1 -zw(np1+mb,i)*ve(i,2*mp1-2,k) 23 continue if(mlat .eq. 0) go to 17 do 24 k=1,nt do 24 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zw(np1+mb,imid)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-zw(np1+mb,imid)*we(imid,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)+zw(np1+mb,imid)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zw(np1+mb,imid)*ve(imid,2*mp1-2,k) 24 continue 17 if(mp2 .gt. ndo2) go to 20 do 21 k=1,nt do 21 i=1,imm1 do 21 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,i)*ve(i,2*mp1-2,k) 1 +zw(np1+mb,i)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,i)*ve(i,2*mp1-1,k) 1 -zw(np1+mb,i)*wo(i,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,i)*we(i,2*mp1-2,k) 1 +zw(np1+mb,i)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,i)*we(i,2*mp1-1,k) 1 -zw(np1+mb,i)*vo(i,2*mp1-2,k) 21 continue if(mlat .eq. 0) go to 20 do 22 k=1,nt do 22 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,imid)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,imid)*ve(imid,2*mp1-1,k) cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,imid)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,imid)*we(imid,2*mp1-1,k) 22 continue 20 continue return c c case ityp=1 , no symmetries but cr and ci equal zero c c case m=0 c 100 do 115 k=1,nt do 115 i=1,imid do 115 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+zv(np1,i)*ve(i,1,k) 115 continue do 116 k=1,nt do 116 i=1,imm1 do 116 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+zv(np1,i)*vo(i,1,k) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 120 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 117 do 123 k=1,nt do 123 i=1,imm1 do 123 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,i)*vo(i,2*mp1-2,k) 1 +zw(np1+mb,i)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,i)*vo(i,2*mp1-1,k) 1 -zw(np1+mb,i)*we(i,2*mp1-2,k) 123 continue if(mlat .eq. 0) go to 117 do 124 k=1,nt do 124 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zw(np1+mb,imid)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-zw(np1+mb,imid)*we(imid,2*mp1-2,k) 124 continue 117 if(mp2 .gt. ndo2) go to 120 do 121 k=1,nt do 121 i=1,imm1 do 121 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,i)*ve(i,2*mp1-2,k) 1 +zw(np1+mb,i)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,i)*ve(i,2*mp1-1,k) 1 -zw(np1+mb,i)*wo(i,2*mp1-2,k) 121 continue if(mlat .eq. 0) go to 120 do 122 k=1,nt do 122 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,imid)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,imid)*ve(imid,2*mp1-1,k) 122 continue 120 continue return c c case ityp=2 , no symmetries but br and bi equal zero c c case m=0 c 200 do 215 k=1,nt do 215 i=1,imid do 215 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-zv(np1,i)*we(i,1,k) 215 continue do 216 k=1,nt do 216 i=1,imm1 do 216 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-zv(np1,i)*wo(i,1,k) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 220 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 217 do 223 k=1,nt do 223 i=1,imm1 do 223 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,i)*wo(i,2*mp1-2,k) 1 +zw(np1+mb,i)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,i)*wo(i,2*mp1-1,k) 1 -zw(np1+mb,i)*ve(i,2*mp1-2,k) 223 continue if(mlat .eq. 0) go to 217 do 224 k=1,nt do 224 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+zw(np1+mb,imid)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zw(np1+mb,imid)*ve(imid,2*mp1-2,k) 224 continue 217 if(mp2 .gt. ndo2) go to 220 do 221 k=1,nt do 221 i=1,imm1 do 221 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,i)*we(i,2*mp1-2,k) 1 +zw(np1+mb,i)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,i)*we(i,2*mp1-1,k) 1 -zw(np1+mb,i)*vo(i,2*mp1-2,k) 221 continue if(mlat .eq. 0) go to 220 do 222 k=1,nt do 222 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,imid)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,imid)*we(imid,2*mp1-1,k) 222 continue 220 continue return c c case ityp=3 , v even , w odd c c case m=0 c 300 do 315 k=1,nt do 315 i=1,imid do 315 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+zv(np1,i)*ve(i,1,k) 315 continue do 316 k=1,nt do 316 i=1,imm1 do 316 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-zv(np1,i)*wo(i,1,k) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 320 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 317 do 323 k=1,nt do 323 i=1,imm1 do 323 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,i)*wo(i,2*mp1-2,k) 1 +zw(np1+mb,i)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,i)*wo(i,2*mp1-1,k) 1 -zw(np1+mb,i)*ve(i,2*mp1-2,k) 323 continue if(mlat .eq. 0) go to 317 do 324 k=1,nt do 324 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+zw(np1+mb,imid)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zw(np1+mb,imid)*ve(imid,2*mp1-2,k) 324 continue 317 if(mp2 .gt. ndo2) go to 320 do 321 k=1,nt do 321 i=1,imm1 do 321 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,i)*ve(i,2*mp1-2,k) 1 +zw(np1+mb,i)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,i)*ve(i,2*mp1-1,k) 1 -zw(np1+mb,i)*wo(i,2*mp1-2,k) 321 continue if(mlat .eq. 0) go to 320 do 322 k=1,nt do 322 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,imid)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,imid)*ve(imid,2*mp1-1,k) 322 continue 320 continue return c c case ityp=4 , v even, w odd, and cr and ci equal 0. c c case m=0 c 400 do 415 k=1,nt do 415 i=1,imid do 415 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+zv(np1,i)*ve(i,1,k) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 420 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 420 do 421 k=1,nt do 421 i=1,imm1 do 421 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,i)*ve(i,2*mp1-2,k) 1 +zw(np1+mb,i)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,i)*ve(i,2*mp1-1,k) 1 -zw(np1+mb,i)*wo(i,2*mp1-2,k) 421 continue if(mlat .eq. 0) go to 420 do 422 k=1,nt do 422 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,imid)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,imid)*ve(imid,2*mp1-1,k) 422 continue 420 continue return c c case ityp=5 v even, w odd, and br and bi equal zero c c case m=0 c 500 do 516 k=1,nt do 516 i=1,imm1 do 516 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-zv(np1,i)*wo(i,1,k) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 520 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 520 do 523 k=1,nt do 523 i=1,imm1 do 523 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,i)*wo(i,2*mp1-2,k) 1 +zw(np1+mb,i)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,i)*wo(i,2*mp1-1,k) 1 -zw(np1+mb,i)*ve(i,2*mp1-2,k) 523 continue if(mlat .eq. 0) go to 520 do 524 k=1,nt do 524 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+zw(np1+mb,imid)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zw(np1+mb,imid)*ve(imid,2*mp1-2,k) 524 continue 520 continue return c c case ityp=6 , v odd , w even c c case m=0 c 600 do 615 k=1,nt do 615 i=1,imid do 615 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-zv(np1,i)*we(i,1,k) 615 continue do 616 k=1,nt do 616 i=1,imm1 do 616 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+zv(np1,i)*vo(i,1,k) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 620 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 617 do 623 k=1,nt do 623 i=1,imm1 do 623 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,i)*vo(i,2*mp1-2,k) 1 +zw(np1+mb,i)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,i)*vo(i,2*mp1-1,k) 1 -zw(np1+mb,i)*we(i,2*mp1-2,k) 623 continue if(mlat .eq. 0) go to 617 do 624 k=1,nt do 624 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zw(np1+mb,imid)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-zw(np1+mb,imid)*we(imid,2*mp1-2,k) 624 continue 617 if(mp2 .gt. ndo2) go to 620 do 621 k=1,nt do 621 i=1,imm1 do 621 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,i)*we(i,2*mp1-2,k) 1 +zw(np1+mb,i)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,i)*we(i,2*mp1-1,k) 1 -zw(np1+mb,i)*vo(i,2*mp1-2,k) 621 continue if(mlat .eq. 0) go to 620 do 622 k=1,nt do 622 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,imid)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,imid)*we(imid,2*mp1-1,k) 622 continue 620 continue return c c case ityp=7 v odd, w even, and cr and ci equal zero c c case m=0 c 700 do 716 k=1,nt do 716 i=1,imm1 do 716 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+zv(np1,i)*vo(i,1,k) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 720 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 720 do 723 k=1,nt do 723 i=1,imm1 do 723 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zv(np1+mb,i)*vo(i,2*mp1-2,k) 1 +zw(np1+mb,i)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+zv(np1+mb,i)*vo(i,2*mp1-1,k) 1 -zw(np1+mb,i)*we(i,2*mp1-2,k) 723 continue if(mlat .eq. 0) go to 720 do 724 k=1,nt do 724 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+zw(np1+mb,imid)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-zw(np1+mb,imid)*we(imid,2*mp1-2,k) 724 continue 720 continue return c c case ityp=8 v odd, w even, and both br and bi equal zero c c case m=0 c 800 do 815 k=1,nt do 815 i=1,imid do 815 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-zv(np1,i)*we(i,1,k) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 820 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 820 do 821 k=1,nt do 821 i=1,imm1 do 821 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,i)*we(i,2*mp1-2,k) 1 +zw(np1+mb,i)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,i)*we(i,2*mp1-1,k) 1 -zw(np1+mb,i)*vo(i,2*mp1-2,k) 821 continue if(mlat .eq. 0) go to 820 do 822 k=1,nt do 822 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-zv(np1+mb,imid)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-zv(np1+mb,imid)*we(imid,2*mp1-1,k) 822 continue 820 continue return end c c dwork must be of length at least 2*(nlat+1) c subroutine vhaesi(nlat,nlon,wvhaes,lvhaes,work,lwork,dwork, + ldwork,ierror) dimension wvhaes(lvhaes),work(lwork) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 mmax = min0(nlat,(nlon+1)/2) imid = (nlat+1)/2 lzimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lvhaes .lt. lzimn+lzimn+nlon+15) return ierror = 4 labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lwork .lt. 5*nlat*imid+labc) return ierror = 5 if (ldwork .lt. 2*(nlat+1)) return ierror = 0 iw1 = 3*nlat*imid+1 idz = (mmax*(nlat+nlat-mmax+1))/2 CALL VEA1(NLAT,NLON,IMID,WVHAES,WVHAES(LZIMN+1),IDZ, + WORK,WORK(IW1),DWORK) call hrffti(nlon,wvhaes(2*lzimn+1)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vhagc.f c c this file contains code and documentation for subroutines c vhagc and vhagci c c ... files which must be loaded with vhagc.f c c sphcom.f, hrfft.f, gaqd.f c c c subroutine vhagc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvhagc,lvhagc,work,lwork,ierror) c c subroutine vhagc performs the vector spherical harmonic analysis c on the vector field (v,w) and stores the result in the arrays c br,bi,cr, and ci. v(i,j) and w(i,j) are the colatitudinal c (measured from the north pole) and east longitudinal components c respectively, located at the gaussian colatitude point theta(i) c and longitude phi(j) = (j-1)*2*pi/nlon. the spectral c representation of (v,w) is given at output parameters v,w in c subroutine vhsec. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 2 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 3 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 5 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 6 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 8 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c c nt the number of analyses. in the program that calls vhagc, c the arrays v,w,br,bi,cr, and ci can be three dimensional c in which case multiple analyses will be performed. c the third index is the analysis index which assumes the c values k=1,...,nt. for a single analysis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c v,w two or three dimensional arrays (see input parameter nt) c that contain the vector function to be analyzed. c v is the colatitudnal component and w is the east c longitudinal component. v(i,j),w(i,j) contain the c components at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges c are defined above at the input parameter ityp. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls vhagc. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls vhagc. jdvw must be at least nlon. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhagc. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhagc. ndab must be at c least nlat. c c wvhagc an array which must be initialized by subroutine vhagci. c once initialized, wvhagc can be used repeatedly by vhagc c as long as nlon and nlat remain unchanged. wvhagc must c not be altered between calls of vhagc. c c lvhagc the dimension of the array wvhagc as it appears in the c program that calls vhagc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhagc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+l2+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhagc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c 2*nlat*(2*nlon*nt+3*l2) c c if ityp .gt. 2 then lwork must be at least c c 2*l2*(2*nlon*nt+3*nlat) c c c c ************************************************************** c c output parameters c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c in the spectral representation of v(i,j) and w(i,j) given c in the discription of subroutine vhsec. br(mp1,np1), c bi(mp1,np1),cr(mp1,np1), and ci(mp1,np1) are computed c for mp1=1,...,mmax and np1=mp1,...,nlat except for np1=nlat c and odd mp1. mmax=min0(nlat,nlon/2) if nlon is even or c mmax=min0(nlat,(nlon+1)/2) if nlon is odd. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhagc c = 10 error in the specification of lwork c c **************************************************************** c c subroutine vhagci(nlat,nlon,wvhagc,lvhagc,dwork,ldwork,ierror) c c subroutine vhagci initializes the array wvhagc which can then be c used repeatedly by subroutine vhagc until nlat or nlon is changed. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lvhagc the dimension of the array wvhagc as it appears in the c program that calls vhagci. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhagc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+l2+15 c c c dwork a double precision work array that does not need to be saved c c ldwork the dimension of the array dwork as it appears in the c program that calls vhagci. ldwork must be at least c c 2*nlat*(nlat+1)+1 c c c ************************************************************** c c output parameters c c wvhagc an array which is initialized for use by subroutine vhagc. c once initialized, wvhagc can be used repeatedly by vhagc c as long as nlat and nlon remain unchanged. wvhagc must not c be altered between calls of vhagc. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lvhagc c = 4 error in the specification of lwork c subroutine vhagc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvhagc,lvhagc,work,lwork,ierror) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvhagc(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. + (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhagc .lt. 2*(lzz1+labc)+nlon+imid+15) return ierror = 10 if (ityp.le.2 .and. lwork.lt.nlat*(4*nlon*nt+6*imid)) return if (ityp.gt.2 .and. lwork.lt.imid*(4*nlon*nt+6*nlat)) return ierror = 0 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl iw5 = iw4+3*imid*nlat lwzvin = lzz1+labc jw1 = (nlat+1)/2+1 jw2 = jw1+lwzvin jw3 = jw2+lwzvin call vhagc1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab, +br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), +work(iw4),work(iw5),wvhagc,wvhagc(jw1),wvhagc(jw2),wvhagc(jw3)) return end subroutine vhagc1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab, +ndab,br,bi,cr,ci,idv,ve,vo,we,wo,vb,wb,wts,wvbin,wwbin,wrfft) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1), 3 wo(idv,nlon,1),wts(*),wvbin(1),wwbin(1),wrfft(1), 4 vb(imid,nlat,3),wb(imid,nlat,3) nlp1 = nlat+1 tsn = 2./nlon fsn = 4./nlon mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 if(ityp .gt. 2) go to 3 do 5 k=1,nt do 5 i=1,imm1 do 5 j=1,nlon ve(i,j,k) = tsn*(v(i,j,k)+v(nlp1-i,j,k)) vo(i,j,k) = tsn*(v(i,j,k)-v(nlp1-i,j,k)) we(i,j,k) = tsn*(w(i,j,k)+w(nlp1-i,j,k)) wo(i,j,k) = tsn*(w(i,j,k)-w(nlp1-i,j,k)) 5 continue go to 2 3 do 8 k=1,nt do 8 i=1,imm1 do 8 j=1,nlon ve(i,j,k) = fsn*v(i,j,k) vo(i,j,k) = fsn*v(i,j,k) we(i,j,k) = fsn*w(i,j,k) wo(i,j,k) = fsn*w(i,j,k) 8 continue 2 if(mlat .eq. 0) go to 7 do 6 k=1,nt do 6 j=1,nlon ve(imid,j,k) = tsn*v(imid,j,k) we(imid,j,k) = tsn*w(imid,j,k) 6 continue 7 do 9 k=1,nt call hrfftf(idv,nlon,ve(1,1,k),idv,wrfft,vb) call hrfftf(idv,nlon,we(1,1,k),idv,wrfft,vb) 9 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 if(ityp.eq.2 .or. ityp.eq.5 .or. ityp.eq.8) go to 11 do 10 k=1,nt do 10 mp1=1,mmax do 10 np1=mp1,nlat br(mp1,np1,k)=0. bi(mp1,np1,k)=0. 10 continue 11 if(ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) go to 13 do 12 k=1,nt do 12 mp1=1,mmax do 12 np1=mp1,nlat cr(mp1,np1,k)=0. ci(mp1,np1,k)=0. 12 continue 13 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 , no symmetries c 1 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 15 k=1,nt do 1015 i=1,imid tv = ve(i,1,k)*wts(i) tw = we(i,1,k)*wts(i) do 10015 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw 10015 continue 1015 continue 15 continue do 16 k=1,nt do 1016 i=1,imm1 tv = vo(i,1,k)*wts(i) tw = wo(i,1,k)*wts(i) do 10016 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw 10016 continue 1016 continue 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 20 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 17 do 23 k=1,nt do 1023 i=1,imm1 c c set temps to optimize quadrature c tvo1 = vo(i,2*mp1-1,k)*wts(i) tvo2 = vo(i,2*mp1-2,k)*wts(i) tve1 = ve(i,2*mp1-1,k)*wts(i) tve2 = ve(i,2*mp1-2,k)*wts(i) two1 = wo(i,2*mp1-1,k)*wts(i) two2 = wo(i,2*mp1-2,k)*wts(i) twe1 = we(i,2*mp1-1,k)*wts(i) twe2 = we(i,2*mp1-2,k)*wts(i) do 10023 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*tvo2 + +wb(i,np1,iw)*twe1 bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tvo1 + -wb(i,np1,iw)*twe2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*two2 + +wb(i,np1,iw)*tve1 ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*two1 + -wb(i,np1,iw)*tve2 10023 continue 1023 continue 23 continue if(mlat .eq. 0) go to 17 i = imid do 24 k=1,nt do 1024 np1=mp1,ndo1,2 br(mp1,np1,k)=br(mp1,np1,k)+wb(i,np1,iw)*we(i,2*mp1-1,k)*wts(i) bi(mp1,np1,k)=bi(mp1,np1,k)-wb(i,np1,iw)*we(i,2*mp1-2,k)*wts(i) cr(mp1,np1,k)=cr(mp1,np1,k)+wb(i,np1,iw)*ve(i,2*mp1-1,k)*wts(i) ci(mp1,np1,k)=ci(mp1,np1,k)-wb(i,np1,iw)*ve(i,2*mp1-2,k)*wts(i) 1024 continue 24 continue 17 if(mp2 .gt. ndo2) go to 20 do 21 k=1,nt do 1021 i=1,imm1 tvo1 = vo(i,2*mp1-1,k)*wts(i) tvo2 = vo(i,2*mp1-2,k)*wts(i) tve1 = ve(i,2*mp1-1,k)*wts(i) tve2 = ve(i,2*mp1-2,k)*wts(i) two1 = wo(i,2*mp1-1,k)*wts(i) two2 = wo(i,2*mp1-2,k)*wts(i) twe1 = we(i,2*mp1-1,k)*wts(i) twe2 = we(i,2*mp1-2,k)*wts(i) do 10021 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*tve2 1 +wb(i,np1,iw)*two1 bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tve1 1 -wb(i,np1,iw)*two2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*twe2 1 +wb(i,np1,iw)*tvo1 ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*twe1 1 -wb(i,np1,iw)*tvo2 10021 continue 1021 continue 21 continue if(mlat .eq. 0) go to 20 i = imid do 22 k=1,nt do 1022 np1=mp2,ndo2,2 br(mp1,np1,k)=br(mp1,np1,k)+vb(i,np1,iv)*ve(i,2*mp1-2,k)*wts(i) bi(mp1,np1,k)=bi(mp1,np1,k)+vb(i,np1,iv)*ve(i,2*mp1-1,k)*wts(i) cr(mp1,np1,k)=cr(mp1,np1,k)-vb(i,np1,iv)*we(i,2*mp1-2,k)*wts(i) ci(mp1,np1,k)=ci(mp1,np1,k)-vb(i,np1,iv)*we(i,2*mp1-1,k)*wts(i) 1022 continue 22 continue 20 continue return c c case ityp=1 , no symmetries but cr and ci equal zero c 100 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 115 k=1,nt do 115 i=1,imid tv = ve(i,1,k)*wts(i) do 115 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv 115 continue do 116 k=1,nt do 116 i=1,imm1 tv = vo(i,1,k)*wts(i) do 116 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 120 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 117 do 123 k=1,nt do 123 i=1,imm1 tvo1 = vo(i,2*mp1-1,k)*wts(i) tvo2 = vo(i,2*mp1-2,k)*wts(i) twe1 = we(i,2*mp1-1,k)*wts(i) twe2 = we(i,2*mp1-2,k)*wts(i) do 123 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*tvo2 + +wb(i,np1,iw)*twe1 bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tvo1 + -wb(i,np1,iw)*twe2 123 continue if(mlat .eq. 0) go to 117 i = imid do 124 k=1,nt do 124 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+wb(i,np1,iw)*we(i,2*mp1-1,k)*wts(i) bi(mp1,np1,k) = bi(mp1,np1,k)-wb(i,np1,iw)*we(i,2*mp1-2,k)*wts(i) 124 continue 117 if(mp2 .gt. ndo2) go to 120 do 121 k=1,nt do 121 i=1,imm1 tve1 = ve(i,2*mp1-1,k)*wts(i) tve2 = ve(i,2*mp1-2,k)*wts(i) two1 = wo(i,2*mp1-1,k)*wts(i) two2 = wo(i,2*mp1-2,k)*wts(i) do 121 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*tve2 + +wb(i,np1,iw)*two1 bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tve1 + -wb(i,np1,iw)*two2 121 continue if(mlat .eq. 0) go to 120 i = imid do 122 k=1,nt do 122 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*ve(i,2*mp1-2,k)*wts(i) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*ve(i,2*mp1-1,k)*wts(i) 122 continue 120 continue return c c case ityp=2 , no symmetries but br and bi equal zero c 200 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 215 k=1,nt do 215 i=1,imid tw = we(i,1,k)*wts(i) do 215 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw 215 continue do 216 k=1,nt do 216 i=1,imm1 tw = wo(i,1,k)*wts(i) do 216 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 220 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 217 do 223 k=1,nt do 223 i=1,imm1 tve1 = ve(i,2*mp1-1,k)*wts(i) tve2 = ve(i,2*mp1-2,k)*wts(i) two1 = wo(i,2*mp1-1,k)*wts(i) two2 = wo(i,2*mp1-2,k)*wts(i) do 223 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*two2 + +wb(i,np1,iw)*tve1 ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*two1 + -wb(i,np1,iw)*tve2 223 continue if(mlat .eq. 0) go to 217 i = imid do 224 k=1,nt do 224 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+wb(i,np1,iw)*ve(i,2*mp1-1,k)*wts(i) ci(mp1,np1,k) = ci(mp1,np1,k)-wb(i,np1,iw)*ve(i,2*mp1-2,k)*wts(i) 224 continue 217 if(mp2 .gt. ndo2) go to 220 do 221 k=1,nt do 221 i=1,imm1 twe1 = we(i,2*mp1-1,k)*wts(i) twe2 = we(i,2*mp1-2,k)*wts(i) tvo1 = vo(i,2*mp1-1,k)*wts(i) tvo2 = vo(i,2*mp1-2,k)*wts(i) do 221 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*twe2 + +wb(i,np1,iw)*tvo1 ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*twe1 + -wb(i,np1,iw)*tvo2 221 continue if(mlat .eq. 0) go to 220 i = imid do 222 k=1,nt do 222 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*we(i,2*mp1-2,k)*wts(i) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*we(i,2*mp1-1,k)*wts(i) 222 continue 220 continue return c c case ityp=3 , v even , w odd c 300 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 315 k=1,nt do 315 i=1,imid tv = ve(i,1,k)*wts(i) do 315 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv 315 continue do 316 k=1,nt do 316 i=1,imm1 tw = wo(i,1,k)*wts(i) do 316 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 320 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 317 do 323 k=1,nt do 323 i=1,imm1 two1 = wo(i,2*mp1-1,k)*wts(i) two2 = wo(i,2*mp1-2,k)*wts(i) tve1 = ve(i,2*mp1-1,k)*wts(i) tve2 = ve(i,2*mp1-2,k)*wts(i) do 323 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*two2 + +wb(i,np1,iw)*tve1 ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*two1 + -wb(i,np1,iw)*tve2 323 continue if(mlat .eq. 0) go to 317 i = imid do 324 k=1,nt do 324 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+wb(i,np1,iw)*ve(i,2*mp1-1,k)*wts(i) ci(mp1,np1,k) = ci(mp1,np1,k)-wb(i,np1,iw)*ve(i,2*mp1-2,k)*wts(i) 324 continue 317 if(mp2 .gt. ndo2) go to 320 do 321 k=1,nt do 321 i=1,imm1 two1 = wo(i,2*mp1-1,k)*wts(i) two2 = wo(i,2*mp1-2,k)*wts(i) tve1 = ve(i,2*mp1-1,k)*wts(i) tve2 = ve(i,2*mp1-2,k)*wts(i) do 321 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*tve2 + +wb(i,np1,iw)*two1 bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tve1 + -wb(i,np1,iw)*two2 321 continue if(mlat .eq. 0) go to 320 i = imid do 322 k=1,nt do 322 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*ve(i,2*mp1-2,k)*wts(i) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*ve(i,2*mp1-1,k)*wts(i) 322 continue 320 continue return c c case ityp=4 , v even, w odd, and cr and ci equal 0. c 400 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 415 k=1,nt do 415 i=1,imid tv = ve(i,1,k)*wts(i) do 415 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 420 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 420 do 421 k=1,nt do 421 i=1,imm1 two1 = wo(i,2*mp1-1,k)*wts(i) two2 = wo(i,2*mp1-2,k)*wts(i) tve1 = ve(i,2*mp1-1,k)*wts(i) tve2 = ve(i,2*mp1-2,k)*wts(i) do 421 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*tve2 + +wb(i,np1,iw)*two1 bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tve1 + -wb(i,np1,iw)*two2 421 continue if(mlat .eq. 0) go to 420 i = imid do 422 k=1,nt do 422 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*ve(i,2*mp1-2,k)*wts(i) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*ve(i,2*mp1-1,k)*wts(i) 422 continue 420 continue return c c case ityp=5 v even, w odd, and br and bi equal zero c 500 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 516 k=1,nt do 516 i=1,imm1 tw = wo(i,1,k)*wts(i) do 516 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 520 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 520 do 523 k=1,nt do 523 i=1,imm1 two1 = wo(i,2*mp1-1,k)*wts(i) two2 = wo(i,2*mp1-2,k)*wts(i) tve1 = ve(i,2*mp1-1,k)*wts(i) tve2 = ve(i,2*mp1-2,k)*wts(i) do 523 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*two2 + +wb(i,np1,iw)*tve1 ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*two1 + -wb(i,np1,iw)*tve2 523 continue if(mlat .eq. 0) go to 520 i = imid do 524 k=1,nt do 524 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+wb(i,np1,iw)*ve(i,2*mp1-1,k)*wts(i) ci(mp1,np1,k) = ci(mp1,np1,k)-wb(i,np1,iw)*ve(i,2*mp1-2,k)*wts(i) 524 continue 520 continue return c c case ityp=6 , v odd , w even c 600 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 615 k=1,nt do 615 i=1,imid tw = we(i,1,k)*wts(i) do 615 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw 615 continue do 616 k=1,nt do 616 i=1,imm1 tv = vo(i,1,k)*wts(i) do 616 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 620 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 617 do 623 k=1,nt do 623 i=1,imm1 twe1 = we(i,2*mp1-1,k)*wts(i) twe2 = we(i,2*mp1-2,k)*wts(i) tvo1 = vo(i,2*mp1-1,k)*wts(i) tvo2 = vo(i,2*mp1-2,k)*wts(i) do 623 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*tvo2 + +wb(i,np1,iw)*twe1 bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tvo1 + -wb(i,np1,iw)*twe2 623 continue if(mlat .eq. 0) go to 617 i = imid do 624 k=1,nt do 624 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+wb(i,np1,iw)*we(i,2*mp1-1,k)*wts(i) bi(mp1,np1,k) = bi(mp1,np1,k)-wb(i,np1,iw)*we(i,2*mp1-2,k)*wts(i) 624 continue 617 if(mp2 .gt. ndo2) go to 620 do 621 k=1,nt do 621 i=1,imm1 twe1 = we(i,2*mp1-1,k)*wts(i) twe2 = we(i,2*mp1-2,k)*wts(i) tvo1 = vo(i,2*mp1-1,k)*wts(i) tvo2 = vo(i,2*mp1-2,k)*wts(i) do 621 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*twe2 + +wb(i,np1,iw)*tvo1 ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*twe1 + -wb(i,np1,iw)*tvo2 621 continue if(mlat .eq. 0) go to 620 i = imid do 622 k=1,nt do 622 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*we(i,2*mp1-2,k)*wts(i) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*we(i,2*mp1-1,k)*wts(i) 622 continue 620 continue return c c case ityp=7 v odd, w even, and cr and ci equal zero c 700 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 716 k=1,nt do 716 i=1,imm1 tv = vo(i,1,k)*wts(i) do 716 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 720 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 720 do 723 k=1,nt do 723 i=1,imm1 twe1 = we(i,2*mp1-1,k)*wts(i) twe2 = we(i,2*mp1-2,k)*wts(i) tvo1 = vo(i,2*mp1-1,k)*wts(i) tvo2 = vo(i,2*mp1-2,k)*wts(i) do 723 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1,iv)*tvo2 + +wb(i,np1,iw)*twe1 bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tvo1 + -wb(i,np1,iw)*twe2 723 continue if(mlat .eq. 0) go to 720 i = imid do 724 k=1,nt do 724 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+wb(i,np1,iw)*we(i,2*mp1-1,k)*wts(i) bi(mp1,np1,k) = bi(mp1,np1,k)-wb(i,np1,iw)*we(i,2*mp1-2,k)*wts(i) 724 continue 720 continue return c c case ityp=8 v odd, w even, and both br and bi equal zero c 800 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m=0 c do 815 k=1,nt do 815 i=1,imid tw = we(i,1,k)*wts(i) do 815 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 820 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 820 do 821 k=1,nt do 821 i=1,imm1 twe1 = we(i,2*mp1-1,k)*wts(i) twe2 = we(i,2*mp1-2,k)*wts(i) tvo1 = vo(i,2*mp1-1,k)*wts(i) tvo2 = vo(i,2*mp1-2,k)*wts(i) do 821 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*twe2 + +wb(i,np1,iw)*tvo1 ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*twe1 + -wb(i,np1,iw)*tvo2 821 continue if(mlat .eq. 0) go to 820 i = imid do 822 k=1,nt do 822 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*we(i,2*mp1-2,k)*wts(i) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*we(i,2*mp1-1,k)*wts(i) 822 continue 820 continue return end subroutine vhagci(nlat,nlon,wvhagc,lvhagc,dwork,ldwork,ierror) dimension wvhagc(1) double precision dwork(*) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 imid = (nlat+1)/2 lzz1 = 2*nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 imid = (nlat+1)/2 if(lvhagc .lt. 2*(lzz1+labc)+nlon+imid+15) return ierror = 4 if (ldwork .lt. 2*nlat*(nlat+1)+1) return ierror = 0 c c compute gaussian points in first nlat+1 words of dwork c double precision c lwk = nlat*(nlat+2) jw1 = 1 c jw2 = jw1+nlat+nlat c jw3 = jw2+nlat+nlat jw2 = jw1+nlat jw3 = jw2+nlat call gaqd(nlat,dwork(jw1),dwork(jw2),dwork(jw3),lwk,ierror) imid = (nlat+1)/2 c c set first imid words of double precision weights in dwork c as single precision in first imid words of wvhagc c call setwts(imid,dwork(nlat+1),wvhagc) c c first nlat+1 words of dwork contain double theta c c iwrk = nlat+2 iwrk = (nlat+1)/2 +1 iw1 = imid+1 call vbgint (nlat,nlon,dwork,wvhagc(iw1),dwork(iwrk)) lwvbin = lzz1+labc iw2 = iw1+lwvbin call wbgint (nlat,nlon,dwork,wvhagc(iw2),dwork(iwrk)) iw3 = iw2+lwvbin call hrffti(nlon,wvhagc(iw3)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vhags.f c c this file contains code and documentation for subroutines c vhags and vhagsi c c ... files which must be loaded with vhags.f c c sphcom.f, hrfft.f, gaqd.f c c subroutine vhags(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvhags,lvhags,work,lwork,ierror) c c subroutine vhags performs the vector spherical harmonic analysis c on the vector field (v,w) and stores the result in the arrays c br, bi, cr, and ci. v(i,j) and w(i,j) are the colatitudinal c (measured from the north pole) and east longitudinal components c respectively, located at the gaussian colatitude point theta(i) c and longitude phi(j) = (j-1)*2*pi/nlon. the spectral c representation of (v,w) is given at output parameters v,w in c subroutine vhses. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 2 no symmetries exist about the equator. the analysis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 3 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 5 v is symmetric and w is antisymmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 6 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 8 v is antisymmetric and w is symmetric about the c equator. the analysis is performed on the northern c hemisphere only. i.e., if nlat is odd the analysis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the analysis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c c nt the number of analyses. in the program that calls vhags, c the arrays v,w,br,bi,cr, and ci can be three dimensional c in which case multiple analyses will be performed. c the third index is the analysis index which assumes the c values k=1,...,nt. for a single analysis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c v,w two or three dimensional arrays (see input parameter nt) c that contain the vector function to be analyzed. c v is the colatitudnal component and w is the east c longitudinal component. v(i,j),w(i,j) contain the c components at the gaussian colatitude point theta(i) c and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges c are defined above at the input parameter ityp. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls vhags. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls vhags. jdvw must be at least nlon. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhags. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhags. ndab must be at c least nlat. c c wvhags an array which must be initialized by subroutine vhgsi. c once initialized, wvhags can be used repeatedly by vhags c as long as nlon and nlat remain unchanged. wvhags must c not be altered between calls of vhags. c c lvhags the dimension of the array wvhags as it appears in the c program that calls vhags. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhags must be at least c c l1*l2(nlat+nlat-l1+1)+nlon+15 c c ??? (nlat+1)*(nlat+1)*nlat/2 + nlon + 15 c c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhags. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c the larger of the two quantities c c 3*nlat*(nlat+1)+2 (required by vhagsi) c c and c c (2*nt+1)*nlat*nlon c c if ityp .gt. 2 then lwork must be at least c the larger of the two quantities c c 3*nlat*(nlat+1)+2 (required by vhagsi) c c and c c (2*nt+1)*l2*nlon c c c ************************************************************** c c output parameters c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c in the spectral representation of v(i,j) and w(i,j) given c in the discription of subroutine vhses. br(mp1,np1), c bi(mp1,np1),cr(mp1,np1), and ci(mp1,np1) are computed c for mp1=1,...,mmax and np1=mp1,...,nlat except for np1=nlat c and odd mp1. mmax=min0(nlat,nlon/2) if nlon is even or c mmax=min0(nlat,(nlon+1)/2) if nlon is odd. c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhags c = 10 error in the specification of lwork c c c subroutine vhagsi(nlat,nlon,wvhags,lvhags,work,lwork,ierror) c c subroutine vhagsi initializes the array wvhags which can then be c used repeatedly by subroutine vhags until nlat or nlon is changed. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lvhags the dimension of the array wvhags as it appears in the c program that calls vhagsi. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhags must be at least c c 3*nlat*(nlat+1)+2 (required by vhagsi) c c dwork a double precision work space that does not need to be saved c c ldwork the dimension of the array dwork as it appears in the c program that calls vhagsi. ldwork must be at least c c (3*nlat*(nlat+3)+2)/2 c c ************************************************************** c c output parameters c c wvhags an array which is initialized for use by subroutine vhags. c once initialized, wvhags can be used repeatedly by vhags c as long as nlat and nlon remain unchanged. wvhags must not c be altered between calls of vhags. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lvhags c = 4 error in the specification of ldwork c subroutine vhags(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvhags,lvhags,work,lwork,ierror) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvhags(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lvhags .lt. lzimn+lzimn+nlon+15) return ierror = 10 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon if(lwork .lt. lnl+lnl+idv*nlon) return ierror = 0 ist = 0 if(ityp .le. 2) ist = imid c c set wvhags pointers c lmn = nlat*(nlat+1)/2 jw1 = 1 jw2 = jw1+imid*lmn jw3 = jw2+imid*lmn c c set work pointers c iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl call vhags1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab, + br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), + work(iw4),idz,wvhags(jw1),wvhags(jw2),wvhags(jw3)) return end subroutine vhags1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab, +ndab,br,bi,cr,ci,idv,ve,vo,we,wo,work,idz,vb,wb,wrfft) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1), 3 wo(idv,nlon,1),work(1), 4 vb(imid,1),wb(imid,1),wrfft(1) nlp1 = nlat+1 tsn = 2./nlon fsn = 4./nlon mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 if(ityp .gt. 2) go to 3 do 5 k=1,nt do 5 i=1,imm1 do 5 j=1,nlon ve(i,j,k) = tsn*(v(i,j,k)+v(nlp1-i,j,k)) vo(i,j,k) = tsn*(v(i,j,k)-v(nlp1-i,j,k)) we(i,j,k) = tsn*(w(i,j,k)+w(nlp1-i,j,k)) wo(i,j,k) = tsn*(w(i,j,k)-w(nlp1-i,j,k)) 5 continue go to 2 3 do 8 k=1,nt do 8 i=1,imm1 do 8 j=1,nlon ve(i,j,k) = fsn*v(i,j,k) vo(i,j,k) = fsn*v(i,j,k) we(i,j,k) = fsn*w(i,j,k) wo(i,j,k) = fsn*w(i,j,k) 8 continue 2 if(mlat .eq. 0) go to 7 do 6 k=1,nt do 6 j=1,nlon ve(imid,j,k) = tsn*v(imid,j,k) we(imid,j,k) = tsn*w(imid,j,k) 6 continue 7 do 9 k=1,nt call hrfftf(idv,nlon,ve(1,1,k),idv,wrfft,work) call hrfftf(idv,nlon,we(1,1,k),idv,wrfft,work) 9 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 if(ityp.eq.2 .or. ityp.eq.5 .or. ityp.eq.8) go to 11 do 10 k=1,nt do 10 mp1=1,mmax do 10 np1=mp1,nlat br(mp1,np1,k)=0. bi(mp1,np1,k)=0. 10 continue 11 if(ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) go to 13 do 12 k=1,nt do 12 mp1=1,mmax do 12 np1=mp1,nlat cr(mp1,np1,k)=0. ci(mp1,np1,k)=0. 12 continue 13 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 , no symmetries c c case m=0 c 1 do 15 k=1,nt do 15 i=1,imid do 15 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1)*ve(i,1,k) cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*we(i,1,k) 15 continue do 16 k=1,nt do 16 i=1,imm1 do 16 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1)*vo(i,1,k) cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*wo(i,1,k) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 20 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 17 do 23 k=1,nt do 23 i=1,imm1 do 23 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-2,k) 1 +wb(i,np1+mb)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-1,k) 1 -wb(i,np1+mb)*we(i,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-2,k) 1 +wb(i,np1+mb)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-1,k) 1 -wb(i,np1+mb)*ve(i,2*mp1-2,k) 23 continue if(mlat .eq. 0) go to 17 do 24 k=1,nt do 24 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+wb(imid,np1+mb)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-wb(imid,np1+mb)*we(imid,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)+wb(imid,np1+mb)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-wb(imid,np1+mb)*ve(imid,2*mp1-2,k) 24 continue 17 if(mp2 .gt. ndo2) go to 20 do 21 k=1,nt do 21 i=1,imm1 do 21 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-2,k) 1 +wb(i,np1+mb)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-1,k) 1 -wb(i,np1+mb)*wo(i,2*mp1-2,k) cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-2,k) 1 +wb(i,np1+mb)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-1,k) 1 -wb(i,np1+mb)*vo(i,2*mp1-2,k) 21 continue if(mlat .eq. 0) go to 20 do 22 k=1,nt do 22 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-1,k) cr(mp1,np1,k) = cr(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-1,k) 22 continue 20 continue return c c case ityp=1 , no symmetries but cr and ci equal zero c c case m=0 c 100 do 115 k=1,nt do 115 i=1,imid do 115 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1)*ve(i,1,k) 115 continue do 116 k=1,nt do 116 i=1,imm1 do 116 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1)*vo(i,1,k) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 120 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 117 do 123 k=1,nt do 123 i=1,imm1 do 123 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-2,k) 1 +wb(i,np1+mb)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-1,k) 1 -wb(i,np1+mb)*we(i,2*mp1-2,k) 123 continue if(mlat .eq. 0) go to 117 do 124 k=1,nt do 124 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+wb(imid,np1+mb)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-wb(imid,np1+mb)*we(imid,2*mp1-2,k) 124 continue 117 if(mp2 .gt. ndo2) go to 120 do 121 k=1,nt do 121 i=1,imm1 do 121 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-2,k) 1 +wb(i,np1+mb)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-1,k) 1 -wb(i,np1+mb)*wo(i,2*mp1-2,k) 121 continue if(mlat .eq. 0) go to 120 do 122 k=1,nt do 122 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-1,k) 122 continue 120 continue return c c case ityp=2 , no symmetries but br and bi equal zero c c case m=0 c 200 do 215 k=1,nt do 215 i=1,imid do 215 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*we(i,1,k) 215 continue do 216 k=1,nt do 216 i=1,imm1 do 216 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*wo(i,1,k) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 220 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 217 do 223 k=1,nt do 223 i=1,imm1 do 223 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-2,k) 1 +wb(i,np1+mb)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-1,k) 1 -wb(i,np1+mb)*ve(i,2*mp1-2,k) 223 continue if(mlat .eq. 0) go to 217 do 224 k=1,nt do 224 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+wb(imid,np1+mb)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-wb(imid,np1+mb)*ve(imid,2*mp1-2,k) 224 continue 217 if(mp2 .gt. ndo2) go to 220 do 221 k=1,nt do 221 i=1,imm1 do 221 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-2,k) 1 +wb(i,np1+mb)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-1,k) 1 -wb(i,np1+mb)*vo(i,2*mp1-2,k) 221 continue if(mlat .eq. 0) go to 220 do 222 k=1,nt do 222 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-1,k) 222 continue 220 continue return c c case ityp=3 , v even , w odd c c case m=0 c 300 do 315 k=1,nt do 315 i=1,imid do 315 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1)*ve(i,1,k) 315 continue do 316 k=1,nt do 316 i=1,imm1 do 316 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*wo(i,1,k) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 320 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 317 do 323 k=1,nt do 323 i=1,imm1 do 323 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-2,k) 1 +wb(i,np1+mb)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-1,k) 1 -wb(i,np1+mb)*ve(i,2*mp1-2,k) 323 continue if(mlat .eq. 0) go to 317 do 324 k=1,nt do 324 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+wb(imid,np1+mb)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-wb(imid,np1+mb)*ve(imid,2*mp1-2,k) 324 continue 317 if(mp2 .gt. ndo2) go to 320 do 321 k=1,nt do 321 i=1,imm1 do 321 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-2,k) 1 +wb(i,np1+mb)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-1,k) 1 -wb(i,np1+mb)*wo(i,2*mp1-2,k) 321 continue if(mlat .eq. 0) go to 320 do 322 k=1,nt do 322 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-1,k) 322 continue 320 continue return c c case ityp=4 , v even, w odd, and cr and ci equal 0. c c case m=0 c 400 do 415 k=1,nt do 415 i=1,imid do 415 np1=2,ndo2,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1)*ve(i,1,k) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 420 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 420 do 421 k=1,nt do 421 i=1,imm1 do 421 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-2,k) 1 +wb(i,np1+mb)*wo(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-1,k) 1 -wb(i,np1+mb)*wo(i,2*mp1-2,k) 421 continue if(mlat .eq. 0) go to 420 do 422 k=1,nt do 422 np1=mp2,ndo2,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-2,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-1,k) 422 continue 420 continue return c c case ityp=5 v even, w odd, and br and bi equal zero c c case m=0 c 500 do 516 k=1,nt do 516 i=1,imm1 do 516 np1=3,ndo1,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*wo(i,1,k) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 520 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 520 do 523 k=1,nt do 523 i=1,imm1 do 523 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-2,k) 1 +wb(i,np1+mb)*ve(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-1,k) 1 -wb(i,np1+mb)*ve(i,2*mp1-2,k) 523 continue if(mlat .eq. 0) go to 520 do 524 k=1,nt do 524 np1=mp1,ndo1,2 cr(mp1,np1,k) = cr(mp1,np1,k)+wb(imid,np1+mb)*ve(imid,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-wb(imid,np1+mb)*ve(imid,2*mp1-2,k) 524 continue 520 continue return c c case ityp=6 , v odd , w even c c case m=0 c 600 do 615 k=1,nt do 615 i=1,imid do 615 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*we(i,1,k) 615 continue do 616 k=1,nt do 616 i=1,imm1 do 616 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1)*vo(i,1,k) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 620 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 617 do 623 k=1,nt do 623 i=1,imm1 do 623 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-2,k) 1 +wb(i,np1+mb)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-1,k) 1 -wb(i,np1+mb)*we(i,2*mp1-2,k) 623 continue if(mlat .eq. 0) go to 617 do 624 k=1,nt do 624 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+wb(imid,np1+mb)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-wb(imid,np1+mb)*we(imid,2*mp1-2,k) 624 continue 617 if(mp2 .gt. ndo2) go to 620 do 621 k=1,nt do 621 i=1,imm1 do 621 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-2,k) 1 +wb(i,np1+mb)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-1,k) 1 -wb(i,np1+mb)*vo(i,2*mp1-2,k) 621 continue if(mlat .eq. 0) go to 620 do 622 k=1,nt do 622 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-1,k) 622 continue 620 continue return c c case ityp=7 v odd, w even, and cr and ci equal zero c c case m=0 c 700 do 716 k=1,nt do 716 i=1,imm1 do 716 np1=3,ndo1,2 br(1,np1,k) = br(1,np1,k)+vb(i,np1)*vo(i,1,k) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 720 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 720 do 723 k=1,nt do 723 i=1,imm1 do 723 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-2,k) 1 +wb(i,np1+mb)*we(i,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-1,k) 1 -wb(i,np1+mb)*we(i,2*mp1-2,k) 723 continue if(mlat .eq. 0) go to 720 do 724 k=1,nt do 724 np1=mp1,ndo1,2 br(mp1,np1,k) = br(mp1,np1,k)+wb(imid,np1+mb)*we(imid,2*mp1-1,k) bi(mp1,np1,k) = bi(mp1,np1,k)-wb(imid,np1+mb)*we(imid,2*mp1-2,k) 724 continue 720 continue return c c case ityp=8 v odd, w even, and both br and bi equal zero c c case m=0 c 800 do 815 k=1,nt do 815 i=1,imid do 815 np1=2,ndo2,2 cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*we(i,1,k) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) return do 820 mp1=2,mmax m = mp1-1 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 820 do 821 k=1,nt do 821 i=1,imm1 do 821 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-2,k) 1 +wb(i,np1+mb)*vo(i,2*mp1-1,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-1,k) 1 -wb(i,np1+mb)*vo(i,2*mp1-2,k) 821 continue if(mlat .eq. 0) go to 820 do 822 k=1,nt do 822 np1=mp2,ndo2,2 cr(mp1,np1,k) = cr(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-2,k) ci(mp1,np1,k) = ci(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-1,k) 822 continue 820 continue return end subroutine vhagsi(nlat,nlon,wvhags,lvhags,dwork,ldwork,ierror) dimension wvhags(lvhags) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 imid = (nlat+1)/2 lmn = (nlat*(nlat+1))/2 if(lvhags .lt. 2*(imid*lmn)+nlon+15) return ierror = 4 c if (ldwork.lt.nlat*(3*nlat+9)+2) return if (ldwork.lt.(nlat*(3*nlat+9)+2)/2) return ierror = 0 jw1 = 1 jw2 = jw1+imid*lmn jw3 = jw2+imid*lmn iw1 = 1 iw2 = iw1+nlat iw3 = iw2+nlat iw4 = iw3+3*imid*nlat c iw2 = iw1+nlat+nlat c iw3 = iw2+nlat+nlat c iw4 = iw3+6*imid*nlat call vhgai1(nlat,imid,wvhags(jw1),wvhags(jw2), +dwork(iw1),dwork(iw2),dwork(iw3),dwork(iw4)) call hrffti(nlon,wvhags(jw3)) return end subroutine vhftoff(nlon,nlat,uoff,ureg,wsav,nr, +nlat2,nlatp1,rlatu,rlonu,rlou,wrk) c c generate ureg from uoff (a vector component!) c implicit none integer nlon,nlat,nlat2,nlatp1,n2,nr,j,i,js,isav real uoff(nlon,nlat),ureg(nlon,nlatp1) real rlatu(nr,nlat2),rlonu(nlatp1,nlon),rlou(nlat,nlon) real wsav(*),wrk(*) isav = 4*nlat+17 n2 = (nlon+1)/2 c c execute full circle latitude shifts for nlon odd or even c if (2*n2 .gt. nlon) then c c odd number of longitudes c do i=1,nlat do j=1,nlon rlou(i,j) = uoff(j,i) end do end do c c half shift in longitude c call vhifth(nlat,nlon,rlou,wsav(isav),wrk) c c set full 2*nlat circles in rlatu using shifted values in rlonu c do j=1,n2-1 js = j+n2 do i=1,nlat rlatu(j,i) = uoff(j,i) rlatu(j,nlat+i) = -rlou(nlat+1-i,js) end do end do do j=n2,nlon js = j-n2+1 do i=1,nlat rlatu(j,i) = uoff(j,i) rlatu(j,nlat+i) = -rlou(nlat+1-i,js) end do end do c c shift the nlon rlat vectors one half latitude grid c call vhifth(nlon,nlat2,rlatu,wsav,wrk) c c set in ureg c do j=1,nlon do i=1,nlat+1 ureg(j,i) = rlatu(j,i) end do end do else c c even number of longitudes (no initial longitude shift necessary) c set full 2*nlat circles (over poles) for each longitude pair (j,js) c negating js vector side for periodicity c do j=1,n2 js = n2+j do i=1,nlat rlatu(j,i) = uoff(j,i) rlatu(j,nlat+i) =-uoff(js,nlatp1-i) end do end do c c shift the n2=(nlon+1)/2 rlat vectors one half latitude grid c call vhifth(n2,nlat2,rlatu,wsav,wrk) c c set ureg,vreg shifted in latitude c do j=1,n2 js = n2+j ureg(j,1) = rlatu(j,1) ureg(js,1) = -rlatu(j,1) do i=2,nlatp1 ureg(j,i) = rlatu(j,i) ureg(js,i) =-rlatu(j,nlat2-i+2) end do end do end if c c execute full circle longitude shift c do j=1,nlon do i=1,nlatp1 rlonu(i,j) = ureg(j,i) end do end do call vhifth(nlatp1,nlon,rlonu,wsav(isav),wrk) do j=1,nlon do i=1,nlatp1 ureg(j,i) = rlonu(i,j) end do end do end subroutine vhftreg(nlon,nlat,uoff,ureg,wsav,nr,nlat2, + nlatp1,rlatu,rlonu,rlou,wrk) c c generate uoff vector component from ureg c implicit none integer nlon,nlat,nlat2,nlatp1,n2,nr,j,i,js,isav real uoff(nlon,nlat),ureg(nlon,nlatp1) real rlatu(nr,nlat2),rlonu(nlatp1,nlon),rlou(nlat,nlon) real wsav(*),wrk(*) isav = 4*nlat+17 n2 = (nlon+1)/2 c c execute full circle latitude shifts for nlon odd or even c if (2*n2 .gt. nlon) then c c odd number of longitudes c do i=1,nlatp1 do j=1,nlon rlonu(i,j) = ureg(j,i) end do end do c c half shift in longitude in rlon c call vhifth(nlatp1,nlon,rlonu,wsav(isav),wrk) c c set full 2*nlat circles in rlat using shifted values in rlon c do j=1,n2 js = j+n2-1 rlatu(j,1) = ureg(j,1) do i=2,nlat rlatu(j,i) = ureg(j,i) rlatu(j,nlat+i) =-rlonu(nlat+2-i,js) end do rlatu(j,nlat+1) = ureg(j,nlat+1) end do do j=n2+1,nlon js = j-n2 rlatu(j,1) = ureg(j,1) do i=2,nlat rlatu(j,i) = ureg(j,i) rlatu(j,nlat+i) =-rlonu(nlat+2-i,js) end do rlatu(j,nlat+1) = ureg(j,nlat+1) end do c c shift the nlon rlat vectors one halflatitude grid c call vhifth(nlon,nlat2,rlatu,wsav,wrk) c c set values in uoff c do j=1,nlon do i=1,nlat uoff(j,i) = rlatu(j,i) end do end do else c c even number of longitudes (no initial longitude shift necessary) c set full 2*nlat circles (over poles) for each longitude pair (j,js) c do j=1,n2 js = n2+j rlatu(j,1) = ureg(j,1) do i=2,nlat rlatu(j,i) = ureg(j,i) rlatu(j,nlat+i) =-ureg(js,nlat+2-i) end do rlatu(j,nlat+1) = ureg(j,nlat+1) end do c c shift the n2=(nlon+1)/2 rlat vectors one half latitude grid c call vhifth(n2,nlat2,rlatu,wsav,wrk) c c set values in uoff c do j=1,n2 js = n2+j do i=1,nlat uoff(j,i) = rlatu(j,i) uoff(js,i) =-rlatu(j,nlat2+1-i) end do end do end if c c execute full circle longitude shift for all latitude circles c do j=1,nlon do i=1,nlat rlou(i,j) = uoff(j,i) end do end do call vhifth(nlat,nlon,rlou,wsav(isav),wrk) do j=1,nlon do i=1,nlat uoff(j,i) = rlou(i,j) end do end do end subroutine vhgai1(nlat,imid,vb,wb,dthet,dwts,dpbar,work) dimension vb(imid,*),wb(imid,*) double precision abel,bbel,cbel,ssqr2,dcf double precision dpbar(imid,nlat,3), dthet(*),dwts(*),work(*) c lwk = 4*nlat*(nlat+2) lwk = nlat*(nlat+2) call gaqd(nlat,dthet,dwts,dpbar,lwk,ierror) c c compute associated legendre functions c c compute m=n=0 legendre polynomials for all theta(i) c ssqr2 = 1./dsqrt(2.d0) do 90 i=1,imid dpbar(i,1,1) = ssqr2 vb(i,1) = 0. wb(i,1) = 0. 90 continue c c main loop for remaining vb, and wb c do 100 n=1,nlat-1 nm = mod(n-2,3)+1 nz = mod(n-1,3)+1 np = mod(n,3)+1 c c compute dpbar for m=0 c call dnlfk(0,n,work) mn = indx(0,n,nlat) do 105 i=1,imid call dnlft(0,n,dthet(i),work,dpbar(i,1,np)) 105 continue c c compute dpbar for m=1 c call dnlfk(1,n,work) mn = indx(1,n,nlat) do 106 i=1,imid call dnlft(1,n,dthet(i),work,dpbar(i,2,np)) c pbar(i,mn) = dpbar(i,2,np) 106 continue 104 continue c c compute and store dpbar for m=2,n c if(n.lt.2) go to 108 do 107 m=2,n abel = dsqrt(dble(float((2*n+1)*(m+n-2)*(m+n-3)))/ 1 dble(float((2*n-3)*(m+n-1)*(m+n)))) bbel = dsqrt(dble(float((2*n+1)*(n-m-1)*(n-m)))/ 1 dble(float((2*n-3)*(m+n-1)*(m+n)))) cbel = dsqrt(dble(float((n-m+1)*(n-m+2)))/ 1 dble(float((m+n-1)*(m+n)))) id = indx(m,n,nlat) if (m.ge.n-1) go to 102 do 103 i=1,imid dpbar(i,m+1,np) = abel*dpbar(i,m-1,nm)+bbel*dpbar(i,m+1,nm) 1 -cbel*dpbar(i,m-1,np) 103 continue go to 107 102 do 101 i=1,imid dpbar(i,m+1,np) = abel*dpbar(i,m-1,nm)-cbel*dpbar(i,m-1,np) 101 continue 107 continue c c compute the derivative of the functions c 108 continue ix = indx(0,n,nlat) iy = indx(n,n,nlat) do 125 i=1,imid vb(i,ix) = -dpbar(i,2,np)*dwts(i) vb(i,iy) = dpbar(i,n,np)/dsqrt(dble(float(2*(n+1))))*dwts(i) 125 continue c if(n.eq.1) go to 131 dcf = dsqrt(dble(float(4*n*(n+1)))) do 130 m=1,n-1 ix = indx(m,n,nlat) abel = dsqrt(dble(float((n+m)*(n-m+1))))/dcf bbel = dsqrt(dble(float((n-m)*(n+m+1))))/dcf do 130 i=1,imid vb(i,ix) = (abel*dpbar(i,m,np)-bbel*dpbar(i,m+2,np))*dwts(i) 130 continue c c compute the vector harmonic w(theta) = m*pbar/cos(theta) c c set wb=0 for m=0 c 131 continue ix = indx(0,n,nlat) do 220 i=1,imid wb(i,ix) = 0.d0 220 continue c c compute wb for m=1,n c dcf = dsqrt(dble(float(n+n+1))/dble(float(4*n*(n+1)*(n+n-1)))) do 230 m=1,n ix = indx(m,n,nlat) abel = dcf*dsqrt(dble(float((n+m)*(n+m-1)))) bbel = dcf*dsqrt(dble(float((n-m)*(n-m-1)))) if(m.ge.n-1) go to 231 do 229 i=1,imid wb(i,ix) = (abel*dpbar(i,m,nz) + bbel*dpbar(i,m+2,nz))*dwts(i) 229 continue go to 230 231 do 228 i=1,imid wb(i,ix) = abel*dpbar(i,m,nz)*dwts(i) 228 continue 230 continue 100 continue return end subroutine vhgsi1(nlat,imid,vb,wb,dthet,dwts,dpbar,work) dimension vb(imid,*),wb(imid,*) double precision abel,bbel,cbel,ssqr2,dcf double precision dthet(*),dwts(*),dpbar(imid,nlat,3),work(*) c c compute gauss points and weights c use dpbar (length 3*nnlat*(nnlat+1)) as work space for gaqd c lwk = nlat*(nlat+2) call gaqd(nlat,dthet,dwts,dpbar,lwk,ierror) c c compute associated legendre functions c c compute m=n=0 legendre polynomials for all theta(i) c ssqr2 = 1./dsqrt(2.d0) do 90 i=1,imid dpbar(i,1,1) = ssqr2 vb(i,1) = 0. wb(i,1) = 0. 90 continue c c main loop for remaining vb, and wb c do 100 n=1,nlat-1 nm = mod(n-2,3)+1 nz = mod(n-1,3)+1 np = mod(n,3)+1 c c compute dpbar for m=0 c call dnlfk(0,n,work) mn = indx(0,n,nlat) do 105 i=1,imid call dnlft(0,n,dthet(i),work,dpbar(i,1,np)) c pbar(i,mn) = dpbar(i,1,np) 105 continue c c compute dpbar for m=1 c call dnlfk(1,n,work) mn = indx(1,n,nlat) do 106 i=1,imid call dnlft(1,n,dthet(i),work,dpbar(i,2,np)) c pbar(i,mn) = dpbar(i,2,np) 106 continue 104 continue c c compute and store dpbar for m=2,n c if(n.lt.2) go to 108 do 107 m=2,n abel = dsqrt(dble(float((2*n+1)*(m+n-2)*(m+n-3)))/ 1 dble(float((2*n-3)*(m+n-1)*(m+n)))) bbel = dsqrt(dble(float((2*n+1)*(n-m-1)*(n-m)))/ 1 dble(float((2*n-3)*(m+n-1)*(m+n)))) cbel = dsqrt(dble(float((n-m+1)*(n-m+2)))/ 1 dble(float((m+n-1)*(m+n)))) id = indx(m,n,nlat) if (m.ge.n-1) go to 102 do 103 i=1,imid dpbar(i,m+1,np) = abel*dpbar(i,m-1,nm)+bbel*dpbar(i,m+1,nm) 1 -cbel*dpbar(i,m-1,np) c pbar(i,id) = dpbar(i,m+1,np) 103 continue go to 107 102 do 101 i=1,imid dpbar(i,m+1,np) = abel*dpbar(i,m-1,nm)-cbel*dpbar(i,m-1,np) c pbar(i,id) = dpbar(i,m+1,np) 101 continue 107 continue c c compute the derivative of the functions c 108 ix = indx(0,n,nlat) iy = indx(n,n,nlat) do 125 i=1,imid vb(i,ix) = -dpbar(i,2,np) vb(i,iy) = dpbar(i,n,np)/dsqrt(dble(float(2*(n+1)))) 125 continue c if(n.eq.1) go to 131 dcf = dsqrt(dble(float(4*n*(n+1)))) do 130 m=1,n-1 ix = indx(m,n,nlat) abel = dsqrt(dble(float((n+m)*(n-m+1))))/dcf bbel = dsqrt(dble(float((n-m)*(n+m+1))))/dcf do 130 i=1,imid vb(i,ix) = abel*dpbar(i,m,np)-bbel*dpbar(i,m+2,np) 130 continue c c compute the vector harmonic w(theta) = m*pbar/cos(theta) c c set wb=0 for m=0 c 131 ix = indx(0,n,nlat) do 220 i=1,imid wb(i,ix) = 0.d0 220 continue c c compute wb for m=1,n c dcf = dsqrt(dble(float(n+n+1))/dble(float(4*n*(n+1)*(n+n-1)))) do 230 m=1,n ix = indx(m,n,nlat) abel = dcf*dsqrt(dble(float((n+m)*(n+m-1)))) bbel = dcf*dsqrt(dble(float((n-m)*(n-m-1)))) if(m.ge.n-1) go to 231 do 229 i=1,imid wb(i,ix) = abel*dpbar(i,m,nz) + bbel*dpbar(i,m+2,nz) 229 continue go to 230 231 do 228 i=1,imid wb(i,ix) = abel*dpbar(i,m,nz) 228 continue 230 continue 100 continue return end subroutine vhifth(m,n,r,wsav,work) implicit none integer m,n,n2,k,l real r(m,n),wsav(*),work(*),r2km2,r2km1 n2 = (n+1)/2 c c compute fourier coefficients for r on shifted grid c call hrfftf(m,n,r,m,wsav(n+2),work) do l=1,m do k=2,n2 r2km2 = r(l,k+k-2) r2km1 = r(l,k+k-1) r(l,k+k-2) = r2km2*wsav(n2+k) - r2km1*wsav(k) r(l,k+k-1) = r2km2*wsav(k) + r2km1*wsav(n2+k) end do end do c c shift r with fourier synthesis and normalization c call hrfftb(m,n,r,m,wsav(n+2),work) do l=1,m do k=1,n r(l,k) = r(l,k)/n end do end do return end subroutine vhifthi(n,dp,wsav) c c initialize wsav for subroutine vhifth c implicit none integer n,n2,k real wsav(*),dp n2 = (n+1)/2 do k=2,n2 wsav(k) = sin((k-1)*dp) wsav(k+n2) = cos((k-1)*dp) end do call hrffti(n,wsav(n+2)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vhsec.f c c this file contains code and documentation for subroutines c vhsec and vhseci c c ... files which must be loaded with vhsec.f c c sphcom.f, hrfft.f c c subroutine vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvhsec,lvhsec,work,lwork,ierror) c c subroutine vhsec performs the vector spherical harmonic synthesis c of the arrays br, bi, cr, and ci and stores the result in the c arrays v and w. v(i,j) and w(i,j) are the colatitudinal c (measured from the north pole) and east longitudinal components c respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the spectral c representation of (v,w) is given below at output parameters v,w. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 2 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 3 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 5 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 6 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 8 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c c nt the number of syntheses. in the program that calls vhsec, c the arrays v,w,br,bi,cr, and ci can be three dimensional c in which case multiple syntheses will be performed. c the third index is the synthesis index which assumes the c values k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls vhsec. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls vhsec. jdvw must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c in the spectral representation of v(i,j) and w(i,j) given c below at the discription of output parameters v and w. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhsec. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhsec. ndab must be at c least nlat. c c wvhsec an array which must be initialized by subroutine vhseci. c once initialized, wvhsec can be used repeatedly by vhsec c as long as nlon and nlat remain unchanged. wvhsec must c not be altered between calls of vhsec. c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls vhsec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhsec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)) c c if ityp .gt. 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) c c ************************************************************** c c output parameters c c v,w two or three dimensional arrays (see input parameter nt) c in which the synthesis is stored. v is the colatitudinal c component and w is the east longitudinal component. c v(i,j),w(i,j) contain the components at colatitude c theta(i) = (i-1)*pi/(nlat-1) and longitude phi(j) = c (j-1)*2*pi/nlon. the index ranges are defined above at c the input parameter ityp. v and w are computed from the c formulas given below c c c define c c 1. theta is colatitude and phi is east longitude c c 2. the normalized associated legendre funnctions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m) c /(2*factorial(n+m)))*sin(theta)**m/(2**n* c factorial(n)) times the (n+m)th derivative c of (x**2-1)**n with respect to x=cos(theta) c c 3. vbar(m,n,theta) = the derivative of pbar(m,n,theta) with c respect to theta divided by the square c root of n(n+1). c c vbar(m,n,theta) is more easily computed in the form c c vbar(m,n,theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1,n,theta) c -sqrt((n-m)*(n+m+1))*pbar(m+1,n,theta))/(2*sqrt(n*(n+1))) c c 4. wbar(m,n,theta) = m/(sin(theta))*pbar(m,n,theta) divided c by the square root of n(n+1). c c wbar(m,n,theta) is more easily computed in the form c c wbar(m,n,theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1)) c *pbar(m-1,n-1,theta)+sqrt((n-m)*(n-m-1))*pbar(m+1,n-1,theta)) c /(2*sqrt(n*(n+1))) c c c the colatitudnal dependence of the normalized surface vector c spherical harmonics are defined by c c 5. bbar(m,n,theta) = (vbar(m,n,theta),i*wbar(m,n,theta)) c c 6. cbar(m,n,theta) = (i*wbar(m,n,theta),-vbar(m,n,theta)) c c c the coordinate to index mappings c c 7. theta(i) = (i-1)*pi/(nlat-1) and phi(j) = (j-1)*2*pi/nlon c c c the maximum (plus one) longitudinal wave number c c 8. mmax = min0(nlat,nlon/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c if we further define the output vector as c c 9. h(i,j) = (v(i,j),w(i,j)) c c and the complex coefficients c c 10. b(m,n) = cmplx(br(m+1,n+1),bi(m+1,n+1)) c c 11. c(m,n) = cmplx(cr(m+1,n+1),ci(m+1,n+1)) c c c then for i=1,...,nlat and j=1,...,nlon c c the expansion for real h(i,j) takes the form c c h(i,j) = the sum from n=1 to n=nlat-1 of the real part of c c .5*(b(0,n)*bbar(0,n,theta(i))+c(0,n)*cbar(0,n,theta(i))) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c b(m,n)*bbar(m,n,theta(i))*exp(i*m*phi(j)) c +c(m,n)*cbar(m,n,theta(i))*exp(i*m*phi(j)) c c ************************************************************* c c in terms of real variables this expansion takes the form c c for i=1,...,nlat and j=1,...,nlon c c v(i,j) = the sum from n=1 to n=nlat-1 of c c .5*br(1,n+1)*vbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c (br(m+1,n+1)*vbar(m,n,theta(i))-ci(m+1,n+1)*wbar(m,n,theta(i))) c *cos(m*phi(j)) c -(bi(m+1,n+1)*vbar(m,n,theta(i))+cr(m+1,n+1)*wbar(m,n,theta(i))) c *sin(m*phi(j)) c c and for i=1,...,nlat and j=1,...,nlon c c w(i,j) = the sum from n=1 to n=nlat-1 of c c -.5*cr(1,n+1)*vbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c -(cr(m+1,n+1)*vbar(m,n,theta(i))+bi(m+1,n+1)*wbar(m,n,theta(i))) c *cos(m*phi(j)) c +(ci(m+1,n+1)*vbar(m,n,theta(i))-br(m+1,n+1)*wbar(m,n,theta(i))) c *sin(m*phi(j)) c c c br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are c assumed zero for m even. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsec c = 10 error in the specification of lwork c c c ******************************************************************* c c subroutine vhseci(nlat,nlon,wvhsec,lvhsec,dwork,ldwork,ierror) c c subroutine vhseci initializes the array wvhsec which can then be c used repeatedly by subroutine vhsec until nlat or nlon is changed. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls vhsec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls vhsec. ldwork must be at least c 2*(nlat+2) c c ************************************************************** c c output parameters c c wvhsec an array which is initialized for use by subroutine vhsec. c once initialized, wvhsec can be used repeatedly by vhsec c as long as nlat or nlon remain unchanged. wvhsec must not c be altered between calls of vhsec. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lvhsec c = 4 error in the specification of ldwork c c c subroutine vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvhsec,lvhsec,work,lwork,ierror) c dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvhsec(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhsec .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 if(ityp .le. 2 .and. 1 lwork .lt. nlat*(2*nt*nlon+max0(6*imid,nlon))) return if(ityp .gt. 2 .and. 1 lwork .lt. imid*(2*nt*nlon+max0(6*nlat,nlon))) return ierror = 0 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl iw5 = iw4+3*imid*nlat lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 lwzvin = lzz1+labc jw1 = lwzvin+1 jw2 = jw1+lwzvin call vhsec1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),work(iw5),wvhsec,wvhsec(jw1),wvhsec(jw2)) return end subroutine vhsec1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab, 1 ndab,br,bi,cr,ci,idv,ve,vo,we,wo,vb,wb,wvbin,wwbin,wrfft) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1), 3 wo(idv,nlon,1),wvbin(1),wwbin(1),wrfft(1), 4 vb(imid,nlat,3),wb(imid,nlat,3) nlp1 = nlat+1 mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 do 10 k=1,nt do 10 j=1,nlon do 10 i=1,idv ve(i,j,k) = 0. we(i,j,k) = 0. 10 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 18 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 no symmetries c 1 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 15 k=1,nt do 15 np1=2,ndo2,2 do 15 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1,iv) we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 15 continue do 16 k=1,nt do 16 np1=3,ndo1,2 do 16 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1,iv) wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 30 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 26 do 25 k=1,nt do 24 np1=mp1,ndo1,2 do 23 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 23 continue if(mlat .eq. 0) go to 24 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 24 continue 25 continue 26 if(mp2 .gt. ndo2) go to 30 do 29 k=1,nt do 28 np1=mp2,ndo2,2 do 27 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 27 continue if(mlat .eq. 0) go to 28 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 28 continue 29 continue 30 continue go to 950 c c case ityp=1 no symmetries, cr and ci equal zero c 100 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 115 k=1,nt do 115 np1=2,ndo2,2 do 115 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 115 continue do 116 k=1,nt do 116 np1=3,ndo1,2 do 116 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 130 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 126 do 125 k=1,nt do 124 np1=mp1,ndo1,2 do 123 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 123 continue if(mlat .eq. 0) go to 124 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 124 continue 125 continue 126 if(mp2 .gt. ndo2) go to 130 do 129 k=1,nt do 128 np1=mp2,ndo2,2 do 127 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 127 continue if(mlat .eq. 0) go to 128 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 128 continue 129 continue 130 continue go to 950 c c case ityp=2 no symmetries, br and bi are equal to zero c 200 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 215 k=1,nt do 215 np1=2,ndo2,2 do 215 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 215 continue do 216 k=1,nt do 216 np1=3,ndo1,2 do 216 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 230 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 226 do 225 k=1,nt do 224 np1=mp1,ndo1,2 do 223 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 223 continue if(mlat .eq. 0) go to 224 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 224 continue 225 continue 226 if(mp2 .gt. ndo2) go to 230 do 229 k=1,nt do 228 np1=mp2,ndo2,2 do 227 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 227 continue if(mlat .eq. 0) go to 228 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 228 continue 229 continue 230 continue go to 950 c c case ityp=3 v even, w odd c 300 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 315 k=1,nt do 315 np1=2,ndo2,2 do 315 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 315 continue do 316 k=1,nt do 316 np1=3,ndo1,2 do 316 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 330 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 326 do 325 k=1,nt do 324 np1=mp1,ndo1,2 do 323 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 323 continue if(mlat .eq. 0) go to 324 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 324 continue 325 continue 326 if(mp2 .gt. ndo2) go to 330 do 329 k=1,nt do 328 np1=mp2,ndo2,2 do 327 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 327 continue if(mlat .eq. 0) go to 328 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 328 continue 329 continue 330 continue go to 950 c c case ityp=4 v even, w odd, and both cr and ci equal zero c 400 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 415 k=1,nt do 415 np1=2,ndo2,2 do 415 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 430 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 430 do 429 k=1,nt do 428 np1=mp2,ndo2,2 do 427 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 427 continue if(mlat .eq. 0) go to 428 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 428 continue 429 continue 430 continue go to 950 c c case ityp=5 v even, w odd, br and bi equal zero c 500 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 516 k=1,nt do 516 np1=3,ndo1,2 do 516 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 530 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 530 do 525 k=1,nt do 524 np1=mp1,ndo1,2 do 523 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 523 continue if(mlat .eq. 0) go to 524 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 524 continue 525 continue 530 continue go to 950 c c case ityp=6 v odd , w even c 600 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 615 k=1,nt do 615 np1=2,ndo2,2 do 615 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 615 continue do 616 k=1,nt do 616 np1=3,ndo1,2 do 616 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 630 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 626 do 625 k=1,nt do 624 np1=mp1,ndo1,2 do 623 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 623 continue if(mlat .eq. 0) go to 624 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 624 continue 625 continue 626 if(mp2 .gt. ndo2) go to 630 do 629 k=1,nt do 628 np1=mp2,ndo2,2 do 627 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 627 continue if(mlat .eq. 0) go to 628 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 628 continue 629 continue 630 continue go to 950 c c case ityp=7 v odd, w even cr and ci equal zero c 700 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 716 k=1,nt do 716 np1=3,ndo1,2 do 716 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 730 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 730 do 725 k=1,nt do 724 np1=mp1,ndo1,2 do 723 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 723 continue if(mlat .eq. 0) go to 724 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 724 continue 725 continue 730 continue go to 950 c c case ityp=8 v odd, w even br and bi equal zero c 800 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 815 k=1,nt do 815 np1=2,ndo2,2 do 815 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 830 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 830 do 829 k=1,nt do 828 np1=mp2,ndo2,2 do 827 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 827 continue if(mlat .eq. 0) go to 828 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 828 continue 829 continue 830 continue 950 do 14 k=1,nt call hrfftb(idv,nlon,ve(1,1,k),idv,wrfft,vb) call hrfftb(idv,nlon,we(1,1,k),idv,wrfft,vb) 14 continue if(ityp .gt. 2) go to 12 do 60 k=1,nt do 60 j=1,nlon do 60 i=1,imm1 v(i,j,k) = .5*(ve(i,j,k)+vo(i,j,k)) w(i,j,k) = .5*(we(i,j,k)+wo(i,j,k)) v(nlp1-i,j,k) = .5*(ve(i,j,k)-vo(i,j,k)) w(nlp1-i,j,k) = .5*(we(i,j,k)-wo(i,j,k)) 60 continue go to 13 12 do 11 k=1,nt do 11 j=1,nlon do 11 i=1,imm1 v(i,j,k) = .5*ve(i,j,k) w(i,j,k) = .5*we(i,j,k) 11 continue 13 if(mlat .eq. 0) return do 65 k=1,nt do 65 j=1,nlon v(imid,j,k) = .5*ve(imid,j,k) w(imid,j,k) = .5*we(imid,j,k) 65 continue return end subroutine vhseci(nlat,nlon,wvhsec,lvhsec,dwork,ldwork,ierror) dimension wvhsec(lvhsec) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 imid = (nlat+1)/2 lzz1 = 2*nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhsec .lt. 2*(lzz1+labc)+nlon+15) return ierror = 4 if(ldwork .lt. 2*nlat+2) return ierror = 0 call vbinit (nlat,nlon,wvhsec,dwork) lwvbin = lzz1+labc iw1 = lwvbin+1 call wbinit (nlat,nlon,wvhsec(iw1),dwork) iw2 = iw1+lwvbin call hrffti(nlon,wvhsec(iw2)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vhses.f c c this file contains code and documentation for subroutines c vhses and vhsesi c c ... files which must be loaded with vhses.f c c sphcom.f, hrfft.f c c c subroutine vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvhses,lvhses,work,lwork,ierror) c c subroutine vhses performs the vector spherical harmonic synthesis c of the arrays br, bi, cr, and ci and stores the result in the c arrays v and w. v(i,j) and w(i,j) are the colatitudinal c (measured from the north pole) and east longitudinal components c respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the spectral c representation of (v,w) is given below at output parameters v,w. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 2 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 3 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 5 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 6 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 8 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c c nt the number of syntheses. in the program that calls vhses, c the arrays v,w,br,bi,cr, and ci can be three dimensional c in which case multiple syntheses will be performed. c the third index is the synthesis index which assumes the c values k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls vhaes. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls vhses. jdvw must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c in the spectral representation of v(i,j) and w(i,j) given c below at the discription of output parameters v and w. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhses. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhses. ndab must be at c least nlat. c c wvhses an array which must be initialized by subroutine vhsesi. c once initialized, wvhses can be used repeatedly by vhses c as long as nlon and nlat remain unchanged. wvhses must c not be altered between calls of vhses. c c lvhses the dimension of the array wvhses as it appears in the c program that calls vhses. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhses must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhses. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c (2*nt+1)*nlat*nlon c c if ityp .gt. 2 then lwork must be at least c c (2*nt+1)*l2*nlon c c ************************************************************** c c output parameters c c v,w two or three dimensional arrays (see input parameter nt) c in which the synthesis is stored. v is the colatitudinal c component and w is the east longitudinal component. c v(i,j),w(i,j) contain the components at colatitude c theta(i) = (i-1)*pi/(nlat-1) and longitude phi(j) = c (j-1)*2*pi/nlon. the index ranges are defined above at c the input parameter ityp. v and w are computed from the c formulas given below c c c define c c 1. theta is colatitude and phi is east longitude c c 2. the normalized associated legendre funnctions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m) c /(2*factorial(n+m)))*sin(theta)**m/(2**n* c factorial(n)) times the (n+m)th derivative c of (x**2-1)**n with respect to x=cos(theta) c c 3. vbar(m,n,theta) = the derivative of pbar(m,n,theta) with c respect to theta divided by the square c root of n(n+1). c c vbar(m,n,theta) is more easily computed in the form c c vbar(m,n,theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1,n,theta) c -sqrt((n-m)*(n+m+1))*pbar(m+1,n,theta))/(2*sqrt(n*(n+1))) c c 4. wbar(m,n,theta) = m/(sin(theta))*pbar(m,n,theta) divided c by the square root of n(n+1). c c wbar(m,n,theta) is more easily computed in the form c c wbar(m,n,theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1)) c *pbar(m-1,n-1,theta)+sqrt((n-m)*(n-m-1))*pbar(m+1,n-1,theta)) c /(2*sqrt(n*(n+1))) c c c the colatitudnal dependence of the normalized surface vector c spherical harmonics are defined by c c 5. bbar(m,n,theta) = (vbar(m,n,theta),i*wbar(m,n,theta)) c c 6. cbar(m,n,theta) = (i*wbar(m,n,theta),-vbar(m,n,theta)) c c c the coordinate to index mappings c c 7. theta(i) = (i-1)*pi/(nlat-1) and phi(j) = (j-1)*2*pi/nlon c c c the maximum (plus one) longitudinal wave number c c 8. mmax = min0(nlat,nlon/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c if we further define the output vector as c c 9. h(i,j) = (v(i,j),w(i,j)) c c and the complex coefficients c c 10. b(m,n) = cmplx(br(m+1,n+1),bi(m+1,n+1)) c c 11. c(m,n) = cmplx(cr(m+1,n+1),ci(m+1,n+1)) c c c then for i=1,...,nlat and j=1,...,nlon c c the expansion for real h(i,j) takes the form c c h(i,j) = the sum from n=1 to n=nlat-1 of the real part of c c .5*(b(0,n)*bbar(0,n,theta(i))+c(0,n)*cbar(0,n,theta(i))) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c b(m,n)*bbar(m,n,theta(i))*exp(i*m*phi(j)) c +c(m,n)*cbar(m,n,theta(i))*exp(i*m*phi(j)) c c ************************************************************* c c in terms of real variables this expansion takes the form c c for i=1,...,nlat and j=1,...,nlon c c v(i,j) = the sum from n=1 to n=nlat-1 of c c .5*br(1,n+1)*vbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c (br(m+1,n+1)*vbar(m,n,theta(i))-ci(m+1,n+1)*wbar(m,n,theta(i))) c *cos(m*phi(j)) c -(bi(m+1,n+1)*vbar(m,n,theta(i))+cr(m+1,n+1)*wbar(m,n,theta(i))) c *sin(m*phi(j)) c c and for i=1,...,nlat and j=1,...,nlon c c w(i,j) = the sum from n=1 to n=nlat-1 of c c -.5*cr(1,n+1)*vbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c -(cr(m+1,n+1)*vbar(m,n,theta(i))+bi(m+1,n+1)*wbar(m,n,theta(i))) c *cos(m*phi(j)) c +(ci(m+1,n+1)*vbar(m,n,theta(i))-br(m+1,n+1)*wbar(m,n,theta(i))) c *sin(m*phi(j)) c c c br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are c assumed zero for m even. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhses c = 10 error in the specification of lwork c c ************************************************************ c c subroutine vhsesi(nlat,nlon,wvhses,lvhses,work,lwork,dwork, c + ldwork,ierror) c c subroutine vhsesi initializes the array wvhses which can then be c used repeatedly by subroutine vhses until nlat or nlon is changed. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lvhses the dimension of the array wvhses as it appears in the c program that calls vhses. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhses must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhses. lwork must be at least c c 3*(max0(l1-2,0)*(nlat+nlat-l1-1))/2+5*l2*nlat c c dwork an unsaved double precision work space c c ldwork the length of the array dwork as it appears in the c program that calls vhsesi. ldwork must be at least c 2*(nlat+1) c c c ************************************************************** c c output parameters c c wvhses an array which is initialized for use by subroutine vhses. c once initialized, wvhses can be used repeatedly by vhses c as long as nlat or nlon remain unchanged. wvhses must not c be altered between calls of vhses. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lvhses c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c c ***************************************** subroutine vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mdab,ndab,wvhses,lvhses,work,lwork,ierror) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvhses(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lvhses .lt. lzimn+lzimn+nlon+15) return ierror = 10 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon if(lwork .lt. lnl+lnl+idv*nlon) return ierror = 0 ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl jw1 = lzimn+1 jw2 = jw1+lzimn call vhses1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),idz,wvhses,wvhses(jw1),wvhses(jw2)) return end subroutine vhses1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab, 1 ndab,br,bi,cr,ci,idv,ve,vo,we,wo,work,idz,vb,wb,wrfft) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1), 3 wo(idv,nlon,1),work(1),wrfft(1), 4 vb(imid,1),wb(imid,1) nlp1 = nlat+1 mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 do 10 k=1,nt do 10 j=1,nlon do 10 i=1,idv ve(i,j,k) = 0. we(i,j,k) = 0. 10 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 18 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 no symmetries c c case m = 0 c 1 do 15 k=1,nt do 15 np1=2,ndo2,2 do 15 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1) we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1) 15 continue do 16 k=1,nt do 16 np1=3,ndo1,2 do 16 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1) wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 30 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 26 do 25 k=1,nt do 24 np1=mp1,ndo1,2 mn = mb+np1 do 23 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 23 continue if(mlat .eq. 0) go to 24 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 24 continue 25 continue 26 if(mp2 .gt. ndo2) go to 30 do 29 k=1,nt do 28 np1=mp2,ndo2,2 mn = mb+np1 do 27 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 27 continue if(mlat .eq. 0) go to 28 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 28 continue 29 continue 30 continue go to 950 c c case ityp=1 no symmetries, cr and ci equal zero c c case m = 0 c 100 continue do 115 k=1,nt do 115 np1=2,ndo2,2 do 115 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1) 115 continue do 116 k=1,nt do 116 np1=3,ndo1,2 do 116 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 130 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 126 do 125 k=1,nt do 124 np1=mp1,ndo1,2 mn = mb+np1 do 123 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 123 continue if(mlat .eq. 0) go to 124 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 124 continue 125 continue 126 if(mp2 .gt. ndo2) go to 130 do 129 k=1,nt do 128 np1=mp2,ndo2,2 mn = mb+np1 do 127 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 127 continue if(mlat .eq. 0) go to 128 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 128 continue 129 continue 130 continue go to 950 c c case ityp=2 no symmetries, br and bi are equal to zero c c case m = 0 c 200 do 215 k=1,nt do 215 np1=2,ndo2,2 do 215 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1) 215 continue do 216 k=1,nt do 216 np1=3,ndo1,2 do 216 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 230 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 226 do 225 k=1,nt do 224 np1=mp1,ndo1,2 mn = mb+np1 do 223 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 223 continue if(mlat .eq. 0) go to 224 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 224 continue 225 continue 226 if(mp2 .gt. ndo2) go to 230 do 229 k=1,nt do 228 np1=mp2,ndo2,2 mn = mb+np1 do 227 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 227 continue if(mlat .eq. 0) go to 228 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 228 continue 229 continue 230 continue go to 950 c c case ityp=3 v even, w odd c c case m = 0 c 300 do 315 k=1,nt do 315 np1=2,ndo2,2 do 315 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1) 315 continue do 316 k=1,nt do 316 np1=3,ndo1,2 do 316 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 330 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 326 do 325 k=1,nt do 324 np1=mp1,ndo1,2 mn = mb+np1 do 323 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 323 continue if(mlat .eq. 0) go to 324 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 324 continue 325 continue 326 if(mp2 .gt. ndo2) go to 330 do 329 k=1,nt do 328 np1=mp2,ndo2,2 mn = mb+np1 do 327 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 327 continue if(mlat .eq. 0) go to 328 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 328 continue 329 continue 330 continue go to 950 c c case ityp=4 v even, w odd, and both cr and ci equal zero c c case m = 0 c 400 do 415 k=1,nt do 415 np1=2,ndo2,2 do 415 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 430 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 430 do 429 k=1,nt do 428 np1=mp2,ndo2,2 mn = mb+np1 do 427 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 427 continue if(mlat .eq. 0) go to 428 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 428 continue 429 continue 430 continue go to 950 c c case ityp=5 v even, w odd, br and bi equal zero c c case m = 0 c 500 do 516 k=1,nt do 516 np1=3,ndo1,2 do 516 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 530 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 530 do 525 k=1,nt do 524 np1=mp1,ndo1,2 mn = mb+np1 do 523 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 523 continue if(mlat .eq. 0) go to 524 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 524 continue 525 continue 530 continue go to 950 c c case ityp=6 v odd , w even c c case m = 0 c 600 do 615 k=1,nt do 615 np1=2,ndo2,2 do 615 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1) 615 continue do 616 k=1,nt do 616 np1=3,ndo1,2 do 616 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 630 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 626 do 625 k=1,nt do 624 np1=mp1,ndo1,2 mn = mb+np1 do 623 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 623 continue if(mlat .eq. 0) go to 624 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 624 continue 625 continue 626 if(mp2 .gt. ndo2) go to 630 do 629 k=1,nt do 628 np1=mp2,ndo2,2 mn = mb+np1 do 627 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 627 continue if(mlat .eq. 0) go to 628 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 628 continue 629 continue 630 continue go to 950 c c case ityp=7 v odd, w even cr and ci equal zero c c case m = 0 c 700 do 716 k=1,nt do 716 np1=3,ndo1,2 do 716 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 730 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 730 do 725 k=1,nt do 724 np1=mp1,ndo1,2 mn = mb+np1 do 723 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 723 continue if(mlat .eq. 0) go to 724 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 724 continue 725 continue 730 continue go to 950 c c case ityp=8 v odd, w even br and bi equal zero c c case m = 0 c 800 do 815 k=1,nt do 815 np1=2,ndo2,2 do 815 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 830 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 830 do 829 k=1,nt do 828 np1=mp2,ndo2,2 mn = mb+np1 do 827 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 827 continue if(mlat .eq. 0) go to 828 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 828 continue 829 continue 830 continue 950 do 14 k=1,nt call hrfftb(idv,nlon,ve(1,1,k),idv,wrfft,work) call hrfftb(idv,nlon,we(1,1,k),idv,wrfft,work) 14 continue if(ityp .gt. 2) go to 12 do 60 k=1,nt do 60 j=1,nlon do 60 i=1,imm1 v(i,j,k) = .5*(ve(i,j,k)+vo(i,j,k)) w(i,j,k) = .5*(we(i,j,k)+wo(i,j,k)) v(nlp1-i,j,k) = .5*(ve(i,j,k)-vo(i,j,k)) w(nlp1-i,j,k) = .5*(we(i,j,k)-wo(i,j,k)) 60 continue go to 13 12 do 11 k=1,nt do 11 j=1,nlon do 11 i=1,imm1 v(i,j,k) = .5*ve(i,j,k) w(i,j,k) = .5*we(i,j,k) 11 continue 13 if(mlat .eq. 0) return do 65 k=1,nt do 65 j=1,nlon v(imid,j,k) = .5*ve(imid,j,k) w(imid,j,k) = .5*we(imid,j,k) 65 continue return end subroutine vhsesi(nlat,nlon,wvhses,lvhses,work,lwork,dwork, + ldwork,ierror) dimension wvhses(lvhses),work(lwork) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 mmax = min0(nlat,(nlon+1)/2) imid = (nlat+1)/2 lzimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lvhses .lt. lzimn+lzimn+nlon+15) return ierror = 4 labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lwork .lt. 5*nlat*imid+labc) return ierror = 5 if (ldwork .lt. 2*(nlat+1)) return ierror = 0 iw1 = 3*nlat*imid+1 idz = (mmax*(nlat+nlat-mmax+1))/2 call ves1(nlat,nlon,imid,wvhses,wvhses(lzimn+1),idz,work, 1 work(iw1),dwork) call hrffti(nlon,wvhses(2*lzimn+1)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vhsgc.f c c this file contains code and documentation for subroutines c vhsgc and vhsgci c c ... files which must be loaded with vhsgc.f c c sphcom.f, hrfft.f, gaqd.f c c subroutine vhsgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvhsgc,lvhsgc,work,lwork,ierror) c c subroutine vhsgc performs the vector spherical harmonic synthesis c of the arrays br, bi, cr, and ci and stores the result in the c arrays v and w. v(i,j) and w(i,j) are the colatitudinal c (measured from the north pole) and east longitudinal components c respectively, located at the gaussian colatitude point theta(i) c and longitude phi(j) = (j-1)*2*pi/nlon. the spectral c representation of (v,w) is given below at output parameters v,w. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 2 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 3 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 5 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 6 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 8 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c c nt the number of syntheses. in the program that calls vhsgc, c the arrays v,w,br,bi,cr, and ci can be three dimensional c in which case multiple syntheses will be performed. c the third index is the synthesis index which assumes the c values k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls vhsgc. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls vhsgc. jdvw must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c in the spectral representation of v(i,j) and w(i,j) given c below at the discription of output parameters v and w. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhsgc. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhsgc. ndab must be at c least nlat. c c wvhsgc an array which must be initialized by subroutine vhsgci. c once initialized, wvhsgc can be used repeatedly by vhsgc c as long as nlon and nlat remain unchanged. wvhsgc must c not be altered between calls of vhsgc. c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls vhsgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhsgc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)) c c if ityp .gt. 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) c c ************************************************************** c c output parameters c c v,w two or three dimensional arrays (see input parameter nt) c in which the synthesis is stored. v is the colatitudinal c component and w is the east longitudinal component. c v(i,j),w(i,j) contain the components at the gaussian c colatitude theta(i) and longitude phi(j) = (j-1)*2*pi/nlon. c the index ranges are defined above at the input parameter c ityp. v and w are computed from the formulas given below. c c define c c 1. theta is colatitude and phi is east longitude c c 2. the normalized associated legendre funnctions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m) c /(2*factorial(n+m)))*sin(theta)**m/(2**n* c factorial(n)) times the (n+m)th derivative c of (x**2-1)**n with respect to x=cos(theta) c c 3. vbar(m,n,theta) = the derivative of pbar(m,n,theta) with c respect to theta divided by the square c root of n(n+1). c c vbar(m,n,theta) is more easily computed in the form c c vbar(m,n,theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1,n,theta) c -sqrt((n-m)*(n+m+1))*pbar(m+1,n,theta))/(2*sqrt(n*(n+1))) c c 4. wbar(m,n,theta) = m/(sin(theta))*pbar(m,n,theta) divided c by the square root of n(n+1). c c wbar(m,n,theta) is more easily computed in the form c c wbar(m,n,theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1)) c *pbar(m-1,n-1,theta)+sqrt((n-m)*(n-m-1))*pbar(m+1,n-1,theta)) c /(2*sqrt(n*(n+1))) c c c the colatitudnal dependence of the normalized surface vector c spherical harmonics are defined by c c 5. bbar(m,n,theta) = (vbar(m,n,theta),i*wbar(m,n,theta)) c c 6. cbar(m,n,theta) = (i*wbar(m,n,theta),-vbar(m,n,theta)) c c c the coordinate to index mappings c c 7. phi(j) = (j-1)*2*pi/nlon, theta(i) is the i(th) guassian c point (see nlat as an input parameter). c c the maximum (plus one) longitudinal wave number c c 8. mmax = min0(nlat,nlon/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c if we further define the output vector as c c 9. h(i,j) = (v(i,j),w(i,j)) c c and the complex coefficients c c 10. b(m,n) = cmplx(br(m+1,n+1),bi(m+1,n+1)) c c 11. c(m,n) = cmplx(cr(m+1,n+1),ci(m+1,n+1)) c c c then for i=1,...,nlat and j=1,...,nlon c c the expansion for real h(i,j) takes the form c c h(i,j) = the sum from n=1 to n=nlat-1 of the real part of c c .5*(b(0,n)*bbar(0,n,theta(i))+c(0,n)*cbar(0,n,theta(i))) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c b(m,n)*bbar(m,n,theta(i))*exp(i*m*phi(j)) c +c(m,n)*cbar(m,n,theta(i))*exp(i*m*phi(j)) c c ************************************************************* c c in terms of real variables this expansion takes the form c c for i=1,...,nlat and j=1,...,nlon c c v(i,j) = the sum from n=1 to n=nlat-1 of c c .5*br(1,n+1)*vbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c (br(m+1,n+1)*vbar(m,n,theta(i))-ci(m+1,n+1)*wbar(m,n,theta(i))) c *cos(m*phi(j)) c -(bi(m+1,n+1)*vbar(m,n,theta(i))+cr(m+1,n+1)*wbar(m,n,theta(i))) c *sin(m*phi(j)) c c and for i=1,...,nlat and j=1,...,nlon c c w(i,j) = the sum from n=1 to n=nlat-1 of c c -.5*cr(1,n+1)*vbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c -(cr(m+1,n+1)*vbar(m,n,theta(i))+bi(m+1,n+1)*wbar(m,n,theta(i))) c *cos(m*phi(j)) c +(ci(m+1,n+1)*vbar(m,n,theta(i))-br(m+1,n+1)*wbar(m,n,theta(i))) c *sin(m*phi(j)) c c c br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are c assumed zero for m even. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgc c = 10 error in the specification of lwork c c************************************************************* c c subroutine vhsgci(nlat,nlon,wvhsgc,lvhsgc,dwork,ldwork,ierror) c c subroutine vhsgci initializes the array wvhsgc which can then be c used repeatedly by subroutine vhsgc until nlat or nlon is changed. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls vhsgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 c c work a double precision work space that does not need to be saved c c ldwork the dimension of the array dwork as it appears in the c program that calls vhsgsi. ldwork must be at least c c 2*nlat*(nlat+1)+1 c c ************************************************************** c c output parameters c c wvhsgc an array which is initialized for use by subroutine vhsgc. c once initialized, wvhsgc can be used repeatedly by vhsgc c as long as nlat and nlon remain unchanged. wvhsgc must not c be altered between calls of vhsgc. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lvhsgc c = 4 error in the specification of ldwork c subroutine vhsgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mdab,ndab,wvhsgc,lvhsgc,work,lwork,ierror) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvhsgc(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c c check save work space length c l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin = 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 if (lvhsgc .lt. lwmin) return c if(lvhsgc .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 if(ityp .le. 2 .and. 1 lwork .lt. nlat*(2*nt*nlon+max0(6*imid,nlon))) return if(ityp .gt. 2 .and. 1 lwork .lt. imid*(2*nt*nlon+max0(6*nlat,nlon))) return ierror = 0 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl iw5 = iw4+3*imid*nlat lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 lwzvin = lzz1+labc jw1 = lwzvin+1 jw2 = jw1+lwzvin call vhsgc1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),work(iw5),wvhsgc,wvhsgc(jw1),wvhsgc(jw2)) return end subroutine vhsgc1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab, 1 ndab,br,bi,cr,ci,idv,ve,vo,we,wo,vb,wb,wvbin,wwbin,wrfft) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1), 3 wo(idv,nlon,1),wvbin(1),wwbin(1),wrfft(1), 4 vb(imid,nlat,3),wb(imid,nlat,3) nlp1 = nlat+1 mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 do 10 k=1,nt do 10 j=1,nlon do 10 i=1,idv ve(i,j,k) = 0. we(i,j,k) = 0. 10 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 18 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 no symmetries c 1 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 15 k=1,nt do 15 np1=2,ndo2,2 do 15 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1,iv) we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 15 continue do 16 k=1,nt do 16 np1=3,ndo1,2 do 16 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1,iv) wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 30 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 26 do 25 k=1,nt do 24 np1=mp1,ndo1,2 do 23 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 23 continue if(mlat .eq. 0) go to 24 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 24 continue 25 continue 26 if(mp2 .gt. ndo2) go to 30 do 29 k=1,nt do 28 np1=mp2,ndo2,2 do 27 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 27 continue if(mlat .eq. 0) go to 28 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 28 continue 29 continue 30 continue go to 950 c c case ityp=1 no symmetries, cr and ci equal zero c 100 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 115 k=1,nt do 115 np1=2,ndo2,2 do 115 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 115 continue do 116 k=1,nt do 116 np1=3,ndo1,2 do 116 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 130 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 126 do 125 k=1,nt do 124 np1=mp1,ndo1,2 do 123 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 123 continue if(mlat .eq. 0) go to 124 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 124 continue 125 continue 126 if(mp2 .gt. ndo2) go to 130 do 129 k=1,nt do 128 np1=mp2,ndo2,2 do 127 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 127 continue if(mlat .eq. 0) go to 128 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 128 continue 129 continue 130 continue go to 950 c c case ityp=2 no symmetries, br and bi are equal to zero c 200 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 215 k=1,nt do 215 np1=2,ndo2,2 do 215 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 215 continue do 216 k=1,nt do 216 np1=3,ndo1,2 do 216 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 230 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 226 do 225 k=1,nt do 224 np1=mp1,ndo1,2 do 223 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 223 continue if(mlat .eq. 0) go to 224 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 224 continue 225 continue 226 if(mp2 .gt. ndo2) go to 230 do 229 k=1,nt do 228 np1=mp2,ndo2,2 do 227 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 227 continue if(mlat .eq. 0) go to 228 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 228 continue 229 continue 230 continue go to 950 c c case ityp=3 v even, w odd c 300 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 315 k=1,nt do 315 np1=2,ndo2,2 do 315 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 315 continue do 316 k=1,nt do 316 np1=3,ndo1,2 do 316 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 330 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 326 do 325 k=1,nt do 324 np1=mp1,ndo1,2 do 323 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 323 continue if(mlat .eq. 0) go to 324 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 324 continue 325 continue 326 if(mp2 .gt. ndo2) go to 330 do 329 k=1,nt do 328 np1=mp2,ndo2,2 do 327 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 327 continue if(mlat .eq. 0) go to 328 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 328 continue 329 continue 330 continue go to 950 c c case ityp=4 v even, w odd, and both cr and ci equal zero c 400 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 415 k=1,nt do 415 np1=2,ndo2,2 do 415 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 430 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 430 do 429 k=1,nt do 428 np1=mp2,ndo2,2 do 427 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 427 continue if(mlat .eq. 0) go to 428 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 428 continue 429 continue 430 continue go to 950 c c case ityp=5 v even, w odd, br and bi equal zero c 500 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 516 k=1,nt do 516 np1=3,ndo1,2 do 516 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 530 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 530 do 525 k=1,nt do 524 np1=mp1,ndo1,2 do 523 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 523 continue if(mlat .eq. 0) go to 524 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 524 continue 525 continue 530 continue go to 950 c c case ityp=6 v odd , w even c 600 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 615 k=1,nt do 615 np1=2,ndo2,2 do 615 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 615 continue do 616 k=1,nt do 616 np1=3,ndo1,2 do 616 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 630 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 626 do 625 k=1,nt do 624 np1=mp1,ndo1,2 do 623 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 623 continue if(mlat .eq. 0) go to 624 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 624 continue 625 continue 626 if(mp2 .gt. ndo2) go to 630 do 629 k=1,nt do 628 np1=mp2,ndo2,2 do 627 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 627 continue if(mlat .eq. 0) go to 628 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 628 continue 629 continue 630 continue go to 950 c c case ityp=7 v odd, w even cr and ci equal zero c 700 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 716 k=1,nt do 716 np1=3,ndo1,2 do 716 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 730 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 730 do 725 k=1,nt do 724 np1=mp1,ndo1,2 do 723 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 723 continue if(mlat .eq. 0) go to 724 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 724 continue 725 continue 730 continue go to 950 c c case ityp=8 v odd, w even br and bi equal zero c 800 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 815 k=1,nt do 815 np1=2,ndo2,2 do 815 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 830 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 830 do 829 k=1,nt do 828 np1=mp2,ndo2,2 do 827 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 827 continue if(mlat .eq. 0) go to 828 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 828 continue 829 continue 830 continue 950 do 14 k=1,nt call hrfftb(idv,nlon,ve(1,1,k),idv,wrfft,vb) call hrfftb(idv,nlon,we(1,1,k),idv,wrfft,vb) 14 continue if(ityp .gt. 2) go to 12 do 60 k=1,nt do 60 j=1,nlon do 60 i=1,imm1 v(i,j,k) = .5*(ve(i,j,k)+vo(i,j,k)) w(i,j,k) = .5*(we(i,j,k)+wo(i,j,k)) v(nlp1-i,j,k) = .5*(ve(i,j,k)-vo(i,j,k)) w(nlp1-i,j,k) = .5*(we(i,j,k)-wo(i,j,k)) 60 continue go to 13 12 do 11 k=1,nt do 11 j=1,nlon do 11 i=1,imm1 v(i,j,k) = .5*ve(i,j,k) w(i,j,k) = .5*we(i,j,k) 11 continue 13 if(mlat .eq. 0) return do 65 k=1,nt do 65 j=1,nlon v(imid,j,k) = .5*ve(imid,j,k) w(imid,j,k) = .5*we(imid,j,k) 65 continue return end subroutine vhsgci(nlat,nlon,wvhsgc,lvhsgc,dwork,ldwork,ierror) dimension wvhsgc(lvhsgc) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 imid = (nlat+1)/2 lzz1 = 2*nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lvhsgc .lt. 2*(lzz1+labc)+nlon+15) return ierror = 4 if (ldwork .lt. 2*nlat*(nlat+1)+1) return ierror = 0 c c compute gaussian points in first nlat+1 words of dwork c double precision c c lwk = 2*nlat*(nlat+2) jw1 = 1 jw2 = jw1+nlat jw3 = jw2+nlat c jw2 = jw1+nlat+nlat c jw3 = jw2+nlat+nlat call gaqd(nlat,dwork(jw1),dwork(jw2),dwork(jw3),ldwork,ierror) c iwrk = nlat+2 iwrk = (nlat+1)/2 + 1 call vbgint (nlat,nlon,dwork,wvhsgc,dwork(iwrk)) lwvbin = lzz1+labc iw1 = lwvbin+1 call wbgint (nlat,nlon,dwork,wvhsgc(iw1),dwork(iwrk)) iw2 = iw1+lwvbin call hrffti(nlon,wvhsgc(iw2)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vhsgs.f c c this file contains code and documentation for subroutines c vhsgs and vhsgsi c c ... files which must be loaded with vhsgs.f c c sphcom.f, hrfft.f, gaqd.f c c subroutine vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvhsgs,lvhsgs,work,lwork,ierror) c c c subroutine vhsgs performs the vector spherical harmonic synthesis c of the arrays br, bi, cr, and ci and stores the result in the c arrays v and w. the synthesis is performed on an equally spaced c longitude grid and a gaussian colatitude grid (measured from c the north pole). v(i,j) and w(i,j) are the colatitudinal and c east longitudinal components respectively, located at the i(th) c colatitude gaussian point (see nlat below) and longitude c phi(j) = (j-1)*2*pi/nlon. the spectral respresentation of (v,w) c is given below at output parameters v,w. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 2 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. on the c arrays v(i,j),w(i,j) for i=1,...,nlat and c j=1,...,nlon. the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 3 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 5 v is symmetric and w is antisymmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c = 6 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the coefficients cr and ci are zero. c c = 8 v is antisymmetric and w is symmetric about the c equator. the synthesis is performed on the northern c hemisphere only. i.e., if nlat is odd the synthesis c is performed on the arrays v(i,j),w(i,j) for c i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the synthesis is performed on the the arrays c v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c the divergence of (v,w) is zero. i.e., c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the coefficients br and bi are zero. c c c nt the number of syntheses. in the program that calls vhsgs, c the arrays v,w,br,bi,cr, and ci can be three dimensional c in which case multiple syntheses will be performed. c the third index is the synthesis index which assumes the c values k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c idvw the first dimension of the arrays v,w as it appears in c the program that calls vhags. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays v,w as it appears in c the program that calls vhsgs. jdvw must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c in the spectral representation of v(i,j) and w(i,j) given c below at the discription of output parameters v and w. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhsgs. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vhsgs. ndab must be at c least nlat. c c wvhsgs an array which must be initialized by subroutine vhsgsi. c once initialized, wvhsgs can be used repeatedly by vhsgs c as long as nlon and nlat remain unchanged. wvhsgs must c not be altered between calls of vhsgs. c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls vhsgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgs must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vhsgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c (2*nt+1)*nlat*nlon c c if ityp .gt. 2 then lwork must be at least c c (2*nt+1)*l2*nlon c c ************************************************************** c c output parameters c c v,w two or three dimensional arrays (see input parameter nt) c in which the synthesis is stored. v is the colatitudinal c component and w is the east longitudinal component. c v(i,j),w(i,j) contain the components at the guassian colatitude c point theta(i) and longitude phi(j) = (j-1)*2*pi/nlon. c the index ranges are defined above at the input parameter c ityp. v and w are computed from the formulas given below. c c c define c c 1. theta is colatitude and phi is east longitude c c 2. the normalized associated legendre funnctions c c pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m) c /(2*factorial(n+m)))*sin(theta)**m/(2**n* c factorial(n)) times the (n+m)th derivative c of (x**2-1)**n with respect to x=cos(theta) c c 3. vbar(m,n,theta) = the derivative of pbar(m,n,theta) with c respect to theta divided by the square c root of n(n+1). c c vbar(m,n,theta) is more easily computed in the form c c vbar(m,n,theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1,n,theta) c -sqrt((n-m)*(n+m+1))*pbar(m+1,n,theta))/(2*sqrt(n*(n+1))) c c 4. wbar(m,n,theta) = m/(sin(theta))*pbar(m,n,theta) divided c by the square root of n(n+1). c c wbar(m,n,theta) is more easily computed in the form c c wbar(m,n,theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1)) c *pbar(m-1,n-1,theta)+sqrt((n-m)*(n-m-1))*pbar(m+1,n-1,theta)) c /(2*sqrt(n*(n+1))) c c c the colatitudnal dependence of the normalized surface vector c spherical harmonics are defined by c c 5. bbar(m,n,theta) = (vbar(m,n,theta),i*wbar(m,n,theta)) c c 6. cbar(m,n,theta) = (i*wbar(m,n,theta),-vbar(m,n,theta)) c c c the coordinate to index mappings c c 7. theta(i) = i(th) gaussian grid point and phi(j) = (j-1)*2*pi/nlon c c c the maximum (plus one) longitudinal wave number c c 8. mmax = min0(nlat,nlon/2) if nlon is even or c mmax = min0(nlat,(nlon+1)/2) if nlon is odd. c c if we further define the output vector as c c 9. h(i,j) = (v(i,j),w(i,j)) c c and the complex coefficients c c 10. b(m,n) = cmplx(br(m+1,n+1),bi(m+1,n+1)) c c 11. c(m,n) = cmplx(cr(m+1,n+1),ci(m+1,n+1)) c c c then for i=1,...,nlat and j=1,...,nlon c c the expansion for real h(i,j) takes the form c c h(i,j) = the sum from n=1 to n=nlat-1 of the real part of c c .5*(b(0,n)*bbar(0,n,theta(i))+c(0,n)*cbar(0,n,theta(i))) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c b(m,n)*bbar(m,n,theta(i))*exp(i*m*phi(j)) c +c(m,n)*cbar(m,n,theta(i))*exp(i*m*phi(j)) c c ************************************************************* c c in terms of real variables this expansion takes the form c c for i=1,...,nlat and j=1,...,nlon c c v(i,j) = the sum from n=1 to n=nlat-1 of c c .5*br(1,n+1)*vbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c (br(m+1,n+1)*vbar(m,n,theta(i))-ci(m+1,n+1)*wbar(m,n,theta(i))) c *cos(m*phi(j)) c -(bi(m+1,n+1)*vbar(m,n,theta(i))+cr(m+1,n+1)*wbar(m,n,theta(i))) c *sin(m*phi(j)) c c and for i=1,...,nlat and j=1,...,nlon c c w(i,j) = the sum from n=1 to n=nlat-1 of c c -.5*cr(1,n+1)*vbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c -(cr(m+1,n+1)*vbar(m,n,theta(i))+bi(m+1,n+1)*wbar(m,n,theta(i))) c *cos(m*phi(j)) c +(ci(m+1,n+1)*vbar(m,n,theta(i))-br(m+1,n+1)*wbar(m,n,theta(i))) c *sin(m*phi(j)) c c c br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are c assumed zero for m even. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lvhsgs c = 10 error in the specification of lwork c c c subroutine vhsgsi(nlat,nlon,wvhsgs,lvhsgs,dwork,ldwork,ierror) c c subroutine vhsgsi initializes the array wvhsgs which can then be c used repeatedly by subroutine vhsgs until nlat or nlon is changed. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls vhsgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgs must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat c c dwork a double precision work array that does not need to be saved c c ldwork the dimension of the array dwork as it appears in the c program that calls vhsgsi. ldwork must be at least c c (3*nlat*(nlat+3)+2)/2 c c ************************************************************** c c output parameters c c wvhsgs an array which is initialized for use by subroutine vhsgs. c once initialized, wvhsgs can be used repeatedly by vhsgs c as long as nlat and nlon remain unchanged. wvhsgs must not c be altered between calls of vhsgs. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lvhsgs c = 4 error in the specification of lwork c subroutine vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci, + mdab,ndab,wvhsgs,lvhsgs,work,lwork,ierror) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvhsgs(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lvhsgs .lt. lzimn+lzimn+nlon+15) return ierror = 10 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon if(lwork .lt. lnl+lnl+idv*nlon) return ierror = 0 ist = 0 if(ityp .le. 2) ist = imid c c set wvhsgs pointers c lmn = nlat*(nlat+1)/2 jw1 = 1 jw2 = jw1+imid*lmn jw3 = jw2+imid*lmn c c set work pointers c iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl call vhsgs1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab, + br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), + work(iw4),idz,wvhsgs(jw1),wvhsgs(jw2),wvhsgs(jw3)) return end subroutine vhsgs1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab, 1 ndab,br,bi,cr,ci,idv,ve,vo,we,wo,work,idz,vb,wb,wrfft) dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1), 3 wo(idv,nlon,1),work(1),wrfft(1), 4 vb(imid,1),wb(imid,1) nlp1 = nlat+1 mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 do 10 k=1,nt do 10 j=1,nlon do 10 i=1,idv ve(i,j,k) = 0. we(i,j,k) = 0. 10 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 18 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 no symmetries c c case m = 0 c 1 continue do 15 k=1,nt do 15 np1=2,ndo2,2 do 15 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1) we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1) 15 continue do 16 k=1,nt do 16 np1=3,ndo1,2 do 16 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1) wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 30 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 26 do 25 k=1,nt do 24 np1=mp1,ndo1,2 mn = mb+np1 do 23 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 23 continue if(mlat .eq. 0) go to 24 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 24 continue 25 continue 26 if(mp2 .gt. ndo2) go to 30 do 29 k=1,nt do 28 np1=mp2,ndo2,2 mn = mb+np1 do 27 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 27 continue if(mlat .eq. 0) go to 28 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 28 continue 29 continue 30 continue go to 950 c c case ityp=1 no symmetries, cr and ci equal zero c c case m = 0 c 100 continue do 115 k=1,nt do 115 np1=2,ndo2,2 do 115 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1) 115 continue do 116 k=1,nt do 116 np1=3,ndo1,2 do 116 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 130 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 126 do 125 k=1,nt do 124 np1=mp1,ndo1,2 mn = mb+np1 do 123 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 123 continue if(mlat .eq. 0) go to 124 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 124 continue 125 continue 126 if(mp2 .gt. ndo2) go to 130 do 129 k=1,nt do 128 np1=mp2,ndo2,2 mn = mb+np1 do 127 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 127 continue if(mlat .eq. 0) go to 128 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 128 continue 129 continue 130 continue go to 950 c c case ityp=2 no symmetries, br and bi are equal to zero c c case m = 0 c 200 do 215 k=1,nt do 215 np1=2,ndo2,2 do 215 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1) 215 continue do 216 k=1,nt do 216 np1=3,ndo1,2 do 216 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 230 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 226 do 225 k=1,nt do 224 np1=mp1,ndo1,2 mn = mb+np1 do 223 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 223 continue if(mlat .eq. 0) go to 224 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 224 continue 225 continue 226 if(mp2 .gt. ndo2) go to 230 do 229 k=1,nt do 228 np1=mp2,ndo2,2 mn = mb+np1 do 227 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 227 continue if(mlat .eq. 0) go to 228 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 228 continue 229 continue 230 continue go to 950 c c case ityp=3 v even, w odd c c case m = 0 c 300 do 315 k=1,nt do 315 np1=2,ndo2,2 do 315 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1) 315 continue do 316 k=1,nt do 316 np1=3,ndo1,2 do 316 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 330 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 326 do 325 k=1,nt do 324 np1=mp1,ndo1,2 mn = mb+np1 do 323 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 323 continue if(mlat .eq. 0) go to 324 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 324 continue 325 continue 326 if(mp2 .gt. ndo2) go to 330 do 329 k=1,nt do 328 np1=mp2,ndo2,2 mn = mb+np1 do 327 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 327 continue if(mlat .eq. 0) go to 328 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 328 continue 329 continue 330 continue go to 950 c c case ityp=4 v even, w odd, and both cr and ci equal zero c c case m = 0 c 400 do 415 k=1,nt do 415 np1=2,ndo2,2 do 415 i=1,imid ve(i,1,k)=ve(i,1,k)+br(1,np1,k)*vb(i,np1) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 430 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 430 do 429 k=1,nt do 428 np1=mp2,ndo2,2 mn = mb+np1 do 427 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 427 continue if(mlat .eq. 0) go to 428 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 428 continue 429 continue 430 continue go to 950 c c case ityp=5 v even, w odd, br and bi equal zero c c case m = 0 c 500 do 516 k=1,nt do 516 np1=3,ndo1,2 do 516 i=1,imm1 wo(i,1,k)=wo(i,1,k)-cr(1,np1,k)*vb(i,np1) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 530 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 530 do 525 k=1,nt do 524 np1=mp1,ndo1,2 mn = mb+np1 do 523 i=1,imm1 ve(i,2*mp1-2,k) = ve(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) ve(i,2*mp1-1,k) = ve(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wo(i,2*mp1-2,k) = wo(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wo(i,2*mp1-1,k) = wo(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 523 continue if(mlat .eq. 0) go to 524 ve(imid,2*mp1-2,k) = ve(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) ve(imid,2*mp1-1,k) = ve(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 524 continue 525 continue 530 continue go to 950 c c case ityp=6 v odd , w even c c case m = 0 c 600 do 615 k=1,nt do 615 np1=2,ndo2,2 do 615 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1) 615 continue do 616 k=1,nt do 616 np1=3,ndo1,2 do 616 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 630 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 626 do 625 k=1,nt do 624 np1=mp1,ndo1,2 mn = mb+np1 do 623 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 623 continue if(mlat .eq. 0) go to 624 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 624 continue 625 continue 626 if(mp2 .gt. ndo2) go to 630 do 629 k=1,nt do 628 np1=mp2,ndo2,2 mn = mb+np1 do 627 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 627 continue if(mlat .eq. 0) go to 628 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 628 continue 629 continue 630 continue go to 950 c c case ityp=7 v odd, w even cr and ci equal zero c c case m = 0 c 700 do 716 k=1,nt do 716 np1=3,ndo1,2 do 716 i=1,imm1 vo(i,1,k)=vo(i,1,k)+br(1,np1,k)*vb(i,np1) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 730 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 730 do 725 k=1,nt do 724 np1=mp1,ndo1,2 mn = mb+np1 do 723 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 723 continue if(mlat .eq. 0) go to 724 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 724 continue 725 continue 730 continue go to 950 c c case ityp=8 v odd, w even br and bi equal zero c c case m = 0 c 800 do 815 k=1,nt do 815 np1=2,ndo2,2 do 815 i=1,imid we(i,1,k)=we(i,1,k)-cr(1,np1,k)*vb(i,np1) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 830 mp1=2,mmax m = mp1-1 c mb = m*(nlat-1)-(m*(m-1))/2 mb = m*nlat-(m*(m+1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 830 do 829 k=1,nt do 828 np1=mp2,ndo2,2 mn = mb+np1 do 827 i=1,imm1 vo(i,2*mp1-2,k) = vo(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vo(i,2*mp1-1,k) = vo(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) we(i,2*mp1-2,k) = we(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) we(i,2*mp1-1,k) = we(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 827 continue if(mlat .eq. 0) go to 828 we(imid,2*mp1-2,k) = we(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) we(imid,2*mp1-1,k) = we(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 828 continue 829 continue 830 continue 950 continue do 14 k=1,nt call hrfftb(idv,nlon,ve(1,1,k),idv,wrfft,work) call hrfftb(idv,nlon,we(1,1,k),idv,wrfft,work) 14 continue if(ityp .gt. 2) go to 12 do 60 k=1,nt do 60 j=1,nlon do 60 i=1,imm1 v(i,j,k) = .5*(ve(i,j,k)+vo(i,j,k)) w(i,j,k) = .5*(we(i,j,k)+wo(i,j,k)) v(nlp1-i,j,k) = .5*(ve(i,j,k)-vo(i,j,k)) w(nlp1-i,j,k) = .5*(we(i,j,k)-wo(i,j,k)) 60 continue go to 13 12 do 11 k=1,nt do 11 j=1,nlon do 11 i=1,imm1 v(i,j,k) = .5*ve(i,j,k) w(i,j,k) = .5*we(i,j,k) 11 continue 13 if(mlat .eq. 0) return do 65 k=1,nt do 65 j=1,nlon v(imid,j,k) = .5*ve(imid,j,k) w(imid,j,k) = .5*we(imid,j,k) 65 continue return end subroutine vhsgsi(nlat,nlon,wvhsgs,lvhsgs,dwork,ldwork,ierror) c c subroutine vhsfsi computes the gaussian points theta, gauss c weights wts, and the components vb and wb of the vector c harmonics. all quantities are computed internally in double c precision but returned in single precision and are therfore c accurate to single precision. c c set imid = (nlat+1)/2 and lmn=(nlat*(nlat+1))/2 then c wvhsgs must have 2*(imid*lmn+nlat)+nlon+15 locations c c double precision array dwork must have c 3*nlat*(nlat+1)+5*nlat+1 = nlat*(3*nlat+8)+1 c locations which is determined by the size of dthet, c dwts, dwork, and dpbar in vhsgs1 c dimension wvhsgs(*) double precision dwork(*) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 imid = (nlat+1)/2 lmn = (nlat*(nlat+1))/2 if(lvhsgs .lt. 2*(imid*lmn)+nlon+15) return ierror = 4 if (ldwork .lt. (nlat*3*(nlat+3)+2)/2) return ierror = 0 c c set saved work space pointers c jw1 = 1 jw2 = jw1+imid*lmn jw3 = jw2+imid*lmn c c set unsaved work space pointers c iw1 = 1 iw2 = iw1+nlat iw3 = iw2+nlat iw4 = iw3+3*imid*nlat c iw2 = iw1+nlat+nlat c iw3 = iw2+nlat+nlat c iw4 = iw3+6*imid*nlat call vhgsi1(nlat,imid,wvhsgs(jw1),wvhsgs(jw2), +dwork(iw1),dwork(iw2),dwork(iw3),dwork(iw4)) call hrffti(nlon,wvhsgs(jw3)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c ... file visgau.f c c contains documentation and code for subroutine visgau c subroutine visequ (nlat,nlon,h,len,eyer,eyelat,eyelon, + wk,lwk,iwk,liwk,ierror) c c subroutine visequ will display a function on the sphere c as a solid. ie. as a "lumpy" sphere. visequ calls subroutine c vsurf to produce the visible surface rendering. c c requires routines visequ1 interp sptc diag stride triang vsurf c vsurf1 prjct box icvmg projct c c visgeo uses the ncar graphics package. c compile with: ncargf77 (all programs above) c c execute with: a.out c c on screen display with: ctrans -d x11 gmeta c c print with: ctrans -d ps.color gmeta > gmeta.ps c lpr -p(your printer) gmeta.ps c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c c h a two dimensional array that contains the discrete c function to be displayed. h(i,j) is the distance from the c center of the sphere to the surface at the colatitude c point theta(i) = (i-1)*pi/(nlat-1) and longitude point c phi(j) = (j-1)*2*pi/nlon. c c len the first dimension of the array h as it appears in the c program that calls visequ. c c eyer the distance from the center of the sphere to the eye. c c eyelat the colatitudinal coordinate of the eye (in degrees). c c eyelon the longitudinal coordinate of the eye (in degrees). c c wk a real work array c c lwk the dimension of the array wk as it appears in the c program that calls visequ. lwk must be at least c 46*nlat*(nlon+1). c c iwk an integer work array c c liwk the dimension of the array iwk as it appears in the c program that calls visequ. liwk must be at least c 14*nlat*(nlon+1). c c ierror = 0 no error c = 1 the eye is positioned inside the sphere c = 2 lwk is less than 46*nlat*(nlon+1) c = 3 liwk is less than 14*nlat*(nlon+1) c c dimension h(len,*),wk(*) integer iwk(*) n = nlat m = nlon+1 mn = m*n ierror = 2 if(lwk .lt. 46*mn) return ierror = 3 if(liwk .lt. 14*mn) return ierror = 1 do 10 j=1,nlon do 10 i=1,nlat if(eyer .le. h(i,j)) return 10 continue ierror = 0 pi = 4.*atan(1.) dtr = pi/180. c c **** set up pointers to sub work arrays in wk and iwk c ntri = mn+mn nw1 = 1 nw2 = nw1+mn nclat = 1 nslat = nclat+n nxp = 1 nyp = nxp+mn nx1 = 1 ny1 = nx1+ntri nz1 = ny1+ntri nx2 = nz1+ntri ny2 = nx2+ntri nz2 = ny2+ntri nx3 = nz2+ntri ny3 = nx3+ntri nz3 = ny3+ntri nx = nz3+ntri ny = nx+mn nz = ny+mn nwrk = nx nitype = 1 niflag = ntri+1 nmst = niflag+mn nmfac = nmst+n c total iwk is 7*ntri c total wk is 58*nlat*(nlon+1) c **** mid-cell interpolation, calculation of polar values call interp(h,len,m,n,wk(nw1),wk(nw2),iwk(niflag)) c **** transform grid points to cartesian coordinates call sptc(h,len,m,n,wk(nclat),wk(nslat),wk(nx),wk(ny),wk(nz)) c **** transform eye position to cartesian coordinates xeye=eyer*sin(dtr*eyelat) yeye=xeye*sin(dtr*eyelon) xeye=xeye*cos(dtr*eyelon) zeye=eyer*cos(dtr*eyelat) c **** project grid points call projct(m,n,xeye,yeye,zeye,wk(nx),wk(ny),wk(nz),wk(nxp), 1 wk(nyp)) c **** check for visibility of cell boundaries call diag(m,n,wk(nxp),wk(nyp),iwk(niflag)) c **** compute longitude stride as a function of latitude call stride(m,n,iwk(nmst),iwk(nmfac)) c **** perform triangulation call triang(m,n,wk(nx),wk(ny),wk(nz),itri,wk(nx1),wk(ny1), 1wk(nz1),wk(nx2),wk(ny2),wk(nz2),wk(nx3),wk(ny3),wk(nz3), 2iwk(nitype),iwk(niflag),iwk(nmst)) c **** call surface plotting routine call vsurf(xeye,yeye,zeye,itri,wk(nx1),wk(ny1),wk(nz1),wk(nx2), 1wk(ny2),wk(nz2),wk(nx3),wk(ny3),wk(nz3),iwk(nitype),wk(nwrk), 1iwk(niflag)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c ... file visgau.f c c contains documentation and code for subroutine visgau c subroutine VISGAU (NLAT,NLON,H,LEN,EYER,EYELAT,EYELON, 1 THETA,WK,LWK,IWK,LIWK,IERROR) c c subroutine visgau produces a three dimensional visible rendering c of the function h(i,j) which is tabulated on a gauss distributed c colatitude grid. c c requires setgau alfk lfpt gaqd drst dintql dpytha c visgau embed intrpg sptcg diag stride c trigau vsurf vsurf1 prjct box icvmg projct c c tvisgau uses the ncar graphics package. c compile with: ncargf77 (all programs above) c c execute with: a.out c c on screen display with: ctrans -d x11 gmeta c c print with: ctrans -d ps.color gmeta > gmeta.ps c lpr -p(your printer) gmeta.ps c c input parameters c c nlat the number of gauss colatitudes. c if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than or equal to 4. the efficiency of the computation is c improved when nlon is a product of small prime numbers. c c c h a two dimensional array that contains the discrete c function to be displayed. h(i,j) is the distance from the c center of the sphere to the surface at gauss colatitude c point theta(i) and longitude point c phi(j) = (j-1)*2*pi/nlon. c c len the first dimension of the array h as it appears in the c program that calls sphere. c c eyer the distance from the center of the sphere to the eye. c c eyelat the colatitudinal coordinate of the eye (in degrees). c c eyelon the longitudinal coordinate of the eye (in degrees). c c theta a double precision array with nlat gauss colatitudes c computed by subroutine gaqd c c wk a real work array c c lwk the dimension of the array wk as it appears in the c program that calls visgau. lwk must be at least c 46*(nlat+2)*(nlon+1). c c iwk an integer work array c c liwk the dimension of the array iwk as it appears in the c program that calls visgau. liwk must be at least c 14*(nlat+2)*(nlon+1). c c ierror = 0 no error c = 1 the eye is positioned inside the sphere c = 2 lwk is less than 46*(nlat+2)*(nlon+1) c = 3 liwk is less than 14*(nlat+2)*(nlon+1) c c dimension h(len,nlon),wk(*) INTEGER IWK(*) double precision theta(nlat) n = nlat+2 m = nlon+1 mn = m*n ierror = 2 if(lwk .lt. 46*mn) return ierror = 3 if(liwk .lt. 14*mn) return ierror = 1 do 10 j=1,nlon do 10 i=1,nlat if(eyer .le. h(i,j)) return 10 continue ierror = 0 c **** set up pointers to sub work arrays in wk ntri = mn+mn nw1 = 1 nw2 = nw1+mn nclat = 1 nslat = nclat+n nxp = 1 nyp = nxp+mn nx1 = 1 ny1 = nx1+ntri nz1 = ny1+ntri nx2 = nz1+ntri ny2 = nx2+ntri nz2 = ny2+ntri nx3 = nz2+ntri ny3 = nx3+ntri nz3 = ny3+ntri nx = nz3+ntri ny = nx+mn nz = ny+mn nwrk = nx nitype = 1 niflag = ntri+1 nmst = niflag+mn nmfac = nmst+n c **** embed h in a larger array call embed(nlat,nlon,h,len,wk(nz1)) c **** mid-cell interpolation call intrpg(wk(nz1),m,n,wk(nw1),wk(nw2),iwk(niflag)) c **** transform grid points to cartesian coordinates call sptcg(wk(nz1),m,n,theta,wk(nclat),wk(nslat),wk(nx),wk(ny), 1 wk(nz)) c **** transform eye position to cartesian coordinates pi = 4.*atan(1.) dtr = pi/180. xeye=eyer*sin(dtr*eyelat) yeye=xeye*sin(dtr*eyelon) xeye=xeye*cos(dtr*eyelon) zeye=eyer*cos(dtr*eyelat) c **** project grid points call projct(m,n,xeye,yeye,zeye,wk(nx),wk(ny),wk(nz),wk(nxp), 1 wk(nyp)) c **** check for visibility of cell boundaries call diag(m,n,wk(nxp),wk(nyp),iwk(niflag)) c **** compute longitude stride as a function of latitude call stride(m,n,iwk(nmst),iwk(nmfac)) c **** perform triangulation call trigau(m,n,wk(nx),wk(ny),wk(nz),itri,wk(nx1),wk(ny1), 1wk(nz1),wk(nx2),wk(ny2),wk(nz2),wk(nx3),wk(ny3),wk(nz3), 2iwk(nitype),iwk(niflag),iwk(nmst)) c **** call surface plotting routine call vsurf(xeye,yeye,zeye,itri,wk(nx1),wk(ny1),wk(nz1),wk(nx2), 1wk(ny2),wk(nz2),wk(nx3),wk(ny3),wk(nz3),iwk(nitype),wk(nwrk), 1iwk(niflag)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c ... visgeo.f c c contains documentation and code for subroutine visgeo c subroutine VISGEO (M,IDP,JDP,X,Y,Z,H,EYER,EYELAT,EYELON, 1 WORK,LWORK,IWORK,LIWORK,IERROR) c c subroutine visgeo will display a function on the sphere c as a solid. ie. as a "lumpy" sphere. visgeo calls subroutine c vsurf to produce the visible surface rendering. X, Y, and Z c are the points on an icosahedral geodesic computed by c subroutine geopts available in spherepack. c c requires routines visgeo1 ctos stoc vsurf vsurf1 c prjct box c c visgeo uses the ncar graphics package. c compile with: ncargf77 (all programs above) c c execute with: a.out c c on screen display with: ctrans -d x11 gmeta c c print with: ctrans -d ps.color gmeta > gmeta.ps c lpr -P(your printer) gmeta.ps c c c input parameters c c m the number of points on one edge of the icosahedron c c idp,jdp the first and second dimensions of the three c dimensional arrays x, y, z, and h. c c x,y,z the coordinates of the geodesic points on c the unit sphere computed by subroutine geopts. c the indices are defined on the unfolded c icosahedron as follows for the case m=3 c c north pole c c (5,1) 0 l c i (4,1) (5,2) a (repeated for c (3,1) (4,2) (5,3) theta1 t k=2,3,4,5 in c (2,1) (3,2) (4,3) i --> c (1,1) (2,2) (3,3) theta2 t the longitudinal c (1,2) (2,3) u direction) c (1,3) pi d c j e c south pole c c total number of vertices is 10*(m-1)**2+2 c total number of triangles is 20*(m-1)**2 c c h a three dimensional array that contains the discrete c function to be displayed. h(i,j,k) is the distance from c the center of the sphere to the "lumpy" surface at the c point [x(i,j,k),y(i,j,k),z(i,j,k)] on the unit sphere. c c eyer the distance from the center of the sphere to the eye. c c eyelat the colatitudinal coordinate of the eye (in degrees). c c eyelon the longitudinal coordinate of the eye (in degrees). c c idp the first dimension of the array h as it appears in c the program that calls visgeo c c jdp the second dimension of the array h as it appears in c the program that calls visgeo c c work a real work array c c lwork the dimension of the array work as it appears in the c program that calls visgeo. lwork must be at least c 480*(m-1)**2. c c iwork an integer work array c c liwork the dimension of the array iwork as it appears in the c program that calls visgeo. liwork must be at least c 140*(m-1)**2. c c input parameter c c ierror = 0 no error c = 1 h(i,j,k) is less than zero for some i,j,k. c = 2 eyer is less than h(i,j,k) for some i,k,k. c = 3 lwork is less than 480*(m-1)**2 c = 4 liwork is less than 140*(m-1)**2 c dimension h(idp,jdp,5),x(idp,jdp,5),y(idp,jdp,5),z(idp,jdp,5), 1 work(*) INTEGER IWORK(*) mmsq = (m-1)**2 ierror = 3 if(lwork .lt. 480*mmsq) return ierror = 4 if(liwork .lt. 140*mmsq) return do 10 k=1,5 do 10 j=1,m do 10 i=1,m+m-1 if(h(i,j,k) .ge. 0.) go to 15 ierror = 1 return 15 if(eyer .gt. h(i,j,k)) go to 10 ierror = 2 return 10 continue ierror = 0 lt = 20*(m-1)**2 lg = 5*m*(m+m-1) i1 = 1 i2 = i1+lt i3 = i2+lt i4 = i3+lt i5 = i4+lt i6 = i5+lt i7 = i6+lt i8 = i7+lt i9 = i8+lt i10 = i9+lt i11 = i10+lt i12 = i11 i13 = i12+lg i14 = i13+lg call visgeo1 (m,idp,jdp,h,eyer,eyelat,eyelon,x,y,z, 1work(i1),work(i2),work(i3),work(i4),work(i5),work(i6), 2work(i7),work(i8),work(i9),IWORK(1),work(i11), 3work(i12),work(i13),work(i14),IWORK(lt+1)) return end subroutine VISGEO1(M,IDP,JDP,H,EYER,EYELAT,EYELON, 1 XI,YI,ZI,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,ITYPE,WORK,X,Y,Z,IWORK) dimension h(idp,jdp,5),xi(idp,jdp,5),yi(idp,jdp,5),zi(idp,jdp,5), 1x1(*),y1(*),z1(*),x2(*),y2(*),z2(*),x3(*),y3(*),z3(*),itype(*), 2work(*),x(m+m-1,m,5),y(m+m-1,m,5),z(m+m-1,m,5) INTEGER IWORK(*) c c the * above refers to 20*(m-1)**2 locations which is the c number of triangles c do 10 k=1,5 do 10 j=1,m do 10 i=1,m+m-1 call ctos(xi(i,j,k),yi(i,j,k),zi(i,j,k),rad,theta,elambda) call stoc(h(i,j,k),theta,elambda,x(i,j,k),y(i,j,k),z(i,j,k)) 10 continue ntri = 0 do 20 k=1,5 do 20 j=1,m-1 do 20 i=1,m+m-2 ntri = ntri+1 x1(ntri) = x(i,j,k) y1(ntri) = y(i,j,k) z1(ntri) = z(i,j,k) x2(ntri) = x(i+1,j+1,k) y2(ntri) = y(i+1,j+1,k) z2(ntri) = z(i+1,j+1,k) x3(ntri) = x(i+1,j,k) y3(ntri) = y(i+1,j,k) z3(ntri) = z(i+1,j,k) itype(ntri) = 13 ntri = ntri+1 x1(ntri) = x(i,j,k) y1(ntri) = y(i,j,k) z1(ntri) = z(i,j,k) x2(ntri) = x(i+1,j+1,k) y2(ntri) = y(i+1,j+1,k) z2(ntri) = z(i+1,j+1,k) x3(ntri) = x(i,j+1,k) y3(ntri) = y(i,j+1,k) z3(ntri) = z(i,j+1,k) itype(ntri) = 3 20 continue c write(6,22) ntri 22 format(i10) c write(6,23) (x1(l2),y1(l2),z1(l2),x2(l2),y2(l2),z2(l2), c 1 x3(l2),y3(l2),z3(l2),l2=1,ntri) c 23 format(9f10.7) c pi = 4.*atan(1.) dtr = pi/180. xeye=eyer*sin(dtr*eyelat) yeye=xeye*sin(dtr*eyelon) xeye=xeye*cos(dtr*eyelon) zeye=eyer*cos(dtr*eyelat) CALL VSURF(XEYE,YEYE,ZEYE,NTRI,X1,Y1,Z1,X2,Y2,Z2, 1 X3,Y3,Z3,ITYPE,WORK,IWORK) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vlapec.f c c this file includes documentation and code for c subroutine vlapec i c c ... files which must be loaded with vlapec.f c c sphcom.f, hrfft.f, vhaec.f, vhsec.f c c c subroutine vlapec(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci, c +mdbc,ndbc,wvhsec,lvhsec,work,lwork,ierror) c c c subroutine vlapec computes the vector laplacian of the vector field c (v,w) in (vlap,wlap) (see the definition of the vector laplacian at c the output parameter description of vlap,wlap below). w and wlap c are east longitudinal components of the vectors. v and vlap are c colatitudinal components of the vectors. br,bi,cr, and ci are the c vector harmonic coefficients of (v,w). these must be precomputed by c vhaec and are input parameters to vlapec. the laplacian components c in (vlap,wlap) have the same symmetry or lack of symmetry about the c equator as (v,w). the input parameters ityp,nt,mdbc,nbdc must have c the same values used by vhaec to compute br,bi,cr, and ci for (v,w). c vlap(i,j) and wlap(i,j) are given on the sphere at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c for i=1,...,nlat and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c for j=1,...,nlon. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp this parameter should have the same value input to subroutine c vhaec to compute the coefficients br,bi,cr, and ci for the c vector field (v,w). ityp is set as follows: c c = 0 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c c c = 1 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c the vorticity of (v,w) is zero so the coefficients cr and c ci are zero and are not used. the vorticity of (vlap,wlap) c is also zero. c c c = 2 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c the divergence of (v,w) is zero so the coefficients br and c bi are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c = 3 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c vorticity of (v,w) is zero so the coefficients cr,ci are c zero and are not used. the vorticity of (vlap,wlap) is c also zero. c c = 5 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c divergence of (v,w) is zero so the coefficients br,bi c are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c c = 6 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c vorticity of (v,w) is zero so the coefficients cr,ci are c zero and are not used. the vorticity of (vlap,wlap) is c also zero. c c = 8 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c divergence of (v,w) is zero so the coefficients br,bi c are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c c nt nt is the number of vector fields (v,w). some computational c efficiency is obtained for multiple fields. in the program c that calls vlapec, the arrays vlap,wlap,br,bi,cr and ci c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple vector synthesis will c be performed to compute the vector laplacian for each field. c the third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the description c of the remaining parameters is simplified by assuming that nt=1 c or that all arrays are two dimensional. c c idvw the first dimension of the arrays vlap and wlap as it appears c in the program that calls vlapec. if ityp=0,1, or 2 then idvw c must be at least nlat. if ityp > 2 and nlat is even then idvw c must be at least nlat/2. if ityp > 2 and nlat is odd then idvw c must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays vlap and wlap as it appears c in the program that calls vlapec. jdvw must be at least nlon. c c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaec. c br,bi,cr and ci must be computed by vhaec prior to calling c vlapec. if ityp=1,4, or 7 then cr,ci are not used and can c be dummy arguments. if ityp=2,5, or 8 then br,bi are not c used and can be dummy arguments. c c mdbc the first dimension of the arrays br,bi,cr and ci as it c appears in the program that calls vlapec. mdbc must be c at least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndbc the second dimension of the arrays br,bi,cr and ci as it c appears in the program that calls vlapec. ndbc must be at c least nlat. c c wvhsec an array which must be initialized by subroutine vhseci. c once initialized, wvhsec c can be used repeatedly by vlapec as long as nlat and nlon c remain unchanged. wvhsec must not be altered between calls c of vlapec. c c lvhsec the dimension of the array wvhsec as it appears in the c program that calls vlapec. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c then lvhsec must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c (see ierror=9 below). c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vlapec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c c if ityp .le. 2 then c c nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(4*nt*l1+1) c c or if ityp .gt. 2 let c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(4*nt*l1+1) c c will suffice as a minimum length for lwork c (see ierror=10 below) c c ************************************************************** c c output parameters c c c vlap, two or three dimensional arrays (see input parameter nt) that c wlap contain the vector laplacian of the field (v,w). wlap(i,j) is c the east longitude component and vlap(i,j) is the colatitudinal c component of the vector laplacian. the definition of the c vector laplacian follows: c c let cost and sint be the cosine and sine at colatitude theta. c let d( )/dlambda and d( )/dtheta be the first order partial c derivatives in longitude and colatitude. let del2 be the scalar c laplacian operator c c del2(s) = [d(sint*d(s)/dtheta)/dtheta + c 2 2 c d (s)/dlambda /sint]/sint c c then the vector laplacian opeator c c dvel2(v,w) = (vlap,wlap) c c is defined by c c vlap = del2(v) - (2*cost*dw/dlambda + v)/sint**2 c c wlap = del2(w) + (2*cost*dv/dlambda - w)/sint**2 c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of idvw c c = 6 error in the specification of jdvw c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lvhsec c c = 10 error in the specification of lwork (lwork < lwkmin) c c c ********************************************************************** c c end of documentation for vlapec c c ********************************************************************** c subroutine vlapec(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi, +cr,ci,mdbc,ndbc,wvhsec,lvhsec,work,lwork,ierror) dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhsec(lvhsec),work(lwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdbc .lt. mmax) return ierror = 8 if(ndbc .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid c c check saved work space c l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin = 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 if (lvhsec .lt. lwmin) return c c verify unsaved work space length c ierror = 10 mn = mmax*nlat*nt if(ityp.lt.3) then c no symmetry if (ityp.eq.0) then c br,bi,cr,ci nonzero lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+4*mn else c br,bi or cr,ci zero lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+2*mn end if else c symmetry about equator if (ityp.eq.3 .or. ityp.eq.6) then c br,bi,cr,ci nonzero lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat else c br,bi or cr,ci zero lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat end if end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers for vector laplacian coefficients c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr else ibr = 1 ibi = 1 icr = ibi+mn ici = icr+mn end if ifn = ici + mn iwk = ifn + nlat liwk = lwork-4*mn-nlat call vlapec1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi, +cr,ci,wvhsec,lvhsec,work(iwk),liwk,ierror) return end subroutine vlapec1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap, +bilap,crlap,cilap,mmax,fnn,mdb,ndb,br,bi,cr,ci,wsave,lwsav, +wk,lwk,ierror) dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt) dimension fnn(nlat),brlap(mmax,nlat,nt),bilap(mmax,nlat,nt) dimension crlap(mmax,nlat,nt),cilap(mmax,nlat,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension cr(mdb,ndb,nt),ci(mdb,ndb,nt) dimension wsave(lwsav),wk(lwk) c c preset coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = -fn*(fn+1.) 1 continue c c set laplacian coefficients from br,bi,cr,ci c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then c c all coefficients needed c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax brlap(m,n,k) = 0.0 bilap(m,n,k) = 0.0 crlap(m,n,k) = 0.0 cilap(m,n,k) = 0.0 4 continue 3 continue do 5 n=2,nlat brlap(1,n,k) = fnn(n)*br(1,n,k) bilap(1,n,k) = fnn(n)*bi(1,n,k) crlap(1,n,k) = fnn(n)*cr(1,n,k) cilap(1,n,k) = fnn(n)*ci(1,n,k) 5 continue do 6 m=2,mmax do 7 n=m,nlat brlap(m,n,k) = fnn(n)*br(m,n,k) bilap(m,n,k) = fnn(n)*bi(m,n,k) crlap(m,n,k) = fnn(n)*cr(m,n,k) cilap(m,n,k) = fnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then c c vorticity is zero so cr,ci=0 not used c do 12 k=1,nt do 13 n=1,nlat do 14 m=1,mmax brlap(m,n,k) = 0.0 bilap(m,n,k) = 0.0 14 continue 13 continue do 15 n=2,nlat brlap(1,n,k) = fnn(n)*br(1,n,k) bilap(1,n,k) = fnn(n)*bi(1,n,k) 15 continue do 16 m=2,mmax do 17 n=m,nlat brlap(m,n,k) = fnn(n)*br(m,n,k) bilap(m,n,k) = fnn(n)*bi(m,n,k) 17 continue 16 continue 12 continue else c c divergence is zero so br,bi=0 not used c do 22 k=1,nt do 23 n=1,nlat do 24 m=1,mmax crlap(m,n,k) = 0.0 cilap(m,n,k) = 0.0 24 continue 23 continue do 25 n=2,nlat crlap(1,n,k) = fnn(n)*cr(1,n,k) cilap(1,n,k) = fnn(n)*ci(1,n,k) 25 continue do 26 m=2,mmax do 27 n=m,nlat crlap(m,n,k) = fnn(n)*cr(m,n,k) cilap(m,n,k) = fnn(n)*ci(m,n,k) 27 continue 26 continue 22 continue end if c c sythesize coefs into vector field (vlap,wlap) c call vhsec(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap,bilap, + crlap,cilap,mmax,nlat,wsave,lwsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vlapes.f c c this file includes documentation and code for c subroutine vlapes i c c ... files which must be loaded with vlapes.f c c sphcom.f, hrfft.f, vhaes.f, vhses.f c c c c c subroutine vlapes(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci, c +mdbc,ndbc,wvhses,lvhses,work,lwork,ierror) c c c subroutine vlapes computes the vector laplacian of the vector field c (v,w) in (vlap,wlap) (see the definition of the vector laplacian at c the output parameter description of vlap,wlap below). w and wlap c are east longitudinal components of the vectors. v and vlap are c colatitudinal components of the vectors. br,bi,cr, and ci are the c vector harmonic coefficients of (v,w). these must be precomputed by c vhaes and are input parameters to vlapes. the laplacian components c in (vlap,wlap) have the same symmetry or lack of symmetry about the c equator as (v,w). the input parameters ityp,nt,mdbc,nbdc must have c the same values used by vhaes to compute br,bi,cr, and ci for (v,w). c vlap(i,j) and wlap(i,j) are given on the sphere at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c for i=1,...,nlat and east longitude c c lambda(j) = (j-1)*2*pi/nlon c c for j=1,...,nlon. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp this parameter should have the same value input to subroutine c vhaes to compute the coefficients br,bi,cr, and ci for the c vector field (v,w). ityp is set as follows: c c = 0 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c c c = 1 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c the vorticity of (v,w) is zero so the coefficients cr and c ci are zero and are not used. the vorticity of (vlap,wlap) c is also zero. c c c = 2 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c the divergence of (v,w) is zero so the coefficients br and c bi are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c = 3 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c vorticity of (v,w) is zero so the coefficients cr,ci are c zero and are not used. the vorticity of (vlap,wlap) is c also zero. c c = 5 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c divergence of (v,w) is zero so the coefficients br,bi c are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c c = 6 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c vorticity of (v,w) is zero so the coefficients cr,ci are c zero and are not used. the vorticity of (vlap,wlap) is c also zero. c c = 8 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c divergence of (v,w) is zero so the coefficients br,bi c are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c c nt nt is the number of vector fields (v,w). some computational c efficiency is obtained for multiple fields. in the program c that calls vlapes, the arrays vlap,wlap,br,bi,cr and ci c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple vector synthesis will c be performed to compute the vector laplacian for each field. c the third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the description c of the remaining parameters is simplified by assuming that nt=1 c or that all arrays are two dimensional. c c idvw the first dimension of the arrays vlap and wlap as it appears c in the program that calls vlapes. if ityp=0,1, or 2 then idvw c must be at least nlat. if ityp > 2 and nlat is even then idvw c must be at least nlat/2. if ityp > 2 and nlat is odd then idvw c must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays vlap and wlap as it appears c in the program that calls vlapes. jdvw must be at least nlon. c c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaes. c br,bi,cr and ci must be computed by vhaes prior to calling c vlapes. if ityp=1,4, or 7 then cr,ci are not used and can c be dummy arguments. if ityp=2,5, or 8 then br,bi are not c used and can be dummy arguments. c c mdbc the first dimension of the arrays br,bi,cr and ci as it c appears in the program that calls vlapes. mdbc must be c at least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndbc the second dimension of the arrays br,bi,cr and ci as it c appears in the program that calls vlapes. ndbc must be at c least nlat. c c wvhses an array which must be initialized by subroutine vhsesi. c once initialized, vhses c can be used repeatedly by vlapes as long as nlat and nlon c remain unchanged. wvhses must not be altered between calls c of vlapes. c c lvhses the dimension of the array wvhses as it appears in the c program that calls vlapes. let c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c then lvhses must be greater than or equal c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vlapes. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if ityp .le. 2 then c c (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1) c c or if ityp .gt. 2 then c c (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1) c c will suffice as a length for lwork. c c ************************************************************** c c output parameters c c c vlap, two or three dimensional arrays (see input parameter nt) that c wlap contain the vector laplacian of the field (v,w). wlap(i,j) is c the east longitude component and vlap(i,j) is the colatitudinal c component of the vector laplacian. the definition of the c vector laplacian follows: c c let cost and sint be the cosine and sine at colatitude theta. c let d( )/dlambda and d( )/dtheta be the first order partial c derivatives in longitude and colatitude. let del2 be the scalar c laplacian operator c c del2(s) = [d(sint*d(s)/dtheta)/dtheta + c 2 2 c d (s)/dlambda /sint]/sint c c then the vector laplacian opeator c c dvel2(v,w) = (vlap,wlap) c c is defined by c c vlap = del2(v) - (2*cost*dw/dlambda + v)/sint**2 c c wlap = del2(w) + (2*cost*dv/dlambda - w)/sint**2 c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of idvw c c = 6 error in the specification of jdvw c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lvhses c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for vlapes c c ********************************************************************** c subroutine vlapes(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi, +cr,ci,mdbc,ndbc,wvhses,lvhses,work,lwork,ierror) dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhses(lvhses),work(lwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdbc .lt. mmax) return ierror = 8 if(ndbc .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid lsavmin = lzimn+lzimn+nlon+15 if(lvhses .lt. lsavmin) return c c verify unsaved work space length c mn = mmax*nlat*nt l2 = (nlat+1)/2 l1 = min0(nlat,nlon/2+1) if (ityp .le. 2) then lwkmin = (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1) else lwkmin = (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers for vector laplacian coefficients c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr else ibr = 1 ibi = 1 icr = ibi+mn ici = icr+mn end if ifn = ici + mn iwk = ifn + nlat liwk = lwork-4*mn-nlat call vlapes1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi, +cr,ci,wvhses,lvhses,work(iwk),liwk,ierror) return end subroutine vlapes1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap, +bilap,crlap,cilap,mmax,fnn,mdb,ndb,br,bi,cr,ci,wsave,lsave, +wk,lwk,ierror) dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt) dimension fnn(nlat),brlap(mmax,nlat,nt),bilap(mmax,nlat,nt) dimension crlap(mmax,nlat,nt),cilap(mmax,nlat,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension cr(mdb,ndb,nt),ci(mdb,ndb,nt) dimension wsave(lsave),wk(lwk) c c preset coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = -fn*(fn+1.) 1 continue c c set laplacian coefficients from br,bi,cr,ci c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then c c all coefficients needed c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax brlap(m,n,k) = 0.0 bilap(m,n,k) = 0.0 crlap(m,n,k) = 0.0 cilap(m,n,k) = 0.0 4 continue 3 continue do 5 n=2,nlat brlap(1,n,k) = fnn(n)*br(1,n,k) bilap(1,n,k) = fnn(n)*bi(1,n,k) crlap(1,n,k) = fnn(n)*cr(1,n,k) cilap(1,n,k) = fnn(n)*ci(1,n,k) 5 continue do 6 m=2,mmax do 7 n=m,nlat brlap(m,n,k) = fnn(n)*br(m,n,k) bilap(m,n,k) = fnn(n)*bi(m,n,k) crlap(m,n,k) = fnn(n)*cr(m,n,k) cilap(m,n,k) = fnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then c c vorticity is zero so cr,ci=0 not used c do 12 k=1,nt do 13 n=1,nlat do 14 m=1,mmax brlap(m,n,k) = 0.0 bilap(m,n,k) = 0.0 14 continue 13 continue do 15 n=2,nlat brlap(1,n,k) = fnn(n)*br(1,n,k) bilap(1,n,k) = fnn(n)*bi(1,n,k) 15 continue do 16 m=2,mmax do 17 n=m,nlat brlap(m,n,k) = fnn(n)*br(m,n,k) bilap(m,n,k) = fnn(n)*bi(m,n,k) 17 continue 16 continue 12 continue else c c divergence is zero so br,bi=0 not used c do 22 k=1,nt do 23 n=1,nlat do 24 m=1,mmax crlap(m,n,k) = 0.0 cilap(m,n,k) = 0.0 24 continue 23 continue do 25 n=2,nlat crlap(1,n,k) = fnn(n)*cr(1,n,k) cilap(1,n,k) = fnn(n)*ci(1,n,k) 25 continue do 26 m=2,mmax do 27 n=m,nlat crlap(m,n,k) = fnn(n)*cr(m,n,k) cilap(m,n,k) = fnn(n)*ci(m,n,k) 27 continue 26 continue 22 continue end if c c sythesize coefs into vector field (vlap,wlap) c call vhses(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap,bilap, + crlap,cilap,mmax,nlat,wsave,lsave,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c ... file vlapgc.f c c this file includes documentation and code for c subroutine vlapgc i c c ... files which must be loaded with vlapgc.f c c sphcom.f, hrfft.f, vhagc.f, vhsgc.f, gaqd.f c c c subroutine vlapgc(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci, c +mdbc,ndbc,wvhsgc,lvhsgc,work,lwork,ierror) c c given the vector spherical harmonic coefficients (br,bi,cr,ci) c precomputed by subroutine vhagc for a vector field (v,w), subroutine c vlapgc computes the vector laplacian of the vector field (v,w) c in (vlap,wlap) (see the definition of the vector laplacian at c the output parameter description of vlap,wlap below). w and wlap c are east longitudinal components of the vectors. v and vlap are c colatitudinal components of the vectors. the laplacian components c in (vlap,wlap) have the same symmetry or lack of symmetry about the c equator as (v,w). the input parameters ityp,nt,mdbc,nbdc must have c the same values used by vhagc to compute br,bi,cr, and ci for (v,w). c vlap(i,j) and wlap(i,j) are given on the sphere at the gaussian c colatitude theta(i) (see nlat as input parameter) and east longitude c lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp this parameter should have the same value input to subroutine c vhagc to compute the coefficients br,bi,cr, and ci for the c vector field (v,w). ityp is set as follows: c c = 0 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c c c = 1 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c the vorticity of (v,w) is zero so the coefficients cr and c ci are zero and are not used. the vorticity of (vlap,wlap) c is also zero. c c c = 2 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c the divergence of (v,w) is zero so the coefficients br and c bi are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c = 3 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c vorticity of (v,w) is zero so the coefficients cr,ci are c zero and are not used. the vorticity of (vlap,wlap) is c also zero. c c = 5 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c divergence of (v,w) is zero so the coefficients br,bi c are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c c = 6 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c vorticity of (v,w) is zero so the coefficients cr,ci are c zero and are not used. the vorticity of (vlap,wlap) is c also zero. c c = 8 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c divergence of (v,w) is zero so the coefficients br,bi c are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c c nt nt is the number of vector fields (v,w). some computational c efficiency is obtained for multiple fields. in the program c that calls vlapgc, the arrays vlap,wlap,br,bi,cr and ci c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple vector synthesis will c be performed to compute the vector laplacian for each field. c the third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the description c of the remaining parameters is simplified by assuming that nt=1 c or that all arrays are two dimensional. c c idvw the first dimension of the arrays vlap and wlap as it appears c in the program that calls vlapgc. if ityp=0,1, or 2 then idvw c must be at least nlat. if ityp > 2 and nlat is even then idvw c must be at least nlat/2. if ityp > 2 and nlat is odd then idvw c must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays vlap and wlap as it appears c in the program that calls vlapgc. jdvw must be at least nlon. c c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhagc. c br,bi,cr and ci must be computed by vhagc prior to calling c vlapgc. if ityp=1,4, or 7 then cr,ci are not used and can c be dummy arguments. if ityp=2,5, or 8 then br,bi are not c used and can be dummy arguments. c c mdbc the first dimension of the arrays br,bi,cr and ci as it c appears in the program that calls vlapgc. mdbc must be c at least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndbc the second dimension of the arrays br,bi,cr and ci as it c appears in the program that calls vlapgc. ndbc must be at c least nlat. c c wvhsgc an array which must be initialized by subroutine vhsgci. c once initialized, wvhsgc c can be used repeatedly by vlapgc as long as nlat and nlon c remain unchanged. wvhsgc must not be altered between calls c of vlapgc. c c lvhsgc the dimension of the array wvhsgc as it appears in the c program that calls vhagc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgc must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vlapgc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if ityp .le. 2 then c c nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(4*nt*l1+1) c c or if ityp .gt. 2 let c c l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(4*nt*l1+1) c c will suffice as a minimum length for lwork c (see ierror=10 below) c (see ierror=10 below) c c ************************************************************** c c output parameters c c c vlap, two or three dimensional arrays (see input parameter nt) that c wlap contain the vector laplacian of the field (v,w). wlap(i,j) is c the east longitude component and vlap(i,j) is the colatitudinal c component of the vector laplacian. the definition of the c vector laplacian follows: c c let cost and sint be the cosine and sine at colatitude theta. c let d( )/dlambda and d( )/dtheta be the first order partial c derivatives in longitude and colatitude. let del2 be the scalar c laplacian operator c c del2(s) = [d(sint*d(s)/dtheta)/dtheta + c 2 2 c d (s)/dlambda /sint]/sint c c then the vector laplacian opeator c c dvel2(v,w) = (vlap,wlap) c c is defined by c c vlap = del2(v) - (2*cost*dw/dlambda + v)/sint**2 c c wlap = del2(w) + (2*cost*dv/dlambda - w)/sint**2 c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of idvw c c = 6 error in the specification of jdvw c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lvhsgc c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for vlapgc c c ********************************************************************** c subroutine vlapgc(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi, +cr,ci,mdbc,ndbc,wvhsgc,lvhsgc,work,lwork,ierror) dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhsgc(lvhsgc),work(lwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdbc .lt. mmax) return ierror = 8 if(ndbc .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid c lsavmin = lzimn+lzimn+nlon+15 c if(lsave .lt. lsavmin) return l1 = min0(nlat,(nlon+1)/2) l2 = (nlat+1)/2 lwmin = 4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+15 if (lvhsgc .lt. lwmin) return c c verify unsaved work space length c mn = mmax*nlat*nt if(ityp.lt.3) then c no symmetry if (ityp.eq.0) then c br,bi,cr,ci nonzero lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+4*mn else c br,bi or cr,ci zero lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+2*mn end if else c symmetry about equator if (ityp.eq.3 .or. ityp.eq.6) then c br,bi,cr,ci nonzero lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat else c br,bi or cr,ci zero lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat end if end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers for vector laplacian coefficients c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr else ibr = 1 ibi = 1 icr = ibi+mn ici = icr+mn end if ifn = ici + mn iwk = ifn + nlat liwk = lwork-4*mn-nlat call vlapgc1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi, +cr,ci,wvhsgc,lvhsgc,work(iwk),liwk,ierror) return end subroutine vlapgc1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap, +bilap,crlap,cilap,mmax,fnn,mdb,ndb,br,bi,cr,ci,wsave,lwsav, +wk,lwk,ierror) dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt) dimension fnn(nlat),brlap(mmax,nlat,nt),bilap(mmax,nlat,nt) dimension crlap(mmax,nlat,nt),cilap(mmax,nlat,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension cr(mdb,ndb,nt),ci(mdb,ndb,nt) dimension wsave(lwsav),wk(lwk) c c preset coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = -fn*(fn+1.) 1 continue c c set laplacian coefficients from br,bi,cr,ci c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then c c all coefficients needed c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax brlap(m,n,k) = 0.0 bilap(m,n,k) = 0.0 crlap(m,n,k) = 0.0 cilap(m,n,k) = 0.0 4 continue 3 continue do 5 n=2,nlat brlap(1,n,k) = fnn(n)*br(1,n,k) bilap(1,n,k) = fnn(n)*bi(1,n,k) crlap(1,n,k) = fnn(n)*cr(1,n,k) cilap(1,n,k) = fnn(n)*ci(1,n,k) 5 continue do 6 m=2,mmax do 7 n=m,nlat brlap(m,n,k) = fnn(n)*br(m,n,k) bilap(m,n,k) = fnn(n)*bi(m,n,k) crlap(m,n,k) = fnn(n)*cr(m,n,k) cilap(m,n,k) = fnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then c c vorticity is zero so cr,ci=0 not used c do 12 k=1,nt do 13 n=1,nlat do 14 m=1,mmax brlap(m,n,k) = 0.0 bilap(m,n,k) = 0.0 14 continue 13 continue do 15 n=2,nlat brlap(1,n,k) = fnn(n)*br(1,n,k) bilap(1,n,k) = fnn(n)*bi(1,n,k) 15 continue do 16 m=2,mmax do 17 n=m,nlat brlap(m,n,k) = fnn(n)*br(m,n,k) bilap(m,n,k) = fnn(n)*bi(m,n,k) 17 continue 16 continue 12 continue else c c divergence is zero so br,bi=0 not used c do 22 k=1,nt do 23 n=1,nlat do 24 m=1,mmax crlap(m,n,k) = 0.0 cilap(m,n,k) = 0.0 24 continue 23 continue do 25 n=2,nlat crlap(1,n,k) = fnn(n)*cr(1,n,k) cilap(1,n,k) = fnn(n)*ci(1,n,k) 25 continue do 26 m=2,mmax do 27 n=m,nlat crlap(m,n,k) = fnn(n)*cr(m,n,k) cilap(m,n,k) = fnn(n)*ci(m,n,k) 27 continue 26 continue 22 continue end if c c sythesize coefs into vector field (vlap,wlap) c call vhsgc(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap,bilap, + crlap,cilap,mmax,nlat,wsave,lwsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vlapgs.f c c this file includes documentation and code for c subroutine vlapgs i c c ... files which must be loaded with vlapgs.f c c sphcom.f, hrfft.f, vhags.f, vhsgs.f, gaqd.f c c c c subroutine vlapgs(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci, c +mdbc,ndbc,wvhsgs,lvhsgs,work,lwork,ierror) c c given the vector spherical harmonic coefficients (br,bi,cr,ci) c precomputed by subroutine vhags for a vector field (v,w), subroutine c vlapgs computes the vector laplacian of the vector field (v,w) c in (vlap,wlap) (see the definition of the vector laplacian at c the output parameter description of vlap,wlap below). w and wlap c are east longitudinal components of the vectors. v and vlap are c colatitudinal components of the vectors. the laplacian components c in (vlap,wlap) have the same symmetry or lack of symmetry about the c equator as (v,w). the input parameters ityp,nt,mdbc,nbdc must have c the same values used by vhags to compute br,bi,cr, and ci for (v,w). c vlap(i,j) and wlap(i,j) are given on the sphere at the gaussian c colatitude theta(i) (see nlat as input parameter) and east longitude c lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon. c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct longitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp this parameter should have the same value input to subroutine c vhags to compute the coefficients br,bi,cr, and ci for the c vector field (v,w). ityp is set as follows: c c = 0 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c c c = 1 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c the vorticity of (v,w) is zero so the coefficients cr and c ci are zero and are not used. the vorticity of (vlap,wlap) c is also zero. c c c = 2 no symmetries exist in (v,w) about the equator. (vlap,wlap) c is computed and stored on the entire sphere in the arrays c vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon. c the divergence of (v,w) is zero so the coefficients br and c bi are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c = 3 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c vorticity of (v,w) is zero so the coefficients cr,ci are c zero and are not used. the vorticity of (vlap,wlap) is c also zero. c c = 5 w is antisymmetric and v is symmetric about the equator. c consequently wlap is antisymmetric and vlap is symmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c divergence of (v,w) is zero so the coefficients br,bi c are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c c = 6 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c vorticity of (v,w) is zero so the coefficients cr,ci are c zero and are not used. the vorticity of (vlap,wlap) is c also zero. c c = 8 w is symmetric and v is antisymmetric about the equator. c consequently wlap is symmetric and vlap is antisymmetric. c (vlap,wlap) is computed and stored on the northern c hemisphere only. if nlat is odd, storage is in the arrays c vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even, storage is in the arrays vlap(i,j), c wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon. the c divergence of (v,w) is zero so the coefficients br,bi c are zero and are not used. the divergence of (vlap,wlap) c is also zero. c c c nt nt is the number of vector fields (v,w). some computational c efficiency is obtained for multiple fields. in the program c that calls vlapgs, the arrays vlap,wlap,br,bi,cr and ci c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple vector synthesis will c be performed to compute the vector laplacian for each field. c the third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt=1. the description c of the remaining parameters is simplified by assuming that nt=1 c or that all arrays are two dimensional. c c idvw the first dimension of the arrays vlap and wlap as it appears c in the program that calls vlapgs. if ityp=0,1, or 2 then idvw c must be at least nlat. if ityp > 2 and nlat is even then idvw c must be at least nlat/2. if ityp > 2 and nlat is odd then idvw c must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays vlap and wlap as it appears c in the program that calls vlapgs. jdvw must be at least nlon. c c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhags. c br,bi,cr and ci must be computed by vhags prior to calling c vlapgs. if ityp=1,4, or 7 then cr,ci are not used and can c be dummy arguments. if ityp=2,5, or 8 then br,bi are not c used and can be dummy arguments. c c mdbc the first dimension of the arrays br,bi,cr and ci as it c appears in the program that calls vlapgs. mdbc must be c at least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndbc the second dimension of the arrays br,bi,cr and ci as it c appears in the program that calls vlapgs. ndbc must be at c least nlat. c c wvhsgs an array which must be initialized by subroutine vlapgsi c (or equivalently by vhsgsi). once initialized, wvhsgs c can be used repeatedly by vlapgs as long as nlat and nlon c remain unchanged. wvhsgs must not be altered between calls c of vlapgs. c c lvhsgs the dimension of the array wvhsgs as it appears in the c program that calls vlapgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lvhsgs must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vlapgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c if ityp .le. 2 then c c (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1) c c or if ityp .gt. 2 then c c (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1) c c will suffice as a length for lwork. c c ************************************************************** c c output parameters c c c vlap, two or three dimensional arrays (see input parameter nt) that c wlap contain the vector laplacian of the field (v,w). wlap(i,j) is c the east longitude component and vlap(i,j) is the colatitudinal c component of the vector laplacian. the definition of the c vector laplacian follows: c c let cost and sint be the cosine and sine at colatitude theta. c let d( )/dlambda and d( )/dtheta be the first order partial c derivatives in longitude and colatitude. let del2 be the scalar c laplacian operator c c del2(s) = [d(sint*d(s)/dtheta)/dtheta + c 2 2 c d (s)/dlambda /sint]/sint c c then the vector laplacian opeator c c dvel2(v,w) = (vlap,wlap) c c is defined by c c vlap = del2(v) - (2*cost*dw/dlambda + v)/sint**2 c c wlap = del2(w) + (2*cost*dv/dlambda - w)/sint**2 c c ierror a parameter which flags errors in input parameters as follows: c c = 0 no errors detected c c = 1 error in the specification of nlat c c = 2 error in the specification of nlon c c = 3 error in the specification of ityp c c = 4 error in the specification of nt c c = 5 error in the specification of idvw c c = 6 error in the specification of jdvw c c = 7 error in the specification of mdbc c c = 8 error in the specification of ndbc c c = 9 error in the specification of lvhsgs c c = 10 error in the specification of lwork c c c ********************************************************************** c c end of documentation for vlapgs c c ********************************************************************** c subroutine vlapgs(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi, +cr,ci,mdbc,ndbc,wvhsgs,lvhsgs,work,lwork,ierror) dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt) dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt) dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt) dimension wvhsgs(lvhsgs),work(lwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdbc .lt. mmax) return ierror = 8 if(ndbc .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid lsavmin = lzimn+lzimn+nlon+15 if(lvhsgs .lt. lsavmin) return c c verify unsaved work space length c mn = mmax*nlat*nt l2 = (nlat+1)/2 l1 = mmax if (ityp .le. 2) then lwkmin = (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1) else lwkmin = (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers for vector laplacian coefficients c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr+mn else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then ibr = 1 ibi = ibr+mn icr = ibi+mn ici = icr else ibr = 1 ibi = 1 icr = ibi+mn ici = icr+mn end if ifn = ici + mn iwk = ifn + nlat liwk = lwork-4*mn-nlat call vlapgs1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,work(ibr), +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi, +cr,ci,wvhsgs,lvhsgs,work(iwk),liwk,ierror) return end subroutine vlapgs1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap, +bilap,crlap,cilap,mmax,fnn,mdb,ndb,br,bi,cr,ci,wsave,lsave, +wk,lwk,ierror) dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt) dimension fnn(nlat),brlap(mmax,nlat,nt),bilap(mmax,nlat,nt) dimension crlap(mmax,nlat,nt),cilap(mmax,nlat,nt) dimension br(mdb,ndb,nt),bi(mdb,ndb,nt) dimension cr(mdb,ndb,nt),ci(mdb,ndb,nt) dimension wsave(lsave),wk(lwk) c c preset coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) fnn(n) = -fn*(fn+1.) 1 continue c c set laplacian coefficients from br,bi,cr,ci c if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then c c all coefficients needed c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mmax brlap(m,n,k) = 0.0 bilap(m,n,k) = 0.0 crlap(m,n,k) = 0.0 cilap(m,n,k) = 0.0 4 continue 3 continue do 5 n=2,nlat brlap(1,n,k) = fnn(n)*br(1,n,k) bilap(1,n,k) = fnn(n)*bi(1,n,k) crlap(1,n,k) = fnn(n)*cr(1,n,k) cilap(1,n,k) = fnn(n)*ci(1,n,k) 5 continue do 6 m=2,mmax do 7 n=m,nlat brlap(m,n,k) = fnn(n)*br(m,n,k) bilap(m,n,k) = fnn(n)*bi(m,n,k) crlap(m,n,k) = fnn(n)*cr(m,n,k) cilap(m,n,k) = fnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then c c vorticity is zero so cr,ci=0 not used c do 12 k=1,nt do 13 n=1,nlat do 14 m=1,mmax brlap(m,n,k) = 0.0 bilap(m,n,k) = 0.0 14 continue 13 continue do 15 n=2,nlat brlap(1,n,k) = fnn(n)*br(1,n,k) bilap(1,n,k) = fnn(n)*bi(1,n,k) 15 continue do 16 m=2,mmax do 17 n=m,nlat brlap(m,n,k) = fnn(n)*br(m,n,k) bilap(m,n,k) = fnn(n)*bi(m,n,k) 17 continue 16 continue 12 continue else c c divergence is zero so br,bi=0 not used c do 22 k=1,nt do 23 n=1,nlat do 24 m=1,mmax crlap(m,n,k) = 0.0 cilap(m,n,k) = 0.0 24 continue 23 continue do 25 n=2,nlat crlap(1,n,k) = fnn(n)*cr(1,n,k) cilap(1,n,k) = fnn(n)*ci(1,n,k) 25 continue do 26 m=2,mmax do 27 n=m,nlat crlap(m,n,k) = fnn(n)*cr(m,n,k) cilap(m,n,k) = fnn(n)*ci(m,n,k) 27 continue 26 continue 22 continue end if c c sythesize coefs into vector field (vlap,wlap) c call vhsgs(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap,bilap, + crlap,cilap,mmax,nlat,wsave,lsave,wk,lwk,ierror) return end subroutine vout ( variable, name ) c*********************************************************************72 c cc VOUT prints a real variable. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 30 November 2009 c c Author: c c John Burkardt c c Parameters: c c Input, real VARIABLE, the value to be printed. c c Input, hollerith NAME, the name. c implicit none character*(*) name real variable write ( *, '(a4,'' = '', g14.6 )' ) name, variable return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c c ... file vrtec.f c c this file includes documentation and code for c subroutine divec i c c ... files which must be loaded with vrtec.f c c sphcom.f, hrfft.f, vhaec.f,shsec.f c c subroutine vrtec(nlat,nlon,isym,nt,vt,ivrt,jvrt,cr,ci,mdc,ndc, c + wshsec,lshsec,work,lwork,ierror) c c given the vector spherical harmonic coefficients cr and ci, precomputed c by subroutine vhaec for a vector field (v,w), subroutine vrtec c computes the vorticity of the vector field in the scalar array c vt. vt(i,j) is the vorticity at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. i.e., c c vt(i,j) = [-dv/dlambda + d(sint*w)/dtheta]/sint c c where sint = sin(theta(i)). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c cr,ci were precomputed. required associated legendre polynomials c are recomputed rather than stored as they are in subroutine vrtes. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the vorticity is c computed on the full or half sphere as follows: c c = 0 c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case the c vorticity is neither symmetric nor antisymmetric about c the equator. the vorticity is computed on the entire c sphere. i.e., in the array vt(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c w is antisymmetric and v is symmetric about the equator. c in this case the vorticity is symmetyric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the vorticity is computed c in the array vt(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the vorticity is computed c in the array vt(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c w is symmetric and v is antisymmetric about the equator c in this case the vorticity is antisymmetric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the vorticity is computed c in the array vt(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the vorticity is computed c in the array vt(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c in the program that calls vrtec, the arrays cr,ci, and vort c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute the vorticity for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c ivrt the first dimension of the array vt as it appears in c the program that calls vrtec. if isym = 0 then ivrt c must be at least nlat. if isym = 1 or 2 and nlat is c even then ivrt must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then ivrt must be at least (nlat+1)/2. c c jvrt the second dimension of the array vt as it appears in c the program that calls vrtec. jvrt must be at least nlon. c c cr,ci two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaec. c *** cr and ci must be computed by vhaec prior to calling c vrtec. c c mdc the first dimension of the arrays cr and ci as it c appears in the program that calls vrtec. mdc must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndc the second dimension of the arrays cr and ci as it c appears in the program that calls vrtec. ndc must be at c least nlat. c c wshsec an array which must be initialized by subroutine shseci. c once initialized, c wshsec can be used repeatedly by vrtec as long as nlon c and nlat remain unchanged. wshsec must not be altered c between calls of vrtec c c lshsec the dimension of the array wshsec as it appears in the c program that calls vrtec. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsec must be at least c c 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vrtec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c if isym is zero then lwork must be at least c c nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) c c if isym is not zero then lwork must be at least c c l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) c c c c ************************************************************** c c output parameters c c c vt a two or three dimensional array (see input parameter nt) c that contains the vorticity of the vector field (v,w) c whose coefficients cr,ci where computed by subroutine vhaec. c vt(i,j) is the vorticity at the colatitude point theta(i) = c (i-1)*pi/(nlat-1) and longitude point lambda(j) = c (j-1)*2*pi/nlon. the index ranges are defined above at the c input parameter isym. c c c ierror an error parameter which indicates fatal errors with input c parameters when returned positive. c = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of ivrt c = 6 error in the specification of jvrt c = 7 error in the specification of mdc c = 8 error in the specification of ndc c = 9 error in the specification of lshsec c = 10 error in the specification of lwork c ********************************************************************** c c subroutine vrtec(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, + wshsec,lshsec,work,lwork,ierror) dimension vort(ivrt,jvrt,nt),cr(mdc,ndc,nt),ci(mdc,ndc,nt) dimension wshsec(lshsec),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ivrt.lt.nlat) .or. 1 (isym.gt.0 .and. ivrt.lt.imid)) return ierror = 6 if(jvrt .lt. nlon) return ierror = 7 if(mdc .lt. min0(nlat,(nlon+1)/2)) return mmax = min0(nlat,(nlon+2)/2) ierror = 8 if(ndc .lt. nlat) return ierror = 9 c c verify saved work space (same as shec) c lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lshsec .lt. lzz1+labc+nlon+15) return ierror = 10 c c verify unsaved work space (add to what shec requires) c ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c c set first dimension for a,b (as requried by shsec) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt c if(lwork.lt.nln+max0(ls*nlon,3*nlat*imid)+2*mn+nlat) return l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 if (isym .eq. 0) then lwkmin = nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call vrtec1(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, +work(ia),work(ib),mab,work(is),wshsec,lshsec,work(iwk),lwk, +ierror) return end subroutine vrtec1(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, + a,b,mab,sqnn,wshsec,lshsec,wk,lwk,ierror) dimension vort(ivrt,jvrt,nt),cr(mdc,ndc,nt),ci(mdc,ndc,nt) dimension a(mab,nlat,nt),b(mab,nlat,nt),sqnn(nlat) dimension wshsec(lshsec),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute vorticity scalar coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = sqnn(n)*cr(1,n,k) b(1,n,k) = sqnn(n)*ci(1,n,k) 5 continue c c compute m>0 coefficients, use mmax from vector coef range c mmax = min0(nlat,(nlon+1)/2) do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = sqnn(n)*cr(m,n,k) b(m,n,k) = sqnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue c c synthesize a,b into vort c call shsec(nlat,nlon,isym,nt,vort,ivrt,jvrt,a,b, + mab,nlat,wshsec,lshsec,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vrtes.f c c this file includes documentation and code for c subroutine divec i c c ... files which must be loaded with vrtes.f c c sphcom.f, hrfft.f, vhaes.f,shses.f c c subroutine vrtes(nlat,nlon,isym,nt,vt,ivrt,jvrt,cr,ci,mdc,ndc, c + wshses,lshses,work,lwork,ierror) c c given the vector spherical harmonic coefficients cr and ci, precomputed c by subroutine vhaes for a vector field (v,w), subroutine vrtes c computes the vorticity of the vector field in the scalar array c vt. vt(i,j) is the vorticity at the colatitude c c theta(i) = (i-1)*pi/(nlat-1) c c and longitude c c lambda(j) = (j-1)*2*pi/nlon c c on the sphere. i.e., c c vt(i,j) = [-dv/dlambda + d(sint*w)/dtheta]/sint c c where sint = sin(theta(i)). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c cr,ci were precomputed. required associated legendre polynomials c are stored rather than recomputed as they are in subroutine vrtec. c c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the vorticity is c computed on the full or half sphere as follows: c c = 0 c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case the c vorticity is neither symmetric nor antisymmetric about c the equator. the vorticity is computed on the entire c sphere. i.e., in the array vt(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c w is antisymmetric and v is symmetric about the equator. c in this case the vorticity is symmetyric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the vorticity is computed c in the array vt(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the vorticity is computed c in the array vt(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c w is symmetric and v is antisymmetric about the equator c in this case the vorticity is antisymmetric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the vorticity is computed c in the array vt(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the vorticity is computed c in the array vt(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c in the program that calls vrtes, the arrays cr,ci, and vort c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute the vorticity for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c ivrt the first dimension of the array vt as it appears in c the program that calls vrtes. if isym = 0 then ivrt c must be at least nlat. if isym = 1 or 2 and nlat is c even then ivrt must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then ivrt must be at least (nlat+1)/2. c c jvrt the second dimension of the array vt as it appears in c the program that calls vrtes. jvrt must be at least nlon. c c cr,ci two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhaes. c *** cr and ci must be computed by vhaes prior to calling c vrtes. c c mdc the first dimension of the arrays cr and ci as it c appears in the program that calls vrtes. mdc must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndc the second dimension of the arrays cr and ci as it c appears in the program that calls vrtes. ndc must be at c least nlat. c c wshses an array which must be initialized by subroutine shsesi. c once initialized, c wshses can be used repeatedly by vrtes as long as nlon c and nlat remain unchanged. wshses must not be altered c between calls of vrtes c c lshses the dimension of the array wshses as it appears in the c program that calls vrtes. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshses must be at least c c (l1*l2*(nlat+nlat-l1+1))/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vrtes. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c if isym = 0 then lwork must be at least c c nlat*((nt+1)*nlon+2*nt*l1+1) c c if isym > 0 then lwork must be at least c c (nt+1)*l2*nlon+nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c vt a two or three dimensional array (see input parameter nt) c that contains the vorticity of the vector field (v,w) c whose coefficients cr,ci where computed by subroutine vhaes. c vt(i,j) is the vorticity at the colatitude point theta(i) = c (i-1)*pi/(nlat-1) and longitude point lambda(j) = c (j-1)*2*pi/nlon. the index ranges are defined above at the c input parameter isym. c c c ierror an error parameter which indicates fatal errors with input c parameters when returned positive. c = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of ivrt c = 6 error in the specification of jvrt c = 7 error in the specification of mdc c = 8 error in the specification of ndc c = 9 error in the specification of lshses c = 10 error in the specification of lwork c ********************************************************************** c c subroutine vrtes(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, + wshses,lshses,work,lwork,ierror) dimension vort(ivrt,jvrt,nt),cr(mdc,ndc,nt),ci(mdc,ndc,nt) dimension wshses(lshses),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ivrt.lt.nlat) .or. 1 (isym.gt.0 .and. ivrt.lt.imid)) return ierror = 6 if(jvrt .lt. nlon) return ierror = 7 if(mdc .lt. min0(nlat,(nlon+1)/2)) return mmax = min0(nlat,(nlon+2)/2) ierror = 8 if(ndc .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lshses .lt. lpimn+nlon+15) return ierror = 10 c c verify unsaved work space (add to what shses requires, file f3) c c c set first dimension for a,b (as requried by shses) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon if(lwork.lt. nln+ls*nlon+2*mn+nlat) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call vrtes1(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, +work(ia),work(ib),mab,work(is),wshses,lshses,work(iwk),lwk, +ierror) return end subroutine vrtes1(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, + a,b,mab,sqnn,wsav,lwsav,wk,lwk,ierror) dimension vort(ivrt,jvrt,nt),cr(mdc,ndc,nt),ci(mdc,ndc,nt) dimension a(mab,nlat,nt),b(mab,nlat,nt),sqnn(nlat) dimension wsav(lwsav),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute divergence scalar coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = sqnn(n)*cr(1,n,k) b(1,n,k) = sqnn(n)*ci(1,n,k) 5 continue c c compute m>0 coefficients c mmax = min0(nlat,(nlon+1)/2) do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = sqnn(n)*cr(m,n,k) b(m,n,k) = sqnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue c c synthesize a,b into vort c call shses(nlat,nlon,isym,nt,vort,ivrt,jvrt,a,b, + mab,nlat,wsav,lwsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vrtgc.f c c this file includes documentation and code for c subroutine divec i c c ... files which must be loaded with vrtgc.f c c sphcom.f, hrfft.f, vhagc.f, shsgc.f, gaqd.f c c subroutine vrtgc(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, c + wshsgc,lshsgc,work,lwork,ierror) c c given the vector spherical harmonic coefficients cr and ci, precomputed c by subroutine vhagc for a vector field (v,w), subroutine vrtgc c computes the vorticity of the vector field in the scalar array c vort. vort(i,j) is the vorticity at the gaussian colatitude c theta(i) (see nlat as input parameter) and longitude c lambda(j) = (j-1)*2*pi/nlon on the sphere. i.e., c c vort(i,j) = [-dv/dlambda + d(sint*w)/dtheta]/sint c c where sint = sin(theta(i)). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c cr,ci were precomputed. required associated legendre polynomials c are recomputed rather than stored as they are in subroutine vrtgs. c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the vorticity is c computed on the full or half sphere as follows: c c = 0 c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case the c vorticity is neither symmetric nor antisymmetric about c the equator. the vorticity is computed on the entire c sphere. i.e., in the array vort(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c w is antisymmetric and v is symmetric about the equator. c in this case the vorticity is symmetyric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the vorticity is computed c in the array vort(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the vorticity is computed c in the array vort(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c w is symmetric and v is antisymmetric about the equator c in this case the vorticity is antisymmetric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the vorticity is computed c in the array vort(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the vorticity is computed c in the array vort(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c in the program that calls vrtgc, the arrays cr,ci, and vort c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute the vorticity for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c ivrt the first dimension of the array vort as it appears in c the program that calls vrtgc. if isym = 0 then ivrt c must be at least nlat. if isym = 1 or 2 and nlat is c even then ivrt must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then ivrt must be at least (nlat+1)/2. c c jvrt the second dimension of the array vort as it appears in c the program that calls vrtgc. jvrt must be at least nlon. c c cr,ci two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhagc. c *** cr and ci must be computed by vhagc prior to calling c vrtgc. c c mdc the first dimension of the arrays cr and ci as it c appears in the program that calls vrtgc. mdc must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndc the second dimension of the arrays cr and ci as it c appears in the program that calls vrtgc. ndc must be at c least nlat. c c wshsgc an array which must be initialized by subroutine shsgci. c once initialized, c wshsgc can be used repeatedly by vrtgc as long as nlon c and nlat remain unchanged. wshsgc must not be altered c between calls of vrtgc c c lshsgc the dimension of the array wshsgc as it appears in the c program that calls vrtgc. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgc must be at least c c nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vrtgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c if isym is zero then lwork must be at least c c nlat*(nlon*nt+max0(3*l2,nlon) + 2*nt*l1+1) c c if isym is not zero then lwork must be at least c c l2*(nlon*nt+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c vort a two or three dimensional array (see input parameter nt) c that contains the vorticity of the vector field (v,w) c whose coefficients cr,ci where computed by subroutine vhagc. c vort(i,j) is the vorticity at the gaussian colatitude point c theta(i) and longitude point lambda(j) = (j-1)*2*pi/nlon. c the index ranges are defined above at the input parameter c isym. c c c ierror an error parameter which indicates fatal errors with input c parameters when returned positive. c = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of ivrt c = 6 error in the specification of jvrt c = 7 error in the specification of mdc c = 8 error in the specification of ndc c = 9 error in the specification of lshsgc c = 10 error in the specification of lwork c ********************************************************************** c c subroutine vrtgc(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, + wshsgc,lshsgc,work,lwork,ierror) dimension vort(ivrt,jvrt,nt),cr(mdc,ndc,nt),ci(mdc,ndc,nt) dimension wshsgc(lshsgc),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ivrt.lt.nlat) .or. 1 (isym.gt.0 .and. ivrt.lt.imid)) return ierror = 6 if(jvrt .lt. nlon) return ierror = 7 if(mdc .lt. min0(nlat,(nlon+1)/2)) return mmax = min0(nlat,(nlon+2)/2) ierror = 8 if(ndc .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 lwmin = nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15 if (lshsgc .lt. lwmin) return ierror = 10 c c verify unsaved work space (add to what shses requires, file f3) c c c set first dimension for a,b (as requried by shses) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon c if(lwork.lt. nln+ls*nlon+2*mn+nlat) return l1 = min0(nlat,(nlon+2)/2) l2 = (nlat+1)/2 if (isym .eq. 0) then lwkmin = nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1) else lwkmin = l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1) end if if (lwork .lt. lwkmin) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call vrtgc1(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, +work(ia),work(ib),mab,work(is),wshsgc,lshsgc,work(iwk),lwk, +ierror) return end subroutine vrtgc1(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, + a,b,mab,sqnn,wsav,lwsav,wk,lwk,ierror) dimension vort(ivrt,jvrt,nt),cr(mdc,ndc,nt),ci(mdc,ndc,nt) dimension a(mab,nlat,nt),b(mab,nlat,nt),sqnn(nlat) dimension wsav(lwsav),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute divergence scalar coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = sqnn(n)*cr(1,n,k) b(1,n,k) = sqnn(n)*ci(1,n,k) 5 continue c c compute m>0 coefficients c mmax = min0(nlat,(nlon+1)/2) do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = sqnn(n)*cr(m,n,k) b(m,n,k) = sqnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue c c synthesize a,b into vort c call shsgc(nlat,nlon,isym,nt,vort,ivrt,jvrt,a,b, + mab,nlat,wsav,lwsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vrtgs.f c c this file includes documentation and code for c subroutine divgs i c c ... files which must be loaded with vrtgs.f c c sphcom.f, hrfft.f, vhgsc.f, shsgs.f, gaqd.f c c subroutine vrtgs(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, c + wshsgs,lshsgs,work,lwork,ierror) c c given the vector spherical harmonic coefficients cr and ci, precomputed c by subroutine vhags for a vector field (v,w), subroutine vrtgs c computes the vorticity of the vector field in the scalar array c vort. vort(i,j) is the vorticity at the gaussian colatitude c theta(i) (see nlat as input parameter) and longitude c lambda(j) = (j-1)*2*pi/nlon on the sphere. i.e., c c vort(i,j) = [-dv/dlambda + d(sint*w)/dtheta]/sint c c where sint = sin(theta(i)). w is the east longitudinal and v c is the colatitudinal component of the vector field from which c cr,ci were precomputed. required associated legendre polynomials c are stored rather than recomputed as they are in subroutine vrtgc. c c c input parameters c c nlat the number of points in the gaussian colatitude grid on the c full sphere. these lie in the interval (0,pi) and are computed c in radians in theta(1) <...< theta(nlat) by subroutine gaqd. c if nlat is odd the equator will be included as the grid point c theta((nlat+1)/2). if nlat is even the equator will be c excluded as a grid point and will lie half way between c theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3. c note: on the half sphere, the number of grid points in the c colatitudinal direction is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than 3. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c c isym a parameter which determines whether the vorticity is c computed on the full or half sphere as follows: c c = 0 c the symmetries/antsymmetries described in isym=1,2 below c do not exist in (v,w) about the equator. in this case the c vorticity is neither symmetric nor antisymmetric about c the equator. the vorticity is computed on the entire c sphere. i.e., in the array vort(i,j) for i=1,...,nlat and c j=1,...,nlon. c c = 1 c w is antisymmetric and v is symmetric about the equator. c in this case the vorticity is symmetyric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the vorticity is computed c in the array vort(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the vorticity is computed c in the array vort(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c = 2 c w is symmetric and v is antisymmetric about the equator c in this case the vorticity is antisymmetric about the c equator and is computed for the northern hemisphere c only. i.e., if nlat is odd the vorticity is computed c in the array vort(i,j) for i=1,...,(nlat+1)/2 and for c j=1,...,nlon. if nlat is even the vorticity is computed c in the array vort(i,j) for i=1,...,nlat/2 and j=1,...,nlon. c c c nt nt is the number of scalar and vector fields. some c computational efficiency is obtained for multiple fields. c in the program that calls vrtgs, the arrays cr,ci, and vort c can be three dimensional corresponding to an indexed multiple c vector field. in this case multiple scalar synthesis will c be performed to compute the vorticity for each field. the c third index is the synthesis index which assumes the values c k=1,...,nt. for a single synthesis set nt = 1. the c description of the remaining parameters is simplified by c assuming that nt=1 or that all the arrays are two dimensional. c c ivrt the first dimension of the array vort as it appears in c the program that calls vrtgs. if isym = 0 then ivrt c must be at least nlat. if isym = 1 or 2 and nlat is c even then ivrt must be at least nlat/2. if isym = 1 or 2 c and nlat is odd then ivrt must be at least (nlat+1)/2. c c jvrt the second dimension of the array vort as it appears in c the program that calls vrtgs. jvrt must be at least nlon. c c cr,ci two or three dimensional arrays (see input parameter nt) c that contain vector spherical harmonic coefficients c of the vector field (v,w) as computed by subroutine vhags. c *** cr and ci must be computed by vhags prior to calling c vrtgs. c c mdc the first dimension of the arrays cr and ci as it c appears in the program that calls vrtgs. mdc must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndc the second dimension of the arrays cr and ci as it c appears in the program that calls vrtgs. ndc must be at c least nlat. c c wshsgs an array which must be initialized by subroutine shsgsi. c once initialized, c wshsgs can be used repeatedly by vrtgs as long as nlon c and nlat remain unchanged. wshsgs must not be altered c between calls of vrtgs c c lshsgs the dimension of the array wshsgs as it appears in the c program that calls vrtgs. define c c l1 = min0(nlat,(nlon+2)/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lshsgs must be at least c c nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vrtgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd. c c if isym = 0 then lwork must be at least c c nlat*((nt+1)*nlon+2*nt*l1+1) c c if isym > 0 then lwork must be at least c c (nt+1)*l2*nlon+nlat*(2*nt*l1+1) c c c ************************************************************** c c output parameters c c c vort a two or three dimensional array (see input parameter nt) c that contains the vorticity of the vector field (v,w) c whose coefficients cr,ci where computed by subroutine vhags. c vort(i,j) is the vorticity at the gaussian colatitude point c theta(i) and longitude point lambda(j) = (j-1)*2*pi/nlon. c the index ranges are defined above at the input parameter c isym. c c c ierror an error parameter which indicates fatal errors with input c parameters when returned positive. c = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of isym c = 4 error in the specification of nt c = 5 error in the specification of ivrt c = 6 error in the specification of jvrt c = 7 error in the specification of mdc c = 8 error in the specification of ndc c = 9 error in the specification of lshsgs c = 10 error in the specification of lwork c ********************************************************************** c c subroutine vrtgs(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, + wshsgs,lshsgs,work,lwork,ierror) dimension vort(ivrt,jvrt,nt),cr(mdc,ndc,nt),ci(mdc,ndc,nt) dimension wshsgs(lshsgs),work(lwork) c c check input parameters c ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 4) return ierror = 3 if (isym.lt.0 .or. isym.gt.2) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((isym.eq.0 .and. ivrt.lt.nlat) .or. 1 (isym.gt.0 .and. ivrt.lt.imid)) return ierror = 6 if(jvrt .lt. nlon) return ierror = 7 if(mdc .lt. min0(nlat,(nlon+1)/2)) return mmax = min0(nlat,(nlon+2)/2) ierror = 8 if(ndc .lt. nlat) return ierror = 9 imid = (nlat+1)/2 lpimn = (imid*mmax*(nlat+nlat-mmax+1))/2 l2 = (nlat+mod(nlat,2))/2 l1 = min0((nlon+2)/2,nlat) lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15 if(lshsgs.lt.lp) return ierror = 10 c c verify unsaved work space (add to what shses requires, file f3) c c c set first dimension for a,b (as requried by shses) c mab = min0(nlat,nlon/2+1) mn = mab*nlat*nt ls = nlat if(isym .gt. 0) ls = imid nln = nt*ls*nlon if(lwork.lt. nln+ls*nlon+2*mn+nlat) return ierror = 0 c c set work space pointers c ia = 1 ib = ia+mn is = ib+mn iwk = is+nlat lwk = lwork-2*mn-nlat call vrtgs1(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, +work(ia),work(ib),mab,work(is),wshsgs,lshsgs,work(iwk),lwk, +ierror) return end subroutine vrtgs1(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc, + a,b,mab,sqnn,wsav,lwsav,wk,lwk,ierror) dimension vort(ivrt,jvrt,nt),cr(mdc,ndc,nt),ci(mdc,ndc,nt) dimension a(mab,nlat,nt),b(mab,nlat,nt),sqnn(nlat) dimension wsav(lwsav),wk(lwk) c c set coefficient multiplyers c do 1 n=2,nlat fn = float(n-1) sqnn(n) = sqrt(fn*(fn+1.)) 1 continue c c compute divergence scalar coefficients for each vector field c do 2 k=1,nt do 3 n=1,nlat do 4 m=1,mab a(m,n,k) = 0.0 b(m,n,k) = 0.0 4 continue 3 continue c c compute m=0 coefficients c do 5 n=2,nlat a(1,n,k) = sqnn(n)*cr(1,n,k) b(1,n,k) = sqnn(n)*ci(1,n,k) 5 continue c c compute m>0 coefficients c mmax = min0(nlat,(nlon+1)/2) do 6 m=2,mmax do 7 n=m,nlat a(m,n,k) = sqnn(n)*cr(m,n,k) b(m,n,k) = sqnn(n)*ci(m,n,k) 7 continue 6 continue 2 continue c c synthesize a,b into vort c call shsgs(nlat,nlon,isym,nt,vort,ivrt,jvrt,a,b, + mab,nlat,wsav,lwsav,wk,lwk,ierror) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vshifte.f contains code and documentation for subroutine vshifte c and its initialization subroutine vshifti c c ... required files c c hrfft.f c c subroutine vshifte(ioff,nlon,nlat,uoff,voff,ureg,vreg, c + wsave,lsave,work,lwork,ierror) c c *** purpose c c subroutine vshifte does a highly accurate 1/2 grid increment shift c in both longitude and latitude of equally spaced vector data on the c sphere. data is transferred between the nlon by nlat "offset grid" c in (uoff,voff) (which excludes poles) and the nlon by nlat+1 "regular c grid" in (ureg,vreg) (which includes poles). the transfer can go from c (uoff,voff) to (ureg,vreg) or vice versa (see ioff). the grids which c underly the vector fields are described below. the north and south c pole are at 0.5*pi and-0.5*pi radians respectively (pi=4.*atan(1.)). c uoff and ureg are the east longitudinal vector data components. voff c and vreg are the latitudinal vector data components. c c subroutine sshifte can be used to shift scalar data on the sphere. c notice that scalar and vector quantities are fundamentally different c on the sphere. for example, vectors are discontinuous and multiple c valued at the poles. scalars are continuous and single valued at the c poles. erroneous results would be produced if one attempted to shift c vector fields with subroutine sshifte applied to each component of c of the vector. c c *** grid descriptions c c let dlon = (pi+pi)/nlon and dlat = pi/nlat be the uniform grid c increments in longitude and latitude c c offset grid c c the "1/2 increment offset" grid (long(j),lat(i)) on which uoff(j,i) c and voff(j,i) are given (ioff=0) or generated (ioff=1) is c c long(j) =0.5*dlon + (j-1)*dlon (j=1,...,nlon) c c and c c lat(i) = -0.5*pi + 0.5*dlat + (i-1)*dlat (i=1,...,nlat) c c the data in (uoff,voff) is "shifted" one half a grid increment in both c longitude and latitude and excludes the poles. each uoff(j,1),voff(j,1) c is given at latitude -pi/2+dlat/2. uoff(j,nlat),voff(j,nlat) is c given at pi/2-dlat/2 (1/2 a grid increment away from the poles). c uoff(1,i),voff(1,i) is given at longitude dlon/2. each uoff(nlon,i), c voff(nlon,i) is given at longitude 2*pi-dlon/2. c c regular grid c c let dlat,dlon be as above. then the nlon by nlat+1 grid on which c ureg(j,i),vreg(j,i) are generated (ioff=0) or given (ioff=1) is c c lone(j) = (j-1)*dlon (j=1,...,nlon) c c and c c late(i) = -0.5*pi + (i-1)*dlat (i=1,...,nlat+1) c c values in ureg,vreg include the poles and start at zero degrees c longitude and at the south pole this is the "usual" equally spaced c grid in geophysical coordinates. c c *** remark c c subroutine vshifte can be used in conjunction with subroutine trvsph c when transferring vector data from an equally spaced "1/2 increment c offset" grid to a gaussian or equally spaced grid (which includes poles) c of any resolution. this problem (personal communication with dennis c shea) is encountered in geophysical modeling and data analysis. c c *** method c c fast fourier transform software from spherepack2 and trigonometric c identities are used to accurately "shift" periodic vectors half a c grid increment in latitude and longitude. latitudinal shifts are c accomplished by setting periodic 2*nlat vectors over the pole for each c longitude. vector values must be negated on one side of the pole c to maintain periodicity prior to the 2*nlat shift over the poles. c when nlon is odd, the 2*nlat latitudinal shift requires an additional c longitude shift to obtain symmetry necessary for full circle shifts c over the poles. finally longitudinal shifts are executed for each c shifted latitude. c c *** argument description c c ... ioff c c ioff = 0 if values on the offset grid in (uoff,voff) are given and c values on the regular grid in (ureg,vreg) are to be generated. c c ioff = 1 if values on the regular grid in (ureg,vreg) are given and c values on the offset grid in (uoff,voff) are to be generated. c c ... nlon c c the number of longitude points on both the "offset" and "regular" c uniform grid in longitude (see "grid description" above). nlon c is also the first dimension of uoff,voff,ureg,vreg. nlon determines c the grid increment in longitude as dlon = 2.*pi/nlon. for example, c nlon = 144 for a 2.5 degree grid. nlon can be even or odd and must c be greater than or equal to 4. the efficiency of the computation c is improved when nlon is a product of small primes. c c ... nlat c c the number of latitude points on the "offset" uniform grid. nlat+1 c is the number of latitude points on the "regular" uniform grid (see c "grid description" above). nlat is the second dimension of uoff,voff. c nlat+1 must be the second dimension of ureg,vreg in the program c calling vshifte. nlat determines the grid in latitude as pi/nlat. c for example, nlat = 36 for a five degree grid. nlat must be at least 3. c c ... uoff c c a nlon by nlat array that contains the east longitudinal vector c data component on the offset grid described above. uoff is a c given input argument if ioff=0. uoff is a generated output c argument if ioff=1. c c ... voff c c a nlon by nlat array that contains the latitudinal vector data c component on the offset grid described above. voff is a given c input argument if ioff=0. voff is a generated output argument c if ioff=1. c c ... ureg c c a nlon by nlat+1 array that contains the east longitudinal vector c data component on the regular grid described above. ureg is a given c input argument if ioff=1. ureg is a generated output argument c if ioff=0. c c ... vreg c c a nlon by nlat+1 array that contains the latitudinal vector data c component on the regular grid described above. vreg is a given c input argument if ioff=1. vreg is a generated output argument c if ioff=0. c c ... wsav c c a real saved work space array that must be initialized by calling c subroutine vshifti(ioff,nlon,nlat,wsav,ier) before calling vshifte. c wsav can then be used repeatedly by vshifte as long as ioff, nlon, c and nlat do not change. this bypasses redundant computations and c saves time. undetectable errors will result if vshifte is called c without initializing wsav whenever ioff, nlon, or nlat change. c c ... lsav c c the length of the saved work space wsav in the routine calling vshifte c and sshifti. lsave must be greater than or equal to 2*(2*nlat+nlon+16). c c ... work c c a real unsaved work space c c ... lwork c c the length of the unsaved work space in the routine calling vshifte c if nlon is even then lwork must be greater than or equal to c c 2*nlon*(nlat+1) c c if nlon is odd then lwork must be greater than or equal to c c nlon*(5*nlat+1) c c ... ier c c indicates errors in input parameters c c = 0 if no errors are detected c c = 1 if ioff is not equal to 0 or 1 c c = 2 if nlon < 4 c c = 3 if nlat < 3 c c = 4 if lsave < 2*(nlon+2*nlat)+32 c c = 5 if lwork < 2*nlon*(nlat+1) for nlon even or c lwork < nlon*(5*nlat+1) for nlon odd c c *** end of vshifte documentation c c subroutine vshifti(ioff,nlon,nlat,lsav,wsav,ier) c c subroutine vshifti initializes the saved work space wsav c for ioff and nlon and nlat (see documentation for vshifte). c vshifti must be called before vshifte whenever ioff or nlon c or nlat change. c c ... ier c c = 0 if no errors with input arguments c c = 1 if ioff is not 0 or 1 c c = 2 if nlon < 4 c c = 3 if nlat < 3 c c = 4 if lsav < 2*(2*nlat+nlon+16) c c *** end of vshifti documentation c subroutine vshifte(ioff,nlon,nlat,uoff,voff,ureg,vreg, + wsav,lsav,wrk,lwrk,ier) implicit none integer ioff,nlon,nlat,n2,nr,nlat2,nlatp1,lsav,lwrk,ier integer i1,i2,i3 real uoff(nlon,nlat),voff(nlon,nlat) real ureg(nlon,*),vreg(nlon,*) real wsav(lsav),wrk(lwrk) c c check input parameters c ier = 1 if (ioff*(ioff-1).ne.0) return ier = 2 if (nlon.lt.4) return ier = 3 if (nlat .lt. 3) return ier = 4 if (lsav .lt. 2*(2*nlat+nlon+16)) return nlat2 = nlat+nlat nlatp1 = nlat+1 n2 = (nlon+1)/2 ier = 5 if (2*n2 .eq. nlon) then if (lwrk .lt. 2*nlon*(nlat+1)) return nr = n2 i1 = 1 i2 = 1 i3 = i2+nlon*nlatp1 else if (lwrk .lt. nlon*(5*nlat+1)) return nr = nlon i1 = 1 i2 = i1+nlat2*nlon i3 = i2+nlatp1*nlon end if ier = 0 if (ioff.eq.0) then c c shift (uoff,voff) to (ureg,vreg) c call vhftoff(nlon,nlat,uoff,ureg,wsav,nr,nlat2, + nlatp1,wrk(i1),wrk(i2),wrk(i2),wrk(i3)) call vhftoff(nlon,nlat,voff,vreg,wsav,nr,nlat2, + nlatp1,wrk(i1),wrk(i2),wrk(i2),wrk(i3)) else c c shift (ureg,vreg) to (uoff,voff) c call vhftreg(nlon,nlat,uoff,ureg,wsav,nr,nlat2, + nlatp1,wrk(i1),wrk(i2),wrk(i2),wrk(i3)) call vhftreg(nlon,nlat,voff,vreg,wsav,nr,nlat2, + nlatp1,wrk(i1),wrk(i2),wrk(i2),wrk(i3)) end if end subroutine vshifti(ioff,nlon,nlat,lsav,wsav,ier) c c initialize wsav for vshifte c integer ioff,nlat,nlon,nlat2,isav,ier real wsav(lsav) real pi,dlat,dlon,dp ier = 1 if (ioff*(ioff-1).ne.0) return ier = 2 if (nlon .lt. 4) return ier = 3 if (nlat .lt. 3) return ier = 4 if (lsav .lt. 2*(2*nlat+nlon+16)) return ier = 0 pi = 4.0*atan(1.0) c c set lat,long increments c dlat = pi/nlat dlon = (pi+pi)/nlon c c set left or right latitude shifts c if (ioff.eq.0) then dp = -0.5*dlat else dp = 0.5*dlat end if nlat2 = nlat+nlat call vhifthi(nlat2,dp,wsav) c c set left or right longitude shifts c if (ioff.eq.0) then dp = -0.5*dlon else dp = 0.5*dlon end if isav = 4*nlat + 17 call vhifthi(nlon,dp,wsav(isav)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c subroutine VSURF(XEYE,YEYE,ZEYE,NTRI,X1,Y1,Z1,X2,Y2,Z2, 1 X3,Y3,Z3,ITYPE,WORK,IWORK) c c subroutine vsurf is like subroutine hidel except the triangles c are categorized. vsurf is also like solid except triangles rather c than lines are covered. c c written by paul n. swarztrauber, national center for atmospheric c research, p.o. box 3000, boulder, colorado, 80307 c c this program plots visible lines for the surface defined c by the input 3-d triangles with corners at (x1,y1,z1), (x2,y2,z2) c and (x3,y3,z3). the sides of these these triangles may or c may not be plotted depending on itype. if itype is 1 then the c side between points (x1,y1,z1) and (x2,y2,z2) is plotted if it c is visible. if itype is 2 then the side between (x2,y2,z2) c and (x3,y3,z3) is plotted. if itype is 3 then the visible portion c of the side between (x3,y3,z3) and (x1,y1,z1) is plotted. c any combination is possible by specifying itype to be one c of the following values: 0,1,2,3,12,13,23,123. c c the length of real array work must be at least 19*ntri c c the length of integer array iwork must be at least 19*ntri c c c the vertices of the triangles are renumbered by vsurf so that c their projections are orientated counterclockwise. the user need c only be aware that the vertices may be renumbered by vsurf. c dimension x1(ntri),y1(ntri),z1(ntri),x2(ntri),y2(ntri),z2(ntri), 1 x3(ntri),y3(ntri),z3(ntri),itype(ntri),work(19*ntri) INTEGER IWORK(19*NTRI) c call vsurf1(xeye,yeye,zeye,ntri,x1,y1,z1,x2,y2,z2,x3,y3,z3, 1 itype,work,work(ntri+1),work(2*ntri+1),work(3*ntri+1), 2 work(4*ntri+1),work(5*ntri+1),work(6*ntri+1),work(7*ntri+1), 3 work(8*ntri+1),work(9*ntri+1),work(10*ntri+1),work(11*ntri+1), 3 work(12*ntri+1),work(13*ntri+1),IWORK(14*NTRI+1),IWORK(6*NTRI+1), 4 IWORK(15*NTRI+1),IWORK(17*NTRI+1)) return end subroutine vsurf1(xeye,yeye,zeye,ntri,x1,y1,z1,x2,y2,z2,x3,y3,z3, 1 itype,px1,py1,px2,py2,px3,py3,vx1,vy1,vx2,vy2,vx3,vy3,tl,tr,kh, 2 next,istart,ifinal) c dimension x1(ntri),y1(ntri),z1(ntri),x2(ntri),y2(ntri),z2(ntri), 1 x3(ntri),y3(ntri),z3(ntri),itype(ntri), 2 px1(ntri),py1(ntri),px2(ntri),py2(ntri), 3 px3(ntri),py3(ntri),vx1(ntri),vy1(ntri), 4 vx2(ntri),vy2(ntri),vx3(ntri),vy3(ntri), 5 tl(ntri),tr(ntri),next(ntri),kh(ntri), 6 istart(2*ntri),ifinal(2*ntri),ltp(3), 7 ird(11),ip2(11),nct(11),ncv(11),last(11) c real l2e double precision le2 c c compute projections of 3-d points c le2 = .6931471805599453094172321d0 l2e = 1.d0/le2 fntri = ntri irmax = .5*l2e*log(fntri) irmax = min(irmax,10) irmp1 = irmax+1 do 4 icv=1,11 ncv(icv) = 0 4 continue nct(1) = 0 ip2(1) = 1 ird(1) = 0 isize = 4 do 7 irp1=2,irmp1 ir = irp1-1 nct(irp1) = 0 ip2(irp1) = 2**ir ird(irp1) = ird(ir)+isize isize = (ip2(irp1)+1)**2 7 continue isxm = ird(irmp1)+isize+1 do 8 isx=1,isxm istart(isx) = 0 ifinal(isx) = 0 8 continue do 6 i=1,ntri next(i) = 0 6 continue call prjct(0,xeye,yeye,zeye,x,y,z,dum1,dum2) c write(6,127) ntri 127 format(' ntri in hidel', i5) do 86 k=1,ntri call prjct(1,xeye,yeye,zeye,x1(k),y1(k),z1(k),px1(k),py1(k)) call prjct(1,xeye,yeye,zeye,x2(k),y2(k),z2(k),px2(k),py2(k)) call prjct(1,xeye,yeye,zeye,x3(k),y3(k),z3(k),px3(k),py3(k)) if (k .lt. 3) then c write(6,333) xeye,yeye,zeye,x1(k),y1(k),z1(k),px1(k),py1(k) 333 format(' xeye, etc.',8e8.1) endif 86 continue c c orientate triangles counter clockwise c do 70 k=1,ntri cprod = (px2(k)-px1(k))*(py3(k)-py1(k))-(py2(k)-py1(k)) 1 *(px3(k)-px1(k)) c if(cprod.eq.0.) write(6,79) k,px1(k),px2(k),px3(k), c - py1(k),py2(k),py3(k) 79 format(' cprod=0 at k=', i5,6e9.2) if(cprod.ge.0.) go to 70 px1h = px1(k) py1h = py1(k) px1(k) = px2(k) py1(k) = py2(k) px2(k) = px1h py2(k) = py1h x1hold = x1(k) y1hold = y1(k) z1hold = z1(k) x1(k) = x2(k) y1(k) = y2(k) z1(k) = z2(k) x2(k) = x1hold y2(k) = y1hold z2(k) = z1hold ityp = itype(k) if(ityp.eq.2) itype(k) = 3 if(ityp.eq.3) itype(k) = 2 if(ityp.eq.12) itype(k) = 13 if(ityp.eq.13) itype(k) = 12 70 continue c c set screen limits c pmax = px1(1) pmin = px1(1) do 87 k=1,ntri pmin = amin1(pmin,px1(k),py1(k),px2(k),py2(k),px3(k),py3(k)) pmax = amax1(pmax,px1(k),py1(k),px2(k),py2(k),px3(k),py3(k)) 87 continue pmin = 1.1*pmin pmax = 1.1*pmax call set(0.,1.,0.,1.,pmin,pmax,pmin,pmax,1) xmin = amin1(px1(1),px2(1),px3(1)) xmax = amax1(px1(1),px2(1),px3(1)) ymin = amin1(py1(1),py2(1),py3(1)) ymax = amax1(py1(1),py2(1),py3(1)) do 1 i=2,ntri xmin = amin1(xmin,px1(i),px2(i),px3(i)) xmax = amax1(xmax,px1(i),px2(i),px3(i)) ymin = amin1(ymin,py1(i),py2(i),py3(i)) ymax = amax1(ymax,py1(i),py2(i),py3(i)) 1 continue dmx = xmax-xmin dmy = ymax-ymin if(dmx .gt. dmy) go to 2 c = ymin d = ymax xmid = .5*(xmin+xmax) hdy = .5*dmy a = xmid-hdy b = xmid+hdy go to 3 2 a = xmin b = xmax ymid = .5*(ymin+ymax) hdx = .5*dmx c = ymid-hdx d = ymid+hdx 3 hgr = b-a c c categorize triangles c do 100 i=1,ntri xmin = amin1(px1(i),px2(i),px3(i)) xmax = amax1(px1(i),px2(i),px3(i)) ymin = amin1(py1(i),py2(i),py3(i)) ymax = amax1(py1(i),py2(i),py3(i)) dxt = amax1(xmax-xmin,ymax-ymin) if(dxt .gt. 0.) go to 10 ir = irmax go to 20 10 ir = l2e*log(hgr/dxt) ir = min(ir,irmax) 20 irp1 = ir+1 nct(irp1) = nct(irp1)+1 hr = hgr/ip2(irp1) xmid = .5*(xmin+xmax) id = (xmid-a)/hr+1.5 ymid = .5*(ymin+ymax) jd = (ymid-c)/hr+1.5 ijd = ip2(irp1)+1 isx = id+(jd-1)*ijd+ird(irp1) ifx = ifinal(isx) if(ifx .gt. 0) go to 50 istart(isx) = i go to 60 50 next(ifx) = i 60 ifinal(isx) = i 100 continue c write(6,106) tcat,(irp1,nct(irp1),irp1=1,irmp1) 106 format(' time to categorize ', e15.6/(' ir+1',i3,' ntri',i7)) c c sort triangles into boxes c l = 0 do 30 irp1=1,irmp1 if(nct(irp1) .eq. 0) go to 30 ist = ird(irp1)+1 isd = ip2(irp1)+1 call box(isd,istart(ist),next,l,ifinal) last(irp1) = l+1 30 continue do 35 irp1=1,irmp1 il = ird(irp1)+(ip2(irp1)+1)**2+1 if(istart(il) .eq. 0) istart(il) = last(irp1) 35 continue c write(6,31) tsort,l,ntri 31 format(' time to sort ', e15.6,' l', i8,' ntri',i8) do 90 k=1,ntri vx1(k) = px2(k)-px1(k) vy1(k) = py2(k)-py1(k) vx2(k) = px3(k)-px2(k) vy2(k) = py3(k)-py2(k) vx3(k) = px1(k)-px3(k) vy3(k) = py1(k)-py3(k) 90 continue tl1 = 0. tl2 = 0. maxs = 0 do 500 ir2=1,irmp1 if(nct(ir2) .eq. 0) go to 500 ist = ird(ir2) isd = ip2(ir2)+1 do 490 j2=1,isd do 480 i2=1,isd ist = ist+1 ls = istart(ist) lf = istart(ist+1)-1 if(lf .lt. ls) go to 480 c c define coverings c kcv = 0 i2m = i2-1 j2m = j2-1 do 300 ir1=1,irmp1 if(nct(ir1) .eq. 0) go to 300 if(ir1 .ge. ir2) go to 260 irdp = 2**(ir2-ir1) i1s = (i2m-1)/irdp i1f = (i2m+1)/irdp if = i2m+1-i1f*irdp if(if .gt. 0) i1f = i1f+1 j1s = (j2m-1)/irdp j1f = (j2m+1)/irdp jf = j2m+1-j1f*irdp if(jf .gt. 0) j1f = j1f+1 go to 270 260 irdp = 2**(ir1-ir2) i1s = irdp*(i2m-1) i1f = irdp*(i2m+1) j1s = irdp*(j2m-1) j1f = irdp*(j2m+1) 270 ijd = ip2(ir1)+1 i1s = max(i1s+1,1) i1f = min(i1f+1,ijd) j1s = max(j1s+1,1) j1f = min(j1f+1,ijd) ixh = (j1s-2)*ijd+ird(ir1) ixs = i1s+ixh ixf = i1f+ixh do 290 j1=j1s,j1f ixs = ixs+ijd kds = istart(ixs) ixf = ixf+ijd kdf = istart(ixf+1)-1 if(kdf .lt. kds) go to 290 do 280 kd=kds,kdf kcv = kcv+1 kh(kcv) = ifinal(kd) 280 continue 290 continue 300 continue do 310 icv=1,10 if(kcv .le. ncv(icv)) go to 310 ncv(icv) = kcv go to 320 310 continue c c 320 do 470 ldo=ls,lf l = ifinal(ldo) ith = itype(l) if(ith .eq. 0) go to 470 ltp(1) = 0 ltp(2) = 0 ltp(3) = 0 id1 = ith/100 ith = ith-100*id1 id2 = ith/10 id3 = ith-10*id2 if(id1 .ne. 0) ltp(id1) = 1 if(id2 .ne. 0) ltp(id2) = 1 if(id3 .ne. 0) ltp(id3) = 1 c if((ith.eq.123) .or. (ith.eq.12) .or.(ith.eq.13)) ltp(1) = 1 c if((ith.eq.123) .or. (ith.eq.23) .or.(ith.eq.12)) ltp(2) = 1 c if((ith.eq.123) .or. (ith.eq.13) .or.(ith.eq.23)) ltp(3) = 1 do 460 ns=1,3 go to (101,102,103),ns 101 if(ltp(ns) .eq. 0) go to 460 px4 = px1(l) py4 = py1(l) px5 = px2(l) py5 = py2(l) x4 = x1(l) y4 = y1(l) z4 = z1(l) x5 = x2(l) y5 = y2(l) z5 = z2(l) go to 105 102 if(ltp(ns) .eq. 0) go to 460 px4 = px2(l) py4 = py2(l) px5 = px3(l) py5 = py3(l) x4 = x2(l) y4 = y2(l) z4 = z2(l) x5 = x3(l) y5 = y3(l) z5 = z3(l) go to 105 103 if(ltp(ns) .eq. 0) go to 460 px4 = px1(l) py4 = py1(l) px5 = px3(l) py5 = py3(l) x4 = x1(l) y4 = y1(l) z4 = z1(l) x5 = x3(l) y5 = y3(l) z5 = z3(l) 105 x54 = px5-px4 y54 = py5-py4 nseg = 0 do 440 kd=1,kcv k = kh(kd) c17 = vx1(k)*y54-vy1(k)*x54 c27 = vx2(k)*y54-vy2(k)*x54 c37 = vx3(k)*y54-vy3(k)*x54 c14 = vy1(k)*(px4-px1(k))-vx1(k)*(py4-py1(k)) c25 = vy2(k)*(px4-px2(k))-vx2(k)*(py4-py2(k)) c36 = vy3(k)*(px4-px3(k))-vx3(k)*(py4-py3(k)) tmin = 0. tmax = 1. if(c17) 151,152,153 151 tmax = amin1(c14/c17,tmax) go to 154 152 if(c14) 154,440,440 153 tmin = amax1(c14/c17,tmin) 154 if(c27) 155,156,157 155 tmax = amin1(c25/c27,tmax) go to 158 156 if(c25) 158,440,440 157 tmin = amax1(c25/c27,tmin) 158 if(c37) 159,160,161 159 tmax = amin1(c36/c37,tmax) go to 162 160 if(c36) 162,440,440 161 tmin = amax1(c36/c37,tmin) 162 if(tmax-tmin .lt. .00001) go to 440 xpl = x4+tmin*(x5-x4) ypl = y4+tmin*(y5-y4) zpl = z4+tmin*(z5-z4) xpr = x4+tmax*(x5-x4) ypr = y4+tmax*(y5-y4) zpr = z4+tmax*(z5-z4) c c the projections of line and plane intersect c now determine if plane covers line c vx1t = x2(k)-x1(k) vy1t = y2(k)-y1(k) vz1t = z2(k)-z1(k) vx2t = x3(k)-x1(k) vy2t = y3(k)-y1(k) vz2t = z3(k)-z1(k) apl = vy1t*vz2t-vy2t*vz1t bpl = vx2t*vz1t-vx1t*vz2t cpl = vx1t*vy2t-vx2t*vy1t dpl = apl*x1(k)+bpl*y1(k)+cpl*z1(k) vx3t = xpl-xeye vy3t = ypl-yeye vz3t = zpl-zeye den = apl*vx3t+bpl*vy3t+cpl*vz3t til = 0. if(den .eq. 0.) go to 410 til = (dpl-apl*xeye-bpl*yeye-cpl*zeye)/den 410 vx3t = xpr-xeye vy3t = ypr-yeye vz3t = zpr-zeye den = apl*vx3t+bpl*vy3t+cpl*vz3t tir = 0. if(den .eq. 0.) go to 412 tir = (dpl-apl*xeye-bpl*yeye-cpl*zeye)/den 412 if(til.ge..99999.and.tir.ge..99999) go to 440 if(til.lt.1..and.tir.lt.1.) go to 164 vx3t = xpr-xpl vy3t = ypr-ypl vz3t = zpr-zpl den = apl*vx3t+bpl*vy3t+cpl*vz3t tim = 0. if(den .eq. 0.) go to 414 tim = (dpl-apl*xpl-bpl*ypl-cpl*zpl)/den 414 thold = tmin+tim*(tmax-tmin) if(til.ge.1.) go to 163 tmax = thold go to 164 163 tmin = thold 164 nseg = nseg+1 tl(nseg) = tmin tr(nseg) = tmax 440 continue maxs = max0(maxs,nseg) if(nseg-1)171,180,172 171 call line(px4,py4,px5,py5) go to 460 c c order the segments according to left end point tl(k) c 172 do 173 k=2,nseg do 173 i=k,nseg if(tl(k-1).le.tl(i)) go to 173 tlh = tl(k-1) trh = tr(k-1) tl(k-1) = tl(i) tr(k-1) = tr(i) tl(i) = tlh tr(i) = trh 173 continue c c eliminate segment overlap c k1 = 1 k2 = 1 174 k2 = k2+1 if(k2.gt.nseg) go to 176 if(tr(k1).lt.tl(k2)) go to 175 tr(k1) = amax1(tr(k1),tr(k2)) go to 174 175 k1 = k1+1 tl(k1) = tl(k2) tr(k1) = tr(k2) go to 174 176 nseg = k1 c c plot all segments of the line c 180 do 181 ks =1,nseg kb = nseg-ks+1 tl(kb+1) = tr(kb) tr(kb) = tl(kb) 181 continue tl(1) = 0. tr(nseg+1) = 1. nsegp = nseg+1 do 450 k=1,nsegp if(abs(tr(k)-tl(k)).lt..000001) go to 450 xa = px4+tl(k)*(px5-px4) ya = py4+tl(k)*(py5-py4) xb = px4+tr(k)*(px5-px4) yb = py4+tr(k)*(py5-py4) call line(xa,ya,xb,yb) 450 continue 460 continue 470 continue 480 continue 490 continue 500 continue c write(6,903) tl1,tl2 903 format(' time to cover', e15.6/ 1 ' time to test ', e15.6) c write(6,904) maxs 904 format(' maximum number of segments', i5) c write(6,250) (ncv(icv),icv=1,10) 250 format(' the ten largest coverings'/(10i5)) call frame end subroutine vtgint (nlat,nlon,theta,wvbin,work) dimension wvbin(*) double precision theta(*), work(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c theta is a double precision array with (nlat+1)/2 locations c nlat is the maximum value of n+1 c the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of work is nlat+2 c call vtgit1 (nlat,nlon,imid,theta,wvbin,wvbin(iw1), + work,work(nlat/2+2)) return end subroutine vtgit1 (nlat,nlon,imid,theta,vb,abc,cvb,work) c c abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c locations where mmax = min0(nlat,(nlon+1)/2) c cvb and work must each have nlat/2+1 locations c dimension vb(imid,nlat,2),abc(*) double precision theta(*),cvb(*),work(*),vbh mdo = min0(2,nlat,(nlon+1)/2) do 160 mp1=1,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dvtk(m,n,cvb,work) do 165 i=1,imid call dvtt(m,n,theta(i),cvb,vbh) vb(i,np1,mp1) = vbh 165 continue 160 continue call rabcv(nlat,nlon,abc) return end subroutine vtini1 (nlat,nlon,imid,vb,abc,cvb,work) c c abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c locations where mmax = min0(nlat,(nlon+1)/2) c cvb and work must each have nlat/2+1 locations c dimension vb(imid,nlat,2),abc(1),cvb(1) double precision pi,dt,cvb,th,vbh,work(*) pi = 4.*datan(1.d0) dt = pi/(nlat-1) mdo = min0(2,nlat,(nlon+1)/2) do 160 mp1=1,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dvtk(m,n,cvb,work) do 165 i=1,imid th = (i-1)*dt call dvtt(m,n,th,cvb,vbh) vb(i,np1,mp1) = vbh 165 continue 160 continue call rabcv(nlat,nlon,abc) return end subroutine vtinit (nlat,nlon,wvbin,dwork) dimension wvbin(*) double precision dwork(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of dwork is nlat+2 c call vtini1 (nlat,nlon,imid,wvbin,wvbin(iw1),dwork, 1 dwork(nlat/2+2)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vtsec.f c c this file includes documentation and code for c subroutines vtsec and vtseci c c ... files which must be loaded with vtsec.f c c sphcom.f, hrfft.f, vhaec.f, vhsec.f c c subroutine vtsec(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvts,lwvts,work,lwork,ierror) c c given the vector harmonic analysis br,bi,cr, and ci (computed c by subroutine vhaec) of some vector function (v,w), this c subroutine computes the vector function (vt,wt) which is c the derivative of (v,w) with respect to colatitude theta. vtsec c is similar to vhsec except the vector harmonics are replaced by c their derivative with respect to colatitude with the result that c (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative c of the colatitudinal component v(i,j) at the point theta(i) = c (i-1)*pi/(nlat-1) and longitude phi(j) = (j-1)*2*pi/nlon. the c spectral representation of (vt,wt) is given below at output c parameters vt,wt. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. the arrays c vt(i,j),wt(i,j) are computed for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator however the c the coefficients cr and ci are zero. the synthesis c is performed on the entire sphere. i.e. the arrays c vt(i,j),wt(i,j) are computed for i=1,...,nlat and c j=1,...,nlon. c c = 2 no symmetries exist about the equator however the c the coefficients br and bi are zero. the synthesis c is performed on the entire sphere. i.e. the arrays c vt(i,j),wt(i,j) are computed for i=1,...,nlat and c j=1,...,nlon. c c = 3 vt is odd and wt is even about the equator. the c synthesis is performed on the northern hemisphere c only. i.e., if nlat is odd the arrays vt(i,j),wt(i,j) c are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the arrays vt(i,j),wt(i,j) are computed c for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 vt is odd and wt is even about the equator and the c coefficients cr and ci are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 5 vt is odd and wt is even about the equator and the c coefficients br and bi are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 6 vt is even and wt is odd about the equator. the c synthesis is performed on the northern hemisphere c only. i.e., if nlat is odd the arrays vt(i,j),wt(i,j) c are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the arrays vt(i,j),wt(i,j) are computed c for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 vt is even and wt is odd about the equator and the c coefficients cr and ci are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 8 vt is even and wt is odd about the equator and the c coefficients br and bi are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of syntheses. in the program that calls vtsec, c the arrays vt,wt,br,bi,cr, and ci can be three dimensional c in which case multiple syntheses will be performed. c the third index is the synthesis index which assumes the c values k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c idvw the first dimension of the arrays vt,wt as it appears in c the program that calls vtsec. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays vt,wt as it appears in c the program that calls vtsec. jdvw must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c of (v,w) as computed by subroutine vhaec. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vtsec. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vtsec. ndab must be at c least nlat. c c wvts an array which must be initialized by subroutine vtseci. c once initialized, wvts can be used repeatedly by vtsec c as long as nlon and nlat remain unchanged. wvts must c not be altered between calls of vtsec. c c lwvts the dimension of the array wvts as it appears in the c program that calls vtsec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwvts must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vtsec. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)) c c if ityp .gt. 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) c c ************************************************************** c c output parameters c c vt,wt two or three dimensional arrays (see input parameter nt) c in which the derivative of (v,w) with respect to c colatitude theta is stored. vt(i,j),wt(i,j) contain the c derivatives at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges c are defined above at the input parameter ityp. vt and wt c are computed from the formulas for v and w given in c subroutine vhsec but with vbar and wbar replaced with c their derivatives with respect to colatitude. these c derivatives are denoted by vtbar and wtbar. c c in terms of real variables this expansion takes the form c c for i=1,...,nlat and j=1,...,nlon c c vt(i,j) = the sum from n=1 to n=nlat-1 of c c .5*br(1,n+1)*vtbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c (br(m+1,n+1)*vtbar(m,n,theta(i)) c -ci(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j)) c -(bi(m+1,n+1)*vtbar(m,n,theta(i)) c +cr(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j)) c c and for i=1,...,nlat and j=1,...,nlon c c wt(i,j) = the sum from n=1 to n=nlat-1 of c c -.5*cr(1,n+1)*vtbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c -(cr(m+1,n+1)*vtbar(m,n,theta(i)) c +bi(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j)) c +(ci(m+1,n+1)*vtbar(m,n,theta(i)) c -br(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j)) c c c br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are c assumed zero for m even. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lwvts c = 10 error in the specification of lwork c c c ******************************************************************* c c subroutine vtseci(nlat,nlon,wvts,lwvts,dwork,ldwork,ierror) c c subroutine vtseci initializes the array wvts which can then be c used repeatedly by subroutine vtsec until nlat or nlon is changed. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lwvts the dimension of the array wvts as it appears in the c program that calls vtsec. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwvts must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array work as it appears in the c program that calls vtsec. lwork must be at least c 2*(nlat+1) c c ************************************************************** c c output parameters c c wvts an array which is initialized for use by subroutine vtsec. c once initialized, wvts can be used repeatedly by vtsec c as long as nlat or nlon remain unchanged. wvts must not c be altered between calls of vtsec. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lwvts c = 4 error in the specification of ldwork c c ********************************************************************** c subroutine vtsec(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvts,lwvts,work,lwork,ierror) c dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvts(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lwvts .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 if(ityp .le. 2 .and. 1 lwork .lt. nlat*(2*nt*nlon+max0(6*imid,nlon))) return if(ityp .gt. 2 .and. 1 lwork .lt. imid*(2*nt*nlon+max0(6*nlat,nlon))) return ierror = 0 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl iw5 = iw4+3*imid*nlat lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 lwzvin = lzz1+labc jw1 = lwzvin+1 jw2 = jw1+lwzvin call vtsec1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),work(iw5),wvts,wvts(jw1),wvts(jw2)) return end subroutine vtsec1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab, 1 ndab,br,bi,cr,ci,idv,vte,vto,wte,wto,vb,wb,wvbin,wwbin,wrfft) dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 vte(idv,nlon,1),vto(idv,nlon,1),wte(idv,nlon,1), 3 wto(idv,nlon,1),wvbin(1),wwbin(1),wrfft(1), 4 vb(imid,nlat,3),wb(imid,nlat,3) nlp1 = nlat+1 mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 do 10 k=1,nt do 10 j=1,nlon do 10 i=1,idv vte(i,j,k) = 0. wte(i,j,k) = 0. 10 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 18 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 no symmetries c 1 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 15 k=1,nt do 15 np1=2,ndo2,2 do 15 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv) wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 15 continue do 16 k=1,nt do 16 np1=3,ndo1,2 do 16 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv) wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 30 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 26 do 25 k=1,nt do 24 np1=mp1,ndo1,2 do 23 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 23 continue if(mlat .eq. 0) go to 24 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 24 continue 25 continue 26 if(mp2 .gt. ndo2) go to 30 do 29 k=1,nt do 28 np1=mp2,ndo2,2 do 27 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 27 continue if(mlat .eq. 0) go to 28 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 28 continue 29 continue 30 continue go to 950 c c case ityp=1 no symmetries, cr and ci equal zero c 100 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 115 k=1,nt do 115 np1=2,ndo2,2 do 115 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 115 continue do 116 k=1,nt do 116 np1=3,ndo1,2 do 116 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 130 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 126 do 125 k=1,nt do 124 np1=mp1,ndo1,2 do 123 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 123 continue if(mlat .eq. 0) go to 124 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 124 continue 125 continue 126 if(mp2 .gt. ndo2) go to 130 do 129 k=1,nt do 128 np1=mp2,ndo2,2 do 127 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 127 continue if(mlat .eq. 0) go to 128 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 128 continue 129 continue 130 continue go to 950 c c case ityp=2 no symmetries, br and bi are equal to zero c 200 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 215 k=1,nt do 215 np1=2,ndo2,2 do 215 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 215 continue do 216 k=1,nt do 216 np1=3,ndo1,2 do 216 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 230 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 226 do 225 k=1,nt do 224 np1=mp1,ndo1,2 do 223 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 223 continue if(mlat .eq. 0) go to 224 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 224 continue 225 continue 226 if(mp2 .gt. ndo2) go to 230 do 229 k=1,nt do 228 np1=mp2,ndo2,2 do 227 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 227 continue if(mlat .eq. 0) go to 228 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 228 continue 229 continue 230 continue go to 950 c c case ityp=3 v odd, w even c 300 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 315 k=1,nt do 315 np1=2,ndo2,2 do 315 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 315 continue do 316 k=1,nt do 316 np1=3,ndo1,2 do 316 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 330 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 326 do 325 k=1,nt do 324 np1=mp1,ndo1,2 do 323 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 323 continue if(mlat .eq. 0) go to 324 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 324 continue 325 continue 326 if(mp2 .gt. ndo2) go to 330 do 329 k=1,nt do 328 np1=mp2,ndo2,2 do 327 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 327 continue if(mlat .eq. 0) go to 328 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 328 continue 329 continue 330 continue go to 950 c c case ityp=4 v odd, w even, and both cr and ci equal zero c 400 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 415 k=1,nt do 415 np1=2,ndo2,2 do 415 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 430 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 430 do 429 k=1,nt do 428 np1=mp2,ndo2,2 do 427 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 427 continue if(mlat .eq. 0) go to 428 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 428 continue 429 continue 430 continue go to 950 c c case ityp=5 v odd, w even, br and bi equal zero c 500 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 516 k=1,nt do 516 np1=3,ndo1,2 do 516 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 530 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 530 do 525 k=1,nt do 524 np1=mp1,ndo1,2 do 523 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 523 continue if(mlat .eq. 0) go to 524 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 524 continue 525 continue 530 continue go to 950 c c case ityp=6 v even , w odd c 600 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 615 k=1,nt do 615 np1=2,ndo2,2 do 615 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 615 continue do 616 k=1,nt do 616 np1=3,ndo1,2 do 616 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 630 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 626 do 625 k=1,nt do 624 np1=mp1,ndo1,2 do 623 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 623 continue if(mlat .eq. 0) go to 624 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 624 continue 625 continue 626 if(mp2 .gt. ndo2) go to 630 do 629 k=1,nt do 628 np1=mp2,ndo2,2 do 627 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 627 continue if(mlat .eq. 0) go to 628 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 628 continue 629 continue 630 continue go to 950 c c case ityp=7 v even, w odd cr and ci equal zero c 700 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 716 k=1,nt do 716 np1=3,ndo1,2 do 716 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 730 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 730 do 725 k=1,nt do 724 np1=mp1,ndo1,2 do 723 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 723 continue if(mlat .eq. 0) go to 724 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 724 continue 725 continue 730 continue go to 950 c c case ityp=8 v even, w odd br and bi equal zero c 800 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 815 k=1,nt do 815 np1=2,ndo2,2 do 815 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 830 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 830 do 829 k=1,nt do 828 np1=mp2,ndo2,2 do 827 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 827 continue if(mlat .eq. 0) go to 828 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 828 continue 829 continue 830 continue 950 do 14 k=1,nt call hrfftb(idv,nlon,vte(1,1,k),idv,wrfft,vb) call hrfftb(idv,nlon,wte(1,1,k),idv,wrfft,vb) 14 continue if(ityp .gt. 2) go to 12 do 60 k=1,nt do 60 j=1,nlon do 60 i=1,imm1 vt(i,j,k) = .5*(vte(i,j,k)+vto(i,j,k)) wt(i,j,k) = .5*(wte(i,j,k)+wto(i,j,k)) vt(nlp1-i,j,k) = .5*(vte(i,j,k)-vto(i,j,k)) wt(nlp1-i,j,k) = .5*(wte(i,j,k)-wto(i,j,k)) 60 continue go to 13 12 do 11 k=1,nt do 11 j=1,nlon do 11 i=1,imm1 vt(i,j,k) = .5*vte(i,j,k) wt(i,j,k) = .5*wte(i,j,k) 11 continue 13 if(mlat .eq. 0) return do 65 k=1,nt do 65 j=1,nlon vt(imid,j,k) = .5*vte(imid,j,k) wt(imid,j,k) = .5*wte(imid,j,k) 65 continue return end subroutine vtseci(nlat,nlon,wvts,lwvts,dwork,ldwork,ierror) c dimension wvts(lwvts) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 imid = (nlat+1)/2 lzz1 = 2*nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lwvts .lt. 2*(lzz1+labc)+nlon+15) return ierror = 4 if (ldwork .lt. 2*nlat+2) return ierror = 0 call vtinit (nlat,nlon,wvts,dwork) lwvbin = lzz1+labc iw1 = lwvbin+1 call wtinit (nlat,nlon,wvts(iw1),dwork) iw2 = iw1+lwvbin call hrffti(nlon,wvts(iw2)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vtses.f c c this file includes documentation and code for c subroutines vtses and vtsesi c c ... files which must be loaded with vtses.f c c sphcom.f, hrfft.f, vhaes.f, vhses.f c c c subroutine vtses(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvts,lwvts,work,lwork,ierror) c c given the vector harmonic analysis br,bi,cr, and ci (computed c by subroutine vhaes) of some vector function (v,w), this c subroutine computes the vector function (vt,wt) which is c the derivative of (v,w) with respect to colatitude theta. vtses c is similar to vhses except the vector harmonics are replaced by c their derivative with respect to colatitude with the result that c (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative c of the colatitudinal component v(i,j) at the point theta(i) = c (i-1)*pi/(nlat-1) and longitude phi(j) = (j-1)*2*pi/nlon. the c spectral representation of (vt,wt) is given below at output c parameters vt,wt. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. the arrays c vt(i,j),wt(i,j) are computed for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator however the c the coefficients cr and ci are zero. the synthesis c is performed on the entire sphere. i.e. the arrays c vt(i,j),wt(i,j) are computed for i=1,...,nlat and c j=1,...,nlon. c c = 2 no symmetries exist about the equator however the c the coefficients br and bi are zero. the synthesis c is performed on the entire sphere. i.e. the arrays c vt(i,j),wt(i,j) are computed for i=1,...,nlat and c j=1,...,nlon. c c = 3 vt is odd and wt is even about the equator. the c synthesis is performed on the northern hemisphere c only. i.e., if nlat is odd the arrays vt(i,j),wt(i,j) c are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the arrays vt(i,j),wt(i,j) are computed c for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 vt is odd and wt is even about the equator and the c coefficients cr and ci are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 5 vt is odd and wt is even about the equator and the c coefficients br and bi are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 6 vt is even and wt is odd about the equator. the c synthesis is performed on the northern hemisphere c only. i.e., if nlat is odd the arrays vt(i,j),wt(i,j) c are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the arrays vt(i,j),wt(i,j) are computed c for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 vt is even and wt is odd about the equator and the c coefficients cr and ci are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 8 vt is even and wt is odd about the equator and the c coefficients br and bi are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of syntheses. in the program that calls vtses, c the arrays vt,wt,br,bi,cr, and ci can be three dimensional c in which case multiple syntheses will be performed. c the third index is the synthesis index which assumes the c values k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c idvw the first dimension of the arrays vt,wt as it appears in c the program that calls vtses. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays vt,wt as it appears in c the program that calls vtses. jdvw must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c of (v,w) as computed by subroutine vhaes. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vtses. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vtses. ndab must be at c least nlat. c c wvts an array which must be initialized by subroutine vtsesi. c once initialized, wvts can be used repeatedly by vtses c as long as nlon and nlat remain unchanged. wvts must c not be altered between calls of vtses. c c lwvts the dimension of the array wvts as it appears in the c program that calls vtses. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwvts must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vtses. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c (2*nt+1)*nlat*nlon c c if ityp .gt. 2 then lwork must be at least c c (2*nt+1)*l2*nlon c c ************************************************************** c c output parameters c c vt,wt two or three dimensional arrays (see input parameter nt) c in which the derivative of (v,w) with respect to c colatitude theta is stored. vt(i,j),wt(i,j) contain the c derivatives at colatitude theta(i) = (i-1)*pi/(nlat-1) c and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges c are defined above at the input parameter ityp. vt and wt c are computed from the formulas for v and w given in c subroutine vhses but with vbar and wbar replaced with c their derivatives with respect to colatitude. these c derivatives are denoted by vtbar and wtbar. c c c ************************************************************* c c in terms of real variables this expansion takes the form c c for i=1,...,nlat and j=1,...,nlon c c vt(i,j) = the sum from n=1 to n=nlat-1 of c c .5*br(1,n+1)*vtbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c (br(m+1,n+1)*vtbar(m,n,theta(i)) c -ci(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j)) c -(bi(m+1,n+1)*vtbar(m,n,theta(i)) c +cr(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j)) c c and for i=1,...,nlat and j=1,...,nlon c c wt(i,j) = the sum from n=1 to n=nlat-1 of c c -.5*cr(1,n+1)*vtbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c -(cr(m+1,n+1)*vtbar(m,n,theta(i)) c +bi(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j)) c +(ci(m+1,n+1)*vtbar(m,n,theta(i)) c -br(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j)) c c c br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are c assumed zero for m even. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lwvts c = 10 error in the specification of lwork c c c ******************************************************************* c c subroutine vtsesi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork, c + ierror) c c subroutine vtsesi initializes the array wvts which can then be c used repeatedly by subroutine vtses until nlat or nlon is changed. c c input parameters c c nlat the number of colatitudes on the full sphere including the c poles. for example, nlat = 37 for a five degree grid. c nlat determines the grid increment in colatitude as c pi/(nlat-1). if nlat is odd the equator is located at c grid point i=(nlat+1)/2. if nlat is even the equator is c located half way between points i=nlat/2 and i=nlat/2+1. c nlat must be at least 3. note: on the half sphere, the c number of grid points in the colatitudinal direction is c nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lwvts the dimension of the array wvts as it appears in the c program that calls vtses. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwvts must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vtses. lwork must be at least c c 3*(max0(l1-2,0)*(nlat+nlat-l1-1))/2+5*l2*nlat c c dwork a double precision work array that does have to be saved. c c ldwork the length of dwork. ldwork must be at least 2*(nlat+1) c c ************************************************************** c c output parameters c c wvts an array which is initialized for use by subroutine vtses. c once initialized, wvts can be used repeatedly by vtses c as long as nlat or nlon remain unchanged. wvts must not c be altered between calls of vtses. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lwvts c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c c ******************************************************************** c subroutine vtses(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvts,lwvts,work,lwork,ierror) c dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvts(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lwvts .lt. lzimn+lzimn+nlon+15) return ierror = 10 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon if(lwork .lt. lnl+lnl+idv*nlon) return ierror = 0 ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl jw1 = lzimn+1 jw2 = jw1+lzimn call vtses1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),idz,wvts,wvts(jw1),wvts(jw2)) return end subroutine vtses1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab, 1 ndab,br,bi,cr,ci,idv,vte,vto,wte,wto,work,idz,vb,wb,wrfft) dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 vte(idv,nlon,1),vto(idv,nlon,1),wte(idv,nlon,1), 3 wto(idv,nlon,1),work(1),wrfft(1), 4 vb(imid,1),wb(imid,1) nlp1 = nlat+1 mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 do 10 k=1,nt do 10 j=1,nlon do 10 i=1,idv vte(i,j,k) = 0. wte(i,j,k) = 0. 10 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 18 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 no symmetries c c case m = 0 c 1 do 15 k=1,nt do 15 np1=2,ndo2,2 do 15 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1) wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1) 15 continue do 16 k=1,nt do 16 np1=3,ndo1,2 do 16 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1) wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 30 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 26 do 25 k=1,nt do 24 np1=mp1,ndo1,2 mn = mb+np1 do 23 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 23 continue if(mlat .eq. 0) go to 24 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 24 continue 25 continue 26 if(mp2 .gt. ndo2) go to 30 do 29 k=1,nt do 28 np1=mp2,ndo2,2 mn = mb+np1 do 27 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 27 continue if(mlat .eq. 0) go to 28 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 28 continue 29 continue 30 continue go to 950 c c case ityp=1 no symmetries, cr and ci equal zero c c case m = 0 c 100 do 115 k=1,nt do 115 np1=2,ndo2,2 do 115 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1) 115 continue do 116 k=1,nt do 116 np1=3,ndo1,2 do 116 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 130 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 126 do 125 k=1,nt do 124 np1=mp1,ndo1,2 mn = mb+np1 do 123 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 123 continue if(mlat .eq. 0) go to 124 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 124 continue 125 continue 126 if(mp2 .gt. ndo2) go to 130 do 129 k=1,nt do 128 np1=mp2,ndo2,2 mn = mb+np1 do 127 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 127 continue if(mlat .eq. 0) go to 128 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 128 continue 129 continue 130 continue go to 950 c c case ityp=2 no symmetries, br and bi are equal to zero c c case m = 0 c 200 do 215 k=1,nt do 215 np1=2,ndo2,2 do 215 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1) 215 continue do 216 k=1,nt do 216 np1=3,ndo1,2 do 216 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 230 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 226 do 225 k=1,nt do 224 np1=mp1,ndo1,2 mn = mb+np1 do 223 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 223 continue if(mlat .eq. 0) go to 224 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 224 continue 225 continue 226 if(mp2 .gt. ndo2) go to 230 do 229 k=1,nt do 228 np1=mp2,ndo2,2 mn = mb+np1 do 227 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 227 continue if(mlat .eq. 0) go to 228 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 228 continue 229 continue 230 continue go to 950 c c case ityp=3 v odd, w even c c case m = 0 c 300 do 315 k=1,nt do 315 np1=2,ndo2,2 do 315 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1) 315 continue do 316 k=1,nt do 316 np1=3,ndo1,2 do 316 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 330 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 326 do 325 k=1,nt do 324 np1=mp1,ndo1,2 mn = mb+np1 do 323 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 323 continue if(mlat .eq. 0) go to 324 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 324 continue 325 continue 326 if(mp2 .gt. ndo2) go to 330 do 329 k=1,nt do 328 np1=mp2,ndo2,2 mn = mb+np1 do 327 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 327 continue if(mlat .eq. 0) go to 328 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 328 continue 329 continue 330 continue go to 950 c c case ityp=4 v odd, w even, and both cr and ci equal zero c c case m = 0 c 400 do 415 k=1,nt do 415 np1=2,ndo2,2 do 415 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 430 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 430 do 429 k=1,nt do 428 np1=mp2,ndo2,2 mn = mb+np1 do 427 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 427 continue if(mlat .eq. 0) go to 428 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 428 continue 429 continue 430 continue go to 950 c c case ityp=5 v odd, w even, br and bi equal zero c c case m = 0 c 500 do 516 k=1,nt do 516 np1=3,ndo1,2 do 516 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 530 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 530 do 525 k=1,nt do 524 np1=mp1,ndo1,2 mn = mb+np1 do 523 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 523 continue if(mlat .eq. 0) go to 524 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 524 continue 525 continue 530 continue go to 950 c c case ityp=6 v even , w odd c c case m = 0 c 600 do 615 k=1,nt do 615 np1=2,ndo2,2 do 615 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1) 615 continue do 616 k=1,nt do 616 np1=3,ndo1,2 do 616 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 630 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 626 do 625 k=1,nt do 624 np1=mp1,ndo1,2 mn = mb+np1 do 623 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 623 continue if(mlat .eq. 0) go to 624 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 624 continue 625 continue 626 if(mp2 .gt. ndo2) go to 630 do 629 k=1,nt do 628 np1=mp2,ndo2,2 mn = mb+np1 do 627 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 627 continue if(mlat .eq. 0) go to 628 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 628 continue 629 continue 630 continue go to 950 c c case ityp=7 v even, w odd cr and ci equal zero c c case m = 0 c 700 do 716 k=1,nt do 716 np1=3,ndo1,2 do 716 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 730 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 730 do 725 k=1,nt do 724 np1=mp1,ndo1,2 mn = mb+np1 do 723 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 723 continue if(mlat .eq. 0) go to 724 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 724 continue 725 continue 730 continue go to 950 c c case ityp=8 v even, w odd, br and bi equal zero c c case m = 0 c 800 do 815 k=1,nt do 815 np1=2,ndo2,2 do 815 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 830 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 830 do 829 k=1,nt do 828 np1=mp2,ndo2,2 mn = mb+np1 do 827 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 827 continue if(mlat .eq. 0) go to 828 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 828 continue 829 continue 830 continue 950 do 14 k=1,nt call hrfftb(idv,nlon,vte(1,1,k),idv,wrfft,work) call hrfftb(idv,nlon,wte(1,1,k),idv,wrfft,work) 14 continue if(ityp .gt. 2) go to 12 do 60 k=1,nt do 60 j=1,nlon do 60 i=1,imm1 vt(i,j,k) = .5*(vte(i,j,k)+vto(i,j,k)) wt(i,j,k) = .5*(wte(i,j,k)+wto(i,j,k)) vt(nlp1-i,j,k) = .5*(vte(i,j,k)-vto(i,j,k)) wt(nlp1-i,j,k) = .5*(wte(i,j,k)-wto(i,j,k)) 60 continue go to 13 12 do 11 k=1,nt do 11 j=1,nlon do 11 i=1,imm1 vt(i,j,k) = .5*vte(i,j,k) wt(i,j,k) = .5*wte(i,j,k) 11 continue 13 if(mlat .eq. 0) return do 65 k=1,nt do 65 j=1,nlon vt(imid,j,k) = .5*vte(imid,j,k) wt(imid,j,k) = .5*wte(imid,j,k) 65 continue return end subroutine vtsesi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork, + ierror) c dimension wvts(lwvts),work(lwork) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 mmax = min0(nlat,(nlon+1)/2) imid = (nlat+1)/2 lzimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lwvts .lt. lzimn+lzimn+nlon+15) return ierror = 4 labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lwork .lt. 5*nlat*imid+labc) return ierror = 5 if (ldwork .lt. 2*(nlat+1)) return ierror = 0 iw1 = 3*nlat*imid+1 idz = (mmax*(nlat+nlat-mmax+1))/2 call vet1(nlat,nlon,imid,wvts,wvts(lzimn+1),idz,work, + work(iw1),dwork) call hrffti(nlon,wvts(2*lzimn+1)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vtsgc.f c c this file includes documentation and code for c subroutines vtsgc and vtsgci c c ... files which must be loaded with vtsgc.f c c sphcom.f, hrfft.f, vhagc.f, vhsgc.f,gaqd.f c c c subroutine vtsgc(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvts,lwvts,work,lwork,ierror) c c given the vector harmonic analysis br,bi,cr, and ci (computed c by subroutine vhagc) of some vector function (v,w), this c subroutine computes the vector function (vt,wt) which is c the derivative of (v,w) with respect to colatitude theta. vtsgc c is similar to vhsgc except the vector harmonics are replaced by c their derivative with respect to colatitude with the result that c (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative c of the colatitudinal component v(i,j) at the gaussian colatitude c theta(i) and longitude phi(j) = (j-1)*2*pi/nlon. the spectral c representation of (vt,wt) is given below at the definition of c output parameters vt,wt. c c input parameters c c nlat the number of gaussian colatitudinal grid points theta(i) c such that 0 < theta(1) <...< theta(nlat) < pi. they are c computed by subroutine gaqd which is called by this c subroutine. if nlat is odd the equator is c theta((nlat+1)/2). if nlat is even the equator lies c half way between theta(nlat/2) and theta(nlat/2+1). nlat c must be at least 3. note: if (v,w) is symmetric about c the equator (see parameter ityp below) the number of c colatitudinal grid points is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. the arrays c vt(i,j),wt(i,j) are computed for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator however the c the coefficients cr and ci are zero which implies c that the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the calculations are performed on the entire sphere. c i.e. the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat and j=1,...,nlon. c c = 2 no symmetries exist about the equator however the c the coefficients br and bi are zero which implies c that the divergence of (v,w) is zero. that is, c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the calculations are performed on the entire sphere. c i.e. the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat and j=1,...,nlon. c c = 3 vt is odd and wt is even about the equator. the c synthesis is performed on the northern hemisphere c only. i.e., if nlat is odd the arrays vt(i,j) c and wt(i,j) are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even the arrays c are computed for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 vt is odd and wt is even about the equator and the c coefficients cr and ci are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 5 vt is odd and wt is even about the equator and the c coefficients br and bi are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 6 vt is even and wt is odd about the equator. the c synthesis is performed on the northern hemisphere c only. i.e., if nlat is odd the arrays vt(i,j),wt(i,j) c are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the arrays vt(i,j),wt(i,j) are computed c for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 vt is even and wt is odd about the equator and the c coefficients cr and ci are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 8 vt is even and wt is odd about the equator and the c coefficients br and bi are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of syntheses. in the program that calls vtsgc, c the arrays vt,wt,br,bi,cr, and ci can be three dimensional c in which case multiple syntheses will be performed. c the third index is the synthesis index which assumes the c values k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c idvw the first dimension of the arrays vt,wt as it appears in c the program that calls vtsgc. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays vt,wt as it appears in c the program that calls vtsgc. jdvw must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c of (v,w) as computed by subroutine vhagc. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vtsgc. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vtsgc. ndab must be at c least nlat. c c wvts an array which must be initialized by subroutine vtsgci. c once initialized, wvts can be used repeatedly by vtsgc c as long as nlon and nlat remain unchanged. wvts must c not be altered between calls of vtsgc. c c lwvts the dimension of the array wvts as it appears in the c program that calls vtsgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwvts must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vtsgc. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c nlat*(2*nt*nlon+max0(6*l2,nlon)) c c if ityp .gt. 2 then lwork must be at least c c l2*(2*nt*nlon+max0(6*nlat,nlon)) c c ************************************************************** c c output parameters c c vt,wt two or three dimensional arrays (see input parameter nt) c in which the derivative of (v,w) with respect to c colatitude theta is stored. vt(i,j),wt(i,j) contain the c derivatives at gaussian colatitude points theta(i) c and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges c are defined above at the input parameter ityp. vt and wt c are computed from the formulas for v and w given in c subroutine vhsgc but with vbar and wbar replaced with c their derivatives with respect to colatitude. these c derivatives are denoted by vtbar and wtbar. c c in terms of real variables this expansion takes the form c c for i=1,...,nlat and j=1,...,nlon c c vt(i,j) = the sum from n=1 to n=nlat-1 of c c .5*br(1,n+1)*vtbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c (br(m+1,n+1)*vtbar(m,n,theta(i)) c -ci(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j)) c -(bi(m+1,n+1)*vtbar(m,n,theta(i)) c +cr(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j)) c c and for i=1,...,nlat and j=1,...,nlon c c wt(i,j) = the sum from n=1 to n=nlat-1 of c c -.5*cr(1,n+1)*vtbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c -(cr(m+1,n+1)*vtbar(m,n,theta(i)) c +bi(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j)) c +(ci(m+1,n+1)*vtbar(m,n,theta(i)) c -br(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j)) c c c br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are c assumed zero for m even. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lwvts c = 10 error in the specification of lwork c c c ******************************************************************* c c subroutine vtsgci(nlat,nlon,wvts,lwvts,dwork,ldwork,ierror) c c subroutine vtsgci initializes the array wvts which can then be c used repeatedly by subroutine vtsgc until nlat or nlon is changed. c c input parameters c c nlat the number of gaussian colatitudinal grid points theta(i) c such that 0 < theta(1) <...< theta(nlat) < pi. they are c computed by subroutine gaqd which is called by this c subroutine. if nlat is odd the equator is c theta((nlat+1)/2). if nlat is even the equator lies c half way between theta(nlat/2) and theta(nlat/2+1). nlat c must be at least 3. note: if (v,w) is symmetric about c the equator (see parameter ityp below) the number of c colatitudinal grid points is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lwvts the dimension of the array wvts as it appears in the c program that calls vtsgc. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwvts must be at least c c 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15 c c c dwork a double precision work array that does not have to be saved. c c ldwork the dimension of the array dwork as it appears in the c program that calls vtsgc. ldwork must be at least c 3*nlat+2 c c ************************************************************** c c output parameters c c wvts an array which is initialized for use by subroutine vtsgc. c once initialized, wvts can be used repeatedly by vtsgc c as long as nlat or nlon remain unchanged. wvts must not c be altered between calls of vtsgc. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lwvts c = 4 error in the specification of lwork c c c c ********************************************************************** c subroutine vtsgc(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvts,lwvts,work,lwork,ierror) c dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvts(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lwvts .lt. 2*(lzz1+labc)+nlon+15) return ierror = 10 if(ityp .le. 2 .and. 1 lwork .lt. nlat*(2*nt*nlon+max0(6*imid,nlon))) return if(ityp .gt. 2 .and. 1 lwork .lt. imid*(2*nt*nlon+max0(6*nlat,nlon))) return ierror = 0 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl iw5 = iw4+3*imid*nlat lzz1 = 2*nlat*imid labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 lwzvin = lzz1+labc jw1 = lwzvin+1 jw2 = jw1+lwzvin call vtsgc1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),work(iw5),wvts,wvts(jw1),wvts(jw2)) return end subroutine vtsgc1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab, 1 ndab,br,bi,cr,ci,idv,vte,vto,wte,wto,vb,wb,wvbin,wwbin,wrfft) dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 vte(idv,nlon,1),vto(idv,nlon,1),wte(idv,nlon,1), 3 wto(idv,nlon,1),wvbin(1),wwbin(1),wrfft(1), 4 vb(imid,nlat,3),wb(imid,nlat,3) nlp1 = nlat+1 mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 do 10 k=1,nt do 10 j=1,nlon do 10 i=1,idv vte(i,j,k) = 0. wte(i,j,k) = 0. 10 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 18 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 no symmetries c 1 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 15 k=1,nt do 15 np1=2,ndo2,2 do 15 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv) wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 15 continue do 16 k=1,nt do 16 np1=3,ndo1,2 do 16 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv) wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 30 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 26 do 25 k=1,nt do 24 np1=mp1,ndo1,2 do 23 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 23 continue if(mlat .eq. 0) go to 24 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 24 continue 25 continue 26 if(mp2 .gt. ndo2) go to 30 do 29 k=1,nt do 28 np1=mp2,ndo2,2 do 27 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 27 continue if(mlat .eq. 0) go to 28 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 28 continue 29 continue 30 continue go to 950 c c case ityp=1 no symmetries, cr and ci equal zero c 100 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 115 k=1,nt do 115 np1=2,ndo2,2 do 115 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 115 continue do 116 k=1,nt do 116 np1=3,ndo1,2 do 116 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 130 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 126 do 125 k=1,nt do 124 np1=mp1,ndo1,2 do 123 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 123 continue if(mlat .eq. 0) go to 124 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 124 continue 125 continue 126 if(mp2 .gt. ndo2) go to 130 do 129 k=1,nt do 128 np1=mp2,ndo2,2 do 127 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 127 continue if(mlat .eq. 0) go to 128 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 128 continue 129 continue 130 continue go to 950 c c case ityp=2 no symmetries, br and bi are equal to zero c 200 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 215 k=1,nt do 215 np1=2,ndo2,2 do 215 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 215 continue do 216 k=1,nt do 216 np1=3,ndo1,2 do 216 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 230 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 226 do 225 k=1,nt do 224 np1=mp1,ndo1,2 do 223 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 223 continue if(mlat .eq. 0) go to 224 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 224 continue 225 continue 226 if(mp2 .gt. ndo2) go to 230 do 229 k=1,nt do 228 np1=mp2,ndo2,2 do 227 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 227 continue if(mlat .eq. 0) go to 228 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 228 continue 229 continue 230 continue go to 950 c c case ityp=3 v odd, w even c 300 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 315 k=1,nt do 315 np1=2,ndo2,2 do 315 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 315 continue do 316 k=1,nt do 316 np1=3,ndo1,2 do 316 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 330 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 326 do 325 k=1,nt do 324 np1=mp1,ndo1,2 do 323 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 323 continue if(mlat .eq. 0) go to 324 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 324 continue 325 continue 326 if(mp2 .gt. ndo2) go to 330 do 329 k=1,nt do 328 np1=mp2,ndo2,2 do 327 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 327 continue if(mlat .eq. 0) go to 328 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 328 continue 329 continue 330 continue go to 950 c c case ityp=4 v odd, w even, and both cr and ci equal zero c 400 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 415 k=1,nt do 415 np1=2,ndo2,2 do 415 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 430 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 430 do 429 k=1,nt do 428 np1=mp2,ndo2,2 do 427 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 427 continue if(mlat .eq. 0) go to 428 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,np1,iw) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,np1,iw) 428 continue 429 continue 430 continue go to 950 c c case ityp=5 v odd, w even, br and bi equal zero c 500 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 516 k=1,nt do 516 np1=3,ndo1,2 do 516 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 530 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 530 do 525 k=1,nt do 524 np1=mp1,ndo1,2 do 523 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 523 continue if(mlat .eq. 0) go to 524 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,np1,iv) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,np1,iv) 524 continue 525 continue 530 continue go to 950 c c case ityp=6 v even , w odd c 600 call vbin(0,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 615 k=1,nt do 615 np1=2,ndo2,2 do 615 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 615 continue do 616 k=1,nt do 616 np1=3,ndo1,2 do 616 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 630 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(0,nlat,nlon,m,vb,iv,wvbin) call wbin(0,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 626 do 625 k=1,nt do 624 np1=mp1,ndo1,2 do 623 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 623 continue if(mlat .eq. 0) go to 624 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 624 continue 625 continue 626 if(mp2 .gt. ndo2) go to 630 do 629 k=1,nt do 628 np1=mp2,ndo2,2 do 627 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 627 continue if(mlat .eq. 0) go to 628 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 628 continue 629 continue 630 continue go to 950 c c case ityp=7 v even, w odd cr and ci equal zero c 700 call vbin(2,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 716 k=1,nt do 716 np1=3,ndo1,2 do 716 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 730 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(2,nlat,nlon,m,vb,iv,wvbin) call wbin(2,nlat,nlon,m,wb,iw,wwbin) if(mp1 .gt. ndo1) go to 730 do 725 k=1,nt do 724 np1=mp1,ndo1,2 do 723 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw) 723 continue if(mlat .eq. 0) go to 724 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,np1,iv) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,np1,iv) 724 continue 725 continue 730 continue go to 950 c c case ityp=8 v even, w odd br and bi equal zero c 800 call vbin(1,nlat,nlon,0,vb,iv,wvbin) c c case m = 0 c do 815 k=1,nt do 815 np1=2,ndo2,2 do 815 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 830 mp1=2,mmax m = mp1-1 mp2 = mp1+1 call vbin(1,nlat,nlon,m,vb,iv,wvbin) call wbin(1,nlat,nlon,m,wb,iw,wwbin) if(mp2 .gt. ndo2) go to 830 do 829 k=1,nt do 828 np1=mp2,ndo2,2 do 827 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv) 827 continue if(mlat .eq. 0) go to 828 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,np1,iw) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,np1,iw) 828 continue 829 continue 830 continue 950 do 14 k=1,nt call hrfftb(idv,nlon,vte(1,1,k),idv,wrfft,vb) call hrfftb(idv,nlon,wte(1,1,k),idv,wrfft,vb) 14 continue if(ityp .gt. 2) go to 12 do 60 k=1,nt do 60 j=1,nlon do 60 i=1,imm1 vt(i,j,k) = .5*(vte(i,j,k)+vto(i,j,k)) wt(i,j,k) = .5*(wte(i,j,k)+wto(i,j,k)) vt(nlp1-i,j,k) = .5*(vte(i,j,k)-vto(i,j,k)) wt(nlp1-i,j,k) = .5*(wte(i,j,k)-wto(i,j,k)) 60 continue go to 13 12 do 11 k=1,nt do 11 j=1,nlon do 11 i=1,imm1 vt(i,j,k) = .5*vte(i,j,k) wt(i,j,k) = .5*wte(i,j,k) 11 continue 13 if(mlat .eq. 0) return do 65 k=1,nt do 65 j=1,nlon vt(imid,j,k) = .5*vte(imid,j,k) wt(imid,j,k) = .5*wte(imid,j,k) 65 continue return end subroutine vtsgci(nlat,nlon,wvts,lwvts,dwork,ldwork,ierror) c dimension wvts(lwvts) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 imid = (nlat+1)/2 lzz1 = 2*nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 if(lwvts .lt. 2*(lzz1+labc)+nlon+15) return ierror = 4 c if(lwork .lt. 2*nlat*(nlat+2)) return if(ldwork .lt. 3*nlat+2) return c call gaqd(nlat,work,work(2*nlat+1),work(4*nlat+1),lwork,ierr) ldwk = 1 call gaqd(nlat,dwork,dwork(nlat+1),dwork(2*nlat+1),ldwk,ierr) ierror = 5 if(ierr .ne. 0) return ierror = 0 c call vtgint (nlat,nlon,work,wvts,work(4*nlat+1)) call vtgint (nlat,nlon,dwork,wvts,dwork(2*nlat+1)) lwvbin = lzz1+labc iw1 = lwvbin+1 c call wtgint (nlat,nlon,work,wvts(iw1),work(4*nlat+1)) call wtgint (nlat,nlon,dwork,wvts(iw1),dwork(2*nlat+1)) iw2 = iw1+lwvbin call hrffti(nlon,wvts(iw2)) return end c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1998 by UCAR . c . . c . University Corporation for Atmospheric Research . c . . c . all rights reserved . c . . c . . c . SPHEREPACK . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c c c ... file vtsgs.f c c this file includes documentation and code for c subroutines vtsgs and vtsgsi c c ... files which must be loaded with vtsgs.f c c sphcom.f, hrfft.f, vhags.f, vhsgs.f,gaqd.f c c c subroutine vtsgs(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci, c + mdab,ndab,wvts,lwvts,work,lwork,ierror) c c given the vector harmonic analysis br,bi,cr, and ci (computed c by subroutine vhags) of some vector function (v,w), this c subroutine computes the vector function (vt,wt) which is c the derivative of (v,w) with respect to colatitude theta. vtsgs c is similar to vhsgs except the vector harmonics are replaced by c their derivative with respect to colatitude with the result that c (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative c of the colatitudinal component v(i,j) at the gaussian colatitude c point theta(i) and longitude phi(j) = (j-1)*2*pi/nlon. the c spectral representation of (vt,wt) is given below at output c parameters vt,wt. c c input parameters c c nlat the number of gaussian colatitudinal grid points theta(i) c such that 0 < theta(1) <...< theta(nlat) < pi. they are c computed by subroutine gaqd which is called by this c subroutine. if nlat is odd the equator is c theta((nlat+1)/2). if nlat is even the equator lies c half way between theta(nlat/2) and theta(nlat/2+1). nlat c must be at least 3. note: if (v,w) is symmetric about c the equator (see parameter ityp below) the number of c colatitudinal grid points is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c ityp = 0 no symmetries exist about the equator. the synthesis c is performed on the entire sphere. i.e. the arrays c vt(i,j),wt(i,j) are computed for i=1,...,nlat and c j=1,...,nlon. c c = 1 no symmetries exist about the equator however the c the coefficients cr and ci are zero which implies c that the curl of (v,w) is zero. that is, c (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0. c the calculations are performed on the entire sphere. c i.e. the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat and j=1,...,nlon. c c = 2 no symmetries exist about the equator however the c the coefficients br and bi are zero which implies c that the divergence of (v,w) is zero. that is, c (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0. c the calculations are performed on the entire sphere. c i.e. the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat and j=1,...,nlon. c c = 3 vt is odd and wt is even about the equator. the c synthesis is performed on the northern hemisphere c only. i.e., if nlat is odd the arrays vt(i,j) c and wt(i,j) are computed for i=1,...,(nlat+1)/2 c and j=1,...,nlon. if nlat is even the arrays c are computed for i=1,...,nlat/2 and j=1,...,nlon. c c = 4 vt is odd and wt is even about the equator and the c coefficients cr and ci are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 5 vt is odd and wt is even about the equator and the c coefficients br and bi are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 6 vt is even and wt is odd about the equator. the c synthesis is performed on the northern hemisphere c only. i.e., if nlat is odd the arrays vt(i,j),wt(i,j) c are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon. c if nlat is even the arrays vt(i,j),wt(i,j) are computed c for i=1,...,nlat/2 and j=1,...,nlon. c c = 7 vt is even and wt is odd about the equator and the c coefficients cr and ci are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c = 8 vt is even and wt is odd about the equator and the c coefficients br and bi are zero. the synthesis is c performed on the northern hemisphere only. i.e. if c nlat is odd the arrays vt(i,j),wt(i,j) are computed c for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is c even the arrays vt(i,j),wt(i,j) are computed for c i=1,...,nlat/2 and j=1,...,nlon. c c nt the number of syntheses. in the program that calls vtsgs, c the arrays vt,wt,br,bi,cr, and ci can be three dimensional c in which case multiple syntheses will be performed. c the third index is the synthesis index which assumes the c values k=1,...,nt. for a single synthesis set nt=1. the c discription of the remaining parameters is simplified c by assuming that nt=1 or that all the arrays are two c dimensional. c c idvw the first dimension of the arrays vt,wt as it appears in c the program that calls vtsgs. if ityp .le. 2 then idvw c must be at least nlat. if ityp .gt. 2 and nlat is c even then idvw must be at least nlat/2. if ityp .gt. 2 c and nlat is odd then idvw must be at least (nlat+1)/2. c c jdvw the second dimension of the arrays vt,wt as it appears in c the program that calls vtsgs. jdvw must be at least nlon. c c br,bi two or three dimensional arrays (see input parameter nt) c cr,ci that contain the vector spherical harmonic coefficients c of (v,w) as computed by subroutine vhags. c c mdab the first dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vtsgs. mdab must be at c least min0(nlat,nlon/2) if nlon is even or at least c min0(nlat,(nlon+1)/2) if nlon is odd. c c ndab the second dimension of the arrays br,bi,cr, and ci as it c appears in the program that calls vtsgs. ndab must be at c least nlat. c c wvts an array which must be initialized by subroutine vtsgsi. c once initialized, wvts can be used repeatedly by vtsgs c as long as nlon and nlat remain unchanged. wvts must c not be altered between calls of vtsgs. c c lwvts the dimension of the array wvts as it appears in the c program that calls vtsgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwvts must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vtsgs. define c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c if ityp .le. 2 then lwork must be at least c c (2*nt+1)*nlat*nlon c c if ityp .gt. 2 then lwork must be at least c c (2*nt+1)*l2*nlon c c ************************************************************** c c output parameters c c vt,wt two or three dimensional arrays (see input parameter nt) c in which the derivative of (v,w) with respect to c colatitude theta is stored. vt(i,j),wt(i,j) contain the c derivatives at gaussian colatitude points theta(i) for c i=1,...,nlat and longitude phi(j) = (j-1)*2*pi/nlon. c the index ranges are defined above at the input parameter c ityp. vt and wt are computed from the formulas for v and c w given in subroutine vhsgs but with vbar and wbar replaced c with their derivatives with respect to colatitude. these c derivatives are denoted by vtbar and wtbar. c c c ************************************************************* c c in terms of real variables this expansion takes the form c c for i=1,...,nlat and j=1,...,nlon c c vt(i,j) = the sum from n=1 to n=nlat-1 of c c .5*br(1,n+1)*vtbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c (br(m+1,n+1)*vtbar(m,n,theta(i)) c -ci(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j)) c -(bi(m+1,n+1)*vtbar(m,n,theta(i)) c +cr(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j)) c c and for i=1,...,nlat and j=1,...,nlon c c wt(i,j) = the sum from n=1 to n=nlat-1 of c c -.5*cr(1,n+1)*vtbar(0,n,theta(i)) c c plus the sum from m=1 to m=mmax-1 of the sum from n=m to c n=nlat-1 of the real part of c c -(cr(m+1,n+1)*vtbar(m,n,theta(i)) c +bi(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j)) c +(ci(m+1,n+1)*vtbar(m,n,theta(i)) c -br(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j)) c c c br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are c assumed zero for m even. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of ityp c = 4 error in the specification of nt c = 5 error in the specification of idvw c = 6 error in the specification of jdvw c = 7 error in the specification of mdab c = 8 error in the specification of ndab c = 9 error in the specification of lwvts c = 10 error in the specification of lwork c c c ******************************************************************* c c subroutine vtsgsi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork, c + ierror) c c subroutine vtsgsi initializes the array wvts which can then be c used repeatedly by subroutine vtsgs until nlat or nlon is changed. c c input parameters c c nlat the number of gaussian colatitudinal grid points theta(i) c such that 0 < theta(1) <...< theta(nlat) < pi. they are c computed by subroutine gaqd which is called by this c subroutine. if nlat is odd the equator is c theta((nlat+1)/2). if nlat is even the equator lies c half way between theta(nlat/2) and theta(nlat/2+1). nlat c must be at least 3. note: if (v,w) is symmetric about c the equator (see parameter ityp below) the number of c colatitudinal grid points is nlat/2 if nlat is even or c (nlat+1)/2 if nlat is odd. c c nlon the number of distinct londitude points. nlon determines c the grid increment in longitude as 2*pi/nlon. for example c nlon = 72 for a five degree grid. nlon must be greater c than zero. the axisymmetric case corresponds to nlon=1. c the efficiency of the computation is improved when nlon c is a product of small prime numbers. c c lwvts the dimension of the array wvts as it appears in the c program that calls vtsgs. define c c l1 = min0(nlat,nlon/2) if nlon is even or c l1 = min0(nlat,(nlon+1)/2) if nlon is odd c c and c c l2 = nlat/2 if nlat is even or c l2 = (nlat+1)/2 if nlat is odd c c then lwvts must be at least c c l1*l2*(nlat+nlat-l1+1)+nlon+15 c c c work a work array that does not have to be saved. c c lwork the dimension of the array work as it appears in the c program that calls vtsgs. lwork must be at least c c 3*(max0(l1-2,0)*(nlat+nlat-l1-1))/2+(5*l2+2)*nlat c c dwork a double precision work array that does not have to be saved c c ldwork the length of dwork. ldwork must be at least c 3*nlat+2 c c ************************************************************** c c output parameters c c wvts an array which is initialized for use by subroutine vtsgs. c once initialized, wvts can be used repeatedly by vtsgs c as long as nlat or nlon remain unchanged. wvts must not c be altered between calls of vtsgs. c c c ierror = 0 no errors c = 1 error in the specification of nlat c = 2 error in the specification of nlon c = 3 error in the specification of lwvts c = 4 error in the specification of lwork c = 5 error in the specification of ldwork c subroutine vtsgs(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci, 1 mdab,ndab,wvts,lwvts,work,lwork,ierror) c dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 work(1),wvts(1) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 if(ityp.lt.0 .or. ityp.gt.8) return ierror = 4 if(nt .lt. 0) return ierror = 5 imid = (nlat+1)/2 if((ityp.le.2 .and. idvw.lt.nlat) .or. 1 (ityp.gt.2 .and. idvw.lt.imid)) return ierror = 6 if(jdvw .lt. nlon) return ierror = 7 mmax = min0(nlat,(nlon+1)/2) if(mdab .lt. mmax) return ierror = 8 if(ndab .lt. nlat) return ierror = 9 idz = (mmax*(nlat+nlat-mmax+1))/2 lzimn = idz*imid if(lwvts .lt. lzimn+lzimn+nlon+15) return ierror = 10 idv = nlat if(ityp .gt. 2) idv = imid lnl = nt*idv*nlon if(lwork .lt. lnl+lnl+idv*nlon) return ierror = 0 ist = 0 if(ityp .le. 2) ist = imid iw1 = ist+1 iw2 = lnl+1 iw3 = iw2+ist iw4 = iw2+lnl jw1 = lzimn+1 jw2 = jw1+lzimn call vtsgs1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab,ndab, 1 br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3), 2 work(iw4),idz,wvts,wvts(jw1),wvts(jw2)) return end subroutine vtsgs1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab, 1 ndab,br,bi,cr,ci,idv,vte,vto,wte,wto,work,idz,vb,wb,wrfft) dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1), 1 bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1), 2 vte(idv,nlon,1),vto(idv,nlon,1),wte(idv,nlon,1), 3 wto(idv,nlon,1),work(1),wrfft(1), 4 vb(imid,1),wb(imid,1) nlp1 = nlat+1 mlat = mod(nlat,2) mlon = mod(nlon,2) mmax = min0(nlat,(nlon+1)/2) imm1 = imid if(mlat .ne. 0) imm1 = imid-1 do 10 k=1,nt do 10 j=1,nlon do 10 i=1,idv vte(i,j,k) = 0. wte(i,j,k) = 0. 10 continue ndo1 = nlat ndo2 = nlat if(mlat .ne. 0) ndo1 = nlat-1 if(mlat .eq. 0) ndo2 = nlat-1 18 itypp = ityp+1 go to (1,100,200,300,400,500,600,700,800),itypp c c case ityp=0 no symmetries c c case m = 0 c 1 do 15 k=1,nt do 15 np1=2,ndo2,2 do 15 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1) wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1) 15 continue do 16 k=1,nt do 16 np1=3,ndo1,2 do 16 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1) wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1) 16 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 30 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 26 do 25 k=1,nt do 24 np1=mp1,ndo1,2 mn = mb+np1 do 23 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 23 continue if(mlat .eq. 0) go to 24 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 24 continue 25 continue 26 if(mp2 .gt. ndo2) go to 30 do 29 k=1,nt do 28 np1=mp2,ndo2,2 mn = mb+np1 do 27 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 27 continue if(mlat .eq. 0) go to 28 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 28 continue 29 continue 30 continue go to 950 c c case ityp=1 no symmetries, cr and ci equal zero c c case m = 0 c 100 do 115 k=1,nt do 115 np1=2,ndo2,2 do 115 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1) 115 continue do 116 k=1,nt do 116 np1=3,ndo1,2 do 116 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1) 116 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 130 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 126 do 125 k=1,nt do 124 np1=mp1,ndo1,2 mn = mb+np1 do 123 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 123 continue if(mlat .eq. 0) go to 124 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 124 continue 125 continue 126 if(mp2 .gt. ndo2) go to 130 do 129 k=1,nt do 128 np1=mp2,ndo2,2 mn = mb+np1 do 127 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 127 continue if(mlat .eq. 0) go to 128 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 128 continue 129 continue 130 continue go to 950 c c case ityp=2 no symmetries, br and bi are equal to zero c c case m = 0 c 200 do 215 k=1,nt do 215 np1=2,ndo2,2 do 215 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1) 215 continue do 216 k=1,nt do 216 np1=3,ndo1,2 do 216 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1) 216 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 230 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 226 do 225 k=1,nt do 224 np1=mp1,ndo1,2 mn = mb+np1 do 223 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 223 continue if(mlat .eq. 0) go to 224 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 224 continue 225 continue 226 if(mp2 .gt. ndo2) go to 230 do 229 k=1,nt do 228 np1=mp2,ndo2,2 mn = mb+np1 do 227 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 227 continue if(mlat .eq. 0) go to 228 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 228 continue 229 continue 230 continue go to 950 c c case ityp=3 v odd, w even c c case m = 0 c 300 do 315 k=1,nt do 315 np1=2,ndo2,2 do 315 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1) 315 continue do 316 k=1,nt do 316 np1=3,ndo1,2 do 316 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1) 316 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 330 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 326 do 325 k=1,nt do 324 np1=mp1,ndo1,2 mn = mb+np1 do 323 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 323 continue if(mlat .eq. 0) go to 324 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 324 continue 325 continue 326 if(mp2 .gt. ndo2) go to 330 do 329 k=1,nt do 328 np1=mp2,ndo2,2 mn = mb+np1 do 327 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 327 continue if(mlat .eq. 0) go to 328 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 328 continue 329 continue 330 continue go to 950 c c case ityp=4 v odd, w even, and both cr and ci equal zero c c case m = 0 c 400 do 415 k=1,nt do 415 np1=2,ndo2,2 do 415 i=1,imm1 vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1) 415 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 430 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 430 do 429 k=1,nt do 428 np1=mp2,ndo2,2 mn = mb+np1 do 427 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 427 continue if(mlat .eq. 0) go to 428 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -bi(mp1,np1,k)*wb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 +br(mp1,np1,k)*wb(imid,mn) 428 continue 429 continue 430 continue go to 950 c c case ityp=5 v odd, w even, br and bi equal zero c c case m = 0 c 500 do 516 k=1,nt do 516 np1=3,ndo1,2 do 516 i=1,imid wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1) 516 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 530 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 530 do 525 k=1,nt do 524 np1=mp1,ndo1,2 mn = mb+np1 do 523 i=1,imm1 vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 523 continue if(mlat .eq. 0) go to 524 wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k) 1 -cr(mp1,np1,k)*vb(imid,mn) wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k) 1 -ci(mp1,np1,k)*vb(imid,mn) 524 continue 525 continue 530 continue go to 950 c c case ityp=6 v even , w odd c c case m = 0 c 600 do 615 k=1,nt do 615 np1=2,ndo2,2 do 615 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1) 615 continue do 616 k=1,nt do 616 np1=3,ndo1,2 do 616 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1) 616 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 630 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 626 do 625 k=1,nt do 624 np1=mp1,ndo1,2 mn = mb+np1 do 623 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 623 continue if(mlat .eq. 0) go to 624 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 624 continue 625 continue 626 if(mp2 .gt. ndo2) go to 630 do 629 k=1,nt do 628 np1=mp2,ndo2,2 mn = mb+np1 do 627 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 627 continue if(mlat .eq. 0) go to 628 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 628 continue 629 continue 630 continue go to 950 c c case ityp=7 v even, w odd cr and ci equal zero c c case m = 0 c 700 do 716 k=1,nt do 716 np1=3,ndo1,2 do 716 i=1,imid vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1) 716 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 730 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp1 .gt. ndo1) go to 730 do 725 k=1,nt do 724 np1=mp1,ndo1,2 mn = mb+np1 do 723 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,mn) 723 continue if(mlat .eq. 0) go to 724 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 +br(mp1,np1,k)*vb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +bi(mp1,np1,k)*vb(imid,mn) 724 continue 725 continue 730 continue go to 950 c c case ityp=8 v even, w odd, br and bi equal zero c c case m = 0 c 800 do 815 k=1,nt do 815 np1=2,ndo2,2 do 815 i=1,imm1 wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1) 815 continue c c case m = 1 through nlat-1 c if(mmax .lt. 2) go to 950 do 830 mp1=2,mmax m = mp1-1 mb = m*(nlat-1)-(m*(m-1))/2 mp2 = mp1+1 if(mp2 .gt. ndo2) go to 830 do 829 k=1,nt do 828 np1=mp2,ndo2,2 mn = mb+np1 do 827 i=1,imm1 vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,mn) vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,mn) wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,mn) wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,mn) 827 continue if(mlat .eq. 0) go to 828 vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k) 1 -ci(mp1,np1,k)*wb(imid,mn) vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k) 1 +cr(mp1,np1,k)*wb(imid,mn) 828 continue 829 continue 830 continue 950 do 14 k=1,nt call hrfftb(idv,nlon,vte(1,1,k),idv,wrfft,work) call hrfftb(idv,nlon,wte(1,1,k),idv,wrfft,work) 14 continue if(ityp .gt. 2) go to 12 do 60 k=1,nt do 60 j=1,nlon do 60 i=1,imm1 vt(i,j,k) = .5*(vte(i,j,k)+vto(i,j,k)) wt(i,j,k) = .5*(wte(i,j,k)+wto(i,j,k)) vt(nlp1-i,j,k) = .5*(vte(i,j,k)-vto(i,j,k)) wt(nlp1-i,j,k) = .5*(wte(i,j,k)-wto(i,j,k)) 60 continue go to 13 12 do 11 k=1,nt do 11 j=1,nlon do 11 i=1,imm1 vt(i,j,k) = .5*vte(i,j,k) wt(i,j,k) = .5*wte(i,j,k) 11 continue 13 if(mlat .eq. 0) return do 65 k=1,nt do 65 j=1,nlon vt(imid,j,k) = .5*vte(imid,j,k) wt(imid,j,k) = .5*wte(imid,j,k) 65 continue return end subroutine vtsgsi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork, + ierror) c c define imid = (nlat+1)/2 and mmax = min0(nlat,(nlon+1)/2) c the length of wvts is imid*mmax*(nlat+nlat-mmax+1)+nlon+15 c and the length of work is labc+5*nlat*imid+2*nlat where c labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c dimension wvts(lwvts),work(lwork) double precision dwork(ldwork) ierror = 1 if(nlat .lt. 3) return ierror = 2 if(nlon .lt. 1) return ierror = 3 mmax = min0(nlat,nlon/2+1) imid = (nlat+1)/2 lzimn = (imid*mmax*(nlat+nlat-mmax+1))/2 if(lwvts .lt. lzimn+lzimn+nlon+15) return ierror = 4 labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 lvin = 3*nlat*imid lwvbin = 2*nlat*imid+labc ltheta = nlat+nlat if(lwork .lt. lvin+lwvbin+ltheta) return ierror = 5 if (ldwork .lt. 3*nlat+2) return ierror = 0 iw1 = lvin+1 iw2 = iw1+lwvbin jw1 = nlat+1 jw2 = jw1+nlat CALL VETG1(NLAT,NLON,IMID,WVTS,WVTS(LZIMN+1),WORK,work(IW1), 1 DWORK,DWORK(JW1),DWORK(JW2),IERROR) if(ierror .ne. 0) return call hrffti(nlon,wvts(2*lzimn+1)) return end subroutine wbgint (nlat,nlon,theta,wwbin,work) dimension wwbin(1) double precision work(*),theta(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c theta is a double precision array with (nlat+1)/2 locations c nlat is the maximum value of n+1 c the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of work is nlat+2 c call wbgit1 (nlat,nlon,imid,theta,wwbin,wwbin(iw1), + work,work(nlat/2+2)) return end subroutine wbgit1 (nlat,nlon,imid,theta,wb,abc,cwb,work) c c abc must have 3*((nlat-3)*nlat+2)/2 locations c cwb and work must each have nlat/2+1 locations c dimension wb(imid,nlat,2),abc(1) double precision cwb(1),theta(1),wbh,work(1) mdo = min0(3,nlat,(nlon+1)/2) if(mdo .lt. 2) return do 160 mp1=2,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dwbk(m,n,cwb,work) do 165 i=1,imid call dwbt(m,n,theta(i),cwb,wbh) wb(i,np1,m) = wbh 165 continue 160 continue call rabcw(nlat,nlon,abc) return end subroutine wbin (ityp,nlat,nlon,m,wb,i3,wwbin) dimension wb(1) ,wwbin(1) imid = (nlat+1)/2 lim = nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 iw1 = lim+1 iw2 = iw1+lim iw3 = iw2+labc iw4 = iw3+labc c c the length of wwbin is 2*lim+3*labc c call wbin1 (ityp,nlat,m,wb,imid,i3,wwbin,wwbin(iw1),wwbin(iw2), 1 wwbin(iw3),wwbin(iw4)) return end subroutine wbin1 (ityp,nlat,m,wb,imid,i3,wb1,wb2,a,b,c) dimension wb(imid,nlat,3),wb1(imid,1),wb2(imid,1), 1 a(1),b(1),c(1) save i1,i2 ihold = i1 i1 = i2 i2 = i3 i3 = ihold if(m-2)25,30,35 25 i1 = 1 i2 = 2 i3 = 3 do 45 np1=2,nlat do 45 i=1,imid wb(i,np1,i3) = wb1(i,np1) 45 continue return 30 do 50 np1=3,nlat do 50 i=1,imid wb(i,np1,i3) = wb2(i,np1) 50 continue return 35 ns = ((m-2)*(nlat+nlat-m-1))/2+1 if(ityp .eq. 1) go to 36 do 85 i=1,imid wb(i,m+1,i3) = a(ns)*wb(i,m-1,i1)-c(ns)*wb(i,m+1,i1) 85 continue 36 if(m .eq. nlat-1) return if(ityp .eq. 2) go to 71 ns = ns+1 do 70 i=1,imid wb(i,m+2,i3) = a(ns)*wb(i,m,i1)-c(ns)*wb(i,m+2,i1) 70 continue 71 nstrt = m+3 if(ityp .eq. 1) nstrt = m+4 if(nstrt .gt. nlat) go to 80 nstp = 2 if(ityp .eq. 0) nstp = 1 do 75 np1=nstrt,nlat,nstp ns = ns+nstp do 75 i=1,imid wb(i,np1,i3) = a(ns)*wb(i,np1-2,i1)+b(ns)*wb(i,np1-2,i3) 1 -c(ns)*wb(i,np1,i1) 75 continue 80 return end subroutine wbini1 (nlat,nlon,imid,wb,abc,cwb,work) c c abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c locations where mmax = min0(nlat,(nlon+1)/2) c cwb and work must each have nlat/2+1 locations c dimension wb(imid,nlat,2),abc(1) double precision pi,dt,cwb(1),wbh,th,work(1) pi = 4.*datan(1.d0) dt = pi/(nlat-1) mdo = min0(3,nlat,(nlon+1)/2) if(mdo .lt. 2) return do 160 mp1=2,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dwbk(m,n,cwb,work) do 165 i=1,imid th = (i-1)*dt call dwbt(m,n,th,cwb,wbh) wb(i,np1,m) = wbh 165 continue 160 continue call rabcw(nlat,nlon,abc) return end subroutine wbinit (nlat,nlon,wwbin,dwork) dimension wwbin(1) double precision dwork(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of dwork is nlat+2 c call wbini1 (nlat,nlon,imid,wwbin,wwbin(iw1),dwork, 1 dwork(nlat/2+2)) return end subroutine wtgint (nlat,nlon,theta,wwbin,work) dimension wwbin(*) double precision theta(*), work(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c theta is a double precision array with (nlat+1)/2 locations c nlat is the maximum value of n+1 c the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of work is nlat+2 c call wtgit1 (nlat,nlon,imid,theta,wwbin,wwbin(iw1), 1 work,work(nlat/2+2)) return end subroutine wtgit1 (nlat,nlon,imid,theta,wb,abc,cwb,work) c c abc must have 3*((nlat-3)*nlat+2)/2 locations c cwb and work must each have nlat/2+1 locations c dimension wb(imid,nlat,2),abc(1) double precision theta(*), cwb(*), work(*), wbh mdo = min0(3,nlat,(nlon+1)/2) if(mdo .lt. 2) return do 160 mp1=2,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dwtk(m,n,cwb,work) do 165 i=1,imid call dwtt(m,n,theta(i),cwb,wbh) wb(i,np1,m) = wbh 165 continue 160 continue call rabcw(nlat,nlon,abc) return end subroutine wtini1 (nlat,nlon,imid,wb,abc,cwb,work) c c abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c locations where mmax = min0(nlat,(nlon+1)/2) c cwb and work must each have nlat/2+1 locations c dimension wb(imid,nlat,2),abc(1) double precision pi,dt,cwb(*),wbh,th,work(*) pi = 4.*datan(1.d0) dt = pi/(nlat-1) mdo = min0(3,nlat,(nlon+1)/2) if(mdo .lt. 2) return do 160 mp1=2,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dwtk(m,n,cwb,work) do 165 i=1,imid th = (i-1)*dt call dwtt(m,n,th,cwb,wbh) wb(i,np1,m) = wbh 165 continue 160 continue call rabcw(nlat,nlon,abc) return end subroutine wtinit (nlat,nlon,wwbin,dwork) dimension wwbin(1) double precision dwork(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of dwork is nlat+2 c call wtini1 (nlat,nlon,imid,wwbin,wwbin(iw1),dwork, 1 dwork(nlat/2+2)) return end subroutine zfin (isym,nlat,nlon,m,z,i3,wzfin) dimension z(1) ,wzfin(1) imid = (nlat+1)/2 lim = nlat*imid mmax = min0(nlat,nlon/2+1) labc = ((mmax-2)*(nlat+nlat-mmax-1))/2 iw1 = lim+1 iw2 = iw1+lim iw3 = iw2+labc iw4 = iw3+labc c c the length of wzfin is 2*lim+3*labc c call zfin1 (isym,nlat,m,z,imid,i3,wzfin,wzfin(iw1),wzfin(iw2), 1 wzfin(iw3),wzfin(iw4)) return end subroutine zfin1 (isym,nlat,m,z,imid,i3,zz,z1,a,b,c) dimension z(imid,nlat,3),zz(imid,1),z1(imid,1), 1 a(1),b(1),c(1) save i1,i2 ihold = i1 i1 = i2 i2 = i3 i3 = ihold if(m-1)25,30,35 25 i1 = 1 i2 = 2 i3 = 3 do 45 np1=1,nlat do 45 i=1,imid z(i,np1,i3) = zz(i,np1) 45 continue return 30 do 50 np1=2,nlat do 50 i=1,imid z(i,np1,i3) = z1(i,np1) 50 continue return 35 ns = ((m-2)*(nlat+nlat-m-1))/2+1 if(isym .eq. 1) go to 36 do 85 i=1,imid z(i,m+1,i3) = a(ns)*z(i,m-1,i1)-c(ns)*z(i,m+1,i1) 85 continue 36 if(m .eq. nlat-1) return if(isym .eq. 2) go to 71 ns = ns+1 do 70 i=1,imid z(i,m+2,i3) = a(ns)*z(i,m,i1)-c(ns)*z(i,m+2,i1) 70 continue 71 nstrt = m+3 if(isym .eq. 1) nstrt = m+4 if(nstrt .gt. nlat) go to 80 nstp = 2 if(isym .eq. 0) nstp = 1 do 75 np1=nstrt,nlat,nstp ns = ns+nstp do 75 i=1,imid z(i,np1,i3) = a(ns)*z(i,np1-2,i1)+b(ns)*z(i,np1-2,i3) 1 -c(ns)*z(i,np1,i1) 75 continue 80 return end subroutine zfini1 (nlat,nlon,imid,z,abc,cz,work) c c abc must have 3*((mmax-2)*(nlat+nlat-mmax-1))/2 locations c where mmax = min0(nlat,nlon/2+1) c cz and work must each have nlat+1 locations c dimension z(imid,nlat,2),abc(1) double precision pi,dt,th,zh,cz(*),work(*) pi = 4.*datan(1.d0) dt = pi/(nlat-1) do 160 mp1=1,2 m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dnzfk(nlat,m,n,cz,work) do 165 i=1,imid th = (i-1)*dt call dnzft(nlat,m,n,th,cz,zh) z(i,np1,mp1) = zh 165 continue z(1,np1,mp1) = .5*z(1,np1,mp1) 160 continue call rabcp(nlat,nlon,abc) return end subroutine zfinit (nlat,nlon,wzfin,dwork) dimension wzfin(*) double precision dwork(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c the length of wzfin is 3*((l-3)*l+2)/2 + 2*l*imid c the length of dwork is nlat+2 c call zfini1 (nlat,nlon,imid,wzfin,wzfin(iw1),dwork, 1 dwork(nlat/2+1)) return end subroutine zvin (ityp,nlat,nlon,m,zv,i3,wzvin) dimension zv(1) ,wzvin(1) imid = (nlat+1)/2 lim = nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 iw1 = lim+1 iw2 = iw1+lim iw3 = iw2+labc iw4 = iw3+labc c c the length of wzvin is 2*lim+3*labc c call zvin1 (ityp,nlat,m,zv,imid,i3,wzvin,wzvin(iw1),wzvin(iw2), 1 wzvin(iw3),wzvin(iw4)) return end subroutine zvin1 (ityp,nlat,m,zv,imid,i3,zvz,zv1,a,b,c) dimension zv(imid,nlat,3),zvz(imid,1),zv1(imid,1), 1 a(1),b(1),c(1) save i1,i2 ihold = i1 i1 = i2 i2 = i3 i3 = ihold if(m-1)25,30,35 25 i1 = 1 i2 = 2 i3 = 3 do 45 np1=1,nlat do 45 i=1,imid zv(i,np1,i3) = zvz(i,np1) 45 continue return 30 do 50 np1=2,nlat do 50 i=1,imid zv(i,np1,i3) = zv1(i,np1) 50 continue return 35 ns = ((m-2)*(nlat+nlat-m-1))/2+1 if(ityp .eq. 1) go to 36 do 85 i=1,imid zv(i,m+1,i3) = a(ns)*zv(i,m-1,i1)-c(ns)*zv(i,m+1,i1) 85 continue 36 if(m .eq. nlat-1) return if(ityp .eq. 2) go to 71 ns = ns+1 do 70 i=1,imid zv(i,m+2,i3) = a(ns)*zv(i,m,i1)-c(ns)*zv(i,m+2,i1) 70 continue 71 nstrt = m+3 if(ityp .eq. 1) nstrt = m+4 if(nstrt .gt. nlat) go to 80 nstp = 2 if(ityp .eq. 0) nstp = 1 do 75 np1=nstrt,nlat,nstp ns = ns+nstp do 75 i=1,imid zv(i,np1,i3) = a(ns)*zv(i,np1-2,i1)+b(ns)*zv(i,np1-2,i3) 1 -c(ns)*zv(i,np1,i1) 75 continue 80 return end subroutine zvini1 (nlat,nlon,imid,zv,abc,czv,work) c c abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c locations where mmax = min0(nlat,(nlon+1)/2) c czv and work must each have nlat/2+1 locations c dimension zv(imid,nlat,2),abc(1) double precision pi,dt,czv(1),zvh,th,work(1) pi = 4.*datan(1.d0) dt = pi/(nlat-1) mdo = min0(2,nlat,(nlon+1)/2) do 160 mp1=1,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dzvk(nlat,m,n,czv,work) do 165 i=1,imid th = (i-1)*dt call dzvt(nlat,m,n,th,czv,zvh) zv(i,np1,mp1) = zvh 165 continue zv(1,np1,mp1) = .5*zv(1,np1,mp1) 160 continue call rabcv(nlat,nlon,abc) return end subroutine zvinit (nlat,nlon,wzvin,dwork) dimension wzvin(1) double precision dwork(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c the length of wzvin is c 2*nlat*imid +3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c the length of dwork is nlat+2 c call zvini1 (nlat,nlon,imid,wzvin,wzvin(iw1),dwork, 1 dwork(nlat/2+2)) return end subroutine zwin (ityp,nlat,nlon,m,zw,i3,wzwin) dimension zw(1) ,wzwin(1) imid = (nlat+1)/2 lim = nlat*imid mmax = min0(nlat,(nlon+1)/2) labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 iw1 = lim+1 iw2 = iw1+lim iw3 = iw2+labc iw4 = iw3+labc c c the length of wzwin is 2*lim+3*labc c call zwin1 (ityp,nlat,m,zw,imid,i3,wzwin,wzwin(iw1),wzwin(iw2), 1 wzwin(iw3),wzwin(iw4)) return end subroutine zwin1 (ityp,nlat,m,zw,imid,i3,zw1,zw2,a,b,c) dimension zw(imid,nlat,3),zw1(imid,1),zw2(imid,1), 1 a(1),b(1),c(1) save i1,i2 ihold = i1 i1 = i2 i2 = i3 i3 = ihold if(m-2)25,30,35 25 i1 = 1 i2 = 2 i3 = 3 do 45 np1=2,nlat do 45 i=1,imid zw(i,np1,i3) = zw1(i,np1) 45 continue return 30 do 50 np1=3,nlat do 50 i=1,imid zw(i,np1,i3) = zw2(i,np1) 50 continue return 35 ns = ((m-2)*(nlat+nlat-m-1))/2+1 if(ityp .eq. 1) go to 36 do 85 i=1,imid zw(i,m+1,i3) = a(ns)*zw(i,m-1,i1)-c(ns)*zw(i,m+1,i1) 85 continue 36 if(m .eq. nlat-1) return if(ityp .eq. 2) go to 71 ns = ns+1 do 70 i=1,imid zw(i,m+2,i3) = a(ns)*zw(i,m,i1)-c(ns)*zw(i,m+2,i1) 70 continue 71 nstrt = m+3 if(ityp .eq. 1) nstrt = m+4 if(nstrt .gt. nlat) go to 80 nstp = 2 if(ityp .eq. 0) nstp = 1 do 75 np1=nstrt,nlat,nstp ns = ns+nstp do 75 i=1,imid zw(i,np1,i3) = a(ns)*zw(i,np1-2,i1)+b(ns)*zw(i,np1-2,i3) 1 -c(ns)*zw(i,np1,i1) 75 continue 80 return end subroutine zwini1 (nlat,nlon,imid,zw,abc,czw,work) c c abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 c locations where mmax = min0(nlat,(nlon+1)/2) c czw and work must each have nlat+1 locations c dimension zw(imid,nlat,2),abc(1) double precision pi,dt,czw(1),zwh,th,work(1) pi = 4.*datan(1.d0) dt = pi/(nlat-1) mdo = min0(3,nlat,(nlon+1)/2) if(mdo .lt. 2) return do 160 mp1=2,mdo m = mp1-1 do 160 np1=mp1,nlat n = np1-1 call dzwk(nlat,m,n,czw,work) do 165 i=1,imid th = (i-1)*dt call dzwt(nlat,m,n,th,czw,zwh) zw(i,np1,m) = zwh 165 continue zw(1,np1,m) = .5*zw(1,np1,m) 160 continue call rabcw(nlat,nlon,abc) return end subroutine zwinit (nlat,nlon,wzwin,dwork) dimension wzwin(1) double precision dwork(*) imid = (nlat+1)/2 iw1 = 2*nlat*imid+1 c c the length of wzvin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2 c the length of dwork is nlat+2 c call zwini1 (nlat,nlon,imid,wzwin,wzwin(iw1),dwork, 1 dwork(nlat/2+2)) return end