/* Subroutine */ int rcvr_(real *zin, real *zout)
{
/* Initialized data */
static real theta = 0.f;
static real thetlo = 0.f;
/* Builtin functions */
double r_mod(real *, real *), cos(doublereal), sin(doublereal);
/* Local variables */
static real zi, zq, zilp, zqlp;
/* THIS SUBROUTINE CONVERTS THE INPUT SIGNAL AT */
/* RADIAN FREQ WC TO 1000 Hz. */
theta += blk2_1.wc * blk1_1.tau;
theta = r_mod(&theta, &c_b2);
zi = *zin * cos(theta);
zq = *zin * sin(theta);
zilp += (zi - zilp) * .07f;
zqlp += (zq - zqlp) * .07f;
thetlo += blk1_1.tau * 6283.2f;
thetlo = r_mod(&thetlo, &c_b2);
*zout = zilp * cos(thetlo) + zqlp * sin(thetlo);
return 0;
} /* rcvr_ */
static bool r_right(const decimal& a)
{
return r_mod(a,d90)==d0;
}
integer rdcalgmskb3_(integer *calb, integer *idir, integer *iband, integer *
itab)
{
/* Initialized data */
static real wnfctr[3] = { .7903f,.7874f,.8676f };
/* System generated locals */
address a__1[2];
integer ret_val, i__1, i__2, i__3[2];
real r__1;
char ch__1[55], ch__2[73], ch__3[42];
/* Builtin functions */
double r_sign(real *, real *), pow_ri(real *, integer *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double r_mod(real *, real *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static real c__, g;
static integer i__, j, k;
static real r__, v, c0, v0;
static integer v1, v2, ig[3], iv, ic0[3], iv0[3], ida, dir[512], ihr, imn,
imo, iok, jok;
extern integer lit_(char *, ftnlen), lwix_(char *, integer *, integer *,
integer *, ftnlen);
static integer iss;
static real riv;
static integer iyr, ixv, ifac;
static real beta[21] /* was [7][3] */;
static integer ltab, ioff;
extern real gmtradgmskb3_(real *, integer *);
static integer kend;
extern /* Subroutine */ int gmpfcogmskb3_(char *, integer *, ftnlen);
static integer nlen;
extern /* Subroutine */ int movb_();
static real rrem;
static integer kbyt;
extern integer ksys_(integer *);
static integer idcal;
static char calbl[1*7168];
static integer iarea;
static char cfile[12], cname[4];
static integer ibeta[21] /* was [7][3] */, idate[2], ifact[3], idsen;
extern /* Subroutine */ int edestX_(char *, integer *, ftnlen);
static integer ntabs, istat;
extern /* Subroutine */ int sysin_(integer *, integer *);
static integer icalbl[1792];
extern /* Subroutine */ int swbyt4_(integer *, integer *), araget_(
integer *, integer *, integer *, integer *);
static integer ispare[3], lbstart, nbstart;
/* All variables must be declared */
/* from each line header for IBUF dat */
/* Input array of calibration constants */
/* for GMS, since the area calibratio */
/* block must be accessed locally) */
/* Area directory buffer (this is mandat */
/* Band number of data in area */
/* absolute radiation temperature */
/* Lookup table containing albedo or */
/* (defines NUMAREAOPTIONS) */
/* Global declarations for McIDAS areas */
/* Copyright(c) 1997, Space Science and Engineering Center, UW-Madison */
/* Refer to "McIDAS Software Acquisition and Distribution Policies" */
/* in the file mcidas/data/license.txt */
/* *** $Id: areaparm.inc,v 1.1 2000/07/12 13:12:23 gad Exp $ *** */
/* area subsystem parameters */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* IF YOU CHANGE THESE VALUES, YOU MUST ALSO CHANGE THEM IN */
/* MCIDAS.H !! */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* MAXGRIDPT maximum number of grid points */
/* MAX_BANDS maximum number of bands within an area */
/* MAXDFELEMENTS maximum number of elements that DF can handle */
/* in an area line */
/* MAXOPENAREAS maximum number of areas that the library can */
/* have open (formerly called `NA') */
/* NUMAREAOPTIONS number of options settable through ARAOPT() */
/* It is presently 5 because there are five options */
/* that ARAOPT() knows about: */
/* 'PREC','SPAC','UNIT','SCAL','CALB' */
/* (formerly called `NB') */
/* --- Size (number of words) in an area directory */
/* MAX_AUXBLOCK_SIZE size (in bytes) of the internal buffers */
/* used to recieve AUX blocks during an */
/* ADDE transaction */
/* ----- MAX_AREA_NUMBER Maximum area number allowed on system */
/* ----- MAXAREARQSTLEN - max length of area request string */
/* Flag identifying conversion code */
/* Source pixel size in bytes */
/* Destination pixel size in bytes */
/* Flag specifying how to construct ITAB */
/* Calibration parameters for conve */
/* Radiance table for GMS-5 */
/* We use only IVAL to pass back */
/* the calibration option used */
/* and rename ITAB because its */
/* address is passed as an arg */
/* platform or compiler depend */
/* too, and might be susceptab */
/* ID number of calibration table */
/* byte offset into GMSCAL file(s) */
/* Logical .AND. function */
/* Acquire SYSVAL value */
/* LW file read */
/* Converts CHAR*4 to INTEGER */
/* Real MOD function */
/* Converts GMS-5 TEMP to RAD */
/* index variable */
/* index variable */
/* index variable */
/* Length of arbitrary block in byt */
/* End word count of a block */
/* Input block starting byte count */
/* Output block starting byte count */
/* Input index value */
/* Interpolated data output index v */
/* First table value */
/* Second table value */
/* area number from IDIR array */
/* spacecraft/sensor ID from IDIR a */
/* LWI status returned */
/* Year */
/* Month */
/* Day of month */
/* Hour of day (GMT) */
/* Minute of hour */
/* (from first word in file) */
/* number of tables in the GMSCAL f */
/* Default GMSCAL table directory */
/* GMS-5 McIDAS Calibration block */
/* Calibration ID from data block */
/* (YY,YY,MM,DD,HH,mm) */
/* Six-byte date data block was gen */
/* (1=primary, 2=redundant) */
/* Sensor selector byte */
/* (significant if non-zero) */
/* bad radiance value counter */
/* (significant if non-zero) */
/* error flag for GMP_FCO function */
/* Byte address of CNAME block */
/* IR bands for converting DN to */
/* sensor output voltage (scaled */
/* Calibration constants for the th */
/* the series expansion for each */
/* Number of calibration constants */
/* G constant for each IR band */
/* V0 constant for each IR band */
/* C0 constant for each IR band */
/* Unused spare location in table */
/* the series expansion to be use */
/* Number of calibration constants */
/* Real input index value IV */
/* Remainder mod 1.0 */
/* IR bands for converting DN to */
/* sensor output voltage */
/* Calibration constants for the th */
/* (volts/watt/cm**2/sr) */
/* G constant to be used */
/* (zero level voltage) */
/* V0 constant to be used */
/* C0 constant to be used */
/* series expansion */
/* Intermediate "DN" value used in */
/* Output voltage from series expan */
/* (watts/cm**2/sr) */
/* Radiance from voltage and G cons */
/* W/cm**2/sr to W/etc/cm**-1 */
/* for the GMS-5 IR bands */
/* Wave number factor to convert fr */
/* calibration tables */
/* Input file containing default */
/* GMS-5 McIDAS Calibration block */
/* Table Name in calibration data b */
/* Parameter adjustments */
--itab;
--idir;
--calb;
/* Function Body */
iss = idir[3];
iarea = idir[33];
ltab = 0;
if (idir[3] == 12) {
ltab = 1;
} else if (idir[3] == 13) {
ltab = 3;
} else if (idir[3] == 82 && *iband == 1) {
ltab = 1;
} else if (idir[3] == 82 && *iband == 2) {
ltab = 3;
} else if (idir[3] == 82 && *iband == 8) {
ltab = 3;
} else if (idir[3] == 83 && *iband == 1) {
ltab = 4;
} else if (idir[3] == 83 && *iband == 2) {
ltab = 5;
} else if (idir[3] == 83 && *iband == 3) {
ltab = 6;
} else if (idir[3] == 83 && *iband == 4) {
ltab = 7;
} else if (idir[3] == 83 && *iband == 8) {
ltab = 5;
} else {
edestX_("RD_CAL: Unrecognized data band or SS", &c__0, (ftnlen)36);
ret_val = -1;
goto L500;
}
if (gmsxxgmskb3_1.kopt <= 0 || gmsxxgmskb3_1.kopt > 15) {
gmsxxgmskb3_1.kopt = ksys_(&c__151);
}
if (gmsxxgmskb3_1.kopt <= 0 || gmsxxgmskb3_1.kopt > 15) {
gmsxxgmskb3_1.kopt = 7;
if (idir[3] <= 82) {
gmsxxgmskb3_1.kopt = 3;
}
}
if (idir[3] <= 82 && gmsxxgmskb3_1.kopt > 3) {
edestX_("Invalid calibration option for SS=", &idir[3], (ftnlen)34);
edestX_(" ...was ", &gmsxxgmskb3_1.kopt, (ftnlen)12);
gmsxxgmskb3_1.kopt = 3;
edestX_(" ...reset to ", &gmsxxgmskb3_1.kopt, (ftnlen)17);
edestX_("Options > 3 valid for GMS-5 and later only!", &c__0, (ftnlen)
43);
}
debuggmskb3_2.ival = 0;
idsen = 0;
if ((gmsxxgmskb3_1.kopt & 12) != 0) {
araget_(&iarea, &idir[63], &c__7168, icalbl);
if (icalbl[0] != lit_("GMS5", (ftnlen)4) || icalbl[1] > 90) {
edestX_("Calibration block is not GMS-5 format.", &c__0, (ftnlen)
38);
edestX_("It cannot be used by the GMS calibration module.", &c__0,
(ftnlen)48);
edestX_("Will attempt to use GMSCAL file tables instead.", &c__0, (
ftnlen)47);
goto L200;
}
nlen = icalbl[1];
if (icalbl[2] == lit_("COEF", (ftnlen)4)) {
movb_(&c__256, icalbl, calbl, &c__0, (ftnlen)1);
for (i__ = 1; i__ <= 60; i__ += 3) {
i__1 = i__ + 2;
for (j = i__; j <= i__1; ++j) {
for (k = -3; k <= 0; ++k) {
if (*(unsigned char *)&calbl[(j << 2) + k - 1] < 32 ||
*(unsigned char *)&calbl[(j << 2) + k - 1] >
126) {
*(unsigned char *)&calbl[(j << 2) + k - 1] = '*';
}
}
}
}
movb_(&c__256, &icalbl[icalbl[3] / 4], calbl, &c__0, (ftnlen)1);
movb_(&c__4, calbl, &idcal, &c__0);
movb_(&c__6, calbl + 4, idate, &c__0, (ftnlen)1);
iyr = idate[0] / 65536;
imo = (idate[0] - (iyr << 16)) / 256;
ida = idate[0] - (iyr << 16) - (imo << 8);
ihr = idate[1] / 65536 / 256;
imn = idate[1] / 65536 - (ihr << 8);
movb_(&c__1, calbl + 10, &idsen, &c__0, (ftnlen)1);
idsen /= 16777216;
/* shift right 3 bytes */
ifact[0] = *(unsigned char *)&calbl[11];
movb_(&c__4, calbl + 12, ibeta, &c__0, (ftnlen)1);
movb_(&c__4, calbl + 16, &ibeta[1], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 20, &ibeta[2], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 24, &ibeta[3], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 28, &ibeta[4], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 32, &ibeta[5], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 36, &ibeta[6], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 40, ig, &c__0, (ftnlen)1);
movb_(&c__4, calbl + 44, iv0, &c__0, (ftnlen)1);
movb_(&c__4, calbl + 48, ic0, &c__0, (ftnlen)1);
movb_(&c__4, calbl + 52, ispare, &c__0, (ftnlen)1);
ifact[1] = *(unsigned char *)&calbl[56];
movb_(&c__4, calbl + 57, &ibeta[7], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 61, &ibeta[8], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 65, &ibeta[9], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 69, &ibeta[10], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 73, &ibeta[11], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 77, &ibeta[12], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 81, &ibeta[13], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 85, &ig[1], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 89, &iv0[1], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 93, &ic0[1], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 97, &ispare[1], &c__0, (ftnlen)1);
ifact[2] = *(unsigned char *)&calbl[101];
movb_(&c__4, calbl + 102, &ibeta[14], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 106, &ibeta[15], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 110, &ibeta[16], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 114, &ibeta[17], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 118, &ibeta[18], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 122, &ibeta[19], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 126, &ibeta[20], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 130, &ig[2], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 134, &iv0[2], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 138, &ic0[2], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 142, &ispare[2], &c__0, (ftnlen)1);
if (*iband > 1 && *iband <= 4) {
g = (ig[*iband - 2] & 2147483647) * 1e-6f;
v0 = (iv0[*iband - 2] & 2147483647) * 1e-6f;
c0 = (ic0[*iband - 2] & 2147483647) * 1e-6f;
r__1 = (real) ig[*iband - 2];
g = r_sign(&g, &r__1);
r__1 = (real) iv0[*iband - 2];
v0 = r_sign(&v0, &r__1);
r__1 = (real) ic0[*iband - 2];
c0 = r_sign(&c0, &r__1);
ifac = ifact[*iband - 2] + 1;
if (ifac < 1 || ifac > 7) {
ifac = 7;
}
for (i__ = 1; i__ <= 3; ++i__) {
i__1 = ifac;
for (j = 1; j <= i__1; ++j) {
beta[j + i__ * 7 - 8] = (ibeta[j + i__ * 7 - 8] &
2147483647) * 1e-6f;
r__1 = (real) ibeta[j + i__ * 7 - 8];
beta[j + i__ * 7 - 8] = r_sign(&beta[j + i__ * 7 - 8],
&r__1);
}
}
for (j = 1; j <= 255; ++j) {
/* index on S-VISSR DN l */
c__ = 255.f - j + c0;
/* convert to instrument */
v = 0.f;
i__1 = ifac;
for (k = 1; k <= i__1; ++k) {
/* do the series expansi */
i__2 = k - 1;
v += beta[k + (*iband - 1) * 7 - 8] * pow_ri(&c__, &
i__2);
}
r__ = (v - v0) / g;
/* convert to radiance W */
r__ = r__ * .5f / wnfctr[*iband - 2];
/* convert to mW/etc./cm */
radgmskb3_1.ktab[j - 1] = (integer) (r__ * 1e3f);
/* the KTAB table as */
/* scale by 1000 and put */
}
iok = 0;
for (j = 2; j <= 255; ++j) {
if (radgmskb3_1.ktab[j - 1] < 0 || radgmskb3_1.ktab[j - 1]
> 190000) {
++iok;
}
}
}
} else {
goto L100;
}
if (ltab <= 3) {
goto L100;
}
if (ltab == 4) {
s_copy(cname, "5VIS", (ftnlen)4, (ftnlen)4);
}
if (ltab == 5) {
s_copy(cname, "5IR1", (ftnlen)4, (ftnlen)4);
}
if (ltab == 6) {
s_copy(cname, "5IR2", (ftnlen)4, (ftnlen)4);
}
if (ltab == 7) {
s_copy(cname, "5IR3", (ftnlen)4, (ftnlen)4);
}
if (ltab >= 8) {
goto L100;
}
kbyt = 0;
kend = nlen / 4;
if (kend > 22) {
edestX_("RD_CAL: Bad directory structure. KEND=", &kend, (ftnlen)
39);
kend = 22;
}
i__1 = kend;
for (j = 5; j <= i__1; ++j) {
if (icalbl[j - 1] == lit_(cname, (ftnlen)4)) {
kbyt = icalbl[j];
}
}
if (kbyt != 0) {
movb_(&c__1024, &icalbl[kbyt / 4], &itab[1], &c__0);
itab[1] = itab[2];
itab[256] = itab[255];
} else {
edestX_("KBYT cannot be set -- no table exists", &c__0, (ftnlen)37)
;
goto L100;
}
if (*iband != 1) {
goto L80;
}
for (i__ = 4; i__ >= 1; --i__) {
lbstart = (i__ - 1 << 6) + 1;
nbstart = i__ - 1 << 8;
for (ixv = 256; ixv >= 1; --ixv) {
riv = (real) (ixv - 1) / 252.f * 63.f;
iv = riv;
v1 = itab[lbstart + iv];
v2 = itab[lbstart + iv + 1];
if (iv == 63) {
v2 = 1000000;
}
rrem = r_mod(&riv, &c_b208);
itab[nbstart + ixv] = v1 + (v2 - v1) * rrem + .5f;
}
}
L80:
debuggmskb3_2.ival = 8;
if (iok > 5 && (gmsxxgmskb3_1.kopt & 15) == 8) {
edestX_("Too many of the real-time power series radiances are", &
c__0, (ftnlen)52);
edestX_("outside expected limits and are likely to be in error.", &
c__0, (ftnlen)54);
goto L100;
}
if ((gmsxxgmskb3_1.kopt & 4) == 0) {
goto L400;
}
}
L100:
if ((gmsxxgmskb3_1.kopt & 4) != 0) {
if (iss == 83) {
if (idsen != 2) {
gmpfcogmskb3_("A", &jok, (ftnlen)1);
}
if (idsen == 2) {
gmpfcogmskb3_("B", &jok, (ftnlen)1);
}
if (jok == 0) {
goto L300;
}
for (j = 1; j <= 256; ++j) {
r__1 = itab[j] * .001f;
radgmskb3_1.ktab[j - 1] = gmtradgmskb3_(&r__1, iband) * 1e3f;
}
} else {
goto L200;
}
debuggmskb3_2.ival = 4;
goto L400;
}
L200:
if ((gmsxxgmskb3_1.kopt & 2) != 0) {
s_copy(cfile, "GMSCALU", (ftnlen)12, (ftnlen)7);
istat = lwix_(cfile, &c__0, &c__512, dir, (ftnlen)12);
swbyt4_(dir, &c__512);
if (istat != 0 && (gmsxxgmskb3_1.kopt & 1) == 0) {
/* Writing concatenation */
i__3[0] = 43, a__1[0] = "ERROR reading calibration tables from f"
"ile ";
i__3[1] = 12, a__1[1] = cfile;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)55);
edestX_(ch__1, &c__0, (ftnlen)55);
goto L300;
}
ntabs = dir[0];
ioff = (ltab - 1 << 8) + 512;
if (ltab > ntabs) {
goto L300;
}
istat = lwix_(cfile, &ioff, &c__256, &itab[1], (ftnlen)12);
swbyt4_(&itab[1], &c__256);
for (j = 1; j <= 256; ++j) {
itab[j + 256] = itab[j];
itab[j + 512] = itab[j];
itab[j + 768] = itab[j];
}
if (istat != 0) {
goto L300;
}
if (iss == 83) {
if (idsen != 2) {
gmpfcogmskb3_("A", &jok, (ftnlen)1);
}
if (idsen == 2) {
gmpfcogmskb3_("B", &jok, (ftnlen)1);
}
if (jok == 0) {
goto L300;
}
for (j = 1; j <= 256; ++j) {
r__1 = itab[j] * .001f;
radgmskb3_1.ktab[j - 1] = gmtradgmskb3_(&r__1, iband) * 1e3f;
}
}
debuggmskb3_2.ival = 2;
goto L400;
}
L300:
if ((gmsxxgmskb3_1.kopt & 1) != 0) {
s_copy(cfile, "GMSCAL", (ftnlen)12, (ftnlen)6);
istat = lwix_(cfile, &c__0, &c__512, dir, (ftnlen)12);
swbyt4_(dir, &c__512);
if (istat != 0) {
/* Writing concatenation */
i__3[0] = 43, a__1[0] = "ERROR reading calibration tables from f"
"ile ";
i__3[1] = 12, a__1[1] = cfile;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)55);
edestX_(ch__1, &c__0, (ftnlen)55);
ret_val = -1;
goto L500;
}
ntabs = dir[0];
ioff = (ltab - 1 << 8) + 512;
if (ltab > ntabs) {
edestX_("RD_CAL ERROR -- Unrecognized Table ID=", <ab, (ftnlen)
38);
/* Writing concatenation */
i__3[0] = 61, a__1[0] = "The table index is greater than number "
"of tables in the file ";
i__3[1] = 12, a__1[1] = cfile;
s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)73);
edestX_(ch__2, &c__0, (ftnlen)73);
edestX_("Check SS and band number for consistency with the table "
"ID", &c__0, (ftnlen)58);
edestX_(" SS=", &idir[3], (
ftnlen)38);
edestX_(" Band=", iband, (ftnlen)
38);
ret_val = -1;
goto L500;
}
istat = lwix_(cfile, &ioff, &c__256, &itab[1], (ftnlen)12);
swbyt4_(&itab[1], &c__256);
for (j = 1; j <= 256; ++j) {
itab[j + 256] = itab[j];
itab[j + 512] = itab[j];
itab[j + 768] = itab[j];
}
if (istat != 0) {
/* Writing concatenation */
i__3[0] = 30, a__1[0] = "File status error reading file";
i__3[1] = 12, a__1[1] = cfile;
s_cat(ch__3, a__1, i__3, &c__2, (ftnlen)42);
edestX_(ch__3, &istat, (ftnlen)42);
ret_val = -1;
goto L500;
}
if (iss == 83) {
if (idsen != 2) {
gmpfcogmskb3_("A", &jok, (ftnlen)1);
}
if (idsen == 2) {
gmpfcogmskb3_("B", &jok, (ftnlen)1);
}
if (jok == 0) {
ret_val = -1;
goto L500;
}
for (j = 1; j <= 256; ++j) {
r__1 = itab[j] * .001f;
radgmskb3_1.ktab[j - 1] = gmtradgmskb3_(&r__1, iband) * 1e3f;
}
}
debuggmskb3_2.ival = 1;
goto L400;
}
ret_val = -1;
goto L500;
L400:
if (debuggmskb3_2.ival == 0) {
ret_val = -1;
} else {
ret_val = 0;
}
L500:
sysin_(&c__152, &debuggmskb3_2.ival);
for (i__ = 1; i__ <= 1024; ++i__) {
debuggmskb3_2.itabr[i__ - 1] = itab[i__];
}
return ret_val;
} /* rdcalgmskb3_ */
/* DECK XLEGF */
/* Subroutine */ int xlegf_(real *dnu1, integer *nudiff, integer *mu1,
integer *mu2, real *theta, integer *id, real *pqa, integer *ipqa,
integer *ierror)
{
/* System generated locals */
integer i__1;
/* Local variables */
static integer i__, l;
static real x, sx, pi2, dnu2;
extern /* Subroutine */ int xred_(real *, integer *, integer *), xset_(
integer *, integer *, real *, integer *, integer *), xpmu_(real *,
real *, integer *, integer *, real *, real *, real *, integer *,
real *, integer *, integer *), xqmu_(real *, real *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
integer *), xqnu_(real *, real *, integer *, real *, real *, real
*, integer *, real *, integer *, integer *), xpnrm_(real *, real *
, integer *, integer *, real *, integer *, integer *), xpmup_(
real *, real *, integer *, integer *, real *, integer *, integer *
), xpqnu_(real *, real *, integer *, real *, integer *, real *,
integer *, integer *), xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE XLEGF */
/* ***PURPOSE Compute normalized Legendre polynomials and associated */
/* Legendre functions. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C3A2, C9 */
/* ***TYPE SINGLE PRECISION (XLEGF-S, DXLEGF-D) */
/* ***KEYWORDS LEGENDRE FUNCTIONS */
/* ***AUTHOR Smith, John M., (NBS and George Mason University) */
/* ***DESCRIPTION */
/* XLEGF: Extended-range Single-precision Legendre Functions */
/* A feature of the XLEGF subroutine for Legendre functions is */
/* the use of extended-range arithmetic, a software extension of */
/* ordinary floating-point arithmetic that greatly increases the */
/* exponent range of the representable numbers. This avoids the */
/* need for scaling the solutions to lie within the exponent range */
/* of the most restrictive manufacturer's hardware. The increased */
/* exponent range is achieved by allocating an integer storage */
/* location together with each floating-point storage location. */
/* The interpretation of the pair (X,I) where X is floating-point */
/* and I is integer is X*(IR**I) where IR is the internal radix of */
/* the computer arithmetic. */
/* This subroutine computes one of the following vectors: */
/* 1. Legendre function of the first kind of negative order, either */
/* a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or */
/* b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X) */
/* 2. Legendre function of the second kind, either */
/* a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or */
/* b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X) */
/* 3. Legendre function of the first kind of positive order, either */
/* a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or */
/* b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X) */
/* 4. Normalized Legendre polynomials, either */
/* a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or */
/* b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X) */
/* where X = COS(THETA). */
/* The input values to XLEGF are DNU1, NUDIFF, MU1, MU2, THETA, */
/* and ID. These must satisfy */
/* DNU1 is REAL and greater than or equal to -0.5; */
/* NUDIFF is INTEGER and non-negative; */
/* MU1 is INTEGER and non-negative; */
/* MU2 is INTEGER and greater than or equal to MU1; */
/* THETA is REAL and in the half-open interval (0,PI/2]; */
/* ID is INTEGER and equal to 1, 2, 3 or 4; */
/* and additionally either NUDIFF = 0 or MU2 = MU1. */
/* If ID=1 and NUDIFF=0, a vector of type 1a above is computed */
/* with NU=DNU1. */
/* If ID=1 and MU1=MU2, a vector of type 1b above is computed */
/* with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. */
/* If ID=2 and NUDIFF=0, a vector of type 2a above is computed */
/* with NU=DNU1. */
/* If ID=2 and MU1=MU2, a vector of type 2b above is computed */
/* with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. */
/* If ID=3 and NUDIFF=0, a vector of type 3a above is computed */
/* with NU=DNU1. */
/* If ID=3 and MU1=MU2, a vector of type 3b above is computed */
/* with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. */
/* If ID=4 and NUDIFF=0, a vector of type 4a above is computed */
/* with NU=DNU1. */
/* If ID=4 and MU1=MU2, a vector of type 4b above is computed */
/* with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. */
/* In each case the vector of computed Legendre function values */
/* is returned in the extended-range vector (PQA(I),IPQA(I)). The */
/* length of this vector is either MU2-MU1+1 or NUDIFF+1. */
/* Where possible, XLEGF returns IPQA(I) as zero. In this case the */
/* value of the Legendre function is contained entirely in PQA(I), */
/* so it can be used in subsequent computations without further */
/* consideration of extended-range arithmetic. If IPQA(I) is nonzero, */
/* then the value of the Legendre function is not representable in */
/* floating-point because of underflow or overflow. The program that */
/* calls XLEGF must test IPQA(I) to ensure correct usage. */
/* IERROR is an error indicator. If no errors are detected, IERROR=0 */
/* when control returns to the calling routine. If an error is detected, */
/* IERROR is returned as nonzero. The calling routine must check the */
/* value of IERROR. */
/* If IERROR=110 or 111, invalid input was provided to XLEGF. */
/* If IERROR=101,102,103, or 104, invalid input was provided to XSET. */
/* If IERROR=105 or 106, an internal consistency error occurred in */
/* XSET (probably due to a software malfunction in the library routine */
/* I1MACH). */
/* If IERROR=107, an overflow or underflow of an extended-range number */
/* was detected in XADJ. */
/* If IERROR=108, an overflow or underflow of an extended-range number */
/* was detected in XC210. */
/* ***SEE ALSO XSET */
/* ***REFERENCES Olver and Smith, Associated Legendre Functions on the */
/* Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518. */
/* Smith, Olver and Lozier, Extended-Range Arithmetic and */
/* Normalized Legendre Polynomials, ACM Trans on Math */
/* Softw, v 7, n 1, March 1981, pp 93--105. */
/* ***ROUTINES CALLED XERMSG, XPMU, XPMUP, XPNRM, XPQNU, XQMU, XQNU, */
/* XRED, XSET */
/* ***REVISION HISTORY (YYMMDD) */
/* 820728 DATE WRITTEN */
/* 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) */
/* 901019 Revisions to prologue. (DWL and WRB) */
/* 901106 Changed all specific intrinsics to generic. (WRB) */
/* Corrected order of sections in prologue and added TYPE */
/* section. (WRB) */
/* CALLs to XERROR changed to CALLs to XERMSG. (WRB) */
/* 920127 Revised PURPOSE section of prologue. (DWL) */
/* ***END PROLOGUE XLEGF */
/* ***FIRST EXECUTABLE STATEMENT XLEGF */
/* Parameter adjustments */
--ipqa;
--pqa;
/* Function Body */
*ierror = 0;
xset_(&c__0, &c__0, &c_b4, &c__0, ierror);
if (*ierror != 0) {
return 0;
}
pi2 = atan(1.f) * 2.f;
/* ZERO OUTPUT ARRAYS */
l = *mu2 - *mu1 + *nudiff + 1;
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
pqa[i__] = 0.f;
/* L290: */
ipqa[i__] = 0;
}
/* CHECK FOR VALID INPUT VALUES */
if (*nudiff < 0) {
goto L400;
}
if (*dnu1 < -.5f) {
goto L400;
}
if (*mu2 < *mu1) {
goto L400;
}
if (*mu1 < 0) {
goto L400;
}
if (*theta <= 0.f || *theta > pi2) {
goto L420;
}
if (*id < 1 || *id > 4) {
goto L400;
}
if (*mu1 != *mu2 && *nudiff > 0) {
goto L400;
}
/* IF DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X) */
/* CANNOT BE CALCULATED. IF DNU1 IS AN INTEGER AND */
/* MU1.GT.DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND */
/* NORMALIZED P(MU,NU,X) WILL BE ZERO. */
dnu2 = *dnu1 + *nudiff;
if (*id == 3 && r_mod(dnu1, &c_b9) != 0.f) {
goto L295;
}
if (*id == 4 && r_mod(dnu1, &c_b9) != 0.f) {
goto L400;
}
if ((*id == 3 || *id == 4) && (real) (*mu1) > dnu2) {
return 0;
}
L295:
x = cos(*theta);
sx = 1.f / sin(*theta);
if (*id == 2) {
goto L300;
}
if (*mu2 - *mu1 <= 0) {
goto L360;
}
/* FIXED NU, VARIABLE MU */
/* CALL XPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X) */
xpmu_(dnu1, &dnu2, mu1, mu2, theta, &x, &sx, id, &pqa[1], &ipqa[1],
ierror);
if (*ierror != 0) {
return 0;
}
goto L380;
L300:
if (*mu2 == *mu1) {
goto L320;
}
/* FIXED NU, VARIABLE MU */
/* CALL XQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X) */
xqmu_(dnu1, &dnu2, mu1, mu2, theta, &x, &sx, id, &pqa[1], &ipqa[1],
ierror);
if (*ierror != 0) {
return 0;
}
goto L390;
/* FIXED MU, VARIABLE NU */
/* CALL XQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X) */
L320:
xqnu_(dnu1, &dnu2, mu1, theta, &x, &sx, id, &pqa[1], &ipqa[1], ierror);
if (*ierror != 0) {
return 0;
}
goto L390;
/* FIXED MU, VARIABLE NU */
/* CALL XPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X) */
L360:
xpqnu_(dnu1, &dnu2, mu1, theta, id, &pqa[1], &ipqa[1], ierror);
if (*ierror != 0) {
return 0;
}
/* IF ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO */
/* P(MU,NU,X) VECTOR. */
L380:
if (*id == 3) {
xpmup_(dnu1, &dnu2, mu1, mu2, &pqa[1], &ipqa[1], ierror);
}
if (*ierror != 0) {
return 0;
}
/* IF ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO */
/* NORMALIZED P(MU,NU,X) VECTOR. */
if (*id == 4) {
xpnrm_(dnu1, &dnu2, mu1, mu2, &pqa[1], &ipqa[1], ierror);
}
if (*ierror != 0) {
return 0;
}
/* PLACE RESULTS IN REDUCED FORM IF POSSIBLE */
/* AND RETURN TO MAIN PROGRAM. */
L390:
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
xred_(&pqa[i__], &ipqa[i__], ierror);
if (*ierror != 0) {
return 0;
}
/* L395: */
}
return 0;
/* ***** ERROR TERMINATION ***** */
L400:
xermsg_("SLATEC", "XLEGF", "DNU1, NUDIFF, MU1, MU2, or ID not valid", &
c__110, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)39);
*ierror = 110;
return 0;
L420:
xermsg_("SLATEC", "XLEGF", "THETA out of range", &c__111, &c__1, (ftnlen)
6, (ftnlen)5, (ftnlen)18);
*ierror = 111;
return 0;
} /* xlegf_ */
/* in the file mcidas/data/license.txt */
/* Subroutine */ int solarp_(integer *jday, integer *jtime, real *gha, real *
dec, real *xlat, real *xlon)
{
/* Initialized data */
static integer init = 0;
/* System generated locals */
real r__1, r__2;
doublereal d__1;
/* Builtin functions */
double sin(doublereal), cos(doublereal), sqrt(doublereal), atan2(
doublereal, doublereal), d_mod(doublereal *, doublereal *), r_mod(
real *, real *);
/* Local variables */
static integer i__;
static real pi, px, py, pz, qx, qy, qz, xs, ys, zs, sha;
static doublereal xha;
static real cand;
static doublereal raha;
static real cinc, sand;
static integer iday;
static real cper, sinc, slra, xmmc, sper;
extern real flalo_(integer *);
static real rdpdg;
extern real ftime_(integer *);
static real xfact;
static integer irayd, iepyd;
static real ptime;
static doublereal ecanm1;
static real oeccen;
static doublereal ecanom;
static real asnode;
extern real geolat_(real *, integer *);
static doublereal diftim;
extern doublereal timdif_(integer *, integer *, integer *, integer *);
static real oincli, perhel, xomega, yomega;
static integer irahms, iephms;
static real epsiln, solsid;
static doublereal xmanom;
/* *** $Id: solarp.f,v 1.1 2001/04/16 20:59:07 daves Exp $ *** */
/* SOLARP MOSHER 1074 WINLIB Z HOUR ANGLE AND SOLAR DECL FOR DAY-TIME */
/* $ SUBROUTINE SOLARP(JDAY, JTIME, GHA, DEC, XLAT, XLON) (DAS) */
/* $ COMPUTES GREENWICH HOUR ANGLE AND DECLINATION OF SUN */
/* $ JDAY = (I) INPUT SATELLITE/YEAR/DAY */
/* $ JTIME = (I) INPUT HOUR/MINUTE/SECOND */
/* $ GHA = (R) OUTPUT GREENWICH HOUR ANGLE */
/* $ DEC = (R) OUTPUT DECLINATION */
/* $ XLAT = (R) OUTPUT LATITUDE OF SUN POSITION */
/* $ XLON = (R) OUTPUT LONGITUDE OF SUN POSITION */
/* $$ SOLARP = COMPUTATION, NAVIGATION */
/* ORBITAL CONSTANTS */
/* IEPYD = EPOCH YEAR-DAY */
/* IEPHMS = EPOCH HOUR-MINUTE-SECOND */
/* OECCEN = ECCENTRICITY OF EARTH ORBIT */
/* OINCLI = INCLINATION TO CELESTIAL EQUATOR */
/* PERHEL = PERIHELION */
/* ASNODE = ASCENDING NODE */
/* XMANOM = MEAN ANOMOLY */
/* XMMC = MEAN MOTION CONSTANT */
/* SHA = CELESTIAL HOUR ANGLE */
/* IRAYD = YYDDD WHEN CELESTIAL COOR. SYS. COINCIDES WITH EARTH COO */
/* IRAHMS = HHMMSS WHEN CELESTIAL COOR. SYS. COINCIDES WITH EARTH COO */
/* REAL*8 DABS,DMOD,DSQRT,DSIN,DCOS,DATAN2 */
if (init != 0) {
goto L1;
}
init = 1;
pi = 3.14159265f;
rdpdg = pi / 180.f;
solsid = 1.00273791f;
iepyd = 74004;
iephms = 0;
oeccen = .016722f;
oincli = rdpdg * flalo_(&c_b3);
perhel = rdpdg * flalo_(&c_b4) + pi;
asnode = rdpdg * flalo_(&c__0);
xmmc = 1.1945902048611111e-5f;
sha = 100.26467f;
irayd = 74001;
irahms = 0;
sinc = sin(oincli);
cinc = cos(oincli);
sper = sin(perhel);
cper = cos(perhel);
sand = sin(asnode);
cand = cos(asnode);
px = cper * cand - sper * sand * cinc;
py = cper * sand + sper * cand * cinc;
pz = sper * sinc;
qx = -sper * cand - cper * sand * cinc;
qy = -sper * sand + cper * cand * cinc;
qz = cper * sinc;
L1:
iday = *jday % 100000;
ptime = ftime_(jtime);
diftim = timdif_(&iepyd, &iephms, &iday, jtime);
xmanom = xmmc * diftim;
ecanm1 = xmanom;
epsiln = 1e-8f;
for (i__ = 1; i__ <= 20; ++i__) {
ecanom = xmanom + oeccen * sin(ecanm1);
if ((d__1 = ecanom - ecanm1, abs(d__1)) < epsiln) {
goto L3;
}
/* L2: */
ecanm1 = ecanom;
}
L3:
xomega = cos(ecanom) - oeccen;
/* Computing 2nd power */
r__1 = oeccen;
yomega = sqrt(1.f - r__1 * r__1) * sin(ecanom);
/* Computing 2nd power */
r__1 = xomega;
/* Computing 2nd power */
r__2 = yomega;
xfact = 1.f / sqrt(r__1 * r__1 + r__2 * r__2);
xomega *= xfact;
yomega *= xfact;
xs = xomega * px + yomega * qx;
ys = xomega * py + yomega * qy;
zs = xomega * pz + yomega * qz;
slra = atan2(ys, xs) / rdpdg;
raha = timdif_(&irayd, &irahms, &iday, jtime) * solsid / 4.f;
*gha = ptime * 15.f;
xha = 360.f - sha - raha + slra + *gha;
*gha = d_mod(&xha, &c_b8);
*gha = 360.f - *gha - 2.f;
/* Computing 2nd power */
r__1 = xs;
/* Computing 2nd power */
r__2 = ys;
*dec = atan2(zs, sqrt(r__1 * r__1 + r__2 * r__2)) / rdpdg;
r__1 = *dec * rdpdg;
*xlat = geolat_(&r__1, &c__1) / rdpdg;
*xlon = -(*gha) - ptime * 15.f + 720.f;
*xlon = r_mod(xlon, &c_b10);
return 0;
} /* solarp_ */
ConstitutiveModelParameters<EvalT, Traits>::
ConstitutiveModelParameters(Teuchos::ParameterList& p,
const Teuchos::RCP<Albany::Layouts>& dl) :
have_temperature_(false),
dl_(dl)
{
// get number of integration points and spatial dimensions
std::vector<PHX::DataLayout::size_type> dims;
dl_->qp_vector->dimensions(dims);
num_pts_ = dims[1];
num_dims_ = dims[2];
// get the Parameter Library
Teuchos::RCP<ParamLib> paramLib =
p.get<Teuchos::RCP<ParamLib> >("Parameter Library", Teuchos::null);
// get the material parameter list
Teuchos::ParameterList* mat_params =
p.get<Teuchos::ParameterList*>("Material Parameters");
// Check for optional field: temperature
if (p.isType<std::string>("Temperature Name")) {
have_temperature_ = true;
PHX::MDField<ScalarT, Cell, QuadPoint>
tmp(p.get<std::string>("Temperature Name"), dl_->qp_scalar);
temperature_ = tmp;
this->addDependentField(temperature_);
}
// step through the possible parameters, registering as necessary
//
// elastic modulus
std::string e_mod("Elastic Modulus");
if (mat_params->isSublist(e_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(e_mod, dl_->qp_scalar);
elastic_mod_ = tmp;
field_map_.insert(std::make_pair(e_mod, elastic_mod_));
parseParameters(e_mod, p, paramLib);
}
// Poisson's ratio
std::string pr("Poissons Ratio");
if (mat_params->isSublist(pr)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(pr, dl_->qp_scalar);
poissons_ratio_ = tmp;
field_map_.insert(std::make_pair(pr, poissons_ratio_));
parseParameters(pr, p, paramLib);
}
// bulk modulus
std::string b_mod("Bulk Modulus");
if (mat_params->isSublist(b_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(b_mod, dl_->qp_scalar);
bulk_mod_ = tmp;
field_map_.insert(std::make_pair(b_mod, bulk_mod_));
parseParameters(b_mod, p, paramLib);
}
// shear modulus
std::string s_mod("Shear Modulus");
if (mat_params->isSublist(s_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(s_mod, dl_->qp_scalar);
shear_mod_ = tmp;
field_map_.insert(std::make_pair(s_mod, shear_mod_));
parseParameters(s_mod, p, paramLib);
}
// yield strength
std::string yield("Yield Strength");
if (mat_params->isSublist(yield)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(yield, dl_->qp_scalar);
yield_strength_ = tmp;
field_map_.insert(std::make_pair(yield, yield_strength_));
parseParameters(yield, p, paramLib);
}
// hardening modulus
std::string h_mod("Hardening Modulus");
if (mat_params->isSublist(h_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(h_mod, dl_->qp_scalar);
hardening_mod_ = tmp;
field_map_.insert(std::make_pair(h_mod, hardening_mod_));
parseParameters(h_mod, p, paramLib);
}
// recovery modulus
std::string r_mod("Recovery Modulus");
if (mat_params->isSublist(r_mod)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(r_mod, dl_->qp_scalar);
recovery_mod_ = tmp;
field_map_.insert(std::make_pair(r_mod, recovery_mod_));
parseParameters(r_mod, p, paramLib);
}
// concentration equilibrium parameter
std::string c_eq("Concentration Equilibrium Parameter");
if (mat_params->isSublist(c_eq)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(c_eq, dl_->qp_scalar);
conc_eq_param_ = tmp;
field_map_.insert(std::make_pair(c_eq, conc_eq_param_));
parseParameters(c_eq, p, paramLib);
}
// diffusion coefficient
std::string d_coeff("Diffusion Coefficient");
if (mat_params->isSublist(d_coeff)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(d_coeff, dl_->qp_scalar);
diff_coeff_ = tmp;
field_map_.insert(std::make_pair(d_coeff, diff_coeff_));
parseParameters(d_coeff, p, paramLib);
}
// thermal conductivity
std::string th_cond("Thermal Conductivity");
if (mat_params->isSublist(th_cond)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(th_cond, dl_->qp_scalar);
thermal_cond_ = tmp;
field_map_.insert(std::make_pair(th_cond, thermal_cond_));
parseParameters(th_cond, p, paramLib);
}
// flow rule coefficient
std::string f_coeff("Flow Rule Coefficient");
if (mat_params->isSublist(f_coeff)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(f_coeff, dl_->qp_scalar);
flow_coeff_ = tmp;
field_map_.insert(std::make_pair(f_coeff, flow_coeff_));
parseParameters(f_coeff, p, paramLib);
}
// flow rule exponent
std::string f_exp("Flow Rule Exponent");
if (mat_params->isSublist(f_exp)) {
PHX::MDField<ScalarT, Cell, QuadPoint> tmp(f_exp, dl_->qp_scalar);
flow_exp_ = tmp;
field_map_.insert(std::make_pair(f_exp, flow_exp_));
parseParameters(f_exp, p, paramLib);
}
// register evaluated fields
typename
std::map<std::string, PHX::MDField<ScalarT, Cell, QuadPoint> >::iterator it;
for (it = field_map_.begin();
it != field_map_.end();
++it) {
this->addEvaluatedField(it->second);
}
this->setName(
"Constitutive Model Parameters" + PHX::TypeString<EvalT>::value);
}
/* DECK RC6J */
/* Subroutine */ int rc6j_(real *l2, real *l3, real *l4, real *l5, real *l6,
real *l1min, real *l1max, real *sixcof, integer *ndim, integer *ier)
{
/* Initialized data */
static real zero = 0.f;
static real eps = .01f;
static real one = 1.f;
static real two = 2.f;
static real three = 3.f;
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4;
/* Local variables */
static integer i__, n;
static real x, y, a1, a2, c1, c2, l1, x1, x2, x3, y1, y2, y3, dv, a1s,
a2s, sum1, sum2, huge__;
static integer nfin, nlim;
static real tiny, c1old, sign1, sign2, denom;
static integer index;
static real cnorm, ratio;
static integer lstep;
extern doublereal r1mach_(integer *);
static integer nfinp1, nfinp2, nfinp3, nstep2;
static real oldfac, newfac, sumbac, srhuge, thresh;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static real sumfor, sumuni, srtiny;
/* ***BEGIN PROLOGUE RC6J */
/* ***PURPOSE Evaluate the 6j symbol h(L1) = {L1 L2 L3} */
/* {L4 L5 L6} */
/* for all allowed values of L1, the other parameters */
/* being held fixed. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C19 */
/* ***TYPE SINGLE PRECISION (RC6J-S, DRC6J-D) */
/* ***KEYWORDS 6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, */
/* RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, */
/* WIGNER COEFFICIENTS */
/* ***AUTHOR Gordon, R. G., Harvard University */
/* Schulten, K., Max Planck Institute */
/* ***DESCRIPTION */
/* *Usage: */
/* REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) */
/* INTEGER NDIM, IER */
/* CALL RC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER) */
/* *Arguments: */
/* L2 :IN Parameter in 6j symbol. */
/* L3 :IN Parameter in 6j symbol. */
/* L4 :IN Parameter in 6j symbol. */
/* L5 :IN Parameter in 6j symbol. */
/* L6 :IN Parameter in 6j symbol. */
/* L1MIN :OUT Smallest allowable L1 in 6j symbol. */
/* L1MAX :OUT Largest allowable L1 in 6j symbol. */
/* SIXCOF :OUT Set of 6j coefficients generated by evaluating the */
/* 6j symbol for all allowed values of L1. SIXCOF(I) */
/* will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1. */
/* NDIM :IN Declared length of SIXCOF in calling program. */
/* IER :OUT Error flag. */
/* IER=0 No errors. */
/* IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer. */
/* IER=2 L4, L2, L6 triangular condition not satisfied. */
/* IER=3 L4, L5, L3 triangular condition not satisfied. */
/* IER=4 L1MAX-L1MIN not an integer. */
/* IER=5 L1MAX less than L1MIN. */
/* IER=6 NDIM less than L1MAX-L1MIN+1. */
/* *Description: */
/* The definition and properties of 6j symbols can be found, for */
/* example, in Appendix C of Volume II of A. Messiah. Although the */
/* parameters of the vector addition coefficients satisfy certain */
/* conventional restrictions, the restriction that they be non-negative */
/* integers or non-negative integers plus 1/2 is not imposed on input */
/* to this subroutine. The restrictions imposed are */
/* 1. L2+L3+L5+L6 and L2+L4+L6 must be integers; */
/* 2. ABS(L2-L4).LE.L6.LE.L2+L4 must be satisfied; */
/* 3. ABS(L4-L5).LE.L3.LE.L4+L5 must be satisfied; */
/* 4. L1MAX-L1MIN must be a non-negative integer, where */
/* L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)). */
/* If all the conventional restrictions are satisfied, then these */
/* restrictions are met. Conversely, if input to this subroutine meets */
/* all of these restrictions and the conventional restriction stated */
/* above, then all the conventional restrictions are satisfied. */
/* The user should be cautious in using input parameters that do */
/* not satisfy the conventional restrictions. For example, the */
/* the subroutine produces values of */
/* h(L1) = { L1 2/3 1 } */
/* {2/3 2/3 2/3} */
/* for L1=1/3 and 4/3 but none of the symmetry properties of the 6j */
/* symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied. */
/* The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX) */
/* where L1MIN and L1MAX are defined above. The sequence h(L1) is */
/* generated by a three-term recurrence algorithm with scaling to */
/* control overflow. Both backward and forward recurrence are used to */
/* maintain numerical stability. The two recurrence sequences are */
/* matched at an interior point and are normalized from the unitary */
/* property of 6j coefficients and Wigner's phase convention. */
/* The algorithm is suited to applications in which large quantum */
/* numbers arise, such as in molecular dynamics. */
/* ***REFERENCES 1. Messiah, Albert., Quantum Mechanics, Volume II, */
/* North-Holland Publishing Company, 1963. */
/* 2. Schulten, Klaus and Gordon, Roy G., Exact recursive */
/* evaluation of 3j and 6j coefficients for quantum- */
/* mechanical coupling of angular momenta, J Math */
/* Phys, v 16, no. 10, October 1975, pp. 1961-1970. */
/* 3. Schulten, Klaus and Gordon, Roy G., Semiclassical */
/* approximations to 3j and 6j coefficients for */
/* quantum-mechanical coupling of angular momenta, */
/* J Math Phys, v 16, no. 10, October 1975, */
/* pp. 1971-1988. */
/* 4. Schulten, Klaus and Gordon, Roy G., Recursive */
/* evaluation of 3j and 6j coefficients, Computer */
/* Phys Comm, v 11, 1976, pp. 269-278. */
/* ***ROUTINES CALLED R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 750101 DATE WRITTEN */
/* 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters */
/* HUGE and TINY revised to depend on R1MACH. */
/* 891229 Prologue description rewritten; other prologue sections */
/* revised; LMATCH (location of match point for recurrences) */
/* removed from argument list; argument IER changed to serve */
/* only as an error flag (previously, in cases without error, */
/* it returned the number of scalings); number of error codes */
/* increased to provide more precise error information; */
/* program comments revised; SLATEC error handler calls */
/* introduced to enable printing of error messages to meet */
/* SLATEC standards. These changes were done by D. W. Lozier, */
/* M. A. McClain and J. M. Smith of the National Institute */
/* of Standards and Technology, formerly NBS. */
/* 910415 Mixed type expressions eliminated; variable C1 initialized; */
/* description of SIXCOF expanded. These changes were done by */
/* D. W. Lozier. */
/* ***END PROLOGUE RC6J */
/* Parameter adjustments */
--sixcof;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT RC6J */
*ier = 0;
/* HUGE is the square root of one twentieth of the largest floating */
/* point number, approximately. */
huge__ = sqrt(r1mach_(&c__2) / 20.f);
srhuge = sqrt(huge__);
tiny = 1.f / huge__;
srtiny = 1.f / srhuge;
/* LMATCH = ZERO */
/* Check error conditions 1, 2, and 3. */
r__1 = *l2 + *l3 + *l5 + *l6 + eps;
r__2 = *l4 + *l2 + *l6 + eps;
if (r_mod(&r__1, &one) >= eps + eps || r_mod(&r__2, &one) >= eps + eps) {
*ier = 1;
xermsg_("SLATEC", "RC6J", "L2+L3+L5+L6 or L4+L2+L6 not integer.", ier,
&c__1, (ftnlen)6, (ftnlen)4, (ftnlen)36);
return 0;
} else if (*l4 + *l2 - *l6 < zero || *l4 - *l2 + *l6 < zero || -(*l4) + *
l2 + *l6 < zero) {
*ier = 2;
xermsg_("SLATEC", "RC6J", "L4, L2, L6 triangular condition not satis"
"fied.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)46);
return 0;
} else if (*l4 - *l5 + *l3 < zero || *l4 + *l5 - *l3 < zero || -(*l4) + *
l5 + *l3 < zero) {
*ier = 3;
xermsg_("SLATEC", "RC6J", "L4, L5, L3 triangular condition not satis"
"fied.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)46);
return 0;
}
/* Limits for L1 */
/* Computing MAX */
r__3 = (r__1 = *l2 - *l3, dabs(r__1)), r__4 = (r__2 = *l5 - *l6, dabs(
r__2));
*l1min = dmax(r__3,r__4);
/* Computing MIN */
r__1 = *l2 + *l3, r__2 = *l5 + *l6;
*l1max = dmin(r__1,r__2);
/* Check error condition 4. */
r__1 = *l1max - *l1min + eps;
if (r_mod(&r__1, &one) >= eps + eps) {
*ier = 4;
xermsg_("SLATEC", "RC6J", "L1MAX-L1MIN not integer.", ier, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)24);
return 0;
}
if (*l1min < *l1max - eps) {
goto L20;
}
if (*l1min < *l1max + eps) {
goto L10;
}
/* Check error condition 5. */
*ier = 5;
xermsg_("SLATEC", "RC6J", "L1MIN greater than L1MAX.", ier, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)25);
return 0;
/* This is reached in case that L1 can take only one value */
L10:
/* LSCALE = 0 */
r__1 = -one;
i__1 = (integer) (*l2 + *l3 + *l5 + *l6 + eps);
sixcof[1] = pow_ri(&r__1, &i__1) / sqrt((*l1min + *l1min + one) * (*l4 + *
l4 + one));
return 0;
/* This is reached in case that L1 can take more than one value. */
L20:
/* LSCALE = 0 */
nfin = (integer) (*l1max - *l1min + one + eps);
if (*ndim - nfin >= 0) {
goto L23;
} else {
goto L21;
}
/* Check error condition 6. */
L21:
*ier = 6;
xermsg_("SLATEC", "RC6J", "Dimension of result array for 6j coefficients"
" too small.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)56);
return 0;
/* Start of forward recursion */
L23:
l1 = *l1min;
newfac = 0.f;
c1 = 0.f;
sixcof[1] = srtiny;
sum1 = (l1 + l1 + one) * tiny;
lstep = 1;
L30:
++lstep;
l1 += one;
oldfac = newfac;
a1 = (l1 + *l2 + *l3 + one) * (l1 - *l2 + *l3) * (l1 + *l2 - *l3) * (-l1
+ *l2 + *l3 + one);
a2 = (l1 + *l5 + *l6 + one) * (l1 - *l5 + *l6) * (l1 + *l5 - *l6) * (-l1
+ *l5 + *l6 + one);
newfac = sqrt(a1 * a2);
if (l1 < one + eps) {
goto L40;
}
dv = two * (*l2 * (*l2 + one) * *l5 * (*l5 + one) + *l3 * (*l3 + one) * *
l6 * (*l6 + one) - l1 * (l1 - one) * *l4 * (*l4 + one)) - (*l2 * (
*l2 + one) + *l3 * (*l3 + one) - l1 * (l1 - one)) * (*l5 * (*l5 +
one) + *l6 * (*l6 + one) - l1 * (l1 - one));
denom = (l1 - one) * newfac;
if (lstep - 2 <= 0) {
goto L32;
} else {
goto L31;
}
L31:
c1old = dabs(c1);
L32:
c1 = -(l1 + l1 - one) * dv / denom;
goto L50;
/* If L1 = 1, (L1 - 1) has to be factored out of DV, hence */
L40:
c1 = -two * (*l2 * (*l2 + one) + *l5 * (*l5 + one) - *l4 * (*l4 + one)) /
newfac;
L50:
if (lstep > 2) {
goto L60;
}
/* If L1 = L1MIN + 1, the third term in recursion equation vanishes */
x = srtiny * c1;
sixcof[2] = x;
sum1 += tiny * (l1 + l1 + one) * c1 * c1;
if (lstep == nfin) {
goto L220;
}
goto L30;
L60:
c2 = -l1 * oldfac / denom;
/* Recursion to the next 6j coefficient X */
x = c1 * sixcof[lstep - 1] + c2 * sixcof[lstep - 2];
sixcof[lstep] = x;
sumfor = sum1;
sum1 += (l1 + l1 + one) * x * x;
if (lstep == nfin) {
goto L100;
}
/* See if last unnormalized 6j coefficient exceeds SRHUGE */
if (dabs(x) < srhuge) {
goto L80;
}
/* This is reached if last 6j coefficient larger than SRHUGE, */
/* so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP) */
/* has to be rescaled to prevent overflow */
/* LSCALE = LSCALE + 1 */
i__1 = lstep;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = sixcof[i__], dabs(r__1)) < srtiny) {
sixcof[i__] = zero;
}
/* L70: */
sixcof[i__] /= srhuge;
}
sum1 /= huge__;
sumfor /= huge__;
x /= srhuge;
/* As long as the coefficient ABS(C1) is decreasing, the recursion */
/* proceeds towards increasing 6j values and, hence, is numerically */
/* stable. Once an increase of ABS(C1) is detected, the recursion */
/* direction is reversed. */
L80:
if (c1old - dabs(c1) <= 0.f) {
goto L100;
} else {
goto L30;
}
/* Keep three 6j coefficients around LMATCH for comparison later */
/* with backward recursion. */
L100:
/* LMATCH = L1 - 1 */
x1 = x;
x2 = sixcof[lstep - 1];
x3 = sixcof[lstep - 2];
/* Starting backward recursion from L1MAX taking NSTEP2 steps, so */
/* that forward and backward recursion overlap at the three points */
/* L1 = LMATCH+1, LMATCH, LMATCH-1. */
nfinp1 = nfin + 1;
nfinp2 = nfin + 2;
nfinp3 = nfin + 3;
nstep2 = nfin - lstep + 3;
l1 = *l1max;
sixcof[nfin] = srtiny;
sum2 = (l1 + l1 + one) * tiny;
l1 += two;
lstep = 1;
L110:
++lstep;
l1 -= one;
oldfac = newfac;
a1s = (l1 + *l2 + *l3) * (l1 - *l2 + *l3 - one) * (l1 + *l2 - *l3 - one) *
(-l1 + *l2 + *l3 + two);
a2s = (l1 + *l5 + *l6) * (l1 - *l5 + *l6 - one) * (l1 + *l5 - *l6 - one) *
(-l1 + *l5 + *l6 + two);
newfac = sqrt(a1s * a2s);
dv = two * (*l2 * (*l2 + one) * *l5 * (*l5 + one) + *l3 * (*l3 + one) * *
l6 * (*l6 + one) - l1 * (l1 - one) * *l4 * (*l4 + one)) - (*l2 * (
*l2 + one) + *l3 * (*l3 + one) - l1 * (l1 - one)) * (*l5 * (*l5 +
one) + *l6 * (*l6 + one) - l1 * (l1 - one));
denom = l1 * newfac;
c1 = -(l1 + l1 - one) * dv / denom;
if (lstep > 2) {
goto L120;
}
/* If L1 = L1MAX + 1 the third term in the recursion equation vanishes */
y = srtiny * c1;
sixcof[nfin - 1] = y;
if (lstep == nstep2) {
goto L200;
}
sumbac = sum2;
sum2 += (l1 + l1 - three) * c1 * c1 * tiny;
goto L110;
L120:
c2 = -(l1 - one) * oldfac / denom;
/* Recursion to the next 6j coefficient Y */
y = c1 * sixcof[nfinp2 - lstep] + c2 * sixcof[nfinp3 - lstep];
if (lstep == nstep2) {
goto L200;
}
sixcof[nfinp1 - lstep] = y;
sumbac = sum2;
sum2 += (l1 + l1 - three) * y * y;
/* See if last unnormalized 6j coefficient exceeds SRHUGE */
if (dabs(y) < srhuge) {
goto L110;
}
/* This is reached if last 6j coefficient larger than SRHUGE, */
/* so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1) */
/* has to be rescaled to prevent overflow */
/* LSCALE = LSCALE + 1 */
i__1 = lstep;
for (i__ = 1; i__ <= i__1; ++i__) {
index = nfin - i__ + 1;
if ((r__1 = sixcof[index], dabs(r__1)) < srtiny) {
sixcof[index] = zero;
}
/* L130: */
sixcof[index] /= srhuge;
}
sumbac /= huge__;
sum2 /= huge__;
goto L110;
/* The forward recursion 6j coefficients X1, X2, X3 are to be matched */
/* with the corresponding backward recursion values Y1, Y2, Y3. */
L200:
y3 = y;
y2 = sixcof[nfinp2 - lstep];
y1 = sixcof[nfinp3 - lstep];
/* Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds */
/* with minimal error. */
ratio = (x1 * y1 + x2 * y2 + x3 * y3) / (x1 * x1 + x2 * x2 + x3 * x3);
nlim = nfin - nstep2 + 1;
if (dabs(ratio) < one) {
goto L211;
}
i__1 = nlim;
for (n = 1; n <= i__1; ++n) {
/* L210: */
sixcof[n] = ratio * sixcof[n];
}
sumuni = ratio * ratio * sumfor + sumbac;
goto L230;
L211:
++nlim;
ratio = one / ratio;
i__1 = nfin;
for (n = nlim; n <= i__1; ++n) {
/* L212: */
sixcof[n] = ratio * sixcof[n];
}
sumuni = sumfor + ratio * ratio * sumbac;
goto L230;
L220:
sumuni = sum1;
/* Normalize 6j coefficients */
L230:
cnorm = one / sqrt((*l4 + *l4 + one) * sumuni);
/* Sign convention for last 6j coefficient determines overall phase */
sign1 = r_sign(&one, &sixcof[nfin]);
r__1 = -one;
i__1 = (integer) (*l2 + *l3 + *l5 + *l6 + eps);
sign2 = pow_ri(&r__1, &i__1);
if (sign1 * sign2 <= 0.f) {
goto L235;
} else {
goto L236;
}
L235:
cnorm = -cnorm;
L236:
if (dabs(cnorm) < one) {
goto L250;
}
i__1 = nfin;
for (n = 1; n <= i__1; ++n) {
/* L240: */
sixcof[n] = cnorm * sixcof[n];
}
return 0;
L250:
thresh = tiny / dabs(cnorm);
i__1 = nfin;
for (n = 1; n <= i__1; ++n) {
if ((r__1 = sixcof[n], dabs(r__1)) < thresh) {
sixcof[n] = zero;
}
/* L251: */
sixcof[n] = cnorm * sixcof[n];
}
return 0;
} /* rc6j_ */
