This commit is contained in:
Guilhem Lavaux 2021-06-21 16:38:06 +02:00
commit a0f0371126
166 changed files with 32610 additions and 0 deletions

3
.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
*.o
*.a
bin/*

456
CHANGES Normal file
View file

@ -0,0 +1,456 @@
5 April 2009
MANGLE 2.2 RELEASE
Upgrades from mangle2.1:
-Added option -B to balkanize to add weights together, or take the maximum or minimum weight instead of just using the last weight in the polygon file
-Added option -W to polyid to write out the weights of the polygons containing each point rather than the id numbers
-Snap now renormalizes input vectors to ensure that all vectors are exact unit vectors
-Fixed bug in weight so that weights are not skipped in file when no midpoint is found
-Upgraded matlab plotting script to allow for an arbitrary range of weights
-Changed /dev/null paths in shell scripts to avoid bub in some linux flavors
-Increased NPOLYSMAX to 90000000
-Added compile flags to allow mangle to write files larger than 2G
--Molly Swanson
--------------------------------------------------------------------------------
25 July 2008
MANGLE 2.1 RELEASE
Upgrades from mangle2.0:
-added versions for Mac OSX (Intel and PowerPC)
-added versions that use real*8 in fortran and double in C (as opposed to real*10 and long double)
-compiled binaries statically to allow for greater portability
-added new example scripts (including an SDSS example)
-made extensive improvements to existing scripts
-added a script to automatically set up mangle environment variables
-added "snapped" and "balkanized" keywords so polygon files can automatically track whether they've been snapped or balkanized
-fixed bug in rasterize that assigned the wrong weights to output polygons
--Molly Swanson
--------------------------------------------------------------------------------
28 Nov 2007
MANGLE 2.0 RELEASE
Upgrades from mangle1.4.1:
-pixelize functions for very speedy processing of masks
-HEALPix import and export capabilities
-loads of other new features
Mangle 2.0 website:
http://space.mit.edu/home/tegmark/mangle/
--Molly Swanson, Colin Hill, Max Tegmark
--------------------------------------------------------------------------------
26 Nov 2007
Fixed rasterize so that it outputs polygon files, updated parse_args.c, added pixelized and snapped versions of HEALPix polygons at Nside=1 through 512 to the /masks/healpix/ directory.
--Colin Hill
--------------------------------------------------------------------------------
19 Nov 2007
Assorted minor updates: fixed issue with SDSSPix pixel boundaries, added 2dF230k weight function, added rounding tolerances in rect_to_poly function
--Molly Swanson
--------------------------------------------------------------------------------
8 Sept 2007
Fixed segmentation fault issue when NPOLYSMAX >~ 3000000 by allocating the main polygon arrays globally rather than locally. Also added calls to free_poly to clean up memory at the end of all programs.
--Molly Swanson
--------------------------------------------------------------------------------
3 Sep 2007
Changed snap and pixelize to use -vo instead of -vn.
Updated rasterize.c to use pixelization info in the most efficient manner possible.
Removed balkanizepolys.c and snappolys.c (put this code back into balkanize.c and snap.c, respectively).
Rewrote rasterize.c in the same format as the other main programs.
--Colin Hill
--------------------------------------------------------------------------------
18 August 2007
Added a script named healpixpolys.scr which constructs, pixelizes, and snaps the HEALPix pixels at any value of Nside.
--Colin Hill
--------------------------------------------------------------------------------
18 August 2007
Redesigned the rasterize algorithm so that no balkanization is required. Rasterize now works by computing the area of the intersection between each input mask polygon and each rasterizer polygon, and using each of these areas in the calculation of the area-averaged weight within each rasterizer pixel. This scheme is completely general and should work for not only the HEALPix pixels, but also other sets of rasterizer pixels.
--Colin Hill
--------------------------------------------------------------------------------
2 June 2007
Changed rasterize.c so that only one array of polygon pointers is used (instead of two).
--Colin Hill
--------------------------------------------------------------------------------
30 May 2007
Changed the way PI is defined in pi.h to ensure it's treated as a long double in the 80 bit version - this solves some issues with pixelizing with SDSSpix in the 80 bit version. Also made minor fix in sdsspix section of get_pixel.c.
--Molly Swanson
--------------------------------------------------------------------------------
22 May 2007
Added formatted versions of the unformatted fortran files defining the 2df100k and 2qz10k masks and produced unformatted versions with gfortran-compiled code that can be read with the 80-bit version of mangle. Updated READMEs and HELP.unformatted to instruct people to use the formatted version if they're having trouble.
Also updated balkanize and pixelize to not take the snap angles at the command line since polygons are no longer self-snapped after balkanizing.
--Molly Swanson
--------------------------------------------------------------------------------
21 May 2007
Added "pixelization" as a keyword so that the scheme and resolution are automatically specified in input files, e.g.
10 polygons
pixelization 3s
polygon 0 ....
Most commands now return an error if two input files have mismatched pixelizations, and sets res_max and scheme to the values defined in the input file. Pixelize ignores any previous pixelization info, and pixelmap uses the value of res_max defined on the command line rather than in the file.
Also took infiles out of the format structure and made it a global variable, for use with the pixelization error checking. Changed the healpix error-checking to use this global variable, and took out the "fmt.infiles = nfiles;" from all of the programs that read in files.
--Molly Swanson
--------------------------------------------------------------------------------
14 May 2007
Removed small typo in rasterize.c, namely, [-B] in the usage that referred to a now-deleted option.
--Colin Hill
--------------------------------------------------------------------------------
2 May 2007
Fixed memory allocation bug in pixelize - pixel loop now correctly skips over null polygons that have been pruned.
Changed initial call to pixel_loop from
n=pixel_loop(0,np,poly,npolys,polys); //np= only non-null polygons
to
n=pixel_loop(0,npoly,poly,npolys,polys); //npoly = all input polygons including null polygons
and added null-skipping code in pixel_loop:
/* skip null polygons */
if (input[j]->np > 0 && input[j]->cm[0] == 0.){
poly[j] = 0x0;
continue;
}
Also added code to automatically set all polygons to be in pixel 0 before pixelizing.
--Molly Swanson
--------------------------------------------------------------------------------
1 May 2007
Fixed some formatting issues when compiling on 64-bit system by changing printf statements for size_t type variables from %d to %zd
Also changed the typedef for "logical" to be int for 64-bit and long for 32-bit (needs to be more robust in figuring out whether you're on a 64-bit system though.)
--Molly Swanson
--------------------------------------------------------------------------------
1 May 2007
Finally committed many changes that were made during January/February:
- snap.c: split snap up into two files (snap.c and snappolys.c) so that the snap function can be used within rasterize (i.e., had to make snap a global function, not local); similar to what was done earlier with balkanize
- snappolys.c: new source file containing snap function, which used to be located in snap.c
- wrmask.c: added new function wr_healpix_weight, which is used to write output files in healpix_weight format
- manglefn.h: added new functions snap and wr_healpix_weight
- rdmask.c: implemented ability to read healpix_weight input files in full generality, i.e., ignore comments, blank lines, etc.
- gsubs.s.f: changed multiplicative factors in gtol subroutine in attempts to make balkanize work on dr4plus mask
- defines.h: increased NPOLYSMAX to 1565000
- format.h and copy_format.c: added 'int infiles' element to format structure (needed for rasterize/healpix_weight format)
- poly2poly.c: updated so that the old healpix2poly routine is now implemented within poly2poly (i.e., poly2poly -ih); in other words, healpix_weight input files are now processed just like any other input files
- defaults.h: set default value for fmt.infiles to be 1
- parse_args.c: updated to reflect deletion of healpix2poly
- rasterize.c: improved so that polygons are now snapped before balkanization occurs; removed redundant balkanization
- balkanize.c, harmonize.c, pixelize.c, polyid.c, pixelmap.c, poly2poly.c, ransack.c, snap.c, weight.c, unify.c:
added line that is needed for rasterize/healpix_weight to work properly: fmt.infiles = nfiles;
- GNUmakefile: updated to reflect changes made (deleted old healpix2poly program; added snappolys.c)
--Colin Hill
--------------------------------------------------------------------------------
17 April 2007
Fixed bug causing pixelize to segfault when it hits NPOLYSMAX:
replaced
if (out > out_max) {
with
if (out >= out_max) {
-Molly Swanson
--------------------------------------------------------------------------------
13 April 2007
Assorted cleanups:
- cleaned up warning messages in snap and unify
- updated Sun makefile
- fixed rdmask so reading in files in old polygon format (no pixel numbers) assigns pixel number 0 rather than reading in the steradian part
- changed wr_poly so it doesn't crash when writing a polygon w/o a "format" structure
was if (fmt->healpix_out) fprintf(file, "healpix_weight %d\n\n", fmt->nweights);
now if (fmt && fmt->healpix_out) fprintf(file, "healpix_weight %d\n\n", fmt->nweights);
- fixed memory allocation bug in ransack: after pruning, pointers were copied to null slots but still left in the original slots, causing problems when original slots are freed.
Rather than doing
poly[np] = poly[ipoly];
for every polygon that isn't pruned, do
/*copy down non-null polygons*/
k=0;
for(ipoly = 0; ipoly < npoly; ipoly++){
if(poly[ipoly]){
poly[k++]=poly[ipoly];
}
}
/*after copying non-null polygons, k should be equal to np */
if(k!=np){
fprintf(stderr, "ransack: should be left with %d non-null polygons, but actually have %d\n",np,k);
}
/*nullify the rest of the array, but don't free, since pointers have been copied above*/
for(ipoly=np; ipoly < npoly; ipoly++){
poly[ipoly]=0x0;
}
after pruning is done. Also made similiar change in poly2poly for consistency, although poly2poly hasn't caused any problems.
--Molly Swanson
--------------------------------------------------------------------------------
1 April 2007
Files for new mangle website added to website directory.
Still some work to be done:
- new title image;
- new 'manual' sections describing rasterize/pixelmap/healpix_weight/etc.;
- need shell scripts for 'scripts' section in 'download';
- some broken links need to be fixed in the 'polygon formats' and
'troubleshooting' sections in 'manual';
- the links and references at the bottom of the old mangle web page need to
be added somewhere;
- the 'quickstart' section needs to be redone, and the current material can
probably be added to the 'manual' section.
--Colin Hill
--------------------------------------------------------------------------------
9 March 2007
Fixed bug in ransack.c line 80
was rp[1] = x;
now rp[1] = y;
--Molly Swanson
--------------------------------------------------------------------------------
mangle1.5
20 Oct 2006
Changes from Colin Hill:
Added SDSSpix pixelization scheme
Added capability to import and export healpix files
New commands: healpix2poly, rasterize
New functions: get_healpix_poly, get_nside, healpix_verts,cmrpirpj
healpix functions: healpix_ang2pix_nest, pix2vec_nest
sdsspix functions: pix2ang, ang2pix, pix2ang_radec, ang2pix_radec,
csurvey2eq,eq2csurvey,superpix,subpix,pix_bound,pix_area,pix2xyz,area_index,
area_index_stripe,assign_parameters
Put balkanize function in separate balkanizepolys.c file
Made various other minor edits
--------------------------------------------------------------------------------
Changes from Molly Swanson:
Fixed bug in polyid created by pixelization stuff
Added pixelmap function
Added option to set polygon ids to their pixel numbers
--------------------------------------------------------------------------------
Changes from Andrew Hamilton:
14 Sep 2006
Thanks to Colin Hill, working with Max Tegmark and Molly Swanson at MIT,
for finding a polygon that defeated mangle.
1. The problem was numerical round-off,
and the immediate fix was to replace line 71 in split_poly.c
if (area != area_tot) { /* boundary intersects poly1 */
with
if (area > area_tot) { /* boundary intersects poly1 */
It should never happen that area < area_tot, since removing a boundary
of a polygon should never decrease its area, but thanks to numerical round-off
the area did decrease. Once that happened, mangle span its wheels.
2. The killer polygon that was responsible for the numerical failure of item 1
is discussed below. To improve mangle's defence against such polygons,
I changed the strategy for modifying the tolerance angle to multiple
intersections. Originally, if mangle detected an inconsistency in the
topology of the distribution of vertices around multiple intersections,
then mangle would double the tolerance angle and try again.
The new strategy is to try tightening as well as loosening the tolerance angle.
Mangle now see-saws between and tighter and looser tolerance angles
successive factors of 2 away from the original input tolerance angle.
3. There was also a bug on line 182 of balkanize.c.
for (i = npoly; i < npolys; i++) {
should have been
for (i = 0; i < npolys; i++) {
This bug became evident as a result of a compiler change.
When tripped, the bug produces a segmentation violation, so if you never
experienced this bug before, it should never have caused an error.
This is Colin Hill's killer polygon:
polygon 6 ( 5 caps, 1.0 weight, 0.000003265281337 str):
-0.2972995896945569 -0.5791945044073898 -0.7590432662449000 0.5786075961488696
-0.1092635942528740 0.6422417176858356 -0.7586745303718128 0.5279437897883537
-0.3927631897959760 -0.5199166454922474 -0.7585669110114012 -0.4794583692304901
-0.0457867636138749 0.6498588533234551 -0.7586745303718132 -0.5279437897887224
-0.3467216633109536 -0.5515406106135746 -0.7586745303718130 0.5279437897887302
It is a long (4.3 degrees) thin (36 arcsec) rectangle, split by a diagonal
which is almost, but not quite, tangent at each end to the long direction.
Each near tangent end is both almost multiply intersecting, and almost kissing.
If you balkanize the killer polygon with the default tolerance angle
for multiple intersections of 10^-5 arsec, then mangle1.4.1 will discard the
polygon as having zero area:
% balkanize killer.poly -
---------------- balkanize ----------------
snap angles: axis 2s latitude 2s edge 2s
multiple intersections closer than 1e-05s will be treated as coincident
...
1 polygons read from j6
warning from balkanize: following polygons have zero area & are being discarded:
0
...
0 polygons written to output
Well, the polygon is thin, 36 arcsec wide, so maybe you don't mind losing
the polygon. But with snap tolerance angles of 2 arcsec, you'd think mangle
should keep it. It turns out that the multiple intersections at each end
of the polygon have separations that vary from 10^-8 arcsec in the thin
direction to 80 arcsec in the long direction, and this distribution of
separations conspires so that mangle finds no consistent topology
(satisfying the 64-bit check number) for tolerance angles to multiple
intersections anywhere between 10^-8 arcsec and 40 arcsec. But 40 arcsec
exceeds the 36 arcsec width of the polygon, so mangle concludes that the
area is zero.
If the tolerance angle for multiple intersections is tightened to
5 x 10^-9 arcsec:
% balkanize -m5e-9s killer.poly -
then mangle does find the correct solution. That is, since the polygon
is already a valid polygon, balkanize spits back the killer polygon
unchanged.
Thus the solution to dealing with this polygon is not to loosen the
tolerance, but to tighten it. The new mangle strategy does this.
Max Tegmark suggests switching the entire mangle code from double (64-bit)
to quadruple (128-bit) precision. This may be a sensible thing to do
at some point. The need for high precision was always evident.
Inevitably, people are messing with masks that have arcsecond precision.
A 1 x 1 arcsec rectangle has an area of 2 x 10^-11 str, which is 2 x 10^-12
of the whole sky. This is a factor of 10^4 larger than the effective
precision 2 x 10^-16 of 64-bit floats. The factor of 10^4 is ok,
but with ever more complicated masks appearing, it may no longer be
providing a sufficient safety margin.
--------------------------------------------------------------------------------
5 Sep 2005
Added '\r' to characters considered blank, so polygon files are dos-compatible.
--------------------------------------------------------------------------------
mangle1.4.3
9 Jan 2006
Molly Swanson
Added "pixel 0" to the polygon files in masks/allsky
Commented out self-snapping step in balkanize to avoid creating problematic
long skinny polygons when running on the sdss mask
Added "list" output format to be read by matlab script
Changed defaults snap angles from 2 to .2 arcseconds
--------------------------------------------------------------------------------
mangle1.4.2
4 Mar 2005
Molly Swanson
Added pixelization functions to speed up snap, balkanize, unify, and polyid.
New command: pixelize
New functions: get_pixel, which_pixel, get_child_pixels, get_parent_pixels,
get_res, pixel_list, pixel_start, poly_sort
Modified polygon format to include pixel number
Made a variety of other small, minor changes
--------------------------------------------------------------------------------
mangle1.4.1
30 Mar 2004
Many thanks to Michael Blanton, who is working on the SDSS mask,
for bringing these two problems to light.
1. In some cases, balkanize creates long, extremely thin polygons that mangle
cannot subsequently deal with, because the polygons are simply too thin for
the numerics. The solution is to add to the balkanization routine a
penultimate step that snaps the edges of each polygon to each other.
This is not a bad idea anyway, since polygons produced by balkanization
should never need additional snapping.
2. Connected with the above problem, in some cases and on some platforms
vmid fails to find a midpoint of a polygon. The problematic polygons
are precisely the long extremely thin polygons mentioned in 1.
In these cases the barycentre of the polygon provides a satisfactory midpoint.
Therefore the barycentre is now included as one of the points to test
as a possible midpoint of a polygon.
In addition to the above, I added "intrinsic" declarations of abs max and min
to the fortran routines that use those functions, as required by some
fortran compilers.
--------------------------------------------------------------------------------
mangle1.4
3 Sep 2003
Several minor improvements.
The mangle code has gotten a pretty good workout on the 2dF 230k sample,
released on 30 June 2003, and there have been no changes in mangle for about
a month now, so I'm getting pretty happy that the code has converged,
at least for the time being.
In the future, if demand warrants, there may be an accelerated version of
mangle that replaces double do loops over polygons with code that is a little
more intelligent about deciding whether 2 polygons are close to each other.
--------------------------------------------------------------------------------
mangle1.3.3
24 June 2003
Implemented spolygon format.
--------------------------------------------------------------------------------
mangle1.3.2
17 June 2003
First general public release.
Major upgrade from mangle1.2; much more robust.
--------------------------------------------------------------------------------
mangle1.2
8 Sep 2001
First limited public release.

18
COPYRIGHT Normal file
View file

@ -0,0 +1,18 @@
You are free to do whatever you like with this software,
provided that, if you do use it, then you reference it.
The correct paper references are
Swanson M E C, Tegmark M, Hamilton A J S, and Hill J C (2007)
"Methods for Rapidly Processing Angular Masks of Next-Generation Galaxy Surveys"(arXiv:0711.4352) http://arxiv.org/abs/0711.4352
and
Hamilton A J S & Tegmark M (2004)
"A scheme to deal accurately and efficiently with complex angular masks
in galaxy surveys", MNRAS, 349, 115-128.
(astro-ph/0306324) http://arXiv.org/abs/astro-ph/0306324
The correct web reference is
http://space.mit.edu/home/tegmark/mangle/
Updated by mecs 28 Nov 2007

51
HELP.unformatted Normal file
View file

@ -0,0 +1,51 @@
Problem
-------
Your fortran refuses to read the unformatted fortran files made on another
system.
Diagnosis
---------
Your computer stores bytes with opposite endianness.
OR
Your version of mangle was compiled using the gfortran fortran compiler,
but you are trying to read unformatted fortran files produced with g77
fortran code.
Solution
--------
Download the formatted version of the masks available in the "data" section
of the mangle website http://space.mit.edu/home/tegmark/mangle/
and use these instead.
Another Solution
----------
WARNING: The following hack works only if each number in the unformatted
fortran file is a single word, i.e. an INTEGER or REAL (not DOUBLE PRECISION).
On a 32-bit machine, each word contains 4 bytes.
The following converts files to the opposite endianness using cpio,
a command famous for its obtuseness.
1. Make a cpio archive file from the original files, as in
ls -1 file1 file2 ... | cpio -o > files.cpio
Notice that the switch -1 is a one, not an ell.
2. Move the cpio archive to another directory where it will not overwrite
the old files
mv files.cpio other_directory
3. Extract the files from the cpio archive in the new directory
cd other_directory
cpio -i -b < files.cpio
The -b switch is the thing that does the byte-swapping in each word.

100
INSTALL Normal file
View file

@ -0,0 +1,100 @@
The mangle software is written in c and fortran,
so to compile mangle you will need both c and fortran compilers.
To (re)compile
--------------
cd <mangle_directory>/src
make
The executables will be in
<mangle_directory>/bin
To remove unneeded object files
-------------------------------
cd <mangle_directory>/src
make clean
To remove a previous compilation and compile from scratch
---------------------------------------------------------
cd <mangle_directory>/src
make cleanest
make
To generate a new Makefile for your local system and then compile from scratch
------------------------------------------------------------------------------
cd <mangle_directory>/src
configure
make cleanest
make
To compile a statically linked version suitable for distribution
----------------------------------------------------------------
cd <mangle_directory>/src
make cleanest
make static
Systems on which mangle 2.x has compiled successfully
-----------------------------------------------------
real*10 version:
Linux
gcc
gfortran 4.1.x or later
Mac OSX Intel
gcc
gfortran 4.1.x or later
see http://gcc.gnu.org/wiki/GFortranBinaries for gfortran for Mac OSX
may require updated version of cctools from ftp://gcc.gnu.org/pub/gcc/infrastructure/
real*8 version:
Linux
gcc
g77
Mac OSX Intel and PowerPC
gcc
g77
Systems on which mangle1.x has compiled successfully
----------------------------------------------------
Linux
gcc versions 2 or 3
g77 or fort77
Solaris
cc or gcc
f77 or g77
To patch mangle1.4 to mangle1.4.1
---------------------------------
cd <mangle_directory>
patch -p1 < ../path.to.the/mangle1.4_to_1.4.1.patch
You will then need to recompile.
Troubleshooting
---------------
If the Makefile gives problems, try using gmake (the gnu version of make)
in place of make. More generally, mangle is known to compile and run
successfully with the gnu versions gcc and g77 of the c and fortran compilers,
and with the gnu version gmake of the make command.
To compile the real*10 version, you will need a compiler that supports real*10,
for example, gfortran version 4.1 or later (though not all distributions
of gfortran support real*10).
There are bound to be problems with compilation in early stages of the general
release of mangle, since mangle has been tested only on a limited number of
systems. If you are having problems compiling, please contact the mangle development
team via Andrew.Hamilton@colorado.edu or tegmark@mit.edu, and we will try to work
with you to get mangle to compile on your system.
Updated by mecs 25 July 2008

33
README Normal file
View file

@ -0,0 +1,33 @@
Read INSTALL for instructions on compilation.
Documentation on mangle is at
http://space.mit.edu/home/tegmark/mangle/
To get started, try creating the mask for an example slice of the SDSS survey:
cd <mangle_directory>/masks/sdss
and follow the README,
or follow the QuickStart section on the website.
Typing a command with no arguments will give you a brief summary of its usage.
Typing a command with the -d switch will tell you what the defaults are.
The mathematical algorithms are described by
Hamilton A J S & Tegmark M (2004)
"A scheme to deal accurately and efficiently with complex angular masks
in galaxy surveys", MNRAS, 349, 115-128
and
Swanson M E C, Tegmark M, Hamilton A J S, and Hill J C (2008)
"Methods for rapidly processing angular masks of next-generation galaxy
surveys", MNRAS, 387, 1391-1402.
The intention is that the probability of the mangle software failing,
once successfully compiled, should be comparable to the probability
of a piece of spacejunk falling on your head (let's hope it ain't true).
If it fails, please check out Troubleshooting at
http://space.mit.edu/home/tegmark/mangle/manual/troubleshooting.html
If you still have a problem, please contact the mangle development team via
Andrew.Hamilton@colorado.edu or tegmark@mit.edu
Updated by mecs 24 July 2008

View file

@ -0,0 +1,42 @@
#!/usr/bin/env python
# takes a fits verion of a mangle file and removes unobserved sectors
# converts a mangle FITS file to a .ply file
import numpy as np
import os
import sys
import pylab as plt
import pyfits as py
maskFile = os.getenv("HOME")+"/workspace/Voids/catalogs/boss/boss_geometry_2011_06_10.fits"
outFile = os.getenv("HOME")+"/workspace/Voids/catalogs/boss/boss_mask.ply"
hdulist = py.open(maskFile)
maskData = hdulist[1].data
hdulist.close()
fp = open(len(maskData), 'w')
fp.write(str(numKeep) + " polygons\n")
fp.write("pixelization 6s\n")
fp.write("snapped\n")
fp.write("balkanized\n")
iKeep = 0
for i in xrange(len(maskData)):
fp.write("polygon %22d ( %d caps, %20.7f weight, %d pixel, %20.16f str):\n" %
(iKeep,
maskData.field('NCAPS')[i],
maskData.field('WEIGHT')[i],
maskData.field('PIXEL')[i],
maskData.field('STR')[i] ))
ncaps = maskData.field('NCAPS')[i]
for iCap in xrange(ncaps):
fp.write("%24.20f %24.20f %24.20f %24.20f\n" %
(maskData.field('XCAPS')[i][iCap][0],
maskData.field('XCAPS')[i][iCap][1],
maskData.field('XCAPS')[i][iCap][2],
maskData.field('CMCAPS')[i][iCap]))
iKeep += 1
fp.close()

1
scripts/2df100k.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/2df100k/2df100k.sh

1
scripts/2df230k.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/2df230k/2df230k.sh

1
scripts/2qz.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/2qz10k/2qz.sh

1
scripts/call Symbolic link
View file

@ -0,0 +1 @@
../masks/healpix/healpix_conversion_scripts/call

97
scripts/find_complement.sh Executable file
View file

@ -0,0 +1,97 @@
#! /bin/sh
# © M E C Swanson 2008
#script to find the complement of a mangle mask
#USAGE: find_complement.sh <mask> <complement>
#EXAMPLE:find_complement.sh holes.pol complement.pol
#input mask can be pixelized beforehand to a fixed resolution
#if the mask is complicated, e.g. pixelize -Ps0,8 holes.pol holes_pixelized.pol
if [ "$MANGLEBINDIR" = "" ] ; then
MANGLEBINDIR="../../bin"
fi
if [ "$MANGLESCRIPTSDIR" = "" ] ; then
MANGLESCRIPTSDIR="../../scripts"
fi
if [ "$MANGLEDATADIR" = "" ] ; then
MANGLEDATADIR="../../masks"
fi
mask=$1
complement=$2
dres=3
dscheme="s"
#check command line arguments
if [ "$mask" = "" ] || [ "$complement" = "" ] ; then
echo >&2 "ERROR: enter the input and output polygon files as command line arguments."
echo >&2 ""
echo >&2 "USAGE: find_complement.sh <mask> <complement>"
echo >&2 "EXAMPLE:find_complement.sh holes.pol complement.pol"
exit 1
fi
head -n 100 $mask > jmaskhead
#grab pixelization info from input files
awk '/pixelization/{print $0}' < jmaskhead > jpix
res=`awk '{print substr($2, 1, length($2)-1)}' < jpix`
scheme=`awk '{print substr($2, length($2))}' < jpix`
rm jpix jmaskhead
#if input file is unpixelized, pixelize it
#if input file is pixelized to a fixed resolution, use it as is.
if [ "$res" = "" ]; then
res=$dres
scheme=$dscheme
echo ""
echo "Pixelizing $1 ..."
$MANGLEBINDIR/pixelize -P${scheme}0,$res $mask jp || exit
echo ""
elif [ "$res" = -1 ] ; then
res=$dres
scheme=$dscheme
echo "WARNING: cannot take the complement of a mask pixelized adaptively."
echo "Pixelizing your mask using a fixed resolution:"
echo ""
echo "Pixelizing $1 ..."
$MANGLEBINDIR/pixelize -P${scheme}0,$res $mask jp || exit
echo ""
else
cp $mask jp
fi
#check for appropriate allsky file, and generate it if it's not there:
allsky=$MANGLEDATADIR/allsky/allsky$res$scheme.pol
if [ ! -e $allsky ] ; then
$MANGLESCRIPTSDIR/make_allsky.sh $res $scheme
fi
#check if input file is snapped
snapped=`awk '/snapped/{print $1}' < $mask`
#if input file isn't snapped, snap it
if [ ! "$snapped" = "snapped" ]; then
echo "Snapping $1 ..."
$MANGLEBINDIR/snap jp jps || exit
rm jp
else
mv jp jps
fi
#set weight of all polygons in mask to zero
echo 0 > jw0
echo "$MANGLEBINDIR/weight -zjw0 $mask jw"
$MANGLEBINDIR/weight -zjw0 jps jw || exit
rm jps
#balkanize the full sky with the zero-weighted mask to find the complement
echo "$MANGLEBINDIR/balkanize $allsky jw jb"
$MANGLEBINDIR/balkanize $allsky jw jb || exit
rm jw
#unify to get rid of zero weight polygons
echo "$MANGLEBINDIR/unify jb $complement"
$MANGLEBINDIR/unify jb $complement || exit
rm jb
echo "Complement of $mask written to ${complement}."

192
scripts/graphmask.m Normal file
View file

@ -0,0 +1,192 @@
function graphmask(infile,outfile,maprange,plottitle,outlines)
% © M E C Swanson 2008
%function for plotting MANGLE polygon files using the Matlab mapping toolbox.
%arguments:
%infile=polygon file to be plotted, in 'list' format, i.e.created with poly2poly -ol30 mypolys.pol mypolys.list
%outfile=name of eps file to output, or use 'none' if you want to, e.g., put the resulting figure into a subplot.
%maprange=[lonmin,lonmax,latmin,latmax] are optional latitude and longitude (Dec and RA)
%limits for the mask. If not provided, default is to plot full sky.
%title=optional title for the plot
%outlines=whether to draw black outlines around polygons. default is no outlines. Use outlines='on' to draw outlines.
%check if mapping toolbox is installed:
if ( ~exist('ispolycw') )
fprintf(2, 'To plot mangle masks in Matlab, you must have the mapping\ntoolbox (version 2.0.3 (R14SP1) or later) installed.\n');
exitval=1;
save('matlabexit.temp','exitval');
exit
end
%process input arguments
if(nargin<1)
error('graphmask requires at least one input argument: the name of the input data file to plot.');
end
if(nargin==1)
outfile='none';
maprange=[0 360 -90 90];
plottitle='';
outlines='';
lims=0;
end
if(nargin==2)
maprange=[0 360 -90 90];
plottitle='';
outlines='';
lims=0;
end
if(nargin==3)
plottitle='';
outlines='';
lims=1;
end
if(nargin==4)
outlines='';
lims=1;
end
if(nargin>=5)
lims=1;
end
if(all(maprange==0))
maprange=[0 360 -90 90];
lims=0;
end
%check if mapping toolbox is installed:
if (~isnumeric(maprange))
fprintf(2, 'ERROR: Non-numeric values used in maprange\n');
exitval=1;
save('matlabexit.temp','exitval');
exit
end
lonmin=maprange(1);
lonmax=maprange(2);
latmin=maprange(3);
latmax=maprange(4);
%set spacing for tickmarks
range=max(latmax-latmin, lonmax-lonmin);
avrange=mean([latmax-latmin, lonmax-lonmin]);
if(range<15)
sp=1;
else if (range<30)
sp=2;
else if (range<90)
sp=5;
else if (range<150)
sp=10;
else if (range<300)
sp=20;
else
sp=50;
end
end
end
end
end
%read in files
weightfile=[infile '.weight'];
xymat=load(infile);
wmat=load(weightfile);
fprintf(1,'Done reading files\n');
ra=xymat(1:end,1);
dec=xymat(1:end,2);
weight=wmat(1:end,2);
%set up map axes
axm=axesm('MapProjection', 'hammer','frame','on','FFaceColor','black','origin',180);
if (lims)
axesm('MapProjection','mercator','frame','on','maplatlimit',[latmin latmax], 'maplonlimit',[lonmin lonmax])
setm(gca,'ParallelLabel','on','PLabelLocation',sp,'LabelFormat','none','fontsize',10);
tightmap;
ax1=gca;
ax2=axes('Position',get(ax1,'Position'));
axesm('MapProjection','mercator','frame','on','maplatlimit',[latmin latmax], 'maplonlimit',[lonmin lonmax])
setm(gca,'FFaceColor','black')
else
axm=axesm('MapProjection', 'hammer','frame','on','FFaceColor','black','origin',180);
end
%plot polygons in list as patches
if (strcmp(outlines,'on'))
h=patchesm(dec,ra,'g','Edgecolor','black','Linewidth',0.3);
else
h=patchesm(dec,ra,'g','Edgecolor','none');
end
%normalize weights
minweight=min(weight);
maxweight=max(weight);
weight=(weight-minweight)./(maxweight-minweight);
%scale weight so that the minimum isn't black unless it's actually zero
if(minweight~=0)
minscale=.1;
zeroscale=minweight-minscale./(1-minscale).*(maxweight-minweight);
if(minscale>0 && zeroscale<=0)
zeroscale=0;
minscale=minweight./maxweight;
end
weight=(1-minscale).*weight+minscale;
else
zeroscale=minweight;
end
%set holes (polygons with points wound counterclockwise) to have weight 0
ccw=~ispolycw(dec,ra);
weight(ccw)=0;
%create cell array of colors with each element as grayscale weight
color=[weight weight weight];
cellcolor=num2cell(color,2);
%apply weight colors to patch objects
set(h,{'FaceColor'},cellcolor);
%tweak map display and add labels
if (lims)
set(gca,'XDir', 'reverse')
gridm on;
setm(gca,'MeridianLabel','on','MLabelLocation',sp,'MLineLocation',sp,'PLineLocation',sp,'MLabelParallel','south',...
'LabelFormat','none', 'MLineLimit',[latmin latmin+.01*avrange],'PLineLimit',[lonmax-.01*avrange, lonmax],...
'glinestyle','-','gcolor',[.5 .5 .5],'fontsize',10);
tightmap;
mlabelzero22pi
xlabel('\newline Right Ascension')
ylabel('Declination\newline ')
else
tightmap;
xlims=get(gca,'XLim');
ylims=get(gca,'YLim');
axis([1.01*xlims 1.01*ylims])
set(gca,'XDir', 'reverse','XColor',[1 1 1],'YColor',[1 1 1])
xlabel('-90^{\circ}','Color','k')
ylabel('360^{\circ}','Rotation',0.0,'Color','k','VerticalAlignment','Middle','HorizontalAlignment','Right')
ax1=gca;
ax2=copyobj(ax1,gcf);
set(ax2,'XAxisLocation','top', 'YAxisLocation','right','Color','none','XColor',[1 1 1],'YColor',[1 1 1]);
axes(ax2);
xlabel('+90^{\circ}','Color','k')
ylabel('0^{\circ}','Rotation',0.0,'Color','k','VerticalAlignment','Middle','HorizontalAlignment','Left')
end
title(plottitle);
%add colorbar
pb=pbaspect;
pos1=get(gca,'Position');
axes('Position',pos1)
axis off
colormap('gray')
caxis([zeroscale maxweight]);
pbaspect(pb);
pos1=get(gca,'Position');
cbar_handle=colorbar('EastOutside');
set(gca,'Position',pos1);
fprintf(1,'Done making mask image\n');
%export image as eps file
if(~strcmp(outfile,'none'))
set (gcf, 'Color', [1 1 1])
if(~lims)
set(gcf,'PaperPosition', [-1.75 .75 14 7])
end
print('-depsc','-r600',outfile);
fprintf(1,'Done writing mask image to %s\n',outfile);
exit
end

69
scripts/graphmask.sh Executable file
View file

@ -0,0 +1,69 @@
#!/bin/sh
# © M E C Swanson 2008
#plot the angular mask described by a polygon file in .list format
#using the matlab mapping toolbox
#
#optional 3rd-6th arguments give the RA and Dec range to plot the mask
#if no range is given, the full sky will be plotted
#To plot range that includes RA=0, use a negative number for the "low"
#end, e.g. for a 10 degree strip covering RA=355 degrees to RA=5 degrees,
#use a range of -5 5.
#Entering in "0 0 0 0" for the range will also give the default full sky behavior,
#which can be used if you also wish to, e.g., enter a title.
#
#optional 7th argument gives a title for the graph
#optional 8th argument turns on drawing black outlines around each polygon
#
#if specifying the full path to a file (rather than just running in the directory
#containing the file you want to plot), put the path in double-quotes as shown below.
#
#USAGE: graphmask.sh <infile> <outfile> [<ramin> <ramax> <decmin> <decmax>] [<title>] [<outlines>]
#EXAMPLES:
#fullsky, no outlines: graphmask.sh "dr4/safe0/sdss_dr4safe0_mask.list" "dr4/safe0/sdss_dr4safe0_mask.eps"
#defined range, title, no outlines: graphmask.sh sdss_slice.list sdss_slice.eps -45 35 8 21 "SDSS slice"
#defined range, no title, outlines: graphmask.sh sdss_slice.list sdss_slice.eps -45 35 8 21 "" on
#fullsky, no title, outlines: graphmask.sh sdss_slice.list sdss_slice.eps 0 0 0 0 "" on
if [ "$MANGLESCRIPTSDIR" = "" ] ; then
MANGLESCRIPTSDIR="../../scripts"
fi
if [ $# -eq 2 ]; then
if [ -e $1 ]; then
if [ -e $2 ]; then
rm $2
fi
matlab -nodisplay -r addpath\(\'$MANGLESCRIPTSDIR\'\)\;graphmask\(\'$1\',\'$2\'\)
else
echo >&2 "ERROR: file $1 not found."
exit 1
fi
elif [ $# -ge 6 ]; then
if [ -e $1 ]; then
if [ -e $2 ]; then
rm $2
fi
echo "addpath('$MANGLESCRIPTSDIR'); graphmask('$1','$2',[$3,$4,$5,$6],'$7','$8')" > jgraphtemp.m
matlab -nodisplay < jgraphtemp.m
rm jgraphtemp.m
else
echo >&2 "ERROR: file $1 not found."
exit 1
fi
else
echo >&2 "USAGE: graphmask.sh <infile> <outfile> [<ramin> <ramax> <decmin> <decmax>] [<title>] [<outlines>]"
echo >&2 "EXAMPLES:"
echo >&2 "fullsky, no outlines: graphmask.sh \"dr4/safe0/sdss_dr4safe0_mask.list\" \"dr4/safe0/sdss_dr4safe0_mask.eps\""
echo >&2 "defined range, title, no outlines: graphmask.sh sdss_slice.list sdss_slice.eps -45 35 8 21 \"SDSS slice\""
echo >&2 "defined range, no title, outlines: graphmask.sh sdss_slice.list sdss_slice.eps -45 35 8 21 \"\" on"
echo >&2 "fullsky, no title, outlines: graphmask.sh sdss_slice.list sdss_slice.eps 0 0 0 0 \"\" on"
exit 1
fi
if [ -e matlabexit.temp ] || [ ! -e $2 ]; then
echo >&2 "ERROR: error in matlab plotting script."
if [ -e matlabexit.temp ]; then
rm matlabexit.temp
fi
exit 1
fi
echo all done!

226
scripts/graphmask.sm Executable file
View file

@ -0,0 +1,226 @@
graphmask 28 # © M E C Swanson 2008
#An sm script to plot mangle graphics files
#first argument: mangle graphics file to read: *.grph
#second argument: postscript file for output graph: *.eps
#third and fourth arguments: optional range for right ascension to plot
# (use 0 0 to plot using range from data)
#fifth and sixth arguments: optional range for declination to plot
# (use 0 0 to plot with dec range adjusted to give equal scaling on x and y axes,
# centered on the range of all the data.)
#seventh argument: title of graph: "I am a title"
#eighth argument: optional switch: 0 for outlines off, 1 for outlines on (default is 0)
#
#WARNINGS:
# -This script uses the opposite color scheme than the matlab script, i.e.,
# weight 1 = black, weight 0 = white
# -RA and Dec are treated as linear variables (no spherical projection). This means that
# ranges that span RA=0 won't plot properly.
# -SM can only plot square eps files, so if you define both RA and Dec range, they should
# have the same length, otherwise your plot will appear stretched.
# -SM has a line length limit of 1500 characters, which SDSS tends to have no trouble overloading.
# If you get an error reading the file, try making your graphics file with lower precision and
# fewer points per 2pi, i.e., use poly2poly -og12 -p3 instead of poly2poly -og30.
#
#USAGE: sm -m $MANGLESCRIPTSDIR/graphmask.sm <infile> <outfile> [<ramin> <ramax>] [<decmin> <decmax>] [<title>] [<outlines>]
#EXAMPLES:
#default range, no outlines: sm -m $MANGLESCRIPTSDIR/graphmask.sm sdss_slice.grph sdss_slice.eps
#defined RA range, outlines: sm -m $MANGLESCRIPTSDIR/graphmask.sm sdss_slice.grph sdss_slice.eps "SDSS slice" 0 35 0 0 1
#defined range, no outlines: sm -m $MANGLESCRIPTSDIR/graphmask.sm sdss_slice.grph sdss_slice.eps "SDSS slice" 10 20 10 20
#defined range, outlines: sm -m graphmask.sm sdss_slice.grph sdss_slice.eps "SDSS slice" 10 20 10 20 1
#
data $1
device postfilecolour $2
#location $gx1 $gx2 $gy1 $(.77*($gx2-$gx1))
if($?3) { define title $3 }
if($?3 && $?4) {
if(!($3==0 && $4==0)){
define azmin $3
define azmax $4
}
}
if($?5 && $?6) {
if(!($5==0 && $6==0)){
define elmin $5
define elmax $6
}
}
if($?7) { define title $7 }
if($?8) { define outlines $8 } else { define outlines 0 }
define i 0 # i = current line to read in file
define in_header 1 # in_header = 1 if reading header of file
#process header information
while{$in_header} {
define i ($i+1)
read row header $i.s
if (header[1]=='polygons'){
define npoly (ATOF((header[0])))
} else { if (header[0]=='unit'){
define unit (header[1])
} else { if (header[0]=='graphics'){
#we've reached the body of the data file, so move on
define in_header 0
} else {
write standard Unrecognized format in line $i of $1.
write standard Please fix the data file and try again.
write smerr.temp 1
quit
}}}
}
define i_start $i #i_start = first line of data
define polycount 0
define first_poly 1
#process polygon data
define numlines ($i_start+2*$npoly-1)
while { $i < $numlines } {
read row specs $i.s
if(specs[0]!='graphics' || dimen(specs)!=12){
write standard Formatting error in line $i of $1
write standard Your data file probably contains a line over 1500 characters long.
write standard Please try to make your data file with shorter lines:
write standard i.e., use poly2poly -og10 -p3 instead of poly2poly -og30.
write smerr.temp 1
quit
}
set id = ATOF(specs[1])
set n_tot = ATOF(specs[3])
set edges = ATOF(specs[5])
set w = ATOF(specs[7])
set midx = ATOF(specs[9])
set midy = ATOF(specs[10])
define numpoints (n_tot[0])
while{$numpoints>0}{
read row polypoints $($i+1)
set n = (dimen(polypoints)/2)
define numpoints ( $numpoints - n[0])
#if there are still points to read in for this polygon,
#we need to read in another line
if($numpoints>0){
write standard "extra line for disconnected polygon"
define numlines ($numlines+1)
}
#separate list of points in x y x y x y ... format into x and y vectors
set ix = 0,2*n[0]-2,2 #even numbers
set iy = 1,2*n[0]-1,2 #odd numbers
# x = numbers with even list indices (indices start at 0)
# y = numbers with odd list indices
# tack first point on at end to close the polygon
set x=polypoints[ix] CONCAT polypoints[0]
set y=polypoints[iy] CONCAT polypoints[1]
# if polygon is in range to be plotted, add it to plot list
if($first_poly){
#if this is the first polygon in list, start the list
set x_all = x
set y_all = y
set numpoints = n+1
set weight = w
define first_poly 0
} else {
#otherwise, tack this one on to the list
set x_all = x_all CONCAT x
set y_all = y_all CONCAT y
set numpoints = numpoints CONCAT (n+1)
set weight = weight CONCAT w
}
define i ($i+1)
define polycount ($polycount+1)
}
define i ($i+1)
}
limits x_all y_all
#adjust limits so the axes have equal scaling
if( ($fx2-$fx1)/$nx > ($fy2-$fy1)/$ny ) {
define ymid (($fy1+$fy2)/2)
define ymin ($ymid - .5*($fx2-$fx1)*$ny/$nx)
define ymax ($ymid + .5*($fx2-$fx1)*$ny/$nx)
define xmin $fx1
define xmax $fx2
} else { if( ($fx2-$fx1)/$nx < ($fy2-$fy1)/$ny ) {
define xmid (($fx1+$fx2)/2)
define xmin ($xmid - .5*($fy2-$fy1)*$nx/$ny)
define xmax ($xmid + .5*($fy2-$fy1)*$nx/$ny)
define ymin $fy1
define ymax $fy2
}}
limits $xmin $xmax $ymin $ymax
#if limits have been specified as arguments, use them
if($?azmin && $?azmax) {
write standard using user-defined limits for RA
define scale (($azmax-$azmin)/($xmax-$xmin))
define ymid (($fy1+$fy2)/2)
define ymin ($ymid - .5*($fy2-$fy1)*$scale)
define ymax ($ymid + .5*($fy2-$fy1)*$scale)
define xmin $azmin
define xmax $azmax
if($?elmin && $?elmax) {
write standard using user-defined limits for dec
define ymin $elmin
define ymax $elmax
}
}
limits $xmin $xmax $ymin $ymax
expand 1.00001
ANGLE 0
AXIS $fx2 $fx1 0 0 $gx1 $gy1 $($gx2-$gx1) 1 $(0)
AXIS $fx2 $fx1 0 0 $gx1 $gy2 $($gx2-$gx1) 0 $(1)
ANGLE 90
AXIS $fy1 $fy2 0 0 $gx1 $gy1 $($gy2-$gy1) 2 $(1)
AXIS $fy1 $fy2 0 0 $gx2 $gy1 $($gy2-$gy1) 0 $(0)
ANGLE 0
#box
xlabel Right Ascension ($unit)
ylabel Declination ($unit)
identification
if ($?title) {
define titlepos ($gy2+100)
relocate ($gx1 $titlepos)
putlabel 9 $title
}
define j 0
do i=0,$polycount-1 {
set k = $j, $j+numpoints[$i]-1
set x=x_all[k]
set y=y_all[k]
#flip so that RA increases from right to left
set x = $fx1+$fx2-x
define j ($j+numpoints[$i])
define gray (int(50+ 200*(1-weight[$i])))
ctype = <0 $gray 255> + 256*<0 $gray 255> + 256*256*<0 $gray 255>
#check if polygon is clockwise or counterclockwise
set ii=0,numpoints[$i]-2
set iplus=1,numpoints[$i]-1
set cross=((x[ii]*y[iplus])-(x[iplus]*y[ii]))
#ishole should be positive if polygon is a hole
set ishole=(.5*sum(cross))
if($outlines){
ctype 0
connect x y
} else {
ctype 1
connect x y
}
if (ishole > 0){
ctype 2
shade 0 x y
} else {
ctype 1
shade 0 x y
}
}
quit
#end

86
scripts/graphmasksm.sh Executable file
View file

@ -0,0 +1,86 @@
#!/bin/sh
# © M E C Swanson 2008
#plot the angular mask described by a polygon file in graphics format
#using sm
#
#optional 3rd-6th arguments give the RA and Dec range to plot the mask
#If no range is given, range will be calculated automatically from the data.
#If only an RA range is given, Dec range will be calculated automatically
#to give equal scaling on x and y axes, centered on the range of all the data.
#
#Entering in "0 0 0 0" for the range will also give an automatic range,
#which can be used if you also wish to, e.g., enter a title.
#Likewise entering "0 0" for the Dec range is equivalent to only specifying an RA range.
#
#optional 7th argument gives a title for the graph
#optional 8th argument turns on drawing black outlines around each polygon
#
#if specifying the full path to a file (rather than just running in the directory
#containing the file you want to plot), put the path in double-quotes as shown below.
#
#USAGE: graphmasksm.sh <infile> <outfile> [<ramin> <ramax>] [<decmin> <decmax>] [<title>] [<outlines>]
#EXAMPLES:
#default range, no outlines: graphmasksm.sh "dr4/safe0/sdss_dr4safe0_mask.grph" "dr4/safe0/sdss_dr4safe0_mask.eps"
#defined range, title, no outlines: graphmasksm.sh sdss_slice.grph sdss_slice.eps -45 35 8 21 "SDSS slice"
#defined range, no title, outlines: graphmasksm.sh sdss_slice.grph sdss_slice.eps -45 35 8 21 " " on
#default range, no title, outlines: graphmasksm.sh sdss_slice.grph sdss_slice.eps 0 0 0 0 " " on
#WARNINGS: (a.k.a., reasons to use the matlab plotting script instead!)
# -This script uses the opposite color scheme than the matlab script, i.e.,
# weight 1 = black, weight 0 = white
# -RA and Dec are treated as linear variables (no spherical projection). This means that
# ranges that span RA=0 won't plot properly.
# -SM can only plot square eps files, so if you define both RA and Dec range, they should
# have the same length, otherwise your plot will appear stretched.
# -SM has a line length limit of 1500 characters, which SDSS tends to have no trouble overloading.
# If you get an error reading the file, try making your graphics file with lower precision and
# fewer points per 2pi, i.e., use poly2poly -og12 -p3 instead of poly2poly -og30.
#
if [ "$MANGLESCRIPTSDIR" = "" ] ; then
MANGLESCRIPTSDIR="../../scripts"
fi
if [ ! "$7" = "" ] ; then
title="\"$7\""
else
title=""
fi
if [ "$8" = "on" ] ; then
outlines=1
else
outlines=""
fi
if [ $# -ge 2 ]; then
if [ -e $1 ]; then
echo "Plotting $1 using sm ..."
if [ -e $2 ]; then
rm $2
fi
sm -m $MANGLESCRIPTSDIR/graphmask.sm $1 $2 $3 $4 $5 $6 $title $outlines > sm.temp
else
echo >&2 "ERROR: file $1 not found."
exit 1
fi
else
echo >&2 "USAGE: graphmasksm.sh <infile> <outfile> [<ramin> <ramax>] [<decmin> <decmax>] [<title>] [<outlines>]"
echo >&2 "EXAMPLES:"
echo >&2 "default range, no outlines: graphmasksm.sh \"dr4/safe0/sdss_dr4safe0_mask.grph\" \"dr4/safe0/sdss_dr4safe0_mask.eps\""
echo >&2 "defined range, title, no outlines: graphmasksm.sh sdss_slice.grph sdss_slice.eps -45 35 8 21 \"SDSS slice\""
echo >&2 "defined range, no title, outlines: graphmasksm.sh sdss_slice.grph sdss_slice.eps -45 35 8 21 \" \" on"
echo >&2 "default range, no title, outlines: graphmasksm.sh sdss_slice.grph sdss_slice.eps 0 0 0 0 \" \" on"
exit 1
fi
if [ -e smerr.temp ] || [ ! -e $2 ]; then
echo >&2 "ERROR: error in sm plotting script."
echo >&2 "See log in sm.temp for more details."
if [ -e smerr.temp ]; then
rm smerr.temp
fi
exit 1
fi
rm sm.temp
echo all done!

1
scripts/healpixpolys.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/healpix/healpixpolys.sh

1
scripts/healpixrast.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/healpix/healpixrast.sh

1
scripts/healpixrast2fits.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/healpix/healpixrast2fits.sh

1
scripts/make_allsky.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/allsky/make_allsky.sh

146
scripts/make_pixelmaps.sh Executable file
View file

@ -0,0 +1,146 @@
#!/bin/sh
# © M E C Swanson 2008
#Script to make pixelmaps of a mask at several resolutions
#Pixelmaps give the average value of the mask's weight in each pixel,
#using one of mangle's pixelization schemes.
#pixelmaps are saved as $inputmask.$res$scheme, e.g. for
#the input mask sdss_dr7safe0_res6d.pol, pixelmap files will be
#sdss_dr7safe0_res6d.pol.1d, sdss_dr7safe0_res6d.pol.2d, etc.
#
#if a galaxy file is given, this script also uses polyid to find in which pixels
#each galaxy in the list lies. The input galaxy file can have any number of columns,
#but the first 2 columns should be the RA and dec.
#output galaxy files for each resolution will attach the pixel number to the end of
#each line in the galaxy file that lies within a pixel in the pixelmap. The naming
#scheme is the same as for the pixelmap files, e.g., for the input galaxy file
#sdss_dr7safe0_galdetails1.dat, the output galaxy files will be
#sdss_dr7safe0_galdetails1.dat.1d, sdss_dr7safe0_galdetails1.dat.2d, etc.
#
#By default, this script cuts out any pixels with average weights less than 0.5 for
#resolution 1 and average weights less than 0.8 for higher resolutions. To run
#the script without these cuts, enter a 0 for the final command line argument.
#
#USAGE: make_pixelmaps.sh <input mask file> [<input galaxy file>] [<0 to turn cuts off>]
#EXAMPLES:
#make_pixelmaps.sh sdss_dr7safe0_res6d.pol
#make_pixelmaps.sh sdss_dr7safe0_res6d.pol 0
#make_pixelmaps.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat
#make_pixelmaps.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat 0
if [ "$MANGLEBINDIR" = "" ] ; then
MANGLEBINDIR="../../bin"
fi
if [ "$MANGLESCRIPTSDIR" = "" ] ; then
MANGLESCRIPTSDIR="../../scripts"
fi
if [ "$MANGLEDATADIR" = "" ] ; then
MANGLEDATADIR="../../masks"
fi
mask=$1
gals=$2
cutweights=$3
#check command line arguments
if [ "$mask" = "" ] ; then
echo >&2 "ERROR: enter the input polygon and galaxy files as command line arguments."
echo >&2 ""
echo >&2 "USAGE: make_pixelmaps.sh <input mask file> [<input galaxy file>] [<0 to turn cuts off>]"
echo >&2 "EXAMPLES:"
echo >&2 "make_pixelmaps.sh sdss_dr7safe0_res6d.pol"
echo >&2 "make_pixelmaps.sh sdss_dr7safe0_res6d.pol 0"
echo >&2 "make_pixelmaps.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat"
echo >&2 "make_pixelmaps.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat 0"
exit 1
fi
if [ "$gals" == 0 ] ; then
cutweights=0
gals=
fi
if [ "$cutweights" = "" ] ; then
cutweights=1
fi
dresmax=6
dscheme="d"
head -n 100 $mask > jmaskhead
#grab pixelization info from input file
awk '/pixelization/{print $0}' < jmaskhead > jpix
resmax=`awk '{print substr($2, 1, length($2)-1)}' < jpix`
scheme=`awk '{print substr($2, length($2))}' < jpix`
rm jpix
#check if input file is snapped and balkanized
snapped=`awk '/snapped/{print $1}' < jmaskhead`
balkanized=`awk '/balkanized/{print $1}' < jmaskhead`
rm jmaskhead
#if input file is not pixelized, snapped, and balkanized, exit.
#if input file is pixelized to a fixed resolution, use it as is.
if [ "$resmax" = "" ]; then
echo >&2 "ERROR: cannot make pixelmaps of an unpixelized mask."
echo >&2 "Pixelize your mask using the pixelize function first."
exit 1
elif [ "$resmax" = -1 ] ; then
resmax=$dresmax
echo "WARNING: making pixelmaps of a mask pixelized adaptively."
echo "Attempting to make pixelmaps up to resolution $resmax."
echo "To guarantee that pixelmaps can be made up to a given resolution,"
echo "Pixelize your mask using a fixed resolution <r> by using 'pixelize -P<scheme>0,<r>'."
fi
#if input file isn't snapped, exit
if [ ! "$snapped" = "snapped" ]; then
echo >&2 "ERROR: cannot make pixelmaps of an unsnapped mask."
echo >&2 "Run snap on your mask before running this script,"
echo >&2 "or add the 'snapped' keyword to your file if it is already snapped."
exit 1
fi
#if input file isn't balkanized, exit
if [ ! "$balkanized" = "balkanized" ]; then
echo >&2 "ERROR: cannot make pixelmaps of an unbalkanized mask."
echo >&2 "Run balkanize on your mask before running this script,"
echo >&2 "or add the 'balkanized' keyword to your file if it already consists"
echo >&2 "of only non-overlapping polygons."
exit 1
fi
for (( res=1; res<=$resmax; res++ ))
do
outmask=$mask.$res$scheme
echo "Generating pixelmap for resolution $res ..."
$MANGLEBINDIR/pixelmap -P${scheme}0,$res $mask $outmask || exit
#cut all pixels with weights less than 0.5 for resolution 1 or 0.8 for higher resolutions
if [ $cutweights -ne 0 ] ; then
if [ $res -le 1 ] ; then
weightcut=0.5
else
weightcut=0.8
fi
mv $outmask jp
$MANGLEBINDIR/poly2poly -j$weightcut jp $outmask || exit
echo "Pixels in $outmask have weights in the range defined in make_pixelmaps.sh."
echo "To run make_pixelmaps.sh without these cuts, enter a 0 for the last command line argument."
echo "EXAMPLE: make_pixelmaps.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat 0"
fi
if [ ! "$gals" == "" ] ; then
if [ -e "$gals" ] ; then
outgals=$gals.$res$scheme
$MANGLESCRIPTSDIR/polyid_gals.sh $outmask $gals $outgals
else
echo >&2 "ERROR: input galaxy file $gals not found!"
exit 1
fi
fi
done

76
scripts/make_setup_script.sh Executable file
View file

@ -0,0 +1,76 @@
#! /bin/sh
# © M E C Swanson 2008
#
#script called by wrapper script setup_mangle_environment to set
#mangle environment variables
#
#USAGE: type 'source setup_mangle_environment' in the base mangle directory
#If environment is setup correctly, typing
#'echo $MANGLEBINDIR; echo $MANGLESCRIPTSDIR; echo $MANGLEDATADIR'
#should print out the names of the appropriate directories.
#
#If the above command doesn't work, try 'source setup_mangle_environment $PWD/'
#
#
#You can also use 'source <MANGLEDIR>setup_mangle_environment <MANGLEDIR>'
#where <MANGLEDIR> is the path to the base mangle directory, e.g., /home/username/mangle2.1/
#
#To automatically set up the mangle environment variables when you start your shell,
#add the following line to your .bashrc (or .tcshrc, or .cshrc, or .login, or .profile)
#(replace <MANGLEDIR> with the path to your mangle installation):
#
#source <MANGLEDIR>setup_mangle_environment <MANGLEDIR>
#If no command line argument is given, assume we're running in the mangle directory
#
#arguments to make_setup_script.sh are:
# $1: 0 if export exists in the environment shell, nonzero otherwise
# $2: name of base mangle directory <MANGLEDIR>
if [ "$2" = "" ]; then
MANGLEDIR=$PWD/
#otherwise use the path in the first command-line argument as $MANGLEDIR
else
MANGLEDIR=$2
fi
MANGLEBINDIR="${MANGLEDIR}bin"
MANGLESCRIPTSDIR="${MANGLEDIR}scripts"
MANGLEDATADIR="${MANGLEDIR}masks"
#check to make sure directories exist
if [ ! -d $MANGLEBINDIR ]; then
echo >&2 "ERROR: The directory $MANGLEBINDIR does not exist"
fi
if [ ! -d $MANGLESCRIPTSDIR ]; then
echo >&2 "ERROR: The directory $MANGLESCRIPTSDIR does not exist"
fi
if [ ! -d $MANGLEDATADIR ]; then
echo >&2 "ERROR: The directory $MANGLEDATADIR does not exist"
fi
if [ ! -d $MANGLEBINDIR ] || [ ! -d $MANGLESCRIPTSDIR ] || [ ! -d $MANGLEDATADIR ]; then
echo >&2 ""
echo >&2 "USAGE: type 'source setup_mangle_environment' in the base mangle directory"
echo >&2 "Or use 'source <MANGLEDIR>setup_mangle_environment <MANGLEDIR>'"
echo >&2 "where <MANGLEDIR> is the path to the base mangle directory,"
echo >&2 "e.g., /home/username/mangle2.1/"
exit 1
fi
#export environment variables and put bin and scripts directories in the path
if [ "$1" = "0" ] ; then
cat <<EOF > setup_script
export MANGLEBINDIR=$MANGLEBINDIR
export MANGLESCRIPTSDIR=$MANGLESCRIPTSDIR
export MANGLEDATADIR=$MANGLEDATADIR
export PATH=$PATH:$MANGLEBINDIR:$MANGLESCRIPTSDIR
EOF
else
cat <<EOF > setup_script
setenv MANGLEBINDIR $MANGLEBINDIR
setenv MANGLESCRIPTSDIR $MANGLESCRIPTSDIR
setenv MANGLEDATADIR $MANGLEDATADIR
setenv PATH $PATH:$MANGLEBINDIR:$MANGLESCRIPTSDIR
EOF
fi

1
scripts/mangle_sdss.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/sdss/mangle_sdss.sh

114
scripts/mangle_testsuite.sh Executable file
View file

@ -0,0 +1,114 @@
#!/bin/sh
# © M E C Swanson 2008
#
#This script tests the mangle installation and creates a tarball of
#output files for further examination.
#
#USAGE: source run_mangle_testsuite > test.log
mkdir test
echo "mangle environment variables are:"
echo "MANGLEBINDIR=$MANGLEBINDIR"
echo "MANGLESCRIPTSDIR=$MANGLESCRIPTSDIR"
echo "MANGLEDATADIR=$MANGLEDATADIR"
echo "PATH=$PATH"
echo "Checking if unformatted fortran files are readable."
cd ../masks/2df100k
../../bin/weight -z2dF100k ngp_fields.dat jnf || exit
../../bin/weight -z2dF100k sgp_fields.dat jnf || exit
cd ../2df230k
../../bin/weight -z2dF230k ngp_fields.dat jnf || exit
../../bin/weight -z2dF230k sgp_fields.dat jnf || exit
rm jnf
echo "Running mangle on 2qz10k mask ..."
cd ../2qz10k/
./2qz.sh
if [ -e 2qz_res4s.eps ]; then
mv 2qz_res4s.eps ../../scripts/test
if [ -e 2qz_north_res4s.eps ]; then
mv 2qz_north_res4s.eps ../../scripts/test
fi
if [ -e 2qz_south_res4s.eps ]; then
mv 2qz_south_res4s.eps ../../scripts/test
fi
fi
mv 2qz_north_res4s.pol 2qz_south_res4s.pol ../../scripts/test
rm 2qz_*
samp=dr6
echo "Running mangle on slice of SDSS $samp mask ..."
cd ../sdss
./sdss_quickstart.sh
if [ -e sdss_${samp}safe0_slice.eps ]; then
mv sdss_${samp}safe0_slice.eps ../../scripts/test
elif [ -e sdss_${samp}safe0_slice1.eps ] && [ -e sdss_${samp}safe0_slice2.eps ]; then
mv sdss_${samp}safe0_slice1.eps sdss_${samp}safe0_slice2.eps ../../scripts/test
else
mv sdss_${samp}safe0_slice.pol ../../scripts/test
fi
rm sdss_${samp}safe0_slice.*
echo "Trimming 2qz north mask with an icosahedron polygon ..."
cd ../../scripts/test
cp ../../masks/icosahedron/icosahedron.pol .
../../bin/poly2poly -J7,7 icosahedron.pol ico7.pol
../../scripts/trim_mask.sh 2qz_north_res4s.pol ico7.pol trimmed_mask.pol
rm icosahedron.pol ico7.pol
echo "Rasterizing 2qz north mask ... "
rm ../../masks/healpix/healpix_polys/nside16_p5s.pol
../../scripts/healpixrast.sh 2qz_north_res4s.pol 16 rasterized_mask.pol
../../scripts/healpixrast2fits.sh 2qz_north_res4s.pol 16 rasterized_mask.fits 16 rasterized_mask.gif
../../scripts/call ../../bin/fits2dat_binary.x 1 16 rasterized_mask.fits j2
echo healpix_weight 3072 > j1
cat j1 j2 > rasterized_mask1.dat
rm j1 j2 args.dat
../../bin/poly2poly rasterized_mask1.dat rasterized_mask1.pol
echo "Making pixelmaps of 2qz north mask ..."
cp ../../masks/2qz10k/azel.dat jazel
tail +2 jazel > azel.dat
../../scripts/make_pixelmaps.sh 2qz_north_res4s.pol azel.dat 0
rm azel.dat jazel
if which matlab >/dev/null 2>&1 ; then
../../bin/poly2poly -ol30 trimmed_mask.pol trimmed_mask.list
../../scripts/graphmask.sh trimmed_mask.list trimmed_mask.eps
rm trimmed_mask.list*
../../bin/poly2poly -ol30 rasterized_mask.pol rasterized_mask.list
../../scripts/graphmask.sh rasterized_mask.list rasterized_mask.eps
rm rasterized_mask.list*
../../bin/poly2poly -ol30 rasterized_mask1.pol rasterized_mask1.list
../../scripts/graphmask.sh rasterized_mask1.list rasterized_mask1.eps
rm rasterized_mask1.list*
for(( i=1; i<=4; i++ ))
do
../../bin/poly2poly -ol30 2qz_north_res4s.pol.${i}s jpix.list
graphmask.sh jpix.list pixmap${i}.eps
rm jpix.list*
done
elif which sm >/dev/null 2>&1 ; then
../../bin/poly2poly -og30 trimmed_mask.pol trimmed_mask.grph
../../scripts/graphmasksm.sh trimmed_mask.grph trimmed_mask.eps
rm trimmed_mask.grph
../../bin/poly2poly -og30 rasterized_mask.pol rasterized_mask.grph
../../scripts/graphmasksm.sh rasterized_mask.grph rasterized_mask.eps
rm rasterized_mask.grph
../../bin/poly2poly -og30 rasterized_mask1.pol rasterized_mask1.grph
../../scripts/graphmasksm.sh rasterized_mask1.grph rasterized_mask1.eps
rm rasterized_mask1.grph
for(( i=1; i<=4; i++ ))
do
../../bin/poly2poly -og30 2qz_north_res4s.pol.${i}s jpix.grph
../../scripts/graphmasksm.sh jpix.grph pixmap${i}.eps
rm jpix.grph*
done
fi
cd ..
echo >&2 "mangle test suite complete! Output files are in test.tar.gz"
mv test.log test
tar cfz test.tar.gz test

1
scripts/plotmap.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/healpix/healpix_conversion_scripts/plotmap.sh

71
scripts/polyid_gals.sh Executable file
View file

@ -0,0 +1,71 @@
#!/bin/sh
# © M E C Swanson 2008
#
#This script uses polyid to find in which polygons in the input mask
#each galaxy in the list lies. The input galaxy file can have any number of columns,
#but the first 2 columns should be the RA and dec.
#output galaxy files for each resolution will attach the polygon number to the end of
#each line in the galaxy file.
#
#By default, galaxies that are not in any polygon in the mask will be cut out of
#the output file. To keep all galaxies in the output file, enter a 0 for the final
#command line argument.
#
#USAGE: polyid_gals.sh <input mask file> <input galaxy file> <output galaxy file> [<0 to turn cuts off>]
#EXAMPLES:
#polyid_gals.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat sdss_dr7safe0_polyidgals_cut.dat
#polyid_gals.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat sdss_dr7safe0_polyidgals_uncut.dat 0
if [ "$MANGLEBINDIR" = "" ] ; then
MANGLEBINDIR="../../bin"
fi
if [ "$MANGLESCRIPTSDIR" = "" ] ; then
MANGLESCRIPTSDIR="../../scripts"
fi
if [ "$MANGLEDATADIR" = "" ] ; then
MANGLEDATADIR="../../masks"
fi
mask=$1
gals=$2
outgals=$3
cut=$4
#check command line arguments
if [ "$mask" = "" ] || [ "$gals" = "" ] || [ "$outgals" = "" ]; then
echo >&2 "ERROR: enter the input polygon file and input and output galaxy files as command line arguments."
echo >&2 ""
echo >&2 "USAGE: polyid_gals.sh <input mask file> <input galaxy file> <output galaxy file> [<0 to turn cuts off>]"
echo >&2 "EXAMPLES:"
echo >&2 "polyid_gals.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat sdss_dr7safe0_polyidgals_cut.dat"
echo >&2 "polyid_gals.sh sdss_dr7safe0_res6d.pol sdss_dr7safe0_galdetails1.dat sdss_dr7safe0_polyidgals_uncut.dat 0"
exit 1
fi
if [ "$cut" = "" ] ; then
cut=1
fi
#count number of columns in input galaxy file
head -n 1 $gals > jgals
numfields=`awk '{print NF}' jgals`
rm jgals
#run polyid on galaxy file and assemble output galaxy files with polygon numbers
echo "Running polyid to find galaxies from $gals in $mask ... "
$MANGLEBINDIR/polyid $mask $gals j1 || exit
tail +2 j1 > j2
awk '{print $3}' j2 > j3
paste $gals j3 > j4
if [ $cut -ne 0 ] ; then
awk "NF == ($numfields+1) {print \$0}" j4 > $outgals
else
cp j4 $outgals
fi
rm j1 j2 j3 j4
count=`wc -l < $outgals`
echo ""
echo "wrote $count galaxies to $outgals."

View file

@ -0,0 +1,6 @@
#USAGE: source run_mangle_testsuite > test.log
echo "Setting mangle environment variables"
cd ..
source setup_mangle_environment $PWD/
cd scripts
./mangle_testsuite.sh

1
scripts/sdss_quickstart.sh Symbolic link
View file

@ -0,0 +1 @@
../masks/sdss/sdss_quickstart.sh

140
scripts/trim_mask.sh Executable file
View file

@ -0,0 +1,140 @@
#! /bin/sh
# © M E C Swanson 2008
#script to trim a mask so that it only includes polygons in a specified region
#USAGE: trim_mask.sh <mask> <trimmer> <outfile> [<pixelization arguments>]
#EXAMPLE:trim_mask.sh mask.pol trimmer.pol trimmed_mask.pol
# You can also optionally provide arguments to the pixelize function
# in the 4th argument:
#EXAMPLE: trim_mask.sh mask.pol trimmer.pol trimmed_mask.pol -Ps0,6
if [ "$MANGLEBINDIR" = "" ] ; then
MANGLEBINDIR="../../bin"
fi
if [ "$MANGLESCRIPTSDIR" = "" ] ; then
MANGLESCRIPTSDIR="../../scripts"
fi
if [ "$MANGLEDATADIR" = "" ] ; then
MANGLEDATADIR="../../masks"
fi
mask=$1
trimmer=$2
outfile=$3
pixargs=$4
#check command line arguments:
if [ "$mask" = "" ] || [ "$trimmer" = "" ] || [ "$outfile" = "" ] ; then
echo >&2 "ERROR: enter the input polygon file, a polygon defining the region you"
echo >&2 "want to trim to, and the output polygon file as command line arguments."
echo >&2 ""
echo >&2 "USAGE: trim_mask.sh <mask> <trimmer> <outfile> [<pixelization arguments>]"
echo >&2 "EXAMPLE: trim_mask.sh mask.pol trimmer.pol trimmed_mask.pol"
echo >&2 "EXAMPLE w/ optional argument to pixelize: trim_mask.sh mask.pol trimmer.pol trimmed_mask.pol -Ps0,6"
exit 1
fi
#if no argument for pixelize is given, pixelize to resolution 6 with the simple scheme:
if [ "$pixargs" = "" ] ; then
pixargs="-Ps0,6"
fi
head -n 100 $mask > jmaskhead
head -n 100 $trimmer > jtrimmerhead
#grab pixelization info from input files
awk '/pixelization/{print $0}' < jmaskhead > jpix
res1=`awk '{print substr($2, 1, length($2)-1)}' < jpix`
scheme1=`awk '{print substr($2, length($2))}' < jpix`
awk '/pixelization/{print $0}' < jtrimmerhead > jpix
res2=`awk '{print substr($2, 1, length($2)-1)}' < jpix`
scheme2=`awk '{print substr($2, length($2))}' < jpix`
rm jpix jmaskhead jtrimmerhead
#if input files are pixelized, make sure they are consistent:
if [ ! "$res1" = "" ] && [ ! "$res2" = "" ] ; then
if [ $res1 -eq -1 ] || [ $res2 -eq -1 ] ; then
echo >&2 "ERROR: cannot trim a mask pixelized adaptively."
echo >&2 "Pixelize both your mask and your trimmer polygon(s) using a fixed resolution,"
echo >&2 "e.g. -Ps0,8, and try again."
exit 1
fi
if [ $res1 -ne $res2 ] ; then
echo >&2 "ERROR: mask polygons and trimmer polygons must be pixelized to the same resolution."
echo >&2 "Pixelize both your mask and your trimmer polygon(s) using a fixed resolution,"
echo >&2 "e.g. -Ps0,8, and try again."
exit 1
fi
#if input files are unpixelized, pixelize them:
elif [ ! "$res1" = "" ] && [ "$res2" = "" ] ; then
if [ $res1 -eq -1 ] ; then
echo >&2 "ERROR: cannot trim a mask pixelized adaptively."
echo >&2 "Pixelize both your mask and your trimmer polygon(s) using a fixed resolution,"
echo >&2 "e.g. -Ps0,8, and try again."
exit 1
fi
echo "$MANGLEBINDIR/pixelize -P${scheme1}0,$res1 $trimmer trimmer_pix"
$MANGLEBINDIR/pixelize -P${scheme1}0,$res1 $trimmer trimmer_pix || exit
trimmer="trimmer_pix"
elif [ "$res1" = "" ] && [ ! "$res2" = "" ] ; then
if [ $res2 -eq -1 ] ; then
echo >&2 "ERROR: cannot trim a mask pixelized adaptively."
echo >&2 "Pixelize both your mask and your trimmer polygon(s) using a fixed resolution,"
echo >&2 "e.g. -Ps0,8, and try again."
exit 1
fi
echo "$MANGLEBINDIR/pixelize -P${scheme2}0,$res2 $mask mask_pix"
$MANGLEBINDIR/pixelize -P${scheme2}0,$res2 $mask mask_pix || exit
mask="mask_pix"
else
echo "$MANGLEBINDIR/pixelize $pixargs $trimmer trimmer_pix"
$MANGLEBINDIR/pixelize $pixargs $trimmer trimmer_pix || exit
echo "$MANGLEBINDIR/pixelize $pixargs $mask mask_pix"
$MANGLEBINDIR/pixelize $pixargs $mask mask_pix || exit
trimmer="trimmer_pix"
mask="mask_pix"
fi
#check if input file is snapped
snapped=`awk '/snapped/{print $1}' < $mask`
#if mask file isn't snapped, snap it
if [ ! "$snapped" = "snapped" ]; then
echo "Snapping $mask ..."
mv $mask jp
$MANGLEBINDIR/snap jp $mask || exit
rm jp
fi
#find the complement of the trimmer polygon
echo "$MANGLESCRIPTSDIR/find_complement.sh $trimmer trimmer_comp"
$MANGLESCRIPTSDIR/find_complement.sh $trimmer trimmer_comp || exit
#set the complement to have zero weight
echo 0 > jw0
echo "$MANGLEBINDIR/weight -zjw0 trimmer_comp jcomp0"
$MANGLEBINDIR/weight -zjw0 trimmer_comp jcomp0 || exit
rm jw0
#balkanize the mask with the zero-weight complement, thereby trimming off
#everything that does not lie within the trimmer polygon
echo "$MANGLEBINDIR/balkanize $mask jcomp0 jb"
$MANGLEBINDIR/balkanize $mask jcomp0 jb || exit
rm jcomp0
#unify to get rid of zero weight polygons
echo "$MANGLEBINDIR/unify jb $outfile"
$MANGLEBINDIR/unify jb $outfile || exit
rm jb
echo "Polygons of $1 trimmed by $2 written to ${outfile}."
#clean up
rm trimmer_comp
if [ -e trimmer_pix ] ; then
rm trimmer_pix
fi
if [ -e mask_pix ] ; then
rm mask_pix
fi

1
src/A.c Normal file
View file

@ -0,0 +1 @@
I foil rm *.c

1
src/A.f Normal file
View file

@ -0,0 +1 @@
I foil rm *.f

1
src/Aa.F Normal file
View file

@ -0,0 +1 @@
I foil rm *.F

284
src/Makefile.in Normal file
View file

@ -0,0 +1,284 @@
mangler:
$(MAKE) libmangle.a $(PROGS)
$(MAKE) install
install:
if [ -d "$(BIN)" ] ; then mv $(PROGS) $(BIN) ; fi
clean:
rm -f *.o core
cleaner:
rm -f *.o core libmangle.a
cleanest:
rm -f *.o core libmangle.a $(PROGS)
if [ -d "$(BIN)" ] ; then cd $(BIN) ; rm -f core $(PROGS) ; fi
static:
$(MAKE) FFLAGS="$(FFLAGS) $(STATICFLAGS)"
libmangle.a: $(COBJ) $(FOBJ) Makefile
@ if [ -r libmangle.a ] ; then echo "updating libmangle.a" ; else echo "creating libmangle.a" ; fi
ar ru libmangle.a $(COBJ) $(FOBJ)
ranlib libmangle.a
balkanize: balkanize.o libmangle.a Makefile
$(F77) $(FFLAGS) -o balkanize balkanize.o $(ILIB) $(LLIB)
ddcount: ddcount.o libmangle.a Makefile
$(F77) $(FFLAGS) -o ddcount ddcount.o $(ILIB) $(LLIB)
drangle: drangle.o libmangle.a Makefile
$(F77) $(FFLAGS) -o drangle drangle.o $(ILIB) $(LLIB)
harmonize: harmonize.o libmangle.a Makefile
$(F77) $(FFLAGS) -o harmonize harmonize.o $(ILIB) $(LLIB)
map: map.o libmangle.a Makefile
$(F77) $(FFLAGS) -o map map.o $(ILIB) $(LLIB)
pixelize: pixelize.o libmangle.a Makefile
$(F77) $(FFLAGS) -o pixelize pixelize.o $(ILIB) $(LLIB)
pixelmap: pixelmap.o libmangle.a Makefile
$(F77) $(FFLAGS) -o pixelmap pixelmap.o $(ILIB) $(LLIB)
polyid: polyid.o libmangle.a Makefile
$(F77) $(FFLAGS) -o polyid polyid.o $(ILIB) $(LLIB)
poly2poly: poly2poly.o libmangle.a Makefile
$(F77) $(FFLAGS) -o poly2poly poly2poly.o $(ILIB) $(LLIB)
ransack: ransack.o libmangle.a Makefile
$(F77) $(FFLAGS) -o ransack ransack.o $(ILIB) $(LLIB)
rasterize: rasterize.o libmangle.a Makefile
$(F77) $(FFLAGS) -o rasterize rasterize.o $(ILIB) $(LLIB)
rotate: rotate.o libmangle.a Makefile
$(F77) $(FFLAGS) -o rotate rotate.o $(ILIB) $(LLIB) $(ISLIB) $(SLIB)
rrcoeffs: rrcoeffs.o libmangle.a Makefile
$(F77) $(FFLAGS) -o rrcoeffs rrcoeffs.o $(ILIB) $(LLIB)
snap: snap.o libmangle.a Makefile
$(F77) $(FFLAGS) -o snap snap.o $(ILIB) $(LLIB)
unify: unify.o libmangle.a Makefile
$(F77) $(FFLAGS) -o unify unify.o $(ILIB) $(LLIB)
weight: weight.o libmangle.a Makefile
$(F77) $(FFLAGS) -o weight weight.o $(ILIB) $(LLIB)
weight_dumb: weight_dumb.o weight_dumb_module.o libmangle.a Makefile
$(F77) $(FFLAGS) -o weight_dumb weight_dumb.o weight_dumb_module.o $(ILIB) $(LLIB) -lstdc++
poly2hpx: poly2hpx.o chealpix.o libmangle.a Makefile
$(F77) $(FFLAGS) -o poly2hpx chealpix.o poly2hpx.o $(ILIB) $(LLIB) -lcfitsio
test: test.o libmangle.a Makefile
$(F77) $(FFLAGS) -o test test.o $(ILIB) $(LLIB)
weight_dumb_module.o: weight_dumb_module.cpp
$(CXX) $(CFLAGS) -c weight_dumb_module.cpp
chealpix.o: healpix/chealpix.c
$(CC) $(CFLAGS) -DENABLE_FITSIO -c healpix/chealpix.c
advise_fmt.o: angunit.h manglefn.h advise_fmt.c
$(CC) $(CFLAGS) -c advise_fmt.c
balkanize.o: parse_args.c defaults.h manglefn.h usage.h balkanize.c
$(CC) $(CFLAGS) -c balkanize.c
braktop_.o: manglefn.h braktop_.c
$(CC) $(CFLAGS) -c braktop_.c
cmminf.o: manglefn.h cmminf.c
$(CC) $(CFLAGS) -c cmminf.c
convert.o: manglefn.h convert.c
$(CC) $(CFLAGS) -c convert.c
copy_format.o: manglefn.h copy_format.c
$(CC) $(CFLAGS) -c copy_format.c
copy_poly.o: manglefn.h copy_poly.c
$(CC) $(CFLAGS) -c copy_poly.c
ddcount.o: parse_args.c angunit.h defaults.h inputfile.h manglefn.h usage.h ddcount.c
$(CC) $(CFLAGS) -c ddcount.c
drandom.o: drandom.c
$(CC) $(CFLAGS) -c drandom.c
drangle.o: parse_args.c angunit.h defaults.h inputfile.h manglefn.h usage.h drangle.c
$(CC) $(CFLAGS) -c drangle.c
drangle_polys.o: manglefn.h pi.h drangle_polys.c
$(CC) $(CFLAGS) -c drangle_polys.c
dranglepolys_.o: manglefn.h dranglepolys_.c
$(CC) $(CFLAGS) -c dranglepolys_.c
dump_poly.o: manglefn.h dump_poly.c
$(CC) $(CFLAGS) -c dump_poly.c
findtop_.o: manglefn.h findtop_.c
$(CC) $(CFLAGS) -c findtop_.c
get_pixel.o: manglefn.h get_pixel.c
$(CC) $(CFLAGS) -c get_pixel.c
garea.o: logical.h manglefn.h garea.c
$(CC) $(CFLAGS) -c garea.c
gcmlim.o: manglefn.h gcmlim.c
$(CC) $(CFLAGS) -c gcmlim.c
gphbv.o: manglefn.h gphbv.c
$(CC) $(CFLAGS) -c gphbv.c
gphi.o: manglefn.h gphi.c
$(CC) $(CFLAGS) -c gphi.c
gptin.o: manglefn.h gptin.c
$(CC) $(CFLAGS) -c gptin.c
gspher.o: manglefn.h pi.h gspher.c
$(CC) $(CFLAGS) -c gspher.c
gsphr.o: manglefn.h pi.h gsphr.c
$(CC) $(CFLAGS) -c gsphr.c
gvert.o: manglefn.h gvert.c
$(CC) $(CFLAGS) -c gvert.c
gvlim.o: manglefn.h gvlim.c
$(CC) $(CFLAGS) -c gvlim.c
gvphi.o: manglefn.h gvphi.c
$(CC) $(CFLAGS) -c gvphi.c
harmonize.o: parse_args.c defaults.h manglefn.h usage.h harmonize.c
$(CC) $(CFLAGS) -c harmonize.c
harmonize_polys.o: manglefn.h pi.h harmonize_polys.c
$(CC) $(CFLAGS) -c harmonize_polys.c
harmonizepolys_.o: manglefn.h harmonizepolys_.c
$(CC) $(CFLAGS) -c harmonizepolys_.c
healpix_ang2pix_nest.o: manglefn.h pi.h healpix_ang2pix_nest.c
$(CC) $(CFLAGS) -c healpix_ang2pix_nest.c
healpixpolys.o: manglefn.h pi.h healpixpolys.c
$(CC) $(CFLAGS) -c healpixpolys.c
ikrand.o: manglefn.h ikrand.c
$(CC) $(CFLAGS) -c ikrand.c
map.o: parse_args.c angunit.h defaults.h inputfile.h manglefn.h usage.h map.c
$(CC) $(CFLAGS) -c map.c
msg.o: manglefn.h msg.c
$(CC) $(CFLAGS) -c msg.c
new_poly.o: manglefn.h new_poly.c
$(CC) $(CFLAGS) -c new_poly.c
new_vert.o: manglefn.h new_vert.c
$(CC) $(CFLAGS) -c new_vert.c
partition_poly.o: manglefn.h partition_poly.c
$(CC) $(CFLAGS) -c partition_poly.c
pixelize.o: parse_args.c defaults.h manglefn.h usage.h pixelize.c
$(CC) $(CFLAGS) -c pixelize.c
pixelmap.o: parse_args.c defaults.h manglefn.h usage.h pixelmap.c
$(CC) $(CFLAGS) -c pixelmap.c
places.o: manglefn.h places.c
$(CC) $(CFLAGS) -c places.c
poly2poly.o: parse_args.c defaults.h manglefn.h usage.h poly2poly.c
$(CC) $(CFLAGS) -c poly2poly.c
poly_id.o: manglefn.h poly_id.c
$(CC) $(CFLAGS) -c poly_id.c
polyid.o: parse_args.c angunit.h defaults.h inputfile.h manglefn.h usage.h polyid.c
$(CC) $(CFLAGS) -c polyid.c
poly_sort.o: manglefn.h poly_sort.c
$(CC) $(CFLAGS) -c poly_sort.c
prune_poly.o: manglefn.h prune_poly.c
$(CC) $(CFLAGS) -c prune_poly.c
ransack.o: parse_args.c angunit.h defaults.h manglefn.h usage.h ransack.c
$(CC) $(CFLAGS) -c ransack.c
rasterize.o: parse_args.c pi.h defaults.h manglefn.h usage.h rasterize.c
$(CC) $(CFLAGS) -c rasterize.c
rdangle.o: manglefn.h rdangle.c
$(CC) $(CFLAGS) -c rdangle.c
rdline.o: inputfile.h rdline.c
$(CC) $(CFLAGS) -c rdline.c
rdmask_.o: defaults.h manglefn.h rdmask_.c
$(CC) $(CFLAGS) -c rdmask_.c
rdmask.o: inputfile.h manglefn.h rdmask.c
$(CC) $(CFLAGS) -c rdmask.c
rdspher.o: manglefn.h rdspher.c
$(CC) $(CFLAGS) -c rdspher.c
rotate.o: parse_args.c parse_fopt.c angunit.h defaults.h inputfile.h manglefn.h usage.h rotate.c
$(CC) $(CFLAGS) -c rotate.c
rrcoeffs.o: parse_args.c defaults.h manglefn.h usage.h rrcoeffs.c
$(CC) $(CFLAGS) -c rrcoeffs.c
scale.o: manglefn.h scale.c
$(CC) $(CFLAGS) -c scale.c
sdsspix.o: manglefn.h sdsspix.c
$(CC) $(CFLAGS) -c sdsspix.c
search.o: manglefn.h search.c
$(CC) $(CFLAGS) -c search.c
snap.o: parse_args.c defaults.h manglefn.h usage.h snap.c
$(CC) $(CFLAGS) -c snap.c
snap_poly.o: manglefn.h snap_poly.c
$(CC) $(CFLAGS) -c snap_poly.c
split_poly.o: manglefn.h split_poly.c
$(CC) $(CFLAGS) -c split_poly.c
strcmpl.o: manglefn.h strcmpl.c
$(CC) $(CFLAGS) -c strcmpl.c
strdict.o: manglefn.h strdict.c
$(CC) $(CFLAGS) -c strdict.c
test.o: manglefn.h test.c
$(CC) $(CFLAGS) -c test.c
unify.o: parse_args.c defaults.h manglefn.h usage.h unify.c
$(CC) $(CFLAGS) -c unify.c
vmid.o: manglefn.h vmid.c
$(CC) $(CFLAGS) -c vmid.c
which_pixel.o: manglefn.h which_pixel.c
$(CC) $(CFLAGS) -c which_pixel.c
weight.o: parse_args.c defaults.h manglefn.h usage.h weight.c
$(CC) $(CFLAGS) -c weight.c
weight_fn.o: inputfile.h manglefn.h weight_fn.c
$(CC) $(CFLAGS) -c weight_fn.c
wrangle.o: manglefn.h wrangle.c
$(CC) $(CFLAGS) -c wrangle.c
wrho.o: manglefn.h wrho.c
$(CC) $(CFLAGS) -c wrho.c
wrmask.o: manglefn.h wrmask.c
$(CC) $(CFLAGS) -c wrmask.c
wrrrcoeffs.o: manglefn.h wrrrcoeffs.c
$(CC) $(CFLAGS) -c wrrrcoeffs.c
wrspher.o: manglefn.h wrspher.c
$(CC) $(CFLAGS) -c wrspher.c
azell.s.o: azell.s.f
$(F77) $(FFLAGS) -c azell.s.f
azel.s.o: azel.s.f
$(F77) $(FFLAGS) -c azel.s.f
braktop.s.o: braktop.s.f
$(F77) $(FFLAGS) -c braktop.s.f
felp.s.o: frames.par felp.s.f
$(F77) $(FFLAGS) -c felp.s.f
fframe.s.o: frames.par radian.par fframe.s.f
$(F77) $(FFLAGS) -c fframe.s.f
findtop.s.o: heapsort.inc findtop.s.f
$(F77) $(FFLAGS) -c findtop.s.f
gaream.s.o: pi.par gaream.s.f
$(F77) $(FFLAGS) -c gaream.s.f
garea.s.o: pi.par garea.s.f
$(F77) $(FFLAGS) -c garea.s.f
gcmlim.s.o: pi.par gcmlim.s.f
$(F77) $(FFLAGS) -c gcmlim.s.f
gphbv.s.o: pi.par gphbv.s.f
$(F77) $(FFLAGS) -c gphbv.s.f
gphim.s.o: pi.par gphim.s.f
$(F77) $(FFLAGS) -c gphim.s.f
gphi.s.o: pi.par gphi.s.f
$(F77) $(FFLAGS) -c gphi.s.f
gptin.s.o: gptin.s.f
$(F77) $(FFLAGS) -c gptin.s.f
gsphera.s.o: pi.par gsphera.s.f
$(F77) $(FFLAGS) -c gsphera.s.f
gspher.s.o: pi.par gspher.s.f
$(F77) $(FFLAGS) -c gspher.s.f
gsubs.s.o: pi.par gsubs.s.f
$(F77) $(FFLAGS) -c gsubs.s.f
gvert.s.o: pi.par gvert.s.f
$(F77) $(FFLAGS) -c gvert.s.f
gvlim.s.o: pi.par gvlim.s.f
$(F77) $(FFLAGS) -c gvlim.s.f
gvphi.s.o: pi.par gvphi.s.f
$(F77) $(FFLAGS) -c gvphi.s.f
iylm.s.o: pi.par iylm.s.f
$(F77) $(FFLAGS) -c iylm.s.f
pix2vec_nest.s.o: pix2vec_nest.s.f
$(F77) $(FFLAGS) -c pix2vec_nest.s.f
twodf100k.o: pi.par twodf100k.f
$(F77) $(FFLAGS) -c twodf100k.f
twodf230k.o: pi.par twodf230k.f
$(F77) $(FFLAGS) -c twodf230k.f
twoqz.o: mangdir.data mangdir.inc twoqz.f
$(F77) $(FFLAGS) -c twoqz.f
wlm.s.o: pi.par wlm.s.f
$(F77) $(FFLAGS) -c wlm.s.f
wrho.s.o: pi.par wrho.s.f
$(F77) $(FFLAGS) -c wrho.s.f

71
src/advise_fmt.c Normal file
View file

@ -0,0 +1,71 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <string.h>
#include "manglefn.h"
/*------------------------------------------------------------------------------
Advise data format.
Input: fmt = pointer to format structure.
*/
void advise_fmt(format *fmt)
{
int n;
char plural[] = "s";
/* format of input data */
if (fmt->in) {
if (fmt->in[strlen(fmt->in) - 1] == 's') {
strcpy(plural, "");
} else {
strcpy(plural, "s");
}
if (fmt->single == 1) {
msg("input data format will be defined by keywords in infiles\n");
} else { /* fmt->single == 0 */
msg("(initial) input data format is %s with", fmt->in);
if (strcmp(fmt->in, "edges") == 0) {
msg(" %d points/edge and", fmt->innve);
n = fmt->nn * fmt->innve * fmt->n;
} else {
n = fmt->nn * fmt->n;
}
if (fmt->n == 0) {
msg(" variable no. of %s%s per line\n", fmt->in, plural);
} else {
msg(" %d %s%s (%d numbers) per line\n", fmt->n, fmt->in, plural, n);
}
}
/* angular unit of input data */
if (fmt->inunitp && !(strcmp(fmt->in, "polygon") == 0 || strcmp(fmt->in, "Region") == 0)) {
msg("will take units of any angles in input polygon files to be %c (", fmt->inunitp);
switch (fmt->inunitp) {
#include "angunit.h"
}
msg(")\n");
}
}
/* format of output data */
if (fmt->out) {
msg("output data format will be %s", fmt->out);
if (strcmp(fmt->out, "edges") == 0) msg(" with %d points/edge", fmt->outnve);
msg("\n");
if (strcmp(fmt->out, "vertices") == 0 || strcmp(fmt->out, "edges") == 0)
msg("WARNING: %s output format loses information\n", fmt->out);
/* angular unit of output data */
if (fmt->outunitp && !(strcmp(fmt->out, "polygon") == 0 || strcmp(fmt->out, "Region") == 0)) {
msg("units of angles in output polygon files will be %c (", fmt->outunitp);
switch (fmt->outunitp) {
#include "angunit.h"
}
msg(")\n");
}
}
}

20
src/angunit.h Normal file
View file

@ -0,0 +1,20 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
/* angular unit corresponding to character */
case 'h':
msg("RA in hms, Dec in dms"); break;
case 'd':
case '°':
msg("degrees"); break;
case 'm':
case '\'':
case '´':
msg("arcminutes"); break;
case 's':
case '"':
case '¨':
msg("arcseconds"); break;
case 'r':
default:
msg("radians"); break;

63
src/azel.s.f Normal file
View file

@ -0,0 +1,63 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine azel(ra,dec,raz,elp,azp,az,el)
real*10 ra,dec,raz,elp,azp,az,el
c
c parameters
real*10 CIRCLE,PI,RADIAN
parameter (CIRCLE = 360._10,
* PI = 3.1415926535897932384626_10,
* RADIAN = 180._10/PI)
c local (automatic) variables
integer iz
real*10 cazm,cdec,cel,celp,cra,sazm,sdec,sel,selp,sra
c *
c * Convert RA & Dec ra, dec -> azimuth & elevation.
c * To accomplish the inverse operation, az, el -> ra, dec,
c * call azel(az, el, azp, elp, raz, ra, dec);
c * To convert RA & Dec to Galactic Longitude and Latitude, use
c * raz = 192.25, elp = 27.4, azp = 123.
c *
c Input: ra = RA in degrees.
c dec = Dec in degrees.
c raz = RA of zenith in degrees.
c elp = elevation of NCP in degrees = Dec of zenith.
c azp = azimuth of NCP in degrees.
c Output: az = azimuth in degrees (0.le.az.lt.360).
c el = elevation in degrees (-90.le.el.le.90).
c
c sines and cosines of input angles
sdec=sin(dec/RADIAN)
cdec=cos(dec/RADIAN)
selp=sin(elp/RADIAN)
celp=cos(elp/RADIAN)
sra=sin((ra-raz)/RADIAN)
cra=cos((ra-raz)/RADIAN)
c sine and cosine of elevation
sel=cdec*celp*cra+sdec*selp
if (sel.gt.1._10) then
sel=1._10
elseif (sel.lt.-1._10) then
sel=-1._10
endif
cel=sqrt(1._10-sel**2)
c elevation in degrees
el=asin(sel)*RADIAN
c if elevation is +90 or -90 degrees, set azimuth to that of NCP
if (cel.eq.0._10) then
az=azp
elseif (cel.ne.0._10) then
c sine and cosine of azimuth relative to NCP azimuth
sazm=-cdec*sra/cel
cazm=(sdec*celp-cdec*selp*cra)/cel
c azimuth in degrees
az=atan2(sazm,cazm)*RADIAN+azp
c ensure azimuth is in interval [0,360)
iz=az/CIRCLE
if (az.lt.0._10) iz=iz-1
az=az-iz*CIRCLE
endif
return
end
c

75
src/azell.s.f Normal file
View file

@ -0,0 +1,75 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine azell(rag,decg,l2p,raz,elp,azp,azg,elg,l2z)
real*10 rag,decg,l2p,raz,elp,azp,azg,elg,l2z
c
c parameters
real*10 CIRCLE,PI,RADIAN
parameter (CIRCLE = 360._10,
* PI = 3.1415926535897932384626_10,
* RADIAN = 180._10/PI)
c local (automatic) variables
integer iz
real*10 cazm,cdecg,celg,celp,cl2m,cra
real*10 sazm,sdecg,selg,selp,sl2m,sra
c *
c * Given transformations g <-> p between and z <-> p between spherical
c * frames, determine transformation g <-> z
c * (I've imagined g = galactic coordinates, p = celestial coordinates,
c * z = dome coordinates, but of course the transformation is quite
c * general).
c *
c Input: rag = RA of NGP in deg [192.25]
c decg = Dec of NGP in deg = latitude of NCP [27.4]
c l2p = longitude of NCP in deg [123]
c raz = RA of zenith in deg
c elp = elevation of NCP in deg = Dec of zenith
c azp = azimuth of NCP in deg
c Output: azg = azimuth of NGP in deg (0.le.az.lt.360)
c elg = elevation NGP in deg (-90.le.el.le.90)
c l2z = longitude of zenith in deg
c
c sines and cosines of input angles
sdecg=sin(decg/RADIAN)
cdecg=cos(decg/RADIAN)
selp=sin(elp/RADIAN)
celp=cos(elp/RADIAN)
sra=sin((rag-raz)/RADIAN)
cra=cos((rag-raz)/RADIAN)
c sine and cosine of elevation of NGP
selg=cdecg*celp*cra+sdecg*selp
if (selg.gt.1._10) then
selg=1._10
elseif (selg.lt.-1._10) then
selg=-1._10
endif
celg=sqrt(1._10-selg*selg)
c elevation of NGP in deg
elg=asin(selg)*RADIAN
c at NGP el +- 90 deg, set NGP az & zenith long consistently
if (celg.eq.0._10) then
azg=azp
l2z=l2p+CIRCLE/2._10
elseif (celg.ne.0._10) then
c sine and cosine of azimuth of NGP relative to NCP azimuth
sazm=-cdecg*sra/celg
cazm=(sdecg*celp-cdecg*selp*cra)/celg
c azimuth in deg
azg=atan2(sazm,cazm)*RADIAN+azp
c sine and cosine of longitude of zenith relative to NCP longitude
sl2m=celp*sra/celg
cl2m=(selp*cdecg-celp*sdecg*cra)/celg
c longitude of zenith in deg
l2z=atan2(sl2m,cl2m)*RADIAN+l2p
endif
c ensure azimuthal angles are in interval [0,360)
iz=azg/CIRCLE
if (azg.lt.0._10) iz=iz-1
azg=azg-iz*CIRCLE
iz=l2z/CIRCLE
if (l2z.lt.0._10) iz=iz-1
l2z=l2z-iz*CIRCLE
return
end
c

525
src/balkanize.c Normal file
View file

@ -0,0 +1,525 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include "manglefn.h"
#include "defaults.h"
/* define CARRY_ON_REGARDLESS if you want balkanize() to continue even when the number of polygons hits NPOLYSMAX;
if CARRY_ON_REGARDLESS is defined, then balkanize() will create a possibly incomplete polygon file of polygons */
#undef CARRY_ON_REGARDLESS
//#define CARRY_ON_REGARDLESS
/* getopt options */
//const char *optstr = "B:dqa:b:t:y:m:s:e:v:p:i:o:";
const char *optstr = "B:dqm:s:e:v:p:i:o:";
/* allocate polygons as a global array */
polygon *polys_global[NPOLYSMAX];
/* local functions */
void usage(void);
#ifdef GCC
int balkanize(int npoly, polygon *[npoly], int npolys, polygon *[npolys]);
#else
int balkanize(int npoly, polygon *[/*npoly*/], int npolys, polygon *[/*npolys*/]);
#endif
/*------------------------------------------------------------------------------
Main program.
*/
int main(int argc, char *argv[])
{
int ifile, nfiles, npoly, npolys,i;
char key;
polygon **polys;
polys=polys_global;
/* default output format */
fmt.out = keywords[POLYGON];
/* default is to renumber output polygons with new id numbers */
fmt.newid = 'n';
/* parse arguments */
parse_args(argc, argv);
/* at least one input and output filename required as arguments */
if (argc - optind < 2) {
if (optind > 1 || argc - optind == 1) {
fprintf(stderr, "%s requires at least 2 arguments: polygon_infile and polygon_outfile\n", argv[0]);
usage();
exit(1);
} else {
usage();
exit(0);
}
}
msg("---------------- balkanize ----------------\n");
// snap angles
scale(&axtol, axunit, 's');
scale(&btol, bunit, 's');
scale(&thtol, thunit, 's');
axunit = 's';
bunit = 's';
thunit = 's';
// msg("snap angles: axis %Lg%c latitude %Lg%c edge %Lg%c\n", axtol, axunit, btol, bunit, thtol, thunit);
scale(&axtol, axunit, 'r');
scale(&btol, bunit, 'r');
scale(&thtol, thunit, 'r');
axunit = 'r';
bunit = 'r';
thunit = 'r';
/* tolerance angle for multiple intersections */
if (mtol != 0.) {
scale(&mtol, munit, 's');
munit = 's';
msg("multiple intersections closer than %Lg%c will be treated as coincident\n", mtol, munit);
scale(&mtol, munit, 'r');
munit = 'r';
}
/* advise data format */
advise_fmt(&fmt);
/* read polygons */
npoly = 0;
nfiles = argc - 1 - optind;
for (ifile = optind; ifile < optind + nfiles; ifile++) {
npolys = rdmask(argv[ifile], &fmt, NPOLYSMAX - npoly, &polys[npoly]);
if (npolys == -1) exit(1);
npoly += npolys;
}
if (nfiles >= 2) {
msg("total of %d polygons read\n", npoly);
}
if (npoly == 0) {
msg("STOP\n");
exit(0);
}
if (snapped==0) {
fprintf(stderr, "Error: input polygons must be snapped before balkanization.\n");
fprintf(stderr, "If your polygons are already snapped, add the 'snapped' keyword\nat the beginning of each of your input polygon files.\n");
exit(1);
}
/* balkanize polygons */
npolys = balkanize(npoly, polys, NPOLYSMAX - npoly, &polys[npoly]);
if (npolys == -1) exit(1);
balkanized=1;
/* write polygons */
ifile = argc - 1;
npolys = wrmask(argv[ifile], &fmt, npolys, &polys[npoly]);
if (npolys == -1) exit(1);
/* memmsg(); */
for(i=0;i<npoly+npolys;i++){
free_poly(polys[i]);
}
return(0);
}
/*------------------------------------------------------------------------------
*/
void usage(void)
{
printf("usage:\n");
printf("balkanize [-d] [-q] [-a<a>[u]] [-b<a>[u]] [-t<a>[u]] [-y<r>] [-m<a>[u]] [-s<n>] [-e<n>] [-vo|-vn|-vp] [-p[+|-][<n>]] [-Bl|-Ba|-Bn|-Bx] [-i<f>[<n>][u]] [-o<f>[u]] polygon_infile1 [polygon_infile2 ...] polygon_outfile\n");
#include "usage.h"
}
/*------------------------------------------------------------------------------
*/
#include "parse_args.c"
/*------------------------------------------------------------------------------
Balkanize overlapping polygons into many disjoint connected polygons.
Input: npoly = number of polygons.
poly = array of pointers to polygons.
npolys = maximum number of output polygons.
Output: polys = array of pointers to polygons.
Return value: number of disjoint connected polygons,
or -1 if error occurred.
*/
int balkanize(int npoly, polygon *poly[/*npoly*/], int npolys, polygon *polys[/*npolys*/])
{
/* part_poly should lasso one-boundary polygons only if they have too many caps */
#define ALL_ONEBOUNDARY 1
/* how part_poly should tighten lasso */
#define ADJUST_LASSO 1
/* part_poly should force polygon to be split even if no part can be lassoed */
#define FORCE_SPLIT 1
/* partition_poly should overwrite all original polygons */
#define OVERWRITE_ORIGINAL 2
#define WARNMAX 8
char *snapped_polys = 0x0;
int discard, dm, dn, dnp, failed, i, ier, inull, isnap, ip, iprune, j, k, m, n, nadj, np, selfsnap;
int *start;
int *total;
int begin, end, p, max_pixel;
long double tol;
poly_sort(npoly, poly, 'p');
/* allocate memory for pixel info arrays start and total */
max_pixel=poly[npoly-1]->pixel+1;
start = (int *) malloc(sizeof(int) * max_pixel);
if (!start) {
fprintf(stderr, "balkanize: failed to allocate memory for %d integers\n", max_pixel);
return(-1);
}
total = (int *) malloc(sizeof(int) * max_pixel);
if (!total) {
fprintf(stderr, "balkanize: failed to allocate memory for %d integers\n", max_pixel);
return(-1);
}
/* build lists of starting indices of each pixel and total number of polygons in each pixel*/
ier=pixel_list(npoly, poly, max_pixel, start, total);
if (ier == -1) {
fprintf(stderr, "balkanize: error building pixel index lists\n");
return(-1);
}
/* start by pruning all input polygons */
np = 0;
inull = 0;
printf("BALKAN: Pruning...\n");
for (i = 0; i < npoly; i++) {
if ((i%100)==0) {
printf(" %d / %d \r", i, npoly);
fflush(stdout);
}
tol = mtol;
iprune = prune_poly(poly[i], tol);
/* error */
if (iprune == -1) {
fprintf(stderr, "balkanize: initial prune failed at polygon %d\n", poly[i]->id);
return(-1);
}
/* zero area polygon */
if (iprune >= 2) {
if (WARNMAX > 0 && inull == 0) msg("warning from balkanize: following polygons have zero area & are being discarded:\n");
if (inull < WARNMAX) {
msg(" %d", (fmt.newid == 'o')? poly[i]->id : i);
} else if (inull == WARNMAX) {
msg(" ... more\n");
}
inull++;
} else {
np++;
}
}
if (WARNMAX > 0 && inull > 0 && inull <= WARNMAX) msg("\n");
if (inull > 0) {
msg("balkanize: %d polygons with zero area are being discarded;\n", inull);
}
/* number of polygons */
msg("balkanizing %d polygons ...\n", np);
/* nullify all output polygons */
for (i = 0; i < npolys; i++) {
polys[i] = 0x0;
}
/*
m = starting index of current set of fragments of i'th polygon
dm = number of current set of fragments of i'th polygon
n = starting index of new subset of fragments of i'th polygon
dn = number of new subset of fragments of i'th polygon
*/
msg("balkanize stage 1 (fragment into non-overlapping polygons):\n");
n = 0;
dnp = 0;
ip = 0;
/* go through each pixel and fragment each polygon against the other polygons in its pixel */
for(p=0;p<max_pixel;p++){
if ((p % 100) == 0) {
printf(" %d / %d \r", p, max_pixel);
fflush(stdout);
}
begin=start[p];
end=start[p]+total[p];
/* too many polygons */
if (n >= npolys) break;
/* fragment each polygon in turn */
for (i = begin; i < end; i++) {
/* skip null polygons */
if (poly[i]->np > 0 && poly[i]->cm[0] == 0.) continue;
/* update indices */
m = n;
dm = 1;
n = m + dm;
/* make sure output polygon has enough room */
ier = room_poly(&polys[m], poly[i]->np, DNP, 0);
if (ier == -1) {
fprintf(stderr, "balkanize: failed to allocate memory for polygon of %d caps\n", poly[i]->np + DNP);
return(-1);
}
/* copy polygon i into output polygon */
copy_poly(poly[i], polys[m]);
/* fragment successively against other polygons */
for (j = begin; j < end; j++) {
/* skip self, or null polygons */
if (j == i || (poly[j]->np > 0 && poly[j]->cm[0] == 0.)) continue;
/* keep only one copy of the intersection of i & j */
/* intersection inherits weight of polygon being fragmented,
so keeping later polygon ensures intersection inherits
weight of later polygon */
if (i < j) {
discard = 1;
} else {
discard = 0;
}
/* fragment each part of i'th polygon */
for (k = m; k < m + dm; k++) {
/* skip null polygons */
if (!polys[k] || (polys[k]->np > 0 && polys[k]->cm[0] == 0.)) continue;
/* fragment */
tol = mtol;
dn = fragment_poly(&polys[k], poly[j], discard, npolys - n, &polys[n], tol, bmethod);
/* error */
if (dn == -1) {
fprintf(stderr, "balkanize: UHOH at polygon %d; continuing ...\n", (fmt.newid == 'o')? polys[i]->id : ip);
continue;
/* return(-1); */
}
/* increment index of next subset of fragments */
n += dn;
/* increment polygon count */
np += dn;
dnp += dn;
if (!polys[k]) {
np--;
dnp--;
}
/* check whether exceeded maximum number of polygons */
//printf("(1) n = %d\n", n);
if (n > npolys) {
fprintf(stderr, "(1) balkanize: total number of polygons (= %d) exceeded maximum %d\n", npoly + n, npoly + npolys);
fprintf(stderr, "if you need more space, enlarge NPOLYSMAX in defines.h, and recompile\n");
fprintf(stderr, "currently, dn = %d, np = %d, dnp = %d, poly[%d]->id = %d, poly[%d]->pixel = %d\n", dn, np, dnp, i, poly[i]->id, i, poly[i]->pixel);
n = npolys;
#ifdef CARRY_ON_REGARDLESS
break;
#else
return(-1);
#endif
}
}
/* copy down non-null polygons */
dm = 0;
for (k = m; k < n; k++) {
if (polys[k]) {
polys[m + dm] = polys[k];
dm++;
}
}
/* nullify but don't free, because freeing polys[k] will free polys[m + dm] */
for (k = m + dm; k < n; k++) {
polys[k] = 0x0;
}
n = m + dm;
if (dm == 0) break;
}
/* too many polygons */
if (n >= npolys) break;
ip++;
}
}
free(start);
free(total);
msg("added %d polygons to make %d\n", dnp, np);
// partition disconnected polygons into connected parts
msg("balkanize stage 2 (partition disconnected polygons into connected parts):\n");
m = n;
dnp = 0;
ip = 0;
failed = 0;
for (i = 0; i < m; i++) {
if ((i%100) == 0) {
printf(" %d / %d \r", i, m);
fflush(stdout);
}
// skip null polygons
if (!polys[i] || (polys[i]->np > 0 && polys[i]->cm[0] == 0.)) continue;
// partition disconnected polygons
tol = mtol;
ier = partition_poly(&polys[i], npolys - n, &polys[n], tol, ALL_ONEBOUNDARY, ADJUST_LASSO, FORCE_SPLIT, OVERWRITE_ORIGINAL, &dn);
// error
if (ier == -1) {
fprintf(stderr, "balkanize: UHOH at polygon %d; continuing ...\n", (fmt.newid == 'o')? polys[i]->id : ip);
continue;
// return(-1);
// failed to partition polygon into desired number of parts
} else if (ier == 1) {
fprintf(stderr, "balkanize: failed to partition polygon %d fully; partitioned it into %d parts\n", (fmt.newid == 'o')? polys[i]->id : ip, dn + 1);
failed++;
}
// increment index of next subset of fragments
n += dn;
// increment polygon count
np += dn;
dnp += dn;
// check whether exceeded maximum number of polygons
//printf("(2) n = %d\n", n);
if (n > npolys) {
fprintf(stderr, "(2) balkanize: total number of polygons (= %d) exceeded maximum %d\n", n + npoly, npoly + npolys);
fprintf(stderr, "if you need more space, enlarge NPOLYSMAX in defines.h, and recompile\n");
n = npolys;
#ifdef CARRY_ON_REGARDLESS
break;
#else
return(-1);
#endif
}
ip++;
}
msg("added %d polygons to make %d\n", dnp, np);
if (failed > 0) {
msg("balkanize: failed to split %d polygons into desired number of connected parts\n", failed);
msg(".............................................................................\n");
msg("Failure to split polygon probably means:\n");
msg("either (1) you forgot to run snap on all your input polygon files;\n");
msg(" or (2) the polygon is too small for the numerics to cope with;\n");
msg(" or (3) you have a weird-shaped polygon.\n");
msg("You may ignore this warning message if the weights of polygons in the input\n");
msg("polygon file(s) are already correct, and you do not want to reweight them.\n");
msg("Similarly, you may ignore this warning message if you do want to reweight the\n");
msg("polygons, but the weights of the different parts of each unsplit polygon are\n");
msg("the same. If you want to reweight the different parts of an unsplit polygon\n");
msg("with different weights, then you will need to split that polygon by hand.\n");
msg("Whatever the case, the output file of balkanized polygons constitutes\n");
msg("a valid mask of non-overlapping polygons, which is safe to use.\n");
msg(".............................................................................\n");
}
/* prune */
j = 0;
inull = 0;
for (i = 0; i < n; i++) {
tol = mtol;
iprune = prune_poly(polys[i], tol);
if (iprune == -1) {
fprintf(stderr, "balkanize: failed to prune polygon %d; continuing ...\n", (fmt.newid == 'o')? polys[i]->id : j);
/* return(-1); */
}
if (iprune >= 2) {
free_poly(polys[i]);
polys[i] = 0x0;
inull++;
} else {
polys[j] = polys[i];
j++;
}
}
if (inull > 0) msg("balkanize: %d balkanized polygons have zero area, and are being discarded\n", inull);
n = j;
/*
// allocate snapped_polys array
snapped_polys = (char *) malloc(sizeof(char) * n);
if (!snapped_polys) {
fprintf(stderr, "balkanize: failed to allocate memory for %d characters\n", n);
return(-1);
}
//snap edges of each polygon
selfsnap = 1;
nadj = snap_polys(fmt, n, polys, selfsnap, axtol, btol, thtol, ytol, mtol, WARNMAX, snapped_polys);
if(nadj==-1){
msg("balkanize: error snapping balkanized polygons\n");
return(-1);
}
// number of polygons whose edges were snapped
isnap = 0;
for (i = 0; i < n; i++) if (snapped_polys[i]) isnap++;
if (isnap > 0) msg("balkanize: edges of %d balkanized polygons were snapped\n", isnap);
// prune snapped polygons
j = 0;
inull = 0;
for (i = 0; i < n; i++) {
if (snapped_polys[i]) {
iprune = prune_poly(polys[i], mtol);
if (iprune == -1) {
fprintf(stderr, "balkanize: failed to prune polygon %d; continuing ...\n", (fmt.newid == 'o')? polys[i]->id : j);
// return(-1);
}
if (iprune >= 2) {
free_poly(polys[i]);
polys[i] = 0x0;
inull++;
} else {
polys[j] = polys[i];
j++;
}
} else {
polys[j] = polys[i];
j++;
}
}
if (inull > 0) msg("balkanize: %d snapped polygons have zero area, and are being discarded\n", inull);
n = j;
// free snapped_polys array
free(snapped_polys);
*/
if(n!=-1){
/* sort polygons by pixel number */
poly_sort(n, polys,'p');
msg("balkanize: balkans contain %d polygons\n", n);
}
/* assign new polygon id numbers in place of inherited ids */
if (fmt.newid == 'n') {
for (i = 0; i < n; i++) {
polys[i]->id = i;
}
}
if (fmt.newid == 'p') {
for (i = 0; i < n; i++) {
polys[i]->id = polys[i]->pixel;
}
}
return(n);
}

381
src/balkanizepolys.c Normal file
View file

@ -0,0 +1,381 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdlib.h>
#include <string.h>
#include "manglefn.h"
/*------------------------------------------------------------------------------
Balkanize overlapping polygons into many disjoint connected polygons.
Input: npoly = number of polygons.
poly = array of pointers to polygons.
npolys = maximum number of output polygons.
mtol = tolerance angle for multiple intersections.
fmt = pointer to format structure.
axtol, btol, thtol, ytol = tolerance angles (see documentation).
Output: polys = array of pointers to polygons.
Return value: number of disjoint connected polygons,
or -1 if error occurred.
*/
int balkanize(int npoly, polygon *poly[/*npoly*/], int npolys, polygon *polys[/*npolys*/], long double mtol, format *fmt, long double axtol, long double btol, long double thtol, long double ytol)
{
/* part_poly should lasso one-boundary polygons only if they have too many caps */
#define ALL_ONEBOUNDARY 1
/* how part_poly should tighten lasso */
#define ADJUST_LASSO 1
/* part_poly should force polygon to be split even if no part can be lassoed */
#define FORCE_SPLIT 1
/* partition_poly should overwrite all original polygons */
#define OVERWRITE_ORIGINAL 2
#define WARNMAX 8
char *snapped_polys = 0x0;
int discard, dm, dn, dnp, failed, i, ier, inull, isnap, ip, iprune, j, k, m, n, nadj, np, selfsnap;
int *start;
int *total;
int begin, end, p, max_pixel;
long double tol;
poly_sort(npoly, poly, 'p');
/* allocate memory for pixel info arrays start and total */
max_pixel=poly[npoly-1]->pixel+1;
start = (int *) malloc(sizeof(int) * max_pixel);
if (!start) {
fprintf(stderr, "balkanize: failed to allocate memory for %d integers\n", max_pixel);
return(-1);
}
total = (int *) malloc(sizeof(int) * max_pixel);
if (!total) {
fprintf(stderr, "balkanize: failed to allocate memory for %d integers\n", max_pixel);
return(-1);
}
/* build lists of starting indices of each pixel and total number of polygons in each pixel*/
ier=pixel_list(npoly, poly, max_pixel, start, total);
if (ier == -1) {
fprintf(stderr, "balkanize: error building pixel index lists\n");
return(-1);
}
/* start by pruning all input polygons */
np = 0;
inull = 0;
for (i = 0; i < npoly; i++) {
tol = mtol;
iprune = prune_poly(poly[i], tol);
/* error */
if (iprune == -1) {
fprintf(stderr, "balkanize: initial prune failed at polygon %d\n", poly[i]->id);
return(-1);
}
/* zero area polygon */
if (iprune >= 2) {
if (WARNMAX > 0 && inull == 0) msg("warning from balkanize: following polygons have zero area & are being discarded:\n");
if (inull < WARNMAX) {
msg(" %d", (fmt->newid == 'o')? poly[i]->id : i);
} else if (inull == WARNMAX) {
msg(" ... more\n");
}
inull++;
} else {
np++;
}
}
if (WARNMAX > 0 && inull > 0 && inull <= WARNMAX) msg("\n");
if (inull > 0) {
msg("balkanize: %d polygons with zero area are being discarded;\n", inull);
}
/* number of polygons */
msg("balkanizing %d polygons ...\n", np);
/* nullify all output polygons */
for (i = 0; i < npolys; i++) {
polys[i] = 0x0;
}
/*
m = starting index of current set of fragments of i'th polygon
dm = number of current set of fragments of i'th polygon
n = starting index of new subset of fragments of i'th polygon
dn = number of new subset of fragments of i'th polygon
*/
msg("balkanize stage 1 (fragment into non-overlapping polygons):\n");
n = 0;
dnp = 0;
ip = 0;
/* go through each pixel and fragment each polygon against the other polygons in its pixel */
for(p=0;p<max_pixel;p++){
begin=start[p];
end=start[p]+total[p];
/* too many polygons */
if (n >= npolys) break;
/* fragment each polygon in turn */
for (i = begin; i < end; i++) {
/* skip null polygons */
if (poly[i]->np > 0 && poly[i]->cm[0] == 0.) continue;
/* update indices */
m = n;
dm = 1;
n = m + dm;
/* make sure output polygon has enough room */
ier = room_poly(&polys[m], poly[i]->np, DNP, 0);
if (ier == -1) {
fprintf(stderr, "balkanize: failed to allocate memory for polygon of %d caps\n", poly[i]->np + DNP);
return(-1);
}
/* copy polygon i into output polygon */
copy_poly(poly[i], polys[m]);
/* fragment successively against other polygons */
for (j = begin; j < end; j++) {
/* skip self, or null polygons */
if (j == i || (poly[j]->np > 0 && poly[j]->cm[0] == 0.)) continue;
/* keep only one copy of the intersection of i & j */
/* intersection inherits weight of polygon being fragmented,
so keeping later polygon ensures intersection inherits
weight of later polygon */
if (i < j) {
discard = 1;
} else {
discard = 0;
}
/* fragment each part of i'th polygon */
for (k = m; k < m + dm; k++) {
/* skip null polygons */
if (!polys[k] || (polys[k]->np > 0 && polys[k]->cm[0] == 0.)) continue;
/* fragment */
tol = mtol;
dn = fragment_poly(&polys[k], poly[j], discard, npolys - n, &polys[n], tol, bmethod);
/* error */
if (dn == -1) {
fprintf(stderr, "balkanize: UHOH at polygon %d; continuing ...\n", (fmt->newid == 'o')? polys[i]->id : ip);
continue;
/* return(-1); */
}
/* increment index of next subset of fragments */
n += dn;
/* increment polygon count */
np += dn;
dnp += dn;
if (!polys[k]) {
np--;
dnp--;
}
/* check whether exceeded maximum number of polygons */
//printf("(1) n = %d\n", n);
if (n > npolys) {
fprintf(stderr, "(1) balkanize: total number of polygons (= %d) exceeded maximum %d\n", npoly + n, npoly + npolys);
fprintf(stderr, "if you need more space, enlarge NPOLYSMAX in defines.h, and recompile\n");
fprintf(stderr, "currently, dn = %d, np = %d, dnp = %d, poly[%d]->id = %d, poly[%d]->pixel = %d\n", dn, np, dnp, i, poly[i]->id, i, poly[i]->pixel);
n = npolys;
#ifdef CARRY_ON_REGARDLESS
break;
#else
return(-1);
#endif
}
}
/* copy down non-null polygons */
dm = 0;
for (k = m; k < n; k++) {
if (polys[k]) {
polys[m + dm] = polys[k];
dm++;
}
}
/* nullify but don't free, because freeing polys[k] will free polys[m + dm] */
for (k = m + dm; k < n; k++) {
polys[k] = 0x0;
}
n = m + dm;
if (dm == 0) break;
}
/* too many polygons */
if (n >= npolys) break;
ip++;
}
}
free(start);
free(total);
msg("added %d polygons to make %d\n", dnp, np);
// partition disconnected polygons into connected parts
msg("balkanize stage 2 (partition disconnected polygons into connected parts):\n");
m = n;
dnp = 0;
ip = 0;
failed = 0;
for (i = 0; i < m; i++) {
// skip null polygons
if (!polys[i] || (polys[i]->np > 0 && polys[i]->cm[0] == 0.)) continue;
// partition disconnected polygons
tol = mtol;
ier = partition_poly(&polys[i], npolys - n, &polys[n], tol, ALL_ONEBOUNDARY, ADJUST_LASSO, FORCE_SPLIT, OVERWRITE_ORIGINAL, &dn);
// error
if (ier == -1) {
fprintf(stderr, "balkanize: UHOH at polygon %d; continuing ...\n", (fmt->newid == 'o')? polys[i]->id : ip);
continue;
// return(-1);
// failed to partition polygon into desired number of parts
} else if (ier == 1) {
fprintf(stderr, "balkanize: failed to partition polygon %d fully; partitioned it into %d parts\n", (fmt->newid == 'o')? polys[i]->id : ip, dn + 1);
failed++;
}
// increment index of next subset of fragments
n += dn;
// increment polygon count
np += dn;
dnp += dn;
// check whether exceeded maximum number of polygons
//printf("(2) n = %d\n", n);
if (n > npolys) {
fprintf(stderr, "(2) balkanize: total number of polygons (= %d) exceeded maximum %d\n", n + npoly, npoly + npolys);
fprintf(stderr, "if you need more space, enlarge NPOLYSMAX in defines.h, and recompile\n");
n = npolys;
#ifdef CARRY_ON_REGARDLESS
break;
#else
return(-1);
#endif
}
ip++;
}
msg("added %d polygons to make %d\n", dnp, np);
if (failed > 0) {
msg("balkanize: failed to split %d polygons into desired number of connected parts\n", failed);
msg(".............................................................................\n");
msg("Failure to split polygon probably means:\n");
msg("either (1) you forgot to run snap on all your input polygon files;\n");
msg(" or (2) the polygon is too small for the numerics to cope with;\n");
msg(" or (3) you have a weird-shaped polygon.\n");
msg("You may ignore this warning message if the weights of polygons in the input\n");
msg("polygon file(s) are already correct, and you do not want to reweight them.\n");
msg("Similarly, you may ignore this warning message if you do want to reweight the\n");
msg("polygons, but the weights of the different parts of each unsplit polygon are\n");
msg("the same. If you want to reweight the different parts of an unsplit polygon\n");
msg("with different weights, then you will need to split that polygon by hand.\n");
msg("Whatever the case, the output file of balkanized polygons constitutes\n");
msg("a valid mask of non-overlapping polygons, which is safe to use.\n");
msg(".............................................................................\n");
}
/* prune */
j = 0;
inull = 0;
for (i = 0; i < n; i++) {
tol = mtol;
iprune = prune_poly(polys[i], tol);
if (iprune == -1) {
fprintf(stderr, "balkanize: failed to prune polygon %d; continuing ...\n", (fmt->newid == 'o')? polys[i]->id : j);
/* return(-1); */
}
if (iprune >= 2) {
free_poly(polys[i]);
polys[i] = 0x0;
inull++;
} else {
polys[j] = polys[i];
j++;
}
}
if (inull > 0) msg("balkanize: %d balkanized polygons have zero area, and are being discarded\n", inull);
n = j;
/*
// allocate snapped_polys array
snapped_polys = (char *) malloc(sizeof(char) * n);
if (!snapped_polys) {
fprintf(stderr, "balkanize: failed to allocate memory for %d characters\n", n);
return(-1);
}
//snap edges of each polygon
selfsnap = 1;
nadj = snap_polys(fmt, n, polys, selfsnap, axtol, btol, thtol, ytol, mtol, WARNMAX, snapped_polys);
if(nadj==-1){
msg("balkanize: error snapping balkanized polygons\n");
return(-1);
}
// number of polygons whose edges were snapped
isnap = 0;
for (i = 0; i < n; i++) if (snapped_polys[i]) isnap++;
if (isnap > 0) msg("balkanize: edges of %d balkanized polygons were snapped\n", isnap);
// prune snapped polygons
j = 0;
inull = 0;
for (i = 0; i < n; i++) {
if (snapped_polys[i]) {
iprune = prune_poly(polys[i], mtol);
if (iprune == -1) {
fprintf(stderr, "balkanize: failed to prune polygon %d; continuing ...\n", (fmt->newid == 'o')? polys[i]->id : j);
// return(-1);
}
if (iprune >= 2) {
free_poly(polys[i]);
polys[i] = 0x0;
inull++;
} else {
polys[j] = polys[i];
j++;
}
} else {
polys[j] = polys[i];
j++;
}
}
if (inull > 0) msg("balkanize: %d snapped polygons have zero area, and are being discarded\n", inull);
n = j;
// free snapped_polys array
free(snapped_polys);
*/
if(n!=-1){
/* sort polygons by pixel number */
poly_sort(n, polys,'p');
msg("balkanize: balkans contain %d polygons\n", n);
}
/* assign new polygon id numbers in place of inherited ids */
if (fmt->newid == 'n') {
for (i = 0; i < n; i++) {
polys[i]->id = i;
}
}
if (fmt->newid == 'p') {
for (i = 0; i < n; i++) {
polys[i]->id = polys[i]->pixel;
}
}
return(n);
}

300
src/braktop.s.f Normal file
View file

@ -0,0 +1,300 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine braktop(aa,ia,a,n,l)
integer ia,n,l
real*10 aa,a(n)
integer idir,istep
c *
c * Bracket aa in table a ordered in decreasing order,
c * i.e. find ia such that
c * a(ia) >= aa > a(ia+1) (l.eq.0)
c * or a(ia) > aa >= a(ia+1) (l.eq.1).
c * Gives ia=0 if
c * aa > a(1) (l.eq.0)
c * or aa >= a(1) (l.eq.1).
c * Gives ia=n if
c * aa <= a(1) (l.eq.0)
c * or aa < a(1) (l.eq.1).
c *
c Input: aa = value to bracket
c a = ordered array of length n
c n = length of a array
c l = 0 or 1 to choose equality on lower or upper limit.
c Input/Output: ia on input = element of a to start search from;
c on output = as above.
c
if (ia.lt.1) ia=1
if (ia.gt.n) ia=n
c idir is which way to search, up or down
if (aa.lt.a(ia)) then
idir=1
elseif (aa.gt.a(ia)) then
idir=-1
elseif (aa.eq.a(ia)) then
ia=ia-l
goto 200
endif
c istep is how far to leap from present position
istep=1
c leap
120 ia=ia+idir*istep
c keep doubling leap till you've straddled desired place
if (ia.lt.1.or.ia.gt.n) then
continue
elseif (idir*aa.lt.idir*a(ia)) then
istep=istep*2
goto 120
elseif (aa.eq.a(ia)) then
ia=ia-l
goto 200
endif
idir=-idir
c binary chop homes in on desired place in table
140 if (istep.gt.1) then
istep=istep/2
ia=ia+idir*istep
if (ia.lt.1) then
idir=1
elseif (ia.gt.n) then
idir=-1
elseif (aa.lt.a(ia)) then
idir=1
elseif (aa.gt.a(ia)) then
idir=-1
elseif (aa.eq.a(ia)) then
ia=ia-l
goto 200
endif
goto 140
endif
if (idir.eq.-1) ia=ia-1
200 continue
return
end
c
c-----------------------------------------------------------------------
subroutine brakbot(aa,ia,a,n,l)
integer ia,n,l
real*10 aa,a(n)
integer idir,istep
c *
c * Bracket aa in table a ordered in increasing order,
c * i.e. find ia such that
c * a(ia) <= aa < a(ia+1) (l.eq.0)
c * or a(ia) < aa <= a(ia+1) (l.eq.1).
c * Gives ia=0 if
c * aa < a(1) (l.eq.0)
c * or aa <= a(1) (l.eq.1).
c * Gives ia=n if
c * aa <= a(1) (l.eq.0)
c * or aa < a(1) (l.eq.1).
c *
c Input: aa = value to bracket
c a = ordered array of length n
c n = length of a array
c l = 0 or 1 to choose equality on lower or upper limit.
c Input/Output: ia on input = element of a to start search from;
c on output = as above.
c
if (ia.lt.1) ia=1
if (ia.gt.n) ia=n
c idir is which way to search, up or down
if (aa.gt.a(ia)) then
idir=1
elseif (aa.lt.a(ia)) then
idir=-1
elseif (aa.eq.a(ia)) then
ia=ia-l
goto 200
endif
c istep is how far to leap from present position
istep=1
c leap
120 ia=ia+idir*istep
c keep doubling leap till you've straddled desired place
if (ia.lt.1.or.ia.gt.n) then
continue
elseif (idir*aa.gt.idir*a(ia)) then
istep=istep*2
goto 120
elseif (aa.eq.a(ia)) then
ia=ia-l
goto 200
endif
idir=-idir
c binary chop homes in on desired place in table
140 if (istep.gt.1) then
istep=istep/2
ia=ia+idir*istep
if (ia.lt.1) then
idir=1
elseif (ia.gt.n) then
idir=-1
elseif (aa.gt.a(ia)) then
idir=1
elseif (aa.lt.a(ia)) then
idir=-1
elseif (aa.eq.a(ia)) then
ia=ia-l
goto 200
endif
goto 140
endif
if (idir.eq.-1) ia=ia-1
200 continue
return
end
c
c-----------------------------------------------------------------------
subroutine braktpa(aa,ia,a,n,l)
integer ia,n,l
real*10 aa,a(n)
c intrinsics
intrinsic abs
c local (automatic) variables
integer idir,istep
c *
c * Bracket aa in table a ordered in decreasing order of absolute value,
c * i.e. find ia such that
c * |a(ia)| >= aa > |a(ia+1)| (l.eq.0)
c * or |a(ia)| > aa >= |a(ia+1)| (l.eq.1).
c * Gives ia=0 if
c * aa > |a(1)| (l.eq.0)
c * or aa >= |a(1)| (l.eq.1).
c * Gives ia=n if
c * aa <= |a(1)| (l.eq.0)
c * or aa < |a(1)| (l.eq.1).
c *
c Input: aa = value to bracket
c a = ordered array of length n
c n = length of a array
c l = 0 or 1 to choose equality on lower or upper limit.
c Input/Output: ia on input = element of a to start search from;
c on output = as above.
c
if (ia.lt.1) ia=1
if (ia.gt.n) ia=n
c idir is which way to search, up or down
if (aa.lt.abs(a(ia))) then
idir=1
elseif (aa.gt.abs(a(ia))) then
idir=-1
elseif (aa.eq.abs(a(ia))) then
ia=ia-l
goto 200
endif
c istep is how far to leap from present position
istep=1
c leap
120 ia=ia+idir*istep
c keep doubling leap till you've straddled desired place
if (ia.lt.1.or.ia.gt.n) then
continue
elseif (idir*aa.lt.idir*abs(a(ia))) then
istep=istep*2
goto 120
elseif (aa.eq.abs(a(ia))) then
ia=ia-l
goto 200
endif
idir=-idir
c binary chop homes in on desired place in table
140 if (istep.gt.1) then
istep=istep/2
ia=ia+idir*istep
if (ia.lt.1) then
idir=1
elseif (ia.gt.n) then
idir=-1
elseif (aa.lt.abs(a(ia))) then
idir=1
elseif (aa.gt.abs(a(ia))) then
idir=-1
elseif (aa.eq.abs(a(ia))) then
ia=ia-l
goto 200
endif
goto 140
endif
if (idir.eq.-1) ia=ia-1
200 continue
return
end
c
c-----------------------------------------------------------------------
subroutine brakbta(aa,ia,a,n,l)
integer ia,n,l
real*10 aa,a(n)
c intrinsics
intrinsic abs
c local (automatic) variables
integer idir,istep
c *
c * Bracket aa in table a ordered in increasing order of absolute value,
c * i.e. find ia such that
c * |a(ia)| <= aa < |a(ia+1)| (l.eq.0)
c * or |a(ia)| < aa <= |a(ia+1)| (l.eq.1).
c * Gives ia=0 if
c * aa < |a(1)| (l.eq.0)
c * or aa <= |a(1)| (l.eq.1).
c * Gives ia=n if
c * aa <= |a(1)| (l.eq.0)
c * or aa < |a(1)| (l.eq.1).
c *
c Input: aa = value to bracket
c a = ordered array of length n
c n = length of a array
c l = 0 or 1 to choose equality on lower or upper limit.
c Input/Output: ia on input = element of a to start search from;
c on output = as above.
c
if (ia.lt.1) ia=1
if (ia.gt.n) ia=n
c idir is which way to search, up or down
if (aa.gt.abs(a(ia))) then
idir=1
elseif (aa.lt.abs(a(ia))) then
idir=-1
elseif (aa.eq.abs(a(ia))) then
ia=ia-l
goto 200
endif
c istep is how far to leap from present position
istep=1
c leap
120 ia=ia+idir*istep
c keep doubling leap till you've straddled desired place
if (ia.lt.1.or.ia.gt.n) then
continue
elseif (idir*aa.gt.idir*abs(a(ia))) then
istep=istep*2
goto 120
elseif (aa.eq.abs(a(ia))) then
ia=ia-l
goto 200
endif
idir=-idir
c binary chop homes in on desired place in table
140 if (istep.gt.1) then
istep=istep/2
ia=ia+idir*istep
if (ia.lt.1) then
idir=1
elseif (ia.gt.n) then
idir=-1
elseif (aa.gt.abs(a(ia))) then
idir=1
elseif (aa.lt.abs(a(ia))) then
idir=-1
elseif (aa.eq.abs(a(ia))) then
ia=ia-l
goto 200
endif
goto 140
endif
if (idir.eq.-1) ia=ia-1
200 continue
return
end
c

27
src/braktop_.c Normal file
View file

@ -0,0 +1,27 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include "manglefn.h"
/*------------------------------------------------------------------------------
c interface to fortran subroutines in braktop.s.f
*/
void braktop(long double aa, int *ia, long double a[], int n, int l)
{
braktop_(&aa, ia, a, &n, &l);
}
void brakbot(long double aa, int *ia, long double a[], int n, int l)
{
brakbot_(&aa, ia, a, &n, &l);
}
void braktpa(long double aa, int *ia, long double a[], int n, int l)
{
braktpa_(&aa, ia, a, &n, &l);
}
void brakbta(long double aa, int *ia, long double a[], int n, int l)
{
brakbta_(&aa, ia, a, &n, &l);
}

22
src/cmminf.c Normal file
View file

@ -0,0 +1,22 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include "manglefn.h"
/*------------------------------------------------------------------------------
Find smallest cap of polygon.
*/
void cmminf(polygon *poly, int *ipmin, long double *cmmin)
{
int ip;
long double cmi;
*cmmin = 2.;
for (ip = 0; ip < poly->np; ip++) {
cmi = (poly->cm[ip] >= 0.)? poly->cm[ip] : 2. + poly->cm[ip];
if (cmi <= *cmmin) {
*ipmin = ip;
*cmmin = cmi;
}
}
}

594
src/convert.c Normal file
View file

@ -0,0 +1,594 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdlib.h>
#include "manglefn.h"
/* initial angular tolerance within which to merge multiple intersections */
extern long double mtol;
/*------------------------------------------------------------------------------
Convert vertices structure to polygon.
Assume that vertices are joined by great circles.
Polygon poly should contain enough room to contain the vertices,
namely poly->npmax >= vert->nv.
*/
void vert_to_poly(vertices *vert, polygon *poly)
{
int iv;
/* number of boundaries of polygon equals number of vertices */
poly->np = vert->nv;
/* convert each pair of adjacent vertices to a great circle */
for (iv = 0; iv < vert->nv; iv++) {
azel_to_gc(&vert->v[iv], &vert->v[(iv+1) % vert->nv],
poly->rp[iv], &poly->cm[iv]);
}
}
/*------------------------------------------------------------------------------
Convert edges, stored in vertices structure, to polygon.
Input: vert = pointer to vertices structure.
nve = number of points per edge.
ev = cumulative number of points on each connected boundary.
Output: poly = pointer to polygon structure.
*/
void edge_to_poly(vertices *vert, int nve, int *ev, polygon *poly)
{
int dev, i, evo, iedge, iv, iv0, iv1, iv2, jv, nedge;
/* number of edges */
nedge = vert->nv / nve;
/* number of boundaries of polygon equals number of edges */
poly->np = nedge;
evo = 0;
iv = 0;
iedge = 0;
/* do each connected boundary */
for (jv = 0; evo < vert->nv; jv++) {
dev = ev[jv] - evo;
/* points on connected boundary */
while (iv < ev[jv]) {
i = iv - evo;
iv0 = evo + i;
iv1 = evo + (i + 1) % dev;
iv2 = evo + (i + 2) % dev;
if (nve == 1) {
/* convert pair of adjacent vertices to a great circle */
azel_to_gc(&vert->v[iv0], &vert->v[iv1],
poly->rp[iedge], &poly->cm[iedge]);
} else {
/* convert triple of vertices to circle */
edge_to_rpcm(&vert->v[iv0], &vert->v[iv1], &vert->v[iv2],
poly->rp[iedge], &poly->cm[iedge]);
}
iv += nve;
iedge++;
}
evo = ev[jv];
}
}
/*------------------------------------------------------------------------------
Convert rectangle to polygon.
Input: angle [4] = list of angles defining the rectangle,
in the order azmin, azmax, elmin, elmax
Output: poly = pointer to polygon structure
Polygon poly should contain enough room for the 4 caps of the rectangle
*/
void rect_to_poly(long double angle[4], polygon *poly){
#define ROUND 1.e-5
long double daz;
int i;
int ip =0;
/*
angle[0]=azmin;
angle[1]=azmax;
angle[2]=elmin;
angle[3]=elmax;
*/
/* azimuthal extent */
daz = angle[1] - angle[0];
/* skip azimuth if it goes full circle */
if (fabsl(daz - TWOPI) > ROUND) {
/* phase daz into interval [0, 2 pi) */
daz = daz - floorl(daz / TWOPI) * TWOPI;
/* azimuth covers half circle: one cap will do */
if (fabsl(daz - PI) <= ROUND) {
i = 0;
az_to_rpcm(angle[i], i % 2, poly->rp[ip], &poly->cm[ip]);
ip++;
/* need two caps */
} else {
/* convert azmin, azmax to rp, cm */
for (i = 0; i < 2; i++) {
az_to_rpcm(angle[i], i % 2, poly->rp[ip], &poly->cm[ip]);
ip++;
}
/* check azimuthal extent is in interval [0, pi] */
if (daz > PI) {
fprintf(stderr, " warning:");
fprintf(stderr, " rectangle has azimuthal extent %.16Lg deg > 180 deg\n",
places(daz * 180./PI, 14));
}
}
}
/* convert elmin, elmax to rp, cm */
for (i = 2; i < 4; i++) {
/*if one of the el limits is a pole, make a tiny circle around the pole.*/
/*
if(fabsl(angle[i] - ((i==2) ? -PIBYTWO : PIBYTWO)) < ROUND){
angle[i]+= (i==2)? (5*ROUND) : (-5*ROUND);
}
*/
if ((i == 2)? (angle[i] > - PIBYTWO+ROUND) : (angle[i] < PIBYTWO-ROUND)) {
el_to_rpcm(angle[i], i % 2, poly->rp[ip], &poly->cm[ip]);
ip++;
}
}
poly->np = ip;
}
/*------------------------------------------------------------------------------
Convert unit vectors to vertices structure.
Input: rp = array of nv unit vectors.
nv = number of unit vectors.
Output: pointer to a vertices structure.
*/
void rps_to_vert(int nv, vec rp[/*nv*/], vertices *vert)
{
int iv;
/* number of vertices */
vert->nv = nv;
/* convert vectors to vertices */
for (iv = 0; iv < nv; iv++) {
rp_to_azel(rp[iv], &vert->v[iv]);
}
/* phase each vertex to the previous */
for (iv = 1; iv < nv; iv++) {
vert->v[iv].az -= rint((vert->v[iv].az - vert->v[iv-1].az) / TWOPI) * TWOPI;
}
}
/*------------------------------------------------------------------------------
Convert unit vector to az-el.
*/
void rp_to_azel(vec rp, azel *v)
{
v->az = atan2l(rp[1], rp[0]);
v->el = atan2l(rp[2], sqrtl(rp[0] * rp[0] + rp[1] * rp[1]));
}
/*------------------------------------------------------------------------------
Convert vertex to unit vector.
*/
void azel_to_rp(azel *v, vec rp)
{
rp[0] = cosl(v->el) * cosl(v->az);
rp[1] = cosl(v->el) * sinl(v->az);
rp[2] = sinl(v->el);
}
/*------------------------------------------------------------------------------
Determine rp, cm for great circle passing through two az-el vertices.
The great circle goes right-handedly from v0 to v1.
*/
void azel_to_gc(azel *v0, azel *v1, vec rp, long double *cm)
{
azel *v;
int iv;
vec rpv[2];
for (iv = 0; iv < 2; iv++) {
v = (iv == 0)? v0: v1;
rpv[iv][0] = cosl(v->el) * cosl(v->az);
rpv[iv][1] = cosl(v->el) * sinl(v->az);
rpv[iv][2] = sinl(v->el);
}
rp_to_gc(rpv[0], rpv[1], rp, cm);
}
/*------------------------------------------------------------------------------
Determine rp, cm for great circle passing through two unit vectors.
The great circle goes right-handedly from rp0 to rp1.
If the two unit vectors coincide, suppress the boundary,
on the assumption that coincident points are redundant
(for example, a mask-maker may specify a triangle with 4 vertices,
with 2 vertices being coincident).
*/
void rp_to_gc(vec rp0, vec rp1, vec rp, long double *cm)
{
int i;
long double rpa;
/* cofactors */
rp[0] = rp0[1]*rp1[2] - rp1[1]*rp0[2];
rp[1] = rp1[0]*rp0[2] - rp0[0]*rp1[2];
rp[2] = rp0[0]*rp1[1] - rp1[0]*rp0[1];
rpa = sqrtl(rp[0]*rp[0] + rp[1]*rp[1] + rp[2]*rp[2]);
/* indeterminate solution (rp0 and rp1 are same or antipodeal points) */
if (rpa == 0.) {
/* suppress boundary, on assumption that coincident points are redundant */
*cm = 2.;
/* normalize rp to 1 */
} else {
for (i = 0; i < 3; i++) rp[i] /= rpa;
/* cm = 1 for great circle */
*cm = 1.;
}
}
/*------------------------------------------------------------------------------
Determine rp, cm for circle passing through three az-el points.
The circle goes right-handedly from v0 to v1 to v2.
*/
void edge_to_rpcm(azel *v0, azel *v1, azel *v2, vec rp, long double *cm)
{
azel *v=0x0;
int iv;
vec rpv[3];
for (iv = 0; iv < 3; iv++) {
switch (iv) {
case 0: v = v0; break;
case 1: v = v1; break;
case 2: v = v2; break;
}
rpv[iv][0] = cosl(v->el) * cosl(v->az);
rpv[iv][1] = cosl(v->el) * sinl(v->az);
rpv[iv][2] = sinl(v->el);
}
rp_to_rpcm(rpv[0], rpv[1], rpv[2], rp, cm);
}
/*------------------------------------------------------------------------------
Determine rp, cm for circle passing through three unit vectors.
The circle goes right-handedly from rp0 to rp1 to rp2.
If two of the unit vectors coincide, join with a great circle.
If three of the unit vectors coincide, suppress the boundary.
*/
void rp_to_rpcm(vec rp0, vec rp1, vec rp2, vec rp, long double *cm)
{
int coincide, i, j;
long double det, rpa;
long double *rpi, *rpj;
rpi=0x0;
rpj=0x0;
/* check whether any two of the three unit vectors coincide */
coincide = 0;
for (j = 0; j < 3; j++) {
switch (j) {
case 0: rpj = rp0; break;
case 1: rpj = rp1; break;
case 2: rpj = rp2; break;
}
for (i = 0; i < j; i++) {
switch (i) {
case 0: rpi = rp0; break;
case 1: rpi = rp1; break;
case 2: rpi = rp2; break;
}
/* vector coincide */
if (rpi[0] == rpj[0] && rpi[1] == rpj[1] && rpi[2] == rpj[2]) {
coincide = 1;
/* set rpj equal to the third vector */
if (i == 0 && j == 1) {
rpj = rp2;
} else if (i == 0 && j == 2) {
rpj = rp1;
} else if (i == 1 && j == 2) {
rpj = rp0;
}
}
if (coincide) break;
}
if (coincide) break;
}
/* if any two vectors coincide, join with great circle */
if (coincide) {
rp_to_gc(rpi, rpj, rp, cm);
/* non-coincident vectors */
} else {
/* cofactors, arranged to reduce roundoff */
rp[0] = rp0[1] * (rp1[2] - rp2[2])
+ rp1[1] * (rp2[2] - rp0[2])
+ rp2[1] * (rp0[2] - rp1[2]);
rp[1] = rp0[0] * (rp2[2] - rp1[2])
+ rp1[0] * (rp0[2] - rp2[2])
+ rp2[0] * (rp1[2] - rp0[2]);
rp[2] = (rp0[0] * rp1[1] - rp1[0] * rp0[1])
+ (rp1[0] * rp2[1] - rp2[0] * rp1[1])
+ (rp2[0] * rp0[1] - rp0[0] * rp2[1]);
/* |rp| */
rpa = sqrtl(rp[0]*rp[0] + rp[1]*rp[1] + rp[2]*rp[2]);
/* indeterminate solution (2 of 3 unit vectors coincide: shouldn't happen) */
if (rpa == 0.) {
/* suppress boundary, not knowing what to do with it */
*cm = 2.;
/* normal solution */
} else {
/* determinant */
det = (rp0[0] * rp1[1] - rp1[0] * rp0[1]) * rp2[2]
+ (rp1[0] * rp2[1] - rp2[0] * rp1[1]) * rp0[2]
+ (rp2[0] * rp0[1] - rp0[0] * rp2[1]) * rp1[2];
if (det >= 0.) {
/* cosl(th) = det / |rp| */
*cm = 1. - det / rpa;
} else {
/* cosl(th) = - det / |rp| */
rpa = - rpa;
*cm = - (1. - det / rpa);
}
/* normalize rp to 1 */
for (i = 0; i < 3; i++) rp[i] /= rpa;
}
}
}
/*------------------------------------------------------------------------------
Convert circle to rp, cm.
Input: angle = (azimuth, elevation, radius) in radians.
Output: rp, cm as used by garea, gspher et al.
*/
void circ_to_rpcm(long double angle[3], vec rp, long double *cm)
{
long double s;
/* Cartesian coordinates of azimuth, elevation */
rp[0] = cosl(angle[1]) * cosl(angle[0]);
rp[1] = cosl(angle[1]) * sinl(angle[0]);
rp[2] = sinl(angle[1]);
/* 1 - cosl(radius) = 2 sin^2(radius/2) */
s = sinl(angle[2] / 2.);
*cm = s * s * 2.;
*cm = (angle[2] >= 0.)? *cm : -*cm;
}
/*------------------------------------------------------------------------------
Convert rp, cm to circle.
Input: rp, cm as used by garea, gspher et al.
Output: angle = (azimuth, elevation, radius) in radians.
*/
void rpcm_to_circ(vec rp, long double *cm, long double angle[3])
{
long double s;
angle[0] = atan2l(rp[1], rp[0]);
angle[1] = atan2l(rp[2], sqrtl(rp[0] * rp[0] + rp[1] * rp[1]));
s = sqrtl(fabsl(*cm) / 2.);
if (s > 1.) s = 1.;
angle[2] = 2. * asinl(s);
angle[2] = (*cm >= 0.)? angle[2] : -angle[2];
}
/*------------------------------------------------------------------------------
Convert line of constant azimuth to rp, cm.
Input: az = azimuth in radians.
m = 0 for minimum elevation;
= 1 for maximum elevation.
Output: rp, cm as used by garea, gspher et al.
*/
void az_to_rpcm(long double az, int m, vec rp, long double *cm)
{
/* axis along equator */
rp[0] = - sinl(az);
rp[1] = cosl(az);
rp[2] = 0.;
/* 1 - cosl(th) = 1 for great circle */
*cm = 1.;
/* min, max */
*cm = (m == 0)? *cm : - *cm;
}
/*------------------------------------------------------------------------------
Convert line of constant elevation to rp, cm.
Input: el = elevation in radians.
m = 0 for minimum elevation;
= 1 for maximum elevation.
Output: rp, cm as used by garea, gspher et al.
*/
void el_to_rpcm(long double el, int m, vec rp, long double *cm)
{
/* north pole */
rp[0] = 0.;
rp[1] = 0.;
rp[2] = 1.;
/* 1 - cosl(th) = 1 - sinl(el) */
*cm = 1 - sinl(el);
/* min, max */
*cm = (m == 0)? *cm : - *cm;
}
/*------------------------------------------------------------------------------
theta_ij = angle in radians between two unit vectors.
*/
long double thij(vec rpi, vec rpj)
{
long double cm, th;
cm = cmij(rpi, rpj);
th = 2. * asinl(cm / 2.);
return(th);
}
/*------------------------------------------------------------------------------
1-cosl(theta_ij) = 2 sin^2(theta_ij/2) between two unit vectors.
*/
long double cmij(vec rpi, vec rpj)
{
long double cm, dx, dy, dz;
dx = rpi[0] - rpj[0];
dy = rpi[1] - rpj[1];
dz = rpi[2] - rpj[2];
cm = (dx*dx + dy*dy + dz*dz) / 2.;
if (cm > 2.) cm = 2.;
return(cm);
}
/*------------------------------------------------------------------------------
Determine whether a polygon is a rectangle,
and if so return <azmin> <azmax> <elmin> <elmax>.
Input: poly = pointer to polygon.
Output: *azmin, *azmax, *elmin, *elmax;
if *azmin >= *azmax, or *elmin >= *elmax, the rectangle is empty;
if *azmin = *azmax + 2*pi, there is no azimuthal constraint.
Return value: 0 if polygon is not a rectangle,
1 if polygon is a rectangle,
2 if polygon is a rectangle with superfluous boundaries.
*/
int poly_to_rect(polygon *poly, long double *azmin, long double *azmax, long double *elmin, long double *elmax)
{
int iaz, ielmin, ielmax, ip;
long double az, el;
*azmin = -TWOPI;
*azmax = TWOPI;
*elmin = -PIBYTWO;
*elmax = PIBYTWO;
iaz = 0;
ielmin = 0;
ielmax = 0;
for (ip = 0; ip < poly->np; ip++) {
/* null polygon */
if (poly->cm[ip] == 0. || poly->cm[ip] <= -2.) return(0);
/* skip superfluous cap */
if (poly->cm[ip] >= 2.) continue;
/* line of constant azimuth */
if (poly->rp[ip][2] == 0.
&& (poly->cm[ip] == 1. || poly->cm[ip] == -1.)) {
/* az is in (-pi,pi] */
az = atan2l(-poly->rp[ip][0], poly->rp[ip][1]);
if (poly->cm[ip] == -1.) az += (az <= 0.)? PI : -PI;
/* shift azmin, azmax to phase of az, az+pi */
if (az >= *azmax) {
while (az >= *azmax) {
*azmin += TWOPI;
*azmax += TWOPI;
}
} else if (az + PI <= *azmin) {
while (az + PI <= *azmin) {
*azmin -= TWOPI;
*azmax -= TWOPI;
}
}
/* revise azmin, azmax */
if (az > *azmin) *azmin = az;
if (az + PI < *azmax) *azmax = az + PI;
iaz++;
/* line of constant elevation */
} else if (poly->rp[ip][0] == 0. && poly->rp[ip][1] == 0.) {
el = asinl(1. - fabsl(poly->cm[ip]));
if (poly->rp[ip][2] < 0.) el = -el;
if ((poly->rp[ip][2] > 0. && poly->cm[ip] >= 0.)
|| (poly->rp[ip][2] < 0. && poly->cm[ip] < 0.)) {
if (el > *elmin) *elmin = el;
ielmin++;
} else {
if (el < *elmax) *elmax = el;
ielmax++;
}
} else {
return(0);
}
}
/* azimuthal constraints include nothing */
if (*azmin > *azmax) {
*azmin = *azmax = 0.;
/* azimuthal constraints include everything */
} else if (*azmin + TWOPI <= *azmax) {
*azmin = -PI;
*azmax = PI;
/* phase azmin to (-pi,pi] */
} else if (*azmin > PI) {
*azmin -= TWOPI;
*azmax -= TWOPI;
}
/* should not happen */
if (iaz > 2 || ielmin > 1 || ielmax > 1) {
msg("poly_to_rect: polygon contains");
if (iaz > 2) msg(" %d az boundaries", iaz);
if (ielmin > 1) msg(" %d elmin boundaries", ielmin);
if (ielmax > 1) msg(" %d elmax boundaries", ielmax);
msg("\n");
return(2);
}
return(1);
}
/*------------------------------------------------------------------------------
Determine whether the first vertex in vert
is closer to the nearest vertex or to the nearest antivertex of poly.
Return value: 0 or 1 as first vertex of vert is closer to the nearest
vertex or antivertex of poly;
-1 if error.
*/
int antivert(vertices *vert, polygon *poly)
{
const int do_vcirc = 0, nve = 1, per = 0;
int anti, ier, iv, nev, nev0, nv;
int *ipv, *gp, *ev;
long double cm, cmmax, cmmin, tol;
long double *angle;
vec rp;
vec *ve;
/* vert has no vertices */
if (vert->nv == 0) return(0);
/* vertices of polygon */
tol = mtol;
ier = gverts(poly, do_vcirc, &tol, per, nve, &nv, &ve, &angle, &ipv, &gp, &nev, &nev0, &ev);
/* error */
if (ier) return(-1);
/* poly has less than 3 vertices */
if (nv < 3) return(0);
/* convert first vertex to unit vector */
azel_to_rp(&vert->v[0], rp);
cmmin = 2.;
cmmax = 0.;
for (iv = 0; iv < nv; iv++) {
cm = cmij(rp, ve[iv]);
if (cm < cmmin) cmmin = cm;
if (cm > cmmax) cmmax = cm;
}
anti = ((cmmin + cmmax <= 2.)? 0 : 1);
return(anti);
}

40
src/copy_format.c Normal file
View file

@ -0,0 +1,40 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <string.h>
#include "manglefn.h"
/*------------------------------------------------------------------------------
Copy format structure from fmt1 to fmt2, except fmt->nweights (this is used
as a sort of flag in rdmask as to whether rd_hpix has been called or not).
*/
void copy_format(format *fmt1, format *fmt2)
{
fmt2->in = fmt1->in;
fmt2->out = fmt1->out;
fmt2->skip = fmt1->skip;
fmt2->end = fmt1->end;
fmt2->single = fmt1->single;
fmt2->n = fmt1->n;
fmt2->nn = fmt1->nn;
fmt2->innve = fmt1->innve;
fmt2->outper = fmt1->outper;
fmt2->outnve = fmt1->outnve;
fmt2->id = fmt1->id;
fmt2->newid = fmt1->newid;
fmt2->pixel = fmt1->pixel;
fmt2->weight = fmt1->weight;
fmt2->inunitp = fmt1->inunitp;
fmt2->outunitp = fmt1->outunitp;
fmt2->inframe = fmt1->inframe;
fmt2->outframe = fmt1->outframe;
fmt2->inunit = fmt1->inunit;
fmt2->outunit = fmt1->outunit;
fmt2->outprecision = fmt1->outprecision;
fmt2->outphase = fmt1->outphase;
fmt2->azn = fmt1->azn;
fmt2->eln = fmt1->eln;
fmt2->azp = fmt1->azp;
fmt2->trunit = fmt1->trunit;
fmt2->nweights = fmt2->nweights;
}

155
src/copy_poly.c Normal file
View file

@ -0,0 +1,155 @@
/*------------------------------------------------------------------------------
Š A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include "manglefn.h"
/*------------------------------------------------------------------------------
Copy poly1.
poly may be the same polygon as poly1.
Input: poly1 is a polygon.
Output: poly is a copy of poly1.
*/
void copy_poly(polygon *poly1, polygon *poly)
{
int i, ip;
for (ip = 0; ip < poly1->np; ip++) {
for (i = 0; i < 3; i++) {
poly->rp[ip][i] = poly1->rp[ip][i];
}
poly->cm[ip] = poly1->cm[ip];
}
poly->np = poly1->np;
poly->id = poly1->id;
poly->pixel = poly1->pixel;
poly->weight = poly1->weight;
}
/*------------------------------------------------------------------------------
Copy first np caps of poly1 into poly.
poly may be the same polygon as poly1.
Input: poly1 is a polygon.
np = number of caps of poly1 to copy into poly.
Output: poly is a copy of the first np caps of poly1.
*/
void copy_polyn(polygon *poly1, int np, polygon *poly)
{
int i, ip;
for (ip = 0; ip < np; ip++) {
for (i = 0; i < 3; i++) {
poly->rp[ip][i] = poly1->rp[ip][i];
}
poly->cm[ip] = poly1->cm[ip];
}
poly->np = np;
poly->id = poly1->id;
poly->pixel = poly1->pixel;
poly->weight = poly1->weight;
}
/*------------------------------------------------------------------------------
Intersection of two polygons.
poly may be the same polygon as poly1, but not the same polygon as poly2.
Input: poly1, poly2 are two polygons.
Ouptput: poly is the intersection of poly1 and poly2,
The id number and weight of poly are taken equal to those of poly1.
*/
void poly_poly(polygon *poly1, polygon *poly2, polygon *poly)
{
int i, ip;
for (ip = 0; ip < poly1->np; ip++) {
for (i = 0; i < 3; i++) {
poly->rp[ip][i] = poly1->rp[ip][i];
}
poly->cm[ip] = poly1->cm[ip];
}
for (ip = 0; ip < poly2->np; ip++) {
for (i = 0; i < 3; i++) {
poly->rp[ip + poly1->np][i] = poly2->rp[ip][i];
}
poly->cm[ip + poly1->np] = poly2->cm[ip];
}
poly->np = poly1->np + poly2->np;
poly->id = poly1->id;
poly->pixel = poly1->pixel;
poly->weight = poly1->weight;
}
/*------------------------------------------------------------------------------
Intersection of a polygon
with the n'th cap, or the complement of the n'th cap, of another polygon.
poly may be the same polygon as poly1, but not the same polygon as poly2.
Input: poly1, poly2 are polygons.
n = intersect poly1 with n'th cap of poly2.
scm = 1 to intersect with n'th cap of poly2;
-1 to intersect with complement of n'th cap of poly2.
Output: poly is the intersection of poly1 and n'th cap of poly2.
The id number and weight of poly are taken equal to those of poly1.
*/
void poly_polyn(polygon *poly1, polygon *poly2, int n, int scm, polygon *poly)
{
int i, ip;
for (ip = 0; ip < poly1->np; ip++) {
for (i = 0; i < 3; i++) {
poly->rp[ip][i] = poly1->rp[ip][i];
}
poly->cm[ip] = poly1->cm[ip];
}
ip = poly1->np;
for (i = 0; i < 3; i++) {
poly->rp[ip][i] = poly2->rp[n][i];
}
poly->cm[ip] = scm * poly2->cm[n];
poly->np = poly1->np + 1;
poly->id = poly1->id;
poly->pixel = poly1->pixel;
poly->weight = poly1->weight;
}
/*------------------------------------------------------------------------------
Make group polygon gpoly.
gpoly may be the same polygon as poly.
Input: poly = pointer to polygon.
gp[ip], ip=1,np = group number of cap ip.
gpg = group to put in gpoly.
gpoly = pointer to group polygon.
*/
void group_poly(polygon *poly, int gp[/*poly->np*/], int gpg, polygon *gpoly)
{
int i, ip, np;
/* number of caps of group polygon */
np = 0;
for (ip = 0; ip < poly->np; ip++) {
if (gp[ip] == gpg) {
np++;
}
}
/* make group polygon */
np = 0;
for (ip = 0; ip < poly->np; ip++) {
if (gp[ip] == gpg) {
for (i = 0; i < 3; i++) {
gpoly->rp[np][i] = poly->rp[ip][i];
}
gpoly->cm[np] = poly->cm[ip];
np++;
}
}
gpoly->np = np;
gpoly->id = poly->id;
gpoly->pixel = poly->pixel;
gpoly->weight = poly->weight;
}

19
src/copy_structure.c Normal file
View file

@ -0,0 +1,19 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
/*------------------------------------------------------------------------------
Copy structure from struct1 to struct2.
Input: n = sizeof(struct1).
struct1, structure = pointers to structures of same size.
Output: revised contents of struct2.
*/
void copy_structure(int n, char *struct1, char *struct2)
{
char *p1, *p2;
int i;
p1 = (char *) struct1;
p2 = (char *) struct2;
for (i = 0; i < n; i++) *p2++ = *p1++;
}

448
src/ddcount.c Normal file
View file

@ -0,0 +1,448 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#ifdef TIME
#include <time.h>
#endif
#include "inputfile.h"
#include "manglefn.h"
#include "defaults.h"
/* getopt options */
const char *optstr = "dqs:e:u:p:i:";
/* allocate polygons as a global array */
polygon *poly_global[NPOLYSMAX];
/* declared in rdmask */
extern inputfile file;
/* local functions */
void usage(void);
#ifdef GCC
long ddcount(char *, char *, char *, format *, int npoly, polygon *[npoly]);
#else
long ddcount(char *, char *, char *, format *, int npoly, polygon *[/*npoly*/]);
#endif
/*------------------------------------------------------------------------------
Main program.
*/
int main(int argc, char *argv[])
{
int ifile, nfiles, npoly,i;
long np;
polygon **poly;
poly=poly_global;
/* parse arguments */
parse_args(argc, argv);
/* three input and one output filename required as arguments */
nfiles = argc - optind;
if (nfiles != 4) {
if (optind > 1 || nfiles >= 1) {
fprintf(stderr, "%s requires 4 arguments: polygon_infile, azel_infile, th_infile, and dd_outfile\n", argv[0]);
usage();
exit(1);
} else {
usage();
exit(0);
}
}
msg("---------------- ddcount ----------------\n");
/* advise data format */
advise_fmt(&fmt);
/* read polygons */
ifile = optind;
npoly = rdmask(argv[optind], &fmt, NPOLYSMAX, poly);
if (npoly == -1) exit(1);
if (npoly == 0) {
msg("STOP\n");
exit(0);
}
/* pair counts */
np = ddcount(argv[optind + 1], argv[optind + 2], argv[optind + 3], &fmt, npoly, poly);
if (np == -1) exit(1);
for(i=0;i<npoly;i++){
free_poly(poly[i]);
}
return(0);
}
/*------------------------------------------------------------------------------
*/
void usage(void)
{
printf("usage:\n");
printf("ddcount [-d] [-q] [-s<n>] [-e<n>] [-u<inunit>] [-p[+|-][<n>]] [-i<f>[<n>][u]] polygon_infile azel_infile th_infile dd_outfile\n");
#include "usage.h"
}
/*------------------------------------------------------------------------------
*/
#include "parse_args.c"
/*------------------------------------------------------------------------------
Counts of pairs in bins bounded by radii th, centred at az el.
Anglar positions az, el are read from azel_in_filename,
angular radii th are read from th_in_filename,
or from azel_in_filename if th_in_filename is null,
and the results are written to out_filename.
Implemented as interpretive read/write, to permit interactive behaviour.
Input: azel_in_filename = name of file to read az, el from;
"" or "-" means read from standard input.
th_in_filename = name of file to read th from;
"" or "-" means read from standard input.
out_filename = name of file to write to;
"" or "-" means write to standard output.
fmt = pointer to format structure.
npoly = number of polygons in poly array.
poly = array of pointers to polygons.
Return value: number of distinct pairs counted,
or -1 if error occurred.
*/
long ddcount(char *azel_in_filename, char *th_in_filename, char *out_filename, format *fmt, int npoly, polygon *poly[/*npoly*/])
{
#define AZEL_STR_LEN 32
char input[] = "input", output[] = "output";
/* maximum number of angular angular radii: will expand as necessary */
static int nthmax = 0;
/* maximum number of az-el points: will expand as necessary */
static int nazelmax = 0;
static int *dd = 0x0, *id = 0x0, *iord = 0x0;
static long double *cm = 0x0, *th = 0x0;
static azel *v = 0x0;
static vec *rp = 0x0;
#ifdef TIME
clock_t time;
#endif
char inunit;
char *word, *next;
char th_str[AZEL_STR_LEN];
int i, iazel, idi, ird, ith, j, jazel, manyid, nazel, nid, noid, nth;
int *id_p;
long np;
long double az, cmm, el, s, t;
char *out_fn;
FILE *outfile;
/* open th_in_filename for reading */
if (strcmp(th_in_filename, "-") == 0) {
file.file = stdin;
file.name = input;
} else {
file.file = fopen(th_in_filename, "r");
if (!file.file) {
fprintf(stderr, "cannot open %s for reading\n", th_in_filename);
return(-1);
}
file.name = th_in_filename;
}
file.line_number = 0;
inunit = (fmt->inunit == 'h')? 'd' : fmt->inunit;
msg("will take units of input th angles in %s to be ", file.name);
switch (inunit) {
#include "angunit.h"
}
msg("\n");
/* read angular radii th from th_in_filename */
nth = 0;
while (1) {
/* read line */
ird = rdline(&file);
/* serious error */
if (ird == -1) return(-1);
/* EOF */
if (ird == 0) break;
/* read angular radius from line */
ird = rdangle(file.line, &next, inunit, &t);
/* error */
if (ird < 1) {
/* retry if nothing read, otherwise break */
if (nth > 0) break;
/* ok */
} else if (ird == 1) {
if (nth >= nthmax) {
if (nthmax == 0) {
nthmax = 64;
} else {
nthmax *= 2;
}
/* (re)allocate memory for th array */
th = (long double *) realloc(th, sizeof(long double) * nthmax);
if (!th) {
fprintf(stderr, "ddcount: failed to allocate memory for %d long doubles\n", nthmax);
return(-1);
}
}
/* store th */
th[nth] = t;
nth++;
}
}
if (file.file != stdin) {
/* close th_in_filename */
fclose(file.file);
/* advise */
msg("%d angular radii read from %s\n", nth, file.name);
}
if (nth == 0) return(nth);
/* open azel_in_filename for reading */
if (!azel_in_filename || strcmp(azel_in_filename, "-") == 0) {
file.file = stdin;
file.name = input;
} else {
file.file = fopen(azel_in_filename, "r");
if (!file.file) {
fprintf(stderr, "cannot open %s for reading\n", azel_in_filename);
return(-1);
}
file.name = azel_in_filename;
}
file.line_number = 0;
/* advise input angular units */
msg("will take units of input az, el angles in %s to be ", file.name);
switch (fmt->inunit) {
#include "angunit.h"
}
msg("\n");
/* read angular positions az, el from azel_in_filename */
nazel = 0;
while (1) {
/* read line */
ird = rdline(&file);
/* serious error */
if (ird == -1) return(-1);
/* EOF */
if (ird == 0) break;
/* read <az> */
word = file.line;
ird = rdangle(word, &next, fmt->inunit, &az);
/* skip header */
if (ird != 1 && nazel == 0) continue;
/* otherwise exit on unrecognized characters */
if (ird != 1) break;
/* read <el> */
word = next;
ird = rdangle(word, &next, fmt->inunit, &el);
/* skip header */
if (ird != 1 && nazel == 0) continue;
/* otherwise exit on unrecognized characters */
if (ird != 1) break;
/* (re)allocate memory for array of az-el points */
if (nazel >= nazelmax) {
if (nazelmax == 0) {
nazelmax = 64;
} else {
nazelmax *= 2;
}
v = (azel *) realloc(v, sizeof(azel) * nazelmax);
if (!v) {
fprintf(stderr, "ddcount: failed to allocate memory for %d az-el points\n", nazelmax);
return(-1);
}
}
/* record az-el */
v[nazel].az = az;
v[nazel].el = el;
/* increment number of az-el points */
nazel++;
}
if (file.file != stdin) {
/* close azel_in_filename */
fclose(file.file);
/* advise */
msg("%d angular positions az, el read from %s\n", nazel, file.name);
}
if (nazel == 0) return(nazel);
/* open out_filename for writing */
if (!out_filename || strcmp(out_filename, "-") == 0) {
outfile = stdout;
out_fn = output;
} else {
outfile = fopen(out_filename, "w");
if (!outfile) {
fprintf(stderr, "cannot open %s for writing\n", out_filename);
return(-1);
}
out_fn = out_filename;
}
/* (re)allocate memory */
cm = (long double *) realloc(dd, sizeof(long double) * nth);
if (!cm) {
fprintf(stderr, "ddcount: failed to allocate memory for %d long doubles\n", nth);
return(-1);
}
dd = (int *) realloc(dd, sizeof(int) * nth);
if (!dd) {
fprintf(stderr, "ddcount: failed to allocate memory for %d ints\n", nth);
return(-1);
}
id = (int *) realloc(id, sizeof(int) * nazel);
if (!id) {
fprintf(stderr, "ddcount: failed to allocate memory for %d ints\n", nazel);
return(-1);
}
rp = (vec *) realloc(rp, sizeof(vec) * nazel);
if (!rp) {
fprintf(stderr, "ddcount: failed to allocate memory for %d unit vectors\n", nazel);
return(-1);
}
iord = (int *) realloc(iord, sizeof(int) * nazel);
if (!iord) {
fprintf(stderr, "ddcount: failed to allocate memory for %d ints\n", nazel);
return(-1);
}
/* store 1 - cosl(th) in cm array */
for (ith = 0; ith < nth; ith++) {
t = th[ith];
scale(&t, inunit, 'r');
s = sinl(t / 2.);
cm[ith] = 2. * s * s;
}
/* convert az-el angles to radians */
for (iazel = 0; iazel < nazel; iazel++) {
scale_azel(&v[iazel], fmt->inunit, 'r');
}
/* convert az-el points to unit vectors */
for (iazel = 0; iazel < nazel; iazel++) {
azel_to_rp(&v[iazel], rp[iazel]);
}
/* polygon id number(s) of az-el points */
msg("figuring polygon id number(s) of each az-el point ...");
noid = 0;
manyid = 0;
for (iazel = 0; iazel < nazel; iazel++) {
nid = poly_id(npoly, poly, v[iazel].az, v[iazel].el, &id_p);
if (nid == 0) {
noid++;
} else if (nid > 1) {
manyid++;
}
/* store first polygon id of point */
if (nid == 0) {
id[iazel] = -1;
} else {
id[iazel] = id_p[0];
}
}
msg(" done\n");
if (noid > 0) {
msg("%d az-el points lie outside the angular mask: discard them\n", noid);
}
if (manyid > 0) {
msg("%d az-el points lie inside more than one polygon: use only first polygon\n", manyid);
}
/* order az-el points in increasing order of polygon id */
finibot(id, nazel, iord, nazel);
/* write header */
fprintf(outfile, "th(%c):", inunit);
for (ith = 0; ith < nth; ith++) {
wrangle(th[ith], inunit, fmt->outprecision, AZEL_STR_LEN, th_str);
fprintf(outfile, "\t%s", th_str);
}
fprintf(outfile, "\n");
msg("counting pairs ...");
#ifdef TIME
printf(" timing ... ");
fflush(stdout);
time = clock();
#endif
/* loop over az-el points */
idi = -1;
nid = 0;
np = 0;
for (iazel = 0; iazel < nazel; iazel++) {
i = iord[iazel];
/* skip points outside mask */
if (id[i] == -1) continue;
/* new polygon */
if (id[i] != idi) {
idi = id[i];
/* reset pair counts to zero */
for (ith = 0; ith < nth; ith++) dd[ith] = 0;
}
//printf(" %d", idi);
/* az-el neighbours within same polygon */
for (jazel = iazel + 1; jazel < nazel; jazel++) {
j = iord[jazel];
/* exit at new polygon */
if (id[j] != idi) break;
/* 1 - cosl(th_ij) */
cmm = cmij(rp[i], rp[j]);
/* ith such that cm[ith-1] <= cmm < cm[ith] */
ith = search(nth, cm, cmm);
/* increment count in this bin */
if (ith < nth) dd[ith]++;
/* increment total pair count */
np++;
}
/* write counts for this polygon */
if (iazel + 1 == nazel || id[iord[iazel + 1]] != idi) {
fprintf(outfile, "%d", idi);
for (ith = 0; ith < nth; ith++) {
fprintf(outfile, "\t%d", dd[ith]);
}
fprintf(outfile, "\n");
fflush(outfile);
nid++;
//printf("\n");
}
}
#ifdef TIME
time = clock() - time;
printf("done in %Lg sec\n", (float)time / (float)CLOCKS_PER_SEC);
#else
msg("\n");
#endif
/* advise */
if (outfile != stdout) {
fclose(outfile);
msg("%d distinct pairs in %d th-bins x %d polygons written to %s\n", np, nth, nid, out_fn);
}
return(np);
}

184
src/defaults.h Normal file
View file

@ -0,0 +1,184 @@
/*------------------------------------------------------------------------------
(C) A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include "defines.h"
/* LOCAL VARIABLES */
/* maximum harmonic */
static int lmax = LMAX;
/* smoothing parameters */
static long double lsmooth = LSMOOTH, esmooth = ESMOOTH;
/* name of file containing harmonics */
static char *Wlm_filename = 0x0;
/* name of survey */
static char *survey = 0x0;
/* option in -f<fopt> command line switch */
static char *fopt = 0x0;
/* seed for random number generator */
static unsigned int seed = SEED;
/* whether seed was read */
static int seed_read = 0;
/* number of random points to generate */
static int nrandom = NRANDOM;
/* write only summary to output */
static int summary = 0;
/* selfsnap = 0 snaps edges of polygons against edges of all other polygons;
selfsnap = 1 snaps edges of polygons only against edges of the same polygon */
static int selfsnap = 0;
/* data format */
static format fmt = {
0x0, /* keyword defining the input data format */
0x0, /* default format of the output data */
SKIP, /* skip first skip characters of each line of data */
END, /* last character to read from line of data */
0, /* keyword does not define precisely one polygon */
0, /* the number of thingys defined by keyword */
0, /* the number of numbers per thingy */
NVE, /* the input number of points per edge */
0, /* controls interpetation of nve */
NVE, /* the output number of points per edge */
0, /* id number of current polygon */
'o', /* whether to use old or new id number */
0, /* default pixel number */
1., /* weight of current polygon */
INUNITP, /* default unit of angles in input polygon data */
OUTUNITP, /* default unit of angles in output polygon data */
0, /* angular frame of input az, el data */
0, /* angular frame of output az, el data */
INUNIT, /* default unit of input az, el data */
OUTUNIT, /* default unit of output az, el data */
-1, /* digits after decimal point in output angles (-1 = automatic) */
OUTPHASE, /* '-' or '+' to make output azimuth in interval (-pi, pi] or [0, 2 pi) */
AZN, /* default */
ELN, /* transformation */
AZP, /* between angular frames */
TRUNIT, /* unit of transformation angles */
0, /* default number of weights in healpix_weight input file */
0, -1 /* by default, healpix weights are not autogenerated. */
};
/* GLOBAL VARIABLES */
/* default is to be verbose */
#ifdef DEBUG
int verbose = 2;
#else
int verbose = 1;
#endif
/* counter for input files read */
int infiles = 0;
/* tolerances */
long double axtol = AXTOL; /* snap angle for axis */
char axunit = AXUNIT; /* unit of snap angle for axis */
long double btol = BTOL; /* snap angle for latitude */
char bunit = BUNIT; /* unit of snap angle for latitude */
long double thtol = THTOL; /* snap angle for edge */
char thunit = THUNIT; /* unit of snap angle for edge */
long double ytol = YTOL; /* edge to length tolerance */
long double mtol = MTOL; /* tolerance angle for multiple intersections */
char munit = MUNIT; /* unit of tolerance angle for multiple intersections */
/* whether min, max weight are turned on */
int is_weight_min = 0;
int is_weight_max = 0;
/* min, max weight to keep */
long double weight_min;
long double weight_max;
/* whether min, max area are turned on */
int is_area_min = 0;
int is_area_max = 0;
/* min, max area to keep */
long double area_min;
long double area_max;
/* whether min, max id are turned on */
int is_id_min = 0;
int is_id_max = 0;
/* min, max id to keep */
int id_min;
int id_max;
/* whether min, max pixel are turned on */
int is_pixel_min = 0;
int is_pixel_max = 0;
/* min, max pixel to keep */
int pixel_min;
int pixel_max;
/* whether to take intersection of polygons in input files */
int intersect = 0;
/* dictionary of keywords */
/* THE NAMES OF FORMATS MUST AGREE WITH THE INDICES IN defines.h */
char *keywords[] = {
"area",
"circle",
"edges",
"graphics",
"healpix_weight",
"id",
"midpoint",
"polygon",
"rectangle",
"Region",
"spolygon",
"vertices",
"weight",
"list",
"pixelization",
"skip",
"end",
"unit",
"balkanized",
"snapped",
"binary_polygon",
'\0'
};
/* dictionary of frames */
/* THE ORDER OF FRAMES MUST AGREE WITH THAT IN frames.par ! */
char *frames[] = {
"unknown",
"eqB1950",
"eqJ2000",
"galactic",
"ecliptic",
"ecliptic2k",
"sdss",
'\0'
};
/*pixelization info*/
int res_max=RES_MAX; /*maximum resolution allowed for pixelization*/
int polys_per_pixel=POLYS_PER_PIXEL; /*level of pixelization: number of polygons allowed per pixel*/
/*set polys_per_pixel=0 to pixelize everything to max resolution*/
char scheme=SCHEME; /*default pixelization scheme*/
int unpixelize=0; /*switch for whether unify should unpixelize or not*/
int pixelized=0; /*counter for pixelized input files */
int snapped=0; /*flag for whether files have been snapped */
int balkanized=0; /*flag for whether files have been balkanized */
/*balkanization method*/
char bmethod=BMETHOD;
//Default is for a balkanized polygon to inherit the weight of
//the last overlapping polygon in the input polygons. other options
//are to add them together (bmethod=a), or to take the minimum
//(bmethod=n) or the maximum (bmethod=x) of the weights
int polyid_weight=0; /*0= polyid prints id numbers, 1= polyid prints weights*/
int weight_is_area=0;
int machine_output=0;

118
src/defines.h Normal file
View file

@ -0,0 +1,118 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#ifndef DEFINES_H
#define DEFINES_H
#define MAXINT (((unsigned int)-1) / 2)
/* maximum number of polygons */
/*
This is the only hard limit built into mangle.
It's supposed to be a feature, not a bug.
If you are making zillions of polygons, chances are it's a silly mistake.
*/
#define NPOLYSMAX 90000000
/* number of extra caps to allocate to polygon, to allow for later splitting */
#define DNP 4
#include "pi.h"
#define TWOPI (2. * PI)
#define PIBYTWO (PI / 2.)
/* list of possible units */
#define UNITS "rdmsh"
/* #define UNITS "rd°m'´s\"¨h" */
/* angular units in arcseconds */
#define RADIAN (648000. / PI)
#define HOUR 54000.
#define DEGREE 3600.
#define MINUTE 60.
#define SECOND 1.
/* default maximum harmonic */
#define LMAX 0
/* default smoothing harmonic (0. = no smooth) */
#define LSMOOTH 0.
/* default smoothing exponent (2. = gaussian) */
#define ESMOOTH 2.
/* default snap angles for axis, latitude, and edge */
#define AXTOL 2.0e-9
#define BTOL 2.0e-9
#define THTOL 2.0e-9
/* default value of ytol */
#define YTOL .01
/* default snap angle for multiple intersections */
#define MTOL 1.0e-11
/* default input units of snap angles */
#define AXUNIT 's'
#define BUNIT 's'
#define THUNIT 's'
#define MUNIT 's'
/* default seed for random number generator */
#define SEED 1
/* default number of random points to generate */
#define NRANDOM 1
/* default number of points per edge */
#define NVE 2
/* default input unit of polygon data is degrees */
#define INUNITP 'd'
/* default output unit of polygon data is degrees */
#define OUTUNITP 'd'
/* default input unit of az, el data is degrees */
#define INUNIT 'd'
/* default output unit of az, el data is degrees */
#define OUTUNIT 'd'
/* default output phase: '-' or '+' to make output azimuth in interval (-pi, pi] or [0, 2 pi) */
#define OUTPHASE '+'
/* identity transformation between angular frames */
#define AZN 0.
#define ELN 90.
#define AZP 180.
/* unit of transformation between angular frames
must be 'd', since degrees is hard-wired into transformation routines */
#define TRUNIT 'd'
/* default number of characters of line of input data to skip */
#define SKIP 0
/* default last character to read from line of input data */
#define END 0
/* list of possible input formats */
#define RFMTS "cehprRsv"
/* list of possible output formats */
#define WFMTS "acegimprRsvwl"
/* possible polygon file formats */
#define AREA 0
#define CIRCLE 1
#define EDGES 2
#define GRAPHICS 3
#define HEALPIX_WEIGHT 4
#define ID 5
#define MIDPOINT 6
#define POLYGON 7
#define RECTANGLE 8
#define REGION 9
#define SPOLYGON 10
#define VERTICES 11
#define WEIGHT 12
#define LIST 13
#define BINARY_POLYGON 20
/*list of allowed pixelization schemes*/
#define SCHEMES "sd"
/*pixelization defaults*/
#define SCHEME 's'
#define POLYS_PER_PIXEL 40
#define RES_MAX 10
/*list of balkanize methods */
#define BMETHODS "lanx" /*last, add, min, max */
/*default balkanize method */
#define BMETHOD 'l'
#endif /* DEFINES_H */

12
src/drandom.c Normal file
View file

@ -0,0 +1,12 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdlib.h>
/*------------------------------------------------------------------------------
Random long double in interval [0., 1.)
*/
long double drandom(void)
{
return((long double)random() / ((long double)RAND_MAX + 1.));
}

538
src/drangle.c Normal file
View file

@ -0,0 +1,538 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#ifdef TIME
#include <time.h>
#endif
#include "inputfile.h"
#include "manglefn.h"
#include "defaults.h"
/* redefine default angular unit for output DR angles to radians */
#undef OUTUNIT
#define OUTUNIT 'r'
/* getopt options */
const char *optstr = "dqm:hs:e:u:p:i:";
/* allocate polygons as a global array */
polygon *poly_global[NPOLYSMAX];
/* declared in rdmask */
extern inputfile file;
/* local functions */
void usage(void);
#ifdef GCC
int drangle(char *, char *, char *, format *, int npoly, polygon *[npoly]);
#else
int drangle(char *, char *, char *, format *, int npoly, polygon *[/*npoly*/]);
#endif
/*------------------------------------------------------------------------------
Main program.
*/
int main(int argc, char *argv[])
{
char *th_in_filename;
int nfiles, np, npoly,i;
polygon **poly;
poly=poly_global;
/* set angular unit for output DR angles to default */
fmt.outunit = OUTUNIT;
/* parse arguments */
parse_args(argc, argv);
/* two or three input and one output filename required as arguments */
nfiles = argc - optind;
if (!(nfiles == 3 || nfiles == 4)) {
if (optind > 1 || nfiles >= 1) {
fprintf(stderr, "%s requires 3 arguments: polygon_infile, azel+th_infile, and dr_outfile\n", argv[0]);
fprintf(stderr, "%*s or 4 arguments: polygon_infile, azel_infile, th_infile, and dr_outfile\n", (int)strlen(argv[0]), " ");
usage();
exit(1);
} else {
usage();
exit(0);
}
}
/* summary option only possible with 3 input and 1 output files */
if (summary && nfiles != 4) {
fprintf(stderr, "%s with summary option -h requires 3 input files and 1 output file:\n", argv[0]);
fprintf(stderr, "%*s polygon_infile azel_infile th_infile dr_outfile\n", (int)strlen(argv[0]), " ");
usage();
exit(1);
}
msg("---------------- drangle ----------------\n");
/* advise data format */
advise_fmt(&fmt);
/* read polygons */
npoly = rdmask(argv[optind], &fmt, NPOLYSMAX, poly);
if (npoly == -1) exit(1);
if (npoly == 0) {
msg("STOP\n");
exit(0);
}
if (snapped==0 || balkanized==0) {
fprintf(stderr, "Error: input polygons must be snapped and balkanized before using drangle.\n");
fprintf(stderr, "If your polygons are already snapped and balkanized, add the 'snapped' and\n'balkanized' keywords at the beginning of each of your input polygon files.\n");
exit(1);
}
/* name of file containing angular radii th, if present */
th_in_filename = (nfiles == 3)? 0x0 : argv[optind + 2];
/* angles */
np = drangle(argv[optind + 1], th_in_filename, argv[argc - 1], &fmt, npoly, poly);
if (np == -1) exit(1);
for(i=0;i<npoly;i++){
free_poly(poly[i]);
}
return(0);
}
/*------------------------------------------------------------------------------
*/
void usage(void)
{
printf("usage:\n");
printf("drangle [-d] [-q] [-h] [-m<a>[u]] [-s<n>] [-e<n>] [-u<inunit>[,<outunit>]] [-p[+|-][<n>]] [-i<f>[<n>][u]] polygon_infile azel[th]_infile [th_infile] dr_outfile\n");
#include "usage.h"
}
/*------------------------------------------------------------------------------
*/
#include "parse_args.c"
/*------------------------------------------------------------------------------
Angles within mask along circles centred at az el, radii th.
Anglar positions az, el are read from azel_in_filename,
angular radii th are read from th_in_filename,
or from azel_in_filename if th_in_filename is null,
and the results are written to out_filename.
Implemented as interpretive read/write, to permit interactive behaviour.
Input: azel_in_filename = name of file to read az, el from;
"" or "-" means read from standard input.
th_in_filename = name of file to read th from;
null means read from azel_in_filename;
"-" means read from standard input.
out_filename = name of file to write to;
"" or "-" means write to standard output.
fmt = pointer to format structure.
npoly = number of polygons in poly array.
poly = array of pointers to polygons.
Return value: number of lines written,
or -1 if error occurred.
*/
int drangle(char *azel_in_filename, char *th_in_filename, char *out_filename, format *fmt, int npoly, polygon *poly[/*npoly*/])
{
#define AZEL_STR_LEN 32
char input[] = "input", output[] = "output";
/* maximum number of angular angular radii: will expand as necessary */
static int nthmax = 0;
static int ndrmax = 0;
static long double *th = 0x0, *cm = 0x0, *drsum = 0x0;
static long double *dr = 0x0;
#ifdef TIME
clock_t time;
#endif
char inunit, outunit;
char *word, *next;
char az_str[AZEL_STR_LEN], el_str[AZEL_STR_LEN], th_str[AZEL_STR_LEN], dr_str[AZEL_STR_LEN];
int ier, ird, ith, len, lenth, np, nt, nth;
long double rp[3], s, t;
azel v;
char *out_fn;
FILE *outfile;
inunit = (fmt->inunit == 'h')? 'd' : fmt->inunit;
/* read angular radii from th_in_filename */
if (th_in_filename) {
/* open th_in_filename for reading */
if (strcmp(th_in_filename, "-") == 0) {
file.file = stdin;
file.name = input;
} else {
file.file = fopen(th_in_filename, "r");
if (!file.file) {
fprintf(stderr, "cannot open %s for reading\n", th_in_filename);
return(-1);
}
file.name = th_in_filename;
}
file.line_number = 0;
msg("will take units of input th angles in %s to be ", file.name);
switch (inunit) {
#include "angunit.h"
}
msg("\n");
/* read angular radii from th_in_filename */
nth = 0;
while (1) {
/* read line */
ird = rdline(&file);
/* serious error */
if (ird == -1) return(-1);
/* EOF */
if (ird == 0) break;
/* read angular radius from line */
ird = rdangle(file.line, &next, inunit, &t);
/* error */
if (ird < 1) {
/* retry if nothing read, otherwise break */
if (nth > 0) break;
/* ok */
} else if (ird == 1) {
if (nth >= nthmax) {
if (nthmax == 0) {
nthmax = 64;
} else {
nthmax *= 2;
}
/* (re)allocate memory for th array */
th = (long double *) realloc(th, sizeof(long double) * nthmax);
if (!th) {
fprintf(stderr, "drangle: failed to allocate memory for %d long doubles\n", nthmax);
return(-1);
}
}
/* copy angular radius into th array */
th[nth] = t;
nth++;
}
}
if (file.file != stdin) {
/* close th_in_filename */
fclose(file.file);
/* advise */
msg("%d angular radii read from %s\n", nth, file.name);
}
if (nth == 0) return(nth);
/* (re)allocate memory for th array */
th = (long double *) realloc(th, sizeof(long double) * nth);
if (!th) {
fprintf(stderr, "drangle: failed to allocate memory for %d long doubles\n", nth);
return(-1);
}
/* (re)allocate memory for cm array */
cm = (long double *) realloc(cm, sizeof(long double) * nth);
if (!cm) {
fprintf(stderr, "drangle: failed to allocate memory for %d long doubles\n", nth);
return(-1);
}
/* (re)allocate memory for drsum array */
drsum = (long double *) realloc(drsum, sizeof(long double) * nth);
if (!drsum) {
fprintf(stderr, "drangle: failed to allocate memory for %d long doubles\n", nth);
return(-1);
}
nthmax = nth;
}
/* open azel_in_filename for reading */
if (!azel_in_filename || strcmp(azel_in_filename, "-") == 0) {
file.file = stdin;
file.name = input;
} else {
file.file = fopen(azel_in_filename, "r");
if (!file.file) {
fprintf(stderr, "cannot open %s for reading\n", azel_in_filename);
return(-1);
}
file.name = azel_in_filename;
}
file.line_number = 0;
/* open out_filename for writing */
if (!out_filename || strcmp(out_filename, "-") == 0) {
outfile = stdout;
out_fn = output;
} else {
outfile = fopen(out_filename, "w");
if (!outfile) {
fprintf(stderr, "cannot open %s for writing\n", out_filename);
return(-1);
}
out_fn = out_filename;
}
/* advise input angular units */
if (th_in_filename) {
msg("will take units of input az, el angles in %s to be ", file.name);
} else {
msg("will take units of input az, el, and th angles in %s to be ", file.name);
}
switch (fmt->inunit) {
#include "angunit.h"
}
if (!th_in_filename && fmt->inunit == 'h') {
msg(", th in deg");
}
msg("\n");
/* advise output angular unit */
outunit = (fmt->outunit == 'h')? 'd' : fmt->outunit;
msg("units of output DR angles will be ");
switch (outunit) {
#include "angunit.h"
}
msg("\n");
#ifdef TIME
printf("timing ... ");
fflush(stdout);
time = clock();
#endif
/* length of az, el and th, dr strings to be written to output */
t = 0.;
wrangle(t, fmt->inunit, fmt->outprecision, AZEL_STR_LEN, az_str);
len = strlen(az_str);
t = 0.;
wrangle(t, inunit, fmt->outprecision, AZEL_STR_LEN, th_str);
lenth = strlen(th_str);
/* write header */
if (!summary) {
if (fmt->inunit == 'h') {
sprintf(az_str, "az(hms)");
sprintf(el_str, "el(dms)");
sprintf(th_str, "th(d):");
} else {
sprintf(az_str, "az(%c)", fmt->inunit);
sprintf(el_str, "el(%c)", fmt->inunit);
sprintf(th_str, "th(%c):", fmt->inunit);
}
if (th_in_filename) {
fprintf(outfile, "%*s %*s %*s\n", len, " ", len, " ", lenth, th_str);
}
fprintf(outfile, "%*s %*s", len, az_str, len, el_str);
if (th_in_filename) {
for (ith = 0; ith < nth; ith++) {
wrangle(th[ith], inunit, fmt->outprecision, AZEL_STR_LEN, th_str);
fprintf(outfile, " %s", th_str);
}
fprintf(outfile, "\n");
} else {
fprintf(outfile, " %*s\n", lenth, th_str);
}
}
/* initialize th and drsum */
if (th_in_filename) {
/* convert th from input units to radians */
for (ith = 0; ith < nth; ith++) {
scale(&th[ith], inunit, 'r');
}
/* initialize sum of dr to zero */
for (ith = 0; ith < nth; ith++) {
drsum[ith] = 0.;
}
}
/* interpretive read/write loop */
np = 0;
nt = 0;
while (1) {
/* read line */
ird = rdline(&file);
/* serious error */
if (ird == -1) return(-1);
/* EOF */
if (ird == 0) break;
/* read <az> */
word = file.line;
ird = rdangle(word, &next, fmt->inunit, &v.az);
/* skip header */
if (ird != 1 && np == 0) continue;
/* otherwise exit on unrecognized characters */
if (ird != 1) break;
/* read <el> */
word = next;
ird = rdangle(word, &next, fmt->inunit, &v.el);
/* skip header */
if (ird != 1 && np == 0) continue;
/* otherwise exit on unrecognized characters */
if (ird != 1) break;
/* convert az and el from input units to radians */
scale_azel(&v, fmt->inunit, 'r');
/* read th */
if (!th_in_filename) {
nth = 0;
while (1) {
word = next;
ird = rdangle(word, &next, inunit, &t);
/* done */
if (ird < 1) break;
/* ok */
if (nth >= nthmax) {
if (nthmax == 0) {
nthmax = 64;
} else {
nthmax *= 2;
}
th = (long double *) realloc(th, sizeof(long double) * nthmax);
if (!th) {
fprintf(stderr, "drangle: failed to allocate memory for %d long doubles\n", nthmax);
return(-1);
}
/* (re)allocate memory for cm array */
cm = (long double *) realloc(cm, sizeof(long double) * nthmax);
if (!cm) {
fprintf(stderr, "drangle: failed to allocate memory for %d long doubles\n", nthmax);
return(-1);
}
}
th[nth] = t;
/* increment count of angular radii */
nth++;
}
/* convert th from input units to radians */
for (ith = 0; ith < nth; ith++) {
scale(&th[nth], inunit, 'r');
}
}
/* allocate memory for dr */
if (nth > ndrmax) {
ndrmax = nth;
dr = (long double *) realloc(dr, sizeof(long double) * ndrmax);
if (!dr) {
fprintf(stderr, "drangle: failed to allocate memory for %d long doubles\n", ndrmax);
return(-1);
}
}
/* unit vector corresponding to angular position az, el */
azel_to_rp(&v, rp);
/* limiting cm = 1-cosl(th) values to each polygon */
ier = cmlim_polys(npoly, poly, mtol, rp);
if (ier == -1) return(-1);
/* cm = 1 - cosl(th) */
for (ith = 0; ith < nth; ith++) {
s = sinl(th[ith] / 2.);
cm[ith] = 2. * s * s;
}
/* angles about rp direction at radii th */
ier = drangle_polys(npoly, poly, mtol, rp, nth, cm, dr);
if (ier == -1) return(-1);
/* sum of dr at radii th */
if (th_in_filename) {
for (ith = 0; ith < nth; ith++) {
drsum[ith] += dr[ith];
}
}
/* convert az and el from radians to original input units */
scale_azel(&v, 'r', fmt->inunit);
/* write result */
if (!summary) {
wrangle(v.az, fmt->inunit, fmt->outprecision, AZEL_STR_LEN, az_str);
wrangle(v.el, fmt->inunit, fmt->outprecision, AZEL_STR_LEN, el_str);
fprintf(outfile, "%s %s", az_str, el_str);
for (ith = 0; ith < nth; ith++) {
scale(&dr[ith], 'r', outunit);
wrangle(dr[ith], outunit, fmt->outprecision, AZEL_STR_LEN, dr_str);
fprintf(outfile, " %s", dr_str);
}
fprintf(outfile, "\n");
fflush(outfile);
}
/* increment counters of results */
np++;
nt += nth;
/* warn about a potentially huge output file */
if (np == 100 && !summary && th_in_filename && outfile != stdout) {
msg("hmm, looks like %s could grow pretty large ...\n", out_fn);
msg("try using the -h switch if you only want a summary in the output file\n");
}
}
/* write sum of dr */
if (summary) {
sprintf(th_str, "th(%c)", inunit);
sprintf(dr_str, "DR(%c)", outunit);
fprintf(outfile, "%*s %*s\n", lenth, th_str, lenth, dr_str);
for (ith = 0; ith < nth; ith++) {
scale(&th[ith], 'r', inunit);
wrangle(th[ith], inunit, fmt->outprecision, AZEL_STR_LEN, th_str);
scale(&drsum[ith], 'r', outunit);
wrangle(drsum[ith] / (long double)np, outunit, fmt->outprecision, AZEL_STR_LEN, dr_str);
fprintf(outfile, "%s %s\n", th_str, dr_str);
}
fflush(outfile);
} else if (th_in_filename) {
fprintf(outfile, "%*s", 2 * len + 1, "Average:");
for (ith = 0; ith < nth; ith++) {
scale(&drsum[ith], 'r', outunit);
wrangle(drsum[ith] / (long double)np, outunit, fmt->outprecision, AZEL_STR_LEN, dr_str);
fprintf(outfile, " %s", dr_str);
}
fprintf(outfile, "\n");
fflush(outfile);
}
/* close azel_in_filename */
if (file.file != stdin) {
fclose(file.file);
}
#ifdef TIME
time = clock() - time;
printf("done in %Lg sec\n", (float)time / (float)CLOCKS_PER_SEC);
#endif
/* advise */
if (outfile != stdout) {
fclose(outfile);
if (summary) {
msg("drangle: header + %d lines written to %s\n", nth, out_fn);
} else {
if (th_in_filename) {
msg("drangle: %d x %d = ", nth, np);
} else {
msg("drangle: total of ");
}
msg("%d angles at %d positions written to %s\n", nt, np, out_fn);
}
}
return(nt);
}

131
src/drangle_polys.c Normal file
View file

@ -0,0 +1,131 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include "manglefn.h"
#include "pi.h"
#define TWOPI (2. * PI)
static int *iord = 0x0;
static long double *cmmin = 0x0, *cmmax = 0x0;
/*------------------------------------------------------------------------------
Minimum and maximum values of cm = 1-cosl(th) between each of npoly polygons
and a unit vector rp.
Input: poly = array of pointers to npoly polygons.
npoly = number of polygons in poly array.
mtol = initial angular tolerance in radians within which to merge multiple intersections.
rp = unit vector.
Return value: number of polygons done;
-1 if error.
*/
int cmlim_polys(int npoly, polygon *poly[/*npoly*/], long double mtol, long double rp[3])
{
int ier, ipoly;
long double tol;
/* allocate memory for cmmin, cmmax, iord */
if (!cmmin) {
cmmin = (long double *) malloc(sizeof(long double) * npoly);
} else {
cmmin = (long double *) realloc(cmmin, sizeof(long double) * npoly);
}
if (!cmmin) {
fprintf(stderr, "cmlim_polys: failed to allocate memory for %d long doubles\n", npoly);
return(-1);
}
if (!cmmax) {
cmmax = (long double *) malloc(sizeof(long double) * npoly);
} else {
cmmax = (long double *) realloc(cmmax, sizeof(long double) * npoly);
}
if (!cmmax) {
fprintf(stderr, "cmlim_polys: failed to allocate memory for %d long doubles\n", npoly);
return(-1);
}
if (!iord) {
iord = (int *) malloc(sizeof(int) * npoly);
} else {
iord = (int *) realloc(iord, sizeof(int) * npoly);
}
if (!iord) {
fprintf(stderr, "cmlim_polys: failed to allocate memory for %d ints\n", npoly);
return(-1);
}
/* min, max distances between rp and each polygon */
for (ipoly = 0; ipoly < npoly; ipoly++) {
if (poly[ipoly]->weight == 0.) continue;
tol = mtol;
ier = gcmlim(poly[ipoly], &tol, rp, &cmmin[ipoly], &cmmax[ipoly]);
if (ier) return(-1);
}
/* order polygons in increasing order of cmmin */
findbot(cmmin, npoly, iord, npoly);
/* number of polygons done */
return(npoly);
}
/*------------------------------------------------------------------------------
Angles within mask along circle centred in unit direction rp, with radii th.
Input: poly = array of pointers to npoly polygons.
npoly = number of polygons in poly array.
mtol = initial angular tolerance in radians within which to merge multiple intersections.
rp = unit vector.
nth = number of angular radii.
cm = array of 1-cosl(angular radii).
Output: dr = array containing angles in radians.
Return value: number of angular radii done;
-1 if error.
*/
int drangle_polys(int npoly, polygon *poly[/*npoly*/], long double mtol, long double rp[3], int nth, long double cm[/*nth*/], long double dr[/*nth*/])
{
int ier, ip, ipoly, ith;
long double angle, tol;
/* angle within mask at each angular radius */
for (ith = 0; ith < nth; ith++) {
/* accumulate angle within each polygon */
dr[ith] = 0.;
for (ip = 0; ip < npoly; ip++) {
ipoly = iord[ip];
/* zero weight polygon contributes nothing */
if (poly[ipoly]->weight == 0.) continue;
if (cm[ith] <= fabsl(cmmin[ipoly])) {
/* polygon encloses circle */
if (cmmin[ipoly] < 0.) {
angle = TWOPI;
/* polygon excludes circle */
} else if (cmmin[ipoly] >= 0.) {
angle = 0.;
/* done, given that cmmin are in increasing order */
break;
}
} else if (cm[ith] >= fabsl(cmmax[ipoly])) {
/* circle and polygon enclose each other */
if (cmmax[ipoly] < 0.) {
angle = TWOPI;
/* circle encloses polygon */
} else if (cmmax[ipoly] >= 0.) {
angle = 0.;
}
} else {
/* circle intersects boundary of region */
tol = mtol;
ier = gphi(poly[ipoly], &tol, rp, cm[ith], &angle);
if (ier) return(-1);
}
dr[ith] += poly[ipoly]->weight * angle;
}
}
/* number of angular radii done */
return(nth);
}

39
src/dranglepolys_.c Normal file
View file

@ -0,0 +1,39 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdlib.h>
#include "manglefn.h"
/* polygons declared in rdmask_() */
extern int npolys;
extern polygon *polys[];
/*------------------------------------------------------------------------------
Simplified fortran interface to cmlim_polys routine.
real*8 mtol
real*8 rp(3)
call cmlimpolys(mtol, rp)
*/
void cmlimpolys_(long double *mtol, vec rp)
{
int ndone;
ndone = cmlim_polys(npolys, polys, *mtol, rp);
if (ndone == -1) exit(1);
}
/*------------------------------------------------------------------------------
Simplified fortran interface to drangle_polys routine.
real*8 mtol
real*8 rp(3)
integer nth
real*8 cm(nth),dr(nth)
call dranglepolys(mtol, rp, nth, cm, dr)
*/
void dranglepolys_(long double *mtol, vec rp, int *nth, long double cm[/**nth*/], long double dr[/**nth*/])
{
int ndone;
ndone = drangle_polys(npolys, polys, *mtol, rp, *nth, cm, dr);
if (ndone == -1) exit(1);
}

14
src/dump_poly.c Normal file
View file

@ -0,0 +1,14 @@
/*------------------------------------------------------------------------------
Š A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include "manglefn.h"
/*------------------------------------------------------------------------------
Dump polygon.
*/
void dump_poly(int npoly, polygon *poly[/*npoly*/])
{
char outfile[] = "jpoly";
wrmask(outfile, 0x0, npoly, poly);
}

21
src/felp.s.f Normal file
View file

@ -0,0 +1,21 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
real*10 function felp(epoch)
real*10 epoch
c
c parameters
include 'frames.par'
c local (automatic) variables
real*10 t
c *
c * Ecliptic latitude of NCP = Dec of ecliptic NP
c * as a function of epoch (e.g. 1950, 2000).
c *
c RA & Dec epoch in centuries since 1900
t=(epoch-1900._10)/100._10
c ecliptic latitude of NCP = Dec of ecliptic NP
felp=90._10-(E1+t*(E2+t*(E3+t*E4)))
return
end
c

185
src/fframe.s.f Normal file
View file

@ -0,0 +1,185 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine fframe(framei,azi,eli,framef,azf,elf)
integer framei,framef
real*10 azi,eli,azf,elf
c
c parameters
real*10 BEPOCH,JEPOCH
parameter (BEPOCH=1950._10,JEPOCH=2000._10)
include 'frames.par'
include 'radian.par'
c externals
real*10 felp,SLA_epj2d
c data variables
logical init
c saved local variables
real*10 azg,elg,elp,l2z
save azg,elg,elp,l2z
c local (automatic) variables
integer iaz
real*10 date,dd,dec2k,dr,ra2k
c *
c * Transform azimuth (phi) and elevation (90-theta) in degrees
c * from one frame to another frame.
c *
c * Subroutines beginning SLA_ are from the STARLINK SLA library.
c * Please respect their copyright.
c *
c * WARNING:
c * The 2000 transformations are done consistently with the SLA
c * library, while the 1950 transformations are done consistently
c * using the transformations actually used by the catalogue makers
c * (notably, IRAS mask is in 1950 ecliptic coordinates).
c * The 1950 and 2000 transformations do not commute exactly,
c * but the residuals are < 1 arcsec.
c *
c * WARNING:
c * The SDSS eta, lambda system is unconventional
c * (latitude <-> longitude, and longitude goes backwards).
c * This subroutine returns conventional quantities
c * azimuth = -eta
c * elevation = lambda.
c *
c Input: framei = initial frame, as defined in frames.par .
c azi = azimuth (longitude) in degrees wrt framei .
c eli = elevation (latitude) in degrees wrt framei .
c Output: framef = final frame, as defined in frames.par .
c azf = azimuth (longitude) in degrees wrt framef
c in interval [0,360).
c elf = elevation (latitude) in degrees wrt framef
c in interval [-90,90].
c
data init /.true./
c
c--------initialize
if (init) then
c ecliptic latitude of North Celestial Pole (1950 FK4)
elp=felp(BEPOCH)
c angles to transform between ecliptic and galactic coordinates
call azell(RAG,DECG,L2P,RAEZ,elp,EAZP,azg,elg,l2z)
init=.false.
endif
c--------initial and final frames identical
if (framei.eq.framef) then
azf=azi
elf=eli
c--------1950 frames ->
elseif (framei.eq.EQUATORIAL.or.framei.eq.ECLIPTIC) then
c........RA & Dec B1950.0 FK4 ->
if (framei.eq.EQUATORIAL) then
if (framef.eq.ECLIPTIC) then
call azel(azi,eli,RAEZ,elp,EAZP,azf,elf)
elseif (framef.eq.GALACTIC) then
call azel(azi,eli,RAG,DECG,L2P,azf,elf)
else
call SLA_fk45z(azi/RADIAN,eli/RADIAN,BEPOCH,ra2k,dec2k)
ra2k=ra2k*RADIAN
dec2k=dec2k*RADIAN
endif
c........Ecliptic 1950 ->
elseif (framei.eq.ECLIPTIC) then
if (framef.eq.EQUATORIAL) then
call azel(azi,eli,EAZP,elp,RAEZ,azf,elf)
elseif (framef.eq.GALACTIC) then
call azel(azi,eli,azg,elg,l2z,azf,elf)
else
date=SLA_epj2d(BEPOCH)
call SLA_ecleq(azi/RADIAN,eli/RADIAN,date,ra2k,dec2k)
ra2k=ra2k*RADIAN
dec2k=dec2k*RADIAN
endif
endif
c........-> 2000 frames
if (framef.eq.EQUATORIAL2K) then
azf=ra2k
elf=dec2k
elseif (framef.eq.ECLIPTIC2K) then
date=SLA_epj2d(JEPOCH)
call SLA_eqecl(ra2k/RADIAN,dec2k/RADIAN,date,azf,elf)
azf=azf*RADIAN
elf=elf*RADIAN
elseif (framef.eq.SDSS) then
call azel(ra2k,dec2k,RASDNP,DECSDNP,-ETANCP,azf,elf)
endif
c--------2000 frames ->
elseif (framei.eq.EQUATORIAL2K.or.framei.eq.ECLIPTIC2K
* .or.framei.eq.SDSS) then
c........initial frame -> RA & Dec 2000 FK5
if (framei.eq.EQUATORIAL2K) then
ra2k=azi
dec2k=eli
elseif (framei.eq.ECLIPTIC2K) then
date=SLA_epj2d(JEPOCH)
call SLA_ecleq(azi/RADIAN,eli/RADIAN,date,ra2k,dec2k)
ra2k=ra2k*RADIAN
dec2k=dec2k*RADIAN
elseif (framei.eq.SDSS) then
call azel(azi,eli,-ETANCP,DECSDNP,RASDNP,ra2k,dec2k)
endif
c........RA & Dec 2000 FK5 -> final frame
if (framef.eq.EQUATORIAL) then
call SLA_fk54z(ra2k/RADIAN,dec2k/RADIAN,BEPOCH,azf,elf,dr,dd)
azf=azf*RADIAN
elf=elf*RADIAN
elseif (framef.eq.ECLIPTIC) then
date=SLA_epj2d(BEPOCH)
call SLA_eqecl(ra2k/RADIAN,dec2k/RADIAN,date,azf,elf)
azf=azf*RADIAN
elf=elf*RADIAN
elseif (framef.eq.GALACTIC) then
call SLA_eqgal(ra2k/RADIAN,dec2k/RADIAN,azf,elf)
azf=azf*RADIAN
elf=elf*RADIAN
elseif (framef.eq.EQUATORIAL2K) then
azf=ra2k
elf=dec2k
elseif (framef.eq.ECLIPTIC2K) then
date=SLA_epj2d(JEPOCH)
call SLA_eqecl(ra2k/RADIAN,dec2k/RADIAN,date,azf,elf)
azf=azf*RADIAN
elf=elf*RADIAN
elseif (framef.eq.SDSS) then
call azel(ra2k,dec2k,RASDNP,DECSDNP,-ETANCP,azf,elf)
endif
c--------Galactic frame ->
elseif (framei.eq.GALACTIC) then
if (framef.eq.EQUATORIAL) then
c call SLA_ge50(azi/RADIAN,eli/RADIAN,azf,elf)
c azf=azf*RADIAN
c elf=elf*RADIAN
call azel(azi,eli,L2P,DECG,RAG,azf,elf)
elseif (framef.eq.ECLIPTIC) then
call azel(azi,eli,l2z,elg,azg,azf,elf)
else
call SLA_galeq(azi/RADIAN,eli/RADIAN,ra2k,dec2k)
if (framef.eq.EQUATORIAL2K) then
azf=ra2k*RADIAN
elf=dec2k*RADIAN
elseif (framef.eq.ECLIPTIC2K) then
date=SLA_epj2d(JEPOCH)
call SLA_eqecl(ra2k,dec2k,date,azf,elf)
azf=azf*RADIAN
elf=elf*RADIAN
elseif (framef.eq.SDSS) then
ra2k=ra2k*RADIAN
dec2k=dec2k*RADIAN
call azel(ra2k,dec2k,RASDNP,DECSDNP,-ETANCP,azf,elf)
endif
endif
endif
c--------put azf in interval [0,360)
iaz=azf/360._10
if (azf.lt.0._10) iaz=iaz-1
azf=azf-iaz*360._10
return
end
c

174
src/findtop.s.f Normal file
View file

@ -0,0 +1,174 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine findtop(a,na,iord,nb)
integer na,nb,iord(nb)
real*10 a(na)
c
c local (automatic) variables
integer i,ia,ib,it,n,ja
logical order
c *
c * Find nb elements of real*10 a having the largest value.
c * Returns index iord of these elements, ordered so iord(1) corresponds
c * to element a(iord(1)) having largest value.
c * If nb .gt. na, last nb-na elements of iord are undefined.
c * Elements of a that are equal are left in their original order.
c *
order(ia,ja)=a(ia).gt.a(ja).or.(a(ia).eq.a(ja).and.ia.lt.ja)
include 'heapsort.inc'
return
end
c
c-----------------------------------------------------------------------
subroutine findbot(a,na,iord,nb)
integer na,nb,iord(nb)
real*10 a(na)
c
c local (automatic) variables
integer i,ia,ib,it,n,ja
logical order
c *
c * Find nb elements of real*10 a having the smallest value.
c * Returns index iord of these elements, ordered so iord(1) corresponds
c * to element a(iord(1)) having smallest value.
c * If nb .gt. na, last nb-na elements of iord are undefined.
c * Elements of a that are equal are left in their original order.
c *
order(ia,ja)=a(ia).lt.a(ja).or.(a(ia).eq.a(ja).and.ia.lt.ja)
include 'heapsort.inc'
return
end
c
c-----------------------------------------------------------------------
subroutine findtpa(a,na,iord,nb)
integer na,nb,iord(nb)
real*10 a(na)
c
c intrinsics
intrinsic abs
c local (automatic) variables
integer i,ia,ib,it,n,ja
logical order
c *
c * Find nb elements of real*10 a having the largest absolute value.
c * Returns index iord of these elements, ordered so iord(1) corresponds
c * to element a(iord(1)) having largest absolute value.
c * If nb .gt. na, last nb-na elements of iord are undefined.
c * Elements of a equal in abs value are left in their original order.
c *
order(ia,ja)=abs(a(ia)).gt.abs(a(ja))
* .or.(abs(a(ia)).eq.abs(a(ja)).and.ia.lt.ja)
include 'heapsort.inc'
return
end
c
c-----------------------------------------------------------------------
subroutine findbta(a,na,iord,nb)
integer na,nb,iord(nb)
real*10 a(na)
c
c intrinsics
intrinsic abs
c local (automatic) variables
integer i,ia,ib,it,n,ja
logical order
c *
c * Find nb elements of real*10 a having the smallest absolute value.
c * Returns index iord of these elements, ordered so iord(1) corresponds
c * to element a(iord(1)) having smallest absolute value.
c * If nb .gt. na, last nb-na elements of iord are undefined.
c * Elements of a equal in abs value are left in their original order.
c *
order(ia,ja)=abs(a(ia)).lt.abs(a(ja))
* .or.(abs(a(ia)).eq.abs(a(ja)).and.ia.lt.ja)
include 'heapsort.inc'
return
end
c
c-----------------------------------------------------------------------
subroutine finitop(a,na,iord,nb)
integer na,nb,iord(nb)
integer a(na)
c
c local (automatic) variables
integer i,ia,ib,it,n,ja
logical order
c *
c * Find nb elements of integer a having the largest value.
c * Returns index iord of these elements, ordered so iord(1) corresponds
c * to element a(iord(1)) having largest value.
c * If nb .gt. na, last nb-na elements of iord are undefined.
c * Elements of a that are equal are left in their original order.
c *
order(ia,ja)=a(ia).gt.a(ja).or.(a(ia).eq.a(ja).and.ia.lt.ja)
include 'heapsort.inc'
return
end
c
c-----------------------------------------------------------------------
subroutine finibot(a,na,iord,nb)
integer na,nb,iord(nb)
integer a(na)
c
c local (automatic) variables
integer i,ia,ib,it,n,ja
logical order
c *
c * Find nb elements of integer a having the smallest value.
c * Returns index iord of these elements, ordered so iord(1) corresponds
c * to element a(iord(1)) having smallest value.
c * If nb .gt. na, last nb-na elements of iord are undefined.
c * Elements of a that are equal are left in their original order.
c *
order(ia,ja)=a(ia).lt.a(ja).or.(a(ia).eq.a(ja).and.ia.lt.ja)
include 'heapsort.inc'
return
end
c
c-----------------------------------------------------------------------
subroutine finitpa(a,na,iord,nb)
integer na,nb,iord(nb)
integer a(na)
c
c intrinsics
intrinsic abs
c local (automatic) variables
integer i,ia,ib,it,n,ja
logical order
c *
c * Find nb elements of integer a having the largest absolute value.
c * Returns index iord of these elements, ordered so iord(1) corresponds
c * to element a(iord(1)) having largest absolute value.
c * If nb .gt. na, last nb-na elements of iord are undefined.
c * Elements of a equal in abs value are left in their original order.
c *
order(ia,ja)=abs(a(ia)).gt.abs(a(ja))
* .or.(abs(a(ia)).eq.abs(a(ja)).and.ia.lt.ja)
include 'heapsort.inc'
return
end
c
c-----------------------------------------------------------------------
subroutine finibta(a,na,iord,nb)
integer na,nb,iord(nb)
integer a(na)
c
c intrinsics
intrinsic abs
c local (automatic) variables
integer i,ia,ib,it,n,ja
logical order
c *
c * Find nb elements of integer a having the smallest absolute value.
c * Returns index iord of these elements, ordered so iord(1) corresponds
c * to element a(iord(1)) having smallest absolute value.
c * If nb .gt. na, last nb-na elements of iord are undefined.
c * Elements of a equal in abs value are left in their original order.
c *
order(ia,ja)=abs(a(ia)).lt.abs(a(ja))
* .or.(abs(a(ia)).eq.abs(a(ja)).and.ia.lt.ja)
include 'heapsort.inc'
return
end
c

79
src/findtop_.c Normal file
View file

@ -0,0 +1,79 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include "manglefn.h"
/*------------------------------------------------------------------------------
c interface to fortran subroutines in findtop.s.f
*/
void findtop(long double a[], int na, int iord[], int nb)
{
int i;
findtop_(a, &na, iord, &nb);
/* convert from fortran to c convention */
for (i = 0; i < nb; i++) iord[i]--;
}
void findbot(long double a[], int na, int iord[], int nb)
{
int i;
findbot_(a, &na, iord, &nb);
/* convert from fortran to c convention */
for (i = 0; i < nb; i++) iord[i]--;
}
void findtpa(long double a[], int na, int iord[], int nb)
{
int i;
findtpa_(a, &na, iord, &nb);
/* convert from fortran to c convention */
for (i = 0; i < nb; i++) iord[i]--;
}
void findbta(long double a[], int na, int iord[], int nb)
{
int i;
findbta_(a, &na, iord, &nb);
/* convert from fortran to c convention */
for (i = 0; i < nb; i++) iord[i]--;
}
void finitop(int a[], int na, int iord[], int nb)
{
int i;
finitop_(a, &na, iord, &nb);
/* convert from fortran to c convention */
for (i = 0; i < nb; i++) iord[i]--;
}
void finibot(int a[], int na, int iord[], int nb)
{
int i;
finibot_(a, &na, iord, &nb);
/* convert from fortran to c convention */
for (i = 0; i < nb; i++) iord[i]--;
}
void finitpa(int a[], int na, int iord[], int nb)
{
int i;
finitpa_(a, &na, iord, &nb);
/* convert from fortran to c convention */
for (i = 0; i < nb; i++) iord[i]--;
}
void finibta(int a[], int na, int iord[], int nb)
{
int i;
finibta_(a, &na, iord, &nb);
/* convert from fortran to c convention */
for (i = 0; i < nb; i++) iord[i]--;
}

48
src/format.h Normal file
View file

@ -0,0 +1,48 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#ifndef FORMAT_H
#define FORMAT_H
#include <stdio.h>
/*
Structure defining format of data.
If your format needs more descriptives, shove 'em in here.
DON'T FORGET TO SET THE DEFAULT VALUES IN defaults.h,
AND TO UPDATE copy_format().
*/
typedef struct format_ {
char *in; /* keyword defining the input data format */
char *out; /* keyword defining the output data format */
size_t skip; /* skip first skip characters of each line */
size_t end; /* read only up to end'th character of each line */
char single; /* keyword defines precisely one polygon */
int n; /* the number of thingys defined by keyword */
int nn; /* the number of thingys per thingy */
int innve; /* the input number of points per edge */
int outper; /* controls interpretation of outnve */
int outnve; /* the output number of points per edge */
int id; /* id number of current polygon */
char newid; /* whether to use old or new id number */
int pixel; /* pixel that current polygon is in */
long double weight; /* weight of current polygon */
char inunitp; /* angular units of input polygon data */
char outunitp; /* angular units of output polygon data */
int inframe; /* angular frame of input az, el data */
int outframe; /* angular frame of output az, el data */
char inunit; /* angular units of input az, el data */
char outunit; /* angular units of output az, el data */
int outprecision; /* digits after decimal point in output angles */
char outphase; /* '-' or '+' to make output azimuth in interval (-pi, pi] or [0, 2 pi) */
long double azn; /* azimuth of new pole wrt original frame */
long double eln; /* elevation of new pole wrt original frame
= elevation of original pole wrt new frame */
long double azp; /* azimuth of original pole wrt new frame */
char trunit; /* angular units of transformation angles */
int nweights; /* the total number of weights/polygons, for use with healpix_weight input files and rasterize */
struct polygon_ *(*rd_poly_function)(struct format_ *, struct _inputfile *thisfile);
int auto_healpix;
} format;
#endif /* FORMAT_H */

48
src/frames.par Normal file
View file

@ -0,0 +1,48 @@
c-----------------------------------------------------------------------
c * Basic data relating angular reference frames
c........index to angular reference frame
integer UNKNOWN,
* EQUATORIAL,EQUATORIAL2K,GALACTIC,ECLIPTIC,ECLIPTIC2K,SDSS
parameter (
* UNKNOWN=0,
* EQUATORIAL=1,
* EQUATORIAL2K=2,
* GALACTIC=3,
* ECLIPTIC=4,
* ECLIPTIC2K=5,
* SDSS=6
* )
c........equatorial (RA & Dec) 1950 <-> galactic
real*10 RAG,DECG,L2P
parameter (
c RA & Dec of galactic north pole in deg
* RAG=192.25_10,DECG=27.4_10,
c galactic longitude of NCP in deg; note b2p=decg
* L2P=123._10)
c........equatorial <-> ecliptic
c Ecliptic latitude of NCP depends on epoch (e.g. 1950, 2000);
c real*10 function felp(epoch) gives ecliptic latitude of NCP.
c coefficients of expansion of ecliptic latitude of NCP
real*10 E1,E2,E3,E4
parameter (E1=23.452294_10,E2=-1.30125e-2_10,
* E3=-1.64e-6_10,E4=5.03e-7_10)
real*10 EAZP,RAEZ
parameter (
c ecliptic longitude of NCP in deg
* EAZP=90._10,
c RA of ecliptic NP in deg
* RAEZ=270._10)
c........equatorial 2000 <-> SDSS
real*10 RASDNP,DECSDNP,ETANCP
parameter (
c RA, Dec J2000 FK5 of SDSS NP (lambda=90 deg) in deg
* RASDNP=275._10,DECSDNP=0._10,
c SDSS longitude (eta) of North Celestial Pole in deg
c ETANCP is per the SDSS convention, which is minus the normal
c convention for longitudes!
* ETANCP=57.2_10)

103
src/garea.c Normal file
View file

@ -0,0 +1,103 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include "logical.h"
#include "manglefn.h"
/* number of extra caps to allocate to polygon, to allow for expansion */
#define DNP 4
/*------------------------------------------------------------------------------
Area of polygon.
This is a c interface to fortran subroutine garea.
Input: poly is a polygon.
verb = 0 to suppress messages from garea, even fatal ones;
1 to allow messages from garea.
Input/Output: *tol = angle within which to merge multiple intersections.
Output: *area = area of polygon.
Return value: 0 if ok;
1 if fatal error;
-1 if failed to allocate memory.
*/
int garea(polygon *poly, long double *tol, int verb, long double *area)
{
polygon *dpoly = 0x0;
logical ldegen;
int ier, ipmin, ipoly, np;
long double cmmin, darea;
/* work arrays */
int *iord;
long double *phi;
/* smallest cap of polygon */
cmminf(poly, &ipmin, &cmmin);
/* number of caps in polygon to be passed to garea_ */
np = (poly->np >= 2 && cmmin > 1.)? poly->np + 1 : poly->np;
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * np * 2);
if (!iord) {
fprintf(stderr, "garea: failed to allocate memory for %d ints\n", np * 2);
return(-1);
}
phi = (long double *) malloc(sizeof(long double) * np * 2);
if (!phi) {
fprintf(stderr, "garea: failed to allocate memory for %d long doubles\n", np * 2);
return(-1);
}
/* <= 1 caps, or smallest cap has area <= pi */
if (np == poly->np) {
/* fortran routine */
garea_(area, poly->rp, poly->cm, &poly->np, tol, &verb, phi, iord, &ldegen);
/* >= 2 caps, and smallest cap has area > pi */
} else {
/* make sure dpoly contains enough space */
ier = room_poly(&dpoly, np, DNP, 0);
if (ier == -1) {
fprintf(stderr, "garea: failed to allocate memory for polygon of %d caps\n", np + DNP);
return(-1);
}
/* make polygon dpoly with extra cap */
poly_polyn(poly, poly, ipmin, 1, dpoly);
/* make the extra cap 1/2 the area of the smallest cap */
dpoly->cm[poly->np] = cmmin / 2.;
/* zero area */
*area = 0.;
for (ipoly = 0; ipoly < 2; ipoly++) {
/* fortran routine */
garea_(&darea, dpoly->rp, dpoly->cm, &dpoly->np, tol, &verb, phi, iord, &ldegen);
/* accumulate area */
*area += darea;
/* fatal error */
if (ldegen) break;
/* the complement of the extra cap */
dpoly->cm[poly->np] = - dpoly->cm[poly->np];
}
}
/* free work arrays */
free(iord);
free(phi);
/* fatal error */
if (ldegen){
fprintf(stderr,"garea: fatal error in polygon %d, pixel %d\n", poly->id,poly->pixel);
return(1);
}
return(0);
}

287
src/garea.s.f Normal file
View file

@ -0,0 +1,287 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine garea(area,rp,cm,np,tol,verb,phi,iord,ldegen)
integer np,verb
logical ldegen
real*10 area,rp(3,np),cm(np),tol
c work arrays (could be automatic if compiler supports it)
integer iord(2*np)
real*10 phi(2,np)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c intrinsics
intrinsic abs
c externals
integer garpi,gsegij,gzeroar
c data variables
real*10 big
real*10 dphmin
c local variables
integer i,iarea,ik,iseg,j,jm,jml,jmu,jp,jpl,jpu,k,km,kp,l,
* nbd,nbd0m,nbd0p,ni,nmult,retry,scmi
C logical warn
logical whole
real*10 bik,cmi,cmik,cmk,d,darea,dph,ikchk,ikran,
* ph,phm,php,psi,si,tolin,xi(3),yi(3)
c *
c * Area of surface of sphere of unit radius bounded by
c * 1 - r.rp(i) < cm(i) (if cm(i).ge.0)
c * 1 - r.rp(i) > -cm(i) (if cm(i).lt.0)
c * for i=1,np where rp(i) are unit directions.
c * See AJSH notes Multfn C115.
c * Cautions:
c * (1) This subroutine underestimates the area by 2*pi
c * if 2*pi <= area < 4*pi
c * and the area is bounded by more than one arc.
c * (2) This subroutine will usually work correctly when there are near
c * multiple (.ge. 3) intersections of boundaries, but in rare
c * instances it may fail. If so, it should flag the failure with
c * ldegen=.true. This error condition should NOT be ignored.
c *
c Input: rp(3,i),i=1,np
c cm(i),i=1,np
c np
c verb
c Output: area
c ldegen = .true. means there's a problem with multiply
c intersecting boundary.
c Input/Output: tol
c Work arrays: phi and iord should be dimensioned at least 2*np
c
c set azimuthal angle of non-intersection to big
data big /1.e6_10/
c possible multiple intersection when dph < dphmin
data dphmin /1.e-8_10/
c
c input tolerance to multiple intersections
tolin=tol
C print *,'--------------------'
c come here with modified tolerance to multiple intersections
100 continue
C write (*,'(a3,a20,4a24)')
C * ' ','x','y','z',
c * 'r',
C * '1-c'
C do j=1,np
C write (*,'(i3,5g24.16)')
C * j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
C * cm(j)
C enddo
c initialise error flag to no error
ldegen=.false.
C warn=.false.
c initialize count of near multiple intersections to zero
nmult=0
c zero area
area=0._10
c check for zero area because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
c no constraints at all will mean area is whole sphere
whole=.true.
c number of intersecting arc segments bounding area
nbd=0
c number of non-intersecting circles bounding area
nbd0m=0
nbd0p=0
c error check on evaluation of vertex terms
ikchk=0._10
c--------identify boundary segments around each circle i in turn
do 280 i=1,np
c cm(i).ge.2 means include whole sphere, which is no constraint
if (cm(i).ge.2._10) goto 280
c there is a constraint, so area is not whole sphere
whole=.false.
c scmi * cmi = 1-cos th(i)
if (cm(i).ge.0._10) then
scmi=1
else
scmi=-1
endif
cmi=abs(cm(i))
c si = sin th(i)
si=sqrt(cmi*(2._10-cmi))
c........construct cartesian axes with z-axis along rp(i)
call gaxisi(rp(1,i),xi,yi)
c........angles phi about z-axis rp(i) of intersection of i & j circles
call gphij(rp,cm,np,i,rp(1,i),scmi,cmi,xi,yi,big,tol,ni,phi)
c i circle lies outside polygon
if (ni.eq.-1) goto 280
c area of polygon is zero
if (ni.eq.-2) then
c area can be non-zero from psi at multiple intersections
area=0._10
goto 410
endif
c........i circle has no intersections
if (ni.eq.0) then
if (scmi.ge.0) then
nbd0p=nbd0p+1
else
nbd0m=nbd0m+1
endif
darea=cm(i)*TWOPI
area=area+darea
C print *,'at',i,': full circle area +=',darea,' =',area
c........i circle has intersections
elseif (ni.gt.0) then
c find ordering of intersection angles around i circle
call findbot(phi,2*np,iord,ni)
C write (*,'("phi")')
C write (*,'(i4,2g24.16)') (j,(phi(k,j),k=1,2),j=1,np)
c........contribution to area from each segment of i circle
jpl=0
c come here to do another segment
220 continue
c........is segment edge of polygon?
iseg=gsegij(rp,cm,np,0,0,i,rp(1,i),scmi,cmi,tol,ni,
* phi,iord,jml,jmu,jpl,jpu,1,jm,jp,km,kp,phm,php,ph,dph)
C print *,'at',i,': iseg =',iseg
c error
if (iseg.eq.-1) goto 420
c not an edge
if (iseg.eq.0) goto 220
c gone full circle
if (iseg.eq.2) goto 280
c near multiple intersection
if (dph.lt.dphmin) then
c increment count of near multiple intersections
nmult=nmult+1
C warn=.true.
C print *,
C * '*** warning from garea: near multiple intersection at',
C * i,': edge',km,kp,' dph =',dph
endif
c........segment satisfies conditions
nbd=nbd+1
c there's a contribution to area from the segment...
if (scmi.lt.0) dph=-dph
darea=cmi*dph-dph
area=area+darea
C print *,'at',i,': edge',km,kp,
C * ' (',jm,' in',jml,jmu,',',jp,' in',jpl,jpu,' of',ni,')'
C print *,'dph =',dph,' area +=',darea,' =',area
c ...and from the end points of the segment
do 240 l=1,2
c end point is intersection of i circle with k circle
if (l.eq.1) then
k=km
elseif (l.eq.2) then
k=kp
endif
c only do ik intersection once,
c but check both ik and ki intersections made it here
c from segment k to segment i right-handedly through vertex
if ((l.eq.1.and.scmi.ge.0).or.(l.eq.2.and.scmi.lt.0)) then
ik=k+np*i
if (k.lt.i) ik=ik+1
c from segment i to segment k right-handedly through vertex
else
ik=i+np*k
if (i.lt.k) ik=ik+1
endif
c pseudo-random number from ik
call ikrand(ik,ikran)
if (i.gt.k) then
c ikchk = ikchk - ikran, subtracted as unsigned long long's
call ikrandm(ikchk,ikran)
C print *,' (intersect',i,k,')'
goto 240
endif
c ikchk = ikchk + ikran, added as unsigned long long's
call ikrandp(ikchk,ikran)
cmk=abs(cm(k))
c cmik = 1-cos th(ik)
cmik=((rp(1,i)-rp(1,k))**2+(rp(2,i)-rp(2,k))**2
* +(rp(3,i)-rp(3,k))**2)/2._10
c bik = cik-ci*ck
c d = 1-ci^2-ck^2-cik^2+2*ci*ck*cik
c cos psi = bik/(si*sk)
c sin psi = sqrt(d)/(si*sk)
c psi = atan(sqrt(d)/bik) is exterior angle at intersection
bik=(cmi+cmk)-cmi*cmk-cmik
if ((scmi.ge.0.and.cm(k).lt.0._10)
* .or.(scmi.lt.0.and.cm(k).ge.0._10)) bik=-bik
c i and k circles kiss
if (phi(1,k).eq.phi(2,k)) then
d=0._10
else
d=-(cmi-cmk)**2+cmik*(2._10*((cmi+cmk)-cmi*cmk)-cmik)
c assert that circles at least touch
if (d.lt.0._10) d=0._10
d=sqrt(d)
endif
psi=atan2(d,bik)
area=area-psi
C print *,' intersect',i,k,' area +=',-psi,' =',area
240 continue
c do another segment
goto 220
endif
280 continue
c--------check on whether ik endpoints matched ki endpoints
if (ikchk.ne.0._10) then
C warn=.true.
C print *,'*** from garea: at tol =',tol,
C * ', ikchk=',ikchk,' should be 0'
c write (*,'(a3,a20,3a24)')
c * ' ','x','y','z','1-c'
c write (*,'(i3,4g24.16)')
c * (j,(rp(i,j),i=1,3),
c * cm(j),j=1,np)
c retry with modified tolerance
call gtol(tol,tolin)
goto 100
elseif (tol.gt.0._10) then
C print *,'... from garea: success at tol =',tol
endif
c--------add/subtract 2*pi's to area
retry=garpi(area,iarea,rp,cm,np,whole,nbd0m,nbd0p,nbd,nmult)
c retry with modified tolerance
if (retry.eq.1) then
C warn=.true.
call gtol(tol,tolin)
goto 100
endif
c--------done
410 continue
C if (warn) then
C write (*,'(a3,a20,4a24)')
C * ' ','x','y','z',
c * 'r',
C * '1-c'
C do j=1,np
C write (*,'(i3,5g24.16)')
C * j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
C * cm(j)
C enddo
C endif
C print *,'final area =',area
C print *,'....................'
return
c
420 continue
c if (verb.ge.1) then
print *,'*** from garea: total failure at tol =',tol
write (*,'(a3,a20,4a24)')
* ' ','x','y','z',
c * 'r',
* '1-c'
do j=1,np
write (*,'(i3,5g24.16)')
* j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
* cm(j)
enddo
c endif
C print *,'....................'
ldegen=.true.
return
c
end
c

100
src/gaream.s.f Normal file
View file

@ -0,0 +1,100 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gaream(area,areat,rp,cm,np,tol,verb,npg,npp,
* cmimin,cmimax,phi,iord,ldegen)
integer np,verb,npg,npp,iord(np)
logical ldegen
real*10 area,areat,rp(3,np),cm(np),tol,cmimin,cmimax,phi(2,np)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c intrinsics
intrinsic abs
c *
c * Same as garea, but speed up matters by checking first whether
c * cm(npg) or cm(npp) lie outside |cmimin| and |cmimax|,
c * giving simpler result.
c * cmimin and cmimax are gotten from prior call to gcmlim.
c *
c * Note this subroutine assumes, without checking, that:
c * if np.eq.npg,
c * then cm(npg).ge.0;
c * elseif np.eq.npp,
c * then cm(npg).ge.0 & cm(npp).lt.0 & rp(.,npg)=rp(.,npp).
c *
c sphere
if (np.eq.npg) then
if (cm(npg).le.abs(cmimin)) then
c region excludes sphere
if (cmimin.ge.0._10) then
area=0._10
c region encloses sphere
elseif (cmimin.lt.0._10) then
area=TWOPI*cm(npg)
endif
elseif (cm(npg).ge.abs(cmimax)) then
c sphere encloses region
if (cmimax.ge.0._10) then
area=areat
c sphere and region enclose each other
elseif (cmimax.lt.0._10) then
area=areat-TWOPI*(2._10-cm(npg))
endif
c sphere intersects boundary of region
else
call garea(area,rp,cm,np,tol,verb,phi,iord,ldegen)
endif
c annulus
elseif (np.eq.npp) then
c region is null
if (cm(npg).le.-cm(npp)) then
area=0._10
elseif (cm(npg).le.abs(cmimin)) then
c region excludes annulus
if (cmimin.ge.0._10) then
area=0._10
c region encloses annulus
elseif (cmimin.lt.0._10) then
area=TWOPI*(cm(npg)+cm(npp))
endif
elseif (-cm(npp).ge.abs(cmimax)) then
c annulus encloses region
if (cmimax.ge.0._10) then
area=0._10
c annulus and region enclose each other
elseif (cmimax.lt.0._10) then
area=TWOPI*(cm(npg)+cm(npp))
endif
elseif (cm(npg).ge.abs(cmimax)
* .and.-cm(npp).le.abs(cmimin)) then
if (cmimin.ge.0._10) then
c annulus contains region
if (cmimax.ge.0._10) then
area=areat
c outer ring of annulus and region enclose each other
elseif (cmimax.lt.0._10) then
area=areat-TWOPI*(2._10-cm(npg))
endif
elseif (cmimin.lt.0._10) then
c inner ring of annulus and region enclose each other
if (cmimax.ge.0._10) then
area=areat-TWOPI*(2._10+cm(npp))
c annulus and region enclose each other
elseif (cmimax.lt.0._10) then
area=areat-TWOPI*(2._10-cm(npg)-cm(npp))
endif
endif
c annulus intersects boundary of region
else
call garea(area,rp,cm,np,tol,verb,phi,iord,ldegen)
endif
c np .ne. npg or npp
else
call garea(area,rp,cm,np,tol,verb,phi,iord,ldegen)
endif
return
end
c

47
src/gcmlim.c Normal file
View file

@ -0,0 +1,47 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include "manglefn.h"
/*------------------------------------------------------------------------------
Minimum and maximum values of cm = 1-cosl(th) between polygon
and a unit vector rp.
This is a c interface to fortran subroutine gcmlim.
Input: poly is a polygon.
*tol = angle within which to merge multiple intersections.
rp = unit vector.
Output: minimum and maximum values of cm = 1-cosl(th).
Return value: 0 if ok;
-1 if failed to allocate memory.
*/
int gcmlim(polygon *poly, long double *tol, vec rp, long double *cmmin, long double *cmmax)
{
/* work arrays */
int *iord;
long double *phi;
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * poly->np * 2);
if (!iord) {
fprintf(stderr, "gcmlim: failed to allocate memory for %d ints\n", poly->np * 2);
return(-1);
}
phi = (long double *) malloc(sizeof(long double) * poly->np * 2);
if (!phi) {
fprintf(stderr, "gcmlim: failed to allocate memory for %d long doubles\n", poly->np * 2);
return(-1);
}
/* fortran routine */
gcmlim_(poly->rp, poly->cm, &poly->np, rp, cmmin, cmmax, tol, phi, iord);
/* free work arrays */
free(iord);
free(phi);
return(0);
}

155
src/gcmlim.s.f Normal file
View file

@ -0,0 +1,155 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gcmlim(rp,cm,np,rpi,cmimin,cmimax,tol,phi,iord)
integer np
real*10 rp(3,np),cm(np),rpi(3),cmimin,cmimax,tol
c work arrays (could be automatic if compiler supports it)
integer iord(2*np)
real*10 phi(2,np)
c
c parameters
include 'pi.par'
c intrinsics
intrinsic abs
c externals
integer gsegij,gzeroar
c data variables
real*10 big
c local variables
integer i,iseg,jm,jml,jmu,jp,jpl,jpu,ni,scmi
integer km,kp
logical inmax,inmin
real*10 cmi,cmik,cmim,dph,ph,phm,php,phimax,phimin,
* si,sik,xi(3),yi(3)
c *
c * Minimum and maximum values of cmi = 1-cos(th)
c * between unit direction rpi
c * and surface of sphere of unit radius bounded by
c * 1 - r.rp(i) < cm(i) (if cm(i).ge.0)
c * 1 - r.rp(i) > -cm(i) (if cm(i).lt.0)
c * for i=1,np where rp(i) are unit directions.
c *
c Input: rp(3,i),i=1,np
c cm(i),i=1,np
c np
c rpi(3)
c tol
c Output: cmimin, cmimax = min, max values of cmi
c < 0 means region encloses limiting circle
c > 0 means region excludes limiting circle
c Work arrays: phi and iord should be dimensioned at least 2*np
c
data big /1.e6_10/
c
c check for zero area because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
cmimin=2._10
cmimax=0._10
inmin=.true.
inmax=.true.
c--------identify boundary segments around each circle i in turn
do 280 i=1,np
c cm(i).ge.2 means include whole sphere, which is no constraint
if (cm(i).ge.2._10) goto 280
c scmi * cmi = 1-cos th(i)
if (cm(i).ge.0._10) then
scmi=1
else
scmi=-1
endif
cmi=abs(cm(i))
c si = sin th(i)
si=sqrt(cmi*(2._10-cmi))
c cmik = 1-cos th(ik), th(ik)=angle twixt rpi & rp(i)
cmik=((rpi(1)-rp(1,i))**2+(rpi(2)-rp(2,i))**2
* +(rpi(3)-rp(3,i))**2)/2._10
c sik = sin th(ik)
sik=sqrt(cmik*(2._10-cmik))
c min circle is outside area
if ((cm(i).ge.0._10.and.cmik.ge.cmi)
* .or.(cm(i).lt.0._10.and.cmik.le.cmi)) inmin=.false.
c max circle is outside area
if ((cm(i).ge.0._10.and.cmik.le.2._10-cmi)
* .or.(cm(i).lt.0._10.and.cmik.ge.2._10-cmi)) inmax=.false.
c........cartesian axes with z-axis along rp(i), x-axis towards rpi
call gaxisii(rpi,rp(1,i),xi,yi)
c........angles phi about z-axis rp(i) of intersection of i & j circles
call gphij(rp,cm,np,i,rp(1,i),scmi,cmi,xi,yi,big,tol,ni,phi)
c i circle lies outside polygon
if (ni.eq.-1) goto 280
c area of polygon is zero
if (ni.eq.-2) goto 410
c........i circle has no intersections
if (ni.eq.0) then
c reduce cmimin?
cmim=cmi+cmik-cmi*cmik-si*sik
if (cmim.lt.cmimin) cmimin=cmim
c increase cmimax?
cmim=cmi+cmik-cmi*cmik+si*sik
if (cmim.gt.cmimax) cmimax=cmim
c........i circle has intersections
elseif (ni.gt.0) then
c find ordering of intersection angles around i circle
call findbot(phi,2*np,iord,ni)
c phimin, max are nearest, furthest points from rpi
phimin=big
phimax=big
c........vertices around i circle
jpl=0
c come here to do another segment
220 continue
c........is segment edge of polygon?
iseg=gsegij(rp,cm,np,0,0,i,rp(1,i),scmi,cmi,tol,ni,
* phi,iord,jml,jmu,jpl,jpu,1,jm,jp,km,kp,phm,php,ph,dph)
c error
if (iseg.eq.-1) goto 420
c not an edge
if (iseg.eq.0) goto 220
c gone full circle
if (iseg.eq.2) goto 240
if (php.ge.phm) then
c segment contains nearest point in i circle, phi=0
if (phm.le.0._10.and.php.ge.0._10) phimin=0._10
elseif (php.lt.phm) then
c segment contains nearest point in i circle, phi=0
if (phm.le.0._10.or.php.ge.0._10) phimin=0._10
c segment contains furthest point in i circle, phi=pi
phimax=0._10
endif
c check if segment endpoints tighten limits
phm=abs(phm)
php=abs(php)
if (phm.lt.phimin) phimin=phm
if (php.lt.phimin) phimin=php
if (PI-phm.lt.phimax) phimax=PI-phm
if (PI-php.lt.phimax) phimax=PI-php
c do another segment
goto 220
c reduce cmimin?
240 if (phimin.ne.big) then
cmim=cmi+cmik-cmi*cmik-si*sik*cos(phimin)
if (cmim.lt.cmimin) cmimin=cmim
endif
c increase cmimax?
if (phimax.ne.big) then
cmim=cmi+cmik-cmi*cmik+si*sik*cos(phimax)
if (cmim.gt.cmimax) cmimax=cmim
endif
endif
280 continue
c region encloses limiting circle
if (inmin) cmimin=-cmimin
if (inmax) cmimax=-cmimax
return
c
c null area
410 cmimin=2._10
cmimax=2._10
return
c
420 print *,'*** from gmclim: total failure at tol =',tol
return
c
end
c

350
src/get_pixel.c Normal file
View file

@ -0,0 +1,350 @@
/*------------------------------------------------------------------------------
© M E C Swanson 2005
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdlib.h>
#include "pi.h"
#include "manglefn.h"
/* Function get_pixel takes a pixel number and returns a pointer to a polygon
containing that pixel.
inputs:
pix: pixel number
scheme: pixelization scheme
returns pointer to polygon containing pixel, or 0x0 if an error occurs
*/
polygon *get_pixel(int pix, char scheme){
int m,n,res,base_pix,i,ier,pix_c[4];
long double azmax, azmin, elmax, elmin;
long double lammin, lammax, etamin, etamax;
long double angle[4], lammin_c[4], lammax_c[4], etamin_c[4], etamax_c[4];
azel v[4],v_r[4];
polygon *pixel;
if(pix<0){
fprintf(stderr, "error in get_pixel: %d not a valid pixel number.\n", pix);
return(0x0);
}
res=get_res(pix,scheme);
if(res==-1) return (0x0);
if(scheme=='s'){
// this scheme divides up the sphere by rectangles in az and el, and is numbered
// such that the resolution is encoded in each pixel number. The whole sky is pixel 0,
// pixels 1, 2, 3, and 4 are each 1/4 of the sky (resolution 1), pixels 5-20 are each
// 1/16 of the sky (resolution 2), etc.
base_pix=pix-pixel_start(res,scheme);
m=base_pix % (int)(powl(2,res));
n=(base_pix-m)/powl(2,res);
azmin=TWOPI/powl(2,res)*m;
azmax=TWOPI/powl(2,res)*(m+1);
elmin=asinl(1-2.0/powl(2,res)*(n+1));
elmax=asinl(1-2.0/powl(2,res)*n);
angle[0]=azmin;
angle[1]=azmax;
angle[2]=elmin;
angle[3]=elmax;
pixel=new_poly(4);
if (!pixel) {
fprintf(stderr, "error in get_pixel: failed to allocate memory for polygon of 4 caps\n");
return(0x0);
}
// printf("az range: %Lf - %Lf, el range: %Lf - %Lf\n", azmin, azmax, elmin,elmax);
rect_to_poly(angle,pixel);
pixel->pixel=pix;
if(!pixel){
fprintf(stderr, "error in get_pixel: polygon is NULL.\n");
}
return(pixel);
}
else if(scheme=='d'){
//this is the SDSSPix pixelization scheme; see http://lahmu.phyast.pitt.edu/~scranton/SDSSPix/
//for more details
assign_parameters();
if(res==0){
pixel=new_poly(0);
pixel->weight=1.;
pixel->pixel=0;
return(pixel);
}
else if(res==1){
ier = get_child_pixels(pix, pix_c, scheme);
if(ier==1){
fprintf(stderr, "error in get_pixel: get_child_pixels failed\n");
return(0x0);
}
for(i=0;i<=3;i++){
pix_bound(1, (unsigned long)pix_c[i] - (unsigned long)pixel_start(2, scheme), &lammin_c[i], &lammax_c[i], &etamin_c[i], &etamax_c[i]);
}
for(i=0;i<=3;i++){
if(lammin_c[i]<=lammin_c[(i+1)%4] && lammin_c[i]<=lammin_c[(i+2)%4] && lammin_c[i]<=lammin_c[(i+3)%4]) lammin=lammin_c[i];
if(lammax_c[i]>=lammax_c[(i+1)%4] && lammax_c[i]>=lammax_c[(i+2)%4] && lammax_c[i]>=lammax_c[(i+3)%4]) lammax=lammax_c[i];
if(etamin_c[i]<=etamin_c[(i+1)%4] && etamin_c[i]<=etamin_c[(i+2)%4] && etamin_c[i]<=etamin_c[(i+3)%4]) etamin=etamin_c[i];
if(etamax_c[i]>=etamax_c[(i+1)%4] && etamax_c[i]>=etamax_c[(i+2)%4] && etamax_c[i]>=etamax_c[(i+3)%4]) etamax=etamax_c[i];
}
/* fix pixels which span eta=0 */
for(i=0;i<=5;i++){
if(pix==9+18*i || pix==113){
etamin=etamin_c[0];
etamax=etamax_c[3];
}
}
if(lammin < -90.) lammin = -90.;
if(lammax > 90.) lammax = 90.;
if(etamin < 0.) etamin += 360.;
if(etamax > 360.) etamax -= 360.;
lammin *= (PI/180.0);
lammax *= (PI/180.0);
etamin *= (PI/180.0);
etamax *= (PI/180.0);
angle[0]=etamin;
angle[1]=etamax;
angle[2]=lammin;
angle[3]=lammax;
pixel=new_poly(4);
if (!pixel) {
fprintf(stderr, "error in get_pixel: failed to allocate memory for polygon of 4 caps\n");
return(0x0);
}
rect_to_poly(angle,pixel);
pixel->pixel=pix;
if(!pixel){
fprintf(stderr, "error in get_pixel: polygon is NULL.\n");
return(0x0);
}
for(i=0;i<pixel->np;i++){
rp_to_azel(pixel->rp[i], &(v[i]));
v[i].az *= (180./PI);
v[i].el *= (180./PI);
if(v[i].az < -180.) v[i].az += 360.;
if(v[i].az > 180.) v[i].az -= 360.;
if(v[i].el < -90.) v[i].el = -90.;
if(v[i].el > 90.) v[i].el = 90.;
csurvey2eq(v[i].el, v[i].az, &(v_r[i].az), &(v_r[i].el));
if(v_r[i].az < 0.) v_r[i].az += 360.;
if(v_r[i].az > 360.) v_r[i].az -= 360.;
if(v_r[i].el < -90.) v_r[i].el = -90.;
if(v_r[i].el > 90.) v_r[i].el = 90.;
v_r[i].az *= (PI/180.);
v_r[i].el *= (PI/180.);
azel_to_rp(&(v_r[i]), pixel->rp[i]);
}
return(pixel);
}
else{
pix_bound((int)powl(2,res-2), (unsigned long)pix - (unsigned long)pixel_start(res, scheme), &lammin, &lammax, &etamin, &etamax);
if(lammin < -90.) lammin = -90.;
if(lammax > 90.) lammax = 90.;
if(etamin < 0.) etamin += 360.;
if(etamax > 360.) etamax -= 360.;
lammin *= (PI/180.0);
lammax *= (PI/180.0);
etamin *= (PI/180.0);
etamax *= (PI/180.0);
angle[0]=etamin;
angle[1]=etamax;
angle[2]=lammin;
angle[3]=lammax;
pixel=new_poly(4);
if (!pixel) {
fprintf(stderr, "error in get_pixel: failed to allocate memory for polygon of 4 caps\n");
return(0x0);
}
rect_to_poly(angle,pixel);
pixel->pixel=pix;
if(!pixel){
fprintf(stderr, "error in get_pixel: polygon is NULL.\n");
return(0x0);
}
for(i=0;i<pixel->np;i++){
rp_to_azel(pixel->rp[i], &(v[i]));
v[i].az *= (180./PI);
v[i].el *= (180./PI);
if(v[i].az < -180.) v[i].az += 360.;
if(v[i].az > 180.) v[i].az -= 360.;
if(v[i].el < -90.) v[i].el = -90.;
if(v[i].el > 90.) v[i].el = 90.;
csurvey2eq(v[i].el, v[i].az, &(v_r[i].az), &(v_r[i].el));
if(v_r[i].az < 0.) v_r[i].az += 360.;
if(v_r[i].az > 360.) v_r[i].az -= 360.;
if(v_r[i].el < -90.) v_r[i].el = -90.;
if(v_r[i].el > 90.) v_r[i].el = 90.;
v_r[i].az *= (PI/180.);
v_r[i].el *= (PI/180.);
azel_to_rp(&(v_r[i]), pixel->rp[i]);
}
return(pixel);
}
}
else{
fprintf(stderr, "error in get_pixel: pixel scheme %c not recognized.\n", scheme);
return(0x0);
}
}
/* Function get_child_pixels takes a pixel number and calculates the numbers of the
child pixels of that pixel
inputs:
pix_p: parent pixel number
scheme: pixelization scheme
outputs:
pix_c[4]: array containing the pixel numbers of the 4 child pixels
returns 0 on success, 1 if an error occurs
*/
int get_child_pixels(int pix_p, int pix_c[], char scheme){
int mp,np,res,base_pix,i;
unsigned long pix_c0, pix_c1, pix_c2, pix_c3;
if(pix_p<0){
fprintf(stderr, "error in get_child_pixels: %d is not a valid pixel number\n",pix_p);
return(1);
}
res=get_res(pix_p, scheme);
//printf("get_res(pix_p = %d) = %d\n", pix_p, res);
if(res==-1) return (1);
if(scheme=='s'){
// this scheme divides up the sphere by rectangles in az and el, and is numbered
// such that the resolution is encoded in each pixel number. The whole sky is pixel 0,
// pixels 1, 2, 3, and 4 are each 1/4 of the sky (resolution 1), pixels 5-20 are each
// 1/16 of the sky (resolution 2), etc.
base_pix=pix_p-pixel_start(res,scheme);
mp=base_pix % (int)(powl(2,res));
np=(base_pix-mp)/powl(2,res);
//child pixels will have nc=2*np or 2*np+1, mc=2*mp or 2*mp+1, res_c=res+1
//for first child pixel (nc=2*np, mc=2*mp), the base pixel number is given by
//base_pix_c = 2^res_c*nc+mc = 2^(res+1)*2*np+2*mp=2^res*4*np+2*mp
//combine this with base_pix_p=2^res*np+mp and extra resolution term 4^res
//to get formula for the number for the first child pixel number below
pix_c[0]=pix_p+powl(4,res)+powl(2,res)*3*np+mp;
pix_c[1]=pix_c[0]+1;
pix_c[2]=pix_c[0]+powl(2,res+1);
pix_c[3]=pix_c[2]+1;
return(0);
}
else if(scheme=='d'){
assign_parameters();
if (pix_p==0){
for(i=0;i<=116;i++) pix_c[i]=i+1;
return(0);
}
else if (pix_p>=1 && pix_p<=108){
for(i=1;i<=91;i+=18){
if(pix_p>=i && pix_p<=i+17) {
pix_c[0]=4*(i-1)+2*(pix_p-i)+pixel_start(res+1,scheme);
break;
}
}
pix_c[1]=pix_c[0]+1;
pix_c[2]=pix_c[0]+36;
pix_c[3]=pix_c[0]+37;
return(0);
}
else if (pix_p>=109 && pix_p<=117){
pix_c[0]=5*pix_p+(114-pix_p);
for(i=1;i<=3;i++) pix_c[i]=pix_c[0]+i;
return(0);
}
else {
subpix((int)powl(2,res-2), (unsigned long)(pix_p-pixel_start(res, scheme)), &pix_c0, &pix_c1, &pix_c2, &pix_c3);
pix_c[0] = (int)pix_c0 + pixel_start(res+1, scheme);
pix_c[1] = (int)pix_c1 + pixel_start(res+1, scheme);
pix_c[2] = (int)pix_c2 + pixel_start(res+1, scheme);
pix_c[3] = (int)pix_c3 + pixel_start(res+1, scheme);
return(0);
}
}
else{
fprintf(stderr, "error in get_child_pixels: pixel scheme %c not recognized.\n", scheme);
return(1);
}
}
/* Function get_res takes a pixel number and returns the resolution
implied by that pixel number.
inputs:
pix: pixel number
scheme: pixelization scheme
returns the resolution of the pixel, or -1 if an error occurs
*/
int get_res(int pix, char scheme){
int res;
if(pix<0){
fprintf(stderr, "error in get_res: %d not a valid pixel number.\n", pix);
return(-1);
}
if(scheme=='s'){
for(res=0;pix>=powl(4,res);res++){
pix-=(int)powl(4,res);
}
return(res);
}
/* else if(scheme=='h'){
if(pix==0){
res=0;
return(res);
}
else if(pix>0){
for(res=2;pix>(int)(12*(powl(4,res)-4)/12);res++){
}
return((int)(res-1));
}
} */
else if(scheme=='d'){
if(pix==0) return(0);
else if(pix>=1 && pix <=117) return(1);
else pix-=117;
for(res=2;pix>(int)powl(4,res-2)*468;res++){
pix-=(int)powl(4,res-2)*468;
}
// sdss_res increases by factors of 2 instead of increments of 1
// sdss_res = (int)powl(2,res-1);
return(res);
}
else{
fprintf(stderr, "error in get_res: pixel scheme %c not recognized.\n", scheme);
return(-1);
}
return(-1);
}

52
src/gphbv.c Normal file
View file

@ -0,0 +1,52 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdlib.h>
#include <stdio.h>
#include "manglefn.h"
/*------------------------------------------------------------------------------
Correction to boundary and vertex terms per subroutine gspher
arising from disjoint polygons which abut along a circle.
This is a c interface to fortran subroutine gphbv.
Input: poly is a polygon.
np = number of caps of 1st polygon.
bnd = which cap of the polygon is the abutting boundary.
Input/Output: *tol = angle within which to merge multiple intersections.
Output: bound, vert = as described in comments to gspher.s.f .
Return value: 0 if ok;
-1 if could not allocate temporary memory.
*/
int gphbv(polygon *poly, int np, int bnd, long double *tol, long double bound[2], long double vert[2])
{
int i;
/* work arrays */
int *iord;
long double *phi;
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * poly->np * 2);
if (!iord) {
fprintf(stderr, "gphbv: failed to allocate memory for %d ints\n", poly->np * 2);
return(-1);
}
phi = (long double *) malloc(sizeof(long double) * poly->np * 2);
if (!phi) {
fprintf(stderr, "gphbv: failed to allocate memory for %d long doubles\n", poly->np * 2);
return(-1);
}
/* translate from c to fortran convention */
i = bnd + 1;
/* the fortran routine */
gphbv_(bound, vert, poly->rp, poly->cm, &poly->np, &np, &poly->np, &i, tol, phi, iord);
/* free work arrays */
free(iord);
free(phi);
return(0);
}

422
src/gphbv.s.f Normal file
View file

@ -0,0 +1,422 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
c * This routine needs upgrading to the same level of robustness
c * as the rest of the mangle software:
c * 1. Should check consistency of multiple intersections,
c * and increase tol and repeat if an inconsistency is detected.
c * 2. As a corollary of 1., need to go around all edges,
c * not just the particular edge i.
c * 3. If 2. is done, then the routine should be able to deal
c * with point abuts in addition to abutments of finite extent.
c *
c * Currently, the routine deals correctly with multiple intersections,
c * albeit without checking for consistency.
c * However, it deals only with abutments of finite extent,
c * NOT with point abutments, where polygons abut at a single point
c * or at a set of isolated points.
c * This is enough to get bound right,
c * but vert is missing contributions from point abuts.
c-----------------------------------------------------------------------
subroutine gphbv(bound,vert,rp,cm,np,npb,npc,i,tol,phi,iord)
integer np,npb,npc,i,iord(2*np)
real*10 bound(2),vert(2),rp(3,np),cm(np),tol,phi(2,np)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c intrinsics
intrinsic abs
c externals
integer gsegij,gzeroar
c data variables
real*10 big,bndtol,psitol
real*10 dphmin
c local (automatic) variables
integer iphbv,iseg,j,jm(2),jml,jmu,jp(2),jpl,jpu,k,km(2),kp(2),
* l,ni,nmult
logical warn
real*10 bik,cmi,cmik,cmk,cti(3),ctk(3),ctpsi(3),
* d,dbound(2),dph,dvert(2),p,ph,phm,php,psi(3),
* scmi,si,sk,t(3),xi(3),yi(3)
c *
c * Correction to boundary and vertex terms per subroutine gspher
c * arising from disjoint regions W12 and W13 which abut along circle i
c * defined by 1 - r.rp(i) = cm(i).
c * W12 (W13) is the intersection of W2 (W3) with global region W1.
c * Regions are bounded by
c * 1 - r.rp(j) < cm(j) (if cm(j).ge.0)
c * 1 - r.rp(j) > -cm(j) (if cm(j).lt.0)
c * for j=1,np where rp(j) are unit directions.
c * The boundary of W2 is in j = 1 to npb
c * W3 npb+1 to npc
c * W1 npc+1 to np.
c * If circle i belongs to W2 (i.e. i=1 to npb) then
c * W2 (W3) is north (south) of circle i if cm(i).ge.0,
c * south (north) of circle i if cm(i).lt.0.
c * Conversely, if circle i belongs to W3 (i.e. i=npb+1 to npc) then
c * W3 (W2) is north (south) of circle i if cm(i).ge.0,
c * south (north) of circle i if cm(i).lt.0.
c * The abutting boundary i' of W3 (W2) which coincides with
c * boundary i of W2 (W3) should be suppressed by setting cm(i')=2.
c * Boundaries j that are duplicates of boundary i
c * or j' of the abutting boundary i'
c * should be suppressed by setting cm(j)=2 and cm(j')=2.
c *
c * Boundary and vertex terms are evaluated for -<W12 W13>.
c *
c * To get bound & vert for correlation <(W1-W12-W13)^2>
c * of region W1 less its intersection with disjoint regions W2 and W3,
c * follow instructions in gspher, i.e. basically
c * call gspher(area,bound,vert,parameters of W1,ibv=0,...)
c * call gspher(darea,dbound,dvert,parameters of W2 & W1,ibv=2,...)
c * area=area-darea, etc.
c * call gspher(darea,dbound,dvert,parameters of W3 & W1,ibv=2,...)
c * area=area-darea, etc.
c * and then, if W2 and W3 abut,
c * call gphbv(dbound,dvert,parameters of W2 W3 & W1,...)
c * bound=bound-2*dbound
c * vert=vert-2*dvert
c *
c * To get bound & vert for cross-correlation <W12(W1-W13)>
c * between W12
c * and region W1 less its intersection with W3 outside W2,
c * follow instructions in gspher, i.e.
c * call gspher(area,bound,vert,parameters of W2 & W1,ibv=1,...)
c * and then, if W2 and W3 abut,
c * call gphbv(dbound,dvert,parameters of W2 W3 & W1,...)
c * bound=bound+dbound
c * vert=vert+dvert
c *
c * To get bound & vert for cross-correlation <(W12-W13)(W1-W13)>
c * between W12 less its intersection with W3 inside W2,
c * and region W1 less its intersection with W3,
c * follow instructions in gspher, i.e.
c * call gspher(area,bound,vert,parameters of W2 & W1,ibv=1,...)
c * call gspher(darea,dbound,dvert,parameters of W3 & W12,ibv=2,...)
c * area=area-darea, etc.
c * and then, if W2' and W3 abut, where W2' denotes complement of W2,
c * call gphbv(dbound,dvert,parameters of W2' W3 & W1,...)
c * bound=bound-dbound
c * vert=vert-dvert
c * Note that usually all W2' constraints should be null.
c * If however W2' abuts W3 along two distinct boundaries, then W2'
c * should be split into two regions W2'a and W2'b which each have a
c * single abutment with W3, and two calls to gphbv should be made
c * call gphbv(dbound,dvert,parameters of W2'a W3 & W1,...)
c * bound=bound-dbound
c * vert=vert-dvert
c * call gphbv(dbound,dvert,parameters of W2'b W3 & W1,...)
c * bound=bound-dbound, etc.
c *
c * In general, to get bound & vert for cross-correlation
c * <(W12-W13-...)(W1-W13-W14-...)>
c * between region W12 less its intersection W13 with a
c * bunch of disjoint W3 lying inside W2,
c * and W1 less its intersections W13 and W14 with that bunch of W3 and
c * another bunch of disjoint W4 lying outside W2,
c * call gspher(area,bound,vert,parameters of W2 & W1,ibv=1,...)
c * then chop out all the W13s by calls
c * call gspher(darea,dbound,dvert,parameters of W3 & W12,ibv=2,...)
c * area=area-darea, etc.
c * then for each W3 (inside W2) abutting the edge of W2
c * call gphbv(dbound,dvert,parameters of W2' W3 & W1,...)
c * bound=bound-dbound, etc.
c * for each W4 (outside W2) abutting W2
c * call gphbv(dbound,dvert,parameters of W2 W4 & W1,...)
c * bound=bound+dbound, etc.
c * for each pair W3a & W3b (inside W2) which abut each other
c * call gphbv(dbound,dvert,parameters of W3a W3b & W1,...)
c * bound=bound-2*dbound, etc.
c * for each pair W3 (inside W2) & W4 (outside W2) abutting each other
c * call gphbv(dbound,dvert,parameters of W3 W4 & W1,...)
c * bound=bound-dbound, etc.
c *
c Input: rp(3,j),j=1,np
c cm(j),j=1,np
c np, npb, npc: W2 1 to npb
c W3 npb+1 to npc
c W1 npc+1 to np.
c i = abutting boundary of W2 (or W3);
c the abutting boundary i' of W3 (or W2) which coincides
c with boundary i of W2 (or W3) should be suppressed
c by setting cm(i')=2.
c Output: bound(2)
c vert(2)
c Work arrays: phi and iord should be dimensioned at least 2*np
c
c set azimuthal angle of non-intersection to big
data big /1.e6_10/
c set vertex term to zero if |psi| < psitol
data psitol /1.e-10_10/
c ok if bound(1) tests not too far outside [0,max]
data bndtol /1.e-10_10/
c warn about multiple intersection when dph < dphmin
data dphmin /1.e-8_10/
c
C print *,'--------------------'
c abutting boundary must belong to W2 or W3
if (i.gt.npc) then
print *,'*** from gphbv: i =',i,' should be .le.',npc
goto 410
endif
c zero stuff
bound(1)=0._10
bound(2)=0._10
vert(1)=0._10
vert(2)=0._10
warn=.false.
c check for zero angle because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
c cm(i).ge.2 means include whole sphere, which is no constraint
if (cm(i).ge.2._10) goto 410
c--------identify boundary segments around circle i
if (cm(i).ge.0._10) then
scmi=1
else
scmi=-1
endif
cmi=abs(cm(i))
si=sqrt(cmi*(2._10-cmi))
c........construct cartesian axes with z-axis along rp(i)
call gaxisi(rp(1,i),xi,yi)
c........angles phi about z-axis rp(i) of intersection of i & j circles
call gphij(rp,cm,np,i,rp(1,i),scmi,cmi,xi,yi,big,tol,ni,phi)
c i circle lies outside polygon
if (ni.eq.-1) goto 410
c area of polygon is zero
if (ni.eq.-2) goto 410
c........i circle has no intersections
if (ni.eq.0) then
dph=TWOPI
dbound(1)=si*dph
dbound(2)=(1._10/si-2._10*si)*dph
bound(1)=bound(1)+dbound(1)
bound(2)=bound(2)+dbound(2)
C print *,'full circle'
C print *,'dbound =',dbound(1),dbound(2),
C * ' bound =',bound(1),bound(2)
c........i circle has intersections
elseif (ni.gt.0) then
c find ordering of intersection angles around i circle
call findbot(phi,2*np,iord,ni)
c........contribution from each segment of i circle
jpl=0
c come here to do another segment
220 continue
c........is segment edge of polygon?
iseg=gsegij(rp,cm,np,npb,npc,i,rp(1,i),scmi,cmi,tol,ni,
* phi,iord,jml,jmu,jpl,jpu,2,jm,jp,km,kp,phm,php,ph,dph)
c error
if (iseg.eq.-1) goto 420
c not an edge
if (iseg.eq.0) goto 220
c gone full circle
if (iseg.eq.2) goto 280
c near multiple intersection
if (dph.lt.dphmin) then
c increment count of near multiple intersections
nmult=nmult+1
c warn=.true.
c print *,
c * '*** warning from gspher: near multiple intersection at'
c * ,i,': segment',km(1),kp(1),' &',km(2),kp(2),' dph=',dph
endif
c........segment satisfies conditions
c. . . . boundary terms
dbound(1)=si*dph
dbound(2)=(1._10/si-2._10*si)*dph
bound(1)=bound(1)+dbound(1)
bound(2)=bound(2)+dbound(2)
C print *,'at',i,': edge',km(1),kp(1),' &',km(2),kp(2),
C * ' (',jm(1),' &',jm(2),' in',jml,jmu,',',
C * jp(1),' &',jp(2),' in',jpl,jpu,' of',ni,')'
C print *,'dph/(2*pi)=',dph/TWOPI
C print *,'dbound =',dbound(1),dbound(2),
C * ' bound =',bound(1),bound(2)
c. . . . vertex terms
do l=1,2
do iphbv=1,2
c end point is intersection of i circle with k circle
if (l.eq.1) then
k=km(iphbv)
elseif (l.eq.2) then
k=kp(iphbv)
endif
if (k.eq.0) then
psi(iphbv)=0._10
ctpsi(iphbv)=1._10/psi(iphbv)
t(iphbv)=0._10
c cti = cot th(i)
cti(iphbv)=(1._10-cmi)/si
if (scmi.lt.0) cti(iphbv)=-cti(iphbv)
if (iphbv.eq.2) cti(iphbv)=-cti(iphbv)
c ctk = cot th(k)
ctk(iphbv)=cti(iphbv)
else
cmk=abs(cm(k))
sk=sqrt(cmk*(2._10-cmk))
c cmik = 1-cos th(ik)
cmik=((rp(1,i)-rp(1,k))**2+(rp(2,i)-rp(2,k))**2
* +(rp(3,i)-rp(3,k))**2)/2._10
c bik = cik-ci*ck
c d = 1-ci^2-ck^2-cik^2+2*ci*ck*cik
c cos psi = bik/(si*sk)
c sin psi = sqrt(d)/(si*sk)
c psi = atan(sqrt(d)/bik) is exterior angle at intersection
bik=(cmi+cmk)-cmi*cmk-cmik
if ((scmi.ge.0.and.cm(k).lt.0._10)
* .or.(scmi.le.0.and.cm(k).ge.0._10)) bik=-bik
if (iphbv.eq.2) bik=-bik
c i and k circles kiss
if (phi(1,k).eq.phi(2,k)) then
d=0._10
else
d=-(cmi-cmk)**2+cmik*(2._10*((cmi+cmk)-cmi*cmk)-cmik)
c assert that circles at least touch
if (d.lt.0._10) d=0._10
d=sqrt(d)
endif
ctpsi(iphbv)=bik/d
psi(iphbv)=atan2(d,bik)
c t=tan psi/2
if (bik.gt.0._10) then
t(iphbv)=d/(bik+sqrt(bik**2+d**2))
elseif (bik.lt.0._10) then
t(iphbv)=(-bik+sqrt(bik**2+d**2))/d
elseif (bik.eq.0._10) then
t(iphbv)=1._10
endif
c cti = cot th(i)
cti(iphbv)=(1._10-cmi)/si
if (scmi.lt.0) cti(iphbv)=-cti(iphbv)
if (iphbv.eq.2) cti(iphbv)=-cti(iphbv)
c ctk = cot th(k)
ctk(iphbv)=(1._10-cmk)/sk
if (cm(k).lt.0._10) ctk(iphbv)=-ctk(iphbv)
endif
enddo
c psi(3) = psi(1) + psi(2) - pi
psi(3)=psi(1)+psi(2)-PI
c cot psi(3)
if (abs(ctpsi(1)).le.1._10) then
if (abs(ctpsi(2)).le.1._10) then
ctpsi(3)=(ctpsi(1)*ctpsi(2)-1._10)
* /(ctpsi(1)+ctpsi(2))
else
ctpsi(3)=(ctpsi(1)-1._10/ctpsi(2))
* /(ctpsi(1)/ctpsi(2)+1._10)
endif
else
if (abs(ctpsi(2)).le.1._10) then
ctpsi(3)=(ctpsi(2)-1._10/ctpsi(1))
* /(1._10+ctpsi(2)/ctpsi(1))
else
ctpsi(3)=(1._10-1._10/ctpsi(1)/ctpsi(2))
* /(1._10/ctpsi(2)+1._10/ctpsi(1))
endif
endif
c tan psi(3)/2
if (abs(t(1)).le.1._10) then
if (abs(t(2)).le.1._10) then
t(3)=(t(1)*t(2)-1._10)/(t(1)+t(2))
else
t(3)=(t(1)-1._10/t(2))/(t(1)/t(2)+1._10)
endif
else
if (abs(t(2)).le.1._10) then
t(3)=(t(2)-1._10/t(1))/(1._10+t(2)/t(1))
else
t(3)=(1._10-1._10/t(1)/t(2))/(1._10/t(2)+1._10/t(1))
endif
endif
cti(3)=ctk(1)
ctk(3)=ctk(2)
do iphbv=1,3
if (abs(psi(iphbv)).le.psitol) then
dvert(1)=0._10
dvert(2)=0._10
else
dvert(1)=1._10-psi(iphbv)*ctpsi(iphbv)
dvert(2)=t(iphbv)*(3._10+t(iphbv)**2)
* *(cti(iphbv)+ctk(iphbv))/2._10
dvert(1)=dvert(1)/2._10
dvert(2)=dvert(2)/2._10
endif
if (iphbv.le.2) then
vert(1)=vert(1)+dvert(1)
vert(2)=vert(2)+dvert(2)
else
vert(1)=vert(1)-dvert(1)
vert(2)=vert(2)-dvert(2)
endif
C print *,'vertex',i,k,' part ',iphbv,
C * ' psi =',psi(iphbv)
C print *,' dvert =',dvert(1),dvert(2),
C * ' vert =',vert(1),vert(2)
C print *,' cot(',psi(iphbv),') =',1._10/tan(psi(iphbv)),
C * ' should =',ctpsi(iphbv)
C print *,' tan(',psi(iphbv),'/2) =',tan(psi(iphbv)/2._10),
C * ' should =',t(iphbv)
C print *,' cot(th_i) =',cti(iphbv),
C * ' cot(th_k) =',ctk(iphbv)
enddo
enddo
c do another segment
goto 220
endif
280 continue
c--------finish off
c check angle is between 0 and 2*pi
p=bound(1)/si/TWOPI
c print *,rp(1,i),rp(2,i),rp(3,i),'angle/(2*pi)=',p
if (p.lt.0._10) then
print *,'*** from gphbv: angle/(2*pi)=',p,
* ' should be .ge. 0'
warn=.true.
elseif (p.gt.1._10) then
if (bound(1)/si.le.TWOPI+bndtol) then
continue
else
print *,'*** from gphbv: angle/(2*pi)=',p,
* ' should be .le. 1'
warn=.true.
endif
endif
if (warn) then
print *,'boundary',i
write (*,'(a3,a20,4a24)')
* ' ','x','y','z',
c * 'r',
* '1-c'
do j=1,np
write (*,'(i3,5g24.16)')
* j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
* cm(j)
enddo
endif
410 continue
C print *,'final bound =',bound(1),bound(2),
C * ' vert =',vert(1),vert(2)
C print *,'....................'
return
c
420 continue
print *,'*** from gphbv: total failure at tol =',tol
write (*,'(a3,a20,4a24)')
* ' ','x','y','z',
c * 'r',
* '1-c'
do j=1,np
write (*,'(i3,5g24.16)')
* j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
* cm(j)
enddo
C print *,'....................'
return
c
end
c

50
src/gphi.c Normal file
View file

@ -0,0 +1,50 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include "manglefn.h"
/*------------------------------------------------------------------------------
Angle along circle centred at unit vector rp,
with radius th given by cm = 1 - cosl(th),
lying inside polygon poly.
The angle is 2 pi if the circle lies entirely inside the polygon.
This is a c interface to fortran subroutine gphi.
Input: poly is a polygon.
*tol = angle within which to merge multiple intersections.
rp = unit vector at the centre of the circle.
cm = 1 - cosl(th), where th is the angular radius of the circle.
Output: *angle = angle along circle, in radians.
Return value: 0 if ok;
-1 if failed to allocate memory.
*/
int gphi(polygon *poly, long double *tol, vec rp, long double cm, long double *angle)
{
/* work arrays */
int *iord;
long double *phi;
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * poly->np * 2);
if (!iord) {
fprintf(stderr, "gphi: failed to allocate memory for %d ints\n", poly->np * 2);
return(-1);
}
phi = (long double *) malloc(sizeof(long double) * poly->np * 2);
if (!phi) {
fprintf(stderr, "gphi: failed to allocate memory for %d long doubles\n", poly->np * 2);
return(-1);
}
/* fortran routine */
gphi_(angle, poly->rp, poly->cm, &poly->np, rp, &cm, tol, phi, iord);
/* free work arrays */
free(iord);
free(phi);
return(0);
}

131
src/gphi.s.f Normal file
View file

@ -0,0 +1,131 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gphi(angle,rp,cm,np,rpi,cmi,tol,phi,iord)
integer np
real*10 angle,rp(3,np),cm(np),rpi(3),cmi,tol
c work arrays (could be automatic if compiler supports it)
integer iord(2*np)
real*10 phi(2,np)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c externals
integer gsegij,gzeroar
c data variables
real*10 angtol,big
c local variables
integer i,iseg,j,jm,jml,jmu,jp,jpl,jpu,km,kp,ni,scmi
real*10 dph,p,ph,phm,php,xi(3),yi(3)
c *
c * Angle along circle about unit direction rpi satisfying
c * 1 - r.rpi = cmi
c * and bounded by
c * 1 - r.rp(j) <= cm(j) (if cm(j).ge.0)
c * 1 - r.rp(j) > -cm(j) (if cm(j).lt.0)
c * for j=1,np where rp(j) are unit directions.
c * If the circle lies along a border of the polygon,
c * then the returned angle is zero.
c *
c Input: rp(3,j),j=1,np
c cm(j),j=1,np
c np
c rpi(3)
c cmi
c tol
c Output: angle
c Work arrays: phi and iord should be dimensioned at least 2*np
c
c set azimuthal angle of non-intersection to big
data big /1.e6_10/
c ok if angle tests not too far outside [0,max]
data angtol /1.e-10_10/
c
c initialise angle to zero
angle=0._10
c check for null circle
if (cmi.lt.0._10) goto 410
if (cmi.gt.2._10) goto 410
c check for zero angle because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
scmi=1
c........construct cartesian axes with z-axis along rpi
call gaxisi(rpi,xi,yi)
c........angles phi about z-axis rp(i) of intersection of i & j circles
c passing i=0 means circle at edge is considered outside polygon
call gphij(rp,cm,np,0,rpi,scmi,cmi,xi,yi,big,tol,ni,phi)
c i circle lies outside (or at edge of) polygon
if (ni.le.-1) goto 410
c........order angles around circle
c circle has no intersections
if (ni.eq.0) then
angle=TWOPI
c circle has intersections
elseif (ni.gt.0) then
c find ordering of intersection angles around circle
call findbot(phi,2*np,iord,ni)
c........vertices around i circle
jpl=0
c come here to do another segment
220 continue
c........is segment edge of polygon?
iseg=gsegij(rp,cm,np,0,0,i,rpi,scmi,cmi,tol,ni,
* phi,iord,jml,jmu,jpl,jpu,1,jm,jp,km,kp,phm,php,ph,dph)
c error
if (iseg.eq.-1) goto 420
c not an edge
if (iseg.eq.0) goto 220
c gone full circle
if (iseg.eq.2) goto 280
c........segment satisfies conditions
c print *,'segment',km,kp,' dph/(2*pi)=',dph/TWOPI
angle=angle+dph
c do another segment
goto 220
endif
280 continue
c........check angle is between 0 and 2*pi
p=angle/TWOPI
c print *,rpi(1),rpi(2),rpi(3),'angle/(2*pi) =',p
if (p.lt.0._10) then
write (*,'(" *** from gphi: angle/(2*pi) = ",g24.16,
* " should be >= 0")') p
goto 420
elseif (p.gt.1._10) then
c check if discrepancy is from numerical roundoff
if (angle.le.TWOPI+angtol) then
angle=TWOPI
else
write (*,'(" *** from gphi: angle/(2*pi) = ",g24.16,
* " should be <= 1")') p
goto 420
endif
endif
c........done
return
c
c zero angle
410 continue
return
c
420 print *,'*** from gphi: total failure at tol =',tol
write (*,'(a3,a20,4a24)')
* ' ','x','y','z',
c * 'r',
* '1-c'
do j=1,np
write (*,'(i3,5g24.16)')
* j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
* cm(j)
enddo
write (*,'(i3,5g24.16)')
* 0,(rpi(i),i=1,3),
c * sqrt(rpi(1)**2+rpi(2)**2+rpi(3)**2),
* cmi
return
c
end
c

43
src/gphim.s.f Normal file
View file

@ -0,0 +1,43 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gphim(angle,rp,cm,np,rpi,cmi,cmimin,cmimax,tol,
* phi,iord)
integer np,iord(2*np)
real*10 angle,rp(3,np),cm(np),rpi(3),cmi,cmimin,cmimax,tol,
* phi(2,np)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c intrinsics
intrinsic abs
c *
c * Same as gphi, but speed up matters by checking first whether cmi
c * lies outside |cmimin| and |cmimax|, giving angle of 0 or 2*pi.
c * cmimin and cmimax are gotten from prior call to gcmlim.
c *
if (cmi.le.abs(cmimin)) then
c region excludes circle
if (cmimin.ge.0._10) then
angle=0._10
c region encloses circle
elseif (cmimin.lt.0._10) then
angle=TWOPI
endif
elseif (cmi.ge.abs(cmimax)) then
c circle encloses region
if (cmimax.ge.0._10) then
angle=0._10
c circle and region enclose each other
elseif (cmimax.lt.0._10) then
angle=TWOPI
endif
else
c circle intersects boundary of region
call gphi(angle,rp,cm,np,rpi,cmi,phi,tol,iord)
endif
return
end
c

21
src/gptin.c Normal file
View file

@ -0,0 +1,21 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include "manglefn.h"
/*------------------------------------------------------------------------------
Determine whether unit vector lies inside polygon.
This is a c interface to fortran logical function gptin.
Input: poly is a polygon.
rp = unit vector.
Return value: 1 if in;
0 if not in.
*/
int gptin(polygon *poly, vec rp)
{
/* fortran routine */
if (gptin_(poly->rp, poly->cm, &poly->np, rp)) return(1);
return(0);
}

52
src/gptin.s.f Normal file
View file

@ -0,0 +1,52 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
logical function gptin(rp,cm,np,rpi)
integer np
real*10 rp(3,np),cm(np),rpi(3)
c
c intrinsics
intrinsic abs
c externals
integer gzeroar
c local (automatic) variables
integer j
real*10 cmij,cmj
c *
c * Determine whether unit direction rpi lies within region bounded by
c * 1 - r.rp(j) <= cm(j) (if cm(j).ge.0)
c * 1 - r.rp(j) > -cm(j) (if cm(j).lt.0)
c * for j=1,np where rp(j) are unit directions.
c *
c Input: rp(3,j),j=1,np
c cm(j),j=1,np
c np
c rpi(3)
c Output: gptin = .true. if point lies within region
c .false. if outside.
c
gptin=.false.
c check for point outside because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
c check each boundary
do 140 j=1,np
c null boundary means no constraint
if (cm(j).ge.2._10) goto 140
cmj=abs(cm(j))
c 1-cos of angle between point and rp(j) direction
cmij=((rpi(1)-rp(1,j))**2+(rpi(2)-rp(2,j))**2
* +(rpi(3)-rp(3,j))**2)/2._10
c check if point is outside rp(j) boundary
if (cm(j).ge.0._10) then
if (cmij.gt.cmj) goto 410
elseif (cm(j).lt.0._10) then
if (cmij.le.cmj) goto 410
endif
140 continue
c point survived all assails
gptin=.true.
c done
410 continue
return
end
c

152
src/gspher.c Normal file
View file

@ -0,0 +1,152 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdlib.h>
#include <stdio.h>
#include "manglefn.h"
#include "pi.h"
/*------------------------------------------------------------------------------
Spherical harmonics of polygon.
This is a c interface to fortran subroutine gspher.
It is the full version, that returns area, bound and vert
in addition to the spherical harmonics.
Input: poly is a polygon.
lmax = maximum harmonic number.
Input/Output: *tol = angle within which to merge multiple intersections.
Output: *area = area of polygon.
bound, vert = as described in comments to gspher.s.f .
w = array containing spherical harmonics of polygon;
NW = ((lmax + 1)(lmax + 2))/ 2 is defined in harmonics.h.
Return value: 0 if ok;
1 if fatal error;
-1 if could not allocate temporary memory.
*/
int gspher(polygon *poly, int lmax, long double *tol, long double *area, long double bound[2], long double vert[2], harmonic w[/*NW*/])
{
logical ldegen;
int i, ibv, ier, im, iphi, iw, lmax1, nw, verb;
long double darea;
/* work arrays */
int *iord;
long double *v, *phw;
/* determine area without 2 pi ambiguity, and a good value for tol */
verb = 1;
ier = garea(poly, tol, verb, area);
if (ier) return(ier);
/* trivial case of zero area */
if (*area == 0.) {
bound[0] = 0.;
bound[1] = 0.;
vert[0] = 0.;
vert[1] = 0.;
for (iw = 0; iw < NW; iw++) {
for (i = 0; i < IM; i++) w[iw][i] = 0.;
}
return(0);
}
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * poly->np * 2);
if (!iord) {
fprintf(stderr, "gspher: failed to allocate memory for %d ints\n", poly->np * 2);
return(-1);
}
phw = (long double *) malloc(sizeof(long double) * poly->np * 2);
if (!phw) {
fprintf(stderr, "gspher: failed to allocate memory for %d long doubles\n", poly->np * 2);
return(-1);
}
v = (long double *) malloc(sizeof(long double) * (lmax + 1));
if (!v) {
fprintf(stderr, "gspher: failed to allocate memory for %d long doubles\n", lmax + 1);
return(-1);
}
/* parameters */
lmax1 = lmax + 1;
im = IM;
nw = NW;
ibv = 0;
iphi = 0;
/* the fortran routine */
gspher_(&darea, bound, vert, w, &lmax1, &im, &nw, poly->rp, poly->cm, &poly->np, &poly->np, &ibv, &iphi, tol, phw, iord, v, &ldegen);
/* monopole harmonic without 2 pi/sqrtl(4 pi) ambiguity */
w[0][0] = *area / sqrtl(4. * PI);
/* free work arrays */
free(iord);
free(phw);
free(v);
/* fatal error */
if (ldegen) return(1);
return(0);
}
/*------------------------------------------------------------------------------
Accelerated computation of spherical harmonics of rectangle.
This is a c interface to fortran subroutine gsphera.
It is the full version, that returns area, bound and vert
in addition to the spherical harmonics.
The acceleration involves some overhead, and works only if two or more
rectangles with the same elmin & elmax are computed in succession.
The overhead means that the accelerated computation is actually slightly
slower for just a single rectangle.
Input: lmax = maximum harmonic number.
Output: w = array containing spherical harmonics of polygon;
NW = ((lmax + 1)(lmax + 2))/ 2 is defined in harmonics.h.
Return value: 0 if ok;
-1 if could not allocate temporary memory.
*/
int gsphera(long double azmin, long double azmax, long double elmin, long double elmax, int lmax, long double *area, long double bound[2], long double vert[2], harmonic w[/*NW*/])
{
/* array used for acceleration */
static long double *dw = 0x0;
int ibv, im, lmax1, nw;
/* work array */
long double *v;
/* allocate memory for work arrays */
v = (long double *) malloc(sizeof(long double) * (lmax + 1));
if (!v) {
fprintf(stderr, "gsphera: failed to allocate memory for %d long doubles\n", lmax + 1);
return(-1);
}
/* parameters */
lmax1 = lmax + 1;
im = IM;
nw = NW;
ibv = 0;
/* dw contains array that is pre-computed, then used by all rects with same elmin, elmax */
if (!dw) {
dw = (long double *) malloc(sizeof(long double) * NW);
if (!dw) {
fprintf(stderr, "gsphera: failed to allocate memory for %d long doubles\n", NW);
return(-1);
}
}
/* fortran routine */
gsphera_(area, bound, vert, w, &lmax1, &im, &nw, &ibv, &azmin, &azmax, &elmin, &elmax, v, dw);
/* free work array */
free(v);
return(0);
}

592
src/gspher.s.f Normal file
View file

@ -0,0 +1,592 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gspher(area,bound,vert,w,lmax1,im,nw,rp,cm,np,npc,ibv,
* iphi,tol,phw,iord,v,ldegen)
integer lmax1,im,nw,np,npc,ibv,iphi
logical ldegen
real*10 area,bound(2),vert(2),w(im,nw),rp(3,np),cm(np),tol
c work arrays (could be automatic if compiler supports it)
integer iord(2*np)
real*10 phw(2,np),v(lmax1)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c intrinsics
intrinsic abs
c externals
integer garpi,gsegij,gzeroar
c data variables
real*10 big
real*10 dphmin
c local (automatic) variables
integer i,iarea,ik,iseg,j,jm,jml,jmu,jp,jpl,jpu,k,km,kp,l,
* nbd,nbd0m,nbd0p,ni,nmult,retry,scmi
C logical warn
logical whole
real*10 bik,ci,cmi,cmik,cmk,cti,ctk,ctpsi,
* d,darea,dbound(2),dph,dvert(2),ikchk,ikran,
* ph,phi,phii,phm,php,psi,psip,ri,rii,si,sk,sqrt4pi,t,tolin,
* xi(3),yi(3)
c *
c * Spherical transform of region W of sphere of unit radius bounded by
c * 1 - r.rp(i) < cm(i) (if cm(i).ge.0)
c * 1 - r.rp(i) > -cm(i) (if cm(i).lt.0)
c * for i=1,np where rp(i) are unit directions.
c * See AJSH notes Multfn C115.
c *
c * bound (boundary) and vert (vertex) are related to the coefficients
c * of the 1st & 2nd order terms of the power series expansion
c * in sin(th/2) of the correlation <WW> at angular separation th:
c * <WW> = sum(lm) |W_lm|^2 P_l(cos th)
c * = 2*pi*area - 4*bound*sin(th/2) + 2*vert*sin^2(th/2) + ...
c * In fact bound is just the total length of the boundary in radians,
c * and vert is the sum over vertex terms of 1-psi/tan(psi), where
c * psi is the exterior angle (=pi-interior angle) at the vertex.
c * The range of validity of the power series expansion in sin(th/2)
c * depends on the tortuousness of the boundary: the more convoluted the
c * boundary, and the sharper the vertex angles, the shorter the range.
c *
c * Oct 1992: next order term incorporated
c * <WW> = 2*pi*area - 4*bound(1)*sin(th/2) + 2*vert(1)*sin^2(th/2)
c * + [2/3*bound(2) + 8/9*vert(2)]*sin^3(th/2) + ...
c *
c * The option ibv modifies the evaluation of bound and vert,
c * and determines the sign of the returned harmonics.
c * ibv = 0: standard option, for <WW>.
c * The code returns the harmonics of W in the array w.
c * ibv = 1: to take the cross-correlation between a region W1 and
c * its intersection W12 with region W2.
c * Here <W12 W1> = <W12^2> + <W12(W1-W12)>
c * and this is what the code evaluates bound and vert for.
c * The code returns the harmonics of W12 in the array w.
c * ibv = 2: to take region W1 less its intersection W12 with region W2.
c * Here <WW> = <(W1-W12)(W1-W12)>
c * = <W1^2> - <W12^2> - 2<W12(W1-W12)>
c * The code evaluates bound and vert for
c * <W12^2> + 2<W12(W1-W12)>.
c * The code returns MINUS the harmonics of W12 in the array w.
c * ibv = 3: to take the union of regions W1 and W2.
c * Here <WW> = <(W1+W2-W12)(W1+W2-W12)>
c * = <W1^2> + <W2^2> - <W12^2> + 2<(W1-W12)(W2-W12)>
c * The code evaluates bound and vert for
c * <W12^2> - 2<(W1-W12)(W2-W12)>.
c * The code returns MINUS the harmonics of W12 in the array w.
c * The correct calling procedure in each case is exampled below.
c *
c * Complement of a region:
c * area -> 4*pi-area, w(1,1) -> sqrt(4*pi)-w(1,1)
c * bound -> bound
c * vert -> vert
c * w -> -w except monopole term w(1,1) as above
c *
c * To get intersection W12 of regions W1 & W2,
c * but evaluate bound & vert for cross-correlation between W12 and W1:
c * put the np2 constraints of region W2 in 1 to npc
c * & the np1 constraints of region W1 in npc+1 to np
c * call gspher(area,bound,vert,w,parameters of W1,npc=np2,1,...)
c *
c * To get region W1 less its intersection with region W2:
c * call gspher(area,bound,vert,w,parameters of W1,npc=0,0,...)
c * put the np2 constraints of region W2 in 1 to npc
c * & the np1 constraints of region W1 in npc+1 to np
c * call gspher(darea,dbound,dvert,w,params of W1 & W2,npc=np2,2,...)
c * area=area-darea
c * bound=bound-dbound
c * vert=vert-dvert
c *
c * To get the union of two regions W1 & W2:
c * call gspher(area,bound,vert,w,parameters of W1,npc=0,0,...)
c * call gspher(darea,dbound,dvert,w,parameters of W2,npc=0,0,...)
c * area=area+darea
c * bound=bound+dbound
c * vert=dvert+dvert
c * put the np2 constraints of region W2 in 1 to npc
c * & the np1 constraints of region W1 in npc+1 to np
c * call gspher(darea,dbound,dvert,w,params of W1 & W2,npc=np2,3,...)
c * area=area-darea
c * bound=bound-dbound
c * vert=dvert-dvert
c *
c * Cautions:
c * (1) This subroutine underestimates the area (monopole harmonic)
c * by 2*pi (sqrt(pi)) if 2*pi <= area < 4*pi
c * and the area is bounded by more than one arc.
c * (2) This subroutine will usually work correctly when there are near
c * multiple (.ge. 3) intersections of boundaries, but in rare
c * instances it may fail. If so, it should flag the failure with
c * ldegen=.true. This error condition should NOT be ignored.
c * (3) There is a mathematical ambiguity in the boundary term bound
c * whenever two (or more) boundaries coincide. To resolve the
c * ambiguity correctly, perturb the boundaries slightly.
c * Likewise there is a mathematical ambiguity in the vertex term
c * vert whenever there are multiple (.ge. 3) intersections.
c * Again, to resolve the ambiguity correctly, perturb the
c * boundaries slightly.
c * It should be noted that if these problems exist, then the series
c * expansion of <WW>, whose coefficients involve bound and vert,
c * probably breaks down already at tiny values of the separation
c * angle th.
c *
c Input: lmax1 = lmax+1 where lmax is maximum desired l of transform.
c im = 1 means compute only real part of harmonics;
c 2 means compute both real and imaginary parts.
c Note harmonics are real if region possesses reflection
c symmetry through plane defined by z-axis and direction
c rp(iphi).
c nw = [(lmax+1)*(lmax+2)]/2
c rp(3,i),i=1,np = x, y, z coordinates of a set of unit
c directions defining the region.
c It is assumed without checking that
c rp(1)^2 + rp(2)^2 + rp(3)^2 = 1 .
c cm(i),i=1,np = set of 1-cos's defining the region.
c np = number of directions.
c npc = part number of directions, used in conjunction with ibv;
c see above for more details;
c npc is irrelevant if ibv = 0.
c ibv = 0 to 3 controls evaluation of bound & vert;
c see above for more details.
c iphi > 0 means compute harmonics in frame of reference where
c y-axis is along z x rp(iphi);
c = 0 means use the input frame of reference.
c Output: area = area of region in steradians.
c bound = length of boundary of region in radians if ibv=0,
c or as explained above if ibv>0.
c vert = sum over vertices of 1-psi/tan(psi) if ibv=0,
c where psi is exterior angle (=pi-interior angle)
c at vertex, or as explained above if ibv>0.
c ldegen = .true. signals an error: the code dealt incorrectly
c with a multiply intersecting boundary.
c Input/Output: w(i,lm) = spherical transform, dimensioned w(im,nw)
c w(i,lm), i=1,im, lm=l*(l+1)/2+m+1, l=0,lmax, m=0,l;
c w(1,lm) is real part, w(2,lm) is imaginary part (if im=2).
c Note w(l,-m)=(-)**m*[Complex conjugate of w(l,m)], just as
c Y(l,-m)=(-)**m*[Complex conjugate of Y(l,m)].
c tol
c Work arrays: phw and iord should be dimensioned at least 2*np.
c v should be dimensioned at least lmax1.
c
c set azimuthal angle of non-intersection to big
data big /1.e6_10/
c possible multiple intersection when dph < dphmin
data dphmin /1.e-8_10/
c
c input tolerance to multiple intersections
tolin=tol
C print *,'--------------------'
c come here with modified tolerance
100 continue
c initialise error flag to no error
ldegen=.false.
C warn=.false.
c zero stuff
area=0._10
bound(1)=0._10
bound(2)=0._10
vert(1)=0._10
vert(2)=0._10
do j=1,nw
do i=1,im
w(i,j)=0._10
enddo
enddo
c check for zero area because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
c no constraints at all will mean area is whole sphere
whole=.true.
c number of intersecting arc segments bounding area
nbd=0
c number of non-intersecting circles bounding area
nbd0m=0
nbd0p=0
c error check on evaluation of vertex terms
ikchk=0._10
c area=sqrt(4pi)*monopole
sqrt4pi=sqrt(4._10*PI)
c harmonics defined so point iphi is at zero azimuthal angle
rii=0._10
if (iphi.ge.1) rii=sqrt(rp(1,iphi)**2+rp(2,iphi)**2)
phii=0._10
if (rii.gt.0._10) phii=atan2(rp(2,iphi),rp(1,iphi))
c--------identify boundary segments around each circle i in turn
do 280 i=1,np
c cm(i).ge.2 means include whole sphere, which is no constraint
if (cm(i).ge.2._10) goto 280
c there is a constraint, so area is not whole sphere
whole=.false.
c scmi * cmi = 1-cos th(i)
if (cm(i).ge.0._10) then
scmi=1
else
scmi=-1
endif
cmi=abs(cm(i))
c ci = cos th(i)
ci=1._10-cmi
c si = sin th(i)
si=sqrt(cmi*(2._10-cmi))
c........ri, phi, rp(3,i) are cylindrical coordinates of rp(i)
ri=sqrt(rp(1,i)**2+rp(2,i)**2)
if (ri.eq.0._10.or.i.eq.iphi) then
phi=0._10
else
phi=atan2(rp(2,i),rp(1,i))-phii
endif
c........construct cartesian axes with z-axis along rp(i)
c The direction of yi is important here,
c unlike some other subroutines (gphi, garea, gphbv, gvlim, gvphi)
c where yi can point in any abitrary direction.
c set yi in direction z x rp(i)
if (ri.gt.0._10) then
yi(1)=-rp(2,i)/ri
yi(2)=rp(1,i)/ri
yi(3)=0._10
c if rp(i) is along z-axis, set yi in direction z x rp(iphi)
elseif (rii.gt.0._10) then
yi(1)=-rp(2,iphi)/rii
yi(2)=rp(1,iphi)/rii
yi(3)=0._10
c if rp(iphi) is also along z-axis, set yi along y-axis
elseif (ri.eq.0._10.and.rii.eq.0._10) then
yi(1)=0._10
yi(2)=1._10
yi(3)=0._10
endif
c xi in direction yi x rp(i)
xi(1)=yi(2)*rp(3,i)-yi(3)*rp(2,i)
xi(2)=yi(3)*rp(1,i)-yi(1)*rp(3,i)
xi(3)=yi(1)*rp(2,i)-yi(2)*rp(1,i)
c........angles phi about z-axis rp(i) of intersection of i & j circles
call gphij(rp,cm,np,i,rp(1,i),scmi,cmi,xi,yi,big,tol,ni,phw)
c i circle lies outside polygon
if (ni.eq.-1) goto 280
c area of polygon is zero
if (ni.eq.-2) then
c area can be non-zero from psi at multiple intersections
area=0._10
bound(1)=0._10
bound(2)=0._10
vert(1)=0._10
vert(2)=0._10
do l=1,nw
do k=1,im
w(k,l)=0._10
enddo
enddo
goto 410
endif
c........i circle has no intersections
if (ni.eq.0) then
if (scmi.ge.0) then
nbd0p=nbd0p+1
else
nbd0m=nbd0m+1
endif
dph=TWOPI
if (scmi.lt.0) dph=-dph
ph=0._10
c increment area
darea=cmi*dph
area=area+darea
c bound(1) term is length of boundary
dbound(1)=si*abs(dph)
dbound(2)=(1._10/si-2._10*si)*abs(dph)
c standard
if (ibv.eq.0
c cross
* .or.(ibv.eq.1.and.i.gt.npc)
c intersection
* .or.(ibv.eq.2.and.i.gt.npc)
c union
* .or.(ibv.eq.3)) then
bound(1)=bound(1)+dbound(1)
bound(2)=bound(2)+dbound(2)
c intersection
elseif (ibv.eq.2.and.i.le.npc) then
bound(1)=bound(1)-dbound(1)
bound(2)=bound(2)-dbound(2)
endif
C print *,'at',i,': full circle area +=',darea,' =',area
C print *,'dbound =',dbound(1),dbound(2),
C * ' bound =',bound(1),bound(2)
c increment spherical transform
if (ibv.ge.2) dph=-dph
call wlm(w,lmax1,im,nw,ri,phi,0,rp(3,i),ci,si,ph,dph,v)
c........i circle has intersections
elseif (ni.gt.0) then
c find ordering of intersection angles around i circle
call findbot(phw,2*np,iord,ni)
c........contribution from each segment of i circle
jpl=0
c come here to do another segment
220 continue
c........is segment edge of polygon?
iseg=gsegij(rp,cm,np,0,0,i,rp(1,i),scmi,cmi,tol,ni,
* phw,iord,jml,jmu,jpl,jpu,1,jm,jp,km,kp,phm,php,ph,dph)
c error
if (iseg.eq.-1) goto 420
c not an edge
if (iseg.eq.0) goto 220
c gone full circle
if (iseg.eq.2) goto 280
c near multiple intersection
if (dph.lt.dphmin) then
c increment count of near multiple intersections
nmult=nmult+1
c warn=.true.
c print *,
c * '*** warning from gspher: near multiple intersection at'
c * ,i,': segment',km,kp,' dph=',dph
endif
c........segment satisfies conditions
nbd=nbd+1
c contribution to area from the boundary segment
if (scmi.lt.0) dph=-dph
darea=cmi*dph-dph
area=area+darea
c bound(1) term is length of boundary
dbound(1)=si*abs(dph)
dbound(2)=(1._10/si-2._10*si)*abs(dph)
c standard
if (ibv.eq.0
c cross
* .or.(ibv.eq.1.and.i.gt.npc)
c intersection
* .or.(ibv.eq.2.and.i.gt.npc)
c union
* .or.(ibv.eq.3)) then
bound(1)=bound(1)+dbound(1)
bound(2)=bound(2)+dbound(2)
c intersection
elseif (ibv.eq.2.and.i.le.npc) then
bound(1)=bound(1)-dbound(1)
bound(2)=bound(2)-dbound(2)
endif
C print *,'at',i,': edge',km,kp,
C * ' (',jm,' in',jml,jmu,',',jp,' in',jpl,jpu,' of',ni,')'
C print *,'dph =',dph,' area +=',darea,' =',area
C print *,'dbound =',dbound(1),dbound(2),
C * ' bound =',bound(1),bound(2)
c contribution to area and vert from end points of the segment
do 240 l=1,2
c end point is intersection of i circle with k circle
if (l.eq.1) then
k=km
elseif (l.eq.2) then
k=kp
endif
c only do ik intersection once,
c but check both ik and ki intersections made it here
c from segment k to segment i right-handedly through vertex
if ((l.eq.1.and.scmi.ge.0).or.(l.eq.2.and.scmi.lt.0)) then
ik=k+np*i
if (k.lt.i) ik=ik+1
c from segment i to segment k right-handedly through vertex
else
ik=i+np*k
if (i.lt.k) ik=ik+1
endif
c pseudo-random number from ik
call ikrand(ik,ikran)
if (i.gt.k) then
c ikchk = ikchk - ikran, subtracted as unsigned long long's
call ikrandm(ikchk,ikran)
goto 240
endif
c ikchk = ikchk + ikran, added as unsigned long long's
call ikrandp(ikchk,ikran)
cmk=abs(cm(k))
sk=sqrt(cmk*(2._10-cmk))
c cmik = 1-cos th(ik)
cmik=((rp(1,i)-rp(1,k))**2+(rp(2,i)-rp(2,k))**2
* +(rp(3,i)-rp(3,k))**2)/2._10
c bik = cik-ci*ck
c d = 1-ci^2-ck^2-cik^2+2*ci*ck*cik
c cos psi = bik/(si*sk)
c sin psi = sqrt(d)/(si*sk)
c psi = atan(sqrt(d)/bik) is exterior angle at intersection
bik=(cmi+cmk)-cmi*cmk-cmik
if ((scmi.ge.0.and.cm(k).lt.0._10)
* .or.(scmi.lt.0.and.cm(k).ge.0._10)) bik=-bik
c i and k circles kiss
if (phw(1,k).eq.phw(2,k)) then
d=0._10
else
d=-(cmi-cmk)**2+cmik*(2._10*((cmi+cmk)-cmi*cmk)-cmik)
c assert that circles at least touch
if (d.lt.0._10) d=0._10
d=sqrt(d)
endif
ctpsi=bik/d
psi=atan2(d,bik)
c increment area
area=area-psi
c t=tan psi/2
if (bik.gt.0._10) then
t=d/(bik+sqrt(bik**2+d**2))
elseif (bik.lt.0._10) then
t=(-bik+sqrt(bik**2+d**2))/d
elseif (bik.eq.0._10) then
t=1._10
endif
c cti = cot th(i)
cti=(1._10-cmi)/si
if (scmi.lt.0) cti=-cti
c ctk = cot th(k)
ctk=(1._10-cmk)/sk
if (cm(k).lt.0._10) ctk=-ctk
c standard
if (ibv.eq.0
* .or.(ibv.eq.1.and.i.gt.npc.and.k.gt.npc)
* .or.(ibv.eq.2.and.i.gt.npc.and.k.gt.npc)
* .or.(ibv.eq.3.and.((i.gt.npc.and.k.gt.npc)
* .or.(i.le.npc.and.k.le.npc)))) then
if (psi.eq.0._10) then
dvert(1)=0._10
dvert(2)=0._10
else
dvert(1)=1._10-psi*ctpsi
dvert(2)=t*(3._10+t**2)*(cti+ctk)/2._10
endif
vert(1)=vert(1)+dvert(1)
vert(2)=vert(2)+dvert(2)
c cross
elseif (ibv.eq.1) then
if (i.le.npc.and.k.le.npc) then
continue
else
dvert(1)=PI/2._10*ctpsi
dvert(2)=t*(3._10+t**2)*(cti+ctk)/2._10
vert(1)=vert(1)-dvert(1)
vert(2)=vert(2)+dvert(2)/2._10
t=1._10/t
dvert(2)=t*(3._10+t**2)*(cti-ctk)/2._10
if (i.gt.npc) then
vert(2)=vert(2)-dvert(2)/2._10
elseif (k.gt.npc) then
vert(2)=vert(2)+dvert(2)/2._10
endif
endif
c intersection
elseif (ibv.eq.2) then
if (i.le.npc.and.k.le.npc) then
if (psi.eq.0._10) then
dvert(1)=0._10
dvert(2)=0._10
else
dvert(1)=1._10-psi*ctpsi
dvert(2)=t*(3._10+t**2)*(cti+ctk)/2._10
endif
vert(1)=vert(1)-dvert(1)
vert(2)=vert(2)-dvert(2)
else
c psip = pi - psi
psip=atan2(d,-bik)
if (psip.eq.0._10) then
dvert(1)=0._10
dvert(2)=0._10
else
dvert(1)=1._10+psip*ctpsi
t=1._10/t
dvert(2)=t*(3._10+t**2)*(cti-ctk)/2._10
endif
vert(1)=vert(1)-dvert(1)
if (i.gt.npc) then
vert(2)=vert(2)-dvert(2)
elseif (k.gt.npc) then
vert(2)=vert(2)+dvert(2)
endif
endif
c union
elseif (ibv.eq.3) then
if (psi.eq.0._10) then
dvert(1)=0._10
dvert(2)=0._10
else
dvert(1)=1._10-psi*ctpsi
dvert(2)=t*(3._10+t**2)*(cti+ctk)/2._10
endif
vert(1)=vert(1)-dvert(1)
vert(2)=vert(2)+dvert(2)
endif
C print *,' intersect',i,k,' area +=',-psi,' =',area
C print *,' dvert =',dvert(1),dvert(2),
C * ' vert =',vert(1),vert(2)
C print *,' cot(',psi,') =',1._10/tan(psi),
C * ' should =',ctpsi
C print *,' tan(',psi,'/2) =',tan(psi/2._10),
C * ' should =',t
C print *,' cot(th_i) =',cti,' cot(th_k) =',ctk
c peculiar monopole term
if (ibv.ge.2) psi=-psi
w(1,1)=w(1,1)-psi/sqrt4pi
240 continue
c increment spherical transform
if (ibv.ge.2) dph=-dph
call wlm(w,lmax1,im,nw,ri,phi,0,rp(3,i),ci,si,ph,dph,v)
c do another segment
goto 220
endif
280 continue
c--------check on whether ik endpoints matched ki endpoints
if (ikchk.ne.0._10) then
C warn=.true.
c print *,'*** from gspher: at tol =',tol,
c * ', ikchk=',ikchk,' should be 0'
c retry with enlarged tolerance
call gtol(tol,tolin)
goto 100
endif
c--------add/subtract 2*pi's to area
retry=garpi(area,iarea,rp,cm,np,whole,nbd0m,nbd0p,nbd,nmult)
c adjust monopole harmonic by corresponding 2*pi/sqrt(4*pi)
if (ibv.eq.0.or.ibv.eq.1) then
i=nint((w(1,1)*sqrt4pi-area)/TWOPI)
elseif (ibv.eq.2.or.ibv.eq.3) then
i=nint((w(1,1)*sqrt4pi+area)/TWOPI)
endif
w(1,1)=w(1,1)-i*TWOPI/sqrt4pi
c retry with modified tolerance
if (retry.eq.1) then
C warn=.true.
call gtol(tol,tolin)
goto 100
endif
c--------done
410 continue
C if (warn) then
C write (*,'(a3,a20,4a24)')
C * ' ','x','y','z',
c * 'r',
C * '1-c'
C do j=1,np
C write (*,'(i3,5g24.16)')
C * j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
C * cm(j)
C enddo
C endif
C print *,'final area =',area,' bound =',bound(1),bound(2),
C * ' vert =',vert(1),vert(2)
C print *,'....................'
return
c
420 print *,'*** from gspher: total failure at tol =',tol
ldegen=.true.
write (*,'(a3,a20,4a24)')
* ' ','x','y','z',
c * 'r',
* '1-c'
do j=1,np
write (*,'(i3,5g24.16)')
* j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
* cm(j)
enddo
C print *,'....................'
return
c
end
c

144
src/gsphera.s.f Normal file
View file

@ -0,0 +1,144 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gsphera(area,bound,vert,w,lmax1,im,nw,ibv,
* azmin,azmax,elmin,elmax,v,dw)
integer lmax1,im,nw,ibv
real*10 area,bound(2),vert(2),w(im,nw),
* azmin,azmax,elmin,elmax,dw(nw)
c work array (could be automatic if compiler supports it)
real*10 v(lmax1)
c
c parameters
include 'pi.par'
real*10 TWOPI,PIBYTWO
parameter (TWOPI=2._10*PI,PIBYTWO=PI/2._10)
c data variables
real*10 elmino,elmaxo
c saved variables
real*10 cl,cu,dth,sl,su
save cl,cu,dth,sl,su
c local (automatic) variables
integer i,l,m,lm,lmax,mmax
real*10 azmx,cmph,d,dph,ph,smph,thmin,thmax
c *
c * Accelerated computation of spherical transform
c * of rectangle bounded by lines of constant latitude & longitude.
c *
c Input: lmax1 = lmax+1 where lmax is maximum desired l of transform.
c im = 1 means compute only real part of harmonics;
c 2 means compute both real and imaginary parts.
c Note harmonics are real if region possesses reflection
c symmetry through plane defined by x- and z-axes.
c nw = [(lmax+1)*(lmax+2)]/2
c ibv = 0 to 3 controls evaluation of bound & vert,
c and determines the sign of the returned harmonics,
c same as in gspher;
c see comments in gspher for more details.
c azmin, azmax = minimum, maximum azimuth of rectangle in radians;
c if azmin > azmax, it is assumed that the rectangle
c runs from azmin to azmax + 2*pi .
c To cover an entire strip of latitude, use
c azmin, azmax = 0, 2*pi .
c elmin, elmax = minimum, maximum elevation of rectangle in radians;
c South pole is at elevation -pi/2, North at +pi/2.
c Output: area = area of rectangle in steradians.
c bound = length of boundary of rectangle in radians if ibv=0,
c or as explained in gspher ibv>0.
c vert = sum over vertices of 1-psi/tan(psi) if ibv=0,
c where psi is exterior angle (=pi-interior angle)
c at vertex, or as explained in gspher if ibv>0.
c dw = integral_thmin^thmax Y_lm(th,0) sin th d th,
c which should be saved between calls.
c Input/Output: w(i,lm) = spherical transform, dimensioned w(im,nw)
c w(i,lm), i=1,im, lm=l*(l+1)/2+m+1, l=0,lmax, m=0,l;
c w(1,lm) is real part, w(2,lm) is imaginary part (if im=2).
c Note w(l,-m)=(-)**m*[Complex conjugate of w(l,m)], just as
c Y(l,-m)=(-)**m*[Complex conjugate of Y(l,m)].
c Work arrays: v should be dimensioned at least lmax1.
c
data elmino,elmaxo /2*0._10/
c
c zero stuff
area=0._10
bound(1)=0._10
bound(2)=0._10
vert(1)=0._10
vert(2)=0._10
do lm=1,nw
do i=1,im
w(i,lm)=0._10
enddo
enddo
c check input parameters OK
if (lmax1.le.0) goto 200
if (elmin.ge.PIBYTWO.or.elmax.le.-PIBYTWO) goto 200
if (elmin.ge.elmax) goto 200
azmx=azmax
c assume azmax.lt.azmin means need to add 2*pi to azmax
if (azmx.lt.azmin) azmx=azmx+TWOPI
c--------compute integrals of harmonics if elmin and elmax changed
if (elmino.ne.elmin.or.elmaxo.ne.elmax) then
if (elmax.ge.PIBYTWO) then
thmin=0._10
cu=1._10
su=0._10
else
thmin=PIBYTWO-elmax
cu=cos(thmin)
su=sin(thmin)
endif
if (elmin.le.-PIBYTWO) then
thmax=PI
cl=-1._10
sl=0._10
else
thmax=PIBYTWO-elmin
cl=cos(thmax)
sl=sin(thmax)
endif
dth=thmax-thmin
c integrals of harmonics: this takes most time
call iylm(thmin,thmax,dw,lmax1,nw,v)
elmaxo=elmax
elmino=elmin
endif
c--------fast computation of harmonics
dph=azmx-azmin
area=(cu-cl)*dph
if (ibv.eq.0.or.ibv.eq.2.or.ibv.eq.3) then
bound(1)=(sl+su)*dph+2._10*dth
bound(2)=(1._10/sl-2._10*sl+1._10/su-2._10*su)*dph-2._10*dth
vert(1)=4._10
vert(2)=4._10*(cl/sl-cu/su)
if (ibv.eq.2) then
bound(1)=-bound(1)
bound(2)=-bound(2)
vert(1)=-vert(1)
vert(2)=-vert(2)
endif
endif
ph=(azmx+azmin)/2._10
if (ibv.ge.2) dph=-dph
lmax=lmax1-1
mmax=lmax
if (dph-nint(dph/TWOPI)*TWOPI.eq.0._10) mmax=0
do m=0,mmax
if (m.eq.0) then
d=dph
elseif (m.gt.0) then
d=sin(m*dph/2._10)*2._10/dble(m)
endif
cmph=cos(m*ph)
smph=sin(m*ph)
lm=(m*(m+1))/2+1
do l=m,lmax
lm=lm+l
w(1,lm)=w(1,lm)+cmph*d*dw(lm)
if (im.eq.2) w(2,lm)=w(2,lm)-smph*d*dw(lm)
enddo
enddo
200 continue
return
end
c

146
src/gsphr.c Normal file
View file

@ -0,0 +1,146 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdlib.h>
#include <stdio.h>
#include "manglefn.h"
#include "pi.h"
/*------------------------------------------------------------------------------
Spherical harmonics of polygon.
This is a simplified c interface to fortran subroutine gspher.
It returns the spherical harmonics, and does not worry about bound and vert.
Input: poly is a polygon.
lmax = maximum harmonic number.
Input/Output: *tol = angle within which to merge multiple intersections.
Output: w = array containing spherical harmonics of polygon;
NW = ((lmax + 1)(lmax + 2))/ 2 is defined in harmonics.h.
Return value: 0 if ok;
1 if fatal error;
-1 if could not allocate temporary memory.
*/
int gsphr(polygon *poly, int lmax, long double *tol, harmonic w[/*NW*/])
{
logical ldegen;
int i, ibv, ier, im, iphi, iw, lmax1, npc, nw, verb;
long double area, bound[2], darea, vert[2];
/* work arrays */
int *iord;
long double *v, *phw;
/* determine area without 2 pi ambiguity, and a good value for tol */
verb = 1;
ier = garea(poly, tol, verb, &area);
if (ier) return(ier);
/* trivial case of zero area */
if (area == 0.) {
for (iw = 0; iw < NW; iw++) {
for (i = 0; i < IM; i++) w[iw][i] = 0.;
}
return(0);
}
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * poly->np * 2);
if (!iord) {
fprintf(stderr, "gsphr: failed to allocate memory for %d ints\n", poly->np * 2);
return(-1);
}
phw = (long double *) malloc(sizeof(long double) * poly->np * 2);
if (!phw) {
fprintf(stderr, "gsphr: failed to allocate memory for %d long doubles\n", poly->np * 2);
return(-1);
}
v = (long double *) malloc(sizeof(long double) * (lmax + 1));
if (!v) {
fprintf(stderr, "gsphr: failed to allocate memory for %d long doubles\n", lmax + 1);
return(-1);
}
/* parameters */
lmax1 = lmax + 1;
im = IM;
nw = NW;
npc = 0;
ibv = 0;
iphi = 0;
/* the fortran routine */
gspher_(&darea, bound, vert, w, &lmax1, &im, &nw, poly->rp, poly->cm, &poly->np, &npc, &ibv, &iphi, tol, phw, iord, v, &ldegen);
/* monopole harmonic without 2 pi/sqrtl(4 pi) ambiguity */
w[0][0] = area / sqrtl(4. * PI);
/* free work arrays */
free(iord);
free(phw);
free(v);
/* fatal error */
if (ldegen) return(1);
return(0);
}
/*------------------------------------------------------------------------------
Accelerated computation of spherical harmonics of rectangle.
This is a simplified c interface to fortran subroutine gsphera.
It returns the spherical harmonics, and does not worry about bound and vert.
The acceleration involves some overhead, and works only if two or more
rectangles with the same elmin & elmax are computed in succession.
The overhead means that the accelerated computation is actually slightly
slower for just a single rectangle.
Input: lmax = maximum harmonic number.
Output: w = array containing spherical harmonics of polygon;
NW = ((lmax + 1)(lmax + 2))/ 2 is defined in harmonics.h.
Return value: 0 if ok;
-1 if could not allocate temporary memory.
*/
int gsphra(long double azmin, long double azmax, long double elmin, long double elmax, int lmax, harmonic w[/*NW*/])
{
/* array used for acceleration */
static long double *dw = 0x0;
int ibv, im, lmax1, nw;
long double area, bound[2], vert[2];
/* work array */
long double *v;
/* allocate memory for work arrays */
v = (long double *) malloc(sizeof(long double) * (lmax + 1));
if (!v) {
fprintf(stderr, "gsphra: failed to allocate memory for %d long doubles\n", lmax + 1);
return(-1);
}
/* parameters */
lmax1 = lmax + 1;
im = IM;
nw = NW;
ibv = 0;
/* dw contains array that is pre-computed, then used by all rects with same elmin, elmax */
if (!dw) {
dw = (long double *) malloc(sizeof(long double) * NW);
if (!dw) {
fprintf(stderr, "gsphra: failed to allocate memory for %d long doubles\n", NW);
return(-1);
}
}
/* fortran routine */
gsphera_(&area, bound, vert, w, &lmax1, &im, &nw, &ibv, &azmin, &azmax, &elmin, &elmax, v, dw);
/* free work array */
free(v);
return(0);
}

1304
src/gsubs.s.f Normal file

File diff suppressed because it is too large Load diff

215
src/gvert.c Normal file
View file

@ -0,0 +1,215 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include "manglefn.h"
/* number of extra vertices to allocate, to allow for expansion */
#define DNV 4
/*------------------------------------------------------------------------------
Points on edges of polygon.
This is a wrapper around gvert,
that calls gvert until the arrays are large enough.
Input: poly is a polygon.
vcirc = 1 to return vertices and midpoints also for bounding circles
which have no intersections;
= 0 not so.
per = 0 or 1 controls meaning of nve.
if per = 0:
nve = desired number of points on each edge, including vertex;
if per = 1:
nve = desired number of points per (2 pi) on each edge.
Input/Output: *tol = angle within which to merge multiple intersections.
Output: *nv = number of vertices.
*ve_p = pointer to array ve[nv][nve] of points on edges;
memory for the array is allocated.
*angle_p = pointer to array angle[nv] of lengths of edges;
memory for the array is allocated.
*ipv_p = pointer to array ipv[nv] containing cap number of iv'th edge;
that is, ve[iv] lie on cap number ipv;
memory for the array is allocated.
*gp_p = pointer to array gp[np] giving group circle belongs to;
memory for the array is allocated.
*nev = number of connected sequences of vertices.
*nev0 = number of bounding circles which have no intersections.
*ev_p = pointer to array ev[nv] of end indices;
memory for the array is allocated.
Return value: 0 if ok;
1 if fatal degenerate intersection of boundaries;
-1 if could not allocate memory.
*/
int gverts(polygon *poly, int vcirc, long double *tol, int per, int nve, int *nv, vec **ve_p, long double **angle_p, int **ipv_p, int **gp_p, int *nev, int *nev0, int **ev_p)
{
static int nvmax = 0, nvemax = 0, npmax = 0;
static int *ipv = 0x0, *gp = 0x0, *ev = 0x0;
static long double *angle = 0x0;
static vec *ve = 0x0;
int ier;
/* putative maximum number of vertices */
if (poly->np <= 1) {
*nv = poly->np;
} else if (poly->np <= 4) {
*nv = poly->np * (poly->np - 1);
} else {
*nv = 6 * (poly->np - 2);
}
/* keep trying till the arrays are big enough */
do {
/* make sure that allocated arrays contain enough space */
if (!ve || !angle || !ipv || !ev || *nv > nvmax) {
if (ve) free(ve);
if (angle) free(angle);
if (ipv) free(ipv);
if (ev) free(ev);
if (nve > nvemax) nvemax = nve + DNV;
ve = (vec *) malloc(sizeof(vec) * (*nv + DNV) * nvemax);
if (!ve) {
fprintf(stderr, "gverts: failed to allocate memory for %d x %d vecs\n", *nv + DNV, nvemax);
return(-1);
}
angle = (long double *) malloc(sizeof(long double) * (*nv + DNV));
if (!angle) {
fprintf(stderr, "gverts: failed to allocate memory for %d long doubles\n", *nv + DNV);
return(-1);
}
ipv = (int *) malloc(sizeof(int) * (*nv + DNV));
if (!ipv) {
fprintf(stderr, "gverts: failed to allocate memory for %d ints\n", *nv + DNV);
return(-1);
}
ev = (int *) malloc(sizeof(int) * (*nv + DNV));
if (!ev) {
fprintf(stderr, "gverts: failed to allocate memory for %d ints\n", *nv + DNV);
return(-1);
}
nvmax = *nv + DNV;
} else if (nve > nvemax) {
if (ve) free(ve);
ve = (vec *) malloc(sizeof(vec) * nvmax * (nve + DNV));
if (!ve) {
fprintf(stderr, "gverts: failed to allocate memory for %d x %d vecs\n", nvmax, nve + DNV);
return(-1);
}
nvemax = nve + DNV;
}
if (!gp || poly->np > npmax) {
if (gp) free(gp);
gp = (int *) malloc(sizeof(int) * (poly->np + DNV));
if (!gp) {
fprintf(stderr, "gverts: failed to allocate memory for %d ints\n", poly->np + DNV);
return(-1);
}
npmax = poly->np + DNV;
}
/* compute vertices of polygon */
ier = gvert(poly, vcirc, tol, nvmax, per, nve, nv, ve, angle, ipv, gp, nev, nev0, ev);
if (ier) return(1);
} while (*nv > nvmax);
/* point ve_p, angle_p, ipv_p, gp_p, and ev_p at ve, angle, ipv, gp, and ev */
*ve_p = ve;
*angle_p = angle;
*ipv_p = ipv;
*gp_p = gp;
*ev_p = ev;
return(0);
}
/*------------------------------------------------------------------------------
Vertices of polygon.
This is a c interface to fortran subroutine gvert.
Input: poly is a polygon.
vcirc = 1 to return vertices and midpoints also for bounding circles
which have no intersections;
= 0 not so.
nvmax = dimension of ve[nvmax][nve], angle[nvmax], ipv[nvmax], and ev[nvmax].
per = 0 or 1 controls meaning of nve.
if per = 0:
nve = desired number of points on each edge, including vertex;
if per = 1:
nve = desired number of points per (2 pi) on each edge.
Input/Output: *tol = angle within which to merge multiple intersections.
Output: *nv = number of vertices.
ve[nv][nve] = points on edges of polygon.
angle[nv] = angular lengths of edges of polygon.
ipv[nv] = cap number of vertices/edges;
that is, vertex v[i] and edge points ve[i]
lie on cap number ipv.
gp[np] = which group of intersecting circles each circle belongs to.
*nev = number of connected sequences of vertices.
*nev0 = number of bounding circles which have no intersections.
ev[nev] = end indices of each connected sequence of vertices.
Return value: 0 if ok;
1 if fatal intersection of boundaries;
-1 if failed to allocate memory.
*/
int gvert(polygon *poly, int vcirc, long double *tol, int nvmax, int per, int nve, int *nv, vec ve[/*nvmax * nve*/], long double angle[/*nvmax*/], int ipv[/*nvmax*/], int gp[/*poly->np*/], int *nev, int *nev0, int ev[/*nvmax*/])
{
int iv;
logical ldegen;
/* work arrays */
int *iord, *iwk;
long double *phi, *wk;
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * poly->np * 2);
if (!iord) {
fprintf(stderr, "gvert: failed to allocate memory for %d ints\n", poly->np * 2);
return(-1);
}
phi = (long double *) malloc(sizeof(long double) * poly->np * 2);
if (!phi) {
fprintf(stderr, "gvert: failed to allocate memory for %d long doubles\n", poly->np * 2);
return(-1);
}
iwk = (int *) malloc(sizeof(int) * nvmax * 4);
if (!iwk) {
fprintf(stderr, "gvert: failed to allocate memory for %d ints\n", nvmax * 4);
return(-1);
}
wk = (long double *) malloc(sizeof(long double) * nvmax);
if (!wk) {
fprintf(stderr, "gvert: failed to allocate memory for %d long doubles\n", nvmax);
return(-1);
}
/* fortran routine */
gvert_(ve, angle, ipv, gp, ev, &nvmax, nv, &per, &nve, nev, nev0, poly->rp, poly->cm, &poly->np, &vcirc, tol, phi, iord, wk, iwk, &ldegen);
/* number of vertices exceeds putative maximum */
if (poly->np >= 5 && *nv > 6 * (poly->np - 2)) {
msg("CONGRATULATIONS! YOU HAVE DISCOVERED A POLYGON WITH 5 OR MORE CAPS\n");
msg("(IT HAS %d CAPS) THAT HAS MORE THAN %d VERTICES (IT HAS %d VERTICES).\n", poly->np, 6 * (poly->np - 2), *nv);
msg("(Either that or you have found a bug.)\n");
msg("PLEASE EMAIL ME Andrew.Hamilton@colorado.edu THE GOOD NEWS,\n");
msg("ALONG WITH A POLYGON FILE CONTAINING THE POLYGON THAT DID IT.\n");
dump_poly(1, &poly);
msg("AND THERE'S THE POLYGON FILE I'D LIKE YOU TO SEND. THANKS!\n");
}
/* convert vertex/edge indices from fortran to c convention */
for (iv = 0; iv < *nv && iv < nvmax; iv++) ipv[iv]--;
/* free work arrays */
free(iord);
free(phi);
free(iwk);
free(wk);
/* fatal intersection of boundaries */
if (ldegen) return(1);
return(0);
}

361
src/gvert.s.f Normal file
View file

@ -0,0 +1,361 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gvert(ve,angle,ipv,gp,ev,nvmax,nv,per,nve,nev,nev0,
* rp,cm,np,vcirc,tol,phi,iord,wk,iwk,ldegen)
integer nvmax,ipv(nvmax),np,gp(np),ev(nvmax),nv,per,nve,nev,nev0,
* vcirc
logical ldegen
real*10 ve(3,nve,nvmax),angle(nvmax),rp(3,np),cm(np),tol
c work arrays (could be automatic if compiler supports it)
integer iord(2*np),iwk(nvmax,4)
real*10 phi(2,np),wk(nvmax)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c intrinsics
intrinsic abs
c externals
integer gsegij,gzeroar
c data variables
real*10 big
c real*10 dphmin
c local (automatic) variables
integer i,ii,ik,iseg,iv,ive,j,jm,jml,jmu,jp,jpl,jpu,km,kp,
* mve,ni,scmi
C logical warn
real*10 amve,cmi,dph,ikchk,ph,phm,php
real*10 si,tolin,xi(3),xv,yi(3),yv,zv
c *
c * Vertices, plus points on edges, of the polygon defined by
c * 1 - r.rp(i) < cm(i) (if cm(i).ge.0)
c * 1 - r.rp(i) > -cm(i) (if cm(i).lt.0)
c * for i=1,np where rp(i) are unit directions.
c *
c * Since each pair of circles can intersect at at most 2 points,
c * an upper limit on the number of possible vertices is np*(np-1),
c * twice the number of distinct pairs of np objects.
c * I can find configurations which exhaust this bound for np <= 4.
c * For np >= 4, I can find configurations with 6*(np-2) vertices,
c * namely, form two triangles from the intersection of 3 caps
c * (producing 6 vertices),
c * then for each additional cap, inscribe it as an excluding cap
c * inside one of the triangles, so as to transform that one
c * triangle (with 3 vertices) into 3 triangles (with 9 vertices).
c *
c * gp(i) is the group of circles to which circle i belongs.
c * Two circles are friends, belonging to the same group,
c * if they intersect, and friends of friends are friends.
c * Theorem: A polygon is not simply-connected
c * if and only if its boundaries belong to distinct groups.
c * The group number is the smallest circle number of circles
c * within the group.
c *
c * Connected sequences of vertices are ordered by group,
c * with the lowest group numbers coming first, except that
c * intersecting boundaries come 1st, then non-intersecting boundaries.
c * Each connected sequence of vertices is ordered right-handedly
c * about the polygon, with the vertices belonging to the lowest
c * circle numbers coming first.
c * The array ev records the end index of each connected
c * sequences of vertices.
c * If the polygon is connected and simply-connected, the usual case,
c * then ev(1) = nv on output, and ev(i) = 0 for i >= 2.
c * If the polygon is not connected and simply-connected,
c * then the number of non-zero elements of ev will equal the
c * number of distinct connected boundaries of the polygon.
c *
c Input: nvmax = guess at maximum nv;
c must be >= np;
c recommend:
c = np if 0 <= np <= 2
c = np*(np-1) if 2 <= np <= 4
c = 6*(np-2) if np >= 4
c rp(3,i),i=1,np
c cm(i),i=1,np
c np
c per = controls meaning of nve
c = 0 for nve points per edge
c = 1 for nve points per 2 pi on each edge,
c rounded up, so there is at least 1 point per edge;
c excess points are set to zero.
c nve = desired number of points per edge
c = 1 for vertices only
c = 2 for vertices + midpoints of edges
c >= 2 for vertices + (nve-1) non-vertex points per edge.
c vcirc = 1 to return vertices and edge points also for bounding
c circles which do not intersect any other circle;
c = 0 otherwise.
c Output: ve(3,ive,iv),ive=1,nve,iv=1,nv are points uniformly spaced
c along the edges of the polygon,
c starting with vertices in ve(3,1,iv).
c angle(iv),i=1,nv are azimuthal lengths of edges of polygon.
c ipv(iv),iv=1,nv is the circle number of the iv'th edge,
c that is,points ve(*,ive,iv) lie on circle number ipv.
c gp(i),i=1,np = which group circle i belongs to:
c circle i and circle j are friends if they intersect,
c and friends of friends are friends.
c ev(i),i=1,nev = end index of each connected sequence of edges;
c the number of non-zero elements of ev is the number
c nev of connected boundaries of the polygon,
c and the last nev0 of these are non-intersecting.
c nv = number of points;
c if this exceeds nvmax, then you should call gvert again
c with a larger nvmax.
c nev = number of connected sequences of vertices,
c including those in non-intersecting circles.
c nev0 = number of non-intersecting boundary circles if vcirc=1;
c = 0 if vcirc=0;
c non-intersecting boundaries come last in ve,
c and the last nev0 entries of ev(i) refer
c to non-intersecting boundaries.
c ldegen = .true. means there's a problem with multiply
c intersecting boundary.
c Input/Output: tol
c Work arrays: phi and iord should be dimensioned at least 2*np.
c iwk should be dimensioned at least 4*nvmax.
c wk should be dimensioned at least nvmax.
c
c data dphmin /1.e-8_10/
data big /1.e6_10/
c
c input tolerance to multiple intersections
tolin=tol
C print *,'--------------------'
c come here with modified tolerance
100 continue
c initialise error flag to no error
ldegen=.false.
C warn=.false.
c zero number of vertices
nv=0
nev=0
nev0=0
c initialise ev to zero
do iv=1,nvmax
ev(iv)=0
enddo
c initially each circle is its own group
do i=1,np
gp(i)=i
enddo
c check for zero area because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
c error check on evaluation of vertex terms
ikchk=0._10
c initialise iwk to inadmissible values
do iv=1,nvmax
iwk(iv,2)=-1
enddo
do iv=1,nvmax
iwk(iv,3)=-1
enddo
c--------identify boundary segments around each circle i in turn
do 280 i=1,np
c cm(i).ge.2 means include whole sphere, which is no constraint
if (cm(i).ge.2._10) goto 280
c scmi * cmi = 1-cos th(i)
if (cm(i).ge.0._10) then
scmi=1
else
scmi=-1
endif
cmi=abs(cm(i))
c si = sin th(i)
si=sqrt(cmi*(2._10-cmi))
c........construct cartesian axes with z-axis along rp(i)
call gaxisi(rp(1,i),xi,yi)
c........angles phi about z-axis rp(i) of intersection of i & j circles
call gphij(rp,cm,np,i,rp(1,i),scmi,cmi,xi,yi,big,tol,ni,phi)
c i circle lies outside polygon
if (ni.eq.-1) goto 280
c area of polygon is zero
if (ni.eq.-2) then
nv=0
nev=0
nev0=0
goto 410
endif
c........i circle has no intersections
if (ni.eq.0) then
c want vertices and midpoints for circles without intersections
if (vcirc.eq.1) then
c introduce pretend circle 0
do j=1,2
if (j.eq.1) then
ii=0
km=i
kp=i
phm=0._10
php=PI
elseif (j.eq.2) then
ii=i
km=0
kp=0
phm=PI
php=TWOPI
endif
dph=php-phm
nv=nv+1
if (nv.le.nvmax) then
c edge index of this vertex
ipv(nv)=i
c azimuthal length of edge
angle(nv)=dph
c edge points
zv=1._10-cmi
if (per.eq.0) then
mve=nve
else
amve=nve*(dph/TWOPI)
mve=amve
if (dble(mve).lt.amve) mve=mve+1
endif
do ive=1,mve
if (cm(i).ge.0._10) then
ph=(phm*(mve-ive+1)+php*(ive-1))/dble(mve)
else
ph=(php*(mve-ive+1)+phm*(ive-1))/dble(mve)
endif
xv=si*cos(ph)
yv=si*sin(ph)
ve(1,ive,nv)=zv*rp(1,i)+xv*xi(1)+yv*yi(1)
ve(2,ive,nv)=zv*rp(2,i)+xv*xi(2)+yv*yi(2)
ve(3,ive,nv)=zv*rp(3,i)+xv*xi(3)+yv*yi(3)
enddo
do ive=mve+1,nve
ve(1,ive,nv)=0._10
ve(2,ive,nv)=0._10
ve(3,ive,nv)=0._10
enddo
endif
c record endpoints of edge
call gvtrail(scmi,np,ii,km,kp,iwk,iwk(1,2),nvmax,nv,
* ik,ikchk)
enddo
nev0=nev0+1
endif
C print *,'at',i,': full circle'
c........i circle has intersections
elseif (ni.gt.0) then
c........friends of i circle
call ggpij(np,gp,i,big,phi)
c........find ordering of intersection angles around i circle
call findbot(phi,2*np,iord,ni)
c........vertices around i circle
jpl=0
c come here to do another segment
220 continue
c........is segment edge of polygon?
iseg=gsegij(rp,cm,np,0,0,i,rp(1,i),scmi,cmi,tol,ni,
* phi,iord,jml,jmu,jpl,jpu,1,jm,jp,km,kp,phm,php,ph,dph)
c error
if (iseg.eq.-1) goto 420
c not an edge
if (iseg.eq.0) goto 220
c gone full circle
if (iseg.eq.2) goto 280
c........segment is edge
c warn about near multiple intersection
c if (dph.lt.dphmin) then
c print *,'*** warning from gvert: near multiple intersectio
c *n at',i,': edge',km,kp,' dph=',real(dph)
c warn=.true.
c endif
C print *,'at',i,': edge',km,kp,
C * ' (',jm,' in',jml,jmu,',',jp,' in',jpl,jpu,' of',ni,')',
C * ' ph=',real(ph),' dph=',real(dph)
nv=nv+1
if (nv.le.nvmax) then
c edge index of this vertex
ipv(nv)=i
c azimuthal length of edge
angle(nv)=dph
c edge points
zv=1._10-cmi
if (per.eq.0) then
mve=nve
else
amve=nve*(dph/TWOPI)
mve=amve
if (dble(mve).lt.amve) mve=mve+1
endif
do ive=1,mve
if (cm(i).ge.0._10) then
ph=(phm*(mve-ive+1)+php*(ive-1))/dble(mve)
else
ph=(php*(mve-ive+1)+phm*(ive-1))/dble(mve)
endif
xv=si*cos(ph)
yv=si*sin(ph)
ve(1,ive,nv)=zv*rp(1,i)+xv*xi(1)+yv*yi(1)
ve(2,ive,nv)=zv*rp(2,i)+xv*xi(2)+yv*yi(2)
ve(3,ive,nv)=zv*rp(3,i)+xv*xi(3)+yv*yi(3)
enddo
do ive=mve+1,nve
ve(1,ive,nv)=0._10
ve(2,ive,nv)=0._10
ve(3,ive,nv)=0._10
enddo
endif
c record endpoints of edge
call gvtrail(scmi,np,i,km,kp,iwk,iwk(1,2),nvmax,nv,ik,ikchk)
c do another segment
goto 220
endif
280 continue
c--------check on whether ik endpoints matched ki endpoints
if (ikchk.ne.0._10) then
C warn=.true.
C print *,'*** from gvert: at tol =',tol,
C * ', ikchk=',ikchk,' should be 0'
c retry with modified tolerance
call gtol(tol,tolin)
goto 100
elseif (tol.gt.0._10) then
C print *,'... from gvert: success at tol =',tol
endif
c--------order vertices right-handedly about polygon
if (nv.gt.0.and.nv.le.nvmax) then
c........which group of friends each circle belongs to
call ggp(np,gp)
c........find order of vertices around polygon
call gvord(np,nv,ipv,gp,ev,nev,iwk,iwk(1,2),iwk(1,3),iwk(1,4))
c........reorder vertices
call vpermi(ipv,nv,iwk(1,2),iwk(1,3))
call vpermdd(ve,3*nve,nv,iwk(1,2),wk)
call vpermd(angle,nv,iwk(1,2),wk)
endif
c--------done
410 continue
C if (warn) then
C write (*,'(a3,a20,4a24)')
C * ' ','x','y','z','r','1-c'
C write (*,'(i3,5g24.16)')
C * (j,(rp(i,j),i=1,3),sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
C * cm(j),j=1,np)
C endif
c if (nv.gt.nvmax) then
c print *,'*** from gvert: number of vertices =',nv,
c * ' exceeds maximum',nvmax
c endif
return
c
420 print *,'*** from gvert: total failure at tol = ',tol
write (*,'(a3,a20,4a24)')
* ' ','x','y','z',
c * 'r',
* '1-c'
do j=1,np
write (*,'(i3,5g24.16)')
* j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
* cm(j)
enddo
ldegen=.true.
return
c
end
c

237
src/gvlim.c Normal file
View file

@ -0,0 +1,237 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include "manglefn.h"
/* number of extra vertices to allocate, to allow for expansion */
#define DNV 4
/*------------------------------------------------------------------------------
Points on polygon nearest to and farthest from unit direction vi,
and minimum and maximum values of cm=1-cosl(theta)
between polygon and unit vector vi.
This is a wrapper around gvlim,
that calls gvlim until the arrays are large enough.
Input: poly is a polygon.
vcirc = 1 to return vertices and midpoints also for bounding circles
which have no intersections;
= 0 not so.
vi = unit vector.
Input/Output: *tol = angle within which to merge multiple intersections.
Output: *nv = number of vertices.
*vmin_p, vmax_p = pointers to arrays vmin[nv], vmax[nv]
giving nearest and farthest points from unit vector vi
on each edge; memory for the arrays is allocated.
*cmvmin_p, *cmvmax_p = pointer to arrays cmvmin[nv], cmvmax[nv]
giving minimum and maximum cm=1-cosl(theta)
between each edge and unit vector vi;
memory for the arrays is allocated.
*cmpmin_p, *cmpmax_p = pointer to arrays cmpmin[np], cmpmax[np]
giving minimum and maximum cm=1-cosl(theta)
between each circle and unit vector vi;
memory for the arrays is allocated.
*ipv_p = pointer to array ipv[nv] containing cap number of iv'th edge;
that is, ve[iv] lie on cap number ipv;
memory for the array is allocated.
*gp_p = pointer to array gp[np] giving group circle belongs to;
memory for the array is allocated.
*nev = number of connected sequences of vertices.
*nev0 = number of bounding circles which have no intersections.
*ev_p = pointer to array ev[nv] of end indices;
memory for the array is allocated.
Return value: 0 if ok;
1 if fatal degenerate intersection of boundaries;
-1 if failed to allocate memory.
*/
int gvlims(polygon *poly, int vcirc, long double *tol, vec vi, int *nv, vec **vmin_p, vec **vmax_p, long double **cmvmin_p, long double **cmvmax_p, long double **cmpmin_p, long double **cmpmax_p, int **ipv_p, int **gp_p, int *nev, int *nev0, int **ev_p)
{
static int nvmax = 0, npmax = 0;
static int *ipv = 0x0, *gp = 0x0, *ev = 0x0;
static long double *cmvmin = 0x0, *cmvmax = 0x0, *cmpmin = 0x0, *cmpmax = 0x0;
static vec *vmin = 0x0, *vmax = 0x0;
int ier;
/* putative maximum number of vertices */
if (poly->np <= 1) {
*nv = poly->np;
} else if (poly->np <= 4) {
*nv = poly->np * (poly->np - 1);
} else {
*nv = 6 * (poly->np - 2);
}
/* keep trying till the arrays are big enough */
do {
/* make sure that allocated arrays contain enough space */
if (!vmin || !vmax || !cmvmin || !cmvmax || !ipv || !ev || *nv > nvmax) {
if (vmin) free(vmin);
if (vmax) free(vmax);
if (cmvmin) free(cmvmin);
if (cmvmax) free(cmvmax);
if (ipv) free(ipv);
if (ev) free(ev);
vmin = (vec *) malloc(sizeof(vec) * (*nv + DNV));
if (!vmin) {
fprintf(stderr, "gvlims: failed to allocate memory for %d vecs\n", *nv + DNV);
return(-1);
}
vmax = (vec *) malloc(sizeof(vec) * (*nv + DNV));
if (!vmax) {
fprintf(stderr, "gvlims: failed to allocate memory for %d vecs\n", *nv + DNV);
return(-1);
}
cmvmin = (long double *) malloc(sizeof(long double) * (*nv + DNV));
if (!cmvmin) {
fprintf(stderr, "gvlims: failed to allocate memory for %d long doubles\n", *nv + DNV);
return(-1);
}
cmvmax = (long double *) malloc(sizeof(long double) * (*nv + DNV));
if (!cmvmax) {
fprintf(stderr, "gvlims: failed to allocate memory for %d long doubles\n", *nv + DNV);
return(-1);
}
ipv = (int *) malloc(sizeof(int) * (*nv + DNV));
if (!ipv) {
fprintf(stderr, "gvlims: failed to allocate memory for %d ints\n", *nv + DNV);
return(-1);
}
ev = (int *) malloc(sizeof(int) * (*nv + DNV));
if (!ev) {
fprintf(stderr, "gvlims: failed to allocate memory for %d ints\n", *nv + DNV);
return(-1);
}
nvmax = *nv + DNV;
}
if (!cmpmin || !cmpmax || !gp || poly->np > npmax) {
if (cmpmin) free(cmpmin);
if (cmpmax) free(cmpmax);
if (gp) free(gp);
cmpmin = (long double *) malloc(sizeof(long double) * (poly->np + DNV));
if (!cmpmin) {
fprintf(stderr, "gvlims: failed to allocate memory for %d long doubles\n", poly->np + DNV);
return(-1);
}
cmpmax = (long double *) malloc(sizeof(long double) * (poly->np + DNV));
if (!cmpmax) {
fprintf(stderr, "gvlims: failed to allocate memory for %d long doubles\n", poly->np + DNV);
return(-1);
}
gp = (int *) malloc(sizeof(int) * (poly->np + DNV));
if (!gp) {
fprintf(stderr, "gvlims: failed to allocate memory for %d ints\n", poly->np + DNV);
return(-1);
}
npmax = poly->np + DNV;
}
/* compute vertices of polygon */
ier = gvlim(poly, vcirc, tol, vi, nvmax, nv, vmin, vmax, cmvmin, cmvmax, cmpmin, cmpmax, ipv, gp, nev, nev0, ev);
if (ier) return(ier);
} while (*nv > nvmax);
/* point arguments at allocated arrays */
*vmin_p = vmin;
*vmax_p = vmax;
*cmvmin_p = cmvmin;
*cmvmax_p = cmvmax;
*cmpmin_p = cmpmin;
*cmpmax_p = cmpmax;
*ev_p = ev;
return(0);
}
/*------------------------------------------------------------------------------
Points on polygon nearest to and farthest from unit direction vi,
and minimum and maximum values of cm=1-cosl(theta)
between polygon and unit vector vi.
This is a c interface to fortran subroutine gvlim.
Input: poly is a polygon.
vcirc = 1 to return vertices and midpoints also for bounding circles
which have no intersections;
= 0 not so.
vi = unit vector.
nvmax = dimension of v[nvmax] and ev[nmax].
Input/Output: *tol = angle within which to merge multiple intersections.
Output: *nv = number of vertices.
vmin[nv], vmax[nv] = arrays giving nearest and farthest
points from unit vector vi on each edge.
cmvmin[nv], cmvmax[nv] = minimum and maximum cm=1-cosl(theta)
between each edge and unit vector vi.
cmpmin[np], cmvmax[np] = minimum and maximum cm=1-cosl(theta)
between each circle and unit vector vi.
ipv[nv] = cap number of vertices/edges;
that is, vertex v[i] and edge points ve[i]
lie on cap number ipv.
gp[np] = which group of intersecting circles each circle belongs to.
*nev = number of connected sequences of vertices.
*nev0 = number of bounding circles which have no intersections.
ev[nev] = end indices of each connected sequence of vertices.
Return value: 0 if ok;
1 if fatal degenerate intersection of boundaries;
-1 if failed to allocate memory.
*/
int gvlim(polygon *poly, int vcirc, long double *tol, vec vi, int nvmax, int *nv, vec vmin[/*nvmax*/], vec vmax[/*nvmax*/], long double cmvmin[/*nvmax*/], long double cmvmax[/*nvmax*/], long double cmpmin[/*poly->np*/], long double cmpmax[/*poly->np*/], int ipv[/*nvmax*/], int gp[/*poly->np*/], int *nev, int *nev0, int ev[/*nvmax*/])
{
logical ldegen;
/* work arrays */
int *iord, *iwk;
long double *phi, *wk;
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * poly->np * 2);
if (!iord) {
fprintf(stderr, "gvlim: failed to allocate memory for %d ints\n", poly->np * 2);
return(-1);
}
phi = (long double *) malloc(sizeof(long double) * poly->np * 2);
if (!phi) {
fprintf(stderr, "gvlim: failed to allocate memory for %d long doubles\n", poly->np * 2);
return(-1);
}
iwk = (int *) malloc(sizeof(int) * nvmax * 4);
if (!iwk) {
fprintf(stderr, "gvlim: failed to allocate memory for %d ints\n", nvmax * 4);
return(-1);
}
wk = (long double *) malloc(sizeof(long double) * nvmax);
if (!wk) {
fprintf(stderr, "gvlim: failed to allocate memory for %d long doubles\n", nvmax);
return(-1);
}
/* fortran routine */
gvlim_(vmin, vmax, cmvmin, cmvmax, cmpmin, cmpmax, ipv, gp, ev, &nvmax, nv, nev, nev0, poly->rp, poly->cm, &poly->np, vi, &vcirc, tol, phi, iord, wk, iwk, &ldegen);
/* number of vertices exceeds putative maximum */
if (poly->np >= 5 && *nv > 6 * (poly->np - 2)) {
msg("CONGRATULATIONS! YOU HAVE DISCOVERED A POLYGON WITH 5 OR MORE CAPS\n");
msg("(IT HAS %d CAPS) THAT HAS MORE THAN %d VERTICES (IT HAS %d VERTICES).\n", poly->np, 6 * (poly->np - 2), *nv);
msg("(Either that or you have found a bug.)\n");
msg("PLEASE EMAIL ME Andrew.Hamilton@colorado.edu THE GOOD NEWS,\n");
msg("ALONG WITH A POLYGON FILE CONTAINING THE POLYGON THAT DID IT.\n");
msg("THANKS!\n");
dump_poly(1, &poly);
msg("AND THERE'S THE POLYGON FILE I'D LIKE YOU TO SEND. THANKS!\n");
}
/* free work arrays */
free(iord);
free(phi);
free(iwk);
free(wk);
/* fatal intersection of boundaries */
if (ldegen) return(1);
return(0);
}

377
src/gvlim.s.f Normal file
View file

@ -0,0 +1,377 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gvlim(vmin,vmax,cmvmin,cmvmax,cmpmin,cmpmax,
* ipv,gp,ev,nvmax,nv,nev,nev0,
* rp,cm,np,rpi,vcirc,tol,phi,iord,wk,iwk,ldegen)
integer nvmax,ipv(nvmax),np,gp(np),ev(nvmax),nv,nev,nev0,vcirc
logical ldegen
real*10 vmin(3,nvmax),vmax(3,nvmax),cmvmin(nvmax),cmvmax(nvmax),
* cmpmin(np),cmpmax(np),rp(3,np),cm(np),rpi(3),tol
c work arrays (could be made automatic if compiler supports it)
integer iord(2*np),iwk(nvmax,4)
real*10 phi(2,np),wk(nvmax)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c intrinsics
intrinsic abs
c externals
integer gsegij,gzeroar
real*10 cmijf
c data variables
real*10 big
c real*10 dphmin
c local variables
integer i,ii,ik,iphi,iseg,iv,j,jm,jml,jmu,jp,jpl,jpu,km,kp,ni,scmi
C logical warn
real*10 cmi,cmik,dph,ikchk,ph,phin,phif,phm,phmax,phmin,php,
* si,sik,tolin,xi(3),xv,yi(3),yv,zv
c *
c * Lifted mostly from gvert and gcmlim.
c *
c * Points nearest to and farthest from unit direction rpi
c * on each edge of polygon defined by
c * 1 - r.rp(i) < cm(i) (if cm(i).ge.0)
c * 1 - r.rp(i) > -cm(i) (if cm(i).lt.0)
c * for i=1,np where rp(i) are unit directions.
c *
c * The edges are ordered right-handedly about the polygon
c * in the same order as given by gvert.
c * The array ev records the end index of each connected
c * sequences of vertices.
c * Intersecting boundaries come 1st, then non-intersecting boundaries.
c * If the polygon is connected and simply-connected, the usual case,
c * then ev(1) = nv on output, and ev(i) = 0 for i >= 2.
c * If the polygon is not connected and simply-connected,
c * then the number of non-zero elements of ev will equal the number
c * of distinct connected boundaries of the polygon.
c *
c Input: nvmax = guess at maximum nv;
c must be >= np;
c recommend:
c = np if 0 <= np <= 2
c = np*(np-1) if 2 <= np <= 4
c = 6*(np-2) if np >= 4
c rp(3,i),i=1,np
c cm(i),i=1,np
c np
c rpi(3) = unit vector.
c vcirc = 1 to return nearest and farthest points also for
c non-intersecting boundary circles.
c = 0 otherwise.
c Output: vmin(3,i),vmax(3,i),i=1,nv are unit vectors which are the
c nearest and farthest points on each edge from rpi.
c cmvmin, cmvmax = 1 - cos th between nearest and farthest
c points vmin, vmax on each edge from rpi.
c cmpmin, cmpmax = 1 - cos th between nearest and farthest
c points on each circle from rpi.
c ipv(iv),iv=1,nv is the circle number of the iv'th edge,
c that is,points ve(*,ive,iv) lie on circle number ipv.
c gp(i),i=1,np = which group circle i belongs to:
c circle i and circle j are friends if they intersect,
c and friends of friends are friends.
c ev(i) = end index of each connected sequence of edges;
c the number of non-zero elements of ev is the number
c nev of connected boundaries of the polygon,
c and the last nev0 of these are non-intersecting.
c nv = number of points;
c if this exceeds nvmax, then you should call gvlim again
c with a larger nvmax.
c nev = number of connected sequences of vertices,
c including those in non-intersecting circles.
c nev0 = number of non-intersecting boundary circles if vcirc=1;
c = 0 if vcirc=0;
c non-intersecting boundaries come last in ve,
c and the last nev0 entries of ev(i) refer
c to non-intersecting boundaries.
c ldegen = .true. means there's a problem with multiply
c intersecting boundary.
c Input/Output: tol
c Work arrays: phi and iord should be dimensioned at least 2*np.
c iwk should be dimensioned at least 4*nvmax.
c wk should be dimensioned at least nvmax.
c
c data dphmin /1.e-8_10/
data big /1.e6_10/
c
c input tolerance to multiple intersections
tolin=tol
c come here with modified tolerance
100 continue
c initialise error flag to no error
ldegen=.false.
C warn=.false.
c zero number of vertices
nv=0
nev=0
nev0=0
c initialise ev to zero
do iv=1,nvmax
ev(iv)=0
enddo
c initially each circle is its own group
do i=1,np
gp(i)=i
enddo
c check for zero area because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
c error check on evaluation of vertex terms
ikchk=0._10
c initialise iwk to inadmissible value
do iv=1,nvmax
iwk(iv,2)=-1
enddo
do iv=1,nvmax
iwk(iv,3)=-1
enddo
c--------identify boundary segments around each circle i in turn
do 280 i=1,np
c cm(i).ge.2 means include whole sphere, which is no constraint
if (cm(i).ge.2._10) then
cmpmin(i)=2._10
cmpmax(i)=0._10
goto 280
endif
c scmi * cmi = 1-cos th(i)
if (cm(i).ge.0._10) then
scmi=1
else
scmi=-1
endif
cmi=abs(cm(i))
c si = sin th(i)
si=sqrt(cmi*(2._10-cmi))
c cmik = 1-cos th(ik), th(ik)=angle twixt rpi & rp(i)
cmik=cmijf(rpi,rp(1,i))
c sik = sin th(ik)
sik=sqrt(cmik*(2._10-cmik))
c........minimum and maximum cm on circle
cmpmin(i)=cmi+cmik-cmi*cmik-si*sik
cmpmax(i)=cmi+cmik-cmi*cmik+si*sik
c........cartesian axes with z-axis along rp(i)
call gaxisi(rp(1,i),xi,yi)
c........azimuthal angle closest to vector rpi
xv=xi(1)*rpi(1)+xi(2)*rpi(2)+xi(3)*rpi(3)
yv=yi(1)*rpi(1)+yi(2)*rpi(2)+yi(3)*rpi(3)
phin=atan2(yv,xv)
if (phin.ge.0._10) then
phif=phin-PI
else
phif=phin+PI
endif
c........angles phi about z-axis rp(i) of intersection of i & j circles
call gphij(rp,cm,np,i,rp(1,i),scmi,cmi,xi,yi,big,tol,ni,phi)
c i circle lies outside polygon
if (ni.eq.-1) goto 280
c area of polygon is zero
if (ni.eq.-2) then
nv=0
nev=0
nev0=0
goto 410
endif
c........i circle has no intersections
if (ni.eq.0) then
c want near and far points for non-intersecting boundary circles
if (vcirc.eq.1) then
c introduce pretend circle 0
do j=1,2
if (j.eq.1) then
ii=0
km=i
kp=i
phm=0._10
php=PI
elseif (j.eq.2) then
ii=i
km=0
kp=0
phm=PI
php=TWOPI
endif
ph=(phm+php)/2._10
dph=php-phm
nv=nv+1
if (nv.le.nvmax) then
c edge index of this vertex
ipv(nv)=i
c phase phin to central point ph
iphi=nint((phin-ph)/TWOPI)
phin=phin-iphi*TWOPI
if (phm.le.phin.and.phin.le.php) then
phmin=0._10
elseif (phm.gt.phin) then
phmin=phm-phin
elseif (phin.gt.php) then
phmin=php-phin
endif
c phase phif to central point ph
iphi=nint((phif-ph)/TWOPI)
phif=phif-iphi*TWOPI
if (phm.le.phif.and.phif.le.php) then
phmax=0._10
elseif (phm.gt.phif) then
phmax=phm-phif
elseif (phif.gt.php) then
phmax=php-phif
endif
c nearest point on edge
xv=si*cos(phmin+phin)
yv=si*sin(phmin+phin)
zv=1._10-cmi
vmin(1,nv)=zv*rp(1,i)+xv*xi(1)+yv*yi(1)
vmin(2,nv)=zv*rp(2,i)+xv*xi(2)+yv*yi(2)
vmin(3,nv)=zv*rp(3,i)+xv*xi(3)+yv*yi(3)
c farthest point on edge
xv=si*cos(phmax+phif)
yv=si*sin(phmax+phif)
zv=1._10-cmi
vmax(1,nv)=zv*rp(1,i)+xv*xi(1)+yv*yi(1)
vmax(2,nv)=zv*rp(2,i)+xv*xi(2)+yv*yi(2)
vmax(3,nv)=zv*rp(3,i)+xv*xi(3)+yv*yi(3)
c minimum, maximum cm
cmvmin(nv)=cmijf(rpi,vmin(1,nv))
cmvmax(nv)=cmijf(rpi,vmax(1,nv))
endif
c record endpoints of edge
call gvtrail(scmi,np,ii,km,kp,iwk,iwk(1,2),nvmax,nv,
* ik,ikchk)
enddo
nev0=nev0+1
endif
c........i circle has intersections
elseif (ni.gt.0) then
c........friends of i circle
call ggpij(np,gp,i,big,phi)
c........find ordering of intersection angles around i circle
call findbot(phi,2*np,iord,ni)
c........vertices around i circle
jpl=0
c come here to do another segment
220 continue
c........is segment edge of polygon?
iseg=gsegij(rp,cm,np,0,0,i,rp(1,i),scmi,cmi,tol,ni,
* phi,iord,jml,jmu,jpl,jpu,1,jm,jp,km,kp,phm,php,ph,dph)
c error
if (iseg.eq.-1) goto 420
c not an edge
if (iseg.eq.0) goto 220
c gone full circle
if (iseg.eq.2) goto 280
c........segment is edge
c warn about near multiple intersection
c if (dph.lt.dphmin) then
c print *,'*** warning from gvlim: near multiple intersectio
c *n at',i,': edge',km,kp,' dph=',real(dph)
c warn=.true.
c endif
c print *,'at',i,': edge',km,kp,
c * ' (',jm,' in',jml,jmu,',',jp,' in',jpl,jpu,' of',ni,')',
c * ' ph=',real(ph),' dph=',real(dph)
nv=nv+1
if (nv.le.nvmax) then
c edge index of this vertex
ipv(nv)=i
c phase phin to central point ph
iphi=nint((phin-ph)/TWOPI)
phin=phin-iphi*TWOPI
if (phm.le.phin.and.phin.le.php) then
phmin=0._10
elseif (phm.gt.phin) then
phmin=phm-phin
elseif (phin.gt.php) then
phmin=php-phin
endif
c phase phif to central point ph
iphi=nint((phif-ph)/TWOPI)
phif=phif-iphi*TWOPI
if (phm.le.phif.and.phif.le.php) then
phmax=0._10
elseif (phm.gt.phif) then
phmax=phm-phif
elseif (phif.gt.php) then
phmax=php-phif
endif
c nearest point on edge
xv=si*cos(phmin+phin)
yv=si*sin(phmin+phin)
zv=1._10-cmi
vmin(1,nv)=zv*rp(1,i)+xv*xi(1)+yv*yi(1)
vmin(2,nv)=zv*rp(2,i)+xv*xi(2)+yv*yi(2)
vmin(3,nv)=zv*rp(3,i)+xv*xi(3)+yv*yi(3)
c farthest point on edge
xv=si*cos(phmax+phif)
yv=si*sin(phmax+phif)
zv=1._10-cmi
vmax(1,nv)=zv*rp(1,i)+xv*xi(1)+yv*yi(1)
vmax(2,nv)=zv*rp(2,i)+xv*xi(2)+yv*yi(2)
vmax(3,nv)=zv*rp(3,i)+xv*xi(3)+yv*yi(3)
c minimum, maximum cm
cmvmin(nv)=cmijf(rpi,vmin(1,nv))
cmvmax(nv)=cmijf(rpi,vmax(1,nv))
endif
c record endpoints of edge
call gvtrail(scmi,np,i,km,kp,iwk,iwk(1,2),nvmax,nv,ik,ikchk)
c do another segment
goto 220
endif
280 continue
c--------check on whether ik endpoints matched ki endpoints
if (ikchk.ne.0._10) then
c print *,'*** from gvlim: ikchk=',ikchk,' should be 0'
C warn=.true.
call gtol(tol,tolin)
goto 100
endif
c--------order vertices right-handedly about polygon
if (nv.gt.0.and.nv.le.nvmax) then
c........which group of friends each circle belongs to
call ggp(np,gp)
c........find order of vertices around polygon
call gvord(np,nv,ipv,gp,ev,nev,iwk,iwk(1,2),iwk(1,3),iwk(1,4))
c........reorder vertices
call vpermi(ipv,nv,iwk(1,2),iwk(1,3))
call vpermdd(vmin,3,nv,iwk(1,2),wk)
call vpermdd(vmax,3,nv,iwk(1,2),wk)
call vpermd(cmvmin,nv,iwk(1,2),wk)
call vpermd(cmvmax,nv,iwk(1,2),wk)
endif
c--------done
410 continue
C if (warn) then
C write (*,'(a3,a20,4a24)')
C * ' ','x','y','z',
c * 'r',
C * '1-c'
C do j=1,np
C write (*,'(i3,5g24.16)')
C * j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
C * cm(j)
C enddo
C endif
c if (nv.gt.nvmax) then
c print *,'*** from gvlim: number of vertices =',nv,
c * ' exceeds maximum',nvmax
c endif
return
c
420 print *,'*** from gvlim: total failure at tol =',tol
write (*,'(a3,a20,4a24)')
* ' ','x','y','z',
c * 'r',
* '1-c'
do j=1,np
write (*,'(i3,5g24.16)')
* j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
* cm(j)
enddo
ldegen=.true.
return
c
end
c

53
src/gvphi.c Normal file
View file

@ -0,0 +1,53 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include "manglefn.h"
/*------------------------------------------------------------------------------
Point at the centre of that part of a circle which
(a) lies inside a polygon, and
(b) contains or is closest to a specified unit vector.
This is a c interface to fortran subroutine gvphi.
Input: poly is a polygon.
rp, cm define a circle.
vi = unit vector.
*tol = angle within which to merge multiple intersections.
Output: angle = length of that part of boundary segment which
(a) lies inside the polygon, and
(b) contains, or is closest to, unit vector vi.
= 0. if the boundary lies entirely outside the polygon.
v = unit vector at centre of said boundary segment.
Return value: 0 if ok;
-1 if failed to allocate memory.
*/
int gvphi(polygon *poly, vec rp, long double cm, vec vi, long double *tol, long double *angle, vec v)
{
/* work arrays */
int *iord;
long double *phi;
/* allocate memory for work arrays */
iord = (int *) malloc(sizeof(int) * poly->np * 2);
if (!iord) {
fprintf(stderr, "gvphi: failed to allocate memory for %d ints\n", poly->np * 2);
return(-1);
}
phi = (long double *) malloc(sizeof(long double) * poly->np * 2);
if (!phi) {
fprintf(stderr, "gvphi: failed to allocate memory for %d long doubles\n", poly->np * 2);
return(-1);
}
/* fortran routine */
gvphi_(angle, v, poly->rp, poly->cm, &poly->np, rp, &cm, vi, tol, phi, iord);
/* free work arrays */
free(iord);
free(phi);
return(0);
}

160
src/gvphi.s.f Normal file
View file

@ -0,0 +1,160 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
subroutine gvphi(angle,v,rp,cm,np,rpi,cmi,vi,tol,phi,iord)
integer np
real*10 angle,v(3),rp(3,np),cm(np),rpi(3),cmi,vi(3),tol
c work arrays (could be automatic if compiler supports it)
integer iord(2*np)
real*10 phi(2,np)
c
c parameters
include 'pi.par'
real*10 TWOPI
parameter (TWOPI=2._10*PI)
c externals
integer gsegij,gzeroar
c data variables
real*10 big
c local (automatic) variables
integer i,iphin,iseg,j,jm,jml,jmu,jp,jpl,jpu,km,kp,ni,scmi
real*10 dph,dphin,dphinmn,ph,phin,phm,php,
* si,xi(3),xv,yi(3),yv,zv
c *
c * This routine is mostly lifted from gphi and gvert.
c *
c * Point at centre of segment of circle
c * 1 - r.rpi = cmi
c * containing, or otherwise closest to, point vi,
c * lying inside
c * 1 - r.rp(j) <= cm(j) (if cm(j).ge.0)
c * 1 - r.rp(j) > -cm(j) (if cm(j).lt.0)
c * for j=1,np where rp(j) are unit directions.
c *
c Input: rp(3,j),j=1,np
c cm(j),j=1,np
c np
c rpi(3)
c cmi
c vi(3) = unit vector desired to lie inside,
c or closest to, segment.
c tol
c Output: angle = angular length of segment of circle
c = 0. if boundary lies entirely outside circle.
c v(3) = unit vector at centre of segment of circle.
c Work arrays: phi and iord should be dimensioned at least 2*np
c
data big /1.e6_10/
c
c initialise length of segment to zero
angle=0._10
c initialise point at centre of segment to zero
v(1)=0._10
v(2)=0._10
v(3)=0._10
c check for null circle
if (cmi.lt.0._10) goto 410
if (cmi.gt.2._10) goto 410
c check for zero angle because one circle is null
if (gzeroar(cm,np).eq.0) goto 410
c initialise dphinmn to impossibly large value
dphinmn=big
c........si = sin thi
scmi=1
si=sqrt(cmi*(2._10-cmi))
c........construct cartesian axes with z-axis along rpi
call gaxisi(rpi,xi,yi)
c........azimuthal angle closest to vector vi
xv=xi(1)*vi(1)+xi(2)*vi(2)+xi(3)*vi(3)
yv=yi(1)*vi(1)+yi(2)*vi(2)+yi(3)*vi(3)
phin=atan2(yv,xv)
c........angles phi about z-axis rp(i) of intersection of i & j circles
c passing i=0 means circle at edge is considered outside polygon
call gphij(rp,cm,np,0,rpi,scmi,cmi,xi,yi,big,tol,ni,phi)
c i circle lies outside (or at edge of) polygon
if (ni.le.-1) goto 410
c........order angles around circle
c circle has no intersections
if (ni.eq.0) then
angle=TWOPI
ph=phin
xv=si*cos(ph)
yv=si*sin(ph)
zv=1._10-cmi
v(1)=zv*rpi(1)+xv*xi(1)+yv*yi(1)
v(2)=zv*rpi(2)+xv*xi(2)+yv*yi(2)
v(3)=zv*rpi(3)+xv*xi(3)+yv*yi(3)
c circle has intersections
elseif (ni.gt.0) then
c find ordering of intersection angles around circle
call findbot(phi,2*np,iord,ni)
c........vertices around i circle
jpl=0
c come here to do another segment
220 continue
c........is segment edge of polygon?
iseg=gsegij(rp,cm,np,0,0,i,rpi,scmi,cmi,tol,ni,
* phi,iord,jml,jmu,jpl,jpu,1,jm,jp,km,kp,phm,php,ph,dph)
c error
if (iseg.eq.-1) goto 420
c not an edge
if (iseg.eq.0) goto 220
c gone full circle
if (iseg.eq.2) goto 280
c........segment satisfies conditions
c print *,'segment',km,kp,
c * ' (',jm,' in',jml,jmu,',',jp,' in',jpl,jpu,' of',ni,')',
c * ' ph=',real(ph),' dph=',real(dph)
c phase phin to central point ph
iphin=nint((phin-ph)/TWOPI)
phin=phin-iphin*TWOPI
if (phm.le.phin.and.phin.le.php) then
dphin=0._10
elseif (phm.gt.phin) then
dphin=phm-phin
elseif (phin.gt.php) then
dphin=phin-php
endif
c segment contains or is closest to phin
if (dphin.lt.dphinmn) then
dphinmn=dphin
angle=dph
c coords of centre of edge in frame where axes are xi, yi, rp
xv=si*cos(ph)
yv=si*sin(ph)
zv=1._10-cmi
v(1)=zv*rpi(1)+xv*xi(1)+yv*yi(1)
v(2)=zv*rpi(2)+xv*xi(2)+yv*yi(2)
v(3)=zv*rpi(3)+xv*xi(3)+yv*yi(3)
c segment contains phin, so cannot be beaten
if (dphin.eq.0._10) goto 280
endif
c do another segment
goto 220
endif
280 continue
return
c
c zero angle
410 continue
return
c
420 print *,'*** from gvphi: total failure at tol =',tol
write (*,'(a3,a20,4a24)')
* ' ','x','y','z',
c * 'r',
* '1-c'
do j=1,np
write (*,'(i3,5g24.16)')
* j,(rp(i,j),i=1,3),
c * sqrt(rp(1,j)**2+rp(2,j)**2+rp(3,j)**2),
* cm(j)
enddo
write (*,'(i3,5g24.16)')
* 0,(rpi(i),i=1,3),
c * sqrt(rpi(1)**2+rpi(2)**2+rpi(3)**2),
* cmi
return
c
end
c

7
src/harmonics.h Normal file
View file

@ -0,0 +1,7 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#define IM 2
#define NW (((lmax + 1) * (lmax + 2)) / 2)
typedef long double harmonic[IM];

123
src/harmonize.c Normal file
View file

@ -0,0 +1,123 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <math.h>
#include "manglefn.h"
#include "defaults.h"
/* getopt options */
const char *optstr = "dql:m:s:e:i:";
/* allocate polygons as a global array */
polygon *polys_global[NPOLYSMAX];
/* local functions */
void usage(void);
/*------------------------------------------------------------------------------
Main program.
*/
int main(int argc, char *argv[])
{
int ifile, nfiles, npoly, npolys, nws,i;
long double area;
harmonic *w;
polygon **polys;
polys=polys_global;
/* parse arguments */
parse_args(argc, argv);
/* at least one input and output filename required as arguments */
if (argc - optind < 2) {
if (optind > 1 || argc - optind == 1) {
fprintf(stderr, "%s requires at least 2 arguments: polygon_infile, and Wlm_outfile\n", argv[0]);
usage();
exit(1);
} else {
usage();
exit(0);
}
}
msg("---------------- harmonize ----------------\n");
/* advise harmonic number */
msg("maximum harmonic number %d\n", lmax);
/* tolerance angle for multiple intersections */
if (mtol != 0.) {
scale(&mtol, munit, 's');
munit = 's';
msg("multiple intersections closer than %Lg%c will be treated as coincident\n", mtol, munit);
scale(&mtol, munit, 'r');
munit = 'r';
}
/* advise data format */
advise_fmt(&fmt);
/* read polygons */
npoly = 0;
nfiles = argc - 1 - optind;
for (ifile = optind; ifile < optind + nfiles; ifile++) {
npolys = rdmask(argv[ifile], &fmt, NPOLYSMAX - npoly, &polys[npoly]);
if (npolys == -1) exit(1);
npoly += npolys;
}
if (nfiles >= 2) {
msg("total of %d polygons read\n", npoly);
}
if (npoly == 0) {
msg("STOP\n");
exit(0);
}
if (snapped==0 || balkanized==0) {
msg("WARNING: 'snapped' and 'balkanized' keywords not found in all input files.\n");
msg("Running harmonize on polygons that are not snapped and balkanized may give misleading results.\n");
}
/* allocate array containing spherical harmonics of complete mask */
w = (harmonic *) malloc(sizeof(harmonic) * NW);
if (!w) {
fprintf(stderr, "harmonize: failed to allocate memory for %d harmonics\n", NW);
exit(1);
}
/* spherical harmonics of region */
npoly = harmonize_polys(npoly, polys, mtol, lmax, w);
if (npoly == -1) exit(1);
/* advise area */
area = w[0][0] * 2. * sqrtl(PI);
msg("area of (weighted) region is %.15Lg str\n", area);
/* write polygons */
ifile = argc - 1;
nws = wrspher(argv[ifile], lmax, w);
if (nws == -1) exit(1);
for(i=0;i<npoly;i++){
free_poly(polys[i]);
}
return(0);
}
/*------------------------------------------------------------------------------
*/
void usage(void)
{
printf("usage:\n");
printf("harmonize [-d] [-q] [-l<lmax>] [-m<a>[u]] [-s<n>] [-e<n>] [-i<f>[<n>][u]] polygon_infile1 [polygon_infile2 ...] Wlm_outfile\n");
#include "usage.h"
}
/*------------------------------------------------------------------------------
*/
#include "parse_args.c"

170
src/harmonize_polys.c Normal file
View file

@ -0,0 +1,170 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include "manglefn.h"
#include "pi.h"
/* advise how many polygons done if lmax >= this */
#define LMAX_ADVICE 250
/*------------------------------------------------------------------------------
Spherical harmonics of sum of weighted polygons.
Input: poly = array of pointers to npoly polygons.
npoly = number of polygons in poly array.
mtol = initial angular tolerance in radians within which to merge multiple intersections.
lmax = maximum harmonic number.
Output: w = harmonics;
NW = ((lmax + 1)(lmax + 2))/ 2 is defined in harmonics.h.
Return value: number of polygons for which spherical harmonics were computed,
or -1 if error occurred.
*/
int harmonize_polys(int npoly, polygon *poly[/*npoly*/], long double mtol, int lmax, harmonic w[/*NW*/])
{
int accelerate, i, ier, ip, ipoly, iq, ir, isrect, iw, naccelerate, ndone, ner, nrect;
long double azmin, azmax, elmin, elmax, azmn, azmx, elmn, elmx, tol;
/* work array contains harmonics of single polygon */
harmonic *dw;
/* work arrays to deal with possible acceleration */
int *iord, *ir_to_ip;
long double *elord;
/* work arrays */
dw = (harmonic *) malloc(sizeof(harmonic) * NW);
if (!dw) {
fprintf(stderr, "harmonize_polys: failed to allocate memory for %d harmonics\n", NW);
return(-1);
}
iord = (int *) malloc(sizeof(int) * npoly);
if (!iord) {
fprintf(stderr, "harmonize_polys: failed to allocate memory for %d ints\n", npoly);
return(-1);
}
ir_to_ip = (int *) malloc(sizeof(int) * npoly);
if (!ir_to_ip) {
fprintf(stderr, "harmonize_polys: failed to allocate memory for %d ints\n", npoly);
return(-1);
}
elord = (long double *) malloc(sizeof(long double) * npoly);
if (!elord) {
fprintf(stderr, "harmonize_polys: failed to allocate memory for %d long doubles\n", npoly);
return(-1);
}
/* zero harmonics of mask */
for (iw = 0; iw < NW; iw++) {
for (i = 0; i < IM; i++) {
w[iw][i] = 0.;
}
}
/* determine which polygons are rectangles, for which acceleration may be possible */
nrect = 0;
ir = npoly;
for (ipoly = 0; ipoly < npoly; ipoly++) {
isrect = poly_to_rect(poly[ipoly], &azmin, &azmax, &elmin, &elmax);
if (isrect && poly[ipoly]->weight != 0.) {
ir_to_ip[nrect] = ipoly;
elord[nrect] = elmin * 1.e8 + elmax;
nrect++;
} else {
ir--;
ir_to_ip[ir] = ipoly;
}
}
msg("harmonize_polys: %d polygons are rectangles, for which acceleration may be possible\n",
nrect);
/* order rectangles by elmin, elmax */
findtop(elord, nrect, iord, nrect);
/* do each polygon */
ndone = 0;
naccelerate = 0;
ner = 0;
if (lmax >= LMAX_ADVICE) msg("doing polygon number (of %d):\n", npoly);
for (ip = 0; ip < npoly; ip++) {
if (lmax >= LMAX_ADVICE) msg(" %d", ip);
accelerate = 0;
/* rectangle */
if (ip < nrect) {
ir = iord[ip];
ipoly = ir_to_ip[ir];
poly_to_rect(poly[ipoly], &azmin, &azmax, &elmin, &elmax);
/* does previous rectangle have same elevation limits? */
if (ip > 0) {
iq = iord[ip - 1];
iq = ir_to_ip[iq];
poly_to_rect(poly[iq], &azmn, &azmx, &elmn, &elmx);
/* if so, use acceleration */
if (elmn == elmin && elmx == elmax) accelerate = 1;
}
/* if not, does next rectangle have same elevation limits? */
if (!accelerate && ip + 1 < nrect) {
iq = iord[ip + 1];
iq = ir_to_ip[iq];
poly_to_rect(poly[iq], &azmn, &azmx, &elmn, &elmx);
/* if so, worth accelerating */
if (elmn == elmin && elmx == elmax) accelerate = 1;
}
/* accelerated computation */
if (accelerate) {
ier = gsphra(azmin, azmax, elmin, elmax, lmax, dw);
if (ier == -1) return(-1);
/* standard computation */
} else {
tol = mtol;
ier = gsphr(poly[ipoly], lmax, &tol, dw);
if (ier == -1) return(-1);
}
/* non-rectangle */
} else {
ipoly = ir_to_ip[ip];
/* zero weight polygon requires no computation */
if (poly[ipoly]->weight == 0.) {
ndone++;
continue;
} else {
tol = mtol;
ier = gsphr(poly[ipoly], lmax, &tol, dw);
if (ier == -1) return(-1);
}
}
/* computation failed */
if (ier) {
ner++;
if (lmax >= LMAX_ADVICE) msg("\n");
fprintf(stderr, "harmonize_polys: computation failed for polygon %d; discard it\n", ipoly);
/* success */
} else {
naccelerate += accelerate;
ndone++;
/* increment harmonics of region */
for (iw = 0; iw < NW; iw++) {
for (i = 0; i < IM; i++) {
w[iw][i] += dw[iw][i] * poly[ipoly]->weight;
}
}
}
}
if (lmax >= LMAX_ADVICE) msg("\n");
/* number of computations that were accelerated */
msg("computation was accelerated for %d rectangles\n", naccelerate);
/* advise */
if (ner > 0) {
fprintf(stderr, "harmonize_polys: discarded %d polygons for which computations failed\n", ner);
}
msg("spherical harmonics of %d weighted polygons accumulated\n", ndone);
/* free work arrays */
free(dw);
free(iord);
free(ir_to_ip);
free(elord);
return(ndone);
}

24
src/harmonizepolys_.c Normal file
View file

@ -0,0 +1,24 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdlib.h>
#include "manglefn.h"
/* polygons declared in rdmask_() */
extern int npolys;
extern polygon *polys[];
/*------------------------------------------------------------------------------
Simplified fortran interface to harmonize_polys routine.
real *8 mtol
integer lmax
real *8 w(IM,NW)
call harmonizepolys(mtol, lmax, w)
*/
void harmonizepolys_(long double *mtol, int *lmax, harmonic w[])
{
int ndone;
ndone = harmonize_polys(npolys, polys, *mtol, *lmax, w);
if (ndone == -1) exit(1);
}

1079
src/healpix/chealpix.c Normal file

File diff suppressed because it is too large Load diff

170
src/healpix/chealpix.h Normal file
View file

@ -0,0 +1,170 @@
/* -----------------------------------------------------------------------------
*
* Copyright (C) 1997-2012 Krzysztof M. Gorski, Eric Hivon, Martin Reinecke,
* Benjamin D. Wandelt, Anthony J. Banday,
* Matthias Bartelmann,
* Reza Ansari & Kenneth M. Ganga
*
*
* This file is part of HEALPix.
*
* HEALPix is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* HEALPix is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with HEALPix; if not, write to the Free Software
* Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*
* For more information about HEALPix see http://healpix.sourceforge.net
*
*----------------------------------------------------------------------------*/
/*
* chealpix.h
*/
#ifndef CHEALPIX_H
#define CHEALPIX_H
#ifdef __cplusplus
extern "C" {
#endif
/*! \defgroup chealpix HEALPix C interface
All angles are in radian, all \a theta values are colatitudes, i.e. counted
downwards from the North Pole. \a Nside can be any positive number for
pixelisations in RING scheme; in NEST scheme, they must be powers of 2.
The maximum \a Nside for the traditional interface is 8192; for the
64bit interface it is 2^29.
*/
/*! \{ */
/* -------------------- */
/* Constant Definitions */
/* -------------------- */
#ifndef HEALPIX_NULLVAL
#define HEALPIX_NULLVAL (-1.6375e30)
#endif /* HEALPIX_NULLVAL */
/* pixel operations */
/* ---------------- */
/*! Sets \a *ipix to the pixel number in NEST scheme at resolution \a nside,
which contains the position \a theta, \a phi. */
void ang2pix_nest(long nside, double theta, double phi, long *ipix);
/*! Sets \a *ipix to the pixel number in RING scheme at resolution \a nside,
which contains the position \a theta, \a phi. */
void ang2pix_ring(long nside, double theta, double phi, long *ipix);
/*! Sets \a theta and \a phi to the angular position of the center of pixel
\a ipix in NEST scheme at resolution \a nside. */
void pix2ang_nest(long nside, long ipix, double *theta, double *phi);
/*! Sets \a theta and \a phi to the angular position of the center of pixel
\a ipix in NEST scheme at resolution \a nside. */
void pix2ang_ring(long nside, long ipix, double *theta, double *phi);
/*! Computes the RING pixel index of pixel \a ipnest at resolution \a nside
and returns it in \a *ipring. On error, \a *ipring is set to -1. */
void nest2ring(long nside, long ipnest, long *ipring);
/*! Computes the NEST pixel index of pixel \a ipring at resolution \a nside
and returns it in \a *ipring. On error, \a *ipnest is set to -1. */
void ring2nest(long nside, long ipring, long *ipnest);
/*! Returns \a 12*nside*nside. */
long nside2npix(long nside);
/*! Returns \a sqrt(npix/12) if this is an integer number, otherwise \a -1. */
long npix2nside(long npix);
/*! Computes a normalized Cartesian vector pointing in the same direction as
\a theta, \a phi, and stores it in \a vec. \a vec must point to storage
sufficient for at least three doubles. */
void ang2vec(double theta, double phi, double *vec);
/*! Computes the angles \a *theta and \a *phi describing the same directions
as the Cartesian vector \a vec. \a vec need not be normalized. */
void vec2ang(const double *vec, double *theta, double *phi);
/*! Sets \a *ipix to the pixel number in NEST scheme at resolution \a nside,
which contains the direction described the Cartesian vector \a vec. */
void vec2pix_nest(long nside, const double *vec, long *ipix);
/*! Sets \a *ipix to the pixel number in RING scheme at resolution \a nside,
which contains the direction described the Cartesian vector \a vec. */
void vec2pix_ring(long nside, const double *vec, long *ipix);
/*! Sets \a vec to the Cartesian vector pointing in the direction of the center
of pixel \a ipix in NEST scheme at resolution \a nside. */
void pix2vec_nest(long nside, long ipix, double *vec);
/*! Sets \a vec to the Cartesian vector pointing in the direction of the center
of pixel \a ipix in RING scheme at resolution \a nside. */
void pix2vec_ring(long nside, long ipix, double *vec);
/* operations on Nside values up to 2^29 */
/*! 64bit integer type
\note We are not using \c int64_t, since this type is not part of the C++
standard, and we want the header to be usable from C++. */
typedef long long hpint64;
/*! Sets \a *ipix to the pixel number in NEST scheme at resolution \a nside,
which contains the position \a theta, \a phi. */
void ang2pix_nest64(hpint64 nside, double theta, double phi, hpint64 *ipix);
/*! Sets \a *ipix to the pixel number in RING scheme at resolution \a nside,
which contains the position \a theta, \a phi. */
void ang2pix_ring64(hpint64 nside, double theta, double phi, hpint64 *ipix);
/*! Sets \a theta and \a phi to the angular position of the center of pixel
\a ipix in NEST scheme at resolution \a nside. */
void pix2ang_nest64(hpint64 nside, hpint64 ipix, double *theta, double *phi);
/*! Sets \a theta and \a phi to the angular position of the center of pixel
\a ipix in RING scheme at resolution \a nside. */
void pix2ang_ring64(hpint64 nside, hpint64 ipix, double *theta, double *phi);
/*! Computes the RING pixel index of pixel \a ipnest at resolution \a nside
and returns it in \a *ipring. On error, \a *ipring is set to -1. */
void nest2ring64(hpint64 nside, hpint64 ipnest, hpint64 *ipring);
/*! Computes the NEST pixel index of pixel \a ipring at resolution \a nside
and returns it in \a *ipring. On error, \a *ipnest is set to -1. */
void ring2nest64(hpint64 nside, hpint64 ipring, hpint64 *ipnest);
/*! Returns \a 12*nside*nside. */
hpint64 nside2npix64(hpint64 nside);
/*! Returns \a sqrt(npix/12) if this is an integer number, otherwise \a -1. */
long npix2nside64(hpint64 npix);
/*! Sets \a *ipix to the pixel number in NEST scheme at resolution \a nside,
which contains the direction described the Cartesian vector \a vec. */
void vec2pix_nest64(hpint64 nside, const double *vec, hpint64 *ipix);
/*! Sets \a *ipix to the pixel number in RING scheme at resolution \a nside,
which contains the direction described the Cartesian vector \a vec. */
void vec2pix_ring64(hpint64 nside, const double *vec, hpint64 *ipix);
/*! Sets \a vec to the Cartesian vector pointing in the direction of the center
of pixel \a ipix in NEST scheme at resolution \a nside. */
void pix2vec_nest64(hpint64 nside, hpint64 ipix, double *vec);
/*! Sets \a vec to the Cartesian vector pointing in the direction of the center
of pixel \a ipix in RING scheme at resolution \a nside. */
void pix2vec_ring64(hpint64 nside, hpint64 ipix, double *vec);
/* FITS operations */
/* --------------- */
float *read_healpix_map (const char *infile, long *nside, char *coordsys,
char *ordering);
void write_healpix_map (const float *signal, long nside, const char *filename,
char nest, const char *coordsys);
long get_fits_size(const char *filename, long *nside, char *ordering);
/*! \} */
#ifdef __cplusplus
} /* extern "C" */
#endif
#endif /* CHEALPIX_H */

154
src/healpix_ang2pix_nest.c Normal file
View file

@ -0,0 +1,154 @@
/* -----------------------------------------------------------------------------
*
* Copyright (C) 1997-2005 Krzysztof M. Gorski, Eric Hivon,
* Benjamin D. Wandelt, Anthony J. Banday,
* Matthias Bartelmann,
* Reza Ansari & Kenneth M. Ganga
*
*
* This file is part of HEALPix.
*
* HEALPix is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* HEALPix is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with HEALPix; if not, write to the Free Software
* Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*
* For more information about HEALPix see http://healpix.jpl.nasa.gov
*
*----------------------------------------------------------------------------- */
/* healpix_ang2pix_nest.c */
/* Standard Includes */
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include "pi.h"
#include "manglefn.h"
void healpix_ang2pix_nest( const int nside, long double theta, long double phi, int *ipix) {
/* =======================================================================
* subroutine ang2pix_nest(nside, theta, phi, ipix)
* =======================================================================
* gives the pixel number ipix (NESTED) corresponding to angles theta and phi
*
* the computation is made to the highest resolution available (nside=8192)
* and then degraded to that required (by integer division)
* this doesn't cost more, and it makes sure that the treatement of round-off
* will be consistent for every resolution
* =======================================================================
*/
long double z, za, z0, tt, tp, tmp;
int face_num,jp,jm;
int ifp, ifm;
int ix, iy, ix_low, ix_hi, iy_low, iy_hi, ipf, ntt;
int i, K, IP, I, J, id;
int ns_max = 8192;
static int x2pix[128], y2pix[128];
static char setup_done = 0;
if( nside < 1 || nside > ns_max ) {
fprintf(stderr, "healpix_ang2pix_nest: nside out of range: %d\n", nside);
exit(0);
}
if( theta < 0. || theta > PI ) {
fprintf(stderr, "healpix_ang2pix_nest: theta out of range: %Lf\n", theta);
exit(0);
}
if( !setup_done ) {
/* set the array giving the number of the pixel lying in (x,y), where x and y
are in {1,128} and the pixel number is in {0,128^2-1} */
for (i = 0; i < 127; i++) x2pix[i] = 0;
for (I = 1; I <= 128; I++) {
J = I - 1; // !pixel numbers
K = 0;
IP = 1;
truc : if (J == 0) {
x2pix[I-1] = K;
y2pix[I-1] = 2*K;
}
else {
id = (int)fmodl(J,2);
J = J/2;
K = IP*id + K;
IP = IP*4;
goto truc;
}
}
setup_done = 1;
}
z = cosl(theta);
za = fabsl(z);
z0 = 2./3.;
if( phi >= TWOPI ) phi = phi - TWOPI;
if( phi < 0. ) phi = phi + TWOPI;
tt = phi / PIBYTWO; /* in [0,4] */
if( za <= z0 ) { /* equatorial region */
/* (the index of edge lines increase when the longitude=phi goes up) */
jp = (int)floorl(ns_max*(0.5 + tt - z*0.75)); /* ascending edge line index */
jm = (int)floorl(ns_max*(0.5 + tt + z*0.75)); /* descending edge line index */
/* finds the face */
ifp = jp / ns_max; /* in {0,4} */
ifm = jm / ns_max;
if( ifp == ifm ) face_num = (int)fmodl(ifp,4) + 4; /* faces 4 to 7 */
else if( ifp < ifm ) face_num = (int)fmodl(ifp,4); /* (half-)faces 0 to 3 */
else face_num = (int)fmodl(ifm,4) + 8; /* (half-)faces 8 to 11 */
ix = (int)fmodl(jm, ns_max);
iy = ns_max - (int)fmodl(jp, ns_max) - 1;
}
else { /* polar region, za > 2/3 */
ntt = (int)floorl(tt);
if( ntt >= 4 ) ntt = 3;
tp = tt - ntt;
tmp = sqrtl( 3.*(1. - za) ); /* in ]0,1] */
/* (the index of edge lines increase when distance from the closest pole
* goes up)
*/
/* line going toward the pole as phi increases */
jp = (int)floorl( ns_max * tp * tmp );
/* that one goes away of the closest pole */
jm = (int)floorl( ns_max * (1. - tp) * tmp );
jp = (int)(jp < ns_max-1 ? jp : ns_max-1);
jm = (int)(jm < ns_max-1 ? jm : ns_max-1);
/* finds the face and pixel's (x,y) */
if( z >= 0 ) {
face_num = ntt; /* in {0,3} */
ix = ns_max - jm - 1;
iy = ns_max - jp - 1;
}
else {
face_num = ntt + 8; /* in {8,11} */
ix = jp;
iy = jm;
}
}
ix_low = (int)fmodl(ix,128);
ix_hi = ix/128;
iy_low = (int)fmodl(iy,128);
iy_hi = iy/128;
ipf = (x2pix[ix_hi] + y2pix[iy_hi]) * (128 * 128) + (x2pix[ix_low] + y2pix[iy_low]);
ipf = (int)(ipf / powl(ns_max/nside,2)); /* in {0, nside**2 - 1} */
*ipix =(int)( ipf + face_num*powl(nside,2)); /* in {0, 12*nside**2 - 1} */
}

252
src/healpixpolys.c Normal file
View file

@ -0,0 +1,252 @@
/*-------------------------------------------------------------
(C) J C Hill 2006
-------------------------------------------------------------*/
#include <stdlib.h>
#include <math.h>
#include "pi.h"
#include "manglefn.h"
/*-----------------------------------------------------------
get_healpix_poly: uses the HEALPix Fortran subroutine
pix2vec_nest to construct the HEALPix
pixels at the desired resolution
Input: nside = HEALPix parameter describing resolution (for
res >= 1, simply defined by 2^(res-1); for
res = 0, define nside = 0)
hpix = id number of HEALPix pixel that you wish to construct
Return value: pointer to polygon if successful
0x0 if error occurred
*/
polygon *get_healpix_poly(int nside, int hpix)
{
int nv, nvmax, i, pix_n, pix_e, pix_s, pix_w, ev[1];
vertices *vert;
polygon *pixel, *pixelbetter;
long double verts_vec[12], verts_vec_n[12], verts_vec_e[12], verts_vec_s[12], verts_vec_w[12], dist_n, dist_w, dist_s, dist_e;
vec center, center_n, center_e, center_s, center_w, vertices_vec[4], vertices_vec_n[4], vertices_vec_e[4], vertices_vec_s[4], vertices_vec_w[4];
azel *vertices_azel[8], vertices[8];
for(i=0;i<=7;i++) vertices_azel[i] = &(vertices[i]);
if (nside == 0) {
pixel=new_poly(0);
pixel->weight=1;
pixel->pixel=0;
return(pixel);
}
else {
healpix_verts(nside, hpix, center, verts_vec);
/* north vertex */
for(i=0;i<=2;i++) (vertices_vec[0])[i] = verts_vec[i];
/* east vertex */
for(i=0;i<=2;i++) (vertices_vec[1])[i] = verts_vec[i+3];
/* south vertex */
for(i=0;i<=2;i++) (vertices_vec[2])[i] = verts_vec[i+6];
/* west vertex */
for(i=0;i<=2;i++) (vertices_vec[3])[i] = verts_vec[i+9];
rp_to_azel(vertices_vec[0], vertices_azel[0]);
rp_to_azel(vertices_vec[3], vertices_azel[2]);
rp_to_azel(vertices_vec[2], vertices_azel[4]);
rp_to_azel(vertices_vec[1], vertices_azel[6]);
pix_n = 4*hpix + 3;
pix_e = 4*hpix + 1;
pix_s = 4*hpix;
pix_w = 4*hpix + 2;
healpix_verts(nside*2, pix_n, center_n, verts_vec_n);
healpix_verts(nside*2, pix_e, center_e, verts_vec_e);
healpix_verts(nside*2, pix_s, center_s, verts_vec_s);
healpix_verts(nside*2, pix_w, center_w, verts_vec_w);
/* north vertex of each child pixel */
for(i=0;i<=2;i++){
(vertices_vec_n[0])[i] = verts_vec_n[i];
(vertices_vec_e[0])[i] = verts_vec_e[i];
(vertices_vec_s[0])[i] = verts_vec_s[i];
(vertices_vec_w[0])[i] = verts_vec_w[i];
}
/* east vertex of each child pixel */
for(i=0;i<=2;i++){
(vertices_vec_n[1])[i] = verts_vec_n[i+3];
(vertices_vec_e[1])[i] = verts_vec_e[i+3];
(vertices_vec_s[1])[i] = verts_vec_s[i+3];
(vertices_vec_w[1])[i] = verts_vec_w[i+3];
}
/* south vertex of each child pixel */
for(i=0;i<=2;i++){
(vertices_vec_n[2])[i] = verts_vec_n[i+6];
(vertices_vec_e[2])[i] = verts_vec_e[i+6];
(vertices_vec_s[2])[i] = verts_vec_s[i+6];
(vertices_vec_w[2])[i] = verts_vec_w[i+6];
}
/* west vertex of each child pixel */
for(i=0;i<=2;i++){
(vertices_vec_n[3])[i] = verts_vec_n[i+9];
(vertices_vec_e[3])[i] = verts_vec_e[i+9];
(vertices_vec_s[3])[i] = verts_vec_s[i+9];
(vertices_vec_w[3])[i] = verts_vec_w[i+9];
}
rp_to_azel(vertices_vec_n[3], vertices_azel[1]);
rp_to_azel(vertices_vec_w[2], vertices_azel[3]);
rp_to_azel(vertices_vec_s[1], vertices_azel[5]);
rp_to_azel(vertices_vec_e[0], vertices_azel[7]);
for(i=0; i<8; i++){
if(vertices[i].az < 0.) vertices[i].az = vertices[i].az + TWOPI;
else {};
}
for(i=0; i<8; i++){
if(vertices[i].az >= TWOPI) vertices[i].az = vertices[i].az - TWOPI;
else {};
}
nv=8; nvmax=8;
vert=new_vert(nvmax);
if(!vert){
fprintf(stderr, "error in get_healpix_poly: failed to allocate memory for 8 vertices\n");
return(0x0);
}
vert->nv=nv; vert->v=&vertices[0];
pixel=new_poly(4);
if(!pixel){
fprintf(stderr, "error in get_healpix_poly: failed to allocate memory for polygon of 4 caps\n");
return(0x0);
}
ev[0] = 8;
edge_to_poly(vert, 2, &ev[0], pixel);
pixel->id = hpix;
pixelbetter=new_poly(5);
if(!pixelbetter){
fprintf(stderr, "error in get_healpix_poly: failed to allocate memory for polygon of 5 caps\n");
return(0x0);
}
pixelbetter->np = 5;
pixelbetter->npmax = 5;
for(i=0; i<=3; i++) {
pixelbetter->rp[i][0] = pixel->rp[i][0];
pixelbetter->rp[i][1] = pixel->rp[i][1];
pixelbetter->rp[i][2] = pixel->rp[i][2];
pixelbetter->cm[i] = pixel->cm[i];
}
pixelbetter->rp[4][0] = center[0]; pixelbetter->rp[4][1] = center[1]; pixelbetter->rp[4][2] = center[2];
pixelbetter->id = hpix;
dist_n = cmrpirpj(center, vertices_vec[0]);
dist_w = cmrpirpj(center, vertices_vec[3]);
dist_s = cmrpirpj(center, vertices_vec[2]);
dist_e = cmrpirpj(center, vertices_vec[1]);
if(dist_n>=dist_w && dist_n>=dist_s && dist_n>=dist_e){
pixelbetter->cm[4] = dist_n+0.000001;
}
else if(dist_w>=dist_n && dist_w>=dist_s && dist_w>=dist_e){
pixelbetter->cm[4] = dist_w+0.000001;
}
else if(dist_s>=dist_n && dist_s>=dist_w && dist_s>=dist_e){
pixelbetter->cm[4] = dist_s+0.000001;
}
else if(dist_e>=dist_n && dist_e>=dist_s && dist_e>=dist_w){
pixelbetter->cm[4] = dist_e+0.000001;
}
else{
fprintf(stderr, "error in get_healpix_poly: cannot find correct fifth cap\n");
return(0x0);
}
if(!pixelbetter){
fprintf(stderr, "error in get_healpix_poly: polygon is NULL.\n");
return(0x0);
}
return(pixelbetter);
}
}
/*------------------------------------------------------------
get_nside: determines the HEALPix nside parameter (related to
the resolution) from the number of weights (i.e.,
polygons) listed in the input file
Input: nweights = number of weights in HEALPix_weight input file
Return value: nside parameter
*/
int get_nside(int nweights)
{
int res, nside;
long double res_d;
if (nweights == 1) {
nside = 0;
return(nside);
}
else {
res_d = (long double)(logl(((long double)nweights)/3.0)/logl(4.0));
/* res_d is often slightly under the correct res, so we add 0.1 to make it correct upon truncation */
res = (int)(res_d+0.1);
nside = (int)(powl(2,(int)(res-1)));
return(nside);
}
}
/*------------------------------------------------------------
healpix_verts: interface to Fortran subroutine that calculates
the exact vertices of any HEALPix pixel at a
given nside
Input: nside = HEALPix parameter describing resolution
pix = pixel number, where the first pixel number
for any resolution is always 0
Output: center = (x,y,z) coordinates of the pixel center
verts = array of (x,y,z) positions of the four
pixel vertices in the order N,E,S,W
*/
void healpix_verts(int nside, int pix, vec center, long double verts[12])
{
pix2vec_nest__(&nside, &pix, &(center[0]), &(center[1]), &(center[2]), &(verts[0]), &(verts[1]), &(verts[2]), &(verts[3]), &(verts[4]), &(verts[5]), &(verts[6]), &(verts[7]), &(verts[8]), &(verts[9]), &(verts[10]), &(verts[11]));
}
/*-------------------------------------------------------------
cmrpirpj: C version of Fortran subroutine that calculates the value
of (1-cosl(th(ij))), where th(ij) is the angle between the
unit vectors rpi and rpj
Input: rpi, rpj = unit vectors
Return value: 1- cosl(th(ij))
*/
long double cmrpirpj(vec rpi, vec rpj)
{
long double cmij;
cmij = (powl((rpi[0]-rpj[0]),2)+powl((rpi[1]-rpj[1]),2)+powl((rpi[2]-rpj[2]),2))/2.;
return(cmij);
}

75
src/heapsort.inc Normal file
View file

@ -0,0 +1,75 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
c *
c * Inline code to find the first nb ordered elements of an array.
c * The order is defined by the `function' order(i,j).
c * It's inlined to allow greater flexibility in defining the
c * order() function. For example, the same code works for both
c * real and integer arrays.
c *
c * Returns index iord of these nb elements, ordered so that iord(1)
c * corresponds to the element having the most extreme value.
c * If nb .gt. na, then the last nb-na elements of iord are undefined.
c * Uses heapsort algorithm.
c *
n=min(na,nb)
if (n.le.0) return
c heap first n elements, so smallest element is at top of heap
do 210 ib=n/2+1,n
iord(ib)=ib
210 continue
do 240 ia=n/2,1,-1
i=ia
230 ib=i*2
if (ib.le.n) then
if (ib.lt.n) then
if (order(iord(ib),iord(ib+1))) ib=ib+1
endif
if (order(ia,iord(ib))) then
iord(i)=iord(ib)
i=ib
goto 230
endif
endif
iord(i)=ia
240 continue
c now compare rest of elements of array to heap
do 340 ia=n+1,na
c if new element is greater than smallest, sift it into heap
i=1
if (order(ia,iord(i))) then
330 ib=i*2
if (ib.le.n) then
if (ib.lt.n) then
if (order(iord(ib),iord(ib+1))) ib=ib+1
endif
if (order(ia,iord(ib))) then
iord(i)=iord(ib)
i=ib
goto 330
endif
endif
iord(i)=ia
endif
340 continue
c unheap iord so largest element is at top
do 390 ja=2,n
ia=2+n-ja
it=iord(ia)
i=1
iord(ia)=iord(i)
380 ib=i*2
if (ib.le.ia-1) then
if (ib.lt.ia-1) then
if (order(iord(ib),iord(ib+1))) ib=ib+1
endif
if (order(it,iord(ib))) then
iord(i)=iord(ib)
i=ib
goto 380
endif
endif
iord(i)=it
390 continue
c

76
src/ikrand.c Normal file
View file

@ -0,0 +1,76 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdlib.h>
#include <stdio.h>
#include "manglefn.h"
/*------------------------------------------------------------------------------
Called as fortran subroutine
ikrand(ik,ikran)
Pseudo-random unsigned long or unsigned long long associated with integer ik,
returned as a long double.
*/
void ikrand_(int *ik, long double *ikran)
{
unsigned long *likran;
unsigned long long *llikran;
/* seed random number generator with *ik */
srandom((unsigned int) *ik);
/* generate pseudo-random unsigned long */
if (sizeof(long long) > sizeof(long double)) {
likran = (unsigned long *)ikran;
*likran = random();
/* generate pseudo-random unsigned long long */
} else {
llikran = (unsigned long long *)ikran;
*llikran = random();
*llikran <<= (8 * sizeof(unsigned long));
*llikran |= random();
}
}
/*------------------------------------------------------------------------------
Called as fortran subroutine
ikrandp(ikchk,ikran)
ikchk = ikchk + ikran
passed as long double's, but treated as unsigned long's or unsigned long long's.
*/
void ikrandp_(long double *ikchk, long double *ikran)
{
unsigned long *likchk;
unsigned long long *llikchk;
if (sizeof(long long) > sizeof(long double)) {
likchk = (unsigned long *)ikchk;
*likchk += *(unsigned long *)ikran;
} else {
llikchk = (unsigned long long *)ikchk;
*llikchk += *(unsigned long long *)ikran;
}
}
/*------------------------------------------------------------------------------
Called as fortran subroutine
ikrandm(ikchk,ikran)
ikchk = ikchk - ikran
passed as long double's, but treated as unsigned long's or unsigned long long's.
*/
void ikrandm_(long double *ikchk, long double *ikran)
{
unsigned long *likchk;
unsigned long long *llikchk;
if (sizeof(long long) > sizeof(long double)) {
likchk = (unsigned long *)ikchk;
*likchk -= *(unsigned long *)ikran;
} else {
llikchk = (unsigned long long *)ikchk;
*llikchk -= *(unsigned long long *)ikran;
}
}

20
src/inputfile.h Normal file
View file

@ -0,0 +1,20 @@
/*------------------------------------------------------------------------------
(C) A J S Hamilton 2001
------------------------------------------------------------------------------*/
#ifndef INPUTFILE_H
#define INPUTFILE_H
#include <stdio.h>
typedef struct _inputfile {
char *name; /* filename */
FILE *file; /* file stream */
char *line; /* line buffer */
size_t bufsize; /* size of line buffer (will expand as necessary) */
unsigned int line_number; /* line number */
unsigned int end; /* maximum number of characters to read (0 = no limit) */
} inputfile;
int rdline(inputfile *);
#endif /* INPUTFILE_H */

74
src/iylm.s.f Normal file
View file

@ -0,0 +1,74 @@
c-----------------------------------------------------------------------
subroutine iylm(thmin,thmax,w,lmax1,nw,v)
integer lmax1,nw
real*10 thmin,thmax,w(nw)
c work array (could be automatic if compiler supports it)
real*10 v(lmax1)
c
c parameters
include 'pi.par'
c data variables
real*10 tiny
c local (automatic) variables
integer lm,lmx1,qphi
real*10 ri,phi,zi,ci,si,ph,dph
c *
c * w_lm = integral from thmin to thmax Y_lm(th,0) sin th d th
c *
c * ISN'T THERE A FASTER WAY OF DOING THIS?
c * I can find an expansion in incomplete beta functions,
c * but the expansion is not much shorter, and not as pretty.
c *
c Input: thmin, thmax = minimum, maximum polar angle in radians.
c lmax1 = lmax+1 where lmax is maximum desired l of transform.
c nw = [(lmax+1)*(lmax+2)]/2 .
c Output: w(lm) = integral from thmax to thmin Y_lm(th,0) d cos th .
c Work array: v should be dimensioned at least lmax1 .
c
data tiny /1.e-30_10/
c
do 120 lm=1,nw
w(lm)=0._10
120 continue
c upper latitude term
ri=0._10
zi=1._10
phi=0._10
ph=0._10
dph=-tiny
if (thmin.eq.0._10.or.thmin.eq.PI) then
si=0._10
lmx1=1
else
si=sin(thmin)
lmx1=lmax1
endif
ci=cos(thmin)
call wlm(w,lmx1,1,nw,ri,phi,0,zi,ci,si,ph,dph,v)
c lower latitude term
dph=tiny
if (thmax.eq.0._10.or.thmax.eq.PI) then
si=0._10
lmx1=1
else
si=sin(thmax)
lmx1=lmax1
endif
ci=cos(thmax)
call wlm(w,lmx1,1,nw,ri,phi,0,zi,ci,si,ph,dph,v)
c longitude term
ri=1._10
zi=0._10
ci=0._10
si=1._10
phi=tiny
qphi=-1
ph=PI-(thmin+thmax)/2._10
dph=thmax-thmin
call wlm(w,lmax1,1,nw,ri,phi,qphi,zi,ci,si,ph,dph,v)
do 140 lm=1,nw
w(lm)=w(lm)/tiny
140 continue
return
end
c

18
src/logical.h Normal file
View file

@ -0,0 +1,18 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/#include <limits.h>
#ifndef LOGICAL_H
#define LOGICAL_H
/* define a c type logical equivalent to fortran's logical, which (on most
systems) is a 32 bit integer
*/
#if LONG_MAX==2147483647
typedef long int logical; /* type of fortran logical, according to f2c */
#elif INT_MAX==2147483647
typedef int logical; /* if long is too big, make logical an int */
#else
#error Could not define a 32-bit integer type for "logical"
#endif
#endif /* LOGICAL_H */

9
src/mangdir.inc Normal file
View file

@ -0,0 +1,9 @@
c-----------------------------------------------------------------------
c © A J S Hamilton 2001
c-----------------------------------------------------------------------
c * mangenv = name of environment variable containing mangle directory.
c * mangdir = pathname of directory containing mangle code.
c * The contents of these variables is initialized in mangdir.dat
character*16 mangenv
character*64 mangdir
c

357
src/manglefn.h Normal file
View file

@ -0,0 +1,357 @@
/*------------------------------------------------------------------------------
(C) A J S Hamilton 2003
------------------------------------------------------------------------------*/
#ifndef MANGLEFN_H
#define MANGLEFN_H
#include "defines.h"
#include "format.h"
#include "harmonics.h"
#include "logical.h"
#include "polygon.h"
#include "vertices.h"
#include "polysort.h"
#ifdef __cplusplus
extern "C" {
#endif
void advise_fmt(format *);
void azel_(long double *, long double *, long double *, long double *, long double *, long double *, long double *);
void azell_(long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *);
void braktop(long double, int *, long double [], int, int);
void brakbot(long double, int *, long double [], int, int);
void braktpa(long double, int *, long double [], int, int);
void brakbta(long double, int *, long double [], int, int);
void braktop_(long double *, int *, long double [], int *, int *);
void brakbot_(long double *, int *, long double [], int *, int *);
void braktpa_(long double *, int *, long double [], int *, int *);
void brakbta_(long double *, int *, long double [], int *, int *);
void cmminf(polygon *, int *, long double *);
void vert_to_poly(vertices *, polygon *);
void edge_to_poly(vertices *, int, int *, polygon *);
void rect_to_poly(long double [4], polygon *);
#if defined(GCC) && 0
void rps_to_vert(int nv, vec [nv], vertices *);
#else
void rps_to_vert(int nv, vec [/*nv*/], vertices *);
#endif
void rp_to_azel(vec, azel *);
void azel_to_rp(azel *, vec);
void azel_to_gc(azel *, azel *, vec, long double *);
void rp_to_gc(vec, vec, vec, long double *);
void edge_to_rpcm(azel *, azel *, azel *, vec, long double *);
void rp_to_rpcm(vec, vec, vec, vec, long double *);
void circ_to_rpcm(long double [3], vec, long double *);
void rpcm_to_circ(vec, long double *, long double [3]);
void az_to_rpcm(long double, int, vec, long double *);
void el_to_rpcm(long double, int, vec, long double *);
long double thij(vec, vec);
long double cmij(vec, vec);
int poly_to_rect(polygon *, long double *, long double *, long double *, long double *);
int antivert(vertices *, polygon *);
void copy_format(format *, format *);
void copy_poly(polygon *, polygon *);
void copy_polyn(polygon *, int, polygon *);
void poly_poly(polygon *, polygon *, polygon *);
void poly_polyn(polygon *, polygon *, int, int, polygon *);
#if defined(GCC) && 0
void group_poly(polygon *poly, int [poly->np], int, polygon *);
#else
void group_poly(polygon *poly, int [/*poly->np*/], int, polygon *);
#endif
void assign_parameters();
void pix2ang(int, unsigned long, long double *, long double *);
void ang2pix(int, long double, long double, unsigned long *);
void pix2ang_radec(int, unsigned long, long double *, long double *);
void ang2pix_radec(int, long double, long double, unsigned long *);
void csurvey2eq(long double, long double, long double *, long double *);
void eq2csurvey(long double, long double, long double *, long double *);
void superpix(int, unsigned long, int, unsigned long *);
void subpix(int, unsigned long, unsigned long *, unsigned long *, unsigned long *, unsigned long *);
void pix_bound(int, unsigned long, long double *, long double *, long double *, long double *);
long double pix_area(int, unsigned long);
void pix2xyz(int, unsigned long, long double *, long double *, long double *);
void area_index(int, long double, long double, long double, long double, unsigned long *, unsigned long *, unsigned long *, unsigned long *);
void area_index_stripe(int, int, unsigned long *, unsigned long *, unsigned long *, unsigned long *);
long double drandom(void);
#if defined(GCC) && 0
int cmlim_polys(int npoly, polygon *[npoly], long double, vec);
int drangle_polys(int npoly, polygon *[npoly], long double, vec, int nth, long double [nth], long double [nth]);
#else
int cmlim_polys(int npoly, polygon *[/*npoly*/], long double, vec);
int drangle_polys(int npoly, polygon *[/*npoly*/], long double, vec, int nth, long double [/*nth*/], long double [/*nth*/]);
#endif
void cmlimpolys_(long double *, vec);
#if defined(GCC) && 0
void dranglepolys_(long double *, vec, int *nth, long double [*nth], long double [*nth]);
#else
void dranglepolys_(long double *, vec, int *nth, long double [/**nth*/], long double [/**nth*/]);
#endif
#if defined(GCC) && 0
void dump_poly(int npoly, polygon *[npoly]);
#else
void dump_poly(int, polygon *[/*npoly*/]);
#endif
void fframe_(int *, long double *, long double *, int *, long double *, long double *);
void findtop(long double [], int, int [], int);
void findbot(long double [], int, int [], int);
void findtpa(long double [], int, int [], int);
void findbta(long double [], int, int [], int);
void finitop(int [], int, int [], int);
void finibot(int [], int, int [], int);
void finitpa(int [], int, int [], int);
void finibta(int [], int, int [], int);
void findtop_(long double [], int *, int [], int *);
void findbot_(long double [], int *, int [], int *);
void findtpa_(long double [], int *, int [], int *);
void findbta_(long double [], int *, int [], int *);
void finitop_(int [], int *, int [], int *);
void finibot_(int [], int *, int [], int *);
void finitpa_(int [], int *, int [], int *);
void finibta_(int [], int *, int [], int *);
polygon *get_pixel(int,char);
int get_child_pixels(int, int [], char);
int get_parent_pixels(int, int [], char);
int get_res(int,char);
void healpix_ang2pix_nest(int, long double, long double, int *);
polygon *get_healpix_poly(int, int);
int get_nside(int);
void healpix_verts(int, int, vec, long double []);
void pix2vec_nest__(int *, int *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *, long double *);
long double cmrpirpj(vec, vec);
int garea(polygon *, long double *, int, long double *);
int gcmlim(polygon *, long double *, vec, long double *, long double *);
int gphbv(polygon *, int, int, long double *, long double [2], long double [2]);
int gphi(polygon *, long double *, vec, long double, long double *);
int gptin(polygon *, vec);
#if defined(GCC) && 0
int gspher(polygon *, int lmax, long double *, long double *, long double [2], long double [2], harmonic [NW]);
int gsphera(long double, long double, long double, long double, int lmax, long double *, long double [2], long double [2], harmonic [NW]);
int gsphr(polygon *, int lmax, long double *, harmonic [NW]);
int gsphra(long double, long double, long double, long double, int lmax, harmonic [NW]);
#else
int gspher(polygon *, int lmax, long double *, long double *, long double [2], long double [2], harmonic [/*NW*/]);
int gsphera(long double, long double, long double, long double, int lmax, long double *, long double [2], long double [2], harmonic [/*NW*/]);
int gsphr(polygon *, int lmax, long double *, harmonic [/*NW*/]);
int gsphra(long double, long double, long double, long double, int lmax, harmonic [/*NW*/]);
#endif
int gverts(polygon *, int, long double *, int, int, int *, vec **, long double **, int **, int **, int *, int *, int **);
#if defined(GCC) && 0
int gvert(polygon *poly, int, long double *, int nvmax, int, int nve, int *, vec [nvmax * nve], long double [nvmax], int [nvmax], int [poly->np], int *, int *, int [nvmax]);
#else
int gvert(polygon *poly, int, long double *, int nvmax, int, int nve, int *, vec [/*nvmax * nve*/], long double [/*nvmax*/], int [/*nvmax*/], int [/*poly->np*/], int *, int *, int [/*nvmax*/]);
#endif
int gvlims(polygon *, int, long double *, vec, int *, vec **, vec **, long double **, long double **, long double **, long double **, int **, int **, int *, int *, int **);
#if defined(GCC) && 0
int gvlim(polygon *poly, int, long double *, vec, int nvmax, int *, vec [nvmax], vec [nvmax], long double [nvmax], long double [nvmax], long double [poly->np], long double [poly->np], int [nvmax], int [poly->np], int *, int *, int [nvmax]);
#else
int gvlim(polygon *poly, int, long double *, vec, int nvmax, int *, vec [/*nvmax*/], vec [/*nvmax*/], long double [/*nvmax*/], long double [/*nvmax*/], long double [/*poly->np*/], long double [/*poly->np*/], int [/*nvmax*/], int [/*poly->np*/], int *, int *, int [/*nvmax*/]);
#endif
int gvphi(polygon *, vec, long double, vec, long double *, long double *, vec);
void garea_(long double *, vec [], long double [], int *, long double *, int *, long double *, int *, logical *);
void gaxisi_(vec, vec, vec);
void gcmlim_(vec [], long double [], int *, vec, long double *, long double *, long double *, long double *, int *);
void gphbv_(long double [2], long double [2], vec [], long double [], int *, int *, int *, int *, long double *, long double *, int *);
void gphi_(long double *, vec [], long double [], int *, vec, long double *, long double *, long double *, int *);
logical gptin_(vec [], long double [], int *, vec);
void gspher_(long double *, long double [2], long double [2], harmonic [], int *, int *, int *, vec [], long double [], int *, int *, int *, int *, long double *, long double *, int *, long double *, logical *);
void gsphera_(long double *, long double [2], long double [2], harmonic [], int *, int *, int *, int *, long double *, long double *, long double *, long double *, long double *, long double *);
void gvert_(vec [], long double [], int [], int [], int [], int *, int *, int *, int *, int *, int *, vec [], long double [], int *, int *, long double *, long double *, int *, long double *, int *, logical *);
void gvlim_(vec [], vec [], long double [], long double [], long double [], long double [], int [], int [], int [], int *, int *, int *, int *, vec [], long double [], int *, long double [], int *, long double *, long double *, int *, long double *, int *, logical *);
void gvphi_(long double *, vec, vec [], long double [], int *, vec, long double *, vec, long double *, long double *, int *);
#if defined(GCC) && 0
int harmonize_polys(int npoly, polygon *[npoly], long double, int lmax, harmonic w[NW]);
#else
int harmonize_polys(int npoly, polygon *poly[/*npoly*/], long double, int lmax, harmonic w[/*NW*/]);
#endif
void harmonizepolys_(long double *, int *, harmonic []);
void ikrand_(int *, long double *);
void ikrandp_(long double *, long double *);
void ikrandm_(long double *, long double *);
void msg(char *, ...);
polygon *new_poly(int);
void free_poly(polygon *);
int room_poly(polygon **, int, int, int);
void memmsg(void);
vertices *new_vert(int);
void free_vert(vertices *);
void parse_args(int, char *[]);
int parse_fopt(void);
#if defined(GCC) && 0
int partition_poly(polygon **, int npolys, polygon *[npolys], long double, int, int, int, int, int *);
int partition_gpoly(polygon *, int npolys, polygon *[npolys], long double, int, int, int, int *);
int part_poly(polygon *, int npolys, polygon *[npolys], long double, int, int, int, int *, int *);
int pixel_list(int npoly, polygon *[npoly], int max_pixel, int [max_pixel], int [max_pixel]);
#else
int partition_poly(polygon **, int npolys, polygon *[/*npolys*/], long double, int, int, int, int, int *);
int partition_gpoly(polygon *, int npolys, polygon *[/*npolys*/], long double, int, int, int, int *);
int part_poly(polygon *, int npolys, polygon *[/*npolys*/], long double, int, int, int, int *, int *);
int pixel_list(int npoly, polygon *[/*npoly*/], int max_pixel, int [/*max_pixel*/], int [/*max_pixel*/]);
#endif
int pixel_start(int, char);
long double places(long double, int);
int poly_cmp(polygon **, polygon **);
#if defined(GCC) && 0
int poly_id(int npoly, polygon *[npoly], long double, long double, int **, long double **);
void poly_sort(int npoly, polygon *[npoly], char);
#else
int poly_id(int npoly, polygon *[/*npoly*/], long double, long double, int **, long double **);
void poly_sort(int npoly, polygon *[/*npoly*/], char);
#endif
int prune_poly(polygon *, long double);
int trim_poly(polygon *);
int touch_poly(polygon *);
int rdangle(char *, char **, char, long double *);
#if defined(GCC) && 0
int rdmask(char *, format *, int npolys, polygon *[npolys]);
#else
int rdmask(char *, format *, int npolys, polygon *[/*npolys*/]);
#endif
void rdmask_(void);
int rdspher(char *, int *, harmonic **);
void scale(long double *, char, char);
void scale_azel(azel *, char, char);
void scale_vert(vertices *, char, char);
#if defined(GCC) && 0
int search(int n, long double [n], long double);
#else
int search(int n, long double [/*n*/], long double);
#endif
#if defined(GCC) && 0
int snap_polys(format *fmt, int npoly, polygon *poly[npoly], int, long double, long double, long double, long double, long double, int, char *);
#else
int snap_polys(format *fmt, int npoly, polygon *poly[/*npoly*/], int, long double, long double, long double, long double, long double, int, char *);
#endif
int snap_poly(polygon *, polygon *, long double, long double);
int snap_polyth(polygon *, polygon *, long double, long double, long double);
int split_poly(polygon **, polygon *, polygon **, long double, char);
#if defined(GCC) && 0
int fragment_poly(polygon **, polygon *, int, int npolys, polygon *[npolys], long double, char);
#else
int fragment_poly(polygon **, polygon *, int, int npolys, polygon *[/*npolys*/], long double, char);
#endif
int strcmpl(const char *, const char *);
int strncmpl(const char *, const char *, size_t);
int strdict(char *, char *[]);
int strdictl(char *, char *[]);
#if defined(GCC) && 0
int vmid(polygon *, long double, int nv, int nve, vec [nv * nve], int [nv], int [nv], int *, vec **);
int vmidc(polygon *, int nv, int nve, vec [nv * nve], int [nv], int [nv], int *, vec **);
#else
int vmid(polygon *, long double, int nv, int nve, vec [/*nv * nve*/], int [/*nv*/], int [/*nv*/], int *, vec **);
int vmidc(polygon *, int nv, int nve, vec [/*nv * nve*/], int [/*nv*/], int [/*nv*/], int *, vec **);
#endif
long double weight_fn(long double, long double, char *);
long double rdweight(char *);
long double twoqz_(long double *, long double *, int *);
long double twodf100k_(long double *, long double *);
long double twodf230k_(long double *, long double *);
int which_pixel(long double, long double, int, char);
#if defined(GCC) && 0
void wrangle(long double, char, int, size_t str_len, char [str_len]);
#else
void wrangle(long double, char, int, size_t str_len, char [/*str_len*/]);
#endif
#if defined(GCC) && 0
long double wrho(long double, long double, int lmax, int, harmonic w[NW], long double, long double);
#else
long double wrho(long double, long double, int lmax, int, harmonic w[/*NW*/], long double, long double);
#endif
long double wrho_(long double *, long double *, harmonic *, int *, int *, int *, int *, long double *, long double *);
#if defined(GCC) && 0
int wr_bin_poly(char *, format *, int npolys, polygon *[npolys], int);
int wrmask(char *, format *, int npolys, polygon *[npolys]);
int wr_circ(char *, format *, int npolys, polygon *[npolys], int);
int wr_edge(char *, format *, int npolys, polygon *[npolys], int);
int wr_rect(char *, format *, int npolys, polygon *[npolys], int);
int wr_poly(char *, format *, int npolys, polygon *[npolys], int);
int wr_Reg(char *, format *, int npolys, polygon *[npolys], int);
int wr_area(char *, format *, int npolys, polygon *[npolys], int);
int wr_id(char *, int npolys, polygon *[npolys], int);
int wr_midpoint(char *, format *, int npolys, polygon *[npolys], int);
int wr_weight(char *, format *, int npolys, polygon *[npolys], int);
int wr_healpix_weight(char *, format *, int numweight, long double [numweight]);
int wr_list(char *, format *, int npolys, polygon *[npolys], int);
int discard_poly(int npolys, polygon *[npolys]);
#else
int wr_bin_poly(char *, format *, int npolys, polygon *[/* npolys */], int);
int wrmask(char *, format *, int npolys, polygon *[/*npolys*/]);
int wr_circ(char *, format *, int npolys, polygon *[/*npolys*/], int);
int wr_edge(char *, format *, int npolys, polygon *[/*npolys*/], int);
int wr_rect(char *, format *, int npolys, polygon *[/*npolys*/], int);
int wr_poly(char *, format *, int npolys, polygon *[/*npolys*/], int);
int wr_Reg(char *, format *, int npolys, polygon *[/*npolys*/], int);
int wr_area(char *, format *, int npolys, polygon *[/*npolys*/], int);
int wr_id(char *, int npolys, polygon *[/*npolys*/], int);
int wr_midpoint(char *, format *, int npolys, polygon *[/*npolys*/], int);
int wr_weight(char *, format *, int npolys, polygon *[/*npolys*/], int);
int wr_healpix_weight(char *, format *, int numweight, long double [/*numweight*/]);
int wr_list(char *, format *, int npolys, polygon *[/*npolys*/], int);
int discard_poly(int npolys, polygon *[/*npolys*/]);
#endif
int wrrrcoeffs(char *, long double, long double [2], long double [2]);
#if defined(GCC) && 0
int wrspher(char *, int lmax, harmonic [NW]);
#else
int wrspher(char *, int lmax, harmonic [/*NW*/]);
#endif
#ifdef __cplusplus
}
#endif
#endif /* MANGLEFN_H */

246
src/map.c Normal file
View file

@ -0,0 +1,246 @@
/*------------------------------------------------------------------------------
© A J S Hamilton 2001
------------------------------------------------------------------------------*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include "inputfile.h"
#include "manglefn.h"
#include "defaults.h"
/* redefine default maximum harmonic */
#undef LMAX
#define LMAX MAXINT
/* getopt options */
const char *optstr = "dqw:l:g:x:u:p:";
/* local functions */
void usage(void);
#ifdef GCC
int map(char *, char *, format *, int lmax, harmonic w[NW], long double, long double);
#else
int map(char *, char *, format *, int lmax, harmonic w[/*NW*/], long double, long double);
#endif
/*------------------------------------------------------------------------------
Main program.
*/
int main(int argc, char *argv[])
{
int nmap, nws;
harmonic *w_p;
/* lmax will be read from Wlm_filename, or set by command line */
lmax = LMAX;
/* parse arguments */
parse_args(argc, argv);
/* one input and output filename required as arguments */
if (argc - optind != 2) {
if (optind > 1 || argc - optind == 1) {
fprintf(stderr, "%s requires 2 arguments: azel_infile, and outfile\n", argv[0]);
usage();
exit(1);
} else {
usage();
exit(0);
}
}
/* file containing harmonics must have been specified */
if (!Wlm_filename) {
fprintf(stderr, "%s requires -w<Wlm_filename> option to specify file containing harmonics\n", argv[0]);
exit(1);
}
msg("---------------- map ----------------\n");
/* advise */
if (lsmooth == 0.) {
msg("no smoothing\n");
} else {
msg("smoothing harmonic number lsmooth = %Lg\n", lsmooth);
if (esmooth != 2.) {
msg("smoothing exponent = %Lg\n", esmooth);
}
}
/* read harmonics */
nws = rdspher(Wlm_filename, &lmax, &w_p);
if (nws == -1) exit(1);
/* map */
nmap = map(argv[argc - 2], argv[argc - 1], &fmt, lmax, w_p, lsmooth, esmooth);
if (nmap == -1) exit(1);
return(0);
}
/*------------------------------------------------------------------------------
*/
void usage(void)
{
printf("usage:\n");
printf("map [-d] [-q] -w<Wlmfile> [-l<lmax>] [-g<lsmooth>] [-u<inunit>[,<outunit>]] [-p[+|-][<n>]] azel_infile outfile\n");
#include "usage.h"
}
/*------------------------------------------------------------------------------
*/
#include "parse_args.c"
/*------------------------------------------------------------------------------
Map. Implemented as interpretive read/write, to permit interactive behaviour.
Input: in_filename = name of file to read from;
"" or "-" means read from standard input.
out_filename = name of file to write to;
"" or "-" means write to standard output.
fmt = pointer to format structure.
w = array containing spherical harmonics.
lmax = maximum harmonic number.
lsmooth = smoothing harmonic number (0. = no smooth).
esmooth = smoothing exponent (2. = gaussian).
Return value: number of items written,
or -1 if error occurred.
*/
int map(char *in_filename, char *out_filename, format *fmt, int lmax, harmonic w[/*NW*/], long double lsmooth, long double esmooth)
{
/* precision of map values written to file */
#define PRECISION 8
#define AZEL_STR_LEN 32
inputfile file = {
'\0', /* input filename */
0x0, /* input file stream */
'\0', /* line buffer */
64, /* size of line buffer (will expand as necessary) */
0, /* line number */
0 /* maximum number of characters to read (0 = no limit) */
};
char input[] = "input", output[] = "output";
char *word, *next;
char az_str[AZEL_STR_LEN], el_str[AZEL_STR_LEN];
int ird, len, mmax, nmap, width;
long double rho;
azel v;
char *out_fn;
FILE *outfile;
/* open in_filename for reading */
if (!in_filename || strcmp(in_filename, "-") == 0) {
file.file = stdin;
file.name = input;
} else {
file.file = fopen(in_filename, "r");
if (!file.file) {
fprintf(stderr, "cannot open %s for reading\n", in_filename);
return(-1);
}
file.name = in_filename;
}
file.line_number = 0;
/* open out_filename for writing */
if (!out_filename || strcmp(out_filename, "-") == 0) {
outfile = stdout;
out_fn = output;
} else {
outfile = fopen(out_filename, "w");
if (!outfile) {
fprintf(stderr, "cannot open %s for writing\n", out_filename);
return(-1);
}
out_fn = out_filename;
}
/* advise angular units */
msg("will take units of input az, el angles in %s to be ", file.name);
switch (fmt->inunit) {
#include "angunit.h"
}
msg("\n");
if (fmt->outunit != fmt->inunit) {
msg("units of output az, el angles will be ");
switch (fmt->outunit) {
#include "angunit.h"
}
msg("\n");
}
/* setting mmax = lmax ensures complete set of azimuthal harmonics */
mmax = lmax;
/* width of map value */
width = PRECISION + 6;
/* write header */
v.az = 0.;
wrangle(v.az, fmt->outunit, fmt->outprecision, AZEL_STR_LEN, az_str);
len = strlen(az_str);
if (fmt->outunit == 'h') {
sprintf(az_str, "az(hms)");
sprintf(el_str, "el(dms)");
} else {
sprintf(az_str, "az(%c)", fmt->outunit);
sprintf(el_str, "el(%c)", fmt->outunit);
}
fprintf(outfile, "%*s %*s %*s\n", len, az_str, len, el_str, width - 4, "wrho");
/* interpretive read/write loop */
nmap = 0;
while (1) {
/* read line */
ird = rdline(&file);
/* serious error */
if (ird == -1) return(-1);
/* EOF */
if (ird == 0) break;
/* read <az> */
word = file.line;
ird = rdangle(word, &next, fmt->inunit, &v.az);
/* skip header */
if (ird != 1 && nmap == 0) continue;
/* otherwise exit on unrecognized characters */
if (ird != 1) break;
/* read <el> */
word = next;
ird = rdangle(word, &next, fmt->inunit, &v.el);
/* skip header */
if (ird != 1 && nmap == 0) continue;
/* otherwise exit on unrecognized characters */
if (ird != 1) break;
/* convert az and el from input units to radians */
scale_azel(&v, fmt->inunit, 'r');
/*
The entire of map.c is an interface to the next line of code.
Bizarre, huh?
*/
/* compute the value of the window function at this point */
rho = wrho(v.az, v.el, lmax, mmax, w, lsmooth, esmooth);
/* convert az and el from radians to output units */
scale_azel(&v, 'r', fmt->outunit);
/* write result */
wrangle(v.az, fmt->outunit, fmt->outprecision, AZEL_STR_LEN, az_str);
wrangle(v.el, fmt->outunit, fmt->outprecision, AZEL_STR_LEN, el_str);
fprintf(outfile, "%s %s %- #*.*Lg\n", az_str, el_str, width, PRECISION, rho);
fflush(outfile);
/* increment counter of results */
nmap++;
}
if (outfile != stdout) {
msg("map: %d values written to %s\n", nmap, out_fn);
}
return(nmap);
}

Some files were not shown because too many files have changed in this diff Show more