spherepack-3.2/0000755000175000017500000000000011464263342013672 5ustar alastairalastairspherepack-3.2/setup.py0000644000175000017500000000405711464224044015406 0ustar alastairalastairimport sys,os target_prefix = sys.prefix for i in range(len(sys.argv)): a = sys.argv[i] if a=='--prefix': target_prefix=sys.argv[i+1] sp = a.split("--prefix=") if len(sp)==2: target_prefix=sp[1] sys.path.insert(0,os.path.join(target_prefix,'lib','python%i.%i' % sys.version_info[:2],'site-packages')) from numpy.distutils.core import Extension import sys sources = """ Src/alf.f Src/gradgs.f Src/idvtgs.f Src/isfvpgs.f Src/ivrtec.f Src/shaes.f Src/slapec.f Src/vhaes.f Src/vlapgc.f Src/vtsgc.f Src/divec.f Src/hrfft.f Src/igradec.f Src/islapec.f Src/ivrtes.f Src/shagc.f Src/slapes.f Src/vhagc.f Src/vlapgs.f Src/vtsgs.f Src/dives.f Src/idivec.f Src/igrades.f Src/islapes.f Src/ivrtgc.f Src/shags.f Src/slapgc.f Src/vhags.f Src/vrtec.f Src/divgc.f Src/idives.f Src/igradgc.f Src/islapgc.f Src/ivrtgs.f Src/shigc.f Src/slapgs.f Src/vhsec.f Src/vrtes.f Src/divgs.f Src/idivgc.f Src/igradgs.f Src/islapgs.f Src/sfvpec.f Src/shigs.f Src/sphcom.f Src/vhses.f Src/vrtgc.f Src/gaqd.f Src/idivgs.f Src/ihgeod.f Src/ivlapec.f Src/sfvpes.f Src/shsec.f Src/sshifte.f Src/vhsgc.f Src/vrtgs.f Src/gradec.f Src/idvtec.f Src/isfvpec.f Src/ivlapes.f Src/sfvpgc.f Src/shses.f Src/trssph.f Src/vhsgs.f Src/vshifte.f Src/grades.f Src/idvtes.f Src/isfvpes.f Src/ivlapgc.f Src/sfvpgs.f Src/shsgc.f Src/trvsph.f Src/vlapec.f Src/vtsec.f Src/gradgc.f Src/idvtgc.f Src/isfvpgc.f Src/ivlapgs.f Src/shaec.f Src/shsgs.f Src/vhaec.f Src/vlapes.f Src/vtses.f """.split() extra_link_args=[] if sys.platform=='darwin': extra_link_args = ['-bundle','-bundle_loader '+sys.prefix+'/bin/python'] ext1 = Extension(name = 'spherepack', extra_link_args=extra_link_args, sources = ['Src/spherepack.pyf',]+sources) if __name__ == "__main__": from numpy.distutils.core import setup setup(name = 'sphere', ext_modules = [ext1,], packages = ['sphere'], package_dir = {'sphere': 'Lib', }, ) spherepack-3.2/spheremodule.doc0000644000175000017500000006572211464224044017065 0ustar alastairalastair********************************************************************************************** ****************** Overview of the CDAT interface to the NCAR SPHEREPACK 3.0 ***************** ********************************************************************************************** None ************************************************************************************ ************************** Sphere class documentation ****************************** ************************************************************************************ -------------------------------------------------------------------------------------- To make an instance x of the Sphere class type x = sphere.Sphere(lonArray , latArray, numberLevels = nlev, numberTimes = ntime, computed_stored = 'computed') where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArray = longitude vector (required) latArray = latitude vector (required) numberLevels = number of levels (optional) numberTimes = number of times (optional) computed_stored (optional) : 'computed' -- computed Legendre polynomials 'stored' -- stored Legendre polynomials This choice involves a 30% storage/speed tradeoff As an example, for a 2D field using 'computed Legendre polynomials' type x = sphere.Sphere(lonArray , latArray) As an example, for a 4D field with 3 levels, 120 times using 'stored Legendre polynomials' type x = sphere.Sphere(lonArray , latArray, 3, 120, 'stored') or using the keywords explicitly x = sphere.Sphere(lonArray , latArray, numberLevels = 3, numberTimes = 120, computed_stored = 'stored') where the order of the keyword entries is immaterial. ----------------------------------------------------------------------------------- **************************** Sphere class functions ******************************** -------------------------------------------------------------------------------------------------------- routine: div purpose: computes the divergence of a vector function usage: div = x.div( u, v, missingValue) where x is an instance of Sphere passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: div -- the divergence of the vector function definition: div(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: idiv purpose: computes an irrotational vector function with given divergence usage: u, v = x.idiv(div, missingValue) passed: div -- divergence function on a global grid missingValue -- an optional number requesting a check for missing data returned: u -- zonal vector function v -- meridional vector function definition: idiv(self, div, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: vrt purpose: computes the scalar vorticity of a vector function usage: vort = x.vrt(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: vort -- the vorticity of the vector function definition: vrt(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: ivrt purpose: computes a divergence-free vector function whose vorticity is given usage: u, v = x.ivrt(vort, missingValue) missingValue -- an optional number requesting a check for missing data passed: vort -- vorticity on a global grid returned: u -- zonal vector function v -- meridional vector function definition: ivrt(self, vort, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: idvt purpose: computes a vector function with given divergence and vorticity usage: u, v = x.idvt(div, vort, missingValue) passed: div -- divergence function on a global grid vort -- vorticity function on a global grid missingValue -- an optional number requesting a check for missing data returned: u -- zonal vector function v -- meridional vector function definition: idvt(self, div, vort, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: vts purpose: computes the derivative of the vector function with respect to latitude usage: ud, vd = x.vrt(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: ud -- zonal vector function vd -- meridional vector function definition: vts(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: grad purpose: computes the gradient of a scalar function usage: u, v = x.grad(sf, missingValue) passed: sf -- scalar function on a global grid returned: u -- zonal vector function v -- meridional vector function missingValue -- an optional number requesting a check for missing data definition: grad(self, sf, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: igrad purpose: computes a scalar function whose gradient is a given vector function usage: sf = x.igrad(u, v, missingValue) passed: u -- zonal vector function v -- meridional vector function missingValue -- an optional number requesting a check for missing data returned: sf -- a scalar function definition: igrad(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: slap purpose: computes a scalar Laplacian of a scalar function usage: slap = x.slap(self, sf, missingValue) missingValue -- an optional number requesting a check for missing data passed: sf -- scalar function on a global grid returned: slap -- scalar function definition: slap(self, sf, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: islap purpose: computes a scalar function whose scalar Laplacian is given usage: sf, ierror = x.islap(slap, missingValue): passed: slap -- scalar Laplacian on a global grid missingValue -- an optional number requesting a check for missing data returned: sf -- a scalar function definition: islap(self, slap, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: vlap purpose: computes the vector Laplacian of a given vector function usage: ulap, vlap = x.vlap(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: ulap -- zonal vector Laplacian function vlap -- meridional vector Laplacian function definition: vlap(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: ivlap purpose: computes a vector function whose Laplacian is a given vector vector function usage: u, v = x.ivlap(ulap, vlap, missingValue) missingValue -- an optional number requesting a check for missing data passed: ulap -- zonal Laplacian vector function on a global grid vlap -- meridional Laplacian vector function on a global grid returned: u -- zonal vector function v -- meridional vector function definition: ivlap(self, ulap, vlap, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: sfvp purpose: computes the stream function and the velocity potential of a vector function usage: sf, vp = x.sfvp(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: sf -- stream function vp -- velocity potential definition: sfvp(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: isfvp purpose: computes a vector function with a given stream function and velocity potential usage: u, v = x.isfvp(sf, vp, missingValue): passed: sf -- stream function on a global grid vp -- velocity potential on a global grid missingValue -- an optional number requesting a check for missing data returned: u -- zonal vector function v -- meridional vector function definition: isfvp(self, sf, vp, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: truncation purpose: performs a triangular truncation of a scalar or a vector function with or without tapering. For example, a request for T42 entails eliminating all values for the total wavenumber above 42. The remaining values are tapered by default. usage: u, v = truncation(42, u, v) u, v = truncation(wave, u, v) u, v = truncation(wave, u, v, 'no', missingValue): or sf = truncation(42, sf): sf = truncation(wave, sf): sf = truncation(wave, sf, v, 'no', missingValue): passed: wave - the truncation wave number. For example, a request for T42 is wave set to 42 whick entails eliminating all values for the total wavenumber above 42. u -- zonal vector function on a global grid v -- meridional vector function on a global grid or sf -- a scalar with v = None instead of u, v taper - (optional) the values remaining after truncation are tapered if the default 'yes' is not changed to 'no'. missingValue -- an optional number requesting a check for missing data returned: u, v or sf definition: truncation(self, wave, u, v = None, taper = 'yes', missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: sha purpose: computes analysis coefficients for a scalar function usage: a, b = x.sha(sf, missingValue) missingValue -- an optional number requesting a check for missing data passed: sf -- scalar function on global grid returned: a -- coefficients b -- coefficients definition: sha(self, sf, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: shs purpose: computes a scalar function from the coefficients usage: sf = x.shs(a, b) passed: a -- coefficients b -- coefficients returned: sf -- scalar function definition: shs(self, a, b): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: vha purpose: computes the vector harmonic analysis usage: br, bi, cr, ci = x.vha(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: br -- coefficients bi -- coefficients cr -- coefficients ci -- coefficients definition: vha(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: vhs purpose: computes the vector harmonic synthesis usage: u, v = x.vhs(br, bi, cr, ci) passed: br -- coefficients bi -- coefficients cr -- coefficients ci -- coefficients returned: u -- zonal vector function v -- meridional vector function definition: vhs(self, br, bi, cr, ci): -------------------------------------------------------------------------------------------------------- ************************************************************************************ **************************** Regrid class documentation **************************** ************************************************************************************ -------------------------------------------------------------------------------------- To make an instance x of the Regrid class type x = sphere.Regrid(lonArrayOut, latArrayOut, lonArrayIn, latArrayIn, numberLevels = nlev, numberTimes = ntime) where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArrayOut = output grid longitude vector (required) latArrayOut = output grid latitude vector (required) lonArrayIn = input grid longitude vector (required) latArrayIn = input grid latitude vector (required) numberLevels = input grid number of levels (optional) numberTimes = input grid number of times (optional) ----------------------------------------------------------------------------------- ****************************** Regrid class functions ****************************** -------------------------------------------------------------------------------------------------------- routine: regridScalar purpose: transfers scalar data from one global spherical grid to another. The grids may be gaussian or equally spaced. usage: sfregrid= x.regridScalar(sf) passed: sf -- scalar function on a global grid returned: sfregrid -- regridded scalar function definition: regridScalar(self, sf, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: regridVector purpose: transfers vector data from one global spherical grid to another. The grids can be gaussian or equally spaced. usage: uregrid, vregrid = x.regridVector(u, v) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid returned: uregrid -- zonal regridded vector function vregrid -- meridional regridded vector function definition: regridVector(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- ************************************************************************************ *************************** Shiftgrid class documentation ************************** ************************************************************************************ -------------------------------------------------------------------------------------- To make an instance x of the Shiftgrid class type x = sphere.Shiftgrid(lonArray, latArray, numberLevels = nlev, numberTimes = ntime) where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArray = longitude vector (required) latArray = latitude vector (required) numberLevels = number of levels (optional) numberTimes = number of times (optional) ----------------------------------------------------------------------------------- ***************************** Shiftgrid class functions **************************** -------------------------------------------------------------------------------------------------------- routine: shiftScalar purpose: transfers scalar data on the sphere between an equally spaced grid that includes the poles and a grid which is offset by a half grid increment in both longitude and latitude (which excludes the poles) usage: sfshift = x.shiftScalar(sf) passed: sf -- an evenly spaced scalar function on a global grid returned: sfshift -- the shifted evenly spaced scalar function definition: shiftScalar(self, sf, missingValue = None): -------------------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------------------- routine: shiftVector purpose: transfers vector data on the sphere between an equally spaced grid that includes the poles and a grid which is offset by a half grid increment in both longitude and latitude (which excludes the poles) usage: ushift, vshift = x.shiftVector(u,v) passed: u -- zonal evenly spaced vector function on a global grid v -- meridional evenly spaced vector function on a global grid returned: ushift -- zonal evenly spaced vector function vshift -- meridional evenly spaced vector function definition: shiftVector(self, u, v, missingValue = None): -------------------------------------------------------------------------------------------------------- ************************************************************************************ **************************** Utility documentation ********************************* ************************************************************************************ ----------------------------------------------------------------------------- routine: gridGenerator purpose: generate the grid vectors usage: lonvals, latvals = sphere.gridGenerator(nlon, nlat, firstLongitude, typeLatitudes, directionLatitudes) passed: nlon - size of longitude vector nlat - size of latitude vector firstLongitude -- first vector element typeLatitudes -- 'even' or 'gaussian' directionLatitudes -- 'north_to_south' or 'south_to_north' return: lonvals, latvals - the double precision grid vectors definition: gridGenerator(nlon, nlat, firstLongitude, typeLatitudes, directionLatitudes): ----------------------------------------------------------------------------------- ------------------------------------------------------------------------------------------- routine: truncate purpose: perform a triangular truncation of the coefficients in the arrays a and b with or without tapering. For example, a request for T42 entails eliminating all values for the total wavenumber above 42. If taper is not None, the remaining values are tapered. usage: a,b = truncate(wave, a, b) -- use tapering a,b = truncate(wave, a, b, taper = 'no') -- turn off tapering passed: a, b - the arrays wave - the truncation wavenumber taper - request for tapering the coefficient values returned: a, b - the truncated coefficient arrays definition: truncate(wave, a, b, taper = 'yes'): note: a, b have indices (nt, n, m) note: the formula for the exponential tapering was taken from John C. Adams. It is described in Sardeshmukh P. D. and Hoskins B. J., 1984, Spatial Smoothing on the Sphere. Mon. Wea. Rev., 112, 2524-2529. ------------------------------------------------------------------------------------------- spherepack-3.2/Test/0000755000175000017500000000000011464224044014605 5ustar alastairalastairspherepack-3.2/Test/test_spherepack.py0000755000175000017500000010761711464224044020362 0ustar alastairalastair# Adapted for numpy/ma/cdms2 by convertcdms.py """Documentation for module spheretest: an automatic test for sphere, an interface to spherepack TESTING Typing cdat spheretest.py generates some testing of the spheremodule using analytically generated winds as the input fields. There are 3 tests. test 1 Starting with analytically generated winds, it calculates the stream function and velocity potential using Spherepack and compares with an analytically generated stream function and velocity potential. test 2 Starting with analytically generated winds on a regular grid, one which includes the poles, it calculates the winds on a grid offset by half a grid point in longitude and latitude, test 3 Starting with analytically generated winds on an evenly spaced grid, it calculates the winds on a gaussian grid. For each test an rms error is calculated and written to the screen. In addition, the output to the screen is placed in the file screen.asc. The numerical results are written to a series of Netcdf files. The contents of these files are described in the screen output. After completing the tests, documentation is written to the file spheremodule.doc. DOCUMENTATION Documentation written to the file spheremodule.doc can be obtained without running the tests after importing the spheretest module by typing spheretest.document() A brief view of the documentation consisting of the overview can be written to the file spheremodule.doc after importing the sphere module by typing spheretest.document(brief = 'yes') """ import sys, string, sphere import spherepack, numpy, math #spherepack.set_pyfort_option(spherepack.MIRROR) debug = 0 # set to 1 for debug prints radius = 6.37122e06 writeTestcase = 'yes' try: import cdms2 except ImportError: print 'Can not write test case results to netCDF files without module cdms2' writeTestcase = 'no' def document(brief = 'no'): #---------------------------------------------------------------------------------------- # # purpose: 'document' writes the doc strings contained in the sphere module # to a file as documentation for the user # # usage: import sphere # sphere.document() # # passed : nothing # # returned: nothing # #---------------------------------------------------------------------------------------- std = sys.stdout sys.stdout = open('spheremodule.doc', 'w') print '**********************************************************************************************\n' print '****************** Overview of the CDAT interface to the NCAR SPHEREPACK 3.0 *****************\n' print '**********************************************************************************************\n' print sphere.__doc__ print print if brief != 'no': return None print ' ************************************************************************************\n' print ' ************************** Sphere class documentation ******************************\n' print ' ************************************************************************************\n' sphere.help('Sphere') # how to make an instance of a class print print ' **************************** Sphere class functions ********************************\n' SphereList = ['div', 'idiv', 'vrt', 'ivrt', 'idvt', 'vts', 'grad', 'igrad', 'slap', 'islap', 'vlap', 'ivlap', 'sfvp', 'isfvp', 'truncation', 'sha', 'shs', 'vha', 'vhs'] for name in SphereList: command = "sphere.help(" + "name" + ")" exec command print print ' ************************************************************************************\n' print ' **************************** Regrid class documentation ****************************\n' print ' ************************************************************************************\n' sphere.help('Regrid') # how to make an instance of a class print print ' ****************************** Regrid class functions ******************************\n' sphere.help('regridScalar') print sphere.help('regridVector') print print ' ************************************************************************************\n' print ' *************************** Shiftgrid class documentation **************************\n' print ' ************************************************************************************\n' sphere.help('Shiftgrid') # how to make an instance of a class print print ' ***************************** Shiftgrid class functions ****************************\n' sphere.help('shiftScalar') print sphere.help('shiftVector') print print ' ************************************************************************************\n' print ' **************************** Utility documentation *********************************\n' print ' ************************************************************************************\n' sphere.help('gridGenerator') # how to make an instance of a class print sphere.help('truncate') print sys.stdout = std return None # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++ Autotest Functions +++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ def sfvp(): #----------------------------------------------------------------------------------- # # purpose: starting with analytically generated winds, calculate the stream # function and velocity potential using Spherepack and compare with # analytically generated stream function and velocity potential. # # usage: sfvp() # # passed : nothing # # returned: nothing # #----------------------------------------------------------------------------------- sendmsg('**************** calculate the stream function and velocity potential on gaussian grid *****************') sendmsg(' ') testError = 0 comp = 'computed' nlon = 128 nlat = 64 lonvals, latvals, timevals, u, v, sfexact, vpexact = sphere_test(nlon, nlat, 'v', 'gaussian') nt = len(timevals) x = sphere.Sphere(lonvals, latvals, numberLevels = 0, numberTimes = nt, computed_stored = comp) sfcal, vpcal = x.sfvp(u, v) scale = radius # scale exact functions to radius for the earth sfexact = sphere.geoscale(scale, sfexact) vpexact = sphere.geoscale(scale, vpexact) sfexact = remove_offset(sfcal, sfexact) # subtract the offset vpexact = remove_offset(vpcal, vpexact) sendmsg('******* compare results') rms = rmserror(sfcal, sfexact) # stream function rms error sendmsg('expected normalized rms error in stream function computation is less than 1.e-05') sendmsg('calculated normalized rms error in stream function computation =', rms) sendmsg(' ') if rms > 1.e-05: testError = testError + 1 rms = rmserror(vpcal, vpexact) # velocity potential rms error sendmsg( 'expected normalized rms error in velocity potential computation is less than 1.e-05') sendmsg( 'calculated normalized rms error in velocity potential computation =', rms) sendmsg(' ') if rms > 1.e-05: testError = testError + 1 if writeTestcase == 'yes': sendmsg('******* write data') sendmsg( 'calculated stream function written to sfcal.nc') # write netcdf file writeField(lonvals, latvals, timevals, 'sfcal', sfcal) sendmsg( 'calculated velocity potential written to vpcal.nc') writeField(lonvals, latvals, timevals, 'vpcal', vpcal) sendmsg(' ') sendmsg( 'exact stream function written to sfexact.nc') # write netcdf file writeField(lonvals, latvals, timevals, 'sfexact', sfexact) sendmsg( 'exact velocity potential written to vpexact.nc') writeField(lonvals, latvals, timevals, 'vpexact', vpexact) sendmsg(' ') sendmsg(' ') return testError def shift(): #----------------------------------------------------------------------------------- # # purpose: starting with analytically generate winds on a regular grid, one # which includes the poles, calculate the winds on a grid offset by # half a grid point in longitude and latitude, # # usage: shift() # # passed : nothing # # returned: nothing # #----------------------------------------------------------------------------------- sendmsg('************ vector shift from a regular evenly spaced grid and a offset evenly spaced grid ************') sendmsg(' ') testError = 0 comp = 'computed' nlon = 144 nlat = 72 lonvals, latvals, timevals, u, v = vshift_testfunction(nlon, nlat) offlonvals, offlatvals, timevals, uexact, vexact = vshift_testfunction(nlon, nlat, grid_type = 'offset') nt = len(timevals) x = sphere.Shiftgrid(lonvals, latvals, numberTimes = nt) ucal, vcal = x.shiftVector(u,v) sendmsg('******* compare results') rms = rmserror(ucal, uexact) # zonal wind rms error sendmsg( 'expected normalized error in zonal wind computation is less than 1.e-06') sendmsg( 'calculated normalized rms error in zonal wind computation =', rms) sendmsg( ' ') if rms > 1.e-06: testError = testError + 1 rms = rmserror(vcal, vexact) sendmsg( 'expected normalized rms error in meridional wind computation is less than 1.e-06') sendmsg( 'calculated normalized rms error in meridional wind computation =', rms) sendmsg(' ') if rms > 1.e-06: testError = testError + 1 if writeTestcase == 'yes': sendmsg( '******* write data') sendmsg( 'calculated zonal wind on the offset grid written to uoffcal.nc') # write netcdf file writeField(offlonvals, offlatvals, timevals, 'uoffcal', ucal) sendmsg( 'calculated meridional wind on the offset grid wriiten to voffcal.nc') writeField(offlonvals, offlatvals, timevals, 'voffcal', vcal) sendmsg(' ') sendmsg( 'exact zonal wind on the offset grid written to uoffexact.nc') # write netcdf file writeField(offlonvals, offlatvals, timevals, 'uoffexact', uexact) sendmsg( 'exact meritional wind on the offset grid written to voffexact.nc') writeField(offlonvals, offlatvals, timevals, 'voffexact', vexact) sendmsg(' ') sendmsg(' ') return testError def regrid(): #----------------------------------------------------------------------------------- # # purpose: starting with analytically generate winds on an evenly spaced grid, # calculate the winds on a gaussian grid. # # usage: regrid() # # passed : nothing # # returned: nothing # #----------------------------------------------------------------------------------- sendmsg('******************************* vector regridding on a sphere ***********************************') sendmsg(' ') testError = 0 nlone = 36 nlate = 19 lonArrayIn, latArrayIn, timevals, uIn, vIn = regrid_testfunction(nlone, nlate, 'v', 'even') nlong = 128 nlatg = 64 lonArrayOut, latArrayOut, timevals, uOut, vOut = regrid_testfunction(nlong, nlatg, 'v', 'gaussian') nt = len(timevals) x = sphere.Regrid(lonArrayOut, latArrayOut, lonArrayIn, latArrayIn, numberTimes = nt) ucal, vcal = x.regridVector(uIn, vIn) sendmsg('******* compare results') rms = rmserror(uOut, ucal) sendmsg( 'expected normalized rms error in regridded zonal wind is less than 1.e-06') sendmsg( 'calculated normalized rms error in regridded zonal wind =', rms) sendmsg(' ') if rms > 1.e-06: testError = testError + 1 rms = rmserror(vOut, vcal) sendmsg( 'expected normalized rms error in regridded meridonal wind is less than 1.e-06') sendmsg( 'calculted normalized rms error in regridded meridonal wind =', rms) sendmsg(' ') if rms > 1.e-06: testError = testError + 1 if writeTestcase == 'yes': sendmsg('******* write data') sendmsg( 'calculated zonal wind on the new grid written to uregridcal.nc') # write netcdf file writeField(lonArrayOut, latArrayOut, timevals, 'uregridcal', ucal) sendmsg( 'calculated meridional wind on the new grid written to vregridcal.nc') writeField(lonArrayOut, latArrayOut, timevals, 'vregridcal', vcal) sendmsg(' ') sendmsg( 'exact zonal wind on the new grid written to uregridexact.nc') # write netcdf file writeField(lonArrayOut, latArrayOut, timevals, 'uregridexact', uOut) sendmsg( 'exact meridional wind on the new grid written to vregridexact.nc') writeField(lonArrayOut, latArrayOut, timevals, 'vregridexact', vOut) sendmsg(' ') sendmsg( 'original zonal wind on the grid written to uorig.nc') writeField(lonArrayIn, latArrayIn, timevals, 'uorig', uIn) sendmsg( 'original meridional wind on the grid written to vorig.nc') writeField(lonArrayIn, latArrayIn, timevals, 'vorig', vIn) return testError def writeField(lons, lats, tmes, varname, dataField): #----------------------------------------------------------------------------------- # # purpose: write an output field # # usage: # # passed : lons, lats, tmes, filename, varname, dataField # # returned: None # #----------------------------------------------------------------------------------- fileObj = cdms2.createDataset(varname + '.nc') lon_axis = fileObj.createAxis('longitude', lons) lon_axis.units = "degrees_east" lat_axis = fileObj.createAxis('latitude', lats) lat_axis.units = "degrees_north" tme_axis = fileObj.createAxis('time', tmes) tme_axis.units = "months" var = fileObj.createVariable(varname, numpy.float32, (tme_axis, lat_axis, lon_axis)) # variable without data var[:] = dataField # copy in the data fileObj.close() return None def writeasc(name, a): #----------------------------------------------------------------------------------- # # purpose: write the data into an ascii file # # passed : name - filename prefix # a - data # # returned: return # #----------------------------------------------------------------------------------- r = numpy.ravel(a) output = open(name + '.asc', 'w') Format = '%12.4E' count = 0 for item in r: output.write(Format % (item,)) count = count + 1 if count == 8: output.write('\n') count = 0 output.close() return None def sendmsg(msg, value = None, screen = 'no'): #------------------------------------------------------------------------------ # # purpose: send the same message to the screen and to a file # # passed : msg - the string # # returned: return # #------------------------------------------------------------------------------ if value is None: if screen != 'no': print msg output.write(msg + '\n') else: if screen != 'no': print msg, `value` output.write(msg + ' %15.11e\n' % (value,)) return None def remove_offset(cal, test): #----------------------------------------------------------------------------------- # # purpose: shift the array so that the test array has an approximate zero mean to agree # with the calculated one. # # passed : the two data sets # # returned: test # #----------------------------------------------------------------------------------- dif = numpy.ravel(cal) - numpy.ravel(test) # remove offset between the test and calculated arrays offset = numpy.sum(dif)/len(dif) test = test + offset test = test.astype(numpy.float32) return test def rmserror(data1, data2): #----------------------------------------------------------------------------------- # # purpose: compute the rms error for two data sets having the same shape # # passed : the two data sets # # returned: rms error # #----------------------------------------------------------------------------------- if data1.shape != data2.shape: print 'Error in shape in rmserror' raise ValueError d1 = numpy.ravel(data1) d2 = numpy.ravel(data2) sq = d1*d1 # find average magnitude avg = numpy.sqrt( numpy.sum(sq)/len(d1)) sq = (d1 - d2)*(d1 - d2) error = numpy.sum(sq)/len(d1) rmserror = (numpy.sqrt(error))/avg return rmserror def sphere_test(nlon, nlat, sorv = 's', grid_choice = 'even'): #----------------------------------------------------------------------------------- # # purpose: compute the scalar and vector test functions used in testrssph.f # and testtrvsph.f in geophysical coordinates # #----------------------------------------------------------------------------------- if sorv != 's' and sorv != 'v': print 'Must pass s or v to select scalar or vector' raise ValueError return # generate the correct geophysical grid points lonlistrad = [] # longitudes in radians delta = 2.*math.pi/nlon for i in range(nlon): value = i*delta lonlistrad.append(value) lons = numpy.array(lonlistrad, numpy.float64) # in radians for computation lonlist = map( (lambda x: (180./math.pi)*x), lonlistrad) lonvals = numpy.array(lonlist, numpy.float64) # in degrees for return if grid_choice == 'even': latlistrad = [] # latitudes in radians delta = math.pi/(nlat - 1) for i in range(nlat): value = math.pi/2. - i*delta latlistrad.append(value) lats = numpy.array(latlistrad, numpy.float64) # in radians for computation latlist = map( (lambda x: (180./math.pi)*x), latlistrad) latvals = numpy.array(latlist, numpy.float64) # array of latitudes in degrees elif grid_choice == 'gaussian': ldwork = nlat*(nlat + 2) work = numpy.zeros((ldwork,),'d') points, wts, ierror = spherepack.gaqd(nlat, work) # get colatitudes from gaqd if ierror != 0: print 'In return from call to gaqd ierror = ', ierror raise ValueError # convert points to latitudes colatlistrad = list(points) latlistrad = map( (lambda x: math.pi/2. - x), colatlistrad) # convert to latitudes lats = numpy.array(latlistrad, numpy.float64) # in radians for computation latlist = map( (lambda x: (180./math.pi)*x), latlistrad) latvals = numpy.array(latlist, numpy.float64) else: print 'grid_choice must be even or gaussian' raise ValueError return # generate the data on geophysical grid points timevals = numpy.array( [0.0], numpy.float) if sorv == 's': sf = numpy.zeros((1,nlat,nlon), numpy.float) # malloc in c order for i in range(len(lons)): # calculate scalar test function p = lons[i] cosp = math.cos(p) sinp = math.sin(p) for j in range(len(lats)): t = lats[j] cost = math.cos(t) sint = math.sin(t) x = cost*cosp y = cost*sinp z = sint sf[0,j,i] = math.exp(x*y*z) # c order sf = sf.astype(numpy.float32) return lonvals, latvals, timevals, sf else: u = numpy.zeros((1,nlat,nlon), numpy.float) # malloc in c order v = numpy.zeros((1,nlat,nlon), numpy.float) sf = numpy.zeros((1,nlat,nlon), numpy.float) vp = numpy.zeros((1,nlat,nlon), numpy.float) for i in range(len(lons)): # calculate vector test functions p = lons[i] cosp = math.cos(p) sinp = math.sin(p) for j in range(len(lats)): t = lats[j] cost = math.cos(t) sint = math.sin(t) x = cost*cosp y = cost*sinp z = sint ex = math.exp(x) ey = math.exp(y) ez = math.exp(z) emz = math.exp(-z) u[0,j,i] = -ex*sinp + ey*sint*sinp + emz*cost # c order v[0,j,i] = -( ex*sint*cosp - ey*cosp - ez*cost ) sf[0,j,i] = ey + emz vp[0,j,i] = ex + ez u = u.astype(numpy.float32) v = v.astype(numpy.float32) sf = sf.astype(numpy.float32) vp = vp.astype(numpy.float32) return lonvals, latvals, timevals, u, v, sf, vp def regrid_testfunction(nlon, nlat, sorv = 'h', grid_choice = 'even'): #----------------------------------------------------------------------------------- # # purpose: compute the scalar and vector test functions used in testrssph.f # and testtrvsph.f in geophysical coordinates # # usage: # # #----------------------------------------------------------------------------------- if sorv != 's' and sorv != 'v': print 'Must pass s or v to select scalar or vector' raise ValueError return # generate the correct geophysical grid points lonlistrad = [] # longitudes in radians delta = 2.*math.pi/nlon for i in range(nlon): value = i*delta lonlistrad.append(value) lons = numpy.array(lonlistrad, numpy.float64) # in radians for computation lonlist = map( (lambda x: (180./math.pi)*x), lonlistrad) lonvals = numpy.array(lonlist, numpy.float64) # in degrees for return if grid_choice == 'even': latlistrad = [] # latitudes in radians delta = math.pi/(nlat - 1) for i in range(nlat): value = math.pi/2. - i*delta latlistrad.append(value) lats = numpy.array(latlistrad, numpy.float64) # in radians for computation latlist = map( (lambda x: (180./math.pi)*x), latlistrad) latvals = numpy.array(latlist, numpy.float64) # array of latitudes in degrees elif grid_choice == 'gaussian': ldwork = nlat*(nlat + 2) work = numpy.zeros((ldwork,),'d') points, wts, ierror = spherepack.gaqd(nlat, work) # get colatitudes from gaqd if ierror != 0: print 'In return from call to gaqd ierror = ', ierror raise ValueError # convert points to latitudes colatlistrad = list(points) latlistrad = map( (lambda x: math.pi/2. - x), colatlistrad) # convert to latitudes lats = numpy.array(latlistrad, numpy.float64) # in radians for computation latlist = map( (lambda x: (180./math.pi)*x), latlistrad) latvals = numpy.array(latlist, numpy.float64) else: print 'grid_choice must be even or gaussian' raise ValueError return # generate the data on geophysical grid points timevals = numpy.array( [0.0], numpy.float) if sorv == 's': sf = numpy.zeros((1,nlat,nlon), numpy.float) # malloc in c order for i in range(len(lons)): # calculate scalar test function p = lons[i] cosp = math.cos(p) sinp = math.sin(p) for j in range(len(lats)): t = lats[j] cost = math.cos(t) sint = math.sin(t) x = cost*cosp y = cost*sinp z = sint sf[0,j,i] = math.exp(x*y*z) # c order sf = sf.astype(numpy.float32) return lonvals, latvals, timevals, sf else: u = numpy.zeros((1,nlat,nlon), numpy.float) # malloc in c order v = numpy.zeros((1,nlat,nlon), numpy.float) for i in range(len(lons)): # calculate vector test functions p = lons[i] cosp = math.cos(p) sinp = math.sin(p) for j in range(len(lats)): t = lats[j] cost = math.cos(t) sint = math.sin(t) x = cost*cosp y = cost*sinp z = sint ex = math.exp(x) ey = math.exp(y) ez = math.exp(z) emz = math.exp(-z) u[0,j,i] = -ex*sinp + ey*sint*sinp + emz*cost # c order v[0,j,i] = -( ex*sint*cosp - ey*cosp - ez*cost ) u = u.astype(numpy.float32) v = v.astype(numpy.float32) return lonvals, latvals, timevals, u, v def sshift_testfunction(nlon, nlat, grid_type = 'regular'): #----------------------------------------------------------------------------------- # # purpose: compute the scalar test function used in testsshifte.f # in geophysical coordinates # # usage: # # #----------------------------------------------------------------------------------- if grid_type != 'regular' and grid_type != 'offset': print 'Must pass regular or offset to select grid from sshift_testfunction' raise ValueError return # ------- generate the longitude grid points reg_lonlistrad = [] # regular longitudes in radians off_lonlistrad = [] # offset longitudes in radians delta = 2.*math.pi/nlon shiftlon = delta/2. for i in range(nlon): value = i*delta svalue = shiftlon + value reg_lonlistrad.append(value) off_lonlistrad.append(svalue) reglons = numpy.array(reg_lonlistrad, numpy.float64) # for use in computation offlons = numpy.array(off_lonlistrad, numpy.float64) # for use in computation lonlist = map( (lambda x: (180./math.pi)*x), reg_lonlistrad) # degrees for return reglonvals = numpy.array(lonlist, numpy.float64) lonlist = map( (lambda x: (180./math.pi)*x), off_lonlistrad) offlonvals = numpy.array(lonlist, numpy.float64) # generate the data on geophysical grid points timevals = numpy.array( [0.0], numpy.float) if grid_type == 'regular': # -------- generate the regular latitude grid points latlistrad = [] # latitudes in radians delta = math.pi/nlat for j in range(nlat + 1): value = math.pi/2. - j*delta latlistrad.append(value) lats = numpy.array(latlistrad, numpy.float64) # latitudes for computation latlist = map( (lambda x: (180./math.pi)*x), latlistrad) latvals = numpy.array(latlist, numpy.float64) # array of latitudes in degrees sf = numpy.zeros((1,nlat + 1,nlon), numpy.float32) # malloc in c order for i in range(len(reglons)): # calculate scalar test function p = reglons[i] cosp = math.cos(p) sinp = math.sin(p) for j in range(len(lats)): t = lats[j] cost = math.cos(t) sint = math.sin(t) x = cost*cosp y = cost*sinp z = sint sf[0,j,i] = math.exp(x + y + z) # c order sf = sf.astype(numpy.float32) return reglonvals, latvals, timevals, sf else: # -------- generate the offset latitude grid points latlistrad = [] # latitudes in radians delta = math.pi/nlat shiftlat = delta/2. for j in range(nlat): value = math.pi/2. - shiftlat - j*delta latlistrad.append(value) lats = numpy.array(latlistrad, numpy.float64) # latitudes for computation latlist = map( (lambda x: (180./math.pi)*x), latlistrad) latvals = numpy.array(latlist, numpy.float64) # array of latitudes in degrees sf = numpy.zeros((1,nlat,nlon), numpy.float32) # malloc in c order for i in range(len(offlons)): # calculate scalar test function p = offlons[i] cosp = math.cos(p) sinp = math.sin(p) for j in range(len(lats)): t = lats[j] cost = math.cos(t) sint = math.sin(t) x = cost*cosp y = cost*sinp z = sint sf[0,j,i] = math.exp(x + y + z) # c order sf = sf.astype(numpy.float32) return offlonvals, latvals, timevals, sf def vshift_testfunction(nlon, nlat, grid_type = 'regular'): #----------------------------------------------------------------------------------- # # purpose: compute the vector test function used in testvshifte.f # in geophysical coordinates # # usage: # # #----------------------------------------------------------------------------------- if grid_type != 'regular' and grid_type != 'offset': print 'Must pass regular or offset to select grid from vshift_testfunction' raise ValueError return # ------- generate the longitude grid points reg_lonlistrad = [] # regular longitudes in radians off_lonlistrad = [] # offset longitudes in radians delta = 2.*math.pi/nlon shiftlon = delta/2. for i in range(nlon): value = i*delta svalue = shiftlon + value reg_lonlistrad.append(value) off_lonlistrad.append(svalue) reglons = numpy.array(reg_lonlistrad, numpy.float64) # for use in computation offlons = numpy.array(off_lonlistrad, numpy.float64) # for use in computation lonlist = map( (lambda x: (180./math.pi)*x), reg_lonlistrad) # degrees for return reglonvals = numpy.array(lonlist, numpy.float64) lonlist = map( (lambda x: (180./math.pi)*x), off_lonlistrad) offlonvals = numpy.array(lonlist, numpy.float64) # generate the data on geophysical grid points timevals = numpy.array( [0.0], numpy.float) if grid_type == 'regular': # -------- generate the regular latitude grid points latlistrad = [] # latitudes in radians delta = math.pi/nlat for j in range(nlat + 1): value = math.pi/2. - j*delta latlistrad.append(value) lats = numpy.array(latlistrad, numpy.float64) # latitudes for computation latlist = map( (lambda x: (180./math.pi)*x), latlistrad) latvals = numpy.array(latlist, numpy.float64) # array of latitudes in degrees u = numpy.zeros((1,nlat + 1,nlon), numpy.float32) # malloc in c order v = numpy.zeros((1,nlat + 1,nlon), numpy.float32) for i in range(len(reglons)): # calculate scalar test function p = reglons[i] cosp = math.cos(p) sinp = math.sin(p) for j in range(len(lats)): t = lats[j] cost = math.cos(t) sint = math.sin(t) x = cost*cosp y = cost*sinp z = sint ex = math.exp(x) ey = math.exp(y) ez = math.exp(z) emz = math.exp(-z) u[0,j,i] = -ex*sinp + ey*sint*sinp + emz*cost # c order v[0,j,i] = -ex*sint*cosp + ey*cosp + ez*cost u = u.astype(numpy.float32) v = v.astype(numpy.float32) return reglonvals, latvals, timevals, u, v else: # -------- generate the offset latitude grid points latlistrad = [] # latitudes in radians delta = math.pi/nlat shiftlat = delta/2. for j in range(nlat): value = math.pi/2. - shiftlat - j*delta latlistrad.append(value) lats = numpy.array(latlistrad, numpy.float64) # latitudes for computation latlist = map( (lambda x: (180./math.pi)*x), latlistrad) latvals = numpy.array(latlist, numpy.float64) # array of latitudes in degrees u = numpy.zeros((1,nlat,nlon), numpy.float32) # malloc in c order v = numpy.zeros((1,nlat,nlon), numpy.float32) for i in range(len(offlons)): # calculate scalar test function p = offlons[i] cosp = math.cos(p) sinp = math.sin(p) for j in range(len(lats)): t = lats[j] cost = math.cos(t) sint = math.sin(t) x = cost*cosp y = cost*sinp z = sint ex = math.exp(x) ey = math.exp(y) ez = math.exp(z) emz = math.exp(-z) u[0,j,i] = -ex*sinp + ey*sint*sinp + emz*cost # c order v[0,j,i] = -ex*sint*cosp + ey*cosp + ez*cost u = u.astype(numpy.float32) v = v.astype(numpy.float32) return offlonvals, latvals, timevals, u, v if __name__ == "__main__": output = open('test.asc', 'w') # global file name print 'Running the test computations' te1 = sfvp() te2 = shift() te3 = regrid() testError = te1 + te2 + te3 write = document() sendmsg(' ') sendmsg('*********') sendmsg('General information on the use of SPHERPACK has been written to the file spheremodule.doc.') sendmsg('*********') sendmsg(' ') if testError == 0: print 'Testing Completed Successfully' else: print 'Testing Completed But It May Have Problems' print 'Some details on the testing have been written to the file test.asc.' print 'General information on the use of SPHEREPACK has been written to the file spheremodule.doc.' output.close() spherepack-3.2/Src/0000755000175000017500000000000011464224044014415 5ustar alastairalastairspherepack-3.2/Src/vhaec.f0000644000175000017500000010126111464224044015653 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vrtec.f0000644000175000017500000002765711464224044015730 0ustar alastairalastairc 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 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 spherepack-3.2/Src/shigs.f0000644000175000017500000002432111464224044015703 0ustar alastairalastairc 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 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 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 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 spherepack-3.2/Src/sshifte.f0000644000175000017500000003524311464224044016240 0ustar alastairalastairc 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 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 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 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 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 spherepack-3.2/Src/isfvpgc.f0000644000175000017500000003064211464224044016232 0ustar alastairalastairc 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 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 spherepack-3.2/Src/idvtec.f0000644000175000017500000003476211464224044016056 0ustar alastairalastairc 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 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 spherepack-3.2/Src/shaec.f0000644000175000017500000004164211464224044015656 0ustar alastairalastairc 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 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 spherepack-3.2/Src/slapgc.f0000644000175000017500000002723111464224044016042 0ustar alastairalastairc 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 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 spherepack-3.2/Src/gradgs.f0000644000175000017500000002720011464224044016034 0ustar alastairalastairc 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 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 spherepack-3.2/Src/sfvpgc.f0000644000175000017500000003126611464224044016064 0ustar alastairalastairc 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 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 spherepack-3.2/Src/alf.f0000644000175000017500000005613211464224044015335 0ustar alastairalastairc 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 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 + mod(n,2)) 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)*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 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 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 spherepack-3.2/Src/trssph.f0000644000175000017500000006175411464224044016124 0ustar alastairalastairc 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 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 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 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 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 spherepack-3.2/Src/slapes.f0000644000175000017500000002705611464224044016065 0ustar alastairalastairc 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 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 spherepack-3.2/Src/spherepack.pyf0000755000175000017500000156672611464224044017314 0ustar alastairalastairpython module spherepack interface subroutine divec(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb,wshsec,lshsec,work,lwork,ierror) ! ************************************************************************** ! ! given the vector spherical harmonic coefficients br and bi, precomputed ! by subroutine vhaec for a vector field (v,w), subroutine divec ! computes the divergence of the vector field in the scalar array dv. ! dv(i,j) is the divergence at the colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. i.e. ! ! dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ] ! ! where sint = sin(theta(i)). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! br,bi were precomputed. required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine dives. ! ! ************************************************************** ! input parameters ! ! nlat the number of colatitudes on the full sphere including the poles. ! ! nlon the number of distinct longitude points. ! ! ! isym a parameter which determines whether the divergence is ! computed on the full or half sphere as follows: ! ! = 0 ! the divergence is computed on the entire ! sphere. i.e., in the array dv(i,j) for i=1,...,nlat and ! j=1,...,nlon. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the array dv as it appears in ! the program that calls divec. ! ! jdv the second dimension of the array dv as it appears in ! the program that calls divec. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaec. ! br and bi must be computed by vhaec prior to calling ! divec. ! ! mdb the first dimension of the arrays br and bi as it ! appears in the program that calls divec. ! ! ndb the second dimension of the arrays br and bi as it ! appears in the program that calls divec. ! ! wshsec an array which must be initialized by subroutine shseci. ! ! lshsec the dimension of the array wshsec as it appears in the ! program that calls divec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls divec. ! ! ************************************************************** ! ! output parameters ! !dv a two or three dimensional array (see input parameter nt) ! that contains the divergence of the vector field (v,w) ! whose coefficients br,bi where computed by subroutine ! vhaec. ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lshsec integer lwork integer, intent(out)::ierror real, intent(out)::dv(idv, jdv, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real wshsec(lshsec) ! end subroutine dives(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb,wshses,lshses,work,lwork,ierror) ! ************************************************************************** ! ! given the vector spherical harmonic coefficients br and bi, precomputed ! by subroutine vhaes for a vector field (v,w), subroutine dives ! computes the divergence of the vector field in the scalar array dv. ! dv(i,j) is the divergence at the colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. i.e. ! ! dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ] ! ! where sint = sin(theta(i)). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! br,bi were precomputed. required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine dives. ! ! ************************************************************** ! input parameters ! ! nlat the number of colatitudes on the full sphere including the poles. ! ! nlon the number of distinct longitude points. ! ! ! isym a parameter which determines whether the divergence is ! computed on the full or half sphere as follows: ! ! = 0 ! the divergence is computed on the entire ! sphere. i.e., in the array dv(i,j) for i=1,...,nlat and ! j=1,...,nlon. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the array dv as it appears in ! the program that calls dives. ! ! jdv the second dimension of the array dv as it appears in ! the program that calls dives. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaes. ! br and bi must be computed by vhaes prior to calling ! dives. ! ! mdb the first dimension of the arrays br and bi as it ! appears in the program that calls dives. ! ! ndb the second dimension of the arrays br and bi as it ! appears in the program that calls dives. ! ! wshses an array which must be initialized by subroutine shsesi. ! ! lshses the dimension of the array wshses as it appears in the ! program that calls dives. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls dives. ! ! ************************************************************** ! ! output parameters ! ! dv a two or three dimensional array (see input parameter nt) ! that contains the divergence of the vector field (v,w) ! whose coefficients br,bi where computed by subroutine ! vhaes. ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lshses integer lwork integer, intent(out)::ierror real, intent(out)::dv(idv, jdv, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real wshses(lshses) ! end subroutine divgc(nlat,nlon,isym,nt,dv,idv,jdv,br,bi,mdb,ndb,wshsgc,lshsgc,work,lwork,ierror) ! ************************************************************************* ! ! given the vector spherical harmonic coefficients br and bi, precomputed ! by subroutine vhagc for a vector field (v,w), subroutine divgc ! computes the divergence of the vector field in the scalar array dv. ! dv(i,j) is the divergence at the gaussian colatitude point theta(i) ! (see nlat as input parameter) and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. i.e. ! ! dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ] ! ! where sint = sin(theta(i)). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! br,bi were precomputed. required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine divgs. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym a parameter which determines whether the divergence is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the divergence is computed on the entire sphere. ! i.e., in the array dv(i,j) for i=1,...,nlat and j=1,...,nlon. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the array dv as it appears in ! the program that calls divgc. ! ! jdv the second dimension of the array dv as it appears in ! the program that calls divgc. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhagc. ! br and bi must be computed by vhagc prior to calling ! divgc. ! ! mdb the first dimension of the arrays br and bi as it ! appears in the program that calls divgc. ! ! ndb the second dimension of the arrays br and bi as it ! appears in the program that calls divgc. ! ! ! wshsgc an array which must be initialized by subroutine shsgci. ! ! lshsgc the dimension of the array wshsgc as it appears in the ! program that calls divgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls divgc. ! ! ************************************************************** ! ! output parameters ! ! dv a two or three dimensional array (see input parameter nt) ! that contains the divergence of the vector field (v,w) ! whose coefficients br,bi where computed by subroutine ! vhagc. ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lshsgc integer lwork integer, intent(out)::ierror real, intent(out)::dv(idv, jdv, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real wshsgc(lshsgc) ! end subroutine divgs(nlat,nlon,isym,nt,divg,idiv,jdiv,br,bi,mdb,ndb,wshsgs,lshsgs,work,lwork,ierror) ! ************************************************************************* ! ! given the vector spherical harmonic coefficients br and bi, precomputed ! by subroutine vhags for a vector field (v,w), subroutine divgs ! computes the divergence of the vector field in the scalar array divg. ! divg(i,j) is the divergence at the gaussian colatitude point theta(i) ! (see nlat as input parameter) and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. i.e. ! ! dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ] ! ! where sint = sin(theta(i)). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! br,bi were precomputed ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the divergence is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the divergence is computed on the entire. ! i.e., in the array divg(i,j) for i=1,...,nlat and j=1,...,nlon. ! ! nt nt is the number of scalar and vector fields. ! ! idiv the first dimension of the array divg as it appears in ! the program that calls divgs. ! ! jdiv the second dimension of the array divg as it appears in ! the program that calls divgs. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhags. ! br and bi must be computed by vhags prior to calling ! divgs. ! ! mdb the first dimension of the arrays br and bi as it ! appears in the program that calls divgs. ! ! ndb the second dimension of the arrays br and bi as it ! appears in the program that calls divgs. ! ! wshsgs an array which must be intialized by subroutine shsgsi. ! ! lshsgs the dimension of the array wshsgs as it appears in the ! program that calls divgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls divgs. ! ! ************************************************************** ! ! output parameters ! ! divg a two or three dimensional array (see input parameter nt) ! that contains the divergence of the vector field (v,w) ! whose coefficients br,bi where computed by subroutine ! vhags. ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idiv ! = 6 error in the specification of jdiv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idiv integer jdiv integer nt integer mdb integer ndb integer lshsgs integer lwork integer, intent(out)::ierror real, intent(out)::divg(idiv, jdiv, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real wshsgs(lshsgs) ! end subroutine gaqd(nlat,theta,wts,dwork,ldwork,ierror) ! ************************************************************************* ! ! subroutine gaqd computes the nlat gaussian colatitudes and weights ! in doubleprecision. the colatitudes are in radians and lie in the ! in the interval (0,pi). ! ! ************************************************************** ! ! input parameters ! ! nlat the number of gaussian colatitudes in the interval (0,pi) ! ! dwork a temporary work space ! ! ldwork the length of the work space in the routine calling gaqd ! ldwork must be at least nlat*(nlat+2). ! ! ************************************************************** ! ! output parameters ! ! theta a doubleprecision vector of length nlat containing the ! nlat gaussian colatitudes on the sphere in increasing radians ! in the interval (o,pi). ! ! wts a doubleprecision vector of length nlat containing the ! nlat gaussian weights. ! ! ierror = 0 no errors ! = 1 if ldwork.lt.nlat*(nlat+2) ! = 2 if nlat.le.0 ! = 3 if unable to compute gaussian points ! (failure in in eigenvalue routine) ! ************************************************************************* ! integer nlat integer ldwork integer, intent(out)::ierror doubleprecision, intent(out)::theta(nlat) doubleprecision, intent(out)::wts(nlat) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine gradec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsec,lvhsec,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shaec for a scalar field sf, subroutine gradec computes ! an irrotational vector field (v,w) such that ! ! gradient(sf) = (v,w). ! ! v is the colatitudinal and w is the east longitudinal component ! of the gradient. i.e., ! ! v(i,j) = d(sf(i,j))/dtheta ! ! and ! ! w(i,j) = 1/sint*d(sf(i,j))/dlambda ! ! at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon. ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine grades. this ! saves storage (compare wvhsec here and wvhses in grades) but increases ! computational requirements. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shaec to compute the arrays a and b from the ! scalar field sf. isym determines whether (v,w) are ! computed on the full or half sphere as follows: ! ! = 0 ! ! sf is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls gradec. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls gradec. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field array sf as computed by subroutine shaec. ! a,b must be computed by shaec prior to calling gradec. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls gradec (and shaec). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls gradec (and shaec). ! ! wvhsec an array which must be initialized by subroutine vhseci. ! ! lvhsec the dimension of the array wvhsec as it appears in the ! program that calls gradec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls gradec. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain an irrotational vector field such that the gradient of ! the scalar field sf is (v,w). ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhsec integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsec(lvhsec) ! end subroutine grades(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhses,lvhses,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shaes for a scalar field sf, subroutine grades computes ! an irrotational vector field (v,w) such that ! ! gradient(sf) = (v,w). ! ! v is the colatitudinal and w is the east longitudinal component ! of the gradient. i.e., ! ! v(i,j) = d(sf(i,j))/dtheta ! ! and ! ! w(i,j) = 1/sint*d(sf(i,j))/dlambda ! ! at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon. ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine grades. this ! saves storage (compare wvhses here and wvhses in grades) but increases ! computational requirements. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shaes to compute the arrays a and b from the ! scalar field sf. isym determines whether (v,w) are ! computed on the full or half sphere as follows: ! ! = 0 ! ! sf is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls grades. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls grades. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field array sf as computed by subroutine shaes. ! a,b must be computed by shaes prior to calling grades. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls grades (and shaes). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls grades (and shaes). ! ! wvhses an array which must be initialized by subroutine vhsesi. ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls grades. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls grades. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain an irrotational vector field such that the gradient of ! the scalar field sf is (v,w). ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhses integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhses(lvhses) ! end subroutine gradgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsgc,lvhsgc,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shagc for a scalar field sf, subroutine gradgc computes ! an irrotational vector field (v,w) such that ! ! gradient(sf) = (v,w). ! ! v is the colatitudinal and w is the east longitudinal component ! of the gradient. i.e., ! ! v(i,j) = d(sf(i,j))/dtheta ! ! and ! ! w(i,j) = 1/sint*d(sf(i,j))/dlambda ! ! at the gaussian colatitude point theta(i) (see nlat as input ! parameter) and longitude lambda(j) = (j-1)*2*pi/nlon where ! where sint = sin(theta(i)). required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine gradgs. this ! saves storage (compare lsav with lsav in gradgs) but increases ! computational requirements. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shagc to compute the arrays a and b from the ! scalar field sf. ! ! = 0 ! ! sf is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls gradgc. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls gradgc. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field array sf as computed by subroutine shagc. ! a,b must be computed by shagc prior to calling gradgc. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls gradgc (and shagc). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls gradgc (and shagc). ! ! wvhsgc an array which must be initialized by subroutine vhsgci. ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls gradgc. Let ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls gradgc. define ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain an irrotational vector field such that the gradient of ! the scalar field sf is (v,w). ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhsgc integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsgc(lvhsgc) ! end subroutine gradgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsgs,lvhsgs,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shags for a scalar field sf, subroutine gradgs computes ! an irrotational vector field (v,w) such that ! ! gradient(sf) = (v,w). ! ! v is the colatitudinal and w is the east longitudinal component ! of the gradient. i.e., ! ! v(i,j) = d(sf(i,j))/dtheta ! ! and ! ! w(i,j) = 1/sint*d(sf(i,j))/dlambda ! ! at the gaussian colatitude point theta(i) (see nlat as input ! parameter) and longitude lambda(j) = (j-1)*2*pi/nlon where ! where sint = sin(theta(i)). required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine gradgs. this ! saves storage (compare lsav with lsav in gradgs) but increases ! computational requirements. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shags to compute the arrays a and b from the ! scalar field sf. ! ! = 0 ! ! sf is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls gradgs. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls gradgs. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field array sf as computed by subroutine shags. ! a,b must be computed by shags prior to calling gradgs. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls gradgs (and shags). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls gradgs (and shags). ! ! wvhsgs an array which must be initialized by subroutine vhsgsi. ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls gradgs. Let ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls gradgs. define ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain an irrotational vector field such that the gradient of ! the scalar field sf is (v,w). ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhsgs integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsgs(lvhsgs) ! end subroutine hrffti(n,wsave) ! ************************************************************************** ! ! subroutine hrffti initializes the array wsave which is used in ! both hrfftf and hrfftb. the prime factorization of n together ! with a tabulation of the trigonometric functions are computed and ! stored in wsave. ! ! ************************************************************** ! ! input parameter ! ! n the length of the sequence to be transformed. ! ! ! ************************************************************** ! ! output parameter ! ! wsave a work array which must be dimensioned at least 2*n+15. ! the same work array can be used for both hrfftf and ! hrfftb as long as n remains unchanged. different wsave ! arrays are required for different values of n. the ! contents of wsave must not be changed between calls ! of hrfftf or hrfftb. ! ! ************************************************************************* ! integer n real, intent(out)::wsave(2*n + 15) ! end subroutine hrfftf(m,n,r,mdimr,wsave,work) ! ************************************************************************** ! ! subroutine hrfftf computes the fourier coefficients of m real ! perodic sequences (fourier analysis); i.e. hrfftf computes the ! real fft of m sequences each with length n. the transform is ! defined below at output parameter r. ! ! ************************************************************** ! ! input parameters ! ! m the number of sequences. ! ! n the length of all m sequences. the method is most ! efficient when n is a product of small primes. n may ! change as long as different work arrays are provided ! ! r r(m,n) is a two dimensional real array that contains m ! sequences each with length n. ! ! mdimr the first dimension of the r array as it appears ! in the program that calls hrfftf. mdimr must be ! greater than or equal to m. ! ! ! wsave a work array with at least least 2*n+15 locations ! in the program that calls hrfftf. the wsave array must be ! initialized by calling subroutine hrffti(n,wsave) and a ! different wsave array must be used for each different ! value of n. this initialization does not have to be ! repeated so long as n remains unchanged thus subsequent ! transforms can be obtained faster than the first. ! the same wsave array can be used by hrfftf and hrfftb. ! ! work a real work array with m*n locations. ! ! ************************************************************** ! ! output parameters ! ! r for all j=1,...,m ! ! r(j,1) = the sum from i=1 to i=n of r(j,i) ! ! ! wsave contains results which must not be destroyed between ! calls of hrfftf or hrfftb. ! ! work a real work array with m*n locations that does ! not have to be saved. ! ************************************************************************* ! integer n integer m integer mdimr real, intent(out)::wsave(2*n + 15) real, intent(inout)::r(mdimr, n) real, intent(temporary):: work(m*n) ! end subroutine hrfftb(m,n,r,mdimr,wsave,work) ! ************************************************************************** ! ! subroutine hrfftb computes the real perodic sequence of m ! sequences from their fourier coefficients (fourier synthesis). ! the transform is defined below at output parameter r. ! ! ************************************************************** ! ! input parameters ! ! m the number of sequences. ! ! n the length of all m sequences. the method is most ! efficient when n is a product of small primes. n may ! change as long as different work arrays are provided ! ! r r(m,n) is a two dimensional real array that contains ! the fourier coefficients of m sequences each with ! length n. ! ! mdimr the first dimension of the r array as it appears ! in the program that calls hrfftb. mdimr must be ! greater than or equal to m. ! ! wsave a work array which must be dimensioned at least 2*n+15. ! in the program that calls hrfftb. the wsave array must be ! initialized by calling subroutine hrffti(n,wsave) and a ! different wsave array must be used for each different ! value of n. this initialization does not have to be ! repeated so long as n remains unchanged thus subsequent ! transforms can be obtained faster than the first. ! ! work a real work array with m*n locations. ! ! ! ! ************************************************************** ! ! output parameters ! ! r for all j=1,...,m ! ! r(j,1) = the sum from i=1 to i=n of r(j,i) ! ! wsave contains results which must not be destroyed between ! calls of hrfftb or hrfftf. ! ! work a real work array with m*n locations that does not ! have to be saved ! ! ************************************************************************* ! integer n integer m integer mdimr real, intent(out)::wsave(2*n + 15) real, intent(inout)::r(mdimr, n) real, intent(temporary):: work(m*n) ! end subroutine idivec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsec,lvhsec,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shaec for a scalar array dv, subroutine idivec computes ! an irrotational vector field (v,w) whose divergence is dv - pertrb. ! w is the east longitude component and v is the colatitudinal component. ! pertrb is a constant which must be subtracted from dv for (v,w) to ! exist (see the description of pertrb below). usually pertrb is zero ! or small relative to dv. the vorticity of (v,w), as computed by ! vortec, is the zero scalar field. v(i,j) and w(i,j) are the ! velocity components at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon. ! ! the ! divergence[v(i,j),w(i,j)] ! ! = [d(w(i,j)/dlambda + d(sint*v(i,j))/dtheta]/sint ! ! = dv(i,j) - pertrb ! ! and ! ! vorticity(v(i,j),w(i,j)) ! ! = [dv/dlambda - d(sint*w)/dtheta]/sint ! ! = 0.0 ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine idives. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! ! isym this has the same value as the isym that was input to ! subroutine shaec to compute the arrays a and b from the ! scalar field dv. isym determines whether (v,w) are ! computed on the full or half sphere as follows: ! ! = 0 ! ! dv is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt nt is the number of divergence and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls idivec. if isym = 0 then idvw ! must be at least nlat. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls idivec. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the divergence array dv as computed by subroutine shaec. ! a,b must be computed by shaec prior to calling idivec. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls idivec (and shaec). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls idivec (and shaec). ! ! wvhsec an array which must be initialized by subroutine vhseci. ! ! lvhsec the dimension of the array wvhsec as it appears in the ! program that calls idivec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls idivec. ! ! ************************************************************** ! ! output parameters ! v,w two or three dimensional arrays (see input parameter nt) that ! contain an irrotational vector field whose divergence is ! dv-pertrb. ! ! pertrb a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). dv - pertrb is a scalar ! field which can be the divergence of a vector field (v,w). ! pertrb is related to the scalar harmonic coefficients a,b ! of dv (computed by shaec) by the formula ! ! pertrb = a(1,1)/(2.*sqrt(2.)) ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsec ! = 10 error in the specification of lwork ! ************************************************************************** ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhsec integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsec(lvhsec) ! end subroutine idives(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhses,lvhses,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shaes for a scalar array dv, subroutine idives computes ! an irrotational vector field (v,w) whose divergence is dv - pertrb. ! w is the east longitude component and v is the colatitudinal component. ! pertrb is a constant which must be subtracted from dv for (v,w) to ! exist (see the description of pertrb below). usually pertrb is zero ! or small relative to dv. the vorticity of (v,w), as computed by ! vortes, is the zero scalar field. i.e., v(i,j) and w(i,j) are the ! velocity components at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon. ! ! the ! ! divergence[v(i,j),w(i,j)] ! ! = [d(w(i,j)/dlambda + d(sint*v(i,j))/dtheta]/sint ! ! = dv(i,j) - pertrb ! ! and ! ! vorticity(v(i,j),w(i,j)) ! ! = [dv/dlambda - d(sint*w)/dtheta]/sint ! ! = 0.0 ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are stored rather than recomputed as they are in subroutine idivec. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shaes to compute the arrays a and b from the ! scalar field dv. isym determines whether (v,w) are ! computed on the full or half sphere as follows: ! ! = 0 ! dv is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt nt is the number of divergence and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls idives. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls idives. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the divergence array dv as computed by subroutine shaes. ! a,b must be computed by shaes prior to calling idives. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls idives (and shaes). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls idives (and shaes). ! ! wvhses an array which must be initialized by subroutine vhesesi. ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls idives. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls idives. ! ! ************************************************************** ! ! output parameters ! ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain an irrotational vector field whose divergence is ! dv-pertrb. ! ! pertrb a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). dv - pertrb is a scalar ! field which can be the divergence of a vector field (v,w). ! pertrb is related to the scalar harmonic coefficients a,b ! of dv (computed by shaes) by the formula ! ! pertrb = a(1,1)/(2.*sqrt(2.)) ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhses ! = 10 error in the specification of lwork ! ************************************************************************** ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhses integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhses(lvhses) ! end subroutine idivgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsgc,lvhsgc,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shagc for a scalar array dv, subroutine idivgc computes ! an irrotational vector field (v,w) whose divergence is dv - pertrb. ! w is the east longitude component and v is the colatitudinal component. ! pertrb is a constant which must be subtracted from dv for (v,w) to ! exist (see the description of pertrb below). usually pertrb is zero ! or small relative to dv. the vorticity of (v,w) is the zero scalar ! field. v(i,j) and w(i,j) are the velocity components at the gaussian ! colatitude theta(i) (see nlat) and longitude lambda(j)=(j-1)*2*pi/nlon. ! the ! ! divergence[v(i,j),w(i,j)] ! ! = [d(w(i,j)/dlambda + d(sint*v(i,j))/dtheta]/sint ! ! = dv(i,j) - pertrb ! ! and ! ! vorticity(v(i,j),w(i,j)) ! ! = [dv/dlambda - d(sint*w)/dtheta]/sint ! ! = 0.0 ! where sint = sin(theta(i)). ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shagc to compute the arrays a and b from the ! scalar field dv. isym determines whether (v,w) are ! computed on the full or half sphere as follows: ! ! = 0 ! ! dv is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt nt is the number of divergence and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls idivgc. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls idivgc. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the divergence array dv as computed by subroutine shagc. ! a,b must be computed by shagc prior to calling idivgc. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls idivgc (and shagc). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls idivgc (and shagc). ! ! wvhsgc an array which must be initialized by subroutine vhsgci. ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls idivgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls idivgc. ! ! ! ************************************************************** ! ! output parameters ! ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain an irrotational vector field whose divergence is ! dv-pertrb. ! ! pertrb a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). dv - pertrb is a scalar ! field which can be the divergence of a vector field (v,w). ! pertrb is related to the scalar harmonic coefficients a,b ! of dv (computed by shagc) by the formula ! ! pertrb = a(1,1)/(2.*sqrt(2.)) ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgc ! = 10 error in the specification of lwork ! ************************************************************************** ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhsgc integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsgc(lvhsgc) ! end subroutine idivgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsgs,lvhsgs,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shags for a scalar array divg, subroutine idivgs computes ! an irrotational vector field (v,w) whose divergence is divg - pertrb. ! w is the east longitude component and v is the colatitudinal component. ! pertrb is a constant which must be subtracted from divg for (v,w) to ! exist (see the description of pertrb below). usually pertrb is zero ! or small relative to divg. the vorticity of (v,w) is the zero scalar ! field. v(i,j) and w(i,j) are the velocity components at the gaussian ! colatitude theta(i) (see nlat) and longitude lambda(j)=(j-1)*2*pi/nlon. ! the ! ! divergence[v(i,j),w(i,j)] ! ! = [d(w(i,j)/dlambda + d(sint*v(i,j))/dtheta]/sint ! ! = divg(i,j) - pertrb ! ! and ! ! vorticity(v(i,j),w(i,j)) ! ! = [dv/dlambda - d(sint*w)/dtheta]/sint ! ! = 0.0 ! ! where sint = sin(theta(i)). ! ! ************************************************************** ! ! input parameters ! ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. nlon determines ! the grid increment in longitude as 2*pi/nlon. for example ! nlon = 72 for a five degree grid. nlon must be greater than ! 3. the efficiency of the computation is improved when nlon ! is a product of small prime numbers. ! ! ! isym this has the same value as the isym that was input to ! subroutine shags to compute the arrays a and b from the ! scalar field divg. isym determines whether (v,w) are ! computed on the full or half sphere as follows: ! ! = 0 ! ! divg is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt nt is the number of divergence and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls idivgs. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls idivgs. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the divergence array divg as computed by subroutine shags. ! a,b must be computed by shags prior to calling idivgs. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls idivgs (and shags). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls idivgs (and shags). ! ! ! wvhsgs an array which must be initialized by subroutine vhsgsi. ! once initialized, ! wvhsgs can be used repeatedly by idivgs as long as nlon ! and nlat remain unchanged. wvhsgs must not be altered ! between calls of idivgs. ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls idivgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls idivgs. define ! ! ************************************************************** ! ! output parameters ! ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain an irrotational vector field whose divergence is ! divg-pertrb. ! ! pertrb a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). divg - pertrb is a scalar ! field which can be the divergence of a vector field (v,w). ! pertrb is related to the scalar harmonic coefficients a,b ! of divg (computed by shags) by the formula ! ! pertrb = a(1,1)/(2.*sqrt(2.)) ! ! the unperturbed scalar field divg can be the divergence of a ! vector field only if a(1,1) is zero. ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhsgs integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsgs(lvhsgs) ! end ! subroutine idvtec(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv,mdab,ndab,wvhsec,lvhsec,work,lwork,pertbd,pertbv,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients ad,bd precomputed ! by subroutine shaec for the scalar field divg and coefficients av,bv ! precomputed by subroutine shaec for the scalar field vort, subroutine ! idvtec computes a vector field (v,w) whose divergence is divg - pertbd ! and whose vorticity is vort - pertbv. w the is east longitude component ! and v is the colatitudinal component of the velocity. if nt=1 (see nt ! below) pertrbd and pertbv are constants which must be subtracted from ! divg and vort for (v,w) to exist (see the description of pertbd and ! pertrbv below). usually pertbd and pertbv are zero or small relative ! to divg and vort. w(i,j) and v(i,j) are the velocity components at ! colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! the ! ! divergence(v(i,j),w(i,j)) ! ! = [d(sint*v)/dtheta + dw/dlambda]/sint ! ! ! = divg(i,j) - pertbd ! ! and ! ! vorticity(v(i,j),w(i,j)) ! ! = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! = vort(i,j) - pertbv ! ! where ! ! sint = cos(theta(i)). ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ! isym isym determines whether (v,w) are computed on the full or half ! sphere as follows: ! ! = 0 ! In this case, the vector field (v,w) is computed on the entire ! sphere. ! ! nt in the program that calls idvtec, nt is the number of scalar ! and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls idvtec. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls idvtec. ! ! ad,bd two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the divergence array divg as computed by subroutine shaec. ! ! av,bv two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the vorticity array vort as computed by subroutine shaec. ! ad,bd,av,bv must be computed by shaec prior to calling idvtec. ! ! mdab the first dimension of the arrays ad,bd,av,bv as it appears ! in the program that calls idvtec (and shaec). ! ! ndab the second dimension of the arrays ad,bd,av,bv as it appears in ! the program that calls idvtec (and shaec). ! ! wvhse an array which must be initialized by subroutine vhseci. ! ! lvhse the dimension of the array wvhsec as it appears in the ! program that calls idvtec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls idvtec. ! ! ************************************************************** ! ! output parameters ! ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a vector field whose divergence is divg - pertbd and ! whose vorticity is vort - pertbv. ! ! pertbd a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). divg - pertbd is a scalar ! field which can be the divergence of a vector field (v,w). ! pertbd is related to the scalar harmonic coefficients ad,bd ! of divg (computed by shaec) by the formula ! ! pertbd = ad(1,1)/(2.*sqrt(2.)) ! ! an unperturbed divg can be the divergence of a vector field ! only if ad(1,1) is zero. ! ! pertbv a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). vort - pertbv is a scalar ! field which can be the vorticity of a vector field (v,w). ! pertbv is related to the scalar harmonic coefficients av,bv ! of vort (computed by shaec) by the formula ! ! pertbv = av(1,1)/(2.*sqrt(2.)) ! ! an unperturbed vort can be the vorticity of a vector field ! only if av(1,1) is zero. ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhsec integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertbd(nt) real, intent(out)::pertbv(nt) real, intent(temporary):: work(lwork) real ad(mdab, ndab, nt) real bd(mdab, ndab, nt) real av(mdab, ndab, nt) real bv(mdab, ndab, nt) real wvhsec(lvhsec) ! end subroutine idvtes(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv,mdab,ndab,wvhses,lvhses,work,lwork,pertbd,pertbv,ierror) ! ************************************************************************** ! ! ! given the scalar spherical harmonic coefficients ad,bd precomputed ! by subroutine shaes for the scalar field divg and coefficients av,bv ! precomputed by subroutine shaes for the scalar field vort, subroutine ! idvtes computes a vector field (v,w) whose divergence is divg - pertbd ! and whose vorticity is vort - pertbv. w the is east longitude component ! and v is the colatitudinal component of the velocity. if nt=1 (see nt ! below) pertrbd and pertbv are constants which must be subtracted from ! divg and vort for (v,w) to exist (see the description of pertbd and ! pertrbv below). usually pertbd and pertbv are zero or small relative ! to divg and vort. w(i,j) and v(i,j) are the velocity components at ! colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! the ! ! divergence(v(i,j),w(i,j)) ! ! = [d(sint*v)/dtheta + dw/dlambda]/sint ! ! = divg(i,j) - pertbd ! ! and ! ! vorticity(v(i,j),w(i,j)) ! ! = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! = vort(i,j) - pertbv ! ! where ! ! sint = cos(theta(i)). ! ! ************************************************************** ! ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! isym isym determines whether (v,w) are computed on the full or half ! sphere as follows: ! ! = 0 ! In this case, the vector field (v,w) is computed on the entire ! sphere. ! ! nt in the program that calls idvtes, nt is the number of scalar ! and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls idvtes. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls idvtes. ! ! ad,bd two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the divergence array divg as computed by subroutine shaes. ! ! av,bv two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the vorticity array vort as computed by subroutine shaes. ! ad,bd,av,bv must be computed by shaes prior to calling idvtes. ! ! mdab the first dimension of the arrays ad,bd,av,bv as it appears ! in the program that calls idvtes (and shaes). ! ! ndab the second dimension of the arrays ad,bd,av,bv as it appears in ! the program that calls idvtes (and shaes). ! ! wvhses an array which must be initialized by subroutine vhsesi. ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls idvtes. define ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls idvtes. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a vector field whose divergence is divg - pertbd and ! whose vorticity is vort - pertbv. ! ! pertbd a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). divg - pertbd is a scalar ! field which can be the divergence of a vector field (v,w). ! pertbd is related to the scalar harmonic coefficients ad,bd ! of divg (computed by shaes) by the formula ! ! pertbd = ad(1,1)/(2.*sqrt(2.)) ! ! an unperturbed divg can be the divergence of a vector field ! only if ad(1,1) is zero. ! ! pertbv a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). vort - pertbv is a scalar ! field which can be the vorticity of a vector field (v,w). ! pertbv is related to the scalar harmonic coefficients av,bv ! of vort (computed by shaes) by the formula ! ! pertbv = av(1,1)/(2.*sqrt(2.)) ! ! an unperturbed vort can be the vorticity of a vector field ! only if av(1,1) is zero. ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhses integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertbd(nt) real, intent(out)::pertbv(nt) real, intent(temporary):: work(lwork) real ad(mdab, ndab, nt) real bd(mdab, ndab, nt) real av(mdab, ndab, nt) real bv(mdab, ndab, nt) real wvhses(lvhses) ! end subroutine idvtgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv,mdab,ndab,wvhsgc,lvhsgc,work,lwork,pertbd,pertbv,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients ad,bd precomputed ! by subroutine shagc for the scalar field divg and coefficients av,bv ! precomputed by subroutine shagc for the scalar field vort, subroutine ! idvtgc computes a vector field (v,w) whose divergence is divg - pertbd ! and whose vorticity is vort - pertbv. w the is east longitude component ! and v is the colatitudinal component of the velocity. if nt=1 (see nt ! below) pertrbd and pertbv are constants which must be subtracted from ! divg and vort for (v,w) to exist (see the description of pertbd and ! pertrbv below). usually pertbd and pertbv are zero or small relative ! to divg and vort. w(i,j) and v(i,j) are the velocity components at ! gaussian colatitude theta(i) (see nlat as input argument) and longitude ! lambda(j) = (j-1)*2*pi/nlon ! ! the ! ! divergence(v(i,j),w(i,j)) ! ! = [d(sint*v)/dtheta + dw/dlambda]/sint ! ! = divg(i,j) - pertbd ! ! and ! ! vorticity(v(i,j),w(i,j)) ! ! = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! = vort(i,j) - pertbv ! ! where ! ! sint = cos(theta(i)). ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym isym determines whether (v,w) are computed on the full or half ! sphere as follows: ! ! = 0 ! In this case, the vector field (v,w) is computed on the entire ! sphere. ! ! nt in the program that calls idvtgc, nt is the number of scalar ! and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls idvtgc. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls idvtgc. ! ! ad,bd two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the divergence array divg as computed by subroutine shagc. ! ! av,bv two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the vorticity array vort as computed by subroutine shagc. ! ad,bd,av,bv must be computed by shagc prior to calling idvtgc. ! ! mdab the first dimension of the arrays ad,bd,av,bv as it appears ! in the program that calls idvtgc (and shagc). ! ! ndab the second dimension of the arrays ad,bd,av,bv as it appears in ! the program that calls idvtgc (and shagc). ! ! wvhsgc an array which must be initialized by subroutine vhsgci. ! ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls idvtgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls idvtgc. ! ! ************************************************************** ! ! output parameters ! ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a vector field whose divergence is divg - pertbd and ! whose vorticity is vort - pertbv. ! ! pertbd a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). divg - pertbd is a scalar ! field which can be the divergence of a vector field (v,w). ! ! pertbv a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). vort - pertbv is a scalar ! field which can be the vorticity of a vector field (v,w). ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhsgc integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertbd(nt) real, intent(out)::pertbv(nt) real, intent(temporary):: work(lwork) real ad(mdab, ndab, nt) real bd(mdab, ndab, nt) real av(mdab, ndab, nt) real bv(mdab, ndab, nt) real wvhsgc(lvhsgc) ! end subroutine idvtgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv,mdab,ndab,wvhsgs,lvhsgs,work,lwork,pertbd,pertbv,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients ad,bd precomputed ! by subroutine shaes for the scalar field divg and coefficients av,bv ! precomputed by subroutine shaes for the scalar field vort, subroutine ! idvtgs computes a vector field (v,w) whose divergence is divg - pertbd ! and whose vorticity is vort - pertbv. w the is east longitude component ! and v is the colatitudinal component of the velocity. if nt=1 (see nt ! below) pertrbd and pertbv are constants which must be subtracted from ! divg and vort for (v,w) to exist (see the description of pertbd and ! pertrbv below). usually pertbd and pertbv are zero or small relative ! to divg and vort. w(i,j) and v(i,j) are the velocity components at ! gaussian colatitude theta(i) (see nlat as input argument) and longitude ! lambda(j) = (j-1)*2*pi/nlon ! ! the ! ! divergence(v(i,j),w(i,j)) ! ! = [d(sint*v)/dtheta + dw/dlambda]/sint ! ! = divg(i,j) - pertbd ! ! and ! ! vorticity(v(i,j),w(i,j)) ! ! = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! = vort(i,j) - pertbv ! ! where ! ! sint = cos(theta(i)). ! ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym isym determines whether (v,w) are computed on the full or half ! sphere as follows: ! ! = 0 ! divg,vort are neither pairwise symmetric/antisymmetric nor ! antisymmetric/symmetric about the equator as described for ! In this case, the vector field (v,w) is computed on the entire ! sphere. ! ! nt in the program that calls idvtgs, nt is the number of scalar ! and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls idvtgs. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls idvtgs. jdvw must be at least nlon. ! ! ad,bd two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the divergence array divg as computed by subroutine shaes. ! ! av,bv two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the vorticity array vort as computed by subroutine shaes. ! ad,bd,av,bv must be computed by shaes prior to calling idvtgs. ! ! mdab the first dimension of the arrays ad,bd,av,bv as it appears ! in the program that calls idvtgs (and shags). ! ! ndab the second dimension of the arrays ad,bd,av,bv as it appears in ! the program that calls idvtgs (and shags). ! ! wvhsgs an array which must be initialized by subroutine vhsgsi. ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls idvtgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls idvtgs. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a vector field whose divergence is divg - pertbd and ! whose vorticity is vort - pertbv. ! pertbd a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). divg - pertbd is a scalar ! field which can be the divergence of a vector field (v,w). ! pertbv a nt dimensional array (see input parameter nt and assume nt=1 ! for the description that follows). vort - pertbv is a scalar ! field which can be the vorticity of a vector field (v,w). ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhsgs integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertbd(nt) real, intent(out)::pertbv(nt) real, intent(temporary):: work(lwork) real ad(mdab, ndab, nt) real bd(mdab, ndab, nt) real av(mdab, ndab, nt) real bv(mdab, ndab, nt) real wvhsgs(lvhsgs) ! end subroutine igradec(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,wshsec,lshsec,work,lwork,ierror) ! ************************************************************************** ! ! let br,bi,cr,ci be the vector spherical harmonic coefficients ! precomputed by vhaec for a vector field (v,w). let (v',w') be ! the irrotational component of (v,w) (i.e., (v',w') is generated ! by assuming cr,ci are zero and synthesizing br,bi with vhsec). ! then subroutine igradec computes a scalar field sf such that ! ! gradient(sf) = (v',w'). ! ! i.e., ! ! v'(i,j) = d(sf(i,j))/dtheta (colatitudinal component of ! the gradient) ! and ! ! w'(i,j) = 1/sint*d(sf(i,j))/dlambda (east longitudinal component ! of the gradient) ! ! at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine igrades. this ! saves storage (compare lshsec and lshses in igrades) but increases ! computational requirements. ! ! note: for an irrotational vector field (v,w), subroutine igradec ! computes a scalar field whose gradient is (v,w). in ay case, ! subroutine igradec inverts the gradient subroutine gradec. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! isym a parameter which determines whether the scalar field sf is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. in this case sf ! is neither symmetric nor antisymmetric about the equator. ! sf is computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! isf the first dimension of the array sf as it appears in ! the program that calls igradec. ! ! jsf the second dimension of the array sf as it appears in ! the program that calls igradec. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaec. ! br,bi must be computed by vhaec prior to calling igradec. ! ! mdb the first dimension of the arrays br and bi as it appears in ! the program that calls igradec (and vhaec). ! ! ndb the second dimension of the arrays br and bi as it appears in ! the program that calls igradec (and vhaec). ! ! wshsec an array which must be initialized by subroutine shseci. ! ! lshsec the dimension of the array wshsec as it appears in the ! program that calls igradec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls igradec. ! ! ************************************************************** ! ! output parameters ! ! sf a two or three dimensional array (see input parameter nt) that ! contain a scalar field whose gradient is the irrotational ! component of the vector field (v,w). ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of isf ! = 6 error in the specification of jsf ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer isf integer jsf integer nt integer mdb integer ndb integer lshsec integer lwork integer, intent(out)::ierror real, intent(out)::sf(isf, jsf, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real wshsec(lshsec) ! end subroutine igrades(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,wshses,lshses,work,lwork,ierror) ! ************************************************************************** ! ! let br,bi,cr,ci be the vector spherical harmonic coefficients ! precomputed by vhaes for a vector field (v,w). let (v',w') be ! the irrotational component of (v,w) (i.e., (v',w') is generated ! by assuming cr,ci are zero and synthesizing br,bi with vhses). ! then subroutine igrades computes a scalar field sf such that ! ! gradient(sf) = (v',w'). ! ! i.e., ! ! v'(i,j) = d(sf(i,j))/dtheta (colatitudinal component of ! the gradient) ! and ! ! w'(i,j) = 1/sint*d(sf(i,j))/dlambda (east longitudinal component ! of the gradient) ! ! at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! where sint = sin(theta(i)). required associated legendre polynomials ! are stored rather than recomputed as they are in subroutine igradec. ! note: for an irrotational vector field (v,w), subroutine igrades ! computes a scalar field whose gradient is (v,w). in ay case, ! subroutine igrades inverts the gradient subroutine grades. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! nlon the number of distinct londitude points. ! ! isym a parameter which determines whether the scalar field sf is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. ! ! nt nt is the number of scalar and vector fields. ! ! isf the first dimension of the array sf as it appears in ! the program that calls igrades. ! ! jsf the second dimension of the array sf as it appears in ! the program that calls igrades. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaes. ! ! mdb the first dimension of the arrays br and bi as it appears in ! the program that calls igrades (and vhaes). ! ! ndb the second dimension of the arrays br and bi as it appears in ! the program that calls igrades (and vhaes). ! ! wshses an array which must be initialized by subroutine igradesi ! (or equivalently by subroutine shsesi). ! ! lshses the dimension of the array wshses as it appears in the ! program that calls igrades. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls igrades. ! ! ************************************************************** ! ! output parameters ! ! sf a two or three dimensional array (see input parameter nt) that ! contain a scalar field whose gradient is the irrotational ! component of the vector field (v,w). ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of isf ! = 6 error in the specification of jsf ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer isf integer jsf integer nt integer mdb integer ndb integer lshses integer lwork integer, intent(out)::ierror real, intent(out)::sf(isf, jsf, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real wshses(lshses) ! end subroutine igradgc(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,wshsgc,lshsgc,work,lwork,ierror) ! ************************************************************************** ! ! let br,bi,cr,ci be the vector spherical harmonic coefficients ! precomputed by vhagc for a vector field (v,w). let (v',w') be ! the irrotational component of (v,w) (i.e., (v',w') is generated ! by assuming cr,ci are zero and synthesizing br,bi with vhsgs). ! then subroutine igradgc computes a scalar field sf such that ! ! gradient(sf) = (v',w'). ! ! i.e., ! ! v'(i,j) = d(sf(i,j))/dtheta (colatitudinal component of ! the gradient) ! and ! ! w'(i,j) = 1/sint*d(sf(i,j))/dlambda (east longitudinal component ! of the gradient) ! ! at the gaussian colatitude theta(i) (see nlat as input parameter) ! and longitude lambda(j) = (j-1)*2*pi/nlon where sint = sin(theta(i)). ! ! note: for an irrotational vector field (v,w), subroutine igradgc ! computes a scalar field whose gradient is (v,w). in ay case, ! subroutine igradgc inverts the gradient subroutine gradgc. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the scalar field sf is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. in this case sf ! is neither symmetric nor antisymmetric about the equator. ! sf is computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! isf the first dimension of the array sf as it appears in ! the program that calls igradgc. ! ! jsf the second dimension of the array sf as it appears in ! the program that calls igradgc. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhagc. ! br,bi must be computed by vhagc prior to calling igradgc. ! ! mdb the first dimension of the arrays br and bi as it appears in ! the program that calls igradgc (and vhagc). ! ! ndb the second dimension of the arrays br and bi as it appears in ! the program that calls igradgc (and vhagc). ! ! wshsgc an array which must be initialized by subroutine shsgci. ! ! lshsgc the dimension of the array wshsgc as it appears in the ! program that calls igradgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls igradgc ! ! ************************************************************** ! ! output parameters ! ! ! sf a two or three dimensional array (see input parameter nt) that ! contain a scalar field whose gradient is the irrotational ! component of the vector field (v,w). ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of isf ! = 6 error in the specification of jsf ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer isf integer jsf integer nt integer mdb integer ndb integer lshsgc integer lwork integer, intent(out)::ierror real, intent(out)::sf(isf, jsf, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real wshsgc(lshsgc) ! end subroutine igradgs(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,wshsgs,lshsgs,work,lwork,ierror) ! ************************************************************************** ! ! let br,bi,cr,ci be the vector spherical harmonic coefficients ! precomputed by vhags for a vector field (v,w). let (v',w') be ! the irrotational component of (v,w) (i.e., (v',w') is generated ! by assuming cr,ci are zero and synthesizing br,bi with vhsgs). ! then subroutine igradgs computes a scalar field sf such that ! ! gradient(sf) = (v',w'). ! ! i.e., ! ! v'(i,j) = d(sf(i,j))/dtheta (colatitudinal component of ! the gradient) ! and ! ! w'(i,j) = 1/sint*d(sf(i,j))/dlambda (east longitudinal component ! of the gradient) ! ! at the gaussian colatitude theta(i) (see nlat as input parameter) ! and longitude lambda(j) = (j-1)*2*pi/nlon where sint = sin(theta(i)). ! ! note: for an irrotational vector field (v,w), subroutine igradgs ! computes a scalar field whose gradient is (v,w). in ay case, ! subroutine igradgs inverts the gradient subroutine gradgs. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the scalar field sf is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. in this case sf ! is neither symmetric nor antisymmetric about the equator. ! sf is computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! isf the first dimension of the array sf as it appears in ! the program that calls igradgs. ! ! jsf the second dimension of the array sf as it appears in ! the program that calls igradgs. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhags. ! br,bi must be computed by vhags prior to calling igradgs. ! ! mdb the first dimension of the arrays br and bi as it appears in ! the program that calls igradgs (and vhags). ! ! ndb the second dimension of the arrays br and bi as it appears in ! the program that calls igradgs (and vhags). ! ! wshsgs an array which must be initialized by subroutine igradgsi ! (or equivalently by subroutine shsesi). ! ! lshsgs the dimension of the array wshsgs as it appears in the ! program that calls igradgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls igradgs. ! ! ************************************************************** ! ! output parameters ! ! sf a two or three dimensional array (see input parameter nt) that ! contain a scalar field whose gradient is the irrotational ! component of the vector field (v,w). ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of isf ! = 6 error in the specification of jsf ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer isf integer jsf integer nt integer mdb integer ndb integer lshsgs integer lwork integer, intent(out)::ierror real, intent(out)::sf(isf, jsf, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real wshsgs(lshsgs) ! end subroutine isfvpec(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb,ndb,wvhsec,lvhsec,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients as,bs precomputed ! by shaec for the scalar stream function sf and av,bv precomputed by ! shaec for the scalar velocity potenital vp, subroutine isfvpec computes ! the vector field (v,w) corresponding to sf and vp. w is the east ! longitudinal and v is the colatitudinal component of the vector field. ! (v,w) is expressed in terms of sf,vp by the helmholtz relations (in ! mathematical spherical coordinates): ! ! v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta ! ! w = 1/sin(theta)*d(st)/dlambda + d(vp)/dtheta ! ! required legendre functions are recomputed rather than stored as ! they are in subroutine isfvpes. v(i,j) and w(i,j) are given at ! colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere (pi=4.0*atan(1.0)). ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlat the number of colatitudes on the full sphere including the ! nlon the number of distinct londitude points. ! ! isym a parameter which determines whether the vector field is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in sf,vp about the equator. in this case v ! and w are not necessarily symmetric or antisymmetric about ! equator. v and w are computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the arrays v,w as it appears in ! the program that calls isfvpec. ! ! jdv the second dimension of the arrays v,w as it appears in ! the program that calls isfvpec. ! ! as,bs two or three dimensional arrays (see input parameter nt) ! that contain the spherical harmonic coefficients of ! the scalar field sf as computed by subroutine shaec. ! ! av,bv two or three dimensional arrays (see input parameter nt) ! that contain the spherical harmonic coefficients of ! the scalar field vp as computed by subroutine shaec. ! ! mdb the first dimension of the arrays as,bs,av,bv as it ! appears in the program that calls isfvpec. ! ! ndb the second dimension of the arrays as,bs,av,bv as it ! appears in the program that calls isfvpec. ! ! wvhsec an array which must be initialized by subroutine vhseci. ! ! lvhsec the dimension of the array wvhsec as it appears in the ! program that calls isfvpec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls isfvpec. ! ! ************************************************************** ! ! output parameters ! !v,w two or three dimensional arrays (see input parameter nt) ! that contains the vector field corresponding to the stream ! function sf and velocity potential vp whose coefficients, ! as,bs (for sf) and av,bv (for vp), were precomputed by ! subroutine shaec. ! colatitude point ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lvhsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lvhsec integer lwork integer, intent(out)::ierror real, intent(out)::v(idv, jdv, nt) real, intent(out)::w(idv, jdv, nt) real, intent(temporary):: work(lwork) real as(mdb, ndb, nt) real bs(mdb, ndb, nt) real av(mdb, ndb, nt) real bv(mdb, ndb, nt) real wvhsec(lvhsec) ! end subroutine isfvpes(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb,ndb,wvhses,lvhses,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients as,bs precomputed ! by shaes for the scalar stream function sf and av,bv precomputed by ! shaes for the scalar velocity potenital vp, subroutine isfvpes computes ! the vector field (v,w) corresponding to sf and vp. w is the east ! longitudinal and v is the colatitudinal component of the vector field. ! (v,w) is expressed in terms of sf,vp by the helmholtz relations (in ! mathematical spherical coordinates): ! ! v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta ! ! w = 1/sin(theta)*d(st)/dlambda + d(vp)/dtheta ! ! required legendre functions are stored rather than recomputed as ! they are in subroutine isfvpes. v(i,j) and w(i,j) are given at ! colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere (pi=4.0*atan(1.0)). ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the vector field is ! computed on the full or half sphere as follows: ! ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in sf,vp about the equator. v and w are ! computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the arrays v,w as it appears in ! the program that calls isfvpes. ! ! jdv the second dimension of the arrays v,w as it appears in ! the program that calls isfvpes. jdv must be at least nlon. ! ! as,bs two or three dimensional arrays (see input parameter nt) ! that contain the spherical harmonic coefficients of ! the scalar field sf as computed by subroutine shaes. ! ! av,bv two or three dimensional arrays (see input parameter nt) ! that contain the spherical harmonic coefficients of ! the scalar field vp as computed by subroutine shaes. ! ! mdb the first dimension of the arrays as,bs,av,bv as it ! appears in the program that calls isfvpes. ! ! ndb the second dimension of the arrays as,bs,av,bv as it ! appears in the program that calls isfvpes. ! ! wvhses an array which must be initialized by subroutine vhsesi. ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls isfvpes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls isfvpes. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) ! that contains the vector field corresponding to the stream ! function sf and velocity potential vp whose coefficients, ! as,bs (for sf) and av,bv (for vp), were precomputed by ! subroutine shaes. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lvhses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lvhses integer lwork integer, intent(out)::ierror real, intent(out)::v(idv, jdv, nt) real, intent(out)::w(idv, jdv, nt) real, intent(temporary):: work(lwork) real as(mdb, ndb, nt) real bs(mdb, ndb, nt) real av(mdb, ndb, nt) real bv(mdb, ndb, nt) real wvhses(lvhses) ! end subroutine isfvpgc(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb,ndb,wvhsgc,lvhsgc,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients as,bs precomputed ! by shagc for the scalar stream function sf and av,bv precomputed by ! shagc for the scalar velocity potenital vp, subroutine isfvpgc computes ! the vector field (v,w) corresponding to sf and vp. w is the east ! longitudinal and v is the colatitudinal component of the vector field. ! (v,w) is expressed in terms of sf,vp by the helmholtz relations (in ! mathematical spherical coordinates): ! ! v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta ! ! w = 1/sin(theta)*d(st)/dlambda + d(vp)/dtheta ! ! required legendre functions are recomputed rather than stored as ! they are in subroutine isfvpgs. v(i,j) and w(i,j) are given at ! the i(th) gaussian colatitude point (see gaqd) theta(i) and east ! longitude lambda(j) = (j-1)*2.*pi/nlon on the sphere. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the vector field is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in sf,vp about the equator. in this case v ! and w are not necessarily symmetric or antisymmetric about ! equator. v and w are computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the arrays v,w as it appears in ! the program that calls isfvpgc. ! ! jdv the second dimension of the arrays v,w as it appears in ! the program that calls isfvpgc. ! ! as,bs two or three dimensional arrays (see input parameter nt) ! that contain the spherical harmonic coefficients of ! the scalar field sf as computed by subroutine shagc. ! ! av,bv two or three dimensional arrays (see input parameter nt) ! that contain the spherical harmonic coefficients of ! the scalar field vp as computed by subroutine shagc. ! ! mdb the first dimension of the arrays as,bs,av,bv as it ! appears in the program that calls isfvpgc. ! ! ndb the second dimension of the arrays as,bs,av,bv as it ! appears in the program that calls isfvpgc. ! ! wvhsgc an array which must be initialized by subroutine vhsgci. ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls isfvpgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! ! program that calls isfvpgc. ! ! ************************************************************** ! ! output parameters ! ! ! !v,w two or three dimensional arrays (see input parameter nt) ! that contains the vector field corresponding to the stream ! function sf and velocity potential vp whose coefficients, ! as,bs (for sf) and av,bv (for vp), were precomputed by ! subroutine shagc. ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lvhsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lvhsgc integer lwork integer, intent(out)::ierror real, intent(out)::v(idv, jdv, nt) real, intent(out)::w(idv, jdv, nt) real, intent(temporary):: work(lwork) real as(mdb, ndb, nt) real bs(mdb, ndb, nt) real av(mdb, ndb, nt) real bv(mdb, ndb, nt) real wvhsgc(lvhsgc) ! end subroutine isfvpgs(nlat,nlon,isym,nt,v,w,idv,jdv,as,bs,av,bv,mdb,ndb,wvhsgs,lvhsgs,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients as,bs precomputed ! by shags for the scalar stream function sf and av,bv precomputed by ! shags for the scalar velocity potenital vp, subroutine isfvpgs computes ! the vector field (v,w) corresponding to sf and vp. w is the east ! longitudinal and v is the colatitudinal component of the vector field. ! (v,w) is expressed in terms of sf,vp by the helmholtz relations (in ! mathematical spherical coordinates): ! ! v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta ! ! w = 1/sin(theta)*d(st)/dlambda + d(vp)/dtheta ! ! required legendre functions are stored rather than recomputed as ! they are in subroutine isfvpgc. v(i,j) and w(i,j) are given at ! the i(th) gaussian colatitude point (see gaqd) theta(i) and east ! longitude lambda(j) = (j-1)*2.*pi/nlon on the sphere. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym a parameter which determines whether the vector field is ! computed on the full or half sphere as follows: ! ! = 0 ! ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in sf,vp about the equator. in this case v ! and w are not necessarily symmetric or antisymmetric about ! equator. v and w are computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the arrays v,w as it appears in ! the program that calls isfvpgs. ! ! jdv the second dimension of the arrays v,w as it appears in ! the program that calls isfvpgs. ! ! as,bs two or three dimensional arrays (see input parameter nt) ! that contain the spherical harmonic coefficients of ! the scalar field sf as computed by subroutine shags. ! ! av,bv two or three dimensional arrays (see input parameter nt) ! that contain the spherical harmonic coefficients of ! the scalar field vp as computed by subroutine shags. ! ! mdb the first dimension of the arrays as,bs,av,bv as it ! appears in the program that calls isfvpgs. ! ! ndb the second dimension of the arrays as,bs,av,bv as it ! appears in the program that calls isfvpgs. ! ! wvhsgs an array which must be initialized by subroutine vhsgsi. ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls isfvpgs. ! ! lwork the dimension of the array work as it appears in the ! program that calls isfvpgs. ! ! ************************************************************** ! ! output parameters ! !v,w two or three dimensional arrays (see input parameter nt) ! that contains the vector field corresponding to the stream ! function sf and velocity potential vp whose coefficients, ! as,bs (for sf) and av,bv (for vp), were precomputed by ! subroutine shags. ! !ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lvhsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lvhsgs integer lwork integer, intent(out)::ierror real, intent(out)::v(idv, jdv, nt) real, intent(out)::w(idv, jdv, nt) real, intent(temporary):: work(lwork) real as(mdb, ndb, nt) real bs(mdb, ndb, nt) real av(mdb, ndb, nt) real bv(mdb, ndb, nt) real wvhsgs(lvhsgs) ! end subroutine islapec(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,mdab,ndab,wshsec,lshsec,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! islapec inverts the laplace or helmholz operator on an equally ! spaced latitudinal grid using o(n**2) storage. given the ! spherical harmonic coefficients a(m,n) and b(m,n) of the right ! hand side slap(i,j), islapec computes a solution sf(i,j) to ! the following helmhotz equation : ! ! 2 2 ! [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint ! ! - xlmbda * sf(i,j) = slap(i,j) ! ! where sf(i,j) is computed at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! for i=1,...,nlat and j=1,...,nlon. ! ! ! ************************************************************** ! ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! nlon the number of distinct longitude points. ! ! isym this parameter should have the same value input to subroutine ! shaec to compute the coefficients a and b for the scalar field ! slap. isym is set as follows: ! ! = 0 no symmetries exist in slap about the equator. scalar ! synthesis is used to compute sf on the entire sphere. ! ! nt the number of solutions. ! ! xlmbda a one dimensional array with nt elements. if xlmbda is ! is identically zero islapec solves poisson's equation. ! if xlmbda > 0.0 islapec solves the helmholtz equation. ! ! ids the first dimension of the array sf as it appears in the ! program that calls islapec. ! ! jds the second dimension of the array sf as it appears in the ! program that calls islapec. ! ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field slap. a,b must be computed by shaec ! prior to calling islapec. ! ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls islapec. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls islapec. ! ! mdab,ndab should have the same values input to shaec to ! compute the coefficients a and b. ! ! wshsec an array which must be initialized by subroutine shseci. ! ! lshsec the dimension of the array wshsec as it appears in the ! program that calls islapec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls islapec. ! ! ************************************************************** ! ! output parameters ! !sf two or three dimensional arrays (see input parameter nt) ! that contain the solution to either the helmholtz ! (xlmbda>0.0) or poisson's equation. ! !pertrb a one dimensional array with nt elements ! !ierror a parameter which flags errors in input parameters as follows: ! =-1 xlmbda is input negative (nonfatal error) ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of ids ! = 6 error in the specification of jds ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lsave ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer ids integer jds integer mdab integer ndab integer lshsec integer lwork integer, intent(out)::ierror real, intent(out)::sf(ids, jds, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real xlmbda(nt) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsec(lshsec) ! end subroutine islapes(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,mdab,ndab,wshses,lshses,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! islapes inverts the laplace or helmholz operator on an equally ! spaced latitudinal grid using o(n**3) storage. given the ! spherical harmonic coefficients a(m,n) and b(m,n) of the right ! hand side slap(i,j), islapes computes a solution sf(i,j) to ! the following helmhotz equation : ! ! 2 2 ! [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint ! ! - xlmbda * sf(i,j) = slap(i,j) ! ! where sf(i,j) is computed at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! for i=1,...,nlat and j=1,...,nlon. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym this parameter should have the same value input to subroutine ! shaes to compute the coefficients a and b for the scalar field ! slap. isym is set as follows: ! ! = 0 no symmetries exist in slap about the equator. scalar ! synthesis is used to compute sf on the entire sphere. ! ! nt the number of solutions. ! ! xlmbda a one dimensional array with nt elements. if xlmbda is ! is identically zero islapes solves poisson's equation. ! if xlmbda > 0.0 islapes solves the helmholtz equation. ! ! ids the first dimension of the array sf as it appears in the ! program that calls islapes. ! ! jds the second dimension of the array sf as it appears in the ! program that calls islapes. ! ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field slap. a,b must be computed by shaes ! prior to calling islapes. ! ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls islapes. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls islapes. ! ! mdab,ndab should have the same values input to shaes to ! compute the coefficients a and b. ! ! ! wshses an array which must be initialized by subroutine shsesi. ! ! lshses the dimension of the array wshses as it appears in the ! program that calls islapes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls islapes. ! ! ************************************************************** ! ! output parameters ! ! !sf a two or three dimensional arrays (see input parameter nt) that ! inverts the scalar laplacian in slap - pertrb. ! !pertrb a one dimensional array with nt elements. ! !ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of ids ! = 6 error in the specification of jds ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lshses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer ids integer jds integer mdab integer ndab integer lshses integer lwork integer, intent(out)::ierror real, intent(out)::sf(ids, jds, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real xlmbda(nt) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshses(lshses) ! end subroutine islapgc(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,mdab,ndab,wshsgc,lshsgc,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! islapgc inverts the laplace or helmholz operator on a Gaussian ! grid using o(n**2) storage. given the ! spherical harmonic coefficients a(m,n) and b(m,n) of the right ! hand side slap(i,j), islapgc computes a solution sf(i,j) to ! the following helmhotz equation : ! ! 2 2 ! [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint ! ! - xlmbda * sf(i,j) = slap(i,j) ! ! where sf(i,j) is computed at the Gaussian colatitude point theta(i) ! (see nlat as an input argument) and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! for i=1,...,nlat and j=1,...,nlon. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym this parameter should have the same value input to subroutine ! shagc to compute the coefficients a and b for the scalar field ! slap. isym is set as follows: ! ! = 0 no symmetries exist in slap about the equator. scalar ! synthesis is used to compute sf on the entire sphere. ! i.e., in the array sf(i,j) for i=1,...,nlat and ! j=1,...,nlon. ! ! nt the number of solutions. ! ! xlmbda a one dimensional array with nt elements. if xlmbda is ! is identically zero islapgc solves poisson's equation. ! if xlmbda > 0.0 islapgc solves the helmholtz equation. ! ! ids the first dimension of the array sf as it appears in the ! program that calls islapgc. ! ! jds the second dimension of the array sf as it appears in the ! program that calls islapgc. ! ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field slap. a,b must be computed by shagc ! prior to calling islapgc. ! ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls islapgc. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls islapgc. ! ! mdab,ndab should have the same values input to shagc to ! compute the coefficients a and b. ! ! wshsgc an array which must be initialized by subroutine shsgci ! once initialized, wshsgc can be used repeatedly by islapgc ! as long as nlon and nlat remain unchanged. wshsgc must ! not be altered between calls of islapgc. ! ! lshsgc the dimension of the array wshsgc as it appears in the ! program that calls islapgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls islapgc. ! ! ************************************************************** ! ! output parameters ! ! sf a two or three dimensional arrays (see input parameter nt) that ! inverts the scalar laplacian in slap. ! ! pertrb a one dimensional array with nt elements. ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of ids ! = 6 error in the specification of jds ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lshsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer ids integer jds integer mdab integer ndab integer lshsgc integer lwork integer, intent(out)::ierror real, intent(out)::sf(ids, jds, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real xlmbda(nt) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsgc(lshsgc) ! end subroutine islapgs(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,mdab,ndab,wshsgs,lshsgs,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! islapgs inverts the laplace or helmholz operator on a Gaussian grid. ! Given the spherical harmonic coefficients a(m,n) and b(m,n) of the ! right hand side slap(i,j), islapgc computes a solution sf(i,j) to ! the following helmhotz equation : ! ! 2 2 ! [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint ! ! - xlmbda * sf(i,j) = slap(i,j) ! ! where sf(i,j) is computed at the Gaussian colatitude point theta(i) ! (see nlat as an input argument) and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! for i=1,...,nlat and j=1,...,nlon. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym this parameter should have the same value input to subroutine ! shags to compute the coefficients a and b for the scalar field ! slap. isym is set as follows: ! ! = 0 no symmetries exist in slap about the equator. scalar ! synthesis is used to compute sf on the entire sphere. ! ! nt the number of analyses. ! !xlmbda a one dimensional array with nt elements. if xlmbda is ! is identically zero islapgc solves poisson's equation. ! if xlmbda > 0.0 islapgc solves the helmholtz equation. ! !ids the first dimension of the array sf as it appears in the ! program that calls islapgs. ! !jds the second dimension of the array sf as it appears in the ! program that calls islapgs. ! !a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field slap as computed by subroutine shags. ! a,b must be computed by shags prior to calling islapgs. ! !mdab the first dimension of the arrays a and b as it appears ! in the program that calls islapgs. ! !ndab the second dimension of the arrays a and b as it appears ! in the program that calls islapgs. ! !wshsgs an array which must be initialized by subroutine islapgsi ! (or equivalently by shsesi). ! !lshsgs the dimension of the array wshsgs as it appears in the ! program that calls islapgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls islapgs. ! ! ************************************************************** ! ! output parameters ! !sf a two or three dimensional arrays (see input parameter nt) that ! inverts the scalar laplacian in slap. ! !pertrb a one dimensional array with nt elements. ! !ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of ids ! = 6 error in the specification of jds ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lshsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer ids integer jds integer mdab integer ndab integer lshsgs integer lwork integer, intent(out)::ierror real, intent(out)::sf(ids, jds, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real xlmbda(nt) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsgs(lshsgs) ! end subroutine ivlapec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdbc,ndbc,wvhsec,lvhsec,work,lwork,ierror) ! ************************************************************************** ! ! subroutine ivlapec computes a the vector field (v,w) whose vector ! laplacian is (vlap,wlap). w and wlap are east longitudinal ! components of the vectors. v and vlap are colatitudinal components ! of the vectors. br,bi,cr, and ci are the vector harmonic coefficients ! of (vlap,wlap). these must be precomputed by vhaec and are input ! parameters to ivlapec. (v,w) have the same symmetry or lack of ! symmetry about the about the equator as (vlap,wlap). the input ! parameters ityp,nt,mdbc,ndbc must have the same values used by ! vhaec to compute br,bi,cr, and ci for (vlap,wlap). ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ityp this parameter should have the same value input to subroutine ! vhaec to compute the coefficients br,bi,cr, and ci for the ! vector field (vlap,wlap). ityp is set as follows: ! ! = 0 no symmetries exist in (vlap,wlap) about the equator. (v,w) ! is computed and stored on the entire sphere. ! ! nt nt is the number of vector fields (vlap,wlap). ! ! idvw the first dimension of the arrays w and v as it appears in ! the program that calls ivlapec. ! ! jdvw the second dimension of the arrays w and v as it appears in ! the program that calls ivlapec. ! ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients of the ! vector field (vlap,wlap) as computed by subroutine vhaec. ! br,bi,cr and ci must be computed by vhaec prior to calling ! ivlapec. ! !mdb ! the first dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls ivlapec. ! !ndb ! the second dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls ivlapec. ! !wvhse !an array which must be initialized by subroutine vhseci. ! !lvhse !the dimension of the array wvhsec as it appears in the ! program that calls ivlapec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls ivlapec. ! ! ************************************************************** ! ! output parameters ! !v,w two or three dimensional arrays (see input parameter nt) that ! contain a vector field whose vector laplacian is (vlap,wlap). ! !ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lvhsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer nt integer idvw integer jdvw integer mdbc integer ndbc integer lvhsec integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdbc, ndbc, nt) real bi(mdbc, ndbc, nt) real cr(mdbc, ndbc, nt) real ci(mdbc, ndbc, nt) real wvhsec(lvhsec) ! end subroutine ivlapes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdbc,ndbc,wvhses,lvhses,work,lwork,ierror) ! ************************************************************************** ! ! subroutine ivlapes computes a the vector field (v,w) whose vector ! laplacian is (vlap,wlap). w and wlap are east longitudinal ! components of the vectors. v and vlap are colatitudinal components ! of the vectors. br,bi,cr, and ci are the vector harmonic coefficients ! of (vlap,wlap). these must be precomputed by vhaes and are input ! parameters to ivlapes. (v,w) have the same symmetry or lack of ! symmetry about the about the equator as (vlap,wlap). the input ! parameters ityp,nt,mdbc,ndbc must have the same values used by ! vhaes to compute br,bi,cr, and ci for (vlap,wlap). ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ityp this parameter should have the same value input to subroutine ! vhaes to compute the coefficients br,bi,cr, and ci for the ! vector field (vlap,wlap). ityp is set as follows: ! ! = 0 no symmetries exist in (vlap,wlap) about the equator. (v,w) ! is computed and stored on the entire sphere. ! ! idvw the first dimension of the arrays w and v as it appears in ! the program that calls ivlapes. ! ! jdvw the second dimension of the arrays w and v as it appears in ! the program that calls ivlapes. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients of the ! vector field (vlap,wlap) as computed by subroutine vhaes. ! ! mdbc the first dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls ivlapes. ! ! ndbc the second dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls ivlapes. ! ! wvhses an array which must be initialized by subroutine vhsesi. ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls ivlapes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls ivlapes. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a vector field whose vector laplacian is (vlap,wlap). ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lvhses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer nt integer idvw integer jdvw integer mdbc integer ndbc integer lvhses integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdbc, ndbc, nt) real bi(mdbc, ndbc, nt) real cr(mdbc, ndbc, nt) real ci(mdbc, ndbc, nt) real wvhses(lvhses) ! end subroutine ivlapgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdbc,ndbc,wvhsgc,lvhsgc,work,lwork,ierror) ! ************************************************************************** ! ! given the vector spherical harmonic coefficients (br,bi,cr,ci) ! precomputed by subroutine vhagc for a vector field (vlap,wlap), ! subroutine ivlapgc computes a vector field (v,w) whose vector ! laplacian is (vlap,wlap). v,vlap are the colatitudinal ! components and w,wlap are the east longitudinal components of ! the vectors. (v,w) have the same symmetry or lack of symmetry ! about the equator as (vlap,wlap). the input parameters ityp, ! nt,mdbc,ndbc must have the same values used by vhagc to compute ! br,bi,cr,ci for (vlap,wlap). ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! ityp this parameter should have the same value input to subroutine ! vhagc to compute the coefficients br,bi,cr, and ci for the ! vector field (vlap,wlap). ityp is set as follows: ! ! = 0 no symmetries exist in (vlap,wlap) about the equator. (v,w) ! is computed and stored on the entire sphere. ! ! nt nt is the number of vector fields (vlap,wlap). ! ! idvw the first dimension of the arrays w and v as it appears in ! the program that calls ivlapgc. ! ! jdvw the second dimension of the arrays w and v as it appears in ! the program that calls ivlapgc. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients of the ! vector field (vlap,wlap) as computed by subroutine vhagc. ! br,bi,cr and ci must be computed by vhagc prior to calling ! ivlapgc. ! ! mdbc the first dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls ivlapgc. ! ! ndbc the second dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls ivlapgc. ! ! wvhsgc an array which must be initialized by subroutine vhsgci. ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls ivlapgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls ivlapgc. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a vector field whose vector laplacian is (vlap,wlap). ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lvhsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer nt integer idvw integer jdvw integer mdbc integer ndbc integer lvhsgc integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdbc, ndbc, nt) real bi(mdbc, ndbc, nt) real cr(mdbc, ndbc, nt) real ci(mdbc, ndbc, nt) real wvhsgc(lvhsgc) ! end subroutine ivlapgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdbc,ndbc,wvhsgs,lvhsgs,work,lwork,ierror) ! ************************************************************************** ! ! given the vector spherical harmonic coefficients (br,bi,cr,ci) ! precomputed by subroutine vhags for a vector field (vlap,wlap), ! subroutine ivlapgs computes a vector field (v,w) whose vector ! laplacian is (vlap,wlap). v,vlap are the colatitudinal ! components and w,wlap are the east longitudinal components of ! the vectors. (v,w) have the same symmetry or lack of symmetry ! about the equator as (vlap,wlap). the input parameters ityp, ! nt,mdbc,ndbc must have the same values used by vhags to compute ! br,bi,cr,ci for (vlap,wlap). ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! ityp this parameter should have the same value input to subroutine ! vhags to compute the coefficients br,bi,cr, and ci for the ! vector field (vlap,wlap). ! ! = 0 no symmetries exist in (vlap,wlap) about the equator. (v,w) ! is computed and stored on the entire sphere. ! ! nt nt is the number of vector fields (vlap,wlap). ! ! idvw the first dimension of the arrays w and v as it appears in ! the program that calls ivlapgs. ! ! jdvw the second dimension of the arrays w and v as it appears in ! the program that calls ivlapgs. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients of the ! vector field (vlap,wlap) as computed by subroutine vhags. ! br,bi,cr and ci must be computed by vhags prior to calling ! ivlapgs. ! ! mdbc the first dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls ivlapgs. ! ! ndbc the second dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls ivlapgs. ! ! wvhsgs an array which must be initialized by subroutine vhsgsi. ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls ivlapgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls ivlapgs. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a vector field whose vector laplacian is (vlap,wlap). ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lvhsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer nt integer idvw integer jdvw integer mdbc integer ndbc integer lvhsgs integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdbc, ndbc, nt) real bi(mdbc, ndbc, nt) real cr(mdbc, ndbc, nt) real ci(mdbc, ndbc, nt) real wvhsgs(lvhsgs) ! end subroutine ivrtec(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsec,lvhsec,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shaec for a scalar array vort, subroutine ivrtec computes ! a divergence free vector field (v,w) whose vorticity is vt - pertrb. ! w is the east longitude component and v is the colatitudinal component. ! pertrb is a constant which must be subtracted from vort for (v,w) to ! exist (see the description of pertrb below). usually pertrb is zero ! or small relative to vort. the divergence of (v,w), as computed by ! ivrtec, is the zero scalar field. i.e., v(i,j) and w(i,j) are the ! colaatitudinal and east longitude velocity components at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon. ! ! the ! ! vorticity(v(i,j),w(i,j)) ! ! = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! = vort(i,j) - pertrb ! ! and ! ! divergence(v(i,j),w(i,j)) ! ! = [d(sint*v)/dtheta + dw/dlambda]/sint ! ! = 0.0 ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine ivrtes. ! ! ************************************************************** ! ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shaec to compute the arrays a and b. isym ! determines whether (v,w) are computed on the full or half ! sphere as follows: ! ! = 0 ! vort is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt in the program that calls ivrtec, nt is the number of vorticity ! and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls ivrtec. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls ivrtec. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the vorticity array vort as computed by subroutine shaec. ! a,b must be computed by shaec prior to calling ivrtec. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls ivrtec (and shaec). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls ivrtec (and shaec). ndab must be at ! least nlat. ! ! ! wvhsec an array which must be initialized by subroutine vhseci. ! ! lvhsec the dimension of the array wvhsec as it appears in the ! program that calls ivrtec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls ivrtec. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a divergence free vector field whose vorticity is ! vort - pertrb. ! !pertrb a nt dimensional array. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhsec integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsec(lvhsec) ! end subroutine ivrtes(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhses,lvhses,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shaes for a scalar array vort, subroutine ivrtes computes ! a divergence free vector field (v,w) whose vorticity is vort - pertrb. ! w is the east longitude component and v is the colatitudinal component. ! pertrb is a constant which must be subtracted from vort for (v,w) to ! exist (see the description of pertrb below). usually pertrb is zero ! or small relative to vort. the divergence of (v,w), as computed by ! ivrtes, is the zero scalar field. i.e., v(i,j) and w(i,j) are the ! colaatitudinal and east longitude velocity components at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon. ! ! the ! ! vorticity(v(i,j),w(i,j)) ! ! = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! = vort(i,j) - pertrb ! ! and ! ! divergence(v(i,j),w(i,j)) ! ! = [d(sint*v)/dtheta + dw/dlambda]/sint ! ! = 0.0 ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are stored rather than recomputed as they are in subroutine ivrtec. ! ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! nlon the number of distinct longitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shaes to compute the arrays a and b. isym ! determines whether (v,w) are computed on the full or half ! sphere as follows: ! ! = 0 ! vort is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt in the program that calls ivrtes, nt is the number of vorticity ! and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls ivrtec. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls ivrtes. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the vorticity array vort as computed by subroutine shaes. ! a,b must be computed by shaes prior to calling ivrtes. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls ivrtes (and shaes). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls ivrtes (and shaes). ! ! wvhses an array which must be initialized by subroutine vhsesi. ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls ivrtes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls ivrtes. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a divergence free vector field whose vorticity is ! vort - pertrb. ! ! pertrb a nt dimensional array. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhses integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhses(lvhses) ! end subroutine ivrtgc(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsgc,lvhsgc,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shagc for a scalar array vt, subroutine ivrtgc computes ! a divergence free vector field (v,w) whose vorticity is vt - pertrb. ! w is the east longitude component and v is the colatitudinal component. ! pertrb is a constant which must be subtracted from vt for (v,w) to ! exist (see the description of pertrb below). usually pertrb is zero ! or small relative to vort. the divergence of (v,w), as computed by ! ivrtgc, is the zero scalar field. v(i,j) and w(i,j) are the ! colatitudinal and east longitude velocity components at gaussian ! colatitude theta(i) (see nlat as input parameter) and longitude ! lambda(j) = (j-1)*2*pi/nlon. the ! ! vorticity(v(i,j),w(i,j)) ! ! = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! = vort(i,j) - pertrb ! ! and ! ! divergence(v(i,j),w(i,j)) ! ! = [d(sint*v)/dtheta + dw/dlambda]/sint ! ! = 0.0 ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine ivrtgs. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shagc to compute the arrays a and b. isym ! determines whether (v,w) are computed on the full or half ! sphere as follows: ! ! = 0 ! vt is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt in the program that calls ivrtgc, nt is the number of vorticity ! and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls ivrtgc. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls ivrtgc. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the vorticity array vt as computed by subroutine shagc. ! a,b must be computed by shagc prior to calling ivrtgc. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls ivrtgcs (and shagc). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls ivrtgc (and shagc). ! ! wvhsg an array which must be initialized by subroutine vhsgci. ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls ivrtgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls ivrtgc. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a divergence free vector field whose vorticity is ! vt - pertrb. ! ! pertrb a nt dimensional array. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhsgc integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsgc(lvhsgc) ! end subroutine ivrtgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,wvhsgs,lvhsgs,work,lwork,pertrb,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shags for a scalar array vt, subroutine ivrtgs computes ! a divergence free vector field (v,w) whose vorticity is vt - pertrb. ! w is the east longitude component and v is the colatitudinal component. ! pertrb is a constant which must be subtracted from vt for (v,w) to ! exist (see the description of pertrb below). usually pertrb is zero ! or small relative to vt. the divergence of (v,w), as computed by ! ivrtgs, is the zero scalar field. v(i,j) and w(i,j) are the ! colatitudinal and east longitude velocity components at gaussian ! colatitude theta(i) (see nlat as input parameter) and longitude ! lambda(j) = (j-1)*2*pi/nlon. the ! ! vorticity(v(i,j),w(i,j)) ! ! = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! = vort(i,j) - pertrb ! ! and ! ! divergence(v(i,j),w(i,j)) ! ! = [d(sint*v)/dtheta + dw/dlambda]/sint ! ! = 0.0 ! ! where sint = sin(theta(i)). required associated legendre polynomials ! are stored rather than recomputed as they are in subroutine ivrtgc. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym this has the same value as the isym that was input to ! subroutine shags to compute the arrays a and b. isym ! determines whether (v,w) are computed on the full or half ! sphere as follows: ! = 0 ! vt is not symmetric about the equator. in this case ! the vector field (v,w) is computed on the entire sphere. ! ! nt in the program that calls ivrtgs, nt is the number of vorticity ! and vector fields. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls ivrtgs. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls ivrtgs. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the vorticity array vt as computed by subroutine shags. ! a,b must be computed by shags prior to calling ivrtgs. ! ! mdab the first dimension of the arrays a and b as it appears in ! the program that calls ivrtgs (and shags). ! ! ndab the second dimension of the arrays a and b as it appears in ! the program that calls ivrtgs (and shags). ! ! wvhsgs an array which must be initialized by subroutine vhsgsi. ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls ivrtgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls ivrtgs. ! ! ************************************************************** ! ! output parameters ! ! ! v,w two or three dimensional arrays (see input parameter nt) that ! contain a divergence free vector field whose vorticity is ! vt - pertrb. ! ! pertrb a nt dimensional array ! ! ierror= 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer idvw integer jdvw integer mdab integer ndab integer lvhsgs integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(out)::pertrb(nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wvhsgs(lvhsgs) ! end subroutine sfvpec(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb,wshsec,lshsec,work,lwork,ierror) ! ************************************************************************** ! ! given the vector spherical harmonic coefficients br,bi,cr,ci, ! computed by subroutine vhaec for a vector field (v,w), sfvpec ! computes a scalar stream function sf and scalar velocity potential ! vp for (v,w). (v,w) is expressed in terms of sf and vp by the ! helmholtz relations (in mathematical spherical coordinates): ! ! v = -1/sint*d(vp)/dlambda + d(st)/dtheta ! ! w = 1/sint*d(st)/dlambda + d(vp)/dtheta ! ! where sint = sin(theta). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! br,bi,cr,ci were precomputed. required associated legendre ! polynomials are recomputed rather than stored as they are in ! subroutine sfvpes. sf(i,j) and vp(i,j) are given at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the stream function and ! velocity potential are computed on the full or half sphere ! as follows: ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. in this case sf ! and vp are not necessarily symmetric or antisymmetric about ! the equator. sf and vp are computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the arrays sf,vp as it appears in ! the program that calls sfvpec. ! ! jdv the second dimension of the arrays sf,vp as it appears in ! the program that calls sfvpec. jdv must be at least nlon. ! ! br,bi, two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaec. ! ! mdb the first dimension of the arrays br,bi,cr,ci as it ! appears in the program that calls sfvpec. ! ! ndb the second dimension of the arrays br,bi,cr,ci as it ! appears in the program that calls sfvpec. ! ! wshsec an array which must be initialized by subroutine shseci. ! ! lshsec the dimension of the array wshsec as it appears in the ! program that calls sfvpec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! ! ************************************************************** ! ! output parameters ! ! sf,vp two or three dimensional arrays (see input parameter nt) ! that contains the stream function and velocity potential ! of the vector field (v,w) whose coefficients br,bi,cr,ci ! where precomputed by subroutine vhaec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lshsec integer lwork integer, intent(out)::ierror real, intent(out)::sf(idv, jdv, nt) real, intent(out)::vp(idv, jdv, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real cr(mdb, ndb, nt) real ci(mdb, ndb, nt) real wshsec(lshsec) ! end subroutine sfvpes(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb,wshses,lshses,work,lwork,ierror) ! ************************************************************************** ! ! given the vector spherical harmonic coefficients br,bi,cr,ci, ! computed by subroutine vhaes for a vector field (v,w), sfvpes ! computes a scalar stream function sf and scalar velocity potential ! vp for (v,w). (v,w) is expressed in terms of sf and vp by the ! helmholtz relations (in mathematical spherical coordinates): ! ! v = -1/sint*d(vp)/dlambda + d(st)/dtheta ! ! w = 1/sint*d(st)/dlambda + d(vp)/dtheta ! ! where sint = sin(theta). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! br,bi,cr,ci were precomputed. required associated legendre ! polynomials are stored rather than recomputed as they are in ! subroutine sfvpec. sf(i,j) and vp(i,j) are given at colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! ! poles. ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the stream function and ! velocity potential are computed on the full or half sphere ! as follows: ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the arrays sf,vp as it appears in ! the program that calls sfvpes. ! ! jdv the second dimension of the arrays sf,vp as it appears in ! the program that calls sfvpes. ! ! br,bi, two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaec. ! ! mdb the first dimension of the arrays br,bi,cr,ci as it ! appears in the program that calls sfvpes. ! ! ndb the second dimension of the arrays br,bi,cr,ci as it ! appears in the program that calls sfvpes. ! ! wshses an array which must be initialized by subroutine shsesi. ! ! lshses the dimension of the array wshses as it appears in the ! program that calls sfrvpes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls sfvpes. ! ! ************************************************************** ! ! output parameters ! ! sf,vp two or three dimensional arrays (see input parameter nt) ! that contains the stream function and velocity potential ! of the vector field (v,w) whose coefficients br,bi,cr,ci ! where computed by subroutine vhaec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lshses integer lwork integer, intent(out)::ierror real, intent(out)::sf(idv, jdv, nt) real, intent(out)::vp(idv, jdv, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real cr(mdb, ndb, nt) real ci(mdb, ndb, nt) real wshses(lshses) ! end subroutine sfvpgc(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb,wshsgc,lshsgc,work,lwork,ierror) ! ************************************************************************** ! ! ! given the vector spherical harmonic coefficients br,bi,cr,ci, ! computed by subroutine vhagc for a vector field (v,w), sfvpgc ! computes a scalar stream function sf and scalar velocity potential ! vp for (v,w). (v,w) is expressed in terms of sf and vp by the ! helmholtz relations (in mathematical spherical coordinates): ! ! v = -1/sint*d(vp)/dlambda + d(st)/dtheta ! ! w = 1/sint*d(st)/dlambda + d(vp)/dtheta ! ! where sint = sin(theta). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! br,bi,cr,ci were precomputed. required associated legendre ! polynomials are recomputed rather than stored as they are in ! subroutine sfvpgs. sf(i,j) and vp(i,j) are given at the i(th) ! gaussian colatitude point theta(i) (see nlat description below) ! and east longitude lambda(j) = (j-1)*2*pi/nlon on the sphere. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the stream function and ! velocity potential are computed on the full or half sphere ! as follows: ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. in this case st ! and vp are not necessarily symmetric or antisymmetric about ! the equator. sf and vp are computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the arrays sf,vp as it appears in ! the program that calls sfvpgc. ! ! jdv the second dimension of the arrays sf,vp as it appears in ! the program that calls sfvpgc. jdv must be at least nlon. ! ! br,bi, two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhagc. ! ! mdb the first dimension of the arrays br,bi,cr,ci as it ! appears in the program that calls sfvpgc. ! ! ndb the second dimension of the arrays br,bi,cr,ci as it ! appears in the program that calls sfvpgc. ! ! wshsgc an array which must be initialized by subroutine shsgci. ! ! lshsgc the dimension of the array wshsgc as it appears in the ! program that calls sfvpgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls sfvpgc. ! ! ************************************************************** ! ! output parameters ! ! sf,vp two or three dimensional arrays (see input parameter nt) ! that contains the stream function and velocity potential ! of the vector field (v,w) whose coefficients br,bi,cr,ci ! where precomputed by subroutine vhagc. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lshsgc integer lwork integer, intent(out)::ierror real, intent(out)::sf(idv, jdv, nt) real, intent(out)::vp(idv, jdv, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real cr(mdb, ndb, nt) real ci(mdb, ndb, nt) real wshsgc(lshsgc) ! end subroutine sfvpgs(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,mdb,ndb,wshsgs,lshsgs,work,lwork,ierror) ! ************************************************************************** ! ! given the vector spherical harmonic coefficients br,bi,cr,ci, ! computed by subroutine vhags for a vector field (v,w), sfvpgs ! computes a scalar stream function sf and scalar velocity potential ! vp for (v,w). (v,w) is expressed in terms of sf and vp by the ! helmholtz relations (in mathematical spherical coordinates): ! ! v = -1/sint*d(vp)/dlambda + d(st)/dtheta ! ! w = 1/sint*d(st)/dlambda + d(vp)/dtheta ! ! where sint = sin(theta). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! br,bi,cr,ci were precomputed. required associated legendre ! polynomials are stored rather than recomputed as they are in ! subroutine sfvpgc. sf(i,j) and vp(i,j) are given at the i(th) ! gaussian colatitude point theta(i) (see nlat description below) ! and east longitude lambda(j) = (j-1)*2*pi/nlon on the sphere. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! isym a parameter which determines whether the stream function and ! velocity potential are computed on the full or half sphere ! as follows: ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. in this case st ! and vp are not necessarily symmetric or antisymmetric about ! the equator. ! ! nt nt is the number of scalar and vector fields. ! ! idv the first dimension of the arrays sf,vp as it appears in ! the program that calls sfvpgs. ! ! jdv the second dimension of the arrays sf,vp as it appears in ! the program that calls sfvpgs. ! ! br,bi, two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhags. ! ! mdb the first dimension of the arrays br,bi,cr,ci as it ! appears in the program that calls sfvpgs. ! ! ndb the second dimension of the arrays br,bi,cr,ci as it ! appears in the program that calls sfvpgs. ! ! wshsgs an array which must be initialized by subroutine shsgsi. ! ! lshsgs the dimension of the array wshsgs as it appears in the ! program that calls sfvpgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls sfvpgs. ! ! ************************************************************** ! ! output parameters ! ! sf,vp two or three dimensional arrays (see input parameter nt) ! that contains the stream function and velocity potential ! of the vector field (v,w) whose coefficients br,bi,cr,ci ! where precomputed by subroutine vhags. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idv ! = 6 error in the specification of jdv ! = 7 error in the specification of mdb ! = 8 error in the specification of ndb ! = 9 error in the specification of lshsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idv integer jdv integer nt integer mdb integer ndb integer lshsgs integer lwork integer, intent(out)::ierror real, intent(out)::sf(idv, jdv, nt) real, intent(out)::vp(idv, jdv, nt) real, intent(temporary):: work(lwork) real br(mdb, ndb, nt) real bi(mdb, ndb, nt) real cr(mdb, ndb, nt) real ci(mdb, ndb, nt) real wshsgs(lshsgs) ! end subroutine shaec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,wshaec,lshaec,work,lwork,ierror) ! ************************************************************************** ! ! subroutine shaec performs the spherical harmonic analysis ! on the array g and stores the result in the arrays a and b. ! the analysis is performed on an equally spaced grid. the ! associated legendre functions are recomputed rather than stored ! as they are in subroutine shaes. the analysis is described ! below at output parameters a,b. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym = 0 no symmetries exist about the equator. the analysis ! is performed on the entire sphere. ! ! nt the number of analyses. ! ! g a two or three dimensional array (see input parameter ! nt) that contains the discrete function to be analyzed. ! ! idg the first dimension of the array g as it appears in the ! program that calls shaec. ! ! jdg the second dimension of the array g as it appears in the ! program that calls shaec. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls shaec. ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls shaec. ! ! wshaec an array which must be initialized by subroutine shaeci. ! once initialized, wshaec can be used repeatedly by shaec ! as long as nlon and nlat remain unchanged. wshaec must ! not be altered between calls of shaec. ! ! lshaec the dimension of the array wshaec as it appears in the ! program that calls shaec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls shaec. ! ! ************************************************************** ! ! output parameters ! ! a,b both a,b are two or three dimensional arrays (see input ! parameter nt) that contain the spherical harmonic ! coefficients in the representation of g(i,j) given in the ! discription of subroutine shsec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idg ! = 6 error in the specification of jdg ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lshaec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idg integer jdg integer nt integer mdab integer ndab integer lshaec integer lwork integer, intent(out)::ierror real, intent(out)::a(mdab, ndab, nt) real, intent(out)::b(mdab, ndab, nt) real, intent(temporary):: work(lwork) real g(idg, jdg, nt) real wshaec(lshaec) ! end subroutine shaeci(nlat,nlon,wshaec,lshaec,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shaeci initializes the array wshaec which can then ! be used repeatedly by subroutine shaec. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! lshaec the dimension of the array wshaec as it appears in the ! program that calls shaeci. ! ! dwork a doubleprecision dwork array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls shaeci. ! ! ************************************************************** ! ! output parameters ! ! wshaec an array which is initialized for use by subroutine shaec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshaec ! = 4 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lshaec integer ldwork integer, intent(out)::ierror real, intent(out)::wshaec(lshaec) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine shaes(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,wshaes,lshaes,work,lwork,ierror) ! ************************************************************************** ! ! subroutine shaes performs the spherical harmonic analysis ! on the array g and stores the result in the arrays a and b. ! the analysis is performed on an equally spaced grid. the ! associated legendre functions are stored rather than recomputed ! as they are in subroutine shaec. the analysis is described ! below at output parameters a,b. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym = 0 no symmetries exist about the equator. the analysis ! is performed on the entire sphere. ! ! nt the number of analyses. ! ! g a two or three dimensional array (see input parameter ! nt) that contains the discrete function to be analyzed. ! ! idg the first dimension of the array g as it appears in the ! program that calls shaes. ! ! jdg the second dimension of the array g as it appears in the ! program that calls shaes. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls shaes. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls shaes. ! ! wshaes an array which must be initialized by subroutine shaesi. ! ! lshaes the dimension of the array wshaes as it appears in the ! program that calls shaes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls shaes. ! ! ! ************************************************************** ! ! output parameters ! ! a,b both a,b are two or three dimensional arrays (see input ! parameter nt) that contain the spherical harmonic ! coefficients in the representation of g(i,j) given in the ! discription of subroutine shses. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idg ! = 6 error in the specification of jdg ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lshaes ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idg integer jdg integer nt integer mdab integer ndab integer lshaes integer lwork integer, intent(out)::ierror real, intent(out)::a(mdab, ndab, nt) real, intent(out)::b(mdab, ndab, nt) real, intent(temporary):: work(lwork) real g(idg, jdg, nt) real wshaes(lshaes) ! end subroutine shaesi(nlat,nlon,wshaes,lshaes,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! ! subroutine shaesi initializes the array wshaes which can then ! be used repeatedly by subroutine shaes ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! lshaes the dimension of the array wshaes as it appears in the ! program that calls shaesi. ! ! work a real work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls shaesi. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls shaesi. ! ! ************************************************************** ! ! output parameters ! ! wshaes an array which is initialized for use by subroutine shaes. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshaes ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lshaes integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wshaes(lshaes) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine shagc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,wshagc,lshagc,work,lwork,ierror) ! ************************************************************************** ! ! subroutine shagc performs the spherical harmonic analysis ! on the array g and stores the result in the arrays a and b. ! the analysis is performed on a gaussian grid in colatitude ! and an equally spaced grid in longitude. the associated ! legendre functions are recomputed rather than stored as they ! are in subroutine shags. the analysis is described below ! at output parameters a,b. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym = 0 no symmetries exist about the equator. the analysis ! is performed on the entire sphere. ! ! nt the number of analyses. ! ! g a two or three dimensional array (see input parameter ! nt) that contains the discrete function to be analyzed. ! ! idg the first dimension of the array g as it appears in the ! program that calls shagc. ! ! jdg the second dimension of the array g as it appears in the ! program that calls shagc. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls shagc. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls shaec. ! ! wshagc an array which must be initialized by subroutine shagci. ! ! lshagc the dimension of the array wshagc as it appears in the ! program that calls shagc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls shagc. ! ! ! ************************************************************** ! ! output parameters ! ! a,b both a,b are two or three dimensional arrays (see input ! parameter nt) that contain the spherical harmonic ! coefficients in the representation of g(i,j) given in the ! discription of subroutine shagc. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idg ! = 6 error in the specification of jdg ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lshagc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idg integer jdg integer nt integer mdab integer ndab integer lshagc integer lwork integer, intent(out)::ierror real, intent(out)::a(mdab, ndab, nt) real, intent(out)::b(mdab, ndab, nt) real, intent(temporary):: work(lwork) real g(idg, jdg, nt) real wshagc(lshagc) ! end subroutine shagci(nlat,nlon,wshagc,lshagc,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shagci initializes the array wshagc which can then ! be used repeatedly by subroutines shagc. it precomputes ! and stores in wshagc quantities such as gaussian weights, ! legendre polynomial coefficients, and fft trigonometric tables. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! wshagc an array which must be initialized by subroutine shagci. ! ! lshagc the dimension of the array wshagc as it appears in the ! program that calls shagc. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls shagci. ! ! ************************************************************** ! ! output parameter ! ! wshagc an array which must be initialized before calling shagc. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshagc ! = 4 error in the specification of ldwork ! = 5 failure in gaqd to compute gaussian points ! (due to failure in eigenvalue routine) ! ************************************************************************* ! integer nlat integer nlon integer lshagc integer ldwork integer, intent(out)::ierror real, intent(out)::wshagc(lshagc) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine shags(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,wshags,lshags,work,lwork,ierror) ! ************************************************************************** ! ! subroutine shags performs the spherical harmonic analysis ! on the array g and stores the result in the arrays a and b. ! the analysis is performed on a gaussian grid in colatitude ! and an equally spaced grid in longitude. the associated ! legendre functions are stored rather than recomputed as they ! are in subroutine shagc. the analysis is described below ! at output parameters a,b. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym = 0 no symmetries exist about the equator. the analysis ! is performed on the entire sphere. ! ! nt the number of analyses. ! ! g a two or three dimensional array (see input parameter ! nt) that contains the discrete function to be analyzed. ! ! idg the first dimension of the array g as it appears in the ! ! jdg the second dimension of the array g as it appears in the ! program that calls shags. jdg must be at least nlon. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls shags. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls shags. ! ! wshags an array which must be initialized by subroutine shagsi. ! ! lshags the dimension of the array wshags as it appears in the ! program that calls shags. ! ! work a real work space which need not be saved ! ! lwork the dimension of the array work as it appears in the ! program that calls shags. ! ! ! ************************************************************** ! ! output parameters ! ! a,b both a,b are two or three dimensional arrays (see input ! parameter nt) that contain the spherical harmonic ! coefficients in the representation of g(i,j) given in the ! discription of subroutine shags. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idg ! = 6 error in the specification of jdg ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lshags ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idg integer jdg integer nt integer mdab integer ndab integer lshags integer lwork integer, intent(out)::ierror real, intent(out)::a(mdab, ndab, nt) real, intent(out)::b(mdab, ndab, nt) real, intent(temporary):: work(lwork) real g(idg, jdg, nt) real wshags(lshags) ! end subroutine shagsi(nlat,nlon,wshags,lshags,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shagsi initializes the array wshags which can then ! be used repeatedly by subroutines shags. it precomputes ! and stores in wshags quantities such as gaussian weights, ! legendre polynomial coefficients, and fft trigonometric tables. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! ! wshags an array which must be initialized by subroutine shagsi. ! ! lshags the dimension of the array wshags as it appears in the ! program that calls shags. ! ! work a real work space which need not be saved ! ! lwork the dimension of the array work as it appears in the ! program that calls shagsi. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the length of dwork in the calling routine. ! ! ! ************************************************************** ! ! output parameter ! ! wshags an array which must be initialized before calling shags. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshags ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! = 6 failure in gaqd to compute gaussian points ! (due to failure in eigenvalue routine) ! ************************************************************************* ! integer nlat integer nlon integer lshags integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wshags(lshags) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine sshifte(ioff,nlon,nlat,goff,greg,wsav,lsav,wrk,lwrk,ier) ! ************************************************************************** ! ! subroutine sshifte does a highly accurate 1/2 grid increment shift ! in both longitude and latitude of equally spaced data on the sphere. ! data is transferred between the nlon by nlat offset grid in goff ! (which excludes poles) and the nlon by nlat+1 regular grid in greg ! (which includes poles). the transfer can go from goff to greg or from ! greg to goff (see ioff). the grids which underly goff and greg are ! described below. the north and south poles are at latitude 0.5*pi and ! -0.5*pi radians respectively where pi = 4.*atan(1.). ! ! ! ************************************************************** ! ! input parameters ! ! nlon the number of longitude points on both the offset and regular ! uniform grid in longitude. ! ! nlat the number of latitude points on the offset uniform grid. nlat+1 ! is the number of latitude points on the regular uniform grid. ! ! greg a nlon by nlat+1 array that contains input data on the regular grid ! described above. ! ! goff a nlon by nlat array that contains input data on the offset grid ! described above. ! ! wsav a real saved work space array that must be initialized by calling ! subroutine sshift2regi(nlon,nlat,wsav,ier) before calling sshift2reg. ! ! lsav the length of the saved work space wsav in the routine calling sshifte ! and sshiftei. ! ! wrk a real unsaved work space ! ! lwrk the length of the unsaved work space in the routine calling sshift2reg ! ! ************************************************************** ! ! output parameters ! ! ier = 0 if no errors are detected ! = 1 if ioff is not equal to 0 or 1 ! = 1 if nlon < 4 ! = 2 if nlat < 3 ! = 3 if lsave < 2*(nlon+2*nlat+16) ! = 4 if lwork < 2*nlon*(nlat+1) for nlon even or ! lwork < nlon*(5*nlat+1) for nlon odd ! ************************************************************************* ! integer ioff integer nlat integer nlon integer lsav integer lwrk integer, intent(out)::ier real, intent(inout)::goff(nlon, nlat) real, intent(inout)::greg(nlon, nlat + 1) real, intent(temporary):: wrk(lwrk) real wsav(lsav) ! end subroutine sshifti(ioff,nlon,nlat,lsav,wsav,ier) ! ************************************************************************** ! ! subroutine sshifti initializes the saved work space wsav ! for ioff and nlon and nlat (see documentation for sshifte). ! sshifti must be called before sshifte whenever ioff or nlon ! or nlat change. ! ! ier = 0 if no errors with input arguments ! = 1 if ioff is not 0 or 1 ! = 2 if nlon < 4 ! = 3 if nlat < 3 ! = 4 if lsav < 2*(2*nlat+nlon+16) ! ************************************************************************* ! integer ioff integer nlat integer nlon integer lsav integer, intent(out)::ier real, intent(out)::wsav(lsav) ! end subroutine shigc(nlat,nlon,wshigc,lshigc,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shigc initializes the array wshigc which can then ! be used repeatedly by subroutines shsgc or shagc. it precomputes ! and stores in wshigc quantities such as gaussian weights, ! legendre polynomial coefficients, and fft trigonometric tables. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! wshigc an array which must be initialized by subroutine shigc. ! ! lshigc the dimension of the array wshigc as it appears in the ! program that calls shsgc or shagc. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls shigc. ! ! ************************************************************** ! ! output parameter ! ! wshigc an array which must be initialized before calling shsgc or shagc. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshigc ! = 4 error in the specification of ldwork ! = 5 failure in gaqd to compute gaussian points ! (due to failure in eigenvalue routine) ! ************************************************************************* ! integer nlat integer nlon integer lshigc integer ldwork integer, intent(out)::ierror real, intent(out)::wshigc(lshigc) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine shigs(nlat,nlon,wshigs,lshigs,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shigs initializes the array wshigs which can then ! be used repeatedly by subroutines shags,shsgs. it precomputes ! and stores in wshigs quantities such as gaussian weights, ! legendre polynomial coefficients, and fft trigonometric tables. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. s ! ! wshigs an array which must be initialized by subroutine shigs . ! ! lshigs the dimension of the array wshigs as it appears in the ! program that calls shigs. ! ! work a real work space which need not be saved ! ! lwork the dimension of the array work as it appears in the ! program that calls shigs. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the length of dwork in the calling routine. ! ! ************************************************************** ! ! output parameter ! ! wshags an array which must be initialized before calling shags. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshags ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! = 6 failure in gaqd to compute gaussian points ! (due to failure in eigenvalue routine) ! ************************************************************************* ! integer nlat integer nlon integer lshigs integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wshigs(lshigs) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine shsec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,wshsec,lshsec,work,lwork,ierror) ! ************************************************************************** ! ! subroutine shsec performs the spherical harmonic synthesis ! on the arrays a and b and stores the result in the array g. ! the synthesis is performed on an equally spaced grid. the ! associated legendre functions are recomputed rather than stored ! as they are in subroutine shses. the synthesis is described ! below at output parameter g. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idg the first dimension of the array g as it appears in the ! program that calls shsec. ! ! jdg the second dimension of the array g as it appears in the ! program that calls shsec. jdg must be at least nlon. ! ! a,b two or three dimensional arrays (see the input parameter ! nt) that contain the coefficients in the spherical harmonic ! expansion of g(i,j) given below at the definition of the ! output parameter g. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls shsec. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls shsec. ! ! wshsec an array which must be initialized by subroutine shseci. ! ! lshsec the dimension of the array wshsec as it appears in the ! program that calls shsec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls shsec. ! ! ************************************************************** ! ! output parameters ! ! g a two or three dimensional array (see input parameter ! nt) that contains the spherical harmonic synthesis of ! the arrays a and b. ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idg ! = 6 error in the specification of jdg ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lshsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idg integer jdg integer nt integer mdab integer ndab integer lshsec integer lwork integer, intent(out)::ierror real, intent(out):: g(idg, jdg, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsec(lshsec) ! end subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shseci initializes the array wshsec which can then ! be used repeatedly by subroutine shsec. ! ! ************************************************************** ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! lshsec the dimension of the array wshsec as it appears in the ! program that calls shseci. ! ! dwork a doubleprecision work array that does not have to be ! saved. ! ! ldwork the dimension of array dwork as it appears in the program ! that calls shseci. ! ! ************************************************************** ! ! output parameters ! ! wshsec an array which is initialized for use by subroutine shsec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshsec ! = 4 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lshsec integer ldwork integer, intent(out)::ierror real, intent(out)::wshsec(lshsec) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine shses(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,wshses,lshses,work,lwork,ierror) ! ************************************************************************** ! ! subroutine shses performs the spherical harmonic synthesis ! on the arrays a and b and stores the result in the array g. ! the synthesis is performed on an equally spaced grid. the ! associated legendre functions are stored rather than recomputed ! as they are in subroutine shsec. the synthesis is described ! below at output parameter g. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idg the first dimension of the array g as it appears in the ! program that calls shses. ! ! jdg the second dimension of the array g as it appears in the ! program that calls shses. ! ! a,b two or three dimensional arrays (see the input parameter ! nt) that contain the coefficients in the spherical harmonic ! expansion of g(i,j) given below at the definition of the ! output parameter g. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls shses. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls shses. ! ! wshses an array which must be initialized by subroutine shsesi. ! ! lshses the dimension of the array wshses as it appears in the ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls shses. ! ! ************************************************************** ! ! output parameters ! ! g a two or three dimensional array (see input parameter ! nt) that contains the spherical harmonic synthesis of ! the arrays a and b. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idg ! = 6 error in the specification of jdg ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lshses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer idg integer jdg integer nt integer mdab integer ndab integer lshses integer lwork integer, intent(out)::ierror real, intent(out):: g(idg, jdg, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshses(lshses) ! end subroutine shsesi(nlat,nlon,wshses,lshses,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shsesi initializes the array wshses which can then ! be used repeatedly by subroutine shses. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! lshses the dimension of the array wshses as it appears in the ! program that calls shsesi. ! ! work a real work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in ! the program that calls shsesi. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls shsesi. ldwork must be at least nlat+1 ! ! ************************************************************** ! ! output parameters ! ! wshses an array which is initialized for use by subroutine shses. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshses ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lshses integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wshses(lshses) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine shsgc(nlat,nlon,mode,nt,g,idg,jdg,a,b,mdab,ndab,wshsgc,lshsgc,work,lwork,ierror) ! ************************************************************************** ! ! subroutine shsgc performs the spherical harmonic synthesis ! on the arrays a and b and stores the result in the array g. ! the synthesis is performed on an equally spaced longitude grid ! and a gaussian colatitude grid. the associated legendre functions ! are recomputed rather than stored as they are in subroutine ! shsgs. the synthesis is described below at output parameter ! g. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! mode = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idg the first dimension of the array g as it appears in the ! program that calls shsgc. ! ! jdg the second dimension of the array g as it appears in the ! program that calls shsgc. jdg must be at least nlon. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls shsgc. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls shsgc. ! ! a,b two or three dimensional arrays (see the input parameter ! nt) that contain the coefficients in the spherical harmonic ! expansion of g(i,j) given below at the definition of the ! output parameter g. ! ! wshsgc an array which must be initialized by subroutine shsgci. ! ! lshsgc the dimension of the array wshsgc as it appears in the ! program that calls shsgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls shsgc. ! ! ! ************************************************************** ! ! output parameters ! ! g a two or three dimensional array (see input parameter nt) ! that contains the discrete function which is synthesized. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idg ! = 6 error in the specification of jdg ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lwshig ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer mode integer idg integer jdg integer nt integer mdab integer ndab integer lshsgc integer lwork integer, intent(out)::ierror real, intent(out):: g(idg, jdg, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsgc(lshsgc) ! end subroutine shsgci(nlat,nlon,wshsgc,lshsgc,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shsgci initializes the array wshsgc which can then ! be used repeatedly by subroutines shsgc. it precomputes ! and stores in wshsgc quantities such as gaussian weights, ! legendre polynomial coefficients, and fft trigonometric tables. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! wshsgc an array which must be initialized by subroutine shsgci. ! ! lshsgc the dimension of the array wshsgc as it appears in the ! program that calls shsgc. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls shsgci. ! ! ! ************************************************************** ! ! output parameter ! ! wshsgc an array which must be initialized before calling shsgc. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshsgc ! = 4 error in the specification of ldwork ! = 5 failure in gaqd to compute gaussian points ! (due to failure in eigenvalue routine) ! ************************************************************************* ! integer nlat integer nlon integer lshsgc integer ldwork integer, intent(out)::ierror real, intent(out)::wshsgc(lshsgc) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine shsgs(nlat,nlon,mode,nt,g,idg,jdg,a,b,mdab,ndab,wshsgs,lshsgs,work,lwork,ierror) ! ************************************************************************** ! ! subroutine shsgs performs the spherical harmonic synthesis ! on the arrays a and b and stores the result in the array g. ! the synthesis is performed on an equally spaced longitude grid ! and a gaussian colatitude grid. the associated legendre functions ! are stored rather than recomputed as they are in subroutine ! shsgc. the synthesis is described below at output parameter ! g. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! mode = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idg the first dimension of the array g as it appears in the ! program that calls shagc. ! ! jdg the second dimension of the array g as it appears in the ! program that calls shagc. ! ! a,b two or three dimensional arrays (see the input parameter ! nt) that contain the coefficients in the spherical harmonic ! expansion of g(i,j) given below at the definition of the ! output parameter g. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls shsgs. mdab must be at least ! min0((nlon+2)/2,nlat) if nlon is even or at least ! min0((nlon+1)/2,nlat) if nlon is odd. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls shsgs. ndab must be at least nlat ! ! wshsgs an array which must be initialized by subroutine shsgsi. ! ! lshsgs the dimension of the array wshsgs as it appears in the ! program that calls shsgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls shsgs. ! ! ************************************************************** ! ! output parameters ! ! g a two or three dimensional array (see input parameter nt) ! that contains the discrete function which is synthesized. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of idg ! = 6 error in the specification of jdg ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lshsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer mode integer idg integer jdg integer nt integer mdab integer ndab integer lshsgs integer lwork integer, intent(out)::ierror real, intent(out):: g(idg, jdg, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsgs(lshsgs) ! end subroutine shsgsi(nlat,nlon,wshsgs,lshsgs,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine shsgsi initializes the array wshsgs which can then ! be used repeatedly by subroutines shsgs. it precomputes ! and stores in wshsgs quantities such as gaussian weights, ! legendre polynomial coefficients, and fft trigonometric tables. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! wshsgs an array which must be initialized by subroutine shsgsi. ! ! lshsgs the dimension of the array wshsgs as it appears in the ! program that calls shsgs. ! ! work a real work space which need not be saved ! ! lwork the dimension of the array work as it appears in the ! program that calls shsgsi. lwork must be at least ! 4*nlat*(nlat+2)+2 in the routine calling shsgsi ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the length of dwork in the calling routine. ! ! ************************************************************** ! ! output parameter ! ! wshsgs an array which must be initialized before calling shsgs. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lshsgs ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! = 5 failure in gaqd to compute gaussian points ! (due to failure in eigenvalue routine) ! ************************************************************************* ! integer nlat integer nlon integer lshsgs integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wshsgs(lshsgs) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine slapec(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,wshsec,lshsec,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shaec for a scalar field sf, subroutine slapec computes ! the laplacian of sf in the scalar array slap. slap(i,j) is the ! laplacian of sf at the colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. i.e. ! ! slap(i,j) = ! ! 2 2 ! [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint ! ! where sint = sin(theta(i)). the scalar laplacian in slap has the ! same symmetry or absence of symmetry about the equator as the scalar ! field sf. the input parameters isym,nt,mdab,ndab must have the ! same values used by shaec to compute a and b for sf. the associated ! legendre functions are recomputed rather than stored as they are ! in subroutine slapes. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym this parameter should have the same value input to subroutine ! shaec to compute the coefficients a and b for the scalar field ! sf. isym is set as follows: ! ! = 0 no symmetries exist in sf about the equator. scalar ! synthesis is used to compute slap on the entire sphere. ! ! nt the number of analyses. ! ! ids the first dimension of the array slap as it appears in the ! program that calls slapec. ! ! jds the second dimension of the array slap as it appears in the ! program that calls slapec. ! ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field sf as computed by subroutine shaec. ! a,b must be computed by shaec prior to calling slapec. ! ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls slapec. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls slapec. ! ! ! wshsec an array which must be initialized by subroutine shseci ! before calling slapec. ! ! lshsec the dimension of the array wshsec as it appears in the ! program that calls slapec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls slapec. ! ! ************************************************************** ! ! output parameters ! ! ! slap a two or three dimensional arrays (see input parameter nt) that ! contain the scalar laplacian of the scalar field sf. ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of ids ! = 6 error in the specification of jds ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lshsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer ids integer jds integer nt integer mdab integer ndab integer lshsec integer lwork integer, intent(out)::ierror real, intent(out):: slap(ids, jds, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsec(lshsec) ! end subroutine slapes(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,wshses,lshses,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shaes for a scalar field sf, subroutine slapes computes ! the laplacian of sf in the scalar array slap. slap(i,j) is the ! laplacian of sf at the colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. i.e. ! ! slap(i,j) = ! ! [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint ! ! where sint = sin(theta(i)). the scalar laplacian in slap has the ! same symmetry or absence of symmetry about the equator as the scalar ! field sf. the input parameters isym,nt,mdab,ndab must have the ! same values used by shaes to compute a and b for sf. the associated ! legendre functions are stored rather than recomputed as they are ! in subroutine slapec. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym this parameter should have the same value input to subroutine ! shaes to compute the coefficients a and b for the scalar field ! sf. isym is set as follows: ! ! = 0 no symmetries exist in sf about the equator. scalar ! synthesis is used to compute slap on the entire sphere. ! ! nt the number of analyses. ! ! ids the first dimension of the array slap as it appears in the ! program that calls slapes. ! ! jds the second dimension of the array slap as it appears in the ! program that calls slapes. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field sf as computed by subroutine shaes. ! a,b must be computed by shaes prior to calling slapes. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls slapes. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls slapes. ! ! wshses an array which must be initialized by subroutine shsesi ! before calling slapes. ! ! lshses the dimension of the array wshses as it appears in the ! program that calls slapes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls slapes. ! ! ************************************************************** ! ! output parameters ! ! slap a two or three dimensional arrays (see input parameter nt) that ! contain the scalar laplacian of the scalar field sf. ! is the scalar laplacian at the colatitude ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of ids ! = 6 error in the specification of jds ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lshses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer ids integer jds integer nt integer mdab integer ndab integer lshses integer lwork integer, intent(out)::ierror real, intent(out):: slap(ids, jds, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshses(lshses) ! end subroutine slapgc(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,wshsgc,lshsgc,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shagc for a scalar field sf, subroutine slapgc computes ! the laplacian of sf in the scalar array slap. slap(i,j) is the ! laplacian of sf at the gaussian colatitude theta(i) (see nlat as ! an input parameter) and east longitude lambda(j) = (j-1)*2*pi/nlon ! on the sphere. i.e. ! ! slap(i,j) = ! 2 2 ! [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint ! ! where sint = sin(theta(i)). the scalar laplacian in slap has the ! same symmetry or absence of symmetry about the equator as the scalar ! field sf. the input parameters isym,nt,mdab,ndab must have the ! same values used by shagc to compute a and b for sf. the associated ! legendre functions are stored rather than recomputed as they are ! in subroutine slapgc. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! ! isym this parameter should have the same value input to subroutine ! shagc to compute the coefficients a and b for the scalar field ! sf. isym is set as follows: ! ! = 0 no symmetries exist in sf about the equator. scalar ! synthesis is used to compute slap on the entire sphere. ! ! nt the number of analyses. ! ! ids the first dimension of the array slap as it appears in the ! program that calls slapgc. ! ! jds the second dimension of the array slap as it appears in the ! program that calls slapgc. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field sf as computed by subroutine shagc. ! a,b must be computed by shagc prior to calling slapgc. ! ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls slapgc. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls slapgc. ! ! mdab,ndab should have the same values input to shagc to ! compute the coefficients a and b. ! ! wshsgc an array which must be initialized by subroutine shsgci. ! ! lshsgc the dimension of the array wshsgc as it appears in the ! program that calls slapgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls slapgc. ! ! ************************************************************** ! ! output parameters ! ! slap a two or three dimensional arrays (see input parameter nt) that ! contain the scalar laplacian of the scalar field sf. ! !ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of ids ! = 6 error in the specification of jds ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lshsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer ids integer jds integer nt integer mdab integer ndab integer lshsgc integer lwork integer, intent(out)::ierror real, intent(out):: slap(ids, jds, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsgc(lshsgc) ! end subroutine slapgs(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,wshsgs,lshsgs,work,lwork,ierror) ! ************************************************************************** ! ! given the scalar spherical harmonic coefficients a and b, precomputed ! by subroutine shags for a scalar field sf, subroutine slapgs computes ! the laplacian of sf in the scalar array slap. slap(i,j) is the ! laplacian of sf at the gaussian colatitude theta(i) (see nlat as ! an input parameter) and east longitude lambda(j) = (j-1)*2*pi/nlon ! on the sphere. i.e. ! ! slap(i,j) = ! 2 2 ! [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint ! ! where sint = sin(theta(i)). the scalar laplacian in slap has the ! same symmetry or absence of symmetry about the equator as the scalar ! field sf. the input parameters isym,nt,mdab,ndab must have the ! same values used by shags to compute a and b for sf. the associated ! legendre functions are stored rather than recomputed as they are ! in subroutine slapgc. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym this parameter should have the same value input to subroutine ! shags to compute the coefficients a and b for the scalar field ! sf. isym is set as follows: ! ! = 0 no symmetries exist in sf about the equator. scalar ! synthesis is used to compute slap on the entire sphere. ! ! nt the number of analyses. ! ! ids the first dimension of the array slap as it appears in the ! program that calls slapgs. ! ! jds the second dimension of the array slap as it appears in the ! program that calls slapgs. ! ! a,b two or three dimensional arrays (see input parameter nt) ! that contain scalar spherical harmonic coefficients ! of the scalar field sf as computed by subroutine shags. ! a,b must be computed by shags prior to calling slapgs. ! ! mdab the first dimension of the arrays a and b as it appears ! in the program that calls slapgs. ! ! ndab the second dimension of the arrays a and b as it appears ! in the program that calls slapgs. ! ! wshsgs an array which must be initialized by subroutine slapgsi ! (or equivalently by shsgsi). ! ! lshsgs the dimension of the array wshsgs as it appears in the ! program that calls slapgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls slapgs. ! ! ************************************************************** ! ! output parameters ! ! slap a two or three dimensional arrays (see input parameter nt) that ! contain the scalar laplacian of the scalar field sf. ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of ids ! = 6 error in the specification of jds ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lshsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer ids integer jds integer nt integer mdab integer ndab integer lshsgs integer lwork integer, intent(out)::ierror real, intent(out):: slap(ids, jds, nt) real, intent(temporary):: work(lwork) real a(mdab, ndab, nt) real b(mdab, ndab, nt) real wshsgs(lshsgs) ! end subroutine trssph(intl,igrida,nlona,nlata,da,igridb,nlonb,nlatb,db,wsave,lsave,lsvmin,work,lwork,lwkmin,dwork,ldwork,ier) ! ************************************************************************** ! ! subroutine trssph transfers data given in array da on a grid on the ! full sphere to data in array db on a grid on the full sphere. the ! grids on which da is given and db is generated can be specified ! independently of each other (see description below and the arguments ! igrida,igridb). for transferring vector data on the sphere, use ! subroutine trvsph. ! ! notice that scalar and vector quantities are fundamentally different ! on the sphere. for example, vectors are discontinuous and multiple ! valued at the poles. scalars are continuous and single valued at the ! poles. erroneous results would be produced if one attempted to transfer ! vector fields between grids with subroutine trssph applied to each ! component of the vector. ! ! ************************************************************** ! ! input arguments ! ! intl an initialization argument which should be zero on an initial call to ! trssph. ! ! igrida an integer vector dimensioned two which identifies the underlying grid ! on the full sphere for the given data array da as follows: ! ! igrida(1) ! ! = -1 if the latitude (or colatitude) grid for da is an equally spaced ! partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which ! runs north to south ! ! = +1 if the latitude (or colatitude) grid for da is an equally spaced ! partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which ! runs south to north ! ! = -2 if the latitude (or colatitude) grid for da is a gaussian partition ! of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north ! to south ! ! = +2 if the latitude (or colatitude) grid for da is a gaussian partition ! of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south ! north ! igrida(2) ! ! = 0 if the underlying grid for da is a nlona by nlata ! ! = 1 if the underlying grid for da is a nlata by nlona ! ! ! nlona the number of longitude points on the uniform grid which partitions ! [0,2pi) for the given data array da. ! ! nlata the number of points in the latitude (or colatitude) grid ! for the given data array da. ! ! da a two dimensional array that contains the data to be transferred. ! ! igridb an integer vector dimensioned two which identifies the underlying grid ! on the full sphere for the transformed data array db as follows: ! ! igridb(1) ! ! = -1 if the latitude (or colatitude) grid for db is an equally spaced ! partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which ! north to south ! ! = +1 if the latitude (or colatitude) grid for db is an equally spaced ! partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which ! south to north ! ! = -2 if the latitude (or colatitude) grid for db is a gaussian partition ! of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north to ! south ! ! = +2 if the latitude (or colatitude) grid for db is a gaussian partition ! of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south to ! north ! igridb(2) ! ! = 0 if the underlying grid for db is a nlonb by nlatb ! ! = 1 if the underlying grid for db is a nlatb by nlonb ! ! ! nlonb the number of longitude points on the uniform grid which partitions ! [0,2pi) for the transformed data array db. ! ! nlatb the number of points in the latitude (or colatitude) grid ! for the transformed data array db. ! ! wsave a saved work space array that can be utilized repeatedly by trssph ! as long as the arguments nlata,nlona,nlatb,nlonb remain unchanged. ! ! lsave the dimension of the work space wsave as it appears in the program ! that calls trssph. ! ! work a real work array that does not have to be preserved ! ! lwork the dimension of the array work as it appears in the program ! calling trssph. ! ! dwork a doubleprecision work array that does not have to be preserved. ! ! ldwork the length of dwork in the routine calling trssph. ! ! ************************************************************** ! ! output arguments ! ! db a two dimensional array that contains the transformed data. ! ! lsvmin the minimum length of the saved work space in wsave. ! ! lwkmin the minimum length of the unsaved work space in work. ! ! ier = 0 if no errors are detected ! = 1 if intl is not 0 or 1 ! = 2 if igrida(1) is not -1 or +1 or -2 or +2 ! = 3 if igrida(2) is not 0 or 1 ! = 4 if nlona is less than 4 ! = 5 if nlata is less than 3 ! = 6 if igridb(1) is not -1 or +1 or -2 or +2 ! = 7 if igridb(2) is not 0 or 1 ! = 8 if nlonb is less than 4 ! = 9 if nlatb is less than 3 ! =10 if there is insufficient saved work space (lsave < lsvmin) ! =11 if there is insufficient unsaved work space (lwork < lwkmin) ! =12 indicates failure in an eigenvalue routine which computes ! gaussian weights and points ! =13 if ldwork is too small (insufficient unsaved doubleprecision ! work space) ! ************************************************************************* ! integer intl integer nlona integer nlata integer nlonb integer nlatb integer lsave integer lwork integer ldwork integer igrida(2) integer igridb(2) integer, intent(out)::ier integer, intent(out)::lsvmin integer, intent(out)::lwkmin real, intent(out)::db(nlatb, nlonb) real, intent(inout):: wsave(lsave) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) real da(nlata, nlona) ! end subroutine trvsph (intl,igrida,nlona,nlata,iveca,ua,va,igridb,nlonb,nlatb,ivecb,ub,vb,wsave,lsave,lsvmin,work,lwork,lwkmin,dwork,ldwork,ier) ! ************************************************************************** ! ! subroutine trvsph transfers vector data given in (ua,va) on a grid on ! the full sphere to vector data in (ub,vb) on a grid on the full sphere. ! the grids on which (ua,va) is given and (ub,vb) is generated can be ! specified independently of each other (see the input arguments igrida, ! igridb,iveca,ivecb). ua and ub are the east longitudinal components of ! the given and transformed vector fields. va is either the latitudinal ! or colatitudinal component of the given vector field (see iveca). ! vb is either the latitudinal or colatitudinal component of the ! transformed vector field (see ivecb). for transferring scalar data ! on the sphere, use subroutine trssph. ! ! notice that scalar and vector quantities are fundamentally different ! on the sphere. for example, vectors are discontinuous and multiple ! valued at the poles. scalars are continuous and single valued at the ! poles. erroneous results would be produced if one attempted to transfer ! vector fields between grids with subroutine trssph applied to each ! component of the vector. ! ! ************************************************************** ! ! input arguments ! ! intl an initialization argument which should be zero on an initial call to ! trvsph. ! ! igrida an integer vector dimensioned two which identifies the underlying grid ! on the full sphere for the given vector data (ua,va) as follows: ! ! igrida(1) ! ! = -1 if the latitude (or colatitude) grid for ua,va is an equally spaced ! partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which ! runs north to south with increasing subscript value ! ! = +1 if the latitude (or colatitude) grid for ua,va is an equally spaced ! partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which ! runs south to north with increasing subscript value ! ! = -2 if the latitude (or colatitude) grid for ua,va is a gaussian partition ! of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north ! to south with increasing subscript value ! ! = +2 if the latitude (or colatitude) grid for ua,va is a gaussian partition ! of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south ! north with increasing subscript value ! igrida(2) ! ! = 0 if the underlying grid for ua,va is a nlona by nlata ! ! = 1 if the underlying grid for ua,va is a nlata by nlona ! ! nlona the number of longitude points on the uniform grid which partitions ! [0,2pi) for the given vector (ua,va). ! ! nlata the number of points in the latitude (or colatitude) grid for the ! given vector (ua,va). ! ! iveca if iveca=0 is input then va is the latitudinal component of the ! given vector field. if iveca=1 then va is the colatitudinal ! compoenent of the given vector field. ! ! ua ua is the east longitudinal component of the given vector field. ! ! va va is either the latitudinal or colatitudinal componenet of the ! given vector field (see iveca). ! ! igridb an integer vector dimensioned two which identifies the underlying grid ! on the full sphere for the transformed vector (ub,vb) as follows: ! ! igridb(1) ! ! = -1 if the latitude (or colatitude) grid for ub,vb is an equally spaced ! partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which ! north to south ! ! = +1 if the latitude (or colatitude) grid for ub,vb is an equally spaced ! partition of [-pi/2,pi/2] ( or [0,pi] ) including the poles which ! south to north ! ! = -2 if the latitude (or colatitude) grid for ub,vb is a gaussian partition ! of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs north to ! south ! ! = +2 ! if the latitude (or colatitude) grid for ub,vb is a gaussian partition ! of (-pi/2,pi/2) ( or (0,pi) ) excluding the poles which runs south to ! north ! igridb(2) ! ! = 0 if the underlying grid for ub,vb is a nlonb by nlatb ! ! = 1 if the underlying grid for ub,vb is a nlatb by nlonb ! ! nlonb the number of longitude points on the uniform grid which partitions ! [0,2pi) for the transformed vector (ub,vb). ! ! nlatb the number of points in the latitude (or colatitude) grid for the ! transformed vector (ub,vb). ! ! ivecb if ivecb=0 is input then vb is the latitudinal component of the ! given vector field. if ivecb=1 then vb is the colatitudinal ! component of the given vector field. ! ! wsave a saved work space array that can be utilized repeatedly by trvsph ! as long as the arguments nlata,nlona,nlatb,nlonb remain unchanged. ! ! lsave the dimension of the work space wsave as it appears in the program ! that calls trvsph. ! ! work a work array that does not have to be preserved ! ! lwork the dimension of the array work as it appears in the program that ! calls trvsph. ! ! dwork a doubleprecision work array that does not have to be preserved. ! ! ldwork the length of dwork in the routine calling trvsph ! ! ************************************************************** ! ! output arguments ! ! ub a two dimensional array that contains the east longitudinal component ! of the transformed vector data. ! ! vb a two dimensional array that contains the latitudinal or colatitudinal ! component of the transformed vector data (see ivecb). ! ! lsvmin the minimum length of the saved work space in wsave. ! lsvmin is computed even if lsave < lsvmin (ier = 10). ! ! lwkmin the minimum length of the unsaved work space in work. ! lwkmin is computed even if lwork < lwkmin (ier = 11). ! ! ier = 0 if no errors are detected ! = 1 if intl is not 0 or 1 ! = 2 if igrida(1) is not -1 or +1 or -2 or +2 ! = 3 if igrida(2) is not 0 or 1 ! = 4 if nlona is less than 4 ! = 5 if nlata is less than 3 ! = 6 if iveca is not 0 or 1 ! = 7 if igridb(1) is not -1 or +1 or -2 or +2 ! = 8 if igridb(2) is not 0 or 1 ! = 9 if nlonb is less than 4 ! =10 if nlatb is less than 3 ! =11 if ivecb is not 0 or 1 ! =12 if there is insufficient saved work space (lsave < lsvmin) ! =13 if there is insufficient unsaved work space (lwork < lwkmin) ! =14 indicates failure in an eigenvalue routine which computes ! gaussian weights and points ! =15 if ldwork is too small (insufficient doubleprecision ! unsaved work space) ! ************************************************************************* ! integer intl integer nlona integer nlata integer iveca integer nlonb integer nlatb integer ivecb integer lsave integer lwork integer ldwork integer igrida(2) integer igridb(2) integer, intent(out)::ier integer, intent(out)::lsvmin integer, intent(out)::lwkmin real, intent(temporary):: work(lwork) real, intent(out)::ub(nlatb, nlonb) real, intent(out)::vb(nlatb, nlonb) real, intent(inout):: wsave(lsave) doubleprecision, intent(temporary):: dwork(ldwork) real ua(nlata, nlona) real va(nlata, nlona) ! end subroutine vhaec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvhaec,lvhaec,work,lwork,ierror) ! ************************************************************************** ! ! subroutine vhaec performs the vector spherical harmonic analysis ! on the vector field (v,w) and stores the result in the arrays ! br, bi, cr, and ci. v(i,j) and w(i,j) are the colatitudinal ! (measured from the north pole) and east longitudinal components ! respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1) ! and longitude phi(j) = (j-1)*2*pi/nlon. the spectral ! representation of (v,w) is given at output parameters v,w in ! subroutine vhsec. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. ! ! nt the number of analyses. ! ! v,w two or three dimensional arrays (see input parameter nt) ! that contain the vector function to be analyzed. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls vhaec. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls vhaec. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhaec. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhaec. ! ! wvhaec an array which must be initialized by subroutine vhaeci. ! ! lvhaec the dimension of the array wvhaec as it appears in the ! program that calls vhaec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhaec. ! ! ************************************************************** ! ! output parameters ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! in the spectral representation of v(i,j) and w(i,j) given ! in the discription of subroutine vhsec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhaec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhaec integer lwork integer, intent(out)::ierror real, intent(out)::br(mdab, ndab, nt) real, intent(out)::bi(mdab, ndab, nt) real, intent(out)::cr(mdab, ndab, nt) real, intent(out)::ci(mdab, ndab, nt) real, intent(temporary):: work(lwork) real v(idvw, jdvw, nt) real w(idvw, jdvw, nt) real wvhaec(lvhaec) ! end subroutine vhaeci(nlat,nlon,wvhaec,lvhaec,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vhaeci initializes the array wvhaec which can then be ! used repeatedly by subroutine vhaec until nlat or nlon is changed. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! nlon the number of distinct londitude points. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls vhaec. ! ! ************************************************************** ! ! output parameters ! ! wvhaec an array which is initialized for use by subroutine vhaec. ! once initialized, wvhaec can be used repeatedly by vhaec ! as long as nlat or nlon remain unchanged. wvhaec must not ! be altered between calls of vhaec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lvhaec ! = 4 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lvhaec integer ldwork integer, intent(out)::ierror real, intent(out)::wvhaec(lvhaec) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vhaes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvhaes,lvhaes,work,lwork,ierror) ! ************************************************************************** ! ! subroutine vhaes performs the vector spherical harmonic analysis ! on the vector field (v,w) and stores the result in the arrays ! br, bi, cr, and ci. v(i,j) and w(i,j) are the colatitudinal ! (measured from the north pole) and east longitudinal components ! respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1) ! and longitude phi(j) = (j-1)*2*pi/nlon. the spectral ! representation of (v,w) is given at output parameters v,w in ! subroutine vhses. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! ityp = 0 no symmetries exist about the equator. the analysis ! is performed on the entire sphere. ! ! nt the number of analyses. ! ! v,w two or three dimensional arrays (see input parameter nt) ! that contain the vector function to be analyzed. ! v is the colatitudnal component and w is the east ! longitudinal component. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls vhaes. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls vhaes. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhaes. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhaes. ! lvhaes an array which must be initialized by subroutine vhaesi. ! ! lvhaes the dimension of the array wvhaes as it appears in the ! program that calls vhaes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhaes. ! ! ************************************************************** ! ! output parameters ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! in the spectral representation of v(i,j) and w(i,j) given ! in the discription of subroutine vhses. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhaes ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhaes integer lwork integer, intent(out)::ierror real, intent(out)::br(mdab, ndab, nt) real, intent(out)::bi(mdab, ndab, nt) real, intent(out)::cr(mdab, ndab, nt) real, intent(out)::ci(mdab, ndab, nt) real, intent(temporary):: work(lwork) real v(idvw, jdvw, nt) real w(idvw, jdvw, nt) real wvhaes(lvhaes) ! end subroutine vhaesi(nlat,nlon,wvhaes,lvhaes,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vhaesi initializes the array wvhaes which can then be ! used repeatedly by subroutine vhaes until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! lvhaes the dimension of the array wvhaes as it appears in the ! program that calls vhaes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhaes. ! ! dwork an unsaved doubleprecision work space ! ! ldwork the length of the array dwork as it appears in the ! program that calls vhaesi. ! ! ************************************************************** ! ! output parameters ! ! wvhaes an array which is initialized for use by subroutine vhaes. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lvhaes ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lvhaes integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wvhaes(lvhaes) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vhagc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvhagc,lvhagc,work,lwork,ierror) ! ************************************************************************** ! ! subroutine vhagc performs the vector spherical harmonic analysis ! on the vector field (v,w) and stores the result in the arrays ! br,bi,cr, and ci. v(i,j) and w(i,j) are the colatitudinal ! (measured from the north pole) and east longitudinal components ! respectively, located at the gaussian colatitude point theta(i) ! and longitude phi(j) = (j-1)*2*pi/nlon. the spectral ! representation of (v,w) is given at output parameters v,w in ! subroutine vhsec. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. the analysis ! is performed on the entire sphere. ! ! nt the number of analyses. ! ! v,w two or three dimensional arrays (see input parameter nt) ! that contain the vector function to be analyzed. ! the program that calls vhagc. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls vhagc. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhagc. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhagc. ! ! wvhagc an array which must be initialized by subroutine vhagci. ! ! lvhagc the dimension of the array wvhagc as it appears in the ! program that calls vhagc. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhagc. ! ! ************************************************************** ! ! output parameters ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! in the spectral representation of v(i,j) and w(i,j) given ! in the discription of subroutine vhsec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhagc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhagc integer lwork integer, intent(out)::ierror real, intent(out)::br(mdab, ndab, nt) real, intent(out)::bi(mdab, ndab, nt) real, intent(out)::cr(mdab, ndab, nt) real, intent(out)::ci(mdab, ndab, nt) real, intent(temporary):: work(lwork) real v(idvw, jdvw, nt) real w(idvw, jdvw, nt) real wvhagc(lvhagc) ! end subroutine vhagci(nlat,nlon,wvhagc,lvhagc,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vhagci initializes the array wvhagc which can then be ! used repeatedly by subroutine vhagc until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! lvhagc the dimension of the array wvhagc as it appears in the ! program that calls vhagci. ! ! dwork a doubleprecision work array that does not need to be saved ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls vhagci. ! ! ************************************************************** ! ! output parameters ! ! wvhagc an array which is initialized for use by subroutine vhagc. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lvhagc ! = 4 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer lvhagc integer ldwork integer, intent(out)::ierror real, intent(out)::wvhagc(lvhagc) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vhags(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvhags,lvhags,work,lwork,ierror) ! ************************************************************************** ! ! subroutine vhags performs the vector spherical harmonic analysis ! on the vector field (v,w) and stores the result in the arrays ! br, bi, cr, and ci. v(i,j) and w(i,j) are the colatitudinal ! (measured from the north pole) and east longitudinal components ! respectively, located at the gaussian colatitude point theta(i) ! and longitude phi(j) = (j-1)*2*pi/nlon. the spectral ! representation of (v,w) is given at output parameters v,w in ! subroutine vhses. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct londitude points. ! ! ityp = 0 no symmetries exist about the equator. the analysis ! is performed on the entire sphere. ! ! nt the number of analyses. ! ! v,w two or three dimensional arrays (see input parameter nt) ! that contain the vector function to be analyzed. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls vhags. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls vhags. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhags. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhags. ! ! wvhags an array which must be initialized by subroutine vhgsi. ! ! lvhags the dimension of the array wvhags as it appears in the ! program that calls vhags. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhags. ! ! ************************************************************** ! ! output parameters ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! in the spectral representation of v(i,j) and w(i,j) given ! in the discription of subroutine vhses. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhags ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhags integer lwork integer, intent(out)::ierror real, intent(out)::br(mdab, ndab, nt) real, intent(out)::bi(mdab, ndab, nt) real, intent(out)::cr(mdab, ndab, nt) real, intent(out)::ci(mdab, ndab, nt) real, intent(temporary):: work(lwork) real v(idvw, jdvw, nt) real w(idvw, jdvw, nt) real wvhags(lvhags) ! end subroutine vhagsi(nlat,nlon,wvhags,lvhags,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vhagsi initializes the array wvhags which can then be ! used repeatedly by subroutine vhags until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! lvhags the dimension of the array wvhags as it appears in the ! program that calls vhagsi. ! ! dwork a doubleprecision work space that does not need to be saved ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls vhagsi. ! ! ************************************************************** ! ! output parameters ! ! wvhags an array which is initialized for use by subroutine vhags. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lvhags ! = 4 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lvhags integer ldwork integer, intent(out)::ierror real, intent(out)::wvhags(lvhags) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvhsec,lvhsec,work,lwork,ierror) ! ************************************************************************** ! ! subroutine vhsec performs the vector spherical harmonic synthesis ! of the arrays br, bi, cr, and ci and stores the result in the ! arrays v and w. v(i,j) and w(i,j) are the colatitudinal ! (measured from the north pole) and east longitudinal components ! respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1) ! and longitude phi(j) = (j-1)*2*pi/nlon. the spectral ! representation of (v,w) is given below at output parameters v,w. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls vhsec. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls vhsec. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! in the spectral representation of v(i,j) and w(i,j) given ! below at the discription of output parameters v and w. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhsec. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhsec. ! ! wvhsec an array which must be initialized by subroutine vhseci. ! ! lvhsec the dimension of the array wvhsec as it appears in the ! program that calls vhsec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhsec. ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) ! in which the synthesis is stored. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhsec integer lwork integer, intent(out)::ierror real, intent(out):: v(idvw, jdvw, nt) real, intent(out):: w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdab, ndab, nt) real bi(mdab, ndab, nt) real cr(mdab, ndab, nt) real ci(mdab, ndab, nt) real wvhsec(lvhsec) ! end subroutine vhseci(nlat,nlon,wvhsec,lvhsec,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vhseci initializes the array wvhsec which can then be ! used repeatedly by subroutine vhsec until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! lvhsec the dimension of the array wvhsec as it appears in the ! program that calls vhsec. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls vhsec. ! ! ************************************************************** ! ! output parameters ! ! wvhsec an array which is initialized for use by subroutine vhsec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lvhsec ! = 4 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lvhsec integer ldwork integer, intent(out)::ierror real, intent(out)::wvhsec(lvhsec) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvhses,lvhses,work,lwork,ierror) ! ************************************************************************** ! ! subroutine vhses performs the vector spherical harmonic synthesis ! of the arrays br, bi, cr, and ci and stores the result in the ! arrays v and w. v(i,j) and w(i,j) are the colatitudinal ! (measured from the north pole) and east longitudinal components ! respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1) ! and longitude phi(j) = (j-1)*2*pi/nlon. the spectral ! representation of (v,w) is given below at output parameters v,w. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls vhaes. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls vhses. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! in the spectral representation of v(i,j) and w(i,j) given ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls vhses. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhses. ! ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) ! in which the synthesis is stored. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhses integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdab, ndab, nt) real bi(mdab, ndab, nt) real cr(mdab, ndab, nt) real ci(mdab, ndab, nt) real wvhses(lvhses) ! end subroutine vhsesi(nlat,nlon,wvhses,lvhses,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! ! subroutine vhsesi initializes the array wvhses which can then be ! used repeatedly by subroutine vhses until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls vhses. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhses. ! ! dwork an unsaved doubleprecision work space ! ! ldwork the length of the array dwork as it appears in the ! program that calls vhsesi. ! ! ************************************************************** ! ! output parameters ! ! wvhses an array which is initialized for use by subroutine vhses. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lvhses ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lvhses integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wvhses(lvhses) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vhsgc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvhsgc,lvhsgc,work,lwork,ierror) ! ************************************************************************** ! ! ! subroutine vhsgc performs the vector spherical harmonic synthesis ! of the arrays br, bi, cr, and ci and stores the result in the ! arrays v and w. v(i,j) and w(i,j) are the colatitudinal ! (measured from the north pole) and east longitudinal components ! respectively, located at the gaussian colatitude point theta(i) ! and longitude phi(j) = (j-1)*2*pi/nlon. the spectral ! representation of (v,w) is given below at output parameters v,w. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls vhsgc. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls vhsgc. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! in the spectral representation of v(i,j) and w(i,j) given ! below at the discription of output parameters v and w. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhsgc. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhsgc. ! ! wvhsgc an array which must be initialized by subroutine vhsgci. ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls vhsgc. ! ! work a work array that does not have to be saved. ! program that calls vhsgc. ! lwork the dimension of the array work as it appears in the ! ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) ! in which the synthesis is stored. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhsgc integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdab, ndab, nt) real bi(mdab, ndab, nt) real cr(mdab, ndab, nt) real ci(mdab, ndab, nt) real wvhsgc(lvhsgc) ! end subroutine vhsgci(nlat,nlon,wvhsgc,lvhsgc,dwork,ldwork,ierror) ! ! subroutine vhsgci initializes the array wvhsgc which can then be ! used repeatedly by subroutine vhsgc until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls vhsgc. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls vhsgsi. ! ! ************************************************************** ! ! output parameters ! ! wvhsgc an array which is initialized for use by subroutine vhsgc. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lvhsgc ! = 4 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lvhsgc integer ldwork integer, intent(out)::ierror real, intent(out)::wvhsgc(lvhsgc) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vhsgs(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvhsgs,lvhsgs,work,lwork,ierror) ! ! subroutine vhsgci initializes the array wvhsgc which can then be ! ! subroutine vhsgs performs the vector spherical harmonic synthesis ! of the arrays br, bi, cr, and ci and stores the result in the ! arrays v and w. the synthesis is performed on an equally spaced ! longitude grid and a gaussian colatitude grid (measured from ! the north pole). v(i,j) and w(i,j) are the colatitudinal and ! east longitudinal components respectively, located at the i(th) ! colatitude gaussian point (see nlat below) and longitude ! phi(j) = (j-1)*2*pi/nlon. the spectral respresentation of (v,w) ! is given below at output parameters v,w. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idvw the first dimension of the arrays v,w as it appears in ! the program that calls vhags. ! ! jdvw the second dimension of the arrays v,w as it appears in ! the program that calls vhsgs. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! in the spectral representation of v(i,j) and w(i,j) given ! below at the discription of output parameters v and w. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhsgs. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vhsgs. ! ! wvhsgs an array which must be initialized by subroutine vhsgsi. ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls vhsgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vhsgs. ! ! ! ************************************************************** ! ! output parameters ! ! v,w two or three dimensional arrays (see input parameter nt) ! in which the synthesis is stored. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lvhsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdab integer ndab integer lvhsgs integer lwork integer, intent(out)::ierror real, intent(out)::v(idvw, jdvw, nt) real, intent(out)::w(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdab, ndab, nt) real bi(mdab, ndab, nt) real cr(mdab, ndab, nt) real ci(mdab, ndab, nt) real wvhsgs(lvhsgs) ! end subroutine vhsgsi(nlat,nlon,wvhsgs,lvhsgs,dwork,ldwork,ierror) ! ! subroutine vhsgci initializes the array wvhsgc which can then be ! subroutine vhsgsi initializes the array wvhsgs which can then be ! used repeatedly by subroutine vhsgs until nlat or nlon is changed. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! nlon the number of distinct longitude points. ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls vhsgs. ! ! dwork a doubleprecision work array that does not need to be saved ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls vhsgsi. ! ! ! ************************************************************** ! ! output parameters ! ! wvhsgs an array which is initialized for use by subroutine vhsgs. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lvhsgs ! = 4 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer lvhsgs integer ldwork integer, intent(out)::ierror real, intent(out)::wvhsgs(lvhsgs) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vlapec(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci,mdbc,ndbc,wvhsec,lvhsec,work,lwork,ierror) ! ! subroutine vhsgci initializes the array wvhsgc which can then be ! subroutine vlapec computes the vector laplacian of the vector field ! (v,w) in (vlap,wlap) (see the definition of the vector laplacian at ! the output parameter description of vlap,wlap below). w and wlap ! are east longitudinal components of the vectors. v and vlap are ! colatitudinal components of the vectors. br,bi,cr, and ci are the ! vector harmonic coefficients of (v,w). these must be precomputed by ! vhaec and are input parameters to vlapec. the laplacian components ! in (vlap,wlap) have the same symmetry or lack of symmetry about the ! equator as (v,w). the input parameters ityp,nt,mdbc,nbdc must have ! the same values used by vhaec to compute br,bi,cr, and ci for (v,w). ! vlap(i,j) and wlap(i,j) are given on the sphere at the colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! for i=1,...,nlat and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! for j=1,...,nlon. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ityp this parameter should have the same value input to subroutine ! vhaec to compute the coefficients br,bi,cr, and ci for the ! vector field (v,w). ityp is set as follows: ! ! = 0 no symmetries exist in (v,w) about the equator. (vlap,wlap) ! is computed and stored on the entire sphere. ! ! nt nt is the number of vector fields (v,w). ! ! idvw the first dimension of the arrays vlap and wlap as it appears ! in the program that calls vlapec. ! ! jdvw the second dimension of the arrays vlap and wlap as it appears ! in the program that calls vlapec. ! ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaec. ! br,bi,cr and ci must be computed by vhaec prior to calling ! vlapec. ! ! mdbc the first dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls vlapec. ! ! ndbc the second dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls vlapec. ! ! wvhsec an array which must be initialized by subroutine vhseci. ! of vlapec. ! ! lvhsec the dimension of the array wvhsec as it appears in the ! program that calls vlapec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vlapec. ! ! ************************************************************** ! ! output parameters ! ! ! vlap, two or three dimensional arrays (see input parameter nt) that ! wlap contain the vector laplacian of the field (v,w). ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lvhsec ! = 10 error in the specification of lwork (lwork < lwkmin) ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdbc integer ndbc integer lvhsec integer lwork integer, intent(out)::ierror real, intent(out)::vlap(idvw, jdvw, nt) real, intent(out)::wlap(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdbc, ndbc, nt) real bi(mdbc, ndbc, nt) real cr(mdbc, ndbc, nt) real ci(mdbc, ndbc, nt) real wvhsec(lvhsec) ! end subroutine vlapes(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci,mdbc,ndbc,wvhses,lvhses,work,lwork,ierror) ! ! subroutine vlapes computes the vector laplacian of the vector field ! (v,w) in (vlap,wlap) (see the definition of the vector laplacian at ! the output parameter description of vlap,wlap below). w and wlap ! are east longitudinal components of the vectors. v and vlap are ! colatitudinal components of the vectors. br,bi,cr, and ci are the ! vector harmonic coefficients of (v,w). these must be precomputed by ! vhaes and are input parameters to vlapes. the laplacian components ! in (vlap,wlap) have the same symmetry or lack of symmetry about the ! equator as (v,w). the input parameters ityp,nt,mdbc,nbdc must have ! the same values used by vhaes to compute br,bi,cr, and ci for (v,w). ! vlap(i,j) and wlap(i,j) are given on the sphere at the colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! for i=1,...,nlat and east longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! for j=1,...,nlon. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ityp this parameter should have the same value input to subroutine ! vhaes to compute the coefficients br,bi,cr, and ci for the ! vector field (v,w). ityp is set as follows: ! ! = 0 no symmetries exist in (v,w) about the equator. (vlap,wlap) ! is computed and stored on the entire sphere. ! ! nt nt is the number of vector fields (v,w). ! !idvw the first dimension of the arrays vlap and wlap as it appears ! in the program that calls vlapes. ! !jdvw the second dimension of the arrays vlap and wlap as it appears ! in the program that calls vlapes. ! !br,bi two or three dimensional arrays (see input parameter nt) !cr,ci that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaes. ! br,bi,cr and ci must be computed by vhaes prior to calling ! vlapes. ! ! mdbc the first dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls vlapes. ! ! ndbc the second dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls vlapes. ! ! wvhses an array which must be initialized by subroutine vhsesi. ! ! lvhses the dimension of the array wvhses as it appears in the ! program that calls vlapes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vlapes. ! ! ************************************************************** ! ! output parameters ! ! vlap, two or three dimensional arrays (see input parameter nt) that ! wlap contain the vector laplacian of the field (v,w). ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lvhses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdbc integer ndbc integer lvhses integer lwork integer, intent(out)::ierror real, intent(out)::vlap(idvw, jdvw, nt) real, intent(out)::wlap(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdbc, ndbc, nt) real bi(mdbc, ndbc, nt) real cr(mdbc, ndbc, nt) real ci(mdbc, ndbc, nt) real wvhses(lvhses) ! end subroutine vlapgc(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci,mdbc,ndbc,wvhsgc,lvhsgc,work,lwork,ierror) ! ! subroutine vlapes computes the vector laplacian of the vector field ! given the vector spherical harmonic coefficients (br,bi,cr,ci) ! precomputed by subroutine vhagc for a vector field (v,w), subroutine ! vlapgc computes the vector laplacian of the vector field (v,w) ! in (vlap,wlap) (see the definition of the vector laplacian at ! the output parameter description of vlap,wlap below). w and wlap ! are east longitudinal components of the vectors. v and vlap are ! colatitudinal components of the vectors. the laplacian components ! in (vlap,wlap) have the same symmetry or lack of symmetry about the ! equator as (v,w). the input parameters ityp,nt,mdbc,nbdc must have ! the same values used by vhagc to compute br,bi,cr, and ci for (v,w). ! vlap(i,j) and wlap(i,j) are given on the sphere at the gaussian ! colatitude theta(i) (see nlat as input parameter) and east longitude ! lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! ityp this parameter should have the same value input to subroutine ! vhagc to compute the coefficients br,bi,cr, and ci for the ! vector field (v,w). ityp is set as follows: ! ! = 0 no symmetries exist in (v,w) about the equator. (vlap,wlap) ! is computed and stored on the entire sphere. ! ! nt nt is the number of vector fields (v,w). ! ! idvw the first dimension of the arrays vlap and wlap as it appears ! in the program that calls vlapgc. ! ! jdvw the second dimension of the arrays vlap and wlap as it appears ! in the program that calls vlapgc. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhagc. ! br,bi,cr and ci must be computed by vhagc prior to calling ! vlapgc. ! ! mdbc the first dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls vlapgc. ! ! ndbc the second dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls vlapgc. ! ! wvhsgc an array which must be initialized by subroutine vhsgci. ! ! lvhsgc the dimension of the array wvhsgc as it appears in the ! program that calls vhagc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vlapgc. ! ! ************************************************************** ! ! output parameters ! ! ! vlap, two or three dimensional arrays (see input parameter nt) that ! wlap contain the vector laplacian of the field (v,w). ! ! ierror a parameter which flags errors in input parameters as follows: ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lvhsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdbc integer ndbc integer lvhsgc integer lwork integer, intent(out)::ierror real, intent(out)::vlap(idvw, jdvw, nt) real, intent(out)::wlap(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdbc, ndbc, nt) real bi(mdbc, ndbc, nt) real cr(mdbc, ndbc, nt) real ci(mdbc, ndbc, nt) real wvhsgc(lvhsgc) ! end subroutine vlapgs(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci,mdbc,ndbc,wvhsgs,lvhsgs,work,lwork,ierror) ! ! subroutine vlapes computes the vector laplacian of the vector field ! given the vector spherical harmonic coefficients (br,bi,cr,ci) ! precomputed by subroutine vhags for a vector field (v,w), subroutine ! vlapgs computes the vector laplacian of the vector field (v,w) ! in (vlap,wlap) (see the definition of the vector laplacian at ! the output parameter description of vlap,wlap below). w and wlap ! are east longitudinal components of the vectors. v and vlap are ! colatitudinal components of the vectors. the laplacian components ! in (vlap,wlap) have the same symmetry or lack of symmetry about the ! equator as (v,w). the input parameters ityp,nt,mdbc,nbdc must have ! the same values used by vhags to compute br,bi,cr, and ci for (v,w). ! vlap(i,j) and wlap(i,j) are given on the sphere at the gaussian ! colatitude theta(i) (see nlat as input parameter) and east longitude ! lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! ityp this parameter should have the same value input to subroutine ! vhags to compute the coefficients br,bi,cr, and ci for the ! vector field (v,w). ityp is set as follows: ! ! = 0 no symmetries exist in (v,w) about the equator. (vlap,wlap) ! is computed and stored on the entire sphere. ! ! nt nt is the number of vector fields (v,w). ! ! idvw the first dimension of the arrays vlap and wlap as it appears ! in the program that calls vlapgs. ! ! jdvw the second dimension of the arrays vlap and wlap as it appears ! in the program that calls vlapgs. ! ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhags. ! br,bi,cr and ci must be computed by vhags prior to calling ! vlapgs. ! ! mdbc the first dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls vlapgs. ! ! ndbc the second dimension of the arrays br,bi,cr and ci as it ! appears in the program that calls vlapgs. ndbc must be at ! least nlat. ! ! wvhsgs an array which must be initialized by subroutine vlapgsi ! ! lvhsgs the dimension of the array wvhsgs as it appears in the ! program that calls vlapgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vlapgs. ! ! ************************************************************** ! ! output parameters ! ! ! vlap, two or three dimensional arrays (see input parameter nt) that ! wlap contain the vector laplacian of the field (v,w). ! ! ierror a parameter which flags errors in input parameters as follows: ! ! = 0 no errors detected ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdbc ! = 8 error in the specification of ndbc ! = 9 error in the specification of lvhsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer idvw integer jdvw integer nt integer mdbc integer ndbc integer lvhsgs integer lwork integer, intent(out)::ierror real, intent(out)::vlap(idvw, jdvw, nt) real, intent(out)::wlap(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdbc, ndbc, nt) real bi(mdbc, ndbc, nt) real cr(mdbc, ndbc, nt) real ci(mdbc, ndbc, nt) real wvhsgs(lvhsgs) ! end subroutine vrtec(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc,wshsec,lshsec,work,lwork,ierror) ! ! subroutine vlapes computes the vector laplacian of the vector field ! given the vector spherical harmonic coefficients cr and ci, precomputed ! by subroutine vhaec for a vector field (v,w), subroutine vrtec ! computes the vorticity of the vector field in the scalar array ! vt. vt(i,j) is the vorticity at the colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. i.e., ! ! vt(i,j) = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! where sint = sin(theta(i)). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! cr,ci were precomputed. required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine vrtes. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the vorticity is ! computed on the full or half sphere as follows: ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. ! ! ivrt the first dimension of the array vt as it appears in ! the program that calls vrtec. ! ! jvrt the second dimension of the array vt as it appears in ! the program that calls vrtec. ! ! cr,ci two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaec. ! cr and ci must be computed by vhaec prior to calling ! vrtec. ! ! mdc the first dimension of the arrays cr and ci as it ! appears in the program that calls vrtec. ! ! ndc the second dimension of the arrays cr and ci as it ! appears in the program that calls vrtec. ! ! wshsec an array which must be initialized by subroutine shseci. ! ! lshsec the dimension of the array wshsec as it appears in the ! program that calls vrtec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vrtec. ! ! ************************************************************** ! ! output parameters ! ! vort a two or three dimensional array (see input parameter nt) ! that contains the vorticity of the vector field (v,w) ! whose coefficients cr,ci where computed by subroutine vhaec. ! ! ierror an error parameter which indicates fatal errors with input ! parameters when returned positive. ! = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of ivrt ! = 6 error in the specification of jvrt ! = 7 error in the specification of mdc ! = 8 error in the specification of ndc ! = 9 error in the specification of lshsec ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer ivrt integer jvrt integer nt integer mdc integer ndc integer lshsec integer lwork integer, intent(out)::ierror real, intent(out)::vort(ivrt, jvrt, nt) real, intent(temporary):: work(lwork) real cr(mdc, ndc, nt) real ci(mdc, ndc, nt) real wshsec(lshsec) ! end subroutine vrtes(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc,wshses,lshses,work,lwork,ierror) ! ! subroutine vlapes computes the vector laplacian of the vector field ! given the vector spherical harmonic coefficients cr and ci, precomputed ! by subroutine vhaes for a vector field (v,w), subroutine vrtes ! computes the vorticity of the vector field in the scalar array ! vt. vt(i,j) is the vorticity at the colatitude ! ! theta(i) = (i-1)*pi/(nlat-1) ! ! and longitude ! ! lambda(j) = (j-1)*2*pi/nlon ! ! on the sphere. i.e., ! ! vt(i,j) = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! where sint = sin(theta(i)). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! cr,ci were precomputed. required associated legendre polynomials ! are stored rather than recomputed as they are in subroutine vrtec. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! isym a parameter which determines whether the vorticity is ! computed on the full or half sphere as follows: ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. the vorticity is ! computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! ivrt the first dimension of the array vt as it appears in ! the program that calls vrtes. ! ! jvrt the second dimension of the array vt as it appears in ! the program that calls vrtes. ! ! cr,ci two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhaes. ! cr and ci must be computed by vhaes prior to calling ! vrtes. ! ! mdc the first dimension of the arrays cr and ci as it ! appears in the program that calls vrtes. ! ! ndc the second dimension of the arrays cr and ci as it ! appears in the program that calls vrtes. ! ! wshses an array which must be initialized by subroutine shsesi. ! ! lshses the dimension of the array wshses as it appears in the ! program that calls vrtes. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vrtes. ! ! ************************************************************** ! ! output parameters ! ! vort a two or three dimensional array (see input parameter nt) ! that contains the vorticity of the vector field (v,w) ! whose coefficients cr,ci where computed by subroutine vhaes. ! ! ierror an error parameter which indicates fatal errors with input ! parameters when returned positive. ! = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of ivrt ! = 6 error in the specification of jvrt ! = 7 error in the specification of mdc ! = 8 error in the specification of ndc ! = 9 error in the specification of lshses ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer ivrt integer jvrt integer nt integer mdc integer ndc integer lshses integer lwork integer, intent(out)::ierror real, intent(out)::vort(ivrt, jvrt, nt) real, intent(temporary):: work(lwork) real cr(mdc, ndc, nt) real ci(mdc, ndc, nt) real wshses(lshses) ! end subroutine vrtgc(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc,wshsgc,lshsgc,work,lwork,ierror) ! ! subroutine vlapes computes the vector laplacian of the vector field ! given the vector spherical harmonic coefficients cr and ci, precomputed ! by subroutine vhagc for a vector field (v,w), subroutine vrtgc ! computes the vorticity of the vector field in the scalar array ! vort. vort(i,j) is the vorticity at the gaussian colatitude ! theta(i) (see nlat as input parameter) and longitude ! lambda(j) = (j-1)*2*pi/nlon on the sphere. i.e., ! ! vort(i,j) = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! where sint = sin(theta(i)). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! cr,ci were precomputed. required associated legendre polynomials ! are recomputed rather than stored as they are in subroutine vrtgs. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! full sphere. ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the vorticity is ! computed on the full or half sphere as follows: ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. the vorticity is ! computed on the entire sphere. ! ! nt nt is the number of scalar and vector fields. ! ! ivrt the first dimension of the array vort as it appears in ! the program that calls vrtgc. ! ! jvrt the second dimension of the array vort as it appears in ! the program that calls vrtgc. ! ! cr,ci two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhagc. ! cr and ci must be computed by vhagc prior to calling ! vrtgc. ! ! mdc the first dimension of the arrays cr and ci as it ! appears in the program that calls vrtgc. ! ! ndc the second dimension of the arrays cr and ci as it ! appears in the program that calls vrtgc. ! ! wshsgc an array which must be initialized by subroutine shsgci. ! ! lshsgc the dimension of the array wshsgc as it appears in the ! program that calls vrtgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vrtgc. ! ! ! ************************************************************** ! ! output parameters ! ! ! vort a two or three dimensional array (see input parameter nt) ! that contains the vorticity of the vector field (v,w) ! whose coefficients cr,ci where computed by subroutine vhagc. ! ! ierror an error parameter which indicates fatal errors with input ! parameters when returned positive. ! = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of ivrt ! = 6 error in the specification of jvrt ! = 7 error in the specification of mdc ! = 8 error in the specification of ndc ! = 9 error in the specification of lshsgc ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer ivrt integer jvrt integer nt integer mdc integer ndc integer lshsgc integer lwork integer, intent(out)::ierror real, intent(out)::vort(ivrt, jvrt, nt) real, intent(temporary):: work(lwork) real cr(mdc, ndc, nt) real ci(mdc, ndc, nt) real wshsgc(lshsgc) ! end subroutine vrtgs(nlat,nlon,isym,nt,vort,ivrt,jvrt,cr,ci,mdc,ndc,wshsgs,lshsgs,work,lwork,ierror) ! ************************************************************************** ! ! given the vector spherical harmonic coefficients cr and ci, precomputed ! by subroutine vhags for a vector field (v,w), subroutine vrtgs ! computes the vorticity of the vector field in the scalar array ! vort. vort(i,j) is the vorticity at the gaussian colatitude ! theta(i) (see nlat as input parameter) and longitude ! lambda(j) = (j-1)*2*pi/nlon on the sphere. i.e., ! ! vort(i,j) = [-dv/dlambda + d(sint*w)/dtheta]/sint ! ! where sint = sin(theta(i)). w is the east longitudinal and v ! is the colatitudinal component of the vector field from which ! cr,ci were precomputed. required associated legendre polynomials ! are stored rather than recomputed as they are in subroutine vrtgc. ! ! ! ************************************************************** ! ! input parameters ! ! nlat the number of points in the gaussian colatitude grid on the ! ! nlon the number of distinct longitude points. ! ! isym a parameter which determines whether the vorticity is ! computed on the full or half sphere as follows: ! ! = 0 ! the symmetries/antsymmetries described in isym=1,2 below ! do not exist in (v,w) about the equator. ! ! nt nt is the number of scalar and vector fields. ! ! ivrt the first dimension of the array vort as it appears in ! the program that calls vrtgs. ! ! jvrt the second dimension of the array vort as it appears in ! the program that calls vrtgs. ! !cr,ci two or three dimensional arrays (see input parameter nt) ! that contain vector spherical harmonic coefficients ! of the vector field (v,w) as computed by subroutine vhags. ! cr and ci must be computed by vhags prior to calling ! vrtgs. ! ! mdc the first dimension of the arrays cr and ci as it ! appears in the program that calls vrtgs. ! ! ndc the second dimension of the arrays cr and ci as it ! appears in the program that calls vrtgs. ! ! wshsgs an array which must be initialized by subroutine shsgsi. ! ! lshsgs the dimension of the array wshsgs as it appears in the ! program that calls vrtgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vrtgs. ! ! ************************************************************** ! ! ! output parameters ! ! vort a two or three dimensional array (see input parameter nt) ! that contains the vorticity of the vector field (v,w) ! whose coefficients cr,ci where computed by subroutine vhags. ! !ierror= 0 no errors ! = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of isym ! = 4 error in the specification of nt ! = 5 error in the specification of ivrt ! = 6 error in the specification of jvrt ! = 7 error in the specification of mdc ! = 8 error in the specification of ndc ! = 9 error in the specification of lshsgs ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer isym integer nt integer ivrt integer jvrt integer mdc integer ndc integer lshsgs integer lwork integer, intent(out)::ierror real, intent(out)::vort(ivrt, jvrt, nt) real, intent(temporary):: work(lwork) real cr(mdc, ndc, nt) real ci(mdc, ndc, nt) real wshsgs(lshsgs) ! end subroutine vshifte(ioff,nlon,nlat,uoff,voff,ureg,vreg,wsav,lsav,wrk,lwrk,ier) ! ************************************************************************** ! subroutine vshifte does a highly accurate 1/2 grid increment shift ! in both longitude and latitude of equally spaced vector data on the ! sphere. data is transferred between the nlon by nlat offset grid ! in (uoff,voff) (which excludes poles) and the nlon by nlat+1 regular ! grid in (ureg,vreg) (which includes poles). the transfer can go from ! (uoff,voff) to (ureg,vreg) or vice versa (see ioff). the grids which ! underly the vector fields are described below. the north and south ! pole are at 0.5*pi and-0.5*pi radians respectively (pi=4.*atan(1.)). ! uoff and ureg are the east longitudinal vector data components. voff ! and vreg are the latitudinal vector data components. ! ! subroutine vshifte here does a shift to the offset grid ! ! ************************************************************** ! ! input parameters ! ! nlon the number of longitude points on both the offset and regular ! uniform grid in longitude. ! ! nlat the number of latitude points on the offset uniform grid. nlat+1 ! is the number of latitude points on the regular uniform grid. ! ! ureg a nlon by nlat+1 array that contains the east longitudinal vector ! data component on the regular grid described above. ! ! vreg a nlon by nlat+1 array that contains the latitudinal vector data ! component on the regular grid described above. ! ! uoff a nlon by nlat array that contains the east longitudinal vector ! data component on the offset grid described above. ! ! voff a nlon by nlat array that contains the latitudinal vector data ! component on the offset grid described above. ! ! ! wsav a real saved work space array that must be initialized by calling ! subroutine vshiftei(nlon,nlat,wsav,ier) before calling vshifte. ! ! lsav the length of the saved work space wsav in the routine calling vshifte ! and sshiftei. ! ! wrk a real unsaved work space ! ! lwrk the length of the unsaved work space in the routine calling vshifte ! ! ************************************************************** ! ! output parameters ! ier = 0 if no errors are detected ! = 1 if ioff is not equal to 0 or 1 ! = 2 if nlon < 4 ! = 3 if nlat < 3 ! = 4 if lsave < 2*(nlon+2*nlat)+32 ! = 5 if lwork < 2*nlon*(nlat+1) for nlon even or ! lwork < nlon*(5*nlat+1) for nlon odd ! ************************************************************************* ! integer ioff integer nlat integer nlon integer lsav integer lwrk integer, intent(out)::ier real, intent(inout)::uoff(nlon, nlat) real, intent(inout)::voff(nlon, nlat) real, intent(inout)::ureg(nlon, nlat + 1) real, intent(inout)::vreg(nlon, nlat + 1) real, intent(temporary):: wrk(lwrk) real wsav(lsav) ! end subroutine vshifti(ioff,nlon,nlat,lsav,wsav,ier) ! ! subroutine vshifti initializes the saved work space wsav ! for ioff and nlon and nlat (see documentation for vshifte). ! vshifti must be called before vshifte whenever ioff or nlon ! or nlat change. ! ! ier = 0 if no errors with input arguments ! = 1 if ioff is not 0 or 1 ! = 2 if nlon < 4 ! = 3 if nlat < 3 ! = 4 if lsav < 2*(2*nlat+nlon+16) ! ************************************************************************* ! integer ioff integer nlat integer nlon integer lsav integer, intent(out)::ier real, intent(out)::wsav(lsav) ! end subroutine vtsec(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvts,lwvts,work,lwork,ierror) ! ************************************************************************** ! ! given the vector harmonic analysis br,bi,cr, and ci (computed ! by subroutine vhaec) of some vector function (v,w), this ! subroutine computes the vector function (vt,wt) which is ! the derivative of (v,w) with respect to colatitude theta. vtsec ! is similar to vhsec except the vector harmonics are replaced by ! their derivative with respect to colatitude with the result that ! (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative ! of the colatitudinal component v(i,j) at the point theta(i) = ! (i-1)*pi/(nlat-1) and longitude phi(j) = (j-1)*2*pi/nlon. the ! spectral representation of (vt,wt) is given below at output ! parameters vt,wt. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct londitude points. ! ! ityp = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. in the program that calls vtsec, ! the arrays vt,wt,br,bi,cr, and ci can be three dimensional ! in which case multiple syntheses will be performed. ! ! idvw the first dimension of the arrays vt,wt as it appears in ! the program that calls vtsec. ! ! jdvw the second dimension of the arrays vt,wt as it appears in ! the program that calls vtsec. jdvw must be at least nlon. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! of (v,w) as computed by subroutine vhaec. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vtsec. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vtsec. ! ! wvts an array which must be initialized by subroutine vtseci. ! ! lwvts the dimension of the array wvts as it appears in the ! program that calls vtsec. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vtsec. ! ! ************************************************************** ! ! ! output parameters ! ! vt,wt two or three dimensional arrays (see input parameter nt) ! in which the derivative of (v,w) with respect to ! colatitude theta is stored. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lwvts ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer nt integer idvw integer jdvw integer mdab integer ndab integer lwvts integer lwork integer, intent(out)::ierror real, intent(out)::vt(idvw, jdvw, nt) real, intent(out)::wt(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdab, ndab, nt) real bi(mdab, ndab, nt) real cr(mdab, ndab, nt) real ci(mdab, ndab, nt) real wvts(lwvts) ! end subroutine vtseci(nlat,nlon,wvts,lwvts,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vtseci initializes the array wvts which can then be ! used repeatedly by subroutine vtsec until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! lwvts the dimension of the array wvts as it appears in the ! program that calls vtsec. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array work as it appears in the ! program that calls vtsec. ! ! ************************************************************** ! ! output parameters ! ! wvts an array which is initialized for use by subroutine vtsec. ! once initialized, wvts can be used repeatedly by vtsec ! as long as nlat or nlon remain unchanged. wvts must not ! be altered between calls of vtsec. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lwvts ! = 4 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lwvts integer ldwork integer, intent(out)::ierror real, intent(out)::wvts(lwvts) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vtses(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvts,lwvts,work,lwork,ierror) ! ************************************************************************** ! ! given the vector harmonic analysis br,bi,cr, and ci (computed ! by subroutine vhaes) of some vector function (v,w), this ! subroutine computes the vector function (vt,wt) which is ! the derivative of (v,w) with respect to colatitude theta. vtses ! is similar to vhses except the vector harmonics are replaced by ! their derivative with respect to colatitude with the result that ! (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative ! of the colatitudinal component v(i,j) at the point theta(i) = ! (i-1)*pi/(nlat-1) and longitude phi(j) = (j-1)*2*pi/nlon. the ! spectral representation of (vt,wt) is given below at output ! parameters vt,wt. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idvw the first dimension of the arrays vt,wt as it appears in ! the program that calls vtses. ! ! jdvw the second dimension of the arrays vt,wt as it appears in ! the program that calls vtses. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! of (v,w) as computed by subroutine vhaes. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vtses. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vtses. ! ! wvts an array which must be initialized by subroutine vtsesi. ! ! lwvts the dimension of the array wvts as it appears in the ! program that calls vtses. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vtses. ! ! ! ************************************************************** ! ! output parameters ! ! vt,wt two or three dimensional arrays (see input parameter nt) ! in which the derivative of (v,w) with respect to ! colatitude theta is stored. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lwvts ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer nt integer idvw integer jdvw integer mdab integer ndab integer lwvts integer lwork integer, intent(out)::ierror real, intent(out)::vt(idvw, jdvw, nt) real, intent(out)::wt(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdab, ndab, nt) real bi(mdab, ndab, nt) real cr(mdab, ndab, nt) real ci(mdab, ndab, nt) real wvts(lwvts) ! end subroutine vtsesi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vtsesi initializes the array wvts which can then be ! used repeatedly by subroutine vtses until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of colatitudes on the full sphere including the ! poles. ! ! nlon the number of distinct longitude points. ! ! lwvts the dimension of the array wvts as it appears in the ! program that calls vtses. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vtses. ! ! dwork a doubleprecision work array that does have to be saved. ! ! ldwork the length of dwork. ! ! ************************************************************** ! ! output parameters ! ! wvts an array which is initialized for use by subroutine vtses. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lwvts ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lwvts integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wvts(lwvts) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vtsgc(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvts,lwvts,work,lwork,ierror) ! ************************************************************************** ! ! given the vector harmonic analysis br,bi,cr, and ci (computed ! by subroutine vhagc) of some vector function (v,w), this ! subroutine computes the vector function (vt,wt) which is ! the derivative of (v,w) with respect to colatitude theta. vtsgc ! is similar to vhsgc except the vector harmonics are replaced by ! their derivative with respect to colatitude with the result that ! (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative ! of the colatitudinal component v(i,j) at the gaussian colatitude ! theta(i) and longitude phi(j) = (j-1)*2*pi/nlon. the spectral ! representation of (vt,wt) is given below at the definition of ! output parameters vt,wt. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of gaussian colatitudinal grid points theta(i) ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. the synthesis ! is performed on the entire sphere. ! ! nt the number of syntheses. ! ! idvw the first dimension of the arrays vt,wt as it appears in ! the program that calls vtsgc. ! ! jdvw the second dimension of the arrays vt,wt as it appears in ! the program that calls vtsgc. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! of (v,w) as computed by subroutine vhagc. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vtsgc. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vtsgc. ! ! wvts an array which must be initialized by subroutine vtsgci. ! ! lwvts the dimension of the array wvts as it appears in the ! program that calls vtsgc. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vtsgc. ! ! ************************************************************** ! ! ! vt,wt two or three dimensional arrays (see input parameter nt) ! in which the derivative of (v,w) with respect to ! colatitude theta is stored. ! ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lwvts ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer nt integer idvw integer jdvw integer mdab integer ndab integer lwvts integer lwork integer, intent(out)::ierror real, intent(out)::vt(idvw, jdvw, nt) real, intent(out)::wt(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdab, ndab, nt) real bi(mdab, ndab, nt) real cr(mdab, ndab, nt) real ci(mdab, ndab, nt) real wvts(lwvts) ! end subroutine vtsgci(nlat,nlon,wvts,lwvts,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vtsgci initializes the array wvts which can then be ! used repeatedly by subroutine vtsgc until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of gaussian colatitudinal grid points. ! ! nlon the number of distinct longitude points. ! ! lwvts the dimension of the array wvts as it appears in the ! program that calls vtsgc. ! ! dwork a doubleprecision work array that does not have to be saved. ! ! ldwork the dimension of the array dwork as it appears in the ! program that calls vtsgc. ! ! ************************************************************** ! ! output parameters ! ! wvts an array which is initialized for use by subroutine vtsgc. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lwvts ! = 4 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer lwvts integer ldwork integer, intent(out)::ierror real, intent(out)::wvts(lwvts) doubleprecision, intent(temporary):: dwork(ldwork) ! end subroutine vtsgs(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci,mdab,ndab,wvts,lwvts,work,lwork,ierror) ! ************************************************************************** ! ! given the vector harmonic analysis br,bi,cr, and ci (computed ! by subroutine vhags) of some vector function (v,w), this ! subroutine computes the vector function (vt,wt) which is ! the derivative of (v,w) with respect to colatitude theta. vtsgs ! is similar to vhsgs except the vector harmonics are replaced by ! their derivative with respect to colatitude with the result that ! (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative ! of the colatitudinal component v(i,j) at the gaussian colatitude ! point theta(i) and longitude phi(j) = (j-1)*2*pi/nlon. the ! spectral representation of (vt,wt) is given below at output ! parameters vt,wt. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of gaussian colatitudinal grid points. ! ! nlon the number of distinct longitude points. ! ! ityp = 0 no symmetries exist about the equator. ! ! nt the number of syntheses. ! ! idvw the first dimension of the arrays vt,wt as it appears in ! the program that calls vtsgs. ! ! jdvw the second dimension of the arrays vt,wt as it appears in ! the program that calls vtsgs. jdvw must be at least nlon. ! ! br,bi two or three dimensional arrays (see input parameter nt) ! cr,ci that contain the vector spherical harmonic coefficients ! of (v,w) as computed by subroutine vhags. ! ! mdab the first dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vtsgs. ! ! ndab the second dimension of the arrays br,bi,cr, and ci as it ! appears in the program that calls vtsgs. ! ! wvts an array which must be initialized by subroutine vtsgsi. ! ! lwvts the dimension of the array wvts as it appears in the ! program that calls vtsgs. ! ! ! ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vtsgs. ! ! ************************************************************** ! ! output parameters ! ! vt,wt two or three dimensional arrays (see input parameter nt) ! in which the derivative of (v,w) with respect to ! colatitude theta is stored. vt(i,j),wt(i,j) contain the ! derivatives at gaussian colatitude points theta(i). ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of ityp ! = 4 error in the specification of nt ! = 5 error in the specification of idvw ! = 6 error in the specification of jdvw ! = 7 error in the specification of mdab ! = 8 error in the specification of ndab ! = 9 error in the specification of lwvts ! = 10 error in the specification of lwork ! ************************************************************************* ! integer nlat integer nlon integer ityp integer nt integer idvw integer jdvw integer mdab integer ndab integer lwvts integer lwork integer, intent(out)::ierror real, intent(out)::vt(idvw, jdvw, nt) real, intent(out)::wt(idvw, jdvw, nt) real, intent(temporary):: work(lwork) real br(mdab, ndab, nt) real bi(mdab, ndab, nt) real cr(mdab, ndab, nt) real ci(mdab, ndab, nt) real wvts(lwvts) ! end subroutine vtsgsi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork,ierror) ! ************************************************************************** ! ! subroutine vtsgsi initializes the array wvts which can then be ! used repeatedly by subroutine vtsgs until nlat or nlon is changed. ! ! ************************************************************** ! ! input parameters ! ! nlat the number of gaussian colatitudinal grid points. ! ! nlon the number of distinct longitude points. ! ! lwvts the dimension of the array wvts as it appears in the ! program that calls vtsgs. ! ! work a work array that does not have to be saved. ! ! lwork the dimension of the array work as it appears in the ! program that calls vtsgs. ! ! dwork a doubleprecision work array that does not have to be saved ! ! ldwork the length of dwork. ! ! ************************************************************** ! ! output parameters ! ! wvts an array which is initialized for use by subroutine vtsgs. ! ! ierror = 0 no errors ! = 1 error in the specification of nlat ! = 2 error in the specification of nlon ! = 3 error in the specification of lwvts ! = 4 error in the specification of lwork ! = 5 error in the specification of ldwork ! ************************************************************************* ! integer nlat integer nlon integer lwvts integer lwork integer ldwork integer, intent(out)::ierror real, intent(out)::wvts(lwvts) real, intent(temporary):: work(lwork) doubleprecision, intent(temporary):: dwork(ldwork) ! end end interface end module spherepack spherepack-3.2/Src/islapec.f0000644000175000017500000003144611464224044016214 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/vrtes.f0000644000175000017500000002700711464224044015735 0ustar alastairalastairc 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 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 spherepack-3.2/Src/divgc.f0000644000175000017500000002772511464224044015675 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vhsgs.f0000644000175000017500000011721311464224044015723 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/isfvpec.f0000644000175000017500000003076711464224044016240 0ustar alastairalastairc 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 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 spherepack-3.2/Src/islapgs.f0000644000175000017500000003150511464224044016232 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/ivlapgs.f0000644000175000017500000004343211464224044016237 0ustar alastairalastairc 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 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 spherepack-3.2/Src/sfvpgs.f0000644000175000017500000003114111464224044016074 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/ivrtes.f0000644000175000017500000003174211464224044016107 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/sfvpes.f0000644000175000017500000003064211464224044016077 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vlapgs.f0000644000175000017500000004405311464224044016066 0ustar alastairalastairc 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 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 spherepack-3.2/Src/shaes.f0000644000175000017500000004240311464224044015672 0ustar alastairalastairc 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 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 spherepack-3.2/Src/trvsph.f0000644000175000017500000006645311464224044016130 0ustar alastairalastairc 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 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 negv(nlat,nlon,v) c c negate (co)latitudinal vector componenet 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 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 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 spherepack-3.2/Src/ivlapes.f0000644000175000017500000004203311464224044016231 0ustar alastairalastairc 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 spherepack-3.2/Src/ivlapec.f0000644000175000017500000004436511464224044016223 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vhses.f0000644000175000017500000011023311464224044015714 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/vtses.f0000644000175000017500000010230011464224044015724 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/sfvpec.f0000644000175000017500000003105311464224044016054 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vhags.f0000755000175000017500000010613311464224044015703 0ustar alastairalastairc 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 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 (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 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 function indx(m,n,nlat) integer indx indx = m*nlat-(m*(m+1))/2+n+1 return end spherepack-3.2/Src/divgs.f0000644000175000017500000002725511464224044015713 0ustar alastairalastairc 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 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 spherepack-3.2/Src/islapes.f0000644000175000017500000003103311464224044016224 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/vlapes.f0000644000175000017500000004377011464224044016071 0ustar alastairalastairc 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 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 spherepack-3.2/Src/slapec.f0000644000175000017500000002736211464224044016045 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vtsgc.f0000644000175000017500000010421411464224044015714 0ustar alastairalastairc 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 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 nlat*(nlat+4) 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. nlat*(nlat+4)) return c call gaqd(nlat,work,work(2*nlat+1),work(4*nlat+1),lwork,ierr) ldwk = ldwork-2*nlat 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 spherepack-3.2/Src/vshifte.f0000644000175000017500000004036311464224044016242 0ustar alastairalastairc 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 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 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 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 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 spherepack-3.2/Src/igrades.f0000644000175000017500000002751611464224044016215 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/ivlapgc.f0000644000175000017500000004412211464224044016214 0ustar alastairalastairc 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 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 spherepack-3.2/Src/idivgs.f0000644000175000017500000003165711464224044016065 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/vlapec.f0000644000175000017500000004505511464224044016047 0ustar alastairalastairc 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 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 spherepack-3.2/Src/idvtgs.f0000644000175000017500000003475511464224044016102 0ustar alastairalastairc 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 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 shaes for the scalar field divg and coefficients av,bv c precomputed by subroutine shaes 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 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 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 = 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 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. +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 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 spherepack-3.2/Src/vhsgc.f0000644000175000017500000011214311464224044015700 0ustar alastairalastairc 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 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 spherepack-3.2/Src/shsec.f0000644000175000017500000004474611464224044015710 0ustar alastairalastairc 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 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 spherepack-3.2/Src/shigc.f0000644000175000017500000002102411464224044015660 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vlapgc.f0000644000175000017500000004512611464224044016050 0ustar alastairalastairc 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 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 spherepack-3.2/Src/shags.f0000644000175000017500000006153611464224044015704 0ustar alastairalastairc 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 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 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 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 spherepack-3.2/Src/grades.f0000644000175000017500000002737211464224044016044 0ustar alastairalastairc 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 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 spherepack-3.2/Src/shsgs.f0000644000175000017500000005626411464224044015730 0ustar alastairalastairc 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 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 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 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 spherepack-3.2/Src/hrfft.f0000644000175000017500000016576411464224044015720 0ustar alastairalastairc 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 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 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 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 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 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 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 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 function pimach() pimach=3.14159265358979 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 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 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 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 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 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 spherepack-3.2/Src/igradec.f0000644000175000017500000003031011464224044016157 0ustar alastairalastairC 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 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 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 spherepack-3.2/Src/vhsec.f0000644000175000017500000011046511464224044015703 0ustar alastairalastairc 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 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 spherepack-3.2/Src/dives.f0000644000175000017500000002710211464224044015700 0ustar alastairalastairc 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 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 spherepack-3.2/Src/igradgs.f0000644000175000017500000002752611464224044016220 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/islapgc.f0000644000175000017500000003120511464224044016207 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/ivrtgc.f0000644000175000017500000003225311464224044016067 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/gradec.f0000644000175000017500000002777011464224044016026 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vtsgs.f0000644000175000017500000010423711464224044015741 0ustar alastairalastairc 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 c c ... file vtsgs.f c c this file includes documentation and code for c subroutines vtsgc and vtsgci 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 nlat*(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+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 lvin = 3*nlat*imid lwvbin = 2*nlat*imid+labc ltheta = nlat+nlat if(lwork .lt. lvin+lwvbin+ltheta) return ierror = 5 if (ldwork .lt. nlat*(nlat+2)) return ierror = 0 iw1 = lvin+1 iw2 = iw1+lwvbin lgaqd = 2*nlat*(nlat+2) lwts = ltheta jw1 = lgaqd+1 CALL VETG1(NLAT,NLON,IMID,WVTS,WVTS(LZIMN+1),DWORK,WORK, 1 WORK(IW1),DWORK(IW2),DWORK(JW1),IERROR) if(ierror .ne. 0) return call hrffti(nlon,wvts(2*lzimn+1)) return end subroutine vetg1(nlat,nlon,imid,vb,wb,dwork,vin,wvbin, 1 theta,wts,ierror) dimension vb(imid,*),wb(imid,*),vin(imid,nlat,3),wvbin(*) double precision dwork(*),theta(*),wts(*) mmax = min0(nlat,(nlon+1)/2) c lwork = 2*nlat*(nlat+2) lwork = nlat*(nlat+2) call gaqd(nlat,theta,wts,dwork,lwork,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 spherepack-3.2/Src/idivgc.f0000644000175000017500000003171011464224044016033 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/igradgc.f0000644000175000017500000002764411464224044016201 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/shsgc.f0000644000175000017500000005426111464224044015703 0ustar alastairalastairc 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 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 spherepack-3.2/Src/divec.f0000644000175000017500000002741711464224044015671 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vrtgc.f0000644000175000017500000002776711464224044015734 0ustar alastairalastairc 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 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 spherepack-3.2/Src/shagc.f0000644000175000017500000005614311464224044015662 0ustar alastairalastairc 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 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 spherepack-3.2/Src/idvtgc.f0000644000175000017500000003502511464224044016051 0ustar alastairalastairc 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 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 nlat*(2*nt*nlon+max0(6*l2,nlon)+4*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*(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 spherepack-3.2/Src/gradgc.f0000644000175000017500000002772211464224044016025 0ustar alastairalastairc 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 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 spherepack-3.2/Src/ivrtec.f0000644000175000017500000003173011464224044016064 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/Makefile0000644000175000017500000000007311464224044016055 0ustar alastairalastairlibsphere.a: *.f g77 -c *.f ld -r -o libsphere.a *.o spherepack-3.2/Src/isfvpes.f0000644000175000017500000003053611464224044016252 0ustar alastairalastairc 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 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 spherepack-3.2/Src/idivec.f0000644000175000017500000003210511464224044016030 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/vhagc.f0000755000175000017500000010775311464224044015674 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/vhaes.f0000644000175000017500000010115611464224044015676 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/shses.f0000644000175000017500000004041411464224044015714 0ustar alastairalastairc 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 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 spherepack-3.2/Src/sphcom.f0000755000175000017500000016215511464224044016072 0ustar alastairalastairc 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 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 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 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 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 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+1 c call zfini1 (nlat,nlon,imid,wzfin,wzfin(iw1),dwork,dwork(imid+1)) 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 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+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 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 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 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 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 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 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 2*nlat+2 c call zvini1 (nlat,nlon,imid,wzvin,wzvin(iw1),dwork,dwork(nlat+2)) 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+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 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 2*nlat+2 c call zwini1 (nlat,nlon,imid,wzwin,wzwin(iw1),dwork,dwork(nlat+2)) 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 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 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 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 2*nlat+2 c call vbini1 (nlat,nlon,imid,wvbin,wvbin(iw1),dwork,dwork(nlat+2)) 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 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 2*nlat+2 c call wbini1 (nlat,nlon,imid,wwbin,wwbin(iw1),dwork,dwork(nlat+2)) 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+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 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 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 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+1)/2 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+1)/2 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 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 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 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 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 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 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 2*nlat+2 c call vtini1 (nlat,nlon,imid,wvbin,wvbin(iw1),dwork,dwork(nlat+2)) 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+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 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 2*nlat+2 c call wtini1 (nlat,nlon,imid,wwbin,wwbin(iw1),dwork,dwork(nlat+2)) 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+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 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 2*nlat+2 c call vtgit1 (nlat,nlon,imid,theta,wvbin,wvbin(iw1), + work,work(nlat+2)) c 1 work,work(2*nlat+3)) 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+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 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 2*nlat+2 c call wtgit1 (nlat,nlon,imid,theta,wwbin,wwbin(iw1), 1 work,work(nlat+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+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 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 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 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 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 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 2*nlat+2 c call vbgit1 (nlat,nlon,imid,theta,wvbin,wvbin(iw1), + work,work(nlat+2)) c 1 work,work(2*nlat+3)) 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+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 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 2*nlat+2 c call wbgit1 (nlat,nlon,imid,theta,wwbin,wwbin(iw1), + work,work(nlat+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+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 spherepack-3.2/Src/gaqd.f0000755000175000017500000001654511464224044015516 0ustar alastairalastairc 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 c c ... file gaqd.f c c this file includes documentation and code for subrooutine gaqd. c c ... required files c c none c c subroutine gaqd(nlat,theta,wts,dwork,ldwork,ierror) 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 dwork a temporary work space c c ldwork the length of the work space in the routine calling gaqd c ldwork must be at least nlat*(nlat+2). c c output parameters c c theta a double precision vector of length nlat containing the c nlat gaussian colatitudes on the sphere in increasing radians c in the interval (o,pi). c c wts a double precision vector of length nlat containing the c nlat gaussian weights. c c ierror = 0 no errors c = 1 if ldwork.lt.nlat*(nlat+2) c = 2 if nlat.le.0 c = 3 if unable to compute gaussian points c (failure in in eigenvalue routine) c c ***************************************************************** subroutine gaqd(nlat,theta,wts,dwork,ldwork,ierror) double precision theta(nlat),wts(nlat),dwork(ldwork),x n = nlat ierror = 1 c check work space length if (ldwork .lt. n*(n+2)) return ierror = 2 if (n.le.0) return ierror = 0 if (n.gt.2) then c c partition dwork space for double precision eigenvalue(vector computation) c i1 = 1 i2 = i1+n i3 = i2+n call gaqd1(n,theta,wts,dwork(i1),dwork(i2),dwork(i3),ierror) if (ierror.ne.0) then ierror = 3 return end if return else if (n.eq.1) then wts(1) = 2.0d0 theta(1) = dacos(0.0d0) else if (n.eq.2) then c compute weights and points analytically when n=2 wts(1) = 1.0d0 wts(2) = 1.0d0 x = dsqrt(1.0d0/3.0d0) theta(1) = dacos(x) theta(2) = dacos(-x) return end if end subroutine gaqd1(n,theta,wts,w,e,z,ier) dimension theta(n),wts(n),w(n),e(n),z(n,n) double precision theta,wts,temp,w,e,z c set symmetric tridiagnonal matrix subdiagonal and diagonal c coefficients for matrix coming from coefficients in the c recursion formula for legendre polynomials c a(n)*p(n-1)+b(n)*p(n)+c(n)*p(n+1) = 0. w(1)=0.d0 e(1) = 0.d0 do 100 j=2,n e(j)= (j-1.d0)/dsqrt((2.d0*j-1.d0)*(2.d0*j-3.d0)) w(j) = 0.d0 100 continue c c compute eigenvalues and eigenvectors c matz = 1 call drst(n,n,w,e,matz,z,ier) if (ier.ne.0) return c c compute gaussian weights and points c do 101 j=1,n theta(j) = dacos(w(j)) c c set gaussian weights as 1st components of eigenvectors squared c wts(j) = 2.0d0*z(1,j)**2 101 continue c c reverse order of gaussian points to be c monotonic increasing in radians c n2 = n/2 do 102 i=1,n2 temp = theta(i) theta(i) = theta(n-i+1) theta(n-i+1) = temp 102 continue return end subroutine drst(nm,n,w,e,matz,z,ierr) c drst is a double precision modification of rst off eispack c to be used to compute gaussian points and weights c integer i,j,n,nm,ierr,matz double precision w(n),e(n),z(nm,n) c c .......... find both eigenvalues and eigenvectors .......... 20 do 40 i = 1, n c do 30 j = 1, n z(j,i) = 0.0d0 30 continue c z(i,i) = 1.0d0 40 continue c call dintql(nm,n,w,e,z,ierr) return end subroutine dintql(nm,n,d,e,z,ierr) c dintql is a double precision modification of intql2 off c eispack to be used by gaqd in spherepack for computing c gaussian weights and points c integer i,j,k,l,m,n,ii,nm,mml,ierr double precision d(n),e(n),z(nm,n) double precision b,c,f,g,p,r,s,tst1,tst2,dpytha ierr = 0 if (n .eq. 1) go to 1001 c do 100 i = 2, n 100 e(i-1) = e(i) c e(n) = 0.0d0 c do 240 l = 1, n j = 0 c .......... look for small sub-diagonal element .......... c 105 nm1 = n-1 if(l .gt. nm1) go to 111 do 110 mdo = l, nm1 m = mdo tst1 = dabs(d(m)) + dabs(d(m+1)) tst2 = tst1 + dabs(e(m)) if (tst2 .eq. tst1) go to 120 110 continue 111 m = n c 120 p = d(l) if (m .eq. l) go to 240 if (j .eq. 30) go to 1000 j = j + 1 c .......... form shift .......... g = (d(l+1) - p) / (2.0d0 * e(l)) r = dpytha(g,1.0d0) g = d(m) - p + e(l) / (g + sign(r,g)) s = 1.0d0 c = 1.0d0 p = 0.0d0 mml = m - l c .......... for i=m-1 step -1 until l do -- .......... do 200 ii = 1, mml i = m - ii f = s * e(i) b = c * e(i) r = dpytha(f,g) e(i+1) = r if (r .eq. 0.0d0) go to 210 s = f / r c = g / r g = d(i+1) - p r = (d(i) - g) * s + 2.0d0 * c * b p = s * r d(i+1) = g + p g = c * r - b c .......... form vector .......... do 180 k = 1, n f = z(k,i+1) z(k,i+1) = s * z(k,i) + c * f z(k,i) = c * z(k,i) - s * f 180 continue c 200 continue c d(l) = d(l) - p e(l) = g e(m) = 0.0d0 go to 105 c .......... recover from underflow .......... 210 d(i+1) = d(i+1) - p e(m) = 0.0d0 go to 105 240 continue c .......... order eigenvalues and eigenvectors .......... do 300 ii = 2, n i = ii - 1 k = i p = d(i) c do 260 j = ii, n if (d(j) .ge. p) go to 260 k = j p = d(j) 260 continue c if (k .eq. i) go to 300 d(k) = d(i) d(i) = p c do 280 j = 1, n p = z(j,i) z(j,i) = z(j,k) z(j,k) = p 280 continue c 300 continue c go to 1001 c .......... set error -- no convergence to an c eigenvalue after 30 iterations .......... 1000 ierr = l 1001 return end double precision function dpytha(a,b) double precision a,b c dpytha is a double precision modification of pythag off eispack c for use by dimtql c c finds sqrt(a**2+b**2) without overflow or destructive underflow c double precision p,r,s,t,u p = dabs(a) if (dabs(b).ge.dabs(a)) p = dabs(b) if (p .eq. 0.0d0) go to 20 r = (dabs(a)/p)**2 if (dabs(b).lt.dabs(a)) r = (dabs(b)/p)**2 10 continue t = 4.0d0 + r if (t .eq. 4.0d0) go to 20 s = r/t u = 1.0d0 + 2.0d0*s p = u*p r = (s/u)**2 * r go to 10 20 dpytha = p return end spherepack-3.2/Src/ihgeod.f0000644000175000017500000001046711464224044016033 0ustar alastairalastairc 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 c ... file ihgeod.f c c contains documentation and code for subroutine ihgeod 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 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 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 spherepack-3.2/Src/vtsec.f0000644000175000017500000010274111464224044015715 0ustar alastairalastairc 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 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 spherepack-3.2/Src/ivrtgs.f0000644000175000017500000003205511464224044016107 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/idives.f0000644000175000017500000003165211464224044016056 0ustar alastairalastairc 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 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 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 spherepack-3.2/Src/isfvpgs.f0000644000175000017500000003053211464224044016250 0ustar alastairalastairc 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 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 spherepack-3.2/Src/vrtgs.f0000644000175000017500000002734211464224044015741 0ustar alastairalastairc 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 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 spherepack-3.2/Src/idvtes.f0000644000175000017500000003466011464224044016073 0ustar alastairalastairc 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 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 spherepack-3.2/Src/slapgs.f0000644000175000017500000002725611464224044016071 0ustar alastairalastairc 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 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 spherepack-3.2/Lib/0000755000175000017500000000000011464224044014374 5ustar alastairalastairspherepack-3.2/Lib/__init__.py0000644000175000017500000000002511464224044016502 0ustar alastairalastairfrom sphere import * spherepack-3.2/Lib/sphere.py0000755000175000017500000120711711464224044016250 0ustar alastairalastair# Adapted for numpy/ma/cdms2 by convertcdms.py """Documentation for module sphere: an interface to spherepack INTRODUCTION This module provides access through Python to the collection of Fortran programs in SPHEREPACK 3.0, which is a collection of programs produced at the National Center for Atmospheric Research by John C. Adams and Paul N. Swarztrauber for computing certain common differential operators and performing related manipulations on a sphere. It provides solutions via the spectral method that uses both scalar and vector harmonic transforms. Since scalar and vector quantities are fundamentially different on the sphere due to the multiple valued and discontinuous nature of vectors at the poles, separate functions are provided for scalar and vector quantities. RESTRICTIONS Spherepack is not for everyone. Spherepack manipulates data defined strictly on the global sphere. Accordingly, the following restrictions apply: The longitude vector consists of unique evenly spaced points spanning the globe. The latitude vector can be either gaussian or evenly spaced including the poles. Missing data is not allowed. THE SHORT STORY To save time in coming up to speed in the use of this python wrapper around SPHEREPACK 3.0, skip to section GENERAL EXAMPLE. To run some test cases using analytically generated data type python sphere.py It also puts out this documentation in the file spheremodule.doc and a copy of the information written to the screen as screen.asc for what it is worth. ORGANIZATION This module is object oriented for simplicity. It is organized as three classes reflecting the three functional groups in SPHEREPACK 3.0 which perform vector analysis computations, regridding and grid shifting. The vector analysis computations are contained in the Sphere class, the regridding in the Regrid class and the grid shifting in the Shiftgrid class. The class names begin with a capital letter. Python is case sensitive. Access to the functions housed in the classes is a simple two step process. The first step is making an instance of the class which hosts the desired functionality. The second step is calling the actual function or functions of interest. Making an instance requires passing the grid vectors and possibly a computaional parameter selecting the storage treatment of the Legendre polynomials. This information is used internally to select the Fortran function call. For example, to compute the divergence of a vector function, it is necessary to choose one of four Fortran functions according to whether the grid is evenly spaced or gaussian and the Legendre polynomials are stored or computed. These bookkeeping details are done automatically for the user based on the argument list passed in the instance statement. Having set up the machinery with the instance call, the class method functions are called by qualification using the dot operator. It is only necessary to submit the data and accept the return of the answer. As a preview, here is the two step process for calculating the divergence and the vorticity of a 2D vector field (u, v) x = sphere.Sphere(longitudeVector, latitudeVector) divergence = x.div(u, v) vorticity = x.vrt(u, v) which demonstrates the advantage of the object oriented approach. The instance can be reused for multiple computations and the argument list is simple and intuitive. Having calculated the divergence and the vorticity, the user may want do view smoother fields. To truncate the fields at T16, write divergence_T16 = x.truncation(16, divergence) vorticity_T16 = x.truncation(16, vorticity) DOCUMENTATION Documentation written to the file spheremodule.doc can be obtained after importing the spheretest module by typing spheretest.document() A brief view of the documentation consisting of the overview can be written to the file spheremodule.doc after importing the sphere module by typing spheretest.document(brief = 'yes') Online documentation for individual classes or method functions is available from the module doctring and the help package. As examples: print sphere.__doc__ -- four page overview of the package sphere.help() -- contents of the help function sphere.help('div') -- documentation for the Sphere class div method sphere.Sphere.div.__doc__ -- documentation for the Sphere class div method For the utilities type for example sphere.help('gridGenerator') -- grid vector generation CONTENTS This module provides access to the Fortran library in terms of three functional groups which perform vector analysis computations, regridding and grid shifting. Vector Analysis and Truncation -- contained in Sphere class The functions for computing differential operations and their inverses on scalar and vector functions in spherical coordinates on a global grid are: div -- computes the divergence of a vector function idiv -- inverts the divergence creating an irrotational vector function vrt -- the vorticity of a vector function ivrt -- inverts the vorticity creating a divergence_free vector function idvt -- inverts the divergence and the vorticity creating a vector function vts -- computes the derivative of the vector function with respect to latitude grad -- computes the gradient of a scalar function igrad -- inverts the gradient creating a scalar function slap -- computes the Laplacian of a scalar function islap -- inverts the Laplacian of a scalar function vlap -- computes the Laplacian of a vector function ivlap -- inverts the Laplacian of a vector function sfvp -- computes the stream function and the velocity potential of a vector function isfvp -- inverts the stream function and the velocity potential of a vector function One additional function, not part of the basic library, has been added to perform triangular truncation with or withhout tapering: truncation-- truncates scalar or vector data at specified total wavenumber The basic functions for spectral analysis and synthesis directly accessible from python are: sha -- computes the spherical harmonic analysis of a scalar function shs -- computes the spherical harmonic synthesis of a scalar function vha -- computes the spherical harmonic analysis of a vector function vhs -- computes the spherical harmonic synthesis of a vector function Regridding -- contained in Regrid class The two functions for regridding are: regridScalar -- transfers scalar data from one global grid to another regridVector -- transfers vector data from one global grid to another Shifting -- contained in Shiftgrid class The two functions for shifting an evenly spaced grid by half an increment in longitude and latitude are: shiftScalar -- transfers scalar data between an evenly spaced regular and an offset grid shiftVector -- transfers vector data between an evenly spaced regular and an offset grid where the regular grid is defined as one which includes the poles. Utilities not part of the overall scheme but still of possible interest gridGenerator -- generates the longitude and latitude vectors truncate -- provides truncation at the spectral coefficient level PROCEDURE Access to the Spherepack Fortran library is provided through the module spherepackmodule.so which has been constructed using the Pyfort utility. A wrapper around the functions in this spherepackmodule.so has been created as sphere.py. Assuming path access to spherepackmodule.so and sphere.py, to use Spherpack3.0 from the National Center for Atmospheric Research, it is only necessary to import the sphere.py module. It contains the classes Sphere, Regrid, and Shiftgrid designed for the user. This is done by typing at the python prompt import sphere Use of spherepack is a two step process. The first step is the creation of an instance of the appropriate class for the computation at hand. For this step there are three classes as a choice: Sphere, Regrid and Shiftgrid. The second step is the selection of the class method of interest by qualification with the dot operator. As notation related to the display of the argument lists in the calls, the required ones use the keyword name only and the optional ones are written as keyword entries. In practise there are lots of choices allowed by Python. At one extreme all arguments can be submitted using keyword assignments while setting them to None for optional unused vectors. In the class Sphere, the computational scheme default 'computed' can be changed to 'stored'. At the other extreme all arguments can be submitted in the correct position. The examples will clarify this. Vector Analysis and Truncation As the first step for the spherical differential operation calculations, the instance x of the Sphere class is made with the statement typed to the python prompt x = sphere.Sphere(lonArray , latArray, numberLevels = nlev, numberTimes = ntime, computed_stored = 'computed') where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArray = longitude vector (required) latArray = latitude vector (required) numberLevels = number of levels (optional) numberTimes = number of times (optional) computed_stored (optional) : 'computed' -- computed Legendre polynomials 'stored' -- stored Legendre polynomials This choice involves a 30% storage/speed tradeoff The instance request uses computed_stored and the grid vectors to associate the actual Fortran calls with the requested calculation. This association is automatic and need not concern the user. If the longitude and latitude grid vectors are not available, prior to the instance creation they can be constructed by calling the utility function girdGenerator. As a second step, the desired method is selected. As a concrete example, the divergence of the the vector pair u and v is found with div = x.div(u, v) or div = x.div(u, v, missingValue) - with the request to check for missing data This div function calls all the spherepack functions needed to return the divergence. The second form looks for the presence of missing data and returns an error if found. It uses the exact value so it must be the value in the data file. Regridding As the first step for regridding make an instance x of the Regrid class with x = sphere.Regrid(lonArrayOut, latArrayOut, lonArrayIn, latArrayIn, numberLevels = nlev, numberTimes = ntime) where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArrayOut = output grid longitude vector (required) latArrayOut = output grid latitude vector (required) lonArrayIn = input grid longitude vector (required) latArrayIn = input grid latitude vector (required) numberLevels = input grid number of levels (optional) numberTimes = input grid number of times (optional) As an example of the second step, regridding a scalar function sf is accomplished with sf = x.regridScalar(sf) or sf = x.regridScalar(sf, missingValue) The second form looks for the presence of missing data and returns an error if found. It uses the exact value so it must be the value in the data file. Shifting For the grid shifting as step one make an instance x of the Shiftgrid class with x = sphere.Shiftgrid(lonArray, latArray, numberLevels = nlev, numberTimes = ntime) where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArray = longitude vector (required) latArray = latitude vector (required) numberLevels = number of levels (optional) numberTimes = number of times (optional) As an example of the second step, shifting a scalar function sf is accomplished with sf = x.shiftScalar(sf) or sf = x.shiftScalar(sf, missingValue) The second form looks for the presence of missing data and returns an error if found. It uses the exact value so it must be the value in the data file. GENERAL EXAMPLE Step 1. Type import sphere Step 2. From this documentation determine the class which offers the desired computation. There are only three choices: the Sphere class, Regrid class and Shiftgrid class to use in ClassName below. Instructions on making an instance is obtained by typing sphere.help('ClassName') Step 3. Make an instance, x, of the specific class ClassName using the statement x = sphere.ClassName(argument1, argument2, .........) Step 4. Perform the actual computation using a specific function named functionName, which has been identified from this documentation. returned values = x.functionName(argument1, argument2, .........) To get information about the agrument list type sphere.help('functionName') TESTING Typing cdat spheretest.py generates some testing of the spheremodule using analytical functions as fields. For additional testing using real geophysical data, you might try the following exercise. Step 1. Get winds u and v and their grid vectors, longitude values (lonvals) and latitude values (latvals), from somewhere.This example uses 2D fields for simplicity. The fields must be global without missing values. Step 2. Make an instance of the Sphere class, x, as x = sphere.Sphere(lonvals, latvals) Step 3. Compute the streamfunction, sf, and the velocity potential, vp, using sf, vp = x.sfvp(u, v) Step 4. Compute the source for the streamfunction, sf_source, and the velocity potential, vp_source, using the scalar Laplacian sf_source = x.slap(sf) vp_source = x.slap(vp) Step 5. Compute the source for the streamfunction, vort, and the velocity potential, div, directly using the divergence and the vorticity vort = x.vrt(u, v) div = x.div(u, v) Step 6. Compare the results for equality, sf_source with vort and vp_source with div. If the comparison fails, please complain about it. """ import sys, string import spherepack, numpy, math #spherepack.set_pyfort_option(spherepack.MIRROR) debug = 0 # set to 1 for debug prints radius = 6.37122e06 usefilled = 'yes' try: import numpy.ma except ImportError: print 'Can not convert from numpy.ma array to numpy array without module numpy.ma' usefilled = 'no' class Sphere: #------------------------------------------------------------------------------------------------------- # # Contents of Sphere class # # The functions for computing differential operations and their inverses on scalar # and vector functions in spherical coordinates on a global grid are: # # div -- computes the divergence of a vector function # idiv -- inverts the divergence creating an irrotational vector function # vrt -- the vorticity of a vector function # ivrt -- inverts the vorticity creating a divergence_free vector function # idvt -- inverts the divergence and the vorticity creating a vector function # # vts -- computes the derivative of the vector function with respect to latitude # grad -- computes the gradient of a scalar function # igrad -- inverts the gradient creating a scalar function # slap -- computes the Laplacian of a scalar function # islap -- inverts the Laplacian of a scalar function # vlap -- computes the Laplacian of a vector function # ivlap -- inverts the Laplacian of a vector function # sfvp -- computes the stream function and the velocity potential of a vector function # isfvp -- inverts the stream function and the velocity potential of a vector function # # One additional function, not part of the basic library, has been added to perform triangular # truncation with or withhout tapering: # # truncation-- truncates scalar or vector data at specified total wavenumber # # The basic functions for spectral analysis and synthesis directly accessible from python are: # # sha -- computes the spherical harmonic analysis of a scalar function # shs -- computes the spherical harmonic synthesis of a scalar function # vha -- computes the spherical harmonic analysis of a vector function # vhs -- computes the spherical harmonic synthesis of a vector function # #------------------------------------------------------------------------------------------------------- def __init__(self, lonArray, latArray, numberLevels = None, numberTimes = None, computed_stored = 'computed'): """ -------------------------------------------------------------------------------------------------------- routine: __init__ for class Sphere purpose: 'init' assigns values to the instance data which are the dimensions lengths, the latitude direction, the latitude type as gaussian or even and the computational scheme computed_stored. usage: x = sphere.Sphere(lonvals, latvals) 2D data x = sphere.Sphere(lonArray = lonvals, latArray = latvals) x = sphere.Sphere(lonArray, latArray, 'stored') x = sphere.Sphere(lonvals, latvals, numberTimes = ntime) 3D data x = sphere.Sphere(lonArray = lonvals, latArray = latvals, numberTimes = ntime) x = sphere.Sphere(lonvals, latvals, numberTimes = ntime, computed_stored = 'stored') x = sphere.Sphere(lonvals, latvals, numberLevels, numberTimes) 4D data x = sphere.Sphere(lonArray = lonvals, latArray = latvals, numberLevels = nlev, numberTimes = ntime) x = sphere.Sphere(lonvals, latvals, numberLevels, numberTimes, 'stored') where nlev and ntime are the actual number of levels and times respectively. passed: lonArray = longitude vector latArray = latitude vector numberLevels = number of levels (optional) numberTimes = number of times (optional) computed_stored (optional) : 'computed' -- computed Legendre polynomials 'stored' -- stored Legendre polynomials This choice involves a 30% storage/speed tradeoff returned: x -- an instance of the Sphere class to qualify using dot notation to choose a computation definition: __init__(self, lonArray, latArray, numberLevels = None, numberTimes = None, computed_stored = 'computed'): --------------------------------------------------------------------------------------------------------""" self.inverseOrder = None # set in (v)sha for use in routines that contain mathtogeo only self.lon = len(lonArray) self.lat = len(latArray) if latArray[len(latArray)-1] > latArray[0]: self.reverseLatitude = 'mathyes' else: self.reverseLatitude = 'no' dimlist = [self.lat, self.lon] self.lev = numberLevels if numberLevels is not None and numberLevels != 0: dimlist.append(self.lev) self.tme = numberTimes if numberTimes is not None and numberTimes != 0: dimlist.append(self.tme) dimlist.reverse() self.standardShape = tuple(dimlist) # math order (ntme,nlev,nlon,nlat) # check the shape for a unique number of longitudes and a unique number of latitudes if self.lon in [self.tme, self.lev, self.lat]: print 'Warning - number of longitudes in duplicated in the shape. The geotomath shape \ transform will not work unless it differs from the number of latitudes and it \ is one of the last two entiries in the shape' if self.lat in [self.tme, self.lev, self.lon]: print 'Warning - number of latitudes in duplicated in the shape. The geotomath shape \ transform will not work unless it differs from the number of longitudes and it \ is one of the last two entiries in the shape' # check grids and get grid_type as 'even' or 'gaussian' grid_type = check_lonlat(lonArray, latArray) # pick the class of functions used in the calculation by setting self.gridComp as a class instance. In # each of the Sphere class functions self.gridComp is called gridComp to simplify the notation. The # choices are: # gc - gaussian latitudes with computed coefficients # ec - evenly spaced latitudes with computed coefficients # gs - gaussian latitudes with stored coefficients # es - evenly spaced latitudes with stored coefficients if computed_stored == 'computed': if grid_type == 'gaussian': self.gridComp = Wrapgc() else: self.gridComp = Wrapec() elif computed_stored == 'stored': if grid_type == 'gaussian': self.gridComp = Wrapgs() else: self.gridComp = Wrapes() else: msg = 'CANNOT PROCESS THE DATA - The computation scheme for the coefficients must be either computed or stored' raise ValueError, msg def div(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: div purpose: computes the divergence of a vector function usage: div = x.div( u, v, missingValue) where x is an instance of Sphere passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: div -- the divergence of the vector function definition: div(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': u = numpy.ma.filled(u) v = numpy.ma.filled(v) nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShape, u, v) # --------------------- Vector Harmonic Analysis ---------------------------- wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, u, v) # ------------------------ Scalar Harmonic Synthesis -------------------------------- wshs, lshs = gridComp.shsi(nlat, nlon) div = gridComp.div(nlat, nlon, nt, br, bi, lshs, wshs) div = mathtogeo(reverseLatitude, standardShape, inverseOrder, div) scale = 1.0/radius # scale to radius of the earth div = geoscale(scale, div) return div def grad(self, sf, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: grad purpose: computes the gradient of a scalar function usage: u, v = x.grad(sf, missingValue) passed: sf -- scalar function on a global grid returned: u -- zonal vector function v -- meridional vector function missingValue -- an optional number requesting a check for missing data definition: grad(self, sf, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': sf = numpy.ma.filled(sf) nt, inverseOrder, sf = geotomath(missingValue, reverseLatitude, standardShape, sf) # --------------------- Scalar Harmonic Analysis ---------------------------- wsha, lsha = gridComp.shai(nlat, nlon) a, b = gridComp.sha(nlat, nlon, nt, lsha, wsha, sf) # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) u, v = gridComp.grad(nlat, nlon, nt, a, b, lvhs, wvhs) u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) scale = 1.0/radius # scale to radius of the earth u, v = geoscale(scale, u, v) v = -1.0*v # make + derivatives for function increasing in south to north direction v = v.astype(numpy.float32) return u, v def idiv(self, div, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: idiv purpose: computes an irrotational vector function with given divergence usage: u, v = x.idiv(div, missingValue) passed: div -- divergence function on a global grid missingValue -- an optional number requesting a check for missing data returned: u -- zonal vector function v -- meridional vector function definition: idiv(self, div, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': div = numpy.ma.filled(div) nt, inverseOrder, div = geotomath(missingValue, reverseLatitude, standardShape, div) scale = radius # scale to unit radius of the earth div = geoscale(scale, div) # --------------------- Scalar Harmonic Analysis ---------------------------- wsha, lsha = gridComp.shai(nlat, nlon) a, b = gridComp.sha(nlat, nlon, nt, lsha, wsha, div) # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) u, v = gridComp.idiv(nlat, nlon, nt, a, b, lvhs, wvhs) u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) return u, v def idvt(self, div, vort, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: idvt purpose: computes a vector function with given divergence and vorticity usage: u, v = x.idvt(div, vort, missingValue) passed: div -- divergence function on a global grid vort -- vorticity function on a global grid missingValue -- an optional number requesting a check for missing data returned: u -- zonal vector function v -- meridional vector function definition: idvt(self, div, vort, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': div = numpy.ma.filled(div) vort = numpy.ma.filled(vort) nt, inverseOrder, div = geotomath(missingValue, reverseLatitude, standardShape, div) scale = radius # scale to unit radius of the earth div = geoscale(scale, div) nt, inverseOrder, vort = geotomath(missingValue, reverseLatitude, standardShape, vort) scale = radius # scale to unit radius of the earth vort = geoscale(scale, vort) # --------------------- Scalar Harmonic Analysis ---------------------------- wsha, lsha = gridComp.shai(nlat, nlon) ad, bd = gridComp.sha(nlat, nlon, nt, lsha, wsha, div) wsha, lsha = gridComp.shai(nlat, nlon) av, bv = gridComp.sha(nlat, nlon, nt, lsha, wsha, vort) # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) u, v = gridComp.idvt(nlat, nlon, nt, ad, bd, av, bv, lvhs, wvhs) u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) return u, v def igrad(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: igrad purpose: computes a scalar function whose gradient is a given vector function usage: sf = x.igrad(u, v, missingValue) passed: u -- zonal vector function v -- meridional vector function missingValue -- an optional number requesting a check for missing data returned: sf -- a scalar function definition: igrad(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': u = numpy.ma.filled(u) v = numpy.ma.filled(v) nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShape, u, v) # --------------------- Vector Harmonic Analysis ---------------------------- v = -1.0*v # make + derivatives for function increasing in south to north direction v = v.astype(numpy.float32) wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, u, v) # ------------------------ Scalar Harmonic Synthesis -------------------------------- wshs, lshs = gridComp.shsi(nlat, nlon) sf = gridComp.igrad(nlat, nlon, nt, lshs, wshs, br, bi) sf = mathtogeo(reverseLatitude, standardShape, inverseOrder, sf) scale = radius # scale to radius of the earth sf = geoscale(scale, sf) return sf def isfvp(self, sf, vp, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: isfvp purpose: computes a vector function with a given stream function and velocity potential usage: u, v = x.isfvp(sf, vp, missingValue): passed: sf -- stream function on a global grid vp -- velocity potential on a global grid missingValue -- an optional number requesting a check for missing data returned: u -- zonal vector function v -- meridional vector function definition: isfvp(self, sf, vp, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': sf = numpy.ma.filled(sf) vp = numpy.ma.filled(vp) nt, inverseOrder, sf = geotomath(missingValue, reverseLatitude, standardShape, sf) scale = 1.0/radius # scale to unit radius of the earth sf = geoscale(scale, sf) nt, inverseOrder, vp = geotomath(missingValue, reverseLatitude, standardShape, vp) scale = 1.0/radius # scale to unit radius of the earth vp = geoscale(scale, vp) # --------------------- Scalar Harmonic Analysis ---------------------------- wsha, lsha = gridComp.shai(nlat, nlon) as, bs = gridComp.sha(nlat, nlon, nt, lsha, wsha, sf) wsha, lsha = gridComp.shai(nlat, nlon) av, bv = gridComp.sha(nlat, nlon, nt, lsha, wsha, vp) # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) u, v = gridComp.isfvp(nlat, nlon, nt, as, bs, av, bv, lvhs, wvhs) u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) return u, v def islap(self, slap, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: islap purpose: computes a scalar function whose scalar Laplacian is given usage: sf, ierror = x.islap(slap, missingValue): passed: slap -- scalar Laplacian on a global grid missingValue -- an optional number requesting a check for missing data returned: sf -- a scalar function definition: islap(self, slap, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': slap = numpy.ma.filled(slap) nt, inverseOrder, slap = geotomath(missingValue, reverseLatitude, standardShape, slap) scale = radius*radius # scale to unit radius of the earth slap = geoscale(scale, slap) # --------------------- Scalar Harmonic Analysis ---------------------------- wsha, lsha = gridComp.shai(nlat, nlon) a, b = gridComp.sha(nlat, nlon, nt, lsha, wsha, slap) # ------------------------ Scalar Harmonic Synthesis -------------------------------- wshs, lshs = gridComp.shsi(nlat, nlon) sf = gridComp.islap( nlat, nlon, nt, lshs, wshs, a, b) sf = mathtogeo(reverseLatitude, standardShape, inverseOrder, sf) return sf def ivlap(self, ulap, vlap, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: ivlap purpose: computes a vector function whose Laplacian is a given vector vector function usage: u, v = x.ivlap(ulap, vlap, missingValue) missingValue -- an optional number requesting a check for missing data passed: ulap -- zonal Laplacian vector function on a global grid vlap -- meridional Laplacian vector function on a global grid returned: u -- zonal vector function v -- meridional vector function definition: ivlap(self, ulap, vlap, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': ulap = numpy.ma.filled(ulap) vlap = numpy.ma.filled(vlap) nt, inverseOrder, ulap, vlap = geotomath(missingValue, reverseLatitude, standardShape, ulap, vlap) scale = radius*radius # scale to unit radius of the earth ulap = geoscale(scale, ulap) vlap = geoscale(scale, vlap) # --------------------- Vector Harmonic Analysis ---------------------------- wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, ulap, vlap) # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) u, v = gridComp.ivlap( nlat, nlon, nt, br, bi, cr, ci, lvhs, wvhs) u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) return u, v def ivrt(self, vort, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: ivrt purpose: computes a divergence-free vector function whose vorticity is given usage: u, v = x.ivrt(vort, missingValue) missingValue -- an optional number requesting a check for missing data passed: vort -- vorticity on a global grid returned: u -- zonal vector function v -- meridional vector function definition: ivrt(self, vort, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': vort = numpy.ma.filled(vort) nt, inverseOrder, vort = geotomath(missingValue, reverseLatitude, standardShape, vort) scale = radius # scale to unit radius of the earth vort = geoscale(scale, vort) # --------------------- Scalar Harmonic Analysis ---------------------------- wsha, lsha = gridComp.shai(nlat, nlon) a, b = gridComp.sha(nlat, nlon, nt, lsha, wsha, vort) # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) u, v = gridComp.ivrt( nlat, nlon, nt, a, b, lvhs, wvhs) u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) return u, v def sfvp(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: sfvp purpose: computes the stream function and the velocity potential of a vector function usage: sf, vp = x.sfvp(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: sf -- stream function vp -- velocity potential definition: sfvp(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': u = numpy.ma.filled(u) v = numpy.ma.filled(v) nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShape, u, v) # --------------------- Vector Harmonic Analysis ---------------------------- wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, u, v) # ------------------------ Scalar Harmonic Synthesis -------------------------------- wshs, lshs = gridComp.shsi(nlat, nlon) sf, vp = gridComp.sfvp( nlat, nlon, nt, br, bi, cr, ci, lshs, wshs) sf = mathtogeo(reverseLatitude, standardShape, inverseOrder, sf) vp = mathtogeo(reverseLatitude, standardShape, inverseOrder, vp) scale = radius # scale to radius of the earth sf, vp = geoscale(scale, sf, vp) return sf, vp def sha(self, sf, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: sha purpose: computes analysis coefficients for a scalar function usage: a, b = x.sha(sf, missingValue) missingValue -- an optional number requesting a check for missing data passed: sf -- scalar function on global grid returned: a -- coefficients b -- coefficients definition: sha(self, sf, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': sf = numpy.ma.filled(sf) nt, inverseOrder, sf = geotomath(missingValue, reverseLatitude, standardShape, sf) self.inverseOrder = inverseOrder # ------------------------ Scalar Analysis -------------------------------- wsha, lsha = gridComp.shai(nlat, nlon) a, b = gridComp.sha( nlat, nlon, nt, lsha, wsha, sf) if a.shape[0] == 1: a = numpy.reshape(a, (a.shape[1], a.shape[2])) b = numpy.reshape(b, (b.shape[1], b.shape[2])) return a, b def shs(self, a, b): """ -------------------------------------------------------------------------------------------------------- routine: shs purpose: computes a scalar function from the coefficients usage: sf = x.shs(a, b) passed: a -- coefficients b -- coefficients returned: sf -- scalar function definition: shs(self, a, b): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude # ------------------------ Scalar Harmonic Synthesis -------------------------------- wshs, lshs = gridComp.shsi(nlat, nlon) if len(a.shape) == 2: a = numpy.reshape(a, (1, a.shape[0], a.shape[1])) b = numpy.reshape(a, (1, b.shape[0], b.shape[1])) nt = a.shape[0] sf = gridComp.shs(nlat, nlon, nt, lshs, wshs, a, b) inverseOrder = self.inverseOrder sf = mathtogeo(reverseLatitude, standardShape, inverseOrder, sf) return sf def slap(self, sf, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: slap purpose: computes a scalar Laplacian of a scalar function usage: slap = x.slap(self, sf, missingValue) missingValue -- an optional number requesting a check for missing data passed: sf -- scalar function on a global grid returned: slap -- scalar function definition: slap(self, sf, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': sf = numpy.ma.filled(sf) nt, inverseOrder, sf = geotomath(missingValue, reverseLatitude, standardShape, sf) # --------------------- Scalar Harmonic Analysis ---------------------------- wsha, lsha = gridComp.shai(nlat, nlon) a, b = gridComp.sha(nlat, nlon, nt, lsha, wsha, sf) # ------------------------ Scalar Harmonic Synthesis -------------------------------- wshs, lshs = gridComp.shsi(nlat, nlon) slap = gridComp.slap( nlat, nlon, nt, lshs, wshs, a, b) slap = mathtogeo(reverseLatitude, standardShape, inverseOrder, slap) scale = 1.0/(radius*radius) # scale to radius of the earth slap = geoscale(scale, slap) return slap def truncation(self, wave, u, v = None, taper = 'yes', missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: truncation purpose: performs a triangular truncation of a scalar or a vector function with or without tapering. For example, a request for T42 entails eliminating all values for the total wavenumber above 42. The remaining values are tapered by default. usage: u, v = truncation(42, u, v) u, v = truncation(wave, u, v) u, v = truncation(wave, u, v, 'no', missingValue): or sf = truncation(42, sf): sf = truncation(wave, sf): sf = truncation(wave, sf, v, 'no', missingValue): passed: wave - the truncation wave number. For example, a request for T42 is wave set to 42 whick entails eliminating all values for the total wavenumber above 42. u -- zonal vector function on a global grid v -- meridional vector function on a global grid or sf -- a scalar with v = None instead of u, v taper - (optional) the values remaining after truncation are tapered if the default 'yes' is not changed to 'no'. missingValue -- an optional number requesting a check for missing data returned: u, v or sf definition: truncation(self, wave, u, v = None, taper = 'yes', missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if v is None: # --------------------- Scalar Harmonic Analysis ---------------------------- if usefilled == 'yes': u = numpy.ma.filled(u) nt, inverseOrder, sf = geotomath(missingValue, reverseLatitude, standardShape, u) wsha, lsha = gridComp.shai(nlat, nlon) a, b = gridComp.sha( nlat, nlon, nt, lsha, wsha, sf) a, b = truncate(wave, a, b, taper) # ------------------------ Scalar Harmonic Synthesis -------------------------------- wshs, lshs = gridComp.shsi(nlat, nlon) sf = gridComp.shs(nlat, nlon, nt, lshs, wshs, a, b) sf = mathtogeo(reverseLatitude, standardShape, inverseOrder, sf) return sf else: # --------------------- Vector Harmonic Analysis ---------------------------- if usefilled == 'yes': u = numpy.ma.filled(u) v = numpy.ma.filled(v) nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShape, u, v) wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, u, v) br, bi = truncate(wave, br, bi, taper) cr, ci = truncate(wave, cr, ci, taper) # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) u, v = gridComp.vhs( nlat, nlon, nt, br, bi, cr, ci, lvhs, wvhs) u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) return u, v def vha(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: vha purpose: computes the vector harmonic analysis usage: br, bi, cr, ci = x.vha(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: br -- coefficients bi -- coefficients cr -- coefficients ci -- coefficients definition: vha(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': u = numpy.ma.filled(u) v = numpy.ma.filled(v) nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShape, u, v) self.inverseOrder = inverseOrder # --------------------- Vector Harmonic Analysis ---------------------------- wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, u, v) if br.shape[0] == 1: br = numpy.reshape(br, (br.shape[1], br.shape[2])) bi = numpy.reshape(bi, (bi.shape[1], bi.shape[2])) cr = numpy.reshape(cr, (cr.shape[1], cr.shape[2])) ci = numpy.reshape(ci, (ci.shape[1], ci.shape[2])) return br, bi, cr, ci def vhs(self, br, bi, cr, ci): """ -------------------------------------------------------------------------------------------------------- routine: vhs purpose: computes the vector harmonic synthesis usage: u, v = x.vhs(br, bi, cr, ci) passed: br -- coefficients bi -- coefficients cr -- coefficients ci -- coefficients returned: u -- zonal vector function v -- meridional vector function definition: vhs(self, br, bi, cr, ci): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) if len(br.shape) == 2: br = numpy.reshape(br, (1, br.shape[0], br.shape[1])) bi = numpy.reshape(bi, (1, bi.shape[0], bi.shape[1])) cr = numpy.reshape(cr, (1, cr.shape[0], cr.shape[1])) ci = numpy.reshape(ci, (1, ci.shape[0], ci.shape[1])) nt = br.shape[0] u, v = gridComp.vhs( nlat, nlon, nt, br, bi, cr, ci, lvhs, wvhs) inverseOrder = self.inverseOrder u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) return u, v def vlap(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: vlap purpose: computes the vector Laplacian of a given vector function usage: ulap, vlap = x.vlap(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: ulap -- zonal vector Laplacian function vlap -- meridional vector Laplacian function definition: vlap(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': u = numpy.ma.filled(u) v = numpy.ma.filled(v) nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShape, u, v) # --------------------- Vector Harmonic Analysis ---------------------------- wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, u, v) # --------------------- Vector Harmonic Synthesis ---------------------------- wvhs, lvhs = gridComp.vhsi(nlat, nlon) ulap, vlap = gridComp.vlap(nlat, nlon, nt, br, bi, cr, ci, lvhs, wvhs) ulap, vlap = mathtogeo(reverseLatitude, standardShape, inverseOrder, ulap, vlap) scale = 1.0/(radius*radius) # scale to radius of the earth ulap, vlap = geoscale(scale, ulap, vlap) return ulap, vlap def vrt(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: vrt purpose: computes the scalar vorticity of a vector function usage: vort = x.vrt(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: vort -- the vorticity of the vector function definition: vrt(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': u = numpy.ma.filled(u) v = numpy.ma.filled(v) nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShape, u, v) # --------------------- Vector Harmonic Analysis ---------------------------- wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, u, v) # ------------------------ Scalar Harmonic Synthesis -------------------------------- wshs, lshs = gridComp.shsi(nlat, nlon) vort = gridComp.vrt(nlat, nlon, nt, cr, ci, lshs, wshs) vort = mathtogeo(reverseLatitude, standardShape, inverseOrder, vort) scale = 1.0/radius # scale to radius of the earth vort = geoscale(scale, vort) return vort def vtsi(self): """ -------------------------------------------------------------------------------------------------------- routine: vtsi purpose: call vtsi to initailize work spaces for vts usage: wvts, lwvts = x.vtsi() passed: nothing returned: wvts -- work space array lvts -- length of work space --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat # ------------------------ Vector Initialization -------------------------------- wvts, lwvts = gridComp.vtsi(nlat, nlon) return wvts, lwvts def vts(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: vts purpose: computes the derivative of the vector function with respect to latitude usage: ud, vd = x.vrt(u, v, missingValue) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid missingValue -- an optional number requesting a check for missing data returned: ud -- zonal vector function vd -- meridional vector function definition: vts(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" gridComp = self.gridComp nlon = self.lon nlat = self.lat standardShape = self.standardShape reverseLatitude = self.reverseLatitude if usefilled == 'yes': u = numpy.ma.filled(u) v = numpy.ma.filled(v) nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShape, u, v) # --------------------- Vector Harmonic Analysis ---------------------------- wvha, lvha = gridComp.vhai(nlat, nlon) br, bi, cr, ci = gridComp.vha(nlat, nlon, nt, lvha, wvha, u, v) # --------------------- Vector Harmonic Synthesis ---------------------------- wvts, lwvts = gridComp.vtsi(nlat, nlon) u, v = gridComp.vts( nlat, nlon, nt, br, bi, cr, ci, lwvts, wvts) u, v = mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v) scale = 1.0/radius # scale to radius of the earth u, v = geoscale(scale, u, v) u = -1.0*u # make + derivatives for function increasing in south to north direction u = u.astype(numpy.float32) v = -1.0*v v = v.astype(numpy.float32) return u, v # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # +++++++++++++++++++++++++++++++ Equally spaced Case ++++++++++++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ class Wrapec: #----------------------------------------------------------------------------- # # purpose: provides a first layer 'gridComp' wrapper to assign the array # the sizes. The final layer in class Sphere, seen by user, will call # associated intializations and preliminary functions and then # return the result expected from the name of the call. # # usage: x = Wrapec() -- makes an instance # #----------------------------------------------------------------------------- def div(self, nlat, nlon, nt, br, bi, lshsec, wshsec): #----------------------------------------------------------------------------- # # purpose: computes the divergence of a vector function on a equally spaced # grid # # usage: dv = x.div(nlat, nlon, nt, br, bi, wshsec, lshsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nlon*nt + max(3*n2, nlon) + 2*nt*n1 + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') dv, ierror = spherepack.divec(nlat, nlon, isym, idv, jdv, numpy.transpose(br), numpy.transpose(bi), wshsec, work) dv = numpy.transpose(dv) if ierror != 0 or debug == 1: print ' ' print 'pass to divec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsec = ', lshsec print 'lwork = ', lwork print 'return from divec with div' if ierror != 0: msg = 'In return from call to shaeci ierror = %d' % (ierror,) raise ValueError, msg return dv def grad(self, nlat, nlon, nt, a, b, lvhsec, wvhsec): #----------------------------------------------------------------------------- # # purpose: computes the gradient of a scalar function on a equally spaced grid # # usage: u, v = x.grad(nlat, nlon, nt, a, b, wvhsec, lvhsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) + nlat*(2*n1*nt + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat # --- call gradec ---- work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.gradec(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsec, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to gradec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsec = ', lvhsec print 'lwork = ', lwork print 'return from gradec with u, v' if ierror != 0: msg = 'In return from call to gradec ierror = %d' % (ierror,) raise ValueError, msg return w, v def idiv(self, nlat, nlon, nt, a, b, lvhsec, wvhsec): #----------------------------------------------------------------------------- # # purpose: computes an irrotational vector function whose divergence is # given on a equally spaced grid. # # usage: u, v = x.idiv(nlat, nlon, nt, a, b, wvhsec, lvhsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 2*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertrb, ierror = spherepack.idivec(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsec, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to idivec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsec = ', lvhsec print 'lwork = ', lwork print 'return from idivec with u, v' if ierror != 0: msg = 'In return from call to idivec ierror = %d' % (ierror,) raise ValueError, msg return w, v def idvt(self, nlat, nlon, nt, ad, bd, av, bv, lvhsec, wvhsec): #----------------------------------------------------------------------------- # # purpose: computes a vector function with given divergence and vorticity # on a equally spaced grid. # # usage: u, v = x.idvt(nlat, nlon, nt, ad, bd, av, bv, wvhsec, lvhsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) + nlat*(4*n1*nt + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertbd, pertbv, ierror = spherepack.idvtec(nlat, nlon, isym, idvw, jdvw, numpy.transpose(ad), numpy.transpose(bd), numpy.transpose(av), numpy.transpose(bv), wvhsec,work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to idvtec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsec = ', lvhsec print 'lwork = ', lwork print 'return from idvtec with u and v' if ierror != 0: msg = 'In return from call to idvtec ierror = %d' % (ierror,) raise ValueError, msg return w, v def igrad(self, nlat, nlon, nt, lshsec, wshsec, br, bi): #----------------------------------------------------------------------------- # # purpose: computes a scalar function whose gradient is a given vector # function on a equally spaced grid # # usage: sf = x.igrad(nlat, nlon, nt, lshsec, wshsec, br, bi) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nlon*nt + max(3*n2, nlon) + 2*nt*n1 + 1) isym = 0 isf = nlat jsf = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat # --- call gradec ---- work = numpy.zeros((lwork,),'f') sf, ierror = spherepack.igradec(nlat, nlon, isym, isf, jsf, numpy.transpose(br), numpy.transpose(bi), wshsec, work) sf = numpy.transpose(sf) if ierror != 0 or debug == 1: print ' ' print 'pass to igradec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'isf = ', isf print 'jsf = ', jsf print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsec = ', lshsec print 'lwork = ', lwork print 'return from igradec with sf' if ierror != 0: msg = 'In return from call to igradec ierror = %d' % (ierror,) raise ValueError, msg return sf def isfvp(self, nlat, nlon, nt, as, bs, av, bv, lvhsec, wvhsec): #----------------------------------------------------------------------------- # # purpose: computes a vector function with a given stream function and # velocity potential on a equally spaced grid # # usage: u, v = x.isfvp(nlat, nlon, nt, as, bs, av, bv, wvhsec, lvhsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 4*n1*nt + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.isfvpec(nlat, nlon, isym, idv, jdv, numpy.transpose(as), numpy.transpose(bs), numpy.transpose(av), numpy.transpose(bv), wvhsec, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to isfvpec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lvhsec = ', lvhsec print 'lwork = ', lwork print 'return from isfvpec with u and v' if ierror != 0: msg = 'In return from call to isfvpec ierror = %d' % (ierror,) raise ValueError, msg return w, v def islap(self, nlat, nlon, nt, lshsec, wshsec, a, b): #----------------------------------------------------------------------------- # # purpose: computes a scalar function whose scalar Laplacian is given on # a equally spaced grid # # usage: sf = x.islap(nlat, nlon, nt, lshsec, wshsec, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 2*nt*n1 + 1) isym = 0 ids = nlat jds = nlon mdab = n1 ndab = nlat xlmbda = numpy.array( [0.0]*nt, numpy.float32) # call for Poisson rather than Helmholtz # --- call islapec ---- work = numpy.zeros((lwork,),'f') sf, pertrb, ierror = spherepack.islapec(nlat, nlon, isym, xlmbda, ids, jds, numpy.transpose(a), numpy.transpose(b), wshsec, work) sf = numpy.transpose(sf) if ierror != 0 or debug == 1: print ' ' print 'pass to islapec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ids = ', ids print 'jds = ', jds print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsec = ', lshsec print 'lwork = ', lwork print 'return from islapec with sf' if ierror != 0: msg = 'In return from call to islapec ierror = %d' % (ierror,) raise ValueError, msg return sf def ivlap(self, nlat, nlon, nt, br, bi, cr, ci, lvhsec, wvhsec): #----------------------------------------------------------------------------- # # purpose: computes a vector function whose Laplacian is a given vector # vector function on a equally spaced grid # # usage: u, v = x.ivlap(nlat, nlon, nt, br, bi, cr, ci, wvhsec, lvhsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) + nlat*(4*nt*n1 + 1) ityp = 0 idvw = nlat jdvw = nlon mdbc = n1 ndbc = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.ivlapec(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsec, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to ivlapec' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdbc = ', mdbc print 'ndbc = ', ndbc print 'lvhsec = ', lvhsec print 'lwork = ', lwork print 'return from ivlapec with u and v' if ierror != 0: msg = 'In return from call to ivlapec ierror = %d' % (ierror,) raise ValueError, msg return w, v def ivrt(self, nlat, nlon, nt, a, b, lvhsec, wvhsec): #----------------------------------------------------------------------------- # # purpose: computes a divergence-free vector function whose vorticity is # given on a equally spaced grid # # usage: w, v = x.ivrt(nlat, nlon, nt, a, b, wvhsec, lvhsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 2*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertrb, ierror = spherepack.ivrtec(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsec, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to ivrtec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsec = ', lvhsec print 'lwork = ', lwork print 'return from ivrtec with u, v' if ierror != 0: msg = 'In return from call to ivrtec ierror = %d' % (ierror,) raise ValueError, msg return w, v def sfvp(self, nlat, nlon, nt, br, bi, cr, ci, lshsec, wshsec): #----------------------------------------------------------------------------- # # purpose: computes the stream function and the velocity potential of a # vector function on a equally spaced grid # # usage: sf, vp = x.sfvp(nlat, nlon, nt, br, bi, cr, ci, wshsec, lshsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nt*nlon + max(3*n2, nlon) + 2*n1*nt + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') sf, vp, ierror = spherepack.sfvpec(nlat, nlon, isym, idv, jdv, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wshsec, work) sf = numpy.transpose(sf) vp = numpy.transpose(vp) if ierror != 0 or debug == 1: print ' ' print 'pass to sfvpec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsec = ', lshsec print 'lwork = ', lwork print 'return from sfvpec with sf and vp' if ierror != 0: msg = 'In return from call to sfvpec ierror = %d' % (ierror,) raise ValueError, msg return sf, vp def shai(self, nlat,nlon): #----------------------------------------------------------------------------- # # purpose: call shai for wshaec # # usage: wsha, lsha = x.shaeci(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lshaec = 2*nlat*n2 + 3*((n1 -2)*(nlat + nlat - n1 -1))/2 + nlon + 15 ldwork = nlat + 1 # --- call shaeci ---- work = numpy.zeros((ldwork,),'d') wshaec, ierror = spherepack.shaeci(nlat, nlon, lshaec, work) if ierror != 0 or debug == 1: print ' ' print 'pass to shaeci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lshaec = ', lshaec print 'ldwork = ', ldwork print 'return from shaeci with wshaec and lshaec' if ierror != 0: msg = 'In return from call to shaeci ierror = %d' % (ierror,) raise ValueError, msg return wshaec, lshaec def sha(self, nlat, nlon, nt, lshaec, wshaec, g): #----------------------------------------------------------------------------- # # purpose: call sha for coefficients # # usage: a, b = x.sha(nlat, nlon, lshaec, wshaec, g) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nt*nlon + max(3*n2, nlon)) isym = 0 idg = nlat jdg = nlon mdab = n1 ndab = nlat # --- call shaec ---- work = numpy.zeros((lwork,),'f') a, b, ierror = spherepack.shaec(nlat, nlon, isym, numpy.transpose(g), mdab, ndab, wshaec, work) a = numpy.transpose(a) b = numpy.transpose(b) if ierror != 0 or debug == 1: print ' ' print 'pass to shaec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idg = ', idg print 'jdg = ', jdg print 'mdab = ', mdab print 'ndab = ', ndab print 'lshaec = ', lshaec print 'lwork = ', lwork print 'return from shaec with a, b' if ierror != 0: msg = 'In return from call to shaec ierror = %d' % (ierror,) raise ValueError, msg return a, b def shsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call shsi for wshsec # # usage: wshs, lshs = x.shsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lshsec = 2*nlat*n2 + 3*((n1 -2)*(nlat + nlat - n1 -1))/2 + nlon + 15 ldwork = nlat + 1 # --- call shseci ---- work = numpy.zeros((ldwork,),'d') wshsec, ierror = spherepack.shseci(nlat, nlon, lshsec, work) if ierror != 0 or debug == 1: print ' ' print 'pass to shseci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lshsec = ', lshsec print 'ldwork = ', ldwork print 'return from shseci with wshsec and lshsec' if ierror != 0: msg = 'In return from call to shseci ierror = %d' % (ierror,) raise ValueError, msg return wshsec, lshsec def shs(self, nlat, nlon, nt, lshsec, wshsec, a, b): #----------------------------------------------------------------------------- # # purpose: computes the spherical harmonic synthesis on an evenly spaced grid # # usage: g = x.shs(nlat,nlon, nt, lshsec, wshsec, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nt*nlon + max(3*n2, nlon)) isym = 0 idg = nlat jdg = nlon mdab = n1 ndab = nlat # --- call shsec ---- work = numpy.zeros((lwork,),'f') g, ierror = spherepack.shsec(nlat, nlon, isym, idg, jdg, numpy.transpose(a), numpy.transpose(b), wshsec, work) g = numpy.transpose(g) if ierror != 0 or debug == 1: print ' ' print 'pass to shsec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idg = ', idg print 'jdg = ', jdg print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsec = ', lshsec print 'lwork = ', lwork print 'return from shsec with g' if ierror != 0: msg = 'In return from call to shsec ierror = %d' % (ierror,) raise ValueError, msg return g def slap(self, nlat, nlon, nt, lshsec, wshsec, a, b): #----------------------------------------------------------------------------- # # purpose: computes a scalar Laplacian of a scalar function on a equally spaced # grid # # usage: slap = x.slap(nlat, nlon, nt, lshsec, wshsec, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 2*nt*n1 + 1) isym = 0 ids = nlat jds = nlon mdab = n1 ndab = nlat # --- call slapec ---- work = numpy.zeros((lwork,),'f') slap, ierror = spherepack.slapec(nlat, nlon, isym, ids, jds, numpy.transpose(a), numpy.transpose(b), wshsec, work) slap = numpy.transpose(slap) if ierror != 0 or debug == 1: print ' ' print 'pass to slapec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ids = ', ids print 'jds = ', jds print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsec = ', lshsec print 'lwork = ', lwork print 'return from slapec with slap' if ierror != 0: msg = 'In return from call to slapec ierror = %d' % (ierror,) raise ValueError, msg return slap def vhai(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call vhai for wvhaec # # usage: wvha, lvha = x.vhai(nlat, nlon) # # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lvhaec = 4*nlat*n2 + 3*max(n1 - 2, 0)*(2*nlat - n1 - 1) + nlon + 15 ldwork = 2*(nlat + 2) # --- call vhaeci ---- work = numpy.zeros((ldwork,),'d') wvhaec, ierror = spherepack.vhaeci(nlat, nlon, lvhaec, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vhaeci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lvhaec = ', lvhaec print 'ldwork = ', ldwork print 'return from vhaeci with wvhaec and lvhaec' if ierror != 0: msg = 'In return from call to vhaeci ierror = %d' % (ierror,) raise ValueError, msg return wvhaec, lvhaec def vha(self, nlat, nlon, nt, lvhaec, wvhaec, w, v): #----------------------------------------------------------------------------- # # purpose: computes the vector harmonic analysis on a equally spaced grid # # usage: br, bi, cr, ci = x.vha(nlat, nlon, nt, lvhaec, wvhaec, w, v) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2,nlon)) ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat # --- call vhaec ---- work = numpy.zeros((lwork,),'f') br, bi, cr, ci, ierror = spherepack.vhaec(nlat, nlon, ityp, numpy.transpose(v), numpy.transpose(w), mdab, ndab, wvhaec, work) br = numpy.transpose(br) bi = numpy.transpose(bi) cr = numpy.transpose(cr) ci = numpy.transpose(ci) if ierror != 0 or debug == 1: print ' ' print 'pass to vhaec' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhaec = ', lvhaec print 'lwork = ', lwork print 'return from vhaec with br,bi,cr,ci' if ierror != 0: msg = 'In return from call to vhaec ierror = %d' % (ierror,) raise ValueError, msg return br, bi, cr, ci def vhsi(self, nlat,nlon): #----------------------------------------------------------------------------- # # purpose: call vhseci for wvhsec # # usage: wvhs, lvhs = x.vhsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lvhsec = 4*nlat*n2 + 3*max(n1 - 2, 0)*(2*nlat - n1 -1) + nlon + 15 ldwork = 2*(nlat + 2) # --- call vhseci ---- work = numpy.zeros((ldwork,),'d') wvhsec, ierror = spherepack.vhseci(nlat, nlon, lvhsec, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vhseci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lvhsec = ', lvhsec print 'ldwork = ', ldwork print 'return from vhseci with wvhsec and lvhsec' if ierror != 0: msg = 'In return from call to vhseci ierror = %d' % (ierror,) raise ValueError, msg return wvhsec, lvhsec def vhs(self, nlat, nlon, nt, br, bi, cr, ci, lvhsec, wvhsec): #----------------------------------------------------------------------------- # # purpose: computes the vector harmonic synthesis on a equally spaced grid # # usage: w, v = x.vhs(nlat, nlon, nt, br, bi, cr, ci, wvhsec, lvhsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vhsec(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsec, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vhsec' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsec = ', lvhsec print 'lwork = ', lwork print 'return from vhsec with u and v' if ierror != 0: msg = 'In return from call to vhsec ierror = %d' % (ierror,) raise ValueError, msg return w, v def vlap(self, nlat, nlon, nt, br, bi, cr, ci, lvhsec, wvhsec): #----------------------------------------------------------------------------- # # purpose: computes the vector Laplacian of a given vector function # on a equally spaced grid # # usage: u, v = x.vlap(nlat, nlon, nt, br, bi, cr, ci, lvhsec, wvhsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) + nlat*(4*nt*n1 + 1) ityp = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdbc = n1 ndbc = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vlapec(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsec, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vlapec' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdbc = ', mdbc print 'ndbc = ', ndbc print 'lvhsec = ', lvhsec print 'lwork = ', lwork print 'return from vlapec with u and v' if ierror != 0: msg = 'In return from call to vlapec ierror = %d' % (ierror,) raise ValueError, msg return w, v def vrt(self, nlat, nlon, nt, cr, ci, lshsec, wshsec): #----------------------------------------------------------------------------- # # purpose: computes the scalar vorticity of a vector function on an # equally spaced grid # # usage: vort = x.vrt(nlat, nlon, nt, cr, ci, lshsec, wshsec) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 isym = 0 ivrt = nlat jvrt = nlon mdc = n1 ndc = nlat n1 = min(nlat, (nlon + 2)/2) # note: error in sizes in vrtec.f comment section n2 = (nlat + 1)/2 lwork = nlat*(nt*nlon + max(3*n2, nlon) + 2*nt*n1 + 1) work = numpy.zeros((lwork,),'f') vort, ierror = spherepack.vrtec(nlat, nlon, isym, ivrt, jvrt, numpy.transpose(cr), numpy.transpose(ci), wshsec, work) vort = numpy.transpose(vort) if ierror != 0 or debug == 1: print ' ' print 'pass to vortec' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ivrt = ', ivrt print 'jvrt = ', jvrt print 'mdc = ', mdc print 'ndc = ', ndc print 'lshsec = ', lshsec print 'lwork = ', lwork print 'return from vrtec with vort' if ierror != 0: msg = 'In return from call to vrtec ierror = %d' % (ierror,) raise ValueError, msg return vort def vtsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: initializes wvts for vtsec # # usage: wvts, lwvts = x.vtsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwvts = 4*nlat*n2 + 3*max(n1 - 2, 0)*(nlat + nlat - n1 - 1) + nlon + 15 ldwork = nlat*(nlat + 4) # --- call vtseci ---- work = numpy.zeros((ldwork,),'d') wvts, ierror = spherepack.vtseci(nlat, nlon, lwvts, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vtseci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lwvts = ', lwvts print 'ldwork = ', ldwork print 'return from vtseci with wvts and lwvts' if ierror != 0: msg = 'In return from call to vtseci ierror = %d' % (ierror,) raise ValueError, msg return wvts, lwvts def vts(self, nlat, nlon, nt, br, bi, cr, ci, lwvts, wvts): #----------------------------------------------------------------------------- # # purpose: computes the derivative of the vector function with respect # to latitude on a equally spaced grid # # usage: u, v = x.vts(nlat, nlon, nt, br, bi, cr, ci, lwvts, wvts) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vtsec(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvts, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vtsec' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lwvts = ', lwvts print 'lwork = ', lwork print 'return from vtsec with u and v' if ierror != 0: msg = 'In return from call to vtsec ierror = %d' % (ierror,) raise ValueError, msg return w, v # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # +++++++++++++++++++++++++++++++ Gaussian Case ++++++++++++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ class Wrapgc: #---------------------------------------------------------------------------------- # # purpose: provides a first layer 'gridComp' wrapper to assign the array # sizes. The final layer in class Sphere, seen by user, will call # associated intializations and preliminary functions and then # return the result expected from the name of the call. # # usage: g = Wrapgc() -- makes an instance # #---------------------------------------------------------------------------------- def div(self, nlat, nlon, nt, br, bi, lshsgc, wshsgc): #----------------------------------------------------------------------------- # # purpose: computes the divergence of a vector function on a gaussian # grid # # usage: dv = g.div(nlat, nlon, nt, br, bi, lshsgc, wshsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nlon*nt + max(3*n2, nlon) + 2*nt*n1 + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') dv, ierror = spherepack.divgc(nlat, nlon, isym, idv, jdv, numpy.transpose(br), numpy.transpose(bi), wshsgc,work) dv = numpy.transpose(dv) if ierror != 0 or debug == 1: print ' ' print 'pass to divgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsgc = ', lshsgc print 'lwork = ', lwork print 'return from divgc with div' if ierror != 0: msg = 'In return from call to divgc ierror = %d' % (ierror,) raise ValueError, msg return dv def grad(self, nlat, nlon, nt, a, b, lvhsgc, wvhsgc): #----------------------------------------------------------------------------- # # purpose: computes the gradient of a scalar function on a gaussian grid # # usage: u, v = g.grad(nlat, nlon, nt, a, b, lvhsgc, wvhsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) + nlat*(2*n1*nt + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat # --- call gradgc ---- work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.gradgc(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsgc, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to gradgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgc = ', lvhsgc print 'lwork = ', lwork print 'return from gradgc with u, v' if ierror != 0: msg = 'In return from call to gradgc ierror = %d' % (ierror,) raise ValueError, msg return w, v def idiv(self, nlat, nlon, nt, a, b, lvhsgc, wvhsgc): #----------------------------------------------------------------------------- # # purpose: computes an irrotational vector function whose divergence is # given on a gaussian grid. # # usage: u, v = g.idiv(nlat, nlon, nt, a, b, wvhsgc, lvhsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 2*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertrb, ierror = spherepack.idivgc(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsgc, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to idivgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgc = ', lvhsgc print 'lwork = ', lwork print 'return from idivgc with u, v' if ierror != 0: msg = 'In return from call to idivgc ierror = %d' % (ierror,) raise ValueError, msg return w, v def idvt(self, nlat, nlon, nt, ad, bd, av, bv, lvhsgc, wvhsgc): #----------------------------------------------------------------------------- # # purpose: computes a vector function with given divergence and vorticity # on a gaussian grid. # # usage: u, v = g.idvt(nlat, nlon, nt, ad, bd, av, bv, wvhsgc, lvhsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 4*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertbd, pertbv, ierror = spherepack.idvtgc(nlat, nlon, isym, idvw, jdvw, numpy.transpose(ad), numpy.transpose(bd), numpy.transpose(av), numpy.transpose(bv), wvhsgc, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to idvtgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgc = ', lvhsgc print 'lwork = ', lwork print 'return from idvtgc with w and v' if ierror != 0: msg = 'In return from call to idvtgc ierror = %d' % (ierror,) raise ValueError, msg return w, v def igrad(self, nlat, nlon, nt, lshsgc, wshsgc, br, bi): #----------------------------------------------------------------------------- # # purpose: computes a scalar function whose gradient is a given vector # function on a gaussian grid # # usage: sf = g.igrad(nlat, nlon, nt, lshsgc, wshsgc, br, bi) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nlon*nt + max(3*n2, nlon) + 2*nt*n1 + 1) isym = 0 isf = nlat jsf = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat # --- call gradgc ---- work = numpy.zeros((lwork,),'f') sf, ierror = spherepack.igradgc(nlat, nlon, isym, isf, jsf, numpy.transpose(br), numpy.transpose(bi), wshsgc, work) sf = numpy.transpose(sf) if ierror != 0 or debug == 1: print ' ' print 'pass to igradgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'isf = ', isf print 'jsf = ', jsf print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsgc = ', lshsgc print 'lwork = ', lwork print 'return from igradgc with sf' if ierror != 0: msg = 'In return from call to igradgc ierror = %d' % (ierror,) raise ValueError, msg return sf def isfvp(self, nlat, nlon, nt, as, bs, av, bv, lvhsgc, wvhsgc): #----------------------------------------------------------------------------- # # purpose: computes a vector function with a given stream function and # velocity potential on a gaussian grid # # usage: u, v = g.isfvp(nlat, nlon, nt, as, bs, av, bv, wvhsgc, lvhsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 4*n1*nt + 1) isym = 0 idv = nlat jdv = nlon mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.isfvpgc(nlat, nlon, isym, idv, jdv, numpy.transpose(as), numpy.transpose(bs), numpy.transpose(av), numpy.transpose(bv), wvhsgc, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to isfvpgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lvhsgc = ', lvhsgc print 'lwork = ', lwork print 'return from isfvpgc with u and v' if ierror != 0: msg = 'In return from call to isfvpgc ierror = %d' % (ierror,) raise ValueError, msg return w, v def islap(self, nlat, nlon, nt, lshsgc, wshsgc, a, b): #----------------------------------------------------------------------------- # # purpose: computes a scalar function whose scalar Laplacian is given on # a gaussian grid # # usage: sf = g.islap(nlat, nlon, nt, lshsgc, wshsgc, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 2*nt*n1 + 1) isym = 0 ids = nlat jds = nlon mdab = n1 ndab = nlat xlmbda = numpy.array( [0.0]*nt, numpy.float32) # call for Poisson rather than Helmholtz # --- call islapgc ---- work = numpy.zeros((lwork,),'f') sf, pertrb, ierror = spherepack.islapgc(nlat, nlon, isym, xlmbda, ids, jds, numpy.transpose(a), numpy.transpose(b), wshsgc, work) sf = numpy.transpose(sf) if ierror != 0 or debug == 1: print ' ' print 'pass to islapgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ids = ', ids print 'jds = ', jds print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsgc = ', lshsgc print 'lwork = ', lwork print 'return from islapgc with sf' if ierror != 0: msg = 'In return from call to islapgc ierror = %d' % (ierror,) raise ValueError, msg return sf def ivlap(self, nlat, nlon, nt, br, bi, cr, ci, lvhsgc, wvhsgc): #----------------------------------------------------------------------------- # # purpose: computes a vector function whose Laplacian is a given vector # vector function on a gaussian grid # # usage: u, v = g.ivlap(nlat, nlon, nt, br, bi, cr, ci, wvhsgc, lvhsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) + nlat*(4*nt*n1 + 1) ityp = 0 idvw = nlat jdvw = nlon mdbc = n1 ndbc = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.ivlapgc(nlat, nlon, ityp, nt, idvw, jdvw, br, bi, cr, ci, mdbc, ndbc, wvhsgc, work) work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.ivlapgc(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsgc, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to ivlapgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdbc = ', mdbc print 'ndbc = ', ndbc print 'lvhsgc = ', lvhsgc print 'lwork = ', lwork print 'return from ivlapgc with u and v' if ierror != 0: msg = 'In return from call to ivlapgc ierror = %d' % (ierror,) raise ValueError, msg return w, v def ivrt(self, nlat, nlon, nt, a, b, lvhsgc, wvhsgc): #----------------------------------------------------------------------------- # # purpose: computes a divergence-free vector function whose vorticity is # given on a gaussian grid # # usage: w, v, ierror = g.ivrt(nlat, nlon, nt, a, b, wvhsgc, lvhsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 2*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertrb, ierror = spherepack.ivrtgc(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsgc, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to ivrtgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgc = ', lvhsgc print 'lwork = ', lwork print 'return from ivrtgc with u, v' if ierror != 0: msg = 'In return from call to ivrtgc ierror = %d' % (ierror,) raise ValueError, msg return w, v def sfvp(self, nlat, nlon, nt, br, bi, cr, ci, lshsgc, wshsgc): #----------------------------------------------------------------------------- # # purpose: computes the stream function and the velocity potential of a # vector function on a gaussian grid # # usage: sf, vp = g.sfvp(nlat, nlon, nt, br, bi, cr, ci, wshsgc, lshsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nt*nlon + max(3*n2, nlon) + 2*n1*nt + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') sf, vp, ierror = spherepack.sfvpgc(nlat, nlon, isym, idv, jdv, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wshsgc, work) sf = numpy.transpose(sf) vp = numpy.transpose(vp) if ierror != 0 or debug == 1: print ' ' print 'pass to sfvpgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsgc = ', lshsgc print 'lwork = ', lwork print 'return from sfvpgc with sf and vp' if ierror != 0: msg = 'In return from call to sfvpgc ierror = %d' % (ierror,) raise ValueError, msg return sf, vp def shai(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call shai for wshagc and lshagc # # usage: wshagc, lshagc = g.shai(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lshagc = nlat*(2*n2 + 3*n1 - 2) + 3*n1*max(1 - n1, 0)/2 + nlon + 15 ldwork = nlat*(nlat + 4) # --- call shagci ---- work = numpy.zeros((ldwork,),'d') wshagc, ierror = spherepack.shagci(nlat, nlon, lshagc, work) if ierror != 0 or debug == 1: print ' ' print 'pass to shagci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lshagc = ', lshagc print 'ldwork = ', ldwork print 'return from shagci with wshagc and lshagc' if ierror != 0: msg = 'In return from call to shagci ierror = %d' % (ierror,) raise ValueError, msg return wshagc, lshagc def sha(self, nlat, nlon, nt, lshagc, wshagc, g): #----------------------------------------------------------------------------- # # purpose: computes the spherical harmonic analysis on a gaussian grid # # usage: a, b = g.sha(nlat, nlon, nt, lshagc, wshagc, g) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nlon*nt + max(3*n2, nlon)) isym = 0 idg = nlat jdg = nlon mdab = n1 ndab = nlat # --- call shagc ---- work = numpy.zeros((lwork,),'f') a, b, ierror = spherepack.shagc(nlat, nlon, isym, numpy.transpose(g), mdab, ndab, wshagc, work) a = numpy.transpose(a) b = numpy.transpose(b) if ierror != 0 or debug == 1: print ' ' print 'pass to shagc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idg = ', idg print 'jdg = ', jdg print 'mdab = ', mdab print 'ndab = ', ndab print 'lshagc = ', lshagc print 'lwork = ', lwork print 'return from shagc with a, b' if ierror != 0: msg = 'In return from call to shagc ierror = %d' % (ierror,) raise ValueError, msg return a, b def shsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call shsgci for wshsgc and lshsgc # # usage: wshsgc, lshsgc = g.shsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lshsgc = nlat*(2*n2 + 3*n1 - 2) + 3*n1*max(1 - n1, 0)/2 + nlon + 15 ldwork = nlat*(nlat + 4) # --- call shsgci ---- work = numpy.zeros((ldwork,),'d') wshsgc, ierror = spherepack.shsgci(nlat, nlon, lshsgc, work) if ierror != 0 or debug == 1: print ' ' print 'pass to shsgci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lshsgc = ', lshsgc print 'ldwork = ', ldwork print 'return from shsgci with wshsgc and lshsgc' if ierror != 0: msg = 'In return from call to shsgci ierror = %d' % (ierror,) raise ValueError, msg return wshsgc, lshsgc def shs(self, nlat, nlon, nt, lshsgc, wshsgc, a, b): #----------------------------------------------------------------------------- # # purpose: computes the spherical harmonic synthesis on a gaussian grid # # usage: g = g.shs(nlat,nlon, nt, lshsgc, wshsgc, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nlon*nt + max(3*n2, nlon) ) mode = 0 idg = nlat jdg = nlon mdab = n1 ndab = nlat # --- call shsgc ---- work = numpy.zeros((lwork,),'f') g, ierror = spherepack.shsgc(nlat, nlon, mode, idg, jdg, numpy.transpose(a), numpy.transpose(b), wshsgc, work) g = numpy.transpose(g) if ierror != 0 or debug == 1: print ' ' print 'pass to shsgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'mode = ', mode print 'nt = ', nt print 'idg = ', idg print 'jdg = ', jdg print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsgc = ', lshsgc print 'lwork = ', lwork print 'return from shsgc with g' if ierror != 0: msg = 'In return from call to shsgc ierror = %d' % (ierror,) raise ValueError, msg return g def slap(self, nlat, nlon, nt, lshsgc, wshsgc, a, b): #----------------------------------------------------------------------------- # # purpose: computes a scalar Laplacian of a scalar function on a gaussian # grid # # usage: slap = g.slap(nlat, nlon, nt, lshsgc, wshsgc, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon) + 2*nt*n1 + 1) isym = 0 ids = nlat jds = nlon mdab = n1 ndab = nlat # --- call slapgc ---- work = numpy.zeros((lwork,),'f') slap, ierror = spherepack.slapgc(nlat, nlon, isym, ids, jds, numpy.transpose(a), numpy.transpose(b), wshsgc, work) slap = numpy.transpose(slap) if ierror != 0 or debug == 1: print ' ' print 'pass to slapgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ids = ', ids print 'jds = ', jds print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsgc = ', lshsgc print 'lwork = ', lwork print 'return from slapgc with slap' if ierror != 0: msg = 'In return from call to slapgc ierror = %d' % (ierror,) raise ValueError, msg return slap def vhai(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call vhai for wvhagc and lvhagc # # usage: wvhagc, lvhagc = g.vhai(nlat, nlon) # # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lvhagc = 4*nlat*n2 + 3*max(n1 - 2, 0)*(2*nlat - n1 - 1) + nlon + n2 + 15 ldwork = 2*nlat*(nlat + 1) + 1 # --- call vhagci ---- work = numpy.zeros((ldwork,),'d') wvhagc, ierror = spherepack.vhagci(nlat, nlon, lvhagc, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vhagci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lvhagc = ', lvhagc print 'ldwork = ', ldwork print 'return from vhagci with wvhagc' if ierror != 0: msg = 'In return from call to vhagci ierror = %d' % (ierror,) raise ValueError, msg return wvhagc, lvhagc def vha(self, nlat, nlon, nt, lvhagc, wvhagc, w, v): #----------------------------------------------------------------------------- # # purpose: computes the vector harmonic analysis on a gaussian grid # # usage: br, bi, cr, ci = g.vhagc(nlat, nlon, nt, lvhagc, wvhagc, w, v) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = 2*nlat*(2*nlon*nt + 3*n2) ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat # --- call vhagc ---- work = numpy.zeros((lwork,),'f') br, bi, cr, ci, ierror = spherepack.vhagc(nlat, nlon, ityp, numpy.transpose(v), numpy.transpose(w), mdab, ndab, wvhagc, work) br = numpy.transpose(br) bi = numpy.transpose(bi) cr = numpy.transpose(cr) ci = numpy.transpose(ci) if ierror != 0 or debug == 1: print ' ' print 'pass to vhagc' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhagc = ', lvhagc print 'lwork = ', lwork print 'return from vhagc with br,bi,cr,ci' if ierror != 0: msg = 'In return from call to vhagc ierror = %d' % (ierror,) raise ValueError, msg return br, bi, cr, ci def vhsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call vhsgci for wvhsgc # # usage: wvhsgc, lvhsgc = g.vhsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lvhsgc = 4*nlat*n2 + 3*max(n1 - 2, 0)*(2*nlat - n1 -1) + nlon + 15 ldwork = 2*nlat*(nlat + 1) + 1 # --- call vhsgci ---- work = numpy.zeros((ldwork,),'d') wvhsgc, ierror = spherepack.vhsgci(nlat, nlon, lvhsgc, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vhsgci' print 'nlon = ', nlon print 'nlat = ', nlat print 'lvhsgc = ', lvhsgc print 'ldwork = ', ldwork print 'return from vhsgci with wvhsgc' if ierror != 0: msg = 'In return from call to vhsgci ierror = %d' % (ierror,) raise ValueError, msg return wvhsgc, lvhsgc def vhs(self, nlat, nlon, nt, br, bi, cr, ci, lvhsgc, wvhsgc): #----------------------------------------------------------------------------- # # purpose: computes the vector harmonic synthesis on a gaussian grid # # usage: u, v = g.vhs(nlat, nlon, nt, br, bi, cr, ci, wvhsgc, lvhsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vhsgc(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsgc, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vhsgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgc = ', lvhsgc print 'lwork = ', lwork print 'return from vhsgc with u and v' if ierror != 0: msg = 'In return from call to vhsgc ierror = %d' % (ierror,) raise ValueError, msg return w, v def vlap(self, nlat, nlon, nt, br, bi, cr, ci, lvhsgc, wvhsgc): #----------------------------------------------------------------------------- # # purpose: computes the vector Laplacian of a given vector function # on a gaussian grid # # usage: u, v = g.vlap(nlat, nlon, nt, br, bi, cr, ci, wvhsgc, lvhsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) + nlat*(4*nt*n1 + 1) ityp = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdbc = n1 ndbc = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vlapgc(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsgc, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vlapgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdbc = ', mdbc print 'ndbc = ', ndbc print 'lvhsgc = ', lvhsgc print 'lwork = ', lwork print 'return from vlapgc with u and v' if ierror != 0: msg = 'In return from call to vlapgc ierror = %d' % (ierror,) raise ValueError, msg return w, v def vrt(self, nlat, nlon, nt, cr, ci, lshsgc, wshsgc): #----------------------------------------------------------------------------- # # purpose: computes the scalar vorticity of a vector function on a # gaussian grid # # usage: vort = g.vrt(nlat, nlon, nt, cr, ci, wshsgc, lshsgc) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(nlon*nt + max(3*n2, nlon) + 2*nt*n1 + 1) isym = 0 ivrt = nlat jvrt = nlon mdc = n1 ndc = nlat work = numpy.zeros((lwork,),'f') vort, ierror = spherepack.vrtgc(nlat, nlon, isym, ivrt, jvrt, numpy.transpose(cr), numpy.transpose(ci), wshsgc, work) vort = numpy.transpose(vort) if ierror != 0 or debug == 1: print ' ' print 'pass to vortgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ivrt = ', ivrt print 'jvrt = ', jvrt print 'mdc = ', mdc print 'ndc = ', ndc print 'lshsgc = ', lshsgc print 'lwork = ', lwork print 'return from vrtgc with vort' if ierror != 0: msg = 'In return from call to vrtgc ierror = %d' % (ierror,) raise ValueError, msg return vort def vtsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: initializes wvts for vtsgc # # usage: wvts, lwvts = g.vtsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwvts = 4*nlat*n2 + 3*max(n1 - 2, 0)*(nlat + nlat - n1 - 1) + nlon + 15 ldwork = nlat*(nlat + 4) # --- call vtsgci ---- work = numpy.zeros((ldwork,),'d') wvts, ierror = spherepack.vtsgci(nlat, nlon, lwvts, work) if ierror != 0 or debug == 1: print ' ' print 'nlon = ', nlon print 'nlat = ', nlat print 'lwvts = ', lwvts print 'ldwork = ', ldwork print 'return from vtsgci with wvts and lwvts' if ierror != 0: msg = 'In return from call to vtsi ierror = %d' % (ierror,) raise ValueError, msg return wvts, lwvts def vts(self, nlat, nlon, nt, br, bi, cr, ci, lwvts, wvts): #----------------------------------------------------------------------------- # # purpose: computes the derivative of the vector function with respect # to latitude on a gaussian grid # # usage: w, v = g.vts(nlat, nlon, nt, br, bi, cr, ci, wvts, lwvts) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*(2*nt*nlon + max(6*n2, nlon)) ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vtsgc(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvts, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vtsgc' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lwvts = ', lwvts print 'lwork = ', lwork print 'return from vtsgc with u and v' if ierror != 0: msg = 'In return from call to vtsgc ierror = %d' % (ierror,) raise ValueError, msg return w, v # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++ Equally Spaced Stored Case ++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ class Wrapes: #----------------------------------------------------------------------------------- # # purpose: provides a first layer 'gridComp' wrapper to assign the array # sizes. The final layer in class Sphere, seen by user, will call the # associated intializations and preliminary functions and then # return the result expected from the name of the call. # # usage: x = Wrapes() -- makes an instance # #----------------------------------------------------------------------------------- def div(self, nlat, nlon, nt, br, bi, lshses, wshses): #----------------------------------------------------------------------------- # # purpose: computes the divergence of a vector function on a equally spaced # grid # # usage: dv = .div(nlat, nlon, nt, br, bi, wshses, lshses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((nt + 1)*nlon + 2*nt*n1 + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') dv, ierror = spherepack.dives(nlat, nlon, isym, idv, jdv, numpy.transpose(br), numpy.transpose(bi), wshses, work) dv = numpy.transpose(dv) if ierror != 0 or debug == 1: print ' ' print 'pass to dives' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lshses = ', lshses print 'lwork = ', lwork print 'return from dives with div' if ierror != 0: msg = 'In return from call to dives ierror = %d' % (ierror,) raise ValueError, msg return dv def grad(self, nlat, nlon, nt, a, b, lvhses, wvhses): #----------------------------------------------------------------------------- # # purpose: computes the gradient of a scalar function on a equally spaced grid # # usage: u, v = x.grad(nlat, nlon, nt, a, b, wvhses, lvhses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((2*nt + 1)*nlon + 2*n1*nt + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat # --- call grades ---- work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.grades(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhses, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to grades' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhses = ', lvhses print 'lwork = ', lwork print 'return from grades with u, v' if ierror != 0: msg = 'In return from call to grades ierror = %d' % (ierror,) raise ValueError, msg return w, v def idiv(self, nlat, nlon, nt, a, b, lvhses, wvhses): #----------------------------------------------------------------------------- # # purpose: computes an irrotational vector function whose divergence is # given on a equally spaced grid. # # usage: u, v = x.idiv(nlat, nlon, nt, a, b, wvhses, lvhses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((2*nt + 1)*nlon + 2*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertrb, ierror = spherepack.idives(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhses, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to idives' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhses = ', lvhses print 'lwork = ', lwork print 'return from idives with u, v' if ierror != 0: msg = 'In return from call to idives ierror = %d' % (ierror,) raise ValueError, msg return w, v def idvt(self, nlat, nlon, nt, ad, bd, av, bv, lvhses, wvhses): #----------------------------------------------------------------------------- # # purpose: computes a vector function with given divergence and vorticity # on a equally spaced grid. # # usage: u, v = x.idvt(nlat, nlon, nt, ad, bd, av, bv, wvhses, lvhses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((2*nt + 1)*nlon + 4*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertbd, pertbv, ierror = spherepack.idvtes(nlat, nlon, isym, idvw, jdvw, numpy.transpose(ad), numpy.transpose(bd), numpy.transpose(av), numpy.transpose(bv), wvhses, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to idvtes' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhses = ', lvhses print 'lwork = ', lwork print 'return from idvtes with u and v' if ierror != 0: msg = 'In return from call to idvtes ierror = %d' % (ierror,) raise ValueError, msg return w, v def igrad(self, nlat, nlon, nt, lshses, wshses, br, bi): #----------------------------------------------------------------------------- # # purpose: computes a scalar function whose gradient is a given vector # function on a equally spaced grid # # usage: sf = x.igrad(nlat, nlon, nt, lshses, wshses, br, bi) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((nt + 1)*nlon + 2*nt*n1 + 1) isym = 0 isf = nlat jsf = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat # --- call grades ---- work = numpy.zeros((lwork,),'f') sf, ierror = spherepack.igrades(nlat, nlon, isym, isf, jsf, numpy.transpose(br), numpy.transpose(bi), wshses, work) sf = numpy.transpose(sf) if ierror != 0 or debug == 1: print ' ' print 'pass to igrades' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'isf = ', isf print 'jsf = ', jsf print 'mdb = ', mdb print 'ndb = ', ndb print 'lshses = ', lshses print 'lwork = ', lwork print 'return from igrades with sf' if ierror != 0: msg = 'In return from call to igrades ierror = %d' % (ierror,) raise ValueError, msg return sf def isfvp(self, nlat, nlon, nt, as, bs, av, bv, lvhses, wvhses): #----------------------------------------------------------------------------- # # purpose: computes a vector function with a given stream function and # velocity potential on a equally spaced grid # # usage: u, v = x.isfvp(nlat, nlon, nt, as, bs, av, bv, wvhses, lvhses) # #----------------------------------------------------------------------------- n1 = min(nlat, (nlon + 2)/2) lwork = nlat*((2*nt + 1)*nlon + 4*n1*nt + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.isfvpes(nlat, nlon, isym, idv, jdv, numpy.transpose(as), numpy.transpose(bis), numpy.transpose(av), numpy.transpose(bv), wvhses, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to isfvpes' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lvhses = ', lvhses print 'lwork = ', lwork print 'return from isfvpes with u and v' if ierror != 0: msg = 'In return from call to isfvpes ierror = %d' % (ierror,) raise ValueError, msg return w, v def islap(self, nlat, nlon, nt, lshses, wshses, a, b): #----------------------------------------------------------------------------- # # purpose: computes a scalar function whose scalar Laplacian is given on # a equally spaced grid # # usage: sf = x.islap(nlat, nlon, nt, lshses, wshses, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((nt + 1)*nlon + 2*nt*n1 + 1) isym = 0 ids = nlat jds = nlon mdab = n1 ndab = nlat xlmbda = numpy.array( [0.0]*nt, numpy.float32) # call for Poisson rather than Helmholtz # --- call islapes ---- work = numpy.zeros((lwork,),'f') sf, pertrb, ierror = spherepack.islapes(nlat, nlon, isym, xlmbda, ids, jds, numpy.transpose(a), numpy.transpose(b), wshses, work) sf = numpy.transpose(sf) if ierror != 0 or debug == 1: print ' ' print 'pass to islapes' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ids = ', ids print 'jds = ', jds print 'mdab = ', mdab print 'ndab = ', ndab print 'lshses = ', lshses print 'lwork = ', lwork print 'return from islapes with sf' if ierror != 0: msg = 'In return from call to islapes ierror = %d' % (ierror,) raise ValueError, msg return sf def ivlap(self, nlat, nlon, nt, br, bi, cr, ci, lvhses, wvhses): #----------------------------------------------------------------------------- # # purpose: computes a vector function whose Laplacian is a given vector # vector function on a equally spaced grid # # usage: u, v = x.ivlap(nlat, nlon, nt, br, bi, cr, ci, wvhses, lvhses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((2*nt + 1)*nlon + 4*nt*n1 + 1) ityp = 0 idvw = nlat jdvw = nlon mdbc = n1 ndbc = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.ivlapes(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhses, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to ivlapes' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdbc = ', mdbc print 'ndbc = ', ndbc print 'lvhses = ', lvhses print 'lwork = ', lwork print 'return from ivlapes with u and v' if ierror != 0: msg = 'In return from call to ivlapes ierror = %d' % (ierror,) raise ValueError, msg return w, v def ivrt(self, nlat, nlon, nt, a, b, lvhses, wvhses): #----------------------------------------------------------------------------- # # purpose: computes a divergence-free vector function whose vorticity is # given on a equally spaced grid # # usage: w, v = x.ivrt(nlat, nlon, nt, a, b, wvhses, lvhses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((2*nt + 1)*nlon + 2*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertrb, ierror = spherepack.ivrtes(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhses, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to ivrtes' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhses = ', lvhses print 'lwork = ', lwork print 'return from ivrtes with u, v' if ierror != 0: msg = 'In return from call to ivrtes ierror = %d' % (ierror,) raise ValueError, msg return w, v def sfvp(self, nlat, nlon, nt, br, bi, cr, ci, lshses, wshses): #----------------------------------------------------------------------------- # # purpose: computes the stream function and the velocity potential of a # vector function on a equally spaced grid # # usage: sf, vp = x.sfvp(nlat, nlon, nt, br, bi, cr, ci, wshses, lshses) # #----------------------------------------------------------------------------- # lwork size changed to use n1 - not n2 as in the fortran code if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) lwork = nlat*((nt + 1)*nlon + 2*n1*nt + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') sf, vp, ierror = spherepack.sfvpes(nlat, nlon, isym, idv, jdv, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wshses, work) sf = numpy.transpose(sf) vp = numpy.transpose(vp) if ierror != 0 or debug == 1: print ' ' print 'pass to sfvpes' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lshses = ', lshses print 'lwork = ', lwork print 'return from sfvpes with sf and vp' if ierror != 0: msg = 'In return from call to sfvpes ierror = %d' % (ierror,) raise ValueError, msg return sf, vp def shai(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call shai for wshaes # # usage: wsha, lsha = x.shai(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lshaes = (n1*n2*(nlat + nlat - n1 + 1))/2 + nlon + 15 lwork = 5*nlat*n2 + 3*((n1 - 2)*(nlat + nlat - n1 -1))/2 ldwork = nlat + 1 # --- call shaesi ---- work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') wshaes, ierror = spherepack.shaesi(nlat, nlon, lshaes, work, dwork) if ierror != 0 or debug == 1: print ' ' print 'pass to shaesi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lshaes = ', lshaes print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from shaesi with wshaes and lshaes' if ierror != 0: msg = 'In return from call to shaies ierror = %d' % (ierror,) raise ValueError, msg return wshaes, lshaes def sha(self, nlat, nlon, nt, lshaes, wshaes, g): #----------------------------------------------------------------------------- # # purpose: call sha for coefficients # # usage: a, b = x.sha(nlat, nlon, lshaes, wshaes, g) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (nt + 1)*nlat*nlon isym = 0 idg = nlat jdg = nlon mdab = n1 ndab = nlat # --- call shaes ---- work = numpy.zeros((lwork,),'f') a, b, ierror = spherepack.shaes(nlat, nlon, isym, numpy.transpose(g), mdab, ndab, wshaes, work) a = numpy.transpose(a) b = numpy.transpose(b) if ierror != 0 or debug == 1: print ' ' print 'pass to shaes' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idg = ', idg print 'jdg = ', jdg print 'mdab = ', mdab print 'ndab = ', ndab print 'lshaes = ', lshaes print 'lwork = ', lwork print 'return from shaes with a, b' if ierror != 0: msg = 'In return from call to shaes ierror = %d' % (ierror,) raise ValueError, msg return a, b def shsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call shsi for wshses # # usage: wshs, lshs = x.shsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lshses = (n1*n2*(nlat + nlat - n1 +1))/2 + nlon + 15 lwork = 5*nlat*n2 + 3*((n1 - 2)*(nlat + nlat - n1 -1))/2 ldwork = nlat + 1 # --- call shsesi ---- dwork = numpy.zeros((ldwork,),'d') work = numpy.zeros((lwork,),'f') wshses, ierror = spherepack.shsesi(nlat, nlon, lshses, work, dwork) if ierror != 0 or debug == 1: print ' ' print 'pass to shsesi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lshses = ', lshses print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from shsesi with wshses and lshses' if ierror != 0: msg = 'In return from call to shsesi ierror = %d' % (ierror,) raise ValueError, msg return wshses, lshses def shs(self, nlat, nlon, nt, lshses, wshses, a, b): #----------------------------------------------------------------------------- # # purpose: computes the spherical harmonic synthesis on an evenly spaced grid # # usage: g = x.shs(nlat,nlon, nt, lshses, wshses, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (nt +1)*nlat*nlon isym = 0 idg = nlat jdg = nlon mdab = n1 ndab = nlat # --- call shses ---- work = numpy.zeros((lwork,),'f') g, ierror = spherepack.shses(nlat, nlon, isym, idg, jdg, numpy.transpose(a), numpy.transpose(b), wshses, work) g = numpy.transpose(g) if ierror != 0 or debug == 1: print ' ' print 'pass to shses' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idg = ', idg print 'jdg = ', jdg print 'mdab = ', mdab print 'ndab = ', ndab print 'lshses = ', lshses print 'lwork = ', lwork print 'return from shses with g' if ierror != 0: msg = 'In return from call to shses ierror = %d' % (ierror,) raise ValueError, msg return g def slap(self, nlat, nlon, nt, lshses, wshses, a, b): #----------------------------------------------------------------------------- # # purpose: computes a scalar Laplacian of a scalar function on a equally spaced # grid # # usage: slap = x.slap(nlat, nlon, nt, lshses, wshses, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (nt + 1)*nlat*nlon + nlat*(2*nt*n1 + 1) isym = 0 ids = nlat jds = nlon mdab = n1 ndab = nlat # --- call slapes ---- work = numpy.zeros((lwork,),'f') slap, ierror = spherepack.slapes(nlat, nlon, isym, ids, jds, numpy.transpose(a), numpy.transpose(b), wshses, work) slap = numpy.transpose(slap) if ierror != 0 or debug == 1: print ' ' print 'pass to slapes' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ids = ', ids print 'jds = ', jds print 'mdab = ', mdab print 'ndab = ', ndab print 'lshses = ', lshses print 'lwork = ', lwork print 'return from slapes with slap' if ierror != 0: msg = 'In return from call to slapes ierror = %d' % (ierror,) raise ValueError, msg return slap def vhai(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call vhasi for wvhaes # # usage: wvha, lvha = x.vhai(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lvhaes = n1*n2*(nlat + nlat - n1 + 1) + nlon + 15 lwork = 3*(max(n1 -2,0)*(nlat + nlat - n1 - 1))/2 + 5*n2*nlat ldwork = 2*(nlat + 1) # --- call vhaesi ---- work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') wvhaes, ierror = spherepack.vhaesi(nlat, nlon, lvhaes, work, dwork) if ierror != 0 or debug == 1: print ' ' print 'pass to vhaesi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lvhaes = ', lvhaes print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from vhaesi with wvhaes and lvhaes' if ierror != 0: msg = 'In return from call to vhaesi ierror = %d' % (ierror,) raise ValueError, msg return wvhaes, lvhaes def vha(self, nlat, nlon, nt, lvhaes, wvhaes, w, v): #----------------------------------------------------------------------------- # # purpose: computes the vector harmonic analysis on a equally spaced grid # # usage: br, bi, cr, ci = x.vha(nlat, nlon, nt, lvhaes, wvhaes, w, v) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat # --- call vhaes ---- work = numpy.zeros((lwork,),'f') br, bi, cr, ci, ierror = spherepack.vhaes(nlat, nlon, ityp, numpy.transpose(v), numpy.transpose(w), mdab, ndab, wvhaes, work) br = numpy.transpose(br) bi = numpy.transpose(bi) cr = numpy.transpose(cr) ci = numpy.transpose(ci) if ierror != 0 or debug == 1: print ' ' print 'pass to vhaes' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhaes = ', lvhaes print 'lwork = ', lwork print 'return from vhaes with br,bi,cr,ci' if ierror != 0: msg = 'In return from call to vhaes ierror = %d' % (ierror,) raise ValueError, msg return br, bi, cr, ci def vhsi(self, nlat,nlon): #----------------------------------------------------------------------------- # # purpose: call vhsesi for wvhses # # usage: wvhs, lvhs = x.vhsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = 3*(max(n1 - 2,0)*(nlat + nlat - n1 -1))/2 + 5*n2*nlat ldwork = 2*(nlat + 1) n1 = min(nlat, (nlon + 2)/2) lvhses = n1*n2*(nlat + nlat - n1 + 1) + nlon + 15 # --- call vhsesi ---- work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') wvhses, ierror = spherepack.vhsesi(nlat, nlon, lvhses, work, dwork) if ierror != 0 or debug == 1: print ' ' print 'pass to vhsesi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lvhses = ', lvhses print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from vhsesi with wvhses and lvhses' if ierror != 0: msg = 'In return from call to vhsies ierror = %d' % (ierror,) raise ValueError, msg return wvhses, lvhses def vhs(self, nlat, nlon, nt, br, bi, cr, ci, lvhses, wvhses): #----------------------------------------------------------------------------- # # purpose: computes the vector harmonic synthesis on a equally spaced grid # # usage: w, v = x.vhs(nlat, nlon, nt, br, bi, cr, ci, wvhses, lvhses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vhses(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhses, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vhses' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhses = ', lvhses print 'lwork = ', lwork print 'return from vhses with u and v' if ierror != 0: msg = 'In return from call to vhses ierror = %d' % (ierror,) raise ValueError, msg return w, v def vlap(self, nlat, nlon, nt, br, bi, cr, ci, lvhses, wvhses): #----------------------------------------------------------------------------- # # purpose: computes the vector Laplacian of a given vector function # on a equally spaced grid # # usage: u, v = x.vlap(nlat, nlon, nt, br, bi, cr, ci, wvhses, lvhses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon + nlat*(4*nt*n1 + 1) ityp = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdbc = n1 ndbc = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vlapes(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhses, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vlapes' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdbc = ', mdbc print 'ndbc = ', ndbc print 'lvhses = ', lvhses print 'lwork = ', lwork print 'return from vlapes with u and v' if ierror != 0: msg = 'In return from call to vlapes ierror = %d' % (ierror,) raise ValueError, msg return w, v def vrt(self, nlat, nlon, nt, cr, ci, lshses, wshses): #----------------------------------------------------------------------------- # # purpose: computes the scalar vorticity of a vector function on a # on a equally spaced grid # # usage: vort = x.vrt(nlat, nlon, nt, cr, ci, wshses, lshses) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 isym = 0 ivrt = nlat jvrt = nlon mdc = n1 ndc = nlat n1 = min(nlat, nlon/2 + 1) # from the code -- not the instructions lwork = nlat*((nt + 1)*nlon + 2*nt*n1 + 1) work = numpy.zeros((lwork,),'f') vort, ierror = spherepack.vrtes(nlat, nlon, isym, ivrt, jvrt, numpy.transpose(cr), numpy.transpose(ci), wshses, work) vort = numpy.transpose(vort) if ierror != 0 or debug == 1: print ' ' print 'pass to vortes' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ivrt = ', ivrt print 'jvrt = ', jvrt print 'mdc = ', mdc print 'ndc = ', ndc print 'lshses = ', lshses print 'lwork = ', lwork print 'return from vrtes with vort' if ierror != 0: msg = 'In return from call to vrtes ierror = %d' % (ierror,) raise ValueError, msg return vort def vtsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: initializes wvts for vtses # # usage: wvts, lwvts = x.vtsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwvts = n1*n2*(nlat + nlat - n1 + 1) + nlon + 15 lwork = 3*(max(n1 - 2,0)*(nlat + nlat - n1 - 1))/2 + 5*n2*nlat ldwork = 2*(nlat + 1) # --- call vtsesi ---- work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') wvts, ierror = spherepack.vtsesi(nlat, nlon, lwvts, work, dwork) if ierror != 0 or debug == 1: print ' ' print 'pass to vtsesi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lwvts = ', lwvts print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from vtsesi with wvts and lwvts' if ierror != 0: msg = 'In return from call to vtsesi ierror = %d' % (ierror,) raise ValueError, msg return wvts, lwvts def vts(self, nlat, nlon, nt, br, bi, cr, ci, lwvts, wvts): #----------------------------------------------------------------------------- # # purpose: computes the derivative of the vector function with respest # to latitude on an evenly spaced grid # # usage: u, v = x.vts(nlat, nlon, nt, br, bi, cr, ci, wvts, lwvts) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vtses(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvts, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vtses' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lwvts = ', lwvts print 'lwork = ', lwork print 'return from vtses with u and v' if ierror != 0: msg = 'In return from call to vtses ierror = %d' % (ierror,) raise ValueError, msg return w, v # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # +++++++++++++++++++++++++ Gaussian Stored Case +++++++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ class Wrapgs: #--------------------------------------------------------------------------------- # # purpose: provides a first layer 'gridComp' wrapper to assign the array # sizes. The final layer in class Sphere, seen by user, will call # associated intializations and preliminary functions and then # return the result expected from the name of the call. # # usage: g = Wrapgs() -- makes an instance # #--------------------------------------------------------------------------------- def div(self, nlat, nlon, nt, br, bi, lshsgs, wshsgs): #----------------------------------------------------------------------------- # # purpose: computes the divergence of a vector function on a gaussian # grid # # usage: dv = g.div(nlat, nlon, nt, br, bi, wshsgs, lshsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((nt + 1)*nlon + 2*nt*n1 + 1) isym = 0 idiv = nlat jdiv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') dv, ierror = spherepack.divgs(nlat, nlon, isym, idiv, jdiv, numpy.transpose(br), numpy.transpose(bi), wshsgs, work) dv = numpy.transpose(dv) if ierror != 0 or debug == 1: print ' ' print 'pass to divgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idiv = ', idiv print 'jdiv = ', jdiv print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsgs = ', lshsgs print 'lwork = ', lwork print 'return from divgs with div' if ierror != 0: msg = 'In return from call to divgs ierror = %d' % (ierror,) raise ValueError, msg return dv def grad(self, nlat, nlon, nt, a, b, lvhsgs, wvhsgs): #----------------------------------------------------------------------------- # # purpose: computes the gradient of a scalar function on a gaussian grid # # usage: u, v = g.grad(nlat, nlon, nt, a, b, wvhsgs, lvhsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((2*nt + 1)*nlon + 2*n1*nt + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat # --- call gradgs ---- work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.gradgs(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsgs, work) v = numpy.transpose(v) w = numpy.transpose(W) if ierror != 0 or debug == 1: print ' ' print 'pass to gradgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgs = ', lvhsgs print 'lwork = ', lwork print 'return from gradgs with u, v' if ierror != 0: msg = 'In return from call to gradgs ierror = %d' % (ierror,) raise ValueError, msg return w, v def idiv(self, nlat, nlon, nt, a, b, lvhsgs, wvhsgs): #----------------------------------------------------------------------------- # # purpose: computes an irrotational vector function whose divergence is # given on a gaussian grid. # # usage: u, v = g.idiv(nlat, nlon, nt, a, b, wvhsgs, lvhsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon + nlat*(2*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertrb, ierror = spherepack.idivgs(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsgs, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to idivgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgs = ', lvhsgs print 'lwork = ', lwork print 'return from idivgs with u, v' if ierror != 0: msg = 'In return from call to idivgs ierror = %d' % (ierror,) raise ValueError, msg return w, v def idvt(self, nlat, nlon, nt, ad, bd, av, bv, lvhsgs, wvhsgs): #----------------------------------------------------------------------------- # # purpose: computes a vector function with given divergence and vorticity # on a gaussian grid. # # usage: u, v = g.idvt(nlat, nlon, nt, ad, bd, av, bv, wvhsgs, lvhsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((2*nt + 1)*nlon + 4*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertbd, pertbv, ierror = spherepack.idvtgs(nlat, nlon, isym, idvw, jdvw, numpy.transpose(ad), numpy.transpose(bd), numpy.transpose(av), numpy.transpose(bv), wvhsgs, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to idvtgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgs = ', lvhsgs print 'lwork = ', lwork print 'return from idvtgs with u and v' if ierror != 0: msg = 'In return from call to idvtgs ierror = %d' % (ierror,) raise ValueError, msg return w, v def igrad(self, nlat, nlon, nt, lshsgs, wshsgs, br, bi): #----------------------------------------------------------------------------- # # purpose: computes a scalar function whose gradient is a given vector # function on a gaussian grid # # usage: sf = g.igrad(nlat, nlon, nt, lshsgs, wshsgs, br, bi) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((nt + 1)*nlon + 2*nt*n1 + 1) isym = 0 isf = nlat jsf = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat # --- call gradgs ---- work = numpy.zeros((lwork,),'f') sf, ierror = spherepack.igradgs(nlat, nlon, isym, isf, jsf, numpy.transpose(br), numpy.transpose(bi), wshsgs, work) sf = numpy.transpose(sf) if ierror != 0 or debug == 1: print ' ' print 'pass to igradgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'isf = ', isf print 'jsf = ', jsf print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsgs = ', lshsgs print 'lwork = ', lwork print 'return from igradgs with sf' if ierror != 0: msg = 'In return from call to igradgs ierror = %d' % (ierror,) raise ValueError, msg return sf def isfvp(self, nlat, nlon, nt, as, bs, av, bv, lvhsgs, wvhsgs): #----------------------------------------------------------------------------- # # purpose: computes a vector function with a given stream function and # velocity potential on a gaussian grid # # usage: u, v, ierror = g.isfvp(nlat, nlon, nt, as, bs, av, bv, wvhsgs, lvhsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((2*nt + 1)*nlon + 4*n1*nt + 1) isym = 0 idv = nlat jdv = nlon mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.isfvpgs(nlat, nlon, isym, idv, jdv, numpy.transpose(as), numpy.transpose(bs), numpy.transpose(av), numpy.transpose(bv), wvhsgs, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to isfvpgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lvhsgs = ', lvhsgs print 'lwork = ', lwork print 'return from isfvpgs with u and v' if ierror != 0: msg = 'In return from call to isfvpgs ierror = %d' % (ierror,) raise ValueError, msg return w, v def islap(self, nlat, nlon, nt, lshsgs, wshsgs, a, b): #----------------------------------------------------------------------------- # # purpose: computes a scalar function whose scalar Laplacian is given on # a gaussian grid # # usage: sf = g.islap(nlat, nlon, nt, lshsgs, wshsgs, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (nt + 1)*nlat*nlon + nlat*(2*nt*n1 + 1) isym = 0 ids = nlat jds = nlon mdab = n1 ndab = nlat xlmbda = numpy.array( [0.0]*nt, numpy.float32) # call for Poisson rather than Helmholtz # --- call islapgs ---- work = numpy.zeros((lwork,),'f') sf, pertrb, ierror = spherepack.islapgs(nlat, nlon, isym, xlmbda, ids, jds, numpy.transpose(a), numpy.transpose(b), wshsgs, work) sf = numpy.transpose(sf) if ierror != 0 or debug == 1: print ' ' print 'pass to islapgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ids = ', ids print 'jds = ', jds print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsgs = ', lshsgs print 'lwork = ', lwork print 'return from islapgs with sf' if ierror != 0: msg = 'In return from call to islapgs ierror = %d' % (ierror,) raise ValueError, msg return sf def ivlap(self, nlat, nlon, nt, br, bi, cr, ci, lvhsgs, wvhsgs): #----------------------------------------------------------------------------- # # purpose: computes a vector function whose Laplacian is a given vector # vector function on a gaussian grid # # usage: u, v = g.ivlap(nlat, nlon, nt, br, bi, cr, ci, wvhsgs, lvhsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon + nlat*(4*nt*n1 + 1) ityp = 0 idvw = nlat jdvw = nlon mdbc = n1 ndbc = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.ivlapgs(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsgs, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to ivlapgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdbc = ', mdbc print 'ndbc = ', ndbc print 'lvhsgs = ', lvhsgs print 'lwork = ', lwork print 'return from ivlapgs with u and v' if ierror != 0: msg = 'In return from call to ivlapgs ierror = %d' % (ierror,) raise ValueError, msg return w, v def ivrt(self, nlat, nlon, nt, a, b, lvhsgs, wvhsgs): #----------------------------------------------------------------------------- # # purpose: computes a divergence-free vector function whose vorticity is # given on a gaussian grid # # usage: w, v, ierror = g.ivrt(nlat, nlon, nt, a, b, wvhsgs, lvhsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon + nlat*(2*nt*n1 + 1) isym = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, pertrb, ierror = spherepack.ivrtgs(nlat, nlon, isym, idvw, jdvw, numpy.transpose(a), numpy.transpose(b), wvhsgs, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to ivrtgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgs = ', lvhsgs print 'lwork = ', lwork print 'return from ivrtgs with u, v' if ierror != 0: msg = 'In return from call to ivrtgs ierror = %d' % (ierror,) raise ValueError, msg return w, v def sfvp(self, nlat, nlon, nt, br, bi, cr, ci, lshsgs, wshsgs): #----------------------------------------------------------------------------- # # purpose: computes the stream function and the velocity potential of a # vector function on a gaussian grid # # usage: sf, vp = g.sfvp(nlat, nlon, nt, br, bi, cr, ci, wshsgs, lshsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*nlon*(nt + 1) + nlat*(2*n1*nt + 1) isym = 0 idv = nlat jdv = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdb = n1 ndb = nlat work = numpy.zeros((lwork,),'f') sf, vp, ierror = spherepack.sfvpgs(nlat, nlon, isym, idv, jdv, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wshsgs, work) sf = numpy.transpose(sp) vp = numpy.transpose(vp) if ierror != 0 or debug == 1: print ' ' print 'pass to sfvpgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idv = ', idv print 'jdv = ', jdv print 'mdb = ', mdb print 'ndb = ', ndb print 'lshsgs = ', lshsgs print 'lwork = ', lwork print 'return from sfvpgs with sf and vp' if ierror != 0: msg = 'In return from call to sfvpgs ierror = %d' % (ierror,) raise ValueError, msg return sf, vp def shai(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call shai for wshags and lshags # # usage: wshags, lshags = g.shai(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lshags = nlat*(3*(n1 + n2) - 2) + (n1 - 1)*(n2*(2*nlat - n1) - 3*n1)/2 + nlon + 15 lwork = 4*nlat*(nlat + 2) + 2 ldwork = nlat*(nlat + 4) # --- call shagsi ---- work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') wshags, ierror = spherepack.shagsi(nlat, nlon, lshags, work, dwork) if ierror != 0 or debug == 1: print ' ' print 'pass to shagsi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lshags = ', lshags print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from shagsi with wshags and lshags' if ierror != 0: msg = 'In return from call to shagsi ierror = %d' % (ierror,) raise ValueError, msg return wshags, lshags def sha(self, nlat, nlon, nt, lshags, wshags, g): #----------------------------------------------------------------------------- # # purpose: computes the spherical harmonic analysis on a gaussian grid # # usage: a, b = g.sha(nlat, nlon, nt, lshags, wshags, g) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*nlon*(nt + 1) isym = 0 idg = nlat jdg = nlon mdab = n1 ndab = nlat # --- call shags ---- work = numpy.zeros((lwork,),'f') a, b, ierror = spherepack.shags(nlat, nlon, isym, numpy.transpose(g), mdab, ndab, wshags, work) a = numpy.transpose(a) b = numpy.transpose(b) if ierror != 0 or debug == 1: print ' ' print 'pass to shags' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'idg = ', idg print 'jdg = ', jdg print 'mdab = ', mdab print 'ndab = ', ndab print 'lshags = ', lshags print 'lwork = ', lwork print 'return from shags with a, b' if ierror != 0: msg = 'In return from call to shags ierror = %d' % (ierror,) raise ValueError, msg return a, b def shsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call shsgsi for wshsgs and lshsgs # # usage: wshsgs, lshsgs = g.shsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lshsgs = nlat*(3*(n1 + n2) -2) + (n1 - 1)*(n2*(2*nlat - n1) - 3*n1)/2 + nlon + 15 lwork = 4*nlat*(nlat + 2) + 2 ldwork = nlat*(nlat + 4) # --- call shsgsi ---- work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') wshsgs, ierror = spherepack.shsgsi(nlat, nlon, lshsgs, work, dwork) if ierror != 0 or debug == 1: print ' ' print 'pass to shsgsi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lshsgs = ', lshsgs print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from shsgsi with wshsgs and lshsgs' if ierror != 0: msg = 'In return from call to shsgsi ierror = %d' % (ierror,) raise ValueError, msg return wshsgs, lshsgs def shs(self, nlat, nlon, nt, lshsgs, wshsgs, a, b): #----------------------------------------------------------------------------- # # purpose: computes the spherical harmonic synthesis on a gaussian grid # # usage: g = g.shs(nlat,nlon, nt, lshsgs, wshsgs, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*nlon*(nt + 1) mode = 0 idg = nlat jdg = nlon mdab = n1 ndab = nlat # --- call shsgs ---- work = numpy.zeros((lwork,),'f') g, ierror = spherepack.shsgs(nlat, nlon, mode, idg, jdg, numpy.transpose(a), numpy.transpose(b), wshsgs, work) if ierror != 0 or debug == 1: print ' ' print 'pass to shsgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'mode = ', mode print 'nt = ', nt print 'idg = ', idg print 'jdg = ', jdg print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsgs = ', lshsgs print 'lwork = ', lwork print 'return from shsgs with g' if ierror != 0: msg = 'In return from call to shsgs ierror = %d' % (ierror,) raise ValueError, msg return g def slap(self, nlat, nlon, nt, lshsgs, wshsgs, a, b): #----------------------------------------------------------------------------- # # purpose: computes a scalar Laplacian of a scalar function on a gaussian # grid # # usage: slap = g.slap(nlat, nlon, nt, lshsgs, wshsgs, a, b) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (nt + 1)*nlat*nlon + nlat*(2*nt*n1 + 1) isym = 0 ids = nlat jds = nlon mdab = n1 ndab = nlat # --- call slapgs ---- work = numpy.zeros((lwork,),'f') slap, ierror = spherepack.slapgs(nlat, nlon, isym, ids, jds, numpy.transpose(a), numpy.transpose(b), wshsgs, work) if ierror != 0 or debug == 1: print ' ' print 'pass to slapgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ids = ', ids print 'jds = ', jds print 'mdab = ', mdab print 'ndab = ', ndab print 'lshsgs = ', lshsgs print 'lwork = ', lwork print 'return from slapgs with slap' if ierror != 0: msg = 'In return from call to slapgs ierror = %d' % (ierror,) raise ValueError, msg return slap def vhai(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call vhagsi for wvhags and lvhags # # usage: wvhags, lvhags = g.vhai(nlat, nlon) # # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lvhags = (nlat +1)*(nlat + 1)*nlat/2 +nlon + 15 ldwork = (3*nlat*(nlat + 3) + 2)/2 # --- call vhagsi ---- work = numpy.zeros((ldwork,),'d') wvhags, ierror = spherepack.vhagsi(nlat, nlon, lvhags, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vhagsi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lvhags = ', lvhags print 'ldwork = ', ldwork print 'return from vhagsi with wvhags' if ierror != 0: msg = 'In return from call to vhagsi ierror = %d' % (ierror,) raise ValueError, msg return wvhags, lvhags def vha(self, nlat, nlon, nt, lvhags, wvhags, w, v): #----------------------------------------------------------------------------- # # purpose: computes the vector harmonic analysis on a gaussian grid # # usage: br, bi, cr, ci = g.vhags(nlat, nlon, nt, lvhags, wvhags, v, w) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (max( (3*nlat*(nlat + 1) + 2), (2*nt + 1)*nlat*nlon) ) ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat # --- call vhags ---- work = numpy.zeros((lwork,),'f') br, bi, cr, ci, ierror = spherepack.vhags(nlat, nlon, ityp, numpy.transpose(v), numpy.transpose(w), mdab, ndab, wvhags, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vhags' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhags = ', lvhags print 'lwork = ', lwork print 'return from vhags with br,bi,cr,ci' if ierror != 0: msg = 'In return from call to vhags ierror = %d' % (ierror,) raise ValueError, msg return br, bi, cr, ci def vhsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: call vhsgsi for wvhsgs # # usage: wvhsgs, lvhsgs = g.vhsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lvhsgs = n1*n2*(nlat + nlat -n1 +1) + nlon + 15 + 2*nlat ldwork = (3*nlat*(nlat + 3) + 2)/2 # --- call vhsgsi ---- work = numpy.zeros((ldwork,),'d') wvhsgs, ierror = spherepack.vhsgsi(nlat, nlon, lvhsgs, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vhsgsi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lvhsgs = ', lvhsgs print 'ldwork = ', ldwork print 'return from vhsgsi with wvhsgs' if ierror != 0: msg = 'In return from call to vhsigs ierror = %d' % (ierror,) raise ValueError, msg return wvhsgs, lvhsgs def vhs(self, nlat, nlon, nt, br, bi, cr, ci, lvhsgs, wvhsgs): #----------------------------------------------------------------------------- # # purpose: computes the vector harmonic synthesis on a gaussian grid # # usage: u, v = g.vhs(nlat, nlon, nt, br, bi, cr, ci, wvhsgs, lvhsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vhsgs(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsgs, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vhsgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lvhsgs = ', lvhsgs print 'lwork = ', lwork print 'return from vhsgs with u and v' if ierror != 0: msg = 'In return from call to vhsgs ierror = %d' % (ierror,) raise ValueError, msg return w, v def vlap(self, nlat, nlon, nt, br, bi, cr, ci, lvhsgs, wvhsgs): #----------------------------------------------------------------------------- # # purpose: computes the vector Laplacian of a given vector function # on a gaussian grid # # usage: u, v = g.vlap(nlat, nlon, nt, br, bi, cr, ci, wvhsgs, lvhsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, (nlon + 2)/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon + nlat*(4*nt*n1 + 1) ityp = 0 idvw = nlat jdvw = nlon if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) mdbc = n1 ndbc = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vlapgs(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvhsgs, work) v = numpy.transpose(v) w = numpy.transpose(w) if ierror != 0 or debug == 1: print ' ' print 'pass to vlapgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdbc = ', mdbc print 'ndbc = ', ndbc print 'lvhsgs = ', lvhsgs print 'lwork = ', lwork print 'return from vlapgs with u and v' if ierror != 0: msg = 'In return from call to vlapgs ierror = %d' % (ierror,) raise ValueError, msg return w, v def vrt(self, nlat, nlon, nt, cr, ci, lshsgs, wshsgs): #----------------------------------------------------------------------------- # # purpose: computes the scalar vorticity of a vector function on a # gaussian grid # # usage: vort = g.vrt(nlat, nlon, nt, cr, ci, wshsgs, lshsgs) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = nlat*((nt + 1)*nlon + 2*nt*n1 + 1) isym = 0 ivrt = nlat jvrt = nlon mdc = n1 ndc = nlat work = numpy.zeros((lwork,),'f') vort, ierror = spherepack.vrtgs(nlat, nlon, isym, ivrt, jvrt, numpy.transpose(cr), numpy.transpose(ci), wshsgs, work) vort = numpy.transpose(vort) if ierror != 0 or debug == 1: print ' ' print 'pass to vortgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'isym = ', isym print 'nt = ', nt print 'ivrt = ', ivrt print 'jvrt = ', jvrt print 'mdc = ', mdc print 'ndc = ', ndc print 'lshsgs = ', lshsgs print 'lwork = ', lwork print 'return from vrtgs with vort' if ierror != 0: msg = 'In return from call to vrtgs ierror = %d' % (ierror,) raise ValueError, msg return vort def vtsi(self, nlat, nlon): #----------------------------------------------------------------------------- # # purpose: initializes wvts for vtsgs # # usage: wvts, lwvts = g.vtsi(nlat, nlon) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwvts = n1*n2*(nlat + nlat - n1 - 1) + nlon + 15 lwork = 3*(max(n1 - 2, 0)*(nlat + nlat - n1 - 1))/2 + (5*n2 + 2)*nlat ldwork = nlat*(nlat + 2) # --- call vtsgsi ---- work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') wvts, ierror = spherepack.vtsgsi(nlat, nlon, lwvts, work, dwork) if ierror != 0 or debug == 1: print ' ' print 'pass to vtsgsi' print 'nlon = ', nlon print 'nlat = ', nlat print 'lwvts = ', lwvts print 'ldwork = ', ldwork print 'return from vtsgsi with wvts and lwvts' if ierror != 0: msg = 'In return from call to vtsgsi ierror = %d' % (ierror,) raise ValueError, msg return wvts, lwvts def vts(self, nlat, nlon, nt, br, bi, cr, ci, lwvts, wvts): #----------------------------------------------------------------------------- # # purpose: computes the derivative of the vector function with respect # to latitude on a gaussian grid # # usage: w, v = g.vts(nlat, nlon, nt, br, bi, cr, ci, wvts, lwvts) # #----------------------------------------------------------------------------- if nlon%2: # nlon is odd n1 = min(nlat, (nlon + 1)/2) else: n1 = min(nlat, nlon/2) if nlat%2: # nlat is odd n2 = (nlat + 1)/2 else: n2 = nlat/2 lwork = (2*nt + 1)*nlat*nlon ityp = 0 idvw = nlat jdvw = nlon mdab = n1 ndab = nlat work = numpy.zeros((lwork,),'f') v, w, ierror = spherepack.vtsgs(nlat, nlon, ityp, idvw, jdvw, numpy.transpose(br), numpy.transpose(bi), numpy.transpose(cr), numpy.transpose(ci), wvts, work) if ierror != 0 or debug == 1: print ' ' print 'pass to vtsgs' print 'nlon = ', nlon print 'nlat = ', nlat print 'ityp = ', ityp print 'nt = ', nt print 'idvw = ', idvw print 'jdvw = ', jdvw print 'mdab = ', mdab print 'ndab = ', ndab print 'lwvts = ', lwvts print 'lwork = ', lwork print 'return from vtsgs with u and v' if ierror != 0: msg = 'In return from call to vtsgs ierror = %d' % (ierror,) raise ValueError, msg return w, v # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # +++++++++++++++++++++++++++++ Regrid class +++++++++++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ class Regrid: #--------------------------------------------------------------------------------------- # # Contents of the Regrid class # # The two functions for regridding are: # # regridScalar -- transfers scalar data from one global grid to another # regridVector -- transfers vector data from one global grid to another # #--------------------------------------------------------------------------------------- def __init__(self, lonArrayOut, latArrayOut, lonArrayIn, latArrayIn, numberLevels = None, numberTimes = None): """ -------------------------------------------------------------------------------------------------------- purpose: 'init' for class Regrid assigns values to the instance data which are the dimensions lengths, the latitude direction and the latitude type as gaussian or even. usage: x = sphere.Regrid(lonArrayOut, latArrayOut, lonArrayIn, latArrayIn, nlev, ntime) where nlev and ntime are the actual number of levels and times respectively. passed: lonArrayOut, lonArrayIn = longitude vectors latArrayOut, latArrayIn = latitude vectors numberLevels = number of levels (optional) numberTimes = number of times (optional) returned: x instance of Regrid definition: __init__(self, lonArrayOut, latArrayOut, lonArrayIn, latArrayIn, numberLevels = None, numberTimes = None): --------------------------------------------------------------------------------------------------------""" self.lonIn = len(lonArrayIn) self.latIn = len(latArrayIn) self.lonOut = len(lonArrayOut) self.latOut = len(latArrayOut) self.reverseLatitude = 'no' # regrid handles latitude north-south or south_north # ------ determine the standardShape for the input and output data for subsequent use ------ dimlistIn = [self.latIn, self.lonIn] # math order dimlistOut = [self.latOut, self.lonOut] self.levIn = numberLevels if numberLevels is not None and numberLevels != 0: dimlistIn.append(self.levIn) dimlistOut.append(self.levIn) self.tmeIn = numberTimes if numberTimes is not None and numberTimes != 0: dimlistIn.append(self.tmeIn) dimlistOut.append(self.tmeIn) dimlistIn.reverse() self.standardShapeIn = tuple(dimlistIn) # math order (ntme,nlev,nlon,nlat) dimlistOut.reverse() self.standardShapeOut = tuple(dimlistOut) # ------ check the shape for a unique number of longitudes and a unique number of latitudes ------ if self.lonIn in [self.tmeIn, self.levIn, self.latIn]: print 'Warning - number of longitudes in duplicated in the shape. The geotomath shape \ transform will not work unless it differs from the number of latitudes and it \ is one of the last two entiries in the shape' if self.latIn in [self.tmeIn, self.levIn, self.lonIn]: print 'Warning - number of latitudes in duplicated in the shape. The geotomath shape \ transform will not work unless it differs from the number of longitudes and it \ is one of the last two entiries in the shape' # ------ set self data for igridIn and igridOut ------ grid_typeIn = check_lonlat(lonArrayIn, latArrayIn) # 'even' or 'gaussian' grid_typeOut = check_lonlat(lonArrayOut, latArrayOut) if latArrayIn[0] > latArrayIn[self.latIn -1]: # get latitude(not colatitude) direction directionIn = 'north_south' else: directionIn = 'south_north' if latArrayOut[0] > latArrayOut[self.latOut -1]: directionOut = 'north_south' else: directionOut = 'south_north' self.igridIn = numpy.zeros((2,)) self.igridOut = numpy.zeros((2,)) if grid_typeIn == 'even': if directionIn == 'north_south': self.igridIn[0] = -1 else: self.igridIn[0] = +1 elif grid_typeIn == 'gaussian': if directionIn == 'north_south': self.igridIn[0] = -2 else: self.igridIn[0] = +2 else: # gaussian msg = 'CANNOT PROCESS THE DATA - Grid maust be even or gaussian' raise ValueError, msg return if grid_typeOut == 'even': if directionOut == 'north_south': self.igridOut[0] = -1 else: self.igridOut[0] = +1 elif grid_typeOut == 'gaussian': if directionOut == 'north_south': self.igridOut[0] = -2 else: self.igridOut[0] = +2 else: # gaussian msg = 'CANNOT PROCESS THE DATA - Grid maust be even or gaussian' raise ValueError, msg return self.igridIn[1] = 1 # for choice nlat x nlon built into .pyf file self.igridOut[1] = 1 def regridScalar(self, sf, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: regridScalar purpose: transfers scalar data from one global spherical grid to another. The grids may be gaussian or equally spaced. usage: sfregrid= x.regridScalar(sf) passed: sf -- scalar function on a global grid returned: sfregrid -- regridded scalar function definition: regridScalar(self, sf, missingValue = None): --------------------------------------------------------------------------------------------------------""" # ------------------ Set Parameters -------------------- igrida = self.igridIn nlona = self.lonIn nlata = self.latIn igridb = self.igridOut nlonb = self.lonOut nlatb = self.latOut standardShapea = self.standardShapeIn standardShapeb = self.standardShapeOut reverseLatitude = self.reverseLatitude # ** calculate lsave and malloc wsave** igrda = abs(igrida[0]) igrdb = abs(igridb[0]) na1 = min(nlata, (nlona + 2)/2) na2 = (nlata + 1)/2 nb1 = min(nlatb, (nlonb + 2)/2) nb2 = (nlatb + 1)/2 if igrda == 1: # even grid nwa = 2*nlata*na2 + 3*((na1 - 2)*(2*nlata - na1 - 1))/2 + nlona + 15 else: # gaussian grid nwa = nlata*(2*na2 + 3*na1 - 2) + 3*na1*(1 - na1)/2 + nlona + 15 if igrdb == 1: # even grid nwb = 2*nlatb*nb2 + 3*((nb1 - 2)*(2*nlatb - nb1 - 1))/2 + nlonb + 15 else: # gaussian grid nwb = nlatb*(2*nb2 + 3*nb1 - 2) + 3*nb1*(1 - nb1)/2 + nlonb + 15 lsave = nwa + nwb wsave = numpy.zeros((lsave,), numpy.float32) # ** calculate lwork ** nlat = max(nlata, nlatb) nlon = max(nlona, nlonb) n1 = min(nlat, (nlon + 2)/2) n2 = (nlat + 1)/2 lwork = nlat*(4*n1 + nlon + 2*nlat + 4) + 3*((n1 - 2)*2*(2*nlat - n1 - 1))/2 # ** calculate ldwork ** ldwork = nlat*(nlat + 4) # ------------------------------------------------------ # ** transform to math order ** nt, inverseOrder, sf = geotomath(missingValue, reverseLatitude, standardShapea, sf) # ** malloc for array b ** db = numpy.zeros((nt, nlonb, nlatb), numpy.float32) # --- call trssph one lon-lat slice at a time ---- intl = 0 work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') for i in range(nt): dummy, lsvmin, lwkmin, ierror = spherepack.trssph(intl, igrida, numpy.transpose(sf[i,:,:]), igridb, nlonb, nlatb, wsave, work, dwork) db[i,:,:] = numpy.transpose(dummy) if ierror != 0: msg = 'In return from call to trssph ierror = %d and call number = %d' % (ierror,i) raise ValueError, msg if ierror != 0 or debug == 1: print ' ' print 'pass to trssph' print 'igrida = ', igrida print 'nlona = ', nlona print 'nlata = ', nlata print 'igridb = ', igridb print 'nlonb = ', nlonb print 'nlatb = ', nlatb print 'lsave = ', lsave print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from trssph with db' print 'lsvmin = ', lsvmin print 'lsave = ', lsave print 'lwkmin = ', lwkmin print 'lwork = ', lwork # ** transform to geo order ** db = mathtogeo(reverseLatitude, standardShapeb, inverseOrder, db) return db def regridVector(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: regridVector purpose: transfers vector data from one global spherical grid to another. The grids can be gaussian or equally spaced. usage: uregrid, vregrid = x.regridVector(u, v) passed: u -- zonal vector function on a global grid v -- meridional vector function on a global grid returned: uregrid -- zonal regridded vector function vregrid -- meridional regridded vector function definition: regridVector(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" # ------------------ Set Parameters -------------------- iveca = 1 ivecb = 1 igrida = self.igridIn nlona = self.lonIn nlata = self.latIn igridb = self.igridOut nlonb = self.lonOut nlatb = self.latOut standardShapea = self.standardShapeIn standardShapeb = self.standardShapeOut reverseLatitude = self.reverseLatitude # ** calculate lsave and malloc wsave** na1 = min(nlata, (nlona + 1)/2) na2 = (nlata + 1)/2 nb1 = min(nlatb, (nlonb + 1)/2) nb2 = (nlatb + 1)/2 nwa = 4*nlata*na2 + 3*max(na1 - 2, 0)*(2*nlata - na1 - 1) + na2 + nlona + 15 nwb = 4*nlatb*nb2 + 3*max(nb1 - 2, 0)*(2*nlatb - nb1 - 1) + nb2 + nlonb + 15 lsave = nwa + nwb wsave = numpy.zeros((lsave,), numpy.float32) # ** calculate lwork ** nlat = max(nlata, nlatb) nlon = max(nlona, nlonb) n1 = min(nlat, (nlon + 2)/2) lwork = 2*nlat*(8*n1 + 4*nlon + 3) # ** calculate ldwork ** ldwork = 2*nlat*(nlat + 1) + 1 # ------------------------------------------------------ # ** transform to math order ** nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShapea, u, v) # ** malloc for array b ** ub = numpy.zeros((nt, nlonb, nlatb), numpy.float32) vb = numpy.zeros((nt, nlonb, nlatb), numpy.float32) # --- call trvsph one lon-lat slice at a time ---- intl = 0 work = numpy.zeros((lwork,),'f') dwork = numpy.zeros((ldwork,),'d') for i in range(nt): dummy1, dummy2, lsvmin, lwkmin, ierror = spherepack.trvsph(intl, igrida, iveca, numpy.transpose(u[i,:,:]), numpy.transpose(v[i,:,:]), igridb, nlonb, nlatb, ivecb, wsave, work, dwork) ub[i,:,:] = numpy.transpose(dummy1) vb[i,:,:] = numpy.transpose(dummy2) if ierror != 0: msg = 'In return from call to trvsph ierror = %d and call number = %d' % (ierror,i) raise ValueError, msg if ierror != 0 or debug == 1: print ' ' print 'pass to trvsph' print 'igrida = ', igrida print 'iveca = ', iveca print 'nlona = ', nlona print 'nlata = ', nlata print 'igridb = ', igridb print 'ivecb = ', ivecb print 'nlonb = ', nlonb print 'nlatb = ', nlatb print 'lsave = ', lsave print 'lwork = ', lwork print 'ldwork = ', ldwork print 'return from trvsph with ub, vb, lsvmin, lwkmin' print 'lsvmin = ', lsvmin print 'lsave = ', lsave print 'lwkmin = ', lwkmin print 'lwork = ', lwork # ** transform to geo order ** ub, vb = mathtogeo(reverseLatitude, standardShapeb, inverseOrder, ub, vb) return ub, vb # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # +++++++++++++++++++++++++++++ Shiftgrid class +++++++++++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ class Shiftgrid: #----------------------------------------------------------------------------------------- # # Shifting -- contained in Shiftgrid class # # The two functions for shifting an evenly spaced grid by half an increment in longitude # and latitude are: # # shiftScalar -- transfers scalar data between an equally spaced regular and an offset grid # shfitVector -- transfers vector data between an equally spaced regular and an offset grid # #----------------------------------------------------------------------------------------- def __init__(self, lonArray, latArray, numberLevels = None, numberTimes = None): """ -------------------------------------------------------------------------------------------------------- purpose: 'init' for class Shiftgrid assigns values to the instance data which are the dimensions lengths, the latitude direction and the grid type as regular (evenly spaced including the poles) or offset from regular by a half grid point in two directions. usage: x = sphere.Shiftgrid(lonArray = lonvals, latArray = latvals, nlev, ntime) where nlev and ntime are the actual number of levels and times respectively. passed: lonArray = longitude vector latArray = latitude vector numberLevels = number of levels (optional) numberTimes = number of times (optional) caution: Grid must be evenly spaced. If it includes the poles in is shifted a half increment from the poles. If it excludes the poles in is shifted a half increment to include the poles. There are only two possible input longitude_latitude grids. definition: __init__(self, lonArray, latArray, numberLevels = None, numberTimes = None): --------------------------------------------------------------------------------------------------------""" # caution: In this class the geo order (nlat,nlon) is used self.grid_type = check_shiftgrids(lonArray, latArray) # get grid type as 'regular' or 'offset' self.lon = len(lonArray) if self.grid_type == 'regular': # self.lat is the size of the offset latitudes self.lat = len(latArray) - 1 else: self.lat = len(latArray) if latArray[0] > latArray[len(latArray)-1]: # the shift routines want latitude south to north self.reverseLatitude = 'geoyes' else: self.reverseLatitude = 'no' dimlist = [self.lon, self.lat] # note the start of geo order here -- note list reverse later dimlistp = [self.lon, self.lat + 1] # note the start of geo order here -- note list reverse later self.lev = numberLevels if numberLevels is not None and numberLevels != 0: dimlist.append(self.lev) dimlistp.append(self.lev) self.tme = numberTimes if numberTimes is not None and numberTimes != 0: dimlist.append(self.tme) dimlistp.append(self.tme) dimlist.reverse() dimlistp.reverse() self.standardShapeGeo = tuple(dimlist) # geo order (ntme,nlev,nlat,nlon) self.standardShapeGeop = tuple(dimlistp) # geo order (ntme,nlev,nlat+1,nlon) # check the shape for a unique number of longitudes and a unique number of latitudes if self.lon in [self.tme, self.lev, self.lat]: print 'Warning - number of longitudes in duplicated in the shape. The geotomath shape \ transform will not work unless it differs from the number of latitudes and it \ is one of the last two entiries in the shape' if self.lat in [self.tme, self.lev, self.lon]: print 'Warning - number of latitudes in duplicated in the shape. The geotomath shape \ transform will not work unless it differs from the number of longitudes and it \ is one of the last two entiries in the shape' def shiftScalar(self, sf, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: shiftScalar purpose: transfers scalar data on the sphere between an equally spaced grid that includes the poles and a grid which is offset by a half grid increment in both longitude and latitude (which excludes the poles) usage: sfshift = x.shiftScalar(sf) passed: sf -- an evenly spaced scalar function on a global grid returned: sfshift -- the shifted evenly spaced scalar function definition: shiftScalar(self, sf, missingValue = None): --------------------------------------------------------------------------------------------------------""" # ---- Set parameters and sizes ---- nlon = self.lon nlat = self.lat standardShapeGeo = self.standardShapeGeo standardShapeGeop = self.standardShapeGeop reverseLatitude = self.reverseLatitude if self.grid_type == 'regular': # sf passed is a regular grid ioff = 1 else: ioff = 0 lsav = 2*(2*nlat + nlon + 16) if nlon%2: # nlon is odd lwrk = nlon*(5*nlat + 1) else: lwrk = 2*nlon*(nlat + 1) # --- call sshifti ---- wsav, ierror = spherepack.sshifti(ioff, nlon, nlat, lsav) if ierror != 0: msg = 'In return from call to sshifti ierror = %d' % (ierror,) raise ValueError, msg # ** transform to standard geo order ** if ioff == 1: # regular grid passed in nt, inverseOrder, sf = geotomath(missingValue, reverseLatitude, standardShapeGeop, sf) else: # offset grid passed in nt, inverseOrder, sf = geotomath(missingValue, reverseLatitude, standardShapeGeo, sf) if nt > 1: # call sshifte one slice at a time if ioff == 1: # regular grid passed in goff_return = numpy.zeros((nt, nlat, nlon), numpy.float32) # malloc for array goff_return for i in range(nt): greg = sf[i,:,:] # --- call sshifte ---- goff = numpy.zeros((nlat, nlon), numpy.float32) # malloc for inout array goff wrk = numpy.zeros((lwrk,),'f') goff = numpy.transpose(goff) greg = numpy.transpose(greg) ierror = spherepack.sshifte(ioff, goff, greg, wsav, wrk) goff = numpy.transpose(goff) greg = numpy.transpose(greg) if ierror != 0 or debug == 1: print ' ' print 'pass to sshifte' print 'nlon = ', nlon print 'nlat = ', nlat print 'lsav = ', lsav print 'lwrk = ', lwrk print 'return from sshifte' if ierror != 0: msg = 'In return from call to sshifte ierror = %d' % (ierror,) raise ValueError, msg goff_return[i,:,:] = goff # ** transform to original geo order ** goff_return = mathtogeo(reverseLatitude, standardShapeGeo, inverseOrder, goff_return) return goff_return else: # offset grid passed in greg_return = numpy.zeros((nt, nlat + 1, nlon), numpy.float32) # malloc for array greg_return ** for i in range(nt): goff = sf[i,:,:] # --- call sshifte ---- greg = numpy.zeros((nlat + 1, nlon), numpy.float32) # malloc for inout array greg wrk = numpy.zeros((lwrk,),'f') goff = numpy.transpose(goff) greg = numpy.transpose(greg) ierror = spherepack.sshifte(ioff, goff, greg, wsav, wrk) goff = numpy.transpose(goff) greg = numpy.transpose(greg) if ierror != 0 or debug == 1: print ' ' print 'pass to sshifte' print 'nlon = ', nlon print 'nlat = ', nlat print 'lsav = ', lsav print 'lwrk = ', lwrk print 'return from sshifte' if ierror != 0: msg = 'In return from call to sshifte ierror = %d' % (ierror,) raise ValueError, msg greg_return[i,:,:] = greg # ** transform to original geo order ** greg_return = mathtogeo(reverseLatitude, standardShapeGeop, inverseOrder, greg_return) return greg_return else: # single section only sf = numpy.reshape(sf, sf.shape[1:]) # remove dummy dimension if ioff == 1: # regular grid passed in greg = sf # --- call sshifte ---- goff = numpy.zeros((nlat, nlon), numpy.float32) # malloc for inout array goff wrk = numpy.zeros((lwrk,),'f') goff = numpy.transpose(goff) greg = numpy.transpose(greg) ierror = spherepack.sshifte(ioff, goff, greg, wsav, wrk) goff = numpy.transpose(goff) greg = numpy.transpose(greg) if ierror != 0 or debug == 1: print ' ' print 'pass to sshifte' print 'nlon = ', nlon print 'nlat = ', nlat print 'lsav = ', lsav print 'lwrk = ', lwrk print 'return from sshifte' if ierror != 0: msg = 'In return from call to sshifte ierror = %d' % (ierror,) raise ValueError, msg goff = numpy.reshape(goff, (1, goff.shape[0], goff.shape[1])) # restore dummy dimension # ** transform to original geo order ** goff = mathtogeo(reverseLatitude, standardShapeGeo, inverseOrder, goff) return goff else: # offset grid passed in goff = sf # --- call sshifte ---- greg = numpy.zeros((nlat + 1, nlon), numpy.float32) # malloc for inout array goff wrk = numpy.zeros((lwrk,),'f') goff = numpy.transpose(goff) greg = numpy.transpose(greg) ierror = spherepack.sshifte(ioff, goff, greg, wsav, wrk) goff = numpy.transpose(goff) greg = numpy.transpose(greg) if ierror != 0 or debug == 1: print ' ' print 'pass to sshifte' print 'nlon = ', nlon print 'nlat = ', nlat print 'lsav = ', lsav print 'lwrk = ', lwrk print 'return from sshifte' if ierror != 0: msg = 'In return from call to sshifte ierror = %d' % (ierror,) raise ValueError, msg greg = numpy.reshape(greg, (1, greg.shape[0], greg.shape[1])) # restore dummy dimension # ** transform to original geo order ** greg = mathtogeo(reverseLatitude, standardShapeGeop, inverseOrder, greg) return greg def shiftVector(self, u, v, missingValue = None): """ -------------------------------------------------------------------------------------------------------- routine: shiftVector purpose: transfers vector data on the sphere between an equally spaced grid that includes the poles and a grid which is offset by a half grid increment in both longitude and latitude (which excludes the poles) usage: ushift, vshift = x.shiftVector(u,v) passed: u -- zonal evenly spaced vector function on a global grid v -- meridional evenly spaced vector function on a global grid returned: ushift -- zonal evenly spaced vector function vshift -- meridional evenly spaced vector function definition: shiftVector(self, u, v, missingValue = None): --------------------------------------------------------------------------------------------------------""" # ---- Set parameters and sizes ---- nlon = self.lon nlat = self.lat standardShapeGeo = self.standardShapeGeo standardShapeGeop = self.standardShapeGeop reverseLatitude = self.reverseLatitude if self.grid_type == 'regular': # sf passed is a regular grid ioff = 1 else: ioff = 0 lsav = 2*(2*nlat + nlon + 16) if nlon%2: # nlon is odd lwrk = nlon*(5*nlat + 1) else: lwrk = 2*nlon*(nlat + 1) # --- call vshifti ---- wsav, ierror = spherepack.vshifti(ioff, nlon, nlat, lsav) if ierror != 0: msg = 'In return from call to vshifti ierror = %d' % (ierror,) raise ValueError, msg # ** transform to standard geo order ** if ioff == 1: # regular grid passed in nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShapeGeop, u, v) v = -1.0*v # undo the colatitude conversion in geotomath v = numpy.array(v.astype(numpy.float32), numpy.float32) else: # offset grid passed in nt, inverseOrder, u, v = geotomath(missingValue, reverseLatitude, standardShapeGeo, u, v) v = -1.0*v # undo the colatitude conversion in geotomath v = numpy.array(v.astype(numpy.float32), numpy.float32) if nt > 1: # call vshifte one slice at a time if ioff == 1: # regular grid passed in uoff_return = numpy.zeros((nt, nlat, nlon), numpy.float32) # malloc for array uoff_return ** voff_return = numpy.zeros((nt, nlat, nlon), numpy.float32) # malloc for array voff_return ** for i in range(nt): ureg = u[i,:,:] vreg = v[i,:,:] # --- call vshift2e ---- uoff = numpy.zeros((nlat, nlon), numpy.float32) # malloc for inout array uoff voff = numpy.zeros((nlat, nlon), numpy.float32) wrk = numpy.zeros((lwrk,),'f') uoff = numpy.transpose(uoff) voff = numpy.transpose(voff) ureg = numpy.transpose(ureg) vreg = numpy.transpose(vreg) ierror = spherepack.vshifte(ioff, uoff, voff, ureg, vreg, wsav, wrk) uoff = numpy.transpose(uoff) voff = numpy.transpose(voff) ureg = numpy.transpose(ureg) vreg = numpy.transpose(vreg) if ierror != 0 or debug == 1: print ' ' print 'pass to sshifte' print 'nlon = ', nlon print 'nlat = ', nlat print 'lsav = ', lsav print 'lwrk = ', lwrk print 'return from vshifte' if ierror != 0: msg = 'In return from call to vshifte ierror = %d' % (ierror,) raise ValueError, msg uoff_return[i,:,:] = uoff voff_return[i,:,:] = voff # ** transform to original geo order ** uoff_return = mathtogeo(reverseLatitude, standardShapeGeo, inverseOrder, uoff_return) voff_return = mathtogeo(reverseLatitude, standardShapeGeo, inverseOrder, voff_return) return uoff_return, voff_return else: # offset grid passed in ureg_return = numpy.zeros((nt, nlat + 1, nlon), numpy.float32) # malloc for array ureg_return ** vreg_return = numpy.zeros((nt, nlat + 1, nlon), numpy.float32) # malloc for array vreg_return ** for i in range(nt): uoff = u[i,:,:] voff = v[i,:,:] # --- call vshifte ---- ureg = numpy.zeros((nlat + 1, nlon), numpy.float32) # malloc for inout array uoff vreg = numpy.zeros((nlat + 1, nlon), numpy.float32) wrk = numpy.zeros((lwrk,),'f') uoff = numpy.transpose(uoff) voff = numpy.transpose(voff) ureg = numpy.transpose(ureg) vreg = numpy.transpose(vreg) ierror = spherepack.vshifte(ioff, uoff, voff, ureg, vreg, wsav, wrk) uoff = numpy.transpose(uoff) voff = numpy.transpose(voff) ureg = numpy.transpose(ureg) vreg = numpy.transpose(vreg) if ierror != 0 or debug == 1: print ' ' print 'pass to vshifte' print 'nlon = ', nlon print 'nlat = ', nlat print 'lsav = ', lsav print 'lwrk = ', lwrk print 'return from sshifte' if ierror != 0: msg = 'In return from call to vshifte ierror = %d' % (ierror,) raise ValueError, msg ureg_return[i,:,:] = ureg vreg_return[i,:,:] = vreg # ** transform to original geo order ** ureg_return, vreg_return = mathtogeo(reverseLatitude, standardShapeGeop, inverseOrder, ureg_return, vreg_return) vreg_return = -1.0*vreg_return vreg_return = numpy.array(vreg_return.astype(numpy.float32), numpy.float32) return ureg_return, vreg_return else: # single section only u = numpy.reshape(u, u.shape[1:]) # remove dummy dimension v = numpy.reshape(v, v.shape[1:]) # remove dummy dimension if ioff == 1: # regular grid passed in ureg = u vreg = v # --- call vshifte ---- uoff = numpy.zeros((nlat, nlon), numpy.float32) # malloc for inout array uoff voff = numpy.zeros((nlat, nlon), numpy.float32) # malloc for inout array uoff wrk = numpy.zeros((lwrk,),'f') uoff = numpy.asfortranarray(numpy.transpose(uoff)) voff = numpy.asfortranarray(numpy.transpose(voff)) ureg = numpy.asfortranarray(numpy.transpose(ureg)) vreg = numpy.asfortranarray(numpy.transpose(vreg)) ierror = spherepack.vshifte(ioff, uoff, voff, ureg, vreg, wsav, wrk) uoff = numpy.transpose(uoff) voff = numpy.transpose(voff) ureg = numpy.transpose(ureg) vreg = numpy.transpose(vreg) if ierror != 0 or debug == 1: print ' ' print 'pass to vshifte' print 'nlon = ', nlon print 'nlat = ', nlat print 'lsav = ', lsav print 'lwrk = ', lwrk print 'return from vshifte' if ierror != 0: msg = 'In return from call to vshifte ierror = %d' % (ierror,) raise ValueError, msg uoff = numpy.reshape(uoff, (1, uoff.shape[0], uoff.shape[1])) # restore dummy dimension voff = numpy.reshape(voff, (1, voff.shape[0], voff.shape[1])) # restore dummy dimension # ** transform to original geo order ** uoff, voff = mathtogeo(reverseLatitude, standardShapeGeo, inverseOrder, uoff, voff) voff = -1.0*voff voff = numpy.array(voff.astype(numpy.float32), numpy.float32) return uoff, voff else: # offset grid passed in uoff = u voff = v # --- call vshifte ---- ureg = numpy.zeros((nlat + 1, nlon), numpy.float32) # malloc for inout array uoff vreg = numpy.zeros((nlat + 1, nlon), numpy.float32) wrk = numpy.zeros((lwrk,),'f') uoff = numpy.transpose(uoff) voff = numpy.transpose(voff) ureg = numpy.transpose(ureg) vreg = numpy.transpose(vreg) ierror = spherepack.vshifte(ioff, uoff, voff, ureg, vreg, wsav, wrk) uoff = numpy.transpose(uoff) voff = numpy.transpose(voff) ureg = numpy.transpose(ureg) vreg = numpy.transpose(vreg) if ierror != 0 or debug == 1: print ' ' print 'pass to vshifte' print 'nlon = ', nlon print 'nlat = ', nlat print 'lsav = ', lsav print 'lwrk = ', lwrk print 'return from vshifte' if ierror != 0: msg = 'In return from call to sshifte ierror = %d' % (ierror,) raise ValueError, msg ureg = numpy.reshape(ureg, (1, ureg.shape[0], ureg.shape[1])) # restore dummy dimension vreg = numpy.reshape(vreg, (1, vreg.shape[0], vreg.shape[1])) # restore dummy dimension # ** transform to original geo order ** ureg, vreg = mathtogeo(reverseLatitude, standardShapeGeop, inverseOrder, ureg, vreg) vreg = -1.0*vreg vreg = numpy.array(vreg.astype(numpy.float32), numpy.float32) return ureg, vreg # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++ Utility Functions +++++++++++++++++++++++++++++++++ # ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ def gaussian_pts_wts_bnds(nlat): #------------------------------------------------------------------------------- # # routine: gaussian_pts_wts_bnds # # purpose: compute the double precision gaussian grid points, weights and # bounds using the spherepack function gaqd # # usage: points, weights, bounds = gaussian_pts_wts_bnds(nlat) # # where nlat is the number of latitudes # #------------------------------------------------------------------------------- rad2deg = 180.0/math.pi # get the gaussian points and weights from spherepack ldwork = nlat*(nlat + 2) work = numpy.zeros((ldwork,),'d') points, wts, ierror = spherepack.gaqd(nlat, work) if ierror != 0: msg = 'In return from call to gaqd ierror = %d' % (ierror,) raise ValueError, msg # convert points to geophysical format colatlist = list(points) latlist = map( (lambda x: 90.0 - x*180.0/math.pi), colatlist) # calculate the bounds sinb = [0.0]*(nlat + 1) # allocate memory bndslist = [0.0]*(nlat + 1) sinb[0] = 1.0 sinb[nlat] = -1.0 for i in range(1,nlat): sinb[i] = sinb[i-1] - wts[i-1] for i in range(nlat + 1): bndslist[i] = rad2deg*math.asin(sinb[i]) # convert lists to double precision arrays pts = numpy.array(latlist, numpy.float64) bnds = numpy.array(bndslist, numpy.float64) return pts, wts, bnds def check_lonlat(checklonpass, checklatpass): #------------------------------------------------------------------------------- # # routine: check_lonlat # # purpose: compare the passed checklat and checklon array with the correct # geophysical ones calculated here. The latitudes must cover the # full sphere for either a evenly spaced (including the poles) or # a gaussian grid. The longitudes must cover full sphere without a wrap. # # usage: laterror, lonerror = check_lonlat(checklon, checklat) # where checklat and checklon is a grid to check # # return: grid_type as 'even' or 'gaussian' # #------------------------------------------------------------------------------- small = 0.001 # use as tolerance in checking values nlat = len(checklatpass) nlon = len(checklonpass) checklon = checklonpass if checklatpass[0] < checklatpass[nlat-1]: # need a copy? checklat = numpy.array(checklatpass, numpy.float64) checklat = checklat[::-1] else: checklat = checklatpass # check the pass for evenly spaced latitude including the poles firstdelta = abs(checklat[0] - checklat[1]) maxdiff = 0.0 for i in range(1, nlat - 1): diff = abs(firstdelta - (checklat[i] - checklat[i+1])) if diff > maxdiff: maxdiff = diff if maxdiff < small: if abs(90. - checklat[0]) > small or abs(-90. - checklat[nlat-1]) > small: print '***************************************************************************' print 'CANNOT PROCESS THE DATA - Evenly spaced grids must include the pole points' print '***************************************************************************' raise ValueError return else: grid_type = 'even' else: grid_type = 'gaussian' # check the pass for evenly spaced longitudes without a wrap if checklon[0] > checklon[nlon-1]: print '****************************************************************' print 'CANNOT PROCESS THE DATA - Longitudes must run from west to east' print '****************************************************************' raise ValueError return delta = 360./nlon if (checklon[nlon-1] - checklon[0]) > (360.0 -(delta - small)) : print '**************************************************' print 'CANNOT PROCESS THE DATA - Longitudes can not wrap' print '**************************************************' raise ValueError return # generate the correct latitude geophysical grid points if grid_type == 'even': latlist = [] delta = 180./(nlat - 1) for i in range(nlat): value = 90. - i*delta latlist.append(value) latvals = numpy.array(latlist, numpy.float64) else: latvals, wts, bnds = gaussian_pts_wts_bnds(nlat) # check lon and lat values delta = 360./nlon maxdiff = 0.0 # max difference between delta and actual increments for i in range(0, nlon - 1): diff = abs(delta - (checklon[i+1] - checklon[i])) if diff > maxdiff: maxdiff = diff if maxdiff > small: print '***********************************************************' print 'CANNOT PROCESS THE DATA - Longitudes are not evenly spaced' print '***********************************************************' raise ValueError return laterror = max( abs(latvals - checklat) ) if laterror > small: print '********************************************************' print 'CANNOT PROCESS THE DATA - Latitude values are incorrect' print '********************************************************' raise ValueError return grid_type def check_shiftgrids(checklon, checklat): #------------------------------------------------------------------------------- # # routine: check_shiftgrids # # purpose: check the passed checklat and checklon arrays for conformity # # For 'reg' grids: # latitudes must be evenly spaced and include the poles # longitudes must start at 0 without a wrap. # For 'off' grids: # latitudes must be evenly spaced and exclude the poles # longitudes must start at 0 + delta/2 without a wrap. # # usage: grid_type = check_shiftgrids(checklat, checklon) # where checklat and checklon is a grid to check # # return: grid_type as 'regular' or 'offset' # #------------------------------------------------------------------------------- small = 0.001 # use as tolerance in checking values nlon = len(checklon) nlat = len(checklat) # check the pass for evenly spaced latitudes and determine the grid type as 'regular' or 'offset' if checklat[0] < checklat[nlat-1]: checklat = checklat[::-1] firstdelta = abs(checklat[0] - checklat[1]) maxdiff = 0.0 for i in range(1, nlat - 1): diff = abs(firstdelta - (checklat[i] - checklat[i+1])) if diff > maxdiff: maxdiff = diff if maxdiff < small: if abs(90. - checklat[0]) < small and abs(-90. - checklat[nlat-1]) < small: # are poles present? grid_type = 'regular' else: grid_type = 'offset' else: print '*********************************************************' print 'CANNOT PROCESS THE DATA - Latitudes are not evenly spaced' print '*********************************************************' raise ValueError return # check the pass for evenly spaced longitudes and conformity to the grid type as 'regular' or 'offset' if checklon[0] > checklon[nlon-1]: print '***************************************************************' print 'CANNOT PROCESS THE DATA - Longitudes must run from west to east' print '***************************************************************' raise ValueError return delta = 360./nlon if (checklon[nlon-1] - checklon[0]) > (360.0 -(delta - small)) : print '*************************************************' print 'CANNOT PROCESS THE DATA - Longitudes can not wrap' print '*************************************************' raise ValueError return maxdiff = 0.0 # max difference between delta and actual increments for i in range(0, nlon - 1): diff = abs(delta - (checklon[i+1] - checklon[i])) if diff > maxdiff: maxdiff = diff if maxdiff > small: print '**********************************************************' print 'CANNOT PROCESS THE DATA - Longitudes are not evenly spaced' print '**********************************************************' raise ValueError return else: if grid_type == 'regular': if abs(0. - checklon[0]) > small or abs(360. - delta - checklon[nlon-1]) > small: print '********************************************************************' print 'WARNING - Longitude end points do not conform to regular grid values' print 'Expected longitude to start at 0 degrees' print '********************************************************************' else: if abs(0. + delta/2. - checklon[0]) > small or abs(360. - delta/2. - checklon[nlon-1]) > small: print '*********************************************************************' print 'WARNING - Longitude end points do not conform to offset grid values' print 'Expected longitude to start offset from 0 degrees by half grid spacing' print '**********************************************************************' return grid_type def geoscale(scale, u, v = None): #------------------------------------------------------------------------------- # # routine: geoscale # # purpose: scale geophysical data # # passed : scale - the the multiplier # u,v - vector functions to scale # or # u and None - u is the scalar function to scale # # returned: u and v # or # u - the scalar function # #------------------------------------------------------------------------------- if v is None: # scalar function case u = scale*u u = numpy.array(u.astype(numpy.float32), numpy.float32) return u else: # vectorscalar function case u = scale*u u = numpy.array(u.astype(numpy.float32), numpy.float32) v = scale*v v = numpy.array(v.astype(numpy.float32), numpy.float32) return u, v def geotomath(missingValue, reverseLatitude, standardShape, u, v = None): #------------------------------------------------------------------------------- # # routine: geotomath # # purpose: transform geophysical data to spherepack math format # # passed : standardShape - the standard math order (ntme, nlev, nlon, nlat) # u,v - vector functions to transform to standard math shape # or # u and None - u is the scalar function to transform to standard math shape # # returned: inverseOrder, u and v (inverseOrder is needed in mathtogeo) # or # inverseOrder, u - the scalar function # # caution: a correct result is certain only if the shape makes a unique list # #------------------------------------------------------------------------------- # ----- Check data type and change to float if necessary ------- if u.dtype.char != 'f': print '*******************************************' print 'WARNING - data will be converted to Float32' print '*******************************************' u = u.astype(numpy.float32) if v is not None: if v.dtype.char != 'f': print '*******************************************' print 'WARNING - data will be converted to Float32' print '*******************************************' v = v.astype(numpy.float32) # ----- Check for missing data ------- if missingValue is not None and usefilled == 'yes': um = numpy.ma.masked_where(u, missingValue) if um.mask is not numpy.ma.nomask: print '************************************************' print 'CANNOT PROCESS THE DATA - field has missing data' print '************************************************' raise ValueError return if v is not None: vm = numpy.ma.masked_where(v, missingValue) if vm.mask is not numpy.ma.nomask: print '************************************************' print 'CANNOT PROCESS THE DATA - field has missing data' print '************************************************' raise ValueError return # ----- Perform preliminary checks ------- if v is not None: if u.shape != v.shape: print '***************************************************************************' print 'CANNOT PROCESS THE DATA - Error in the data - u and v have different shapes' print '***************************************************************************' raise 'IndexError' return origShape = u.shape # u is the scalar function if len(standardShape) != len(origShape): print '***********************************' print 'CANNOT PROCESS THE DATA' print 'Shapes are not the same length' print 'standardShape is : ', standardShape print 'origShape is : ', origShape print '***********************************' raise IndexError return # ----- Determine the new order ----- size = len(standardShape) newOrderlist = [None]*size # malloc for i in range(size): # make tuple to transpose original data to standard order test = standardShape[i] for j in range(size): if test == origShape[j]: if j not in newOrderlist: # all numbers in newOrderlist must be different newOrderlist[i] = j break # use first found if there are duplicates newOrder = tuple(newOrderlist) # ----- Determine the inverse to this new order for use in mathtogeo ----- xform = [] for i in range(len(newOrder)): xform.append( [newOrder[i], i] ) xform.sort() inverse_shapelist = [] for item in xform: inverse_shapelist.append(item[1]) inverseOrder = tuple(inverse_shapelist) # ----- Determine nt for the triple (nt, nlon, nlat) ----- if size == 4: nt = standardShape[0]*standardShape[1] elif size == 3: nt = standardShape[0] elif size == 2: nt = 1 else: print '**************************************************************' print 'CANNOT PROCESS THE DATA - size of data array must be 2, 3 or 4' print '**************************************************************' raise IndexError return triple = (nt, standardShape[size - 2], standardShape[size - 1]) u = numpy.transpose(u, newOrder) # transpose data to standard math u = numpy.array(u.astype(numpy.float32), numpy.float32) # make contiguous u = numpy.reshape(u, triple) # reshape to form for spherepack if reverseLatitude != 'no': if reverseLatitude == 'mathyes': u = u[:,:,::-1] elif reverseLatitude == 'geoyes': u = u[:,::-1,:] else: print 'Only choices for reverseLatitude are strings no, mathyes or geoyes' raise ValueError if v is None: # scalar function case return nt, inverseOrder, u else: v = numpy.transpose(v, newOrder) v = -1.0*v v = numpy.array(v.astype(numpy.float32), numpy.float32) # make contiguous v = numpy.reshape(v, triple) if reverseLatitude != 'no': if reverseLatitude == 'mathyes': v = v[:,:,::-1] elif reverseLatitude == 'geoyes': v = v[:,::-1,:] else: print 'Only choices for reverseLatitude are strings no, mathyes or geoyes' raise ValueError return nt, inverseOrder, u, v def mathtogeo(reverseLatitude, standardShape, inverseOrder, u, v = None): #------------------------------------------------------------------------------- # # routine: mathtogeo # # purpose: transform spherepack math format to geophysical order # # passed : u,v which must be math order or u alone as a scalar function # # returned: u, v or only u in original data order # #------------------------------------------------------------------------------- if v is not None: # vector case # Restore the standard time and level shape in the vector data if reverseLatitude != 'no': if reverseLatitude == 'mathyes': u = u[:,:,::-1] v = v[:,:,::-1] elif reverseLatitude == 'geoyes': u = u[:,::-1,:] v = v[:,::-1,:] else: print 'Only choices for reverseLatitude are strings no, mathyes or geoyes' raise ValueError u = numpy.reshape(u, standardShape) u = numpy.array(u.astype(numpy.float32), numpy.float32) # make contiguous v = numpy.reshape(v, standardShape) v = numpy.array(v.astype(numpy.float32), numpy.float32) # make contiguous # Restore the shape of the data to conform to that of the original data u = numpy.transpose(u, inverseOrder) u = numpy.array(u.astype(numpy.float32), numpy.float32) # make contiguous v = numpy.transpose(v, inverseOrder) v = -1.0*v v = numpy.array(v.astype(numpy.float32), numpy.float32) return u, v else: # scalar case # Restore the standard time and level shape in the scalar data if reverseLatitude != 'no': if reverseLatitude == 'mathyes': u = u[:,:,::-1] elif reverseLatitude == 'geoyes': u = u[:,::-1,:] else: print 'Only choices for reverseLatitude are strings no, mathyes or geoyes' raise ValueError u = numpy.reshape(u, standardShape) u = numpy.array(u.astype(numpy.float32), numpy.float32) # make contiguous # Restore the shape of the data to conform to that of the original data u = numpy.transpose(u, inverseOrder) u = numpy.array(u.astype(numpy.float32), numpy.float32) # make contiguous return u def gridGenerator(nlon, nlat, firstLongitude, typeLatitudes, directionLatitudes): #-------------------------------------------------------------------------------------------- # # routine: gridGenerator # # purpose: generate the grid vectors # # usage: lonvals, latvals = sphere.gridGenerator(nlon, nlat, firstLongitude, # typeLatitudes, directionLatitudes) # # passed: nlon - size of longitude vector # nlat - size of latitude vector # firstLongitude -- first vector element # typeLatitudes -- 'even' or 'gaussian' # directionLatitudes -- 'north_to_south' or 'south_to_north' # # return: lonvals, latvals - the double precision grid vectors # # definition: gridGenerator(nlon, nlat, firstLongitude, typeLatitudes, directionLatitudes): # #-------------------------------------------------------------------------------------------- if typeLatitudes != 'even' and typeLatitudes != 'gaussian': # check ltitude request print '****************************************************************' print 'CANNOT PROCESS THE DATA - typeLatitudes must be even or gaussian' print '****************************************************************' raise ValueError return if directionLatitudes != 'north_to_south' and directionLatitudes != 'south_to_north': print '*************************************************************************************' print 'CANNOT PROCESS THE DATA - directionLatitudes must be north_to_south or south_to_north' print '*************************************************************************************' raise ValueError return delta = 360./nlon # generate the longitude vector lonlist = [] for i in range(nlon): value = firstLongitude + i*delta lonlist.append(value) lonvals = numpy.array(lonlist, numpy.float64) if typeLatitudes == 'even': # generate latitude vector latlist = [] delta = 180./(nlat - 1) for i in range(nlat): value = 90. - i*delta latlist.append(value) latvals = numpy.array(latlist, numpy.float64) else: latvals, wts, bnds = gaussian_pts_wts_bnds(nlat) if directionLatitudes == 'south_to_north': latvals = latvals[::-1] return lonvals, latvals def truncate(wave, a, b, taper = 'yes'): #-------------------------------------------------------------------------------------------- # # routine: truncate # # purpose: perform a triangular truncation of the coefficients in the arrays a and b with # or without tapering. For example, a request for T42 entails eliminating all # values for the total wavenumber above 42. If taper is not None, the remaining # values are tapered. # # usage: a,b = truncate(wave, a, b) -- use tapering # a,b = truncate(wave, a, b, taper = 'no') -- turn off tapering # # passed: a, b - the arrays # wave - the truncation wavenumber # taper - request for tapering the coefficient values # # returned: a, b - the truncated coefficient arrays # # definition: truncate(wave, a, b, taper = 'yes'): # # note: a, b have indices (nt, n, m) # # note: the formula for the exponential tapering was taken from John C. Adams. It is described # in Sardeshmukh P. D. and Hoskins B. J., 1984, Spatial Smoothing on the Sphere. Mon. Wea. # Rev., 112, 2524-2529. # #-------------------------------------------------------------------------------------------- ashape = a.shape # -- Preliminary error checks -- bshape = b.shape if ashape != bshape: print 'In truncate -- the shape of the two coefficient arrays passed are not the same ' raise IndexError if len(ashape) != 3: print 'In truncate -- the coefficient arrays must be 3D' raise IndexError nb = ashape[1] if wave + 1 > nb: print 'In truncate -- the wave number for the truncation is too large' raise IndexError t = wave + 1 # -- Perform triangular truncation -- a[:, t:, :] = 0.0 b[:, t:, :] = 0.0 if taper == 'yes': # -- Perform exponential tapering also -- twgt = numpy.zeros(nb, numpy.float32) iw = wave/10 jp = max(iw, 1) jw = 10.0*jp con = 1.0/(jw*(jw + 1)) for j in range(wave + 1): # last value is j = wave x = j*(j+1)*con value = math.pow(x, jp) twgt[j] =math.exp(-value) a = numpy.transpose(a, (0,2,1)) a = a*twgt # multipy by trianglar weights a = numpy.transpose(a, (0,2,1)) b = numpy.transpose(b, (0,2,1)) b = b*twgt # multipy by trianglar weights b = numpy.transpose(b, (0,2,1)) a = numpy.array(a.astype(numpy.float32), numpy.float32) b = numpy.array(b.astype(numpy.float32), numpy.float32) return a, b def help(choice = None): import sphere if choice is None: print """------------------------------------------------------------------------------------------- To get an overview of the sphere module, type sphere.help('overview') CLASS CONTENTS Sphere class -- Vector Analysis and Truncation To get information on making an instance type sphere.help('Sphere') To get information on using a function type sphere.help('functionName') where functionName is one of the following: div -- computes the divergence of a vector function idiv -- inverts the divergence creating an irrotational vector function vrt -- the vorticity of a vector function ivrt -- inverts the vorticity creating a divergence_free vector function idvt -- inverts the divergence and the vorticity creating a vector function vts -- computes the derivative of the vector function with respect to latitude grad -- computes the gradient of a scalar function igrad -- inverts the gradient creating a scalar function slap -- computes the Laplacian of a scalar function islap -- inverts the Laplacian of a scalar function vlap -- computes the Laplacian of a vector function ivlap -- inverts the Laplacian of a vector function sfvp -- computes the stream function and the velocity potential of a vector function isfvp -- inverts the stream function and the velocity potential of a vector function truncation-- truncates scalar or vector data at specified total wavenumber sha -- computes the spherical harmonic analysis of a scalar function shs -- computes the spherical harmonic synthesis of a scalar function vha -- computes the spherical harmonic analysis of a vector function vhs -- computes the spherical harmonic synthesis of a vector function Regrid class -- Regridding To get information on making an instance type sphere.help('Regrid') To get information on using a function type sphere.help('functionName') where functionName is one of the following: regridScalar -- transfers scalar data from one global grid to another regridVector -- transfers vector data from one global grid to another Shiftgrid class -- shifting To get information on making an instance type sphere.help('Shiftgrid') To get information on using a function type sphere.help('functionName') where functionName is one of the following: shiftScalar -- transfers scalar data between an evenly spaced regular and an offset grid shiftVector -- transfers vector data between an evenly spaced regular and an offset grid where the regular grid is defined as one which includes the poles. UTILITIES Utilities not part of the overall scheme but still of possible interest gridGenerator -- generates the longitude and latitude vectors truncate -- provides truncation at the spectral coefficient level To get information on their use type sphere.help('gridGenerator') sphere.help('truncate') EXAMPLES To get a general example type sphere.help('GeneralExample') To get a suggestion for an example of the the use of the Sphere class which has an an answer which can be verified type sphere.help('SphereTest') ----------------------------------------------------------------------------------------------------------------""" elif choice == 'overview': # look at the whole package print sphere.__doc__ elif choice == 'Sphere': # how to make an instance of a class print """ -------------------------------------------------------------------------------------- To make an instance x of the Sphere class type x = sphere.Sphere(lonArray , latArray, numberLevels = nlev, numberTimes = ntime, computed_stored = 'computed') where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArray = longitude vector (required) latArray = latitude vector (required) numberLevels = number of levels (optional) numberTimes = number of times (optional) computed_stored (optional) : 'computed' -- computed Legendre polynomials 'stored' -- stored Legendre polynomials This choice involves a 30% storage/speed tradeoff As an example, for a 2D field using 'computed Legendre polynomials' type x = sphere.Sphere(lonArray , latArray) As an example, for a 4D field with 3 levels, 120 times using 'stored Legendre polynomials' type x = sphere.Sphere(lonArray , latArray, 3, 120, 'stored') or using the keywords explicitly x = sphere.Sphere(lonArray , latArray, numberLevels = 3, numberTimes = 120, computed_stored = 'stored') where the order of the keyword entries is immaterial. -----------------------------------------------------------------------------------""" elif choice == 'Regrid': print """ -------------------------------------------------------------------------------------- To make an instance x of the Regrid class type x = sphere.Regrid(lonArrayOut, latArrayOut, lonArrayIn, latArrayIn, numberLevels = nlev, numberTimes = ntime) where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArrayOut = output grid longitude vector (required) latArrayOut = output grid latitude vector (required) lonArrayIn = input grid longitude vector (required) latArrayIn = input grid latitude vector (required) numberLevels = input grid number of levels (optional) numberTimes = input grid number of times (optional) -----------------------------------------------------------------------------------""" elif choice == 'Shiftgrid': print """ -------------------------------------------------------------------------------------- To make an instance x of the Shiftgrid class type x = sphere.Shiftgrid(lonArray, latArray, numberLevels = nlev, numberTimes = ntime) where nlev and ntime are the actual number of levels and times respectively and the keywords are lonArray = longitude vector (required) latArray = latitude vector (required) numberLevels = number of levels (optional) numberTimes = number of times (optional) -----------------------------------------------------------------------------------""" elif choice == 'GeneralExample': # example and a suggestion print """ -------------------------------------------------------------------------------------- Step 1. Type import sphere Step 2. From this documentation determine the class which offers the desired computation. You can avoid reading this documentation by noting that there are only three choices: the Sphere class, Regrid class and Shiftgrid class to use in ClassName below. A list of the functions in a particular class is obtained by typing sphere.ClassName.__doc__ Step 3. Make an instance, x, of the specific class ClassName using the statement x = sphere.ClassName(argument1, argument2, .........) To get information on and examples of the argument list type sphere.ClassName.__init__.__doc__ where Classname is Sphere, Regrid or Shiftgrid. Step 4. Perform the actual computation using a specific function named functionName, which has been identified in Step 2 by writing returned values = x.functionName(argument1, argument2, .........) To get information on the argument list and the returned values type sphere.Clasname.functionName.__doc__ -----------------------------------------------------------------------------------""" elif choice == 'SphereTest': print """ -------------------------------------------------------------------------------------- Typing cdat sphere.py generates some testing of the spheremodule using analytical functions as fields. For additional testing using real geophysical data, you might try the following exercise. Step 1. Get winds u and v and their grid vectors, longitude values (lonvals) and latitude values,(latvals) from somewhere. This example uses 2D fields for simplicity. The fields must be global without missing values. Step 2. Make an instance of the Sphere class, x, as x = sphere.Sphere(lonvals, latvals) Step 3. Compute the streamfunction, sf, and the velocity potential, vp, using sf, vp = x.sfvp(u, v) Step 4. Compute the source for the streamfunction, sf_source, and the velocity potential, vp_source, using the scalar Laplacian sf_source = x.slap(sf) vp_source = x.slap(vp) Step 5. Compute the source for the streamfunction, vort, and the velocity potential, div, directly using the divergence and the vorticity vort = x.vrt(u, v) div = x.div(u, v) Step 6. Compare the results for equality, sf_source with vort and vp_source with div. If the comparison fails, please complain about it. -----------------------------------------------------------------------------------""" elif choice == 'gridGenerator': # utilities print """ ----------------------------------------------------------------------------- routine: gridGenerator purpose: generate the grid vectors usage: lonvals, latvals = sphere.gridGenerator(nlon, nlat, firstLongitude, typeLatitudes, directionLatitudes) passed: nlon - size of longitude vector nlat - size of latitude vector firstLongitude -- first vector element typeLatitudes -- 'even' or 'gaussian' directionLatitudes -- 'north_to_south' or 'south_to_north' return: lonvals, latvals - the double precision grid vectors definition: gridGenerator(nlon, nlat, firstLongitude, typeLatitudes, directionLatitudes): -----------------------------------------------------------------------------------""" elif choice == 'truncate': print """ ------------------------------------------------------------------------------------------- routine: truncate purpose: perform a triangular truncation of the coefficients in the arrays a and b with or without tapering. For example, a request for T42 entails eliminating all values for the total wavenumber above 42. If taper is not None, the remaining values are tapered. usage: a,b = truncate(wave, a, b) -- use tapering a,b = truncate(wave, a, b, taper = 'no') -- turn off tapering passed: a, b - the arrays wave - the truncation wavenumber taper - request for tapering the coefficient values returned: a, b - the truncated coefficient arrays definition: truncate(wave, a, b, taper = 'yes'): note: a, b have indices (nt, n, m) note: the formula for the exponential tapering was taken from John C. Adams. It is described in Sardeshmukh P. D. and Hoskins B. J., 1984, Spatial Smoothing on the Sphere. Mon. Wea. Rev., 112, 2524-2529. -------------------------------------------------------------------------------------------""" elif choice == 'div': # Sphere class method functions print sphere.Sphere.div.__doc__ elif choice == 'idiv': print sphere.Sphere.idiv.__doc__ elif choice == 'vrt': print sphere.Sphere.vrt.__doc__ elif choice == 'ivrt': print sphere.Sphere.ivrt.__doc__ elif choice == 'idvt': print sphere.Sphere.idvt.__doc__ elif choice == 'vts': print sphere.Sphere.vts.__doc__ elif choice == 'grad': print sphere.Sphere.grad.__doc__ elif choice == 'igrad': print sphere.Sphere.igrad.__doc__ elif choice == 'slap': print sphere.Sphere.slap.__doc__ elif choice == 'islap': print sphere.Sphere.islap.__doc__ elif choice == 'vlap': print sphere.Sphere.vlap.__doc__ elif choice == 'ivlap': print sphere.Sphere.ivlap.__doc__ elif choice == 'sfvp': print sphere.Sphere.sfvp.__doc__ elif choice == 'isfvp': print sphere.Sphere.isfvp.__doc__ elif choice == 'truncation': print sphere.Sphere.truncation.__doc__ elif choice == 'sha': print sphere.Sphere.sha.__doc__ elif choice == 'shs': print sphere.Sphere.shs.__doc__ elif choice == 'vha': print sphere.Sphere.vha.__doc__ elif choice == 'vhs': print sphere.Sphere.vhs.__doc__ elif choice == 'regridScalar': # Regrid class method functions print sphere.Regrid.regridScalar.__doc__ elif choice == 'regridVector': print sphere.Regrid.regridVector.__doc__ elif choice == 'shiftScalar': # Regrid class method functions print sphere.Shiftgrid.shiftScalar.__doc__ elif choice == 'shiftVector': print sphere.Shiftgrid.shiftVector.__doc__ else: print 'Unknown Request - cannot provide help for ', choice return None