Index: src/csh/meanc.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/meanc.csh,v retrieving revision 1.7 retrieving revision 1.8 diff -r1.7 -r1.8 31c31 < echo '# $Id: meanc.csh,v 1.7 2002/08/07 00:01:48 welling Exp $' --- > echo '# $Id: meanc.csh,v 1.8 2003/12/04 21:20:25 welling Exp $' 34c34 < -dataout .dat -parameters par/$F_MEANC_PARMS.$$ \ --- > -parameters par/$F_MEANC_PARMS.$$ \ Index: Makefile.common =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/Makefile.common,v retrieving revision 1.42 retrieving revision 1.43 diff -r1.42 -r1.43 31c31 < SRCDIRS = util libcrg libmri libcdf fmri reader baseline deghost \ --- > SRCDIRS = util libcrg libmri libdcdf fmri reader baseline deghost \ Index: src/csh/FIASCO =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/FIASCO,v retrieving revision 1.26 retrieving revision 1.27 diff -r1.26 -r1.27 30c30 < # $Id: FIASCO,v 1.26 2003/09/18 19:20:00 bakalj Exp $ --- > # $Id: FIASCO,v 1.28 2003/12/03 22:00:11 bakalj Exp $ 49c49 < echo '$Id: FIASCO,v 1.26 2003/09/18 19:20:00 bakalj Exp $'\ --- > echo '$Id: FIASCO,v 1.28 2003/12/03 22:00:11 bakalj Exp $'\ 56c56 < setenv FIASCO_PATCHLVL 0 --- > setenv FIASCO_PATCHLVL 2 Index: src/csh/false_discovery.py =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/false_discovery.py,v retrieving revision 1.12 retrieving revision 1.13 diff -r1.12 -r1.13 8a9,10 > idString= "$Id: false_discovery.py,v 1.13 2003/10/29 22:45:46 welling Exp $" > Index: src/csh/fisher_combine.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/fisher_combine.csh,v retrieving revision 1.4 retrieving revision 1.5 diff -r1.4 -r1.5 36c36 < echo '# $Id: fisher_combine.csh,v 1.4 2003/09/18 05:05:00 bakalj Exp $' --- > echo '# $Id: fisher_combine.csh,v 1.5 2003/10/28 00:03:04 welling Exp $' 88c88 < mri_rpn_math '1,$1,$2,ct,-,.000001,+,dup,1.0,swap,1.0,<,if_keep,ln,-2,*' \ --- > mri_rpn_math '1,$1,$2,ct,-,dup,1.0,swap,1.0,<,if_keep,ln,-2,*' \ Index: src/csh/map_name.py =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/map_name.py,v retrieving revision 1.6 retrieving revision 1.7 diff -r1.6 -r1.7 46a47 > global mapDict 52a54,55 > if verbose: > print "Added new dictionary <%s> to mapDict"%dictKey 54a58 > global mapDict 66a71 > global mapDict 91a97,98 > if verbose: > print "Added new dictionary <%s> to mapDict"%mapAttr 111,117d117 < def defineTerm( dict, term ): < brk= string.find(term,"="); < if brk > 0: < dict[string.strip(term[0:brk])]= string.strip(term[brk+1:]); < else: < dict["-"]= mapExpression(term); < 127a128,160 > def expandDictionary(dict,nameOfAnotherDict): > global mapDict > if mapDict.has_key(nameOfAnotherDict): > if verbose: > print "Adding dictionary for <%s>"%nameOfAnotherDict > for (key,val) in mapDict[nameOfAnotherDict].items(): > dict[key]= val > > def maybeExpandDictionary(dict,termKey,term): > global mapDict > if mapDict.has_key(term): > subDict= mapDict[term] > if subDict.has_key(termKey): > if subDict[termKey]==term: > if verbose: > print "Adding dictionary for <%s>:<%s>"%(termKey,term) > for (key,val) in subDict.items(): > if key != termKey: > dict[key]= val > > def defineTerm( dict, term ): > if verbose: > print "defining term <%s>"%term > brk= string.find(term,"="); > if brk > 0: > key= string.strip(term[0:brk]) > val= string.strip(term[brk+1:]) > dict[key]= val > maybeExpandDictionary(dict,key,val) > else: > dict["-"]= mapExpression(term); > maybeExpandDictionary(dict,"-",val) > 140c173,177 < return term[0:brk1]+recursiveMap(dict,term[brk1+1:brk2],lvl+1)+recursiveMap(dict,term[brk2+1:],lvl+1); --- > mapResult1= recursiveMap(dict,term[brk1+1:brk2],lvl+1) > mapResult2= recursiveMap(dict,term[brk2+1:],lvl+1) > maybeExpandDictionary(dict,term[brk1+1:brk2],mapResult1) > maybeExpandDictionary(dict,term[brk2+1:],mapResult2) > result= term[0:brk1]+ mapResult1 + mapResult2 143c180,181 < return recursiveMap(dict,dict[term],lvl+1); --- > result= recursiveMap(dict,dict[term],lvl+1); > maybeExpandDictionary(dict,term,result) 145c183,186 < return term; --- > result= term; > if verbose: > print "mapped <%s> to <%s>"%(term,result) > return result 264,266c305 < addDict= mapDict[mainkey]; < for k in addDict.keys(): < valDict[k]= addDict[k]; --- > expandDictionary(valDict,mainkey) Index: src/csh/masked_false_discovery.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/masked_false_discovery.csh,v retrieving revision 1.3 diff -r1.3 masked_false_discovery.csh 3c3 < # Usage: masked_false_discovery.py qval Mask Pmap --- > # Usage: masked_false_discovery.csh qval Mask Pmap 7a8,14 > if ( $# != 3 ) then > echo "usage: $0 qval Mask Pmap" > echo " qval is the Q threshold (e.g. 0.01)" > echo " Mask is a Pgh MRI file containing a mask of the brain" > echo " Pmap is a Pgh MRI file containing the P scores" > exit -1 > endif Index: src/csh/merge_fisher.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/merge_fisher.csh,v retrieving revision 1.7 retrieving revision 1.8 diff -r1.7 -r1.8 210c210 < '$1,0.000001,+,0.99999,*,0.0,1.0,inv_cnormal' \ --- > '$1,0.0,1.0,inv_cnormal' \ Index: src/csh/mri_to_ps.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/mri_to_ps.csh,v retrieving revision 1.13 retrieving revision 1.14 diff -r1.13 -r1.14 30c30 < echo '#$Id: mri_to_ps.csh,v 1.13 2003/10/04 22:03:05 bakalj Exp $' --- > echo '#$Id: mri_to_ps.csh,v 1.14 2003/11/04 22:26:52 welling Exp $' 77c77 < set ctblchunk = `mri_printfield -input $1 -field color_table -nofail` --- > set ctblchunk = `mri_printfield -field color_table -nofail $1` Index: src/csh/outlier.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/outlier.csh,v retrieving revision 1.7 diff -r1.7 outlier.csh 31c31 < echo '# $Id: outlier.csh,v 1.7 2002/08/07 00:01:48 welling Exp $' --- > echo '# $Id: outlier.csh,v 1.8 2003/11/26 23:16:50 welling Exp $' 33c33 < outlier -input $1.mri -headerout $2.mri -dataout .dat \ --- > outlier -input $1.mri -headerout $2.mri \ Index: src/csh/parallel.MPI_start.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/parallel.MPI_start.csh,v retrieving revision 1.2 diff -r1.2 parallel.MPI_start.csh 2c2 < # parallel.PVM_start.csh --- > # parallel.MPI_start.csh 29c29 < echo '# $Id: parallel.MPI_start.csh,v 1.2 2003/07/18 22:25:26 welling Exp $' --- > echo '# $Id: parallel.MPI_start.csh,v 1.4 2003/11/26 23:16:50 welling Exp $' 35c35 < # Nothing to do; mpirun takes care of most logistics for us. --- > # Not much to do; mpirun takes care of most logistics for us. 37a38,40 > #---------------------------------------------------------------------------* > # Phase 1: check .rhosts or .ssh set appropriately > #---------------------------------------------------------------------------* 38a42,86 > echo "checking .ssh files set appropriately..." > if ( ! -f ~/.ssh/known_hosts || ! -f ~/.ssh/known_hosts2) then > unset echo > echo > echo "It looks like your account is not set up to use ssh." > echo "The easiest way to do this is just to use the ssh" > echo "command to connect once to each of the hosts in your" > echo "parallel computing cluster." > exit 1 > endif > set rherr=0 > foreach m ($parallel_hosts) > echo "Checking that $m is a known host..." > set status = `test_in_subshell.csh grep $m ~/.ssh/known_hosts` > set status2 = `test_in_subshell.csh grep $m ~/.ssh/known_hosts2` > if ( $status && $status2 ) then > unset echo > echo > echo "You need to use ssh to connect to $m, just once" > echo "so its identity will become known." > exit 1 > endif > end > echo "checking that $HOST is allowed to connect to the remote hosts..." > set ssh_host_auth = 0 > if ( -e ~/.ssh/authorized_keys ) then > if ( ! `test_in_subshell.csh grep $HOST ~/.ssh/authorized_keys` ) then > set ssh_host_auth = 1 > endif > else if ( -e ~/.ssh/authorized_keys2 ) then > if ( ! `test_in_subshell.csh grep $user@$HOST ~/.ssh/authorized_keys2` ) \ > then > set ssh_host_auth = 1 > endif > endif > if ( ! $ssh_host_auth ) then > unset echo > echo > echo "You need to use ssh-keygen to prove your identity" > echo "to the remote hosts. To do this, do the commands:" > echo " ssh-keygen -t dsa" > echo " cd ${HOME}/.ssh" > echo " cat id_dsa.pub >> authorized_keys2" > exit 1 > endif Index: src/csh/parallel.PVM_start.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/parallel.PVM_start.csh,v retrieving revision 1.2 diff -r1.2 parallel.PVM_start.csh 29c29 < echo '# $Id: parallel.PVM_start.csh,v 1.2 2003/07/18 22:25:26 welling Exp $' --- > echo '# $Id: parallel.PVM_start.csh,v 1.4 2003/11/26 23:31:07 welling Exp $' 108c108 < exit --- > exit 1 120c120 < exit --- > exit 1 131c131 < exit --- > exit 1 177c177 < if ( ! -f ~/.ssh/known_hosts || ! -f ~/.ssh/known_hosts2) then --- > if ( ! -f ~/.ssh/known_hosts && ! -f ~/.ssh/known_hosts2) then 246c246 < exit --- > exit 1 Index: src/csh/parallel.run.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/parallel.run.csh,v retrieving revision 1.5 diff -r1.5 parallel.run.csh 29c29 < echo '# $Id: parallel.run.csh,v 1.5 2003/07/18 22:25:26 welling Exp $' --- > echo '# $Id: parallel.run.csh,v 1.7 2003/11/26 23:16:50 welling Exp $' 77,78c77,78 < echo rm ${linkname} < rm ${linkname} --- > echo rm -f ${linkname} > rm -f ${linkname} 127c127 < echo $worker > $tmp --- > echo $worker >> $tmp Index: src/csh/parallel.start.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/parallel.start.csh,v retrieving revision 1.14 diff -r1.14 parallel.start.csh 29c29 < echo '# $Id: parallel.start.csh,v 1.14 2003/07/18 22:25:26 welling Exp $' --- > echo '# $Id: parallel.start.csh,v 1.15 2003/11/25 00:01:41 welling Exp $' 81a82 > if ( $status ) exit $status 83a85 > if ( $status ) exit $status Index: src/csh/phase_lock.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/phase_lock.csh,v retrieving revision 1.8 diff -r1.8 phase_lock.csh 31c31 < echo '#$Id: phase_lock.csh,v 1.8 2003/10/04 22:02:40 bakalj Exp $' --- > echo '#$Id: phase_lock.csh,v 1.9 2003/11/24 21:55:13 welling Exp $' 38,43c38,52 < # Find out some dimensions < set vdim = `mri_printfield -field images.extent.v $1` < set xdim = `mri_printfield -field images.extent.x $1` < set ydim = `mri_printfield -field images.extent.y $1` < set zdim = `mri_printfield -field images.extent.z $1` < set tdim = `mri_printfield -field images.extent.t $1` --- > set imagechunk = "`mri_printfield -fld images -nofail $1 `" > if ( dummy"${imagechunk}" == 'dummy[chunk]' ) then > set mainchunk = 'images' > else > set mainchunk = 'samples' > set sampleschunk = "`mri_printfield -fld samples -nofail $1 `" > if ( dummy"${sampleschunk}" != 'dummy[chunk]' ) then > echo "$0 : input file does not contain images or samples!" > exit -1 > endif > endif > set missingchunk = "`mri_printfield -fld missing -nofail $1`" > if ( dummy"${missingchunk}" == 'dummy[chunk]' ) then > set has_missing = 1 > endif 45,46c54,78 < @ pdim = ( $xdim * $ydim ) < @ pcenter = ( ( $ydim / 2 ) * $xdim + ( $xdim / 2 ) ) --- > # Find out some dimensions > set dimstr = `mri_printfield -field ${mainchunk}.dimensions $1` > set vdim = `mri_printfield -field ${mainchunk}.extent.v $1` > set zdim = `mri_printfield -field ${mainchunk}.extent.z $1` > set tdim = `mri_printfield -field ${mainchunk}.extent.t $1` > > if ( ${mainchunk} == 'images' ) then > if ( ${dimstr} != 'vxyzt' ) then > echo "$0 can only handle images chunk in vxyzt order!" > exit -1 > endif > set xdim = `mri_printfield -field ${mainchunk}.extent.x $1` > set ydim = `mri_printfield -field ${mainchunk}.extent.y $1` > @ pdim = ( $xdim * $ydim ) > set sdim = 1 > set cdim = 1 > else > if ( ${dimstr} != 'vpsczt' ) then > echo "$0 can only handle samples chunk in vpsczt order!" > exit -1 > endif > set pdim = `mri_printfield -field ${mainchunk}.extent.p $1` > set sdim = `mri_printfield -field ${mainchunk}.extent.s $1` > set cdim = `mri_printfield -field ${mainchunk}.extent.c $1` > endif 57a90,124 > # > # Find the sample at the origin. For EPI we assume it's just the > # center sample; for spiral we check the trajectory. > # > if ( ${mainchunk} == 'images' ) then > @ pcenter = ( ( $ydim / 2 ) * $xdim + ( $xdim / 2 ) ) > else > mri_copy_chunk -chunk sample_kxloc -chunk_out images $1 $tmpdir/kxloc > mri_copy_chunk -chunk sample_kyloc -chunk_out images $1 $tmpdir/kyloc > > set dz = 0 > while ( $dz < $zdim ) > set dc = 0 > while ( $dc < $cdim ) > set ds = 0 > while ( $ds < $sdim ) > set whichp = `mri_rpn_math -out $tmpdir/junk '0,$p,$s,'$ds',==,$c,'$dc',==,*,$z,'$dz',==,*,$1,0,==,*,$2,0,==,*,if_print_1' $tmpdir/kxloc $tmpdir/kyloc | tail -1 ` > if ( ${?origin_sample} ) then > if ( $origin_sample != $whichp ) then > echo "##ERROR##: k-space sample locations which vary by " \ > "slice, coil, or shot are not supported." > exit -1 > endif > else > set pcenter = $whichp > endif > @ ds = $ds + 1 > end > @ dc = $dc + 1 > end > @ dz = $dz + 1 > end > echo "origin sample is " $pcenter > endif > 59,62c126,141 < mri_permute -order vztxy $1 $tmpdir/in_p < mri_remap -order vztp -length 2:${zdim}:${tdim}:${pdim} $tmpdir/in_p < mri_complex_to_scalar -mag $tmpdir/in_p $tmpdir/raw_mags < mri_complex_to_scalar -phu $tmpdir/in_p $tmpdir/raw_phases --- > if ( ${mainchunk} == 'images' ) then > mri_permute -order vztxy $1 $tmpdir/in_p > mri_remap -order vztpsc -length 2:${zdim}:${tdim}:${pdim}:${sdim}:${cdim} \ > $tmpdir/in_p > else > mri_permute -chunk samples -order vztpsc $1 $tmpdir/in_p > endif > mri_complex_to_scalar -chunk ${mainchunk} -mag $tmpdir/in_p $tmpdir/raw_mags > mri_complex_to_scalar -chunk ${mainchunk} -phu $tmpdir/in_p $tmpdir/raw_phases > foreach dset ( $tmpdir/raw_mags $tmpdir/raw_phases ) > if ( $has_missing ) mri_delete_chunk -chunk missing $dset > if ( $mainchunk == 'samples' ) then > mri_delete_chunk -chunk sample_kxloc $dset > mri_delete_chunk -chunk sample_kyloc $dset > endif > end 68c147 < mri_rpn_math -out $tmpdir/product '$1,$2,*' \ --- > mri_rpn_math -out $tmpdir/product -chunk ${mainchunk} '$1,$2,*' \ 70,74c149,157 < mri_permute -order vpzt $tmpdir/product $tmpdir/product_p < mri_permute -order vpzt $tmpdir/raw_mags $tmpdir/raw_mags_p < mri_subsample -d p -l 1 -sum $tmpdir/product_p $tmpdir/prod_sum < mri_subsample -d p -l 1 -sum $tmpdir/raw_mags_p $tmpdir/mag_sum < mri_rpn_math -out $tmpdir/rephase_raw '$1,$2,/' \ --- > mri_permute -chunk ${mainchunk} -order vpsczt \ > $tmpdir/product $tmpdir/product_p > mri_permute -chunk ${mainchunk} -order vpsczt \ > $tmpdir/raw_mags $tmpdir/raw_mags_p > mri_subsample -d p -l 1 -sum \ > $tmpdir/product_p $tmpdir/prod_sum > mri_subsample -d p -l 1 -sum \ > $tmpdir/raw_mags_p $tmpdir/mag_sum > mri_rpn_math -chunk ${mainchunk} -out $tmpdir/rephase_raw '$1,$2,/' \ 76c159 < mri_remap -order vztp $tmpdir/rephase_raw --- > mri_remap -chunk ${mainchunk} -order vztpsc $tmpdir/rephase_raw 79c162,163 < mri_subset -d p -l 1 -s $pcenter $tmpdir/raw_phases $tmpdir/rephase_raw --- > mri_subset -d p -l 1 -s $pcenter \ > $tmpdir/raw_phases $tmpdir/rephase_raw 91c175 < mri_rpn_math -out $tmpdir/result_p_r '$1,$2,$3,-,cos,*' \ --- > mri_rpn_math -out $tmpdir/result_p_r -chunk ${mainchunk} '$1,$2,$3,-,cos,*' \ 93c177 < mri_rpn_math -out $tmpdir/result_p_i '$1,$2,$3,-,sin,*' \ --- > mri_rpn_math -out $tmpdir/result_p_i -chunk ${mainchunk} '$1,$2,$3,-,sin,*' \ 97,98c181,182 < mri_remap -order ztpv $tmpdir/result_p_r < mri_remap -order ztpv $tmpdir/result_p_i --- > mri_remap -order ztpscv -chunk ${mainchunk} $tmpdir/result_p_r > mri_remap -order ztpscv -chunk ${mainchunk} $tmpdir/result_p_i 103c187,188 < mri_permute -order vztp $tmpdir/result_p_p $tmpdir/result_p --- > mri_permute -order vztpsc -chunk ${mainchunk} \ > $tmpdir/result_p_p $tmpdir/result_p 105,106c190,201 < mri_permute -order vpzt $tmpdir/result_p $2 < mri_remap -order vxyzt -length 2:${xdim}:${ydim}:${zdim}:${tdim} $2 --- > mri_permute -order vpsczt -chunk ${mainchunk} $tmpdir/result_p $tmpdir/result > mri_destroy_dataset $tmpdir/result_p > mri_copy_dataset $1 $2 > mri_delete_chunk -chunk $mainchunk $2 > mri_copy_chunk -chunk $mainchunk $tmpdir/result $2 > mri_destroy_dataset $tmpdir/result > if ( ${mainchunk} == 'images' ) then > mri_remap -order vxyzt -length 2:${xdim}:${ydim}:${zdim}:${tdim} $2 > else > mri_remap -chunk samples -order vpsczt \ > -length 2:${pdim}:${sdim}:${cdim}:${zdim}:${tdim} $2 > endif 113c208 < mri_rpn_math -out $tmpdir/junk '0,$t,$z,$1,1,if_print_3' \ --- > mri_rpn_math -out $tmpdir/junk -chunk $mainchunk '0,$t,$z,$1,1,if_print_3' \ 118c213 < mri_rpn_math -out $tmpdir/junk '0,$t,$z,$1,1,if_print_3' \ --- > mri_rpn_math -out $tmpdir/junk -chunk $mainchunk '0,$t,$z,$1,1,if_print_3' \ Index: src/csh/physio_correct_triggered.py =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/physio_correct_triggered.py,v retrieving revision 1.9 retrieving revision 1.10 diff -r1.9 -r1.10 39c39 < idString= "$Id: physio_correct_triggered.py,v 1.9 2003/09/16 22:55:43 welling Exp $" --- > idString= "$Id: physio_correct_triggered.py,v 1.10 2003/10/14 20:30:30 bakalj Exp $" 258,260d257 < if (timesFound writeListToCmdInput(cleanSamples,"mri_from_ascii -order t -len %d %s"%(len(cleanSamples),cleanSyncThreshDS)) 278c275 < writeListToCmdInput(time,"mri_from_ascii -order t -len %d -o %s"%(len(cleanSamples),timeDS)) --- > writeListToCmdInput(time,"mri_from_ascii -order t -len %d %s"%(len(cleanSamples),timeDS)) 284c281 < safeRun("mri_rpn_math -out %s/junk '0,$1,$2,if_print_1' %s %s | mri_from_ascii -order t -len %d -o %s/%s"%(tmpdir,thisDS,cleanSyncThreshDS,zdim*tdim,tmpdir,os.path.basename(thisDS))) --- > safeRun("mri_rpn_math -out %s/junk '0,$1,$2,if_print_1' %s %s | mri_from_ascii -order t -len %d %s/%s"%(tmpdir,thisDS,cleanSyncThreshDS,zdim*tdim,tmpdir,os.path.basename(thisDS))) Index: src/csh/spiral.proc.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/spiral.proc.csh,v retrieving revision 1.6 diff -r1.6 spiral.proc.csh 30c30 < # $Id: spiral.proc.csh,v 1.6 1999/07/07 23:32:50 welling Exp $ --- > # $Id: spiral.proc.csh,v 1.7 2003/11/26 23:16:50 welling Exp $ 44c44 < if($F_PARALLEL) source $FIASCO/parallel.start.csh --- > if ($F_PARALLEL) source $FIASCO/parallel.start.csh Index: src/fmri/filetypes.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/fmri/filetypes.c,v retrieving revision 1.3 retrieving revision 1.4 diff -r1.3 -r1.4 61c61 < static char rcsid[] = "$Id: filetypes.c,v 1.3 2002/07/22 20:57:28 welling Exp $"; --- > static char rcsid[] = "$Id: filetypes.c,v 1.4 2003/11/04 22:25:36 welling Exp $"; 120a121,124 > FRZ_RDBHEAD_RDB_HDR_LOGO_SIZE))) > logotype = FILE_LX; > else if (!(strncmp((char*)header+FRZ_RDBHEAD_RDB_HDR_LOGO_OFF, > FRZ_RDBHEAD_RDB_INVALID_LOGO, Index: src/fmri/frozen_header_info_cnv4.h =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/fmri/frozen_header_info_cnv4.h,v retrieving revision 1.2 retrieving revision 1.3 diff -r1.2 -r1.3 70a71 > #define FRZ_RDBHEAD_RDB_INVALID_LOGO "INVALIDNMR" Index: src/fmri/frozen_header_info_lx2.h =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/fmri/frozen_header_info_lx2.h,v retrieving revision 1.2 retrieving revision 1.3 diff -r1.2 -r1.3 70a71 > #define FRZ_RDBHEAD_RDB_INVALID_LOGO "INVALIDNMR" Index: src/fmri/frozen_header_info_prelx.h =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/fmri/frozen_header_info_prelx.h,v retrieving revision 1.3 retrieving revision 1.4 diff -r1.3 -r1.4 71a72 > #define FRZ_RDBHEAD_RDB_INVALID_LOGO "INVALIDNMR" Index: src/mri_util/Makefile =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/Makefile,v retrieving revision 1.32 retrieving revision 1.33 diff -r1.32 -r1.33 23c23 < PKG_LIBS = -lcdf -lfmri -lmri -lpar -lbio -lacct \ --- > PKG_LIBS = -ldcdf -lfmri -lmri -lpar -lbio -lacct \ Index: src/mri_util/mri_copy_dataset.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/mri_copy_dataset.c,v retrieving revision 1.2 retrieving revision 1.3 diff -r1.2 -r1.3 33c33 < static char rcsid[] = "$Id: mri_copy_dataset.c,v 1.2 2003/08/07 19:49:31 bakalj Exp $"; --- > static char rcsid[] = "$Id: mri_copy_dataset.c,v 1.3 2003/10/29 22:42:57 welling Exp $"; 79c79 < Abort( "Input and output files must be distinct." ); --- > Abort( "Input and output files must be distinct!\n" ); Index: src/mri_util/mri_fft_help.help =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/mri_fft_help.help,v retrieving revision 1.7 retrieving revision 1.8 diff -r1.7 -r1.8 13c13,15 < mri_fft [-d dim] [-v] [-f | -i] [-c | -m | -p | -s] infile outfile --- > > mri_fft [-d dim] [-v] [-fwd | -inv] > [-cpx | -mod | -pha | -sqr] infile outfile Index: src/mri_util/mri_matmult.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/mri_matmult.c,v retrieving revision 1.14 retrieving revision 1.15 diff -r1.14 -r1.15 50c50 < static char rcsid[] = "$Id: mri_matmult.c,v 1.14 2003/08/07 20:36:03 bakalj Exp $"; --- > static char rcsid[] = "$Id: mri_matmult.c,v 1.15 2003/10/29 22:43:12 welling Exp $"; 56c56 < #define MAYBE_MAKE_HASHMARK( i, n ) if (verbose_flg) makeHashMark(i,n) --- > #define MAYBE_MAKE_HASHMARK( n ) if (verbose_flg) makeHashMark(n) 58c58 < static void makeHashMark( long i, long n ) --- > static void makeHashMark( long n ) 59a60 > static long i= 0; 66c67 < --- > i++; 113c114 < static char* safe_get_dims(MRI_Dataset* ds, const char* chunk) --- > static const char* safe_get_dims(MRI_Dataset* ds, const char* chunk) 150c151,155 < long right_slow_blksize, long summed_extent) --- > long right_slow_blksize, long summed_extent, > long long left_foreach_offset, > long long right_foreach_offset, > long long out_foreach_offset, > long long foreach_blksize) 173c178 < 0, MRI_DOUBLE); --- > right_foreach_offset, MRI_DOUBLE); 182c187,188 < left_base_offset= left_sum_offset= right_offset= out_offset= 0; --- > left_base_offset= left_foreach_offset; > out_offset= out_foreach_offset; 184c190 < right_offset= 0; --- > right_offset= right_foreach_offset; 212,213c218,219 < mri_set_chunk(Out, chunk, left_fast_blksize, out_offset, < MRI_DOUBLE, accum_fast_buf); --- > mri_set_chunk(Out, chunk, left_fast_blksize, > out_offset, MRI_DOUBLE, accum_fast_buf); 217c223 < MAYBE_MAKE_HASHMARK( left_slow, left_slow_blksize ); --- > MAYBE_MAKE_HASHMARK( left_slow_blksize*foreach_blksize ); 229c235,240 < long summed_extent) --- > long summed_extent, > long long left_foreach_offset, > long long right_foreach_offset, > long long out_foreach_offset, > long long foreach_blksize) > 252c263 < 0, MRI_DOUBLE); --- > right_foreach_offset, MRI_DOUBLE); 261c272,273 < left_base_offset= left_sum_offset= right_offset= out_offset= 0; --- > left_base_offset= left_foreach_offset; > out_offset= out_foreach_offset; 263c275 < right_offset= 0; --- > right_offset= right_foreach_offset; 301c313 < MAYBE_MAKE_HASHMARK( left_slow, left_slow_blksize ); --- > MAYBE_MAKE_HASHMARK( left_slow_blksize*foreach_blksize ); 311c323,327 < long right_slow_blksize, long summed_extent) --- > long right_slow_blksize, long summed_extent, > long long left_foreach_offset, > long long right_foreach_offset, > long long out_foreach_offset, > long long foreach_blksize) 333c349 < 0, MRI_DOUBLE); --- > right_foreach_offset, MRI_DOUBLE); 343c359,360 < left_base_offset= right_offset= out_offset= 0; --- > left_base_offset= left_foreach_offset; > out_offset= out_foreach_offset; 351c368 < right_offset= 0; --- > right_offset= right_foreach_offset; 376c393 < MAYBE_MAKE_HASHMARK( left_slow, left_slow_blksize ); --- > MAYBE_MAKE_HASHMARK( left_slow_blksize*foreach_blksize ); 388c405,409 < long summed_extent) --- > long summed_extent, > long long left_foreach_offset, > long long right_foreach_offset, > long long out_foreach_offset, > long long foreach_blksize) 410c431 < 0, MRI_DOUBLE); --- > right_foreach_offset, MRI_DOUBLE); 420c441,442 < left_base_offset= right_offset= out_offset= 0; --- > left_base_offset= left_foreach_offset; > out_offset= out_foreach_offset; 428c450 < right_offset= 0; --- > right_offset= right_foreach_offset; 458c480 < MAYBE_MAKE_HASHMARK( left_slow, left_slow_blksize ); --- > MAYBE_MAKE_HASHMARK( left_slow_blksize*foreach_blksize ); 470c492,496 < long summed_extent) --- > long summed_extent, > long long left_foreach_offset, > long long right_foreach_offset, > long long out_foreach_offset, > long long foreach_blksize) 493c519 < --- > 499c525 < 0, MRI_DOUBLE); --- > right_foreach_offset, MRI_DOUBLE); 510c536,537 < left_base_offset= out_offset= 0; --- > left_base_offset= left_foreach_offset; > out_offset= out_foreach_offset; 518c545 < right_offset= 0; --- > right_offset= right_foreach_offset; 546,547c573,574 < fprintf(stderr,"Writing block %d to %d (size %d)\n", < left_slow,(int)out_offset, --- > fprintf(stderr,"Writing block %ld to %lld (size %ld)\n", > left_slow,out_offset, 553c580 < MAYBE_MAKE_HASHMARK( left_slow, left_slow_blksize ); --- > MAYBE_MAKE_HASHMARK( left_slow_blksize*foreach_blksize ); 566c593,597 < long summed_extent) --- > long summed_extent, > long long left_foreach_offset, > long long right_foreach_offset, > long long out_foreach_offset, > long long foreach_blksize) 596c627 < 0, MRI_DOUBLE); --- > right_foreach_offset, MRI_DOUBLE); 607c638,639 < left_base_offset= out_offset= 0; --- > left_base_offset= left_foreach_offset; > out_offset= out_foreach_offset; 615c647 < right_offset= 0; --- > right_offset= right_foreach_offset; 643,644c675,676 < fprintf(stderr,"Writing block %d to %d (size %d)\n", < left_slow,(int)out_offset, --- > fprintf(stderr,"Writing block %ld to %lld (size %ld)\n", > left_slow,out_offset, 650c682 < MAYBE_MAKE_HASHMARK( left_slow, left_slow_blksize ); --- > MAYBE_MAKE_HASHMARK( left_slow_blksize*foreach_blksize ); 658c690,691 < MRI_Dataset* Out, char* chunk, const int summed_dim) --- > MRI_Dataset* Out, char* chunk, const int summed_dim, > const char* foreach_dims) 660,661c693,696 < char* dimstr1= safe_get_dims(Left,chunk); < char* dimstr2= safe_get_dims(Right,chunk); --- > char* dimstr1_orig= strdup(safe_get_dims(Left,chunk)); > char* dimstr1= dimstr1_orig; > char* dimstr2_orig= strdup(safe_get_dims(Right,chunk)); > char* dimstr2= dimstr2_orig; 666a702,706 > long long foreach_blksize= 1; > long long left_foreach_offset= 0; > long long right_foreach_offset= 0; > long long out_foreach_offset= 0; > long long foreach_loop; 667a708,716 > if (*foreach_dims) { > char* here= strstr(dimstr1,foreach_dims); > *here= '\0'; > here= strstr(dimstr2,foreach_dims); > *here= '\0'; > here= (char*)foreach_dims; > while (*here) foreach_blksize *= safe_get_extent(Left, chunk, *here++); > } > 674c723 < fprintf(stderr,"Left string %s, block sizes: %d %d %d\n", --- > fprintf(stderr,"Left string %s, block sizes: %ld %ld %ld\n", 676c725 < fprintf(stderr,"Right string %s, block sizes: %d %d %d\n", --- > fprintf(stderr,"Right string %s, block sizes: %ld %ld %ld\n", 677a727,728 > fprintf(stderr,"Foreach string <%s>, block size %lld\n", > foreach_dims, foreach_blksize ); 683c734 < Message("Counting out %d blocks:\n",left_slow_blksize); --- > Message("Counting out %lld blocks:\n",left_slow_blksize*foreach_blksize); 685,689c736,751 < if (left_fast_blksize*summed_extent <= MAX_AT_ONCE) { < if (left_fast_blksize*right_slow_blksize <= MAX_AT_ONCE) { < mult_leftsmall_accumsmall(Left, Right, Out, chunk, < left_fast_blksize, left_slow_blksize, < right_slow_blksize, summed_extent); --- > for (foreach_loop=0; foreach_loop if (left_fast_blksize*summed_extent <= MAX_AT_ONCE) { > if (left_fast_blksize*right_slow_blksize <= MAX_AT_ONCE) { > mult_leftsmall_accumsmall(Left, Right, Out, chunk, > left_fast_blksize, left_slow_blksize, > right_slow_blksize, summed_extent, > left_foreach_offset, right_foreach_offset, > out_foreach_offset, foreach_blksize); > } > else { > mult_leftsmall(Left, Right, Out, chunk, > left_fast_blksize, left_slow_blksize, > right_slow_blksize, summed_extent, > left_foreach_offset, right_foreach_offset, > out_foreach_offset, foreach_blksize); > } 692,694c754,758 < mult_leftsmall(Left, Right, Out, chunk, < left_fast_blksize, left_slow_blksize, < right_slow_blksize, summed_extent); --- > mult_general(Left, Right, Out, chunk, > left_fast_blksize, left_slow_blksize, > right_slow_blksize, summed_extent, > left_foreach_offset, right_foreach_offset, > out_foreach_offset, foreach_blksize); 695a760,765 > left_foreach_offset += > left_fast_blksize*summed_extent*left_slow_blksize; > right_foreach_offset += > right_fast_blksize*summed_extent*right_slow_blksize; > out_foreach_offset += > left_fast_blksize*right_slow_blksize*left_slow_blksize; 697,701c767,769 < else { < mult_general(Left, Right, Out, chunk, < left_fast_blksize, left_slow_blksize, < right_slow_blksize, summed_extent); < } --- > > free(dimstr1_orig); > free(dimstr2_orig); 706c774 < const int summed_dim) --- > const int summed_dim, const char* foreach_dims) 708,709c776,779 < char* dimstr1= safe_get_dims(Left,chunk); < char* dimstr2= safe_get_dims(Right,chunk); --- > char* dimstr1_orig= strdup(safe_get_dims(Left,chunk)); > char* dimstr1= dimstr1_orig; > char* dimstr2_orig= strdup(safe_get_dims(Right,chunk)); > char* dimstr2= dimstr2_orig; 714a785,798 > long long foreach_blksize= 1; > long long left_foreach_offset= 0; > long long right_foreach_offset= 0; > long long out_foreach_offset= 0; > long long foreach_loop; > > if (*foreach_dims) { > char* here= strstr(dimstr1,foreach_dims); > *here= '\0'; > here= strstr(dimstr2,foreach_dims); > *here= '\0'; > here= (char*)foreach_dims; > while (*here) foreach_blksize *= safe_get_extent(Left, chunk, *here++); > } 722c806 < fprintf(stderr,"Left string %s, block sizes: %d %d %d\n", --- > fprintf(stderr,"Left string %s, block sizes: %ld %ld %ld\n", 724c808 < fprintf(stderr,"Right string %s, block sizes: %d %d %d\n", --- > fprintf(stderr,"Right string %s, block sizes: %ld %ld %ld\n", 725a810,811 > fprintf(stderr,"Foreach string %s, block size %lld\n", > foreach_dims,foreach_blksize ); 731c817 < Message("Counting out %d blocks:\n",left_slow_blksize); --- > Message("Counting out %d blocks:\n",left_slow_blksize*foreach_blksize); 733,737c819,837 < if (left_fast_blksize*summed_extent <= MAX_AT_ONCE) { < if (left_fast_blksize*right_slow_blksize <= MAX_AT_ONCE) { < mult_leftsmall_accumsmall_complex(Left, Right, Out, chunk, < left_fast_blksize, left_slow_blksize, < right_slow_blksize, summed_extent); --- > for (foreach_loop=0; foreach_loop if (left_fast_blksize*summed_extent <= MAX_AT_ONCE) { > if (left_fast_blksize*right_slow_blksize <= MAX_AT_ONCE) { > mult_leftsmall_accumsmall_complex(Left, Right, Out, chunk, > left_fast_blksize, left_slow_blksize, > right_slow_blksize, summed_extent, > left_foreach_offset, > right_foreach_offset, > out_foreach_offset, > foreach_blksize); > > } > else { > mult_leftsmall_complex(Left, Right, Out, chunk, > left_fast_blksize, left_slow_blksize, > right_slow_blksize, summed_extent, > left_foreach_offset, right_foreach_offset, > out_foreach_offset, foreach_blksize); > } 740,742c840,844 < mult_leftsmall_complex(Left, Right, Out, chunk, < left_fast_blksize, left_slow_blksize, < right_slow_blksize, summed_extent); --- > mult_general_complex(Left, Right, Out, chunk, > left_fast_blksize, left_slow_blksize, > right_slow_blksize, summed_extent, > left_foreach_offset, right_foreach_offset, > out_foreach_offset, foreach_blksize); 743a846,851 > left_foreach_offset += > left_fast_blksize*summed_extent*left_slow_blksize; > right_foreach_offset += > right_fast_blksize*summed_extent*right_slow_blksize; > out_foreach_offset += > left_fast_blksize*right_slow_blksize*left_slow_blksize; 745,749c853,855 < else { < mult_general_complex(Left, Right, Out, chunk, < left_fast_blksize, left_slow_blksize, < right_slow_blksize, summed_extent); < } --- > > free(dimstr1_orig); > free(dimstr2_orig); 758c864,865 < const char* chunk, int complex ) --- > const char* chunk, const int complex, > int* summed_dim_ptr, char** foreach_dims_ptr) 760,761c867,870 < char* dimstr1= safe_get_dims(Left,chunk); < char* dimstr2= safe_get_dims(Right,chunk); --- > char* dimstr1_orig= strdup(safe_get_dims(Left,chunk)); > char* dimstr1= dimstr1_orig; > char* dimstr2_orig= strdup(safe_get_dims(Right,chunk)); > char* dimstr2= dimstr2_orig; 764a874 > char* foreach_dims; 780c890,904 < /* There must be exactly one dimension in common */ --- > /* Find any looped-over dimensions and clip them from the dim strings */ > here= dimstr1 + strlen(dimstr1) - 1; > there= dimstr2 + strlen(dimstr2) - 1; > while (*here==*there && here>dimstr1 && there>dimstr2) { > if (safe_get_extent(Left,chunk,*here) > != safe_get_extent(Right,chunk,*here)) > Abort("%s: extents of looped-over dimension %c do not match!\n", > progname, *here); > here--; > there--; > } > foreach_dims= strdup(here+1); > *(here+1)= *(there+1)= '\0'; > > /* In remaining dim string, there must be exactly one dimension in common */ 800c924,928 < return summed_dim; --- > *summed_dim_ptr= summed_dim; > *foreach_dims_ptr= foreach_dims; > free(dimstr1_orig); > free(dimstr2_orig); > return 1; 805c933 < int complex ) --- > const int complex, const char* foreach_dims ) 814,815c942,945 < char* dimstr1= safe_get_dims(Factor1,chunk); < char* dimstr2= safe_get_dims(Factor2,chunk); --- > char* dimstr1_orig= strdup(safe_get_dims(Factor1,chunk)); > char* dimstr1= dimstr1_orig; > char* dimstr2_orig= strdup(safe_get_dims(Factor2,chunk)); > char* dimstr2= dimstr2_orig; 818c948,949 < char* here; --- > char* here= NULL; > char* there= NULL; 827a959,967 > if (foreach_dims[0]) { > there= strstr(dimstr1+1,foreach_dims); > *there= '\0'; > there= strstr(dimstr2+1,foreach_dims); > *there= '\0'; > } > /* here now points to the live part of dimstr2, excluding the summed dim, > * the foreach dims if any, and the v dim if any. > */ 831,832c971,972 < Message("Multiplying complex input chunk <%s>, dims v%s and v%s.\n", < chunk,dimstr1,dimstr2); --- > Message("Multiplying complex input chunk <%s>, dims v%s%s and v%s%s.\n", > chunk,dimstr1,foreach_dims,dimstr2,foreach_dims); 835,836c975,976 < Message("Multiplying input chunk <%s>, dims %s and %s.\n", < chunk,dimstr1,dimstr2); --- > Message("Multiplying input chunk <%s>, dims %s%s and %s%s.\n", > chunk,dimstr1,foreach_dims,dimstr2,foreach_dims); 838c978,979 < Message("Summing over dimension %c\n",summed_dim); --- > Message("Summing over dimension %c, looping over dimensions <%s>\n", > summed_dim, foreach_dims); 843c984 < here++; /* now points to left slow dimensions */ --- > here++; /* now points to left slow dimensions + foreach dims */ 870a1012,1013 > free(dimstr1_orig); > free(dimstr2_orig); 876a1020 > char* foreach_dims= NULL; 945,946c1089,1091 < summed_dim= structure_check(Factor1, Factor2, chunk, complex_flg); < if (summed_dim == '\0') --- > if (!structure_check(Factor1, Factor2, chunk, complex_flg, &summed_dim, > &foreach_dims) > || summed_dim=='\0' || foreach_dims==NULL) 959c1104,1105 < restructure_dims( Output, chunk, Factor1, Factor2, complex_flg ); --- > restructure_dims( Output, chunk, Factor1, Factor2, complex_flg, > foreach_dims ); 963c1109,1110 < mult_chunk_complex(Factor1, Factor2, Output, chunk, summed_dim); --- > mult_chunk_complex(Factor1, Factor2, Output, chunk, summed_dim, > foreach_dims); 965c1112 < mult_chunk(Factor1, Factor2, Output, chunk, summed_dim); --- > mult_chunk(Factor1, Factor2, Output, chunk, summed_dim, foreach_dims); Index: src/mri_util/mri_matmult_help.help =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/mri_matmult_help.help,v retrieving revision 1.6 retrieving revision 1.7 diff -r1.6 -r1.7 72a73,107 > Suppose that dataset file1 contains complex data as follows: > > images.datatype = float32 > images.dimensions = vxqtsc > images.extent.c = 4 > images.extent.s = 7 > images.extent.v = 2 > images.extent.t = 10 > images.extent.q = 2 > images.extent.x = 5 > > > and that dataset file2 contains complex data as follows: > > images.dimensions = vqyzsc > images.extent.c = 4 > images.extent.s = 7 > images.extent.v = 2 > images.extent.q = 2 > images.extent.y = 5 > images.extent.z = 10 > > It would be an error to multiply these datasets without the -complex > flag set. With the -complex flag set, the output dataset will have > the following dimensions and extents: > > images.dimensions = vxyztsc > images.extent.c = 4 > images.extent.s = 7 > images.extent.v = 2 > images.extent.t = 10 > images.extent.x = 5 > images.extent.y = 5 > images.extent.z = 10 > 91,92c126,127 < File1 must have one dimension in common with File2 in the normal < case, or two such dimensions (v and some other) in the complex case. --- > See the Details or Examples sections for dimension order > requirements for this input file. 102,105c137,138 < File2 must have one dimension in common with File1 in the normal < case, or two such dimensions (v and some other) in the complex case. < That dimension must be the leftmost dimension in the normal case, < or the leftmost after v in the complex case. --- > See the Details or Examples sections for dimension order > requirements for this input file. 142,157c175,216 < The selected chunks of File1 and File2 must have exactly one < dimension in common (other than v in the complex case), and that < dimension must be the leftmost (fastest varying) dimension in < that chunk in File2. The extent of that dimension must be the < same in both chunks. < < Suppose that dimension name is 'x'. Suppose further that the < dimensions of the selected chunk in File1 are "axb" and those of < File2 are "xc", where 'a', 'b', and 'c' are arbitrary strings < with no common characters. In this situation, the dimensions of < the output chunk will be "acb", with all dimensions having the < same extents as they do in the original files. Call the specific < voxel values in File1 and File2 R(a,x,b) and S(x,c) respectively. < Each voxel P(abc) of the output dataset will have the value: < < P(a,c,b) = sum( R(a,X,b)S(X,c) ) --- > Let the selected chunk of File1 be called _L_ (for left), and > let the selected chunk of File2 be called _R_ . _L_ and _R_ > are matrices, each with dimensions in a specific order and of > specific extents. To be multiplied, _L_ and _R_ must have > dimension orders of the forms XQYS and QZS respectively. (This > is for the scalar case; we'll return to the complex case > momentarily). X, Y, Z, and S are character strings with no common > characters; Q is any single character not in X, Y, Z, or S. The > extents of the dimensions in S and Q must be the same in _L_ and _R_. > > If the chunks match this pattern, they can be multiplied. The > result will be a matrix _P_ with the dimension string XZYS with > values calculated as follows: > > for each s in S { > for each x in X { > for each y in Y { > for each z in Z { > total= 0 > for each q in Q { > total= total+ _L_[xqys] * _R_[qzs] > } > _P_[xzys]= total > } > } > } > } > > In other words, there is a separate matrix multiplaction over q for > every s in S. > > For example, suppose the dimensions of the selected chunk in File1 > are abxytw and those in File2 are xztw. Then X corresponds to ab, > Q to x, Y to y, Z to z, and S to tw. These two chunks can be > multiplied to produce a chunk with dimensions abzytw. However, if > the dimensions of File2 were xzwt there would be no consistent > pattern for S and the chunks could not be multiplied. > > In the complex case, the first dimensions of both _L_ and _R_ > must be v, and that dimension must have an extent of 2. This > dimension is interpreted as the real and imaginary part of a chunk > of complex numbers. 159,161c218 < for all X in the extent of x. < < All the math is carried out in double precision, with conversion to --- > All of the math is carried out in double precision, with conversion to 163,164d219 < < In the complex case simply treat P(), R(), and S() as complex. Index: src/mri_util/mri_rpn_math.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/mri_rpn_math.c,v retrieving revision 1.39 retrieving revision 1.40 diff -r1.39 -r1.40 60c60 < #include "cdflib.h" --- > #include "dcdflib.h" 71c71 < static char rcsid[] = "$Id: mri_rpn_math.c,v 1.39 2003/09/25 19:45:42 welling Exp $"; --- > static char rcsid[] = "$Id: mri_rpn_math.c,v 1.40 2003/10/07 23:25:10 welling Exp $"; 981,982c981,982 < long one= 1; < long status; --- > int one= 1; > int status; 984a985 > double qval; 990c991 < cdf_t(&one, &val, stack_top+i, stack_top+CHUNKSIZE+i, --- > cdf_t(&one, &val, &qval, stack_top+i, stack_top+CHUNKSIZE+i, 1002,1003c1003,1004 < long two= 2; < long status; --- > int two= 2; > int status; 1005a1007 > double qval; 1011c1013,1014 < cdf_t(&two, stack_top+i, &val, stack_top+CHUNKSIZE+i, --- > qval= 1.0- *(stack_top+i); > cdf_t(&two, stack_top+i, &qval, &val, stack_top+CHUNKSIZE+i, 1024,1025c1027,1028 < long one= 1; < long status; --- > int one= 1; > int status; 1027a1031 > double qval; 1033c1037 < cdf_poi( &one, &val, stack_top+i, stack_top+CHUNKSIZE+i, --- > cdf_poi( &one, &val, &qval, stack_top+i, stack_top+CHUNKSIZE+i, 1045,1046c1049,1050 < long two= 2; < long status; --- > int two= 2; > int status; 1048a1053 > double qval; 1054c1059,1060 < cdf_poi(&two, stack_top+i, &val, stack_top+CHUNKSIZE+i, --- > qval= 1.0- *(stack_top+i); > cdf_poi(&two, stack_top+i, &qval, &val, stack_top+CHUNKSIZE+i, 1067,1068c1073,1074 < long one= 1; < long status; --- > int one= 1; > int status; 1070a1077 > double qval; 1076c1083 < cdf_f(&one, &val, stack_top+i, stack_top+CHUNKSIZE+i, --- > cdf_f(&one, &val, &qval, stack_top+i, stack_top+CHUNKSIZE+i, 1089,1090c1096,1097 < long two= 2; < long status; --- > int two= 2; > int status; 1092a1100 > double qval; 1098c1106,1107 < cdf_f(&two, stack_top+i, &val, stack_top+CHUNKSIZE+i, --- > qval= 1.0- *(stack_top+i); > cdf_f(&two, stack_top+i, &qval, &val, stack_top+CHUNKSIZE+i, 1112,1113c1121,1122 < long one= 1; < long status; --- > int one= 1; > int status; 1115a1125 > double qval; 1121c1131 < cdf_chi(&one, &val, stack_top+i, stack_top+CHUNKSIZE+i, --- > cdf_chi(&one, &val, &qval, stack_top+i, stack_top+CHUNKSIZE+i, 1133,1134c1143,1144 < long two= 2; < long status; --- > int two= 2; > int status; 1136a1147 > double qval; 1142c1153,1154 < cdf_chi(&two, stack_top+i, &val, stack_top+CHUNKSIZE+i, --- > qval= 1.0- *(stack_top+i); > cdf_chi(&two, stack_top+i, &qval, &val, stack_top+CHUNKSIZE+i, 1155,1156c1167,1168 < long one= 1; < long status; --- > int one= 1; > int status; 1158a1171,1172 > double qval; > double b; 1164c1178,1179 < cdf_bet(&one, &val, stack_top+i, stack_top+CHUNKSIZE+i, --- > b= 1.0- *(stack_top+i); > cdf_bet(&one, &val, &qval, stack_top+i, &b, stack_top+CHUNKSIZE+i, 1177,1178c1192,1193 < long two= 2; < long status; --- > int two= 2; > int status; 1180a1196,1197 > double qval; > double b; 1186c1203,1204 < cdf_bet(&two, stack_top+i, &val, stack_top+CHUNKSIZE+i, --- > qval= 1.0- *(stack_top+i); > cdf_bet(&two, stack_top+i, &qval, &val, &b, stack_top+CHUNKSIZE+i, 1200,1201c1218,1219 < long one= 1; < long status; --- > int one= 1; > int status; 1203a1222,1223 > double qval; > double ompr; 1209,1210c1229,1231 < cdf_bin(&one, &val, stack_top+i, stack_top+CHUNKSIZE+i, < stack_top+(2*CHUNKSIZE)+i, &status, &bound); --- > ompr= 1.0- *(stack_top+(2*CHUNKSIZE)+i); > cdf_bin(&one, &val, &qval, stack_top+i, stack_top+CHUNKSIZE+i, > stack_top+(2*CHUNKSIZE)+i, &ompr, &status, &bound); 1222,1223c1243,1244 < long two= 2; < long status; --- > int two= 2; > int status; 1225a1247,1248 > double qval; > double ompr; 1231,1232c1254,1257 < cdf_bin(&two, stack_top+i, &val, stack_top+CHUNKSIZE+i, < stack_top+(2*CHUNKSIZE)+i, &status, &bound); --- > qval= 1.0- *(stack_top+i); > ompr= 1.0- *(stack_top+(2*CHUNKSIZE)+i); > cdf_bin(&two, stack_top+i, &qval, &val, stack_top+CHUNKSIZE+i, > stack_top+(2*CHUNKSIZE)+i, &ompr, &status, &bound); 1245,1246c1270,1271 < long one= 1; < long status; --- > int one= 1; > int status; 1248a1274 > double qval; 1254c1280 < cdf_gam(&one, &val, stack_top+i, stack_top+CHUNKSIZE+i, --- > cdf_gam(&one, &val, &qval, stack_top+i, stack_top+CHUNKSIZE+i, 1267,1268c1293,1294 < long two= 2; < long status; --- > int two= 2; > int status; 1270a1297 > double qval; 1276c1303,1304 < cdf_gam(&two, stack_top+i, &val, stack_top+CHUNKSIZE+i, --- > qval= 1.0- *(stack_top+i); > cdf_gam(&two, stack_top+i, &qval, &val, stack_top+CHUNKSIZE+i, 1290,1291c1318,1319 < long one= 1; < long status; --- > int one= 1; > int status; 1293a1322 > double qval; 1299c1328 < cdf_nor(&one, &val, stack_top+i, stack_top+CHUNKSIZE+i, --- > cdf_nor(&one, &val, &qval, stack_top+i, stack_top+CHUNKSIZE+i, 1312,1313c1341,1342 < long two= 2; < long status; --- > int two= 2; > int status; 1315a1345 > double qval; 1321c1351,1352 < cdf_nor(&two, stack_top+i, &val, stack_top+CHUNKSIZE+i, --- > qval= 1.0- *(stack_top+i); > cdf_nor(&two, stack_top+i, &qval, &val, stack_top+CHUNKSIZE+i, Index: src/mri_util/mri_scan_fold_help.help =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/mri_scan_fold_help.help,v retrieving revision 1.3 retrieving revision 1.4 diff -r1.3 -r1.4 11c11 < mri_scan_fold -dz nslices [-v] [-order Boolean] infile outfile --- > mri_scan_fold -zdm nslices [-v] [-reo Boolean] infile outfile Index: src/outlier/outlier.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/outlier/outlier.c,v retrieving revision 1.8 diff -r1.8 outlier.c 50c50 < static char rcsid[] = "$Id: outlier.c,v 1.8 2001/12/21 20:53:09 welling Exp $"; --- > static char rcsid[] = "$Id: outlier.c,v 1.9 2003/11/27 00:48:48 welling Exp $"; 128c128,129 < int z, int dx, int dy, int dz, int dt ) --- > int z, int dx, int dy, int dz, int dt, > long* countOut ) 175a177 > *countOut= count; 182c184,185 < int z, int dx, int dy, int dz, int dt ) --- > int z, int dx, int dy, int dz, int dt, > long* countOut) 243a247 > *countOut= count; 416a421 > count= 0; 424c429 < z, dx, dy, dz, dt ); --- > z, dx, dy, dz, dt, &count ); 427c432 < z, dx, dy, dz, dt ); --- > z, dx, dy, dz, dt, &count ); 479a485,486 > if (count==0) count= dt; > Index: src/reader/Makefile =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/Makefile,v retrieving revision 1.25 retrieving revision 1.26 diff -r1.25 -r1.26 25,27c25,28 < $O/ram_reader.o $O/convert_reader.o $O/lx_image_reader.o \ < $O/multi_reader.o $O/afni_reader.o $O/dicom_reader.o \ < $O/siemens_kspace_reader.o $O/analyze_reader.o \ --- > $O/lx_2dfast_reader_prelx.o $O/lx_2dfast_reader_cnv4.o \ > $O/lx_2dfast_reader_lx2.o $O/ram_reader.o $O/convert_reader.o \ > $O/lx_image_reader.o $O/multi_reader.o $O/afni_reader.o \ > $O/dicom_reader.o $O/siemens_kspace_reader.o $O/analyze_reader.o \ 29c30 < $O/smart_utils.o $O/vec3.o --- > $O/smart_utils.o $O/vec3.o 127a129,146 > > $O/lx_2dfast_reader_cnv4.o: lx_2dfast_reader.c \ > ../fmri/frozen_header_info.h \ > ../fmri/frozen_header_info_cnv4.h > @echo "%%%% Compiling lx_2dfast_reader.c to $(@F) %%%%" > $(CC_FOR_CNV4) lx_2dfast_reader.c > > $O/lx_2dfast_reader_prelx.o: lx_2dfast_reader.c \ > ../fmri/frozen_header_info.h \ > ../fmri/frozen_header_info_prelx.h > @echo "%%%% Compiling lx_2dfast_reader.c to $(@F) %%%%" > $(CC_FOR_PRELX) lx_2dfast_reader.c > > $O/lx_2dfast_reader_lx2.o: lx_2dfast_reader.c \ > ../fmri/frozen_header_info.h \ > ../fmri/frozen_header_info_lx2.h > @echo "%%%% Compiling lx_2dfast_reader.c to $(@F) %%%%" > $(CC_FOR_LX2) lx_2dfast_reader.c Index: src/reader/lx_image_reader.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/lx_image_reader.c,v retrieving revision 1.10 diff -r1.10 lx_image_reader.c 57c57 < static char rcsid[] = "$Id: lx_image_reader.c,v 1.10 2003/06/26 22:12:42 welling Exp $"; --- > static char rcsid[] = "$Id: lx_image_reader.c,v 1.11 2003/11/06 17:59:01 welling Exp $"; 97,102c97,104 < float voxel[3]; < float tlc[3]; < float trc[3]; < float brc[3]; < float edge_lr[3]; < float edge_tb[3]; --- > double voxel[3]; > double tlc[3]; > double trc[3]; > double brc[3]; > double edge_lr[3]; > double edge_bt[3]; > double norm[3]; > float temp[3]; 206,208c208,213 < BRdFloat32Array(gemshdr + FRZ_LXI_GEMS_TLC_OFF, tlc, 3); < BRdFloat32Array(gemshdr + FRZ_LXI_GEMS_TRC_OFF, trc, 3); < BRdFloat32Array(gemshdr + FRZ_LXI_GEMS_BRC_OFF, brc, 3); --- > BRdFloat32Array(gemshdr + FRZ_LXI_GEMS_TLC_OFF, temp, 3); > for (i=0; i<3; i++) tlc[i]= temp[i]; /* type conversion */ > BRdFloat32Array(gemshdr + FRZ_LXI_GEMS_TRC_OFF, temp, 3); > for (i=0; i<3; i++) trc[i]= temp[i]; /* type conversion */ > BRdFloat32Array(gemshdr + FRZ_LXI_GEMS_BRC_OFF, temp, 3); > for (i=0; i<3; i++) brc[i]= temp[i]; /* type conversion */ 218a224,228 > subtractVec3( edge_lr, trc, tlc ); > subtractVec3( edge_bt, trc, brc ); > crossVec3( norm, edge_lr, edge_bt ); > normalizeVec3( norm ); > 223,227c233 < } < < for (i=0; i<3; i++) { < edge_lr[i]= trc[i]-tlc[i]; < edge_tb[i]= trc[i]-brc[i]; --- > fprintf(stderr," norm=(%f, %f, %f)\n", norm[0], norm[1], norm[2]); 258,259c264,265 < if (fabs(edge_tb[0])>fabs(edge_tb[1])) { < if (fabs(edge_tb[0])>fabs(edge_tb[2])) { --- > if (fabs(edge_bt[0])>fabs(edge_bt[1])) { > if (fabs(edge_bt[0])>fabs(edge_bt[2])) { 271c277 < if (fabs(edge_tb[1])>fabs(edge_tb[2])) { --- > if (fabs(edge_bt[1])>fabs(edge_bt[2])) { 292,300c298,301 < kvDefDouble(info,"slice_tlc.0", tlc[0]); < kvDefDouble(info,"slice_tlc.1", tlc[1]); < kvDefDouble(info,"slice_tlc.2", tlc[2]); < kvDefDouble(info,"slice_trc.0", trc[0]); < kvDefDouble(info,"slice_trc.1", trc[1]); < kvDefDouble(info,"slice_trc.2", trc[2]); < kvDefDouble(info,"slice_brc.0", brc[0]); < kvDefDouble(info,"slice_brc.1", brc[1]); < kvDefDouble(info,"slice_brc.2", brc[2]); --- > defVec3( info, "slice_tlc", tlc ); > defVec3( info, "slice_trc", trc ); > defVec3( info, "slice_brc", brc ); > defVec3( info, "slice_norm", norm ); Index: src/reader/lx_reader.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/lx_reader.c,v retrieving revision 1.23 retrieving revision 1.24 diff -r1.23 -r1.24 51a52,53 > ---2DFAST--- > -Gee, I really should learn something about this pulse sequence. 86c88 < static char rcsid[] = "$Id: lx_reader.c,v 1.23 2003/07/01 21:35:22 welling Exp $"; --- > static char rcsid[] = "$Id: lx_reader.c,v 1.24 2003/11/04 22:24:35 welling Exp $"; 281a284,295 > > /* > * Sometimes the GE header logo is INVALID rather than GE_MED_NMR. > * Make a note of this and continue. > * > */ > if (!(strncmp((char*)rdbhead+FRZ_RDBHEAD_RDB_HDR_LOGO_OFF, > FRZ_RDBHEAD_RDB_INVALID_LOGO, > FRZ_RDBHEAD_RDB_HDR_LOGO_SIZE))) { > kvDefBoolean(info,"GE_hdr_invalid",1); > kvDefString(defs,"GE_hdr_invalid","GE RDB_LOGO is marked INVALID?"); > } 475a490,494 > } > else if (!strncmp(pulse_seq,"2dfast",3)) { > /* Interpret as 2dfast structural scan */ > ADD_VSUFFIX(scan2dfastHeader)(info, rdbhead, acq_tab, examhead, > serieshead, imagehead); Index: src/reader/lx_splx_reader.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/lx_splx_reader.c,v retrieving revision 1.12 retrieving revision 1.13 diff -r1.12 -r1.13 66c66 < static char rcsid[] = "$Id: lx_splx_reader.c,v 1.12 2003/06/26 22:12:42 welling Exp $"; --- > static char rcsid[] = "$Id: lx_splx_reader.c,v 1.13 2003/11/04 22:24:35 welling Exp $"; 184a185 > Index: src/reader/multi_reader.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/multi_reader.c,v retrieving revision 1.20 diff -r1.20 multi_reader.c 50c50 < static char rcsid[] = "$Id: multi_reader.c,v 1.20 2003/10/02 01:12:12 welling Exp $"; --- > static char rcsid[] = "$Id: multi_reader.c,v 1.21 2003/11/06 17:59:01 welling Exp $"; 409c409 < static int locateVolumeCorners( FileHandler* self, KVHash* info ) --- > static int locateVolumeCorners( FileHandler* self, KVHash* info, int recur ) 431a432,436 > if (recur>1) { > if (verbose_flg) fprintf(stderr,"locateVolumeCorners is lost in recursion!\n"); > return 0; > } > 519a525,535 > copyVec3(vol_blb, base_tlc); > xplusbyVec3(vol_blf, vol_blb, y_norm, > -(kvGetInt(info,"dy")-1)*kvGetDouble(info,"voxel_y")); > xplusbyVec3(vol_brf, vol_blf, x_norm, > (kvGetInt(info,"dx")-1)*kvGetDouble(info,"voxel_x")); > xplusbyVec3(vol_tlf, vol_blf, z_norm, > (kvGetInt(info,"dz")-1)*kvGetDouble(info,"voxel_z")); > defVec3(info, "tlf", vol_tlf); > defVec3(info, "brf", vol_brf); > defVec3(info, "blb", vol_blb); > defVec3(info, "blf", vol_blf); 522,527c538,546 < Warning(1,"%s: multi_reader: volume is inside-out!\n",progname); < kvDefDouble(info,"slice_thickness", -kvGetDouble(info,"voxel_z")); < kvDefDouble(info,"slice_gap", < -(kvGetDouble(info,"voxel_z") + first_disp_step)); < kvDefDouble(info,"voxel_z", first_disp_step); < } --- > /* Reverse the order of slices within each volume */ > FileHandler** fh_table= NULL; > char* dimstr= kvGetString(info,"dimstr"); > char buf[64]; > int dz; > int dt; > int z; > int t; > int totSlices; 529,540c548,590 < copyVec3(vol_blb, base_tlc); < xplusbyVec3(vol_blf, vol_blb, y_norm, < -(kvGetInt(info,"dy")-1)*kvGetDouble(info,"voxel_y")); < xplusbyVec3(vol_brf, vol_blf, x_norm, < (kvGetInt(info,"dx")-1)*kvGetDouble(info,"voxel_x")); < xplusbyVec3(vol_tlf, vol_blf, z_norm, < (kvGetInt(info,"dz")-1)*kvGetDouble(info,"voxel_z")); < defVec3(info, "tlf", vol_tlf); < defVec3(info, "brf", vol_brf); < defVec3(info, "blb", vol_blb); < defVec3(info, "blf", vol_blf); < --- > Warning(1,"%s: multi_reader: volume is inside-out; trying to fix it!\n", > progname); > > if (!(fh_table=(FileHandler**)malloc(slist_count(data->kids) > *sizeof(FileHandler*)))) > Abort("%s: unable to allocate %d bytes!\n",progname, > slist_count(data->kids)*sizeof(FileHandler*)); > > /* This is a volume, so strlen(dimstr) is at least 3 */ > sprintf(buf,"d%c",dimstr[strlen(dimstr)-1]); > dt= kvGetInt(info,buf); > if (dt==slist_count(data->kids)) { > /* There is only one instance of the volume */ > dz= dt; > dt= 1; > } > else { > sprintf(buf,"d%c",dimstr[strlen(dimstr)-2]); > dz= kvGetInt(info,buf); > } > totSlices= dz*dt; > if (totSlices != slist_count(data->kids)) { > if (verbose_flg) > fprintf(stderr,"Cannot flip volume; files are not one slice each!\n"); > return 0; > } > > if (!(fh_table=(FileHandler**)malloc(slist_count(data->kids) > *sizeof(FileHandler*)))) > Abort("%s: unable to allocate %d bytes!\n",progname, > slist_count(data->kids)*sizeof(FileHandler*)); > > slist_totop(data->kids); > for (t=0; t for (z=dz-1; z>=0; z--) > fh_table[t*dz+z]= (FileHandler*)slist_pop(data->kids); > for (t=0; t for (z=0; z slist_append(data->kids, fh_table[t*dz + z]); > free(fh_table); > > return locateVolumeCorners(self, info, recur+1); > } 681c731 < (void)locateVolumeCorners(self, info); --- > (void)locateVolumeCorners(self, info, 0); Index: src/reader/smartreader.h =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/smartreader.h,v retrieving revision 1.13 diff -r1.13 smartreader.h 124a125 > void normalizeVec3( double* v ); 159a161,163 > extern void scan2dfastHeader_cnv4( KVHash* info, unsigned char*, > unsigned char*, unsigned char*, > unsigned char*, unsigned char* ); 176a181,183 > extern void scan2dfastHeader_lx2( KVHash* info, unsigned char*, > unsigned char*, unsigned char*, > unsigned char*, unsigned char* ); 193a201,203 > extern void scan2dfastHeader_prelx( KVHash* info, unsigned char*, > unsigned char*, unsigned char*, > unsigned char*, unsigned char* ); Index: src/reader/smartreader_help.help =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/smartreader_help.help,v retrieving revision 1.8 retrieving revision 1.9 diff -r1.8 -r1.9 301,302c301,302 < GE LX data files for several EPI pulse sequences, and for spiral < sequences with pulse sequence ID strings "splx1" and later. --- > GE LX data files for several EPI pulse sequences, 2dfast, and for > spiral sequences with pulse sequence ID strings "splx1" and later. Index: src/reader/vec3.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/vec3.c,v retrieving revision 1.2 diff -r1.2 vec3.c 51c51 < static char rcsid[] = "$Id: vec3.c,v 1.2 2003/06/26 22:12:42 welling Exp $"; --- > static char rcsid[] = "$Id: vec3.c,v 1.3 2003/11/06 17:59:01 welling Exp $"; 143a144,153 > } > > void normalizeVec3( double* v ) > { > double cpy[3]; > double norm; > copyVec3( cpy, v ); > norm= normVec3( cpy ); > if (norm==0.0) return; > else multVec3( v, cpy, 1.0/norm ); Index: src/csh/mark_spikes_missing.csh =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/mark_spikes_missing.csh,v retrieving revision 1.2 retrieving revision 1.3 diff -r1.2 -r1.3 37c37 < echo '#$Id: mark_spikes_missing.csh,v 1.2 2003/09/11 18:51:43 bakalj Exp $' --- > echo '#$Id: mark_spikes_missing.csh,v 1.3 2003/12/02 19:48:41 welling Exp $' 78c78 < echo $step >> $F_SUMM_MISSING --- > echo $step.$$ >> $F_SUMM_MISSING Index: src/meanc/meanc.c =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/meanc/meanc.c,v retrieving revision 1.10 retrieving revision 1.11 diff -r1.10 -r1.11 53c53 < static char rcsid[] = "$Id: meanc.c,v 1.10 2003/02/22 00:57:57 welling Exp $"; --- > static char rcsid[] = "$Id: meanc.c,v 1.11 2003/12/02 23:20:41 welling Exp $"; 61c61 < char outfile[512], parfile[512]; --- > char parfile[512]; 94d93 < cl_get( "dataout|d", "%option %s[%]", ".dat", outfile ); 139d137 < mri_set_string( Output, "images.file", outfile ); 313,335c311,334 < < /* Calculate multiplicative adjustment parameter */ < adj[t][z] = fixed_mean / mean; < < /* Multiply adjustment across entire image */ < if( dv == 1 ) < for( y = 0; y < dy; y++ ) < for( x = 0; x < dx; x++ ) < corr_img[y][x] = img[y][x] * adj[t][z]; < else < for( y = 0; y < dy; y++ ) < for( x = 0; x < dx; x++ ) < { < c_corr_img[y][x].real = c_img[y][x].real * adj[t][z]; < c_corr_img[y][x].imag = c_img[y][x].imag * adj[t][z]; < } < < /* Set corrected output image */ < if( dv == 1 ) < mri_set_image( Output, t, z, MRI_FLOAT, *corr_img ); < else < mri_set_image( Output, t, z, MRI_COMPLEX_FLOAT, *c_corr_img ); < --- > else > { > /* Calculate multiplicative adjustment parameter */ > adj[t][z] = fixed_mean / mean; > > /* Multiply adjustment across entire image */ > if( dv == 1 ) > for( y = 0; y < dy; y++ ) > for( x = 0; x < dx; x++ ) > corr_img[y][x] = img[y][x] * adj[t][z]; > else > for( y = 0; y < dy; y++ ) > for( x = 0; x < dx; x++ ) > { > c_corr_img[y][x].real = c_img[y][x].real * adj[t][z]; > c_corr_img[y][x].imag = c_img[y][x].imag * adj[t][z]; > } > > /* Set corrected output image */ > if( dv == 1 ) > mri_set_image( Output, t, z, MRI_FLOAT, *corr_img ); > else > mri_set_image( Output, t, z, MRI_COMPLEX_FLOAT, *c_corr_img ); > } 350a350 > fprintf(fp,"##Format: order:z_fastest type:raw names:(meanc)\n"); Index: src/mri_util/mri_esa_help.help =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/mri_esa_help.help,v retrieving revision 1.4 retrieving revision 1.5 diff -r1.4 -r1.5 15,16c15,16 < Suppose the input file infile.mri has dimensions xyt, with extents < 100:100:30. Each of the 30 t's represent a different 100x100 real --- > Suppose the input file infile.mri has dimensions xyz, with extents > 100:100:30. Each of the 30 z's represent a different 100x100 real 24,25c24,25 < eigenvalues.mri will have dimensions yt, with extents 10:30 . Each < of the 30 t's represents the largest 10 eigenvalues of the --- > eigenvalues.mri will have dimensions yz, with extents 10:30 . Each > of the 30 z's represents the largest 10 eigenvalues of the 28,29c28,29 < eigenvectors.mri will have dimensions xyt, with extents 100:10:30. < Each of the 30 t's will contain the 10 eigenvectors (each of length --- > eigenvectors.mri will have dimensions xyz, with extents 100:10:30. > Each of the 30 z's will contain the 10 eigenvectors (each of length 38c38,39 < real symmetric matrices and each is solved in turn. --- > real symmetric matrices and each is solved in turn. The particular > letter names of the dimensions don't matter. Index: src/mri_util/mri_rpn_math_help.help =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/mri_util/mri_rpn_math_help.help,v retrieving revision 1.25 retrieving revision 1.27 diff -r1.25 -r1.27 67c67,74 < The special filename "-" means read from stdin. --- > Be careful of the "-": > > Do not start an expression on the command line with "-". The > following will cause a processing error: > mri_rpn_math -out junk "-1, $1, +" detrend > > "-" following -exp means read from stdin. For example: > echo "-1, $1, +" > mri_rpn_math -out junk -exp - detrend 377c384 < m4include(../libcdf/libcdf_help.help) --- > m4include(../libdcdf/libdcdf_help.help) Index: src/csh/fiasco_utils.py =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/csh/fiasco_utils.py,v retrieving revision 1.5 retrieving revision 1.6 diff -r1.5 -r1.6 29c29 < _idString_= "$Id: fiasco_utils.py,v 1.5 2003/09/24 22:55:47 welling Exp $" --- > _idString_= "$Id: fiasco_utils.py,v 1.6 2003/11/27 02:02:58 welling Exp $" 79c79 < verboseMessage("removing temporary directory %s"%path) --- > debugMessage("removing temporary directory tree %s"%path) 81c81,85 < os.remove("%s/%s"%(path,file)) --- > kidPath= os.path.join(path,file) > if os.path.isdir(kidPath): > removeTmpDir(kidPath) > else: > os.remove(kidPath) 86a91 > cmdout.readlines() # Throw away the output 146a152,229 > def dsExists( thisDS ): > if os.path.splitext(thisDS)[1]=='.mri': > return os.access(thisDS,os.F_OK) > else: > return os.access("%s.mri"%thisDS,os.F_OK) > > def chunkExists( thisDS, chunk ): > cmd= "mri_printfield -field %s -nofail %s" % (chunk,thisDS) > debugMessage("running <%s>"%cmd) > cmdout= os.popen(cmd) > xstr= cmdout.read() > if cmdout.close() != None : > sys.exit("mri_printfield failed for %s on %s!"%(chunk,thisDS)) > xstr= string.strip(xstr) > return (xstr=='[chunk]') > > class MRIChunk: > def __init__(self,ds,name): > self.ds= ds > self.name= name > self.dict= {} > def addPair(self,key,value): > self.dict[key]= value > def __str__(self): > return "chunk %s: %s"%(self.name,str(self.dict)) > def hasValue(self,key): > return self.dict.has_key(key) > def getValue(self,key): > return self.dict[key] > def getDim(self,d): > return int(self.getValue("extent.%s"%d)) > > class MRIDataset: > def __init__(self,fname): > self.fname= fname > self.chunks= {} > self.orphans= {} > if os.path.splitext(fname)[1]=='.mri': > f= file(fname,"r") > else: > f= file("%s.mri"%fname,"r") > lines= f.readlines() > f.close() > currentChunkName= "" > prefix= currentChunkName+'.' > for line in lines: > if string.find(line,'\f')>=0: > break > (key,val)= map(string.strip,string.split(line,'=',1)) > if val == '[chunk]': > currentChunkName= key > prefix= currentChunkName+'.' > self.chunks[currentChunkName]= MRIChunk(self,key) > else: > if prefix!="." and string.find(key,prefix)==0: > # still working on this chunk > self.chunks[currentChunkName].addPair(key[len(prefix):],val) > else: > currentChunkName= "" > prefix= "." > self.orphans[key]= val > > def __str__(self): > chStr= "" > for ch in self.chunks: > print str(ch) > chStr= chStr + "<%s> "%str(ch) > return "dataset %s: orphans %s, chunks <%s>"%\ > (self.fname,str(self.orphans),chStr) > > def hasChunk(self,chname): > return self.chunks.has_key(chname) > > def getChunk(self,chname): > return self.chunks[chname] > > def getOrphan(self,key): > return self.orphans[key] Index: src/image_proc/Makefile =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/image_proc/Makefile,v retrieving revision 1.7 retrieving revision 1.8 diff -r1.7 -r1.8 14c14 < -lcdf $(LAPACK_LIBS) --- > -ldcdf $(LAPACK_LIBS) Index: src/par_util/Makefile =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/par_util/Makefile,v retrieving revision 1.2 retrieving revision 1.3 diff -r1.2 -r1.3 13c13 < PKG_LIBS = -lcdf -lfmri -lmri -lpar -lbio -lacct -lmisc \ --- > PKG_LIBS = -ldcdf -lfmri -lmri -lpar -lbio -lacct -lmisc \ Index: src/misc/Makefile =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/misc/Makefile,v retrieving revision 1.3 retrieving revision 1.4 diff -r1.3 -r1.4 16c16 < PKG_LIBS = -lcdf -lfmri -lmri -lpar -lbio -lacct \ --- > PKG_LIBS = -ldcdf -lfmri -lmri -lpar -lbio -lacct \ Index: src/libdcdf/cdftester.c ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/cdftester.c 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,125 @@ +#include +#include +#include + +int main(int argc, char* argv[]) { + double df; + double p, pout; + double q, qout; + double x, xout; + int retval= 0; + int one= 1; + int two= 2; + double t1=0.0, t2=0.0, t3=0.0; + int status; + double bound; + int i; + + if (argc<2) { + printf("usage: %s x p df [t1 [t2 [t3]]]\n",argv[0]); + return -1; + } + + if (argc>=2) x= atof(argv[1]); + if (argc>=3) p= atof(argv[2]); + if (argc>=4) df= atof(argv[3]); + if (argc>=5) t1= atof(argv[4]); + if (argc>=6) t2= atof(argv[5]); + if (argc>=7) t3= atof(argv[6]); + + q= 1.0-p; + +#ifdef never + /* Test normal distribution */ + printf("normal dist\n"); + + cdf_nor(&one, &pout, &qout, &x, &t1, &t2, &status, &bound); + printf("%ld %ld %g: ??? %f %f %f -> %f\n",retval,status,bound,x,t1,t2,pout); + + cdf_nor(&two, &p, &q, &xout, &t1, &t2, &status, &bound); + printf("%ld %ld %g: %f ??? %f %f -> %f\n",retval,status,bound,p,t1,t2,xout); +#endif + +#ifdef never + /* Test chi squared distribution */ + printf("chi squared dist\n"); + + cdf_chi(&one, &pout, &qout, &x, &df, &status, &bound); + printf("%ld %ld %g: ??? %f %f -> %f\n",retval,status,bound,x,df,pout); + + cdf_chi(&two, &p, &q, &xout, &df, &status, &bound); + printf("%ld %ld %g: %f ??? %f -> %f\n",retval,status,bound,p,df,xout); +#endif + +#ifdef never + /* Test F distribution */ + printf("F dist\n"); + + cdf_f(&one, &pout, &qout, &x, &df, &t1, &status, &bound); + printf("%ld %ld %g: ??? %f %f %f -> %f\n",retval,status,bound,x,df,t1,pout); + + cdf_f(&two, &p, &q, &xout, &df, &t1, &status, &bound); + printf("%ld %ld %g: %f ??? %f %f -> %f\n",retval,status,bound,p,df,t1,xout); +#endif + +#ifdef never + /* Test T distribution */ + printf("T dist\n"); + + cdf_t(&one, &pout, &qout, &x, &df, &status, &bound); + printf("%ld %g: ??? %f %f -> %f\n",status,bound,x,df,pout); + + cdf_t(&two, &p, &q, &xout, &df, &status, &bound); + printf("%ld %g: %f ??? %f -> %f\n",status,bound,p,df,xout); +#endif + +#ifdef never + /* Test Poisson distribution */ + printf("Poisson dist\n"); + + cdf_poi(&one, &pout, &qout, &x, &df, &status, &bound); + printf("%ld %ld %g: ??? %f %f -> %f\n",retval,status,bound,x,df,pout); + + cdf_poi(&two, &p, &q, &xout, &df, &status, &bound); + printf("%ld %ld %g: %f ??? %f -> %f\n",retval,status,bound,p,df,xout); +#endif + +#ifdef never + /* Test binomial distribution */ + printf("Binomial dist\n"); + + cdf_bin(&one, &pout, &qout, &x, &df, &t1, &status, &bound); + printf("%ld %ld %g: ??? %f %f %f -> %f\n",retval,status,bound,x,df,t1,pout); + + cdf_bin(&two, &p, &q, &xout, &df, &t1, &status, &bound); + printf("%ld %ld %g: %f ??? %f %f -> %f\n",retval,status,bound,p,df,t1,xout); +#endif + +#ifdef never + /* Test beta distribution */ + printf("Beta dist\n"); + + cdf_bet(&one, &pout, &qout, &x, &df, &t1, &status, &bound); + printf("%ld %ld %g: ??? %f %f %f -> %f\n",retval,status,bound,x,df,t1,pout); + + cdf_bet(&two, &p, &q, &xout, &df, &t1, &status, &bound); + printf("%ld %ld %g: %f ??? %f %f -> %f\n",retval,status,bound,p,df,t1,xout); +#endif + +#ifdef never + /* Test gamma distribution */ + printf("Gamma dist\n"); + + cdf_gam(&one, &pout, &qout, &x, &df, &t1, &status, &bound); + printf("%ld %ld %g: ??? %f %f %f -> %f\n",retval,status,bound,x,df,t1,pout); + + cdf_gam(&two, &p, &q, &xout, &df, &t1, &status, &bound); + printf("%ld %ld %g: %f ??? %f %f -> %f\n",retval,status,bound,p,df,t1,xout); +#endif + + for (i=1; i<=10; i++) { + printf("cdf_ipmpar[%d]= %d\n",i,cdf_ipmpar(&i)); + } + + return 0; +} Index: src/libdcdf/dcdflib.c ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/dcdflib.c 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,9204 @@ +#include +#include +#include +#include "dcdflib.h" +#include "dcdflib_private.h" +/* +----------------------------------------------------------------------- + + COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8 + + -------- + + IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY + LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). + +----------------------------------------------------------------------- +*/ +double algdiv(double *a,double *b) +{ +static double c0 = .833333333333333e-01; +static double c1 = -.277777777760991e-02; +static double c2 = .793650666825390e-03; +static double c3 = -.595202931351870e-03; +static double c4 = .837308034031215e-03; +static double c5 = -.165322962780713e-02; +static double algdiv,c,d,h,s11,s3,s5,s7,s9,t,u,v,w,x,x2,T1; +/* + .. + .. Executable Statements .. +*/ + if(*a <= *b) goto S10; + h = *b/ *a; + c = 1.0e0/(1.0e0+h); + x = h/(1.0e0+h); + d = *a+(*b-0.5e0); + goto S20; +S10: + h = *a/ *b; + c = h/(1.0e0+h); + x = 1.0e0/(1.0e0+h); + d = *b+(*a-0.5e0); +S20: +/* + SET SN = (1 - X**N)/(1 - X) +*/ + x2 = x*x; + s3 = 1.0e0+(x+x2); + s5 = 1.0e0+(x+x2*s3); + s7 = 1.0e0+(x+x2*s5); + s9 = 1.0e0+(x+x2*s7); + s11 = 1.0e0+(x+x2*s9); +/* + SET W = DEL(B) - DEL(A + B) +*/ + t = pow(1.0e0/ *b,2.0); + w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0; + w *= (c/ *b); +/* + COMBINE THE RESULTS +*/ + T1 = *a/ *b; + u = d*alnrel(&T1); + v = *a*(log(*b)-1.0e0); + if(u <= v) goto S30; + algdiv = w-v-u; + return algdiv; +S30: + algdiv = w-u-v; + return algdiv; +} +double alngam(double *x) +/* +********************************************************************** + + double alngam(double *x) + double precision LN of the GAMma function + + + Function + + + Returns the natural logarithm of GAMMA(X). + + + Arguments + + + X --> value at which scaled log gamma is to be returned + X is DOUBLE PRECISION + + + Method + + + If X .le. 6.0, then use recursion to get X below 3 + then apply rational approximation number 5236 of + Hart et al, Computer Approximations, John Wiley and + Sons, NY, 1968. + + If X .gt. 6.0, then use recursion to get X to at least 12 and + then use formula 5423 of the same source. + +********************************************************************** +*/ +{ +#define hln2pi 0.91893853320467274178e0 +static double coef[5] = { + 0.83333333333333023564e-1,-0.27777777768818808e-2,0.79365006754279e-3, + -0.594997310889e-3,0.8065880899e-3 +}; +static double scoefd[4] = { + 0.62003838007126989331e2,0.9822521104713994894e1,-0.8906016659497461257e1, + 0.1000000000000000000e1 +}; +static double scoefn[9] = { + 0.62003838007127258804e2,0.36036772530024836321e2,0.20782472531792126786e2, + 0.6338067999387272343e1,0.215994312846059073e1,0.3980671310203570498e0, + 0.1093115956710439502e0,0.92381945590275995e-2,0.29737866448101651e-2 +}; +static int K1 = 9; +static int K3 = 4; +static int K5 = 5; +static double alngam,offset,prod,xx; +static int i,n; +static double T2,T4,T6; +/* + .. + .. Executable Statements .. +*/ + if(!(*x <= 6.0e0)) goto S70; + prod = 1.0e0; + xx = *x; + if(!(*x > 3.0e0)) goto S30; +S10: + if(!(xx > 3.0e0)) goto S20; + xx -= 1.0e0; + prod *= xx; + goto S10; +S30: +S20: + if(!(*x < 2.0e0)) goto S60; +S40: + if(!(xx < 2.0e0)) goto S50; + prod /= xx; + xx += 1.0e0; + goto S40; +S60: +S50: + T2 = xx-2.0e0; + T4 = xx-2.0e0; + alngam = devlpl(scoefn,&K1,&T2)/devlpl(scoefd,&K3,&T4); +/* + COMPUTE RATIONAL APPROXIMATION TO GAMMA(X) +*/ + alngam *= prod; + alngam = log(alngam); + goto S110; +S70: + offset = hln2pi; +/* + IF NECESSARY MAKE X AT LEAST 12 AND CARRY CORRECTION IN OFFSET +*/ + n = fifidint(12.0e0-*x); + if(!(n > 0)) goto S90; + prod = 1.0e0; + for(i=1; i<=n; i++) prod *= (*x+(double)(i-1)); + offset -= log(prod); + xx = *x+(double)n; + goto S100; +S90: + xx = *x; +S100: +/* + COMPUTE POWER SERIES +*/ + T6 = 1.0e0/pow(xx,2.0); + alngam = devlpl(coef,&K5,&T6)/xx; + alngam += (offset+(xx-0.5e0)*log(xx)-xx); +S110: + return alngam; +#undef hln2pi +} +double alnrel(double *a) +/* +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION LN(1 + A) +----------------------------------------------------------------------- +*/ +{ +static double p1 = -.129418923021993e+01; +static double p2 = .405303492862024e+00; +static double p3 = -.178874546012214e-01; +static double q1 = -.162752256355323e+01; +static double q2 = .747811014037616e+00; +static double q3 = -.845104217945565e-01; +static double alnrel,t,t2,w,x; +/* + .. + .. Executable Statements .. +*/ + if(fabs(*a) > 0.375e0) goto S10; + t = *a/(*a+2.0e0); + t2 = t*t; + w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0); + alnrel = 2.0e0*t*w; + return alnrel; +S10: + x = 1.e0+*a; + alnrel = log(x); + return alnrel; +} +double apser(double *a,double *b,double *x,double *eps) +/* +----------------------------------------------------------------------- + APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR + A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN + A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED. +----------------------------------------------------------------------- +*/ +{ +static double g = .577215664901533e0; +static double apser,aj,bx,c,j,s,t,tol; +/* + .. + .. Executable Statements .. +*/ + bx = *b**x; + t = *x-bx; + if(*b**eps > 2.e-2) goto S10; + c = log(*x)+psi(b)+g+t; + goto S20; +S10: + c = log(bx)+g+t; +S20: + tol = 5.0e0**eps*fabs(c); + j = 1.0e0; + s = 0.0e0; +S30: + j += 1.0e0; + t *= (*x-bx/j); + aj = t/j; + s += aj; + if(fabs(aj) > tol) goto S30; + apser = -(*a*(c+s)); + return apser; +} +double basym(double *a,double *b,double *lambda,double *eps) +/* +----------------------------------------------------------------------- + ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B. + LAMBDA = (A + B)*Y - B AND EPS IS THE TOLERANCE USED. + IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT + A AND B ARE GREATER THAN OR EQUAL TO 15. +----------------------------------------------------------------------- +*/ +{ +static double e0 = 1.12837916709551e0; +static double e1 = .353553390593274e0; +static int num = 20; +/* +------------------------ + ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP + ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN. + THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1. +------------------------ + E0 = 2/SQRT(PI) + E1 = 2**(-3/2) +------------------------ +*/ +static int K3 = 1; +static double basym,bsum,dsum,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,t0,t1,u,w,w0,z,z0, + z2,zn,znm1; +static int i,im1,imj,j,m,mm1,mmj,n,np1; +static double a0[21],b0[21],c[21],d[21],T1,T2; +/* + .. + .. Executable Statements .. +*/ + basym = 0.0e0; + if(*a >= *b) goto S10; + h = *a/ *b; + r0 = 1.0e0/(1.0e0+h); + r1 = (*b-*a)/ *b; + w0 = 1.0e0/sqrt(*a*(1.0e0+h)); + goto S20; +S10: + h = *b/ *a; + r0 = 1.0e0/(1.0e0+h); + r1 = (*b-*a)/ *a; + w0 = 1.0e0/sqrt(*b*(1.0e0+h)); +S20: + T1 = -(*lambda/ *a); + T2 = *lambda/ *b; + f = *a*rlog1(&T1)+*b*rlog1(&T2); + t = exp(-f); + if(t == 0.0e0) return basym; + z0 = sqrt(f); + z = 0.5e0*(z0/e1); + z2 = f+f; + a0[0] = 2.0e0/3.0e0*r1; + c[0] = -(0.5e0*a0[0]); + d[0] = -c[0]; + j0 = 0.5e0/e0*erfc1(&K3,&z0); + j1 = e1; + sum = j0+d[0]*w0*j1; + s = 1.0e0; + h2 = h*h; + hn = 1.0e0; + w = w0; + znm1 = z; + zn = z2; + for(n=2; n<=num; n+=2) { + hn = h2*hn; + a0[n-1] = 2.0e0*r0*(1.0e0+h*hn)/((double)n+2.0e0); + np1 = n+1; + s += hn; + a0[np1-1] = 2.0e0*r1*s/((double)n+3.0e0); + for(i=n; i<=np1; i++) { + r = -(0.5e0*((double)i+1.0e0)); + b0[0] = r*a0[0]; + for(m=2; m<=i; m++) { + bsum = 0.0e0; + mm1 = m-1; + for(j=1; j<=mm1; j++) { + mmj = m-j; + bsum += (((double)j*r-(double)mmj)*a0[j-1]*b0[mmj-1]); + } + b0[m-1] = r*a0[m-1]+bsum/(double)m; + } + c[i-1] = b0[i-1]/((double)i+1.0e0); + dsum = 0.0e0; + im1 = i-1; + for(j=1; j<=im1; j++) { + imj = i-j; + dsum += (d[imj-1]*c[j-1]); + } + d[i-1] = -(dsum+c[i-1]); + } + j0 = e1*znm1+((double)n-1.0e0)*j0; + j1 = e1*zn+(double)n*j1; + znm1 = z2*znm1; + zn = z2*zn; + w = w0*w; + t0 = d[n-1]*w*j0; + w = w0*w; + t1 = d[np1-1]*w*j1; + sum += (t0+t1); + if(fabs(t0)+fabs(t1) <= *eps*sum) goto S80; + } +S80: + u = exp(-bcorr(a,b)); + basym = e0*t*u*sum; + return basym; +} +double bcorr(double *a0,double *b0) +/* +----------------------------------------------------------------------- + + EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE + LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A). + IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8. + +----------------------------------------------------------------------- +*/ +{ +static double c0 = .833333333333333e-01; +static double c1 = -.277777777760991e-02; +static double c2 = .793650666825390e-03; +static double c3 = -.595202931351870e-03; +static double c4 = .837308034031215e-03; +static double c5 = -.165322962780713e-02; +static double bcorr,a,b,c,h,s11,s3,s5,s7,s9,t,w,x,x2; +/* + .. + .. Executable Statements .. +*/ + a = fifdmin1(*a0,*b0); + b = fifdmax1(*a0,*b0); + h = a/b; + c = h/(1.0e0+h); + x = 1.0e0/(1.0e0+h); + x2 = x*x; +/* + SET SN = (1 - X**N)/(1 - X) +*/ + s3 = 1.0e0+(x+x2); + s5 = 1.0e0+(x+x2*s3); + s7 = 1.0e0+(x+x2*s5); + s9 = 1.0e0+(x+x2*s7); + s11 = 1.0e0+(x+x2*s9); +/* + SET W = DEL(B) - DEL(A + B) +*/ + t = pow(1.0e0/b,2.0); + w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0; + w *= (c/b); +/* + COMPUTE DEL(A) + W +*/ + t = pow(1.0e0/a,2.0); + bcorr = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a+w; + return bcorr; +} +double betaln(double *a0,double *b0) +/* +----------------------------------------------------------------------- + EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION +----------------------------------------------------------------------- + E = 0.5*LN(2*PI) +-------------------------- +*/ +{ +static double e = .918938533204673e0; +static double betaln,a,b,c,h,u,v,w,z; +static int i,n; +static double T1; +/* + .. + .. Executable Statements .. +*/ + a = fifdmin1(*a0,*b0); + b = fifdmax1(*a0,*b0); + if(a >= 8.0e0) goto S100; + if(a >= 1.0e0) goto S20; +/* +----------------------------------------------------------------------- + PROCEDURE WHEN A .LT. 1 +----------------------------------------------------------------------- +*/ + if(b >= 8.0e0) goto S10; + T1 = a+b; + betaln = gamln(&a)+(gamln(&b)-gamln(&T1)); + return betaln; +S10: + betaln = gamln(&a)+algdiv(&a,&b); + return betaln; +S20: +/* +----------------------------------------------------------------------- + PROCEDURE WHEN 1 .LE. A .LT. 8 +----------------------------------------------------------------------- +*/ + if(a > 2.0e0) goto S40; + if(b > 2.0e0) goto S30; + betaln = gamln(&a)+gamln(&b)-gsumln(&a,&b); + return betaln; +S30: + w = 0.0e0; + if(b < 8.0e0) goto S60; + betaln = gamln(&a)+algdiv(&a,&b); + return betaln; +S40: +/* + REDUCTION OF A WHEN B .LE. 1000 +*/ + if(b > 1000.0e0) goto S80; + n = a-1.0e0; + w = 1.0e0; + for(i=1; i<=n; i++) { + a -= 1.0e0; + h = a/b; + w *= (h/(1.0e0+h)); + } + w = log(w); + if(b < 8.0e0) goto S60; + betaln = w+gamln(&a)+algdiv(&a,&b); + return betaln; +S60: +/* + REDUCTION OF B WHEN B .LT. 8 +*/ + n = b-1.0e0; + z = 1.0e0; + for(i=1; i<=n; i++) { + b -= 1.0e0; + z *= (b/(a+b)); + } + betaln = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b))); + return betaln; +S80: +/* + REDUCTION OF A WHEN B .GT. 1000 +*/ + n = a-1.0e0; + w = 1.0e0; + for(i=1; i<=n; i++) { + a -= 1.0e0; + w *= (a/(1.0e0+a/b)); + } + betaln = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b)); + return betaln; +S100: +/* +----------------------------------------------------------------------- + PROCEDURE WHEN A .GE. 8 +----------------------------------------------------------------------- +*/ + w = bcorr(&a,&b); + h = a/b; + c = h/(1.0e0+h); + u = -((a-0.5e0)*log(c)); + v = b*alnrel(&h); + if(u <= v) goto S110; + betaln = -(0.5e0*log(b))+e+w-v-u; + return betaln; +S110: + betaln = -(0.5e0*log(b))+e+w-u-v; + return betaln; +} +double bfrac(double *a,double *b,double *x,double *y,double *lambda, + double *eps) +/* +----------------------------------------------------------------------- + CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1. + IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B. +----------------------------------------------------------------------- +*/ +{ +static double bfrac,alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,t,w,yp1; +/* + .. + .. Executable Statements .. +*/ + bfrac = brcomp(a,b,x,y); + if(bfrac == 0.0e0) return bfrac; + c = 1.0e0+*lambda; + c0 = *b/ *a; + c1 = 1.0e0+1.0e0/ *a; + yp1 = *y+1.0e0; + n = 0.0e0; + p = 1.0e0; + s = *a+1.0e0; + an = 0.0e0; + bn = anp1 = 1.0e0; + bnp1 = c/c1; + r = c1/c; +S10: +/* + CONTINUED FRACTION CALCULATION +*/ + n += 1.0e0; + t = n/ *a; + w = n*(*b-n)**x; + e = *a/s; + alpha = p*(p+c0)*e*e*(w**x); + e = (1.0e0+t)/(c1+t+t); + beta = n+w/s+e*(c+n*yp1); + p = 1.0e0+t; + s += 2.0e0; +/* + UPDATE AN, BN, ANP1, AND BNP1 +*/ + t = alpha*an+beta*anp1; + an = anp1; + anp1 = t; + t = alpha*bn+beta*bnp1; + bn = bnp1; + bnp1 = t; + r0 = r; + r = anp1/bnp1; + if(fabs(r-r0) <= *eps*r) goto S20; +/* + RESCALE AN, BN, ANP1, AND BNP1 +*/ + an /= bnp1; + bn /= bnp1; + anp1 = r; + bnp1 = 1.0e0; + goto S10; +S20: +/* + TERMINATION +*/ + bfrac *= r; + return bfrac; +} +void bgrat(double *a,double *b,double *x,double *y,double *w, + double *eps,int *ierr) +/* +----------------------------------------------------------------------- + ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B. + THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED + THAT A .GE. 15 AND B .LE. 1. EPS IS THE TOLERANCE USED. + IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +----------------------------------------------------------------------- +*/ +{ +static double bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,t2,u,v,z; +static int i,n,nm1; +static double c[30],d[30],T1; +/* + .. + .. Executable Statements .. +*/ + bm1 = *b-0.5e0-0.5e0; + nu = *a+0.5e0*bm1; + if(*y > 0.375e0) goto S10; + T1 = -*y; + lnx = alnrel(&T1); + goto S20; +S10: + lnx = log(*x); +S20: + z = -(nu*lnx); + if(*b*z == 0.0e0) goto S70; +/* + COMPUTATION OF THE EXPANSION + SET R = EXP(-Z)*Z**B/GAMMA(B) +*/ + r = *b*(1.0e0+gam1(b))*exp(*b*log(z)); + r *= (exp(*a*lnx)*exp(0.5e0*bm1*lnx)); + u = algdiv(b,a)+*b*log(nu); + u = r*exp(-u); + if(u == 0.0e0) goto S70; + grat1(b,&z,&r,&p,&q,eps); + v = 0.25e0*pow(1.0e0/nu,2.0); + t2 = 0.25e0*lnx*lnx; + l = *w/u; + j = q/r; + sum = j; + t = cn = 1.0e0; + n2 = 0.0e0; + for(n=1; n<=30; n++) { + bp2n = *b+n2; + j = (bp2n*(bp2n+1.0e0)*j+(z+bp2n+1.0e0)*t)*v; + n2 += 2.0e0; + t *= t2; + cn /= (n2*(n2+1.0e0)); + c[n-1] = cn; + s = 0.0e0; + if(n == 1) goto S40; + nm1 = n-1; + coef = *b-(double)n; + for(i=1; i<=nm1; i++) { + s += (coef*c[i-1]*d[n-i-1]); + coef += *b; + } +S40: + d[n-1] = bm1*cn+s/(double)n; + dj = d[n-1]*j; + sum += dj; + if(sum <= 0.0e0) goto S70; + if(fabs(dj) <= *eps*(sum+l)) goto S60; + } +S60: +/* + ADD THE RESULTS TO W +*/ + *ierr = 0; + *w += (u*sum); + return; +S70: +/* + THE EXPANSION CANNOT BE COMPUTED +*/ + *ierr = 1; + return; +} +double bpser(double *a,double *b,double *x,double *eps) +/* +----------------------------------------------------------------------- + POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1 + OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED. +----------------------------------------------------------------------- +*/ +{ +static double bpser,a0,apb,b0,c,n,sum,t,tol,u,w,z; +static int i,m; +/* + .. + .. Executable Statements .. +*/ + bpser = 0.0e0; + if(*x == 0.0e0) return bpser; +/* +----------------------------------------------------------------------- + COMPUTE THE FACTOR X**A/(A*BETA(A,B)) +----------------------------------------------------------------------- +*/ + a0 = fifdmin1(*a,*b); + if(a0 < 1.0e0) goto S10; + z = *a*log(*x)-betaln(a,b); + bpser = exp(z)/ *a; + goto S100; +S10: + b0 = fifdmax1(*a,*b); + if(b0 >= 8.0e0) goto S90; + if(b0 > 1.0e0) goto S40; +/* + PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1 +*/ + bpser = pow(*x,*a); + if(bpser == 0.0e0) return bpser; + apb = *a+*b; + if(apb > 1.0e0) goto S20; + z = 1.0e0+gam1(&apb); + goto S30; +S20: + u = *a+*b-1.e0; + z = (1.0e0+gam1(&u))/apb; +S30: + c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; + bpser *= (c*(*b/apb)); + goto S100; +S40: +/* + PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8 +*/ + u = gamln1(&a0); + m = b0-1.0e0; + if(m < 1) goto S60; + c = 1.0e0; + for(i=1; i<=m; i++) { + b0 -= 1.0e0; + c *= (b0/(a0+b0)); + } + u = log(c)+u; +S60: + z = *a*log(*x)-u; + b0 -= 1.0e0; + apb = a0+b0; + if(apb > 1.0e0) goto S70; + t = 1.0e0+gam1(&apb); + goto S80; +S70: + u = a0+b0-1.e0; + t = (1.0e0+gam1(&u))/apb; +S80: + bpser = exp(z)*(a0/ *a)*(1.0e0+gam1(&b0))/t; + goto S100; +S90: +/* + PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 +*/ + u = gamln1(&a0)+algdiv(&a0,&b0); + z = *a*log(*x)-u; + bpser = a0/ *a*exp(z); +S100: + if(bpser == 0.0e0 || *a <= 0.1e0**eps) return bpser; +/* +----------------------------------------------------------------------- + COMPUTE THE SERIES +----------------------------------------------------------------------- +*/ + sum = n = 0.0e0; + c = 1.0e0; + tol = *eps/ *a; +S110: + n += 1.0e0; + c *= ((0.5e0+(0.5e0-*b/n))**x); + w = c/(*a+n); + sum += w; + if(fabs(w) > tol) goto S110; + bpser *= (1.0e0+*a*sum); + return bpser; +} +void bratio(double *a,double *b,double *x,double *y,double *w, + double *w1,int *ierr) +/* +----------------------------------------------------------------------- + + EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B) + + -------------------- + + IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1 + AND Y = 1 - X. BRATIO ASSIGNS W AND W1 THE VALUES + + W = IX(A,B) + W1 = 1 - IX(A,B) + + IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. + IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND + W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED, + THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO + ONE OF THE FOLLOWING VALUES ... + + IERR = 1 IF A OR B IS NEGATIVE + IERR = 2 IF A = B = 0 + IERR = 3 IF X .LT. 0 OR X .GT. 1 + IERR = 4 IF Y .LT. 0 OR Y .GT. 1 + IERR = 5 IF X + Y .NE. 1 + IERR = 6 IF X = A = 0 + IERR = 7 IF Y = B = 0 + +-------------------- + WRITTEN BY ALFRED H. MORRIS, JR. + NAVAL SURFACE WARFARE CENTER + DAHLGREN, VIRGINIA + REVISED ... NOV 1991 +----------------------------------------------------------------------- +*/ +{ +static int K1 = 1; +static double a0,b0,eps,lambda,t,x0,y0,z; +static int ierr1,ind,n; +static double T2,T3,T4,T5; +/* + .. + .. Executable Statements .. +*/ +/* + ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST + FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0 +*/ + eps = spmpar(&K1); + *w = *w1 = 0.0e0; + if(*a < 0.0e0 || *b < 0.0e0) goto S270; + if(*a == 0.0e0 && *b == 0.0e0) goto S280; + if(*x < 0.0e0 || *x > 1.0e0) goto S290; + if(*y < 0.0e0 || *y > 1.0e0) goto S300; + z = *x+*y-0.5e0-0.5e0; + if(fabs(z) > 3.0e0*eps) goto S310; + *ierr = 0; + if(*x == 0.0e0) goto S210; + if(*y == 0.0e0) goto S230; + if(*a == 0.0e0) goto S240; + if(*b == 0.0e0) goto S220; + eps = fifdmax1(eps,1.e-15); + if(fifdmax1(*a,*b) < 1.e-3*eps) goto S260; + ind = 0; + a0 = *a; + b0 = *b; + x0 = *x; + y0 = *y; + if(fifdmin1(a0,b0) > 1.0e0) goto S40; +/* + PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1 +*/ + if(*x <= 0.5e0) goto S10; + ind = 1; + a0 = *b; + b0 = *a; + x0 = *y; + y0 = *x; +S10: + if(b0 < fifdmin1(eps,eps*a0)) goto S90; + if(a0 < fifdmin1(eps,eps*b0) && b0*x0 <= 1.0e0) goto S100; + if(fifdmax1(a0,b0) > 1.0e0) goto S20; + if(a0 >= fifdmin1(0.2e0,b0)) goto S110; + if(pow(x0,a0) <= 0.9e0) goto S110; + if(x0 >= 0.3e0) goto S120; + n = 20; + goto S140; +S20: + if(b0 <= 1.0e0) goto S110; + if(x0 >= 0.3e0) goto S120; + if(x0 >= 0.1e0) goto S30; + if(pow(x0*b0,a0) <= 0.7e0) goto S110; +S30: + if(b0 > 15.0e0) goto S150; + n = 20; + goto S140; +S40: +/* + PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1 +*/ + if(*a > *b) goto S50; + lambda = *a-(*a+*b)**x; + goto S60; +S50: + lambda = (*a+*b)**y-*b; +S60: + if(lambda >= 0.0e0) goto S70; + ind = 1; + a0 = *b; + b0 = *a; + x0 = *y; + y0 = *x; + lambda = fabs(lambda); +S70: + if(b0 < 40.0e0 && b0*x0 <= 0.7e0) goto S110; + if(b0 < 40.0e0) goto S160; + if(a0 > b0) goto S80; + if(a0 <= 100.0e0) goto S130; + if(lambda > 0.03e0*a0) goto S130; + goto S200; +S80: + if(b0 <= 100.0e0) goto S130; + if(lambda > 0.03e0*b0) goto S130; + goto S200; +S90: +/* + EVALUATION OF THE APPROPRIATE ALGORITHM +*/ + *w = fpser(&a0,&b0,&x0,&eps); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S100: + *w1 = apser(&a0,&b0,&x0,&eps); + *w = 0.5e0+(0.5e0-*w1); + goto S250; +S110: + *w = bpser(&a0,&b0,&x0,&eps); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S120: + *w1 = bpser(&b0,&a0,&y0,&eps); + *w = 0.5e0+(0.5e0-*w1); + goto S250; +S130: + T2 = 15.0e0*eps; + *w = bfrac(&a0,&b0,&x0,&y0,&lambda,&T2); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S140: + *w1 = bup(&b0,&a0,&y0,&x0,&n,&eps); + b0 += (double)n; +S150: + T3 = 15.0e0*eps; + bgrat(&b0,&a0,&y0,&x0,w1,&T3,&ierr1); + *w = 0.5e0+(0.5e0-*w1); + goto S250; +S160: + n = b0; + b0 -= (double)n; + if(b0 != 0.0e0) goto S170; + n -= 1; + b0 = 1.0e0; +S170: + *w = bup(&b0,&a0,&y0,&x0,&n,&eps); + if(x0 > 0.7e0) goto S180; + *w += bpser(&a0,&b0,&x0,&eps); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S180: + if(a0 > 15.0e0) goto S190; + n = 20; + *w += bup(&a0,&b0,&x0,&y0,&n,&eps); + a0 += (double)n; +S190: + T4 = 15.0e0*eps; + bgrat(&a0,&b0,&x0,&y0,w,&T4,&ierr1); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S200: + T5 = 100.0e0*eps; + *w = basym(&a0,&b0,&lambda,&T5); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S210: +/* + TERMINATION OF THE PROCEDURE +*/ + if(*a == 0.0e0) goto S320; +S220: + *w = 0.0e0; + *w1 = 1.0e0; + return; +S230: + if(*b == 0.0e0) goto S330; +S240: + *w = 1.0e0; + *w1 = 0.0e0; + return; +S250: + if(ind == 0) return; + t = *w; + *w = *w1; + *w1 = t; + return; +S260: +/* + PROCEDURE FOR A AND B .LT. 1.E-3*EPS +*/ + *w = *b/(*a+*b); + *w1 = *a/(*a+*b); + return; +S270: +/* + ERROR RETURN +*/ + *ierr = 1; + return; +S280: + *ierr = 2; + return; +S290: + *ierr = 3; + return; +S300: + *ierr = 4; + return; +S310: + *ierr = 5; + return; +S320: + *ierr = 6; + return; +S330: + *ierr = 7; + return; +} +double brcmp1(int *mu,double *a,double *b,double *x,double *y) +/* +----------------------------------------------------------------------- + EVALUATION OF EXP(MU) * (X**A*Y**B/BETA(A,B)) +----------------------------------------------------------------------- +*/ +{ +static double Const = .398942280401433e0; +static double brcmp1,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z; +static int i,n; +/* +----------------- + CONST = 1/SQRT(2*PI) +----------------- +*/ +static double T1,T2,T3,T4; +/* + .. + .. Executable Statements .. +*/ + a0 = fifdmin1(*a,*b); + if(a0 >= 8.0e0) goto S130; + if(*x > 0.375e0) goto S10; + lnx = log(*x); + T1 = -*x; + lny = alnrel(&T1); + goto S30; +S10: + if(*y > 0.375e0) goto S20; + T2 = -*y; + lnx = alnrel(&T2); + lny = log(*y); + goto S30; +S20: + lnx = log(*x); + lny = log(*y); +S30: + z = *a*lnx+*b*lny; + if(a0 < 1.0e0) goto S40; + z -= betaln(a,b); + brcmp1 = esum(mu,&z); + return brcmp1; +S40: +/* +----------------------------------------------------------------------- + PROCEDURE FOR A .LT. 1 OR B .LT. 1 +----------------------------------------------------------------------- +*/ + b0 = fifdmax1(*a,*b); + if(b0 >= 8.0e0) goto S120; + if(b0 > 1.0e0) goto S70; +/* + ALGORITHM FOR B0 .LE. 1 +*/ + brcmp1 = esum(mu,&z); + if(brcmp1 == 0.0e0) return brcmp1; + apb = *a+*b; + if(apb > 1.0e0) goto S50; + z = 1.0e0+gam1(&apb); + goto S60; +S50: + u = *a+*b-1.e0; + z = (1.0e0+gam1(&u))/apb; +S60: + c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; + brcmp1 = brcmp1*(a0*c)/(1.0e0+a0/b0); + return brcmp1; +S70: +/* + ALGORITHM FOR 1 .LT. B0 .LT. 8 +*/ + u = gamln1(&a0); + n = b0-1.0e0; + if(n < 1) goto S90; + c = 1.0e0; + for(i=1; i<=n; i++) { + b0 -= 1.0e0; + c *= (b0/(a0+b0)); + } + u = log(c)+u; +S90: + z -= u; + b0 -= 1.0e0; + apb = a0+b0; + if(apb > 1.0e0) goto S100; + t = 1.0e0+gam1(&apb); + goto S110; +S100: + u = a0+b0-1.e0; + t = (1.0e0+gam1(&u))/apb; +S110: + brcmp1 = a0*esum(mu,&z)*(1.0e0+gam1(&b0))/t; + return brcmp1; +S120: +/* + ALGORITHM FOR B0 .GE. 8 +*/ + u = gamln1(&a0)+algdiv(&a0,&b0); + T3 = z-u; + brcmp1 = a0*esum(mu,&T3); + return brcmp1; +S130: +/* +----------------------------------------------------------------------- + PROCEDURE FOR A .GE. 8 AND B .GE. 8 +----------------------------------------------------------------------- +*/ + if(*a > *b) goto S140; + h = *a/ *b; + x0 = h/(1.0e0+h); + y0 = 1.0e0/(1.0e0+h); + lambda = *a-(*a+*b)**x; + goto S150; +S140: + h = *b/ *a; + x0 = 1.0e0/(1.0e0+h); + y0 = h/(1.0e0+h); + lambda = (*a+*b)**y-*b; +S150: + e = -(lambda/ *a); + if(fabs(e) > 0.6e0) goto S160; + u = rlog1(&e); + goto S170; +S160: + u = e-log(*x/x0); +S170: + e = lambda/ *b; + if(fabs(e) > 0.6e0) goto S180; + v = rlog1(&e); + goto S190; +S180: + v = e-log(*y/y0); +S190: + T4 = -(*a*u+*b*v); + z = esum(mu,&T4); + brcmp1 = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b)); + return brcmp1; +} +double brcomp(double *a,double *b,double *x,double *y) +/* +----------------------------------------------------------------------- + EVALUATION OF X**A*Y**B/BETA(A,B) +----------------------------------------------------------------------- +*/ +{ +static double Const = .398942280401433e0; +static double brcomp,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z; +static int i,n; +/* +----------------- + CONST = 1/SQRT(2*PI) +----------------- +*/ +static double T1,T2; +/* + .. + .. Executable Statements .. +*/ + brcomp = 0.0e0; + if(*x == 0.0e0 || *y == 0.0e0) return brcomp; + a0 = fifdmin1(*a,*b); + if(a0 >= 8.0e0) goto S130; + if(*x > 0.375e0) goto S10; + lnx = log(*x); + T1 = -*x; + lny = alnrel(&T1); + goto S30; +S10: + if(*y > 0.375e0) goto S20; + T2 = -*y; + lnx = alnrel(&T2); + lny = log(*y); + goto S30; +S20: + lnx = log(*x); + lny = log(*y); +S30: + z = *a*lnx+*b*lny; + if(a0 < 1.0e0) goto S40; + z -= betaln(a,b); + brcomp = exp(z); + return brcomp; +S40: +/* +----------------------------------------------------------------------- + PROCEDURE FOR A .LT. 1 OR B .LT. 1 +----------------------------------------------------------------------- +*/ + b0 = fifdmax1(*a,*b); + if(b0 >= 8.0e0) goto S120; + if(b0 > 1.0e0) goto S70; +/* + ALGORITHM FOR B0 .LE. 1 +*/ + brcomp = exp(z); + if(brcomp == 0.0e0) return brcomp; + apb = *a+*b; + if(apb > 1.0e0) goto S50; + z = 1.0e0+gam1(&apb); + goto S60; +S50: + u = *a+*b-1.e0; + z = (1.0e0+gam1(&u))/apb; +S60: + c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; + brcomp = brcomp*(a0*c)/(1.0e0+a0/b0); + return brcomp; +S70: +/* + ALGORITHM FOR 1 .LT. B0 .LT. 8 +*/ + u = gamln1(&a0); + n = b0-1.0e0; + if(n < 1) goto S90; + c = 1.0e0; + for(i=1; i<=n; i++) { + b0 -= 1.0e0; + c *= (b0/(a0+b0)); + } + u = log(c)+u; +S90: + z -= u; + b0 -= 1.0e0; + apb = a0+b0; + if(apb > 1.0e0) goto S100; + t = 1.0e0+gam1(&apb); + goto S110; +S100: + u = a0+b0-1.e0; + t = (1.0e0+gam1(&u))/apb; +S110: + brcomp = a0*exp(z)*(1.0e0+gam1(&b0))/t; + return brcomp; +S120: +/* + ALGORITHM FOR B0 .GE. 8 +*/ + u = gamln1(&a0)+algdiv(&a0,&b0); + brcomp = a0*exp(z-u); + return brcomp; +S130: +/* +----------------------------------------------------------------------- + PROCEDURE FOR A .GE. 8 AND B .GE. 8 +----------------------------------------------------------------------- +*/ + if(*a > *b) goto S140; + h = *a/ *b; + x0 = h/(1.0e0+h); + y0 = 1.0e0/(1.0e0+h); + lambda = *a-(*a+*b)**x; + goto S150; +S140: + h = *b/ *a; + x0 = 1.0e0/(1.0e0+h); + y0 = h/(1.0e0+h); + lambda = (*a+*b)**y-*b; +S150: + e = -(lambda/ *a); + if(fabs(e) > 0.6e0) goto S160; + u = rlog1(&e); + goto S170; +S160: + u = e-log(*x/x0); +S170: + e = lambda/ *b; + if(fabs(e) > 0.6e0) goto S180; + v = rlog1(&e); + goto S190; +S180: + v = e-log(*y/y0); +S190: + z = exp(-(*a*u+*b*v)); + brcomp = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b)); + return brcomp; +} +double bup(double *a,double *b,double *x,double *y,int *n,double *eps) +/* +----------------------------------------------------------------------- + EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER. + EPS IS THE TOLERANCE USED. +----------------------------------------------------------------------- +*/ +{ +static int K1 = 1; +static int K2 = 0; +static double bup,ap1,apb,d,l,r,t,w; +static int i,k,kp1,mu,nm1; +/* + .. + .. Executable Statements .. +*/ +/* + OBTAIN THE SCALING FACTOR EXP(-MU) AND + EXP(MU)*(X**A*Y**B/BETA(A,B))/A +*/ + apb = *a+*b; + ap1 = *a+1.0e0; + mu = 0; + d = 1.0e0; + if(*n == 1 || *a < 1.0e0) goto S10; + if(apb < 1.1e0*ap1) goto S10; + mu = fabs(exparg(&K1)); + k = exparg(&K2); + if(k < mu) mu = k; + t = mu; + d = exp(-t); +S10: + bup = brcmp1(&mu,a,b,x,y)/ *a; + if(*n == 1 || bup == 0.0e0) return bup; + nm1 = *n-1; + w = d; +/* + LET K BE THE INDEX OF THE MAXIMUM TERM +*/ + k = 0; + if(*b <= 1.0e0) goto S50; + if(*y > 1.e-4) goto S20; + k = nm1; + goto S30; +S20: + r = (*b-1.0e0)**x/ *y-*a; + if(r < 1.0e0) goto S50; + k = t = nm1; + if(r < t) k = r; +S30: +/* + ADD THE INCREASING TERMS OF THE SERIES +*/ + for(i=1; i<=k; i++) { + l = i-1; + d = (apb+l)/(ap1+l)**x*d; + w += d; + } + if(k == nm1) goto S70; +S50: +/* + ADD THE REMAINING TERMS OF THE SERIES +*/ + kp1 = k+1; + for(i=kp1; i<=nm1; i++) { + l = i-1; + d = (apb+l)/(ap1+l)**x*d; + w += d; + if(d <= *eps*w) goto S70; + } +S70: +/* + TERMINATE THE PROCEDURE +*/ + bup *= w; + return bup; +} +void cdf_bet(int *which,double *p,double *q,double *x,double *y, + double *a,double *b,int *status,double *bound) +/********************************************************************** + + void cdf_bet(int *which,double *p,double *q,double *x,double *y, + double *a,double *b,int *status,double *bound) + + Cumulative Distribution Function + BETa Distribution + + + Function + + + Calculates any one parameter of the beta distribution given + values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,Y,A and B + iwhich = 2 : Calculate X and Y from P,Q,A and B + iwhich = 3 : Calculate A from P,Q,X,Y and B + iwhich = 4 : Calculate B from P,Q,X,Y and A + + P <--> The integral from 0 to X of the chi-square + distribution. + Input range: [0, 1]. + + Q <--> 1-P. + Input range: [0, 1]. + P + Q = 1.0. + + X <--> Upper limit of integration of beta density. + Input range: [0,1]. + Search range: [0,1] + + Y <--> 1-X. + Input range: [0,1]. + Search range: [0,1] + X + Y = 1.0. + + A <--> The first parameter of the beta density. + Input range: (0, +infinity). + Search range: [1D-300,1D300] + + B <--> The second parameter of the beta density. + Input range: (0, +infinity). + Search range: [1D-300,1D300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if X + Y .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Cumulative distribution function (P) is calculated directly by + code associated with the following reference. + + DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant + Digit Computation of the Incomplete Beta Function Ratios. ACM + Trans. Math. Softw. 18 (1993), 360-373. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + Note + + + The beta density is proportional to + t^(A-1) * (1-t)^(B-1) + +**********************************************************************/ +{ +#define tol (1.0e-8) +#define atol (1.0e-50) +#define zero (1.0e-300) +#define inf 1.0e300 +#define one 1.0e0 +static int K1 = 1; +static double K2 = 0.0e0; +static double K3 = 1.0e0; +static double K8 = 0.5e0; +static double K9 = 5.0e0; +static double fx,xhi,xlo,cum,ccum,xy,pq; +static unsigned long qhi,qleft,qporq; +static double T4,T5,T6,T7,T10,T11,T12,T13,T14,T15; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q < 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S150; +/* + X +*/ + if(!(*x < 0.0e0 || *x > 1.0e0)) goto S140; + if(!(*x < 0.0e0)) goto S120; + *bound = 0.0e0; + goto S130; +S120: + *bound = 1.0e0; +S130: + *status = -4; + return; +S150: +S140: + if(*which == 2) goto S190; +/* + Y +*/ + if(!(*y < 0.0e0 || *y > 1.0e0)) goto S180; + if(!(*y < 0.0e0)) goto S160; + *bound = 0.0e0; + goto S170; +S160: + *bound = 1.0e0; +S170: + *status = -5; + return; +S190: +S180: + if(*which == 3) goto S210; +/* + A +*/ + if(!(*a <= 0.0e0)) goto S200; + *bound = 0.0e0; + *status = -6; + return; +S210: +S200: + if(*which == 4) goto S230; +/* + B +*/ + if(!(*b <= 0.0e0)) goto S220; + *bound = 0.0e0; + *status = -7; + return; +S230: +S220: + if(*which == 1) goto S270; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260; + if(!(pq < 0.0e0)) goto S240; + *bound = 0.0e0; + goto S250; +S240: + *bound = 1.0e0; +S250: + *status = 3; + return; +S270: +S260: + if(*which == 2) goto S310; +/* + X + Y +*/ + xy = *x+*y; + if(!(fabs(xy-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300; + if(!(xy < 0.0e0)) goto S280; + *bound = 0.0e0; + goto S290; +S280: + *bound = 1.0e0; +S290: + *status = 4; + return; +S310: +S300: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P and Q +*/ + cumbet(x,y,a,b,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating X and Y +*/ + T4 = atol; + T5 = tol; + dstzr(&K2,&K3,&T4,&T5); + if(!qporq) goto S340; + *status = 0; + dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi); + *y = one-*x; +S320: + if(!(*status == 1)) goto S330; + cumbet(x,y,a,b,&cum,&ccum); + fx = cum-*p; + dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi); + *y = one-*x; + goto S320; +S330: + goto S370; +S340: + *status = 0; + dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi); + *x = one-*y; +S350: + if(!(*status == 1)) goto S360; + cumbet(x,y,a,b,&cum,&ccum); + fx = ccum-*q; + dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi); + *x = one-*y; + goto S350; +S370: +S360: + if(!(*status == -1)) goto S400; + if(!qleft) goto S380; + *status = 1; + *bound = 0.0e0; + goto S390; +S380: + *status = 2; + *bound = 1.0e0; +S400: +S390: + ; + } + else if(3 == *which) { +/* + Computing A +*/ + *a = 5.0e0; + T6 = zero; + T7 = inf; + T10 = atol; + T11 = tol; + dstinv(&T6,&T7,&K8,&K8,&K9,&T10,&T11); + *status = 0; + dinvr(status,a,&fx,&qleft,&qhi); +S410: + if(!(*status == 1)) goto S440; + cumbet(x,y,a,b,&cum,&ccum); + if(!qporq) goto S420; + fx = cum-*p; + goto S430; +S420: + fx = ccum-*q; +S430: + dinvr(status,a,&fx,&qleft,&qhi); + goto S410; +S440: + if(!(*status == -1)) goto S470; + if(!qleft) goto S450; + *status = 1; + *bound = zero; + goto S460; +S450: + *status = 2; + *bound = inf; +S470: +S460: + ; + } + else if(4 == *which) { +/* + Computing B +*/ + *b = 5.0e0; + T12 = zero; + T13 = inf; + T14 = atol; + T15 = tol; + dstinv(&T12,&T13,&K8,&K8,&K9,&T14,&T15); + *status = 0; + dinvr(status,b,&fx,&qleft,&qhi); +S480: + if(!(*status == 1)) goto S510; + cumbet(x,y,a,b,&cum,&ccum); + if(!qporq) goto S490; + fx = cum-*p; + goto S500; +S490: + fx = ccum-*q; +S500: + dinvr(status,b,&fx,&qleft,&qhi); + goto S480; +S510: + if(!(*status == -1)) goto S540; + if(!qleft) goto S520; + *status = 1; + *bound = zero; + goto S530; +S520: + *status = 2; + *bound = inf; +S530: + ; + } +S540: + return; +#undef tol +#undef atol +#undef zero +#undef inf +#undef one +} +void cdf_bin(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) +/********************************************************************** + + void cdf_bin(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) + + Cumulative Distribution Function + BINomial distribution + + + Function + + + Calculates any one parameter of the binomial + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR + iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR + iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR + iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN + + P <--> The cumulation from 0 to S of the binomial distribution. + (Probablility of S or fewer successes in XN trials each + with probability of success PR.) + Input range: [0,1]. + + Q <--> 1-P. + Input range: [0, 1]. + P + Q = 1.0. + + S <--> The number of successes observed. + Input range: [0, XN] + Search range: [0, XN] + + XN <--> The number of binomial trials. + Input range: (0, +infinity). + Search range: [1E-300, 1E300] + + PR <--> The probability of success in each binomial trial. + Input range: [0,1]. + Search range: [0,1] + + OMPR <--> 1-PR + Input range: [0,1]. + Search range: [0,1] + PR + OMPR = 1.0 + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if PR + OMPR .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.24 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the binomial + distribution to the cumulative incomplete beta distribution. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + +**********************************************************************/ +{ +#define atol (1.0e-50) +#define tol (1.0e-8) +#define zero (1.0e-300) +#define inf 1.0e300 +#define one 1.0e0 +static int K1 = 1; +static double K2 = 0.0e0; +static double K3 = 0.5e0; +static double K4 = 5.0e0; +static double K11 = 1.0e0; +static double fx,xhi,xlo,cum,ccum,pq,prompr; +static unsigned long qhi,qleft,qporq; +static double T5,T6,T7,T8,T9,T10,T12,T13; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 && *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q < 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 3) goto S130; +/* + XN +*/ + if(!(*xn <= 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -5; + return; +S130: +S120: + if(*which == 2) goto S170; +/* + S +*/ + if(!(*s < 0.0e0 || *which != 3 && *s > *xn)) goto S160; + if(!(*s < 0.0e0)) goto S140; + *bound = 0.0e0; + goto S150; +S140: + *bound = *xn; +S150: + *status = -4; + return; +S170: +S160: + if(*which == 4) goto S210; +/* + PR +*/ + if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S200; + if(!(*pr < 0.0e0)) goto S180; + *bound = 0.0e0; + goto S190; +S180: + *bound = 1.0e0; +S190: + *status = -6; + return; +S210: +S200: + if(*which == 4) goto S250; +/* + OMPR +*/ + if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S240; + if(!(*ompr < 0.0e0)) goto S220; + *bound = 0.0e0; + goto S230; +S220: + *bound = 1.0e0; +S230: + *status = -7; + return; +S250: +S240: + if(*which == 1) goto S290; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S280; + if(!(pq < 0.0e0)) goto S260; + *bound = 0.0e0; + goto S270; +S260: + *bound = 1.0e0; +S270: + *status = 3; + return; +S290: +S280: + if(*which == 4) goto S330; +/* + PR + OMPR +*/ + prompr = *pr+*ompr; + if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S320; + if(!(prompr < 0.0e0)) goto S300; + *bound = 0.0e0; + goto S310; +S300: + *bound = 1.0e0; +S310: + *status = 4; + return; +S330: +S320: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumbin(s,xn,pr,ompr,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating S +*/ + *s = 5.0e0; + T5 = atol; + T6 = tol; + dstinv(&K2,xn,&K3,&K3,&K4,&T5,&T6); + *status = 0; + dinvr(status,s,&fx,&qleft,&qhi); +S340: + if(!(*status == 1)) goto S370; + cumbin(s,xn,pr,ompr,&cum,&ccum); + if(!qporq) goto S350; + fx = cum-*p; + goto S360; +S350: + fx = ccum-*q; +S360: + dinvr(status,s,&fx,&qleft,&qhi); + goto S340; +S370: + if(!(*status == -1)) goto S400; + if(!qleft) goto S380; + *status = 1; + *bound = 0.0e0; + goto S390; +S380: + *status = 2; + *bound = *xn; +S400: +S390: + ; + } + else if(3 == *which) { +/* + Calculating XN +*/ + *xn = 5.0e0; + T7 = zero; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); + *status = 0; + dinvr(status,xn,&fx,&qleft,&qhi); +S410: + if(!(*status == 1)) goto S440; + cumbin(s,xn,pr,ompr,&cum,&ccum); + if(!qporq) goto S420; + fx = cum-*p; + goto S430; +S420: + fx = ccum-*q; +S430: + dinvr(status,xn,&fx,&qleft,&qhi); + goto S410; +S440: + if(!(*status == -1)) goto S470; + if(!qleft) goto S450; + *status = 1; + *bound = zero; + goto S460; +S450: + *status = 2; + *bound = inf; +S470: +S460: + ; + } + else if(4 == *which) { +/* + Calculating PR and OMPR +*/ + T12 = atol; + T13 = tol; + dstzr(&K2,&K11,&T12,&T13); + if(!qporq) goto S500; + *status = 0; + dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); + *ompr = one-*pr; +S480: + if(!(*status == 1)) goto S490; + cumbin(s,xn,pr,ompr,&cum,&ccum); + fx = cum-*p; + dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); + *ompr = one-*pr; + goto S480; +S490: + goto S530; +S500: + *status = 0; + dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); + *pr = one-*ompr; +S510: + if(!(*status == 1)) goto S520; + cumbin(s,xn,pr,ompr,&cum,&ccum); + fx = ccum-*q; + dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); + *pr = one-*ompr; + goto S510; +S530: +S520: + if(!(*status == -1)) goto S560; + if(!qleft) goto S540; + *status = 1; + *bound = 0.0e0; + goto S550; +S540: + *status = 2; + *bound = 1.0e0; +S550: + ; + } +S560: + return; +#undef atol +#undef tol +#undef zero +#undef inf +#undef one +} +void cdf_chi(int *which,double *p,double *q,double *x,double *df, + int *status,double *bound) +/********************************************************************** + + void cdf_chi(int *which,double *p,double *q,double *x,double *df, + int *status,double *bound) + + Cumulative Distribution Function + CHI-Square distribution + + + Function + + + Calculates any one parameter of the chi-square + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next three argument + values is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from X and DF + iwhich = 2 : Calculate X from P,Q and DF + iwhich = 3 : Calculate DF from P,Q and X + + P <--> The integral from 0 to X of the chi-square + distribution. + Input range: [0, 1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X <--> Upper limit of integration of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E300] + + DF <--> Degrees of freedom of the + chi-square distribution. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 10 indicates error returned from cumgam. See + references in cdf_gam + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.19 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the chisqure + distribution to the incomplete distribution. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tol (1.0e-8) +#define atol (1.0e-50) +#define zero (1.0e-300) +#define inf 1.0e300 +static int K1 = 1; +static double K2 = 0.0e0; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double fx,cum,ccum,pq,porq; +static unsigned long qhi,qleft,qporq; +static double T3,T6,T7,T8,T9,T10,T11; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 3)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 3.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + X +*/ + if(!(*x < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + DF +*/ + if(!(*df <= 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 1) goto S190; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180; + if(!(pq < 0.0e0)) goto S160; + *bound = 0.0e0; + goto S170; +S160: + *bound = 1.0e0; +S170: + *status = 3; + return; +S190: +S180: + if(*which == 1) goto S220; +/* + Select the minimum of P or Q +*/ + qporq = *p <= *q; + if(!qporq) goto S200; + porq = *p; + goto S210; +S200: + porq = *q; +S220: +S210: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P and Q +*/ + *status = 0; + cumchi(x,df,p,q); + if(porq > 1.5e0) { + *status = 10; + return; + } + } + else if(2 == *which) { +/* + Calculating X +*/ + *x = 5.0e0; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,x,&fx,&qleft,&qhi); +S230: + if(!(*status == 1)) goto S270; + cumchi(x,df,&cum,&ccum); + if(!qporq) goto S240; + fx = cum-*p; + goto S250; +S240: + fx = ccum-*q; +S250: + if(!(fx+porq > 1.5e0)) goto S260; + *status = 10; + return; +S260: + dinvr(status,x,&fx,&qleft,&qhi); + goto S230; +S270: + if(!(*status == -1)) goto S300; + if(!qleft) goto S280; + *status = 1; + *bound = 0.0e0; + goto S290; +S280: + *status = 2; + *bound = inf; +S300: +S290: + ; + } + else if(3 == *which) { +/* + Calculating DF +*/ + *df = 5.0e0; + T8 = zero; + T9 = inf; + T10 = atol; + T11 = tol; + dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); + *status = 0; + dinvr(status,df,&fx,&qleft,&qhi); +S310: + if(!(*status == 1)) goto S350; + cumchi(x,df,&cum,&ccum); + if(!qporq) goto S320; + fx = cum-*p; + goto S330; +S320: + fx = ccum-*q; +S330: + if(!(fx+porq > 1.5e0)) goto S340; + *status = 10; + return; +S340: + dinvr(status,df,&fx,&qleft,&qhi); + goto S310; +S350: + if(!(*status == -1)) goto S380; + if(!qleft) goto S360; + *status = 1; + *bound = zero; + goto S370; +S360: + *status = 2; + *bound = inf; +S370: + ; + } +S380: + return; +#undef tol +#undef atol +#undef zero +#undef inf +} +void cdf_chn(int *which,double *p,double *q,double *x,double *df, + double *pnonc,int *status,double *bound) +/********************************************************************** + + void cdf_chn(int *which,double *p,double *q,double *x,double *df, + double *pnonc,int *status,double *bound) + + Cumulative Distribution Function + Non-central Chi-Square + + + Function + + + Calculates any one parameter of the non-central chi-square + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next three argument + values is to be calculated from the others. + Input range: 1..4 + iwhich = 1 : Calculate P and Q from X and DF + iwhich = 2 : Calculate X from P,DF and PNONC + iwhich = 3 : Calculate DF from P,X and PNONC + iwhich = 3 : Calculate PNONC from P,X and DF + + P <--> The integral from 0 to X of the non-central chi-square + distribution. + Input range: [0, 1-1E-16). + + Q <--> 1-P. + Q is not used by this subroutine and is only included + for similarity with other cdf_* routines. + + X <--> Upper limit of integration of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E300] + + DF <--> Degrees of freedom of the non-central + chi-square distribution. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + PNONC <--> Non-centrality parameter of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E4] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.25 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to compute the cumulative + distribution function. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + WARNING + + The computation time required for this routine is proportional + to the noncentrality parameter (PNONC). Very large values of + this parameter can consume immense computer resources. This is + why the search range is bounded by 10,000. + +**********************************************************************/ +{ +#define tent4 1.0e4 +#define tol (1.0e-8) +#define atol (1.0e-50) +#define zero (1.0e-300) +#define one (1.0e0-1.0e-16) +#define inf 1.0e300 +static double K1 = 0.0e0; +static double K3 = 0.5e0; +static double K4 = 5.0e0; +static double fx,cum,ccum; +static unsigned long qhi,qleft; +static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > one)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = one; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 2) goto S90; +/* + X +*/ + if(!(*x < 0.0e0)) goto S80; + *bound = 0.0e0; + *status = -4; + return; +S90: +S80: + if(*which == 3) goto S110; +/* + DF +*/ + if(!(*df <= 0.0e0)) goto S100; + *bound = 0.0e0; + *status = -5; + return; +S110: +S100: + if(*which == 4) goto S130; +/* + PNONC +*/ + if(!(*pnonc < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -6; + return; +S130: +S120: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P and Q +*/ + cumchn(x,df,pnonc,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating X +*/ + *x = 5.0e0; + T2 = inf; + T5 = atol; + T6 = tol; + dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6); + *status = 0; + dinvr(status,x,&fx,&qleft,&qhi); +S140: + if(!(*status == 1)) goto S150; + cumchn(x,df,pnonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,x,&fx,&qleft,&qhi); + goto S140; +S150: + if(!(*status == -1)) goto S180; + if(!qleft) goto S160; + *status = 1; + *bound = 0.0e0; + goto S170; +S160: + *status = 2; + *bound = inf; +S180: +S170: + ; + } + else if(3 == *which) { +/* + Calculating DF +*/ + *df = 5.0e0; + T7 = zero; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); + *status = 0; + dinvr(status,df,&fx,&qleft,&qhi); +S190: + if(!(*status == 1)) goto S200; + cumchn(x,df,pnonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,df,&fx,&qleft,&qhi); + goto S190; +S200: + if(!(*status == -1)) goto S230; + if(!qleft) goto S210; + *status = 1; + *bound = zero; + goto S220; +S210: + *status = 2; + *bound = inf; +S230: +S220: + ; + } + else if(4 == *which) { +/* + Calculating PNONC +*/ + *pnonc = 5.0e0; + T11 = tent4; + T12 = atol; + T13 = tol; + dstinv(&K1,&T11,&K3,&K3,&K4,&T12,&T13); + *status = 0; + dinvr(status,pnonc,&fx,&qleft,&qhi); +S240: + if(!(*status == 1)) goto S250; + cumchn(x,df,pnonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,pnonc,&fx,&qleft,&qhi); + goto S240; +S250: + if(!(*status == -1)) goto S280; + if(!qleft) goto S260; + *status = 1; + *bound = zero; + goto S270; +S260: + *status = 2; + *bound = tent4; +S270: + ; + } +S280: + return; +#undef tent4 +#undef tol +#undef atol +#undef zero +#undef one +#undef inf +} +void cdf_f(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,int *status,double *bound) +/********************************************************************** + + void cdf_f(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,int *status,double *bound) + + Cumulative Distribution Function + F distribution + + + Function + + + Calculates any one parameter of the F distribution + given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from F,DFN and DFD + iwhich = 2 : Calculate F from P,Q,DFN and DFD + iwhich = 3 : Calculate DFN from P,Q,F and DFD + iwhich = 4 : Calculate DFD from P,Q,F and DFN + + P <--> The integral from 0 to F of the f-density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + F <--> Upper limit of integration of the f-density. + Input range: [0, +infinity). + Search range: [0,1E300] + + DFN < --> Degrees of freedom of the numerator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + DFD < --> Degrees of freedom of the denominator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.6.2 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function for the F variate to + that of an incomplete beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + WARNING + + The value of the cumulative F distribution is not necessarily + monotone in either degrees of freedom. There thus may be two + values that provide a given CDF value. This routine assumes + monotonicity and will find an arbitrary one of the two values. + +**********************************************************************/ +{ +#define tol (1.0e-8) +#define atol (1.0e-50) +#define zero (1.0e-300) +#define inf 1.0e300 +static int K1 = 1; +static double K2 = 0.0e0; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double pq,fx,cum,ccum; +static unsigned long qhi,qleft,qporq; +static double T3,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + F +*/ + if(!(*f < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + DFN +*/ + if(!(*dfn <= 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 4) goto S170; +/* + DFD +*/ + if(!(*dfd <= 0.0e0)) goto S160; + *bound = 0.0e0; + *status = -6; + return; +S170: +S160: + if(*which == 1) goto S210; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200; + if(!(pq < 0.0e0)) goto S180; + *bound = 0.0e0; + goto S190; +S180: + *bound = 1.0e0; +S190: + *status = 3; + return; +S210: +S200: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumf(f,dfn,dfd,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating F +*/ + *f = 5.0e0; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,f,&fx,&qleft,&qhi); +S220: + if(!(*status == 1)) goto S250; + cumf(f,dfn,dfd,&cum,&ccum); + if(!qporq) goto S230; + fx = cum-*p; + goto S240; +S230: + fx = ccum-*q; +S240: + dinvr(status,f,&fx,&qleft,&qhi); + goto S220; +S250: + if(!(*status == -1)) goto S280; + if(!qleft) goto S260; + *status = 1; + *bound = 0.0e0; + goto S270; +S260: + *status = 2; + *bound = inf; +S280: +S270: + ; + } + else if(3 == *which) { +/* + Calculating DFN +*/ + *dfn = 5.0e0; + T8 = zero; + T9 = inf; + T10 = atol; + T11 = tol; + dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); + *status = 0; + dinvr(status,dfn,&fx,&qleft,&qhi); +S290: + if(!(*status == 1)) goto S320; + cumf(f,dfn,dfd,&cum,&ccum); + if(!qporq) goto S300; + fx = cum-*p; + goto S310; +S300: + fx = ccum-*q; +S310: + dinvr(status,dfn,&fx,&qleft,&qhi); + goto S290; +S320: + if(!(*status == -1)) goto S350; + if(!qleft) goto S330; + *status = 1; + *bound = zero; + goto S340; +S330: + *status = 2; + *bound = inf; +S350: +S340: + ; + } + else if(4 == *which) { +/* + Calculating DFD +*/ + *dfd = 5.0e0; + T12 = zero; + T13 = inf; + T14 = atol; + T15 = tol; + dstinv(&T12,&T13,&K4,&K4,&K5,&T14,&T15); + *status = 0; + dinvr(status,dfd,&fx,&qleft,&qhi); +S360: + if(!(*status == 1)) goto S390; + cumf(f,dfn,dfd,&cum,&ccum); + if(!qporq) goto S370; + fx = cum-*p; + goto S380; +S370: + fx = ccum-*q; +S380: + dinvr(status,dfd,&fx,&qleft,&qhi); + goto S360; +S390: + if(!(*status == -1)) goto S420; + if(!qleft) goto S400; + *status = 1; + *bound = zero; + goto S410; +S400: + *status = 2; + *bound = inf; +S410: + ; + } +S420: + return; +#undef tol +#undef atol +#undef zero +#undef inf +} +void cdf_fnc(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,double *phonc,int *status,double *bound) +/********************************************************************** + + void cdf_fnc(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,double *phonc,int *status,double *bound) + + Cumulative Distribution Function + Non-central F distribution + + + Function + + + Calculates any one parameter of the Non-central F + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next five argument + values is to be calculated from the others. + Legal range: 1..5 + iwhich = 1 : Calculate P and Q from F,DFN,DFD and PNONC + iwhich = 2 : Calculate F from P,Q,DFN,DFD and PNONC + iwhich = 3 : Calculate DFN from P,Q,F,DFD and PNONC + iwhich = 4 : Calculate DFD from P,Q,F,DFN and PNONC + iwhich = 5 : Calculate PNONC from P,Q,F,DFN and DFD + + P <--> The integral from 0 to F of the non-central f-density. + Input range: [0,1-1E-16). + + Q <--> 1-P. + Q is not used by this subroutine and is only included + for similarity with other cdf_* routines. + + F <--> Upper limit of integration of the non-central f-density. + Input range: [0, +infinity). + Search range: [0,1E300] + + DFN < --> Degrees of freedom of the numerator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + DFD < --> Degrees of freedom of the denominator sum of squares. + Must be in range: (0, +infinity). + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + PNONC <-> The non-centrality parameter + Input range: [0,infinity) + Search range: [0,1E4] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.6.20 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to compute the cumulative + distribution function. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + WARNING + + The computation time required for this routine is proportional + to the noncentrality parameter (PNONC). Very large values of + this parameter can consume immense computer resources. This is + why the search range is bounded by 10,000. + + WARNING + + The value of the cumulative noncentral F distribution is not + necessarily monotone in either degrees of freedom. There thus + may be two values that provide a given CDF value. This routine + assumes monotonicity and will find an arbitrary one of the two + values. + +**********************************************************************/ +{ +#define tent4 1.0e4 +#define tol (1.0e-8) +#define atol (1.0e-50) +#define zero (1.0e-300) +#define one (1.0e0-1.0e-16) +#define inf 1.0e300 +static double K1 = 0.0e0; +static double K3 = 0.5e0; +static double K4 = 5.0e0; +static double fx,cum,ccum; +static unsigned long qhi,qleft; +static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15,T16,T17; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 5)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 5.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > one)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = one; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 2) goto S90; +/* + F +*/ + if(!(*f < 0.0e0)) goto S80; + *bound = 0.0e0; + *status = -4; + return; +S90: +S80: + if(*which == 3) goto S110; +/* + DFN +*/ + if(!(*dfn <= 0.0e0)) goto S100; + *bound = 0.0e0; + *status = -5; + return; +S110: +S100: + if(*which == 4) goto S130; +/* + DFD +*/ + if(!(*dfd <= 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -6; + return; +S130: +S120: + if(*which == 5) goto S150; +/* + PHONC +*/ + if(!(*phonc < 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -7; + return; +S150: +S140: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumfnc(f,dfn,dfd,phonc,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating F +*/ + *f = 5.0e0; + T2 = inf; + T5 = atol; + T6 = tol; + dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6); + *status = 0; + dinvr(status,f,&fx,&qleft,&qhi); +S160: + if(!(*status == 1)) goto S170; + cumfnc(f,dfn,dfd,phonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,f,&fx,&qleft,&qhi); + goto S160; +S170: + if(!(*status == -1)) goto S200; + if(!qleft) goto S180; + *status = 1; + *bound = 0.0e0; + goto S190; +S180: + *status = 2; + *bound = inf; +S200: +S190: + ; + } + else if(3 == *which) { +/* + Calculating DFN +*/ + *dfn = 5.0e0; + T7 = zero; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); + *status = 0; + dinvr(status,dfn,&fx,&qleft,&qhi); +S210: + if(!(*status == 1)) goto S220; + cumfnc(f,dfn,dfd,phonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,dfn,&fx,&qleft,&qhi); + goto S210; +S220: + if(!(*status == -1)) goto S250; + if(!qleft) goto S230; + *status = 1; + *bound = zero; + goto S240; +S230: + *status = 2; + *bound = inf; +S250: +S240: + ; + } + else if(4 == *which) { +/* + Calculating DFD +*/ + *dfd = 5.0e0; + T11 = zero; + T12 = inf; + T13 = atol; + T14 = tol; + dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14); + *status = 0; + dinvr(status,dfd,&fx,&qleft,&qhi); +S260: + if(!(*status == 1)) goto S270; + cumfnc(f,dfn,dfd,phonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,dfd,&fx,&qleft,&qhi); + goto S260; +S270: + if(!(*status == -1)) goto S300; + if(!qleft) goto S280; + *status = 1; + *bound = zero; + goto S290; +S280: + *status = 2; + *bound = inf; +S300: +S290: + ; + } + else if(5 == *which) { +/* + Calculating PHONC +*/ + *phonc = 5.0e0; + T15 = tent4; + T16 = atol; + T17 = tol; + dstinv(&K1,&T15,&K3,&K3,&K4,&T16,&T17); + *status = 0; + dinvr(status,phonc,&fx,&qleft,&qhi); +S310: + if(!(*status == 1)) goto S320; + cumfnc(f,dfn,dfd,phonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,phonc,&fx,&qleft,&qhi); + goto S310; +S320: + if(!(*status == -1)) goto S350; + if(!qleft) goto S330; + *status = 1; + *bound = 0.0e0; + goto S340; +S330: + *status = 2; + *bound = tent4; +S340: + ; + } +S350: + return; +#undef tent4 +#undef tol +#undef atol +#undef zero +#undef one +#undef inf +} +void cdf_gam(int *which,double *p,double *q,double *x,double *shape, + double *scale,int *status,double *bound) +/********************************************************************** + + void cdf_gam(int *which,double *p,double *q,double *x,double *shape, + double *scale,int *status,double *bound) + + Cumulative Distribution Function + GAMma Distribution + + + Function + + + Calculates any one parameter of the gamma + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE + iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE + iwhich = 3 : Calculate SHAPE from P,Q,X and SCALE + iwhich = 4 : Calculate SCALE from P,Q,X and SHAPE + + P <--> The integral from 0 to X of the gamma density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X <--> The upper limit of integration of the gamma density. + Input range: [0, +infinity). + Search range: [0,1E300] + + SHAPE <--> The shape parameter of the gamma density. + Input range: (0, +infinity). + Search range: [1E-300,1E300] + + SCALE <--> The scale parameter of the gamma density. + Input range: (0, +infinity). + Search range: (1E-300,1E300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 10 if the gamma or inverse gamma routine cannot + compute the answer. Usually happens only for + X and SHAPE very large (gt 1E10 or more) + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Cumulative distribution function (P) is calculated directly by + the code associated with: + + DiDinato, A. R. and Morris, A. H. Computation of the incomplete + gamma function ratios and their inverse. ACM Trans. Math. + Softw. 12 (1986), 377-393. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + Note + + + + The gamma density is proportional to + T**(SHAPE - 1) * EXP(- SCALE * T) + +**********************************************************************/ +{ +#define tol (1.0e-8) +#define atol (1.0e-50) +#define zero (1.0e-300) +#define inf 1.0e300 +static int K1 = 1; +static double K5 = 0.5e0; +static double K6 = 5.0e0; +static double xx,fx,xscale,cum,ccum,pq,porq; +static int ierr; +static unsigned long qhi,qleft,qporq; +static double T2,T3,T4,T7,T8,T9; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + X +*/ + if(!(*x < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + SHAPE +*/ + if(!(*shape <= 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 4) goto S170; +/* + SCALE +*/ + if(!(*scale <= 0.0e0)) goto S160; + *bound = 0.0e0; + *status = -6; + return; +S170: +S160: + if(*which == 1) goto S210; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200; + if(!(pq < 0.0e0)) goto S180; + *bound = 0.0e0; + goto S190; +S180: + *bound = 1.0e0; +S190: + *status = 3; + return; +S210: +S200: + if(*which == 1) goto S240; +/* + Select the minimum of P or Q +*/ + qporq = *p <= *q; + if(!qporq) goto S220; + porq = *p; + goto S230; +S220: + porq = *q; +S240: +S230: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + *status = 0; + xscale = *x**scale; + cumgam(&xscale,shape,p,q); + if(porq > 1.5e0) *status = 10; + } + else if(2 == *which) { +/* + Computing X +*/ + T2 = -1.0e0; + gaminv(shape,&xx,&T2,p,q,&ierr); + if(ierr < 0.0e0) { + *status = 10; + return; + } + else { + *x = xx/ *scale; + *status = 0; + } + } + else if(3 == *which) { +/* + Computing SHAPE +*/ + *shape = 5.0e0; + xscale = *x**scale; + T3 = zero; + T4 = inf; + T7 = atol; + T8 = tol; + dstinv(&T3,&T4,&K5,&K5,&K6,&T7,&T8); + *status = 0; + dinvr(status,shape,&fx,&qleft,&qhi); +S250: + if(!(*status == 1)) goto S290; + cumgam(&xscale,shape,&cum,&ccum); + if(!qporq) goto S260; + fx = cum-*p; + goto S270; +S260: + fx = ccum-*q; +S270: + if(!(qporq && cum > 1.5e0 || !qporq && ccum > 1.5e0)) goto S280; + *status = 10; + return; +S280: + dinvr(status,shape,&fx,&qleft,&qhi); + goto S250; +S290: + if(!(*status == -1)) goto S320; + if(!qleft) goto S300; + *status = 1; + *bound = zero; + goto S310; +S300: + *status = 2; + *bound = inf; +S320: +S310: + ; + } + else if(4 == *which) { +/* + Computing SCALE +*/ + T9 = -1.0e0; + gaminv(shape,&xx,&T9,p,q,&ierr); + if(ierr < 0.0e0) { + *status = 10; + return; + } + else { + *scale = xx/ *x; + *status = 0; + } + } + return; +#undef tol +#undef atol +#undef zero +#undef inf +} +void cdf_nbn(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) +/********************************************************************** + + void cdf_nbn(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) + + Cumulative Distribution Function + Negative BiNomial distribution + + + Function + + + Calculates any one parameter of the negative binomial + distribution given values for the others. + + The cumulative negative binomial distribution returns the + probability that there will be F or fewer failures before the + XNth success in binomial trials each of which has probability of + success PR. + + The individual term of the negative binomial is the probability of + S failures before XN successes and is + Choose( S, XN+S-1 ) * PR^(XN) * (1-PR)^S + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR + iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR + iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR + iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN + + P <--> The cumulation from 0 to S of the negative + binomial distribution. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + S <--> The upper limit of cumulation of the binomial distribution. + There are F or fewer failures before the XNth success. + Input range: [0, +infinity). + Search range: [0, 1E300] + + XN <--> The number of successes. + Input range: [0, +infinity). + Search range: [0, 1E300] + + PR <--> The probability of success in each binomial trial. + Input range: [0,1]. + Search range: [0,1]. + + OMPR <--> 1-PR + Input range: [0,1]. + Search range: [0,1] + PR + OMPR = 1.0 + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if PR + OMPR .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.26 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce calculation of + the cumulative distribution function to that of an incomplete + beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tol (1.0e-8) +#define atol (1.0e-50) +#define inf 1.0e300 +#define one 1.0e0 +static int K1 = 1; +static double K2 = 0.0e0; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double K11 = 1.0e0; +static double fx,xhi,xlo,pq,prompr,cum,ccum; +static unsigned long qhi,qleft,qporq; +static double T3,T6,T7,T8,T9,T10,T12,T13; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + S +*/ + if(!(*s < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + XN +*/ + if(!(*xn < 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 4) goto S190; +/* + PR +*/ + if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S180; + if(!(*pr < 0.0e0)) goto S160; + *bound = 0.0e0; + goto S170; +S160: + *bound = 1.0e0; +S170: + *status = -6; + return; +S190: +S180: + if(*which == 4) goto S230; +/* + OMPR +*/ + if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S220; + if(!(*ompr < 0.0e0)) goto S200; + *bound = 0.0e0; + goto S210; +S200: + *bound = 1.0e0; +S210: + *status = -7; + return; +S230: +S220: + if(*which == 1) goto S270; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260; + if(!(pq < 0.0e0)) goto S240; + *bound = 0.0e0; + goto S250; +S240: + *bound = 1.0e0; +S250: + *status = 3; + return; +S270: +S260: + if(*which == 4) goto S310; +/* + PR + OMPR +*/ + prompr = *pr+*ompr; + if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300; + if(!(prompr < 0.0e0)) goto S280; + *bound = 0.0e0; + goto S290; +S280: + *bound = 1.0e0; +S290: + *status = 4; + return; +S310: +S300: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumnbn(s,xn,pr,ompr,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating S +*/ + *s = 5.0e0; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,s,&fx,&qleft,&qhi); +S320: + if(!(*status == 1)) goto S350; + cumnbn(s,xn,pr,ompr,&cum,&ccum); + if(!qporq) goto S330; + fx = cum-*p; + goto S340; +S330: + fx = ccum-*q; +S340: + dinvr(status,s,&fx,&qleft,&qhi); + goto S320; +S350: + if(!(*status == -1)) goto S380; + if(!qleft) goto S360; + *status = 1; + *bound = 0.0e0; + goto S370; +S360: + *status = 2; + *bound = inf; +S380: +S370: + ; + } + else if(3 == *which) { +/* + Calculating XN +*/ + *xn = 5.0e0; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10); + *status = 0; + dinvr(status,xn,&fx,&qleft,&qhi); +S390: + if(!(*status == 1)) goto S420; + cumnbn(s,xn,pr,ompr,&cum,&ccum); + if(!qporq) goto S400; + fx = cum-*p; + goto S410; +S400: + fx = ccum-*q; +S410: + dinvr(status,xn,&fx,&qleft,&qhi); + goto S390; +S420: + if(!(*status == -1)) goto S450; + if(!qleft) goto S430; + *status = 1; + *bound = 0.0e0; + goto S440; +S430: + *status = 2; + *bound = inf; +S450: +S440: + ; + } + else if(4 == *which) { +/* + Calculating PR and OMPR +*/ + T12 = atol; + T13 = tol; + dstzr(&K2,&K11,&T12,&T13); + if(!qporq) goto S480; + *status = 0; + dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); + *ompr = one-*pr; +S460: + if(!(*status == 1)) goto S470; + cumnbn(s,xn,pr,ompr,&cum,&ccum); + fx = cum-*p; + dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); + *ompr = one-*pr; + goto S460; +S470: + goto S510; +S480: + *status = 0; + dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); + *pr = one-*ompr; +S490: + if(!(*status == 1)) goto S500; + cumnbn(s,xn,pr,ompr,&cum,&ccum); + fx = ccum-*q; + dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); + *pr = one-*ompr; + goto S490; +S510: +S500: + if(!(*status == -1)) goto S540; + if(!qleft) goto S520; + *status = 1; + *bound = 0.0e0; + goto S530; +S520: + *status = 2; + *bound = 1.0e0; +S530: + ; + } +S540: + return; +#undef tol +#undef atol +#undef inf +#undef one +} +void cdf_nor(int *which,double *p,double *q,double *x,double *mean, + double *sd,int *status,double *bound) +/********************************************************************** + + void cdf_nor(int *which,double *p,double *q,double *x,double *mean, + double *sd,int *status,double *bound) + + Cumulative Distribution Function + NORmal distribution + + + Function + + + Calculates any one parameter of the normal + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next parameter + values is to be calculated using values of the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,MEAN and SD + iwhich = 2 : Calculate X from P,Q,MEAN and SD + iwhich = 3 : Calculate MEAN from P,Q,X and SD + iwhich = 4 : Calculate SD from P,Q,X and MEAN + + P <--> The integral from -infinity to X of the normal density. + Input range: (0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X < --> Upper limit of integration of the normal-density. + Input range: ( -infinity, +infinity) + + MEAN <--> The mean of the normal density. + Input range: (-infinity, +infinity) + + SD <--> Standard Deviation of the normal density. + Input range: (0, +infinity). + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + + + A slightly modified version of ANORM from + + Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN + Package of Special Function Routines and Test Drivers" + acm Transactions on Mathematical Software. 19, 22-32. + + is used to calulate the cumulative standard normal distribution. + + The rational functions from pages 90-95 of Kennedy and Gentle, + Statistical Computing, Marcel Dekker, NY, 1980 are used as + starting values to Newton's Iterations which compute the inverse + standard normal. Therefore no searches are necessary for any + parameter. + + For X < -15, the asymptotic expansion for the normal is used as + the starting value in finding the inverse standard normal. + This is formula 26.2.12 of Abramowitz and Stegun. + + + Note + + + The normal density is proportional to + exp( - 0.5 * (( X - MEAN)/SD)**2) + +**********************************************************************/ +{ +static int K1 = 1; +static double z,pq; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + *status = 0; + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p <= 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 1) goto S150; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S140; + if(!(pq < 0.0e0)) goto S120; + *bound = 0.0e0; + goto S130; +S120: + *bound = 1.0e0; +S130: + *status = 3; + return; +S150: +S140: + if(*which == 4) goto S170; +/* + SD +*/ + if(!(*sd <= 0.0e0)) goto S160; + *bound = 0.0e0; + *status = -6; + return; +S170: +S160: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Computing P +*/ + z = (*x-*mean)/ *sd; + cumnor(&z,p,q); + } + else if(2 == *which) { +/* + Computing X +*/ + z = dinvnr(p,q); + *x = *sd*z+*mean; + } + else if(3 == *which) { +/* + Computing the MEAN +*/ + z = dinvnr(p,q); + *mean = *x-*sd*z; + } + else if(4 == *which) { +/* + Computing SD +*/ + z = dinvnr(p,q); + *sd = (*x-*mean)/z; + } + return; +} +void cdf_poi(int *which,double *p,double *q,double *s,double *xlam, + int *status,double *bound) +/********************************************************************** + + void cdf_poi(int *which,double *p,double *q,double *s,double *xlam, + int *status,double *bound) + + Cumulative Distribution Function + POIsson distribution + + + Function + + + Calculates any one parameter of the Poisson + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which argument + value is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from S and XLAM + iwhich = 2 : Calculate A from P,Q and XLAM + iwhich = 3 : Calculate XLAM from P,Q and S + + P <--> The cumulation from 0 to S of the poisson density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + S <--> Upper limit of cumulation of the Poisson. + Input range: [0, +infinity). + Search range: [0,1E300] + + XLAM <--> Mean of the Poisson distribution. + Input range: [0, +infinity). + Search range: [0,1E300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.21 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function to that of computing a + chi-square, hence an incomplete gamma function. + + Cumulative distribution function (P) is calculated directly. + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tol (1.0e-8) +#define atol (1.0e-50) +#define inf 1.0e300 +static int K1 = 1; +static double K2 = 0.0e0; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double fx,cum,ccum,pq; +static unsigned long qhi,qleft,qporq; +static double T3,T6,T7,T8,T9,T10; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 3)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 3.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + S +*/ + if(!(*s < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + XLAM +*/ + if(!(*xlam < 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 1) goto S190; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180; + if(!(pq < 0.0e0)) goto S160; + *bound = 0.0e0; + goto S170; +S160: + *bound = 1.0e0; +S170: + *status = 3; + return; +S190: +S180: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumpoi(s,xlam,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating S +*/ + *s = 5.0e0; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,s,&fx,&qleft,&qhi); +S200: + if(!(*status == 1)) goto S230; + cumpoi(s,xlam,&cum,&ccum); + if(!qporq) goto S210; + fx = cum-*p; + goto S220; +S210: + fx = ccum-*q; +S220: + dinvr(status,s,&fx,&qleft,&qhi); + goto S200; +S230: + if(!(*status == -1)) goto S260; + if(!qleft) goto S240; + *status = 1; + *bound = 0.0e0; + goto S250; +S240: + *status = 2; + *bound = inf; +S260: +S250: + ; + } + else if(3 == *which) { +/* + Calculating XLAM +*/ + *xlam = 5.0e0; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10); + *status = 0; + dinvr(status,xlam,&fx,&qleft,&qhi); +S270: + if(!(*status == 1)) goto S300; + cumpoi(s,xlam,&cum,&ccum); + if(!qporq) goto S280; + fx = cum-*p; + goto S290; +S280: + fx = ccum-*q; +S290: + dinvr(status,xlam,&fx,&qleft,&qhi); + goto S270; +S300: + if(!(*status == -1)) goto S330; + if(!qleft) goto S310; + *status = 1; + *bound = 0.0e0; + goto S320; +S310: + *status = 2; + *bound = inf; +S320: + ; + } +S330: + return; +#undef tol +#undef atol +#undef inf +} +void cdf_t(int *which,double *p,double *q,double *t,double *df, + int *status,double *bound) +/********************************************************************** + + void cdf_t(int *which,double *p,double *q,double *t,double *df, + int *status,double *bound) + + Cumulative Distribution Function + T distribution + + + Function + + + Calculates any one parameter of the t distribution given + values for the others. + + + Arguments + + + WHICH --> Integer indicating which argument + values is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from T and DF + iwhich = 2 : Calculate T from P,Q and DF + iwhich = 3 : Calculate DF from P,Q and T + + P <--> The integral from -infinity to t of the t-density. + Input range: (0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + T <--> Upper limit of integration of the t-density. + Input range: ( -infinity, +infinity). + Search range: [ -1E300, 1E300 ] + + DF <--> Degrees of freedom of the t-distribution. + Input range: (0 , +infinity). + Search range: [1e-300, 1E10] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.27 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function to that of an incomplete + beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tol (1.0e-8) +#define atol (1.0e-50) +#define zero (1.0e-300) +#define inf 1.0e300 +#define maxdf 1.0e10 +static int K1 = 1; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double fx,cum,ccum,pq; +static unsigned long qhi,qleft,qporq; +static double T2,T3,T6,T7,T8,T9,T10,T11; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 3)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 3.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p <= 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 3) goto S130; +/* + DF +*/ + if(!(*df <= 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -5; + return; +S130: +S120: + if(*which == 1) goto S170; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S160; + if(!(pq < 0.0e0)) goto S140; + *bound = 0.0e0; + goto S150; +S140: + *bound = 1.0e0; +S150: + *status = 3; + return; +S170: +S160: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Computing P and Q +*/ + cumt(t,df,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Computing T + .. Get initial approximation for T +*/ + *t = dt1(p,q,df); + T2 = -inf; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&T2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,t,&fx,&qleft,&qhi); +S180: + if(!(*status == 1)) goto S210; + cumt(t,df,&cum,&ccum); + if(!qporq) goto S190; + fx = cum-*p; + goto S200; +S190: + fx = ccum-*q; +S200: + dinvr(status,t,&fx,&qleft,&qhi); + goto S180; +S210: + if(!(*status == -1)) goto S240; + if(!qleft) goto S220; + *status = 1; + *bound = -inf; + goto S230; +S220: + *status = 2; + *bound = inf; +S240: +S230: + ; + } + else if(3 == *which) { +/* + Computing DF +*/ + *df = 5.0e0; + T8 = zero; + T9 = maxdf; + T10 = atol; + T11 = tol; + dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); + *status = 0; + dinvr(status,df,&fx,&qleft,&qhi); +S250: + if(!(*status == 1)) goto S280; + cumt(t,df,&cum,&ccum); + if(!qporq) goto S260; + fx = cum-*p; + goto S270; +S260: + fx = ccum-*q; +S270: + dinvr(status,df,&fx,&qleft,&qhi); + goto S250; +S280: + if(!(*status == -1)) goto S310; + if(!qleft) goto S290; + *status = 1; + *bound = zero; + goto S300; +S290: + *status = 2; + *bound = maxdf; +S300: + ; + } +S310: + return; +#undef tol +#undef atol +#undef zero +#undef inf +#undef maxdf +} +void cumbet(double *x,double *y,double *a,double *b,double *cum, + double *ccum) +/* +********************************************************************** + + void cumbet(double *x,double *y,double *a,double *b,double *cum, + double *ccum) + + Double precision cUMulative incomplete BETa distribution + + + Function + + + Calculates the cdf to X of the incomplete beta distribution + with parameters a and b. This is the integral from 0 to x + of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1) + + + Arguments + + + X --> Upper limit of integration. + X is DOUBLE PRECISION + + Y --> 1 - X. + Y is DOUBLE PRECISION + + A --> First parameter of the beta distribution. + A is DOUBLE PRECISION + + B --> Second parameter of the beta distribution. + B is DOUBLE PRECISION + + CUM <-- Cumulative incomplete beta distribution. + CUM is DOUBLE PRECISION + + CCUM <-- Compliment of Cumulative incomplete beta distribution. + CCUM is DOUBLE PRECISION + + + Method + + + Calls the routine BRATIO. + + References + + Didonato, Armido R. and Morris, Alfred H. Jr. (1992) Algorithim + 708 Significant Digit Computation of the Incomplete Beta Function + Ratios. ACM ToMS, Vol.18, No. 3, Sept. 1992, 360-373. + +********************************************************************** +*/ +{ +static int ierr; +/* + .. + .. Executable Statements .. +*/ + if(!(*x <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + if(!(*y <= 0.0e0)) goto S20; + *cum = 1.0e0; + *ccum = 0.0e0; + return; +S20: + bratio(a,b,x,y,cum,ccum,&ierr); +/* + Call bratio routine +*/ + return; +} +void cumbin(double *s,double *xn,double *pr,double *ompr, + double *cum,double *ccum) +/* +********************************************************************** + + void cumbin(double *s,double *xn,double *pr,double *ompr, + double *cum,double *ccum) + + CUmulative BINomial distribution + + + Function + + + Returns the probability of 0 to S successes in XN binomial + trials, each of which has a probability of success, PBIN. + + + Arguments + + + S --> The upper limit of cumulation of the binomial distribution. + S is DOUBLE PRECISION + + XN --> The number of binomial trials. + XN is DOUBLE PRECISIO + + PBIN --> The probability of success in each binomial trial. + PBIN is DOUBLE PRECIS + + OMPR --> 1 - PBIN + OMPR is DOUBLE PRECIS + + CUM <-- Cumulative binomial distribution. + CUM is DOUBLE PRECISI + + CCUM <-- Compliment of Cumulative binomial distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Formula 26.5.24 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the binomial + distribution to the cumulative beta distribution. + +********************************************************************** +*/ +{ +static double T1,T2; +/* + .. + .. Executable Statements .. +*/ + if(!(*s < *xn)) goto S10; + T1 = *s+1.0e0; + T2 = *xn-*s; + cumbet(pr,ompr,&T1,&T2,ccum,cum); + goto S20; +S10: + *cum = 1.0e0; + *ccum = 0.0e0; +S20: + return; +} +void cumchi(double *x,double *df,double *cum,double *ccum) +/* +********************************************************************** + + void cumchi(double *x,double *df,double *cum,double *ccum) + CUMulative of the CHi-square distribution + + + Function + + + Calculates the cumulative chi-square distribution. + + + Arguments + + + X --> Upper limit of integration of the + chi-square distribution. + X is DOUBLE PRECISION + + DF --> Degrees of freedom of the + chi-square distribution. + DF is DOUBLE PRECISION + + CUM <-- Cumulative chi-square distribution. + CUM is DOUBLE PRECISIO + + CCUM <-- Compliment of Cumulative chi-square distribution. + CCUM is DOUBLE PRECISI + + + Method + + + Calls incomplete gamma function (CUMGAM) + +********************************************************************** +*/ +{ +static double a,xx; +/* + .. + .. Executable Statements .. +*/ + a = *df*0.5e0; + xx = *x*0.5e0; + cumgam(&xx,&a,cum,ccum); + return; +} +void cumchn(double *x,double *df,double *pnonc,double *cum, + double *ccum) +/* +********************************************************************** + + void cumchn(double *x,double *df,double *pnonc,double *cum, + double *ccum) + + CUMulative of the Non-central CHi-square distribution + + + Function + + + Calculates the cumulative non-central chi-square + distribution, i.e., the probability that a random variable + which follows the non-central chi-square distribution, with + non-centrality parameter PNONC and continuous degrees of + freedom DF, is less than or equal to X. + + + Arguments + + + X --> Upper limit of integration of the non-central + chi-square distribution. + X is DOUBLE PRECISION + + DF --> Degrees of freedom of the non-central + chi-square distribution. + DF is DOUBLE PRECISION + + PNONC --> Non-centrality parameter of the non-central + chi-square distribution. + PNONC is DOUBLE PRECIS + + CUM <-- Cumulative non-central chi-square distribution. + CUM is DOUBLE PRECISIO + + CCUM <-- Compliment of Cumulative non-central chi-square distribut + CCUM is DOUBLE PRECISI + + + Method + + + Uses formula 26.4.25 of Abramowitz and Stegun, Handbook of + Mathematical Functions, US NBS (1966) to calculate the + non-central chi-square. + + + Variables + + + EPS --- Convergence criterion. The sum stops when a + term is less than EPS*SUM. + EPS is DOUBLE PRECISIO + + NTIRED --- Maximum number of terms to be evaluated + in each sum. + NTIRED is INTEGER + + QCONV --- .TRUE. if convergence achieved - + i.e., program did not stop on NTIRED criterion. + QCONV is LOGICAL + + CCUM <-- Compliment of Cumulative non-central + chi-square distribution. + CCUM is DOUBLE PRECISI + +********************************************************************** +*/ +{ +#define dg(i) (*df+2.0e0*(double)(i)) +#define qsmall(xx) (int)(sum < 1.0e-20 || (xx) < eps*sum) +#define qtired(i) (int)((i) > ntired) +static double eps = 1.0e-5; +static int ntired = 1000; +static double adj,centaj,centwt,chid2,dfd2,lcntaj,lcntwt,lfact,pcent,pterm,sum, + sumadj,term,wt,xnonc; +static int i,icent,iterb,iterf; +static double T1,T2,T3; +/* + .. + .. Executable Statements .. +*/ + if(!(*x <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + if(!(*pnonc <= 1.0e-10)) goto S20; +/* + When non-centrality parameter is (essentially) zero, + use cumulative chi-square distribution +*/ + cumchi(x,df,cum,ccum); + return; +S20: + xnonc = *pnonc/2.0e0; +/* +********************************************************************** + The following code calcualtes the weight, chi-square, and + adjustment term for the central term in the infinite series. + The central term is the one in which the poisson weight is + greatest. The adjustment term is the amount that must + be subtracted from the chi-square to move up two degrees + of freedom. +********************************************************************** +*/ + icent = fifidint(xnonc); + if(icent == 0) icent = 1; + chid2 = *x/2.0e0; +/* + Calculate central weight term +*/ + T1 = (double)(icent+1); + lfact = alngam(&T1); + lcntwt = -xnonc+(double)icent*log(xnonc)-lfact; + centwt = exp(lcntwt); +/* + Calculate central chi-square +*/ + T2 = dg(icent); + cumchi(x,&T2,&pcent,ccum); +/* + Calculate central adjustment term +*/ + dfd2 = dg(icent)/2.0e0; + T3 = 1.0e0+dfd2; + lfact = alngam(&T3); + lcntaj = dfd2*log(chid2)-chid2-lfact; + centaj = exp(lcntaj); + sum = centwt*pcent; +/* +********************************************************************** + Sum backwards from the central term towards zero. + Quit whenever either + (1) the zero term is reached, or + (2) the term gets small relative to the sum, or + (3) More than NTIRED terms are totaled. +********************************************************************** +*/ + iterb = 0; + sumadj = 0.0e0; + adj = centaj; + wt = centwt; + i = icent; + goto S40; +S30: + if(qtired(iterb) || qsmall(term) || i == 0) goto S50; +S40: + dfd2 = dg(i)/2.0e0; +/* + Adjust chi-square for two fewer degrees of freedom. + The adjusted value ends up in PTERM. +*/ + adj = adj*dfd2/chid2; + sumadj += adj; + pterm = pcent+sumadj; +/* + Adjust poisson weight for J decreased by one +*/ + wt *= ((double)i/xnonc); + term = wt*pterm; + sum += term; + i -= 1; + iterb += 1; + goto S30; +S50: + iterf = 0; +/* +********************************************************************** + Now sum forward from the central term towards infinity. + Quit when either + (1) the term gets small relative to the sum, or + (2) More than NTIRED terms are totaled. +********************************************************************** +*/ + sumadj = adj = centaj; + wt = centwt; + i = icent; + goto S70; +S60: + if(qtired(iterf) || qsmall(term)) goto S80; +S70: +/* + Update weights for next higher J +*/ + wt *= (xnonc/(double)(i+1)); +/* + Calculate PTERM and add term to sum +*/ + pterm = pcent-sumadj; + term = wt*pterm; + sum += term; +/* + Update adjustment term for DF for next iteration +*/ + i += 1; + dfd2 = dg(i)/2.0e0; + adj = adj*chid2/dfd2; + sumadj += adj; + iterf += 1; + goto S60; +S80: + *cum = sum; + *ccum = 0.5e0+(0.5e0-*cum); + return; +#undef dg +#undef qsmall +#undef qtired +} +void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum) +/* +********************************************************************** + + void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum) + CUMulative F distribution + + + Function + + + Computes the integral from 0 to F of the f-density with DFN + and DFD degrees of freedom. + + + Arguments + + + F --> Upper limit of integration of the f-density. + F is DOUBLE PRECISION + + DFN --> Degrees of freedom of the numerator sum of squares. + DFN is DOUBLE PRECISI + + DFD --> Degrees of freedom of the denominator sum of squares. + DFD is DOUBLE PRECISI + + CUM <-- Cumulative f distribution. + CUM is DOUBLE PRECISI + + CCUM <-- Compliment of Cumulative f distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Formula 26.5.28 of Abramowitz and Stegun is used to reduce + the cumulative F to a cumulative beta distribution. + + + Note + + + If F is less than or equal to 0, 0 is returned. + +********************************************************************** +*/ +{ +#define half 0.5e0 +#define done 1.0e0 +static double dsum,prod,xx,yy; +static int ierr; +static double T1,T2; +/* + .. + .. Executable Statements .. +*/ + if(!(*f <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + prod = *dfn**f; +/* + XX is such that the incomplete beta with parameters + DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM + YY is 1 - XX + Calculate the smaller of XX and YY accurately +*/ + dsum = *dfd+prod; + xx = *dfd/dsum; + if(xx > half) { + yy = prod/dsum; + xx = done-yy; + } + else yy = done-xx; + T1 = *dfd*half; + T2 = *dfn*half; + bratio(&T1,&T2,&xx,&yy,ccum,cum,&ierr); + return; +#undef half +#undef done +} +void cumfnc(double *f,double *dfn,double *dfd,double *pnonc, + double *cum,double *ccum) +/* +********************************************************************** + + F -NON- -C-ENTRAL F DISTRIBUTION + + + + Function + + + COMPUTES NONCENTRAL F DISTRIBUTION WITH DFN AND DFD + DEGREES OF FREEDOM AND NONCENTRALITY PARAMETER PNONC + + + Arguments + + + X --> UPPER LIMIT OF INTEGRATION OF NONCENTRAL F IN EQUATION + + DFN --> DEGREES OF FREEDOM OF NUMERATOR + + DFD --> DEGREES OF FREEDOM OF DENOMINATOR + + PNONC --> NONCENTRALITY PARAMETER. + + CUM <-- CUMULATIVE NONCENTRAL F DISTRIBUTION + + CCUM <-- COMPLIMENT OF CUMMULATIVE + + + Method + + + USES FORMULA 26.6.20 OF REFERENCE FOR INFINITE SERIES. + SERIES IS CALCULATED BACKWARD AND FORWARD FROM J = LAMBDA/2 + (THIS IS THE TERM WITH THE LARGEST POISSON WEIGHT) UNTIL + THE CONVERGENCE CRITERION IS MET. + + FOR SPEED, THE INCOMPLETE BETA FUNCTIONS ARE EVALUATED + BY FORMULA 26.5.16. + + + REFERENCE + + + HANDBOOD OF MATHEMATICAL FUNCTIONS + EDITED BY MILTON ABRAMOWITZ AND IRENE A. STEGUN + NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55 + MARCH 1965 + P 947, EQUATIONS 26.6.17, 26.6.18 + + + Note + + + THE SUM CONTINUES UNTIL A SUCCEEDING TERM IS LESS THAN EPS + TIMES THE SUM (OR THE SUM IS LESS THAN 1.0E-20). EPS IS + SET TO 1.0E-4 IN A DATA STATEMENT WHICH CAN BE CHANGED. + +********************************************************************** +*/ +{ +#define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum) +#define half 0.5e0 +#define done 1.0e0 +static double eps = 1.0e-4; +static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum, + upterm,xmult,xnonc; +static int i,icent,ierr; +static double T1,T2,T3,T4,T5,T6; +/* + .. + .. Executable Statements .. +*/ + if(!(*f <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + if(!(*pnonc < 1.0e-10)) goto S20; +/* + Handle case in which the non-centrality parameter is + (essentially) zero. +*/ + cumf(f,dfn,dfd,cum,ccum); + return; +S20: + xnonc = *pnonc/2.0e0; +/* + Calculate the central term of the poisson weighting factor. +*/ + icent = xnonc; + if(icent == 0) icent = 1; +/* + Compute central weight term +*/ + T1 = (double)(icent+1); + centwt = exp(-xnonc+(double)icent*log(xnonc)-alngam(&T1)); +/* + Compute central incomplete beta term + Assure that minimum of arg to beta and 1 - arg is computed + accurately. +*/ + prod = *dfn**f; + dsum = *dfd+prod; + yy = *dfd/dsum; + if(yy > half) { + xx = prod/dsum; + yy = done-xx; + } + else xx = done-yy; + T2 = *dfn*half+(double)icent; + T3 = *dfd*half; + bratio(&T2,&T3,&xx,&yy,&betdn,&dummy,&ierr); + adn = *dfn/2.0e0+(double)icent; + aup = adn; + b = *dfd/2.0e0; + betup = betdn; + sum = centwt*betdn; +/* + Now sum terms backward from icent until convergence or all done +*/ + xmult = centwt; + i = icent; + T4 = adn+b; + T5 = adn+1.0e0; + dnterm = exp(alngam(&T4)-alngam(&T5)-alngam(&b)+adn*log(xx)+b*log(yy)); +S30: + if(qsmall(xmult*betdn) || i <= 0) goto S40; + xmult *= ((double)i/xnonc); + i -= 1; + adn -= 1.0; + dnterm = (adn+1.0)/((adn+b)*xx)*dnterm; + betdn += dnterm; + sum += (xmult*betdn); + goto S30; +S40: + i = icent+1; +/* + Now sum forwards until convergence +*/ + xmult = centwt; + if(aup-1.0+b == 0) upterm = exp(-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+ + b*log(yy)); + else { + T6 = aup-1.0+b; + upterm = exp(alngam(&T6)-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+b* + log(yy)); + } + goto S60; +S50: + if(qsmall(xmult*betup)) goto S70; +S60: + xmult *= (xnonc/(double)i); + i += 1; + aup += 1.0; + upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm; + betup -= upterm; + sum += (xmult*betup); + goto S50; +S70: + *cum = sum; + *ccum = 0.5e0+(0.5e0-*cum); + return; +#undef qsmall +#undef half +#undef done +} +void cumgam(double *x,double *a,double *cum,double *ccum) +/* +********************************************************************** + + void cumgam(double *x,double *a,double *cum,double *ccum) + Double precision cUMulative incomplete GAMma distribution + + + Function + + + Computes the cumulative of the incomplete gamma + distribution, i.e., the integral from 0 to X of + (1/GAM(A))*EXP(-T)*T**(A-1) DT + where GAM(A) is the complete gamma function of A, i.e., + GAM(A) = integral from 0 to infinity of + EXP(-T)*T**(A-1) DT + + + Arguments + + + X --> The upper limit of integration of the incomplete gamma. + X is DOUBLE PRECISION + + A --> The shape parameter of the incomplete gamma. + A is DOUBLE PRECISION + + CUM <-- Cumulative incomplete gamma distribution. + CUM is DOUBLE PRECISION + + CCUM <-- Compliment of Cumulative incomplete gamma distribution. + CCUM is DOUBLE PRECISIO + + + Method + + + Calls the routine GRATIO. + +********************************************************************** +*/ +{ +static int K1 = 0; +/* + .. + .. Executable Statements .. +*/ + if(!(*x <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + gratio(a,x,cum,ccum,&K1); +/* + Call gratio routine +*/ + return; +} +void cumnbn(double *s,double *xn,double *pr,double *ompr, + double *cum,double *ccum) +/* +********************************************************************** + + void cumnbn(double *s,double *xn,double *pr,double *ompr, + double *cum,double *ccum) + + CUmulative Negative BINomial distribution + + + Function + + + Returns the probability that it there will be S or fewer failures + before there are XN successes, with each binomial trial having + a probability of success PR. + + Prob(# failures = S | XN successes, PR) = + ( XN + S - 1 ) + ( ) * PR^XN * (1-PR)^S + ( S ) + + + Arguments + + + S --> The number of failures + S is DOUBLE PRECISION + + XN --> The number of successes + XN is DOUBLE PRECISIO + + PR --> The probability of success in each binomial trial. + PR is DOUBLE PRECISIO + + OMPR --> 1 - PR + OMPR is DOUBLE PRECIS + + CUM <-- Cumulative negative binomial distribution. + CUM is DOUBLE PRECISI + + CCUM <-- Compliment of Cumulative negative binomial distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Formula 26.5.26 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the negative + binomial distribution to the cumulative beta distribution. + +********************************************************************** +*/ +{ +static double T1; +/* + .. + .. Executable Statements .. +*/ + T1 = *s+1.e0; + cumbet(pr,ompr,xn,&T1,cum,ccum); + return; +} +void cumnor(double *arg,double *result,double *ccum) +/* +********************************************************************** + + void cumnor(double *arg,double *result,double *ccum) + + + Function + + + Computes the cumulative of the normal distribution, i.e., + the integral from -infinity to x of + (1/sqrt(2*pi)) exp(-u*u/2) du + + X --> Upper limit of integration. + X is DOUBLE PRECISION + + RESULT <-- Cumulative normal distribution. + RESULT is DOUBLE PRECISION + + CCUM <-- Compliment of Cumulative normal distribution. + CCUM is DOUBLE PRECISION + + Renaming of function ANORM from: + + Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN + Package of Special Function Routines and Test Drivers" + acm Transactions on Mathematical Software. 19, 22-32. + + with slight modifications to return ccum and to deal with + machine constants. + +********************************************************************** + Original Comments: +------------------------------------------------------------------ + + This function evaluates the normal distribution function: + + / x + 1 | -t*t/2 + P(x) = ----------- | e dt + sqrt(2 pi) | + /-oo + + The main computation evaluates near-minimax approximations + derived from those in "Rational Chebyshev approximations for + the error function" by W. J. Cody, Math. Comp., 1969, 631-637. + This transportable program uses rational functions that + theoretically approximate the normal distribution function to + at least 18 significant decimal digits. The accuracy achieved + depends on the arithmetic system, the compiler, the intrinsic + functions, and proper selection of the machine-dependent + constants. + +******************************************************************* +******************************************************************* + + Explanation of machine-dependent constants. + + MIN = smallest machine representable number. + + EPS = argument below which anorm(x) may be represented by + 0.5 and above which x*x will not underflow. + A conservative value is the largest machine number X + such that 1.0 + X = 1.0 to machine precision. +******************************************************************* +******************************************************************* + + Error returns + + The program returns ANORM = 0 for ARG .LE. XLOW. + + + Intrinsic functions required are: + + ABS, AINT, EXP + + + Author: W. J. Cody + Mathematics and Computer Science Division + Argonne National Laboratory + Argonne, IL 60439 + + Latest modification: March 15, 1992 + +------------------------------------------------------------------ +*/ +{ +static double a[5] = { + 2.2352520354606839287e00,1.6102823106855587881e02,1.0676894854603709582e03, + 1.8154981253343561249e04,6.5682337918207449113e-2 +}; +static double b[4] = { + 4.7202581904688241870e01,9.7609855173777669322e02,1.0260932208618978205e04, + 4.5507789335026729956e04 +}; +static double c[9] = { + 3.9894151208813466764e-1,8.8831497943883759412e00,9.3506656132177855979e01, + 5.9727027639480026226e02,2.4945375852903726711e03,6.8481904505362823326e03, + 1.1602651437647350124e04,9.8427148383839780218e03,1.0765576773720192317e-8 +}; +static double d[8] = { + 2.2266688044328115691e01,2.3538790178262499861e02,1.5193775994075548050e03, + 6.4855582982667607550e03,1.8615571640885098091e04,3.4900952721145977266e04, + 3.8912003286093271411e04,1.9685429676859990727e04 +}; +static double half = 0.5e0; +static double p[6] = { + 2.1589853405795699e-1,1.274011611602473639e-1,2.2235277870649807e-2, + 1.421619193227893466e-3,2.9112874951168792e-5,2.307344176494017303e-2 +}; +static double one = 1.0e0; +static double q[5] = { + 1.28426009614491121e00,4.68238212480865118e-1,6.59881378689285515e-2, + 3.78239633202758244e-3,7.29751555083966205e-5 +}; +static double sixten = 1.60e0; +static double sqrpi = 3.9894228040143267794e-1; +static double thrsh = 0.66291e0; +static double root32 = 5.656854248e0; +static double zero = 0.0e0; +static int K1 = 1; +static int K2 = 2; +static int i; +static double del,eps,temp,x,xden,xnum,y,xsq,min; +/* +------------------------------------------------------------------ + Machine dependent constants +------------------------------------------------------------------ +*/ + eps = spmpar(&K1)*0.5e0; + min = spmpar(&K2); + x = *arg; + y = fabs(x); + if(y <= thrsh) { +/* +------------------------------------------------------------------ + Evaluate anorm for |X| <= 0.66291 +------------------------------------------------------------------ +*/ + xsq = zero; + if(y > eps) xsq = x*x; + xnum = a[4]*xsq; + xden = xsq; + for(i=0; i<3; i++) { + xnum = (xnum+a[i])*xsq; + xden = (xden+b[i])*xsq; + } + *result = x*(xnum+a[3])/(xden+b[3]); + temp = *result; + *result = half+temp; + *ccum = half-temp; + } +/* +------------------------------------------------------------------ + Evaluate anorm for 0.66291 <= |X| <= sqrt(32) +------------------------------------------------------------------ +*/ + else if(y <= root32) { + xnum = c[8]*y; + xden = y; + for(i=0; i<7; i++) { + xnum = (xnum+c[i])*y; + xden = (xden+d[i])*y; + } + *result = (xnum+c[7])/(xden+d[7]); + xsq = fifdint(y*sixten)/sixten; + del = (y-xsq)*(y+xsq); + *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result; + *ccum = one-*result; + if(x > zero) { + temp = *result; + *result = *ccum; + *ccum = temp; + } + } +/* +------------------------------------------------------------------ + Evaluate anorm for |X| > sqrt(32) +------------------------------------------------------------------ +*/ + else { + *result = zero; + xsq = one/(x*x); + xnum = p[5]*xsq; + xden = xsq; + for(i=0; i<4; i++) { + xnum = (xnum+p[i])*xsq; + xden = (xden+q[i])*xsq; + } + *result = xsq*(xnum+p[4])/(xden+q[4]); + *result = (sqrpi-*result)/y; + xsq = fifdint(x*sixten)/sixten; + del = (x-xsq)*(x+xsq); + *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result; + *ccum = one-*result; + if(x > zero) { + temp = *result; + *result = *ccum; + *ccum = temp; + } + } + if(*result < min) *result = 0.0e0; +/* +------------------------------------------------------------------ + Fix up for negative argument, erf, etc. +------------------------------------------------------------------ +----------Last card of ANORM ---------- +*/ + if(*ccum < min) *ccum = 0.0e0; +} +void cumpoi(double *s,double *xlam,double *cum,double *ccum) +/* +********************************************************************** + + void cumpoi(double *s,double *xlam,double *cum,double *ccum) + CUMulative POIsson distribution + + + Function + + + Returns the probability of S or fewer events in a Poisson + distribution with mean XLAM. + + + Arguments + + + S --> Upper limit of cumulation of the Poisson. + S is DOUBLE PRECISION + + XLAM --> Mean of the Poisson distribution. + XLAM is DOUBLE PRECIS + + CUM <-- Cumulative poisson distribution. + CUM is DOUBLE PRECISION + + CCUM <-- Compliment of Cumulative poisson distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Uses formula 26.4.21 of Abramowitz and Stegun, Handbook of + Mathematical Functions to reduce the cumulative Poisson to + the cumulative chi-square distribution. + +********************************************************************** +*/ +{ +static double chi,df; +/* + .. + .. Executable Statements .. +*/ + df = 2.0e0*(*s+1.0e0); + chi = 2.0e0**xlam; + cumchi(&chi,&df,ccum,cum); + return; +} +void cumt(double *t,double *df,double *cum,double *ccum) +/* +********************************************************************** + + void cumt(double *t,double *df,double *cum,double *ccum) + CUMulative T-distribution + + + Function + + + Computes the integral from -infinity to T of the t-density. + + + Arguments + + + T --> Upper limit of integration of the t-density. + T is DOUBLE PRECISION + + DF --> Degrees of freedom of the t-distribution. + DF is DOUBLE PRECISIO + + CUM <-- Cumulative t-distribution. + CCUM is DOUBLE PRECIS + + CCUM <-- Compliment of Cumulative t-distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Formula 26.5.27 of Abramowitz and Stegun, Handbook of + Mathematical Functions is used to reduce the t-distribution + to an incomplete beta. + +********************************************************************** +*/ +{ +static double K2 = 0.5e0; +static double xx,a,oma,tt,yy,dfptt,T1; +/* + .. + .. Executable Statements .. +*/ + tt = *t**t; + dfptt = *df+tt; + xx = *df/dfptt; + yy = tt/dfptt; + T1 = 0.5e0**df; + cumbet(&xx,&yy,&T1,&K2,&a,&oma); + if(!(*t <= 0.0e0)) goto S10; + *cum = 0.5e0*a; + *ccum = oma+*cum; + goto S20; +S10: + *ccum = 0.5e0*a; + *cum = oma+*ccum; +S20: + return; +} +double dbetrm(double *a,double *b) +/* +********************************************************************** + + double dbetrm(double *a,double *b) + Double Precision Sterling Remainder for Complete + Beta Function + + + Function + + + Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B) + where Lgamma is the log of the (complete) gamma function + + Let ZZ be approximation obtained if each log gamma is approximated + by Sterling's formula, i.e., + Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z + + Returns Log(Beta(A,B)) - ZZ + + + Arguments + + + A --> One argument of the Beta + DOUBLE PRECISION A + + B --> The other argument of the Beta + DOUBLE PRECISION B + +********************************************************************** +*/ +{ +static double dbetrm,T1,T2,T3; +/* + .. + .. Executable Statements .. +*/ +/* + Try to sum from smallest to largest +*/ + T1 = *a+*b; + dbetrm = -dstrem(&T1); + T2 = fifdmax1(*a,*b); + dbetrm += dstrem(&T2); + T3 = fifdmin1(*a,*b); + dbetrm += dstrem(&T3); + return dbetrm; +} +double devlpl(double a[],int *n,double *x) +/* +********************************************************************** + + double devlpl(double a[],int *n,double *x) + Double precision EVALuate a PoLynomial at X + + + Function + + + returns + A(1) + A(2)*X + ... + A(N)*X**(N-1) + + + Arguments + + + A --> Array of coefficients of the polynomial. + A is DOUBLE PRECISION(N) + + N --> Length of A, also degree of polynomial - 1. + N is INTEGER + + X --> Point at which the polynomial is to be evaluated. + X is DOUBLE PRECISION + +********************************************************************** +*/ +{ +static double devlpl,term; +static int i; +/* + .. + .. Executable Statements .. +*/ + term = a[*n-1]; + for(i= *n-1-1; i>=0; i--) term = a[i]+term**x; + devlpl = term; + return devlpl; +} +double dexpm1(double *x) +/* +********************************************************************** + + double dexpm1(double *x) + Evaluation of the function EXP(X) - 1 + + + Arguments + + + X --> Argument at which exp(x)-1 desired + DOUBLE PRECISION X + + + Method + + + Renaming of function rexp from code of: + + DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant + Digit Computation of the Incomplete Beta Function Ratios. ACM + Trans. Math. Softw. 18 (1993), 360-373. + +********************************************************************** +*/ +{ +static double p1 = .914041914819518e-09; +static double p2 = .238082361044469e-01; +static double q1 = -.499999999085958e+00; +static double q2 = .107141568980644e+00; +static double q3 = -.119041179760821e-01; +static double q4 = .595130811860248e-03; +static double dexpm1,w; +/* + .. + .. Executable Statements .. +*/ + if(fabs(*x) > 0.15e0) goto S10; + dexpm1 = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0)); + return dexpm1; +S10: + w = exp(*x); + if(*x > 0.0e0) goto S20; + dexpm1 = w-0.5e0-0.5e0; + return dexpm1; +S20: + dexpm1 = w*(0.5e0+(0.5e0-1.0e0/w)); + return dexpm1; +} +double dinvnr(double *p,double *q) +/* +********************************************************************** + + double dinvnr(double *p,double *q) + Double precision NoRmal distribution INVerse + + + Function + + + Returns X such that CUMNOR(X) = P, i.e., the integral from - + infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P + + + Arguments + + + P --> The probability whose normal deviate is sought. + P is DOUBLE PRECISION + + Q --> 1-P + P is DOUBLE PRECISION + + + Method + + + The rational function on page 95 of Kennedy and Gentle, + Statistical Computing, Marcel Dekker, NY , 1980 is used as a start + value for the Newton method of finding roots. + + + Note + + + If P or Q .lt. machine EPS returns +/- DINVNR(EPS) + +********************************************************************** +*/ +{ +#define maxit 100 +#define eps (1.0e-13) +#define r2pi 0.3989422804014326e0 +#define nhalf (-0.5e0) +#define dennor(x) (r2pi*exp(nhalf*(x)*(x))) +static double dinvnr,strtx,xcur,cum,ccum,pp,dx; +static int i; +static unsigned long qporq; +/* + .. + .. Executable Statements .. +*/ +/* + FIND MINIMUM OF P AND Q +*/ + qporq = *p <= *q; + if(!qporq) goto S10; + pp = *p; + goto S20; +S10: + pp = *q; +S20: +/* + INITIALIZATION STEP +*/ + strtx = stvaln(&pp); + xcur = strtx; +/* + NEWTON INTERATIONS +*/ + for(i=1; i<=maxit; i++) { + cumnor(&xcur,&cum,&ccum); + dx = (cum-pp)/dennor(xcur); + xcur -= dx; + if(fabs(dx/xcur) < eps) goto S40; + } + dinvnr = strtx; +/* + IF WE GET HERE, NEWTON HAS FAILED +*/ + if(!qporq) dinvnr = -dinvnr; + return dinvnr; +S40: +/* + IF WE GET HERE, NEWTON HAS SUCCEDED +*/ + dinvnr = xcur; + if(!qporq) dinvnr = -dinvnr; + return dinvnr; +#undef maxit +#undef eps +#undef r2pi +#undef nhalf +#undef dennor +} +/* DEFINE DINVR */ +static void E0000(int IENTRY,int *status,double *x,double *fx, + unsigned long *qleft,unsigned long *qhi,double *zabsst, + double *zabsto,double *zbig,double *zrelst, + double *zrelto,double *zsmall,double *zstpmu) +{ +#define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz)) +static double absstp,abstol,big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi, + xlb,xlo,xsave,xub,yy; +static int i99999; +static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup; + switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;} +DINVR: + if(*status > 0) goto S310; + qcond = !qxmon(small,*x,big); + if(qcond) ftnstop(" SMALL, X, BIG not monotone in INVR"); + xsave = *x; +/* + See that SMALL and BIG bound the zero and set QINCR +*/ + *x = small; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 1; + goto S300; +S10: + fsmall = *fx; + *x = big; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 2; + goto S300; +S20: + fbig = *fx; + qincr = fbig > fsmall; + if(!qincr) goto S50; + if(fsmall <= 0.0e0) goto S30; + *status = -1; + *qleft = *qhi = 1; + return; +S30: + if(fbig >= 0.0e0) goto S40; + *status = -1; + *qleft = *qhi = 0; + return; +S40: + goto S80; +S50: + if(fsmall >= 0.0e0) goto S60; + *status = -1; + *qleft = 1; + *qhi = 0; + return; +S60: + if(fbig <= 0.0e0) goto S70; + *status = -1; + *qleft = 0; + *qhi = 1; + return; +S80: +S70: + *x = xsave; + step = fifdmax1(absstp,relstp*fabs(*x)); +/* + YY = F(X) - Y + GET-FUNCTION-VALUE +*/ + i99999 = 3; + goto S300; +S90: + yy = *fx; + if(!(yy == 0.0e0)) goto S100; + *status = 0; + qok = 1; + return; +S100: + qup = qincr && yy < 0.0e0 || !qincr && yy > 0.0e0; +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + HANDLE CASE IN WHICH WE MUST STEP HIGHER +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +*/ + if(!qup) goto S170; + xlb = xsave; + xub = fifdmin1(xlb+step,big); + goto S120; +S110: + if(qcond) goto S150; +S120: +/* + YY = F(XUB) - Y +*/ + *x = xub; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 4; + goto S300; +S130: + yy = *fx; + qbdd = qincr && yy >= 0.0e0 || !qincr && yy <= 0.0e0; + qlim = xub >= big; + qcond = qbdd || qlim; + if(qcond) goto S140; + step = stpmul*step; + xlb = xub; + xub = fifdmin1(xlb+step,big); +S140: + goto S110; +S150: + if(!(qlim && !qbdd)) goto S160; + *status = -1; + *qleft = 0; + *qhi = !qincr; + *x = big; + return; +S160: + goto S240; +S170: +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + HANDLE CASE IN WHICH WE MUST STEP LOWER +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +*/ + xub = xsave; + xlb = fifdmax1(xub-step,small); + goto S190; +S180: + if(qcond) goto S220; +S190: +/* + YY = F(XLB) - Y +*/ + *x = xlb; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 5; + goto S300; +S200: + yy = *fx; + qbdd = qincr && yy <= 0.0e0 || !qincr && yy >= 0.0e0; + qlim = xlb <= small; + qcond = qbdd || qlim; + if(qcond) goto S210; + step = stpmul*step; + xub = xlb; + xlb = fifdmax1(xub-step,small); +S210: + goto S180; +S220: + if(!(qlim && !qbdd)) goto S230; + *status = -1; + *qleft = 1; + *qhi = qincr; + *x = small; + return; +S240: +S230: + dstzr(&xlb,&xub,&abstol,&reltol); +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F. +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +*/ + *status = 0; + goto S260; +S250: + if(!(*status == 1)) goto S290; +S260: + dzror(status,x,fx,&xlo,&xhi,&qdum1,&qdum2); + if(!(*status == 1)) goto S280; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 6; + goto S300; +S280: +S270: + goto S250; +S290: + *x = xlo; + *status = 0; + return; +DSTINV: + small = *zsmall; + big = *zbig; + absstp = *zabsst; + relstp = *zrelst; + stpmul = *zstpmu; + abstol = *zabsto; + reltol = *zrelto; + return; +S300: +/* + TO GET-FUNCTION-VALUE +*/ + *status = 1; + return; +S310: + switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case + 4: goto S130;case 5: goto S200;case 6: goto S270;default: break;} +#undef qxmon +} +void dinvr(int *status,double *x,double *fx, + unsigned long *qleft,unsigned long *qhi) +/* +********************************************************************** + + void dinvr(int *status,double *x,double *fx, + unsigned long *qleft,unsigned long *qhi) + + Double precision + bounds the zero of the function and invokes zror + Reverse Communication + + + Function + + + Bounds the function and invokes ZROR to perform the zero + finding. STINVR must have been called before this routine + in order to set its parameters. + + + Arguments + + + STATUS <--> At the beginning of a zero finding problem, STATUS + should be set to 0 and INVR invoked. (The value + of parameters other than X will be ignored on this cal + + When INVR needs the function evaluated, it will set + STATUS to 1 and return. The value of the function + should be set in FX and INVR again called without + changing any of its other parameters. + + When INVR has finished without error, it will return + with STATUS 0. In that case X is approximately a root + of F(X). + + If INVR cannot bound the function, it returns status + -1 and sets QLEFT and QHI. + INTEGER STATUS + + X <-- The value of X at which F(X) is to be evaluated. + DOUBLE PRECISION X + + FX --> The value of F(X) calculated when INVR returns with + STATUS = 1. + DOUBLE PRECISION FX + + QLEFT <-- Defined only if QMFINV returns .FALSE. In that + case it is .TRUE. If the stepping search terminated + unsucessfully at SMALL. If it is .FALSE. the search + terminated unsucessfully at BIG. + QLEFT is LOGICAL + + QHI <-- Defined only if QMFINV returns .FALSE. In that + case it is .TRUE. if F(X) .GT. Y at the termination + of the search and .FALSE. if F(X) .LT. Y at the + termination of the search. + QHI is LOGICAL + +********************************************************************** +*/ +{ + E0000(0,status,x,fx,qleft,qhi,NULL,NULL,NULL,NULL,NULL,NULL,NULL); +} +void dstinv(double *zsmall,double *zbig,double *zabsst, + double *zrelst,double *zstpmu,double *zabsto, + double *zrelto) +/* +********************************************************************** + void dstinv(double *zsmall,double *zbig,double *zabsst, + double *zrelst,double *zstpmu,double *zabsto, + double *zrelto) + + Double Precision - SeT INverse finder - Reverse Communication + Function + Concise Description - Given a monotone function F finds X + such that F(X) = Y. Uses Reverse communication -- see invr. + This routine sets quantities needed by INVR. + More Precise Description of INVR - + F must be a monotone function, the results of QMFINV are + otherwise undefined. QINCR must be .TRUE. if F is non- + decreasing and .FALSE. if F is non-increasing. + QMFINV will return .TRUE. if and only if F(SMALL) and + F(BIG) bracket Y, i. e., + QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or + QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL) + if QMFINV returns .TRUE., then the X returned satisfies + the following condition. let + TOL(X) = MAX(ABSTOL,RELTOL*ABS(X)) + then if QINCR is .TRUE., + F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X)) + and if QINCR is .FALSE. + F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X)) + Arguments + SMALL --> The left endpoint of the interval to be + searched for a solution. + SMALL is DOUBLE PRECISION + BIG --> The right endpoint of the interval to be + searched for a solution. + BIG is DOUBLE PRECISION + ABSSTP, RELSTP --> The initial step size in the search + is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm. + ABSSTP is DOUBLE PRECISION + RELSTP is DOUBLE PRECISION + STPMUL --> When a step doesn't bound the zero, the step + size is multiplied by STPMUL and another step + taken. A popular value is 2.0 + DOUBLE PRECISION STPMUL + ABSTOL, RELTOL --> Two numbers that determine the accuracy + of the solution. See function for a precise definition. + ABSTOL is DOUBLE PRECISION + RELTOL is DOUBLE PRECISION + Method + Compares F(X) with Y for the input value of X then uses QINCR + to determine whether to step left or right to bound the + desired x. the initial step size is + MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X. + Iteratively steps right or left until it bounds X. + At each step which doesn't bound X, the step size is doubled. + The routine is careful never to step beyond SMALL or BIG. If + it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE. + after setting QLEFT and QHI. + If X is successfully bounded then Algorithm R of the paper + 'Two Efficient Algorithms with Guaranteed Convergence for + Finding a Zero of a Function' by J. C. P. Bus and + T. J. Dekker in ACM Transactions on Mathematical + Software, Volume 1, No. 4 page 330 (DEC. '75) is employed + to find the zero of the function F(X)-Y. This is routine + QRZERO. +********************************************************************** +*/ +{ + E0000(1,NULL,NULL,NULL,NULL,NULL,zabsst,zabsto,zbig,zrelst,zrelto,zsmall, + zstpmu); +} +double dlanor(double *x) +/* +********************************************************************** + + double dlanor(double *x) + Double precision Logarith of the Asymptotic Normal + + + Function + + + Computes the logarithm of the cumulative normal distribution + from abs( x ) to infinity for abs( x ) >= 5. + + + Arguments + + + X --> Value at which cumulative normal to be evaluated + DOUBLE PRECISION X + + + Method + + + 23 term expansion of formula 26.2.12 of Abramowitz and Stegun. + The relative error at X = 5 is about 0.5E-5. + + + Note + + + ABS(X) must be >= 5 else there is an error stop. + +********************************************************************** +*/ +{ +#define dlsqpi 0.91893853320467274177e0 +static double coef[12] = { + -1.0e0,3.0e0,-15.0e0,105.0e0,-945.0e0,10395.0e0,-135135.0e0,2027025.0e0, + -34459425.0e0,654729075.0e0,-13749310575.e0,316234143225.0e0 +}; +static int K1 = 12; +static double dlanor,approx,correc,xx,xx2,T2; +/* + .. + .. Executable Statements .. +*/ + xx = fabs(*x); + if(xx < 5.0e0) ftnstop(" Argument too small in DLANOR"); + approx = -dlsqpi-0.5e0*xx*xx-log(xx); + xx2 = xx*xx; + T2 = 1.0e0/xx2; + correc = devlpl(coef,&K1,&T2)/xx2; + correc = dln1px(&correc); + dlanor = approx+correc; + return dlanor; +#undef dlsqpi +} +double dln1mx(double *x) +/* +********************************************************************** + + double dln1mx(double *x) + Double precision LN(1-X) + + + Function + + + Returns ln(1-x) for small x (good accuracy if x .le. 0.1). + Note that the obvious code of + LOG(1.0-X) + won't work for small X because 1.0-X loses accuracy + + + Arguments + + + X --> Value for which ln(1-x) is desired. + X is DOUBLE PRECISION + + + Method + + + If X > 0.1, the obvious code above is used ELSE + The Taylor series for 1-x is expanded to 20 terms. + +********************************************************************** +*/ +{ +static double dln1mx,T1; +/* + .. + .. Executable Statements .. +*/ + T1 = -*x; + dln1mx = dln1px(&T1); + return dln1mx; +} +double dln1px(double *a) +/* +********************************************************************** + + double dln1px(double *a) + Double precision LN(1+X) + + + Function + + + Returns ln(1+x) + Note that the obvious code of + LOG(1.0+X) + won't work for small X because 1.0+X loses accuracy + + + Arguments + + + X --> Value for which ln(1-x) is desired. + X is DOUBLE PRECISION + + + Method + + + Renames ALNREL from: + DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant + Digit Computation of the Incomplete Beta Function Ratios. ACM + Trans. Math. Softw. 18 (1993), 360-373. + +********************************************************************** +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION LN(1 + A) +----------------------------------------------------------------------- +*/ +{ +static double p1 = -.129418923021993e+01; +static double p2 = .405303492862024e+00; +static double p3 = -.178874546012214e-01; +static double q1 = -.162752256355323e+01; +static double q2 = .747811014037616e+00; +static double q3 = -.845104217945565e-01; +static double dln1px,t,t2,w,x; +/* + .. + .. Executable Statements .. +*/ + if(fabs(*a) > 0.375e0) goto S10; + t = *a/(*a+2.0e0); + t2 = t*t; + w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0); + dln1px = 2.0e0*t*w; + return dln1px; +S10: + x = 1.e0+*a; + dln1px = log(x); + return dln1px; +} +double dlnbet(double *a0,double *b0) +/* +********************************************************************** + + double dlnbet(a0,b0) + Double precision LN of the complete BETa + + + Function + + + Returns the natural log of the complete beta function, + i.e., + + ln( Gamma(a)*Gamma(b) / Gamma(a+b) + + + Arguments + + + A,B --> The (symmetric) arguments to the complete beta + DOUBLE PRECISION A, B + + + Method + + + Renames BETALN from: + DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant + Digit Computation of the Incomplete Beta Function Ratios. ACM + Trans. Math. Softw. 18 (1993), 360-373. + +********************************************************************** +----------------------------------------------------------------------- + EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION +----------------------------------------------------------------------- + E = 0.5*LN(2*PI) +-------------------------- +*/ +{ +static double e = .918938533204673e0; +static double dlnbet,a,b,c,h,u,v,w,z; +static int i,n; +static double T1; +/* + .. + .. Executable Statements .. +*/ + a = fifdmin1(*a0,*b0); + b = fifdmax1(*a0,*b0); + if(a >= 8.0e0) goto S100; + if(a >= 1.0e0) goto S20; +/* +----------------------------------------------------------------------- + PROCEDURE WHEN A .LT. 1 +----------------------------------------------------------------------- +*/ + if(b >= 8.0e0) goto S10; + T1 = a+b; + dlnbet = gamln(&a)+(gamln(&b)-gamln(&T1)); + return dlnbet; +S10: + dlnbet = gamln(&a)+algdiv(&a,&b); + return dlnbet; +S20: +/* +----------------------------------------------------------------------- + PROCEDURE WHEN 1 .LE. A .LT. 8 +----------------------------------------------------------------------- +*/ + if(a > 2.0e0) goto S40; + if(b > 2.0e0) goto S30; + dlnbet = gamln(&a)+gamln(&b)-gsumln(&a,&b); + return dlnbet; +S30: + w = 0.0e0; + if(b < 8.0e0) goto S60; + dlnbet = gamln(&a)+algdiv(&a,&b); + return dlnbet; +S40: +/* + REDUCTION OF A WHEN B .LE. 1000 +*/ + if(b > 1000.0e0) goto S80; + n = a-1.0e0; + w = 1.0e0; + for(i=1; i<=n; i++) { + a -= 1.0e0; + h = a/b; + w *= (h/(1.0e0+h)); + } + w = log(w); + if(b < 8.0e0) goto S60; + dlnbet = w+gamln(&a)+algdiv(&a,&b); + return dlnbet; +S60: +/* + REDUCTION OF B WHEN B .LT. 8 +*/ + n = b-1.0e0; + z = 1.0e0; + for(i=1; i<=n; i++) { + b -= 1.0e0; + z *= (b/(a+b)); + } + dlnbet = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b))); + return dlnbet; +S80: +/* + REDUCTION OF A WHEN B .GT. 1000 +*/ + n = a-1.0e0; + w = 1.0e0; + for(i=1; i<=n; i++) { + a -= 1.0e0; + w *= (a/(1.0e0+a/b)); + } + dlnbet = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b)); + return dlnbet; +S100: +/* +----------------------------------------------------------------------- + PROCEDURE WHEN A .GE. 8 +----------------------------------------------------------------------- +*/ + w = bcorr(&a,&b); + h = a/b; + c = h/(1.0e0+h); + u = -((a-0.5e0)*log(c)); + v = b*alnrel(&h); + if(u <= v) goto S110; + dlnbet = -(0.5e0*log(b))+e+w-v-u; + return dlnbet; +S110: + dlnbet = -(0.5e0*log(b))+e+w-u-v; + return dlnbet; +} +double dlngam(double *a) +/* +********************************************************************** + + double dlngam(double *a) + Double precision LN of the GAMma function + + + Function + + + Returns the natural logarithm of GAMMA(X). + + + Arguments + + + X --> value at which scaled log gamma is to be returned + X is DOUBLE PRECISION + + + Method + + + Renames GAMLN from: + DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant + Digit Computation of the Incomplete Beta Function Ratios. ACM + Trans. Math. Softw. 18 (1993), 360-373. + +********************************************************************** +----------------------------------------------------------------------- + EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A +----------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS + NAVAL SURFACE WARFARE CENTER + DAHLGREN, VIRGINIA +-------------------------- + D = 0.5*(LN(2*PI) - 1) +-------------------------- +*/ +{ +static double c0 = .833333333333333e-01; +static double c1 = -.277777777760991e-02; +static double c2 = .793650666825390e-03; +static double c3 = -.595202931351870e-03; +static double c4 = .837308034031215e-03; +static double c5 = -.165322962780713e-02; +static double d = .418938533204673e0; +static double dlngam,t,w; +static int i,n; +static double T1; +/* + .. + .. Executable Statements .. +*/ + if(*a > 0.8e0) goto S10; + dlngam = gamln1(a)-log(*a); + return dlngam; +S10: + if(*a > 2.25e0) goto S20; + t = *a-0.5e0-0.5e0; + dlngam = gamln1(&t); + return dlngam; +S20: + if(*a >= 10.0e0) goto S40; + n = *a-1.25e0; + t = *a; + w = 1.0e0; + for(i=1; i<=n; i++) { + t -= 1.0e0; + w = t*w; + } + T1 = t-1.0e0; + dlngam = gamln1(&T1)+log(w); + return dlngam; +S40: + t = pow(1.0e0/ *a,2.0); + w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a; + dlngam = d+w+(*a-0.5e0)*(log(*a)-1.0e0); + return dlngam; +} +double dstrem(double *z) +{ +/* +********************************************************************** + double dstrem(double *z) + Double precision Sterling Remainder + Function + Returns Log(Gamma(Z)) - Sterling(Z) where Sterling(Z) is + Sterling's Approximation to Log(Gamma(Z)) + Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z + Arguments + Z --> Value at which Sterling remainder calculated + Must be positive. + DOUBLE PRECISION Z + Method + If Z >= 6 uses 9 terms of series in Bernoulli numbers + (Values calculated using Maple) + Otherwise computes difference explicitly +********************************************************************** +*/ +#define hln2pi 0.91893853320467274178e0 +#define ncoef 10 +static double coef[ncoef] = { + 0.0e0,0.0833333333333333333333333333333e0, + -0.00277777777777777777777777777778e0,0.000793650793650793650793650793651e0, + -0.000595238095238095238095238095238e0, + 0.000841750841750841750841750841751e0,-0.00191752691752691752691752691753e0, + 0.00641025641025641025641025641026e0,-0.0295506535947712418300653594771e0, + 0.179644372368830573164938490016e0 +}; +static int K1 = 10; +static double dstrem,sterl,T2; +/* + .. + .. Executable Statements .. +*/ +/* + For information, here are the next 11 coefficients of the + remainder term in Sterling's formula + -1.39243221690590111642743221691 + 13.4028640441683919944789510007 + -156.848284626002017306365132452 + 2193.10333333333333333333333333 + -36108.7712537249893571732652192 + 691472.268851313067108395250776 + -0.152382215394074161922833649589D8 + 0.382900751391414141414141414141D9 + -0.108822660357843910890151491655D11 + 0.347320283765002252252252252252D12 + -0.123696021422692744542517103493D14 +*/ + if(*z <= 0.0e0) ftnstop("Zero or negative argument in DSTREM"); + if(!(*z > 6.0e0)) goto S10; + T2 = 1.0e0/pow(*z,2.0); + dstrem = devlpl(coef,&K1,&T2)**z; + goto S20; +S10: + sterl = hln2pi+(*z-0.5e0)*log(*z)-*z; + dstrem = dlngam(z)-sterl; +S20: + return dstrem; +#undef hln2pi +#undef ncoef +} +double dt1(double *p,double *q,double *df) +/* +********************************************************************** + + double dt1(double *p,double *q,double *df) + Double precision Initalize Approximation to + INVerse of the cumulative T distribution + + + Function + + + Returns the inverse of the T distribution function, i.e., + the integral from 0 to INVT of the T density is P. This is an + initial approximation + + + Arguments + + + P --> The p-value whose inverse from the T distribution is + desired. + P is DOUBLE PRECISION + + Q --> 1-P. + Q is DOUBLE PRECISION + + DF --> Degrees of freedom of the T distribution. + DF is DOUBLE PRECISION + +********************************************************************** +*/ +{ +static double coef[4][5] = { + 1.0e0,1.0e0,0.0e0,0.0e0,0.0e0,3.0e0,16.0e0,5.0e0,0.0e0,0.0e0,-15.0e0,17.0e0, + 19.0e0,3.0e0,0.0e0,-945.0e0,-1920.0e0,1482.0e0,776.0e0,79.0e0 +}; +static double denom[4] = { + 4.0e0,96.0e0,384.0e0,92160.0e0 +}; +static int ideg[4] = { + 2,3,4,5 +}; +static double dt1,denpow,sum,term,x,xp,xx; +static int i; +/* + .. + .. Executable Statements .. +*/ + x = fabs(dinvnr(p,q)); + xx = x*x; + sum = x; + denpow = 1.0e0; + for(i=0; i<4; i++) { + term = devlpl(&coef[i][0],&ideg[i],&xx)*x; + denpow *= *df; + sum += (term/(denpow*denom[i])); + } + if(!(*p >= 0.5e0)) goto S20; + xp = sum; + goto S30; +S20: + xp = -sum; +S30: + dt1 = xp; + return dt1; +} +/* DEFINE DZROR */ +static void E0001(int IENTRY,int *status,double *x,double *fx, + double *xlo,double *xhi,unsigned long *qleft, + unsigned long *qhi,double *zabstl,double *zreltl, + double *zxhi,double *zxlo) +{ +#define ftol(zx) (0.5e0*fifdmax1(abstol,reltol*fabs((zx)))) +static double a,abstol,b,c,d,fa,fb,fc,fd,fda,fdb,m,mb,p,q,reltol,tol,w,xxhi,xxlo; +static int ext,i99999; +static unsigned long first,qrzero; + switch(IENTRY){case 0: goto DZROR; case 1: goto DSTZR;} +DZROR: + if(*status > 0) goto S280; + *xlo = xxlo; + *xhi = xxhi; + b = *x = *xlo; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 1; + goto S270; +S10: + fb = *fx; + *xlo = *xhi; + a = *x = *xlo; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 2; + goto S270; +S20: +/* + Check that F(ZXLO) < 0 < F(ZXHI) or + F(ZXLO) > 0 > F(ZXHI) +*/ + if(!(fb < 0.0e0)) goto S40; + if(!(*fx < 0.0e0)) goto S30; + *status = -1; + *qleft = *fx < fb; + *qhi = 0; + return; +S40: +S30: + if(!(fb > 0.0e0)) goto S60; + if(!(*fx > 0.0e0)) goto S50; + *status = -1; + *qleft = *fx > fb; + *qhi = 1; + return; +S60: +S50: + fa = *fx; + first = 1; +S70: + c = a; + fc = fa; + ext = 0; +S80: + if(!(fabs(fc) < fabs(fb))) goto S100; + if(!(c != a)) goto S90; + d = a; + fd = fa; +S90: + a = b; + fa = fb; + *xlo = c; + b = *xlo; + fb = fc; + c = a; + fc = fa; +S100: + tol = ftol(*xlo); + m = (c+b)*.5e0; + mb = m-b; + if(!(fabs(mb) > tol)) goto S240; + if(!(ext > 3)) goto S110; + w = mb; + goto S190; +S110: + tol = fifdsign(tol,mb); + p = (b-a)*fb; + if(!first) goto S120; + q = fa-fb; + first = 0; + goto S130; +S120: + fdb = (fd-fb)/(d-b); + fda = (fd-fa)/(d-a); + p = fda*p; + q = fdb*fa-fda*fb; +S130: + if(!(p < 0.0e0)) goto S140; + p = -p; + q = -q; +S140: + if(ext == 3) p *= 2.0e0; + if(!(p*1.0e0 == 0.0e0 || p <= q*tol)) goto S150; + w = tol; + goto S180; +S150: + if(!(p < mb*q)) goto S160; + w = p/q; + goto S170; +S160: + w = mb; +S190: +S180: +S170: + d = a; + fd = fa; + a = b; + fa = fb; + b += w; + *xlo = b; + *x = *xlo; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 3; + goto S270; +S200: + fb = *fx; + if(!(fc*fb >= 0.0e0)) goto S210; + goto S70; +S210: + if(!(w == mb)) goto S220; + ext = 0; + goto S230; +S220: + ext += 1; +S230: + goto S80; +S240: + *xhi = c; + qrzero = fc >= 0.0e0 && fb <= 0.0e0 || fc < 0.0e0 && fb >= 0.0e0; + if(!qrzero) goto S250; + *status = 0; + goto S260; +S250: + *status = -1; +S260: + return; +DSTZR: + xxlo = *zxlo; + xxhi = *zxhi; + abstol = *zabstl; + reltol = *zreltl; + return; +S270: +/* + TO GET-FUNCTION-VALUE +*/ + *status = 1; + return; +S280: + switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S200; + default: break;} +#undef ftol +} +void dzror(int *status,double *x,double *fx,double *xlo, + double *xhi,unsigned long *qleft,unsigned long *qhi) +/* +********************************************************************** + + void dzror(int *status,double *x,double *fx,double *xlo, + double *xhi,unsigned long *qleft,unsigned long *qhi) + + Double precision ZeRo of a function -- Reverse Communication + + + Function + + + Performs the zero finding. STZROR must have been called before + this routine in order to set its parameters. + + + Arguments + + + STATUS <--> At the beginning of a zero finding problem, STATUS + should be set to 0 and ZROR invoked. (The value + of other parameters will be ignored on this call.) + + When ZROR needs the function evaluated, it will set + STATUS to 1 and return. The value of the function + should be set in FX and ZROR again called without + changing any of its other parameters. + + When ZROR has finished without error, it will return + with STATUS 0. In that case (XLO,XHI) bound the answe + + If ZROR finds an error (which implies that F(XLO)-Y an + F(XHI)-Y have the same sign, it returns STATUS -1. In + this case, XLO and XHI are undefined. + INTEGER STATUS + + X <-- The value of X at which F(X) is to be evaluated. + DOUBLE PRECISION X + + FX --> The value of F(X) calculated when ZROR returns with + STATUS = 1. + DOUBLE PRECISION FX + + XLO <-- When ZROR returns with STATUS = 0, XLO bounds the + inverval in X containing the solution below. + DOUBLE PRECISION XLO + + XHI <-- When ZROR returns with STATUS = 0, XHI bounds the + inverval in X containing the solution above. + DOUBLE PRECISION XHI + + QLEFT <-- .TRUE. if the stepping search terminated unsucessfully + at XLO. If it is .FALSE. the search terminated + unsucessfully at XHI. + QLEFT is LOGICAL + + QHI <-- .TRUE. if F(X) .GT. Y at the termination of the + search and .FALSE. if F(X) .LT. Y at the + termination of the search. + QHI is LOGICAL + +********************************************************************** +*/ +{ + E0001(0,status,x,fx,xlo,xhi,qleft,qhi,NULL,NULL,NULL,NULL); +} +void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl) +/* +********************************************************************** + void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl) + Double precision SeT ZeRo finder - Reverse communication version + Function + Sets quantities needed by ZROR. The function of ZROR + and the quantities set is given here. + Concise Description - Given a function F + find XLO such that F(XLO) = 0. + More Precise Description - + Input condition. F is a double precision function of a single + double precision argument and XLO and XHI are such that + F(XLO)*F(XHI) .LE. 0.0 + If the input condition is met, QRZERO returns .TRUE. + and output values of XLO and XHI satisfy the following + F(XLO)*F(XHI) .LE. 0. + ABS(F(XLO) .LE. ABS(F(XHI) + ABS(XLO-XHI) .LE. TOL(X) + where + TOL(X) = MAX(ABSTOL,RELTOL*ABS(X)) + If this algorithm does not find XLO and XHI satisfying + these conditions then QRZERO returns .FALSE. This + implies that the input condition was not met. + Arguments + XLO --> The left endpoint of the interval to be + searched for a solution. + XLO is DOUBLE PRECISION + XHI --> The right endpoint of the interval to be + for a solution. + XHI is DOUBLE PRECISION + ABSTOL, RELTOL --> Two numbers that determine the accuracy + of the solution. See function for a + precise definition. + ABSTOL is DOUBLE PRECISION + RELTOL is DOUBLE PRECISION + Method + Algorithm R of the paper 'Two Efficient Algorithms with + Guaranteed Convergence for Finding a Zero of a Function' + by J. C. P. Bus and T. J. Dekker in ACM Transactions on + Mathematical Software, Volume 1, no. 4 page 330 + (Dec. '75) is employed to find the zero of F(X)-Y. +********************************************************************** +*/ +{ + E0001(1,NULL,NULL,NULL,NULL,NULL,NULL,NULL,zabstl,zreltl,zxhi,zxlo); +} +double erf1(double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF THE REAL ERROR FUNCTION +----------------------------------------------------------------------- +*/ +{ +static double c = .564189583547756e0; +static double a[5] = { + .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01, + .479137145607681e-01,.128379167095513e+00 +}; +static double b[3] = { + .301048631703895e-02,.538971687740286e-01,.375795757275549e+00 +}; +static double p[8] = { + -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00, + 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02, + 4.51918953711873e+02,3.00459261020162e+02 +}; +static double q[8] = { + 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01, + 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02, + 7.90950925327898e+02,3.00459260956983e+02 +}; +static double r[5] = { + 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01, + 4.65807828718470e+00,2.82094791773523e-01 +}; +static double s[4] = { + 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01, + 1.80124575948747e+01 +}; +static double erf1,ax,bot,t,top,x2; +/* + .. + .. Executable Statements .. +*/ + ax = fabs(*x); + if(ax > 0.5e0) goto S10; + t = *x**x; + top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0; + bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0; + erf1 = *x*(top/bot); + return erf1; +S10: + if(ax > 4.0e0) goto S20; + top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[ + 7]; + bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[ + 7]; + erf1 = 0.5e0+(0.5e0-exp(-(*x**x))*top/bot); + if(*x < 0.0e0) erf1 = -erf1; + return erf1; +S20: + if(ax >= 5.8e0) goto S30; + x2 = *x**x; + t = 1.0e0/x2; + top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4]; + bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0; + erf1 = (c-top/(x2*bot))/ax; + erf1 = 0.5e0+(0.5e0-exp(-x2)*erf1); + if(*x < 0.0e0) erf1 = -erf1; + return erf1; +S30: + erf1 = fifdsign(1.0e0,*x); + return erf1; +} +double erfc1(int *ind,double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION + + ERFC1(IND,X) = ERFC(X) IF IND = 0 + ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE +----------------------------------------------------------------------- +*/ +{ +static double c = .564189583547756e0; +static double a[5] = { + .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01, + .479137145607681e-01,.128379167095513e+00 +}; +static double b[3] = { + .301048631703895e-02,.538971687740286e-01,.375795757275549e+00 +}; +static double p[8] = { + -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00, + 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02, + 4.51918953711873e+02,3.00459261020162e+02 +}; +static double q[8] = { + 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01, + 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02, + 7.90950925327898e+02,3.00459260956983e+02 +}; +static double r[5] = { + 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01, + 4.65807828718470e+00,2.82094791773523e-01 +}; +static double s[4] = { + 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01, + 1.80124575948747e+01 +}; +static int K1 = 1; +static double erfc1,ax,bot,e,t,top,w; +/* + .. + .. Executable Statements .. +*/ +/* + ABS(X) .LE. 0.5 +*/ + ax = fabs(*x); + if(ax > 0.5e0) goto S10; + t = *x**x; + top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0; + bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0; + erfc1 = 0.5e0+(0.5e0-*x*(top/bot)); + if(*ind != 0) erfc1 = exp(t)*erfc1; + return erfc1; +S10: +/* + 0.5 .LT. ABS(X) .LE. 4 +*/ + if(ax > 4.0e0) goto S20; + top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[ + 7]; + bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[ + 7]; + erfc1 = top/bot; + goto S40; +S20: +/* + ABS(X) .GT. 4 +*/ + if(*x <= -5.6e0) goto S60; + if(*ind != 0) goto S30; + if(*x > 100.0e0) goto S70; + if(*x**x > -exparg(&K1)) goto S70; +S30: + t = pow(1.0e0/ *x,2.0); + top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4]; + bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0; + erfc1 = (c-t*top/bot)/ax; +S40: +/* + FINAL ASSEMBLY +*/ + if(*ind == 0) goto S50; + if(*x < 0.0e0) erfc1 = 2.0e0*exp(*x**x)-erfc1; + return erfc1; +S50: + w = *x**x; + t = w; + e = w-t; + erfc1 = (0.5e0+(0.5e0-e))*exp(-t)*erfc1; + if(*x < 0.0e0) erfc1 = 2.0e0-erfc1; + return erfc1; +S60: +/* + LIMIT VALUE FOR LARGE NEGATIVE X +*/ + erfc1 = 2.0e0; + if(*ind != 0) erfc1 = 2.0e0*exp(*x**x); + return erfc1; +S70: +/* + LIMIT VALUE FOR LARGE POSITIVE X + WHEN IND = 0 +*/ + erfc1 = 0.0e0; + return erfc1; +} +double esum(int *mu,double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF EXP(MU + X) +----------------------------------------------------------------------- +*/ +{ +static double esum,w; +/* + .. + .. Executable Statements .. +*/ + if(*x > 0.0e0) goto S10; + if(*mu < 0) goto S20; + w = (double)*mu+*x; + if(w > 0.0e0) goto S20; + esum = exp(w); + return esum; +S10: + if(*mu > 0) goto S20; + w = (double)*mu+*x; + if(w < 0.0e0) goto S20; + esum = exp(w); + return esum; +S20: + w = *mu; + esum = exp(w)*exp(*x); + return esum; +} +double exparg(int *l) +/* +-------------------------------------------------------------------- + IF L = 0 THEN EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH + EXP(W) CAN BE COMPUTED. + + IF L IS NONZERO THEN EXPARG(L) = THE LARGEST NEGATIVE W FOR + WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO. + + NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED. +-------------------------------------------------------------------- +*/ +{ +static int K1 = 4; +static int K2 = 9; +static int K3 = 10; +static double exparg,lnb; +static int b,m; +/* + .. + .. Executable Statements .. +*/ + b = cdf_ipmpar(&K1); + if(b != 2) goto S10; + lnb = .69314718055995e0; + goto S40; +S10: + if(b != 8) goto S20; + lnb = 2.0794415416798e0; + goto S40; +S20: + if(b != 16) goto S30; + lnb = 2.7725887222398e0; + goto S40; +S30: + lnb = log((double)b); +S40: + if(*l == 0) goto S50; + m = cdf_ipmpar(&K2)-1; + exparg = 0.99999e0*((double)m*lnb); + return exparg; +S50: + m = cdf_ipmpar(&K3); + exparg = 0.99999e0*((double)m*lnb); + return exparg; +} +double fpser(double *a,double *b,double *x,double *eps) +/* +----------------------------------------------------------------------- + + EVALUATION OF I (A,B) + X + + FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5. + +----------------------------------------------------------------------- + + SET FPSER = X**A +*/ +{ +static int K1 = 1; +static double fpser,an,c,s,t,tol; +/* + .. + .. Executable Statements .. +*/ + fpser = 1.0e0; + if(*a <= 1.e-3**eps) goto S10; + fpser = 0.0e0; + t = *a*log(*x); + if(t < exparg(&K1)) return fpser; + fpser = exp(t); +S10: +/* + NOTE THAT 1/B(A,B) = B +*/ + fpser = *b/ *a*fpser; + tol = *eps/ *a; + an = *a+1.0e0; + t = *x; + s = t/an; +S20: + an += 1.0e0; + t = *x*t; + c = t/an; + s += c; + if(fabs(c) > tol) goto S20; + fpser *= (1.0e0+*a*s); + return fpser; +} +double gam1(double *a) +/* + ------------------------------------------------------------------ + COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 + ------------------------------------------------------------------ +*/ +{ +static double s1 = .273076135303957e+00; +static double s2 = .559398236957378e-01; +static double p[7] = { + .577215664901533e+00,-.409078193005776e+00,-.230975380857675e+00, + .597275330452234e-01,.766968181649490e-02,-.514889771323592e-02, + .589597428611429e-03 +}; +static double q[5] = { + .100000000000000e+01,.427569613095214e+00,.158451672430138e+00, + .261132021441447e-01,.423244297896961e-02 +}; +static double r[9] = { + -.422784335098468e+00,-.771330383816272e+00,-.244757765222226e+00, + .118378989872749e+00,.930357293360349e-03,-.118290993445146e-01, + .223047661158249e-02,.266505979058923e-03,-.132674909766242e-03 +}; +static double gam1,bot,d,t,top,w,T1; +/* + .. + .. Executable Statements .. +*/ + t = *a; + d = *a-0.5e0; + if(d > 0.0e0) t = d-0.5e0; + T1 = t; + if(T1 < 0) goto S40; + else if(T1 == 0) goto S10; + else goto S20; +S10: + gam1 = 0.0e0; + return gam1; +S20: + top = (((((p[6]*t+p[5])*t+p[4])*t+p[3])*t+p[2])*t+p[1])*t+p[0]; + bot = (((q[4]*t+q[3])*t+q[2])*t+q[1])*t+1.0e0; + w = top/bot; + if(d > 0.0e0) goto S30; + gam1 = *a*w; + return gam1; +S30: + gam1 = t/ *a*(w-0.5e0-0.5e0); + return gam1; +S40: + top = (((((((r[8]*t+r[7])*t+r[6])*t+r[5])*t+r[4])*t+r[3])*t+r[2])*t+r[1])*t+ + r[0]; + bot = (s2*t+s1)*t+1.0e0; + w = top/bot; + if(d > 0.0e0) goto S50; + gam1 = *a*(w+0.5e0+0.5e0); + return gam1; +S50: + gam1 = t*w/ *a; + return gam1; +} +void gaminv(double *a,double *x,double *x0,double *p,double *q, + int *ierr) +/* + ---------------------------------------------------------------------- + INVERSE INCOMPLETE GAMMA RATIO FUNCTION + + GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1. + THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER + ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X + TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE + PARTICULAR COMPUTER ARITHMETIC BEING USED. + + ------------ + + X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0, + AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT + NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN + A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE + IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X. + + X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER + DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET + X0 .LE. 0. + + IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. + WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING + VALUES ... + + IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS + NOT USED. + IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS + WERE PERFORMED. + IERR = -2 (INPUT ERROR) A .LE. 0 + IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A + IS TOO LARGE. + IERR = -4 (INPUT ERROR) P + Q .NE. 1 + IERR = -6 20 ITERATIONS WERE PERFORMED. THE MOST + RECENT VALUE OBTAINED FOR X IS GIVEN. + THIS CANNOT OCCUR IF X0 .LE. 0. + IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X. + THIS MAY OCCUR WHEN X IS APPROXIMATELY 0. + IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE + ROUTINE IS NOT CERTAIN OF ITS ACCURACY. + ITERATION CANNOT BE PERFORMED IN THIS + CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY + WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS + POSITIVE THEN THIS CAN OCCUR WHEN A IS + EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY + LARGE (SAY A .GE. 1.E20). + ---------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS, JR. + NAVAL SURFACE WEAPONS CENTER + DAHLGREN, VIRGINIA + ------------------- +*/ +{ +static double a0 = 3.31125922108741e0; +static double a1 = 11.6616720288968e0; +static double a2 = 4.28342155967104e0; +static double a3 = .213623493715853e0; +static double b1 = 6.61053765625462e0; +static double b2 = 6.40691597760039e0; +static double b3 = 1.27364489782223e0; +static double b4 = .036117081018842e0; +static double c = .577215664901533e0; +static double ln10 = 2.302585e0; +static double tol = 1.e-5; +static double amin[2] = { + 500.0e0,100.0e0 +}; +static double bmin[2] = { + 1.e-28,1.e-13 +}; +static double dmin[2] = { + 1.e-06,1.e-04 +}; +static double emin[2] = { + 2.e-03,6.e-03 +}; +static double eps0[2] = { + 1.e-10,1.e-08 +}; +static int K1 = 1; +static int K2 = 2; +static int K3 = 3; +static int K8 = 0; +static double am1,amax,ap1,ap2,ap3,apn,b,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,pn,qg,qn, + r,rta,s,s2,sum,t,u,w,xmax,xmin,xn,y,z; +static int iop; +static double T4,T5,T6,T7,T9; +/* + .. + .. Executable Statements .. +*/ +/* + ****** E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS. + E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0. + XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE + LARGEST POSITIVE NUMBER. +*/ + e = spmpar(&K1); + xmin = spmpar(&K2); + xmax = spmpar(&K3); + *x = 0.0e0; + if(*a <= 0.0e0) goto S300; + t = *p+*q-1.e0; + if(fabs(t) > e) goto S320; + *ierr = 0; + if(*p == 0.0e0) return; + if(*q == 0.0e0) goto S270; + if(*a == 1.0e0) goto S280; + e2 = 2.0e0*e; + amax = 0.4e-10/(e*e); + iop = 1; + if(e > 1.e-10) iop = 2; + eps = eps0[iop-1]; + xn = *x0; + if(*x0 > 0.0e0) goto S160; +/* + SELECTION OF THE INITIAL APPROXIMATION XN OF X + WHEN A .LT. 1 +*/ + if(*a > 1.0e0) goto S80; + T4 = *a+1.0e0; + g = Xgamm(&T4); + qg = *q*g; + if(qg == 0.0e0) goto S360; + b = qg/ *a; + if(qg > 0.6e0**a) goto S40; + if(*a >= 0.30e0 || b < 0.35e0) goto S10; + t = exp(-(b+c)); + u = t*exp(t); + xn = t*exp(u); + goto S160; +S10: + if(b >= 0.45e0) goto S40; + if(b == 0.0e0) goto S360; + y = -log(b); + s = 0.5e0+(0.5e0-*a); + z = log(y); + t = y-s*z; + if(b < 0.15e0) goto S20; + xn = y-s*log(t)-log(1.0e0+s/(t+1.0e0)); + goto S220; +S20: + if(b <= 0.01e0) goto S30; + u = ((t+2.0e0*(3.0e0-*a))*t+(2.0e0-*a)*(3.0e0-*a))/((t+(5.0e0-*a))*t+2.0e0); + xn = y-s*log(t)-log(u); + goto S220; +S30: + c1 = -(s*z); + c2 = -(s*(1.0e0+c1)); + c3 = s*((0.5e0*c1+(2.0e0-*a))*c1+(2.5e0-1.5e0**a)); + c4 = -(s*(((c1/3.0e0+(2.5e0-1.5e0**a))*c1+((*a-6.0e0)**a+7.0e0))*c1+( + (11.0e0**a-46.0)**a+47.0e0)/6.0e0)); + c5 = -(s*((((-(c1/4.0e0)+(11.0e0**a-17.0e0)/6.0e0)*c1+((-(3.0e0**a)+13.0e0)* + *a-13.0e0))*c1+0.5e0*(((2.0e0**a-25.0e0)**a+72.0e0)**a-61.0e0))*c1+(( + (25.0e0**a-195.0e0)**a+477.0e0)**a-379.0e0)/12.0e0)); + xn = (((c5/y+c4)/y+c3)/y+c2)/y+c1+y; + if(*a > 1.0e0) goto S220; + if(b > bmin[iop-1]) goto S220; + *x = xn; + return; +S40: + if(b**q > 1.e-8) goto S50; + xn = exp(-(*q/ *a+c)); + goto S70; +S50: + if(*p <= 0.9e0) goto S60; + T5 = -*q; + xn = exp((alnrel(&T5)+gamln1(a))/ *a); + goto S70; +S60: + xn = exp(log(*p*g)/ *a); +S70: + if(xn == 0.0e0) goto S310; + t = 0.5e0+(0.5e0-xn/(*a+1.0e0)); + xn /= t; + goto S160; +S80: +/* + SELECTION OF THE INITIAL APPROXIMATION XN OF X + WHEN A .GT. 1 +*/ + if(*q <= 0.5e0) goto S90; + w = log(*p); + goto S100; +S90: + w = log(*q); +S100: + t = sqrt(-(2.0e0*w)); + s = t-(((a3*t+a2)*t+a1)*t+a0)/((((b4*t+b3)*t+b2)*t+b1)*t+1.0e0); + if(*q > 0.5e0) s = -s; + rta = sqrt(*a); + s2 = s*s; + xn = *a+s*rta+(s2-1.0e0)/3.0e0+s*(s2-7.0e0)/(36.0e0*rta)-((3.0e0*s2+7.0e0)* + s2-16.0e0)/(810.0e0**a)+s*((9.0e0*s2+256.0e0)*s2-433.0e0)/(38880.0e0**a* + rta); + xn = fifdmax1(xn,0.0e0); + if(*a < amin[iop-1]) goto S110; + *x = xn; + d = 0.5e0+(0.5e0-*x/ *a); + if(fabs(d) <= dmin[iop-1]) return; +S110: + if(*p <= 0.5e0) goto S130; + if(xn < 3.0e0**a) goto S220; + y = -(w+gamln(a)); + d = fifdmax1(2.0e0,*a*(*a-1.0e0)); + if(y < ln10*d) goto S120; + s = 1.0e0-*a; + z = log(y); + goto S30; +S120: + t = *a-1.0e0; + T6 = -(t/(xn+1.0e0)); + xn = y+t*log(xn)-alnrel(&T6); + T7 = -(t/(xn+1.0e0)); + xn = y+t*log(xn)-alnrel(&T7); + goto S220; +S130: + ap1 = *a+1.0e0; + if(xn > 0.70e0*ap1) goto S170; + w += gamln(&ap1); + if(xn > 0.15e0*ap1) goto S140; + ap2 = *a+2.0e0; + ap3 = *a+3.0e0; + *x = exp((w+*x)/ *a); + *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a); + *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a); + *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2*(1.0e0+*x/ap3))))/ *a); + xn = *x; + if(xn > 1.e-2*ap1) goto S140; + if(xn <= emin[iop-1]*ap1) return; + goto S170; +S140: + apn = ap1; + t = xn/apn; + sum = 1.0e0+t; +S150: + apn += 1.0e0; + t *= (xn/apn); + sum += t; + if(t > 1.e-4) goto S150; + t = w-log(sum); + xn = exp((xn+t)/ *a); + xn *= (1.0e0-(*a*log(xn)-xn-t)/(*a-xn)); + goto S170; +S160: +/* + SCHRODER ITERATION USING P +*/ + if(*p > 0.5e0) goto S220; +S170: + if(*p <= 1.e10*xmin) goto S350; + am1 = *a-0.5e0-0.5e0; +S180: + if(*a <= amax) goto S190; + d = 0.5e0+(0.5e0-xn/ *a); + if(fabs(d) <= e2) goto S350; +S190: + if(*ierr >= 20) goto S330; + *ierr += 1; + gratio(a,&xn,&pn,&qn,&K8); + if(pn == 0.0e0 || qn == 0.0e0) goto S350; + r = rcomp(a,&xn); + if(r == 0.0e0) goto S350; + t = (pn-*p)/r; + w = 0.5e0*(am1-xn); + if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S200; + *x = xn*(1.0e0-t); + if(*x <= 0.0e0) goto S340; + d = fabs(t); + goto S210; +S200: + h = t*(1.0e0+w*t); + *x = xn*(1.0e0-h); + if(*x <= 0.0e0) goto S340; + if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return; + d = fabs(h); +S210: + xn = *x; + if(d > tol) goto S180; + if(d <= eps) return; + if(fabs(*p-pn) <= tol**p) return; + goto S180; +S220: +/* + SCHRODER ITERATION USING Q +*/ + if(*q <= 1.e10*xmin) goto S350; + am1 = *a-0.5e0-0.5e0; +S230: + if(*a <= amax) goto S240; + d = 0.5e0+(0.5e0-xn/ *a); + if(fabs(d) <= e2) goto S350; +S240: + if(*ierr >= 20) goto S330; + *ierr += 1; + gratio(a,&xn,&pn,&qn,&K8); + if(pn == 0.0e0 || qn == 0.0e0) goto S350; + r = rcomp(a,&xn); + if(r == 0.0e0) goto S350; + t = (*q-qn)/r; + w = 0.5e0*(am1-xn); + if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S250; + *x = xn*(1.0e0-t); + if(*x <= 0.0e0) goto S340; + d = fabs(t); + goto S260; +S250: + h = t*(1.0e0+w*t); + *x = xn*(1.0e0-h); + if(*x <= 0.0e0) goto S340; + if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return; + d = fabs(h); +S260: + xn = *x; + if(d > tol) goto S230; + if(d <= eps) return; + if(fabs(*q-qn) <= tol**q) return; + goto S230; +S270: +/* + SPECIAL CASES +*/ + *x = xmax; + return; +S280: + if(*q < 0.9e0) goto S290; + T9 = -*p; + *x = -alnrel(&T9); + return; +S290: + *x = -log(*q); + return; +S300: +/* + ERROR RETURN +*/ + *ierr = -2; + return; +S310: + *ierr = -3; + return; +S320: + *ierr = -4; + return; +S330: + *ierr = -6; + return; +S340: + *ierr = -7; + return; +S350: + *x = xn; + *ierr = -8; + return; +S360: + *x = xmax; + *ierr = -8; + return; +} +double gamln(double *a) +/* +----------------------------------------------------------------------- + EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A +----------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS + NAVAL SURFACE WARFARE CENTER + DAHLGREN, VIRGINIA +-------------------------- + D = 0.5*(LN(2*PI) - 1) +-------------------------- +*/ +{ +static double c0 = .833333333333333e-01; +static double c1 = -.277777777760991e-02; +static double c2 = .793650666825390e-03; +static double c3 = -.595202931351870e-03; +static double c4 = .837308034031215e-03; +static double c5 = -.165322962780713e-02; +static double d = .418938533204673e0; +static double gamln,t,w; +static int i,n; +static double T1; +/* + .. + .. Executable Statements .. +*/ + if(*a > 0.8e0) goto S10; + gamln = gamln1(a)-log(*a); + return gamln; +S10: + if(*a > 2.25e0) goto S20; + t = *a-0.5e0-0.5e0; + gamln = gamln1(&t); + return gamln; +S20: + if(*a >= 10.0e0) goto S40; + n = *a-1.25e0; + t = *a; + w = 1.0e0; + for(i=1; i<=n; i++) { + t -= 1.0e0; + w = t*w; + } + T1 = t-1.0e0; + gamln = gamln1(&T1)+log(w); + return gamln; +S40: + t = pow(1.0e0/ *a,2.0); + w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a; + gamln = d+w+(*a-0.5e0)*(log(*a)-1.0e0); + return gamln; +} +double gamln1(double *a) +/* +----------------------------------------------------------------------- + EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25 +----------------------------------------------------------------------- +*/ +{ +static double p0 = .577215664901533e+00; +static double p1 = .844203922187225e+00; +static double p2 = -.168860593646662e+00; +static double p3 = -.780427615533591e+00; +static double p4 = -.402055799310489e+00; +static double p5 = -.673562214325671e-01; +static double p6 = -.271935708322958e-02; +static double q1 = .288743195473681e+01; +static double q2 = .312755088914843e+01; +static double q3 = .156875193295039e+01; +static double q4 = .361951990101499e+00; +static double q5 = .325038868253937e-01; +static double q6 = .667465618796164e-03; +static double r0 = .422784335098467e+00; +static double r1 = .848044614534529e+00; +static double r2 = .565221050691933e+00; +static double r3 = .156513060486551e+00; +static double r4 = .170502484022650e-01; +static double r5 = .497958207639485e-03; +static double s1 = .124313399877507e+01; +static double s2 = .548042109832463e+00; +static double s3 = .101552187439830e+00; +static double s4 = .713309612391000e-02; +static double s5 = .116165475989616e-03; +static double gamln1,w,x; +/* + .. + .. Executable Statements .. +*/ + if(*a >= 0.6e0) goto S10; + w = ((((((p6**a+p5)**a+p4)**a+p3)**a+p2)**a+p1)**a+p0)/((((((q6**a+q5)**a+ + q4)**a+q3)**a+q2)**a+q1)**a+1.0e0); + gamln1 = -(*a*w); + return gamln1; +S10: + x = *a-0.5e0-0.5e0; + w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/(((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x + +1.0e0); + gamln1 = x*w; + return gamln1; +} +double Xgamm(double *a) +/* +----------------------------------------------------------------------- + + EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS + + ----------- + + GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT + BE COMPUTED. + +----------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS, JR. + NAVAL SURFACE WEAPONS CENTER + DAHLGREN, VIRGINIA +----------------------------------------------------------------------- +*/ +{ +static double d = .41893853320467274178e0; +static double pi = 3.1415926535898e0; +static double r1 = .820756370353826e-03; +static double r2 = -.595156336428591e-03; +static double r3 = .793650663183693e-03; +static double r4 = -.277777777770481e-02; +static double r5 = .833333333333333e-01; +static double p[7] = { + .539637273585445e-03,.261939260042690e-02,.204493667594920e-01, + .730981088720487e-01,.279648642639792e+00,.553413866010467e+00,1.0e0 +}; +static double q[7] = { + -.832979206704073e-03,.470059485860584e-02,.225211131035340e-01, + -.170458969313360e+00,-.567902761974940e-01,.113062953091122e+01,1.0e0 +}; +static int K2 = 3; +static int K3 = 0; +static double Xgamm,bot,g,lnx,s,t,top,w,x,z; +static int i,j,m,n,T1; +/* + .. + .. Executable Statements .. +*/ + Xgamm = 0.0e0; + x = *a; + if(fabs(*a) >= 15.0e0) goto S110; +/* +----------------------------------------------------------------------- + EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15 +----------------------------------------------------------------------- +*/ + t = 1.0e0; + m = fifidint(*a)-1; +/* + LET T BE THE PRODUCT OF A-J WHEN A .GE. 2 +*/ + T1 = m; + if(T1 < 0) goto S40; + else if(T1 == 0) goto S30; + else goto S10; +S10: + for(j=1; j<=m; j++) { + x -= 1.0e0; + t = x*t; + } +S30: + x -= 1.0e0; + goto S80; +S40: +/* + LET T BE THE PRODUCT OF A+J WHEN A .LT. 1 +*/ + t = *a; + if(*a > 0.0e0) goto S70; + m = -m-1; + if(m == 0) goto S60; + for(j=1; j<=m; j++) { + x += 1.0e0; + t = x*t; + } +S60: + x += (0.5e0+0.5e0); + t = x*t; + if(t == 0.0e0) return Xgamm; +S70: +/* + THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS + CODE MAY BE OMITTED IF DESIRED. +*/ + if(fabs(t) >= 1.e-30) goto S80; + if(fabs(t)*spmpar(&K2) <= 1.0001e0) return Xgamm; + Xgamm = 1.0e0/t; + return Xgamm; +S80: +/* + COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1 +*/ + top = p[0]; + bot = q[0]; + for(i=1; i<7; i++) { + top = p[i]+x*top; + bot = q[i]+x*bot; + } + Xgamm = top/bot; +/* + TERMINATION +*/ + if(*a < 1.0e0) goto S100; + Xgamm *= t; + return Xgamm; +S100: + Xgamm /= t; + return Xgamm; +S110: +/* +----------------------------------------------------------------------- + EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15 +----------------------------------------------------------------------- +*/ + if(fabs(*a) >= 1.e3) return Xgamm; + if(*a > 0.0e0) goto S120; + x = -*a; + n = x; + t = x-(double)n; + if(t > 0.9e0) t = 1.0e0-t; + s = sin(pi*t)/pi; + if(fifmod(n,2) == 0) s = -s; + if(s == 0.0e0) return Xgamm; +S120: +/* + COMPUTE THE MODIFIED ASYMPTOTIC SUM +*/ + t = 1.0e0/(x*x); + g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x; +/* + ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X) + BUT LESS ACCURACY WILL NORMALLY BE OBTAINED. +*/ + lnx = log(x); +/* + FINAL ASSEMBLY +*/ + z = x; + g = d+g+(z-0.5e0)*(lnx-1.e0); + w = g; + t = g-w; + if(w > 0.99999e0*exparg(&K3)) return Xgamm; + Xgamm = exp(w)*(1.0e0+t); + if(*a < 0.0e0) Xgamm = 1.0e0/(Xgamm*s)/x; + return Xgamm; +} +void grat1(double *a,double *x,double *r,double *p,double *q, + double *eps) +{ +static int K2 = 0; +static double a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,t,tol,w,z,T1,T3; +/* + .. + .. Executable Statements .. +*/ +/* +----------------------------------------------------------------------- + EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS + P(A,X) AND Q(A,X) + IT IS ASSUMED THAT A .LE. 1. EPS IS THE TOLERANCE TO BE USED. + THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A). +----------------------------------------------------------------------- +*/ + if(*a**x == 0.0e0) goto S120; + if(*a == 0.5e0) goto S100; + if(*x < 1.1e0) goto S10; + goto S60; +S10: +/* + TAYLOR SERIES FOR P(A,X)/X**A +*/ + an = 3.0e0; + c = *x; + sum = *x/(*a+3.0e0); + tol = 0.1e0**eps/(*a+1.0e0); +S20: + an += 1.0e0; + c = -(c*(*x/an)); + t = c/(*a+an); + sum += t; + if(fabs(t) > tol) goto S20; + j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0)); + z = *a*log(*x); + h = gam1(a); + g = 1.0e0+h; + if(*x < 0.25e0) goto S30; + if(*a < *x/2.59e0) goto S50; + goto S40; +S30: + if(z > -.13394e0) goto S50; +S40: + w = exp(z); + *p = w*g*(0.5e0+(0.5e0-j)); + *q = 0.5e0+(0.5e0-*p); + return; +S50: + l = rexp(&z); + w = 0.5e0+(0.5e0+l); + *q = (w*j-l)*g-h; + if(*q < 0.0e0) goto S90; + *p = 0.5e0+(0.5e0-*q); + return; +S60: +/* + CONTINUED FRACTION EXPANSION +*/ + a2nm1 = a2n = 1.0e0; + b2nm1 = *x; + b2n = *x+(1.0e0-*a); + c = 1.0e0; +S70: + a2nm1 = *x*a2n+c*a2nm1; + b2nm1 = *x*b2n+c*b2nm1; + am0 = a2nm1/b2nm1; + c += 1.0e0; + cma = c-*a; + a2n = a2nm1+cma*a2n; + b2n = b2nm1+cma*b2n; + an0 = a2n/b2n; + if(fabs(an0-am0) >= *eps*an0) goto S70; + *q = *r*an0; + *p = 0.5e0+(0.5e0-*q); + return; +S80: +/* + SPECIAL CASES +*/ + *p = 0.0e0; + *q = 1.0e0; + return; +S90: + *p = 1.0e0; + *q = 0.0e0; + return; +S100: + if(*x >= 0.25e0) goto S110; + T1 = sqrt(*x); + *p = erf1(&T1); + *q = 0.5e0+(0.5e0-*p); + return; +S110: + T3 = sqrt(*x); + *q = erfc1(&K2,&T3); + *p = 0.5e0+(0.5e0-*q); + return; +S120: + if(*x <= *a) goto S80; + goto S90; +} +void gratio(double *a,double *x,double *ans,double *qans,int *ind) +/* + ---------------------------------------------------------------------- + EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS + P(A,X) AND Q(A,X) + + ---------- + + IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X + ARE NOT BOTH 0. + + ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE + P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER. + IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS + POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF + IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE + 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY + IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT. + + ERROR RETURN ... + ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE, + WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT. + P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN + X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE. + ---------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS, JR. + NAVAL SURFACE WEAPONS CENTER + DAHLGREN, VIRGINIA + -------------------- +*/ +{ +static double alog10 = 2.30258509299405e0; +static double d10 = -.185185185185185e-02; +static double d20 = .413359788359788e-02; +static double d30 = .649434156378601e-03; +static double d40 = -.861888290916712e-03; +static double d50 = -.336798553366358e-03; +static double d60 = .531307936463992e-03; +static double d70 = .344367606892378e-03; +static double rt2pin = .398942280401433e0; +static double rtpi = 1.77245385090552e0; +static double third = .333333333333333e0; +static double acc0[3] = { + 5.e-15,5.e-7,5.e-4 +}; +static double big[3] = { + 20.0e0,14.0e0,10.0e0 +}; +static double d0[13] = { + .833333333333333e-01,-.148148148148148e-01,.115740740740741e-02, + .352733686067019e-03,-.178755144032922e-03,.391926317852244e-04, + -.218544851067999e-05,-.185406221071516e-05,.829671134095309e-06, + -.176659527368261e-06,.670785354340150e-08,.102618097842403e-07, + -.438203601845335e-08 +}; +static double d1[12] = { + -.347222222222222e-02,.264550264550265e-02,-.990226337448560e-03, + .205761316872428e-03,-.401877572016461e-06,-.180985503344900e-04, + .764916091608111e-05,-.161209008945634e-05,.464712780280743e-08, + .137863344691572e-06,-.575254560351770e-07,.119516285997781e-07 +}; +static double d2[10] = { + -.268132716049383e-02,.771604938271605e-03,.200938786008230e-05, + -.107366532263652e-03,.529234488291201e-04,-.127606351886187e-04, + .342357873409614e-07,.137219573090629e-05,-.629899213838006e-06, + .142806142060642e-06 +}; +static double d3[8] = { + .229472093621399e-03,-.469189494395256e-03,.267720632062839e-03, + -.756180167188398e-04,-.239650511386730e-06,.110826541153473e-04, + -.567495282699160e-05,.142309007324359e-05 +}; +static double d4[6] = { + .784039221720067e-03,-.299072480303190e-03,-.146384525788434e-05, + .664149821546512e-04,-.396836504717943e-04,.113757269706784e-04 +}; +static double d5[4] = { + -.697281375836586e-04,.277275324495939e-03,-.199325705161888e-03, + .679778047793721e-04 +}; +static double d6[2] = { + -.592166437353694e-03,.270878209671804e-03 +}; +static double e00[3] = { + .25e-3,.25e-1,.14e0 +}; +static double x00[3] = { + 31.0e0,17.0e0,9.7e0 +}; +static int K1 = 1; +static int K2 = 0; +static double a2n,a2nm1,acc,am0,amn,an,an0,apn,b2n,b2nm1,c,c0,c1,c2,c3,c4,c5,c6, + cma,e,e0,g,h,j,l,r,rta,rtx,s,sum,t,t1,tol,twoa,u,w,x0,y,z; +static int i,iop,m,max,n; +static double wk[20],T3; +static int T4,T5; +static double T6,T7; +/* + .. + .. Executable Statements .. +*/ +/* + -------------------- + ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST + FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . +*/ + e = spmpar(&K1); + if(*a < 0.0e0 || *x < 0.0e0) goto S430; + if(*a == 0.0e0 && *x == 0.0e0) goto S430; + if(*a**x == 0.0e0) goto S420; + iop = *ind+1; + if(iop != 1 && iop != 2) iop = 3; + acc = fifdmax1(acc0[iop-1],e); + e0 = e00[iop-1]; + x0 = x00[iop-1]; +/* + SELECT THE APPROPRIATE ALGORITHM +*/ + if(*a >= 1.0e0) goto S10; + if(*a == 0.5e0) goto S390; + if(*x < 1.1e0) goto S160; + t1 = *a*log(*x)-*x; + u = *a*exp(t1); + if(u == 0.0e0) goto S380; + r = u*(1.0e0+gam1(a)); + goto S250; +S10: + if(*a >= big[iop-1]) goto S30; + if(*a > *x || *x >= x0) goto S20; + twoa = *a+*a; + m = fifidint(twoa); + if(twoa != (double)m) goto S20; + i = m/2; + if(*a == (double)i) goto S210; + goto S220; +S20: + t1 = *a*log(*x)-*x; + r = exp(t1)/Xgamm(a); + goto S40; +S30: + l = *x/ *a; + if(l == 0.0e0) goto S370; + s = 0.5e0+(0.5e0-l); + z = rlog(&l); + if(z >= 700.0e0/ *a) goto S410; + y = *a*z; + rta = sqrt(*a); + if(fabs(s) <= e0/rta) goto S330; + if(fabs(s) <= 0.4e0) goto S270; + t = pow(1.0e0/ *a,2.0); + t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0); + t1 -= y; + r = rt2pin*rta*exp(t1); +S40: + if(r == 0.0e0) goto S420; + if(*x <= fifdmax1(*a,alog10)) goto S50; + if(*x < x0) goto S250; + goto S100; +S50: +/* + TAYLOR SERIES FOR P/R +*/ + apn = *a+1.0e0; + t = *x/apn; + wk[0] = t; + for(n=2; n<=20; n++) { + apn += 1.0e0; + t *= (*x/apn); + if(t <= 1.e-3) goto S70; + wk[n-1] = t; + } + n = 20; +S70: + sum = t; + tol = 0.5e0*acc; +S80: + apn += 1.0e0; + t *= (*x/apn); + sum += t; + if(t > tol) goto S80; + max = n-1; + for(m=1; m<=max; m++) { + n -= 1; + sum += wk[n-1]; + } + *ans = r/ *a*(1.0e0+sum); + *qans = 0.5e0+(0.5e0-*ans); + return; +S100: +/* + ASYMPTOTIC EXPANSION +*/ + amn = *a-1.0e0; + t = amn/ *x; + wk[0] = t; + for(n=2; n<=20; n++) { + amn -= 1.0e0; + t *= (amn/ *x); + if(fabs(t) <= 1.e-3) goto S120; + wk[n-1] = t; + } + n = 20; +S120: + sum = t; +S130: + if(fabs(t) <= acc) goto S140; + amn -= 1.0e0; + t *= (amn/ *x); + sum += t; + goto S130; +S140: + max = n-1; + for(m=1; m<=max; m++) { + n -= 1; + sum += wk[n-1]; + } + *qans = r/ *x*(1.0e0+sum); + *ans = 0.5e0+(0.5e0-*qans); + return; +S160: +/* + TAYLOR SERIES FOR P(A,X)/X**A +*/ + an = 3.0e0; + c = *x; + sum = *x/(*a+3.0e0); + tol = 3.0e0*acc/(*a+1.0e0); +S170: + an += 1.0e0; + c = -(c*(*x/an)); + t = c/(*a+an); + sum += t; + if(fabs(t) > tol) goto S170; + j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0)); + z = *a*log(*x); + h = gam1(a); + g = 1.0e0+h; + if(*x < 0.25e0) goto S180; + if(*a < *x/2.59e0) goto S200; + goto S190; +S180: + if(z > -.13394e0) goto S200; +S190: + w = exp(z); + *ans = w*g*(0.5e0+(0.5e0-j)); + *qans = 0.5e0+(0.5e0-*ans); + return; +S200: + l = rexp(&z); + w = 0.5e0+(0.5e0+l); + *qans = (w*j-l)*g-h; + if(*qans < 0.0e0) goto S380; + *ans = 0.5e0+(0.5e0-*qans); + return; +S210: +/* + FINITE SUMS FOR Q WHEN A .GE. 1 + AND 2*A IS AN INTEGER +*/ + sum = exp(-*x); + t = sum; + n = 1; + c = 0.0e0; + goto S230; +S220: + rtx = sqrt(*x); + sum = erfc1(&K2,&rtx); + t = exp(-*x)/(rtpi*rtx); + n = 0; + c = -0.5e0; +S230: + if(n == i) goto S240; + n += 1; + c += 1.0e0; + t = *x*t/c; + sum += t; + goto S230; +S240: + *qans = sum; + *ans = 0.5e0+(0.5e0-*qans); + return; +S250: +/* + CONTINUED FRACTION EXPANSION +*/ + tol = fifdmax1(5.0e0*e,acc); + a2nm1 = a2n = 1.0e0; + b2nm1 = *x; + b2n = *x+(1.0e0-*a); + c = 1.0e0; +S260: + a2nm1 = *x*a2n+c*a2nm1; + b2nm1 = *x*b2n+c*b2nm1; + am0 = a2nm1/b2nm1; + c += 1.0e0; + cma = c-*a; + a2n = a2nm1+cma*a2n; + b2n = b2nm1+cma*b2n; + an0 = a2n/b2n; + if(fabs(an0-am0) >= tol*an0) goto S260; + *qans = r*an0; + *ans = 0.5e0+(0.5e0-*qans); + return; +S270: +/* + GENERAL TEMME EXPANSION +*/ + if(fabs(s) <= 2.0e0*e && *a*e*e > 3.28e-3) goto S430; + c = exp(-y); + T3 = sqrt(y); + w = 0.5e0*erfc1(&K1,&T3); + u = 1.0e0/ *a; + z = sqrt(z+z); + if(l < 1.0e0) z = -z; + T4 = iop-2; + if(T4 < 0) goto S280; + else if(T4 == 0) goto S290; + else goto S300; +S280: + if(fabs(s) <= 1.e-3) goto S340; + c0 = ((((((((((((d0[12]*z+d0[11])*z+d0[10])*z+d0[9])*z+d0[8])*z+d0[7])*z+d0[ + 6])*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third; + c1 = (((((((((((d1[11]*z+d1[10])*z+d1[9])*z+d1[8])*z+d1[7])*z+d1[6])*z+d1[5] + )*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; + c2 = (((((((((d2[9]*z+d2[8])*z+d2[7])*z+d2[6])*z+d2[5])*z+d2[4])*z+d2[3])*z+ + d2[2])*z+d2[1])*z+d2[0])*z+d20; + c3 = (((((((d3[7]*z+d3[6])*z+d3[5])*z+d3[4])*z+d3[3])*z+d3[2])*z+d3[1])*z+ + d3[0])*z+d30; + c4 = (((((d4[5]*z+d4[4])*z+d4[3])*z+d4[2])*z+d4[1])*z+d4[0])*z+d40; + c5 = (((d5[3]*z+d5[2])*z+d5[1])*z+d5[0])*z+d50; + c6 = (d6[1]*z+d6[0])*z+d60; + t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0; + goto S310; +S290: + c0 = (((((d0[5]*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third; + c1 = (((d1[3]*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; + c2 = d2[0]*z+d20; + t = (c2*u+c1)*u+c0; + goto S310; +S300: + t = ((d0[2]*z+d0[1])*z+d0[0])*z-third; +S310: + if(l < 1.0e0) goto S320; + *qans = c*(w+rt2pin*t/rta); + *ans = 0.5e0+(0.5e0-*qans); + return; +S320: + *ans = c*(w-rt2pin*t/rta); + *qans = 0.5e0+(0.5e0-*ans); + return; +S330: +/* + TEMME EXPANSION FOR L = 1 +*/ + if(*a*e*e > 3.28e-3) goto S430; + c = 0.5e0+(0.5e0-y); + w = (0.5e0-sqrt(y)*(0.5e0+(0.5e0-y/3.0e0))/rtpi)/c; + u = 1.0e0/ *a; + z = sqrt(z+z); + if(l < 1.0e0) z = -z; + T5 = iop-2; + if(T5 < 0) goto S340; + else if(T5 == 0) goto S350; + else goto S360; +S340: + c0 = ((((((d0[6]*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z- + third; + c1 = (((((d1[5]*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; + c2 = ((((d2[4]*z+d2[3])*z+d2[2])*z+d2[1])*z+d2[0])*z+d20; + c3 = (((d3[3]*z+d3[2])*z+d3[1])*z+d3[0])*z+d30; + c4 = (d4[1]*z+d4[0])*z+d40; + c5 = (d5[1]*z+d5[0])*z+d50; + c6 = d6[0]*z+d60; + t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0; + goto S310; +S350: + c0 = (d0[1]*z+d0[0])*z-third; + c1 = d1[0]*z+d10; + t = (d20*u+c1)*u+c0; + goto S310; +S360: + t = d0[0]*z-third; + goto S310; +S370: +/* + SPECIAL CASES +*/ + *ans = 0.0e0; + *qans = 1.0e0; + return; +S380: + *ans = 1.0e0; + *qans = 0.0e0; + return; +S390: + if(*x >= 0.25e0) goto S400; + T6 = sqrt(*x); + *ans = erf1(&T6); + *qans = 0.5e0+(0.5e0-*ans); + return; +S400: + T7 = sqrt(*x); + *qans = erfc1(&K2,&T7); + *ans = 0.5e0+(0.5e0-*qans); + return; +S410: + if(fabs(s) <= 2.0e0*e) goto S430; +S420: + if(*x <= *a) goto S370; + goto S380; +S430: +/* + ERROR RETURN +*/ + *ans = 2.0e0; + return; +} +double gsumln(double *a,double *b) +/* +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) + FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 +----------------------------------------------------------------------- +*/ +{ +static double gsumln,x,T1,T2; +/* + .. + .. Executable Statements .. +*/ + x = *a+*b-2.e0; + if(x > 0.25e0) goto S10; + T1 = 1.0e0+x; + gsumln = gamln1(&T1); + return gsumln; +S10: + if(x > 1.25e0) goto S20; + gsumln = gamln1(&x)+alnrel(&x); + return gsumln; +S20: + T2 = x-1.0e0; + gsumln = gamln1(&T2)+log(x*(1.0e0+x)); + return gsumln; +} +double psi(double *xx) +/* +--------------------------------------------------------------------- + + EVALUATION OF THE DIGAMMA FUNCTION + + ----------- + + PSI(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT + BE COMPUTED. + + THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV + APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY + CODY, STRECOK AND THACHER. + +--------------------------------------------------------------------- + PSI WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK + PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI WAS MODIFIED BY + A.H. MORRIS (NSWC). +--------------------------------------------------------------------- +*/ +{ +static double dx0 = 1.461632144968362341262659542325721325e0; +static double piov4 = .785398163397448e0; +static double p1[7] = { + .895385022981970e-02,.477762828042627e+01,.142441585084029e+03, + .118645200713425e+04,.363351846806499e+04,.413810161269013e+04, + .130560269827897e+04 +}; +static double p2[4] = { + -.212940445131011e+01,-.701677227766759e+01,-.448616543918019e+01, + -.648157123766197e+00 +}; +static double q1[6] = { + .448452573429826e+02,.520752771467162e+03,.221000799247830e+04, + .364127349079381e+04,.190831076596300e+04,.691091682714533e-05 +}; +static double q2[4] = { + .322703493791143e+02,.892920700481861e+02,.546117738103215e+02, + .777788548522962e+01 +}; +static int K1 = 3; +static int K2 = 1; +static double psi,aug,den,sgn,upper,w,x,xmax1,xmx0,xsmall,z; +static int i,m,n,nq; +/* + .. + .. Executable Statements .. +*/ +/* +--------------------------------------------------------------------- + MACHINE DEPENDENT CONSTANTS ... + XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT + WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED + AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE + ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH + PSI MAY BE REPRESENTED AS ALOG(X). + XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X) + MAY BE REPRESENTED BY 1/X. +--------------------------------------------------------------------- +*/ + xmax1 = cdf_ipmpar(&K1); + xmax1 = fifdmin1(xmax1,1.0e0/spmpar(&K2)); + xsmall = 1.e-9; + x = *xx; + aug = 0.0e0; + if(x >= 0.5e0) goto S50; +/* +--------------------------------------------------------------------- + X .LT. 0.5, USE REFLECTION FORMULA + PSI(1-X) = PSI(X) + PI * COTAN(PI*X) +--------------------------------------------------------------------- +*/ + if(fabs(x) > xsmall) goto S10; + if(x == 0.0e0) goto S100; +/* +--------------------------------------------------------------------- + 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE + FOR PI*COTAN(PI*X) +--------------------------------------------------------------------- +*/ + aug = -(1.0e0/x); + goto S40; +S10: +/* +--------------------------------------------------------------------- + REDUCTION OF ARGUMENT FOR COTAN +--------------------------------------------------------------------- +*/ + w = -x; + sgn = piov4; + if(w > 0.0e0) goto S20; + w = -w; + sgn = -sgn; +S20: +/* +--------------------------------------------------------------------- + MAKE AN ERROR EXIT IF X .LE. -XMAX1 +--------------------------------------------------------------------- +*/ + if(w >= xmax1) goto S100; + nq = fifidint(w); + w -= (double)nq; + nq = fifidint(w*4.0e0); + w = 4.0e0*(w-(double)nq*.25e0); +/* +--------------------------------------------------------------------- + W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X. + ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST + QUADRANT AND DETERMINE SIGN +--------------------------------------------------------------------- +*/ + n = nq/2; + if(n+n != nq) w = 1.0e0-w; + z = piov4*w; + m = n/2; + if(m+m != n) sgn = -sgn; +/* +--------------------------------------------------------------------- + DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X) +--------------------------------------------------------------------- +*/ + n = (nq+1)/2; + m = n/2; + m += m; + if(m != n) goto S30; +/* +--------------------------------------------------------------------- + CHECK FOR SINGULARITY +--------------------------------------------------------------------- +*/ + if(z == 0.0e0) goto S100; +/* +--------------------------------------------------------------------- + USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND + SIN/COS AS A SUBSTITUTE FOR TAN +--------------------------------------------------------------------- +*/ + aug = sgn*(cos(z)/sin(z)*4.0e0); + goto S40; +S30: + aug = sgn*(sin(z)/cos(z)*4.0e0); +S40: + x = 1.0e0-x; +S50: + if(x > 3.0e0) goto S70; +/* +--------------------------------------------------------------------- + 0.5 .LE. X .LE. 3.0 +--------------------------------------------------------------------- +*/ + den = x; + upper = p1[0]*x; + for(i=1; i<=5; i++) { + den = (den+q1[i-1])*x; + upper = (upper+p1[i+1-1])*x; + } + den = (upper+p1[6])/(den+q1[5]); + xmx0 = x-dx0; + psi = den*xmx0+aug; + return psi; +S70: +/* +--------------------------------------------------------------------- + IF X .GE. XMAX1, PSI = LN(X) +--------------------------------------------------------------------- +*/ + if(x >= xmax1) goto S90; +/* +--------------------------------------------------------------------- + 3.0 .LT. X .LT. XMAX1 +--------------------------------------------------------------------- +*/ + w = 1.0e0/(x*x); + den = w; + upper = p2[0]*w; + for(i=1; i<=3; i++) { + den = (den+q2[i-1])*w; + upper = (upper+p2[i+1-1])*w; + } + aug = upper/(den+q2[3])-0.5e0/x+aug; +S90: + psi = aug+log(x); + return psi; +S100: +/* +--------------------------------------------------------------------- + ERROR RETURN +--------------------------------------------------------------------- +*/ + psi = 0.0e0; + return psi; +} +double rcomp(double *a,double *x) +/* + ------------------- + EVALUATION OF EXP(-X)*X**A/GAMMA(A) + ------------------- + RT2PIN = 1/SQRT(2*PI) + ------------------- +*/ +{ +static double rt2pin = .398942280401433e0; +static double rcomp,t,t1,u; +/* + .. + .. Executable Statements .. +*/ + rcomp = 0.0e0; + if(*a >= 20.0e0) goto S20; + t = *a*log(*x)-*x; + if(*a >= 1.0e0) goto S10; + rcomp = *a*exp(t)*(1.0e0+gam1(a)); + return rcomp; +S10: + rcomp = exp(t)/Xgamm(a); + return rcomp; +S20: + u = *x/ *a; + if(u == 0.0e0) return rcomp; + t = pow(1.0e0/ *a,2.0); + t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0); + t1 -= (*a*rlog(&u)); + rcomp = rt2pin*sqrt(*a)*exp(t1); + return rcomp; +} +double rexp(double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION EXP(X) - 1 +----------------------------------------------------------------------- +*/ +{ +static double p1 = .914041914819518e-09; +static double p2 = .238082361044469e-01; +static double q1 = -.499999999085958e+00; +static double q2 = .107141568980644e+00; +static double q3 = -.119041179760821e-01; +static double q4 = .595130811860248e-03; +static double rexp,w; +/* + .. + .. Executable Statements .. +*/ + if(fabs(*x) > 0.15e0) goto S10; + rexp = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0)); + return rexp; +S10: + w = exp(*x); + if(*x > 0.0e0) goto S20; + rexp = w-0.5e0-0.5e0; + return rexp; +S20: + rexp = w*(0.5e0+(0.5e0-1.0e0/w)); + return rexp; +} +double rlog(double *x) +/* + ------------------- + COMPUTATION OF X - 1 - LN(X) + ------------------- +*/ +{ +static double a = .566749439387324e-01; +static double b = .456512608815524e-01; +static double p0 = .333333333333333e+00; +static double p1 = -.224696413112536e+00; +static double p2 = .620886815375787e-02; +static double q1 = -.127408923933623e+01; +static double q2 = .354508718369557e+00; +static double rlog,r,t,u,w,w1; +/* + .. + .. Executable Statements .. +*/ + if(*x < 0.61e0 || *x > 1.57e0) goto S40; + if(*x < 0.82e0) goto S10; + if(*x > 1.18e0) goto S20; +/* + ARGUMENT REDUCTION +*/ + u = *x-0.5e0-0.5e0; + w1 = 0.0e0; + goto S30; +S10: + u = *x-0.7e0; + u /= 0.7e0; + w1 = a-u*0.3e0; + goto S30; +S20: + u = 0.75e0**x-1.e0; + w1 = b+u/3.0e0; +S30: +/* + SERIES EXPANSION +*/ + r = u/(u+2.0e0); + t = r*r; + w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0); + rlog = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1; + return rlog; +S40: + r = *x-0.5e0-0.5e0; + rlog = r-log(*x); + return rlog; +} +double rlog1(double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION X - LN(1 + X) +----------------------------------------------------------------------- +*/ +{ +static double a = .566749439387324e-01; +static double b = .456512608815524e-01; +static double p0 = .333333333333333e+00; +static double p1 = -.224696413112536e+00; +static double p2 = .620886815375787e-02; +static double q1 = -.127408923933623e+01; +static double q2 = .354508718369557e+00; +static double rlog1,h,r,t,w,w1; +/* + .. + .. Executable Statements .. +*/ + if(*x < -0.39e0 || *x > 0.57e0) goto S40; + if(*x < -0.18e0) goto S10; + if(*x > 0.18e0) goto S20; +/* + ARGUMENT REDUCTION +*/ + h = *x; + w1 = 0.0e0; + goto S30; +S10: + h = *x+0.3e0; + h /= 0.7e0; + w1 = a-h*0.3e0; + goto S30; +S20: + h = 0.75e0**x-0.25e0; + w1 = b+h/3.0e0; +S30: +/* + SERIES EXPANSION +*/ + r = h/(h+2.0e0); + t = r*r; + w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0); + rlog1 = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1; + return rlog1; +S40: + w = *x+0.5e0+0.5e0; + rlog1 = *x-log(w); + return rlog1; +} +double spmpar(int *i) +/* +----------------------------------------------------------------------- + + SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR + THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT + I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE + SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND + ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN + + SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION, + + SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, + + SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE. + +----------------------------------------------------------------------- + WRITTEN BY + ALFRED H. MORRIS, JR. + NAVAL SURFACE WARFARE CENTER + DAHLGREN VIRGINIA +----------------------------------------------------------------------- +----------------------------------------------------------------------- + MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE + CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS + MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION +----------------------------------------------------------------------- +*/ +{ +static int K1 = 4; +static int K2 = 8; +static int K3 = 9; +static int K4 = 10; +static double spmpar,b,binv,bm1,one,w,z; +static int emax,emin,ibeta,m; +/* + .. + .. Executable Statements .. +*/ + if(*i > 1) goto S10; + b = cdf_ipmpar(&K1); + m = cdf_ipmpar(&K2); + spmpar = pow(b,(double)(1-m)); + return spmpar; +S10: + if(*i > 2) goto S20; + b = cdf_ipmpar(&K1); + emin = cdf_ipmpar(&K3); + one = 1.0; + binv = one/b; + w = pow(b,(double)(emin+2)); + spmpar = w*binv*binv*binv; + return spmpar; +S20: + ibeta = cdf_ipmpar(&K1); + m = cdf_ipmpar(&K2); + emax = cdf_ipmpar(&K4); + b = ibeta; + bm1 = ibeta-1; + one = 1.0; + z = pow(b,(double)(m-1)); + w = ((z-one)*b+bm1)/(b*z); + z = pow(b,(double)(emax-2)); + spmpar = w*z*b*b; + return spmpar; +} +double stvaln(double *p) +/* +********************************************************************** + + double stvaln(double *p) + STarting VALue for Neton-Raphon + calculation of Normal distribution Inverse + + + Function + + + Returns X such that CUMNOR(X) = P, i.e., the integral from - + infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P + + + Arguments + + + P --> The probability whose normal deviate is sought. + P is DOUBLE PRECISION + + + Method + + + The rational function on page 95 of Kennedy and Gentle, + Statistical Computing, Marcel Dekker, NY , 1980. + +********************************************************************** +*/ +{ +static double xden[5] = { + 0.993484626060e-1,0.588581570495e0,0.531103462366e0,0.103537752850e0, + 0.38560700634e-2 +}; +static double xnum[5] = { + -0.322232431088e0,-1.000000000000e0,-0.342242088547e0,-0.204231210245e-1, + -0.453642210148e-4 +}; +static int K1 = 5; +static double stvaln,sign,y,z; +/* + .. + .. Executable Statements .. +*/ + if(!(*p <= 0.5e0)) goto S10; + sign = -1.0e0; + z = *p; + goto S20; +S10: + sign = 1.0e0; + z = 1.0e0-*p; +S20: + y = sqrt(-(2.0e0*log(z))); + stvaln = y+devlpl(xnum,&K1,&y)/devlpl(xden,&K1,&y); + stvaln = sign*stvaln; + return stvaln; +} +/************************************************************************ +FIFDINT: +Truncates a double precision number to an integer and returns the +value in a double. +************************************************************************/ +double fifdint(double a) +/* a - number to be truncated */ +{ + return (double) ((int) a); +} +/************************************************************************ +FIFDMAX1: +returns the maximum of two numbers a and b +************************************************************************/ +double fifdmax1(double a,double b) +/* a - first number */ +/* b - second number */ +{ + if (a < b) return b; + else return a; +} +/************************************************************************ +FIFDMIN1: +returns the minimum of two numbers a and b +************************************************************************/ +double fifdmin1(double a,double b) +/* a - first number */ +/* b - second number */ +{ + if (a < b) return a; + else return b; +} +/************************************************************************ +FIFDSIGN: +transfers the sign of the variable "sign" to the variable "mag" +************************************************************************/ +double fifdsign(double mag,double sign) +/* mag - magnitude */ +/* sign - sign to be transfered */ +{ + if (mag < 0) mag = -mag; + if (sign < 0) mag = -mag; + return mag; + +} +/************************************************************************ +FIFIDINT: +Truncates a double precision number to a long integer +************************************************************************/ +long fifidint(double a) +/* a - number to be truncated */ +{ + if (a < 1.0) return (long) 0; + else return (long) a; +} +/************************************************************************ +FIFMOD: +returns the modulo of a and b +************************************************************************/ +long fifmod(long a,long b) +/* a - numerator */ +/* b - denominator */ +{ + return a % b; +} +/************************************************************************ +FTNSTOP: +Prints msg to standard error and then exits +************************************************************************/ +void ftnstop(char* msg) +/* msg - error message */ +{ + if (msg != NULL) fprintf(stderr,"%s\n",msg); + exit(0); +} Index: src/libdcdf/dcdflib.chs ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/dcdflib.chs 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,185 @@ + + + + + + + + + + + + DCDFLIB + + Library of C Routines for Cumulative Distribution + Functions, Inverses, and Other Parameters + + (February, 1994) + + + + + + + Summary Documentation of Each Routine + + + + + + + + + Compiled and Written by: + + Barry W. Brown + James Lovato + Kathy Russell + + + + + + + + + + Department of Biomathematics, Box 237 + The University of Texas, M.D. Anderson Cancer Center + 1515 Holcombe Boulevard + Houston, TX 77030 + + + This work was supported by grant CA-16672 from the National Cancer Institute. + + +WHICH and STATUS are pointers to int , all other arguements are +pointers to double. + + +-------------------- DISTRIBUTION + +WHICH PARAMETERS INPUT RANGE SEARCH RANGE REQUIREMENTS + + +-------------------- Beta + +void cdfbet(int *which,double *p,double *q,double *x,double *y, + double *a,double *b,int *status,double *bound) + + 1 P and Q [0,1];[0,1] ----------- SUM to 1.0 + 2 X and Y [0,1];[0,1] [0,1],[0,1] SUM to 1.0 + 3 A (0,infinity) [1E-300,1E300] + 4 B (0,infinity) [1E-300,1E300] + +-------------------- Binomial + +void cdfbin(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) + + 1 P and Q [0,1];[0,1] ----------- SUM to 1.0 + 2 S [0,XN] [0,XN] + 3 XN (0,infinity) [1E-300,1E300] + 4 PR and OMPR [0,1];[0,1] [0,1];[0,1] SUM to 1.0 + +-------------------- Chi-square + +void cdfchi(int *which,double *p,double *q,double *x,double *df, + int *status,double *bound) + + SUBROUTINE CDFCHI( WHICH, P, Q, X, DF, STATUS, BOUND ) + + 1 P and Q [0,1],(0,1] ----------- SUM to 1.0 + 2 X [0,infinity] [0,1E300] + 3 DF (0,infinity) [1E-300,1E300] + +-------------------- Noncentral Chi-square + +void cdfchn(int *which,double *p,double *q,double *x,double *df, + double *pnonc,int *status,double *bound) + + 1 P and Q [0,1-1E-16],none ----------- + 2 X [0,infinity] [0,1E300] + 3 DF (0,infinity) [1E-300,1E300] + 4 PNONC [0,infinity) [0,1E4] + +NOTE: We do not yet have a method to calculation the Noncentral Chi-Square +distribution acurately near 1; therefore, Q is not used by CDFCHN. There +are no input requirements of Q, and when WHICH is 1, Q is returned as 1-P. + +-------------------- F + +void cdff(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,int *status,double *bound) + + 1 P and Q [0,1],(0,1] ----------- SUM to 1.0 + 2 F [0,infinity) [0,1E300] + 3 DFN (0,infinity) [1E-300,1E300] + 4 DFD (0,infinity) [1E-300,1E300] + +-------------------- Noncentral F + +void cdffnc(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,double *phonc,int *status,double *bound) + + 1 P and Q [0,1-1E-16],none ----------- + 2 F [0,infinity) [0,1E300] + 3 DFN (0,infinity) [1E-300,1E300] + 4 DFD (0,infinity) [1E-300,1E300] + 5 PNONC [0,infinity) [0,1E4] + +NOTE: We do not yet have a method to calculation the Noncentral F +distribution acurately near 1; therefore, Q is not used by CDFF. +There are no input requirements of Q, and when WHICH is 1, Q is returned +as 1-P. + +-------------------- Gamma + +void cdfgam(int *which,double *p,double *q,double *x, + double *shape,double *scale,int *status,double *bound) + + 1 P and Q [0,1],(0,1] ----------- SUM to 1.0 + 2 X [0,infinity) [0,1E300] + 3 SHAPE (0,infinity) [1E-300,1E300] + 4 SCALE (0,infinity) [1E-300,1E300] + +-------------------- Negative Binomial + +void cdfnbn(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) + + 1 P and Q [0,1];(0,1] ----------- SUM to 1.0 + 2 S [0,infinity) [0,1E300] + 3 XN [0,infinity) [0,1E300] + 4 PR and OMPR [0,1];[0,1] [0,1];[0,1] SUM to 1.0 + +-------------------- Normal + +void cdfnor(int *which,double *p,double *q,double *x, + double *mean,double *sd,int *status,double *bound) + + 1 P and Q (0,1],(0,1] ----------- SUM to 1.0 + 2 X (-inf.,inf.) ----------- + 3 MEAN (-inf.,inf.) ----------- + 4 SD (0,infinity) ----------- + +-------------------- Poisson + +void cdfpoi(int *which,double *p,double *q,double *s, + double *xlam,int *status,double *bound) + + 1 P and Q [0,1],(0,1] ----------- SUM to 1.0 + 2 S [0,infinity) [0,1E300] + 3 XLAM [0,infinity) [0,1E300] + +-------------------- Student's t + +void cdft(int *which,double *p,double *q,double *t,double *df, + int *status,double *bound) + + 1 P and Q (0,1],(0,1] ----------- SUM to 1.0 + 2 T (-inf.,inf.) [-1E300,1E300] + 3 DF (0,infinity) [1E-300,1E10] + + + Index: src/libdcdf/dcdflib.fdoc ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/dcdflib.fdoc 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,998 @@ + + + + + + + + + + + + DCDFLIB + + Library of C Routines for Cumulative Distribution + Functions, Inverses, and Other Parameters + + (February, 1994) + + + + + + + Full Documentation of Each Routine + + + + + + + + + Compiled and Written by: + + Barry W. Brown + James Lovato + Kathy Russell + + + + + + + + + + Department of Biomathematics, Box 237 + The University of Texas, M.D. Anderson Cancer Center + 1515 Holcombe Boulevard + Houston, TX 77030 + + + This work was supported by grant CA-16672 from the National Cancer Institute. + +/********************************************************************** + + void cdfbet(int *which,double *p,double *q,double *x,double *y, + double *a,double *b,int *status,double *bound) + + Cumulative Distribution Function + BETa Distribution + + + Function + + + Calculates any one parameter of the beta distribution given + values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,Y,A and B + iwhich = 2 : Calculate X and Y from P,Q,A and B + iwhich = 3 : Calculate A from P,Q,X,Y and B + iwhich = 4 : Calculate B from P,Q,X,Y and A + + P <--> The integral from 0 to X of the chi-square + distribution. + Input range: [0, 1]. + + Q <--> 1-P. + Input range: [0, 1]. + P + Q = 1.0. + + X <--> Upper limit of integration of beta density. + Input range: [0,1]. + Search range: [0,1] + + Y <--> 1-X. + Input range: [0,1]. + Search range: [0,1] + X + Y = 1.0. + + A <--> The first parameter of the beta density. + Input range: (0, +infinity). + Search range: [1D-300,1D300] + + B <--> The second parameter of the beta density. + Input range: (0, +infinity). + Search range: [1D-300,1D300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if X + Y .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Cumulative distribution function (P) is calculated directly by + code associated with the following reference. + + DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant + Digit Computation of the Incomplete Beta Function Ratios. ACM + Trans. Math. Softw. 18 (1993), 360-373. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + Note + + + The beta density is proportional to + t^(A-1) * (1-t)^(B-1) + +**********************************************************************/ +/********************************************************************** + + void cdfbin(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) + + Cumulative Distribution Function + BINomial distribution + + + Function + + + Calculates any one parameter of the binomial + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR + iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR + iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR + iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN + + P <--> The cumulation from 0 to S of the binomial distribution. + (Probablility of S or fewer successes in XN trials each + with probability of success PR.) + Input range: [0,1]. + + Q <--> 1-P. + Input range: [0, 1]. + P + Q = 1.0. + + S <--> The number of successes observed. + Input range: [0, XN] + Search range: [0, XN] + + XN <--> The number of binomial trials. + Input range: (0, +infinity). + Search range: [1E-300, 1E300] + + PR <--> The probability of success in each binomial trial. + Input range: [0,1]. + Search range: [0,1] + + OMPR <--> 1-PR + Input range: [0,1]. + Search range: [0,1] + PR + OMPR = 1.0 + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if PR + OMPR .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.24 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the binomial + distribution to the cumulative incomplete beta distribution. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + +**********************************************************************/ +/********************************************************************** + + void cdfchi(int *which,double *p,double *q,double *x,double *df, + int *status,double *bound) + + Cumulative Distribution Function + CHI-Square distribution + + + Function + + + Calculates any one parameter of the chi-square + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next three argument + values is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from X and DF + iwhich = 2 : Calculate X from P,Q and DF + iwhich = 3 : Calculate DF from P,Q and X + + P <--> The integral from 0 to X of the chi-square + distribution. + Input range: [0, 1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X <--> Upper limit of integration of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E300] + + DF <--> Degrees of freedom of the + chi-square distribution. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 10 indicates error returned from cumgam. See + references in cdfgam + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.19 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the chisqure + distribution to the incomplete distribution. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +/********************************************************************** + + void cdfchn(int *which,double *p,double *q,double *x,double *df, + double *pnonc,int *status,double *bound) + + Cumulative Distribution Function + Non-central Chi-Square + + + Function + + + Calculates any one parameter of the non-central chi-square + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next three argument + values is to be calculated from the others. + Input range: 1..4 + iwhich = 1 : Calculate P and Q from X and DF + iwhich = 2 : Calculate X from P,DF and PNONC + iwhich = 3 : Calculate DF from P,X and PNONC + iwhich = 3 : Calculate PNONC from P,X and DF + + P <--> The integral from 0 to X of the non-central chi-square + distribution. + Input range: [0, 1-1E-16). + + Q <--> 1-P. + Q is not used by this subroutine and is only included + for similarity with other cdf* routines. + + X <--> Upper limit of integration of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E300] + + DF <--> Degrees of freedom of the non-central + chi-square distribution. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + PNONC <--> Non-centrality parameter of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E4] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.25 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to compute the cumulative + distribution function. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + WARNING + + The computation time required for this routine is proportional + to the noncentrality parameter (PNONC). Very large values of + this parameter can consume immense computer resources. This is + why the search range is bounded by 10,000. + +**********************************************************************/ +/********************************************************************** + + void cdff(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,int *status,double *bound) + + Cumulative Distribution Function + F distribution + + + Function + + + Calculates any one parameter of the F distribution + given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from F,DFN and DFD + iwhich = 2 : Calculate F from P,Q,DFN and DFD + iwhich = 3 : Calculate DFN from P,Q,F and DFD + iwhich = 4 : Calculate DFD from P,Q,F and DFN + + P <--> The integral from 0 to F of the f-density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + F <--> Upper limit of integration of the f-density. + Input range: [0, +infinity). + Search range: [0,1E300] + + DFN < --> Degrees of freedom of the numerator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + DFD < --> Degrees of freedom of the denominator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.6.2 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function for the F variate to + that of an incomplete beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + WARNING + + The value of the cumulative F distribution is not necessarily + monotone in either degrees of freedom. There thus may be two + values that provide a given CDF value. This routine assumes + monotonicity and will find an arbitrary one of the two values. + +**********************************************************************/ +/********************************************************************** + + void cdffnc(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,double *phonc,int *status,double *bound) + + Cumulative Distribution Function + Non-central F distribution + + + Function + + + Calculates any one parameter of the Non-central F + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next five argument + values is to be calculated from the others. + Legal range: 1..5 + iwhich = 1 : Calculate P and Q from F,DFN,DFD and PNONC + iwhich = 2 : Calculate F from P,Q,DFN,DFD and PNONC + iwhich = 3 : Calculate DFN from P,Q,F,DFD and PNONC + iwhich = 4 : Calculate DFD from P,Q,F,DFN and PNONC + iwhich = 5 : Calculate PNONC from P,Q,F,DFN and DFD + + P <--> The integral from 0 to F of the non-central f-density. + Input range: [0,1-1E-16). + + Q <--> 1-P. + Q is not used by this subroutine and is only included + for similarity with other cdf* routines. + + F <--> Upper limit of integration of the non-central f-density. + Input range: [0, +infinity). + Search range: [0,1E300] + + DFN < --> Degrees of freedom of the numerator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + DFD < --> Degrees of freedom of the denominator sum of squares. + Must be in range: (0, +infinity). + Input range: (0, +infinity). + Search range: [ 1E-300, 1E300] + + PNONC <-> The non-centrality parameter + Input range: [0,infinity) + Search range: [0,1E4] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.6.20 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to compute the cumulative + distribution function. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + WARNING + + The computation time required for this routine is proportional + to the noncentrality parameter (PNONC). Very large values of + this parameter can consume immense computer resources. This is + why the search range is bounded by 10,000. + + WARNING + + The value of the cumulative noncentral F distribution is not + necessarily monotone in either degrees of freedom. There thus + may be two values that provide a given CDF value. This routine + assumes monotonicity and will find an arbitrary one of the two + values. + +**********************************************************************/ +/********************************************************************** + + void cdfgam(int *which,double *p,double *q,double *x, + double *shape,double *scale,int *status,double *bound) + + Cumulative Distribution Function + GAMma Distribution + + + Function + + + Calculates any one parameter of the gamma + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE + iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE + iwhich = 3 : Calculate SHAPE from P,Q,X and SCALE + iwhich = 4 : Calculate SCALE from P,Q,X and SHAPE + + P <--> The integral from 0 to X of the gamma density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X <--> The upper limit of integration of the gamma density. + Input range: [0, +infinity). + Search range: [0,1E300] + + SHAPE <--> The shape parameter of the gamma density. + Input range: (0, +infinity). + Search range: [1E-300,1E300] + + SCALE <--> The scale parameter of the gamma density. + Input range: (0, +infinity). + Search range: (1E-300,1E300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 10 if the gamma or inverse gamma routine cannot + compute the answer. Usually happens only for + X and SHAPE very large (gt 1E10 or more) + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Cumulative distribution function (P) is calculated directly by + the code associated with: + + DiDinato, A. R. and Morris, A. H. Computation of the incomplete + gamma function ratios and their inverse. ACM Trans. Math. + Softw. 12 (1986), 377-393. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + Note + + + + The gamma density is proportional to + T**(SHAPE - 1) * EXP(- SCALE * T) + +**********************************************************************/ +/********************************************************************** + + void cdfnbn(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) + + Cumulative Distribution Function + Negative BiNomial distribution + + + Function + + + Calculates any one parameter of the negative binomial + distribution given values for the others. + + The cumulative negative binomial distribution returns the + probability that there will be F or fewer failures before the + XNth success in binomial trials each of which has probability of + success PR. + + The individual term of the negative binomial is the probability of + S failures before XN successes and is + Choose( S, XN+S-1 ) * PR^(XN) * (1-PR)^S + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR + iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR + iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR + iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN + + P <--> The cumulation from 0 to S of the negative + binomial distribution. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + S <--> The upper limit of cumulation of the binomial distribution. + There are F or fewer failures before the XNth success. + Input range: [0, +infinity). + Search range: [0, 1E300] + + XN <--> The number of successes. + Input range: [0, +infinity). + Search range: [0, 1E300] + + PR <--> The probability of success in each binomial trial. + Input range: [0,1]. + Search range: [0,1]. + + OMPR <--> 1-PR + Input range: [0,1]. + Search range: [0,1] + PR + OMPR = 1.0 + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if PR + OMPR .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.26 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce calculation of + the cumulative distribution function to that of an incomplete + beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +/********************************************************************** + + void cdfnor(int *which,double *p,double *q,double *x, + double *mean,double *sd,int *status,double *bound) + + Cumulative Distribution Function + NORmal distribution + + + Function + + + Calculates any one parameter of the normal + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next parameter + values is to be calculated using values of the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,MEAN and SD + iwhich = 2 : Calculate X from P,Q,MEAN and SD + iwhich = 3 : Calculate MEAN from P,Q,X and SD + iwhich = 4 : Calculate SD from P,Q,X and MEAN + + P <--> The integral from -infinity to X of the normal density. + Input range: (0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X < --> Upper limit of integration of the normal-density. + Input range: ( -infinity, +infinity) + + MEAN <--> The mean of the normal density. + Input range: (-infinity, +infinity) + + SD <--> Standard Deviation of the normal density. + Input range: (0, +infinity). + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + + + A slightly modified version of ANORM from + + Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN + Package of Special Function Routines and Test Drivers" + acm Transactions on Mathematical Software. 19, 22-32. + + is used to calulate the cumulative standard normal distribution. + + The rational functions from pages 90-95 of Kennedy and Gentle, + Statistical Computing, Marcel Dekker, NY, 1980 are used as + starting values to Newton's Iterations which compute the inverse + standard normal. Therefore no searches are necessary for any + parameter. + + For X < -15, the asymptotic expansion for the normal is used as + the starting value in finding the inverse standard normal. + This is formula 26.2.12 of Abramowitz and Stegun. + + + Note + + + The normal density is proportional to + exp( - 0.5 * (( X - MEAN)/SD)**2) + +**********************************************************************/ +/********************************************************************** + + void cdfpoi(int *which,double *p,double *q,double *s, + double *xlam,int *status,double *bound) + + Cumulative Distribution Function + POIsson distribution + + + Function + + + Calculates any one parameter of the Poisson + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which argument + value is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from S and XLAM + iwhich = 2 : Calculate A from P,Q and XLAM + iwhich = 3 : Calculate XLAM from P,Q and S + + P <--> The cumulation from 0 to S of the poisson density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + S <--> Upper limit of cumulation of the Poisson. + Input range: [0, +infinity). + Search range: [0,1E300] + + XLAM <--> Mean of the Poisson distribution. + Input range: [0, +infinity). + Search range: [0,1E300] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.21 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function to that of computing a + chi-square, hence an incomplete gamma function. + + Cumulative distribution function (P) is calculated directly. + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +/********************************************************************** + + void cdft(int *which,double *p,double *q,double *t,double *df, + int *status,double *bound) + + Cumulative Distribution Function + T distribution + + + Function + + + Calculates any one parameter of the t distribution given + values for the others. + + + Arguments + + + WHICH --> Integer indicating which argument + values is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from T and DF + iwhich = 2 : Calculate T from P,Q and DF + iwhich = 3 : Calculate DF from P,Q and T + + P <--> The integral from -infinity to t of the t-density. + Input range: (0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + T <--> Upper limit of integration of the t-density. + Input range: ( -infinity, +infinity). + Search range: [ -1E300, 1E300 ] + + DF <--> Degrees of freedom of the t-distribution. + Input range: (0 , +infinity). + Search range: [1e-300, 1E10] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.27 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function to that of an incomplete + beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ + Index: src/libdcdf/dcdflib.h ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/dcdflib.h 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,24 @@ +extern void cdf_bet(int* which ,double* p, double* q, double* x, double* y, + double* a, double* b, int* status, double* bound); +extern void cdf_bin(int* which, double* p, double* q, double* s, double* xn, + double* pr, double* ompr, int* status, double* bound); +extern void cdf_chi(int* which, double* p, double* q, double* x, double* df, + int* status, double* bound); +extern void cdf_chn(int* which, double* p, double* q, double* x, double* df, + double* pnonc, int* status, double* bound); +extern void cdf_f(int* which, double* p, double* q, double* f, double* dfn, + double* dfd, int* status, double* bound); +extern void cdf_fnc(int* which, double* p, double* q, double* f, double* dfn, + double* dfd, double* phonc, int* status, double* bound); +extern void cdf_gam(int* which, double* p, double* q, double* x, + double* shape, double* scale, int* status, double* bound); +extern void cdf_nbn(int* which, double* p, double* q, double* s, double* xn, + double* pr, double* ompr, int* status, double* bound); +extern void cdf_nor(int* which, double* p, double* q, double* x, + double* mean, double* sd, int* status, double* bound); +extern void cdf_poi(int* which, double* p, double* q, double* s, double* xlam, + int* status, double* bound); +extern void cdf_t(int* which, double* p, double* q, double* t, double* df, + int* status, double* bound); +extern int cdf_ipmpar(int* which); + Index: src/libdcdf/dcdflib_private.h ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/dcdflib_private.h 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,75 @@ +static double algdiv(double*,double*); +static double alngam(double*); +static double alnrel(double*); +static double apser(double*,double*,double*,double*); +static double basym(double*,double*,double*,double*); +static double bcorr(double*,double*); +static double betaln(double*,double*); +static double bfrac(double*,double*,double*,double*,double*,double*); +static void bgrat(double*,double*,double*,double*,double*,double*,int*i); +static double bpser(double*,double*,double*,double*); +static void bratio(double*,double*,double*,double*,double*,double*,int*); +static double brcmp1(int*,double*,double*,double*,double*); +static double brcomp(double*,double*,double*,double*); +static double bup(double*,double*,double*,double*,int*,double*); +static void cumbet(double*,double*,double*,double*,double*,double*); +static void cumbin(double*,double*,double*,double*,double*,double*); +static void cumchi(double*,double*,double*,double*); +static void cumchn(double*,double*,double*,double*,double*); +static void cumf(double*,double*,double*,double*,double*); +static void cumfnc(double*,double*,double*,double*,double*,double*); +static void cumgam(double*,double*,double*,double*); +static void cumnbn(double*,double*,double*,double*,double*,double*); +static void cumnor(double*,double*,double*); +static void cumpoi(double*,double*,double*,double*); +static void cumt(double*,double*,double*,double*); +static double dbetrm(double*,double*); +static double devlpl(double [],int*,double*); +static double dexpm1(double*); +static double dinvnr(double *p,double *q); +static void E0000(int,int*,double*,double*,unsigned long*, + unsigned long*,double*,double*,double*, + double*,double*,double*,double*); +static void dinvr(int*,double*,double*,unsigned long*,unsigned long*); +static void dstinv(double*,double*,double*,double*,double*,double*, + double*); +static double dlanor(double*); +static double dln1mx(double*); +static double dln1px(double*); +static double dlnbet(double*,double*); +static double dlngam(double*); +static double dstrem(double*); +static double dt1(double*,double*,double*); +static void E0001(int,int*,double*,double*,double*,double*, + unsigned long*,unsigned long*,double*,double*, + double*,double*); +static void dzror(int*,double*,double*,double*,double *, + unsigned long*,unsigned long*); +static void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl); +static double erf1(double*); +static double erfc1(int*,double*); +static double esum(int*,double*); +static double exparg(int*); +static double fpser(double*,double*,double*,double*); +static double gam1(double*); +static void gaminv(double*,double*,double*,double*,double*,int*); +static double gamln(double*); +static double gamln1(double*); +static double Xgamm(double*); +static void grat1(double*,double*,double*,double*,double*,double*); +static void gratio(double*,double*,double*,double*,int*); +static double gsumln(double*,double*); +static double psi(double*); +static double rcomp(double*,double*); +static double rexp(double*); +static double rlog(double*); +static double rlog1(double*); +static double spmpar(int*); +static double stvaln(double*); +static double fifdint(double); +static double fifdmax1(double,double); +static double fifdmin1(double,double); +static double fifdsign(double,double); +static long fifidint(double); +static long fifmod(long,long); +static void ftnstop(char*); Index: src/libdcdf/depend.mk.dummy ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/depend.mk.dummy 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,2 @@ +# This is a harmless dummy dependencies file. + Index: src/libdcdf/ipmpar.c ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/ipmpar.c 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,444 @@ +#include +#include "../fmri/lapack.h" +#include "dcdflib.h" +/* +----------------------------------------------------------------------- + + IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER + THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER + HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ... + + INTEGERS. + + ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM + + SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) ) + + WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1. + + IPMPAR(1) = A, THE BASE. + + IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS. + + IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE. + + FLOATING-POINT NUMBERS. + + IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING + POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE + NONZERO NUMBERS ARE REPRESENTED IN THE FORM + + SIGN (B**E) * (X(1)/B + ... + X(M)/B**M) + + WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M, + X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX. + + IPMPAR(4) = B, THE BASE. + + SINGLE-PRECISION + + IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS. + + IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E. + + IPMPAR(7) = EMAX, THE LARGEST EXPONENT E. + + DOUBLE-PRECISION + + IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS. + + IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E. + + IPMPAR(10) = EMAX, THE LARGEST EXPONENT E. + +----------------------------------------------------------------------- + + TO DEFINE THIS FUNCTION FOR THE COMPUTER BEING USED REMOVE + THE COMMENT DELIMITORS FROM THE DEFINITIONS DIRECTLY BELOW THE NAME + OF THE MACHINE + +----------------------------------------------------------------------- + + IPMPAR IS AN ADAPTATION OF THE FUNCTION I1MACH, WRITTEN BY + P.A. FOX, A.D. HALL, AND N.L. SCHRYER (BELL LABORATORIES). + IPMPAR WAS FORMED BY A.H. MORRIS (NSWC). THE CONSTANTS ARE + FROM BELL LABORATORIES, NSWC, AND OTHER SOURCES. + +----------------------------------------------------------------------- + .. Scalar Arguments .. +*/ +int cdf_ipmpar(int *i) +{ + static int imach[11]; + static int ipmpar; +/* MACHINE CONSTANTS FOR AMDAHL MACHINES. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 16; + imach[5] = 6; + imach[6] = -64; + imach[7] = 63; + imach[8] = 14; + imach[9] = -64; + imach[10] = 63; +*/ +/* MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T + PC 7300, AND AT&T 6300. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -125; + imach[7] = 128; + imach[8] = 53; + imach[9] = -1021; + imach[10] = 1024; +*/ +/* MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. */ +/* + imach[1] = 2; + imach[2] = 33; + imach[3] = 8589934591; + imach[4] = 2; + imach[5] = 24; + imach[6] = -256; + imach[7] = 255; + imach[8] = 60; + imach[9] = -256; + imach[10] = 255; +*/ +/* MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. */ +/* + imach[1] = 2; + imach[2] = 39; + imach[3] = 549755813887; + imach[4] = 8; + imach[5] = 13; + imach[6] = -50; + imach[7] = 76; + imach[8] = 26; + imach[9] = -50; + imach[10] = 76; +*/ +/* MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. */ +/* + imach[1] = 2; + imach[2] = 39; + imach[3] = 549755813887; + imach[4] = 8; + imach[5] = 13; + imach[6] = -50; + imach[7] = 76; + imach[8] = 26; + imach[9] = -32754; + imach[10] = 32780; +*/ +/* MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES + 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT + ARITHMETIC (NOS OPERATING SYSTEM). */ +/* + imach[1] = 2; + imach[2] = 48; + imach[3] = 281474976710655; + imach[4] = 2; + imach[5] = 48; + imach[6] = -974; + imach[7] = 1070; + imach[8] = 95; + imach[9] = -926; + imach[10] = 1070; +*/ +/* MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT + ARITHMETIC (NOS/VE OPERATING SYSTEM). */ +/* + imach[1] = 2; + imach[2] = 63; + imach[3] = 9223372036854775807; + imach[4] = 2; + imach[5] = 48; + imach[6] = -4096; + imach[7] = 4095; + imach[8] = 96; + imach[9] = -4096; + imach[10] = 4095; +*/ +/* MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. */ +/* + imach[1] = 2; + imach[2] = 63; + imach[3] = 9223372036854775807; + imach[4] = 2; + imach[5] = 47; + imach[6] = -8189; + imach[7] = 8190; + imach[8] = 94; + imach[9] = -8099; + imach[10] = 8190; +*/ +/* MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. */ +/* + imach[1] = 2; + imach[2] = 15; + imach[3] = 32767; + imach[4] = 16; + imach[5] = 6; + imach[6] = -64; + imach[7] = 63; + imach[8] = 14; + imach[9] = -64; + imach[10] = 63; +*/ +/* MACHINE CONSTANTS FOR THE HARRIS 220. */ +/* + imach[1] = 2; + imach[2] = 23; + imach[3] = 8388607; + imach[4] = 2; + imach[5] = 23; + imach[6] = -127; + imach[7] = 127; + imach[8] = 38; + imach[9] = -127; + imach[10] = 127; +*/ +/* MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 + AND DPS 8/70 SERIES. */ +/* + imach[1] = 2; + imach[2] = 35; + imach[3] = 34359738367; + imach[4] = 2; + imach[5] = 27; + imach[6] = -127; + imach[7] = 127; + imach[8] = 63; + imach[9] = -127; + imach[10] = 127; +*/ +/* MACHINE CONSTANTS FOR THE HP 2100 + 3 WORD DOUBLE PRECISION OPTION WITH FTN4 */ +/* + imach[1] = 2; + imach[2] = 15; + imach[3] = 32767; + imach[4] = 2; + imach[5] = 23; + imach[6] = -128; + imach[7] = 127; + imach[8] = 39; + imach[9] = -128; + imach[10] = 127; +*/ +/* MACHINE CONSTANTS FOR THE HP 2100 + 4 WORD DOUBLE PRECISION OPTION WITH FTN4 */ +/* + imach[1] = 2; + imach[2] = 15; + imach[3] = 32767; + imach[4] = 2; + imach[5] = 23; + imach[6] = -128; + imach[7] = 127; + imach[8] = 55; + imach[9] = -128; + imach[10] = 127; +*/ +/* MACHINE CONSTANTS FOR THE HP 9000. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -126; + imach[7] = 128; + imach[8] = 53; + imach[9] = -1021; + imach[10] = 1024; +*/ +/* MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, + THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA + 5/7/9 AND THE SEL SYSTEMS 85/86. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 16; + imach[5] = 6; + imach[6] = -64; + imach[7] = 63; + imach[8] = 14; + imach[9] = -64; + imach[10] = 63; +*/ +/* MACHINE CONSTANTS FOR THE IBM PC. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -125; + imach[7] = 128; + imach[8] = 53; + imach[9] = -1021; + imach[10] = 1024; +*/ +/* MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT + MACFORTRAN II. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -125; + imach[7] = 128; + imach[8] = 53; + imach[9] = -1021; + imach[10] = 1024; +*/ +/* MACHINE CONSTANTS FOR THE MICROVAX - VMS FORTRAN. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -127; + imach[7] = 127; + imach[8] = 56; + imach[9] = -127; + imach[10] = 127; +*/ +/* MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). */ +/* + imach[1] = 2; + imach[2] = 35; + imach[3] = 34359738367; + imach[4] = 2; + imach[5] = 27; + imach[6] = -128; + imach[7] = 127; + imach[8] = 54; + imach[9] = -101; + imach[10] = 127; +*/ +/* MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). */ +/* + imach[1] = 2; + imach[2] = 35; + imach[3] = 34359738367; + imach[4] = 2; + imach[5] = 27; + imach[6] = -128; + imach[7] = 127; + imach[8] = 62; + imach[9] = -128; + imach[10] = 127; +*/ +/* MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING + 32-BIT INTEGER ARITHMETIC. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -127; + imach[7] = 127; + imach[8] = 56; + imach[9] = -127; + imach[10] = 127; +*/ +/* MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -125; + imach[7] = 128; + imach[8] = 53; + imach[9] = -1021; + imach[10] = 1024; +*/ +/* MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D + SERIES (MIPS R3000 PROCESSOR). */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -125; + imach[7] = 128; + imach[8] = 53; + imach[9] = -1021; + imach[10] = 1024; +*/ +/* MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T + 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T + PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). */ +/* + + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -125; + imach[7] = 128; + imach[8] = 53; + imach[9] = -1021; + imach[10] = 1024; +*/ + +/* MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. */ +/* + imach[1] = 2; + imach[2] = 35; + imach[3] = 34359738367; + imach[4] = 2; + imach[5] = 27; + imach[6] = -128; + imach[7] = 127; + imach[8] = 60; + imach[9] = -1024; + imach[10] = 1023; +*/ +/* MACHINE CONSTANTS FOR THE VAX 11/780. */ +/* + imach[1] = 2; + imach[2] = 31; + imach[3] = 2147483647; + imach[4] = 2; + imach[5] = 24; + imach[6] = -127; + imach[7] = 127; + imach[8] = 56; + imach[9] = -127; + imach[10] = 127; +*/ +/* Since we have LAPACK, let's do this portably */ + if ( imach[1]==0 ) { + /* Not yet initialized */ + imach[1]= (int)SLAMCH("B"); + imach[2]= CHAR_BIT*sizeof(int)-1; + imach[3]= INT_MAX; + imach[4]= imach[1]; + imach[5]= (int)SLAMCH("N"); + imach[6]= (int)SLAMCH("M"); + imach[7]= (int)SLAMCH("L"); + imach[8]= (int)DLAMCH("N"); + imach[9]= (int)DLAMCH("M"); + imach[10]= (int)DLAMCH("L"); + } + ipmpar = imach[*i]; + return ipmpar; +} Index: src/libdcdf/libdcdf_help.help ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/libdcdf_help.help 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,9 @@ +*CumulativeDistributionFunctions + + Cumulative distribution functions and their inverses are provided + by routines from "dcdflib.c", available from the + \Guide to Available Mathematical Software\. This version has + been slightly modified in packaging, for example changing names like + cdft() to cdf_t(), reducing the number of external symbols, and + changes to the routines that provide machine precision information. + Index: src/libdcdf/Makefile ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/Makefile 2003-12-03 17:26:07.000000000 -0500 @@ -0,0 +1,46 @@ +# +# Makefile for the C version of cdflib +# +# Copyright (c) 1999 Pittsburgh Supercomputing Center +# +# HISTORY +# 4/99 Written by Joel Welling +# + +PKG = libcdf +PKG_EXPORTS = dcdflib.h +PKG_MAKELIBS = $L/libdcdf.a +PKG_MAKEBINS = cdftester + +PKG_LIBS = $(LAPACK_LIBS) + +MAKEFILES= Makefile +CSOURCE = ipmpar.c dcdflib.c cdftester.c +HFILES= dcdflib.h dcdflib_private.h +DOCFILES= README libdcdf_help.help + +include ../Makefile.pkg + +LIB_OBJ = $O/dcdflib.o $O/ipmpar.o + +$L/libdcdf.a: $(LIB_OBJ) + @echo "%%%% Building libdcdf.a %%%%" + @$(AR) $(ARFLAGS) $L/libdcdf.a $(LIB_OBJ) + @$(RANLIB) $L/libdcdf.a + +$O/dcdflib.o: dcdflib.c + $(CC_RULE) + +$O/ipmpar.o: ipmpar.c + $(CC_RULE) + +cdftester: $O/cdftester.o $(LIB_OBJ) + @echo "%%%% Linking $(@F) %%%%" + @$(LD) -o cdftester $(LFLAGS) $O/cdftester.o $(LIB_OBJ) $(PKG_LIBS) -lm + +$O/cdftester.o: cdftester.c + $(CC_RULE) + +releaseprep: + echo "no release prep from " `pwd` + Index: src/libdcdf/README ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/libdcdf/README 2003-10-07 19:25:10.000000000 -0400 @@ -0,0 +1,382 @@ + + + + + + + + + + + + DCDFLIB + + Library of C Routines for Cumulative Distribution + Functions, Inverses, and Other Parameters + + (February, 1994) + + + + + + + Summary Documentation of Each Routine + + + + + + + + + Compiled and Written by: + + Barry W. Brown + James Lovato + Kathy Russell + + + + + + + + + + Department of Biomathematics, Box 237 + The University of Texas, M.D. Anderson Cancer Center + 1515 Holcombe Boulevard + Houston, TX 77030 + + + This work was supported by grant CA-16672 from the National Cancer Institute. + + + SUMMARY OF DCDFLIB + +This library contains routines to compute cumulative distribution +functions, inverses, and parameters of the distribution for the +following set of statistical distributions: + + (1) Beta + (2) Binomial + (3) Chi-square + (4) Noncentral Chi-square + (5) F + (6) Noncentral F + (7) Gamma + (8) Negative Binomial + (9) Normal + (10) Poisson + (11) Student's t + +Given values of all but one parameter of a distribution, the other is +computed. These calculations are done with C pointers to Doubles. + + -------------------- WARNINGS -------------------- + +The F and Noncentral F distribution are not necessarily monotone in +either degree of freedom argument. Consequently, there may be two +degree of freedom arguments that satisfy the specified condition. An +arbitrary one of these will be found by the cdf routines. + +The amount of computation required for the noncentral chisquare and +noncentral F distribution is proportional to the value of the +noncentrality parameter. Very large values of this parameter can +require immense numbers of computation. Consequently, when the +noncentrality parameter is to be calculated, the upper limit searched +is 10,000. + + -------------------- END WARNINGS -------------------- + + + COMMENTS ON THE C VERSION OF DCDFLIB + +The C version was obtained by converting the original Fortran DCDFLIB +to C using PROMULA.FORTRAN and performing some hand crafting of the +result. Information on PROMULA.FORTRAN can be obtained from + + PROMULA Development Corporation + 3620 N. High Street, Suite 301 + Columbus, Ohio 43214 + (614) 263-5454 + +DCDFLIB.C was tested using the xlc compiler under AIX 3.1 on an IBM +RS/6000. The code was also examined with lint on the same system. +DCDFLIB was also successfully tested run using the gcc compiler (see +below) on a Solbourne. + +DCDFLIB.C can be obtained by anonymous ftp to odin.mda.uth.tmc.edu +(129.106.3.17) where it is available as + /pub/unix/dcdflib.c.tar.Z + +The Fortran version of DCDFLIB is available as + /pub/unix/dcdflib.f.tar.Z +on the same machine. +^L + + + + + CAVEAT + +DCDFLIB.C is written in ANSI C and makes heavy use of prototypes. It +will not compile under old style (KR) C compilers (such as the default +Sun cc compiler). + +I don't recommend conversion to an obsolete C dialect. Instead, get +the Free Software Foundation's excellent ANSI C compiler, gcc. It +compiles KR C as well as ANSI C. A version of gcc that runs on many +varieties of Unix is available by anonymous ftp as + /pub/gnu/gcc-1.40.tar.Z +at prep.ai.mit.edu (18.71.0.38). A Vax version is also present on +/pub/gnu. The compilers are also available on tape. Write the Free +Software Foundation at: + + Free Software Foundation, Inc. + 675 Massachusetts Avenue + Cambridge, MA 02139 + Phone: (617) 876-3296 + +A MSDOS port of gcc, performed by DJ Delorie is also available by ftp. + +File location: + + host: grape.ecs.clarkson.edu + login: ftp + password: send your e-mail address + directory: ~ftp/pub/msdos/djgcc + +File in .ZIP format - djgpp.zip - one 2.2M file, contains everything. + +A version of DCDFLIB which compiles under old style C can be obtained +by anonymous ftp to odin.mda.uth.tmc.edu (129.106.3.17) where it is +available as + /pub/unix/dcdflib.kr.c.tar.Z + + + DOCUMENTATION + +This file contains an overview of the library and is the primary +documentation. + +Other documentation is in directory 'doc' on the distribution as +character (ASCII) files. A summary of all of the available routines +is contained in dcdflib.chs (chs is an abbreviation of 'cheat sheet'). +The 'chs' file will probably be the primary reference. The file, +dcdflib.fdoc, contains the comments for each routine intended for +direct use. The file, dcdflib.h, contains prototypes for each routine +intended for direct use. + + INSTALLATION + +Directory src contains the C source. The files ipmpar.c and dcdflib.c +constitute DCDFLIB. The file cdflib.h is included in dcdflib.c. + +A few routines use machine dependent constants. Lists of such +constants for different machines are found in ipmpar.c. Uncomment the +ones appropriate to your machine. The distributed version uses the +IEEE arithmetic that is used by the IBM PC, Macintosh, and most Unix +workstations. If you need to change the distribution version you must +comment out the definitions for IEEE arithmetic as well as uncomment +the ones appropriate to your machine. + +NOTE: dcdflib should be linked to the C math library. + +NOTE: Ignore compiler warnings of the type "statement not reached". + + SOURCES + +The following routines, written by others, are incorporated into +DCDFLIB. + + Beta Distribution + +DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant Digit +Computation of the Incomplete Beta Function Ratios. ACM Trans. Math. +Softw. 18 (1993), 360-373. + + Gamma Distribution and It's Inverse + +DiDinato, A. R. and Morris, A. H. Computation of the Incomplete Gamma +Function Ratios and their Inverse. ACM Trans. Math. Softw. 12 +(1986), 377-393. + + Normal Distribution + +Kennedy and Gentle, Statistical Computing, Marcel Dekker, NY, 1980. +The rational function approximations from pages 90-95 are used during +the calculation of the inverse normal. + +Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN +Package of Special Function Routines and Test Drivers", acm +Transactions on Mathematical Software. 19, 22-32. A slightly modified +version of Cody's function anorm is used for the cumultive normal. + + Zero Finder + +J. C. P. Bus and T. J. Dekker. Two Efficient Algorithms with +Guaranteed Convergence for Finding a Zero of a Function. ACM Trans. +Math. Softw. 4 (1975), 330. + +We transliterated Algoritm R of this paper from Algol to Fortran. + + General Reference + +Abramowitz, M. and Stegun, I. A. Handbook of Mathematical Functions +With Formulas, Graphs, and Mathematical Tables. (1964) National +Bureau of Standards. + +This book has been reprinted by Dover and others. + + + LEGALITIES + +Code that appeared in an ACM publication is subject to their +algorithms policy: + + Submittal of an algorithm for publication in one of the ACM + Transactions implies that unrestricted use of the algorithm within a + computer is permissible. General permission to copy and distribute + the algorithm without fee is granted provided that the copies are not + made or distributed for direct commercial advantage. The ACM + copyright notice and the title of the publication and its date appear, + and notice is given that copying is by permission of the Association + for Computing Machinery. To copy otherwise, or to republish, requires + a fee and/or specific permission. + + Krogh, F. Algorithms Policy. ACM Tran. Math. Softw. 13(1987), + 183-186. + +We place the DCDFLIB code that we have written in the public domain. + + NO WARRANTY + + WE PROVIDE ABSOLUTELY NO WARRANTY OF ANY KIND EITHER EXPRESSED OR + IMPLIED, INCLUDING BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK + AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD + THIS PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY + SERVICING, REPAIR OR CORRECTION. + + IN NO EVENT SHALL THE UNIVERSITY OF TEXAS OR ANY OF ITS COMPONENT + INSTITUTIONS INCLUDING M. D. ANDERSON HOSPITAL BE LIABLE TO YOU FOR + DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, + INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR + INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA OR + ITS ANALYSIS BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD + PARTIES) THE PROGRAM. + + (Above NO WARRANTY modified from the GNU NO WARRANTY statement.) + + HOW TO USE THE ROUTINES + +The calling sequence for each routine is of the form: + + void cdfgam(int *which,double *p,double *q,double *x, + double *,int *status,double *bound) + +WHICH and STATUS are pointers to int , all other arguements are +pointers to double. + + is a one to three character name identifying the distribution. +which is an input integer value that identifies what parameter value +is to be calculated from the values of the other parameters. + +P is always the cdf evaluated at X, Q is always the compliment of the +cdf evaluated at X, i.e. 1-P, and X is always the value at which the +cdf is evaluated. The auxiliary parameters, , of the +distribution differ by distribution. + +If WHICH is 1, P and Q are to be calculated, i.e., the cdf; if WHICH +is 2, X is to be calculated, i.e., the inverse cdf. The value of one +auxiliary parameter in can also be the value calculated. + +STATUS returns 0 if the calculation completes correctly. + + --------------------WARNING-------------------- + +If STATUS is not 0, no meaningful answer is returned. + + -------------------- END WARNING -------------------- + +STATUS returns -I if the I'th input parameter was not in the legal +range (see below). Parameters are counted with which being the first +in these return values. + +A STATUS value of 1 indicates that the desired answer was apparently +lower than the lower bound on the search interval. A return code of 2 +indicates that the answer was apparently higher than the upper bound +on the search interval. A return code of 3 indicates that P and Q did +not sum to 1. Other positive codes are routine specific. + +BOUND is not set if status is returned as 0. If STATUS is -I then +BOUND is the bound illegally exceeded by input parameter I, where +WHICH is counted as 1, P as 2, Q as 3, X as 4, etc. If STATUS is +returned as 1 or 2 then bound is returned as the lower or upper bound +on the search interval respectively. + + + BOUNDS + +Below are the rules that we used in determining bounds on quantities +to be calculated. Those who don't care can find a summary of the +bounds in dcdflib.chs. Input bounds are checked for legality of +input. The search range is the range of values searched for an +answer. + + Input Bounds + +Bounds on input parameters are checked by the cdf* routines. These +bounds were set according to the following rules. + +P: If the domain of the cdf (X) extends to -infinity then P must be +greater than 0 otherwise P must be greater than or equal to 0. P must +always be less than or equal to 1. + +Q: If the domain of the cdf (X) extends to +infinity then Q must be +greater than 0 otherwise Q must be greater than or equal to 0. Q must +always be less than or equal to 1. + +Further, P and Q must sum to 1. The smaller of the two P and Q will be +used in calculations to increase accuracy + +X: If the domain is infinite in either the positive or negative +direction, no check is performed in that direction. If the left end +of the domain is 0, then X is checked to assure non-negativity. + +DF, SD, etc.: Some auxiliary parameters must be positive. The lowest +input values accepted for these parameters is 1E-300. + + + Search Bounds + +These are the ranges searched for an answer. If the domain of the +parameter in the cdf is closed at some finite value, e.g., 0, then +this value is the same endpoint of the search range. If the domain is +open at some finite endpoint (which only occurs for 0 -- some +parameters must be strictly positive) then the endpoint is 1E-300. If +the domain is infinite in either direction then +/- 1E300 is used as +the endpoint of the search range. + + HOW THE ROUTINES WORK + +The cumulative distribution functions are computed directly. The +normal, gamma, and beta functions use the code from the references +cited. Other cdfs are calculated by relating them to one of these +distributions. For example, the binomial and negative binomial cdfs +can be converted to a beta cdf. This is how fractional observations +are handled. The formula from Abramowitz and Stegun for converting +the cdfs is cited in the fdoc file. (We think the formula for the +negative binomial in A&S is wrong, but there is a correct one which we +used.) + +The inverse normal and gamma are also taken from the references. For +all other parameters, a search is made for the value that provides the +desired P. Initial values are chosen crudely for the search (e.g., +5). If the domain of the cdf for the parameter being calculated is +infinite, a step doubling strategy is used to bound the desired value +then the zero finder is employed to refine the answer. The zero +finder attempts to obtain the answer accurately to about eight decimal +places. Index: src/fmri/bvls_help.help ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/fmri/bvls_help.help 2003-04-01 17:50:02.000000000 -0500 @@ -0,0 +1,98 @@ +*Details:BvlsCalculation + + BVLS solves linear least-squares problems with upper and lower + bounds on the variables, using an active set strategy. It can be + used iteratively to solve minimum l-1, l-2 and l-infinity fitting + problems. Bvls stands for "bounded variable least squares". This + implementation was translated from bvls.f. That source is available + from Statlib. This document comes from that source code. + + See the article ``Bounded Variable Least Squares: An Algorithm and + Applications'' by P.B. Stark and R.L. Parker, in the journal + Computational Statistics, in press (1995) for further description + and applications to minimum l-1, l-2 and l-infinity fitting problems, + as well as finding bounds on linear functionals subject to bounds on + variables and fitting linear data within l-1, l-2 or l-infinity + measures of misfit. + + BVLS solves the problem: + + min || a.x - b || such that bl <= x <= bu + 2 + where + x is an unknown n-vector + a is a given m by n matrix + b is a given m-vector + bl is a given n-vector of lower bounds on the + components of x. + bu is a given n-vector of upper bounds on the + components of x. + + + + Method: active variable method along the general plan of NNLS by + Lawson & Hanson, "Solving Least Squares Problems," 1974. See + Algorithm 23.10. Step numbers in comment statements refer to their + scheme. For more details and further uses, see the article + "Bounded Variable Least Squares: An Algorithm and Applications" + by Stark and Parker in 1995 Computational Statistics. + + A number of measures are taken to enhance numerical reliability: + + 1. As noted by Lawson and Hanson, roundoff errors in the computation + of the gradient of the misfit may cause a component on the bounds + to appear to want to become active, yet when the component is added + to the active set, it moves away from the feasible region. In this + case the component is not made active, the gradient of the misfit + with respect to a change in that component is set to zero, and the + program returns to the Kuhn-Tucker test. Flag ifrom5 is used in + this test, which occurs at the end of Step 6. + + + 2. When the least-squares minimizer after Step 6 is infeasible, it + is used in a convex interpolation with the previous solution to + obtain a feasible vector. The constant in this interpolation is + supposed to put at least one component of x on a bound. There can + be difficulties: + + 2a. Sometimes, due to roundoff, no interpolated component ends up on + a bound. The code in Step 11 uses the flag jj, computed in Step 8, + to ensure that at least the component that determined the + interpolation constant alpha is moved to the appropriate bound. + This guarantees that what Lawson and Hanson call `Loop B' is finite. + + 2b. The code in Step 11 also incorporates Lawson and Hanson's feature + that any components remaining infeasible at this stage (which must + be due to roundoff) are moved to their nearer bound. + + + 3. If the columns of a passed to qr are linearly dependent, the new + potentially active component is not introduced: the gradient of the + misfit with respect to that component is set to zero, and control + returns to the Kuhn-Tucker test. + + + 4. When some of the columns of a are approximately linearly + dependent, we have observed cycling of active components: a + component just moved to a bound desires immediately to become + active again; qr allows it to become active and a different + component is moved to its bound. This component immediately wants + to become active, which qr allows, and the original component is + moved back to its bound. We have taken two steps to avoid this + problem: + + 4a. First, the column of the matrix a corresponding to the new + potentially active component is passed to qr as the last column of + its matrix. This ordering tends to make a component recently moved + to a bound fail the test mentioned in (1), above. + + 4b. Second, we have incorporated a test that prohibits short cycles. + If the most recent successful change to the active set was to move + the component x(jj) to a bound, x(jj) is not permitted to reenter + the solution at this stage. This test occurs just after checking + the Kuhn-Tucker conditions, and uses the flag jj, set in Step 8. + The flag jj is reset after Step 6 if Step 6 was entered from + Step 5 indicating that a new component has successfully entered the + active set. The test for resetting jj uses the flag ifrom5, + which will not equal zero in case Step 6 was entered from Step 5. + Index: src/reader/lx_2dfast_reader.c ======================================== --- /dev/null 2002-08-30 19:31:37.000000000 -0400 +++ src/reader/lx_2dfast_reader.c 2003-11-04 17:24:35.000000000 -0500 @@ -0,0 +1,316 @@ +/************************************************************ + * * + * lx_2dfast_reader.c * + * * + * Permission is hereby granted to any individual or * + * institution for use, copying, or redistribution of * + * this code and associated documentation, provided * + * that such code and documentation are not sold for * + * profit and the following copyright notice is retained * + * in the code and documentation: * + * Copyright (c) 1995 Department of Statistics, * + * Carnegie Mellon University * + * * + * This program 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. Neither Carnegie Mellon University * + * nor any of the authors assume any liability for * + * damages, incidental or otherwise, caused by the * + * installation or use of this software. * + * * + * CLINICAL APPLICATIONS ARE NOT RECOMMENDED, AND THIS * + * SOFTWARE HAS NOT BEEN EVALUATED BY THE UNITED STATES * + * FDA FOR ANY CLINICAL USE. * + * * + * * + * Original programming by Mark Fitzgerald 5-96 * + * Modified to exclusively use libmri calls for output, * + * Greg Hood (PSC), 9-98 * + * Modified to read header files, and to use LX2 * + * resampling stuff, Joel Welling (PSC/Stats), 5-1999 * + ************************************************************/ +/* This routine uses functionality from the "epirecon" code + * supplied with the GE LX2 scanner system, author + * Bryan J. Mock (GE Medical Systems). + */ + +#include +#include +#include +#include +#include +#include "mri.h" +#if (SGI64 || SGI5 || SGIMP) +#include +#endif + +#include "bio.h" +#include "fmri.h" +#include "array.h" +#include "stdcrg.h" +#include "misc.h" +#include "smartreader.h" +#include "nr_sub.h" +#include "frozen_header_info.h" + +/* LX header files */ +#ifdef USE_RDBM_LX2 +#define ADD_VSUFFIX(x) x ## _lx2 +#elif USE_RDBM_PRELX +#define ADD_VSUFFIX(x) x ## _prelx +#else +#define ADD_VSUFFIX(x) x ## _cnv4 +#endif + +static char rcsid[] = "$Id: lx_2dfast_reader.c,v 1.1 2003/11/04 22:24:35 welling Exp $"; + +#define BLANKY_NUM_DEFAULT 2 +#define BLANKY_NUM_MAX 10 + +#define GE_RESAMPLE_SCRIPT "ge_ramp_resample.csh" + +static int +IntBRdFloat32 (unsigned char *addr) +{ + return((int) Round(BRdFloat32(addr))); +} + +void ADD_VSUFFIX(scan2dfastHeader)( KVHash* info, + unsigned char* rdbhead, + unsigned char* acq_tab, + unsigned char* examhead, + unsigned char* serieshead, + unsigned char* imagehead ) +{ + /* Read from header. A two-step translation then happens: + * from the header fields to the language of Mock's "epirecon", + * then to the language of this program. + */ + KVHash* defs= kvGetHash(info,"definitions"); + + float bandwidth; /* reciever bandwidth from header */ + char plane[4]; /* if pl = L/R > axial or A/P > sag, */ + /* S/I > coronal */ + int xres, yres; /* acq. resolution */ + int rcxres,rcyres; /* reconstructed resolution (with fovar=1.0) */ + float fovar; /* Field of View Aspect Ratio from header */ + int numreps; /* total reps and rep number (nex in header) */ + int frame; /* size of each image points calc. from */ + /* header info */ + int ssp_size; /* Adding these together (+ header) should */ + int pt_size = 0; /* For extended Dynamic Range data */ + int rhraw_size; /* give expected file size in bytes */ + float hnw; /* homodyne correction transition width in */ + /* header */ + float fw, fr; /* fermi width and radius from header */ + char pl; /* orientation of slice */ + short swapfp; /* swapped freq/phase encode direction 1 = */ + /* yes - determines if images are reoriented */ + short rot, tpose; + int blanky_num; /* # of y lines to blank @ top & bottom of image */ + int bviews = 0; /* # of baseline views */ + int ileaves = 1; /* # of interleaves if multi-shot EPI */ + int fast_rec = 0; /* fast_reciever check */ + int vpsht; /* Ky views per shot */ + int interm_xres; /* reconstructed x resolution (with fovar != 1.0)*/ + + /* Offset of the actual sample data */ + kvDefLong(info,"start_offset", + FRZ_POOL_HEADER_SIZE + + (2 * kvGetInt(info,"pt_size") + * (kvGetInt(info,"bviews")+kvGetInt(info,"bl_save")))); + + /* Set acquired matrix size xres,yres, reconstruction size rcxres, */ + /* rcyres, number of slices, frame size of each image, and number of */ + /* reps (nex) from rawheader */ + xres = BRdInt16(rdbhead+FRZ_RDBHEAD_RDB_HDR_DA_XRES_OFF); + yres = BRdInt16(rdbhead+FRZ_RDBHEAD_RDB_HDR_DA_YRES_OFF)-1; + fovar = BRdFloat32(rdbhead+FRZ_RDBHEAD_RDB_HDR_PHASE_SCALE_OFF); + + /* Other variables in the nomenclature of Mock's "epirecon" */ + rcxres = BRdInt16(rdbhead+FRZ_RDBHEAD_RDB_HDR_RC_XRES_OFF); + interm_xres = (int)((float)rcxres/fovar); + rcyres = BRdInt16(rdbhead+FRZ_RDBHEAD_RDB_HDR_RC_YRES_OFF); + numreps = BRdFloat32(imagehead+FRZ_IMAGEHEAD_NEX_OFF); + /* allow for ext dyn. range data */ + pt_size = kvGetInt(info,"pt_size"); + frame = xres*yres*pt_size; + ssp_size = BRdInt32(rdbhead+FRZ_RDBHEAD_RDB_HDR_SSPSAVE_OFF); + rhraw_size = + BRdInt32(rdbhead+FRZ_RDBHEAD_RDB_HDR_RAW_PASS_SIZE_OFF); + hnw = BRdFloat32(rdbhead+FRZ_RDBHEAD_RDB_HDR_NTRAN_OFF); + fw = BRdFloat32(rdbhead+FRZ_RDBHEAD_RDB_HDR_FERMI_WIDTH_OFF); + fr = BRdFloat32(rdbhead+FRZ_RDBHEAD_RDB_HDR_FERMI_RADIUS_OFF); + pl = *((char*)imagehead + FRZ_IMAGEHEAD_LOC_RAS_OFF); + swapfp = BRdInt16(imagehead+FRZ_IMAGEHEAD_SWAPPF_OFF); + bandwidth = BRdFloat32(imagehead+FRZ_IMAGEHEAD_VBW_OFF); + blanky_num = BRdInt16(rdbhead+FRZ_RDBHEAD_RDB_HDR_SLBLANK_OFF); + bviews = kvGetInt(info,"bviews"); + fast_rec = BRdInt32(rdbhead+FRZ_RDBHEAD_RDB_HDR_FAST_REC_OFF); + ileaves = BRdInt16(rdbhead+FRZ_RDBHEAD_RDB_HDR_ILEAVES_OFF); + + /* set number of blank lines to 2 if out of bounds */ + if( (blanky_num == 0) || (blanky_num > BLANKY_NUM_MAX) ) + blanky_num = BLANKY_NUM_DEFAULT; + + /* number of views per shot */ + if(ileaves != 0) vpsht= yres/ileaves; + else vpsht= yres; /* presumably single shot data */ + + /* BJM: safety check in case BW field in image header is NULL */ + if(bandwidth == 62.0) + bandwidth+= 0.5; + else if (bandwidth == 0.0) /* assume GE epibold.e */ + bandwidth = BRdFloat32(rdbhead+FRZ_RDBHEAD_RDB_HDR_USER16_OFF); + else if (bandwidth == 0.0) { /* if STILL Zero.. */ + Warning(1,"%s: Warning: Reciever bandwidth was ZERO\n", progname); + if (kvLookup(info,"bandpassdir")) { + Warning(1, + "%s: Not performing band pass asymmetry correction\n",progname); + kvDeleteAll(info,"bandpassdir"); + } + } + kvDefDouble(info,"bandwidth",bandwidth); + kvDefString(defs,"bandwidth","receiver bandwdith in MHz"); + + kvDefDouble(info,"fermi_width",fw); + kvDefString(defs,"fermi_width","Fermi filter width"); + kvDefDouble(info,"fermi_radius",fr); + kvDefString(defs,"fermi_radius","Fermi filter radius"); + + kvDefDouble(info,"fov_x",BRdFloat32(imagehead+FRZ_IMAGEHEAD_DFOV_OFF)); + kvDefString(defs,"fov_x","X field of view (mm)"); + + if(fovar == 0.5) { + kvDefDouble(info,"fov_y", + BRdFloat32(imagehead+FRZ_IMAGEHEAD_DFOV_RECT_OFF)/fovar); + } + else { + kvDefDouble(info,"fov_y", + BRdFloat32(imagehead+FRZ_IMAGEHEAD_DFOV_RECT_OFF)); + } + kvDefString(defs,"fov_y","Y field of view (mm)"); + + kvDefDouble(info,"voxel_x", + BRdFloat32(imagehead+FRZ_IMAGEHEAD_PIXSIZE_X_OFF)); + kvDefString(defs,"voxel_x","X voxel size (mm)"); + kvDefDouble(info,"voxel_y", + BRdFloat32(imagehead+FRZ_IMAGEHEAD_PIXSIZE_Y_OFF)); + kvDefString(defs,"voxel_y","Y voxel size (mm)"); + kvDefDouble(info,"image_x",BRdFloat32(imagehead+FRZ_IMAGEHEAD_DIM_X_OFF)); + kvDefDouble(info,"image_y",BRdFloat32(imagehead+FRZ_IMAGEHEAD_DIM_Y_OFF)); + kvDefInt(info,"overscan",BRdInt16(rdbhead+FRZ_RDBHEAD_RDB_HDR_HNOVER_OFF)); + + if (pt_size<4) kvDefInt(info,"datatype_in",MRI_SHORT); + else kvDefInt(info,"datatype_in",MRI_INT); + kvDefInt(info,"dv",2); + + kvDefInt(info,"dy",vpsht); + kvDefInt(info,"dy_base",rcyres); + kvDefString(defs,"dy_base","y samples after reconstruction and clipping"); + if (rcyres == yres) { + kvDefBoolean(info,"partialk",0); + } + else { + kvDefBoolean(info,"partialk",0); + } + kvDefString(defs,"partialk","partial-k completion needed"); + + if (ileaves != 0) kvDefInt(info,"ds",ileaves); + else kvDefInt(info,"ds",1); + kvDefInt(info,"dt",numreps); + + kvDefInt(info,"ncoils", + BRdInt16(rdbhead + FRZ_RDBHEAD_RDB_HDR_DAB_0_STOP_RCV_OFF) - + BRdInt16(rdbhead + FRZ_RDBHEAD_RDB_HDR_DAB_0_START_RCV_OFF) + 1); + kvDefString(defs,"ncoils","# of coils"); + kvDefInt(info,"coil_record_length", + BRdInt32(rdbhead + FRZ_RDBHEAD_RDB_HDR_RAW_PASS_SIZE_OFF) + / kvGetInt(info,"ncoils")); + kvDefString(defs,"coil_record_length","# of bytes in one coil record"); + kvDefInt(info,"baseline_length",4*kvGetInt(info,"ndat")); + kvDefString(defs,"baseline_length","# of bytes in one baseline record"); + if (kvGetInt(info,"ncoils")>1) + kvDefInt(info,"dc",kvGetInt(info,"ncoils")); + + /* For some reason, these files are broken up into groups of at most + * 7 slices. + */ + if (kvGetInt(info,"nslices") > 7) + kvDefInt(info,"dz",7); + else + kvDefInt(info,"dz",kvGetInt(info,"nslices")); + + if (rcxres != xres) { + /* ramp resampling required */ + if (!kvLookup(info,"rampfile")) + Warning(1,"%s: scan_2dfast_header: ramp resampling needed, but no ramp file given!\n", + progname); + kvDefInt(info,"dx_resampled",rcxres); + kvDefInt(info,"dq",xres); + kvDefBoolean(info,"resample",1); + kvDefString(defs,"resample","regridding for ramp sampling required"); + kvDefString(info,"resample_method",GE_RESAMPLE_SCRIPT); + if (kvLookup(info,"dc") && kvGetInt(info,"dc")>1) { + if (kvLookup(info,"ds") && kvGetInt(info,"ds")>1) { + kvDefString(info,"dimstr","vqyszct"); + } + else { + kvDefString(info,"dimstr","vqyzct"); + } + } + else { + if (kvLookup(info,"ds") && kvGetInt(info,"ds")>1) { + kvDefString(info,"dimstr","vqyszt"); + } + else { + kvDefString(info,"dimstr","vqyzt"); + } + } + } + else { + kvDefInt(info,"dx",xres); + if (kvLookup(info,"dc") && kvGetInt(info,"dc")>1) { + if (kvLookup(info,"ds") && kvGetInt(info,"ds")>1) { + kvDefString(info,"dimstr","vxyszct"); + } + else { + kvDefString(info,"dimstr","vxyzct"); + } + } + else { + if (kvLookup(info,"ds") && kvGetInt(info,"ds")>1) { + kvDefString(info,"dimstr","vxyszt"); + } + else { + kvDefString(info,"dimstr","vxyzt"); + } + } + } + + kvDefBoolean(info,"reorder",1); + kvDefString(info,"reorder_pattern","even/odd"); + kvDefLong(info,"skip",0); + kvDefLong(info,"sliceskip",0); + + kvDefBoolean(info,"rowflip",0); + kvDefString(defs,"rowflip","EPI row reversal needed"); + kvDefString(info,"rowflip_pattern","none"); + kvDefString(defs,"rowflip_pattern","EPI row reversal pattern"); + + if (kvGetInt(info,"overscan")==0) { + kvDefBoolean(info,"ychop",1); + kvDefInt(info,"kspace_ctr.y",0); + } + else { + kvDefBoolean(info,"ychop",1); + kvDefInt(info,"kspace_ctr.y",yres-kvGetInt(info,"overscan")); + } + kvDefString(defs,"kspace_ctr.y", "this row crosses the k-space origin"); + + kvDefInt(info,"kspace_ctr.x",xres/2); + kvDefString(defs,"kspace_ctr.x", "this column crosses the k-space origin"); + +} + Index: src/reader/Makefile =================================================================== RCS file: /home/TINGENEK/welling/cvsroot/Fiasco/src/reader/Makefile,v retrieving revision 1.26 retrieving revision 1.28 diff -r1.26 -r1.28 45c45 < tables.c smart_utils.c vec3.c --- > tables.c smart_utils.c vec3.c lx_2dfast_reader.c