typedef long int integer; typedef unsigned long uinteger; typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; typedef long int logical; typedef short int shortlogical; typedef char logical1; typedef char integer1; typedef long int flag; typedef long int ftnlen; typedef long int ftnint; typedef struct { flag cierr; ftnint ciunit; flag ciend; char *cifmt; ftnint cirec; } cilist; typedef struct { flag icierr; char *iciunit; flag iciend; char *icifmt; ftnint icirlen; ftnint icirnum; } icilist; typedef struct { flag oerr; ftnint ounit; char *ofnm; ftnlen ofnmlen; char *osta; char *oacc; char *ofm; ftnint orl; char *oblnk; } olist; typedef struct { flag cerr; ftnint cunit; char *csta; } cllist; typedef struct { flag aerr; ftnint aunit; } alist; typedef struct { flag inerr; ftnint inunit; char *infile; ftnlen infilen; ftnint *inex; ftnint *inopen; ftnint *innum; ftnint *innamed; char *inname; ftnlen innamlen; char *inacc; ftnlen inacclen; char *inseq; ftnlen inseqlen; char *indir; ftnlen indirlen; char *infmt; ftnlen infmtlen; char *inform; ftnint informlen; char *inunf; ftnlen inunflen; ftnint *inrecl; ftnint *innrec; char *inblank; ftnlen inblanklen; } inlist; union Multitype { integer1 g; shortint h; integer i; real r; doublereal d; complex c; doublecomplex z; }; typedef union Multitype Multitype; struct Vardesc { char *name; char *addr; ftnlen *dims; int type; }; typedef struct Vardesc Vardesc; struct Namelist { char *name; Vardesc **vars; int nvars; }; typedef struct Namelist Namelist; typedef int (*U_fp)(); typedef shortint (*J_fp)(); typedef integer (*I_fp)(); typedef real (*R_fp)(); typedef doublereal (*D_fp)(), (*E_fp)(); typedef void (*C_fp)(); typedef void (*Z_fp)(); typedef logical (*L_fp)(); typedef shortlogical (*K_fp)(); typedef void (*H_fp)(); typedef int (*S_fp)(); typedef void C_f; typedef void H_f; typedef void Z_f; typedef doublereal E_f; struct { integer iero; } ierode_; struct { doublereal precis; integer iout, iprint; } colout_; struct { doublereal rho[7], coef[49]; } colloc_; union { struct { integer k, nc, mstar, kd, mmax, mt[20]; } _1; struct { integer k, ncomp, mstar, kd, mmax, m[20]; } _2; struct { integer k, ncomp, id1, id2, mmax, m[20]; } _3; struct { integer kdum, ncomp, mstar, kd, mmax, m[20]; } _4; struct { integer kdum, ndum, mstar, kd, mmax, m[20]; } _5; struct { integer k, ncdum, mstar, kdum, mmax, m[20]; } _6; struct { integer k, ncomp, mstar, kdum, mmax, m[20]; } _7; } colord_; struct { integer n, nold, nmax, nz, ndmz; } colapr_; struct { integer mshflg, mshnum, mshlmt, mshalt; } colmsh_; union { struct { doublereal tzeta[40], tleft, tright; integer izeta, idum; } _1; struct { doublereal zeta[40], aleft, aright; integer izeta, idum; } _2; struct { doublereal zeta[40], aleft, aright; integer izeta, izsave; } _3; } colsid_; struct { integer nonlin, iter, limit, icare, iguess; } colnln_; union { struct { doublereal ttl[40], wgtmsh[40], wgterr[40], tolin[40], root[40]; integer jtol[40], lttol[40], ntol; } _1; struct { doublereal tol[40], wgtmsh[40], wgterr[40], tolin[40], root[40]; integer jtol[40], ltol[40], ntol; } _2; } colest_; struct { integer iero; } iercol_; struct { doublereal b[28], acol[196] , asave[112] ; } colbas_; struct { integer nunit, iunit[5]; } xeruni_; struct { integer iero; } ierajf_; struct { integer jupbnd; } dqa001_; union { struct { doublereal rownd, rowns[209], ccmax, el0, h__, hmin, hmxi, hu, rc, tn, uround; integer iownd[14], iowns[6], icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu; } _1; struct { doublereal tret, rowns[209], ccmax, el0, h__, hmin, hmxi, hu, rc, tn, uround; integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns[6], icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu; } _2; struct { doublereal tret, rowns[209], ccmax, el0, h__, hmin, hmxi, hu, rc, tn, uround; integer illin, init, lyh, lewt, lacor, lsavr, lwm, liwm, mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns[6], icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, msbp, mxncf, n, nq, nst, nre, nje, nqu; } _3; struct { doublereal rownd, rowns[209], ccmax, el0, h__, hmin, hmxi, hu, rc, tn, uround; integer iownd[14], iowns[6], icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, msbp, mxncf, n, nq, nst, nre, nje, nqu; } _4; struct { doublereal rls[219]; integer ils[39]; } _5; struct { doublereal rownd, conit, crate, el[13], elco[156] , hold, rmax, tesco[36] , ccmax, el0, h__, hmin, hmxi, hu, rc, tn, uround; integer iownd[14], ialth, ipup, lmax, meo, nqnyh, nslp, icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu; } _6; struct { doublereal rownd, conit, crate, el[13], elco[156] , hold, rmax, tesco[36] , ccmax, el0, h__, hmin, hmxi, hu, rc, tn, uround; integer iownd[14], ialth, ipup, lmax, meo, nqnyh, nslp, icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, msbp, mxncf, n, nq, nst, nre, nje, nqu; } _7; } ls0001_; struct { doublereal stk[2000000]; } stack_; struct { integer bot, top, idstk[3000] , lstk[500], leps, bbot, bot0; } vstk_; struct { integer ids[1536] , pstk[256], rstk[256], pt, niv, macr, paus, icall; } recu_; struct { integer ddt, err, lct[8], lin[8192], lpt[6], hio, rio, wio, rte, wte; } iop_; struct { integer err1, err2, errct, toperr; } errgst_; struct { integer sym, syn[6], char1, fin, fun, lhs, rhs, ran[2], comp[2]; } com_; struct { char alfa[63], alfb[63], buf[4096]; } cha1_; struct { integer nlink; } link1_; struct { char tablin[1000]; } link2_; struct { integer wmac, lcntr, nmacs, macnms[120] , lgptrs[21], bptlg[100]; } dbg_; union { struct { doublereal tsw, rowns2[20], pdnorm; integer insufr, insufi, ixpr, iowns2[2], jtyp, mused, mxordn, mxords; } _1; struct { doublereal rownd2, rowns2[20], pdnorm; integer iownd2[3], iowns2[2], jtyp, mused, mxordn, mxords; } _2; struct { doublereal rlsa[22]; integer ilsa[9]; } _3; struct { doublereal rownd2, pdest, pdlast, ratio, cm1[12], cm2[5], pdnorm; integer iownd2[3], icount, irflag, jtyp, mused, mxordn, mxords; } _4; } lsa001_; union { struct { doublereal rownr3[2], t0, tlast, toutc; integer lg0, lg1, lgx, iownr3[2], irfnd, itaskc, ngc, nge; } _1; struct { doublereal rownr3[2], t0, tlast, toutc; integer iownd3[3], iownr3[2], irfnd, itaskc, ngc, nge; } _2; struct { doublereal alpha, x2, rdum3[3]; integer iownd3[3], imax, last, idum3[4]; } _3; struct { doublereal rlsr[5]; integer ilsr[9]; } _4; } lsr001_; struct { integer kmax, kount; doublereal dxsav, xp[200], yp[2000] ; } path_; union { struct { integer ieh[2]; } _1; struct { integer mesflg, lunit; } _2; } eh0001_; struct { doublereal u1; integer nc; } fprf2c_; union { struct { doublereal t0, tf, dti, dtf, ermx; integer iu[5], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu; } _1; struct { doublereal t00, tf0, dti0, dtf0, ermx0; integer iu0[5], nuc0, nuv0, ilin0, nti0, ntf0, ny0, nea0, itmx0, nex0, nob0, ntob0, ntobi0, nitu0, ndtu0; } _2; } icsez_; union { struct { integer nitv, nrtv, ndtv; } _1; struct { integer nitv0, nrtv0, ndtv0; } _2; } nird_; static integer c__1 = 1; static integer c_n1 = -1; static integer c__3 = 3; static integer c__2 = 2; static doublereal c_b61 = 0.; static integer c__0 = 0; static doublereal c_b89 = 1.; static doublereal c_b418 = -1.; static doublereal c_b806 = .5; static integer c__65 = 65; static integer c__4 = 4; static doublereal c_b1934 = .16666666666666666; static doublereal c_b1936 = .33333333333333331; static doublereal c_b1938 = .66666666666666663; static doublereal c_b1940 = .83333333333333337; static integer c_n998 = -998; static integer c__5 = 5; static integer c__6 = 6; static integer c__7 = 7; static integer c__8 = 8; static integer c__9 = 9; static integer c__10 = 10; static integer c__11 = 11; static integer c__12 = 12; static integer c__13 = 13; static integer c__14 = 14; static integer c__15 = 15; static integer c__17 = 17; static integer c__18 = 18; static integer c__19 = 19; static integer c_n999 = -999; static integer c__72 = 72; static integer c__30 = 30; static integer c__51 = 51; static integer c__52 = 52; static integer c__60 = 60; static integer c__999 = 999; static integer c__103 = 103; static integer c__50 = 50; static integer c__104 = 104; static integer c__101 = 101; static integer c__102 = 102; static integer c__105 = 105; static integer c__106 = 106; static integer c__107 = 107; static integer c__301 = 301; static integer c__201 = 201; static integer c__202 = 202; static integer c__203 = 203; static integer c__204 = 204; static integer c__205 = 205; static integer c__206 = 206; static integer c__207 = 207; static integer c__40 = 40; static integer c__16 = 16; static integer c__20 = 20; static integer c__21 = 21; static integer c__22 = 22; static integer c__23 = 23; static integer c__24 = 24; static integer c__25 = 25; static integer c__26 = 26; static integer c__27 = 27; static integer c__28 = 28; static integer c__29 = 29; static integer c__302 = 302; static integer c__303 = 303; static integer c__31 = 31; static integer c__32 = 32; static integer c__208 = 208; static integer c__210 = 210; static doublereal c_b5310 = 1.5; static doublereal c_b5340 = 1e-4; static doublereal c_b5732 = .9; static doublereal c_b5779 = .75; static logical c_false = (0) ; static doublereal c_b7108 = .25; static integer c_n24 = -24; static integer c_n34 = -34; static doublereal c_b8137 = 10.; int dgelq2_(m, n, a, lda, tau, work, info) integer *m, *n; doublereal *a; integer *lda; doublereal *tau, *work; integer *info; { integer a_dim1, a_offset, i__1, i__2, i__3; static integer i__, k; extern int dlarf_(), dlarfg_(), xerbla_(); static doublereal aii; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("DGELQ2", &i__1, 6L); return 0; } k = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; i__1 = k; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n - i__ + 1; i__3 = i__ + 1; dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + (( i__3 ) <= ( *n ) ? ( i__3 ) : ( *n )) * a_dim1] , lda, &tau[i__]); if (i__ < *m) { aii = a[i__ + i__ * a_dim1]; a[i__ + i__ * a_dim1] = 1.; i__2 = *m - i__; i__3 = *n - i__ + 1; dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], 5L); a[i__ + i__ * a_dim1] = aii; } } return 0; } int dgelqf_(m, n, a, lda, tau, work, lwork, info) integer *m, *n; doublereal *a; integer *lda; doublereal *tau, *work; integer *lwork, *info; { integer a_dim1, a_offset, i__1, i__2, i__3, i__4; static integer i__, k, nbmin, iinfo; extern int dgelq2_(); static integer ib, nb; extern int dlarfb_(); static integer nx; extern int dlarft_(), xerbla_(); extern integer ilaenv_(); static integer ldwork, iws; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -4; } else if (*lwork < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("DGELQF", &i__1, 6L); return 0; } k = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; if (k == 0) { work[1] = 1.; return 0; } nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L); nbmin = 2; nx = 0; iws = *m; if (nb > 1 && nb < k) { i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L); nx = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; if (nx < k) { ldwork = *m; iws = ldwork * nb; if (*lwork < iws) { nb = *lwork / ldwork; i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, & c_n1, 6L, 1L); nbmin = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } } } if (nb >= nbmin && nb < k && nx < k) { i__1 = k - nx; i__2 = nb; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { i__3 = k - i__ + 1; ib = (( i__3 ) <= ( nb ) ? ( i__3 ) : ( nb )) ; i__3 = *n - i__ + 1; dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ 1], &iinfo); if (i__ + ib <= *m) { i__3 = *n - i__ + 1; dlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 7L); i__3 = *m - i__ - ib + 1; i__4 = *n - i__ + 1; dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + 1], &ldwork, 5L, 12L, 7L, 7L); } } } else { i__ = 1; } if (i__ <= k) { i__2 = *m - i__ + 1; i__1 = *n - i__ + 1; dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] , &iinfo); } work[1] = (doublereal) iws; return 0; } int dgels_(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info, trans_len) char *trans; integer *m, *n, *nrhs; doublereal *a; integer *lda; doublereal *b; integer *ldb; doublereal *work; integer *lwork, *info; ftnlen trans_len; { integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; static doublereal anrm, bnrm; static integer brow; static logical tpsd; static integer i__, j, iascl, ibscl; extern logical lsame_(); extern int dtrsm_(); static integer wsize; static doublereal rwork[1]; extern int dlabad_(); static integer nb; extern doublereal dlamch_(), dlange_(); static integer mn; extern int dgelqf_(), dlascl_(), dgeqrf_(), dlaset_(), xerbla_(); extern integer ilaenv_(); static integer scllen; static doublereal bignum; extern int dormlq_(), dormqr_(); static doublereal smlnum; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; b_dim1 = *ldb; b_offset = b_dim1 + 1; b -= b_offset; --work; *info = 0; mn = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; if (! (lsame_(trans, "N", 1L, 1L) || lsame_(trans, "T", 1L, 1L))) { *info = -1; } else if (*m < 0) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*nrhs < 0) { *info = -4; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -6; } else { i__1 = (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ; if (*ldb < (( i__1 ) >= ( *n ) ? ( i__1 ) : ( *n )) ) { *info = -8; } else { i__3 = (( *m ) >= ( *n ) ? ( *m ) : ( *n )) ; i__1 = 1, i__2 = mn + (( i__3 ) >= ( *nrhs ) ? ( i__3 ) : ( *nrhs )) ; if (*lwork < (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ) { *info = -10; } } } if (*info == 0 || *info == -10) { tpsd = (1) ; if (lsame_(trans, "N", 1L, 1L)) { tpsd = (0) ; } if (*m >= *n) { nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L); if (tpsd) { i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, & c_n1, 6L, 2L); nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } else { i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, & c_n1, 6L, 2L); nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } } else { nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L); if (tpsd) { i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, & c_n1, 6L, 2L); nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } else { i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, & c_n1, 6L, 2L); nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } } i__1 = (( *m ) >= ( *n ) ? ( *m ) : ( *n )) ; wsize = mn + (( i__1 ) >= ( *nrhs ) ? ( i__1 ) : ( *nrhs )) * nb; work[1] = (doublereal) wsize; } if (*info != 0) { i__1 = -(*info); xerbla_("DGELS ", &i__1, 6L); return 0; } i__1 = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; if ((( i__1 ) <= ( *nrhs ) ? ( i__1 ) : ( *nrhs )) == 0) { i__1 = (( *m ) >= ( *n ) ? ( *m ) : ( *n )) ; dlaset_("Full", &i__1, nrhs, &c_b61, &c_b61, &b[b_offset], ldb, 4L); return 0; } smlnum = dlamch_("S", 1L) / dlamch_("P", 1L); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); anrm = dlange_("M", m, n, &a[a_offset], lda, rwork, 1L); iascl = 0; if (anrm > 0. && anrm < smlnum) { dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info, 1L); iascl = 1; } else if (anrm > bignum) { dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info, 1L); iascl = 2; } else if (anrm == 0.) { i__1 = (( *m ) >= ( *n ) ? ( *m ) : ( *n )) ; dlaset_("F", &i__1, nrhs, &c_b61, &c_b61, &b[b_offset], ldb, 1L); goto L50; } brow = *m; if (tpsd) { brow = *n; } bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork, 1L); ibscl = 0; if (bnrm > 0. && bnrm < smlnum) { dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], ldb, info, 1L); ibscl = 1; } else if (bnrm > bignum) { dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], ldb, info, 1L); ibscl = 2; } if (*m >= *n) { i__1 = *lwork - mn; dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) ; if (! tpsd) { i__1 = *lwork - mn; dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[ 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info, 4L, 9L) ; dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, & c_b89, &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 8L); scllen = *n; } else { dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b89, &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 9L, 8L); i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = *n + 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = 0.; } } i__1 = *lwork - mn; dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, & work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info, 4L, 12L); scllen = *m; } } else { i__1 = *lwork - mn; dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) ; if (! tpsd) { dtrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, & c_b89, &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 8L); i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = *m + 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = 0.; } } i__1 = *lwork - mn; dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[ 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info, 4L, 9L) ; scllen = *n; } else { i__1 = *lwork - mn; dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, & work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info, 4L, 12L); dtrsm_("Left", "Lower", "Transpose", "Non-unit", m, nrhs, &c_b89, &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 9L, 8L); scllen = *m; } } if (iascl == 1) { dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset] , ldb, info, 1L); } else if (iascl == 2) { dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset] , ldb, info, 1L); } if (ibscl == 1) { dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset] , ldb, info, 1L); } else if (ibscl == 2) { dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset] , ldb, info, 1L); } L50: work[1] = (doublereal) wsize; return 0; } int dgemm_(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c__, ldc, transa_len, transb_len) char *transa, *transb; integer *m, *n, *k; doublereal *alpha, *a; integer *lda; doublereal *b; integer *ldb; doublereal *beta, *c__; integer *ldc; ftnlen transa_len; ftnlen transb_len; { integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3; static integer info; static logical nota, notb; static doublereal temp; static integer i__, j, l, ncola; extern logical lsame_(); static integer nrowa, nrowb; extern int xerbla_(); a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; b_dim1 = *ldb; b_offset = b_dim1 + 1; b -= b_offset; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; nota = lsame_(transa, "N", 1L, 1L); notb = lsame_(transb, "N", 1L, 1L); if (nota) { nrowa = *m; ncola = *k; } else { nrowa = *k; ncola = *m; } if (notb) { nrowb = *k; } else { nrowb = *n; } info = 0; if (! nota && ! lsame_(transa, "C", 1L, 1L) && ! lsame_(transa, "T", 1L, 1L)) { info = 1; } else if (! notb && ! lsame_(transb, "C", 1L, 1L) && ! lsame_(transb, "T", 1L, 1L)) { info = 2; } else if (*m < 0) { info = 3; } else if (*n < 0) { info = 4; } else if (*k < 0) { info = 5; } else if (*lda < (( 1 ) >= ( nrowa ) ? ( 1 ) : ( nrowa )) ) { info = 8; } else if (*ldb < (( 1 ) >= ( nrowb ) ? ( 1 ) : ( nrowb )) ) { info = 10; } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { info = 13; } if (info != 0) { xerbla_("DGEMM ", &info, 6L); return 0; } if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { return 0; } if (*alpha == 0.) { if (*beta == 0.) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + j * c_dim1] = 0.; } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; } } } return 0; } if (notb) { if (nota) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*beta == 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + j * c_dim1] = 0.; } } else if (*beta != 1.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; } } i__2 = *k; for (l = 1; l <= i__2; ++l) { if (b[l + j * b_dim1] != 0.) { temp = *alpha * b[l + j * b_dim1]; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; } } } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = 0.; i__3 = *k; for (l = 1; l <= i__3; ++l) { temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; } if (*beta == 0.) { c__[i__ + j * c_dim1] = *alpha * temp; } else { c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ i__ + j * c_dim1]; } } } } } else { if (nota) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*beta == 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + j * c_dim1] = 0.; } } else if (*beta != 1.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; } } i__2 = *k; for (l = 1; l <= i__2; ++l) { if (b[j + l * b_dim1] != 0.) { temp = *alpha * b[j + l * b_dim1]; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; } } } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = 0.; i__3 = *k; for (l = 1; l <= i__3; ++l) { temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; } if (*beta == 0.) { c__[i__ + j * c_dim1] = *alpha * temp; } else { c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ i__ + j * c_dim1]; } } } } } return 0; } int dgemv_(trans, m, n, alpha, a, lda, x, incx, beta, y, incy, trans_len) char *trans; integer *m, *n; doublereal *alpha, *a; integer *lda; doublereal *x; integer *incx; doublereal *beta, *y; integer *incy; ftnlen trans_len; { integer a_dim1, a_offset, i__1, i__2; static integer info; static doublereal temp; static integer lenx, leny, i__, j; extern logical lsame_(); static integer ix, iy, jx, jy, kx, ky; extern int xerbla_(); a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --x; --y; info = 0; if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L, 1L)) { info = 1; } else if (*m < 0) { info = 2; } else if (*n < 0) { info = 3; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { info = 6; } else if (*incx == 0) { info = 8; } else if (*incy == 0) { info = 11; } if (info != 0) { xerbla_("DGEMV ", &info, 6L); return 0; } if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { return 0; } if (lsame_(trans, "N", 1L, 1L)) { lenx = *n; leny = *m; } else { lenx = *m; leny = *n; } if (*incx > 0) { kx = 1; } else { kx = 1 - (lenx - 1) * *incx; } if (*incy > 0) { ky = 1; } else { ky = 1 - (leny - 1) * *incy; } if (*beta != 1.) { if (*incy == 1) { if (*beta == 0.) { i__1 = leny; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = 0.; } } else { i__1 = leny; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = *beta * y[i__]; } } } else { iy = ky; if (*beta == 0.) { i__1 = leny; for (i__ = 1; i__ <= i__1; ++i__) { y[iy] = 0.; iy += *incy; } } else { i__1 = leny; for (i__ = 1; i__ <= i__1; ++i__) { y[iy] = *beta * y[iy]; iy += *incy; } } } } if (*alpha == 0.) { return 0; } if (lsame_(trans, "N", 1L, 1L)) { jx = kx; if (*incy == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0.) { temp = *alpha * x[jx]; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] += temp * a[i__ + j * a_dim1]; } } jx += *incx; } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0.) { temp = *alpha * x[jx]; iy = ky; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { y[iy] += temp * a[i__ + j * a_dim1]; iy += *incy; } } jx += *incx; } } } else { jy = ky; if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = 0.; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp += a[i__ + j * a_dim1] * x[i__]; } y[jy] += *alpha * temp; jy += *incy; } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = 0.; ix = kx; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp += a[i__ + j * a_dim1] * x[ix]; ix += *incx; } y[jy] += *alpha * temp; jy += *incy; } } } return 0; } int dgeqr2_(m, n, a, lda, tau, work, info) integer *m, *n; doublereal *a; integer *lda; doublereal *tau, *work; integer *info; { integer a_dim1, a_offset, i__1, i__2, i__3; static integer i__, k; extern int dlarf_(), dlarfg_(), xerbla_(); static doublereal aii; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("DGEQR2", &i__1, 6L); return 0; } k = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; i__1 = k; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *m - i__ + 1; i__3 = i__ + 1; dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[(( i__3 ) <= ( *m ) ? ( i__3 ) : ( *m )) + i__ * a_dim1] , &c__1, &tau[i__]); if (i__ < *n) { aii = a[i__ + i__ * a_dim1]; a[i__ + i__ * a_dim1] = 1.; i__2 = *m - i__ + 1; i__3 = *n - i__; dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L); a[i__ + i__ * a_dim1] = aii; } } return 0; } int dgeqrf_(m, n, a, lda, tau, work, lwork, info) integer *m, *n; doublereal *a; integer *lda; doublereal *tau, *work; integer *lwork, *info; { integer a_dim1, a_offset, i__1, i__2, i__3, i__4; static integer i__, k, nbmin, iinfo; extern int dgeqr2_(); static integer ib, nb; extern int dlarfb_(); static integer nx; extern int dlarft_(), xerbla_(); extern integer ilaenv_(); static integer ldwork, iws; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -4; } else if (*lwork < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("DGEQRF", &i__1, 6L); return 0; } k = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; if (k == 0) { work[1] = 1.; return 0; } nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L); nbmin = 2; nx = 0; iws = *n; if (nb > 1 && nb < k) { i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L); nx = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; if (nx < k) { ldwork = *n; iws = ldwork * nb; if (*lwork < iws) { nb = *lwork / ldwork; i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, & c_n1, 6L, 1L); nbmin = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } } } if (nb >= nbmin && nb < k && nx < k) { i__1 = k - nx; i__2 = nb; for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { i__3 = k - i__ + 1; ib = (( i__3 ) <= ( nb ) ? ( i__3 ) : ( nb )) ; i__3 = *m - i__ + 1; dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ 1], &iinfo); if (i__ + ib <= *n) { i__3 = *m - i__ + 1; dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 10L); i__3 = *m - i__ + 1; i__4 = *n - i__ - ib + 1; dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, & i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + 1], &ldwork, 4L, 9L, 7L, 10L); } } } else { i__ = 1; } if (i__ <= k) { i__2 = *m - i__ + 1; i__1 = *n - i__ + 1; dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] , &iinfo); } work[1] = (doublereal) iws; return 0; } int dger_(m, n, alpha, x, incx, y, incy, a, lda) integer *m, *n; doublereal *alpha, *x; integer *incx; doublereal *y; integer *incy; doublereal *a; integer *lda; { integer a_dim1, a_offset, i__1, i__2; static integer info; static doublereal temp; static integer i__, j, ix, jy, kx; extern int xerbla_(); --x; --y; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; info = 0; if (*m < 0) { info = 1; } else if (*n < 0) { info = 2; } else if (*incx == 0) { info = 5; } else if (*incy == 0) { info = 7; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { info = 9; } if (info != 0) { xerbla_("DGER ", &info, 6L); return 0; } if (*m == 0 || *n == 0 || *alpha == 0.) { return 0; } if (*incy > 0) { jy = 1; } else { jy = 1 - (*n - 1) * *incy; } if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (y[jy] != 0.) { temp = *alpha * y[jy]; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] += x[i__] * temp; } } jy += *incy; } } else { if (*incx > 0) { kx = 1; } else { kx = 1 - (*m - 1) * *incx; } i__1 = *n; for (j = 1; j <= i__1; ++j) { if (y[jy] != 0.) { temp = *alpha * y[jy]; ix = kx; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] += x[ix] * temp; ix += *incx; } } jy += *incy; } } return 0; } int dlabad_(small, large) doublereal *small, *large; { double d_lg10(), sqrt(); if (d_lg10(large) > 2e3) { *small = sqrt(*small); *large = sqrt(*large); } return 0; } int dlacon_(n, v, x, isgn, est, kase) integer *n; doublereal *v, *x; integer *isgn; doublereal *est; integer *kase; { integer i__1; doublereal d__1; double d_sign(); integer i_dnnt(); static integer iter; static doublereal temp; static integer jump, i__, j; extern doublereal dasum_(); static integer jlast; extern int dcopy_(); extern integer idamax_(); static doublereal altsgn, estold; --isgn; --x; --v; if (*kase == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = 1. / (doublereal) (*n); } *kase = 1; jump = 1; return 0; } switch ((int)jump) { case 1: goto L20; case 2: goto L40; case 3: goto L70; case 4: goto L110; case 5: goto L140; } L20: if (*n == 1) { v[1] = x[1]; *est = (( v[1] ) >= 0 ? ( v[1] ) : -( v[1] )) ; goto L150; } *est = dasum_(n, &x[1], &c__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = d_sign(&c_b89, &x[i__]); isgn[i__] = i_dnnt(&x[i__]); } *kase = 2; jump = 2; return 0; L40: j = idamax_(n, &x[1], &c__1); iter = 2; L50: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = 0.; } x[j] = 1.; *kase = 1; jump = 3; return 0; L70: dcopy_(n, &x[1], &c__1, &v[1], &c__1); estold = *est; *est = dasum_(n, &v[1], &c__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = d_sign(&c_b89, &x[i__]); if (i_dnnt(&d__1) != isgn[i__]) { goto L90; } } goto L120; L90: if (*est <= estold) { goto L120; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = d_sign(&c_b89, &x[i__]); isgn[i__] = i_dnnt(&x[i__]); } *kase = 2; jump = 4; return 0; L110: jlast = j; j = idamax_(n, &x[1], &c__1); if (x[jlast] != (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) && iter < 5) { ++iter; goto L50; } L120: altsgn = 1.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 1.); altsgn = -altsgn; } *kase = 1; jump = 5; return 0; L140: temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; if (temp > *est) { dcopy_(n, &x[1], &c__1, &v[1], &c__1); *est = temp; } L150: *kase = 0; return 0; } int dlae2_(a, b, c__, rt1, rt2) doublereal *a, *b, *c__, *rt1, *rt2; { doublereal d__1; double sqrt(); static doublereal acmn, acmx, ab, df, tb, sm, rt, adf; sm = *a + *c__; df = *a - *c__; adf = (( df ) >= 0 ? ( df ) : -( df )) ; tb = *b + *b; ab = (( tb ) >= 0 ? ( tb ) : -( tb )) ; if ((( *a ) >= 0 ? ( *a ) : -( *a )) > (( *c__ ) >= 0 ? ( *c__ ) : -( *c__ )) ) { acmx = *a; acmn = *c__; } else { acmx = *c__; acmn = *a; } if (adf > ab) { d__1 = ab / adf; rt = adf * sqrt(d__1 * d__1 + 1.); } else if (adf < ab) { d__1 = adf / ab; rt = ab * sqrt(d__1 * d__1 + 1.); } else { rt = ab * sqrt(2.); } if (sm < 0.) { *rt1 = (sm - rt) * .5; *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else if (sm > 0.) { *rt1 = (sm + rt) * .5; *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else { *rt1 = rt * .5; *rt2 = rt * -.5; } return 0; } int dlaev2_(a, b, c__, rt1, rt2, cs1, sn1) doublereal *a, *b, *c__, *rt1, *rt2, *cs1, *sn1; { doublereal d__1; double sqrt(); static doublereal acmn, acmx, ab, df, cs, ct, tb, sm, tn, rt, adf, acs; static integer sgn1, sgn2; sm = *a + *c__; df = *a - *c__; adf = (( df ) >= 0 ? ( df ) : -( df )) ; tb = *b + *b; ab = (( tb ) >= 0 ? ( tb ) : -( tb )) ; if ((( *a ) >= 0 ? ( *a ) : -( *a )) > (( *c__ ) >= 0 ? ( *c__ ) : -( *c__ )) ) { acmx = *a; acmn = *c__; } else { acmx = *c__; acmn = *a; } if (adf > ab) { d__1 = ab / adf; rt = adf * sqrt(d__1 * d__1 + 1.); } else if (adf < ab) { d__1 = adf / ab; rt = ab * sqrt(d__1 * d__1 + 1.); } else { rt = ab * sqrt(2.); } if (sm < 0.) { *rt1 = (sm - rt) * .5; sgn1 = -1; *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else if (sm > 0.) { *rt1 = (sm + rt) * .5; sgn1 = 1; *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else { *rt1 = rt * .5; *rt2 = rt * -.5; sgn1 = 1; } if (df >= 0.) { cs = df + rt; sgn2 = 1; } else { cs = df - rt; sgn2 = -1; } acs = (( cs ) >= 0 ? ( cs ) : -( cs )) ; if (acs > ab) { ct = -tb / cs; *sn1 = 1. / sqrt(ct * ct + 1.); *cs1 = ct * *sn1; } else { if (ab == 0.) { *cs1 = 1.; *sn1 = 0.; } else { tn = -cs / tb; *cs1 = 1. / sqrt(tn * tn + 1.); *sn1 = tn * *cs1; } } if (sgn1 == sgn2) { tn = *cs1; *cs1 = -(*sn1); *sn1 = tn; } return 0; } doublereal dlamch_(cmach, cmach_len) char *cmach; ftnlen cmach_len; { static logical first = (1) ; integer i__1; doublereal ret_val; double pow_di(); static doublereal base; static integer beta; static doublereal emin, prec, emax; static integer imin, imax; static logical lrnd; static doublereal rmin, rmax, t, rmach; extern logical lsame_(); static doublereal small, sfmin; extern int dlamc2_(); static integer it; static doublereal rnd, eps; if (first) { first = (0) ; dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); base = (doublereal) beta; t = (doublereal) it; if (lrnd) { rnd = 1.; i__1 = 1 - it; eps = pow_di(&base, &i__1) / 2; } else { rnd = 0.; i__1 = 1 - it; eps = pow_di(&base, &i__1); } prec = eps * base; emin = (doublereal) imin; emax = (doublereal) imax; sfmin = rmin; small = 1. / rmax; if (small >= sfmin) { sfmin = small * (eps + 1.); } } if (lsame_(cmach, "E", 1L, 1L)) { rmach = eps; } else if (lsame_(cmach, "S", 1L, 1L)) { rmach = sfmin; } else if (lsame_(cmach, "B", 1L, 1L)) { rmach = base; } else if (lsame_(cmach, "P", 1L, 1L)) { rmach = prec; } else if (lsame_(cmach, "N", 1L, 1L)) { rmach = t; } else if (lsame_(cmach, "R", 1L, 1L)) { rmach = rnd; } else if (lsame_(cmach, "M", 1L, 1L)) { rmach = emin; } else if (lsame_(cmach, "U", 1L, 1L)) { rmach = rmin; } else if (lsame_(cmach, "L", 1L, 1L)) { rmach = emax; } else if (lsame_(cmach, "O", 1L, 1L)) { rmach = rmax; } ret_val = rmach; return ret_val; } int dlamc1_(beta, t, rnd, ieee1) integer *beta, *t; logical *rnd, *ieee1; { static logical first = (1) ; doublereal d__1, d__2; static logical lrnd; static doublereal a, b, c__, f; static integer lbeta; static doublereal savec; extern doublereal dlamc3_(); static logical lieee1; static doublereal t1, t2; static integer lt; static doublereal one, qtr; if (first) { first = (0) ; one = 1.; a = 1.; c__ = 1.; L10: if (c__ == one) { a *= 2; c__ = dlamc3_(&a, &one); d__1 = -a; c__ = dlamc3_(&c__, &d__1); goto L10; } b = 1.; c__ = dlamc3_(&a, &b); L20: if (c__ == a) { b *= 2; c__ = dlamc3_(&a, &b); goto L20; } qtr = one / 4; savec = c__; d__1 = -a; c__ = dlamc3_(&c__, &d__1); lbeta = (integer) (c__ + qtr); b = (doublereal) lbeta; d__1 = b / 2; d__2 = -b / 100; f = dlamc3_(&d__1, &d__2); c__ = dlamc3_(&f, &a); if (c__ == a) { lrnd = (1) ; } else { lrnd = (0) ; } d__1 = b / 2; d__2 = b / 100; f = dlamc3_(&d__1, &d__2); c__ = dlamc3_(&f, &a); if (lrnd && c__ == a) { lrnd = (0) ; } d__1 = b / 2; t1 = dlamc3_(&d__1, &a); d__1 = b / 2; t2 = dlamc3_(&d__1, &savec); lieee1 = t1 == a && t2 > savec && lrnd; lt = 0; a = 1.; c__ = 1.; L30: if (c__ == one) { ++lt; a *= lbeta; c__ = dlamc3_(&a, &one); d__1 = -a; c__ = dlamc3_(&c__, &d__1); goto L30; } } *beta = lbeta; *t = lt; *rnd = lrnd; *ieee1 = lieee1; return 0; } int dlamc2_(beta, t, rnd, eps, emin, rmin, emax, rmax) integer *beta, *t; logical *rnd; doublereal *eps; integer *emin; doublereal *rmin; integer *emax; doublereal *rmax; { static logical first = (1) ; static logical iwarn = (0) ; static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorrect:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the value EMIN looks\002,\002 acceptable please comment out \002,/\002 the IF block as marked within the code of routine\002,\002 DLAMC2,\002,/\002 otherwise supply EMIN explicitly.\002,/)"; integer i__1; doublereal d__1, d__2, d__3, d__4, d__5; double pow_di(); integer s_wsfe(), do_fio(), e_wsfe(); static logical ieee; static doublereal half; static logical lrnd; static doublereal leps, zero, a, b, c__; static integer i__, lbeta; static doublereal rbase; static integer lemin, lemax, gnmin; static doublereal small; static integer gpmin; static doublereal third, lrmin, lrmax, sixth; extern int dlamc1_(); extern doublereal dlamc3_(); static logical lieee1; extern int dlamc4_(), dlamc5_(); static integer lt, ngnmin, ngpmin; static doublereal one, two; static cilist io___156 = { 0, 6, 0, fmt_9999, 0 }; if (first) { first = (0) ; zero = 0.; one = 1.; two = 2.; dlamc1_(&lbeta, <, &lrnd, &lieee1); b = (doublereal) lbeta; i__1 = -lt; a = pow_di(&b, &i__1); leps = a; b = two / 3; half = one / 2; d__1 = -half; sixth = dlamc3_(&b, &d__1); third = dlamc3_(&sixth, &sixth); d__1 = -half; b = dlamc3_(&third, &d__1); b = dlamc3_(&b, &sixth); b = (( b ) >= 0 ? ( b ) : -( b )) ; if (b < leps) { b = leps; } leps = 1.; L10: if (leps > b && b > zero) { leps = b; d__1 = half * leps; d__3 = two, d__4 = d__3, d__3 *= d__3; d__5 = leps; d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5); c__ = dlamc3_(&d__1, &d__2); d__1 = -c__; c__ = dlamc3_(&half, &d__1); b = dlamc3_(&half, &c__); d__1 = -b; c__ = dlamc3_(&half, &d__1); b = dlamc3_(&half, &c__); goto L10; } if (a < leps) { leps = a; } rbase = one / lbeta; small = one; for (i__ = 1; i__ <= 3; ++i__) { d__1 = small * rbase; small = dlamc3_(&d__1, &zero); } a = dlamc3_(&one, &small); dlamc4_(&ngpmin, &one, &lbeta); d__1 = -one; dlamc4_(&ngnmin, &d__1, &lbeta); dlamc4_(&gpmin, &a, &lbeta); d__1 = -a; dlamc4_(&gnmin, &d__1, &lbeta); ieee = (0) ; if (ngpmin == ngnmin && gpmin == gnmin) { if (ngpmin == gpmin) { lemin = ngpmin; } else if (gpmin - ngpmin == 3) { lemin = ngpmin - 1 + lt; ieee = (1) ; } else { lemin = (( ngpmin ) <= ( gpmin ) ? ( ngpmin ) : ( gpmin )) ; iwarn = (1) ; } } else if (ngpmin == gpmin && ngnmin == gnmin) { if ((i__1 = ngpmin - ngnmin, (( i__1 ) >= 0 ? ( i__1 ) : -( i__1 )) ) == 1) { lemin = (( ngpmin ) >= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) ; } else { lemin = (( ngpmin ) <= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) ; iwarn = (1) ; } } else if ((i__1 = ngpmin - ngnmin, (( i__1 ) >= 0 ? ( i__1 ) : -( i__1 )) ) == 1 && gpmin == gnmin) { if (gpmin - (( ngpmin ) <= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) == 3) { lemin = (( ngpmin ) >= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) - 1 + lt; } else { lemin = (( ngpmin ) <= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) ; iwarn = (1) ; } } else { i__1 = (( ngpmin ) <= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) , i__1 = (( i__1 ) <= ( gpmin ) ? ( i__1 ) : ( gpmin )) ; lemin = (( i__1 ) <= ( gnmin ) ? ( i__1 ) : ( gnmin )) ; iwarn = (1) ; } if (iwarn) { first = (1) ; s_wsfe(&io___156); do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer)); e_wsfe(); } ieee = ieee || lieee1; lrmin = 1.; i__1 = 1 - lemin; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = lrmin * rbase; lrmin = dlamc3_(&d__1, &zero); } dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); } *beta = lbeta; *t = lt; *rnd = lrnd; *eps = leps; *emin = lemin; *rmin = lrmin; *emax = lemax; *rmax = lrmax; return 0; } doublereal dlamc3_(a, b) doublereal *a, *b; { doublereal ret_val; ret_val = *a + *b; return ret_val; } int dlamc4_(emin, start, base) integer *emin; doublereal *start; integer *base; { integer i__1; doublereal d__1; static doublereal zero, a; static integer i__; static doublereal rbase, b1, b2, c1, c2, d1, d2; extern doublereal dlamc3_(); static doublereal one; a = *start; one = 1.; rbase = one / *base; zero = 0.; *emin = 1; d__1 = a * rbase; b1 = dlamc3_(&d__1, &zero); c1 = a; c2 = a; d1 = a; d2 = a; L10: if (c1 == a && c2 == a && d1 == a && d2 == a) { --(*emin); a = b1; d__1 = a / *base; b1 = dlamc3_(&d__1, &zero); d__1 = b1 * *base; c1 = dlamc3_(&d__1, &zero); d1 = zero; i__1 = *base; for (i__ = 1; i__ <= i__1; ++i__) { d1 += b1; } d__1 = a * rbase; b2 = dlamc3_(&d__1, &zero); d__1 = b2 / rbase; c2 = dlamc3_(&d__1, &zero); d2 = zero; i__1 = *base; for (i__ = 1; i__ <= i__1; ++i__) { d2 += b2; } goto L10; } return 0; } int dlamc5_(beta, p, emin, ieee, emax, rmax) integer *beta, *p, *emin; logical *ieee; integer *emax; doublereal *rmax; { integer i__1; doublereal d__1; static integer lexp; static doublereal oldy; static integer uexp, i__; static doublereal y, z__; static integer nbits; extern doublereal dlamc3_(); static doublereal recbas; static integer exbits, expsum, try__; lexp = 1; exbits = 1; L10: try__ = lexp << 1; if (try__ <= -(*emin)) { lexp = try__; ++exbits; goto L10; } if (lexp == -(*emin)) { uexp = lexp; } else { uexp = try__; ++exbits; } if (uexp + *emin > -lexp - *emin) { expsum = lexp << 1; } else { expsum = uexp << 1; } *emax = expsum + *emin - 1; nbits = exbits + 1 + *p; if (nbits % 2 == 1 && *beta == 2) { --(*emax); } if (*ieee) { --(*emax); } recbas = 1. / *beta; z__ = *beta - 1.; y = 0.; i__1 = *p; for (i__ = 1; i__ <= i__1; ++i__) { z__ *= recbas; if (y < 1.) { oldy = y; } y = dlamc3_(&y, &z__); } if (y >= 1.) { y = oldy; } i__1 = *emax; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = y * *beta; y = dlamc3_(&d__1, &c_b61); } *rmax = y; return 0; } doublereal dlange_(norm, m, n, a, lda, work, norm_len) char *norm; integer *m, *n; doublereal *a; integer *lda; doublereal *work; ftnlen norm_len; { integer a_dim1, a_offset, i__1, i__2; doublereal ret_val, d__1, d__2, d__3; double sqrt(); static integer i__, j; static doublereal scale; extern logical lsame_(); static doublereal value; extern int dlassq_(); static doublereal sum; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --work; if ((( *m ) <= ( *n ) ? ( *m ) : ( *n )) == 0) { value = 0.; } else if (lsame_(norm, "M", 1L, 1L)) { value = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } } } else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') { value = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } value = (( value ) >= ( sum ) ? ( value ) : ( sum )) ; } } else if (lsame_(norm, "I", 1L, 1L)) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } value = 0.; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = value, d__2 = work[i__]; value = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) { scale = 0.; sum = 1.; i__1 = *n; for (j = 1; j <= i__1; ++j) { dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); } value = scale * sqrt(sum); } ret_val = value; return ret_val; } doublereal dlansp_(norm, uplo, n, ap, work, norm_len, uplo_len) char *norm, *uplo; integer *n; doublereal *ap, *work; ftnlen norm_len; ftnlen uplo_len; { integer i__1, i__2; doublereal ret_val, d__1, d__2, d__3; double sqrt(); static doublereal absa; static integer i__, j, k; static doublereal scale; extern logical lsame_(); static doublereal value; extern int dlassq_(); static doublereal sum; --work; --ap; if (*n == 0) { value = 0.; } else if (lsame_(norm, "M", 1L, 1L)) { value = 0.; if (lsame_(uplo, "U", 1L, 1L)) { k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { d__2 = value, d__3 = (d__1 = ap[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } k += j; } } else { k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { d__2 = value, d__3 = (d__1 = ap[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } k = k + *n - j + 1; } } } else if (lsame_(norm, "I", 1L, 1L) || lsame_(norm, "O", 1L, 1L) || *( unsigned char *)norm == '1') { value = 0.; k = 1; if (lsame_(uplo, "U", 1L, 1L)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { absa = (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); sum += absa; work[i__] += absa; ++k; } work[j] = sum + (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); ++k; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = value, d__2 = work[i__]; value = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.; } i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = work[j] + (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); ++k; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { absa = (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); sum += absa; work[i__] += absa; ++k; } value = (( value ) >= ( sum ) ? ( value ) : ( sum )) ; } } } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) { scale = 0.; sum = 1.; k = 2; if (lsame_(uplo, "U", 1L, 1L)) { i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); k += j; } } else { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; } } sum *= 2; k = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (ap[k] != 0.) { absa = (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (scale < absa) { d__1 = scale / absa; sum = sum * (d__1 * d__1) + 1.; scale = absa; } else { d__1 = absa / scale; sum += d__1 * d__1; } } if (lsame_(uplo, "U", 1L, 1L)) { k = k + i__ + 1; } else { k = k + *n - i__ + 1; } } value = scale * sqrt(sum); } ret_val = value; return ret_val; } doublereal dlanst_(norm, n, d__, e, norm_len) char *norm; integer *n; doublereal *d__, *e; ftnlen norm_len; { integer i__1; doublereal ret_val, d__1, d__2, d__3, d__4, d__5; double sqrt(); static integer i__; static doublereal scale; extern logical lsame_(); static doublereal anorm; extern int dlassq_(); static doublereal sum; --e; --d__; if (*n <= 0) { anorm = 0.; } else if (lsame_(norm, "M", 1L, 1L)) { anorm = (d__1 = d__[*n], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { d__2 = anorm, d__3 = (d__1 = d__[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); anorm = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; d__2 = anorm, d__3 = (d__1 = e[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); anorm = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } } else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1' || lsame_(norm, "I", 1L, 1L)) { if (*n == 1) { anorm = (( d__[1] ) >= 0 ? ( d__[1] ) : -( d__[1] )) ; } else { d__3 = (( d__[1] ) >= 0 ? ( d__[1] ) : -( d__[1] )) + (( e[1] ) >= 0 ? ( e[1] ) : -( e[1] )) , d__4 = (d__1 = e[*n - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = d__[*n], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ); anorm = (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ; i__1 = *n - 1; for (i__ = 2; i__ <= i__1; ++i__) { d__4 = anorm, d__5 = (d__1 = d__[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = e[ i__], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + (d__3 = e[i__ - 1], (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) ); anorm = (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) ; } } } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) { scale = 0.; sum = 1.; if (*n > 1) { i__1 = *n - 1; dlassq_(&i__1, &e[1], &c__1, &scale, &sum); sum *= 2; } dlassq_(n, &d__[1], &c__1, &scale, &sum); anorm = scale * sqrt(sum); } ret_val = anorm; return ret_val; } doublereal dlantr_(norm, uplo, diag, m, n, a, lda, work, norm_len, uplo_len, diag_len) char *norm, *uplo, *diag; integer *m, *n; doublereal *a; integer *lda; doublereal *work; ftnlen norm_len; ftnlen uplo_len; ftnlen diag_len; { integer a_dim1, a_offset, i__1, i__2, i__3, i__4; doublereal ret_val, d__1, d__2, d__3; double sqrt(); static integer i__, j; static doublereal scale; static logical udiag; extern logical lsame_(); static doublereal value; extern int dlassq_(); static doublereal sum; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --work; if ((( *m ) <= ( *n ) ? ( *m ) : ( *n )) == 0) { value = 0.; } else if (lsame_(norm, "M", 1L, 1L)) { if (lsame_(diag, "U", 1L, 1L)) { value = 1.; if (lsame_(uplo, "U", 1L, 1L)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__3 = *m, i__4 = j - 1; i__2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ; for (i__ = 1; i__ <= i__2; ++i__) { d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } } } } else { value = 0.; if (lsame_(uplo, "U", 1L, 1L)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = (( *m ) <= ( j ) ? ( *m ) : ( j )) ; for (i__ = 1; i__ <= i__2; ++i__) { d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } } } } } else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') { value = 0.; udiag = lsame_(diag, "U", 1L, 1L); if (lsame_(uplo, "U", 1L, 1L)) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag && j <= *m) { sum = 1.; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } else { sum = 0.; i__2 = (( *m ) <= ( j ) ? ( *m ) : ( j )) ; for (i__ = 1; i__ <= i__2; ++i__) { sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } value = (( value ) >= ( sum ) ? ( value ) : ( sum )) ; } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (udiag) { sum = 1.; i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } else { sum = 0.; i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } value = (( value ) >= ( sum ) ? ( value ) : ( sum )) ; } } } else if (lsame_(norm, "I", 1L, 1L)) { if (lsame_(uplo, "U", 1L, 1L)) { if (lsame_(diag, "U", 1L, 1L)) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__3 = *m, i__4 = j - 1; i__2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } } else { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = (( *m ) <= ( j ) ? ( *m ) : ( j )) ; for (i__ = 1; i__ <= i__2; ++i__) { work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } } } else { if (lsame_(diag, "U", 1L, 1L)) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 1.; } i__1 = *m; for (i__ = *n + 1; i__ <= i__1; ++i__) { work[i__] = 0.; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } } else { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } } } value = 0.; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = value, d__2 = work[i__]; value = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) { if (lsame_(uplo, "U", 1L, 1L)) { if (lsame_(diag, "U", 1L, 1L)) { scale = 1.; sum = (doublereal) (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__3 = *m, i__4 = j - 1; i__2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ; dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); } } else { scale = 0.; sum = 1.; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = (( *m ) <= ( j ) ? ( *m ) : ( j )) ; dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); } } } else { if (lsame_(diag, "U", 1L, 1L)) { scale = 1.; sum = (doublereal) (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m - j; i__3 = *m, i__4 = j + 1; dlassq_(&i__2, &a[(( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) + j * a_dim1], &c__1, & scale, &sum); } } else { scale = 0.; sum = 1.; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m - j + 1; dlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum); } } } value = scale * sqrt(sum); } ret_val = value; return ret_val; } doublereal dlapy2_(x, y) doublereal *x, *y; { doublereal ret_val, d__1; double sqrt(); static doublereal xabs, yabs, w, z__; xabs = (( *x ) >= 0 ? ( *x ) : -( *x )) ; yabs = (( *y ) >= 0 ? ( *y ) : -( *y )) ; w = (( xabs ) >= ( yabs ) ? ( xabs ) : ( yabs )) ; z__ = (( xabs ) <= ( yabs ) ? ( xabs ) : ( yabs )) ; if (z__ == 0.) { ret_val = w; } else { d__1 = z__ / w; ret_val = w * sqrt(d__1 * d__1 + 1.); } return ret_val; } int dlarf_(side, m, n, v, incv, tau, c__, ldc, work, side_len) char *side; integer *m, *n; doublereal *v; integer *incv; doublereal *tau, *c__; integer *ldc; doublereal *work; ftnlen side_len; { integer c_dim1, c_offset; doublereal d__1; extern int dger_(); extern logical lsame_(); extern int dgemv_(); --v; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; if (lsame_(side, "L", 1L, 1L)) { if (*tau != 0.) { dgemv_("Transpose", m, n, &c_b89, &c__[c_offset], ldc, &v[1], incv, &c_b61, &work[1], &c__1, 9L); d__1 = -(*tau); dger_(m, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc); } } else { if (*tau != 0.) { dgemv_("No transpose", m, n, &c_b89, &c__[c_offset], ldc, &v[1], incv, &c_b61, &work[1], &c__1, 12L); d__1 = -(*tau); dger_(m, n, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc); } } return 0; } int dlarfb_(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c__, ldc, work, ldwork, side_len, trans_len, direct_len, storev_len) char *side, *trans, *direct, *storev; integer *m, *n, *k; doublereal *v; integer *ldv; doublereal *t; integer *ldt; doublereal *c__; integer *ldc; doublereal *work; integer *ldwork; ftnlen side_len; ftnlen trans_len; ftnlen direct_len; ftnlen storev_len; { integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, i__2; static integer i__, j; extern int dgemm_(); extern logical lsame_(); extern int dcopy_(), dtrmm_(); static char transt[1]; v_dim1 = *ldv; v_offset = v_dim1 + 1; v -= v_offset; t_dim1 = *ldt; t_offset = t_dim1 + 1; t -= t_offset; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; work_dim1 = *ldwork; work_offset = work_dim1 + 1; work -= work_offset; if (*m <= 0 || *n <= 0) { return 0; } if (lsame_(trans, "N", 1L, 1L)) { *(unsigned char *)transt = 'T'; } else { *(unsigned char *)transt = 'N'; } if (lsame_(storev, "C", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { if (lsame_(side, "L", 1L, 1L)) { i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); } dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b89, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); if (*m > *k) { i__1 = *m - *k; dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b89, & c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], ldv, &c_b89, &work[work_offset], ldwork, 9L, 12L); } dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b89, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); if (*m > *k) { i__1 = *m - *k; dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b418, &v[*k + 1 + v_dim1], ldv, &work[work_offset], ldwork, &c_b89, &c__[*k + 1 + c_dim1], ldc, 12L, 9L); } dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b89, & v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 9L, 4L); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; } } } else if (lsame_(side, "R", 1L, 1L)) { i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); } dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b89, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); if (*n > *k) { i__1 = *n - *k; dgemm_("No transpose", "No transpose", m, k, &i__1, & c_b89, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 + v_dim1], ldv, &c_b89, &work[work_offset], ldwork, 12L, 12L); } dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b89, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); if (*n > *k) { i__1 = *n - *k; dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b418, &work[work_offset], ldwork, &v[*k + 1 + v_dim1], ldv, &c_b89, &c__[(*k + 1) * c_dim1 + 1], ldc, 12L, 9L); } dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b89, & v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 9L, 4L); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; } } } } else { if (lsame_(side, "L", 1L, 1L)) { i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); } dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b89, &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); if (*m > *k) { i__1 = *m - *k; dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b89, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b89, & work[work_offset], ldwork, 9L, 12L); } dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b89, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); if (*m > *k) { i__1 = *m - *k; dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b418, &v[v_offset], ldv, &work[work_offset], ldwork, & c_b89, &c__[c_offset], ldc, 12L, 9L); } dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b89, & v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, 5L, 5L, 9L, 4L); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * work_dim1]; } } } else if (lsame_(side, "R", 1L, 1L)) { i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ j * work_dim1 + 1], &c__1); } dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b89, &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); if (*n > *k) { i__1 = *n - *k; dgemm_("No transpose", "No transpose", m, k, &i__1, & c_b89, &c__[c_offset], ldc, &v[v_offset], ldv, & c_b89, &work[work_offset], ldwork, 12L, 12L); } dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b89, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); if (*n > *k) { i__1 = *n - *k; dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b418, &work[work_offset], ldwork, &v[v_offset], ldv, & c_b89, &c__[c_offset], ldc, 12L, 9L); } dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b89, & v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, 5L, 5L, 9L, 4L); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * work_dim1]; } } } } } else if (lsame_(storev, "R", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { if (lsame_(side, "L", 1L, 1L)) { i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); } dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b89, & v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 9L, 4L); if (*m > *k) { i__1 = *m - *k; dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b89, & c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b89, &work[work_offset], ldwork, 9L, 9L); } dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b89, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); if (*m > *k) { i__1 = *m - *k; dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b418, &v[ (*k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, &c_b89, &c__[*k + 1 + c_dim1], ldc, 9L, 9L); } dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b89, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; } } } else if (lsame_(side, "R", 1L, 1L)) { i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); } dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b89, & v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 9L, 4L); if (*n > *k) { i__1 = *n - *k; dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b89, & c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b89, &work[work_offset], ldwork, 12L, 9L); } dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b89, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); if (*n > *k) { i__1 = *n - *k; dgemm_("No transpose", "No transpose", m, &i__1, k, & c_b418, &work[work_offset], ldwork, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b89, &c__[(*k + 1) * c_dim1 + 1], ldc, 12L, 12L); } dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b89, &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 12L, 4L); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; } } } } else { if (lsame_(side, "L", 1L, 1L)) { i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); } dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b89, & v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] , ldwork, 5L, 5L, 9L, 4L); if (*m > *k) { i__1 = *m - *k; dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b89, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b89, & work[work_offset], ldwork, 9L, 9L); } dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b89, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); if (*m > *k) { i__1 = *m - *k; dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b418, &v[ v_offset], ldv, &work[work_offset], ldwork, & c_b89, &c__[c_offset], ldc, 9L, 9L); } dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b89, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork, 5L, 5L, 12L, 4L); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * work_dim1]; } } } else if (lsame_(side, "R", 1L, 1L)) { i__1 = *k; for (j = 1; j <= i__1; ++j) { dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ j * work_dim1 + 1], &c__1); } dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b89, & v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] , ldwork, 5L, 5L, 9L, 4L); if (*n > *k) { i__1 = *n - *k; dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b89, & c__[c_offset], ldc, &v[v_offset], ldv, &c_b89, & work[work_offset], ldwork, 12L, 9L); } dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b89, &t[ t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 1L, 8L); if (*n > *k) { i__1 = *n - *k; dgemm_("No transpose", "No transpose", m, &i__1, k, & c_b418, &work[work_offset], ldwork, &v[v_offset], ldv, &c_b89, &c__[c_offset], ldc, 12L, 12L); } dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b89, &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ work_offset], ldwork, 5L, 5L, 12L, 4L); i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * work_dim1]; } } } } } return 0; } int dlarfg_(n, alpha, x, incx, tau) integer *n; doublereal *alpha, *x; integer *incx; doublereal *tau; { integer i__1; doublereal d__1; double d_sign(); static doublereal beta; extern doublereal dnrm2_(); static integer j; extern int dscal_(); static doublereal xnorm; extern doublereal dlapy2_(), dlamch_(); static doublereal safmin, rsafmn; static integer knt; --x; if (*n <= 1) { *tau = 0.; return 0; } i__1 = *n - 1; xnorm = dnrm2_(&i__1, &x[1], incx); if (xnorm == 0.) { *tau = 0.; } else { d__1 = dlapy2_(alpha, &xnorm); beta = -d_sign(&d__1, alpha); safmin = dlamch_("S", 1L) / dlamch_("E", 1L); if ((( beta ) >= 0 ? ( beta ) : -( beta )) < safmin) { rsafmn = 1. / safmin; knt = 0; L10: ++knt; i__1 = *n - 1; dscal_(&i__1, &rsafmn, &x[1], incx); beta *= rsafmn; *alpha *= rsafmn; if ((( beta ) >= 0 ? ( beta ) : -( beta )) < safmin) { goto L10; } i__1 = *n - 1; xnorm = dnrm2_(&i__1, &x[1], incx); d__1 = dlapy2_(alpha, &xnorm); beta = -d_sign(&d__1, alpha); *tau = (beta - *alpha) / beta; i__1 = *n - 1; d__1 = 1. / (*alpha - beta); dscal_(&i__1, &d__1, &x[1], incx); *alpha = beta; i__1 = knt; for (j = 1; j <= i__1; ++j) { *alpha *= safmin; } } else { *tau = (beta - *alpha) / beta; i__1 = *n - 1; d__1 = 1. / (*alpha - beta); dscal_(&i__1, &d__1, &x[1], incx); *alpha = beta; } } return 0; } int dlarft_(direct, storev, n, k, v, ldv, tau, t, ldt, direct_len, storev_len) char *direct, *storev; integer *n, *k; doublereal *v; integer *ldv; doublereal *tau, *t; integer *ldt; ftnlen direct_len; ftnlen storev_len; { integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; doublereal d__1; static integer i__, j; extern logical lsame_(); extern int dgemv_(), dtrmv_(); static doublereal vii; v_dim1 = *ldv; v_offset = v_dim1 + 1; v -= v_offset; --tau; t_dim1 = *ldt; t_offset = t_dim1 + 1; t -= t_offset; if (*n == 0) { return 0; } if (lsame_(direct, "F", 1L, 1L)) { i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { if (tau[i__] == 0.) { i__2 = i__; for (j = 1; j <= i__2; ++j) { t[j + i__ * t_dim1] = 0.; } } else { vii = v[i__ + i__ * v_dim1]; v[i__ + i__ * v_dim1] = 1.; if (lsame_(storev, "C", 1L, 1L)) { i__2 = *n - i__ + 1; i__3 = i__ - 1; d__1 = -tau[i__]; dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b61, &t[ i__ * t_dim1 + 1], &c__1, 9L); } else { i__2 = i__ - 1; i__3 = *n - i__ + 1; d__1 = -tau[i__]; dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ * v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, & c_b61, &t[i__ * t_dim1 + 1], &c__1, 12L); } v[i__ + i__ * v_dim1] = vii; i__2 = i__ - 1; dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, 5L, 12L, 8L); t[i__ + i__ * t_dim1] = tau[i__]; } } } else { for (i__ = *k; i__ >= 1; --i__) { if (tau[i__] == 0.) { i__1 = *k; for (j = i__; j <= i__1; ++j) { t[j + i__ * t_dim1] = 0.; } } else { if (i__ < *k) { if (lsame_(storev, "C", 1L, 1L)) { vii = v[*n - *k + i__ + i__ * v_dim1]; v[*n - *k + i__ + i__ * v_dim1] = 1.; i__1 = *n - *k + i__; i__2 = *k - i__; d__1 = -tau[i__]; dgemv_("Transpose", &i__1, &i__2, &d__1, &v[(i__ + 1) * v_dim1 + 1], ldv, &v[i__ * v_dim1 + 1], & c__1, &c_b61, &t[i__ + 1 + i__ * t_dim1], & c__1, 9L); v[*n - *k + i__ + i__ * v_dim1] = vii; } else { vii = v[i__ + (*n - *k + i__) * v_dim1]; v[i__ + (*n - *k + i__) * v_dim1] = 1.; i__1 = *k - i__; i__2 = *n - *k + i__; d__1 = -tau[i__]; dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + 1 + v_dim1], ldv, &v[i__ + v_dim1], ldv, & c_b61, &t[i__ + 1 + i__ * t_dim1], &c__1, 12L) ; v[i__ + (*n - *k + i__) * v_dim1] = vii; } i__1 = *k - i__; dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1], &c__1, 5L, 12L, 8L); } t[i__ + i__ * t_dim1] = tau[i__]; } } } return 0; } int dlartg_(f, g, cs, sn, r__) doublereal *f, *g, *cs, *sn, *r__; { static logical first = (1) ; integer i__1; doublereal d__1, d__2; double log(), pow_di(), sqrt(); static integer i__; static doublereal scale; static integer count; static doublereal f1, g1, safmn2, safmx2; extern doublereal dlamch_(); static doublereal safmin, eps; if (first) { first = (0) ; safmin = dlamch_("S", 1L); eps = dlamch_("E", 1L); d__1 = dlamch_("B", 1L); i__1 = (integer) (log(safmin / eps) / log(dlamch_("B", 1L)) / 2.); safmn2 = pow_di(&d__1, &i__1); safmx2 = 1. / safmn2; } if (*g == 0.) { *cs = 1.; *sn = 0.; *r__ = *f; } else if (*f == 0.) { *cs = 0.; *sn = 1.; *r__ = *g; } else { f1 = *f; g1 = *g; d__1 = (( f1 ) >= 0 ? ( f1 ) : -( f1 )) , d__2 = (( g1 ) >= 0 ? ( g1 ) : -( g1 )) ; scale = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (scale >= safmx2) { count = 0; L10: ++count; f1 *= safmn2; g1 *= safmn2; d__1 = (( f1 ) >= 0 ? ( f1 ) : -( f1 )) , d__2 = (( g1 ) >= 0 ? ( g1 ) : -( g1 )) ; scale = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (scale >= safmx2) { goto L10; } d__1 = f1; d__2 = g1; *r__ = sqrt(d__1 * d__1 + d__2 * d__2); *cs = f1 / *r__; *sn = g1 / *r__; i__1 = count; for (i__ = 1; i__ <= i__1; ++i__) { *r__ *= safmx2; } } else if (scale <= safmn2) { count = 0; L30: ++count; f1 *= safmx2; g1 *= safmx2; d__1 = (( f1 ) >= 0 ? ( f1 ) : -( f1 )) , d__2 = (( g1 ) >= 0 ? ( g1 ) : -( g1 )) ; scale = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (scale <= safmn2) { goto L30; } d__1 = f1; d__2 = g1; *r__ = sqrt(d__1 * d__1 + d__2 * d__2); *cs = f1 / *r__; *sn = g1 / *r__; i__1 = count; for (i__ = 1; i__ <= i__1; ++i__) { *r__ *= safmn2; } } else { d__1 = f1; d__2 = g1; *r__ = sqrt(d__1 * d__1 + d__2 * d__2); *cs = f1 / *r__; *sn = g1 / *r__; } if ((( *f ) >= 0 ? ( *f ) : -( *f )) > (( *g ) >= 0 ? ( *g ) : -( *g )) && *cs < 0.) { *cs = -(*cs); *sn = -(*sn); *r__ = -(*r__); } } return 0; } int dlascl_(type__, kl, ku, cfrom, cto, m, n, a, lda, info, type_len) char *type__; integer *kl, *ku; doublereal *cfrom, *cto; integer *m, *n; doublereal *a; integer *lda, *info; ftnlen type_len; { integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; static logical done; static doublereal ctoc; static integer i__, j; extern logical lsame_(); static integer itype, k1, k2, k3, k4; static doublereal cfrom1; extern doublereal dlamch_(); static doublereal cfromc; extern int xerbla_(); static doublereal bignum, smlnum, mul, cto1; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; *info = 0; if (lsame_(type__, "G", 1L, 1L)) { itype = 0; } else if (lsame_(type__, "L", 1L, 1L)) { itype = 1; } else if (lsame_(type__, "U", 1L, 1L)) { itype = 2; } else if (lsame_(type__, "H", 1L, 1L)) { itype = 3; } else if (lsame_(type__, "B", 1L, 1L)) { itype = 4; } else if (lsame_(type__, "Q", 1L, 1L)) { itype = 5; } else if (lsame_(type__, "Z", 1L, 1L)) { itype = 6; } else { itype = -1; } if (itype == -1) { *info = -1; } else if (*cfrom == 0.) { *info = -4; } else if (*m < 0) { *info = -6; } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { *info = -7; } else if (itype <= 3 && *lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -9; } else if (itype >= 4) { i__1 = *m - 1; if (*kl < 0 || *kl > (( i__1 ) >= ( 0 ) ? ( i__1 ) : ( 0 )) ) { *info = -2; } else { i__1 = *n - 1; if (*ku < 0 || *ku > (( i__1 ) >= ( 0 ) ? ( i__1 ) : ( 0 )) || (itype == 4 || itype == 5) && *kl != *ku) { *info = -3; } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { *info = -9; } } } if (*info != 0) { i__1 = -(*info); xerbla_("DLASCL", &i__1, 6L); return 0; } if (*n == 0 || *m == 0) { return 0; } smlnum = dlamch_("S", 1L); bignum = 1. / smlnum; cfromc = *cfrom; ctoc = *cto; L10: cfrom1 = cfromc * smlnum; cto1 = ctoc / bignum; if ((( cfrom1 ) >= 0 ? ( cfrom1 ) : -( cfrom1 )) > (( ctoc ) >= 0 ? ( ctoc ) : -( ctoc )) && ctoc != 0.) { mul = smlnum; done = (0) ; cfromc = cfrom1; } else if ((( cto1 ) >= 0 ? ( cto1 ) : -( cto1 )) > (( cfromc ) >= 0 ? ( cfromc ) : -( cfromc )) ) { mul = bignum; done = (0) ; ctoc = cto1; } else { mul = ctoc / cfromc; done = (1) ; } if (itype == 0) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] *= mul; } } } else if (itype == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] *= mul; } } } else if (itype == 2) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = (( j ) <= ( *m ) ? ( j ) : ( *m )) ; for (i__ = 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] *= mul; } } } else if (itype == 3) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__3 = j + 1; i__2 = (( i__3 ) <= ( *m ) ? ( i__3 ) : ( *m )) ; for (i__ = 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] *= mul; } } } else if (itype == 4) { k3 = *kl + 1; k4 = *n + 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__3 = k3, i__4 = k4 - j; i__2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ; for (i__ = 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] *= mul; } } } else if (itype == 5) { k1 = *ku + 2; k3 = *ku + 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k1 - j; i__3 = k3; for (i__ = (( i__2 ) >= ( 1 ) ? ( i__2 ) : ( 1 )) ; i__ <= i__3; ++i__) { a[i__ + j * a_dim1] *= mul; } } } else if (itype == 6) { k1 = *kl + *ku + 2; k2 = *kl + 1; k3 = (*kl << 1) + *ku + 1; k4 = *kl + *ku + 1 + *m; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__3 = k1 - j; i__4 = k3, i__5 = k4 - j; i__2 = (( i__4 ) <= ( i__5 ) ? ( i__4 ) : ( i__5 )) ; for (i__ = (( i__3 ) >= ( k2 ) ? ( i__3 ) : ( k2 )) ; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] *= mul; } } } if (! done) { goto L10; } return 0; } int dlaset_(uplo, m, n, alpha, beta, a, lda, uplo_len) char *uplo; integer *m, *n; doublereal *alpha, *beta, *a; integer *lda; ftnlen uplo_len; { integer a_dim1, a_offset, i__1, i__2, i__3; static integer i__, j; extern logical lsame_(); a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; if (lsame_(uplo, "U", 1L, 1L)) { i__1 = *n; for (j = 2; j <= i__1; ++j) { i__3 = j - 1; i__2 = (( i__3 ) <= ( *m ) ? ( i__3 ) : ( *m )) ; for (i__ = 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] = *alpha; } } } else if (lsame_(uplo, "L", 1L, 1L)) { i__1 = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j + 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] = *alpha; } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] = *alpha; } } } i__1 = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; for (i__ = 1; i__ <= i__1; ++i__) { a[i__ + i__ * a_dim1] = *beta; } return 0; } int dlasr_(side, pivot, direct, m, n, c__, s, a, lda, side_len, pivot_len, direct_len) char *side, *pivot, *direct; integer *m, *n; doublereal *c__, *s, *a; integer *lda; ftnlen side_len; ftnlen pivot_len; ftnlen direct_len; { integer a_dim1, a_offset, i__1, i__2; static integer info; static doublereal temp; static integer i__, j; extern logical lsame_(); static doublereal ctemp, stemp; extern int xerbla_(); --c__; --s; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; info = 0; if (! (lsame_(side, "L", 1L, 1L) || lsame_(side, "R", 1L, 1L))) { info = 1; } else if (! (lsame_(pivot, "V", 1L, 1L) || lsame_(pivot, "T", 1L, 1L) || lsame_(pivot, "B", 1L, 1L))) { info = 2; } else if (! (lsame_(direct, "F", 1L, 1L) || lsame_(direct, "B", 1L, 1L))) { info = 3; } else if (*m < 0) { info = 4; } else if (*n < 0) { info = 5; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { info = 9; } if (info != 0) { xerbla_("DLASR ", &info, 6L); return 0; } if (*m == 0 || *n == 0) { return 0; } if (lsame_(side, "L", 1L, 1L)) { if (lsame_(pivot, "V", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *m - 1; for (j = 1; j <= i__1; ++j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { temp = a[j + 1 + i__ * a_dim1]; a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * a[j + i__ * a_dim1]; a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + i__ * a_dim1]; } } } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *m - 1; j >= 1; --j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { temp = a[j + 1 + i__ * a_dim1]; a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * a[j + i__ * a_dim1]; a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + i__ * a_dim1]; } } } } } else if (lsame_(pivot, "T", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *m; for (j = 2; j <= i__1; ++j) { ctemp = c__[j - 1]; stemp = s[j - 1]; if (ctemp != 1. || stemp != 0.) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { temp = a[j + i__ * a_dim1]; a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ i__ * a_dim1 + 1]; a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ i__ * a_dim1 + 1]; } } } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *m; j >= 2; --j) { ctemp = c__[j - 1]; stemp = s[j - 1]; if (ctemp != 1. || stemp != 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { temp = a[j + i__ * a_dim1]; a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ i__ * a_dim1 + 1]; a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ i__ * a_dim1 + 1]; } } } } } else if (lsame_(pivot, "B", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *m - 1; for (j = 1; j <= i__1; ++j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { temp = a[j + i__ * a_dim1]; a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + ctemp * temp; a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * a_dim1] - stemp * temp; } } } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *m - 1; j >= 1; --j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { temp = a[j + i__ * a_dim1]; a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + ctemp * temp; a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * a_dim1] - stemp * temp; } } } } } } else if (lsame_(side, "R", 1L, 1L)) { if (lsame_(pivot, "V", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = a[i__ + (j + 1) * a_dim1]; a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * a[i__ + j * a_dim1]; a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ i__ + j * a_dim1]; } } } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *n - 1; j >= 1; --j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { temp = a[i__ + (j + 1) * a_dim1]; a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * a[i__ + j * a_dim1]; a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ i__ + j * a_dim1]; } } } } } else if (lsame_(pivot, "T", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *n; for (j = 2; j <= i__1; ++j) { ctemp = c__[j - 1]; stemp = s[j - 1]; if (ctemp != 1. || stemp != 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = a[i__ + j * a_dim1]; a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ i__ + a_dim1]; a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + a_dim1]; } } } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *n; j >= 2; --j) { ctemp = c__[j - 1]; stemp = s[j - 1]; if (ctemp != 1. || stemp != 0.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { temp = a[i__ + j * a_dim1]; a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ i__ + a_dim1]; a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + a_dim1]; } } } } } else if (lsame_(pivot, "B", 1L, 1L)) { if (lsame_(direct, "F", 1L, 1L)) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = a[i__ + j * a_dim1]; a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + ctemp * temp; a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * a_dim1] - stemp * temp; } } } } else if (lsame_(direct, "B", 1L, 1L)) { for (j = *n - 1; j >= 1; --j) { ctemp = c__[j]; stemp = s[j]; if (ctemp != 1. || stemp != 0.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { temp = a[i__ + j * a_dim1]; a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + ctemp * temp; a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * a_dim1] - stemp * temp; } } } } } } return 0; } int dlasrt_(id, n, d__, info, id_len) char *id; integer *n; doublereal *d__; integer *info; ftnlen id_len; { integer i__1, i__2; static integer endd, i__, j; extern logical lsame_(); static integer stack[64] ; static doublereal dmnmx, d1, d2, d3; static integer start; extern int xerbla_(); static integer stkpnt, dir; static doublereal tmp; --d__; *info = 0; dir = -1; if (lsame_(id, "D", 1L, 1L)) { dir = 0; } else if (lsame_(id, "I", 1L, 1L)) { dir = 1; } if (dir == -1) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("DLASRT", &i__1, 6L); return 0; } if (*n <= 1) { return 0; } stkpnt = 1; stack[0] = 1; stack[1] = *n; L10: start = stack[(stkpnt << 1) - 2]; endd = stack[(stkpnt << 1) - 1]; --stkpnt; if (endd - start <= 20 && endd - start > 0) { if (dir == 0) { i__1 = endd; for (i__ = start + 1; i__ <= i__1; ++i__) { i__2 = start + 1; for (j = i__; j >= i__2; --j) { if (d__[j] > d__[j - 1]) { dmnmx = d__[j]; d__[j] = d__[j - 1]; d__[j - 1] = dmnmx; } else { goto L30; } } L30: ; } } else { i__1 = endd; for (i__ = start + 1; i__ <= i__1; ++i__) { i__2 = start + 1; for (j = i__; j >= i__2; --j) { if (d__[j] < d__[j - 1]) { dmnmx = d__[j]; d__[j] = d__[j - 1]; d__[j - 1] = dmnmx; } else { goto L50; } } L50: ; } } } else if (endd - start > 20) { d1 = d__[start]; d2 = d__[endd]; i__ = (start + endd) / 2; d3 = d__[i__]; if (d1 < d2) { if (d3 < d1) { dmnmx = d1; } else if (d3 < d2) { dmnmx = d3; } else { dmnmx = d2; } } else { if (d3 < d2) { dmnmx = d2; } else if (d3 < d1) { dmnmx = d3; } else { dmnmx = d1; } } if (dir == 0) { i__ = start - 1; j = endd + 1; L60: L70: --j; if (d__[j] < dmnmx) { goto L70; } L80: ++i__; if (d__[i__] > dmnmx) { goto L80; } if (i__ < j) { tmp = d__[i__]; d__[i__] = d__[j]; d__[j] = tmp; goto L60; } if (j - start > endd - j - 1) { ++stkpnt; stack[(stkpnt << 1) - 2] = start; stack[(stkpnt << 1) - 1] = j; ++stkpnt; stack[(stkpnt << 1) - 2] = j + 1; stack[(stkpnt << 1) - 1] = endd; } else { ++stkpnt; stack[(stkpnt << 1) - 2] = j + 1; stack[(stkpnt << 1) - 1] = endd; ++stkpnt; stack[(stkpnt << 1) - 2] = start; stack[(stkpnt << 1) - 1] = j; } } else { i__ = start - 1; j = endd + 1; L90: L100: --j; if (d__[j] > dmnmx) { goto L100; } L110: ++i__; if (d__[i__] < dmnmx) { goto L110; } if (i__ < j) { tmp = d__[i__]; d__[i__] = d__[j]; d__[j] = tmp; goto L90; } if (j - start > endd - j - 1) { ++stkpnt; stack[(stkpnt << 1) - 2] = start; stack[(stkpnt << 1) - 1] = j; ++stkpnt; stack[(stkpnt << 1) - 2] = j + 1; stack[(stkpnt << 1) - 1] = endd; } else { ++stkpnt; stack[(stkpnt << 1) - 2] = j + 1; stack[(stkpnt << 1) - 1] = endd; ++stkpnt; stack[(stkpnt << 1) - 2] = start; stack[(stkpnt << 1) - 1] = j; } } } if (stkpnt > 0) { goto L10; } return 0; } int dlassq_(n, x, incx, scale, sumsq) integer *n; doublereal *x; integer *incx; doublereal *scale, *sumsq; { integer i__1, i__2; doublereal d__1; static doublereal absxi; static integer ix; --x; if (*n > 0) { i__1 = (*n - 1) * *incx + 1; i__2 = *incx; for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { if (x[ix] != 0.) { absxi = (d__1 = x[ix], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (*scale < absxi) { d__1 = *scale / absxi; *sumsq = *sumsq * (d__1 * d__1) + 1; *scale = absxi; } else { d__1 = absxi / *scale; *sumsq += d__1 * d__1; } } } } return 0; } int dlatrs_(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info, uplo_len, trans_len, diag_len, normin_len) char *uplo, *trans, *diag, *normin; integer *n; doublereal *a; integer *lda; doublereal *x, *scale, *cnorm; integer *info; ftnlen uplo_len; ftnlen trans_len; ftnlen diag_len; ftnlen normin_len; { integer a_dim1, a_offset, i__1, i__2, i__3; doublereal d__1, d__2, d__3; static integer jinc; extern doublereal ddot_(); static doublereal xbnd; static integer imax; static doublereal tmax, tjjs, xmax, grow, sumj; static integer i__, j; extern int dscal_(); extern logical lsame_(); static doublereal tscal, uscal; extern doublereal dasum_(); static integer jlast; extern int daxpy_(); static logical upper; extern int dtrsv_(); extern doublereal dlamch_(); static doublereal xj; extern integer idamax_(); extern int xerbla_(); static doublereal bignum; static logical notran; static integer jfirst; static doublereal smlnum; static logical nounit; static doublereal rec, tjj; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --x; --cnorm; *info = 0; upper = lsame_(uplo, "U", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); nounit = lsame_(diag, "N", 1L, 1L); if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L, 1L)) { *info = -2; } else if (! nounit && ! lsame_(diag, "U", 1L, 1L)) { *info = -3; } else if (! lsame_(normin, "Y", 1L, 1L) && ! lsame_(normin, "N", 1L, 1L)) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("DLATRS", &i__1, 6L); return 0; } if (*n == 0) { return 0; } smlnum = dlamch_("Safe minimum", 12L) / dlamch_("Precision", 9L); bignum = 1. / smlnum; *scale = 1.; if (lsame_(normin, "N", 1L, 1L)) { if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1); } } else { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); } cnorm[*n] = 0.; } } imax = idamax_(n, &cnorm[1], &c__1); tmax = cnorm[imax]; if (tmax <= bignum) { tscal = 1.; } else { tscal = 1. / (smlnum * tmax); dscal_(n, &tscal, &cnorm[1], &c__1); } j = idamax_(n, &x[1], &c__1); xmax = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); xbnd = xmax; if (notran) { if (upper) { jfirst = *n; jlast = 1; jinc = -1; } else { jfirst = 1; jlast = *n; jinc = 1; } if (tscal != 1.) { grow = 0.; goto L50; } if (nounit) { grow = 1. / (( xbnd ) >= ( smlnum ) ? ( xbnd ) : ( smlnum )) ; xbnd = grow; i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { if (grow <= smlnum) { goto L50; } tjj = (d__1 = a[j + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); d__1 = xbnd, d__2 = (( 1. ) <= ( tjj ) ? ( 1. ) : ( tjj )) * grow; xbnd = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (tjj + cnorm[j] >= smlnum) { grow *= tjj / (tjj + cnorm[j]); } else { grow = 0.; } } grow = xbnd; } else { d__1 = 1., d__2 = 1. / (( xbnd ) >= ( smlnum ) ? ( xbnd ) : ( smlnum )) ; grow = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { if (grow <= smlnum) { goto L50; } grow *= 1. / (cnorm[j] + 1.); } } L50: ; } else { if (upper) { jfirst = 1; jlast = *n; jinc = 1; } else { jfirst = *n; jlast = 1; jinc = -1; } if (tscal != 1.) { grow = 0.; goto L80; } if (nounit) { grow = 1. / (( xbnd ) >= ( smlnum ) ? ( xbnd ) : ( smlnum )) ; xbnd = grow; i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { if (grow <= smlnum) { goto L80; } xj = cnorm[j] + 1.; d__1 = grow, d__2 = xbnd / xj; grow = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; tjj = (d__1 = a[j + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (xj > tjj) { xbnd *= tjj / xj; } } grow = (( grow ) <= ( xbnd ) ? ( grow ) : ( xbnd )) ; } else { d__1 = 1., d__2 = 1. / (( xbnd ) >= ( smlnum ) ? ( xbnd ) : ( smlnum )) ; grow = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { if (grow <= smlnum) { goto L80; } xj = cnorm[j] + 1.; grow /= xj; } } L80: ; } if (grow * tscal > smlnum) { dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, 1L, 1L, 1L); } else { if (xmax > bignum) { *scale = bignum / xmax; dscal_(n, scale, &x[1], &c__1); xmax = bignum; } if (notran) { i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (nounit) { tjjs = a[j + j * a_dim1] * tscal; } else { tjjs = tscal; if (tscal == 1.) { goto L100; } } tjj = (( tjjs ) >= 0 ? ( tjjs ) : -( tjjs )) ; if (tjj > smlnum) { if (tjj < 1.) { if (xj > tjj * bignum) { rec = 1. / xj; dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j] /= tjjs; xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } else if (tjj > 0.) { if (xj > tjj * bignum) { rec = tjj * bignum / xj; if (cnorm[j] > 1.) { rec /= cnorm[j]; } dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } x[j] /= tjjs; xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } else { i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { x[i__] = 0.; } x[j] = 1.; xj = 1.; *scale = 0.; xmax = 0.; } L100: if (xj > 1.) { rec = 1. / xj; if (cnorm[j] > (bignum - xmax) * rec) { rec *= .5; dscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } else if (xj * cnorm[j] > bignum - xmax) { dscal_(n, &c_b806, &x[1], &c__1); *scale *= .5; } if (upper) { if (j > 1) { i__3 = j - 1; d__1 = -x[j] * tscal; daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); i__3 = j - 1; i__ = idamax_(&i__3, &x[1], &c__1); xmax = (d__1 = x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } else { if (j < *n) { i__3 = *n - j; d__1 = -x[j] * tscal; daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, & x[j + 1], &c__1); i__3 = *n - j; i__ = j + idamax_(&i__3, &x[j + 1], &c__1); xmax = (d__1 = x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } } } else { i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); uscal = tscal; rec = 1. / (( xmax ) >= ( 1. ) ? ( xmax ) : ( 1. )) ; if (cnorm[j] > (bignum - xj) * rec) { rec *= .5; if (nounit) { tjjs = a[j + j * a_dim1] * tscal; } else { tjjs = tscal; } tjj = (( tjjs ) >= 0 ? ( tjjs ) : -( tjjs )) ; if (tjj > 1.) { d__1 = 1., d__2 = rec * tjj; rec = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; uscal /= tjjs; } if (rec < 1.) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } sumj = 0.; if (uscal == 1.) { if (upper) { i__3 = j - 1; sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); } else if (j < *n) { i__3 = *n - j; sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[ j + 1], &c__1); } } else { if (upper) { i__3 = j - 1; for (i__ = 1; i__ <= i__3; ++i__) { sumj += a[i__ + j * a_dim1] * uscal * x[i__]; } } else if (j < *n) { i__3 = *n; for (i__ = j + 1; i__ <= i__3; ++i__) { sumj += a[i__ + j * a_dim1] * uscal * x[i__]; } } } if (uscal == tscal) { x[j] -= sumj; xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (nounit) { tjjs = a[j + j * a_dim1] * tscal; } else { tjjs = tscal; if (tscal == 1.) { goto L150; } } tjj = (( tjjs ) >= 0 ? ( tjjs ) : -( tjjs )) ; if (tjj > smlnum) { if (tjj < 1.) { if (xj > tjj * bignum) { rec = 1. / xj; dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j] /= tjjs; } else if (tjj > 0.) { if (xj > tjj * bignum) { rec = tjj * bignum / xj; dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } x[j] /= tjjs; } else { i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { x[i__] = 0.; } x[j] = 1.; *scale = 0.; xmax = 0.; } L150: ; } else { x[j] = x[j] / tjjs - sumj; } d__2 = xmax, d__3 = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); xmax = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } } *scale /= tscal; } if (tscal != 1.) { d__1 = 1. / tscal; dscal_(n, &d__1, &cnorm[1], &c__1); } return 0; } int dopgtr_(uplo, n, ap, tau, q, ldq, work, info, uplo_len) char *uplo; integer *n; doublereal *ap, *tau, *q; integer *ldq; doublereal *work; integer *info; ftnlen uplo_len; { integer q_dim1, q_offset, i__1, i__2, i__3; static integer i__, j; extern logical lsame_(); static integer iinfo; static logical upper; extern int dorg2l_(), dorg2r_(); static integer ij; extern int xerbla_(); --ap; --tau; q_dim1 = *ldq; q_offset = q_dim1 + 1; q -= q_offset; --work; *info = 0; upper = lsame_(uplo, "U", 1L, 1L); if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ldq < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("DOPGTR", &i__1, 6L); return 0; } if (*n == 0) { return 0; } if (upper) { ij = 2; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { q[i__ + j * q_dim1] = ap[ij]; ++ij; } ij += 2; q[*n + j * q_dim1] = 0.; } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { q[i__ + *n * q_dim1] = 0.; } q[*n + *n * q_dim1] = 1.; i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; dorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & iinfo); } else { q[q_dim1 + 1] = 1.; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { q[i__ + q_dim1] = 0.; } ij = 3; i__1 = *n; for (j = 2; j <= i__1; ++j) { q[j * q_dim1 + 1] = 0.; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { q[i__ + j * q_dim1] = ap[ij]; ++ij; } ij += 2; } if (*n > 1) { i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; dorg2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], &work[1], &iinfo); } } return 0; } int dorg2l_(m, n, k, a, lda, tau, work, info) integer *m, *n, *k; doublereal *a; integer *lda; doublereal *tau, *work; integer *info; { integer a_dim1, a_offset, i__1, i__2, i__3; doublereal d__1; static integer i__, j, l; extern int dscal_(), dlarf_(); static integer ii; extern int xerbla_(); a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0 || *n > *m) { *info = -2; } else if (*k < 0 || *k > *n) { *info = -3; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("DORG2L", &i__1, 6L); return 0; } if (*n <= 0) { return 0; } i__1 = *n - *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (l = 1; l <= i__2; ++l) { a[l + j * a_dim1] = 0.; } a[*m - *n + j + j * a_dim1] = 1.; } i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { ii = *n - *k + i__; a[*m - *n + ii + ii * a_dim1] = 1.; i__2 = *m - *n + ii; i__3 = ii - 1; dlarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & a[a_offset], lda, &work[1], 4L); i__2 = *m - *n + ii - 1; d__1 = -tau[i__]; dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1); a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__]; i__2 = *m; for (l = *m - *n + ii + 1; l <= i__2; ++l) { a[l + ii * a_dim1] = 0.; } } return 0; } int dorg2r_(m, n, k, a, lda, tau, work, info) integer *m, *n, *k; doublereal *a; integer *lda; doublereal *tau, *work; integer *info; { integer a_dim1, a_offset, i__1, i__2; doublereal d__1; static integer i__, j, l; extern int dscal_(), dlarf_(), xerbla_(); a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; --work; *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0 || *n > *m) { *info = -2; } else if (*k < 0 || *k > *n) { *info = -3; } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("DORG2R", &i__1, 6L); return 0; } if (*n <= 0) { return 0; } i__1 = *n; for (j = *k + 1; j <= i__1; ++j) { i__2 = *m; for (l = 1; l <= i__2; ++l) { a[l + j * a_dim1] = 0.; } a[j + j * a_dim1] = 1.; } for (i__ = *k; i__ >= 1; --i__) { if (i__ < *n) { a[i__ + i__ * a_dim1] = 1.; i__1 = *m - i__ + 1; i__2 = *n - i__; dlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L); } if (i__ < *m) { i__1 = *m - i__; d__1 = -tau[i__]; dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1); } a[i__ + i__ * a_dim1] = 1. - tau[i__]; i__1 = i__ - 1; for (l = 1; l <= i__1; ++l) { a[l + i__ * a_dim1] = 0.; } } return 0; } int dorm2r_(side, trans, m, n, k, a, lda, tau, c__, ldc, work, info, side_len, trans_len) char *side, *trans; integer *m, *n, *k; doublereal *a; integer *lda; doublereal *tau, *c__; integer *ldc; doublereal *work; integer *info; ftnlen side_len; ftnlen trans_len; { integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; static logical left; static integer i__; extern int dlarf_(); extern logical lsame_(); static integer i1, i2, i3, ic, jc, mi, ni, nq; extern int xerbla_(); static logical notran; static doublereal aii; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; *info = 0; left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); if (left) { nq = *m; } else { nq = *n; } if (! left && ! lsame_(side, "R", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "T", 1L, 1L)) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*lda < (( 1 ) >= ( nq ) ? ( 1 ) : ( nq )) ) { *info = -7; } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("DORM2R", &i__1, 6L); return 0; } if (*m == 0 || *n == 0 || *k == 0) { return 0; } if (left && ! notran || ! left && notran) { i1 = 1; i2 = *k; i3 = 1; } else { i1 = *k; i2 = 1; i3 = -1; } if (left) { ni = *n; jc = 1; } else { mi = *m; ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { if (left) { mi = *m - i__ + 1; ic = i__; } else { ni = *n - i__ + 1; jc = i__; } aii = a[i__ + i__ * a_dim1]; a[i__ + i__ * a_dim1] = 1.; dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ ic + jc * c_dim1], ldc, &work[1], 1L); a[i__ + i__ * a_dim1] = aii; } return 0; } int dorml2_(side, trans, m, n, k, a, lda, tau, c__, ldc, work, info, side_len, trans_len) char *side, *trans; integer *m, *n, *k; doublereal *a; integer *lda; doublereal *tau, *c__; integer *ldc; doublereal *work; integer *info; ftnlen side_len; ftnlen trans_len; { integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; static logical left; static integer i__; extern int dlarf_(); extern logical lsame_(); static integer i1, i2, i3, ic, jc, mi, ni, nq; extern int xerbla_(); static logical notran; static doublereal aii; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; *info = 0; left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); if (left) { nq = *m; } else { nq = *n; } if (! left && ! lsame_(side, "R", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "T", 1L, 1L)) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*lda < (( 1 ) >= ( *k ) ? ( 1 ) : ( *k )) ) { *info = -7; } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("DORML2", &i__1, 6L); return 0; } if (*m == 0 || *n == 0 || *k == 0) { return 0; } if (left && notran || ! left && ! notran) { i1 = 1; i2 = *k; i3 = 1; } else { i1 = *k; i2 = 1; i3 = -1; } if (left) { ni = *n; jc = 1; } else { mi = *m; ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { if (left) { mi = *m - i__ + 1; ic = i__; } else { ni = *n - i__ + 1; jc = i__; } aii = a[i__ + i__ * a_dim1]; a[i__ + i__ * a_dim1] = 1.; dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ ic + jc * c_dim1], ldc, &work[1], 1L); a[i__ + i__ * a_dim1] = aii; } return 0; } int dormlq_(side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, side_len, trans_len) char *side, *trans; integer *m, *n, *k; doublereal *a; integer *lda; doublereal *tau, *c__; integer *ldc; doublereal *work; integer *lwork, *info; ftnlen side_len; ftnlen trans_len; { address a__1[2]; integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5; char ch__1[2]; int s_cat(); static logical left; static integer i__; static doublereal t[4160] ; extern logical lsame_(); static integer nbmin, iinfo, i1, i2, i3; extern int dorml2_(); static integer ib, ic, jc, nb, mi, ni; extern int dlarfb_(); static integer nq, nw; extern int dlarft_(), xerbla_(); extern integer ilaenv_(); static logical notran; static integer ldwork; static char transt[1]; static integer iws; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; *info = 0; left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); if (left) { nq = *m; nw = *n; } else { nq = *n; nw = *m; } if (! left && ! lsame_(side, "R", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "T", 1L, 1L)) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*lda < (( 1 ) >= ( *k ) ? ( 1 ) : ( *k )) ) { *info = -7; } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -10; } else if (*lwork < (( 1 ) >= ( nw ) ? ( 1 ) : ( nw )) ) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("DORMLQ", &i__1, 6L); return 0; } if (*m == 0 || *n == 0 || *k == 0) { work[1] = 1.; return 0; } i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, 2L); i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1, 6L, 2L); nb = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { iws = nw * nb; if (*lwork < iws) { nb = *lwork / ldwork; i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, 2L); i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1, 6L, 2L); nbmin = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } } else { iws = nw; } if (nb < nbmin || nb >= *k) { dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], &iinfo, 1L, 1L); } else { if (left && notran || ! left && ! notran) { i1 = 1; i2 = *k; i3 = nb; } else { i1 = (*k - 1) / nb * nb + 1; i2 = 1; i3 = -nb; } if (left) { ni = *n; jc = 1; } else { mi = *m; ic = 1; } if (notran) { *(unsigned char *)transt = 'T'; } else { *(unsigned char *)transt = 'N'; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { i__4 = nb, i__5 = *k - i__ + 1; ib = (( i__4 ) <= ( i__5 ) ? ( i__4 ) : ( i__5 )) ; i__4 = nq - i__ + 1; dlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], t, &c__65, 7L, 7L); if (left) { mi = *m - i__ + 1; ic = i__; } else { ni = *n - i__ + 1; jc = i__; } dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork, 1L, 1L, 7L, 7L); } } work[1] = (doublereal) iws; return 0; } int dormqr_(side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, side_len, trans_len) char *side, *trans; integer *m, *n, *k; doublereal *a; integer *lda; doublereal *tau, *c__; integer *ldc; doublereal *work; integer *lwork, *info; ftnlen side_len; ftnlen trans_len; { address a__1[2]; integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, i__5; char ch__1[2]; int s_cat(); static logical left; static integer i__; static doublereal t[4160] ; extern logical lsame_(); static integer nbmin, iinfo, i1, i2, i3; extern int dorm2r_(); static integer ib, ic, jc, nb, mi, ni; extern int dlarfb_(); static integer nq, nw; extern int dlarft_(), xerbla_(); extern integer ilaenv_(); static logical notran; static integer ldwork, iws; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --tau; c_dim1 = *ldc; c_offset = c_dim1 + 1; c__ -= c_offset; --work; *info = 0; left = lsame_(side, "L", 1L, 1L); notran = lsame_(trans, "N", 1L, 1L); if (left) { nq = *m; nw = *n; } else { nq = *n; nw = *m; } if (! left && ! lsame_(side, "R", 1L, 1L)) { *info = -1; } else if (! notran && ! lsame_(trans, "T", 1L, 1L)) { *info = -2; } else if (*m < 0) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*k < 0 || *k > nq) { *info = -5; } else if (*lda < (( 1 ) >= ( nq ) ? ( 1 ) : ( nq )) ) { *info = -7; } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { *info = -10; } else if (*lwork < (( 1 ) >= ( nw ) ? ( 1 ) : ( nw )) ) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("DORMQR", &i__1, 6L); return 0; } if (*m == 0 || *n == 0 || *k == 0) { work[1] = 1.; return 0; } i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, 2L); i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1, 6L, 2L); nb = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; nbmin = 2; ldwork = nw; if (nb > 1 && nb < *k) { iws = nw * nb; if (*lwork < iws) { nb = *lwork / ldwork; i__3[0] = 1, a__1[0] = side; i__3[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__3, &c__2, 2L); i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1, 6L, 2L); nbmin = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } } else { iws = nw; } if (nb < nbmin || nb >= *k) { dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ c_offset], ldc, &work[1], &iinfo, 1L, 1L); } else { if (left && ! notran || ! left && notran) { i1 = 1; i2 = *k; i3 = nb; } else { i1 = (*k - 1) / nb * nb + 1; i2 = 1; i3 = -nb; } if (left) { ni = *n; jc = 1; } else { mi = *m; ic = 1; } i__1 = i2; i__2 = i3; for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { i__4 = nb, i__5 = *k - i__ + 1; ib = (( i__4 ) <= ( i__5 ) ? ( i__4 ) : ( i__5 )) ; i__4 = nq - i__ + 1; dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], t, &c__65, 7L, 10L); if (left) { mi = *m - i__ + 1; ic = i__; } else { ni = *n - i__ + 1; jc = i__; } dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork, 1L, 1L, 7L, 10L); } } work[1] = (doublereal) iws; return 0; } int dpptrf_(uplo, n, ap, info, uplo_len) char *uplo; integer *n; doublereal *ap; integer *info; ftnlen uplo_len; { integer i__1, i__2; doublereal d__1; double sqrt(); extern doublereal ddot_(); extern int dspr_(); static integer j; extern int dscal_(); extern logical lsame_(); static logical upper; extern int dtpsv_(); static integer jc, jj; extern int xerbla_(); static doublereal ajj; --ap; *info = 0; upper = lsame_(uplo, "U", 1L, 1L); if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("DPPTRF", &i__1, 6L); return 0; } if (*n == 0) { return 0; } if (upper) { jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { jc = jj + 1; jj += j; if (j > 1) { i__2 = j - 1; dtpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[ jc], &c__1, 5L, 9L, 8L); } i__2 = j - 1; ajj = ap[jj] - ddot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1); if (ajj <= 0.) { ap[jj] = ajj; goto L30; } ap[jj] = sqrt(ajj); } } else { jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { ajj = ap[jj]; if (ajj <= 0.) { ap[jj] = ajj; goto L30; } ajj = sqrt(ajj); ap[jj] = ajj; if (j < *n) { i__2 = *n - j; d__1 = 1. / ajj; dscal_(&i__2, &d__1, &ap[jj + 1], &c__1); i__2 = *n - j; dspr_("Lower", &i__2, &c_b418, &ap[jj + 1], &c__1, &ap[jj + * n - j + 1], 5L); jj = jj + *n - j + 1; } } } goto L40; L30: *info = j; L40: return 0; } int drscl_(n, sa, sx, incx) integer *n; doublereal *sa, *sx; integer *incx; { static doublereal cden; static logical done; static doublereal cnum, cden1, cnum1; extern int dscal_(), dlabad_(); extern doublereal dlamch_(); static doublereal bignum, smlnum, mul; --sx; if (*n <= 0) { return 0; } smlnum = dlamch_("S", 1L); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); cden = *sa; cnum = 1.; L10: cden1 = cden * smlnum; cnum1 = cnum / bignum; if ((( cden1 ) >= 0 ? ( cden1 ) : -( cden1 )) > (( cnum ) >= 0 ? ( cnum ) : -( cnum )) && cnum != 0.) { mul = smlnum; done = (0) ; cden = cden1; } else if ((( cnum1 ) >= 0 ? ( cnum1 ) : -( cnum1 )) > (( cden ) >= 0 ? ( cden ) : -( cden )) ) { mul = bignum; done = (0) ; cnum = cnum1; } else { mul = cnum / cden; done = (1) ; } dscal_(n, &mul, &sx[1], incx); if (! done) { goto L10; } return 0; } int dspev_(jobz, uplo, n, ap, w, z__, ldz, work, info, jobz_len, uplo_len) char *jobz, *uplo; integer *n; doublereal *ap, *w, *z__; integer *ldz; doublereal *work; integer *info; ftnlen jobz_len; ftnlen uplo_len; { integer z_dim1, z_offset, i__1; doublereal d__1; double sqrt(); static integer inde; static doublereal anrm; static integer imax; static doublereal rmin, rmax; extern int dscal_(); static doublereal sigma; extern logical lsame_(); static integer iinfo; static logical wantz; extern doublereal dlamch_(); static integer iscale; static doublereal safmin; extern int xerbla_(); static doublereal bignum; extern doublereal dlansp_(); static integer indtau; extern int dsterf_(); static integer indwrk; extern int dopgtr_(), dsptrd_(), dsteqr_(); static doublereal smlnum, eps; --ap; --w; z_dim1 = *ldz; z_offset = z_dim1 + 1; z__ -= z_offset; --work; wantz = lsame_(jobz, "V", 1L, 1L); *info = 0; if (! (wantz || lsame_(jobz, "N", 1L, 1L))) { *info = -1; } else if (! (lsame_(uplo, "U", 1L, 1L) || lsame_(uplo, "L", 1L, 1L))) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPEV ", &i__1, 6L); return 0; } if (*n == 0) { return 0; } if (*n == 1) { w[1] = ap[1]; if (wantz) { z__[z_dim1 + 1] = 1.; } return 0; } safmin = dlamch_("Safe minimum", 12L); eps = dlamch_("Precision", 9L); smlnum = safmin / eps; bignum = 1. / smlnum; rmin = sqrt(smlnum); rmax = sqrt(bignum); anrm = dlansp_("M", uplo, n, &ap[1], &work[1], 1L, 1L); iscale = 0; if (anrm > 0. && anrm < rmin) { iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { iscale = 1; sigma = rmax / anrm; } if (iscale == 1) { i__1 = *n * (*n + 1) / 2; dscal_(&i__1, &sigma, &ap[1], &c__1); } inde = 1; indtau = inde + *n; dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo, 1L); if (! wantz) { dsterf_(n, &w[1], &work[inde], info); } else { indwrk = indtau + *n; dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[ indwrk], &iinfo, 1L); dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ indtau], info, 1L); } if (iscale == 1) { if (*info == 0) { imax = *n; } else { imax = *info - 1; } d__1 = 1. / sigma; dscal_(&imax, &d__1, &w[1], &c__1); } return 0; } int dspgst_(itype, uplo, n, ap, bp, info, uplo_len) integer *itype; char *uplo; integer *n; doublereal *ap, *bp; integer *info; ftnlen uplo_len; { integer i__1, i__2; doublereal d__1; extern doublereal ddot_(); extern int dspr2_(); static integer j, k; extern int dscal_(); extern logical lsame_(); extern int daxpy_(), dspmv_(); static logical upper; static integer j1, k1; extern int dtpmv_(), dtpsv_(); static integer jj, kk; static doublereal ct; extern int xerbla_(); static doublereal ajj; static integer j1j1; static doublereal akk; static integer k1k1; static doublereal bjj, bkk; --bp; --ap; *info = 0; upper = lsame_(uplo, "U", 1L, 1L); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGST", &i__1, 6L); return 0; } if (*itype == 1) { if (upper) { jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1 = jj + 1; jj += j; bjj = bp[jj]; dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], & c__1, 1L, 9L, 7L); i__2 = j - 1; dspmv_(uplo, &i__2, &c_b418, &ap[1], &bp[j1], &c__1, &c_b89, & ap[j1], &c__1, 1L); i__2 = j - 1; d__1 = 1. / bjj; dscal_(&i__2, &d__1, &ap[j1], &c__1); i__2 = j - 1; ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], & c__1)) / bjj; } } else { kk = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1k1 = kk + *n - k + 1; akk = ap[kk]; bkk = bp[kk]; d__1 = bkk; akk /= d__1 * d__1; ap[kk] = akk; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; dscal_(&i__2, &d__1, &ap[kk + 1], &c__1); ct = akk * -.5; i__2 = *n - k; daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; dspr2_(uplo, &i__2, &c_b418, &ap[kk + 1], &c__1, &bp[kk + 1], &c__1, &ap[k1k1], 1L); i__2 = *n - k; daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1, 1L, 12L, 8L); } kk = k1k1; } } } else { if (upper) { kk = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1 = kk + 1; kk += k; akk = ap[kk]; bkk = bp[kk]; i__2 = k - 1; dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1, 1L, 12L, 8L); ct = akk * .5; i__2 = k - 1; daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; dspr2_(uplo, &i__2, &c_b89, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1], 1L); i__2 = k - 1; daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; dscal_(&i__2, &bkk, &ap[k1], &c__1); d__1 = bkk; ap[kk] = akk * (d__1 * d__1); } } else { jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1j1 = jj + *n - j + 1; ajj = ap[jj]; bjj = bp[jj]; i__2 = *n - j; ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); i__2 = *n - j; dscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; dspmv_(uplo, &i__2, &c_b89, &ap[j1j1], &bp[jj + 1], &c__1, & c_b89, &ap[jj + 1], &c__1, 1L); i__2 = *n - j + 1; dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj], &c__1, 1L, 9L, 8L); jj = j1j1; } } } return 0; } int dspgv_(itype, jobz, uplo, n, ap, bp, w, z__, ldz, work, info, jobz_len, uplo_len) integer *itype; char *jobz, *uplo; integer *n; doublereal *ap, *bp, *w, *z__; integer *ldz; doublereal *work; integer *info; ftnlen jobz_len; ftnlen uplo_len; { integer z_dim1, z_offset, i__1; static integer neig, j; extern logical lsame_(); extern int dspev_(); static char trans[1]; static logical upper; extern int dtpmv_(), dtpsv_(); static logical wantz; extern int xerbla_(), dpptrf_(), dspgst_(); --ap; --bp; --w; z_dim1 = *ldz; z_offset = z_dim1 + 1; z__ -= z_offset; --work; wantz = lsame_(jobz, "V", 1L, 1L); upper = lsame_(uplo, "U", 1L, 1L); *info = 0; if (*itype < 0 || *itype > 3) { *info = -1; } else if (! (wantz || lsame_(jobz, "N", 1L, 1L))) { *info = -2; } else if (! (upper || lsame_(uplo, "L", 1L, 1L))) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPGV ", &i__1, 6L); return 0; } if (*n == 0) { return 0; } dpptrf_(uplo, n, &bp[1], info, 1L); if (*info != 0) { *info = *n + *info; return 0; } dspgst_(itype, uplo, n, &ap[1], &bp[1], info, 1L); dspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info, 1L, 1L); if (wantz) { neig = *n; if (*info > 0) { neig = *info - 1; } if (*itype == 1 || *itype == 2) { if (upper) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'T'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1, 1L, 1L, 8L); } } else if (*itype == 3) { if (upper) { *(unsigned char *)trans = 'T'; } else { *(unsigned char *)trans = 'N'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1, 1L, 1L, 8L); } } } return 0; } int dspmv_(uplo, n, alpha, ap, x, incx, beta, y, incy, uplo_len) char *uplo; integer *n; doublereal *alpha, *ap, *x; integer *incx; doublereal *beta, *y; integer *incy; ftnlen uplo_len; { integer i__1, i__2; static integer info; static doublereal temp1, temp2; static integer i__, j, k; extern logical lsame_(); static integer kk, ix, iy, jx, jy, kx, ky; extern int xerbla_(); --y; --x; --ap; info = 0; if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) { info = 1; } else if (*n < 0) { info = 2; } else if (*incx == 0) { info = 6; } else if (*incy == 0) { info = 9; } if (info != 0) { xerbla_("DSPMV ", &info, 6L); return 0; } if (*n == 0 || *alpha == 0. && *beta == 1.) { return 0; } if (*incx > 0) { kx = 1; } else { kx = 1 - (*n - 1) * *incx; } if (*incy > 0) { ky = 1; } else { ky = 1 - (*n - 1) * *incy; } if (*beta != 1.) { if (*incy == 1) { if (*beta == 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = 0.; } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = *beta * y[i__]; } } } else { iy = ky; if (*beta == 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { y[iy] = 0.; iy += *incy; } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { y[iy] = *beta * y[iy]; iy += *incy; } } } } if (*alpha == 0.) { return 0; } kk = 1; if (lsame_(uplo, "U", 1L, 1L)) { if (*incx == 1 && *incy == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp1 = *alpha * x[j]; temp2 = 0.; k = kk; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] += temp1 * ap[k]; temp2 += ap[k] * x[i__]; ++k; } y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; kk += j; } } else { jx = kx; jy = ky; i__1 = *n; for (j = 1; j <= i__1; ++j) { temp1 = *alpha * x[jx]; temp2 = 0.; ix = kx; iy = ky; i__2 = kk + j - 2; for (k = kk; k <= i__2; ++k) { y[iy] += temp1 * ap[k]; temp2 += ap[k] * x[ix]; ix += *incx; iy += *incy; } y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; jx += *incx; jy += *incy; kk += j; } } } else { if (*incx == 1 && *incy == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp1 = *alpha * x[j]; temp2 = 0.; y[j] += temp1 * ap[kk]; k = kk + 1; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { y[i__] += temp1 * ap[k]; temp2 += ap[k] * x[i__]; ++k; } y[j] += *alpha * temp2; kk += *n - j + 1; } } else { jx = kx; jy = ky; i__1 = *n; for (j = 1; j <= i__1; ++j) { temp1 = *alpha * x[jx]; temp2 = 0.; y[jy] += temp1 * ap[kk]; ix = jx; iy = jy; i__2 = kk + *n - j; for (k = kk + 1; k <= i__2; ++k) { ix += *incx; iy += *incy; y[iy] += temp1 * ap[k]; temp2 += ap[k] * x[ix]; } y[jy] += *alpha * temp2; jx += *incx; jy += *incy; kk += *n - j + 1; } } } return 0; } int dspr_(uplo, n, alpha, x, incx, ap, uplo_len) char *uplo; integer *n; doublereal *alpha, *x; integer *incx; doublereal *ap; ftnlen uplo_len; { integer i__1, i__2; static integer info; static doublereal temp; static integer i__, j, k; extern logical lsame_(); static integer kk, ix, jx, kx; extern int xerbla_(); --ap; --x; info = 0; if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) { info = 1; } else if (*n < 0) { info = 2; } else if (*incx == 0) { info = 5; } if (info != 0) { xerbla_("DSPR ", &info, 6L); return 0; } if (*n == 0 || *alpha == 0.) { return 0; } if (*incx <= 0) { kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { kx = 1; } kk = 1; if (lsame_(uplo, "U", 1L, 1L)) { if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[j] != 0.) { temp = *alpha * x[j]; k = kk; i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { ap[k] += x[i__] * temp; ++k; } } kk += j; } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0.) { temp = *alpha * x[jx]; ix = kx; i__2 = kk + j - 1; for (k = kk; k <= i__2; ++k) { ap[k] += x[ix] * temp; ix += *incx; } } jx += *incx; kk += j; } } } else { if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[j] != 0.) { temp = *alpha * x[j]; k = kk; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { ap[k] += x[i__] * temp; ++k; } } kk = kk + *n - j + 1; } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0.) { temp = *alpha * x[jx]; ix = jx; i__2 = kk + *n - j; for (k = kk; k <= i__2; ++k) { ap[k] += x[ix] * temp; ix += *incx; } } jx += *incx; kk = kk + *n - j + 1; } } } return 0; } int dspr2_(uplo, n, alpha, x, incx, y, incy, ap, uplo_len) char *uplo; integer *n; doublereal *alpha, *x; integer *incx; doublereal *y; integer *incy; doublereal *ap; ftnlen uplo_len; { integer i__1, i__2; static integer info; static doublereal temp1, temp2; static integer i__, j, k; extern logical lsame_(); static integer kk, ix, iy, jx, jy, kx, ky; extern int xerbla_(); --ap; --y; --x; info = 0; if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) { info = 1; } else if (*n < 0) { info = 2; } else if (*incx == 0) { info = 5; } else if (*incy == 0) { info = 7; } if (info != 0) { xerbla_("DSPR2 ", &info, 6L); return 0; } if (*n == 0 || *alpha == 0.) { return 0; } if (*incx != 1 || *incy != 1) { if (*incx > 0) { kx = 1; } else { kx = 1 - (*n - 1) * *incx; } if (*incy > 0) { ky = 1; } else { ky = 1 - (*n - 1) * *incy; } jx = kx; jy = ky; } kk = 1; if (lsame_(uplo, "U", 1L, 1L)) { if (*incx == 1 && *incy == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[j] != 0. || y[j] != 0.) { temp1 = *alpha * y[j]; temp2 = *alpha * x[j]; k = kk; i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; ++k; } } kk += j; } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0. || y[jy] != 0.) { temp1 = *alpha * y[jy]; temp2 = *alpha * x[jx]; ix = kx; iy = ky; i__2 = kk + j - 1; for (k = kk; k <= i__2; ++k) { ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; ix += *incx; iy += *incy; } } jx += *incx; jy += *incy; kk += j; } } } else { if (*incx == 1 && *incy == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[j] != 0. || y[j] != 0.) { temp1 = *alpha * y[j]; temp2 = *alpha * x[j]; k = kk; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; ++k; } } kk = kk + *n - j + 1; } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0. || y[jy] != 0.) { temp1 = *alpha * y[jy]; temp2 = *alpha * x[jx]; ix = jx; iy = jy; i__2 = kk + *n - j; for (k = kk; k <= i__2; ++k) { ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; ix += *incx; iy += *incy; } } jx += *incx; jy += *incy; kk = kk + *n - j + 1; } } } return 0; } int dsptrd_(uplo, n, ap, d__, e, tau, info, uplo_len) char *uplo; integer *n; doublereal *ap, *d__, *e, *tau; integer *info; ftnlen uplo_len; { integer i__1, i__2; extern doublereal ddot_(); static doublereal taui; extern int dspr2_(); static integer i__; static doublereal alpha; extern logical lsame_(); extern int daxpy_(), dspmv_(); static integer i1; static logical upper; static integer ii; extern int dlarfg_(), xerbla_(); static integer i1i1; --tau; --e; --d__; --ap; *info = 0; upper = lsame_(uplo, "U", 1L, 1L); if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPTRD", &i__1, 6L); return 0; } if (*n <= 0) { return 0; } if (upper) { i1 = *n * (*n - 1) / 2 + 1; for (i__ = *n - 1; i__ >= 1; --i__) { dlarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui); e[i__] = ap[i1 + i__ - 1]; if (taui != 0.) { ap[i1 + i__ - 1] = 1.; dspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b61, & tau[1], &c__1, 1L); alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &ap[i1], & c__1); daxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1); dspr2_(uplo, &i__, &c_b418, &ap[i1], &c__1, &tau[1], &c__1, & ap[1], 1L); ap[i1 + i__ - 1] = e[i__]; } d__[i__ + 1] = ap[i1 + i__]; tau[i__] = taui; i1 -= i__; } d__[1] = ap[1]; } else { ii = 1; i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { i1i1 = ii + *n - i__ + 1; i__2 = *n - i__; dlarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui); e[i__] = ap[ii + 1]; if (taui != 0.) { ap[ii + 1] = 1.; i__2 = *n - i__; dspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & c_b61, &tau[i__], &c__1, 1L); i__2 = *n - i__; alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1); i__2 = *n - i__; daxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1); i__2 = *n - i__; dspr2_(uplo, &i__2, &c_b418, &ap[ii + 1], &c__1, &tau[i__], & c__1, &ap[i1i1], 1L); ap[ii + 1] = e[i__]; } d__[i__] = ap[ii]; tau[i__] = taui; ii = i1i1; } d__[*n] = ap[ii]; } return 0; } int dsptrf_(uplo, n, ap, ipiv, info, uplo_len) char *uplo; integer *n; doublereal *ap; integer *ipiv, *info; ftnlen uplo_len; { integer i__1; doublereal d__1, d__2, d__3; double sqrt(); static integer imax, jmax; extern int drot_(), dspr_(); static doublereal c__; static integer j, k; static doublereal s, t, alpha; extern int dscal_(); extern logical lsame_(); extern int dswap_(); static integer kstep; static logical upper; static doublereal r1, r2; extern int dlaev2_(); static integer kc, kk, kp; static doublereal absakk; static integer kx; extern integer idamax_(); extern int xerbla_(); static doublereal colmax, rowmax; static integer knc, kpc, npp; --ipiv; --ap; *info = 0; upper = lsame_(uplo, "U", 1L, 1L); if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla_("DSPTRF", &i__1, 6L); return 0; } alpha = (sqrt(17.) + 1.) / 8.; if (upper) { k = *n; kc = (*n - 1) * *n / 2 + 1; L10: knc = kc; if (k < 1) { goto L70; } kstep = 1; absakk = (d__1 = ap[kc + k - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (k > 1) { i__1 = k - 1; imax = idamax_(&i__1, &ap[kc], &c__1); colmax = (d__1 = ap[kc + imax - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } else { colmax = 0.; } if ((( absakk ) >= ( colmax ) ? ( absakk ) : ( colmax )) == 0.) { if (*info == 0) { *info = k; } kp = k; } else { if (absakk >= alpha * colmax) { kp = k; } else { rowmax = 0.; jmax = imax; kx = imax * (imax + 1) / 2 + imax; i__1 = k; for (j = imax + 1; j <= i__1; ++j) { if ((d__1 = ap[kx], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > rowmax) { rowmax = (d__1 = ap[kx], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); jmax = j; } kx += j; } kpc = (imax - 1) * imax / 2 + 1; if (imax > 1) { i__1 = imax - 1; jmax = idamax_(&i__1, &ap[kpc], &c__1); d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); rowmax = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } if (absakk >= alpha * colmax * (colmax / rowmax)) { kp = k; } else if ((d__1 = ap[kpc + imax - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= alpha * rowmax) { kp = imax; } else { kp = imax; kstep = 2; } } kk = k - kstep + 1; if (kstep == 2) { knc = knc - k + 1; } if (kp != kk) { i__1 = kp - 1; dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1); kx = kpc + kp - 1; i__1 = kk - 1; for (j = kp + 1; j <= i__1; ++j) { kx = kx + j - 1; t = ap[knc + j - 1]; ap[knc + j - 1] = ap[kx]; ap[kx] = t; } t = ap[knc + kk - 1]; ap[knc + kk - 1] = ap[kpc + kp - 1]; ap[kpc + kp - 1] = t; if (kstep == 2) { t = ap[kc + k - 2]; ap[kc + k - 2] = ap[kc + kp - 1]; ap[kc + kp - 1] = t; } } if (kstep == 1) { r1 = 1. / ap[kc + k - 1]; i__1 = k - 1; d__1 = -r1; dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], 1L); i__1 = k - 1; dscal_(&i__1, &r1, &ap[kc], &c__1); } else { dlaev2_(&ap[kc - 1], &ap[kc + k - 2], &ap[kc + k - 1], &r1, & r2, &c__, &s); r1 = 1. / r1; r2 = 1. / r2; i__1 = k - 2; drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &s); i__1 = k - 2; d__1 = -r1; dspr_(uplo, &i__1, &d__1, &ap[knc], &c__1, &ap[1], 1L); i__1 = k - 2; d__1 = -r2; dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], 1L); i__1 = k - 2; dscal_(&i__1, &r1, &ap[knc], &c__1); i__1 = k - 2; dscal_(&i__1, &r2, &ap[kc], &c__1); i__1 = k - 2; d__1 = -s; drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &d__1); } } if (kstep == 1) { ipiv[k] = kp; } else { ipiv[k] = -kp; ipiv[k - 1] = -kp; } k -= kstep; kc = knc - k; goto L10; } else { k = 1; kc = 1; npp = *n * (*n + 1) / 2; L40: knc = kc; if (k > *n) { goto L70; } kstep = 1; absakk = (d__1 = ap[kc], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (k < *n) { i__1 = *n - k; imax = k + idamax_(&i__1, &ap[kc + 1], &c__1); colmax = (d__1 = ap[kc + imax - k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } else { colmax = 0.; } if ((( absakk ) >= ( colmax ) ? ( absakk ) : ( colmax )) == 0.) { if (*info == 0) { *info = k; } kp = k; } else { if (absakk >= alpha * colmax) { kp = k; } else { rowmax = 0.; kx = kc + imax - k; i__1 = imax - 1; for (j = k; j <= i__1; ++j) { if ((d__1 = ap[kx], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > rowmax) { rowmax = (d__1 = ap[kx], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); jmax = j; } kx = kx + *n - j; } kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1; if (imax < *n) { i__1 = *n - imax; jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1); d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); rowmax = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } if (absakk >= alpha * colmax * (colmax / rowmax)) { kp = k; } else if ((d__1 = ap[kpc], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= alpha * rowmax) { kp = imax; } else { kp = imax; kstep = 2; } } kk = k + kstep - 1; if (kstep == 2) { knc = knc + *n - k + 1; } if (kp != kk) { if (kp < *n) { i__1 = *n - kp; dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1], &c__1); } kx = knc + kp - kk; i__1 = kp - 1; for (j = kk + 1; j <= i__1; ++j) { kx = kx + *n - j + 1; t = ap[knc + j - kk]; ap[knc + j - kk] = ap[kx]; ap[kx] = t; } t = ap[knc]; ap[knc] = ap[kpc]; ap[kpc] = t; if (kstep == 2) { t = ap[kc + 1]; ap[kc + 1] = ap[kc + kp - k]; ap[kc + kp - k] = t; } } if (kstep == 1) { if (k < *n) { r1 = 1. / ap[kc]; i__1 = *n - k; d__1 = -r1; dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n - k + 1], 1L); i__1 = *n - k; dscal_(&i__1, &r1, &ap[kc + 1], &c__1); } } else { if (k < *n - 1) { dlaev2_(&ap[kc], &ap[kc + 1], &ap[knc], &r1, &r2, &c__, & s); r1 = 1. / r1; r2 = 1. / r2; i__1 = *n - k - 1; drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, & c__, &s); i__1 = *n - k - 1; d__1 = -r1; dspr_(uplo, &i__1, &d__1, &ap[kc + 2], &c__1, &ap[knc + * n - k], 1L); i__1 = *n - k - 1; d__1 = -r2; dspr_(uplo, &i__1, &d__1, &ap[knc + 1], &c__1, &ap[knc + * n - k], 1L); i__1 = *n - k - 1; dscal_(&i__1, &r1, &ap[kc + 2], &c__1); i__1 = *n - k - 1; dscal_(&i__1, &r2, &ap[knc + 1], &c__1); i__1 = *n - k - 1; d__1 = -s; drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, & c__, &d__1); } } } if (kstep == 1) { ipiv[k] = kp; } else { ipiv[k] = -kp; ipiv[k + 1] = -kp; } k += kstep; kc = knc + *n - k + 2; goto L40; } L70: return 0; } int dsteqr_(compz, n, d__, e, z__, ldz, work, info, compz_len) char *compz; integer *n; doublereal *d__, *e, *z__; integer *ldz; doublereal *work; integer *info; ftnlen compz_len; { integer z_dim1, z_offset, i__1, i__2; doublereal d__1, d__2; double sqrt(), d_sign(); static integer lend, jtot; extern int dlae2_(); static doublereal b, c__, f, g; static integer i__, j, k, l, m; static doublereal p, r__, s; extern logical lsame_(); extern int dlasr_(); static doublereal anorm; extern int dswap_(); static integer l1; extern int dlaev2_(); static integer lendm1, lendp1; extern doublereal dlapy2_(); static integer ii; extern doublereal dlamch_(); static integer mm, iscale; extern int dlascl_(), dlaset_(); static doublereal safmin; extern int dlartg_(); static doublereal safmax; extern int xerbla_(); extern doublereal dlanst_(); extern int dlasrt_(); static integer lendsv; static doublereal ssfmin; static integer nmaxit, icompz; static doublereal ssfmax; static integer lm1, mm1, nm1; static doublereal rt1, rt2, eps; static integer lsv; static doublereal tst, eps2; --d__; --e; z_dim1 = *ldz; z_offset = z_dim1 + 1; z__ -= z_offset; --work; *info = 0; if (lsame_(compz, "N", 1L, 1L)) { icompz = 0; } else if (lsame_(compz, "V", 1L, 1L)) { icompz = 1; } else if (lsame_(compz, "I", 1L, 1L)) { icompz = 2; } else { icompz = -1; } if (icompz < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ldz < 1 || icompz > 0 && *ldz < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("DSTEQR", &i__1, 6L); return 0; } if (*n == 0) { return 0; } if (*n == 1) { if (icompz == 2) { z__[z_dim1 + 1] = 1.; } return 0; } eps = dlamch_("E", 1L); d__1 = eps; eps2 = d__1 * d__1; safmin = dlamch_("S", 1L); safmax = 1. / safmin; ssfmax = sqrt(safmax) / 3.; ssfmin = sqrt(safmin) / eps2; if (icompz == 2) { dlaset_("Full", n, n, &c_b61, &c_b89, &z__[z_offset], ldz, 4L); } nmaxit = *n * 30; jtot = 0; l1 = 1; nm1 = *n - 1; L10: if (l1 > *n) { goto L160; } if (l1 > 1) { e[l1 - 1] = 0.; } if (l1 <= nm1) { i__1 = nm1; for (m = l1; m <= i__1; ++m) { tst = (d__1 = e[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (tst == 0.) { goto L30; } if (tst <= sqrt((d__1 = d__[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) )) * sqrt((d__2 = d__[m + 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) * eps) { e[m] = 0.; goto L30; } } } m = *n; L30: l = l1; lsv = l; lend = m; lendsv = lend; l1 = m + 1; if (lend == l) { goto L10; } i__1 = lend - l + 1; anorm = dlanst_("I", &i__1, &d__[l], &e[l], 1L); iscale = 0; if (anorm == 0.) { goto L10; } if (anorm > ssfmax) { iscale = 1; i__1 = lend - l + 1; dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, info, 1L); i__1 = lend - l; dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, info, 1L); } else if (anorm < ssfmin) { iscale = 2; i__1 = lend - l + 1; dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, info, 1L); i__1 = lend - l; dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, info, 1L); } if ((d__1 = d__[lend], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < (d__2 = d__[l], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) { lend = lsv; l = lendsv; } if (lend > l) { L40: if (l != lend) { lendm1 = lend - 1; i__1 = lendm1; for (m = l; m <= i__1; ++m) { d__2 = (d__1 = e[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); tst = d__2 * d__2; if (tst <= eps2 * (d__1 = d__[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * (d__2 = d__[m + 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + safmin) { goto L60; } } } m = lend; L60: if (m < lend) { e[m] = 0.; } p = d__[l]; if (m == l) { goto L80; } if (m == l + 1) { if (icompz > 0) { dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); work[l] = c__; work[*n - 1 + l] = s; dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & z__[l * z_dim1 + 1], ldz, 1L, 1L, 1L); } else { dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); } d__[l] = rt1; d__[l + 1] = rt2; e[l] = 0.; l += 2; if (l <= lend) { goto L40; } goto L140; } if (jtot == nmaxit) { goto L140; } ++jtot; g = (d__[l + 1] - p) / (e[l] * 2.); r__ = dlapy2_(&g, &c_b89); g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); s = 1.; c__ = 1.; p = 0.; mm1 = m - 1; i__1 = l; for (i__ = mm1; i__ >= i__1; --i__) { f = s * e[i__]; b = c__ * e[i__]; dlartg_(&g, &f, &c__, &s, &r__); if (i__ != m - 1) { e[i__ + 1] = r__; } g = d__[i__ + 1] - p; r__ = (d__[i__] - g) * s + c__ * 2. * b; p = s * r__; d__[i__ + 1] = g + p; g = c__ * r__ - b; if (icompz > 0) { work[i__] = c__; work[*n - 1 + i__] = -s; } } if (icompz > 0) { mm = m - l + 1; dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l * z_dim1 + 1], ldz, 1L, 1L, 1L); } d__[l] -= p; e[l] = g; goto L40; L80: d__[l] = p; ++l; if (l <= lend) { goto L40; } goto L140; } else { L90: if (l != lend) { lendp1 = lend + 1; i__1 = lendp1; for (m = l; m >= i__1; --m) { d__2 = (d__1 = e[m - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); tst = d__2 * d__2; if (tst <= eps2 * (d__1 = d__[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * (d__2 = d__[m - 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + safmin) { goto L110; } } } m = lend; L110: if (m > lend) { e[m - 1] = 0.; } p = d__[l]; if (m == l) { goto L130; } if (m == l - 1) { if (icompz > 0) { dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) ; work[m] = c__; work[*n - 1 + m] = s; dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & z__[(l - 1) * z_dim1 + 1], ldz, 1L, 1L, 1L); } else { dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); } d__[l - 1] = rt1; d__[l] = rt2; e[l - 1] = 0.; l += -2; if (l >= lend) { goto L90; } goto L140; } if (jtot == nmaxit) { goto L140; } ++jtot; g = (d__[l - 1] - p) / (e[l - 1] * 2.); r__ = dlapy2_(&g, &c_b89); g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); s = 1.; c__ = 1.; p = 0.; lm1 = l - 1; i__1 = lm1; for (i__ = m; i__ <= i__1; ++i__) { f = s * e[i__]; b = c__ * e[i__]; dlartg_(&g, &f, &c__, &s, &r__); if (i__ != m) { e[i__ - 1] = r__; } g = d__[i__] - p; r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; p = s * r__; d__[i__] = g + p; g = c__ * r__ - b; if (icompz > 0) { work[i__] = c__; work[*n - 1 + i__] = s; } } if (icompz > 0) { mm = l - m + 1; dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m * z_dim1 + 1], ldz, 1L, 1L, 1L); } d__[l] -= p; e[lm1] = g; goto L90; L130: d__[l] = p; --l; if (l >= lend) { goto L90; } goto L140; } L140: if (iscale == 1) { i__1 = lendsv - lsv + 1; dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info, 1L); i__1 = lendsv - lsv; dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, info, 1L); } else if (iscale == 2) { i__1 = lendsv - lsv + 1; dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], n, info, 1L); i__1 = lendsv - lsv; dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, info, 1L); } if (jtot < nmaxit) { goto L10; } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { if (e[i__] != 0.) { ++(*info); } } goto L190; L160: if (icompz == 0) { dlasrt_("I", n, &d__[1], info, 1L); } else { i__1 = *n; for (ii = 2; ii <= i__1; ++ii) { i__ = ii - 1; k = i__; p = d__[i__]; i__2 = *n; for (j = ii; j <= i__2; ++j) { if (d__[j] < p) { k = j; p = d__[j]; } } if (k != i__) { d__[k] = d__[i__]; d__[i__] = p; dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], &c__1); } } } L190: return 0; } int dsterf_(n, d__, e, info) integer *n; doublereal *d__, *e; integer *info; { integer i__1; doublereal d__1, d__2; double sqrt(), d_sign(); static doublereal oldc; static integer lend, jtot; extern int dlae2_(); static doublereal c__; static integer i__, l, m; static doublereal p, gamma, r__, s, alpha, sigma, anorm; static integer l1, lendm1, lendp1; extern doublereal dlapy2_(); static doublereal bb; extern doublereal dlamch_(); static integer iscale; extern int dlascl_(); static doublereal oldgam, safmin; extern int xerbla_(); static doublereal safmax; extern doublereal dlanst_(); extern int dlasrt_(); static integer lendsv; static doublereal ssfmin; static integer nmaxit; static doublereal ssfmax; static integer lm1, mm1, nm1; static doublereal rt1, rt2, eps, rte; static integer lsv; static doublereal tst, eps2; --e; --d__; *info = 0; if (*n < 0) { *info = -1; i__1 = -(*info); xerbla_("DSTERF", &i__1, 6L); return 0; } if (*n <= 1) { return 0; } eps = dlamch_("E", 1L); d__1 = eps; eps2 = d__1 * d__1; safmin = dlamch_("S", 1L); safmax = 1. / safmin; ssfmax = sqrt(safmax) / 3.; ssfmin = sqrt(safmin) / eps2; nmaxit = *n * 30; sigma = 0.; jtot = 0; l1 = 1; nm1 = *n - 1; L10: if (l1 > *n) { goto L170; } if (l1 > 1) { e[l1 - 1] = 0.; } if (l1 <= nm1) { i__1 = nm1; for (m = l1; m <= i__1; ++m) { tst = (d__1 = e[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (tst == 0.) { goto L30; } if (tst <= sqrt((d__1 = d__[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) )) * sqrt((d__2 = d__[m + 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) * eps) { e[m] = 0.; goto L30; } } } m = *n; L30: l = l1; lsv = l; lend = m; lendsv = lend; l1 = m + 1; if (lend == l) { goto L10; } i__1 = lend - l + 1; anorm = dlanst_("I", &i__1, &d__[l], &e[l], 1L); iscale = 0; if (anorm > ssfmax) { iscale = 1; i__1 = lend - l + 1; dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, info, 1L); i__1 = lend - l; dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, info, 1L); } else if (anorm < ssfmin) { iscale = 2; i__1 = lend - l + 1; dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, info, 1L); i__1 = lend - l; dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, info, 1L); } i__1 = lend - 1; for (i__ = l; i__ <= i__1; ++i__) { d__1 = e[i__]; e[i__] = d__1 * d__1; } if ((d__1 = d__[lend], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < (d__2 = d__[l], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) { lend = lsv; l = lendsv; } if (lend >= l) { L50: if (l != lend) { lendm1 = lend - 1; i__1 = lendm1; for (m = l; m <= i__1; ++m) { tst = (d__1 = e[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (tst <= eps2 * (d__1 = d__[m] * d__[m + 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) )) { goto L70; } } } m = lend; L70: if (m < lend) { e[m] = 0.; } p = d__[l]; if (m == l) { goto L90; } if (m == l + 1) { rte = sqrt(e[l]); dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); d__[l] = rt1; d__[l + 1] = rt2; e[l] = 0.; l += 2; if (l <= lend) { goto L50; } goto L150; } if (jtot == nmaxit) { goto L150; } ++jtot; rte = sqrt(e[l]); sigma = (d__[l + 1] - p) / (rte * 2.); r__ = dlapy2_(&sigma, &c_b89); sigma = p - rte / (sigma + d_sign(&r__, &sigma)); c__ = 1.; s = 0.; gamma = d__[m] - sigma; p = gamma * gamma; mm1 = m - 1; i__1 = l; for (i__ = mm1; i__ >= i__1; --i__) { bb = e[i__]; r__ = p + bb; if (i__ != m - 1) { e[i__ + 1] = s * r__; } oldc = c__; c__ = p / r__; s = bb / r__; oldgam = gamma; alpha = d__[i__]; gamma = c__ * (alpha - sigma) - s * oldgam; d__[i__ + 1] = oldgam + (alpha - gamma); if (c__ != 0.) { p = gamma * gamma / c__; } else { p = oldc * bb; } } e[l] = s * p; d__[l] = sigma + gamma; goto L50; L90: d__[l] = p; ++l; if (l <= lend) { goto L50; } goto L150; } else { L100: if (l != lend) { lendp1 = lend + 1; i__1 = lendp1; for (m = l; m >= i__1; --m) { tst = (d__1 = e[m - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (tst <= eps2 * (d__1 = d__[m] * d__[m - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) )) { goto L120; } } } m = lend; L120: if (m > lend) { e[m - 1] = 0.; } p = d__[l]; if (m == l) { goto L140; } if (m == l - 1) { rte = sqrt(e[l - 1]); dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); d__[l] = rt1; d__[l - 1] = rt2; e[l - 1] = 0.; l += -2; if (l >= lend) { goto L100; } goto L150; } if (jtot == nmaxit) { goto L150; } ++jtot; rte = sqrt(e[l - 1]); sigma = (d__[l - 1] - p) / (rte * 2.); r__ = dlapy2_(&sigma, &c_b89); sigma = p - rte / (sigma + d_sign(&r__, &sigma)); c__ = 1.; s = 0.; gamma = d__[m] - sigma; p = gamma * gamma; lm1 = l - 1; i__1 = lm1; for (i__ = m; i__ <= i__1; ++i__) { bb = e[i__]; r__ = p + bb; if (i__ != m) { e[i__ - 1] = s * r__; } oldc = c__; c__ = p / r__; s = bb / r__; oldgam = gamma; alpha = d__[i__ + 1]; gamma = c__ * (alpha - sigma) - s * oldgam; d__[i__] = oldgam + (alpha - gamma); if (c__ != 0.) { p = gamma * gamma / c__; } else { p = oldc * bb; } } e[lm1] = s * p; d__[l] = sigma + gamma; goto L100; L140: d__[l] = p; --l; if (l >= lend) { goto L100; } goto L150; } L150: if (iscale == 1) { i__1 = lendsv - lsv + 1; dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info, 1L); } if (iscale == 2) { i__1 = lendsv - lsv + 1; dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], n, info, 1L); } if (jtot == nmaxit) { i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { if (e[i__] != 0.) { ++(*info); } } return 0; } goto L10; L170: dlasrt_("I", n, &d__[1], info, 1L); return 0; } int dtpmv_(uplo, trans, diag, n, ap, x, incx, uplo_len, trans_len, diag_len) char *uplo, *trans, *diag; integer *n; doublereal *ap, *x; integer *incx; ftnlen uplo_len; ftnlen trans_len; ftnlen diag_len; { integer i__1, i__2; static integer info; static doublereal temp; static integer i__, j, k; extern logical lsame_(); static integer kk, ix, jx, kx; extern int xerbla_(); static logical nounit; --x; --ap; info = 0; if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) { info = 1; } else if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L, 1L)) { info = 2; } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) { info = 3; } else if (*n < 0) { info = 4; } else if (*incx == 0) { info = 7; } if (info != 0) { xerbla_("DTPMV ", &info, 6L); return 0; } if (*n == 0) { return 0; } nounit = lsame_(diag, "N", 1L, 1L); if (*incx <= 0) { kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { kx = 1; } if (lsame_(trans, "N", 1L, 1L)) { if (lsame_(uplo, "U", 1L, 1L)) { kk = 1; if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[j] != 0.) { temp = x[j]; k = kk; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { x[i__] += temp * ap[k]; ++k; } if (nounit) { x[j] *= ap[kk + j - 1]; } } kk += j; } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0.) { temp = x[jx]; ix = kx; i__2 = kk + j - 2; for (k = kk; k <= i__2; ++k) { x[ix] += temp * ap[k]; ix += *incx; } if (nounit) { x[jx] *= ap[kk + j - 1]; } } jx += *incx; kk += j; } } } else { kk = *n * (*n + 1) / 2; if (*incx == 1) { for (j = *n; j >= 1; --j) { if (x[j] != 0.) { temp = x[j]; k = kk; i__1 = j + 1; for (i__ = *n; i__ >= i__1; --i__) { x[i__] += temp * ap[k]; --k; } if (nounit) { x[j] *= ap[kk - *n + j]; } } kk -= *n - j + 1; } } else { kx += (*n - 1) * *incx; jx = kx; for (j = *n; j >= 1; --j) { if (x[jx] != 0.) { temp = x[jx]; ix = kx; i__1 = kk - (*n - (j + 1)); for (k = kk; k >= i__1; --k) { x[ix] += temp * ap[k]; ix -= *incx; } if (nounit) { x[jx] *= ap[kk - *n + j]; } } jx -= *incx; kk -= *n - j + 1; } } } } else { if (lsame_(uplo, "U", 1L, 1L)) { kk = *n * (*n + 1) / 2; if (*incx == 1) { for (j = *n; j >= 1; --j) { temp = x[j]; if (nounit) { temp *= ap[kk]; } k = kk - 1; for (i__ = j - 1; i__ >= 1; --i__) { temp += ap[k] * x[i__]; --k; } x[j] = temp; kk -= j; } } else { jx = kx + (*n - 1) * *incx; for (j = *n; j >= 1; --j) { temp = x[jx]; ix = jx; if (nounit) { temp *= ap[kk]; } i__1 = kk - j + 1; for (k = kk - 1; k >= i__1; --k) { ix -= *incx; temp += ap[k] * x[ix]; } x[jx] = temp; jx -= *incx; kk -= j; } } } else { kk = 1; if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[j]; if (nounit) { temp *= ap[kk]; } k = kk + 1; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { temp += ap[k] * x[i__]; ++k; } x[j] = temp; kk += *n - j + 1; } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[jx]; ix = jx; if (nounit) { temp *= ap[kk]; } i__2 = kk + *n - j; for (k = kk + 1; k <= i__2; ++k) { ix += *incx; temp += ap[k] * x[ix]; } x[jx] = temp; jx += *incx; kk += *n - j + 1; } } } } return 0; } int dtpsv_(uplo, trans, diag, n, ap, x, incx, uplo_len, trans_len, diag_len) char *uplo, *trans, *diag; integer *n; doublereal *ap, *x; integer *incx; ftnlen uplo_len; ftnlen trans_len; ftnlen diag_len; { integer i__1, i__2; static integer info; static doublereal temp; static integer i__, j, k; extern logical lsame_(); static integer kk, ix, jx, kx; extern int xerbla_(); static logical nounit; --x; --ap; info = 0; if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) { info = 1; } else if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L, 1L)) { info = 2; } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) { info = 3; } else if (*n < 0) { info = 4; } else if (*incx == 0) { info = 7; } if (info != 0) { xerbla_("DTPSV ", &info, 6L); return 0; } if (*n == 0) { return 0; } nounit = lsame_(diag, "N", 1L, 1L); if (*incx <= 0) { kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { kx = 1; } if (lsame_(trans, "N", 1L, 1L)) { if (lsame_(uplo, "U", 1L, 1L)) { kk = *n * (*n + 1) / 2; if (*incx == 1) { for (j = *n; j >= 1; --j) { if (x[j] != 0.) { if (nounit) { x[j] /= ap[kk]; } temp = x[j]; k = kk - 1; for (i__ = j - 1; i__ >= 1; --i__) { x[i__] -= temp * ap[k]; --k; } } kk -= j; } } else { jx = kx + (*n - 1) * *incx; for (j = *n; j >= 1; --j) { if (x[jx] != 0.) { if (nounit) { x[jx] /= ap[kk]; } temp = x[jx]; ix = jx; i__1 = kk - j + 1; for (k = kk - 1; k >= i__1; --k) { ix -= *incx; x[ix] -= temp * ap[k]; } } jx -= *incx; kk -= j; } } } else { kk = 1; if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[j] != 0.) { if (nounit) { x[j] /= ap[kk]; } temp = x[j]; k = kk + 1; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { x[i__] -= temp * ap[k]; ++k; } } kk += *n - j + 1; } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0.) { if (nounit) { x[jx] /= ap[kk]; } temp = x[jx]; ix = jx; i__2 = kk + *n - j; for (k = kk + 1; k <= i__2; ++k) { ix += *incx; x[ix] -= temp * ap[k]; } } jx += *incx; kk += *n - j + 1; } } } } else { if (lsame_(uplo, "U", 1L, 1L)) { kk = 1; if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[j]; k = kk; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { temp -= ap[k] * x[i__]; ++k; } if (nounit) { temp /= ap[kk + j - 1]; } x[j] = temp; kk += j; } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[jx]; ix = kx; i__2 = kk + j - 2; for (k = kk; k <= i__2; ++k) { temp -= ap[k] * x[ix]; ix += *incx; } if (nounit) { temp /= ap[kk + j - 1]; } x[jx] = temp; jx += *incx; kk += j; } } } else { kk = *n * (*n + 1) / 2; if (*incx == 1) { for (j = *n; j >= 1; --j) { temp = x[j]; k = kk; i__1 = j + 1; for (i__ = *n; i__ >= i__1; --i__) { temp -= ap[k] * x[i__]; --k; } if (nounit) { temp /= ap[kk - *n + j]; } x[j] = temp; kk -= *n - j + 1; } } else { kx += (*n - 1) * *incx; jx = kx; for (j = *n; j >= 1; --j) { temp = x[jx]; ix = kx; i__1 = kk - (*n - (j + 1)); for (k = kk; k >= i__1; --k) { temp -= ap[k] * x[ix]; ix -= *incx; } if (nounit) { temp /= ap[kk - *n + j]; } x[jx] = temp; jx -= *incx; kk -= *n - j + 1; } } } } return 0; } int dtrcon_(norm, uplo, diag, n, a, lda, rcond, work, iwork, info, norm_len, uplo_len, diag_len) char *norm, *uplo, *diag; integer *n; doublereal *a; integer *lda; doublereal *rcond, *work; integer *iwork, *info; ftnlen norm_len; ftnlen uplo_len; ftnlen diag_len; { integer a_dim1, a_offset, i__1; doublereal d__1; static integer kase, kase1; static doublereal scale; extern logical lsame_(); extern int drscl_(); static doublereal anorm; static logical upper; static doublereal xnorm; extern doublereal dlamch_(); extern int dlacon_(); static integer ix; extern integer idamax_(); extern int xerbla_(); extern doublereal dlantr_(); static doublereal ainvnm; extern int dlatrs_(); static logical onenrm; static char normin[1]; static doublereal smlnum; static logical nounit; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --work; --iwork; *info = 0; upper = lsame_(uplo, "U", 1L, 1L); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", 1L, 1L); nounit = lsame_(diag, "N", 1L, 1L); if (! onenrm && ! lsame_(norm, "I", 1L, 1L)) { *info = -1; } else if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { *info = -2; } else if (! nounit && ! lsame_(diag, "U", 1L, 1L)) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*lda < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("DTRCON", &i__1, 6L); return 0; } if (*n == 0) { *rcond = 1.; return 0; } *rcond = 0.; smlnum = dlamch_("Safe minimum", 12L) * (doublereal) (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ; anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1], 1L, 1L, 1L); if (anorm > 0.) { ainvnm = 0.; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &work[(*n << 1) + 1], info, 1L, 12L, 1L, 1L); } else { dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &work[(*n << 1) + 1], info, 1L, 9L, 1L, 1L); } *(unsigned char *)normin = 'Y'; if (scale != 1.) { ix = idamax_(n, &work[1], &c__1); xnorm = (d__1 = work[ix], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (scale < xnorm * smlnum || scale == 0.) { goto L20; } drscl_(n, &scale, &work[1], &c__1); } goto L10; } if (ainvnm != 0.) { *rcond = 1. / anorm / ainvnm; } } L20: return 0; } int dtrmm_(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb, side_len, uplo_len, transa_len, diag_len) char *side, *uplo, *transa, *diag; integer *m, *n; doublereal *alpha, *a; integer *lda; doublereal *b; integer *ldb; ftnlen side_len; ftnlen uplo_len; ftnlen transa_len; ftnlen diag_len; { integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; static integer info; static doublereal temp; static integer i__, j, k; static logical lside; extern logical lsame_(); static integer nrowa; static logical upper; extern int xerbla_(); static logical nounit; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; b_dim1 = *ldb; b_offset = b_dim1 + 1; b -= b_offset; lside = lsame_(side, "L", 1L, 1L); if (lside) { nrowa = *m; } else { nrowa = *n; } nounit = lsame_(diag, "N", 1L, 1L); upper = lsame_(uplo, "U", 1L, 1L); info = 0; if (! lside && ! lsame_(side, "R", 1L, 1L)) { info = 1; } else if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { info = 2; } else if (! lsame_(transa, "N", 1L, 1L) && ! lsame_(transa, "T", 1L, 1L) && ! lsame_(transa, "C", 1L, 1L)) { info = 3; } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) { info = 4; } else if (*m < 0) { info = 5; } else if (*n < 0) { info = 6; } else if (*lda < (( 1 ) >= ( nrowa ) ? ( 1 ) : ( nrowa )) ) { info = 9; } else if (*ldb < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { info = 11; } if (info != 0) { xerbla_("DTRMM ", &info, 6L); return 0; } if (*n == 0) { return 0; } if (*alpha == 0.) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = 0.; } } return 0; } if (lside) { if (lsame_(transa, "N", 1L, 1L)) { if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (k = 1; k <= i__2; ++k) { if (b[k + j * b_dim1] != 0.) { temp = *alpha * b[k + j * b_dim1]; i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { b[i__ + j * b_dim1] += temp * a[i__ + k * a_dim1]; } if (nounit) { temp *= a[k + k * a_dim1]; } b[k + j * b_dim1] = temp; } } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { for (k = *m; k >= 1; --k) { if (b[k + j * b_dim1] != 0.) { temp = *alpha * b[k + j * b_dim1]; b[k + j * b_dim1] = temp; if (nounit) { b[k + j * b_dim1] *= a[k + k * a_dim1]; } i__2 = *m; for (i__ = k + 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] += temp * a[i__ + k * a_dim1]; } } } } } } else { if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { for (i__ = *m; i__ >= 1; --i__) { temp = b[i__ + j * b_dim1]; if (nounit) { temp *= a[i__ + i__ * a_dim1]; } i__2 = i__ - 1; for (k = 1; k <= i__2; ++k) { temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; } b[i__ + j * b_dim1] = *alpha * temp; } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = b[i__ + j * b_dim1]; if (nounit) { temp *= a[i__ + i__ * a_dim1]; } i__3 = *m; for (k = i__ + 1; k <= i__3; ++k) { temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; } b[i__ + j * b_dim1] = *alpha * temp; } } } } } else { if (lsame_(transa, "N", 1L, 1L)) { if (upper) { for (j = *n; j >= 1; --j) { temp = *alpha; if (nounit) { temp *= a[j + j * a_dim1]; } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; } i__1 = j - 1; for (k = 1; k <= i__1; ++k) { if (a[k + j * a_dim1] != 0.) { temp = *alpha * a[k + j * a_dim1]; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] += temp * b[i__ + k * b_dim1]; } } } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = *alpha; if (nounit) { temp *= a[j + j * a_dim1]; } i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; } i__2 = *n; for (k = j + 1; k <= i__2; ++k) { if (a[k + j * a_dim1] != 0.) { temp = *alpha * a[k + j * a_dim1]; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { b[i__ + j * b_dim1] += temp * b[i__ + k * b_dim1]; } } } } } } else { if (upper) { i__1 = *n; for (k = 1; k <= i__1; ++k) { i__2 = k - 1; for (j = 1; j <= i__2; ++j) { if (a[j + k * a_dim1] != 0.) { temp = *alpha * a[j + k * a_dim1]; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { b[i__ + j * b_dim1] += temp * b[i__ + k * b_dim1]; } } } temp = *alpha; if (nounit) { temp *= a[k + k * a_dim1]; } if (temp != 1.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; } } } } else { for (k = *n; k >= 1; --k) { i__1 = *n; for (j = k + 1; j <= i__1; ++j) { if (a[j + k * a_dim1] != 0.) { temp = *alpha * a[j + k * a_dim1]; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] += temp * b[i__ + k * b_dim1]; } } } temp = *alpha; if (nounit) { temp *= a[k + k * a_dim1]; } if (temp != 1.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; } } } } } } return 0; } int dtrmv_(uplo, trans, diag, n, a, lda, x, incx, uplo_len, trans_len, diag_len) char *uplo, *trans, *diag; integer *n; doublereal *a; integer *lda; doublereal *x; integer *incx; ftnlen uplo_len; ftnlen trans_len; ftnlen diag_len; { integer a_dim1, a_offset, i__1, i__2; static integer info; static doublereal temp; static integer i__, j; extern logical lsame_(); static integer ix, jx, kx; extern int xerbla_(); static logical nounit; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --x; info = 0; if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) { info = 1; } else if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L, 1L)) { info = 2; } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) { info = 3; } else if (*n < 0) { info = 4; } else if (*lda < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) { info = 6; } else if (*incx == 0) { info = 8; } if (info != 0) { xerbla_("DTRMV ", &info, 6L); return 0; } if (*n == 0) { return 0; } nounit = lsame_(diag, "N", 1L, 1L); if (*incx <= 0) { kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { kx = 1; } if (lsame_(trans, "N", 1L, 1L)) { if (lsame_(uplo, "U", 1L, 1L)) { if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[j] != 0.) { temp = x[j]; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { x[i__] += temp * a[i__ + j * a_dim1]; } if (nounit) { x[j] *= a[j + j * a_dim1]; } } } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0.) { temp = x[jx]; ix = kx; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { x[ix] += temp * a[i__ + j * a_dim1]; ix += *incx; } if (nounit) { x[jx] *= a[j + j * a_dim1]; } } jx += *incx; } } } else { if (*incx == 1) { for (j = *n; j >= 1; --j) { if (x[j] != 0.) { temp = x[j]; i__1 = j + 1; for (i__ = *n; i__ >= i__1; --i__) { x[i__] += temp * a[i__ + j * a_dim1]; } if (nounit) { x[j] *= a[j + j * a_dim1]; } } } } else { kx += (*n - 1) * *incx; jx = kx; for (j = *n; j >= 1; --j) { if (x[jx] != 0.) { temp = x[jx]; ix = kx; i__1 = j + 1; for (i__ = *n; i__ >= i__1; --i__) { x[ix] += temp * a[i__ + j * a_dim1]; ix -= *incx; } if (nounit) { x[jx] *= a[j + j * a_dim1]; } } jx -= *incx; } } } } else { if (lsame_(uplo, "U", 1L, 1L)) { if (*incx == 1) { for (j = *n; j >= 1; --j) { temp = x[j]; if (nounit) { temp *= a[j + j * a_dim1]; } for (i__ = j - 1; i__ >= 1; --i__) { temp += a[i__ + j * a_dim1] * x[i__]; } x[j] = temp; } } else { jx = kx + (*n - 1) * *incx; for (j = *n; j >= 1; --j) { temp = x[jx]; ix = jx; if (nounit) { temp *= a[j + j * a_dim1]; } for (i__ = j - 1; i__ >= 1; --i__) { ix -= *incx; temp += a[i__ + j * a_dim1] * x[ix]; } x[jx] = temp; jx -= *incx; } } } else { if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[j]; if (nounit) { temp *= a[j + j * a_dim1]; } i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { temp += a[i__ + j * a_dim1] * x[i__]; } x[j] = temp; } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[jx]; ix = jx; if (nounit) { temp *= a[j + j * a_dim1]; } i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { ix += *incx; temp += a[i__ + j * a_dim1] * x[ix]; } x[jx] = temp; jx += *incx; } } } } return 0; } int dtrsm_(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb, side_len, uplo_len, transa_len, diag_len) char *side, *uplo, *transa, *diag; integer *m, *n; doublereal *alpha, *a; integer *lda; doublereal *b; integer *ldb; ftnlen side_len; ftnlen uplo_len; ftnlen transa_len; ftnlen diag_len; { integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; static integer info; static doublereal temp; static integer i__, j, k; static logical lside; extern logical lsame_(); static integer nrowa; static logical upper; extern int xerbla_(); static logical nounit; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; b_dim1 = *ldb; b_offset = b_dim1 + 1; b -= b_offset; lside = lsame_(side, "L", 1L, 1L); if (lside) { nrowa = *m; } else { nrowa = *n; } nounit = lsame_(diag, "N", 1L, 1L); upper = lsame_(uplo, "U", 1L, 1L); info = 0; if (! lside && ! lsame_(side, "R", 1L, 1L)) { info = 1; } else if (! upper && ! lsame_(uplo, "L", 1L, 1L)) { info = 2; } else if (! lsame_(transa, "N", 1L, 1L) && ! lsame_(transa, "T", 1L, 1L) && ! lsame_(transa, "C", 1L, 1L)) { info = 3; } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) { info = 4; } else if (*m < 0) { info = 5; } else if (*n < 0) { info = 6; } else if (*lda < (( 1 ) >= ( nrowa ) ? ( 1 ) : ( nrowa )) ) { info = 9; } else if (*ldb < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) { info = 11; } if (info != 0) { xerbla_("DTRSM ", &info, 6L); return 0; } if (*n == 0) { return 0; } if (*alpha == 0.) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = 0.; } } return 0; } if (lside) { if (lsame_(transa, "N", 1L, 1L)) { if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*alpha != 1.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] ; } } for (k = *m; k >= 1; --k) { if (b[k + j * b_dim1] != 0.) { if (nounit) { b[k + j * b_dim1] /= a[k + k * a_dim1]; } i__2 = k - 1; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ i__ + k * a_dim1]; } } } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*alpha != 1.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] ; } } i__2 = *m; for (k = 1; k <= i__2; ++k) { if (b[k + j * b_dim1] != 0.) { if (nounit) { b[k + j * b_dim1] /= a[k + k * a_dim1]; } i__3 = *m; for (i__ = k + 1; i__ <= i__3; ++i__) { b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ i__ + k * a_dim1]; } } } } } } else { if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = *alpha * b[i__ + j * b_dim1]; i__3 = i__ - 1; for (k = 1; k <= i__3; ++k) { temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; } if (nounit) { temp /= a[i__ + i__ * a_dim1]; } b[i__ + j * b_dim1] = temp; } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { for (i__ = *m; i__ >= 1; --i__) { temp = *alpha * b[i__ + j * b_dim1]; i__2 = *m; for (k = i__ + 1; k <= i__2; ++k) { temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; } if (nounit) { temp /= a[i__ + i__ * a_dim1]; } b[i__ + j * b_dim1] = temp; } } } } } else { if (lsame_(transa, "N", 1L, 1L)) { if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (*alpha != 1.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] ; } } i__2 = j - 1; for (k = 1; k <= i__2; ++k) { if (a[k + j * a_dim1] != 0.) { i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ i__ + k * b_dim1]; } } } if (nounit) { temp = 1. / a[j + j * a_dim1]; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; } } } } else { for (j = *n; j >= 1; --j) { if (*alpha != 1.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] ; } } i__1 = *n; for (k = j + 1; k <= i__1; ++k) { if (a[k + j * a_dim1] != 0.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ i__ + k * b_dim1]; } } } if (nounit) { temp = 1. / a[j + j * a_dim1]; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; } } } } } else { if (upper) { for (k = *n; k >= 1; --k) { if (nounit) { temp = 1. / a[k + k * a_dim1]; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; } } i__1 = k - 1; for (j = 1; j <= i__1; ++j) { if (a[j + k * a_dim1] != 0.) { temp = a[j + k * a_dim1]; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] -= temp * b[i__ + k * b_dim1]; } } } if (*alpha != 1.) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] ; } } } } else { i__1 = *n; for (k = 1; k <= i__1; ++k) { if (nounit) { temp = 1. / a[k + k * a_dim1]; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; } } i__2 = *n; for (j = k + 1; j <= i__2; ++j) { if (a[j + k * a_dim1] != 0.) { temp = a[j + k * a_dim1]; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { b[i__ + j * b_dim1] -= temp * b[i__ + k * b_dim1]; } } } if (*alpha != 1.) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] ; } } } } } } return 0; } int dtrsv_(uplo, trans, diag, n, a, lda, x, incx, uplo_len, trans_len, diag_len) char *uplo, *trans, *diag; integer *n; doublereal *a; integer *lda; doublereal *x; integer *incx; ftnlen uplo_len; ftnlen trans_len; ftnlen diag_len; { integer a_dim1, a_offset, i__1, i__2; static integer info; static doublereal temp; static integer i__, j; extern logical lsame_(); static integer ix, jx, kx; extern int xerbla_(); static logical nounit; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --x; info = 0; if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) { info = 1; } else if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L, 1L)) { info = 2; } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) { info = 3; } else if (*n < 0) { info = 4; } else if (*lda < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) { info = 6; } else if (*incx == 0) { info = 8; } if (info != 0) { xerbla_("DTRSV ", &info, 6L); return 0; } if (*n == 0) { return 0; } nounit = lsame_(diag, "N", 1L, 1L); if (*incx <= 0) { kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { kx = 1; } if (lsame_(trans, "N", 1L, 1L)) { if (lsame_(uplo, "U", 1L, 1L)) { if (*incx == 1) { for (j = *n; j >= 1; --j) { if (x[j] != 0.) { if (nounit) { x[j] /= a[j + j * a_dim1]; } temp = x[j]; for (i__ = j - 1; i__ >= 1; --i__) { x[i__] -= temp * a[i__ + j * a_dim1]; } } } } else { jx = kx + (*n - 1) * *incx; for (j = *n; j >= 1; --j) { if (x[jx] != 0.) { if (nounit) { x[jx] /= a[j + j * a_dim1]; } temp = x[jx]; ix = jx; for (i__ = j - 1; i__ >= 1; --i__) { ix -= *incx; x[ix] -= temp * a[i__ + j * a_dim1]; } } jx -= *incx; } } } else { if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[j] != 0.) { if (nounit) { x[j] /= a[j + j * a_dim1]; } temp = x[j]; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { x[i__] -= temp * a[i__ + j * a_dim1]; } } } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (x[jx] != 0.) { if (nounit) { x[jx] /= a[j + j * a_dim1]; } temp = x[jx]; ix = jx; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { ix += *incx; x[ix] -= temp * a[i__ + j * a_dim1]; } } jx += *incx; } } } } else { if (lsame_(uplo, "U", 1L, 1L)) { if (*incx == 1) { i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[j]; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { temp -= a[i__ + j * a_dim1] * x[i__]; } if (nounit) { temp /= a[j + j * a_dim1]; } x[j] = temp; } } else { jx = kx; i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[jx]; ix = kx; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { temp -= a[i__ + j * a_dim1] * x[ix]; ix += *incx; } if (nounit) { temp /= a[j + j * a_dim1]; } x[jx] = temp; jx += *incx; } } } else { if (*incx == 1) { for (j = *n; j >= 1; --j) { temp = x[j]; i__1 = j + 1; for (i__ = *n; i__ >= i__1; --i__) { temp -= a[i__ + j * a_dim1] * x[i__]; } if (nounit) { temp /= a[j + j * a_dim1]; } x[j] = temp; } } else { kx += (*n - 1) * *incx; jx = kx; for (j = *n; j >= 1; --j) { temp = x[jx]; ix = kx; i__1 = j + 1; for (i__ = *n; i__ >= i__1; --i__) { temp -= a[i__ + j * a_dim1] * x[ix]; ix -= *incx; } if (nounit) { temp /= a[j + j * a_dim1]; } x[jx] = temp; jx -= *incx; } } } } return 0; } integer ilaenv_(ispec, name__, opts, n1, n2, n3, n4, name_len, opts_len) integer *ispec; char *name__, *opts; integer *n1, *n2, *n3, *n4; ftnlen name_len; ftnlen opts_len; { integer ret_val; int s_copy(); integer s_cmp(); static integer i__; static logical cname, sname; static integer nbmin; static char c1[1], c2[2], c3[3], c4[2]; static integer ic, nb, iz, nx; static char subnam[6]; switch ((int)*ispec) { case 1: goto L100; case 2: goto L100; case 3: goto L100; case 4: goto L400; case 5: goto L500; case 6: goto L600; case 7: goto L700; case 8: goto L800; } ret_val = -1; return ret_val; L100: ret_val = 1; s_copy(subnam, name__, 6L, name_len); ic = *(unsigned char *)subnam; iz = 'Z'; if (iz == 90 || iz == 122) { if (ic >= 97 && ic <= 122) { *(unsigned char *)subnam = (char) (ic - 32); for (i__ = 2; i__ <= 6; ++i__) { ic = *(unsigned char *)&subnam[i__ - 1]; if (ic >= 97 && ic <= 122) { *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); } } } } else if (iz == 233 || iz == 169) { if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && ic <= 169) { *(unsigned char *)subnam = (char) (ic + 64); for (i__ = 2; i__ <= 6; ++i__) { ic = *(unsigned char *)&subnam[i__ - 1]; if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && ic <= 169) { *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); } } } } else if (iz == 218 || iz == 250) { if (ic >= 225 && ic <= 250) { *(unsigned char *)subnam = (char) (ic - 32); for (i__ = 2; i__ <= 6; ++i__) { ic = *(unsigned char *)&subnam[i__ - 1]; if (ic >= 225 && ic <= 250) { *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); } } } } *(unsigned char *)c1 = *(unsigned char *)subnam; sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D'; cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z'; if (! (cname || sname)) { return ret_val; } s_copy(c2, subnam + 1, 2L, 2L); s_copy(c3, subnam + 3, 3L, 3L); s_copy(c4, c3 + 1, 2L, 2L); switch ((int)*ispec) { case 1: goto L110; case 2: goto L200; case 3: goto L300; } L110: nb = 1; if (s_cmp(c2, "GE", 2L, 2L) == 0) { if (s_cmp(c3, "TRF", 3L, 3L) == 0) { if (sname) { nb = 64; } else { nb = 64; } } else if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 || s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) == 0) { if (sname) { nb = 32; } else { nb = 32; } } else if (s_cmp(c3, "HRD", 3L, 3L) == 0) { if (sname) { nb = 32; } else { nb = 32; } } else if (s_cmp(c3, "BRD", 3L, 3L) == 0) { if (sname) { nb = 32; } else { nb = 32; } } else if (s_cmp(c3, "TRI", 3L, 3L) == 0) { if (sname) { nb = 64; } else { nb = 64; } } } else if (s_cmp(c2, "PO", 2L, 2L) == 0) { if (s_cmp(c3, "TRF", 3L, 3L) == 0) { if (sname) { nb = 64; } else { nb = 64; } } } else if (s_cmp(c2, "SY", 2L, 2L) == 0) { if (s_cmp(c3, "TRF", 3L, 3L) == 0) { if (sname) { nb = 64; } else { nb = 64; } } else if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) { nb = 1; } else if (sname && s_cmp(c3, "GST", 3L, 3L) == 0) { nb = 64; } } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) { if (s_cmp(c3, "TRF", 3L, 3L) == 0) { nb = 64; } else if (s_cmp(c3, "TRD", 3L, 3L) == 0) { nb = 1; } else if (s_cmp(c3, "GST", 3L, 3L) == 0) { nb = 64; } } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) { if (*(unsigned char *)c3 == 'G') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nb = 32; } } else if (*(unsigned char *)c3 == 'M') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nb = 32; } } } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) { if (*(unsigned char *)c3 == 'G') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nb = 32; } } else if (*(unsigned char *)c3 == 'M') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nb = 32; } } } else if (s_cmp(c2, "GB", 2L, 2L) == 0) { if (s_cmp(c3, "TRF", 3L, 3L) == 0) { if (sname) { if (*n4 <= 64) { nb = 1; } else { nb = 32; } } else { if (*n4 <= 64) { nb = 1; } else { nb = 32; } } } } else if (s_cmp(c2, "PB", 2L, 2L) == 0) { if (s_cmp(c3, "TRF", 3L, 3L) == 0) { if (sname) { if (*n2 <= 64) { nb = 1; } else { nb = 32; } } else { if (*n2 <= 64) { nb = 1; } else { nb = 32; } } } } else if (s_cmp(c2, "TR", 2L, 2L) == 0) { if (s_cmp(c3, "TRI", 3L, 3L) == 0) { if (sname) { nb = 64; } else { nb = 64; } } } else if (s_cmp(c2, "LA", 2L, 2L) == 0) { if (s_cmp(c3, "UUM", 3L, 3L) == 0) { if (sname) { nb = 64; } else { nb = 64; } } } else if (sname && s_cmp(c2, "ST", 2L, 2L) == 0) { if (s_cmp(c3, "EBZ", 3L, 3L) == 0) { nb = 1; } } ret_val = nb; return ret_val; L200: nbmin = 2; if (s_cmp(c2, "GE", 2L, 2L) == 0) { if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 || s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) == 0) { if (sname) { nbmin = 2; } else { nbmin = 2; } } else if (s_cmp(c3, "HRD", 3L, 3L) == 0) { if (sname) { nbmin = 2; } else { nbmin = 2; } } else if (s_cmp(c3, "BRD", 3L, 3L) == 0) { if (sname) { nbmin = 2; } else { nbmin = 2; } } else if (s_cmp(c3, "TRI", 3L, 3L) == 0) { if (sname) { nbmin = 2; } else { nbmin = 2; } } } else if (s_cmp(c2, "SY", 2L, 2L) == 0) { if (s_cmp(c3, "TRF", 3L, 3L) == 0) { if (sname) { nbmin = 8; } else { nbmin = 8; } } else if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) { nbmin = 2; } } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) { if (s_cmp(c3, "TRD", 3L, 3L) == 0) { nbmin = 2; } } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) { if (*(unsigned char *)c3 == 'G') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nbmin = 2; } } else if (*(unsigned char *)c3 == 'M') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nbmin = 2; } } } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) { if (*(unsigned char *)c3 == 'G') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nbmin = 2; } } else if (*(unsigned char *)c3 == 'M') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nbmin = 2; } } } ret_val = nbmin; return ret_val; L300: nx = 0; if (s_cmp(c2, "GE", 2L, 2L) == 0) { if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 || s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) == 0) { if (sname) { nx = 128; } else { nx = 128; } } else if (s_cmp(c3, "HRD", 3L, 3L) == 0) { if (sname) { nx = 128; } else { nx = 128; } } else if (s_cmp(c3, "BRD", 3L, 3L) == 0) { if (sname) { nx = 128; } else { nx = 128; } } } else if (s_cmp(c2, "SY", 2L, 2L) == 0) { if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) { nx = 1; } } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) { if (s_cmp(c3, "TRD", 3L, 3L) == 0) { nx = 1; } } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) { if (*(unsigned char *)c3 == 'G') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nx = 128; } } } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) { if (*(unsigned char *)c3 == 'G') { if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L) == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) { nx = 128; } } } ret_val = nx; return ret_val; L400: ret_val = 6; return ret_val; L500: ret_val = 2; return ret_val; L600: ret_val = (integer) ((real) (( *n1 ) <= ( *n2 ) ? ( *n1 ) : ( *n2 )) * (float)1.6); return ret_val; L700: ret_val = 1; return ret_val; L800: ret_val = 50; return ret_val; } logical lsame_(ca, cb, ca_len, cb_len) char *ca, *cb; ftnlen ca_len; ftnlen cb_len; { logical ret_val; static integer inta, intb, zcode; ret_val = *(unsigned char *)ca == *(unsigned char *)cb; if (ret_val) { return ret_val; } zcode = 'Z'; inta = *(unsigned char *)ca; intb = *(unsigned char *)cb; if (zcode == 90 || zcode == 122) { if (inta >= 97 && inta <= 122) { inta += -32; } if (intb >= 97 && intb <= 122) { intb += -32; } } else if (zcode == 233 || zcode == 169) { if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta >= 162 && inta <= 169) { inta += 64; } if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb >= 162 && intb <= 169) { intb += 64; } } else if (zcode == 218 || zcode == 250) { if (inta >= 225 && inta <= 250) { inta += -32; } if (intb >= 225 && intb <= 250) { intb += -32; } } ret_val = inta == intb; return ret_val; } int xerbla_(srname, info, srname_len) char *srname; integer *info; ftnlen srname_len; { static char fmt_9999[] = "(\002 ** On entry to \002,a6,\002 parameter number \002,i2,\002 had \002,\002an illegal value\002)"; integer s_wsfe(), do_fio(), e_wsfe(); int s_stop(); static cilist io___630 = { 0, 6, 0, fmt_9999, 0 }; s_wsfe(&io___630); do_fio(&c__1, srname, 6L); do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer)); e_wsfe(); s_stop("", 0L); } int ainvg_(res, adda, neq, t, y, ydot, miter, ml, mu, pw, ipvt, ier) int (*res) (), (*adda) (); integer *neq; doublereal *t, *y, *ydot; integer *miter, *ml, *mu; doublereal *pw; integer *ipvt, *ier; { integer i__1; extern int dgbfa_(), dgefa_(); static integer i__; extern int dgbsl_(), dgesl_(); static integer lenpw, nrowpw, mlp1; --ipvt; --pw; --ydot; --y; if (*miter >= 4) { goto L100; } lenpw = *neq * *neq; i__1 = lenpw; for (i__ = 1; i__ <= i__1; ++i__) { pw[i__] = 0.; } *ier = 1; (*res)(neq, t, &y[1], &pw[1], &ydot[1], ier); if (ierode_ .iero > 0) { return 0; } if (*ier > 1) { return 0; } (*adda)(neq, t, &y[1], &c__0, &c__0, &pw[1], neq); if (ierode_ .iero > 0) { return 0; } dgefa_(&pw[1], neq, neq, &ipvt[1], ier); if (*ier == 0) { goto L20; } *ier = -(*ier); return 0; L20: dgesl_(&pw[1], neq, neq, &ipvt[1], &ydot[1], &c__0); return 0; L100: nrowpw = (*ml << 1) + *mu + 1; lenpw = *neq * nrowpw; i__1 = lenpw; for (i__ = 1; i__ <= i__1; ++i__) { pw[i__] = 0.; } *ier = 1; (*res)(neq, t, &y[1], &pw[1], &ydot[1], ier); if (ierode_ .iero > 0) { return 0; } if (*ier > 1) { return 0; } mlp1 = *ml + 1; (*adda)(neq, t, &y[1], ml, mu, &pw[mlp1], &nrowpw); if (ierode_ .iero > 0) { return 0; } dgbfa_(&pw[1], &nrowpw, neq, ml, mu, &ipvt[1], ier); if (*ier == 0) { goto L120; } *ier = -(*ier); return 0; L120: dgbsl_(&pw[1], &nrowpw, neq, ml, mu, &ipvt[1], &ydot[1], &c__0); return 0; } doublereal bnorm_(n, a, nra, ml, mu, w) integer *n; doublereal *a; integer *nra, *ml, *mu; doublereal *w; { integer a_dim1, a_offset, i__1, i__2; doublereal ret_val, d__1, d__2; static integer i__, j, i1; static doublereal an; static integer jhi, jlo; static doublereal sum; --w; a_dim1 = *nra; a_offset = a_dim1 + 1; a -= a_offset; an = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sum = 0.; i1 = i__ + *mu + 1; i__2 = i__ - *ml; jlo = (( i__2 ) >= ( 1 ) ? ( i__2 ) : ( 1 )) ; i__2 = i__ + *mu; jhi = (( i__2 ) <= ( *n ) ? ( i__2 ) : ( *n )) ; i__2 = jhi; for (j = jlo; j <= i__2; ++j) { sum += (d__1 = a[i1 - j + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / w[j]; } d__1 = an, d__2 = sum * w[i__]; an = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } ret_val = an; return ret_val; } int cfode_(meth, elco, tesco) integer *meth; doublereal *elco, *tesco; { integer i__1; static doublereal ragq, pint, xpin, fnqm1; static integer i__; static doublereal agamq, rqfac, tsign, rq1fac; static integer ib; static doublereal pc[12]; static integer nq; static doublereal fnq; static integer nqm1, nqp1; tesco -= 4; elco -= 14; switch ((int)*meth) { case 1: goto L100; case 2: goto L200; } L100: elco[14] = 1.; elco[15] = 1.; tesco[4] = 0.; tesco[5] = 2.; tesco[7] = 1.; tesco[39] = 0.; pc[0] = 1.; rqfac = 1.; for (nq = 2; nq <= 12; ++nq) { rq1fac = rqfac; rqfac /= (doublereal) nq; nqm1 = nq - 1; fnqm1 = (doublereal) nqm1; nqp1 = nq + 1; pc[nq - 1] = 0.; i__1 = nqm1; for (ib = 1; ib <= i__1; ++ib) { i__ = nqp1 - ib; pc[i__ - 1] = pc[i__ - 2] + fnqm1 * pc[i__ - 1]; } pc[0] = fnqm1 * pc[0]; pint = pc[0]; xpin = pc[0] / 2.; tsign = 1.; i__1 = nq; for (i__ = 2; i__ <= i__1; ++i__) { tsign = -tsign; pint += tsign * pc[i__ - 1] / (doublereal) i__; xpin += tsign * pc[i__ - 1] / (doublereal) (i__ + 1); } elco[nq * 13 + 1] = pint * rq1fac; elco[nq * 13 + 2] = 1.; i__1 = nq; for (i__ = 2; i__ <= i__1; ++i__) { elco[i__ + 1 + nq * 13] = rq1fac * pc[i__ - 1] / (doublereal) i__; } agamq = rqfac * xpin; ragq = 1. / agamq; tesco[nq * 3 + 2] = ragq; if (nq < 12) { tesco[nqp1 * 3 + 1] = ragq * rqfac / (doublereal) nqp1; } tesco[nqm1 * 3 + 3] = ragq; } return 0; L200: pc[0] = 1.; rq1fac = 1.; for (nq = 1; nq <= 5; ++nq) { fnq = (doublereal) nq; nqp1 = nq + 1; pc[nqp1 - 1] = 0.; i__1 = nq; for (ib = 1; ib <= i__1; ++ib) { i__ = nq + 2 - ib; pc[i__ - 1] = pc[i__ - 2] + fnq * pc[i__ - 1]; } pc[0] = fnq * pc[0]; i__1 = nqp1; for (i__ = 1; i__ <= i__1; ++i__) { elco[i__ + nq * 13] = pc[i__ - 1] / pc[1]; } elco[nq * 13 + 2] = 1.; tesco[nq * 3 + 1] = rq1fac; tesco[nq * 3 + 2] = (doublereal) nqp1 / elco[nq * 13 + 1]; tesco[nq * 3 + 3] = (doublereal) (nq + 2) / elco[nq * 13 + 1]; rq1fac /= fnq; } return 0; } int colnew_0_(n__, ncomp, m, aleft, aright, zeta, ipar, ltol, tol, fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess) int n__; integer *ncomp, *m; doublereal *aleft, *aright, *zeta; integer *ipar, *ltol; doublereal *tol, *fixpnt; integer *ispace; doublereal *fspace; integer *iflag; int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (* guess) (); { static char fmt_99[] = "(//,\002 VERSION *COLNEW* OF COLSYS . \002,//)" ; static char fmt_260[] = "(///\002 THE NUMBER OF (LINEAR) DIFF EQNS IS \002,i3/1x,\002THEIR ORDERS ARE\002,20i3)"; static char fmt_270[] = "(///\002 THE NUMBER OF (NONLINEAR) DIFF EQNS IS \002,i3/1x,\002THEIR ORDERS ARE\002,20i3)"; static char fmt_280[] = "(\002 SIDE CONDITION POINTS ZETA\002,8f10.6,4(/27x,8f10.6))"; static char fmt_340[] = "(\002 THERE ARE\002,i5,\002 FIXED POINTS IN THE MESH -\002,10(6f10.6/))"; static char fmt_290[] = "(\002 NUMBER OF COLLOC PTS PER INTERVAL IS\002,i3)"; static char fmt_300[] = "(\002 COMPONENTS OF Z REQUIRING TOLERANCES -\002,8(7x,i2,1x),4(/38x,8i10))"; static char fmt_310[] = "(\002 CORRESPONDING ERROR TOLERANCES -\002,6x,8d10.2,4(/39x,8d10.2))"; static char fmt_320[] = "(\002 INITIAL MESH(ES) AND Z,DMZ PROVIDED BY USER\002)"; static char fmt_330[] = "(\002 NO ADAPTIVE MESH SELECTION\002)"; static char fmt_350[] = "(\002 THE MAXIMUM NUMBER OF SUBINTERVALS IS MIN (\002,i4,\002 (ALLOWED FROM FSPACE),\002,i4,\002 (ALLOWED FROM ISPACE) )\002)"; static char fmt_360[] = "(/\002 INSUFFICIENT SPACE TO DOUBLE MESH FOR ERROR ESTIMATE\002)"; integer i__1, i__2, i__3; doublereal d__1, d__2; integer s_wsfe(), e_wsfe(), do_fio(); static integer nrec, lscl, ldmz, idmz, ldqz, lrhs, i__, iread, ndimf, ndimi, ldscl, nmaxf, nfixf, ldelz, nfixi, nmaxi; static doublereal dummy[1]; static integer lpvtg, k2, lpvtw; static doublereal precp1; static integer ib, ic, lg, ip, lw, lv, lz, laccum, ldeldz, linteg, lxiold, ldqdmz, nsizef, lslope, nsizei; extern int newmsh_(); static integer lvalst; extern int consts_(); static integer nfxpnt; extern int contrl_(); static integer np1, lxi; static cilist io___657 = { 0, 6, 0, fmt_99, 0 }; static cilist io___664 = { 0, 0, 0, fmt_260, 0 }; static cilist io___666 = { 0, 0, 0, fmt_270, 0 }; static cilist io___667 = { 0, 0, 0, fmt_280, 0 }; static cilist io___668 = { 0, 0, 0, fmt_340, 0 }; static cilist io___669 = { 0, 0, 0, fmt_290, 0 }; static cilist io___670 = { 0, 0, 0, fmt_300, 0 }; static cilist io___671 = { 0, 0, 0, fmt_310, 0 }; static cilist io___672 = { 0, 0, 0, fmt_320, 0 }; static cilist io___673 = { 0, 0, 0, fmt_330, 0 }; static cilist io___682 = { 0, 0, 0, fmt_350, 0 }; static cilist io___683 = { 0, 0, 0, fmt_360, 0 }; --m; --zeta; --ipar; --ltol; --tol; --fixpnt; --ispace; --fspace; switch(n__) { case 1: goto L_colsys; } L_colsys: if (ipar[7] <= 0) { s_wsfe(&io___657); e_wsfe(); } colout_ .iout = 6; colout_ .precis = 1.; L10: colout_ .precis /= 2.; precp1 = colout_ .precis + 1.; if (precp1 > 1.) { goto L10; } colout_ .precis *= 100.; *iflag = -3; if (*ncomp < 1 || *ncomp > 20) { return 0; } i__1 = *ncomp; for (i__ = 1; i__ <= i__1; ++i__) { if (m[i__] < 1 || m[i__] > 4) { return 0; } } colnln_ .nonlin = ipar[1]; (colord_._1) .k = ipar[2]; colapr_ .n = ipar[3]; if (colapr_ .n == 0) { colapr_ .n = 5; } iread = ipar[8]; colnln_ .iguess = ipar[9]; if (colnln_ .nonlin == 0 && colnln_ .iguess == 1) { colnln_ .iguess = 0; } if (colnln_ .iguess >= 2 && iread == 0) { iread = 1; } colnln_ .icare = ipar[10]; (colest_._1) .ntol = ipar[4]; ndimf = ipar[5]; ndimi = ipar[6]; nfxpnt = ipar[11]; colout_ .iprint = ipar[7]; (colord_._1) .mstar = 0; (colord_._1) .mmax = 0; i__1 = *ncomp; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = (colord_._1) .mmax, i__3 = m[i__]; (colord_._1) .mmax = (( i__2 ) >= ( i__3 ) ? ( i__2 ) : ( i__3 )) ; (colord_._1) .mstar += m[i__]; (colord_._1) .mt[i__ - 1] = m[i__]; } if ((colord_._1) .k == 0) { i__1 = (colord_._1) .mmax + 1, i__2 = 5 - (colord_._1) .mmax; (colord_._1) .k = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } i__1 = (colord_._1) .mstar; for (i__ = 1; i__ <= i__1; ++i__) { (colsid_._1) .tzeta[i__ - 1] = zeta[i__]; } i__1 = (colest_._1) .ntol; for (i__ = 1; i__ <= i__1; ++i__) { (colest_._1) .lttol[i__ - 1] = ltol[i__]; (colest_._1) .tolin[i__ - 1] = tol[i__]; } (colsid_._1) .tleft = *aleft; (colsid_._1) .tright = *aright; (colord_._1) .nc = *ncomp; (colord_._1) .kd = (colord_._1) .k * *ncomp; if (colout_ .iprint > -1) { goto L80; } if (colnln_ .nonlin > 0) { goto L60; } io___664.ciunit = colout_ .iout; s_wsfe(&io___664); do_fio(&c__1, (char *)&(*ncomp), (ftnlen)sizeof(integer)); i__1 = *ncomp; for (ip = 1; ip <= i__1; ++ip) { do_fio(&c__1, (char *)&m[ip], (ftnlen)sizeof(integer)); } e_wsfe(); goto L70; L60: io___666.ciunit = colout_ .iout; s_wsfe(&io___666); do_fio(&c__1, (char *)&(*ncomp), (ftnlen)sizeof(integer)); i__1 = *ncomp; for (ip = 1; ip <= i__1; ++ip) { do_fio(&c__1, (char *)&m[ip], (ftnlen)sizeof(integer)); } e_wsfe(); L70: io___667.ciunit = colout_ .iout; s_wsfe(&io___667); i__1 = (colord_._1) .mstar; for (ip = 1; ip <= i__1; ++ip) { do_fio(&c__1, (char *)&zeta[ip], (ftnlen)sizeof(doublereal)); } e_wsfe(); if (nfxpnt > 0) { io___668.ciunit = colout_ .iout; s_wsfe(&io___668); do_fio(&c__1, (char *)&nfxpnt, (ftnlen)sizeof(integer)); i__1 = nfxpnt; for (ip = 1; ip <= i__1; ++ip) { do_fio(&c__1, (char *)&fixpnt[ip], (ftnlen)sizeof(doublereal)); } e_wsfe(); } io___669.ciunit = colout_ .iout; s_wsfe(&io___669); do_fio(&c__1, (char *)& (colord_._1) .k, (ftnlen)sizeof(integer)); e_wsfe(); io___670.ciunit = colout_ .iout; s_wsfe(&io___670); i__1 = (colest_._1) .ntol; for (ip = 1; ip <= i__1; ++ip) { do_fio(&c__1, (char *)<ol[ip], (ftnlen)sizeof(integer)); } e_wsfe(); io___671.ciunit = colout_ .iout; s_wsfe(&io___671); i__1 = (colest_._1) .ntol; for (ip = 1; ip <= i__1; ++ip) { do_fio(&c__1, (char *)&tol[ip], (ftnlen)sizeof(doublereal)); } e_wsfe(); if (colnln_ .iguess >= 2) { io___672.ciunit = colout_ .iout; s_wsfe(&io___672); e_wsfe(); } if (iread == 2) { io___673.ciunit = colout_ .iout; s_wsfe(&io___673); e_wsfe(); } L80: if ((colord_._1) .k < 0 || (colord_._1) .k > 7) { return 0; } if (colapr_ .n < 0) { return 0; } if (iread < 0 || iread > 2) { return 0; } if (colnln_ .iguess < 0 || colnln_ .iguess > 4) { return 0; } if (colnln_ .icare < 0 || colnln_ .icare > 2) { return 0; } if ((colest_._1) .ntol < 0 || (colest_._1) .ntol > (colord_._1) .mstar) { return 0; } if (nfxpnt < 0) { return 0; } if (colout_ .iprint < -1 || colout_ .iprint > 1) { return 0; } if ((colord_._1) .mstar < 0 || (colord_._1) .mstar > 40) { return 0; } ip = 1; i__1 = (colord_._1) .mstar; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = zeta[i__] - *aleft, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < colout_ .precis || (d__2 = zeta[i__] - *aright, (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) < colout_ .precis) { goto L100; } L90: if (ip > nfxpnt) { return 0; } if (zeta[i__] - colout_ .precis < fixpnt[ip]) { goto L95; } ++ip; goto L90; L95: if (zeta[i__] + colout_ .precis < fixpnt[ip]) { return 0; } L100: ; } colmsh_ .mshlmt = 3; colmsh_ .mshflg = 0; colmsh_ .mshnum = 1; colmsh_ .mshalt = 1; colnln_ .limit = 40; nrec = 0; i__1 = (colord_._1) .mstar; for (i__ = 1; i__ <= i__1; ++i__) { ib = (colord_._1) .mstar + 1 - i__; if (zeta[ib] >= *aright) { nrec = i__; } } nfixi = (colord_._1) .mstar; nsizei = (colord_._1) .kd + 3 + (colord_._1) .mstar; nfixf = nrec * ((colord_._1) .mstar << 1) + (colord_._1) .mstar * 5 + 3; nsizef = (colord_._1) .mstar * 3 + 4 + ((colord_._1) .kd + 5) * ((colord_._1) .kd + (colord_._1) .mstar) + (((colord_._1) .mstar << 1) - nrec << 1) * (colord_._1) .mstar; nmaxf = (ndimf - nfixf) / nsizef; nmaxi = (ndimi - nfixi) / nsizei; if (colout_ .iprint < 1) { io___682.ciunit = colout_ .iout; s_wsfe(&io___682); do_fio(&c__1, (char *)&nmaxf, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nmaxi, (ftnlen)sizeof(integer)); e_wsfe(); } colapr_ .nmax = (( nmaxf ) <= ( nmaxi ) ? ( nmaxf ) : ( nmaxi )) ; if (colapr_ .nmax < colapr_ .n) { return 0; } if (colapr_ .nmax < nfxpnt + 1) { return 0; } if (colapr_ .nmax < (nfxpnt << 1) + 2 && colout_ .iprint < 1) { io___683.ciunit = colout_ .iout; s_wsfe(&io___683); e_wsfe(); } lxi = 1; lg = lxi + colapr_ .nmax + 1; lxiold = lg + ((colord_._1) .mstar << 1) * (colapr_ .nmax * (((colord_._1) .mstar << 1) - nrec) + nrec); lw = lxiold + colapr_ .nmax + 1; i__1 = (colord_._1) .kd; lv = lw + i__1 * i__1 * colapr_ .nmax; lz = lv + (colord_._1) .mstar * (colord_._1) .kd * colapr_ .nmax; ldmz = lz + (colord_._1) .mstar * (colapr_ .nmax + 1); ldelz = ldmz + (colord_._1) .kd * colapr_ .nmax; ldeldz = ldelz + (colord_._1) .mstar * (colapr_ .nmax + 1); ldqz = ldeldz + (colord_._1) .kd * colapr_ .nmax; ldqdmz = ldqz + (colord_._1) .mstar * (colapr_ .nmax + 1); lrhs = ldqdmz + (colord_._1) .kd * colapr_ .nmax; lvalst = lrhs + (colord_._1) .kd * colapr_ .nmax + (colord_._1) .mstar; lslope = lvalst + ((colord_._1) .mstar << 2) * colapr_ .nmax; laccum = lslope + colapr_ .nmax; lscl = laccum + colapr_ .nmax + 1; ldscl = lscl + (colord_._1) .mstar * (colapr_ .nmax + 1); lpvtg = 1; lpvtw = lpvtg + (colord_._1) .mstar * (colapr_ .nmax + 1); linteg = lpvtw + (colord_._1) .kd * colapr_ .nmax; if (colnln_ .iguess < 2) { goto L160; } colapr_ .nold = colapr_ .n; if (colnln_ .iguess == 4) { colapr_ .nold = ispace[1]; } colapr_ .nz = (colord_._1) .mstar * (colapr_ .nold + 1); colapr_ .ndmz = (colord_._1) .kd * colapr_ .nold; np1 = colapr_ .n + 1; if (colnln_ .iguess == 4) { np1 = np1 + colapr_ .nold + 1; } i__1 = colapr_ .nz; for (i__ = 1; i__ <= i__1; ++i__) { fspace[lz + i__ - 1] = fspace[np1 + i__]; } idmz = np1 + colapr_ .nz; i__1 = colapr_ .ndmz; for (i__ = 1; i__ <= i__1; ++i__) { fspace[ldmz + i__ - 1] = fspace[idmz + i__]; } np1 = colapr_ .nold + 1; if (colnln_ .iguess == 4) { goto L140; } i__1 = np1; for (i__ = 1; i__ <= i__1; ++i__) { fspace[lxiold + i__ - 1] = fspace[lxi + i__ - 1]; } goto L160; L140: i__1 = np1; for (i__ = 1; i__ <= i__1; ++i__) { fspace[lxiold + i__ - 1] = fspace[colapr_ .n + 1 + i__]; } L160: consts_(& (colord_._1) .k, colloc_ .rho, colloc_ .coef); i__1 = iread + 3; newmsh_(&i__1, &fspace[lxi], &fspace[lxiold], dummy, dummy, dummy, dummy, dummy, &nfxpnt, &fixpnt[1]); if (colnln_ .iguess >= 2) { goto L230; } np1 = colapr_ .n + 1; i__1 = np1; for (i__ = 1; i__ <= i__1; ++i__) { fspace[i__ + lxiold - 1] = fspace[i__ + lxi - 1]; } colapr_ .nold = colapr_ .n; if (colnln_ .nonlin == 0 || colnln_ .iguess == 1) { goto L230; } i__1 = colapr_ .nz; for (i__ = 1; i__ <= i__1; ++i__) { fspace[lz - 1 + i__] = 0.; } i__1 = colapr_ .ndmz; for (i__ = 1; i__ <= i__1; ++i__) { fspace[ldmz - 1 + i__] = 0.; } L230: if (colnln_ .iguess >= 2) { colnln_ .iguess = 0; } contrl_(&fspace[lxi], &fspace[lxiold], &fspace[lz], &fspace[ldmz], & fspace[lrhs], &fspace[ldelz], &fspace[ldeldz], &fspace[ldqz], & fspace[ldqdmz], &fspace[lg], &fspace[lw], &fspace[lv], &fspace[ lvalst], &fspace[lslope], &fspace[lscl], &fspace[ldscl], &fspace[ laccum], &ispace[lpvtg], &ispace[linteg], &ispace[lpvtw], &nfxpnt, &fixpnt[1], iflag, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } ispace[1] = colapr_ .n; ispace[2] = (colord_._1) .k; ispace[3] = *ncomp; ispace[4] = (colord_._1) .mstar; ispace[5] = (colord_._1) .mmax; ispace[6] = colapr_ .nz + colapr_ .ndmz + colapr_ .n + 2; k2 = (colord_._1) .k * (colord_._1) .k; ispace[7] = ispace[6] + k2 - 1; i__1 = *ncomp; for (i__ = 1; i__ <= i__1; ++i__) { ispace[i__ + 7] = m[i__]; } i__1 = colapr_ .nz; for (i__ = 1; i__ <= i__1; ++i__) { fspace[colapr_ .n + 1 + i__] = fspace[lz - 1 + i__]; } idmz = colapr_ .n + 1 + colapr_ .nz; i__1 = colapr_ .ndmz; for (i__ = 1; i__ <= i__1; ++i__) { fspace[idmz + i__] = fspace[ldmz - 1 + i__]; } ic = idmz + colapr_ .ndmz; i__1 = k2; for (i__ = 1; i__ <= i__1; ++i__) { fspace[ic + i__] = colloc_ .coef[i__ - 1]; } return 0; } int colnew_(ncomp, m, aleft, aright, zeta, ipar, ltol, tol, fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess) integer *ncomp, *m; doublereal *aleft, *aright, *zeta; integer *ipar, *ltol; doublereal *tol, *fixpnt; integer *ispace; doublereal *fspace; integer *iflag; int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (* guess) (); { return colnew_0_(0, ncomp, m, aleft, aright, zeta, ipar, ltol, tol, fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess); } int colsys_(ncomp, m, aleft, aright, zeta, ipar, ltol, tol, fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess) integer *ncomp, *m; doublereal *aleft, *aright, *zeta; integer *ipar, *ltol; doublereal *tol, *fixpnt; integer *ispace; doublereal *fspace; integer *iflag; int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (* guess) (); { return colnew_0_(1, ncomp, m, aleft, aright, zeta, ipar, ltol, tol, fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess); } int contrl_(xi, xiold, z__, dmz, rhs, delz, deldmz, dqz, dqdmz, g, w, v, valstr, slope, scale, dscale, accum, ipvtg, integs, ipvtw, nfxpnt, fixpnt, iflag, fsub, dfsub, gsub, dgsub, guess) doublereal *xi, *xiold, *z__, *dmz, *rhs, *delz, *deldmz, *dqz, *dqdmz, *g, * w, *v, *valstr, *slope, *scale, *dscale, *accum; integer *ipvtg, *integs, *ipvtw, *nfxpnt; doublereal *fixpnt; integer *iflag; int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (* guess) (); { static char fmt_495[] = "(//\002 A LOCAL ELIMINATION MATRIX IS SINGULAR \002)"; static char fmt_490[] = "(//\002 THE GLOBAL BVP-MATRIX IS SINGULAR \002)"; static char fmt_530[] = "(/\002 FIXED JACOBIAN ITERATIONS,\002)"; static char fmt_510[] = "(\002 ITERATION = \002,i3,\002 NORM (RHS) = \002,d10.2)"; static char fmt_560[] = "(/\002 CONVERGENCE AFTER\002,i3,\002 ITERATIONS\002/)"; static char fmt_540[] = "(/\002 SWITCH TO DAMPED NEWTON ITERATION,\002)"; static char fmt_500[] = "(/\002 FULL DAMPED NEWTON ITERATION,\002)"; static char fmt_520[] = "(\002 ITERATION = \002,i3,\002 RELAXATION FACTOR = \002,d10.2/\002 NORM OF SCALED RHS CHANGES FROM \002,d10.2,\002 TO\002,d10.2/\002 NORM OF RHS CHANGES FROM \002,d10.2,\002 TO\002,d10.2,d10.2)"; static char fmt_550[] = "(\002 RELAXATION FACTOR CORRECTED TO RELAX = \002,d10.2/\002 NORM OF SCALED RHS CHANGES FROM \002,d10.2,\002 TO\002,d10.2/\002 NORM OF RHS CHANGES FROM \002,d10.2,\002 TO\002,d10.2,d10.2)"; static char fmt_610[] = "(\002 MESH VALUES FOR Z(\002,i2,\002),\002)"; static char fmt_620[] = "(\002 \002,8d15.7)"; static char fmt_570[] = "(/\002 NO CONVERGENCE AFTER \002,i3,\002 ITERATIONS\002/)"; static char fmt_580[] = "(/\002 NO CONVERGENCE. RELAXATION FACTOR =\002,d10.3,\002 IS TOO SMALL (LESS THAN\002,d10.3,\002)\002/)"; static char fmt_590[] = "(\002 (NO CONVERGENCE)\002)"; static char fmt_600[] = "(\002 (PROBABLY TOLERANCES TOO STRINGENT, OR NMAX TOO \002,\002SMALL)\002)"; integer i__1, i__2, i__3; doublereal d__1, d__2; integer s_wsfe(), e_wsfe(), do_fio(); double sqrt(); static doublereal fact; static integer ifin, icor, ifrz, i__, j; static doublereal check, andif; extern int skale_(); static doublereal anscl; static integer imesh, ipred; static doublereal anfix, relax; static integer iconv, msing; static doublereal rnold, anorm, dummy[1], rnorm; static integer lj, it, iz; static doublereal factor; extern int errchk_(); static integer ifreez; static doublereal relmin; static integer noconv; extern int newmsh_(); static doublereal rlxold; static integer lmtfrz; static doublereal rstart; static integer np1; extern int lsyslv_(); static doublereal arg; static integer inz; static cilist io___721 = { 0, 0, 0, fmt_495, 0 }; static cilist io___722 = { 0, 0, 0, fmt_490, 0 }; static cilist io___726 = { 0, 0, 0, fmt_530, 0 }; static cilist io___727 = { 0, 0, 0, fmt_510, 0 }; static cilist io___728 = { 0, 0, 0, fmt_510, 0 }; static cilist io___733 = { 0, 0, 0, fmt_560, 0 }; static cilist io___734 = { 0, 0, 0, fmt_510, 0 }; static cilist io___735 = { 0, 0, 0, fmt_540, 0 }; static cilist io___737 = { 0, 0, 0, fmt_500, 0 }; static cilist io___744 = { 0, 0, 0, fmt_520, 0 }; static cilist io___745 = { 0, 0, 0, fmt_550, 0 }; static cilist io___749 = { 0, 0, 0, fmt_560, 0 }; static cilist io___750 = { 0, 0, 0, fmt_560, 0 }; static cilist io___752 = { 0, 0, 0, fmt_610, 0 }; static cilist io___753 = { 0, 0, 0, fmt_620, 0 }; static cilist io___756 = { 0, 0, 0, fmt_570, 0 }; static cilist io___757 = { 0, 0, 0, fmt_580, 0 }; static cilist io___758 = { 0, 0, 0, fmt_590, 0 }; static cilist io___759 = { 0, 0, 0, fmt_600, 0 }; --fixpnt; --ipvtw; --integs; --ipvtg; --accum; --dscale; --scale; --slope; --valstr; --v; --w; --g; --dqdmz; --dqz; --deldmz; --delz; --rhs; --dmz; --z__; --xiold; --xi; relmin = .001; rstart = .01; lmtfrz = 4; check = 0.; i__1 = (colest_._2) .ntol; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = (colest_._2) .tolin[i__ - 1]; check = (( d__1 ) >= ( check ) ? ( d__1 ) : ( check )) ; } imesh = 1; iconv = 0; if (colnln_ .nonlin == 0) { iconv = 1; } icor = 0; noconv = 0; msing = 0; L20: colnln_ .iter = 0; if (colnln_ .nonlin > 0) { goto L50; } lsyslv_(&msing, &xi[1], &xiold[1], dummy, dummy, &z__[1], &dmz[1], &g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &ipvtw[1], & rnorm, &c__0, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } if (msing == 0) { goto L400; } L30: if (msing < 0) { goto L40; } if (colout_ .iprint < 1) { io___721.ciunit = colout_ .iout; s_wsfe(&io___721); e_wsfe(); } goto L460; L40: if (colout_ .iprint < 1) { io___722.ciunit = colout_ .iout; s_wsfe(&io___722); e_wsfe(); } *iflag = 0; return 0; L50: relax = 1.; if (colnln_ .icare == 1 || colnln_ .icare == -1) { relax = rstart; } if (iconv == 0) { goto L160; } ifreez = 0; lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1], &g[1], &w[1], &v[1], &rhs[1], &dqdmz[1], &integs[1], &ipvtg[1], & ipvtw[1], &rnold, &c__1, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } if (colout_ .iprint < 0) { io___726.ciunit = colout_ .iout; s_wsfe(&io___726); e_wsfe(); } if (colout_ .iprint < 0) { io___727.ciunit = colout_ .iout; s_wsfe(&io___727); do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&rnold, (ftnlen)sizeof(doublereal)); e_wsfe(); } goto L70; L60: if (colout_ .iprint < 0) { io___728.ciunit = colout_ .iout; s_wsfe(&io___728); do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal)); e_wsfe(); } rnold = rnorm; i__1 = ifreez + 3; lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1], &g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], & ipvtw[1], &rnorm, &i__1, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } L70: if (msing != 0) { goto L30; } if (ifreez == 1) { goto L80; } ++ colnln_ .iter; ifrz = 0; L80: i__1 = colapr_ .nz; for (i__ = 1; i__ <= i__1; ++i__) { z__[i__] += delz[i__]; } i__1 = colapr_ .ndmz; for (i__ = 1; i__ <= i__1; ++i__) { dmz[i__] += deldmz[i__]; } lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1], &g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], & ipvtw[1], &rnorm, &c__2, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } if (rnorm < colout_ .precis) { goto L390; } if (rnorm > rnold) { goto L130; } if (ifreez == 1) { goto L110; } ifreez = 1; goto L60; L110: ++ifrz; if (ifrz >= lmtfrz) { ifreez = 0; } if (rnold < rnorm * 4.) { ifreez = 0; } i__1 = (colest_._2) .ntol; for (it = 1; it <= i__1; ++it) { inz = (colest_._2) .ltol[it - 1]; i__2 = colapr_ .nz; i__3 = (colord_._2) .mstar; for (iz = inz; i__3 < 0 ? iz >= i__2 : iz <= i__2; iz += i__3) { if ((d__1 = delz[iz], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (colest_._2) .tolin[it - 1] * (( d__2 = z__[iz], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1.)) { goto L60; } } } if (colout_ .iprint < 1) { io___733.ciunit = colout_ .iout; s_wsfe(&io___733); do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer)); e_wsfe(); } goto L400; L130: if (colout_ .iprint < 0) { io___734.ciunit = colout_ .iout; s_wsfe(&io___734); do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (colout_ .iprint < 0) { io___735.ciunit = colout_ .iout; s_wsfe(&io___735); e_wsfe(); } iconv = 0; relax = rstart; i__3 = colapr_ .nz; for (i__ = 1; i__ <= i__3; ++i__) { z__[i__] -= delz[i__]; } i__3 = colapr_ .ndmz; for (i__ = 1; i__ <= i__3; ++i__) { dmz[i__] -= deldmz[i__]; } np1 = colapr_ .n + 1; i__3 = np1; for (i__ = 1; i__ <= i__3; ++i__) { xiold[i__] = xi[i__]; } colapr_ .nold = colapr_ .n; colnln_ .iter = 0; L160: if (colout_ .iprint < 0) { io___737.ciunit = colout_ .iout; s_wsfe(&io___737); e_wsfe(); } lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1], &g[1], &w[1], &v[1], &rhs[1], &dqdmz[1], &integs[1], &ipvtg[1], & ipvtw[1], &rnold, &c__1, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } if (msing != 0) { goto L30; } if (colnln_ .iguess == 1) { colnln_ .iguess = 0; } skale_(& colapr_ .n, & (colord_._2) .mstar, & (colord_._2) .kd, &z__[1], &xi[1], & scale[1], &dscale[1]); goto L220; L170: rnold = rnorm; if (colnln_ .iter >= colnln_ .limit) { goto L430; } skale_(& colapr_ .n, & (colord_._2) .mstar, & (colord_._2) .kd, &z__[1], &xi[1], & scale[1], &dscale[1]); anscl = 0.; i__3 = colapr_ .nz; for (i__ = 1; i__ <= i__3; ++i__) { d__1 = delz[i__] * scale[i__]; anscl += d__1 * d__1; } i__3 = colapr_ .ndmz; for (i__ = 1; i__ <= i__3; ++i__) { d__1 = deldmz[i__] * dscale[i__]; anscl += d__1 * d__1; } anscl = sqrt(anscl / (doublereal) (colapr_ .nz + colapr_ .ndmz)); lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1], &g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], & ipvtw[1], &rnorm, &c__3, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } if (msing != 0) { goto L30; } andif = 0.; i__3 = colapr_ .nz; for (i__ = 1; i__ <= i__3; ++i__) { d__1 = (dqz[i__] - delz[i__]) * scale[i__]; andif += d__1 * d__1; } i__3 = colapr_ .ndmz; for (i__ = 1; i__ <= i__3; ++i__) { d__1 = (dqdmz[i__] - deldmz[i__]) * dscale[i__]; andif += d__1 * d__1; } andif = sqrt(andif / (doublereal) (colapr_ .nz + colapr_ .ndmz) + colout_ .precis); relax = relax * anscl / andif; if (relax > 1.) { relax = 1.; } L220: rlxold = relax; ipred = 1; ++ colnln_ .iter; i__3 = colapr_ .nz; for (i__ = 1; i__ <= i__3; ++i__) { z__[i__] += relax * delz[i__]; } i__3 = colapr_ .ndmz; for (i__ = 1; i__ <= i__3; ++i__) { dmz[i__] += relax * deldmz[i__]; } L250: lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &dqz[1], &dqdmz[1], & g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &ipvtw[ 1], &rnorm, &c__2, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &dqz[1], &dqdmz[1], & g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &ipvtw[ 1], &rnorm, &c__4, fsub, dfsub, gsub, dgsub, guess); if (iercol_ .iero > 0) { return 0; } anorm = 0.; anfix = 0.; i__3 = colapr_ .nz; for (i__ = 1; i__ <= i__3; ++i__) { d__1 = delz[i__] * scale[i__]; anorm += d__1 * d__1; d__1 = dqz[i__] * scale[i__]; anfix += d__1 * d__1; } i__3 = colapr_ .ndmz; for (i__ = 1; i__ <= i__3; ++i__) { d__1 = deldmz[i__] * dscale[i__]; anorm += d__1 * d__1; d__1 = dqdmz[i__] * dscale[i__]; anfix += d__1 * d__1; } anorm = sqrt(anorm / (doublereal) (colapr_ .nz + colapr_ .ndmz)); anfix = sqrt(anfix / (doublereal) (colapr_ .nz + colapr_ .ndmz)); if (icor == 1) { goto L280; } if (colout_ .iprint < 0) { io___744.ciunit = colout_ .iout; s_wsfe(&io___744); do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&relax, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&anorm, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&anfix, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&rnold, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal)); e_wsfe(); } goto L290; L280: if (colout_ .iprint < 0) { io___745.ciunit = colout_ .iout; s_wsfe(&io___745); do_fio(&c__1, (char *)&relax, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&anorm, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&anfix, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&rnold, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal)); e_wsfe(); } L290: icor = 0; if (anfix < colout_ .precis || rnorm < colout_ .precis) { goto L390; } if (anfix > anorm) { goto L300; } if (anfix <= check) { goto L350; } if (ipred != 1) { goto L170; } L300: if (colnln_ .iter >= colnln_ .limit) { goto L430; } ipred = 0; arg = (anfix / anorm - 1.) / relax + 1.; if (arg < 0.) { goto L170; } d__1 = relax; if (arg <= relax * .25 + d__1 * d__1 * .125) { goto L310; } factor = sqrt(arg * 8. + 1.) - 1.; if ((d__1 = factor - 1., (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < factor * .1) { goto L170; } if (factor < .5) { factor = .5; } relax /= factor; goto L320; L310: if (relax >= .9) { goto L170; } relax = 1.; L320: icor = 1; if (relax < relmin) { goto L440; } fact = relax - rlxold; i__3 = colapr_ .nz; for (i__ = 1; i__ <= i__3; ++i__) { z__[i__] += fact * delz[i__]; } i__3 = colapr_ .ndmz; for (i__ = 1; i__ <= i__3; ++i__) { dmz[i__] += fact * deldmz[i__]; } rlxold = relax; goto L250; L350: i__3 = (colest_._2) .ntol; for (it = 1; it <= i__3; ++it) { inz = (colest_._2) .ltol[it - 1]; i__2 = colapr_ .nz; i__1 = (colord_._2) .mstar; for (iz = inz; i__1 < 0 ? iz >= i__2 : iz <= i__2; iz += i__1) { if ((d__1 = dqz[iz], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (colest_._2) .tolin[it - 1] * ((d__2 = z__[iz], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1.)) { goto L170; } } } if (colout_ .iprint < 1) { io___749.ciunit = colout_ .iout; s_wsfe(&io___749); do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer)); e_wsfe(); } i__1 = colapr_ .nz; for (i__ = 1; i__ <= i__1; ++i__) { z__[i__] += dqz[i__]; } i__1 = colapr_ .ndmz; for (i__ = 1; i__ <= i__1; ++i__) { dmz[i__] += dqdmz[i__]; } L390: if ((anfix < colout_ .precis || rnorm < colout_ .precis) && colout_ .iprint < 1) { io___750.ciunit = colout_ .iout; s_wsfe(&io___750); do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer)); e_wsfe(); } iconv = 1; if (colnln_ .icare == -1) { colnln_ .icare = 0; } L400: if (colout_ .iprint >= 0) { goto L420; } i__1 = (colord_._2) .mstar; for (j = 1; j <= i__1; ++j) { io___752.ciunit = colout_ .iout; s_wsfe(&io___752); do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); e_wsfe(); io___753.ciunit = colout_ .iout; s_wsfe(&io___753); i__2 = colapr_ .nz; i__3 = (colord_._2) .mstar; for (lj = j; i__3 < 0 ? lj >= i__2 : lj <= i__2; lj += i__3) { do_fio(&c__1, (char *)&z__[lj], (ftnlen)sizeof(doublereal)); } e_wsfe(); } L420: ifin = 1; if (imesh == 2) { errchk_(&xi[1], &z__[1], &dmz[1], &valstr[1], &ifin); } if (imesh == 1 || ifin == 0 && colnln_ .icare != 2) { goto L460; } *iflag = 1; return 0; L430: if (colout_ .iprint < 1) { io___756.ciunit = colout_ .iout; s_wsfe(&io___756); do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer)); e_wsfe(); } goto L450; L440: if (colout_ .iprint < 1) { io___757.ciunit = colout_ .iout; s_wsfe(&io___757); do_fio(&c__1, (char *)&relax, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&relmin, (ftnlen)sizeof(doublereal)); e_wsfe(); } L450: *iflag = -2; ++noconv; if (colnln_ .icare == 2 && noconv > 1) { return 0; } if (colnln_ .icare == 0) { colnln_ .icare = -1; } L460: np1 = colapr_ .n + 1; i__3 = np1; for (i__ = 1; i__ <= i__3; ++i__) { xiold[i__] = xi[i__]; } colapr_ .nold = colapr_ .n; imesh = 1; if (iconv == 0 || colmsh_ .mshnum >= colmsh_ .mshlmt || colmsh_ .mshalt >= colmsh_ .mshlmt) { imesh = 2; } if (colmsh_ .mshalt >= colmsh_ .mshlmt && colmsh_ .mshnum < colmsh_ .mshlmt) { colmsh_ .mshalt = 1; } newmsh_(&imesh, &xi[1], &xiold[1], &z__[1], &dmz[1], &valstr[1], &slope[1] , &accum[1], nfxpnt, &fixpnt[1]); if (colapr_ .n <= colapr_ .nmax) { goto L480; } colapr_ .n /= 2; *iflag = -1; if (iconv == 0 && colout_ .iprint < 1) { io___758.ciunit = colout_ .iout; s_wsfe(&io___758); e_wsfe(); } if (iconv == 1 && colout_ .iprint < 1) { io___759.ciunit = colout_ .iout; s_wsfe(&io___759); e_wsfe(); } return 0; L480: if (iconv == 0) { imesh = 1; } if (colnln_ .icare == 1) { iconv = 0; } goto L20; } int skale_(n, mstar, kd, z__, xi, scale, dscale) integer *n, *mstar, *kd; doublereal *z__, *xi, *scale, *dscale; { integer z_dim1, z_offset, scale_dim1, scale_offset, dscale_dim1, dscale_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; static doublereal basm[5], scal; static integer idmz; static doublereal h__; static integer j, l, icomp, mj, iz, np1; scale_dim1 = *mstar; scale_offset = scale_dim1 + 1; scale -= scale_offset; z_dim1 = *mstar; z_offset = z_dim1 + 1; z__ -= z_offset; dscale_dim1 = *kd; dscale_offset = dscale_dim1 + 1; dscale -= dscale_offset; --xi; basm[0] = 1.; i__1 = *n; for (j = 1; j <= i__1; ++j) { iz = 1; h__ = xi[j + 1] - xi[j]; i__2 = (colord_._3) .mmax; for (l = 1; l <= i__2; ++l) { basm[l] = basm[l - 1] * h__ / (doublereal) l; } i__2 = (colord_._3) .ncomp; for (icomp = 1; icomp <= i__2; ++icomp) { scal = ((d__1 = z__[iz + j * z_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = z__[iz + (j + 1) * z_dim1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) * .5 + 1.; mj = (colord_._3) .m[icomp - 1]; i__3 = mj; for (l = 1; l <= i__3; ++l) { scale[iz + j * scale_dim1] = basm[l - 1] / scal; ++iz; } scal = basm[mj] / scal; i__3 = *kd; i__4 = (colord_._3) .ncomp; for (idmz = icomp; i__4 < 0 ? idmz >= i__3 : idmz <= i__3; idmz += i__4) { dscale[idmz + j * dscale_dim1] = scal; } } } np1 = *n + 1; i__1 = *mstar; for (iz = 1; iz <= i__1; ++iz) { scale[iz + np1 * scale_dim1] = scale[iz + *n * scale_dim1]; } return 0; } int newmsh_(mode, xi, xiold, z__, dmz, valstr, slope, accum, nfxpnt, fixpnt) integer *mode; doublereal *xi, *xiold, *z__, *dmz, *valstr, *slope, *accum; integer *nfxpnt; doublereal *fixpnt; { static char fmt_360[] = "(/\002 THE FORMER MESH (OF\002,i5,\002 SUBINTERVALS),\002,100(/8f12.6))"; static char fmt_370[] = "(/\002 EXPECTED N TOO LARGE \002)"; static char fmt_350[] = "(/\002 MESH SELECTION INFO,\002/\002 DEGREE OF EQUIDISTRIBUTION = \002,f8.5,\002 PREDICTION FOR REQUIRED N =\002,i8)"; static char fmt_340[] = "(/\002 THE NEW MESH (OF\002,i5,\002 SUBINTERVALS), \002,100(/8f12.6))"; integer i__1, i__2, i__3; doublereal d__1, d__2, d__3, d__4, d__5; integer s_wsfe(), do_fio(), e_wsfe(); double pow_dd(); static doublereal accl, accr; static integer lold; static doublereal avrg; static integer nmin; static doublereal temp; static integer lnew; static doublereal tsum; static integer nmax2, nfxp1, i__, j, l; static doublereal x, hiold; static integer ileft, iflip, nregn; static doublereal xleft, d1[40], d2[40], dummy[1]; static integer n2, noldp1, jj, in; static doublereal dx; static integer jz, naccum; static doublereal degequ; extern int horder_(); static integer iright, lcarry; static doublereal oneovh, hd6, xright; static integer kstore; extern int approx_(); static integer np1; static doublereal slphmx; static integer nmx; static cilist io___772 = { 0, 0, 0, fmt_360, 0 }; static cilist io___784 = { 0, 0, 0, fmt_370, 0 }; static cilist io___801 = { 0, 0, 0, fmt_350, 0 }; static cilist io___812 = { 0, 0, 0, fmt_340, 0 }; --fixpnt; --accum; --slope; --valstr; --dmz; --z__; --xiold; --xi; nfxp1 = *nfxpnt + 1; switch ((int)*mode) { case 1: goto L180; case 2: goto L100; case 3: goto L50; case 4: goto L20; case 5: goto L10; } L10: colmsh_ .mshlmt = 1; L20: if (colnln_ .iguess < 2) { goto L40; } noldp1 = colapr_ .nold + 1; if (colout_ .iprint < 1) { io___772.ciunit = colout_ .iout; s_wsfe(&io___772); do_fio(&c__1, (char *)& colapr_ .nold, (ftnlen)sizeof(integer)); i__1 = noldp1; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&xiold[i__], (ftnlen)sizeof(doublereal)); } e_wsfe(); } if (colnln_ .iguess != 3) { goto L40; } colapr_ .n = colapr_ .nold / 2; i__ = 0; i__1 = colapr_ .nold; for (j = 1; j <= i__1; j += 2) { ++i__; xi[i__] = xiold[j]; } L40: np1 = colapr_ .n + 1; xi[1] = (colsid_._2) .aleft; xi[np1] = (colsid_._2) .aright; goto L320; L50: if (colapr_ .n < nfxp1) { colapr_ .n = nfxp1; } np1 = colapr_ .n + 1; xi[1] = (colsid_._2) .aleft; ileft = 1; xleft = (colsid_._2) .aleft; i__1 = nfxp1; for (j = 1; j <= i__1; ++j) { xright = (colsid_._2) .aright; iright = np1; if (j == nfxp1) { goto L60; } xright = fixpnt[j]; nmin = (integer) ((xright - (colsid_._2) .aleft) / ((colsid_._2) .aright - (colsid_._2) .aleft) * (doublereal) colapr_ .n + 1.5); if (nmin > colapr_ .n - *nfxpnt + j) { nmin = colapr_ .n - *nfxpnt + j; } i__2 = ileft + 1; iright = (( i__2 ) >= ( nmin ) ? ( i__2 ) : ( nmin )) ; L60: xi[iright] = xright; nregn = iright - ileft - 1; if (nregn == 0) { goto L80; } dx = (xright - xleft) / (doublereal) (nregn + 1); i__2 = nregn; for (i__ = 1; i__ <= i__2; ++i__) { xi[ileft + i__] = xleft + (doublereal) i__ * dx; } L80: ileft = iright; xleft = xright; } goto L320; L100: n2 = colapr_ .n << 1; if (n2 <= colapr_ .nmax) { goto L120; } if (*mode == 2) { goto L110; } colapr_ .n = colapr_ .nmax / 2; goto L220; L110: if (colout_ .iprint < 1) { io___784.ciunit = colout_ .iout; s_wsfe(&io___784); e_wsfe(); } colapr_ .n = n2; return 0; L120: if (colmsh_ .mshflg == 0) { goto L140; } kstore = 1; i__1 = colapr_ .nold; for (i__ = 1; i__ <= i__1; ++i__) { hd6 = (xiold[i__ + 1] - xiold[i__]) / 6.; x = xiold[i__] + hd6; approx_(&i__, &x, &valstr[kstore], colbas_ .asave, dummy, &xiold[1], & colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__4, dummy, & c__0); x += hd6 * 4.; kstore += (colord_._2) .mstar * 3; approx_(&i__, &x, &valstr[kstore], & colbas_ .asave[84], dummy, &xiold[ 1], & colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, & c__4, dummy, &c__0); kstore += (colord_._2) .mstar; } goto L160; L140: kstore = 1; i__1 = colapr_ .n; for (i__ = 1; i__ <= i__1; ++i__) { x = xi[i__]; hd6 = (xi[i__ + 1] - xi[i__]) / 6.; for (j = 1; j <= 4; ++j) { x += hd6; if (j == 3) { x += hd6; } approx_(&i__, &x, &valstr[kstore], & colbas_ .asave[j * 28 - 28], dummy, &xiold[1], & colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__4, dummy, &c__0); kstore += (colord_._2) .mstar; } } L160: colmsh_ .mshflg = 0; colmsh_ .mshnum = 1; *mode = 2; j = 2; i__1 = colapr_ .n; for (i__ = 1; i__ <= i__1; ++i__) { xi[j] = (xiold[i__] + xiold[i__ + 1]) / 2.; xi[j + 1] = xiold[i__ + 1]; j += 2; } colapr_ .n = n2; goto L320; L180: if (colapr_ .nold == 1) { goto L100; } if (colapr_ .nold <= *nfxpnt << 1) { goto L100; } i__ = 1; hiold = xiold[2] - xiold[1]; horder_(&c__1, d1, &hiold, &dmz[1], & (colord_._2) .ncomp, & (colord_._2) .k); hiold = xiold[3] - xiold[2]; horder_(&c__2, d2, &hiold, &dmz[1], & (colord_._2) .ncomp, & (colord_._2) .k); accum[1] = 0.; slope[1] = 0.; oneovh = 2. / (xiold[3] - xiold[1]); i__1 = (colest_._2) .ntol; for (j = 1; j <= i__1; ++j) { jj = (colest_._2) .jtol[j - 1]; jz = (colest_._2) .ltol[j - 1]; d__5 = (d__1 = d2[jj - 1] - d1[jj - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * (colest_._2) .wgtmsh[ j - 1] * oneovh / ((d__2 = z__[jz], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1.); d__3 = slope[1], d__4 = pow_dd(&d__5, & (colest_._2) .root[j - 1]); slope[1] = (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ; } slphmx = slope[1] * (xiold[2] - xiold[1]); accum[2] = slphmx; iflip = 1; i__1 = colapr_ .nold; for (i__ = 2; i__ <= i__1; ++i__) { hiold = xiold[i__ + 1] - xiold[i__]; if (iflip == -1) { horder_(&i__, d1, &hiold, &dmz[1], & (colord_._2) .ncomp, & (colord_._2) .k); } if (iflip == 1) { horder_(&i__, d2, &hiold, &dmz[1], & (colord_._2) .ncomp, & (colord_._2) .k); } oneovh = 2. / (xiold[i__ + 1] - xiold[i__ - 1]); slope[i__] = 0.; i__2 = (colest_._2) .ntol; for (j = 1; j <= i__2; ++j) { jj = (colest_._2) .jtol[j - 1]; jz = (colest_._2) .ltol[j - 1] + (i__ - 1) * (colord_._2) .mstar; d__5 = (d__1 = d2[jj - 1] - d1[jj - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * (colest_._2) .wgtmsh[j - 1] * oneovh / ((d__2 = z__[jz], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1.); d__3 = slope[i__], d__4 = pow_dd(&d__5, & (colest_._2) .root[j - 1]); slope[i__] = (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ; } temp = slope[i__] * (xiold[i__ + 1] - xiold[i__]); slphmx = (( slphmx ) >= ( temp ) ? ( slphmx ) : ( temp )) ; accum[i__ + 1] = accum[i__] + temp; iflip = -iflip; } avrg = accum[colapr_ .nold + 1] / (doublereal) colapr_ .nold; degequ = avrg / (( slphmx ) >= ( colout_ .precis ) ? ( slphmx ) : ( colout_ .precis )) ; naccum = (integer) (accum[colapr_ .nold + 1] + 1.); if (colout_ .iprint < 0) { io___801.ciunit = colout_ .iout; s_wsfe(&io___801); do_fio(&c__1, (char *)°equ, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&naccum, (ftnlen)sizeof(integer)); e_wsfe(); } if (avrg < colout_ .precis) { goto L100; } if (degequ >= .5) { goto L100; } i__1 = colapr_ .nold + 1; nmx = (( i__1 ) >= ( naccum ) ? ( i__1 ) : ( naccum )) / 2; nmax2 = colapr_ .nmax / 2; i__1 = (( nmax2 ) <= ( colapr_ .nold ) ? ( nmax2 ) : ( colapr_ .nold )) ; colapr_ .n = (( i__1 ) <= ( nmx ) ? ( i__1 ) : ( nmx )) ; L220: noldp1 = colapr_ .nold + 1; if (colapr_ .n < nfxp1) { colapr_ .n = nfxp1; } ++ colmsh_ .mshnum; if (colapr_ .n < colapr_ .nold) { colmsh_ .mshnum = colmsh_ .mshlmt; } if (colapr_ .n > colapr_ .nold / 2) { colmsh_ .mshalt = 1; } if (colapr_ .n == colapr_ .nold / 2) { ++ colmsh_ .mshalt; } colmsh_ .mshflg = 0; in = 1; accl = 0.; lold = 2; xi[1] = (colsid_._2) .aleft; xi[colapr_ .n + 1] = (colsid_._2) .aright; i__1 = nfxp1; for (i__ = 1; i__ <= i__1; ++i__) { if (i__ == nfxp1) { goto L250; } i__2 = noldp1; for (j = lold; j <= i__2; ++j) { lnew = j; if (fixpnt[i__] <= xiold[j]) { goto L240; } } L240: accr = accum[lnew] + (fixpnt[i__] - xiold[lnew]) * slope[lnew - 1]; nregn = (integer) ((accr - accl) / accum[noldp1] * (doublereal) colapr_ .n - .5); i__2 = nregn, i__3 = colapr_ .n - in - nfxp1 + i__; nregn = (( i__2 ) <= ( i__3 ) ? ( i__2 ) : ( i__3 )) ; xi[in + nregn + 1] = fixpnt[i__]; goto L260; L250: accr = accum[noldp1]; lnew = noldp1; nregn = colapr_ .n - in; L260: if (nregn == 0) { goto L300; } temp = accl; tsum = (accr - accl) / (doublereal) (nregn + 1); i__2 = nregn; for (j = 1; j <= i__2; ++j) { ++in; temp += tsum; i__3 = lnew; for (l = lold; l <= i__3; ++l) { lcarry = l; if (temp <= accum[l]) { goto L280; } } L280: lold = lcarry; xi[in] = xiold[lold - 1] + (temp - accum[lold - 1]) / slope[lold - 1]; } L300: ++in; accl = accr; lold = lnew; } *mode = 1; L320: np1 = colapr_ .n + 1; if (colout_ .iprint < 1) { io___812.ciunit = colout_ .iout; s_wsfe(&io___812); do_fio(&c__1, (char *)& colapr_ .n, (ftnlen)sizeof(integer)); i__1 = np1; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&xi[i__], (ftnlen)sizeof(doublereal)); } e_wsfe(); } colapr_ .nz = (colord_._2) .mstar * (colapr_ .n + 1); colapr_ .ndmz = (colord_._2) .kd * colapr_ .n; return 0; } int consts_(k, rho, coef) integer *k; doublereal *rho, *coef; { static doublereal cnsts1[28] = { .25,.0625,.072169,.018342,.019065,.05819, .0054658,.005337,.01889,.027792,.0016095,.0014964,.0075938, .0057573,.018342,.004673,4.15e-4,.001919,.001468,.006371,.00461, 1.342e-4,1.138e-4,4.889e-4,4.177e-4,.001374,.001654,.002863 }; static doublereal cnsts2[28] = { .125,.002604,.008019,2.17e-5,7.453e-5, 5.208e-4,9.689e-8,3.689e-7,3.1e-6,2.451e-5,2.691e-10,1.12e-9, 1.076e-8,9.405e-8,1.033e-6,5.097e-13,2.29e-12,2.446e-11,2.331e-10, 2.936e-9,3.593e-8,7.001e-16,3.363e-15,3.921e-14,4.028e-13, 5.646e-12,7.531e-11,1.129e-9 }; integer coef_dim1, coef_offset, i__1, i__2; static integer koff, mtot, i__, j, l; extern int rkbas_(); static integer jcomp, ltoli; static doublereal dummy[1]; static integer mj, iz; extern int vmonde_(); coef_dim1 = *k; coef_offset = coef_dim1 + 1; coef -= coef_offset; --rho; koff = *k * (*k + 1) / 2; iz = 1; i__1 = (colord_._4) .ncomp; for (j = 1; j <= i__1; ++j) { mj = (colord_._4) .m[j - 1]; i__2 = mj; for (l = 1; l <= i__2; ++l) { (colest_._2) .wgterr[iz - 1] = cnsts1[koff - mj + l - 1]; ++iz; } } jcomp = 1; mtot = (colord_._4) .m[0]; i__2 = (colest_._2) .ntol; for (i__ = 1; i__ <= i__2; ++i__) { ltoli = (colest_._2) .ltol[i__ - 1]; L20: if (ltoli <= mtot) { goto L30; } ++jcomp; mtot += (colord_._4) .m[jcomp - 1]; goto L20; L30: (colest_._2) .jtol[i__ - 1] = jcomp; (colest_._2) .wgtmsh[i__ - 1] = cnsts2[koff + ltoli - mtot - 1] * 10. / (colest_._2) .tolin[i__ - 1]; (colest_._2) .root[i__ - 1] = 1. / (doublereal) (*k + mtot - ltoli + 1); } switch ((int)*k) { case 1: goto L50; case 2: goto L60; case 3: goto L70; case 4: goto L80; case 5: goto L90; case 6: goto L100; case 7: goto L110; } L50: rho[1] = 0.; goto L120; L60: rho[2] = .57735026918962576451; rho[1] = -rho[2]; goto L120; L70: rho[3] = .77459666924148337704; rho[2] = 0.; rho[1] = -rho[3]; goto L120; L80: rho[4] = .86113631159405257523; rho[3] = .3399810435848562648; rho[2] = -rho[3]; rho[1] = -rho[4]; goto L120; L90: rho[5] = .9061798459386639928; rho[4] = .53846931010568309104; rho[3] = 0.; rho[2] = -rho[4]; rho[1] = -rho[5]; goto L120; L100: rho[6] = .93246951420315202781; rho[5] = .66120938646626451366; rho[4] = .23861918608319690863; rho[3] = -rho[4]; rho[2] = -rho[5]; rho[1] = -rho[6]; goto L120; L110: rho[7] = .949107991234275852452; rho[6] = .74153118559939443986; rho[5] = .4058451513773971669; rho[4] = 0.; rho[3] = -rho[5]; rho[2] = -rho[6]; rho[1] = -rho[7]; L120: i__2 = *k; for (j = 1; j <= i__2; ++j) { rho[j] = (rho[j] + 1.) * .5; } i__2 = *k; for (j = 1; j <= i__2; ++j) { i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { coef[i__ + j * coef_dim1] = 0.; } coef[j + j * coef_dim1] = 1.; vmonde_(&rho[1], &coef[j * coef_dim1 + 1], k); } rkbas_(&c_b89, &coef[coef_offset], k, & (colord_._4) .mmax, colbas_ .b, dummy, & c__0); i__2 = *k; for (i__ = 1; i__ <= i__2; ++i__) { rkbas_(&rho[i__], &coef[coef_offset], k, & (colord_._4) .mmax, & colbas_ .acol[i__ * 28 - 28], dummy, &c__0); } rkbas_(&c_b1934, &coef[coef_offset], k, & (colord_._4) .mmax, colbas_ .asave, dummy, &c__0); rkbas_(&c_b1936, &coef[coef_offset], k, & (colord_._4) .mmax, & colbas_ .asave[ 28], dummy, &c__0); rkbas_(&c_b1938, &coef[coef_offset], k, & (colord_._4) .mmax, & colbas_ .asave[ 56], dummy, &c__0); rkbas_(&c_b1940, &coef[coef_offset], k, & (colord_._4) .mmax, & colbas_ .asave[ 84], dummy, &c__0); return 0; } int errchk_(xi, z__, dmz, valstr, ifin) doublereal *xi, *z__, *dmz, *valstr; integer *ifin; { static char fmt_130[] = "(/\002 THE ESTIMATED ERRORS ARE,\002)"; static char fmt_120[] = "(\002 U(\002,i2,\002) -\002,4d12.4)"; integer i__1, i__2; doublereal d__1, d__2; integer s_wsfe(), e_wsfe(), do_fio(); static integer knew, ltjz, iback, j, i__, l; static doublereal x; static integer ltolj; static doublereal dummy[1]; static integer lj, mj; static doublereal errest[40]; static integer kstore; extern int approx_(); static doublereal err[40]; static cilist io___837 = { 0, 0, 0, fmt_130, 0 }; static cilist io___840 = { 0, 0, 0, fmt_120, 0 }; --valstr; --dmz; --z__; --xi; *ifin = 1; colmsh_ .mshflg = 1; i__1 = (colord_._2) .mstar; for (j = 1; j <= i__1; ++j) { errest[j - 1] = 0.; } i__1 = colapr_ .n; for (iback = 1; iback <= i__1; ++iback) { i__ = colapr_ .n + 1 - iback; knew = ((i__ - 1 << 2) + 2) * (colord_._2) .mstar + 1; kstore = ((i__ - 1 << 1) + 1) * (colord_._2) .mstar + 1; x = xi[i__] + (xi[i__ + 1] - xi[i__]) * 2. / 3.; approx_(&i__, &x, &valstr[knew], & colbas_ .asave[56], dummy, &xi[1], & colapr_ .n, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__4, dummy, & c__0); i__2 = (colord_._2) .mstar; for (l = 1; l <= i__2; ++l) { err[l - 1] = (colest_._2) .wgterr[l - 1] * (d__1 = valstr[knew] - valstr[kstore], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); ++knew; ++kstore; } knew = ((i__ - 1 << 2) + 1) * (colord_._2) .mstar + 1; kstore = (i__ - 1 << 1) * (colord_._2) .mstar + 1; x = xi[i__] + (xi[i__ + 1] - xi[i__]) / 3.; approx_(&i__, &x, &valstr[knew], & colbas_ .asave[28], dummy, &xi[1], & colapr_ .n, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__4, dummy, & c__0); i__2 = (colord_._2) .mstar; for (l = 1; l <= i__2; ++l) { err[l - 1] += (colest_._2) .wgterr[l - 1] * (d__1 = valstr[knew] - valstr[kstore], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); ++knew; ++kstore; } i__2 = (colord_._2) .mstar; for (l = 1; l <= i__2; ++l) { d__1 = errest[l - 1], d__2 = err[l - 1]; errest[l - 1] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if (*ifin == 0) { goto L60; } i__2 = (colest_._2) .ntol; for (j = 1; j <= i__2; ++j) { ltolj = (colest_._2) .ltol[j - 1]; ltjz = ltolj + (i__ - 1) * (colord_._2) .mstar; if (err[ltolj - 1] > (colest_._2) .tolin[j - 1] * ((d__1 = z__[ltjz], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + 1.)) { *ifin = 0; } } L60: ; } if (colout_ .iprint >= 0) { return 0; } io___837.ciunit = colout_ .iout; s_wsfe(&io___837); e_wsfe(); lj = 1; i__1 = (colord_._2) .ncomp; for (j = 1; j <= i__1; ++j) { mj = lj - 1 + (colord_._2) .m[j - 1]; io___840.ciunit = colout_ .iout; s_wsfe(&io___840); do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); i__2 = mj; for (l = lj; l <= i__2; ++l) { do_fio(&c__1, (char *)&errest[l - 1], (ftnlen)sizeof(doublereal)); } e_wsfe(); lj = mj + 1; } return 0; } int lsyslv_(msing, xi, xiold, z__, dmz, delz, deldmz, g, w, v, rhs, dmzo, integs, ipvtg, ipvtw, rnorm, mode, fsub, dfsub, gsub, dgsub, guess) integer *msing; doublereal *xi, *xiold, *z__, *dmz, *delz, *deldmz, *g, *w, *v, *rhs, *dmzo; integer *integs, *ipvtg, *ipvtw; doublereal *rnorm; integer *mode; int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (* guess) (); { integer i__1, i__2, i__3; doublereal d__1; double sqrt(); static integer iold; static doublereal gval; static integer ncol, idmz, irhs; static doublereal hrho, xcol, zval[40]; static integer izet, nrow; static doublereal f[40], h__; static integer i__, j, l, lside; static doublereal dmval[20], value; static integer idmzo; static doublereal dummy[1]; static integer m1; static doublereal df[800]; static integer ig, jj; static doublereal at[28]; static integer iv, iw; extern int gblock_(); static integer lw; extern int fcblok_(); static integer iz; extern int sbblok_(), gderiv_(), vwblok_(), dmzsol_(), approx_(); static doublereal dgz[40], xii; --ipvtw; --ipvtg; integs -= 4; --dmzo; --rhs; --v; --w; --g; --deldmz; --delz; --dmz; --z__; --xiold; --xi; m1 = *mode + 1; switch ((int)m1) { case 1: goto L10; case 2: goto L30; case 3: goto L30; case 4: goto L30; case 5: goto L310; } L10: i__1 = (colord_._2) .mstar; for (i__ = 1; i__ <= i__1; ++i__) { zval[i__ - 1] = 0.; } L30: idmz = 1; idmzo = 1; irhs = 1; ig = 1; iw = 1; iv = 1; (colsid_._3) .izeta = 1; lside = 0; iold = 1; ncol = (colord_._2) .mstar << 1; *rnorm = 0.; if (*mode > 1) { goto L80; } i__1 = colapr_ .n; for (i__ = 1; i__ <= i__1; ++i__) { integs[i__ * 3 + 2] = ncol; if (i__ < colapr_ .n) { goto L40; } integs[colapr_ .n * 3 + 3] = ncol; lside = (colord_._2) .mstar; goto L60; L40: integs[i__ * 3 + 3] = (colord_._2) .mstar; L50: if (lside == (colord_._2) .mstar) { goto L60; } if ((colsid_._3) .zeta[lside] >= xi[i__] + colout_ .precis) { goto L60; } ++lside; goto L50; L60: nrow = (colord_._2) .mstar + lside; integs[i__ * 3 + 1] = nrow; } L80: if (*mode == 2) { goto L90; } lw = (colord_._2) .kd * (colord_._2) .kd * colapr_ .n; i__1 = lw; for (l = 1; l <= i__1; ++l) { w[l] = 0.; } L90: i__1 = colapr_ .n; for (i__ = 1; i__ <= i__1; ++i__) { xii = xi[i__]; h__ = xi[i__ + 1] - xi[i__]; nrow = integs[i__ * 3 + 1]; L100: if ((colsid_._3) .izeta > (colord_._2) .mstar) { goto L140; } if ((colsid_._3) .zeta[(colsid_._3) .izeta - 1] > xii + colout_ .precis) { goto L140; } if (*mode == 0) { goto L110; } if (colnln_ .iguess != 1) { goto L102; } (*guess)(&xii, zval, dmval); if (iercol_ .iero > 0) { return 0; } goto L110; L102: if (*mode != 1) { goto L106; } approx_(&iold, &xii, zval, at, colloc_ .coef, &xiold[1], & colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__2, dummy, & c__0); goto L110; L106: approx_(&i__, &xii, zval, at, dummy, &xi[1], & colapr_ .n, &z__[1], & dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__1, dummy, &c__0); if (*mode == 3) { goto L120; } L110: (*gsub)(& (colsid_._3) .izeta, zval, &gval); if (iercol_ .iero > 0) { return 0; } rhs[colapr_ .ndmz + (colsid_._3) .izeta] = -gval; d__1 = gval; *rnorm += d__1 * d__1; if (*mode == 2) { goto L130; } L120: gderiv_(&g[ig], &nrow, & (colsid_._3) .izeta, zval, dgz, &c__1, dgsub); if (iercol_ .iero > 0) { return 0; } L130: ++ (colsid_._3) .izeta; goto L100; L140: i__2 = (colord_._2) .k; for (j = 1; j <= i__2; ++j) { hrho = h__ * colloc_ .rho[j - 1]; xcol = xii + hrho; if (*mode == 0) { goto L200; } if (colnln_ .iguess != 1) { goto L160; } (*guess)(&xcol, zval, &dmzo[irhs]); if (iercol_ .iero > 0) { return 0; } goto L170; L160: if (*mode != 1) { goto L190; } approx_(&iold, &xcol, zval, at, colloc_ .coef, &xiold[1], & colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__2, &dmzo[irhs], &c__1); L170: (*fsub)(&xcol, zval, f); if (iercol_ .iero > 0) { return 0; } i__3 = (colord_._2) .ncomp; for (jj = 1; jj <= i__3; ++jj) { value = dmzo[irhs] - f[jj - 1]; rhs[irhs] = -value; d__1 = value; *rnorm += d__1 * d__1; ++irhs; } goto L210; L190: approx_(&i__, &xcol, zval, & colbas_ .acol[j * 28 - 28], colloc_ .coef, &xi[1], & colapr_ .n, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__4, dummy, &c__0); if (*mode == 3) { goto L210; } (*fsub)(&xcol, zval, f); if (iercol_ .iero > 0) { return 0; } i__3 = (colord_._2) .ncomp; for (jj = 1; jj <= i__3; ++jj) { value = dmz[irhs] - f[jj - 1]; rhs[irhs] = -value; d__1 = value; *rnorm += d__1 * d__1; ++irhs; } goto L220; L200: (*fsub)(&xcol, zval, &rhs[irhs]); if (iercol_ .iero > 0) { return 0; } irhs += (colord_._2) .ncomp; L210: vwblok_(&xcol, &hrho, &j, &w[iw], &v[iv], &ipvtw[idmz], & (colord_._2) .kd, zval, df, & colbas_ .acol[j * 28 - 28], &dmzo[ idmzo], & (colord_._2) .ncomp, dfsub, msing); if (iercol_ .iero > 0) { return 0; } if (*msing != 0) { return 0; } L220: ; } if (*mode != 2) { gblock_(&h__, &g[ig], &nrow, & (colsid_._3) .izeta, &w[iw], &v[iv], & (colord_._2) .kd, dummy, &deldmz[idmz], &ipvtw[idmz], &c__1); } if (i__ < colapr_ .n) { goto L280; } (colsid_._3) .izsave = (colsid_._3) .izeta; L240: if ((colsid_._3) .izeta > (colord_._2) .mstar) { goto L290; } if (*mode == 0) { goto L250; } if (colnln_ .iguess != 1) { goto L245; } (*guess)(& (colsid_._3) .aright, zval, dmval); if (iercol_ .iero > 0) { return 0; } goto L250; L245: if (*mode != 1) { goto L246; } i__2 = colapr_ .nold + 1; approx_(&i__2, & (colsid_._3) .aright, zval, at, colloc_ .coef, &xiold[1], & colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__1, dummy, & c__0); goto L250; L246: i__2 = colapr_ .n + 1; approx_(&i__2, & (colsid_._3) .aright, zval, at, colloc_ .coef, &xi[1], & colapr_ .n, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__1, dummy, & c__0); if (*mode == 3) { goto L260; } L250: (*gsub)(& (colsid_._3) .izeta, zval, &gval); if (iercol_ .iero > 0) { return 0; } rhs[colapr_ .ndmz + (colsid_._3) .izeta] = -gval; d__1 = gval; *rnorm += d__1 * d__1; if (*mode == 2) { goto L270; } L260: i__2 = (colsid_._3) .izeta + (colord_._2) .mstar; gderiv_(&g[ig], &nrow, &i__2, zval, dgz, &c__2, dgsub); if (iercol_ .iero > 0) { return 0; } L270: ++ (colsid_._3) .izeta; goto L240; L280: ig += nrow * ncol; iv += (colord_._2) .kd * (colord_._2) .mstar; iw += (colord_._2) .kd * (colord_._2) .kd; idmz += (colord_._2) .kd; if (*mode == 1) { idmzo += (colord_._2) .kd; } L290: ; } if (*mode == 0 || *mode == 3) { goto L300; } *rnorm = sqrt(*rnorm / (doublereal) (colapr_ .nz + colapr_ .ndmz)); if (*mode != 2) { goto L300; } return 0; L300: fcblok_(&g[1], &integs[4], & colapr_ .n, &ipvtg[1], df, msing); *msing = -(*msing); if (*msing != 0) { return 0; } L310: i__1 = colapr_ .ndmz; for (l = 1; l <= i__1; ++l) { deldmz[l] = rhs[l]; } iz = 1; idmz = 1; iw = 1; izet = 1; i__1 = colapr_ .n; for (i__ = 1; i__ <= i__1; ++i__) { nrow = integs[i__ * 3 + 1]; (colsid_._3) .izeta = nrow + 1 - (colord_._2) .mstar; if (i__ == colapr_ .n) { (colsid_._3) .izeta = (colsid_._3) .izsave; } L322: if (izet == (colsid_._3) .izeta) { goto L324; } delz[iz - 1 + izet] = rhs[colapr_ .ndmz + izet]; ++izet; goto L322; L324: h__ = xi[i__ + 1] - xi[i__]; gblock_(&h__, &g[1], &nrow, & (colsid_._3) .izeta, &w[iw], &v[1], & (colord_._2) .kd, &delz[iz], &deldmz[idmz], &ipvtw[idmz], &c__2); iz += (colord_._2) .mstar; idmz += (colord_._2) .kd; iw += (colord_._2) .kd * (colord_._2) .kd; if (i__ < colapr_ .n) { goto L320; } L326: if (izet > (colord_._2) .mstar) { goto L320; } delz[iz - 1 + izet] = rhs[colapr_ .ndmz + izet]; ++izet; goto L326; L320: ; } sbblok_(&g[1], &integs[4], & colapr_ .n, &ipvtg[1], &delz[1]); dmzsol_(& (colord_._2) .kd, & (colord_._2) .mstar, & colapr_ .n, &v[1], &delz[1], & deldmz[1]); if (*mode != 1) { return 0; } i__1 = colapr_ .ndmz; for (l = 1; l <= i__1; ++l) { dmz[l] = dmzo[l]; } iz = 1; idmz = 1; iw = 1; izet = 1; i__1 = colapr_ .n; for (i__ = 1; i__ <= i__1; ++i__) { nrow = integs[i__ * 3 + 1]; (colsid_._3) .izeta = nrow + 1 - (colord_._2) .mstar; if (i__ == colapr_ .n) { (colsid_._3) .izeta = (colsid_._3) .izsave; } L330: if (izet == (colsid_._3) .izeta) { goto L340; } z__[iz - 1 + izet] = dgz[izet - 1]; ++izet; goto L330; L340: h__ = xi[i__ + 1] - xi[i__]; gblock_(&h__, &g[1], &nrow, & (colsid_._3) .izeta, &w[iw], df, & (colord_._2) .kd, &z__[iz], &dmz[idmz], &ipvtw[idmz], &c__2); iz += (colord_._2) .mstar; idmz += (colord_._2) .kd; iw += (colord_._2) .kd * (colord_._2) .kd; if (i__ < colapr_ .n) { goto L350; } L342: if (izet > (colord_._2) .mstar) { goto L350; } z__[iz - 1 + izet] = dgz[izet - 1]; ++izet; goto L342; L350: ; } sbblok_(&g[1], &integs[4], & colapr_ .n, &ipvtg[1], &z__[1]); dmzsol_(& (colord_._2) .kd, & (colord_._2) .mstar, & colapr_ .n, &v[1], &z__[1], &dmz[ 1]); return 0; } int gderiv_(gi, nrow, irow, zval, dgz, mode, dgsub) doublereal *gi; integer *nrow, *irow; doublereal *zval, *dgz; integer *mode; int (*dgsub) (); { integer gi_dim1, gi_offset, i__1; static integer j; static doublereal dg[40], dot; gi_dim1 = *nrow; gi_offset = gi_dim1 + 1; gi -= gi_offset; --zval; --dgz; i__1 = (colord_._5) .mstar; for (j = 1; j <= i__1; ++j) { dg[j - 1] = 0.; } (*dgsub)(& (colsid_._2) .izeta, &zval[1], dg); if (iercol_ .iero > 0) { return 0; } if (colnln_ .nonlin == 0 || colnln_ .iter > 0) { goto L30; } dot = 0.; i__1 = (colord_._5) .mstar; for (j = 1; j <= i__1; ++j) { dot += dg[j - 1] * zval[j]; } dgz[(colsid_._2) .izeta] = dot; L30: if (*mode == 2) { goto L50; } i__1 = (colord_._5) .mstar; for (j = 1; j <= i__1; ++j) { gi[*irow + j * gi_dim1] = dg[j - 1]; gi[*irow + ((colord_._5) .mstar + j) * gi_dim1] = 0.; } return 0; L50: i__1 = (colord_._5) .mstar; for (j = 1; j <= i__1; ++j) { gi[*irow + j * gi_dim1] = 0.; gi[*irow + ((colord_._5) .mstar + j) * gi_dim1] = dg[j - 1]; } return 0; } int vwblok_(xcol, hrho, jj, wi, vi, ipvtw, kd, zval, df, acol, dmzo, ncomp, dfsub, msing) doublereal *xcol, *hrho; integer *jj; doublereal *wi, *vi; integer *ipvtw, *kd; doublereal *zval, *df, *acol, *dmzo; integer *ncomp; int (*dfsub) (); integer *msing; { integer wi_dim1, wi_offset, vi_dim1, vi_offset, df_dim1, df_offset, i__1, i__2, i__3, i__4; static doublereal fact, basm[5]; static integer jcol; extern int dgefa_(); static integer j, l; extern int dgesl_(); static integer jcomp, i0, i1, i2; static doublereal ha[28] ; static integer id; static doublereal bl; static integer mj, jn, ll, ir, jv, jw, iw, lp1, jdf; static doublereal ajl; --ipvtw; vi_dim1 = *kd; vi_offset = vi_dim1 + 1; vi -= vi_offset; wi_dim1 = *kd; wi_offset = wi_dim1 + 1; wi -= wi_offset; --zval; acol -= 8; --dmzo; df_dim1 = *ncomp; df_offset = df_dim1 + 1; df -= df_offset; if (*jj > 1) { goto L30; } i__1 = *kd; for (id = 1; id <= i__1; ++id) { wi[id + id * wi_dim1] = 1.; } L30: fact = 1.; i__1 = (colord_._6) .mmax; for (l = 1; l <= i__1; ++l) { fact = fact * *hrho / (doublereal) l; basm[l - 1] = fact; i__2 = (colord_._6) .k; for (j = 1; j <= i__2; ++j) { ha[j + l * 7 - 8] = fact * acol[j + l * 7]; } } i__2 = (colord_._6) .mstar; for (jcol = 1; jcol <= i__2; ++jcol) { i__1 = *ncomp; for (ir = 1; ir <= i__1; ++ir) { df[ir + jcol * df_dim1] = 0.; } } (*dfsub)(xcol, &zval[1], &df[df_offset]); if (iercol_ .iero > 0) { return 0; } i0 = (*jj - 1) * *ncomp; i1 = i0 + 1; i2 = i0 + *ncomp; if (colnln_ .nonlin == 0 || colnln_ .iter > 0) { goto L60; } i__1 = (colord_._6) .mstar; for (j = 1; j <= i__1; ++j) { fact = -zval[j]; i__2 = *ncomp; for (id = 1; id <= i__2; ++id) { dmzo[i0 + id] += fact * df[id + j * df_dim1]; } } L60: i__2 = (colord_._6) .mstar; for (j = 1; j <= i__2; ++j) { i__1 = *ncomp; for (id = 1; id <= i__1; ++id) { vi[i0 + id + j * vi_dim1] = df[id + j * df_dim1]; } } jn = 1; i__1 = *ncomp; for (jcomp = 1; jcomp <= i__1; ++jcomp) { mj = (colord_._6) .m[jcomp - 1]; jn += mj; i__2 = mj; for (l = 1; l <= i__2; ++l) { jv = jn - l; jw = jcomp; i__3 = (colord_._6) .k; for (j = 1; j <= i__3; ++j) { ajl = -ha[j + l * 7 - 8]; i__4 = i2; for (iw = i1; iw <= i__4; ++iw) { wi[iw + jw * wi_dim1] += ajl * vi[iw + jv * vi_dim1]; } jw += *ncomp; } lp1 = l + 1; if (l == mj) { goto L130; } i__3 = mj; for (ll = lp1; ll <= i__3; ++ll) { jdf = jn - ll; bl = basm[ll - l - 1]; i__4 = i2; for (iw = i1; iw <= i__4; ++iw) { vi[iw + jv * vi_dim1] += bl * vi[iw + jdf * vi_dim1]; } } L130: ; } } if (*jj < (colord_._6) .k) { return 0; } *msing = 0; dgefa_(&wi[wi_offset], kd, kd, &ipvtw[1], msing); if (*msing != 0) { return 0; } i__1 = (colord_._6) .mstar; for (j = 1; j <= i__1; ++j) { dgesl_(&wi[wi_offset], kd, kd, &ipvtw[1], &vi[j * vi_dim1 + 1], &c__0) ; } return 0; } int gblock_(h__, gi, nrow, irow, wi, vi, kd, rhsz, rhsdmz, ipvtw, mode) doublereal *h__, *gi; integer *nrow, *irow; doublereal *wi, *vi; integer *kd; doublereal *rhsz, *rhsdmz; integer *ipvtw, *mode; { integer gi_dim1, gi_offset, vi_dim1, vi_offset, i__1, i__2, i__3, i__4; static doublereal fact, basm[5]; static integer jcol; static doublereal rsum; static integer j, l; extern int dgesl_(); static integer icomp, jcomp; static doublereal hb[28] ; static integer id, jd, mj, ll, ir, ind; gi_dim1 = *nrow; gi_offset = gi_dim1 + 1; gi -= gi_offset; --wi; vi_dim1 = *kd; vi_offset = vi_dim1 + 1; vi -= vi_offset; --rhsz; --rhsdmz; --ipvtw; fact = 1.; basm[0] = 1.; i__1 = (colord_._7) .mmax; for (l = 1; l <= i__1; ++l) { fact = fact * *h__ / (doublereal) l; basm[l] = fact; i__2 = (colord_._7) .k; for (j = 1; j <= i__2; ++j) { hb[j + l * 7 - 8] = fact * colbas_ .b[j + l * 7 - 8]; } } switch ((int)*mode) { case 1: goto L40; case 2: goto L110; } L40: i__1 = (colord_._7) .mstar; for (j = 1; j <= i__1; ++j) { i__2 = (colord_._7) .mstar; for (ir = 1; ir <= i__2; ++ir) { gi[*irow - 1 + ir + j * gi_dim1] = 0.; gi[*irow - 1 + ir + ((colord_._7) .mstar + j) * gi_dim1] = 0.; } gi[*irow - 1 + j + ((colord_._7) .mstar + j) * gi_dim1] = 1.; } ir = *irow; i__1 = (colord_._7) .ncomp; for (icomp = 1; icomp <= i__1; ++icomp) { mj = (colord_._7) .m[icomp - 1]; ir += mj; i__2 = mj; for (l = 1; l <= i__2; ++l) { id = ir - l; i__3 = (colord_._7) .mstar; for (jcol = 1; jcol <= i__3; ++jcol) { ind = icomp; rsum = 0.; i__4 = (colord_._7) .k; for (j = 1; j <= i__4; ++j) { rsum -= hb[j + l * 7 - 8] * vi[ind + jcol * vi_dim1]; ind += (colord_._7) .ncomp; } gi[id + jcol * gi_dim1] = rsum; } jd = id - *irow; i__3 = l; for (ll = 1; ll <= i__3; ++ll) { gi[id + (jd + ll) * gi_dim1] -= basm[ll - 1]; } } } return 0; L110: dgesl_(&wi[1], kd, kd, &ipvtw[1], &rhsdmz[1], &c__0); ir = *irow; i__1 = (colord_._7) .ncomp; for (jcomp = 1; jcomp <= i__1; ++jcomp) { mj = (colord_._7) .m[jcomp - 1]; ir += mj; i__2 = mj; for (l = 1; l <= i__2; ++l) { ind = jcomp; rsum = 0.; i__3 = (colord_._7) .k; for (j = 1; j <= i__3; ++j) { rsum += hb[j + l * 7 - 8] * rhsdmz[ind]; ind += (colord_._7) .ncomp; } rhsz[ir - l] = rsum; } } return 0; } int appsln_(x, z__, fspace, ispace) doublereal *x, *z__, *fspace; integer *ispace; { static doublereal a[28]; static integer i__; static doublereal dummy[1]; extern int approx_(); static integer is4, is5, is6; --ispace; --fspace; --z__; is6 = ispace[6]; is5 = ispace[1] + 2; is4 = is5 + ispace[4] * (ispace[1] + 1); i__ = 1; approx_(&i__, x, &z__[1], a, &fspace[is6], &fspace[1], &ispace[1], & fspace[is5], &fspace[is4], &ispace[2], &ispace[3], &ispace[5], & ispace[8], &ispace[4], &c__2, dummy, &c__0); return 0; } int approx_(i__, x, zval, a, coef, xi, n, z__, dmz, k, ncomp, mmax, m, mstar, mode, dmval, modm) integer *i__; doublereal *x, *zval, *a, *coef, *xi; integer *n; doublereal *z__, *dmz; integer *k, *ncomp, *mmax, *m, *mstar, *mode; doublereal *dmval; integer *modm; { static char fmt_900[] = "(\002 ****** DOMAIN ERROR IN APPROX ******\002/\002 X =\002,d20.10,\002 ALEFT =\002,d20.10,\002 ARIGHT =\002,d20.10)"; integer i__1, i__2, i__3; integer s_wsfe(), do_fio(), e_wsfe(); static doublereal fact; static integer idmz; static doublereal zsum; static integer j, l; static doublereal s; extern int rkbas_(); static integer ileft, jcomp, lb; static doublereal bm[4], dm[7]; static integer mj, ll, ir, iz, iright, ind; static cilist io___920 = { 0, 0, 0, fmt_900, 0 }; --dmval; --m; --dmz; --z__; --xi; --coef; a -= 8; --zval; switch ((int)*mode) { case 1: goto L10; case 2: goto L30; case 3: goto L80; case 4: goto L90; } L10: *x = xi[*i__]; iz = (*i__ - 1) * *mstar; i__1 = *mstar; for (j = 1; j <= i__1; ++j) { ++iz; zval[j] = z__[iz]; } return 0; L30: if (*x >= xi[1] - colout_ .precis && *x <= xi[*n + 1] + colout_ .precis) { goto L40; } if (colout_ .iprint < 1) { io___920.ciunit = colout_ .iout; s_wsfe(&io___920); do_fio(&c__1, (char *)&(*x), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&xi[1], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&xi[*n + 1], (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*x < xi[1]) { *x = xi[1]; } if (*x > xi[*n + 1]) { *x = xi[*n + 1]; } L40: if (*i__ > *n || *i__ < 1) { *i__ = (*n + 1) / 2; } ileft = *i__; if (*x < xi[ileft]) { goto L60; } i__1 = *n; for (l = ileft; l <= i__1; ++l) { *i__ = l; if (*x < xi[l + 1]) { goto L80; } } goto L80; L60: iright = ileft - 1; i__1 = iright; for (l = 1; l <= i__1; ++l) { *i__ = iright + 1 - l; if (*x >= xi[*i__]) { goto L80; } } L80: s = (*x - xi[*i__]) / (xi[*i__ + 1] - xi[*i__]); rkbas_(&s, &coef[1], k, mmax, &a[8], dm, modm); L90: bm[0] = *x - xi[*i__]; i__1 = *mmax; for (l = 2; l <= i__1; ++l) { bm[l - 1] = bm[0] / (doublereal) l; } ir = 1; iz = (*i__ - 1) * *mstar + 1; idmz = (*i__ - 1) * *k * *ncomp; i__1 = *ncomp; for (jcomp = 1; jcomp <= i__1; ++jcomp) { mj = m[jcomp]; ir += mj; iz += mj; i__2 = mj; for (l = 1; l <= i__2; ++l) { ind = idmz + jcomp; zsum = 0.; i__3 = *k; for (j = 1; j <= i__3; ++j) { zsum += a[j + l * 7] * dmz[ind]; ind += *ncomp; } i__3 = l; for (ll = 1; ll <= i__3; ++ll) { lb = l + 1 - ll; zsum = zsum * bm[lb - 1] + z__[iz - ll]; } zval[ir - l] = zsum; } } if (*modm == 0) { return 0; } i__1 = *ncomp; for (jcomp = 1; jcomp <= i__1; ++jcomp) { dmval[jcomp] = 0.; } ++idmz; i__1 = *k; for (j = 1; j <= i__1; ++j) { fact = dm[j - 1]; i__2 = *ncomp; for (jcomp = 1; jcomp <= i__2; ++jcomp) { dmval[jcomp] += fact * dmz[idmz]; ++idmz; } } return 0; } int rkbas_(s, coef, k, m, rkb, dm, mode) doublereal *s, *coef; integer *k, *m; doublereal *rkb, *dm; integer *mode; { integer coef_dim1, coef_offset, i__1, i__2, i__3; static integer i__, j, l; static doublereal p, t[10]; static integer lb, kpm1; coef_dim1 = *k; coef_offset = coef_dim1 + 1; coef -= coef_offset; rkb -= 8; --dm; if (*k == 1) { goto L70; } kpm1 = *k + *m - 1; i__1 = kpm1; for (i__ = 1; i__ <= i__1; ++i__) { t[i__ - 1] = *s / (doublereal) i__; } i__1 = *m; for (l = 1; l <= i__1; ++l) { lb = *k + l + 1; i__2 = *k; for (i__ = 1; i__ <= i__2; ++i__) { p = coef[i__ * coef_dim1 + 1]; i__3 = *k; for (j = 2; j <= i__3; ++j) { p = p * t[lb - j - 1] + coef[j + i__ * coef_dim1]; } rkb[i__ + l * 7] = p; } } if (*mode == 0) { return 0; } i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { p = coef[i__ * coef_dim1 + 1]; i__2 = *k; for (j = 2; j <= i__2; ++j) { p = p * t[*k + 1 - j - 1] + coef[j + i__ * coef_dim1]; } dm[i__] = p; } return 0; L70: rkb[8] = 1.; dm[1] = 1.; return 0; } int vmonde_(rho, coef, k) doublereal *rho, *coef; integer *k; { integer i__1, i__2; static integer ifac, i__, j, km1, kmi; --coef; --rho; if (*k == 1) { return 0; } km1 = *k - 1; i__1 = km1; for (i__ = 1; i__ <= i__1; ++i__) { kmi = *k - i__; i__2 = kmi; for (j = 1; j <= i__2; ++j) { coef[j] = (coef[j + 1] - coef[j]) / (rho[j + i__] - rho[j]); } } ifac = 1; i__2 = km1; for (i__ = 1; i__ <= i__2; ++i__) { kmi = *k + 1 - i__; i__1 = kmi; for (j = 2; j <= i__1; ++j) { coef[j] -= rho[j + i__ - 1] * coef[j - 1]; } coef[kmi] = (doublereal) ifac * coef[kmi]; ifac *= i__; } coef[1] = (doublereal) ifac * coef[1]; return 0; } int horder_(i__, uhigh, hi, dmz, ncomp, k) integer *i__; doublereal *uhigh, *hi, *dmz; integer *ncomp, *k; { integer i__1, i__2; double pow_di(); static doublereal fact; static integer idmz, j, id; static doublereal dn; static integer kin; --dmz; --uhigh; i__1 = *k - 1; dn = 1. / pow_di(hi, &i__1); i__1 = *ncomp; for (id = 1; id <= i__1; ++id) { uhigh[id] = 0.; } kin = 1; idmz = (*i__ - 1) * *k * *ncomp + 1; i__1 = *k; for (j = 1; j <= i__1; ++j) { fact = dn * colloc_ .coef[kin - 1]; i__2 = *ncomp; for (id = 1; id <= i__2; ++id) { uhigh[id] += fact * dmz[idmz]; ++idmz; } kin += *k; } return 0; } int dmzsol_(kd, mstar, n, v, z__, dmz) integer *kd, *mstar, *n; doublereal *v, *z__, *dmz; { integer v_dim1, v_offset, dmz_dim1, dmz_offset, i__1, i__2, i__3; static doublereal fact; static integer i__, j, l, jz; dmz_dim1 = *kd; dmz_offset = dmz_dim1 + 1; dmz -= dmz_offset; v_dim1 = *kd; v_offset = v_dim1 + 1; v -= v_offset; --z__; jz = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *mstar; for (j = 1; j <= i__2; ++j) { fact = z__[jz]; i__3 = *kd; for (l = 1; l <= i__3; ++l) { dmz[l + i__ * dmz_dim1] += fact * v[l + jz * v_dim1]; } ++jz; } } return 0; } int fcblok_(bloks, integs, nbloks, ipivot, scrtch, info) doublereal *bloks; integer *integs, *nbloks, *ipivot; doublereal *scrtch; integer *info; { static integer ncol, last, nrow, i__, index; extern int factrb_(), shiftb_(); static integer indexn, indexx; --bloks; integs -= 4; --ipivot; --scrtch; *info = 0; indexx = 1; indexn = 1; i__ = 1; L10: index = indexn; nrow = integs[i__ * 3 + 1]; ncol = integs[i__ * 3 + 2]; last = integs[i__ * 3 + 3]; factrb_(&bloks[index], &ipivot[indexx], &scrtch[1], &nrow, &ncol, &last, info); if (*info != 0) { goto L20; } if (i__ == *nbloks) { return 0; } ++i__; indexn = nrow * ncol + index; indexx += last; shiftb_(&bloks[index], &nrow, &ncol, &last, &bloks[indexn], &integs[i__ * 3 + 1], &integs[i__ * 3 + 2]); goto L10; L20: *info = *info + indexx - 1; return 0; } int factrb_(w, ipivot, d__, nrow, ncol, last, info) doublereal *w; integer *ipivot; doublereal *d__; integer *nrow, *ncol, *last, *info; { integer w_dim1, w_offset, i__1, i__2; doublereal d__1, d__2, d__3; static integer i__, j, k, l; static doublereal s, t, colmax; static integer kp1; --d__; --ipivot; w_dim1 = *nrow; w_offset = w_dim1 + 1; w -= w_offset; i__1 = *nrow; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = 0.; } i__1 = *ncol; for (j = 1; j <= i__1; ++j) { i__2 = *nrow; for (i__ = 1; i__ <= i__2; ++i__) { d__2 = d__[i__], d__3 = (d__1 = w[i__ + j * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); d__[i__] = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } } k = 1; L30: if (d__[k] == 0.) { goto L90; } if (k == *nrow) { goto L80; } l = k; kp1 = k + 1; colmax = (d__1 = w[k + k * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / d__[k]; i__2 = *nrow; for (i__ = kp1; i__ <= i__2; ++i__) { if ((d__1 = w[i__ + k * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= colmax * d__[i__]) { goto L40; } colmax = (d__1 = w[i__ + k * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / d__[i__]; l = i__; L40: ; } ipivot[k] = l; t = w[l + k * w_dim1]; s = d__[l]; if (l == k) { goto L50; } w[l + k * w_dim1] = w[k + k * w_dim1]; w[k + k * w_dim1] = t; d__[l] = d__[k]; d__[k] = s; L50: if ((( t ) >= 0 ? ( t ) : -( t )) + d__[k] <= d__[k]) { goto L90; } t = -1. / t; i__2 = *nrow; for (i__ = kp1; i__ <= i__2; ++i__) { w[i__ + k * w_dim1] *= t; } i__2 = *ncol; for (j = kp1; j <= i__2; ++j) { t = w[l + j * w_dim1]; if (l == k) { goto L62; } w[l + j * w_dim1] = w[k + j * w_dim1]; w[k + j * w_dim1] = t; L62: if (t == 0.) { goto L70; } i__1 = *nrow; for (i__ = kp1; i__ <= i__1; ++i__) { w[i__ + j * w_dim1] += w[i__ + k * w_dim1] * t; } L70: ; } k = kp1; if (k <= *last) { goto L30; } return 0; L80: if ((d__1 = w[*nrow + *nrow * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + d__[*nrow] > d__[* nrow]) { return 0; } L90: *info = k; return 0; } int shiftb_(ai, nrowi, ncoli, last, ai1, nrowi1, ncoli1) doublereal *ai; integer *nrowi, *ncoli, *last; doublereal *ai1; integer *nrowi1, *ncoli1; { integer ai_dim1, ai_offset, ai1_dim1, ai1_offset, i__1, i__2; static integer jmax, mmax, j, m, jmaxp1; ai_dim1 = *nrowi; ai_offset = ai_dim1 + 1; ai -= ai_offset; ai1_dim1 = *nrowi1; ai1_offset = ai1_dim1 + 1; ai1 -= ai1_offset; mmax = *nrowi - *last; jmax = *ncoli - *last; if (mmax < 1 || jmax < 1) { return 0; } i__1 = jmax; for (j = 1; j <= i__1; ++j) { i__2 = mmax; for (m = 1; m <= i__2; ++m) { ai1[m + j * ai1_dim1] = ai[*last + m + (*last + j) * ai_dim1]; } } if (jmax == *ncoli1) { return 0; } jmaxp1 = jmax + 1; i__2 = *ncoli1; for (j = jmaxp1; j <= i__2; ++j) { i__1 = mmax; for (m = 1; m <= i__1; ++m) { ai1[m + j * ai1_dim1] = 0.; } } return 0; } int sbblok_(bloks, integs, nbloks, ipivot, x) doublereal *bloks; integer *integs, *nbloks, *ipivot; doublereal *x; { integer i__1; static integer ncol, last, nrow, i__, j, index; extern int subbak_(); static integer indexx; extern int subfor_(); static integer nbp1; --bloks; integs -= 4; --ipivot; --x; index = 1; indexx = 1; i__1 = *nbloks; for (i__ = 1; i__ <= i__1; ++i__) { nrow = integs[i__ * 3 + 1]; last = integs[i__ * 3 + 3]; subfor_(&bloks[index], &ipivot[indexx], &nrow, &last, &x[indexx]); index = nrow * integs[i__ * 3 + 2] + index; indexx += last; } nbp1 = *nbloks + 1; i__1 = *nbloks; for (j = 1; j <= i__1; ++j) { i__ = nbp1 - j; nrow = integs[i__ * 3 + 1]; ncol = integs[i__ * 3 + 2]; last = integs[i__ * 3 + 3]; index -= nrow * ncol; indexx -= last; subbak_(&bloks[index], &nrow, &ncol, &last, &x[indexx]); } return 0; } int subfor_(w, ipivot, nrow, last, x) doublereal *w; integer *ipivot, *nrow, *last; doublereal *x; { integer w_dim1, w_offset, i__1, i__2; static integer i__, k; static doublereal t; static integer lstep, ip, kp1; --x; --ipivot; w_dim1 = *nrow; w_offset = w_dim1 + 1; w -= w_offset; if (*nrow == 1) { return 0; } i__1 = *nrow - 1; lstep = (( i__1 ) <= ( *last ) ? ( i__1 ) : ( *last )) ; i__1 = lstep; for (k = 1; k <= i__1; ++k) { kp1 = k + 1; ip = ipivot[k]; t = x[ip]; x[ip] = x[k]; x[k] = t; if (t == 0.) { goto L20; } i__2 = *nrow; for (i__ = kp1; i__ <= i__2; ++i__) { x[i__] += w[i__ + k * w_dim1] * t; } L20: ; } return 0; } int subbak_(w, nrow, ncol, last, x) doublereal *w; integer *nrow, *ncol, *last; doublereal *x; { integer w_dim1, w_offset, i__1, i__2; static integer i__, j, k; static doublereal t; static integer kb, km1, lm1, lp1; --x; w_dim1 = *nrow; w_offset = w_dim1 + 1; w -= w_offset; lp1 = *last + 1; if (lp1 > *ncol) { goto L30; } i__1 = *ncol; for (j = lp1; j <= i__1; ++j) { t = -x[j]; if (t == 0.) { goto L20; } i__2 = *last; for (i__ = 1; i__ <= i__2; ++i__) { x[i__] += w[i__ + j * w_dim1] * t; } L20: ; } L30: if (*last == 1) { goto L60; } lm1 = *last - 1; i__1 = lm1; for (kb = 1; kb <= i__1; ++kb) { km1 = *last - kb; k = km1 + 1; x[k] /= w[k + k * w_dim1]; t = -x[k]; if (t == 0.) { goto L50; } i__2 = km1; for (i__ = 1; i__ <= i__2; ++i__) { x[i__] += w[i__ + k * w_dim1] * t; } L50: ; } L60: x[1] /= w[w_dim1 + 1]; return 0; } int ddaini_(x, y, yprime, neq, res, jac, h__, wt, idid, rpar, ipar, phi, delta, e, wm, iwm, hmin, uround, nonneg, ntemp) doublereal *x, *y, *yprime; integer *neq; int (*res) (), (*jac) (); doublereal *h__, *wt; integer *idid; doublereal *rpar; integer *ipar; doublereal *phi, *delta, *e, *wm; integer *iwm; doublereal *hmin, *uround; integer *nonneg, *ntemp; { static integer maxit = 10; static integer mjac = 5; static doublereal damp = .75; integer phi_dim1, phi_offset, i__1; doublereal d__1, d__2; double pow_dd(); static doublereal rate; static integer ires; static doublereal xold; static integer i__, jcalc, m; static doublereal r__, s, ynorm; extern int ddajac_(); static doublereal cj; extern doublereal ddanrm_(); extern int ddaslv_(); static logical convgd; static doublereal delnrm, oldnrm; static integer ncf, nef, ier, nsf; static doublereal err; --y; --yprime; phi_dim1 = *neq; phi_offset = phi_dim1 + 1; phi -= phi_offset; --wt; --rpar; --ipar; --delta; --e; --wm; --iwm; *idid = 1; nef = 0; ncf = 0; nsf = 0; xold = *x; ynorm = ddanrm_(neq, &y[1], &wt[1], &rpar[1], &ipar[1]); i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { phi[i__ + phi_dim1] = y[i__]; phi[i__ + (phi_dim1 << 1)] = yprime[i__]; } L200: cj = 1. / *h__; *x += *h__; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] += *h__ * yprime[i__]; } jcalc = -1; m = 0; convgd = (1) ; L300: ++iwm[12]; ires = 0; (*res)(x, &y[1], &yprime[1], &delta[1], &ires, &rpar[1], &ipar[1]); if (ierode_ .iero != 0) { return 0; } if (ires < 0) { goto L430; } if (jcalc != -1) { goto L310; } ++iwm[13]; jcalc = 0; ddajac_(neq, x, &y[1], &yprime[1], &delta[1], &cj, h__, &ier, &wt[1], &e[ 1], &wm[1], &iwm[1], res, &ires, uround, jac, &rpar[1], &ipar[1], ntemp); if (ierode_ .iero != 0) { return 0; } s = 1e6; if (ires < 0) { goto L430; } if (ier != 0) { goto L430; } nsf = 0; L310: i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { delta[i__] *= damp; } ddaslv_(neq, &delta[1], &wm[1], &iwm[1]); i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] -= delta[i__]; yprime[i__] -= cj * delta[i__]; } delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); if (delnrm <= *uround * 100. * ynorm) { goto L400; } if (m > 0) { goto L340; } oldnrm = delnrm; goto L350; L340: d__1 = delnrm / oldnrm; d__2 = 1. / m; rate = pow_dd(&d__1, &d__2); if (rate > .9) { goto L430; } s = rate / (1. - rate); L350: if (s * delnrm <= .33) { goto L400; } ++m; if (m >= maxit) { goto L430; } if (m / mjac * mjac == m) { jcalc = -1; } goto L300; L400: if (*nonneg == 0) { goto L450; } i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = y[i__]; delta[i__] = (( d__1 ) <= ( 0. ) ? ( d__1 ) : ( 0. )) ; } delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); if (delnrm > .33) { goto L430; } i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] -= delta[i__]; yprime[i__] -= cj * delta[i__]; } goto L450; L430: convgd = (0) ; L450: if (! convgd) { goto L600; } i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { e[i__] = y[i__] - phi[i__ + phi_dim1]; } err = ddanrm_(neq, &e[1], &wt[1], &rpar[1], &ipar[1]); if (err <= 1.) { return 0; } L600: *x = xold; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = phi[i__ + phi_dim1]; yprime[i__] = phi[i__ + (phi_dim1 << 1)]; } if (convgd) { goto L640; } if (ier == 0) { goto L620; } ++nsf; *h__ *= .25; if (nsf < 3 && (( *h__ ) >= 0 ? ( *h__ ) : -( *h__ )) >= *hmin) { goto L690; } *idid = -12; return 0; L620: if (ires > -2) { goto L630; } *idid = -12; return 0; L630: ++ncf; *h__ *= .25; if (ncf < 10 && (( *h__ ) >= 0 ? ( *h__ ) : -( *h__ )) >= *hmin) { goto L690; } *idid = -12; return 0; L640: ++nef; r__ = .9 / (err * 2. + 1e-4); d__1 = .1, d__2 = (( .5 ) <= ( r__ ) ? ( .5 ) : ( r__ )) ; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; *h__ *= r__; if ((( *h__ ) >= 0 ? ( *h__ ) : -( *h__ )) >= *hmin && nef < 10) { goto L690; } *idid = -12; return 0; L690: goto L200; } int ddajac_(neq, x, y, yprime, delta, cj, h__, ier, wt, e, wm, iwm, res, ires, uround, jac, rpar, ipar, ntemp) integer *neq; doublereal *x, *y, *yprime, *delta, *cj, *h__; integer *ier; doublereal *wt, *e, *wm; integer *iwm; int (*res) (); integer *ires; doublereal *uround; int (*jac) (); doublereal *rpar; integer *ipar, *ntemp; { integer i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4, d__5; double sqrt(), d_sign(); static integer nrow; static doublereal squr; static integer npdm1; extern int dgbfa_(), dgefa_(); static integer i__, j, k, l, n, mband, lenpd, isave, msave; static doublereal ysave; static integer i1, i2, mtype, ii, meband; static doublereal delinv; static integer ipsave; static doublereal ypsave; static integer mba; static doublereal del; static integer meb1; --ipar; --rpar; --iwm; --wm; --e; --wt; --delta; --yprime; --y; *ier = 0; npdm1 = 0; mtype = iwm[4]; switch ((int)mtype) { case 1: goto L100; case 2: goto L200; case 3: goto L300; case 4: goto L400; case 5: goto L500; } L100: lenpd = *neq * *neq; i__1 = lenpd; for (i__ = 1; i__ <= i__1; ++i__) { wm[npdm1 + i__] = 0.; } (*jac)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]); if (ierode_ .iero != 0) { return 0; } goto L230; L200: *ires = 0; nrow = npdm1; squr = sqrt(*uround); i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { d__4 = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__5 = (d__2 = *h__ * yprime[i__], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ), d__4 = (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) , d__5 = (d__3 = wt[i__], (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) ); del = squr * (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) ; d__1 = *h__ * yprime[i__]; del = d_sign(&del, &d__1); del = y[i__] + del - y[i__]; ysave = y[i__]; ypsave = yprime[i__]; y[i__] += del; yprime[i__] += *cj * del; (*res)(x, &y[1], &yprime[1], &e[1], ires, &rpar[1], &ipar[1]); if (ierode_ .iero != 0) { return 0; } if (*ires < 0) { return 0; } delinv = 1. / del; i__2 = *neq; for (l = 1; l <= i__2; ++l) { wm[nrow + l] = (e[l] - delta[l]) * delinv; } nrow += *neq; y[i__] = ysave; yprime[i__] = ypsave; } L230: dgefa_(&wm[1], neq, neq, &iwm[21], ier); return 0; L300: return 0; L400: lenpd = ((iwm[1] << 1) + iwm[2] + 1) * *neq; i__1 = lenpd; for (i__ = 1; i__ <= i__1; ++i__) { wm[npdm1 + i__] = 0.; } (*jac)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]); if (ierode_ .iero != 0) { return 0; } meband = (iwm[1] << 1) + iwm[2] + 1; goto L550; L500: mband = iwm[1] + iwm[2] + 1; mba = (( mband ) <= ( *neq ) ? ( mband ) : ( *neq )) ; meband = mband + iwm[1]; meb1 = meband - 1; msave = *neq / mband + 1; isave = *ntemp - 1; ipsave = isave + msave; *ires = 0; squr = sqrt(*uround); i__1 = mba; for (j = 1; j <= i__1; ++j) { i__2 = *neq; i__3 = mband; for (n = j; i__3 < 0 ? n >= i__2 : n <= i__2; n += i__3) { k = (n - j) / mband + 1; wm[isave + k] = y[n]; wm[ipsave + k] = yprime[n]; d__4 = (d__1 = y[n], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__5 = (d__2 = *h__ * yprime[n], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ), d__4 = (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) , d__5 = (d__3 = wt[n], (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) ); del = squr * (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) ; d__1 = *h__ * yprime[n]; del = d_sign(&del, &d__1); del = y[n] + del - y[n]; y[n] += del; yprime[n] += *cj * del; } (*res)(x, &y[1], &yprime[1], &e[1], ires, &rpar[1], &ipar[1]); if (ierode_ .iero != 0) { return 0; } if (*ires < 0) { return 0; } i__3 = *neq; i__2 = mband; for (n = j; i__2 < 0 ? n >= i__3 : n <= i__3; n += i__2) { k = (n - j) / mband + 1; y[n] = wm[isave + k]; yprime[n] = wm[ipsave + k]; d__4 = (d__1 = y[n], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__5 = (d__2 = *h__ * yprime[n], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ), d__4 = (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) , d__5 = (d__3 = wt[n], (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) ); del = squr * (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) ; d__1 = *h__ * yprime[n]; del = d_sign(&del, &d__1); del = y[n] + del - y[n]; delinv = 1. / del; i__4 = 1, i__5 = n - iwm[2]; i1 = (( i__4 ) >= ( i__5 ) ? ( i__4 ) : ( i__5 )) ; i__4 = *neq, i__5 = n + iwm[1]; i2 = (( i__4 ) <= ( i__5 ) ? ( i__4 ) : ( i__5 )) ; ii = n * meb1 - iwm[1] + npdm1; i__4 = i2; for (i__ = i1; i__ <= i__4; ++i__) { wm[ii + i__] = (e[i__] - delta[i__]) * delinv; } } } L550: dgbfa_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[21], ier); return 0; } doublereal ddanrm_(neq, v, wt, rpar, ipar) integer *neq; doublereal *v, *wt, *rpar; integer *ipar; { integer i__1; doublereal ret_val, d__1, d__2; double sqrt(); static doublereal vmax; static integer i__; static doublereal sum; --wt; --v; --rpar; --ipar; ret_val = 0.; vmax = 0.; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = v[i__] / wt[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > vmax) { vmax = (d__2 = v[i__] / wt[i__], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ); } } if (vmax <= 0.) { goto L30; } sum = 0.; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = v[i__] / wt[i__] / vmax; sum += d__1 * d__1; } ret_val = vmax * sqrt(sum / *neq); L30: return ret_val; } int ddaslv_(neq, delta, wm, iwm) integer *neq; doublereal *delta, *wm; integer *iwm; { extern int dgbsl_(), dgesl_(); static integer mtype, meband; --iwm; --wm; --delta; mtype = iwm[4]; switch ((int)mtype) { case 1: goto L100; case 2: goto L100; case 3: goto L300; case 4: goto L400; case 5: goto L400; } L100: dgesl_(&wm[1], neq, neq, &iwm[21], &delta[1], &c__0); return 0; L300: return 0; L400: meband = (iwm[1] << 1) + iwm[2] + 1; dgbsl_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[21], &delta[1], &c__0) ; return 0; } int ddassl_(res, neq, t, y, yprime, tout, info, rtol, atol, idid, rwork, lrw, iwork, liw, rpar, ipar, jac) int (*res) (); integer *neq; doublereal *t, *y, *yprime, *tout; integer *info; doublereal *rtol, *atol; integer *idid; doublereal *rwork; integer *lrw, *iwork, *liw; doublereal *rpar; integer *ipar; int (*jac) (); { address a__1[4], a__2[5], a__3[6], a__4[3], a__5[2]; integer i__1, i__2[4], i__3[5], i__4[6], i__5[3], i__6[2]; doublereal d__1, d__2; char ch__1[118], ch__2[81], ch__3[128], ch__4[62], ch__5[110], ch__6[121], ch__7[90], ch__8[132], ch__9[126], ch__10[85], ch__11[98], ch__12[21], ch__13[30], ch__14[61], ch__15[71], ch__16[32], ch__17[51], ch__18[78], ch__19[66], ch__20[49], ch__21[27]; integer s_wsfi(), do_fio(), e_wsfi(); int s_cat(); double d_sign(); static logical done; static integer lphi; static doublereal hmax, hmin; static char xern1[8], xern2[8], xern3[16], xern4[16]; static doublereal h__; static integer i__, mband; static doublereal r__; static integer lenpd; static doublereal atoli; static integer msave, itemp, leniw, nzflg, ntemp, lenrw; static doublereal tdist; static integer mxord; static doublereal rtoli, tnext, tstop; static integer le; extern doublereal dlamch_(); extern int ddaini_(); static doublereal ho, rh, tn; extern doublereal ddanrm_(); extern int ddatrp_(), ddastp_(), ddawts_(), xermsg_(); static doublereal uround, ypnorm; static integer lpd, lwm, lwt; static icilist io___1060 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___1084 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1085 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1086 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1087 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1089 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1090 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1091 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1092 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1093 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1094 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1095 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1096 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1097 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1098 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1099 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1100 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1101 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1102 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___1103 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___1104 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___1106 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___1107 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___1108 = { 0, xern2, 0, "(I8)", 8, 1 }; static icilist io___1109 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1110 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1111 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1112 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1113 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1114 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1115 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1116 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1117 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 }; static icilist io___1118 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___1119 = { 0, xern1, 0, "(I8)", 8, 1 }; static icilist io___1120 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 }; --ipar; --rpar; --iwork; --rwork; --atol; --rtol; --info; --yprime; --y; if (info[1] != 0) { goto L100; } for (i__ = 2; i__ <= 11; ++i__) { if (info[i__] != 0 && info[i__] != 1) { goto L701; } } if (*neq <= 0) { goto L702; } mxord = 5; if (info[9] == 0) { goto L20; } mxord = iwork[3]; if (mxord < 1 || mxord > 5) { goto L703; } L20: iwork[3] = mxord; if (info[6] != 0) { goto L40; } i__1 = *neq; lenpd = i__1 * i__1; lenrw = (iwork[3] + 4) * *neq + 40 + lenpd; if (info[5] != 0) { goto L30; } iwork[4] = 2; goto L60; L30: iwork[4] = 1; goto L60; L40: if (iwork[1] < 0 || iwork[1] >= *neq) { goto L717; } if (iwork[2] < 0 || iwork[2] >= *neq) { goto L718; } lenpd = ((iwork[1] << 1) + iwork[2] + 1) * *neq; if (info[5] != 0) { goto L50; } iwork[4] = 5; mband = iwork[1] + iwork[2] + 1; msave = *neq / mband + 1; lenrw = (iwork[3] + 4) * *neq + 40 + lenpd + (msave << 1); goto L60; L50: iwork[4] = 4; lenrw = (iwork[3] + 4) * *neq + 40 + lenpd; L60: leniw = *neq + 20; iwork[16] = lenpd; if (*lrw < lenrw) { goto L704; } if (*liw < leniw) { goto L705; } if (*tout == *t) { goto L719; } if (info[7] == 0) { goto L70; } hmax = rwork[2]; if (hmax <= 0.) { goto L710; } L70: iwork[11] = 0; iwork[12] = 0; iwork[13] = 0; iwork[10] = 0; *idid = 1; goto L200; L100: if (info[1] == 1) { goto L110; } if (info[1] != -1) { goto L701; } s_wsfi(&io___1060); do_fio(&c__1, (char *)&(*idid), (ftnlen)sizeof(integer)); e_wsfi(); i__2[0] = 57, a__1[0] = "THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = "; i__2[1] = 8, a__1[1] = xern1; i__2[2] = 39, a__1[2] = " AND NO APPROPRIATE ACTION WAS TAKEN. "; i__2[3] = 14, a__1[3] = "RUN TERMINATED"; s_cat(ch__1, a__1, i__2, &c__4, 118L); xermsg_("SLATEC", "DDASSL", ch__1, &c_n998, &c__2, 6L, 6L, 118L); return 0; L110: iwork[10] = iwork[11]; L200: nzflg = 0; rtoli = rtol[1]; atoli = atol[1]; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { if (info[2] == 1) { rtoli = rtol[i__]; } if (info[2] == 1) { atoli = atol[i__]; } if (rtoli > 0. || atoli > 0.) { nzflg = 1; } if (rtoli < 0.) { goto L706; } if (atoli < 0.) { goto L707; } } if (nzflg == 0) { goto L708; } le = *neq + 41; lwt = le + *neq; lphi = lwt + *neq; lpd = lphi + (iwork[3] + 1) * *neq; lwm = lpd; ntemp = iwork[16] + 1; if (info[1] == 1) { goto L400; } tn = *t; *idid = 1; ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], & ipar[1]); i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[lwt + i__ - 1] <= 0.) { goto L713; } } uround = dlamch_("P", 1L); rwork[9] = uround; d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ; hmin = uround * 4. * (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (tdist < hmin) { goto L714; } if (info[8] == 0) { goto L310; } ho = rwork[3]; if ((*tout - *t) * ho < 0.) { goto L711; } if (ho == 0.) { goto L712; } goto L320; L310: ho = tdist * .001; ypnorm = ddanrm_(neq, &yprime[1], &rwork[lwt], &rpar[1], &ipar[1]); if (ypnorm > .5 / ho) { ho = .5 / ypnorm; } d__1 = *tout - *t; ho = d_sign(&ho, &d__1); L320: if (info[7] == 0) { goto L330; } rh = (( ho ) >= 0 ? ( ho ) : -( ho )) / rwork[2]; if (rh > 1.) { ho /= rh; } L330: if (info[4] == 0) { goto L340; } tstop = rwork[1]; if ((tstop - *t) * ho < 0.) { goto L715; } if ((*t + ho - tstop) * ho > 0.) { ho = tstop - *t; } if ((tstop - *tout) * ho < 0.) { goto L709; } L340: if (info[11] == 0) { goto L350; } ddaini_(&tn, &y[1], &yprime[1], neq, res, jac, &ho, &rwork[lwt], idid, & rpar[1], &ipar[1], &rwork[lphi], &rwork[41], &rwork[le], &rwork[ lwm], &iwork[1], &hmin, &rwork[9], &info[10], &ntemp); if (ierode_ .iero != 0) { return 0; } if (*idid < 0) { goto L390; } L350: h__ = ho; rwork[3] = h__; itemp = lphi + *neq; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { rwork[lphi + i__ - 1] = y[i__]; rwork[itemp + i__ - 1] = h__ * yprime[i__]; } L390: goto L500; L400: uround = rwork[9]; done = (0) ; tn = rwork[4]; h__ = rwork[3]; if (info[7] == 0) { goto L410; } rh = (( h__ ) >= 0 ? ( h__ ) : -( h__ )) / rwork[2]; if (rh > 1.) { h__ /= rh; } L410: if (*t == *tout) { goto L719; } if ((*t - *tout) * h__ > 0.) { goto L711; } if (info[4] == 1) { goto L430; } if (info[3] == 1) { goto L420; } if ((tn - *tout) * h__ < 0.) { goto L490; } ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *t = *tout; *idid = 3; done = (1) ; goto L490; L420: if ((tn - *t) * h__ <= 0.) { goto L490; } if ((tn - *tout) * h__ > 0.) { goto L425; } ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[ 29]); *t = tn; *idid = 1; done = (1) ; goto L490; L425: ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *t = *tout; *idid = 3; done = (1) ; goto L490; L430: if (info[3] == 1) { goto L440; } tstop = rwork[1]; if ((tn - tstop) * h__ > 0.) { goto L715; } if ((tstop - *tout) * h__ < 0.) { goto L709; } if ((tn - *tout) * h__ < 0.) { goto L450; } ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *t = *tout; *idid = 3; done = (1) ; goto L490; L440: tstop = rwork[1]; if ((tn - tstop) * h__ > 0.) { goto L715; } if ((tstop - *tout) * h__ < 0.) { goto L709; } if ((tn - *t) * h__ <= 0.) { goto L450; } if ((tn - *tout) * h__ > 0.) { goto L445; } ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[ 29]); *t = tn; *idid = 1; done = (1) ; goto L490; L445: ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *t = *tout; *idid = 3; done = (1) ; goto L490; L450: if ((d__1 = tn - tstop, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > uround * 100. * ((( tn ) >= 0 ? ( tn ) : -( tn )) + (( h__ ) >= 0 ? ( h__ ) : -( h__ )) )) { goto L460; } ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *idid = 2; *t = tstop; done = (1) ; goto L490; L460: tnext = tn + h__; if ((tnext - tstop) * h__ <= 0.) { goto L490; } h__ = tstop - tn; rwork[3] = h__; L490: if (done) { goto L580; } L500: if (*idid == -12) { goto L527; } if (iwork[11] - iwork[10] < 500) { goto L510; } *idid = -1; goto L527; L510: ddawts_(neq, &info[2], &rtol[1], &atol[1], &rwork[lphi], &rwork[lwt], & rpar[1], &ipar[1]); i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + lwt - 1] > 0.) { goto L520; } *idid = -3; goto L527; L520: ; } r__ = ddanrm_(neq, &rwork[lphi], &rwork[lwt], &rpar[1], &ipar[1]) * 100. * uround; if (r__ <= 1.) { goto L525; } if (info[2] == 1) { goto L523; } rtol[1] = r__ * rtol[1]; atol[1] = r__ * atol[1]; *idid = -2; goto L527; L523: i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { rtol[i__] = r__ * rtol[i__]; atol[i__] = r__ * atol[i__]; } *idid = -2; goto L527; L525: d__1 = (( tn ) >= 0 ? ( tn ) : -( tn )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ; hmin = uround * 4. * (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (info[7] == 0) { goto L526; } rh = (( h__ ) >= 0 ? ( h__ ) : -( h__ )) / rwork[2]; if (rh > 1.) { h__ /= rh; } L526: ddastp_(&tn, &y[1], &yprime[1], neq, res, jac, &h__, &rwork[lwt], &info[1] , idid, &rpar[1], &ipar[1], &rwork[lphi], &rwork[41], &rwork[le], &rwork[lwm], &iwork[1], &rwork[11], &rwork[17], &rwork[23], & rwork[29], &rwork[35], &rwork[5], &rwork[6], &rwork[7], &rwork[8], &hmin, &rwork[9], &iwork[6], &iwork[5], &iwork[7], &iwork[8], & iwork[9], &info[10], &ntemp); if (ierode_ .iero != 0) { return 0; } L527: if (*idid < 0) { goto L600; } if (info[4] != 0) { goto L540; } if (info[3] != 0) { goto L530; } if ((tn - *tout) * h__ < 0.) { goto L500; } ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *idid = 3; *t = *tout; goto L580; L530: if ((tn - *tout) * h__ >= 0.) { goto L535; } *t = tn; *idid = 1; goto L580; L535: ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *idid = 3; *t = *tout; goto L580; L540: if (info[3] != 0) { goto L550; } if ((tn - *tout) * h__ < 0.) { goto L542; } ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *t = *tout; *idid = 3; goto L580; L542: if ((d__1 = tn - tstop, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= uround * 100. * ((( tn ) >= 0 ? ( tn ) : -( tn )) + (( h__ ) >= 0 ? ( h__ ) : -( h__ )) ) ) { goto L545; } tnext = tn + h__; if ((tnext - tstop) * h__ <= 0.) { goto L500; } h__ = tstop - tn; goto L500; L545: ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *idid = 2; *t = tstop; goto L580; L550: if ((tn - *tout) * h__ >= 0.) { goto L555; } if ((d__1 = tn - tstop, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= uround * 100. * ((( tn ) >= 0 ? ( tn ) : -( tn )) + (( h__ ) >= 0 ? ( h__ ) : -( h__ )) ) ) { goto L552; } *t = tn; *idid = 1; goto L580; L552: ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *idid = 2; *t = tstop; goto L580; L555: ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & rwork[29]); *t = *tout; *idid = 3; goto L580; L580: rwork[4] = tn; rwork[3] = h__; return 0; L600: itemp = -(*idid); switch ((int)itemp) { case 1: goto L610; case 2: goto L620; case 3: goto L630; case 4: goto L690; case 5: goto L690; case 6: goto L640; case 7: goto L650; case 8: goto L660; case 9: goto L670; case 10: goto L675; case 11: goto L680; case 12: goto L685; } L610: s_wsfi(&io___1084); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); i__2[0] = 15, a__1[0] = "AT CURRENT T = "; i__2[1] = 16, a__1[1] = xern3; i__2[2] = 25, a__1[2] = " 500 STEPS TAKEN ON THIS "; i__2[3] = 25, a__1[3] = "CALL BEFORE REACHING TOUT"; s_cat(ch__2, a__1, i__2, &c__4, 81L); xermsg_("SLATEC", "DDASSL", ch__2, idid, &c__1, 6L, 6L, 81L); goto L690; L620: s_wsfi(&io___1085); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); i__3[0] = 7, a__2[0] = "AT T = "; i__3[1] = 16, a__2[1] = xern3; i__3[2] = 33, a__2[2] = " TOO MUCH ACCURACY REQUESTED FOR "; i__3[3] = 54, a__2[3] = "PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO "; i__3[4] = 18, a__2[4] = "APPROPRIATE VALUES"; s_cat(ch__3, a__2, i__3, &c__5, 128L); xermsg_("SLATEC", "DDASSL", ch__3, idid, &c__1, 6L, 6L, 128L); goto L690; L630: s_wsfi(&io___1086); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); i__2[0] = 7, a__1[0] = "AT T = "; i__2[1] = 16, a__1[1] = xern3; i__2[2] = 36, a__1[2] = " SOME ELEMENT OF WT HAS BECOME .LE. "; i__2[3] = 3, a__1[3] = "0.0"; s_cat(ch__4, a__1, i__2, &c__4, 62L); xermsg_("SLATEC", "DDASSL", ch__4, idid, &c__1, 6L, 6L, 62L); goto L690; L640: s_wsfi(&io___1087); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1089); do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal)); e_wsfi(); i__3[0] = 7, a__2[0] = "AT T = "; i__3[1] = 16, a__2[1] = xern3; i__3[2] = 18, a__2[2] = " AND STEPSIZE H = "; i__3[3] = 16, a__2[3] = xern4; i__3[4] = 53, a__2[4] = " THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN"; s_cat(ch__5, a__2, i__3, &c__5, 110L); xermsg_("SLATEC", "DDASSL", ch__5, idid, &c__1, 6L, 6L, 110L); goto L690; L650: s_wsfi(&io___1090); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1091); do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal)); e_wsfi(); i__4[0] = 7, a__3[0] = "AT T = "; i__4[1] = 16, a__3[1] = xern3; i__4[2] = 18, a__3[2] = " AND STEPSIZE H = "; i__4[3] = 16, a__3[3] = xern4; i__4[4] = 53, a__3[4] = " THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH "; i__4[5] = 11, a__3[5] = "ABS(H)=HMIN"; s_cat(ch__6, a__3, i__4, &c__6, 121L); xermsg_("SLATEC", "DDASSL", ch__6, idid, &c__1, 6L, 6L, 121L); goto L690; L660: s_wsfi(&io___1092); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1093); do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal)); e_wsfi(); i__3[0] = 7, a__2[0] = "AT T = "; i__3[1] = 16, a__2[1] = xern3; i__3[2] = 18, a__2[2] = " AND STEPSIZE H = "; i__3[3] = 16, a__2[3] = xern4; i__3[4] = 33, a__2[4] = " THE ITERATION MATRIX IS SINGULAR"; s_cat(ch__7, a__2, i__3, &c__5, 90L); xermsg_("SLATEC", "DDASSL", ch__7, idid, &c__1, 6L, 6L, 90L); goto L690; L670: s_wsfi(&io___1094); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1095); do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal)); e_wsfi(); i__4[0] = 7, a__3[0] = "AT T = "; i__4[1] = 16, a__3[1] = xern3; i__4[2] = 18, a__3[2] = " AND STEPSIZE H = "; i__4[3] = 16, a__3[3] = xern4; i__4[4] = 57, a__3[4] = " THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST "; i__4[5] = 18, a__3[5] = "FAILED REPEATEDLY."; s_cat(ch__8, a__3, i__4, &c__6, 132L); xermsg_("SLATEC", "DDASSL", ch__8, idid, &c__1, 6L, 6L, 132L); goto L690; L675: s_wsfi(&io___1096); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1097); do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal)); e_wsfi(); i__4[0] = 7, a__3[0] = "AT T = "; i__4[1] = 16, a__3[1] = xern3; i__4[2] = 18, a__3[2] = " AND STEPSIZE H = "; i__4[3] = 16, a__3[3] = xern4; i__4[4] = 57, a__3[4] = " THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL "; i__4[5] = 12, a__3[5] = "TO MINUS ONE"; s_cat(ch__9, a__3, i__4, &c__6, 126L); xermsg_("SLATEC", "DDASSL", ch__9, idid, &c__1, 6L, 6L, 126L); goto L690; L680: s_wsfi(&io___1098); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1099); do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal)); e_wsfi(); i__3[0] = 7, a__2[0] = "AT T = "; i__3[1] = 16, a__2[1] = xern3; i__3[2] = 18, a__2[2] = " AND STEPSIZE H = "; i__3[3] = 16, a__2[3] = xern4; i__3[4] = 28, a__2[4] = " IRES WAS EQUAL TO MINUS TWO"; s_cat(ch__10, a__2, i__3, &c__5, 85L); xermsg_("SLATEC", "DDASSL", ch__10, idid, &c__1, 6L, 6L, 85L); goto L690; L685: s_wsfi(&io___1100); do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1101); do_fio(&c__1, (char *)&ho, (ftnlen)sizeof(doublereal)); e_wsfi(); i__3[0] = 7, a__2[0] = "AT T = "; i__3[1] = 16, a__2[1] = xern3; i__3[2] = 18, a__2[2] = " AND STEPSIZE H = "; i__3[3] = 16, a__2[3] = xern4; i__3[4] = 41, a__2[4] = " THE INITIAL YPRIME COULD NOT BE COMPUTED"; s_cat(ch__11, a__2, i__3, &c__5, 98L); xermsg_("SLATEC", "DDASSL", ch__11, idid, &c__1, 6L, 6L, 98L); goto L690; L690: info[1] = -1; *t = tn; rwork[4] = tn; rwork[3] = h__; return 0; L701: xermsg_("SLATEC", "DDASSL", "SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE", &c__1, &c__1, 6L, 6L, 46L); goto L750; L702: s_wsfi(&io___1102); do_fio(&c__1, (char *)&(*neq), (ftnlen)sizeof(integer)); e_wsfi(); i__5[0] = 6, a__4[0] = "NEQ = "; i__5[1] = 8, a__4[1] = xern1; i__5[2] = 7, a__4[2] = " .LE. 0"; s_cat(ch__12, a__4, i__5, &c__3, 21L); xermsg_("SLATEC", "DDASSL", ch__12, &c__2, &c__1, 6L, 6L, 21L); goto L750; L703: s_wsfi(&io___1103); do_fio(&c__1, (char *)&mxord, (ftnlen)sizeof(integer)); e_wsfi(); i__5[0] = 9, a__4[0] = "MAXORD = "; i__5[1] = 8, a__4[1] = xern1; i__5[2] = 13, a__4[2] = " NOT IN RANGE"; s_cat(ch__13, a__4, i__5, &c__3, 30L); xermsg_("SLATEC", "DDASSL", ch__13, &c__3, &c__1, 6L, 6L, 30L); goto L750; L704: s_wsfi(&io___1104); do_fio(&c__1, (char *)&lenrw, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___1106); do_fio(&c__1, (char *)&(*lrw), (ftnlen)sizeof(integer)); e_wsfi(); i__2[0] = 29, a__1[0] = "RWORK LENGTH NEEDED, LENRW = "; i__2[1] = 8, a__1[1] = xern1; i__2[2] = 16, a__1[2] = ", EXCEEDS LRW = "; i__2[3] = 8, a__1[3] = xern2; s_cat(ch__14, a__1, i__2, &c__4, 61L); xermsg_("SLATEC", "DDASSL", ch__14, &c__4, &c__1, 6L, 6L, 61L); goto L750; L705: s_wsfi(&io___1107); do_fio(&c__1, (char *)&leniw, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___1108); do_fio(&c__1, (char *)&(*liw), (ftnlen)sizeof(integer)); e_wsfi(); i__2[0] = 29, a__1[0] = "IWORK LENGTH NEEDED, LENIW = "; i__2[1] = 8, a__1[1] = xern1; i__2[2] = 16, a__1[2] = ", EXCEEDS LIW = "; i__2[3] = 8, a__1[3] = xern2; s_cat(ch__14, a__1, i__2, &c__4, 61L); xermsg_("SLATEC", "DDASSL", ch__14, &c__5, &c__1, 6L, 6L, 61L); goto L750; L706: xermsg_("SLATEC", "DDASSL", "SOME ELEMENT OF RTOL IS .LT. 0", &c__6, & c__1, 6L, 6L, 30L); goto L750; L707: xermsg_("SLATEC", "DDASSL", "SOME ELEMENT OF ATOL IS .LT. 0", &c__7, & c__1, 6L, 6L, 30L); goto L750; L708: xermsg_("SLATEC", "DDASSL", "ALL ELEMENTS OF RTOL AND ATOL ARE ZERO", & c__8, &c__1, 6L, 6L, 38L); goto L750; L709: s_wsfi(&io___1109); do_fio(&c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1110); do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(doublereal)); e_wsfi(); i__2[0] = 24, a__1[0] = "INFO(4) = 1 AND TSTOP = "; i__2[1] = 16, a__1[1] = xern3; i__2[2] = 15, a__1[2] = " BEHIND TOUT = "; i__2[3] = 16, a__1[3] = xern4; s_cat(ch__15, a__1, i__2, &c__4, 71L); xermsg_("SLATEC", "DDASSL", ch__15, &c__9, &c__1, 6L, 6L, 71L); goto L750; L710: s_wsfi(&io___1111); do_fio(&c__1, (char *)&hmax, (ftnlen)sizeof(doublereal)); e_wsfi(); i__5[0] = 7, a__4[0] = "HMAX = "; i__5[1] = 16, a__4[1] = xern3; i__5[2] = 9, a__4[2] = " .LT. 0.0"; s_cat(ch__16, a__4, i__5, &c__3, 32L); xermsg_("SLATEC", "DDASSL", ch__16, &c__10, &c__1, 6L, 6L, 32L); goto L750; L711: s_wsfi(&io___1112); do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1113); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); e_wsfi(); i__2[0] = 7, a__1[0] = "TOUT = "; i__2[1] = 16, a__1[1] = xern3; i__2[2] = 12, a__1[2] = " BEHIND T = "; i__2[3] = 16, a__1[3] = xern4; s_cat(ch__17, a__1, i__2, &c__4, 51L); xermsg_("SLATEC", "DDASSL", ch__17, &c__11, &c__1, 6L, 6L, 51L); goto L750; L712: xermsg_("SLATEC", "DDASSL", "INFO(8)=1 AND H0=0.0", &c__12, &c__1, 6L, 6L, 20L); goto L750; L713: xermsg_("SLATEC", "DDASSL", "SOME ELEMENT OF WT IS .LE. 0.0", &c__13, & c__1, 6L, 6L, 30L); goto L750; L714: s_wsfi(&io___1114); do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1115); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); e_wsfi(); i__3[0] = 7, a__2[0] = "TOUT = "; i__3[1] = 16, a__2[1] = xern3; i__3[2] = 18, a__2[2] = " TOO CLOSE TO T = "; i__3[3] = 16, a__2[3] = xern4; i__3[4] = 21, a__2[4] = " TO START INTEGRATION"; s_cat(ch__18, a__2, i__3, &c__5, 78L); xermsg_("SLATEC", "DDASSL", ch__18, &c__14, &c__1, 6L, 6L, 78L); goto L750; L715: s_wsfi(&io___1116); do_fio(&c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); e_wsfi(); s_wsfi(&io___1117); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); e_wsfi(); i__2[0] = 22, a__1[0] = "INFO(4)=1 AND TSTOP = "; i__2[1] = 16, a__1[1] = xern3; i__2[2] = 12, a__1[2] = " BEHIND T = "; i__2[3] = 16, a__1[3] = xern4; s_cat(ch__19, a__1, i__2, &c__4, 66L); xermsg_("SLATEC", "DDASSL", ch__19, &c__15, &c__1, 6L, 6L, 66L); goto L750; L717: s_wsfi(&io___1118); do_fio(&c__1, (char *)&iwork[1], (ftnlen)sizeof(integer)); e_wsfi(); i__5[0] = 5, a__4[0] = "ML = "; i__5[1] = 8, a__4[1] = xern1; i__5[2] = 36, a__4[2] = " ILLEGAL. EITHER .LT. 0 OR .GT. NEQ"; s_cat(ch__20, a__4, i__5, &c__3, 49L); xermsg_("SLATEC", "DDASSL", ch__20, &c__17, &c__1, 6L, 6L, 49L); goto L750; L718: s_wsfi(&io___1119); do_fio(&c__1, (char *)&iwork[2], (ftnlen)sizeof(integer)); e_wsfi(); i__5[0] = 5, a__4[0] = "MU = "; i__5[1] = 8, a__4[1] = xern1; i__5[2] = 36, a__4[2] = " ILLEGAL. EITHER .LT. 0 OR .GT. NEQ"; s_cat(ch__20, a__4, i__5, &c__3, 49L); xermsg_("SLATEC", "DDASSL", ch__20, &c__18, &c__1, 6L, 6L, 49L); goto L750; L719: s_wsfi(&io___1120); do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(doublereal)); e_wsfi(); i__6[0] = 11, a__5[0] = "TOUT = T = "; i__6[1] = 16, a__5[1] = xern3; s_cat(ch__21, a__5, i__6, &c__2, 27L); xermsg_("SLATEC", "DDASSL", ch__21, &c__19, &c__1, 6L, 6L, 27L); goto L750; L750: *idid = -33; if (info[1] == -1) { xermsg_("SLATEC", "DDASSL", "REPEATED OCCURRENCES OF ILLEGAL INPUT$$RUN TERMINATED. APPARENT INFINITE LOOP", &c_n999, &c__2, 6L, 6L, 77L); } info[1] = -1; return 0; } int ddastp_(x, y, yprime, neq, res, jac, h__, wt, jstart, idid, rpar, ipar, phi, delta, e, wm, iwm, alpha, beta, gamma, psi, sigma, cj, cjold, hold, s, hmin, uround, iphase, jcalc, k, kold, ns, nonneg, ntemp) doublereal *x, *y, *yprime; integer *neq; int (*res) (), (*jac) (); doublereal *h__, *wt; integer *jstart, *idid; doublereal *rpar; integer *ipar; doublereal *phi, *delta, *e, *wm; integer *iwm; doublereal *alpha, *beta, *gamma, *psi, *sigma, *cj, *cjold, *hold, *s, *hmin, *uround; integer *iphase, *jcalc, *k, *kold, *ns, *nonneg, *ntemp; { static integer maxit = 4; static doublereal xrate = .25; integer phi_dim1, phi_offset, i__1, i__2; doublereal d__1, d__2; double pow_dd(); static doublereal rate, hnew; static integer ires, knew; static doublereal terk, xold, erkm1, erkm2, erkp1, temp1, temp2; static integer i__, j, m, kdiff; static doublereal r__, enorm; static integer j1; static doublereal pnorm, alpha0, terkm1, terkm2; extern int ddajac_(); static doublereal terkp1, ck; extern doublereal ddanrm_(); static doublereal alphas; extern int ddaslv_(), ddatrp_(); static doublereal cjlast, delnrm; static logical convgd; static doublereal oldnrm; static integer km1, kp1, kp2, ncf, nef, ier; static doublereal erk; static integer nsf; static doublereal err, est; static integer nsp1; --y; --yprime; phi_dim1 = *neq; phi_offset = phi_dim1 + 1; phi -= phi_offset; --wt; --rpar; --ipar; --delta; --e; --wm; --iwm; --alpha; --beta; --gamma; --psi; --sigma; *idid = 1; xold = *x; ncf = 0; nsf = 0; nef = 0; if (*jstart != 0) { goto L120; } iwm[14] = 0; iwm[15] = 0; *k = 1; *kold = 0; *hold = 0.; *jstart = 1; psi[1] = *h__; *cjold = 1. / *h__; *cj = *cjold; *s = 100.; *jcalc = -1; delnrm = 1.; *iphase = 0; *ns = 0; L120: L200: kp1 = *k + 1; kp2 = *k + 2; km1 = *k - 1; xold = *x; if (*h__ != *hold || *k != *kold) { *ns = 0; } i__1 = *ns + 1, i__2 = *kold + 2; *ns = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; nsp1 = *ns + 1; if (kp1 < *ns) { goto L230; } beta[1] = 1.; alpha[1] = 1.; temp1 = *h__; gamma[1] = 0.; sigma[1] = 1.; i__1 = kp1; for (i__ = 2; i__ <= i__1; ++i__) { temp2 = psi[i__ - 1]; psi[i__ - 1] = temp1; beta[i__] = beta[i__ - 1] * psi[i__ - 1] / temp2; temp1 = temp2 + *h__; alpha[i__] = *h__ / temp1; sigma[i__] = (i__ - 1) * sigma[i__ - 1] * alpha[i__]; gamma[i__] = gamma[i__ - 1] + alpha[i__ - 1] / *h__; } psi[kp1] = temp1; L230: alphas = 0.; alpha0 = 0.; i__1 = *k; for (i__ = 1; i__ <= i__1; ++i__) { alphas -= 1. / i__; alpha0 -= alpha[i__]; } cjlast = *cj; *cj = -alphas / *h__; ck = (d__1 = alpha[kp1] + alphas - alpha0, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); d__1 = ck, d__2 = alpha[kp1]; ck = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; temp1 = (1. - xrate) / (xrate + 1.); temp2 = 1. / temp1; if (*cj / *cjold < temp1 || *cj / *cjold > temp2) { *jcalc = -1; } if (*cj != cjlast) { *s = 100.; } if (kp1 < nsp1) { goto L280; } i__1 = kp1; for (j = nsp1; j <= i__1; ++j) { i__2 = *neq; for (i__ = 1; i__ <= i__2; ++i__) { phi[i__ + j * phi_dim1] = beta[j] * phi[i__ + j * phi_dim1]; } } L280: *x += *h__; L300: i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = phi[i__ + phi_dim1]; yprime[i__] = 0.; } i__1 = kp1; for (j = 2; j <= i__1; ++j) { i__2 = *neq; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] += phi[i__ + j * phi_dim1]; yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1]; } } pnorm = ddanrm_(neq, &y[1], &wt[1], &rpar[1], &ipar[1]); convgd = (1) ; m = 0; ++iwm[12]; ires = 0; (*res)(x, &y[1], &yprime[1], &delta[1], &ires, &rpar[1], &ipar[1]); if (ierode_ .iero != 0) { return 0; } if (ires < 0) { goto L380; } if (*jcalc != -1) { goto L340; } ++iwm[13]; *jcalc = 0; ddajac_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ier, &wt[1], &e[1] , &wm[1], &iwm[1], res, &ires, uround, jac, &rpar[1], &ipar[1], ntemp); if (ierode_ .iero != 0) { return 0; } *cjold = *cj; *s = 100.; if (ires < 0) { goto L380; } if (ier != 0) { goto L380; } nsf = 0; L340: i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { e[i__] = 0.; } L350: temp1 = 2. / (*cj / *cjold + 1.); i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { delta[i__] *= temp1; } ddaslv_(neq, &delta[1], &wm[1], &iwm[1]); i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] -= delta[i__]; e[i__] -= delta[i__]; yprime[i__] -= *cj * delta[i__]; } delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); if (delnrm <= *uround * 100. * pnorm) { goto L375; } if (m > 0) { goto L365; } oldnrm = delnrm; goto L367; L365: d__1 = delnrm / oldnrm; d__2 = 1. / m; rate = pow_dd(&d__1, &d__2); if (rate > .9) { goto L370; } *s = rate / (1. - rate); L367: if (*s * delnrm <= .33) { goto L375; } ++m; if (m >= maxit) { goto L370; } ++iwm[12]; ires = 0; (*res)(x, &y[1], &yprime[1], &delta[1], &ires, &rpar[1], &ipar[1]); if (ierode_ .iero != 0) { return 0; } if (ires < 0) { goto L380; } goto L350; L370: if (*jcalc == 0) { goto L380; } *jcalc = -1; goto L300; L375: if (*nonneg == 0) { goto L390; } i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = y[i__]; delta[i__] = (( d__1 ) <= ( 0. ) ? ( d__1 ) : ( 0. )) ; } delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); if (delnrm > .33) { goto L380; } i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { e[i__] -= delta[i__]; } goto L390; L380: convgd = (0) ; L390: *jcalc = 1; if (! convgd) { goto L600; } enorm = ddanrm_(neq, &e[1], &wt[1], &rpar[1], &ipar[1]); erk = sigma[*k + 1] * enorm; terk = (*k + 1) * erk; est = erk; knew = *k; if (*k == 1) { goto L430; } i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { delta[i__] = phi[i__ + kp1 * phi_dim1] + e[i__]; } erkm1 = sigma[*k] * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); terkm1 = *k * erkm1; if (*k > 2) { goto L410; } if (terkm1 <= terk * .5) { goto L420; } goto L430; L410: i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { delta[i__] = phi[i__ + *k * phi_dim1] + delta[i__]; } erkm2 = sigma[*k - 1] * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1] ); terkm2 = (*k - 1) * erkm2; if ((( terkm1 ) >= ( terkm2 ) ? ( terkm1 ) : ( terkm2 )) > terk) { goto L430; } L420: knew = *k - 1; est = erkm1; L430: err = ck * enorm; if (err > 1.) { goto L600; } *idid = 1; ++iwm[11]; kdiff = *k - *kold; *kold = *k; *hold = *h__; if (knew == km1 || *k == iwm[3]) { *iphase = 1; } if (*iphase == 0) { goto L545; } if (knew == km1) { goto L540; } if (*k == iwm[3]) { goto L550; } if (kp1 >= *ns || kdiff == 1) { goto L550; } i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { delta[i__] = e[i__] - phi[i__ + kp2 * phi_dim1]; } erkp1 = 1. / (*k + 2) * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1] ); terkp1 = (*k + 2) * erkp1; if (*k > 1) { goto L520; } if (terkp1 >= terk * .5) { goto L550; } goto L530; L520: if (terkm1 <= (( terk ) <= ( terkp1 ) ? ( terk ) : ( terkp1 )) ) { goto L540; } if (terkp1 >= terk || *k == iwm[3]) { goto L550; } L530: *k = kp1; est = erkp1; goto L550; L540: *k = km1; est = erkm1; goto L550; L545: *k = kp1; hnew = *h__ * 2.; *h__ = hnew; goto L575; L550: hnew = *h__; temp2 = (doublereal) (*k + 1); d__1 = est * 2. + 1e-4; d__2 = -1. / temp2; r__ = pow_dd(&d__1, &d__2); if (r__ < 2.) { goto L555; } hnew = *h__ * 2.; goto L560; L555: if (r__ > 1.) { goto L560; } d__1 = .5, d__2 = (( .9 ) <= ( r__ ) ? ( .9 ) : ( r__ )) ; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; hnew = *h__ * r__; L560: *h__ = hnew; L575: if (*kold == iwm[3]) { goto L585; } i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { phi[i__ + kp2 * phi_dim1] = e[i__]; } L585: i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { phi[i__ + kp1 * phi_dim1] += e[i__]; } i__1 = kp1; for (j1 = 2; j1 <= i__1; ++j1) { j = kp1 - j1 + 1; i__2 = *neq; for (i__ = 1; i__ <= i__2; ++i__) { phi[i__ + j * phi_dim1] += phi[i__ + (j + 1) * phi_dim1]; } } return 0; L600: *iphase = 1; *x = xold; if (kp1 < nsp1) { goto L630; } i__2 = kp1; for (j = nsp1; j <= i__2; ++j) { temp1 = 1. / beta[j]; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { phi[i__ + j * phi_dim1] = temp1 * phi[i__ + j * phi_dim1]; } } L630: i__2 = kp1; for (i__ = 2; i__ <= i__2; ++i__) { psi[i__ - 1] = psi[i__] - *h__; } if (convgd) { goto L660; } ++iwm[15]; if (ier == 0) { goto L650; } ++nsf; r__ = .25; *h__ *= r__; if (nsf < 3 && (( *h__ ) >= 0 ? ( *h__ ) : -( *h__ )) >= *hmin) { goto L690; } *idid = -8; goto L675; L650: if (ires > -2) { goto L655; } *idid = -11; goto L675; L655: ++ncf; r__ = .25; *h__ *= r__; if (ncf < 10 && (( *h__ ) >= 0 ? ( *h__ ) : -( *h__ )) >= *hmin) { goto L690; } *idid = -7; if (ires < 0) { *idid = -10; } if (nef >= 3) { *idid = -9; } goto L675; L660: ++nef; ++iwm[14]; if (nef > 1) { goto L665; } *k = knew; temp2 = (doublereal) (*k + 1); d__1 = est * 2. + 1e-4; d__2 = -1. / temp2; r__ = pow_dd(&d__1, &d__2) * .9; d__1 = .25, d__2 = (( .9 ) <= ( r__ ) ? ( .9 ) : ( r__ )) ; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; *h__ *= r__; if ((( *h__ ) >= 0 ? ( *h__ ) : -( *h__ )) >= *hmin) { goto L690; } *idid = -6; goto L675; L665: if (nef > 2) { goto L670; } *k = knew; *h__ *= .25; if ((( *h__ ) >= 0 ? ( *h__ ) : -( *h__ )) >= *hmin) { goto L690; } *idid = -6; goto L675; L670: *k = 1; *h__ *= .25; if ((( *h__ ) >= 0 ? ( *h__ ) : -( *h__ )) >= *hmin) { goto L690; } *idid = -6; goto L675; L675: ddatrp_(x, x, &y[1], &yprime[1], neq, k, &phi[phi_offset], &psi[1]); return 0; L690: goto L200; } int ddatrp_(x, xout, yout, ypout, neq, kold, phi, psi) doublereal *x, *xout, *yout, *ypout; integer *neq, *kold; doublereal *phi, *psi; { integer phi_dim1, phi_offset, i__1, i__2; static doublereal temp1, c__, d__; static integer i__, j; static doublereal gamma; static integer koldp1; --yout; --ypout; phi_dim1 = *neq; phi_offset = phi_dim1 + 1; phi -= phi_offset; --psi; koldp1 = *kold + 1; temp1 = *xout - *x; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { yout[i__] = phi[i__ + phi_dim1]; ypout[i__] = 0.; } c__ = 1.; d__ = 0.; gamma = temp1 / psi[1]; i__1 = koldp1; for (j = 2; j <= i__1; ++j) { d__ = d__ * gamma + c__ / psi[j - 1]; c__ *= gamma; gamma = (temp1 + psi[j - 1]) / psi[j]; i__2 = *neq; for (i__ = 1; i__ <= i__2; ++i__) { yout[i__] += c__ * phi[i__ + j * phi_dim1]; ypout[i__] += d__ * phi[i__ + j * phi_dim1]; } } return 0; } int ddawts_(neq, iwt, rtol, atol, y, wt, rpar, ipar) integer *neq, *iwt; doublereal *rtol, *atol, *y, *wt, *rpar; integer *ipar; { integer i__1; doublereal d__1; static integer i__; static doublereal atoli, rtoli; --ipar; --rpar; --wt; --y; --atol; --rtol; rtoli = rtol[1]; atoli = atol[1]; i__1 = *neq; for (i__ = 1; i__ <= i__1; ++i__) { if (*iwt == 0) { goto L10; } rtoli = rtol[i__]; atoli = atol[i__]; L10: wt[i__] = rtoli * (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + atoli; } return 0; } int xerhlt_(messg, messg_len) char *messg; ftnlen messg_len; { int s_stop(); s_stop("", 0L); } int xermsg_(librar, subrou, messg, nerr, level, librar_len, subrou_len, messg_len) char *librar, *subrou, *messg; integer *nerr, *level; ftnlen librar_len; ftnlen subrou_len; ftnlen messg_len; { address a__1[2]; integer i__1, i__2[2]; char ch__1[87]; int s_copy(); integer i_len(), s_wsfi(), do_fio(), e_wsfi(); int s_cat(); static char temp[72]; static integer i__, ltemp; extern int xerhlt_(); static integer lkntrl, mkntrl; extern int xerprn_(); static icilist io___1178 = { 0, temp, 0, "('ERROR NUMBER = ', I8)", 72, 1 }; if (*nerr < -9999999 || *nerr > 99999999 || *nerr == 0 || *level < -1 || * level > 2) { xerprn_(" ***", &c_n1, "FATAL ERROR IN...$$ XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ JOB ABORT DUE TO FATAL ERROR.", &c__72, 4L, 91L); xerhlt_(" ***XERMSG -- INVALID INPUT", 27L); return 0; } lkntrl = 1; mkntrl = 1; if (lkntrl != 0) { s_copy(temp, "MESSAGE FROM ROUTINE ", 21L, 21L); i__1 = i_len(subrou, subrou_len); i__ = (( i__1 ) <= ( 16 ) ? ( i__1 ) : ( 16 )) ; s_copy(temp + 21, subrou, i__, i__); i__1 = i__ + 21; s_copy(temp + i__1, " IN LIBRARY ", i__ + 33 - i__1, 12L); ltemp = i__ + 33; i__1 = i_len(librar, librar_len); i__ = (( i__1 ) <= ( 16 ) ? ( i__1 ) : ( 16 )) ; i__1 = ltemp; s_copy(temp + i__1, librar, ltemp + i__ - i__1, i__); i__1 = ltemp + i__; s_copy(temp + i__1, ".", ltemp + i__ + 1 - i__1, 1L); ltemp = ltemp + i__ + 1; xerprn_(" ***", &c_n1, temp, &c__72, 4L, ltemp); } if (lkntrl > 0) { if (*level <= 0) { s_copy(temp, "INFORMATIVE MESSAGE,", 20L, 20L); ltemp = 20; } else if (*level == 1) { s_copy(temp, "POTENTIALLY RECOVERABLE ERROR,", 30L, 30L); ltemp = 30; } else { s_copy(temp, "FATAL ERROR,", 12L, 12L); ltemp = 12; } if (mkntrl == 2 && *level >= 1 || mkntrl == 1 && *level == 2) { i__1 = ltemp; s_copy(temp + i__1, " PROGRAM ABORTED.", ltemp + 17 - i__1, 17L); ltemp += 17; } else { i__1 = ltemp; s_copy(temp + i__1, " PROGRAM CONTINUES.", ltemp + 19 - i__1, 19L) ; ltemp += 19; } xerprn_(" ***", &c_n1, temp, &c__72, 4L, ltemp); } xerprn_(" * ", &c_n1, messg, &c__72, 4L, messg_len); if (lkntrl > 0) { s_wsfi(&io___1178); do_fio(&c__1, (char *)&(*nerr), (ftnlen)sizeof(integer)); e_wsfi(); for (i__ = 16; i__ <= 22; ++i__) { if (*(unsigned char *)&temp[i__ - 1] != ' ') { goto L20; } } L20: i__2[0] = 15, a__1[0] = temp; i__2[1] = 23 - (i__ - 1), a__1[1] = temp + (i__ - 1); s_cat(ch__1, a__1, i__2, &c__2, 87L); xerprn_(" * ", &c_n1, ch__1, &c__72, 4L, 23 - (i__ - 1) + 15); } if (lkntrl != 0) { xerprn_(" * ", &c_n1, " ", &c__72, 4L, 1L); xerprn_(" ***", &c_n1, "END OF MESSAGE", &c__72, 4L, 14L); xerprn_(" ", &c__0, " ", &c__72, 4L, 1L); } if (*level <= 0 || *level == 1 && mkntrl <= 1) { return 0; } if (lkntrl > 0) { if (*level == 1) { xerprn_(" ***", &c_n1, "JOB ABORT DUE TO UNRECOVERED ERROR.", & c__72, 4L, 35L); } else { xerprn_(" ***", &c_n1, "JOB ABORT DUE TO FATAL ERROR.", &c__72, 4L, 29L); } xerhlt_(" ", 1L); } return 0; } int xerprn_(prefix, npref, messg, nwrap, prefix_len, messg_len) char *prefix; integer *npref; char *messg; integer *nwrap; ftnlen prefix_len; ftnlen messg_len; { integer i__1, i__2; integer i_len(); int s_copy(); integer s_wsfe(), do_fio(), e_wsfe(), i_indx(), s_cmp(); static integer i__, n; static char cbuff[148]; static integer lpref, nextc, lwrap, nunit, iu[5], lpiece, idelta, lenmsg; extern int xgetua_(); static cilist io___1187 = { 0, 0, 0, "(A)", 0 }; static cilist io___1191 = { 0, 0, 0, "(A)", 0 }; xgetua_(iu, &nunit); n = 6; i__1 = nunit; for (i__ = 1; i__ <= i__1; ++i__) { if (iu[i__ - 1] == 0) { iu[i__ - 1] = n; } } if (*npref < 0) { lpref = i_len(prefix, prefix_len); } else { lpref = *npref; } lpref = (( 16 ) <= ( lpref ) ? ( 16 ) : ( lpref )) ; if (lpref != 0) { s_copy(cbuff, prefix, lpref, prefix_len); } i__1 = 16, i__2 = (( 132 ) <= ( *nwrap ) ? ( 132 ) : ( *nwrap )) ; lwrap = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; lenmsg = i_len(messg, messg_len); n = lenmsg; i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (*(unsigned char *)&messg[lenmsg - 1] != ' ') { goto L30; } --lenmsg; } L30: if (lenmsg == 0) { i__1 = lpref; s_copy(cbuff + i__1, " ", lpref + 1 - i__1, 1L); i__1 = nunit; for (i__ = 1; i__ <= i__1; ++i__) { io___1187.ciunit = iu[i__ - 1]; s_wsfe(&io___1187); do_fio(&c__1, cbuff, lpref + 1); e_wsfe(); } return 0; } nextc = 1; L50: lpiece = i_indx(messg + (nextc - 1), "$$", lenmsg - (nextc - 1), 2L); if (lpiece == 0) { idelta = 0; i__1 = lwrap, i__2 = lenmsg + 1 - nextc; lpiece = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; if (lpiece < lenmsg + 1 - nextc) { for (i__ = lpiece + 1; i__ >= 2; --i__) { i__1 = nextc + i__ - 2; if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, 1L) == 0) { lpiece = i__ - 1; idelta = 1; goto L54; } } } L54: i__1 = lpref; s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, nextc + lpiece - 1 - (nextc - 1)); nextc = nextc + lpiece + idelta; } else if (lpiece == 1) { nextc += 2; goto L50; } else if (lpiece > lwrap + 1) { idelta = 0; lpiece = lwrap; for (i__ = lpiece + 1; i__ >= 2; --i__) { i__1 = nextc + i__ - 2; if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, 1L) == 0) { lpiece = i__ - 1; idelta = 1; goto L58; } } L58: i__1 = lpref; s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, nextc + lpiece - 1 - (nextc - 1)); nextc = nextc + lpiece + idelta; } else { --lpiece; i__1 = lpref; s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, nextc + lpiece - 1 - (nextc - 1)); nextc = nextc + lpiece + 2; } i__1 = nunit; for (i__ = 1; i__ <= i__1; ++i__) { io___1191.ciunit = iu[i__ - 1]; s_wsfe(&io___1191); do_fio(&c__1, cbuff, lpref + lpiece); e_wsfe(); } if (nextc <= lenmsg) { goto L50; } return 0; } int xgetua_(iunita, n) integer *iunita, *n; { integer i__1; static integer i__; --iunita; if (xeruni_ .nunit <= 0) { xeruni_ .nunit = 1; xeruni_ .iunit[0] = 0; } *n = xeruni_ .nunit; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { iunita[i__] = xeruni_ .iunit[i__ - 1]; } return 0; } int xsetua_(iunita, n) integer *iunita, *n; { address a__1[2]; integer i__1[2], i__2; char ch__1[37]; integer s_wsfi(), do_fio(), e_wsfi(); int s_cat(); static char xern1[8]; static integer i__; extern int xermsg_(); static icilist io___1194 = { 0, xern1, 0, "(I8)", 8, 1 }; --iunita; if (*n < 1 || *n > 5) { s_wsfi(&io___1194); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); e_wsfi(); i__1[0] = 29, a__1[0] = "INVALID NUMBER OF UNITS, N = "; i__1[1] = 8, a__1[1] = xern1; s_cat(ch__1, a__1, i__1, &c__2, 37L); xermsg_("SLATEC", "XSETUA", ch__1, &c__1, &c__2, 6L, 6L, 37L); return 0; } i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { xeruni_ .iunit[i__ - 1] = iunita[i__]; } xeruni_ .nunit = *n; return 0; } int dqag0_(f, a, b, epsabs, epsrel, result, abserr, work, lwork, iwork, liwork, ifail) doublereal (*f) (); doublereal *a, *b, *epsabs, *epsrel, *result, *abserr, *work; integer *lwork, *iwork, *liwork, *ifail; { doublereal d__1, d__2; extern int dqags_(); static integer limit, ibl, iel, ier, irl; --work; --iwork; if (*lwork < 4) { goto L20; } if (*liwork < *lwork / 8 + 2) { goto L20; } limit = *lwork / 4; ibl = limit + 1; iel = limit + ibl; irl = limit + iel; d__1 = (( *epsabs ) >= 0 ? ( *epsabs ) : -( *epsabs )) ; d__2 = (( *epsrel ) >= 0 ? ( *epsrel ) : -( *epsrel )) ; dqags_(f, a, b, &d__1, &d__2, &work[1], &work[ibl], &work[iel], &work[irl] , &limit, &iwork[1], liwork, result, abserr, &ier); if (ier != 0) { goto L40; } *ifail = 0; goto L60; L20: ier = 6; L40: *ifail = 1; L60: return 0; } int dqags_(f, a, b, epsabs, epsrel, alist__, blist, elist, rlist, limit, iord, liord, result, abserr, ier) doublereal (*f) (); doublereal *a, *b, *epsabs, *epsrel, *alist__, *blist, *elist, *rlist; integer *limit, *iord, *liord; doublereal *result, *abserr; integer *ier; { integer i__1, i__2; doublereal d__1, d__2; static doublereal area, dres; static integer ksgn, last, nres; static doublereal area1, area2; static integer last1; static doublereal area12; static integer k; static doublereal small, erro12; extern int order_(); static integer ierro; static doublereal a1, a2, b1, b2, defab1, defab2, oflow; static integer ktmin, nrmax; static doublereal uflow; static logical noext; static integer iroff1, iroff2, iroff3; static doublereal res3la[3], error1, error2; static integer id, numrl2; static doublereal rlist2[52], defabs; extern doublereal dlamch_(); static doublereal epmach; extern int epsalg_(); static doublereal erlarg, abseps, correc, errbnd, resabs, erlast, errmax; static integer maxerr; static doublereal reseps; static logical extrap; static doublereal ertest; extern int quarul_(); static doublereal errsum; --rlist; --elist; --blist; --alist__; --iord; epmach = dlamch_("p", 1L); uflow = dlamch_("u", 1L); oflow = dlamch_("o", 1L); ierajf_ .iero = 0; last1 = 1; *ier = 0; ierro = 0; quarul_(f, a, b, result, abserr, &defabs, &resabs); if (ierajf_ .iero > 0) { *ier = 6; return 0; } dres = (( *result ) >= 0 ? ( *result ) : -( *result )) ; d__1 = *epsabs, d__2 = *epsrel * dres; errbnd = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (*abserr <= epmach * 100. * defabs && *abserr > errbnd) { *ier = 2; } if (*limit < 2 && *abserr > errbnd) { *ier = 1; } if (*ier != 0 || *abserr <= errbnd) { goto L320; } alist__[1] = *a; blist[1] = *b; rlist[1] = *result; rlist2[0] = *result; errmax = *abserr; maxerr = 1; area = *result; errsum = *abserr; *abserr = oflow; nrmax = 1; nres = 0; numrl2 = 2; ktmin = 0; extrap = (0) ; noext = (0) ; iroff1 = 0; iroff2 = 0; iroff3 = 0; ksgn = -1; if (dres >= (1. - epmach * 50.) * defabs) { ksgn = 1; } if (*limit < 2) { goto L220; } i__1 = *limit; for (last = 2; last <= i__1; ++last) { last1 = last; a1 = alist__[maxerr]; b1 = (alist__[maxerr] + blist[maxerr]) * .5; a2 = b1; b2 = blist[maxerr]; erlast = errmax; quarul_(f, &a1, &b1, &area1, &error1, &resabs, &defab1); if (ierajf_ .iero > 0) { *ier = 6; return 0; } quarul_(f, &a2, &b2, &area2, &error2, &resabs, &defab2); if (ierajf_ .iero > 0) { *ier = 6; return 0; } area12 = area1 + area2; erro12 = error1 + error2; errsum = errsum + erro12 - errmax; area = area + area12 - rlist[maxerr]; if (defab1 == error1 || defab2 == error2) { goto L40; } if ((d__1 = rlist[maxerr] - area12, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (( area12 ) >= 0 ? ( area12 ) : -( area12 )) * 1e-5 || erro12 < errmax * .99) { goto L20; } if (extrap) { ++iroff2; } if (! extrap) { ++iroff1; } L20: if (last > 10 && erro12 > errmax) { ++iroff3; } L40: rlist[maxerr] = area1; rlist[last] = area2; d__1 = *epsabs, d__2 = *epsrel * (( area ) >= 0 ? ( area ) : -( area )) ; errbnd = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (errsum <= errbnd) { goto L280; } if (iroff1 + iroff2 >= 10 || iroff3 >= 20) { *ier = 2; } if (iroff2 >= 5) { ierro = 3; } if (last == *limit) { *ier = 1; } d__1 = (( a1 ) >= 0 ? ( a1 ) : -( a1 )) , d__2 = (( b2 ) >= 0 ? ( b2 ) : -( b2 )) ; if ((( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) <= (epmach * 100. + 1.) * ((( a2 ) >= 0 ? ( a2 ) : -( a2 )) + uflow * 1e3)) { *ier = 4; } if (*ier != 0) { goto L220; } if (error2 > error1) { goto L60; } alist__[last] = a2; blist[maxerr] = b1; blist[last] = b2; elist[maxerr] = error1; elist[last] = error2; goto L80; L60: alist__[maxerr] = a2; alist__[last] = a1; blist[last] = b1; rlist[maxerr] = area2; rlist[last] = area1; elist[maxerr] = error2; elist[last] = error1; L80: order_(limit, &last, &maxerr, &errmax, &elist[1], &iord[1], liord, & nrmax); if (last == 2) { goto L180; } if (noext) { goto L200; } erlarg -= erlast; if ((d__1 = b1 - a1, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > small) { erlarg += erro12; } if (extrap) { goto L100; } if ((d__1 = blist[maxerr] - alist__[maxerr], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > small) { goto L200; } extrap = (1) ; nrmax = 2; L100: if (ierro == 3 || erlarg <= ertest) { goto L140; } id = nrmax; i__2 = dqa001_ .jupbnd; for (k = id; k <= i__2; ++k) { maxerr = iord[nrmax]; errmax = elist[maxerr]; if ((d__1 = blist[maxerr] - alist__[maxerr], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > small) { goto L200; } ++nrmax; } L140: ++numrl2; rlist2[numrl2 - 1] = area; epsalg_(&numrl2, rlist2, &reseps, &abseps, res3la, &nres); ++ktmin; if (ktmin > 5 && *abserr < errsum * .001) { *ier = 5; } if (abseps >= *abserr) { goto L160; } ktmin = 0; *abserr = abseps; *result = reseps; correc = erlarg; d__1 = *epsabs, d__2 = *epsrel * (( reseps ) >= 0 ? ( reseps ) : -( reseps )) ; ertest = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (*abserr <= ertest) { goto L220; } L160: if (numrl2 == 1) { noext = (1) ; } if (*ier == 5) { goto L220; } maxerr = iord[1]; errmax = elist[maxerr]; nrmax = 1; extrap = (0) ; small *= .5; erlarg = errsum; goto L200; L180: small = (d__1 = *b - *a, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * .375; erlarg = errsum; ertest = errbnd; rlist2[1] = area; L200: ; } L220: if (*abserr == oflow) { goto L280; } if (*ier + ierro == 0) { goto L260; } if (ierro == 3) { *abserr += correc; } if (*ier == 0) { *ier = 3; } if (*result != 0. && area != 0.) { goto L240; } if (*abserr > errsum) { goto L280; } if (area == 0.) { goto L320; } goto L260; L240: if (*abserr / (( *result ) >= 0 ? ( *result ) : -( *result )) > errsum / (( area ) >= 0 ? ( area ) : -( area )) ) { goto L280; } L260: d__1 = (( *result ) >= 0 ? ( *result ) : -( *result )) , d__2 = (( area ) >= 0 ? ( area ) : -( area )) ; if (ksgn == -1 && (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) <= defabs * .01) { goto L320; } if (.01 > *result / area || *result / area > 100. || errsum > (( area ) >= 0 ? ( area ) : -( area )) ) { *ier = 6; } goto L320; L280: *result = 0.; i__1 = last; for (k = 1; k <= i__1; ++k) { *result += rlist[k]; } *abserr = errsum; L320: if (*ier > 2) { --(*ier); } iord[1] = last1 << 2; return 0; } int epsalg_(n, epstab, result, abserr, res3la, nres) integer *n; doublereal *epstab, *result, *abserr, *res3la; integer *nres; { static integer limexp = 50; integer i__1; doublereal d__1, d__2, d__3; static doublereal e1abs; static integer i__; static doublereal e0, e1, e2, e3, error, oflow; static integer k1, k2, k3; static doublereal delta1, delta2, delta3; static integer ib, ie; extern doublereal dlamch_(); static doublereal epmach, ss, epsinf; static integer newelm, ib2, ind; static doublereal res; static integer num; static doublereal err1, err2, err3, tol1, tol2, tol3; --res3la; --epstab; epmach = dlamch_("p", 1L); oflow = dlamch_("o", 1L); ++(*nres); *abserr = oflow; *result = epstab[*n]; if (*n < 3) { goto L200; } epstab[*n + 2] = epstab[*n]; newelm = (*n - 1) / 2; epstab[*n] = oflow; num = *n; k1 = *n; i__1 = newelm; for (i__ = 1; i__ <= i__1; ++i__) { k2 = k1 - 1; k3 = k1 - 2; res = epstab[k1 + 2]; e0 = epstab[k3]; e1 = epstab[k2]; e2 = res; e1abs = (( e1 ) >= 0 ? ( e1 ) : -( e1 )) ; delta2 = e2 - e1; err2 = (( delta2 ) >= 0 ? ( delta2 ) : -( delta2 )) ; d__1 = (( e2 ) >= 0 ? ( e2 ) : -( e2 )) ; tol2 = (( d__1 ) >= ( e1abs ) ? ( d__1 ) : ( e1abs )) * epmach; delta3 = e1 - e0; err3 = (( delta3 ) >= 0 ? ( delta3 ) : -( delta3 )) ; d__1 = e1abs, d__2 = (( e0 ) >= 0 ? ( e0 ) : -( e0 )) ; tol3 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) * epmach; if (err2 > tol2 || err3 > tol3) { goto L20; } *result = res; *abserr = err2 + err3; goto L200; L20: e3 = epstab[k1]; epstab[k1] = e1; delta1 = e1 - e3; err1 = (( delta1 ) >= 0 ? ( delta1 ) : -( delta1 )) ; d__1 = e1abs, d__2 = (( e3 ) >= 0 ? ( e3 ) : -( e3 )) ; tol1 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) * epmach; if (err1 < tol1 || err2 < tol2 || err3 < tol3) { goto L40; } ss = 1. / delta1 + 1. / delta2 - 1. / delta3; epsinf = (d__1 = ss * e1, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (epsinf > 1e-4) { goto L60; } L40: *n = i__ + i__ - 1; goto L100; L60: res = e1 + 1. / ss; epstab[k1] = res; k1 += -2; error = err2 + (d__1 = res - e2, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + err3; if (error > *abserr) { goto L80; } *abserr = error; *result = res; L80: ; } L100: if (*n == limexp) { *n = (limexp / 2 << 1) - 1; } ib = 1; if (num / 2 << 1 == num) { ib = 2; } ie = newelm + 1; i__1 = ie; for (i__ = 1; i__ <= i__1; ++i__) { ib2 = ib + 2; epstab[ib] = epstab[ib2]; ib = ib2; } if (num == *n) { goto L160; } ind = num - *n + 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { epstab[i__] = epstab[ind]; ++ind; } L160: if (*nres >= 4) { goto L180; } res3la[*nres] = *result; *abserr = oflow; goto L200; L180: *abserr = (d__1 = *result - res3la[3], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = *result - res3la[2], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + (d__3 = *result - res3la[1], (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) ); res3la[1] = res3la[2]; res3la[2] = res3la[3]; res3la[3] = *result; L200: d__1 = *abserr, d__2 = epmach * 5. * (( *result ) >= 0 ? ( *result ) : -( *result )) ; *abserr = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; return 0; } int ewset_(n, itol, rtol, atol, ycur, ewt) integer *n, *itol; doublereal *rtol, *atol, *ycur, *ewt; { integer i__1; doublereal d__1; static integer i__; static doublereal atoli, rtoli; --ewt; --ycur; --rtol; --atol; rtoli = rtol[1]; atoli = atol[1]; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol >= 3) { rtoli = rtol[i__]; } if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } ewt[i__] = rtoli * (d__1 = ycur[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + atoli; } return 0; } doublereal fnorm_(n, a, w) integer *n; doublereal *a, *w; { integer a_dim1, a_offset, i__1, i__2; doublereal ret_val, d__1, d__2; static integer i__, j; static doublereal an, sum; --w; a_dim1 = *n; a_offset = a_dim1 + 1; a -= a_offset; an = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sum = 0.; i__2 = *n; for (j = 1; j <= i__2; ++j) { sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / w[j]; } d__1 = an, d__2 = sum * w[i__]; an = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } ret_val = an; return ret_val; } int intdy_(t, k, yh, nyh, dky, iflag) doublereal *t; integer *k; doublereal *yh; integer *nyh; doublereal *dky; integer *iflag; { integer yh_dim1, yh_offset, i__1, i__2; double pow_di(); static doublereal c__; static integer i__, j; static doublereal r__, s; static integer ic, jb, jj; static doublereal tp; static integer jb2, jj1, jp1; extern int xerrwv_(); yh_dim1 = *nyh; yh_offset = yh_dim1 + 1; yh -= yh_offset; --dky; *iflag = 0; if (*k < 0 || *k > (ls0001_._1) .nq) { goto L80; } tp = (ls0001_._1) .tn - (ls0001_._1) .hu * ((ls0001_._1) .uround * 100. + 1.); if ((*t - tp) * (*t - (ls0001_._1) .tn) > 0.) { goto L90; } s = (*t - (ls0001_._1) .tn) / (ls0001_._1) .h__; ic = 1; if (*k == 0) { goto L15; } jj1 = (ls0001_._1) .l - *k; i__1 = (ls0001_._1) .nq; for (jj = jj1; jj <= i__1; ++jj) { ic *= jj; } L15: c__ = (doublereal) ic; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { dky[i__] = c__ * yh[i__ + (ls0001_._1) .l * yh_dim1]; } if (*k == (ls0001_._1) .nq) { goto L55; } jb2 = (ls0001_._1) .nq - *k; i__1 = jb2; for (jb = 1; jb <= i__1; ++jb) { j = (ls0001_._1) .nq - jb; jp1 = j + 1; ic = 1; if (*k == 0) { goto L35; } jj1 = jp1 - *k; i__2 = j; for (jj = jj1; jj <= i__2; ++jj) { ic *= jj; } L35: c__ = (doublereal) ic; i__2 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__2; ++i__) { dky[i__] = c__ * yh[i__ + jp1 * yh_dim1] + s * dky[i__]; } } if (*k == 0) { return 0; } L55: i__1 = -(*k); r__ = pow_di(& (ls0001_._1) .h__, &i__1); i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { dky[i__] = r__ * dky[i__]; } return 0; L80: xerrwv_("intdy-- k (=i1) illegal ", &c__30, &c__51, &c__1, &c__1, k, &c__0, &c__0, &c_b61, &c_b61, 30L); *iflag = -1; return 0; L90: xerrwv_("intdy-- t (=r1) illegal ", &c__30, &c__52, &c__1, &c__0, & c__0, &c__0, &c__1, t, &c_b61, 30L); xerrwv_(" t n est pas entre tcur - hu (= r1) et tcur (=r2)", &c__60, &c__52, &c__1, &c__0, &c__0, &c__0, &c__2, &tp, & (ls0001_._1) .tn, 54L) ; *iflag = -2; return 0; } int lsdisc_(f, neq, y, t, tout, rwork, lrw, istate) int (*f) (); integer *neq; doublereal *y, *t, *tout, *rwork; integer *lrw, *istate; { integer i__1; int s_copy(); static integer j; extern int dcopy_(), error_(); static integer itout, it; static doublereal tt; --y; --rwork; it = (integer) (*t); itout = (integer) (*tout); ierode_ .iero = 0; if (itout < it) { s_copy(cha1_ .buf, "ode discrete : a requested k is smaller than initial one", 4096L, 57L); error_(&c__999); return 0; } else if (itout == it) { *istate = 2; return 0; } else { i__1 = itout - 1; for (j = it; j <= i__1; ++j) { tt = (doublereal) j; (*f)(neq, &tt, &y[1], &rwork[1]); if (ierode_ .iero > 0) { return 0; } dcopy_(neq, &rwork[1], &c__1, &y[1], &c__1); } *t = *tout; *istate = 2; return 0; } } int lsoda_(f, neq, y, t, tout, itol, rtol, atol, itask, istate, iopt, rwork, lrw, iwork, liw, jac, jt) int (*f) (); integer *neq; doublereal *y, *t, *tout; integer *itol; doublereal *rtol, *atol; integer *itask, *istate, *iopt; doublereal *rwork; integer *lrw, *iwork, *liw; int (*jac) (); integer *jt; { static integer mord[2] = { 12,5 }; static integer mxstp0 = 500; static integer mxhnl0 = 10; integer i__1; doublereal d__1, d__2; double sqrt(), d_sign(); extern int prja_(); static doublereal hmax; static logical ihit; static doublereal ewti, size; static integer len1c, len1n, len1s, i__, iflag; static doublereal atoli; static integer leniw, lenwm; extern int stoda_(); static integer imxer; static doublereal tcrit; static integer lenrw; static doublereal h0; static integer i1, i2; static doublereal rtoli, tdist, tolsf; extern int ewset_(); static doublereal tnext; extern int intdy_(); static doublereal w0; extern int solsy_(); extern doublereal dlamch_(); static integer ml; static doublereal rh; static integer mu; static doublereal tp; static integer leniwc, lenrwc, lf0, lenrwn, lenrws; extern doublereal vmnorm_(); extern int xerrwv_(); static doublereal big; static integer kgo; static doublereal ayi, hmx, tol, sum; static integer len1, len2; --neq; --y; --rtol; --atol; --rwork; --iwork; ierode_ .iero = 0; if (*istate < 1 || *istate > 3) { goto L601; } if (*itask < 1 || *itask > 5) { goto L602; } if (*istate == 1) { goto L10; } if ((ls0001_._2) .init == 0) { goto L603; } if (*istate == 2) { goto L200; } goto L20; L10: (ls0001_._2) .init = 0; if (*tout == *t) { goto L430; } L20: (ls0001_._2) .ntrep = 0; if (neq[1] <= 0) { goto L604; } if (*istate == 1) { goto L25; } if (neq[1] > (ls0001_._2) .n) { goto L605; } L25: (ls0001_._2) .n = neq[1]; if (*itol < 1 || *itol > 4) { goto L606; } if (*iopt < 0 || *iopt > 1) { goto L607; } if (*jt == 3 || *jt < 1 || *jt > 5) { goto L608; } (lsa001_._1) .jtyp = *jt; if (*jt <= 2) { goto L30; } ml = iwork[1]; mu = iwork[2]; if (ml < 0 || ml >= (ls0001_._2) .n) { goto L609; } if (mu < 0 || mu >= (ls0001_._2) .n) { goto L610; } L30: if (*iopt == 1) { goto L40; } (lsa001_._1) .ixpr = 0; (ls0001_._2) .mxstep = mxstp0; (ls0001_._2) .mxhnil = mxhnl0; (ls0001_._2) .hmxi = 0.; (ls0001_._2) .hmin = 0.; if (*istate != 1) { goto L60; } h0 = 0.; (lsa001_._1) .mxordn = mord[0]; (lsa001_._1) .mxords = mord[1]; goto L60; L40: (lsa001_._1) .ixpr = iwork[5]; if ((lsa001_._1) .ixpr < 0 || (lsa001_._1) .ixpr > 1) { goto L611; } (ls0001_._2) .mxstep = iwork[6]; if ((ls0001_._2) .mxstep < 0) { goto L612; } if ((ls0001_._2) .mxstep == 0) { (ls0001_._2) .mxstep = mxstp0; } (ls0001_._2) .mxhnil = iwork[7]; if ((ls0001_._2) .mxhnil < 0) { goto L613; } if ((ls0001_._2) .mxhnil == 0) { (ls0001_._2) .mxhnil = mxhnl0; } if (*istate != 1) { goto L50; } h0 = rwork[5]; (lsa001_._1) .mxordn = iwork[8]; if ((lsa001_._1) .mxordn < 0) { goto L628; } if ((lsa001_._1) .mxordn == 0) { (lsa001_._1) .mxordn = 100; } (lsa001_._1) .mxordn = (( (lsa001_._1) .mxordn ) <= ( mord[0] ) ? ( (lsa001_._1) .mxordn ) : ( mord[0] )) ; (lsa001_._1) .mxords = iwork[9]; if ((lsa001_._1) .mxords < 0) { goto L629; } if ((lsa001_._1) .mxords == 0) { (lsa001_._1) .mxords = 100; } (lsa001_._1) .mxords = (( (lsa001_._1) .mxords ) <= ( mord[1] ) ? ( (lsa001_._1) .mxords ) : ( mord[1] )) ; if ((*tout - *t) * h0 < 0.) { goto L614; } L50: hmax = rwork[6]; if (hmax < 0.) { goto L615; } (ls0001_._2) .hmxi = 0.; if (hmax > 0.) { (ls0001_._2) .hmxi = 1. / hmax; } (ls0001_._2) .hmin = rwork[7]; if ((ls0001_._2) .hmin < 0.) { goto L616; } L60: if (*istate == 1) { (ls0001_._2) .meth = 1; } if (*istate == 1) { (ls0001_._2) .nyh = (ls0001_._2) .n; } (ls0001_._2) .lyh = 21; len1n = ((lsa001_._1) .mxordn + 1) * (ls0001_._2) .nyh + 20; len1s = ((lsa001_._1) .mxords + 1) * (ls0001_._2) .nyh + 20; (ls0001_._2) .lwm = len1s + 1; if (*jt <= 2) { lenwm = (ls0001_._2) .n * (ls0001_._2) .n + 2; } if (*jt >= 4) { lenwm = ((ml << 1) + mu + 1) * (ls0001_._2) .n + 2; } len1s += lenwm; len1c = len1n; if ((ls0001_._2) .meth == 2) { len1c = len1s; } len1 = (( len1n ) >= ( len1s ) ? ( len1n ) : ( len1s )) ; len2 = (ls0001_._2) .n * 3; lenrw = len1 + len2; lenrwn = len1n + len2; lenrws = len1s + len2; lenrwc = len1c + len2; iwork[17] = lenrw; (ls0001_._2) .liwm = 1; leniw = (ls0001_._2) .n + 20; leniwc = 20; if ((ls0001_._2) .meth == 2) { leniwc = leniw; } iwork[18] = leniw; if (*istate == 1 && *lrw < lenrwc) { goto L617; } if (*istate == 1 && *liw < leniwc) { goto L618; } if (*istate == 3 && *lrw < lenrwc) { goto L550; } if (*istate == 3 && *liw < leniwc) { goto L555; } (ls0001_._2) .lewt = len1 + 1; (lsa001_._1) .insufr = 0; if (*lrw >= lenrw) { goto L65; } (lsa001_._1) .insufr = 2; (ls0001_._2) .lewt = len1c + 1; xerrwv_("lsoda-- attention size of rwork now suffisent", &c__60, &c__103, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 46L); xerrwv_("but may become too small : integration continues", &c__60, & c__103, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 48L); xerrwv_("required size is i1 given size is i2", &c__50, &c__103, &c__1, & c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 36L); L65: (ls0001_._2) .lsavf = (ls0001_._2) .lewt + (ls0001_._2) .n; (ls0001_._2) .lacor = (ls0001_._2) .lsavf + (ls0001_._2) .n; (lsa001_._1) .insufi = 0; if (*liw >= leniw) { goto L70; } (lsa001_._1) .insufi = 2; xerrwv_("lsoda-- size for iwork now sufficient", &c__60, &c__104, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 38L); xerrwv_("may become too small. integration continues", &c__60, &c__104, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 44L); xerrwv_("required size is i1, given size is i2", &c__50, &c__104, &c__1, & c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 37L); L70: rtoli = rtol[1]; atoli = atol[1]; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol >= 3) { rtoli = rtol[i__]; } if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } if (rtoli < 0.) { goto L619; } if (atoli < 0.) { goto L620; } } if (*istate == 1) { goto L100; } (ls0001_._2) .jstart = -1; if ((ls0001_._2) .n == (ls0001_._2) .nyh) { goto L200; } i1 = (ls0001_._2) .lyh + (ls0001_._2) .l * (ls0001_._2) .nyh; i2 = (ls0001_._2) .lyh + ((ls0001_._2) .maxord + 1) * (ls0001_._2) .nyh - 1; if (i1 > i2) { goto L200; } i__1 = i2; for (i__ = i1; i__ <= i__1; ++i__) { rwork[i__] = 0.; } goto L200; L100: (ls0001_._2) .uround = dlamch_("p", 1L); (ls0001_._2) .tn = *t; (lsa001_._1) .tsw = *t; (ls0001_._2) .maxord = (lsa001_._1) .mxordn; if (*itask != 4 && *itask != 5) { goto L110; } tcrit = rwork[1]; if ((tcrit - *tout) * (*tout - *t) < 0.) { goto L625; } if (h0 != 0. && (*t + h0 - tcrit) * h0 > 0.) { h0 = tcrit - *t; } L110: (ls0001_._2) .jstart = 0; (ls0001_._2) .nhnil = 0; (ls0001_._2) .nst = 0; (ls0001_._2) .nje = 0; (ls0001_._2) .nslast = 0; (ls0001_._2) .hu = 0.; (ls0001_._2) .nqu = 0; (lsa001_._1) .mused = 0; (ls0001_._2) .miter = 0; (ls0001_._2) .ccmax = .3; (ls0001_._2) .maxcor = 3; (ls0001_._2) .msbp = 20; (ls0001_._2) .mxncf = 10; lf0 = (ls0001_._2) .lyh + (ls0001_._2) .nyh; (*f)(&neq[1], t, &y[1], &rwork[lf0]); if (ierode_ .iero > 0) { return 0; } (ls0001_._2) .nfe = 1; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + (ls0001_._2) .lyh - 1] = y[i__]; } (ls0001_._2) .nq = 1; (ls0001_._2) .h__ = 1.; ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) { goto L621; } rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1]; } if (h0 != 0.) { goto L180; } tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ; w0 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (tdist < (ls0001_._2) .uround * 2. * w0) { goto L622; } tol = rtol[1]; if (*itol <= 2) { goto L140; } i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = tol, d__2 = rtol[i__]; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } L140: if (tol > 0.) { goto L160; } atoli = atol[1]; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } ayi = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (ayi != 0.) { d__1 = tol, d__2 = atoli / ayi; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } } L160: d__1 = tol, d__2 = (ls0001_._2) .uround * 100.; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; tol = (( tol ) <= ( .001 ) ? ( tol ) : ( .001 )) ; sum = vmnorm_(& (ls0001_._2) .n, &rwork[lf0], &rwork[(ls0001_._2) .lewt]); d__1 = sum; sum = 1. / (tol * w0 * w0) + tol * (d__1 * d__1); h0 = 1. / sqrt(sum); h0 = (( h0 ) <= ( tdist ) ? ( h0 ) : ( tdist )) ; d__1 = *tout - *t; h0 = d_sign(&h0, &d__1); L180: rh = (( h0 ) >= 0 ? ( h0 ) : -( h0 )) * (ls0001_._2) .hmxi; if (rh > 1.) { h0 /= rh; } (ls0001_._2) .h__ = h0; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + lf0 - 1] = h0 * rwork[i__ + lf0 - 1]; } goto L270; L200: (ls0001_._2) .nslast = (ls0001_._2) .nst; switch ((int)*itask) { case 1: goto L210; case 2: goto L250; case 3: goto L220; case 4: goto L230; case 5: goto L240; } L210: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); if (iflag != 0) { goto L627; } *t = *tout; goto L420; L220: tp = (ls0001_._2) .tn - (ls0001_._2) .hu * ((ls0001_._2) .uround * 100. + 1.); if ((tp - *tout) * (ls0001_._2) .h__ > 0.) { goto L623; } if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } *t = (ls0001_._2) .tn; goto L400; L230: tcrit = rwork[1]; if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) { goto L624; } if ((tcrit - *tout) * (ls0001_._2) .h__ < 0.) { goto L625; } if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L245; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); if (iflag != 0) { goto L627; } *t = *tout; goto L420; L240: tcrit = rwork[1]; if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) { goto L624; } L245: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; if (ihit) { *t = tcrit; } if (ihit) { goto L400; } tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.); if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) { goto L250; } (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.); if (*istate == 2 && (ls0001_._2) .jstart != -1) { (ls0001_._2) .jstart = -2; } L250: if ((ls0001_._2) .meth == (lsa001_._1) .mused) { goto L255; } if ((lsa001_._1) .insufr == 1) { goto L550; } if ((lsa001_._1) .insufi == 1) { goto L555; } L255: if ((ls0001_._2) .nst - (ls0001_._2) .nslast >= (ls0001_._2) .mxstep) { goto L500; } ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) { goto L510; } rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1]; } L270: tolsf = (ls0001_._2) .uround * vmnorm_(& (ls0001_._2) .n, &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); if (tolsf <= .01) { goto L280; } tolsf *= 200.; if ((ls0001_._2) .nst == 0) { goto L626; } goto L520; L280: if ((ls0001_._2) .tn + (ls0001_._2) .h__ != (ls0001_._2) .tn) { goto L290; } ++ (ls0001_._2) .nhnil; if ((ls0001_._2) .nhnil > (ls0001_._2) .mxhnil) { goto L290; } xerrwv_("lsoda-- caution... t (=r1) and h (=r2) are", &c__50, &c__101, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 43L); xerrwv_(" such that t + h = t at next step", &c__60, &c__101, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 37L); xerrwv_(" (h = pas). integration continues", &c__50, &c__101, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 38L); if ((ls0001_._2) .nhnil < (ls0001_._2) .mxhnil) { goto L290; } xerrwv_("lsoda-- previous message precedent given i1 times", &c__50, & c__102, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" will no more be repeated", &c__50, &c__102, &c__1, &c__1, & (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 29L); L290: stoda_(&neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &rwork[ (ls0001_._2) .lyh], &rwork[(ls0001_._2) .lewt], &rwork[(ls0001_._2) .lsavf], & rwork[(ls0001_._2) .lacor], &rwork[(ls0001_._2) .lwm], &iwork[(ls0001_._2) .liwm] , f, jac, prja_, solsy_); if (ierode_ .iero > 0) { return 0; } kgo = 1 - (ls0001_._2) .kflag; switch ((int)kgo) { case 1: goto L300; case 2: goto L530; case 3: goto L540; } L300: (ls0001_._2) .init = 1; if ((ls0001_._2) .meth == (lsa001_._1) .mused) { goto L310; } (lsa001_._1) .tsw = (ls0001_._2) .tn; (ls0001_._2) .maxord = (lsa001_._1) .mxordn; if ((ls0001_._2) .meth == 2) { (ls0001_._2) .maxord = (lsa001_._1) .mxords; } if ((ls0001_._2) .meth == 2) { rwork[(ls0001_._2) .lwm] = sqrt((ls0001_._2) .uround); } (lsa001_._1) .insufr = (( (lsa001_._1) .insufr ) <= ( 1 ) ? ( (lsa001_._1) .insufr ) : ( 1 )) ; (lsa001_._1) .insufi = (( (lsa001_._1) .insufi ) <= ( 1 ) ? ( (lsa001_._1) .insufi ) : ( 1 )) ; (ls0001_._2) .jstart = -1; if ((lsa001_._1) .ixpr == 0) { goto L310; } if ((ls0001_._2) .meth == 2) { xerrwv_("lsoda-- using stiff method ", &c__60, &c__105, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 28L); } if ((ls0001_._2) .meth == 1) { xerrwv_("lsoda-- using adams formulas (non stiff)", &c__60, &c__106, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 40L); } xerrwv_(" a t = r1, trial with step h = r2, step nst = i1 ", &c__60, &c__107, &c__1, &c__1, & (ls0001_._2) .nst, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 54L); L310: switch ((int)*itask) { case 1: goto L320; case 2: goto L400; case 3: goto L330; case 4: goto L340; case 5: goto L350; } L320: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); *t = *tout; goto L420; L330: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ >= 0.) { goto L400; } goto L250; L340: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L345; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); *t = *tout; goto L420; L345: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; if (ihit) { goto L400; } tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.); if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) { goto L250; } (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.); if ((ls0001_._2) .jstart != -1) { (ls0001_._2) .jstart = -2; } goto L250; L350: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; L400: i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1]; } *t = (ls0001_._2) .tn; if (*itask != 4 && *itask != 5) { goto L420; } if (ihit) { *t = tcrit; } L420: *istate = 2; (ls0001_._2) .illin = 0; rwork[11] = (ls0001_._2) .hu; rwork[12] = (ls0001_._2) .h__; rwork[13] = (ls0001_._2) .tn; rwork[15] = (lsa001_._1) .tsw; iwork[11] = (ls0001_._2) .nst; iwork[12] = (ls0001_._2) .nfe; iwork[13] = (ls0001_._2) .nje; iwork[14] = (ls0001_._2) .nqu; iwork[15] = (ls0001_._2) .nq; iwork[19] = (lsa001_._1) .mused; iwork[20] = (ls0001_._2) .meth; return 0; L430: ++ (ls0001_._2) .ntrep; if ((ls0001_._2) .ntrep < 5) { return 0; } xerrwv_("lsoda-- repeated calls with istate = 1 and tout = t (=r1) ", & c__60, &c__301, &c__1, &c__0, &c__0, &c__0, &c__1, t, &c_b61, 60L) ; goto L800; L500: xerrwv_("lsoda-- at t (=r1), mxstep (=i1) steps ", &c__50, &c__201, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 42L); xerrwv_("needed before reaching totu", &c__50, &c__201, &c__1, &c__1, & (ls0001_._2) .mxstep, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 27L); *istate = -1; goto L580; L510: ewti = rwork[(ls0001_._2) .lewt + i__ - 1]; xerrwv_("lsoda-- at t (=r1), ewt(i1) is r2 .le. 0.", &c__50, &c__202, & c__1, &c__1, &i__, &c__0, &c__2, & (ls0001_._2) .tn, &ewti, 42L); *istate = -6; goto L580; L520: xerrwv_("lsoda-- a t (=r1), too much precision required", &c__50, & c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 48L); xerrwv_(" with respect to epsilon tolsf (=r2) ", &c__50, &c__203, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, &tolsf, 38L); rwork[14] = tolsf; *istate = -2; goto L580; L530: xerrwv_("lsoda-- at t(=r1) and for step h(=r2), error", &c__50, &c__204, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 45L); xerrwv_(" failed with abs(h) = hmin", &c__50, &c__204, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 31L); *istate = -4; goto L560; L540: xerrwv_("lsoda-- at t (=r1) and step h (=r2), the", &c__50, &c__205, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 41L); xerrwv_(" corrector does not converge ", &c__50, &c__205, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 31L); xerrwv_(" with abs(h) = hmin ", &c__30, &c__205, &c__1, &c__0, & c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 27L); *istate = -5; goto L560; L550: xerrwv_("lsoda-- a t(=r1), rwork too small", &c__50, &c__206, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 34L); xerrwv_(" to continue. integration ok.", &c__60, &c__206, &c__1, & c__0, &c__0, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 36L); *istate = -7; goto L580; L555: xerrwv_("lsoda-- at t(=r1) iwork too small", &c__50, &c__207, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 35L); xerrwv_(" to continue. integration ok.", &c__60, &c__207, &c__1, & c__0, &c__0, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 36L); *istate = -7; goto L580; L560: big = 0.; imxer = 1; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { size = (d__1 = rwork[i__ + (ls0001_._2) .lacor - 1] * rwork[i__ + (ls0001_._2) .lewt - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (big >= size) { goto L570; } big = size; imxer = i__; L570: ; } iwork[16] = imxer; L580: i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1]; } *t = (ls0001_._2) .tn; (ls0001_._2) .illin = 0; rwork[11] = (ls0001_._2) .hu; rwork[12] = (ls0001_._2) .h__; rwork[13] = (ls0001_._2) .tn; rwork[15] = (lsa001_._1) .tsw; iwork[11] = (ls0001_._2) .nst; iwork[12] = (ls0001_._2) .nfe; iwork[13] = (ls0001_._2) .nje; iwork[14] = (ls0001_._2) .nqu; iwork[15] = (ls0001_._2) .nq; iwork[19] = (lsa001_._1) .mused; iwork[20] = (ls0001_._2) .meth; return 0; L601: xerrwv_("lsoda-- istate (=i1) illegal ", &c__30, &c__1, &c__1, &c__1, istate, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L602: xerrwv_("lsoda-- itask (=i1) illegal ", &c__30, &c__2, &c__1, &c__1, itask, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L603: xerrwv_("lsoda-- istate .gt. 1 ", &c__50, &c__3, &c__1, &c__0, &c__0, & c__0, &c__0, &c_b61, &c_b61, 23L); goto L700; L604: xerrwv_("lsoda-- neq (=i1) .lt. 1 ", &c__30, &c__4, &c__1, &c__1, & neq[1], &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L605: xerrwv_("lsoda-- istate and neq increased from i1 to i2", &c__50, &c__5, &c__1, &c__2, & (ls0001_._2) .n, &neq[1], &c__0, &c_b61, &c_b61, 48L); goto L700; L606: xerrwv_("lsoda-- itol (=i1) illegal ", &c__30, &c__6, &c__1, &c__1, itol, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L607: xerrwv_("lsoda-- iopt (=i1) illegal ", &c__30, &c__7, &c__1, &c__1, iopt, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L608: xerrwv_("lsoda-- jt (=i1) illegal ", &c__30, &c__8, &c__1, &c__1, jt, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L609: xerrwv_("lsoda-- ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, & c__9, &c__1, &c__2, &ml, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L610: xerrwv_("lsoda-- mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, & c__10, &c__1, &c__2, &mu, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L611: xerrwv_("lsoda-- ixpr (=i1) illegal ", &c__30, &c__11, &c__1, &c__1, & (lsa001_._1) .ixpr, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L612: xerrwv_("lsoda-- mxstep (=i1) .lt. 0 ", &c__30, &c__12, &c__1, &c__1, & (ls0001_._2) .mxstep, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L613: xerrwv_("lsoda-- mxhnil (=i1) .lt. 0 ", &c__30, &c__13, &c__1, &c__1, & (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L614: xerrwv_("lsoda-- tout (=r1) .gt. t (=r2) ", &c__40, &c__14, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 40L); xerrwv_(" h0 (=r1) gives direction", &c__50, &c__14, &c__1, &c__0, & c__0, &c__0, &c__1, &h0, &c_b61, 30L); goto L700; L615: xerrwv_("lsoda-- hmax (=r1) .lt. 0.0 ", &c__30, &c__15, &c__1, &c__0, & c__0, &c__0, &c__1, &hmax, &c_b61, 30L); goto L700; L616: xerrwv_("lsoda-- hmin (=r1) .lt. 0.0 ", &c__30, &c__16, &c__1, &c__0, & c__0, &c__0, &c__1, & (ls0001_._2) .hmin, &c_b61, 30L); goto L700; L617: xerrwv_("lsoda-- required size for iwork (i1) larger than i2", &c__60, & c__17, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 51L); goto L700; L618: xerrwv_("lsoda-- required size for iwork (=i1) larger than i2", &c__60, & c__18, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 52L); goto L700; L619: xerrwv_("lsoda-- rtol(i1) is r1 .lt. 0.0 ", &c__40, &c__19, &c__1, &c__1, &i__, &c__0, &c__1, &rtoli, &c_b61, 40L); goto L700; L620: xerrwv_("lsoda-- atol(i1) is r1 .lt. 0.0 ", &c__40, &c__20, &c__1, &c__1, &i__, &c__0, &c__1, &atoli, &c_b61, 40L); goto L700; L621: ewti = rwork[(ls0001_._2) .lewt + i__ - 1]; xerrwv_("lsoda-- ewt(i1) is r1 .le. 0.0 ", &c__40, &c__21, &c__1, &c__1, &i__, &c__0, &c__1, &ewti, &c_b61, 40L); goto L700; L622: xerrwv_("lsoda-- tout (=r1) too close to t(=r2) to integrate", &c__60, & c__22, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 52L); goto L700; L623: xerrwv_("lsoda-- itask = i1 and tout (=r1) .gt. tcur - hu (= r2) ", & c__60, &c__23, &c__1, &c__1, itask, &c__0, &c__2, tout, &tp, 58L); goto L700; L624: xerrwv_("lsoda-- itask = 4 or 5 and tcrit (=r1) .gt. tcur (=r2) ", & c__60, &c__24, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, & (ls0001_._2) .tn, 58L); goto L700; L625: xerrwv_("lsoda-- itask = 4 or 5 and tcrit (=r1) .gt. tout (=r2)", & c__60, &c__25, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, tout, 57L); goto L700; L626: xerrwv_("lsoda-- precision asked ", &c__50, &c__26, &c__1, &c__0, &c__0, & c__0, &c__0, &c_b61, &c_b61, 24L); xerrwv_("too accurate. tolsf (=r1)", &c__60, &c__26, &c__1, &c__0, &c__0, &c__0, &c__1, &tolsf, &c_b61, 25L); rwork[14] = tolsf; goto L700; L627: xerrwv_("lsoda-- problems due to intdy. itask=i1,tout=r1", &c__50, & c__27, &c__1, &c__1, itask, &c__0, &c__1, tout, &c_b61, 48L); goto L700; L628: xerrwv_("lsoda-- mxordn (=i1) .lt. 0 ", &c__30, &c__28, &c__1, &c__1, & (lsa001_._1) .mxordn, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L629: xerrwv_("lsoda-- mxords (=i1) .lt. 0 ", &c__30, &c__29, &c__1, &c__1, & (lsa001_._1) .mxords, &c__0, &c__0, &c_b61, &c_b61, 30L); L700: if ((ls0001_._2) .illin == 5) { goto L710; } ++ (ls0001_._2) .illin; *istate = -3; return 0; L710: xerrwv_("lsoda-- incorrect input", &c__50, &c__302, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 24L); L800: xerrwv_("lsoda-- infinite loop? ", &c__50, &c__303, &c__2, &c__0, &c__0, & c__0, &c__0, &c_b61, &c_b61, 23L); return 0; } int lsodar_(f, neq, y, t, tout, itol, rtol, atol, itask, istate, iopt, rwork, lrw, iwork, liw, jac, jt, g, ng, jroot) int (*f) (); integer *neq; doublereal *y, *t, *tout; integer *itol; doublereal *rtol, *atol; integer *itask, *istate, *iopt; doublereal *rwork; integer *lrw, *iwork, *liw; int (*jac) (); integer *jt; int (*g) (); integer *ng, *jroot; { static integer mord[2] = { 12,5 }; static integer mxstp0 = 500; static integer mxhnl0 = 10; integer i__1; doublereal d__1, d__2; double sqrt(), d_sign(); extern int prja_(); static doublereal hmax; static integer irfp; static logical ihit; static doublereal ewti, size; static integer len1c, len1n, len1s, i__, iflag; extern int rchek_(); static doublereal atoli; static integer leniw, lenwm, lenyh, imxer; static doublereal tcrit; extern int dcopy_(); static integer lenrw, i1, i2; static doublereal h0, rtoli, tdist, tnext, tolsf, w0; extern int solsy_(); extern int ewset_(), intdy_(), stoda_(); extern doublereal dlamch_(); static integer ml; static doublereal rh; static integer mu; static doublereal tp; static integer leniwc, lenrwc, lf0, lenrwn, lenrws, lyhnew; extern doublereal vmnorm_(); extern int xerrwv_(); static doublereal big; static integer kgo; static doublereal ayi, hmx; static integer irt; static doublereal tol, sum; static integer len1, len2; --neq; --y; --rtol; --atol; --rwork; --iwork; --jroot; if (*istate < 1 || *istate > 3) { goto L601; } if (*itask < 1 || *itask > 5) { goto L602; } (lsr001_._1) .itaskc = *itask; if (*istate == 1) { goto L10; } if ((ls0001_._2) .init == 0) { goto L603; } if (*istate == 2) { goto L200; } goto L20; L10: (ls0001_._2) .init = 0; if (*tout == *t) { goto L430; } L20: (ls0001_._2) .ntrep = 0; if (neq[1] <= 0) { goto L604; } if (*istate == 1) { goto L25; } if (neq[1] > (ls0001_._2) .n) { goto L605; } L25: (ls0001_._2) .n = neq[1]; if (*itol < 1 || *itol > 4) { goto L606; } if (*iopt < 0 || *iopt > 1) { goto L607; } if (*jt == 3 || *jt < 1 || *jt > 5) { goto L608; } (lsa001_._1) .jtyp = *jt; if (*jt <= 2) { goto L30; } ml = iwork[1]; mu = iwork[2]; if (ml < 0 || ml >= (ls0001_._2) .n) { goto L609; } if (mu < 0 || mu >= (ls0001_._2) .n) { goto L610; } L30: if (*ng < 0) { goto L630; } if (*istate == 1) { goto L35; } if ((lsr001_._1) .irfnd == 0 && *ng != (lsr001_._1) .ngc) { goto L631; } L35: (lsr001_._1) .ngc = *ng; if (*iopt == 1) { goto L40; } (lsa001_._1) .ixpr = 0; (ls0001_._2) .mxstep = mxstp0; (ls0001_._2) .mxhnil = mxhnl0; (ls0001_._2) .hmxi = 0.; (ls0001_._2) .hmin = 0.; if (*istate != 1) { goto L60; } h0 = 0.; (lsa001_._1) .mxordn = mord[0]; (lsa001_._1) .mxords = mord[1]; goto L60; L40: (lsa001_._1) .ixpr = iwork[5]; if ((lsa001_._1) .ixpr < 0 || (lsa001_._1) .ixpr > 1) { goto L611; } (ls0001_._2) .mxstep = iwork[6]; if ((ls0001_._2) .mxstep < 0) { goto L612; } if ((ls0001_._2) .mxstep == 0) { (ls0001_._2) .mxstep = mxstp0; } (ls0001_._2) .mxhnil = iwork[7]; if ((ls0001_._2) .mxhnil < 0) { goto L613; } if ((ls0001_._2) .mxhnil == 0) { (ls0001_._2) .mxhnil = mxhnl0; } if (*istate != 1) { goto L50; } h0 = rwork[5]; (lsa001_._1) .mxordn = iwork[8]; if ((lsa001_._1) .mxordn < 0) { goto L628; } if ((lsa001_._1) .mxordn == 0) { (lsa001_._1) .mxordn = 100; } (lsa001_._1) .mxordn = (( (lsa001_._1) .mxordn ) <= ( mord[0] ) ? ( (lsa001_._1) .mxordn ) : ( mord[0] )) ; (lsa001_._1) .mxords = iwork[9]; if ((lsa001_._1) .mxords < 0) { goto L629; } if ((lsa001_._1) .mxords == 0) { (lsa001_._1) .mxords = 100; } (lsa001_._1) .mxords = (( (lsa001_._1) .mxords ) <= ( mord[1] ) ? ( (lsa001_._1) .mxords ) : ( mord[1] )) ; if ((*tout - *t) * h0 < 0.) { goto L614; } L50: hmax = rwork[6]; if (hmax < 0.) { goto L615; } (ls0001_._2) .hmxi = 0.; if (hmax > 0.) { (ls0001_._2) .hmxi = 1. / hmax; } (ls0001_._2) .hmin = rwork[7]; if ((ls0001_._2) .hmin < 0.) { goto L616; } L60: if (*istate == 1) { (ls0001_._2) .meth = 1; } if (*istate == 1) { (ls0001_._2) .nyh = (ls0001_._2) .n; } (lsr001_._1) .lg0 = 21; (lsr001_._1) .lg1 = (lsr001_._1) .lg0 + *ng; (lsr001_._1) .lgx = (lsr001_._1) .lg1 + *ng; lyhnew = (lsr001_._1) .lgx + *ng; if (*istate == 1) { (ls0001_._2) .lyh = lyhnew; } if (lyhnew == (ls0001_._2) .lyh) { goto L62; } lenyh = (ls0001_._2) .l * (ls0001_._2) .nyh; if (*lrw < lyhnew - 1 + lenyh) { goto L62; } i1 = 1; if (lyhnew > (ls0001_._2) .lyh) { i1 = -1; } dcopy_(&lenyh, &rwork[(ls0001_._2) .lyh], &i1, &rwork[lyhnew], &i1); (ls0001_._2) .lyh = lyhnew; L62: len1n = lyhnew - 1 + ((lsa001_._1) .mxordn + 1) * (ls0001_._2) .nyh; len1s = lyhnew - 1 + ((lsa001_._1) .mxords + 1) * (ls0001_._2) .nyh; (ls0001_._2) .lwm = len1s + 1; if (*jt <= 2) { lenwm = (ls0001_._2) .n * (ls0001_._2) .n + 2; } if (*jt >= 4) { lenwm = ((ml << 1) + mu + 1) * (ls0001_._2) .n + 2; } len1s += lenwm; len1c = len1n; if ((ls0001_._2) .meth == 2) { len1c = len1s; } len1 = (( len1n ) >= ( len1s ) ? ( len1n ) : ( len1s )) ; len2 = (ls0001_._2) .n * 3; lenrw = len1 + len2; lenrwn = len1n + len2; lenrws = len1s + len2; lenrwc = len1c + len2; iwork[17] = lenrw; (ls0001_._2) .liwm = 1; leniw = (ls0001_._2) .n + 20; leniwc = 20; if ((ls0001_._2) .meth == 2) { leniwc = leniw; } iwork[18] = leniw; if (*istate == 1 && *lrw < lenrwc) { goto L617; } if (*istate == 1 && *liw < leniwc) { goto L618; } if (*istate == 3 && *lrw < lenrwc) { goto L550; } if (*istate == 3 && *liw < leniwc) { goto L555; } (ls0001_._2) .lewt = len1 + 1; (lsa001_._1) .insufr = 0; if (*lrw >= lenrw) { goto L65; } (lsa001_._1) .insufr = 2; (ls0001_._2) .lewt = len1c + 1; xerrwv_("lsodar- warning.. rwork length is sufficient for now, but ", & c__60, &c__103, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 60L); xerrwv_(" may not be later. integration will proceed anyway. ", & c__60, &c__103, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 60L); xerrwv_(" length needed is lenrw = i1, while lrw = i2.", &c__50, & c__103, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 50L); L65: (ls0001_._2) .lsavf = (ls0001_._2) .lewt + (ls0001_._2) .n; (ls0001_._2) .lacor = (ls0001_._2) .lsavf + (ls0001_._2) .n; (lsa001_._1) .insufi = 0; if (*liw >= leniw) { goto L70; } (lsa001_._1) .insufi = 2; xerrwv_("lsodar- warning.. iwork length is sufficient for now, but ", & c__60, &c__104, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 60L); xerrwv_(" may not be later. integration will proceed anyway. ", & c__60, &c__104, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 60L); xerrwv_(" length needed is leniw = i1, while liw = i2.", &c__50, & c__104, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 50L); L70: rtoli = rtol[1]; atoli = atol[1]; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol >= 3) { rtoli = rtol[i__]; } if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } if (rtoli < 0.) { goto L619; } if (atoli < 0.) { goto L620; } } if (*istate == 1) { goto L100; } (ls0001_._2) .jstart = -1; if ((ls0001_._2) .n == (ls0001_._2) .nyh) { goto L200; } i1 = (ls0001_._2) .lyh + (ls0001_._2) .l * (ls0001_._2) .nyh; i2 = (ls0001_._2) .lyh + ((ls0001_._2) .maxord + 1) * (ls0001_._2) .nyh - 1; if (i1 > i2) { goto L200; } i__1 = i2; for (i__ = i1; i__ <= i__1; ++i__) { rwork[i__] = 0.; } goto L200; L100: (ls0001_._2) .uround = dlamch_("p", 1L); (ls0001_._2) .tn = *t; (lsa001_._1) .tsw = *t; (ls0001_._2) .maxord = (lsa001_._1) .mxordn; if (*itask != 4 && *itask != 5) { goto L110; } tcrit = rwork[1]; if ((tcrit - *tout) * (*tout - *t) < 0.) { goto L625; } if (h0 != 0. && (*t + h0 - tcrit) * h0 > 0.) { h0 = tcrit - *t; } L110: (ls0001_._2) .jstart = 0; (ls0001_._2) .nhnil = 0; (ls0001_._2) .nst = 0; (ls0001_._2) .nje = 0; (ls0001_._2) .nslast = 0; (ls0001_._2) .hu = 0.; (ls0001_._2) .nqu = 0; (lsa001_._1) .mused = 0; (ls0001_._2) .miter = 0; (ls0001_._2) .ccmax = .3; (ls0001_._2) .maxcor = 3; (ls0001_._2) .msbp = 20; (ls0001_._2) .mxncf = 10; lf0 = (ls0001_._2) .lyh + (ls0001_._2) .nyh; (*f)(&neq[1], t, &y[1], &rwork[lf0]); if (ierode_ .iero > 0) { return 0; } (ls0001_._2) .nfe = 1; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + (ls0001_._2) .lyh - 1] = y[i__]; } (ls0001_._2) .nq = 1; (ls0001_._2) .h__ = 1.; ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) { goto L621; } rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1]; } if (h0 != 0.) { goto L180; } tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ; w0 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (tdist < (ls0001_._2) .uround * 2. * w0) { goto L622; } tol = rtol[1]; if (*itol <= 2) { goto L140; } i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = tol, d__2 = rtol[i__]; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } L140: if (tol > 0.) { goto L160; } atoli = atol[1]; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } ayi = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (ayi != 0.) { d__1 = tol, d__2 = atoli / ayi; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } } L160: d__1 = tol, d__2 = (ls0001_._2) .uround * 100.; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; tol = (( tol ) <= ( .001 ) ? ( tol ) : ( .001 )) ; sum = vmnorm_(& (ls0001_._2) .n, &rwork[lf0], &rwork[(ls0001_._2) .lewt]); d__1 = sum; sum = 1. / (tol * w0 * w0) + tol * (d__1 * d__1); h0 = 1. / sqrt(sum); h0 = (( h0 ) <= ( tdist ) ? ( h0 ) : ( tdist )) ; d__1 = *tout - *t; h0 = d_sign(&h0, &d__1); L180: rh = (( h0 ) >= 0 ? ( h0 ) : -( h0 )) * (ls0001_._2) .hmxi; if (rh > 1.) { h0 /= rh; } (ls0001_._2) .h__ = h0; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + lf0 - 1] = h0 * rwork[i__ + lf0 - 1]; } (lsr001_._1) .irfnd = 0; (lsr001_._1) .toutc = *tout; if ((lsr001_._1) .ngc == 0) { goto L270; } rchek_(&c__1, g, &neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, & rwork[(lsr001_._1) .lg0], &rwork[(lsr001_._1) .lg1], &rwork[(lsr001_._1) .lgx], & jroot[1], &irt); if (ierode_ .iero > 0) { return 0; } if (irt == 0) { goto L270; } goto L632; L200: (ls0001_._2) .nslast = (ls0001_._2) .nst; irfp = (lsr001_._1) .irfnd; if ((lsr001_._1) .ngc == 0) { goto L205; } if (*itask == 1 || *itask == 4) { (lsr001_._1) .toutc = *tout; } rchek_(&c__2, g, &neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, & rwork[(lsr001_._1) .lg0], &rwork[(lsr001_._1) .lg1], &rwork[(lsr001_._1) .lgx], & jroot[1], &irt); if (ierode_ .iero > 0) { return 0; } if (irt != 1) { goto L205; } (lsr001_._1) .irfnd = 1; *istate = 3; *t = (lsr001_._1) .t0; goto L425; L205: (lsr001_._1) .irfnd = 0; if (irfp == 1 && (lsr001_._1) .tlast != (ls0001_._2) .tn && *itask == 2) { goto L400; } switch ((int)*itask) { case 1: goto L210; case 2: goto L250; case 3: goto L220; case 4: goto L230; case 5: goto L240; } L210: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); if (iflag != 0) { goto L627; } *t = *tout; goto L420; L220: tp = (ls0001_._2) .tn - (ls0001_._2) .hu * ((ls0001_._2) .uround * 100. + 1.); if ((tp - *tout) * (ls0001_._2) .h__ > 0.) { goto L623; } if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } *t = (ls0001_._2) .tn; goto L400; L230: tcrit = rwork[1]; if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) { goto L624; } if ((tcrit - *tout) * (ls0001_._2) .h__ < 0.) { goto L625; } if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L245; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); if (iflag != 0) { goto L627; } *t = *tout; goto L420; L240: tcrit = rwork[1]; if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) { goto L624; } L245: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; if (ihit) { *t = tcrit; } if (irfp == 1 && (lsr001_._1) .tlast != (ls0001_._2) .tn && *itask == 5) { goto L400; } if (ihit) { goto L400; } tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.); if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) { goto L250; } (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.); if (*istate == 2) { (ls0001_._2) .jstart = -2; } L250: if ((ls0001_._2) .meth == (lsa001_._1) .mused) { goto L255; } if ((lsa001_._1) .insufr == 1) { goto L550; } if ((lsa001_._1) .insufi == 1) { goto L555; } L255: if ((ls0001_._2) .nst - (ls0001_._2) .nslast >= (ls0001_._2) .mxstep) { goto L500; } ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) { goto L510; } rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1]; } L270: tolsf = (ls0001_._2) .uround * vmnorm_(& (ls0001_._2) .n, &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); if (tolsf <= .01) { goto L280; } tolsf *= 200.; if ((ls0001_._2) .nst == 0) { goto L626; } goto L520; L280: if ((ls0001_._2) .tn + (ls0001_._2) .h__ != (ls0001_._2) .tn) { goto L290; } ++ (ls0001_._2) .nhnil; if ((ls0001_._2) .nhnil > (ls0001_._2) .mxhnil) { goto L290; } xerrwv_("lsodar- warning..internal t (=r1) and h (=r2) are", &c__50, & c__101, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" such that in the machine, t + h = t on the next step ", & c__60, &c__101, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 59L); xerrwv_(" (h = step size). solver will continue anyway", &c__50, & c__101, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 50L); if ((ls0001_._2) .nhnil < (ls0001_._2) .mxhnil) { goto L290; } xerrwv_("sodar- above warning has been issued i1 times. ", &c__50, & c__102, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L); xerrwv_(" it will not be issued again for this problem", &c__50, & c__102, &c__1, &c__1, & (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, & c_b61, 49L); L290: stoda_(&neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &rwork[ (ls0001_._2) .lyh], &rwork[(ls0001_._2) .lewt], &rwork[(ls0001_._2) .lsavf], & rwork[(ls0001_._2) .lacor], &rwork[(ls0001_._2) .lwm], &iwork[(ls0001_._2) .liwm] , f, jac, prja_, solsy_); if (ierode_ .iero > 0) { return 0; } kgo = 1 - (ls0001_._2) .kflag; switch ((int)kgo) { case 1: goto L300; case 2: goto L530; case 3: goto L540; } L300: (ls0001_._2) .init = 1; if ((ls0001_._2) .meth == (lsa001_._1) .mused) { goto L310; } (lsa001_._1) .tsw = (ls0001_._2) .tn; (ls0001_._2) .maxord = (lsa001_._1) .mxordn; if ((ls0001_._2) .meth == 2) { (ls0001_._2) .maxord = (lsa001_._1) .mxords; } if ((ls0001_._2) .meth == 2) { rwork[(ls0001_._2) .lwm] = sqrt((ls0001_._2) .uround); } (lsa001_._1) .insufr = (( (lsa001_._1) .insufr ) <= ( 1 ) ? ( (lsa001_._1) .insufr ) : ( 1 )) ; (lsa001_._1) .insufi = (( (lsa001_._1) .insufi ) <= ( 1 ) ? ( (lsa001_._1) .insufi ) : ( 1 )) ; (ls0001_._2) .jstart = -1; if ((lsa001_._1) .ixpr == 0) { goto L310; } if ((ls0001_._2) .meth == 2) { xerrwv_("lsodar- a switch to the bdf (stiff) method has occurred " , &c__60, &c__105, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 60L); } if ((ls0001_._2) .meth == 1) { xerrwv_("lsodar- a switch to the adams (nonstiff) method has occurred" , &c__60, &c__106, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 60L); } xerrwv_(" at t = r1, tentative step size h = r2, step nst = i1 ", & c__60, &c__107, &c__1, &c__1, & (ls0001_._2) .nst, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 60L); L310: if ((lsr001_._1) .ngc == 0) { goto L315; } rchek_(&c__3, g, &neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, & rwork[(lsr001_._1) .lg0], &rwork[(lsr001_._1) .lg1], &rwork[(lsr001_._1) .lgx], & jroot[1], &irt); if (ierode_ .iero > 0) { return 0; } if (irt != 1) { goto L315; } (lsr001_._1) .irfnd = 1; *istate = 3; *t = (lsr001_._1) .t0; goto L425; L315: switch ((int)*itask) { case 1: goto L320; case 2: goto L400; case 3: goto L330; case 4: goto L340; case 5: goto L350; } L320: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); *t = *tout; goto L420; L330: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ >= 0.) { goto L400; } goto L250; L340: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L345; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); *t = *tout; goto L420; L345: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; if (ihit) { goto L400; } tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.); if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) { goto L250; } (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.); (ls0001_._2) .jstart = -2; goto L250; L350: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; L400: i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1]; } *t = (ls0001_._2) .tn; if (*itask != 4 && *itask != 5) { goto L420; } if (ihit) { *t = tcrit; } L420: *istate = 2; L425: (ls0001_._2) .illin = 0; rwork[11] = (ls0001_._2) .hu; rwork[12] = (ls0001_._2) .h__; rwork[13] = (ls0001_._2) .tn; rwork[15] = (lsa001_._1) .tsw; iwork[11] = (ls0001_._2) .nst; iwork[12] = (ls0001_._2) .nfe; iwork[13] = (ls0001_._2) .nje; iwork[14] = (ls0001_._2) .nqu; iwork[15] = (ls0001_._2) .nq; iwork[19] = (lsa001_._1) .mused; iwork[20] = (ls0001_._2) .meth; iwork[10] = (lsr001_._1) .nge; (lsr001_._1) .tlast = *t; return 0; L430: ++ (ls0001_._2) .ntrep; if ((ls0001_._2) .ntrep < 5) { return 0; } xerrwv_("lsodar- repeated calls with istate = 1 and tout = t (=r1) ", & c__60, &c__301, &c__1, &c__0, &c__0, &c__0, &c__1, t, &c_b61, 60L) ; goto L800; L500: xerrwv_("lsodar- at current t (=r1), mxstep (=i1) steps", &c__50, & c__201, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 47L); xerrwv_(" taken on this call before reaching tout ", &c__50, & c__201, &c__1, &c__1, & (ls0001_._2) .mxstep, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 50L); *istate = -1; goto L580; L510: ewti = rwork[(ls0001_._2) .lewt + i__ - 1]; xerrwv_("lsodar- at t (=r1), ewt(i1) has become r2 .le. 0.", &c__50, & c__202, &c__1, &c__1, &i__, &c__0, &c__2, & (ls0001_._2) .tn, &ewti, 50L); *istate = -6; goto L580; L520: xerrwv_("lsodar- at t (=r1), too much accuracy requested ", &c__50, & c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L); xerrwv_(" for precision of machine.. see tolsf (=r2)", &c__50, & c__203, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, &tolsf, 49L); rwork[14] = tolsf; *istate = -2; goto L580; L530: xerrwv_("lsodar- at t(=r1) and step size h(=r2), the error", &c__50, & c__204, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" test failed repeatedly or with abs(h) = hmin", &c__50, & c__204, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 50L); *istate = -4; goto L560; L540: xerrwv_("lsodar- at t (=r1) and step size h (=r2), the ", &c__50, & c__205, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L); xerrwv_(" corrector convergence failed repeatedly ", &c__50, & c__205, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L); xerrwv_(" or with abs(h) = hmin ", &c__30, &c__205, &c__1, &c__0, & c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 30L); *istate = -5; goto L560; L550: xerrwv_("lsodar- at current t(=r1), rwork length too small", &c__50, & c__206, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" to proceed. the integration was otherwise successful.", & c__60, &c__206, &c__1, &c__0, &c__0, &c__0, &c__1, & (ls0001_._2) .tn, & c_b61, 60L); *istate = -7; goto L580; L555: xerrwv_("lsodar- at current t(=r1), iwork length too small", &c__50, & c__207, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" to proceed. the integration was otherwise successful.", & c__60, &c__207, &c__1, &c__0, &c__0, &c__0, &c__1, & (ls0001_._2) .tn, & c_b61, 60L); *istate = -7; goto L580; L560: big = 0.; imxer = 1; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { size = (d__1 = rwork[i__ + (ls0001_._2) .lacor - 1] * rwork[i__ + (ls0001_._2) .lewt - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (big >= size) { goto L570; } big = size; imxer = i__; L570: ; } iwork[16] = imxer; L580: i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1]; } *t = (ls0001_._2) .tn; (ls0001_._2) .illin = 0; rwork[11] = (ls0001_._2) .hu; rwork[12] = (ls0001_._2) .h__; rwork[13] = (ls0001_._2) .tn; rwork[15] = (lsa001_._1) .tsw; iwork[11] = (ls0001_._2) .nst; iwork[12] = (ls0001_._2) .nfe; iwork[13] = (ls0001_._2) .nje; iwork[14] = (ls0001_._2) .nqu; iwork[15] = (ls0001_._2) .nq; iwork[19] = (lsa001_._1) .mused; iwork[20] = (ls0001_._2) .meth; iwork[10] = (lsr001_._1) .nge; (lsr001_._1) .tlast = *t; return 0; L601: xerrwv_("lsodar- istate (=i1) illegal ", &c__30, &c__1, &c__1, &c__1, istate, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L602: xerrwv_("lsodar- itask (=i1) illegal ", &c__30, &c__2, &c__1, &c__1, itask, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L603: xerrwv_("lsodar- istate .gt. 1 but lsodar not initialized ", &c__50, & c__3, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); goto L700; L604: xerrwv_("lsodar- neq (=i1) .lt. 1 ", &c__30, &c__4, &c__1, &c__1, & neq[1], &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L605: xerrwv_("lsodar- istate = 3 and neq increased (i1 to i2) ", &c__50, & c__5, &c__1, &c__2, & (ls0001_._2) .n, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L606: xerrwv_("lsodar- itol (=i1) illegal ", &c__30, &c__6, &c__1, &c__1, itol, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L607: xerrwv_("lsodar- iopt (=i1) illegal ", &c__30, &c__7, &c__1, &c__1, iopt, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L608: xerrwv_("lsodar- jt (=i1) illegal ", &c__30, &c__8, &c__1, &c__1, jt, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L609: xerrwv_("lsodar- ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, & c__9, &c__1, &c__2, &ml, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L610: xerrwv_("lsodar- mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, & c__10, &c__1, &c__2, &mu, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L611: xerrwv_("lsodar- ixpr (=i1) illegal ", &c__30, &c__11, &c__1, &c__1, & (lsa001_._1) .ixpr, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L612: xerrwv_("lsodar- mxstep (=i1) .lt. 0 ", &c__30, &c__12, &c__1, &c__1, & (ls0001_._2) .mxstep, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L613: xerrwv_("lsodar- mxhnil (=i1) .lt. 0 ", &c__30, &c__13, &c__1, &c__1, & (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L614: xerrwv_("lsodar- tout (=r1) behind t (=r2) ", &c__40, &c__14, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 40L); xerrwv_(" integration direction is given by h0 (=r1) ", &c__50, & c__14, &c__1, &c__0, &c__0, &c__0, &c__1, &h0, &c_b61, 50L); goto L700; L615: xerrwv_("lsodar- hmax (=r1) .lt. 0.0 ", &c__30, &c__15, &c__1, &c__0, & c__0, &c__0, &c__1, &hmax, &c_b61, 30L); goto L700; L616: xerrwv_("lsodar- hmin (=r1) .lt. 0.0 ", &c__30, &c__16, &c__1, &c__0, & c__0, &c__0, &c__1, & (ls0001_._2) .hmin, &c_b61, 30L); goto L700; L617: xerrwv_("lsodar- rwork length needed, lenrw (=i1), exceeds lrw (=i2)", & c__60, &c__17, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 60L); goto L700; L618: xerrwv_("lsodar- iwork length needed, leniw (=i1), exceeds liw (=i2)", & c__60, &c__18, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 60L); goto L700; L619: xerrwv_("lsodar- rtol(i1) is r1 .lt. 0.0 ", &c__40, &c__19, &c__1, &c__1, &i__, &c__0, &c__1, &rtoli, &c_b61, 40L); goto L700; L620: xerrwv_("lsodar- atol(i1) is r1 .lt. 0.0 ", &c__40, &c__20, &c__1, &c__1, &i__, &c__0, &c__1, &atoli, &c_b61, 40L); goto L700; L621: ewti = rwork[(ls0001_._2) .lewt + i__ - 1]; xerrwv_("lsodar- ewt(i1) is r1 .le. 0.0 ", &c__40, &c__21, &c__1, &c__1, &i__, &c__0, &c__1, &ewti, &c_b61, 40L); goto L700; L622: xerrwv_("lsodar- tout (=r1) too close to t(=r2) to start integration", & c__60, &c__22, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 60L); goto L700; L623: xerrwv_("lsodar- itask = i1 and tout (=r1) behind tcur - hu (= r2) ", & c__60, &c__23, &c__1, &c__1, itask, &c__0, &c__2, tout, &tp, 60L); goto L700; L624: xerrwv_("lsodar- itask = 4 or 5 and tcrit (=r1) behind tcur (=r2) ", & c__60, &c__24, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, & (ls0001_._2) .tn, 60L); goto L700; L625: xerrwv_("lsodar- itask = 4 or 5 and tcrit (=r1) behind tout (=r2) ", & c__60, &c__25, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, tout, 60L); goto L700; L626: xerrwv_("lsodar- at start of problem, too much accuracy ", &c__50, & c__26, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" requested for precision of machine.. see tolsf (=r1) ", & c__60, &c__26, &c__1, &c__0, &c__0, &c__0, &c__1, &tolsf, &c_b61, 60L); rwork[14] = tolsf; goto L700; L627: xerrwv_("lsodar- trouble from intdy. itask = i1, tout = r1", &c__50, & c__27, &c__1, &c__1, itask, &c__0, &c__1, tout, &c_b61, 50L); goto L700; L628: xerrwv_("lsodar- mxordn (=i1) .lt. 0 ", &c__30, &c__28, &c__1, &c__1, & (lsa001_._1) .mxordn, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L629: xerrwv_("lsodar- mxords (=i1) .lt. 0 ", &c__30, &c__29, &c__1, &c__1, & (lsa001_._1) .mxords, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L630: xerrwv_("lsodar- ng (=i1) .lt. 0 ", &c__30, &c__30, &c__1, &c__1, ng, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L631: xerrwv_("lsodar- ng changed (from i1 to i2) illegally, ", &c__50, & c__31, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" i.e. not immediately after a root was found ", &c__50, & c__31, &c__1, &c__2, & (lsr001_._1) .ngc, ng, &c__0, &c_b61, &c_b61, 50L); goto L700; L632: xerrwv_("lsodar- one or more components of g has a root ", &c__50, & c__32, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" too near to the initial point ", &c__40, &c__32, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 40L); L700: if ((ls0001_._2) .illin == 5) { goto L710; } ++ (ls0001_._2) .illin; (lsr001_._1) .tlast = *t; *istate = -3; return 0; L710: xerrwv_("lsodar- repeated occurrences of illegal input ", &c__50, & c__302, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); L800: xerrwv_("lsodar- run aborted.. apparent infinite loop ", &c__50, & c__303, &c__2, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); return 0; } int lsode_(f, neq, y, t, tout, itol, rtol, atol, itask, istate, iopt, rwork, lrw, iwork, liw, jac, mf) int (*f) (); integer *neq; doublereal *y, *t, *tout; integer *itol; doublereal *rtol, *atol; integer *itask, *istate, *iopt; doublereal *rwork; integer *lrw, *iwork, *liw; int (*jac) (); integer *mf; { static integer mord[2] = { 12,5 }; static integer mxstp0 = 500; static integer mxhnl0 = 10; integer i__1, i__2; doublereal d__1, d__2; double sqrt(), d_sign(); static doublereal hmax; static logical ihit; static doublereal ewti, size; static integer i__, iflag; static doublereal atoli; static integer leniw; extern int prepj_(); static integer lenwm; extern int stode_(); static integer imxer; static doublereal tcrit; static integer lenrw; static doublereal h0; static integer i1, i2; static doublereal rtoli, tdist, tolsf; extern doublereal vnorm_(); static doublereal tnext; extern int ewset_(), intdy_(); static doublereal w0; extern int solsy_(); extern doublereal dlamch_(); static integer ml; static doublereal rh; static integer mu; static doublereal tp; static integer lf0; extern int xerrwv_(); static doublereal big; static integer kgo; static doublereal ayi, hmx, tol, sum; --neq; --y; --rtol; --atol; --rwork; --iwork; ierode_ .iero = 0; if (*istate < 1 || *istate > 3) { goto L601; } if (*itask < 1 || *itask > 5) { goto L602; } if (*istate == 1) { goto L10; } if ((ls0001_._2) .init == 0) { goto L603; } if (*istate == 2) { goto L200; } goto L20; L10: (ls0001_._2) .init = 0; if (*tout == *t) { goto L430; } L20: (ls0001_._2) .ntrep = 0; if (neq[1] <= 0) { goto L604; } if (*istate == 1) { goto L25; } if (neq[1] > (ls0001_._2) .n) { goto L605; } L25: (ls0001_._2) .n = neq[1]; if (*itol < 1 || *itol > 4) { goto L606; } if (*iopt < 0 || *iopt > 1) { goto L607; } (ls0001_._2) .meth = *mf / 10; (ls0001_._2) .miter = *mf - (ls0001_._2) .meth * 10; if ((ls0001_._2) .meth < 1 || (ls0001_._2) .meth > 2) { goto L608; } if ((ls0001_._2) .miter < 0 || (ls0001_._2) .miter > 5) { goto L608; } if ((ls0001_._2) .miter <= 3) { goto L30; } ml = iwork[1]; mu = iwork[2]; if (ml < 0 || ml >= (ls0001_._2) .n) { goto L609; } if (mu < 0 || mu >= (ls0001_._2) .n) { goto L610; } L30: if (*iopt == 1) { goto L40; } (ls0001_._2) .maxord = mord[(ls0001_._2) .meth - 1]; (ls0001_._2) .mxstep = mxstp0; (ls0001_._2) .mxhnil = mxhnl0; if (*istate == 1) { h0 = 0.; } (ls0001_._2) .hmxi = 0.; (ls0001_._2) .hmin = 0.; goto L60; L40: (ls0001_._2) .maxord = iwork[5]; if ((ls0001_._2) .maxord < 0) { goto L611; } if ((ls0001_._2) .maxord == 0) { (ls0001_._2) .maxord = 100; } i__1 = (ls0001_._2) .maxord, i__2 = mord[(ls0001_._2) .meth - 1]; (ls0001_._2) .maxord = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; (ls0001_._2) .mxstep = iwork[6]; if ((ls0001_._2) .mxstep < 0) { goto L612; } if ((ls0001_._2) .mxstep == 0) { (ls0001_._2) .mxstep = mxstp0; } (ls0001_._2) .mxhnil = iwork[7]; if ((ls0001_._2) .mxhnil < 0) { goto L613; } if ((ls0001_._2) .mxhnil == 0) { (ls0001_._2) .mxhnil = mxhnl0; } if (*istate != 1) { goto L50; } h0 = rwork[5]; if ((*tout - *t) * h0 < 0.) { goto L614; } L50: hmax = rwork[6]; if (hmax < 0.) { goto L615; } (ls0001_._2) .hmxi = 0.; if (hmax > 0.) { (ls0001_._2) .hmxi = 1. / hmax; } (ls0001_._2) .hmin = rwork[7]; if ((ls0001_._2) .hmin < 0.) { goto L616; } L60: (ls0001_._2) .lyh = 21; if (*istate == 1) { (ls0001_._2) .nyh = (ls0001_._2) .n; } (ls0001_._2) .lwm = (ls0001_._2) .lyh + ((ls0001_._2) .maxord + 1) * (ls0001_._2) .nyh; if ((ls0001_._2) .miter == 0) { lenwm = 0; } if ((ls0001_._2) .miter == 1 || (ls0001_._2) .miter == 2) { lenwm = (ls0001_._2) .n * (ls0001_._2) .n + 2; } if ((ls0001_._2) .miter == 3) { lenwm = (ls0001_._2) .n + 2; } if ((ls0001_._2) .miter >= 4) { lenwm = ((ml << 1) + mu + 1) * (ls0001_._2) .n + 2; } (ls0001_._2) .lewt = (ls0001_._2) .lwm + lenwm; (ls0001_._2) .lsavf = (ls0001_._2) .lewt + (ls0001_._2) .n; (ls0001_._2) .lacor = (ls0001_._2) .lsavf + (ls0001_._2) .n; lenrw = (ls0001_._2) .lacor + (ls0001_._2) .n - 1; iwork[17] = lenrw; (ls0001_._2) .liwm = 1; leniw = (ls0001_._2) .n + 20; if ((ls0001_._2) .miter == 0 || (ls0001_._2) .miter == 3) { leniw = 20; } iwork[18] = leniw; if (lenrw > *lrw) { goto L617; } if (leniw > *liw) { goto L618; } rtoli = rtol[1]; atoli = atol[1]; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol >= 3) { rtoli = rtol[i__]; } if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } if (rtoli < 0.) { goto L619; } if (atoli < 0.) { goto L620; } } if (*istate == 1) { goto L100; } (ls0001_._2) .jstart = -1; if ((ls0001_._2) .nq <= (ls0001_._2) .maxord) { goto L90; } i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + (ls0001_._2) .lsavf - 1] = rwork[i__ + (ls0001_._2) .lwm - 1]; } L90: if ((ls0001_._2) .miter > 0) { rwork[(ls0001_._2) .lwm] = sqrt((ls0001_._2) .uround); } if ((ls0001_._2) .n == (ls0001_._2) .nyh) { goto L200; } i1 = (ls0001_._2) .lyh + (ls0001_._2) .l * (ls0001_._2) .nyh; i2 = (ls0001_._2) .lyh + ((ls0001_._2) .maxord + 1) * (ls0001_._2) .nyh - 1; if (i1 > i2) { goto L200; } i__1 = i2; for (i__ = i1; i__ <= i__1; ++i__) { rwork[i__] = 0.; } goto L200; L100: (ls0001_._2) .uround = dlamch_("p", 1L); (ls0001_._2) .tn = *t; if (*itask != 4 && *itask != 5) { goto L110; } tcrit = rwork[1]; if ((tcrit - *tout) * (*tout - *t) < 0.) { goto L625; } if (h0 != 0. && (*t + h0 - tcrit) * h0 > 0.) { h0 = tcrit - *t; } L110: (ls0001_._2) .jstart = 0; if ((ls0001_._2) .miter > 0) { rwork[(ls0001_._2) .lwm] = sqrt((ls0001_._2) .uround); } (ls0001_._2) .nhnil = 0; (ls0001_._2) .nst = 0; (ls0001_._2) .nje = 0; (ls0001_._2) .nslast = 0; (ls0001_._2) .hu = 0.; (ls0001_._2) .nqu = 0; (ls0001_._2) .ccmax = .3; (ls0001_._2) .maxcor = 3; (ls0001_._2) .msbp = 20; (ls0001_._2) .mxncf = 10; lf0 = (ls0001_._2) .lyh + (ls0001_._2) .nyh; (*f)(&neq[1], t, &y[1], &rwork[lf0]); if (ierode_ .iero > 0) { return 0; } (ls0001_._2) .nfe = 1; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + (ls0001_._2) .lyh - 1] = y[i__]; } (ls0001_._2) .nq = 1; (ls0001_._2) .h__ = 1.; ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) { goto L621; } rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1]; } if (h0 != 0.) { goto L180; } tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ; w0 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (tdist < (ls0001_._2) .uround * 2. * w0) { goto L622; } tol = rtol[1]; if (*itol <= 2) { goto L140; } i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = tol, d__2 = rtol[i__]; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } L140: if (tol > 0.) { goto L160; } atoli = atol[1]; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } ayi = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (ayi != 0.) { d__1 = tol, d__2 = atoli / ayi; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } } L160: d__1 = tol, d__2 = (ls0001_._2) .uround * 100.; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; tol = (( tol ) <= ( .001 ) ? ( tol ) : ( .001 )) ; sum = vnorm_(& (ls0001_._2) .n, &rwork[lf0], &rwork[(ls0001_._2) .lewt]); d__1 = sum; sum = 1. / (tol * w0 * w0) + tol * (d__1 * d__1); h0 = 1. / sqrt(sum); h0 = (( h0 ) <= ( tdist ) ? ( h0 ) : ( tdist )) ; d__1 = *tout - *t; h0 = d_sign(&h0, &d__1); L180: rh = (( h0 ) >= 0 ? ( h0 ) : -( h0 )) * (ls0001_._2) .hmxi; if (rh > 1.) { h0 /= rh; } (ls0001_._2) .h__ = h0; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + lf0 - 1] = h0 * rwork[i__ + lf0 - 1]; } goto L270; L200: (ls0001_._2) .nslast = (ls0001_._2) .nst; switch ((int)*itask) { case 1: goto L210; case 2: goto L250; case 3: goto L220; case 4: goto L230; case 5: goto L240; } L210: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); if (iflag != 0) { goto L627; } *t = *tout; goto L420; L220: tp = (ls0001_._2) .tn - (ls0001_._2) .hu * ((ls0001_._2) .uround * 100. + 1.); if ((tp - *tout) * (ls0001_._2) .h__ > 0.) { goto L623; } if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } goto L400; L230: tcrit = rwork[1]; if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) { goto L624; } if ((tcrit - *tout) * (ls0001_._2) .h__ < 0.) { goto L625; } if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L245; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); if (iflag != 0) { goto L627; } *t = *tout; goto L420; L240: tcrit = rwork[1]; if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) { goto L624; } L245: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; if (ihit) { goto L400; } tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.); if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) { goto L250; } (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.); if (*istate == 2) { (ls0001_._2) .jstart = -2; } L250: if ((ls0001_._2) .nst - (ls0001_._2) .nslast >= (ls0001_._2) .mxstep) { goto L500; } ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) { goto L510; } rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1]; } L270: tolsf = (ls0001_._2) .uround * vnorm_(& (ls0001_._2) .n, &rwork[(ls0001_._2) .lyh], & rwork[(ls0001_._2) .lewt]); if (tolsf <= 1.) { goto L280; } tolsf *= 2.; if ((ls0001_._2) .nst == 0) { goto L626; } goto L520; L280: if ((ls0001_._2) .tn + (ls0001_._2) .h__ != (ls0001_._2) .tn) { goto L290; } ++ (ls0001_._2) .nhnil; if ((ls0001_._2) .nhnil > (ls0001_._2) .mxhnil) { goto L290; } xerrwv_("lsode-- caution... t (=r1) and h (=r2) are", &c__50, &c__101, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 43L); xerrwv_(" such that t + h = t at next step", &c__60, &c__101, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 37L); xerrwv_(" (h = pas). integration continues", &c__50, &c__101, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 39L); if ((ls0001_._2) .nhnil < (ls0001_._2) .mxhnil) { goto L290; } xerrwv_("lsode-- preceding message given i1 times", &c__50, &c__102, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 41L); xerrwv_(" wiil not be repeated", &c__50, &c__102, &c__1, &c__1, & (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 25L); L290: stode_(&neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &rwork[ (ls0001_._2) .lyh], &rwork[(ls0001_._2) .lewt], &rwork[(ls0001_._2) .lsavf], & rwork[(ls0001_._2) .lacor], &rwork[(ls0001_._2) .lwm], &iwork[(ls0001_._2) .liwm] , f, jac, prepj_, solsy_); if (ierode_ .iero > 0) { return 0; } kgo = 1 - (ls0001_._2) .kflag; switch ((int)kgo) { case 1: goto L300; case 2: goto L530; case 3: goto L540; } L300: (ls0001_._2) .init = 1; switch ((int)*itask) { case 1: goto L310; case 2: goto L400; case 3: goto L330; case 4: goto L340; case 5: goto L350; } L310: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L250; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); *t = *tout; goto L420; L330: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ >= 0.) { goto L400; } goto L250; L340: if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) { goto L345; } intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag); *t = *tout; goto L420; L345: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; if (ihit) { goto L400; } tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.); if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) { goto L250; } (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.); (ls0001_._2) .jstart = -2; goto L250; L350: hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn )) + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ; ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. * hmx; L400: i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1]; } *t = (ls0001_._2) .tn; if (*itask != 4 && *itask != 5) { goto L420; } if (ihit) { *t = tcrit; } L420: *istate = 2; (ls0001_._2) .illin = 0; rwork[11] = (ls0001_._2) .hu; rwork[12] = (ls0001_._2) .h__; rwork[13] = (ls0001_._2) .tn; iwork[11] = (ls0001_._2) .nst; iwork[12] = (ls0001_._2) .nfe; iwork[13] = (ls0001_._2) .nje; iwork[14] = (ls0001_._2) .nqu; iwork[15] = (ls0001_._2) .nq; return 0; L430: ++ (ls0001_._2) .ntrep; if ((ls0001_._2) .ntrep < 5) { return 0; } xerrwv_("lsode-- calls with istate = 1 and tout = t (=r1) ", &c__60, & c__301, &c__1, &c__0, &c__0, &c__0, &c__1, t, &c_b61, 51L); goto L800; L500: xerrwv_("lsode-- at t (=r1), mxstep (=i1) steps ", &c__50, &c__201, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 42L); xerrwv_("necessary before reaching tout", &c__50, &c__201, &c__1, &c__1, & (ls0001_._2) .mxstep, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 30L); *istate = -1; goto L580; L510: ewti = rwork[(ls0001_._2) .lewt + i__ - 1]; xerrwv_("lsode-- at t (=r1),ewt(i1) (=r2) is .le.0", &c__50, &c__202, & c__1, &c__1, &i__, &c__0, &c__2, & (ls0001_._2) .tn, &ewti, 42L); *istate = -6; goto L580; L520: xerrwv_("lsode-- a t (=r1), too much precision required", &c__50, & c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 48L); xerrwv_(" w.r.t. machine precision tolsf (=r2) ", &c__50, &c__203, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, &tolsf, 38L); rwork[14] = tolsf; *istate = -2; goto L580; L530: xerrwv_("lsode-- at t(=r1) for step h(=r2), error test", &c__50, &c__204, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 46L); xerrwv_(" failed with abs(h) = hmin", &c__50, &c__204, &c__1, &c__0, & c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 29L); *istate = -4; goto L560; L540: xerrwv_("lsode-- at t (=r1) with step h (=r2), ", &c__50, &c__205, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 39L); xerrwv_(" corrector does not converge ", &c__50, &c__205, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 33L); xerrwv_(" with abs(h) = hmin ", &c__30, &c__205, &c__1, &c__0, & c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 27L); *istate = -5; L560: big = 0.; imxer = 1; i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { size = (d__1 = rwork[i__ + (ls0001_._2) .lacor - 1] * rwork[i__ + (ls0001_._2) .lewt - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (big >= size) { goto L570; } big = size; imxer = i__; L570: ; } iwork[16] = imxer; L580: i__1 = (ls0001_._2) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1]; } *t = (ls0001_._2) .tn; (ls0001_._2) .illin = 0; rwork[11] = (ls0001_._2) .hu; rwork[12] = (ls0001_._2) .h__; rwork[13] = (ls0001_._2) .tn; iwork[11] = (ls0001_._2) .nst; iwork[12] = (ls0001_._2) .nfe; iwork[13] = (ls0001_._2) .nje; iwork[14] = (ls0001_._2) .nqu; iwork[15] = (ls0001_._2) .nq; return 0; L601: xerrwv_("lsode-- istate (=i1) illegal ", &c__30, &c__1, &c__1, &c__1, istate, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L602: xerrwv_("lsode-- itask (=i1) illegal ", &c__30, &c__2, &c__1, &c__1, itask, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L603: xerrwv_("lsode-- istate .gt. 1 ", &c__50, &c__3, &c__1, &c__0, &c__0, & c__0, &c__0, &c_b61, &c_b61, 23L); goto L700; L604: xerrwv_("lsode-- neq (=i1) .lt. 1 ", &c__30, &c__4, &c__1, &c__1, & neq[1], &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L605: xerrwv_("lsode-- istate and neq increased from i1 to i2", &c__50, &c__5, &c__1, &c__2, & (ls0001_._2) .n, &neq[1], &c__0, &c_b61, &c_b61, 48L); goto L700; L606: xerrwv_("lsode-- itol (=i1) illegal ", &c__30, &c__6, &c__1, &c__1, itol, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L607: xerrwv_("lsode-- iopt (=i1) illegal ", &c__30, &c__7, &c__1, &c__1, iopt, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L608: xerrwv_("lsode-- mf (=i1) illegal ", &c__30, &c__8, &c__1, &c__1, mf, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L609: xerrwv_("lsode-- ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, & c__9, &c__1, &c__2, &ml, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L610: xerrwv_("lsode-- mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, & c__10, &c__1, &c__2, &mu, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L611: xerrwv_("lsode-- maxord (=i1) .lt. 0 ", &c__30, &c__11, &c__1, &c__1, & (ls0001_._2) .maxord, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L612: xerrwv_("lsode-- mxstep (=i1) .lt. 0 ", &c__30, &c__12, &c__1, &c__1, & (ls0001_._2) .mxstep, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L613: xerrwv_("lsode-- mxhnil (=i1) .lt. 0 ", &c__30, &c__13, &c__1, &c__1, & (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L614: xerrwv_("lsode-- tout (=r1) .gt. t (=r2) ", &c__40, &c__14, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 40L); xerrwv_(" h0 (=r1) gives integration direction", &c__50, &c__14, & c__1, &c__0, &c__0, &c__0, &c__1, &h0, &c_b61, 42L); goto L700; L615: xerrwv_("lsode-- hmax (=r1) .lt. 0.0 ", &c__30, &c__15, &c__1, &c__0, & c__0, &c__0, &c__1, &hmax, &c_b61, 30L); goto L700; L616: xerrwv_("lsode-- hmin (=r1) .lt. 0.0 ", &c__30, &c__16, &c__1, &c__0, & c__0, &c__0, &c__1, & (ls0001_._2) .hmin, &c_b61, 30L); goto L700; L617: xerrwv_("lsode-- necessary size for rwork (i1) larger than i2", &c__60, & c__17, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 52L); goto L700; L618: xerrwv_("lsode-- necessary size for iwork (i1) larger than liw (i2)", & c__60, &c__18, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 58L); goto L700; L619: xerrwv_("lsode-- rtol(i1) est r1 .lt. 0.0 ", &c__40, &c__19, & c__1, &c__1, &i__, &c__0, &c__1, &rtoli, &c_b61, 41L); goto L700; L620: xerrwv_("lsode-- atol(i1) est r1 .lt. 0.0 ", &c__40, &c__20, & c__1, &c__1, &i__, &c__0, &c__1, &atoli, &c_b61, 41L); goto L700; L621: ewti = rwork[(ls0001_._2) .lewt + i__ - 1]; xerrwv_("lsode-- ewt(i1) (=r1) est .le. 0.0 ", &c__40, &c__21, & c__1, &c__1, &i__, &c__0, &c__1, &ewti, &c_b61, 44L); goto L700; L622: xerrwv_("lsode-- tout (=r1) too close to t(=r2) ", &c__60, &c__22, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 40L); goto L700; L623: xerrwv_("lsode-- itask (=i1) and tout (=r1) .gt. tcur - hu (= r2) ", & c__60, &c__23, &c__1, &c__1, itask, &c__0, &c__2, tout, &tp, 59L); goto L700; L624: xerrwv_("lsode-- itask = 4 or 5 and tcrit (=r1) .gt. tcur (=r2) ", & c__60, &c__24, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, & (ls0001_._2) .tn, 58L); goto L700; L625: xerrwv_("lsode-- itask = 4 or 5 and tcrit (=r1) .gt. tout (=r2)", & c__60, &c__25, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, tout, 57L); goto L700; L626: xerrwv_("lsode-- initial precision required", &c__50, &c__26, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 34L); xerrwv_("too high wrt machine precision tolsf (=r1)", &c__60, &c__26, & c__1, &c__0, &c__0, &c__0, &c__1, &tolsf, &c_b61, 42L); rwork[14] = tolsf; goto L700; L627: xerrwv_("lsode-- problems in intdy. itask=i1,tout=r1", &c__50, &c__27, & c__1, &c__1, itask, &c__0, &c__1, tout, &c_b61, 44L); L700: if ((ls0001_._2) .illin == 5) { goto L710; } ++ (ls0001_._2) .illin; *istate = -3; return 0; L710: xerrwv_("lsode-- incorrect inputs", &c__50, &c__302, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 24L); L800: xerrwv_("lsode-- infinite loop ", &c__50, &c__303, &c__2, &c__0, &c__0, & c__0, &c__0, &c_b61, &c_b61, 22L); return 0; } int lsodi_(res, adda, jac, neq, y, ydoti, t, tout, itol, rtol, atol, itask, istate, iopt, rwork, lrw, iwork, liw, mf) int (*res) (), (*adda) (), (*jac) (); integer *neq; doublereal *y, *ydoti, *t, *tout; integer *itol; doublereal *rtol, *atol; integer *itask, *istate, *iopt; doublereal *rwork; integer *lrw, *iwork, *liw, *mf; { static integer mord[2] = { 12,5 }; static integer mxstp0 = 500; static integer mxhnl0 = 10; integer i__1, i__2; doublereal d__1, d__2; double sqrt(), d_sign(); static doublereal hmax; static logical ihit; static integer ires; static doublereal ewti, size; static integer i__, iflag; extern int ainvg_(); static doublereal atoli; static integer leniw, lenwm; extern int stodi_(); static integer imxer; static doublereal tcrit; static integer i1, i2, lenrw; static doublereal h0, rtoli, tdist, tnext, tolsf; extern doublereal vnorm_(); extern int ewset_(); static doublereal w0; extern int solsy_(); extern int intdy_(); extern doublereal dlamch_(); static integer ml; static doublereal rh; static integer lp, mu; static doublereal tp; extern int prepji_(); extern int xerrwv_(); static doublereal big; static integer ier, kgo; static doublereal ayi, hmx, tol, sum; static integer lyd0; --neq; --y; --ydoti; --rtol; --atol; --rwork; --iwork; ierode_ .iero = 0; if (*istate < 0 || *istate > 3) { goto L601; } if (*itask < 1 || *itask > 5) { goto L602; } if (*istate <= 1) { goto L10; } if ((ls0001_._3) .init == 0) { goto L603; } if (*istate == 2) { goto L200; } goto L20; L10: (ls0001_._3) .init = 0; if (*tout == *t) { goto L430; } L20: (ls0001_._3) .ntrep = 0; if (neq[1] <= 0) { goto L604; } if (*istate <= 1) { goto L25; } if (neq[1] > (ls0001_._3) .n) { goto L605; } L25: (ls0001_._3) .n = neq[1]; if (*itol < 1 || *itol > 4) { goto L606; } if (*iopt < 0 || *iopt > 1) { goto L607; } (ls0001_._3) .meth = *mf / 10; (ls0001_._3) .miter = *mf - (ls0001_._3) .meth * 10; if ((ls0001_._3) .meth < 1 || (ls0001_._3) .meth > 2) { goto L608; } if ((ls0001_._3) .miter <= 0 || (ls0001_._3) .miter > 5) { goto L608; } if ((ls0001_._3) .miter == 3) { goto L608; } if ((ls0001_._3) .miter < 3) { goto L30; } ml = iwork[1]; mu = iwork[2]; if (ml < 0 || ml >= (ls0001_._3) .n) { goto L609; } if (mu < 0 || mu >= (ls0001_._3) .n) { goto L610; } L30: if (*iopt == 1) { goto L40; } (ls0001_._3) .maxord = mord[(ls0001_._3) .meth - 1]; (ls0001_._3) .mxstep = mxstp0; (ls0001_._3) .mxhnil = mxhnl0; if (*istate <= 1) { h0 = 0.; } (ls0001_._3) .hmxi = 0.; (ls0001_._3) .hmin = 0.; goto L60; L40: (ls0001_._3) .maxord = iwork[5]; if ((ls0001_._3) .maxord < 0) { goto L611; } if ((ls0001_._3) .maxord == 0) { (ls0001_._3) .maxord = 100; } i__1 = (ls0001_._3) .maxord, i__2 = mord[(ls0001_._3) .meth - 1]; (ls0001_._3) .maxord = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; (ls0001_._3) .mxstep = iwork[6]; if ((ls0001_._3) .mxstep < 0) { goto L612; } if ((ls0001_._3) .mxstep == 0) { (ls0001_._3) .mxstep = mxstp0; } (ls0001_._3) .mxhnil = iwork[7]; if ((ls0001_._3) .mxhnil < 0) { goto L613; } if ((ls0001_._3) .mxhnil == 0) { (ls0001_._3) .mxhnil = mxhnl0; } if (*istate > 1) { goto L50; } h0 = rwork[5]; if ((*tout - *t) * h0 < 0.) { goto L614; } L50: hmax = rwork[6]; if (hmax < 0.) { goto L615; } (ls0001_._3) .hmxi = 0.; if (hmax > 0.) { (ls0001_._3) .hmxi = 1. / hmax; } (ls0001_._3) .hmin = rwork[7]; if ((ls0001_._3) .hmin < 0.) { goto L616; } L60: (ls0001_._3) .lyh = 21; if (*istate <= 1) { (ls0001_._3) .nyh = (ls0001_._3) .n; } (ls0001_._3) .lwm = (ls0001_._3) .lyh + ((ls0001_._3) .maxord + 1) * (ls0001_._3) .nyh; if ((ls0001_._3) .miter <= 2) { lenwm = (ls0001_._3) .n * (ls0001_._3) .n + 2; } if ((ls0001_._3) .miter >= 4) { lenwm = ((ml << 1) + mu + 1) * (ls0001_._3) .n + 2; } (ls0001_._3) .lewt = (ls0001_._3) .lwm + lenwm; (ls0001_._3) .lsavr = (ls0001_._3) .lewt + (ls0001_._3) .n; (ls0001_._3) .lacor = (ls0001_._3) .lsavr + (ls0001_._3) .n; lenrw = (ls0001_._3) .lacor + (ls0001_._3) .n - 1; iwork[17] = lenrw; (ls0001_._3) .liwm = 1; leniw = (ls0001_._3) .n + 20; iwork[18] = leniw; if (lenrw > *lrw) { goto L617; } if (leniw > *liw) { goto L618; } rtoli = rtol[1]; atoli = atol[1]; i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol >= 3) { rtoli = rtol[i__]; } if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } if (rtoli < 0.) { goto L619; } if (atoli < 0.) { goto L620; } } if (*istate <= 1) { goto L100; } (ls0001_._3) .jstart = -1; if ((ls0001_._3) .nq <= (ls0001_._3) .maxord) { goto L90; } i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { ydoti[i__] = rwork[i__ + (ls0001_._3) .lwm - 1]; } L90: rwork[(ls0001_._3) .lwm] = sqrt((ls0001_._3) .uround); if ((ls0001_._3) .n == (ls0001_._3) .nyh) { goto L200; } i1 = (ls0001_._3) .lyh + (ls0001_._3) .l * (ls0001_._3) .nyh; i2 = (ls0001_._3) .lyh + ((ls0001_._3) .maxord + 1) * (ls0001_._3) .nyh - 1; if (i1 > i2) { goto L200; } i__1 = i2; for (i__ = i1; i__ <= i__1; ++i__) { rwork[i__] = 0.; } goto L200; L100: (ls0001_._3) .uround = dlamch_("p", 1L); (ls0001_._3) .tn = *t; if (*itask != 4 && *itask != 5) { goto L105; } tcrit = rwork[1]; if ((tcrit - *tout) * (*tout - *t) < 0.) { goto L625; } if (h0 != 0. && (*t + h0 - tcrit) * h0 > 0.) { h0 = tcrit - *t; } L105: (ls0001_._3) .jstart = 0; rwork[(ls0001_._3) .lwm] = sqrt((ls0001_._3) .uround); (ls0001_._3) .nhnil = 0; (ls0001_._3) .nst = 0; (ls0001_._3) .nre = 0; (ls0001_._3) .nje = 0; (ls0001_._3) .nslast = 0; (ls0001_._3) .hu = 0.; (ls0001_._3) .nqu = 0; (ls0001_._3) .ccmax = .3; (ls0001_._3) .maxcor = 3; (ls0001_._3) .msbp = 20; (ls0001_._3) .mxncf = 10; lyd0 = (ls0001_._3) .lyh + (ls0001_._3) .nyh; lp = (ls0001_._3) .lwm + 1; if (*istate == 1) { goto L120; } ainvg_(res, adda, &neq[1], t, &y[1], &rwork[lyd0], & (ls0001_._3) .miter, &ml, & mu, &rwork[lp], &iwork[21], &ier); ++ (ls0001_._3) .nre; if (ier < 0) { goto L560; } else if (ier == 0) { goto L110; } else { goto L565; } L110: if (ierode_ .iero > 0) { return 0; } i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + (ls0001_._3) .lyh - 1] = y[i__]; } goto L130; L120: i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + (ls0001_._3) .lyh - 1] = y[i__]; rwork[i__ + lyd0 - 1] = ydoti[i__]; } L130: (ls0001_._3) .nq = 1; (ls0001_._3) .h__ = 1.; ewset_(& (ls0001_._3) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._3) .lyh], & rwork[(ls0001_._3) .lewt]); i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + (ls0001_._3) .lewt - 1] <= 0.) { goto L621; } rwork[i__ + (ls0001_._3) .lewt - 1] = 1. / rwork[i__ + (ls0001_._3) .lewt - 1]; } if (h0 != 0.) { goto L180; } tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ; w0 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if (tdist < (ls0001_._3) .uround * 2. * w0) { goto L622; } tol = rtol[1]; if (*itol <= 2) { goto L145; } i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = tol, d__2 = rtol[i__]; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } L145: if (tol > 0.) { goto L160; } atoli = atol[1]; i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (*itol == 2 || *itol == 4) { atoli = atol[i__]; } ayi = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (ayi != 0.) { d__1 = tol, d__2 = atoli / ayi; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } } L160: d__1 = tol, d__2 = (ls0001_._3) .uround * 100.; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; tol = (( tol ) <= ( .001 ) ? ( tol ) : ( .001 )) ; sum = vnorm_(& (ls0001_._3) .n, &rwork[lyd0], &rwork[(ls0001_._3) .lewt]); d__1 = sum; sum = 1. / (tol * w0 * w0) + tol * (d__1 * d__1); h0 = 1. / sqrt(sum); h0 = (( h0 ) <= ( tdist ) ? ( h0 ) : ( tdist )) ; d__1 = *tout - *t; h0 = d_sign(&h0, &d__1); L180: rh = (( h0 ) >= 0 ? ( h0 ) : -( h0 )) * (ls0001_._3) .hmxi; if (rh > 1.) { h0 /= rh; } (ls0001_._3) .h__ = h0; i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + lyd0 - 1] = h0 * rwork[i__ + lyd0 - 1]; } goto L270; L200: (ls0001_._3) .nslast = (ls0001_._3) .nst; switch ((int)*itask) { case 1: goto L210; case 2: goto L250; case 3: goto L220; case 4: goto L230; case 5: goto L240; } L210: if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) { goto L250; } intdy_(tout, &c__0, &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &y[1], &iflag); if (iflag != 0) { goto L627; } *t = *tout; goto L420; L220: tp = (ls0001_._3) .tn - (ls0001_._3) .hu * ((ls0001_._3) .uround * 100. + 1.); if ((tp - *tout) * (ls0001_._3) .h__ > 0.) { goto L623; } if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) { goto L250; } goto L400; L230: tcrit = rwork[1]; if (((ls0001_._3) .tn - tcrit) * (ls0001_._3) .h__ > 0.) { goto L624; } if ((tcrit - *tout) * (ls0001_._3) .h__ < 0.) { goto L625; } if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) { goto L245; } intdy_(tout, &c__0, &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &y[1], &iflag); if (iflag != 0) { goto L627; } *t = *tout; goto L420; L240: tcrit = rwork[1]; if (((ls0001_._3) .tn - tcrit) * (ls0001_._3) .h__ > 0.) { goto L624; } L245: hmx = (( (ls0001_._3) .tn ) >= 0 ? ( (ls0001_._3) .tn ) : -( (ls0001_._3) .tn )) + (( (ls0001_._3) .h__ ) >= 0 ? ( (ls0001_._3) .h__ ) : -( (ls0001_._3) .h__ )) ; ihit = (d__1 = (ls0001_._3) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._3) .uround * 100. * hmx; if (ihit) { goto L400; } tnext = (ls0001_._3) .tn + (ls0001_._3) .h__ * ((ls0001_._3) .uround * 4. + 1.); if ((tnext - tcrit) * (ls0001_._3) .h__ <= 0.) { goto L250; } (ls0001_._3) .h__ = (tcrit - (ls0001_._3) .tn) * (1. - (ls0001_._3) .uround * 4.); if (*istate == 2) { (ls0001_._3) .jstart = -2; } L250: if ((ls0001_._3) .nst - (ls0001_._3) .nslast >= (ls0001_._3) .mxstep) { goto L500; } ewset_(& (ls0001_._3) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._3) .lyh], & rwork[(ls0001_._3) .lewt]); i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { if (rwork[i__ + (ls0001_._3) .lewt - 1] <= 0.) { goto L510; } rwork[i__ + (ls0001_._3) .lewt - 1] = 1. / rwork[i__ + (ls0001_._3) .lewt - 1]; } L270: tolsf = (ls0001_._3) .uround * vnorm_(& (ls0001_._3) .n, &rwork[(ls0001_._3) .lyh], & rwork[(ls0001_._3) .lewt]); if (tolsf <= 1.) { goto L280; } tolsf *= 2.; if ((ls0001_._3) .nst == 0) { goto L626; } goto L520; L280: if ((ls0001_._3) .tn + (ls0001_._3) .h__ != (ls0001_._3) .tn) { goto L290; } ++ (ls0001_._3) .nhnil; if ((ls0001_._3) .nhnil > (ls0001_._3) .mxhnil) { goto L290; } xerrwv_("lsodi-- attention.. t (=r1) and h (=r2) are", &c__50, &c__101, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 44L); xerrwv_(" such that t + h = t at next step", &c__60, &c__101, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 37L); xerrwv_(" (h = pas). integration continues", &c__50, &c__101, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._3) .tn, & (ls0001_._3) .h__, 38L); if ((ls0001_._3) .nhnil < (ls0001_._3) .mxhnil) { goto L290; } xerrwv_("lsodi-- previous message has been given i1 times", &c__50, & c__102, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L); xerrwv_(" it will not be repeated", &c__50, &c__102, &c__1, &c__1, & (ls0001_._3) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 28L); L290: stodi_(&neq[1], &y[1], &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &rwork[ (ls0001_._3) .lyh], &rwork[(ls0001_._3) .lewt], &ydoti[1], &rwork[ (ls0001_._3) .lsavr], &rwork[(ls0001_._3) .lacor], &rwork[(ls0001_._3) .lwm], & iwork[(ls0001_._3) .liwm], res, adda, jac, prepji_, solsy_); if (ierode_ .iero > 0) { return 0; } kgo = 1 - (ls0001_._3) .kflag; switch ((int)kgo) { case 1: goto L300; case 2: goto L530; case 3: goto L540; case 4: goto L400; case 5: goto L550; } L300: (ls0001_._3) .init = 1; switch ((int)*itask) { case 1: goto L310; case 2: goto L400; case 3: goto L330; case 4: goto L340; case 5: goto L350; } L310: if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) { goto L250; } intdy_(tout, &c__0, &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &y[1], &iflag); *t = *tout; goto L420; L330: if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ >= 0.) { goto L400; } goto L250; L340: if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) { goto L345; } intdy_(tout, &c__0, &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &y[1], &iflag); *t = *tout; goto L420; L345: hmx = (( (ls0001_._3) .tn ) >= 0 ? ( (ls0001_._3) .tn ) : -( (ls0001_._3) .tn )) + (( (ls0001_._3) .h__ ) >= 0 ? ( (ls0001_._3) .h__ ) : -( (ls0001_._3) .h__ )) ; ihit = (d__1 = (ls0001_._3) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._3) .uround * 100. * hmx; if (ihit) { goto L400; } tnext = (ls0001_._3) .tn + (ls0001_._3) .h__ * ((ls0001_._3) .uround * 4. + 1.); if ((tnext - tcrit) * (ls0001_._3) .h__ <= 0.) { goto L250; } (ls0001_._3) .h__ = (tcrit - (ls0001_._3) .tn) * (1. - (ls0001_._3) .uround * 4.); (ls0001_._3) .jstart = -2; goto L250; L350: hmx = (( (ls0001_._3) .tn ) >= 0 ? ( (ls0001_._3) .tn ) : -( (ls0001_._3) .tn )) + (( (ls0001_._3) .h__ ) >= 0 ? ( (ls0001_._3) .h__ ) : -( (ls0001_._3) .h__ )) ; ihit = (d__1 = (ls0001_._3) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._3) .uround * 100. * hmx; L400: i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = rwork[i__ + (ls0001_._3) .lyh - 1]; } *t = (ls0001_._3) .tn; if (*itask != 4 && *itask != 5) { goto L420; } if (ihit) { *t = tcrit; } L420: *istate = 2; if ((ls0001_._3) .kflag == -3) { *istate = 3; } (ls0001_._3) .illin = 0; rwork[11] = (ls0001_._3) .hu; rwork[12] = (ls0001_._3) .h__; rwork[13] = (ls0001_._3) .tn; iwork[11] = (ls0001_._3) .nst; iwork[12] = (ls0001_._3) .nre; iwork[13] = (ls0001_._3) .nje; iwork[14] = (ls0001_._3) .nqu; iwork[15] = (ls0001_._3) .nq; return 0; L430: ++ (ls0001_._3) .ntrep; if ((ls0001_._3) .ntrep < 5) { return 0; } xerrwv_("lsodi-- repeated calls with istate=0 or 1 and tout=t (r1) ", & c__60, &c__301, &c__1, &c__0, &c__0, &c__0, &c__1, t, &c_b61, 60L) ; goto L800; L500: xerrwv_("lsodi-- at t (=r1), mxstep (=i1) steps ", &c__50, &c__201, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 42L); xerrwv_("necessary before reaching tout", &c__50, &c__201, &c__1, &c__1, & (ls0001_._3) .mxstep, &c__0, &c__1, & (ls0001_._3) .tn, &c_b61, 30L); *istate = -1; goto L580; L510: ewti = rwork[(ls0001_._3) .lewt + i__ - 1]; xerrwv_("lsodi-- at t (=r1), ewt(i1) (r2) is .le. 0", &c__50, &c__202, & c__1, &c__1, &i__, &c__0, &c__2, & (ls0001_._3) .tn, &ewti, 43L); *istate = -6; goto L590; L520: xerrwv_("lsodi-- at t (=r1), too much precision required", &c__50, & c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L); xerrwv_(" w.r.t. machine precision tolsf (=r2) ", &c__50, &c__203, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._3) .tn, &tolsf, 39L); rwork[14] = tolsf; *istate = -2; goto L590; L530: xerrwv_("lsodi-- at t(=r1) anf for h(=r2), error", &c__50, &c__204, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 40L); xerrwv_(" test failed with abs(h) = hmin", &c__50, &c__204, &c__1, & c__0, &c__0, &c__0, &c__2, & (ls0001_._3) .tn, & (ls0001_._3) .h__, 36L); *istate = -4; goto L570; L540: xerrwv_("lsodi-- at t (=r1) for step h (=r2), le", &c__50, &c__205, & c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 40L); xerrwv_(" corrector does not converge ", &c__50, &c__205, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 32L); xerrwv_(" with abs(h) = hmin ", &c__30, &c__205, &c__1, &c__0, & c__0, &c__0, &c__2, & (ls0001_._3) .tn, & (ls0001_._3) .h__, 27L); *istate = -5; goto L570; L550: xerrwv_("lsodi-- at t (=r1) repeated error (ires=3) due to ", &c__50, & c__206, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 51L); xerrwv_("routine which evaluates the residue", &c__30, &c__206, &c__1, & c__0, &c__0, &c__0, &c__1, & (ls0001_._3) .tn, &c_b61, 35L); *istate = -7; goto L590; L560: ier = -ier; xerrwv_("lsodi-- initialization failed dy/dt: singular matrix", &c__60, & c__207, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 52L); xerrwv_("dgefa or dgbfa return info=(i1)", &c__50, &c__207, &c__1, &c__1, &ier, &c__0, &c__0, &c_b61, &c_b61, 31L); *istate = -8; return 0; L565: xerrwv_("lsodi-- initialisation failed dy/dt: routine", &c__50, &c__208, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 46L); xerrwv_(" of residue evaluation returns:", &c__50, &c__208, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 36L); xerrwv_(" ires = (i1)", &c__20, &c__208, &c__1, &c__1, &ier, &c__0, &c__0, &c_b61, &c_b61, 18L); *istate = -8; return 0; L570: big = 0.; imxer = 1; i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { size = (d__1 = rwork[i__ + (ls0001_._3) .lacor - 1] * rwork[i__ + (ls0001_._3) .lewt - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (big >= size) { goto L575; } big = size; imxer = i__; L575: ; } iwork[16] = imxer; L580: lyd0 = (ls0001_._3) .lyh + (ls0001_._3) .nyh; i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { rwork[i__ + (ls0001_._3) .lsavr - 1] = rwork[i__ + lyd0 - 1] / (ls0001_._3) .h__; y[i__] = rwork[i__ + (ls0001_._3) .lyh - 1]; } ires = 1; (*res)(&neq[1], & (ls0001_._3) .tn, &y[1], &rwork[(ls0001_._3) .lsavr], &ydoti[1], & ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._3) .nre; if (ires <= 1) { goto L595; } xerrwv_("lsodi-- routine for evaluation od residue returns", &c__50, & c__210, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L); xerrwv_(" ires=i1 ", &c__50, &c__210, &c__1, &c__1, &ires, &c__0, & c__0, &c_b61, &c_b61, 12L); goto L595; L590: i__1 = (ls0001_._3) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = rwork[i__ + (ls0001_._3) .lyh - 1]; } L595: *t = (ls0001_._3) .tn; (ls0001_._3) .illin = 0; rwork[11] = (ls0001_._3) .hu; rwork[12] = (ls0001_._3) .h__; rwork[13] = (ls0001_._3) .tn; iwork[11] = (ls0001_._3) .nst; iwork[12] = (ls0001_._3) .nre; iwork[13] = (ls0001_._3) .nje; iwork[14] = (ls0001_._3) .nqu; iwork[15] = (ls0001_._3) .nq; return 0; L601: xerrwv_("lsodi-- istate (=i1) illegal ", &c__30, &c__1, &c__1, &c__1, istate, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L602: xerrwv_("lsodi-- itask (=i1) illegal ", &c__30, &c__2, &c__1, &c__1, itask, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L603: xerrwv_("lsodi-- istate .gt. 1 ", &c__50, &c__3, &c__1, &c__0, &c__0, & c__0, &c__0, &c_b61, &c_b61, 23L); goto L700; L604: xerrwv_("lsodi-- neq (=i1) .lt. 1 ", &c__30, &c__4, &c__1, &c__1, & neq[1], &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L605: xerrwv_("lsodi-- istate = 3 et neq jumps from i1 to i2", &c__50, &c__5, & c__1, &c__2, & (ls0001_._3) .n, &neq[1], &c__0, &c_b61, &c_b61, 46L); goto L700; L606: xerrwv_("lsodi-- itol (=i1) illegal ", &c__30, &c__6, &c__1, &c__1, itol, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L607: xerrwv_("lsodi-- iopt (=i1) illegal ", &c__30, &c__7, &c__1, &c__1, iopt, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L608: xerrwv_("lsodi-- mf (=i1) illegal ", &c__30, &c__8, &c__1, &c__1, mf, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L609: xerrwv_("lsodi-- ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, & c__9, &c__1, &c__2, &ml, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L610: xerrwv_("lsodi-- mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, & c__10, &c__1, &c__2, &mu, &neq[1], &c__0, &c_b61, &c_b61, 50L); goto L700; L611: xerrwv_("lsodi-- maxord (=i1) .lt. 0 ", &c__30, &c__11, &c__1, &c__1, & (ls0001_._3) .maxord, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L612: xerrwv_("lsodi-- mxstep (=i1) .lt. 0 ", &c__30, &c__12, &c__1, &c__1, & (ls0001_._3) .mxstep, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L613: xerrwv_("lsodi-- mxhnil (=i1) .lt. 0 ", &c__30, &c__13, &c__1, &c__1, & (ls0001_._3) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 30L); goto L700; L614: xerrwv_("lsodi-- tout (=r1) .gt. t (=r2) ", &c__40, &c__14, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 40L); xerrwv_(" h0 (=r1) gives integration direction", &c__50, &c__14, & c__1, &c__0, &c__0, &c__0, &c__1, &h0, &c_b61, 42L); goto L700; L615: xerrwv_("lsodi-- hmax (=r1) .lt. 0.0 ", &c__30, &c__15, &c__1, &c__0, & c__0, &c__0, &c__1, &hmax, &c_b61, 30L); goto L700; L616: xerrwv_("lsodi-- hmin (=r1) .lt. 0.0 ", &c__30, &c__16, &c__1, &c__0, & c__0, &c__0, &c__1, & (ls0001_._3) .hmin, &c_b61, 30L); goto L700; L617: xerrwv_("lsodi-- necessary size for rwork (i1) larger than i2", &c__60, & c__17, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 53L); goto L700; L618: xerrwv_("lsodi-- necessary size for iwork (i1) larger than i2", &c__60, & c__18, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 53L); goto L700; L619: xerrwv_("lsodi-- rtol(i1) is r1 .lt. 0.0 ", &c__40, &c__19, &c__1, &c__1, &i__, &c__0, &c__1, &rtoli, &c_b61, 40L); goto L700; L620: xerrwv_("lsodi-- atol(i1) is r1 .lt. 0.0 ", &c__40, &c__20, &c__1, &c__1, &i__, &c__0, &c__1, &atoli, &c_b61, 40L); goto L700; L621: ewti = rwork[(ls0001_._3) .lewt + i__ - 1]; xerrwv_("lsodi-- ewt(i1) (=r1) is .le. 0.0 ", &c__40, &c__21, & c__1, &c__1, &i__, &c__0, &c__1, &ewti, &c_b61, 44L); goto L700; L622: xerrwv_("lsodi-- tout (=r1) too close to t(=r2) ", &c__60, &c__22, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 40L); goto L700; L623: xerrwv_("lsodi-- itask = i1 and tout (=r1) .gt. tcur - hu (= r2) ", & c__60, &c__23, &c__1, &c__1, itask, &c__0, &c__2, tout, &tp, 58L); goto L700; L624: xerrwv_("lsodi-- itask = 4 or 5 and tcrit (=r1) .gt. tcur (=r2) ", & c__60, &c__24, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, & (ls0001_._3) .tn, 58L); goto L700; L625: xerrwv_("lsodi-- itask = 4 or 5 and tcrit (=r1) .gt. tout (=r2)", & c__60, &c__25, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, tout, 57L); goto L700; L626: xerrwv_("lsodi-- too much accuracy required", &c__50, &c__26, &c__1, & c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 34L); xerrwv_("w.r.t machine precision tolsf (=r1)", &c__60, &c__26, &c__1, & c__0, &c__0, &c__0, &c__1, &tolsf, &c_b61, 35L); rwork[14] = tolsf; goto L700; L627: xerrwv_("lsodi-- problems due to intdy. itask=i1,tout=r1", &c__50, & c__27, &c__1, &c__1, itask, &c__0, &c__1, tout, &c_b61, 48L); L700: if ((ls0001_._3) .illin == 5) { goto L710; } ++ (ls0001_._3) .illin; *istate = -3; return 0; L710: xerrwv_("lsodi-- incorrect inputs", &c__50, &c__302, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 25L); L800: xerrwv_("lsodi-- infinite loop", &c__50, &c__303, &c__2, &c__0, &c__0, & c__0, &c__0, &c_b61, &c_b61, 21L); return 0; } int order_(limit, last, maxerr, ermax, elist, iord, liord, nrmax) integer *limit, *last, *maxerr; doublereal *ermax, *elist; integer *iord, *liord, *nrmax; { integer i__1; static integer ibeg, jbnd, i__, j, k, isucc; static doublereal errmin, errmax; static integer ido; --elist; --iord; if (*last > 2) { goto L20; } iord[1] = 1; iord[2] = 2; goto L180; L20: errmax = elist[*maxerr]; if (*nrmax == 1) { goto L60; } ido = *nrmax - 1; i__1 = ido; for (i__ = 1; i__ <= i__1; ++i__) { isucc = iord[*nrmax - 1]; if (errmax <= elist[isucc]) { goto L60; } iord[*nrmax] = isucc; --(*nrmax); } L60: dqa001_ .jupbnd = *last; if (*last > *limit / 2 + 2) { dqa001_ .jupbnd = *limit + 3 - *last; } errmin = elist[*last]; jbnd = dqa001_ .jupbnd - 1; ibeg = *nrmax + 1; if (ibeg > jbnd) { goto L100; } i__1 = jbnd; for (i__ = ibeg; i__ <= i__1; ++i__) { isucc = iord[i__]; if (errmax >= elist[isucc]) { goto L120; } iord[i__ - 1] = isucc; } L100: iord[jbnd] = *maxerr; iord[dqa001_ .jupbnd] = *last; goto L180; L120: iord[i__ - 1] = *maxerr; k = jbnd; i__1 = jbnd; for (j = i__; j <= i__1; ++j) { isucc = iord[k]; if (errmin < elist[isucc]) { goto L160; } iord[k + 1] = isucc; --k; } iord[i__] = *last; goto L180; L160: iord[k + 1] = *last; L180: *maxerr = iord[*nrmax]; *ermax = elist[*maxerr]; return 0; } int prepj_(neq, y, yh, nyh, ewt, ftem, savf, wm, iwm, f, jac) integer *neq; doublereal *y, *yh; integer *nyh; doublereal *ewt, *ftem, *savf, *wm; integer *iwm; int (*f) (), (*jac) (); { integer yh_dim1, yh_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; static integer lenp; static doublereal srur; extern int dgbfa_(), dgefa_(); static integer i__, j, mband; static doublereal r__; static integer i1, i2, j1; extern doublereal vnorm_(); static doublereal r0, di; static integer ii, jj, meband, ml, mu; static doublereal yi, yj, hl0; static integer ml3; static doublereal fac; static integer mba, ier; static doublereal con, yjj; static integer meb1; --neq; --y; yh_dim1 = *nyh; yh_offset = yh_dim1 + 1; yh -= yh_offset; --ewt; --ftem; --savf; --wm; --iwm; ++ (ls0001_._1) .nje; (ls0001_._1) .ierpj = 0; (ls0001_._1) .jcur = 1; hl0 = (ls0001_._1) .h__ * (ls0001_._1) .el0; switch ((int)(ls0001_._1) .miter) { case 1: goto L100; case 2: goto L200; case 3: goto L300; case 4: goto L400; case 5: goto L500; } L100: lenp = (ls0001_._1) .n * (ls0001_._1) .n; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] = 0.; } (*jac)(&neq[1], & (ls0001_._1) .tn, &y[1], &c__0, &c__0, &wm[3], & (ls0001_._1) .n); if (ierode_ .iero > 0) { return 0; } con = -hl0; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] *= con; } goto L240; L200: fac = vnorm_(& (ls0001_._1) .n, &savf[1], &ewt[1]); r0 = (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ )) * 1e3 * (ls0001_._1) .uround * (doublereal) (ls0001_._1) .n * fac; if (r0 == 0.) { r0 = 1.; } srur = wm[1]; j1 = 2; i__1 = (ls0001_._1) .n; for (j = 1; j <= i__1; ++j) { yj = y[j]; d__1 = srur * (( yj ) >= 0 ? ( yj ) : -( yj )) , d__2 = r0 / ewt[j]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; y[j] += r__; fac = -hl0 / r__; (*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &ftem[1]); if (ierode_ .iero > 0) { return 0; } i__2 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__2; ++i__) { wm[i__ + j1] = (ftem[i__] - savf[i__]) * fac; } y[j] = yj; j1 += (ls0001_._1) .n; } (ls0001_._1) .nfe += (ls0001_._1) .n; L240: j = 3; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { wm[j] += 1.; j += (ls0001_._1) .n + 1; } dgefa_(&wm[3], & (ls0001_._1) .n, & (ls0001_._1) .n, &iwm[21], &ier); if (ier != 0) { (ls0001_._1) .ierpj = 1; } return 0; L300: wm[2] = hl0; r__ = (ls0001_._1) .el0 * .1; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] += r__ * ((ls0001_._1) .h__ * savf[i__] - yh[i__ + (yh_dim1 << 1)]); } (*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &wm[3]); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._1) .nfe; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { r0 = (ls0001_._1) .h__ * savf[i__] - yh[i__ + (yh_dim1 << 1)]; di = r0 * .1 - (ls0001_._1) .h__ * (wm[i__ + 2] - savf[i__]); wm[i__ + 2] = 1.; if ((( r0 ) >= 0 ? ( r0 ) : -( r0 )) < (ls0001_._1) .uround / ewt[i__]) { goto L320; } if ((( di ) >= 0 ? ( di ) : -( di )) == 0.) { goto L330; } wm[i__ + 2] = r0 * .1 / di; L320: ; } return 0; L330: (ls0001_._1) .ierpj = 1; return 0; L400: ml = iwm[1]; mu = iwm[2]; ml3 = 3; mband = ml + mu + 1; meband = mband + ml; lenp = meband * (ls0001_._1) .n; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] = 0.; } (*jac)(&neq[1], & (ls0001_._1) .tn, &y[1], &ml, &mu, &wm[ml3], &meband); if (ierode_ .iero > 0) { return 0; } con = -hl0; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] *= con; } goto L570; L500: ml = iwm[1]; mu = iwm[2]; mband = ml + mu + 1; mba = (( mband ) <= ( (ls0001_._1) .n ) ? ( mband ) : ( (ls0001_._1) .n )) ; meband = mband + ml; meb1 = meband - 1; srur = wm[1]; fac = vnorm_(& (ls0001_._1) .n, &savf[1], &ewt[1]); r0 = (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ )) * 1e3 * (ls0001_._1) .uround * (doublereal) (ls0001_._1) .n * fac; if (r0 == 0.) { r0 = 1.; } i__1 = mba; for (j = 1; j <= i__1; ++j) { i__2 = (ls0001_._1) .n; i__3 = mband; for (i__ = j; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) { yi = y[i__]; d__1 = srur * (( yi ) >= 0 ? ( yi ) : -( yi )) , d__2 = r0 / ewt[i__]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; y[i__] += r__; } (*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &ftem[1]); if (ierode_ .iero > 0) { return 0; } i__3 = (ls0001_._1) .n; i__2 = mband; for (jj = j; i__2 < 0 ? jj >= i__3 : jj <= i__3; jj += i__2) { y[jj] = yh[jj + yh_dim1]; yjj = y[jj]; d__1 = srur * (( yjj ) >= 0 ? ( yjj ) : -( yjj )) , d__2 = r0 / ewt[jj]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; fac = -hl0 / r__; i__4 = jj - mu; i1 = (( i__4 ) >= ( 1 ) ? ( i__4 ) : ( 1 )) ; i__4 = jj + ml; i2 = (( i__4 ) <= ( (ls0001_._1) .n ) ? ( i__4 ) : ( (ls0001_._1) .n )) ; ii = jj * meb1 - ml + 2; i__4 = i2; for (i__ = i1; i__ <= i__4; ++i__) { wm[ii + i__] = (ftem[i__] - savf[i__]) * fac; } } } (ls0001_._1) .nfe += mba; L570: ii = mband + 2; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { wm[ii] += 1.; ii += meband; } dgbfa_(&wm[3], &meband, & (ls0001_._1) .n, &ml, &mu, &iwm[21], &ier); if (ier != 0) { (ls0001_._1) .ierpj = 1; } return 0; } int prepji_(neq, y, yh, nyh, ewt, rtem, savr, s, wm, iwm, res, jac, adda) integer *neq; doublereal *y, *yh; integer *nyh; doublereal *ewt, *rtem, *savr, *s, *wm; integer *iwm; int (*res) (), (*jac) (), (*adda) (); { integer yh_dim1, yh_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; static integer lenp, ires; static doublereal srur; extern int dgbfa_(), dgefa_(); static integer i__, j, mband; static doublereal r__; static integer i1, i2, j1, ii, jj, meband, ml, mu; static doublereal yi, yj, hl0; static integer ml3; static doublereal fac; static integer mba, ier; static doublereal con, yjj; static integer meb1; --neq; --y; yh_dim1 = *nyh; yh_offset = yh_dim1 + 1; yh -= yh_offset; --ewt; --rtem; --savr; --s; --wm; --iwm; ++ (ls0001_._4) .nje; hl0 = (ls0001_._4) .h__ * (ls0001_._4) .el0; (ls0001_._4) .ierpj = 0; (ls0001_._4) .jcur = 1; switch ((int)(ls0001_._4) .miter) { case 1: goto L100; case 2: goto L200; case 3: goto L300; case 4: goto L400; case 5: goto L500; } L100: ires = 1; (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._4) .nre; if (ires > 1) { goto L600; } lenp = (ls0001_._4) .n * (ls0001_._4) .n; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] = 0.; } (*jac)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &c__0, &c__0, &wm[3], & (ls0001_._4) .n); if (ierode_ .iero > 0) { return 0; } con = -hl0; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] *= con; } goto L240; L200: ires = -1; (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._4) .nre; if (ires > 1) { goto L600; } srur = wm[1]; j1 = 2; i__1 = (ls0001_._4) .n; for (j = 1; j <= i__1; ++j) { yj = y[j]; d__1 = srur * (( yj ) >= 0 ? ( yj ) : -( yj )) , d__2 = .01 / ewt[j]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; y[j] += r__; fac = -hl0 / r__; (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &rtem[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._4) .nre; if (ires > 1) { goto L600; } i__2 = (ls0001_._4) .n; for (i__ = 1; i__ <= i__2; ++i__) { wm[i__ + j1] = (rtem[i__] - savr[i__]) * fac; } y[j] = yj; j1 += (ls0001_._4) .n; } ires = 1; (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._4) .nre; if (ires > 1) { goto L600; } L240: (*adda)(&neq[1], & (ls0001_._4) .tn, &y[1], &c__0, &c__0, &wm[3], & (ls0001_._4) .n); if (ierode_ .iero > 0) { return 0; } dgefa_(&wm[3], & (ls0001_._4) .n, & (ls0001_._4) .n, &iwm[21], &ier); if (ier != 0) { (ls0001_._4) .ierpj = 1; } return 0; L300: return 0; L400: ires = 1; (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._4) .nre; if (ires > 1) { goto L600; } ml = iwm[1]; mu = iwm[2]; ml3 = 3; mband = ml + mu + 1; meband = mband + ml; lenp = meband * (ls0001_._4) .n; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] = 0.; } (*jac)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &ml, &mu, &wm[ml3], &meband); if (ierode_ .iero > 0) { return 0; } con = -hl0; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] *= con; } goto L570; L500: ires = -1; (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._4) .nre; if (ires > 1) { goto L600; } ml = iwm[1]; mu = iwm[2]; ml3 = ml + 3; mband = ml + mu + 1; mba = (( mband ) <= ( (ls0001_._4) .n ) ? ( mband ) : ( (ls0001_._4) .n )) ; meband = mband + ml; meb1 = meband - 1; srur = wm[1]; i__1 = mba; for (j = 1; j <= i__1; ++j) { i__2 = (ls0001_._4) .n; i__3 = mband; for (i__ = j; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) { yi = y[i__]; d__1 = srur * (( yi ) >= 0 ? ( yi ) : -( yi )) , d__2 = .01 / ewt[i__]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; y[i__] += r__; } (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &rtem[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._4) .nre; if (ires > 1) { goto L600; } i__3 = (ls0001_._4) .n; i__2 = mband; for (jj = j; i__2 < 0 ? jj >= i__3 : jj <= i__3; jj += i__2) { y[jj] = yh[jj + yh_dim1]; yjj = y[jj]; d__1 = srur * (( yjj ) >= 0 ? ( yjj ) : -( yjj )) , d__2 = .01 / ewt[jj]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; fac = -hl0 / r__; i__4 = jj - mu; i1 = (( i__4 ) >= ( 1 ) ? ( i__4 ) : ( 1 )) ; i__4 = jj + ml; i2 = (( i__4 ) <= ( (ls0001_._4) .n ) ? ( i__4 ) : ( (ls0001_._4) .n )) ; ii = jj * meb1 - ml + 2; i__4 = i2; for (i__ = i1; i__ <= i__4; ++i__) { wm[ii + i__] = (rtem[i__] - savr[i__]) * fac; } } } ires = 1; (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._4) .nre; if (ires > 1) { goto L600; } L570: (*adda)(&neq[1], & (ls0001_._4) .tn, &y[1], &ml, &mu, &wm[ml3], &meband); if (ierode_ .iero > 0) { return 0; } dgbfa_(&wm[3], &meband, & (ls0001_._4) .n, &ml, &mu, &iwm[21], &ier); if (ier != 0) { (ls0001_._4) .ierpj = 1; } return 0; L600: (ls0001_._4) .ierpj = ires; return 0; } int prja_(neq, y, yh, nyh, ewt, ftem, savf, wm, iwm, f, jac) integer *neq; doublereal *y, *yh; integer *nyh; doublereal *ewt, *ftem, *savf, *wm; integer *iwm; int (*f) (), (*jac) (); { integer yh_dim1, yh_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; static integer lenp; static doublereal srur; extern int dgbfa_(), dgefa_(); static integer i__, j, mband; static doublereal r__; extern doublereal bnorm_(), fnorm_(); static integer i1, i2, j1; static doublereal r0; static integer ii, jj, meband, ml, mu; static doublereal yi, yj, hl0; static integer ml3; extern doublereal vmnorm_(); static doublereal fac; static integer mba, ier; static doublereal con, yjj; static integer meb1; --neq; --y; yh_dim1 = *nyh; yh_offset = yh_dim1 + 1; yh -= yh_offset; --ewt; --ftem; --savf; --wm; --iwm; ++ (ls0001_._1) .nje; (ls0001_._1) .ierpj = 0; (ls0001_._1) .jcur = 1; hl0 = (ls0001_._1) .h__ * (ls0001_._1) .el0; switch ((int)(ls0001_._1) .miter) { case 1: goto L100; case 2: goto L200; case 3: goto L300; case 4: goto L400; case 5: goto L500; } L100: lenp = (ls0001_._1) .n * (ls0001_._1) .n; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] = 0.; } (*jac)(&neq[1], & (ls0001_._1) .tn, &y[1], &c__0, &c__0, &wm[3], & (ls0001_._1) .n); if (ierode_ .iero > 0) { return 0; } con = -hl0; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] *= con; } goto L240; L200: fac = vmnorm_(& (ls0001_._1) .n, &savf[1], &ewt[1]); r0 = (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ )) * 1e3 * (ls0001_._1) .uround * (doublereal) (ls0001_._1) .n * fac; if (r0 == 0.) { r0 = 1.; } srur = wm[1]; j1 = 2; i__1 = (ls0001_._1) .n; for (j = 1; j <= i__1; ++j) { yj = y[j]; d__1 = srur * (( yj ) >= 0 ? ( yj ) : -( yj )) , d__2 = r0 / ewt[j]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; y[j] += r__; fac = -hl0 / r__; (*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &ftem[1]); if (ierode_ .iero > 0) { return 0; } i__2 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__2; ++i__) { wm[i__ + j1] = (ftem[i__] - savf[i__]) * fac; } y[j] = yj; j1 += (ls0001_._1) .n; } (ls0001_._1) .nfe += (ls0001_._1) .n; L240: (lsa001_._2) .pdnorm = fnorm_(& (ls0001_._1) .n, &wm[3], &ewt[1]) / (( hl0 ) >= 0 ? ( hl0 ) : -( hl0 )) ; j = 3; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { wm[j] += 1.; j += (ls0001_._1) .n + 1; } dgefa_(&wm[3], & (ls0001_._1) .n, & (ls0001_._1) .n, &iwm[21], &ier); if (ier != 0) { (ls0001_._1) .ierpj = 1; } return 0; L300: return 0; L400: ml = iwm[1]; mu = iwm[2]; ml3 = ml + 3; mband = ml + mu + 1; meband = mband + ml; lenp = meband * (ls0001_._1) .n; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] = 0.; } (*jac)(&neq[1], & (ls0001_._1) .tn, &y[1], &ml, &mu, &wm[ml3], &meband); if (ierode_ .iero > 0) { return 0; } con = -hl0; i__1 = lenp; for (i__ = 1; i__ <= i__1; ++i__) { wm[i__ + 2] *= con; } goto L570; L500: ml = iwm[1]; mu = iwm[2]; mband = ml + mu + 1; mba = (( mband ) <= ( (ls0001_._1) .n ) ? ( mband ) : ( (ls0001_._1) .n )) ; meband = mband + ml; meb1 = meband - 1; srur = wm[1]; fac = vmnorm_(& (ls0001_._1) .n, &savf[1], &ewt[1]); r0 = (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ )) * 1e3 * (ls0001_._1) .uround * (doublereal) (ls0001_._1) .n * fac; if (r0 == 0.) { r0 = 1.; } i__1 = mba; for (j = 1; j <= i__1; ++j) { i__2 = (ls0001_._1) .n; i__3 = mband; for (i__ = j; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) { yi = y[i__]; d__1 = srur * (( yi ) >= 0 ? ( yi ) : -( yi )) , d__2 = r0 / ewt[i__]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; y[i__] += r__; } (*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &ftem[1]); if (ierode_ .iero > 0) { return 0; } i__3 = (ls0001_._1) .n; i__2 = mband; for (jj = j; i__2 < 0 ? jj >= i__3 : jj <= i__3; jj += i__2) { y[jj] = yh[jj + yh_dim1]; yjj = y[jj]; d__1 = srur * (( yjj ) >= 0 ? ( yjj ) : -( yjj )) , d__2 = r0 / ewt[jj]; r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; fac = -hl0 / r__; i__4 = jj - mu; i1 = (( i__4 ) >= ( 1 ) ? ( i__4 ) : ( 1 )) ; i__4 = jj + ml; i2 = (( i__4 ) <= ( (ls0001_._1) .n ) ? ( i__4 ) : ( (ls0001_._1) .n )) ; ii = jj * meb1 - ml + 2; i__4 = i2; for (i__ = i1; i__ <= i__4; ++i__) { wm[ii + i__] = (ftem[i__] - savf[i__]) * fac; } } } (ls0001_._1) .nfe += mba; L570: (lsa001_._2) .pdnorm = bnorm_(& (ls0001_._1) .n, &wm[3], &meband, &ml, &mu, &ewt[1]) / (( hl0 ) >= 0 ? ( hl0 ) : -( hl0 )) ; ii = mband + 2; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { wm[ii] += 1.; ii += meband; } dgbfa_(&wm[3], &meband, & (ls0001_._1) .n, &ml, &mu, &iwm[21], &ier); if (ier != 0) { (ls0001_._1) .ierpj = 1; } return 0; } int quarul_(f, a, b, result, abserr, resabs, resasc) doublereal (*f) (); doublereal *a, *b, *result, *abserr, *resabs, *resasc; { static doublereal xgk[11] = { .9956571630258080807355272807, .9739065285171717200779640121,.9301574913557082260012071801, .8650633666889845107320966884,.7808177265864168970637175783, .6794095682990244062343273651,.5627571346686046833390000993, .4333953941292471907992659432,.2943928627014601981311266031, .1488743389816312108848260011,0. }; static doublereal wgk[11] = { .01169463886737187427806439606, .03255816230796472747881897246,.05475589657435199603138130024, .07503967481091995276704314092,.09312545458369760553506546508, .1093871588022976418992105903,.1234919762620658510779581098, .1347092173114733259280540018,.1427759385770600807970942731, .147739104901338491374841516,.1494455540029169056649364684 }; static doublereal wg[10] = { 0.,.06667134430868813759356880989,0., .1494513491505805931457763397,0.,.2190863625159820439955349342,0., .2692667193099963550912269216,0.,.2955242247147528701738929947 }; doublereal d__1, d__2, d__3; double pow_dd(); static doublereal absc, resg, resk, fsum, fval1, fval2; static integer j; static doublereal hlgth, reskh, uflow, fc; extern doublereal dlamch_(); static doublereal epmach, dhlgth, centre, fv1[10], fv2[10]; epmach = dlamch_("p", 1L); uflow = dlamch_("u", 1L); centre = (*a + *b) * .5; hlgth = (*b - *a) * .5; dhlgth = (( hlgth ) >= 0 ? ( hlgth ) : -( hlgth )) ; resg = 0.; fc = (*f)(¢re); if (ierajf_ .iero != 0) { return 0; } resk = wgk[10] * fc; *resabs = (( resk ) >= 0 ? ( resk ) : -( resk )) ; for (j = 1; j <= 10; ++j) { absc = hlgth * xgk[j - 1]; d__1 = centre - absc; fval1 = (*f)(&d__1); if (ierajf_ .iero != 0) { return 0; } d__1 = centre + absc; fval2 = (*f)(&d__1); if (ierajf_ .iero != 0) { return 0; } fv1[j - 1] = fval1; fv2[j - 1] = fval2; fsum = fval1 + fval2; resg += wg[j - 1] * fsum; resk += wgk[j - 1] * fsum; *resabs += wgk[j - 1] * ((( fval1 ) >= 0 ? ( fval1 ) : -( fval1 )) + (( fval2 ) >= 0 ? ( fval2 ) : -( fval2 )) ); } reskh = resk * .5; *resasc = wgk[10] * (d__1 = fc - reskh, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); for (j = 1; j <= 10; ++j) { *resasc += wgk[j - 1] * ((d__1 = fv1[j - 1] - reskh, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + ( d__2 = fv2[j - 1] - reskh, (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )); } *result = resk * hlgth; *resabs *= dhlgth; *resasc *= dhlgth; *abserr = (d__1 = (resk - resg) * hlgth, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (*resasc != 0. && *abserr != 0.) { d__3 = *abserr * 200. / *resasc; d__1 = 1., d__2 = pow_dd(&d__3, &c_b5310); *abserr = *resasc * (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if (*resabs > uflow / (epmach * 50.)) { d__1 = epmach * *resabs * 50.; *abserr = (( d__1 ) >= ( *abserr ) ? ( d__1 ) : ( *abserr )) ; } return 0; } int rchek_(job, g, neq, y, yh, nyh, g0, g1, gx, jroot, irt) integer *job; int (*g) (); integer *neq; doublereal *y, *yh; integer *nyh; doublereal *g0, *g1, *gx; integer *jroot, *irt; { integer yh_dim1, yh_offset, i__1; doublereal d__1; double d_sign(); static doublereal temp1, temp2; static integer i__, iflag, jflag; static doublereal x, hming; extern int dcopy_(), intdy_(); static doublereal t1; extern int roots_(); static logical zroot; --neq; --y; yh_dim1 = *nyh; yh_offset = yh_dim1 + 1; yh -= yh_offset; --g0; --g1; --gx; --jroot; *irt = 0; i__1 = (lsr001_._2) .ngc; for (i__ = 1; i__ <= i__1; ++i__) { jroot[i__] = 0; } hming = ((( (ls0001_._1) .tn ) >= 0 ? ( (ls0001_._1) .tn ) : -( (ls0001_._1) .tn )) + (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ )) ) * (ls0001_._1) .uround * 100.; switch ((int)*job) { case 1: goto L100; case 2: goto L200; case 3: goto L300; } L100: (lsr001_._2) .t0 = (ls0001_._1) .tn; (*g)(&neq[1], & (lsr001_._2) .t0, &y[1], & (lsr001_._2) .ngc, &g0[1]); if (ierode_ .iero > 0) { return 0; } (lsr001_._2) .nge = 1; zroot = (0) ; i__1 = (lsr001_._2) .ngc; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = g0[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= 0.) { zroot = (1) ; } } if (! zroot) { goto L190; } temp1 = d_sign(&hming, & (ls0001_._1) .h__); (lsr001_._2) .t0 += temp1; temp2 = temp1 / (ls0001_._1) .h__; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] += temp2 * yh[i__ + (yh_dim1 << 1)]; } (*g)(&neq[1], & (lsr001_._2) .t0, &y[1], & (lsr001_._2) .ngc, &g0[1]); if (ierode_ .iero > 0) { return 0; } ++ (lsr001_._2) .nge; zroot = (0) ; i__1 = (lsr001_._2) .ngc; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = g0[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= 0.) { zroot = (1) ; } } if (! zroot) { goto L190; } *irt = -1; return 0; L190: return 0; L200: if ((lsr001_._2) .irfnd == 0) { goto L260; } intdy_(& (lsr001_._2) .t0, &c__0, &yh[yh_offset], nyh, &y[1], &iflag); (*g)(&neq[1], & (lsr001_._2) .t0, &y[1], & (lsr001_._2) .ngc, &g0[1]); if (ierode_ .iero > 0) { return 0; } ++ (lsr001_._2) .nge; zroot = (0) ; i__1 = (lsr001_._2) .ngc; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = g0[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= 0.) { zroot = (1) ; } } if (! zroot) { goto L260; } temp1 = d_sign(&hming, & (ls0001_._1) .h__); (lsr001_._2) .t0 += temp1; if (((lsr001_._2) .t0 - (ls0001_._1) .tn) * (ls0001_._1) .h__ < 0.) { goto L230; } temp2 = temp1 / (ls0001_._1) .h__; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] += temp2 * yh[i__ + (yh_dim1 << 1)]; } goto L240; L230: intdy_(& (lsr001_._2) .t0, &c__0, &yh[yh_offset], nyh, &y[1], &iflag); L240: (*g)(&neq[1], & (lsr001_._2) .t0, &y[1], & (lsr001_._2) .ngc, &g0[1]); if (ierode_ .iero > 0) { return 0; } ++ (lsr001_._2) .nge; zroot = (0) ; i__1 = (lsr001_._2) .ngc; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = g0[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > 0.) { goto L250; } jroot[i__] = 1; zroot = (1) ; L250: ; } if (! zroot) { goto L260; } *irt = 1; return 0; L260: if ((ls0001_._1) .tn == (lsr001_._2) .tlast) { goto L390; } L300: if ((lsr001_._2) .itaskc == 2 || (lsr001_._2) .itaskc == 3 || (lsr001_._2) .itaskc == 5) { goto L310; } if (((lsr001_._2) .toutc - (ls0001_._1) .tn) * (ls0001_._1) .h__ >= 0.) { goto L310; } t1 = (lsr001_._2) .toutc; if ((t1 - (lsr001_._2) .t0) * (ls0001_._1) .h__ <= 0.) { goto L390; } intdy_(&t1, &c__0, &yh[yh_offset], nyh, &y[1], &iflag); goto L330; L310: t1 = (ls0001_._1) .tn; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = yh[i__ + yh_dim1]; } L330: (*g)(&neq[1], &t1, &y[1], & (lsr001_._2) .ngc, &g1[1]); if (ierode_ .iero > 0) { return 0; } ++ (lsr001_._2) .nge; jflag = 0; L350: roots_(& (lsr001_._2) .ngc, &hming, &jflag, & (lsr001_._2) .t0, &t1, &g0[1], &g1[1], & gx[1], &x, &jroot[1]); if (jflag > 1) { goto L360; } intdy_(&x, &c__0, &yh[yh_offset], nyh, &y[1], &iflag); (*g)(&neq[1], &x, &y[1], & (lsr001_._2) .ngc, &gx[1]); if (ierode_ .iero > 0) { return 0; } ++ (lsr001_._2) .nge; goto L350; L360: (lsr001_._2) .t0 = x; dcopy_(& (lsr001_._2) .ngc, &gx[1], &c__1, &g0[1], &c__1); if (jflag == 4) { goto L390; } intdy_(&x, &c__0, &yh[yh_offset], nyh, &y[1], &iflag); *irt = 1; return 0; L390: return 0; } int lsrgk_(f, neq, y, t, tout, itol, rtol, atol, itask, istate, iopt, rwork, lrw, iwork, liw, jac, mf) int (*f) (); integer *neq; doublereal *y, *t, *tout; integer *itol; doublereal *rtol, *atol; integer *itask, *istate, *iopt; doublereal *rwork; integer *lrw, *iwork, *liw; int (*jac) (); integer *mf; { static integer nbad; extern int rkqc_(); extern int odeint_(); static integer nok; --neq; --y; --rtol; --atol; --rwork; --iwork; ierode_ .iero = 0; odeint_(&y[1], &neq[1], t, tout, &atol[1], &c_b5340, &c_b61, &nok, &nbad, f, rkqc_); *t = *tout; if (ierode_ .iero > 0) { *istate = -1; } return 0; } int odeint_(ystart, nvar, x1, x2, eps, h1, hmin, nok, nbad, derivs, rkqc) doublereal *ystart; integer *nvar; doublereal *x1, *x2, *eps, *h1, *hmin; integer *nok, *nbad; int (*derivs) (), (*rkqc) (); { integer i__1; doublereal d__1, d__2; double d_sign(); integer s_wsle(), do_lio(), e_wsle(); static doublereal hdid, dydx[10], xsav; static integer nstp; static doublereal h__; static integer i__; static doublereal x, y[10], yscal[10], hnext; static cilist io___1589 = { 0, 6, 0, 0, 0 }; static cilist io___1590 = { 0, 6, 0, 0, 0 }; --ystart; ierode_ .iero = 0; if ((d__1 = *x2 - *x1, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= 1e-30) { return 0; } x = *x1; d__1 = *x2 - *x1; h__ = d_sign(h1, &d__1); *nok = 0; *nbad = 0; path_ .kount = 0; i__1 = *nvar; for (i__ = 1; i__ <= i__1; ++i__) { y[i__ - 1] = ystart[i__]; } xsav = x - path_ .dxsav * 2.; for (nstp = 1; nstp <= 10000; ++nstp) { (*derivs)(nvar, &x, y, dydx); if (ierode_ .iero > 0) { return 0; } i__1 = *nvar; for (i__ = 1; i__ <= i__1; ++i__) { yscal[i__ - 1] = (d__1 = y[i__ - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = h__ * dydx[i__ - 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1e-30; } if (path_ .kmax > 0) { if ((d__1 = x - xsav, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (( path_ .dxsav ) >= 0 ? ( path_ .dxsav ) : -( path_ .dxsav )) ) { if (path_ .kount < path_ .kmax - 1) { ++ path_ .kount; path_ .xp[path_ .kount - 1] = x; i__1 = *nvar; for (i__ = 1; i__ <= i__1; ++i__) { path_ .yp[i__ + path_ .kount * 10 - 11] = y[i__ - 1]; } xsav = x; } } } if ((x + h__ - *x2) * (x + h__ - *x1) > 0.) { h__ = *x2 - x; } (*rkqc)(y, dydx, nvar, &x, &h__, eps, yscal, &hdid, &hnext, derivs); if (hdid == h__) { ++(*nok); } else { ++(*nbad); } if ((x - *x2) * (*x2 - *x1) >= 0.) { i__1 = *nvar; for (i__ = 1; i__ <= i__1; ++i__) { ystart[i__] = y[i__ - 1]; } if (path_ .kmax != 0) { ++ path_ .kount; path_ .xp[path_ .kount - 1] = x; i__1 = *nvar; for (i__ = 1; i__ <= i__1; ++i__) { path_ .yp[i__ + path_ .kount * 10 - 11] = y[i__ - 1]; } } return 0; } if ((( hnext ) >= 0 ? ( hnext ) : -( hnext )) < *hmin) { s_wsle(&io___1589); do_lio(&c__9, &c__1, "stepsize", 8L); do_lio(&c__5, &c__1, (char *)&hnext, (ftnlen)sizeof(doublereal)); do_lio(&c__9, &c__1, " smaller than minimum.", 22L); e_wsle(); } h__ = hnext; } s_wsle(&io___1590); do_lio(&c__9, &c__1, "Trop d'iterations a faire pour la precision demandee.", 53L); e_wsle(); return 0; } int rk4_(y, dydx, n, x, h__, yout, derivs) doublereal *y, *dydx; integer *n; doublereal *x, *h__, *yout; int (*derivs) (); { integer i__1; doublereal d__1; static integer i__; static doublereal h6, hh, xh, yt[10], dym[10], dyt[10]; --yout; --dydx; --y; ierode_ .iero = 0; hh = *h__ * (float).5; h6 = *h__ / (float)6.; xh = *x + hh; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { yt[i__ - 1] = y[i__] + hh * dydx[i__]; } (*derivs)(n, &xh, yt, dyt); if (ierode_ .iero > 0) { return 0; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { yt[i__ - 1] = y[i__] + hh * dyt[i__ - 1]; } (*derivs)(n, &xh, yt, dym); if (ierode_ .iero > 0) { return 0; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { yt[i__ - 1] = y[i__] + *h__ * dym[i__ - 1]; dym[i__ - 1] = dyt[i__ - 1] + dym[i__ - 1]; } d__1 = *x + *h__; (*derivs)(n, &d__1, yt, dyt); if (ierode_ .iero > 0) { return 0; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { yout[i__] = y[i__] + h6 * (dydx[i__] + dyt[i__ - 1] + dym[i__ - 1] * ( float)2.); } return 0; } int rkqc_(y, dydx, n, x, htry, eps, yscal, hdid, hnext, derivs) doublereal *y, *dydx; integer *n; doublereal *x, *htry, *eps, *yscal, *hdid, *hnext; int (*derivs) (); { integer i__1; doublereal d__1, d__2, d__3; integer s_wsle(), do_lio(), e_wsle(); double pow_dd(); static doublereal xsav, ysav[10], h__; static integer i__; static doublereal dysav[10], pgrow, ytemp[10], hh, errmax, pshrnk; extern int rk4_(); static cilist io___1607 = { 0, 6, 0, 0, 0 }; --yscal; --dydx; --y; ierode_ .iero = 0; pgrow = (float)-.2; pshrnk = (float)-.25; xsav = *x; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ysav[i__ - 1] = y[i__]; dysav[i__ - 1] = dydx[i__]; } h__ = *htry; L1: hh = h__ * (float).5; rk4_(ysav, dysav, n, &xsav, &hh, ytemp, derivs); *x = xsav + hh; (*derivs)(n, x, ytemp, &dydx[1]); if (ierode_ .iero > 0) { return 0; } rk4_(ytemp, &dydx[1], n, x, &hh, &y[1], derivs); *x = xsav + h__; if (*x == xsav) { s_wsle(&io___1607); do_lio(&c__9, &c__1, "stepsize not significant in rkqc.", 33L); e_wsle(); ierode_ .iero = 1; return 0; } rk4_(ysav, dysav, n, &xsav, &h__, ytemp, derivs); errmax = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ytemp[i__ - 1] = y[i__] - ytemp[i__ - 1]; d__2 = errmax, d__3 = (d__1 = ytemp[i__ - 1] / (yscal[i__] * *eps), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); errmax = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } if (errmax > 1.) { h__ = h__ * .9 * pow_dd(&errmax, &pshrnk); goto L1; } else { *hdid = h__; if (errmax > 6e-4) { *hnext = h__ * .9 * pow_dd(&errmax, &pgrow); } else { *hnext = h__ * (float)4.; } } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] += ytemp[i__ - 1] * .0666666667; } return 0; } int roots_(ng, hmin, jflag, x0, x1, g0, g1, gx, x, jroot) integer *ng; doublereal *hmin; integer *jflag; doublereal *x0, *x1, *g0, *g1, *gx, *x; integer *jroot; { static doublereal zero = 0.; integer i__1; doublereal d__1, d__2; double d_sign(); static doublereal tmax; static integer i__; extern int dcopy_(); static doublereal t2; static logical xroot, zroot, sgnchg; static integer imxold, nxlast; --jroot; --gx; --g1; --g0; if (*jflag == 1) { goto L200; } (lsr001_._3) .imax = 0; tmax = zero; zroot = (0) ; i__1 = *ng; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = g1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > zero) { goto L110; } zroot = (1) ; goto L120; L110: if (d_sign(&c_b89, &g0[i__]) == d_sign(&c_b89, &g1[i__])) { goto L120; } t2 = (d__1 = g1[i__] / (g1[i__] - g0[i__]), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (t2 <= tmax) { goto L120; } tmax = t2; (lsr001_._3) .imax = i__; L120: ; } if ((lsr001_._3) .imax > 0) { goto L130; } sgnchg = (0) ; goto L140; L130: sgnchg = (1) ; L140: if (! sgnchg) { goto L400; } xroot = (0) ; nxlast = 0; (lsr001_._3) .last = 1; L150: if (xroot) { goto L300; } if (nxlast == (lsr001_._3) .last) { goto L160; } (lsr001_._3) .alpha = 1.; goto L180; L160: if ((lsr001_._3) .last == 0) { goto L170; } (lsr001_._3) .alpha *= .5; goto L180; L170: (lsr001_._3) .alpha *= 2.; L180: (lsr001_._3) .x2 = *x1 - (*x1 - *x0) * g1[(lsr001_._3) .imax] / (g1[(lsr001_._3) .imax] - (lsr001_._3) .alpha * g0[(lsr001_._3) .imax]); if ((d__1 = (lsr001_._3) .x2 - *x0, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < *hmin && (d__2 = *x1 - *x0, (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) > *hmin * 10.) { (lsr001_._3) .x2 = *x0 + (*x1 - *x0) * .1; } *jflag = 1; *x = (lsr001_._3) .x2; return 0; L200: imxold = (lsr001_._3) .imax; (lsr001_._3) .imax = 0; tmax = zero; zroot = (0) ; i__1 = *ng; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = gx[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > zero) { goto L210; } zroot = (1) ; goto L220; L210: if (d_sign(&c_b89, &g0[i__]) == d_sign(&c_b89, &gx[i__])) { goto L220; } t2 = (d__1 = gx[i__] / (gx[i__] - g0[i__]), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (t2 <= tmax) { goto L220; } tmax = t2; (lsr001_._3) .imax = i__; L220: ; } if ((lsr001_._3) .imax > 0) { goto L230; } sgnchg = (0) ; (lsr001_._3) .imax = imxold; goto L240; L230: sgnchg = (1) ; L240: nxlast = (lsr001_._3) .last; if (! sgnchg) { goto L250; } *x1 = (lsr001_._3) .x2; dcopy_(ng, &gx[1], &c__1, &g1[1], &c__1); (lsr001_._3) .last = 1; xroot = (0) ; goto L270; L250: if (! zroot) { goto L260; } *x1 = (lsr001_._3) .x2; dcopy_(ng, &gx[1], &c__1, &g1[1], &c__1); xroot = (1) ; goto L270; L260: dcopy_(ng, &gx[1], &c__1, &g0[1], &c__1); *x0 = (lsr001_._3) .x2; (lsr001_._3) .last = 0; xroot = (0) ; L270: if ((d__1 = *x1 - *x0, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= *hmin) { xroot = (1) ; } goto L150; L300: *jflag = 2; *x = *x1; dcopy_(ng, &g1[1], &c__1, &gx[1], &c__1); i__1 = *ng; for (i__ = 1; i__ <= i__1; ++i__) { jroot[i__] = 0; if ((d__1 = g1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > zero) { goto L310; } jroot[i__] = 1; goto L320; L310: if (d_sign(&c_b89, &g0[i__]) != d_sign(&c_b89, &g1[i__])) { jroot[i__] = 1; } L320: ; } return 0; L400: if (! zroot) { goto L420; } *x = *x1; dcopy_(ng, &g1[1], &c__1, &gx[1], &c__1); i__1 = *ng; for (i__ = 1; i__ <= i__1; ++i__) { jroot[i__] = 0; if ((d__1 = g1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= zero) { jroot[i__] = 1; } } *jflag = 3; return 0; L420: dcopy_(ng, &g1[1], &c__1, &gx[1], &c__1); *x = *x1; *jflag = 4; return 0; } int rscar1_(rsav, isav) doublereal *rsav, *isav; { static integer lenrls = 219; static integer lenils = 39; static integer lenrla = 22; static integer lenila = 9; static integer lenrlr = 5; static integer lenilr = 9; integer i__1; static integer i__, l; extern int dcopy_(); --isav; --rsav; l = 1; dcopy_(&lenrls, &rsav[l], &c__1, (ls0001_._5) .rls, &c__1); l += lenrls; dcopy_(&lenrla, &rsav[l], &c__1, (lsa001_._3) .rlsa, &c__1); l += lenrla; dcopy_(&lenrlr, &rsav[l], &c__1, (lsr001_._4) .rlsr, &c__1); l = 0; i__1 = lenils; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._5) .ils[i__ - 1] = (integer) isav[l + i__]; } l += lenils; i__1 = lenila; for (i__ = 1; i__ <= i__1; ++i__) { (lsa001_._3) .ilsa[i__ - 1] = (integer) isav[l + i__]; } l += lenila; i__1 = lenilr; for (i__ = 1; i__ <= i__1; ++i__) { (lsr001_._4) .ilsr[i__ - 1] = (integer) isav[l + i__]; } l += lenilr; (eh0001_._1) .ieh[0] = (integer) isav[l + 1]; (eh0001_._1) .ieh[1] = (integer) isav[l + 2]; return 0; } int rscma1_(rsav, isav) doublereal *rsav, *isav; { static integer lenrls = 219; static integer lenils = 39; static integer lenrla = 22; static integer lenila = 9; integer i__1; static integer i__; --isav; --rsav; i__1 = lenrls; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._5) .rls[i__ - 1] = rsav[i__]; } i__1 = lenrla; for (i__ = 1; i__ <= i__1; ++i__) { (lsa001_._3) .rlsa[i__ - 1] = rsav[lenrls + i__]; } i__1 = lenils; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._5) .ils[i__ - 1] = (integer) isav[i__]; } i__1 = lenila; for (i__ = 1; i__ <= i__1; ++i__) { (lsa001_._3) .ilsa[i__ - 1] = (integer) isav[lenils + i__]; } (eh0001_._1) .ieh[0] = (integer) isav[lenils + lenila + 1]; (eh0001_._1) .ieh[1] = (integer) isav[lenils + lenila + 2]; return 0; } int rscom1_(rsav, isav) doublereal *rsav, *isav; { static integer lenrls = 219; static integer lenils = 39; integer i__1; static integer i__; --isav; --rsav; i__1 = lenrls; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._5) .rls[i__ - 1] = rsav[i__]; } i__1 = lenils; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._5) .ils[i__ - 1] = (integer) isav[i__]; } (eh0001_._1) .ieh[0] = (integer) isav[lenils + 1]; (eh0001_._1) .ieh[1] = (integer) isav[lenils + 2]; return 0; } int solsy_(wm, iwm, x, tem) doublereal *wm; integer *iwm; doublereal *x, *tem; { integer i__1; static integer i__; static doublereal r__; extern int dgbsl_(), dgesl_(); static doublereal di; static integer meband, ml, mu; static doublereal hl0, phl0; --tem; --x; --iwm; --wm; (ls0001_._1) .iersl = 0; switch ((int)(ls0001_._1) .miter) { case 1: goto L100; case 2: goto L100; case 3: goto L300; case 4: goto L400; case 5: goto L400; } L100: dgesl_(&wm[3], & (ls0001_._1) .n, & (ls0001_._1) .n, &iwm[21], &x[1], &c__0); return 0; L300: phl0 = wm[2]; hl0 = (ls0001_._1) .h__ * (ls0001_._1) .el0; wm[2] = hl0; if (hl0 == phl0) { goto L330; } r__ = hl0 / phl0; i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { di = 1. - r__ * (1. - 1. / wm[i__ + 2]); if ((( di ) >= 0 ? ( di ) : -( di )) == 0.) { goto L390; } wm[i__ + 2] = 1. / di; } L330: i__1 = (ls0001_._1) .n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = wm[i__ + 2] * x[i__]; } return 0; L390: (ls0001_._1) .iersl = 1; return 0; L400: ml = iwm[1]; mu = iwm[2]; meband = (ml << 1) + mu + 1; dgbsl_(&wm[3], &meband, & (ls0001_._1) .n, &ml, &mu, &iwm[21], &x[1], &c__0); return 0; } int stoda_(neq, y, yh, nyh, yh1, ewt, savf, acor, wm, iwm, f, jac, pjac, slvs) integer *neq; doublereal *y, *yh; integer *nyh; doublereal *yh1, *ewt, *savf, *acor, *wm; integer *iwm; int (*f) (), (*jac) (), (*pjac) (), (*slvs) (); { static doublereal sm1[12] = { .5,.575,.55,.45,.35,.25,.2,.15,.1,.075,.05, .025 }; integer yh_dim1, yh_offset, i__1, i__2; doublereal d__1, d__2, d__3; double pow_dd(); static doublereal dcon, delp; static integer lm1p1, lm2p1; static doublereal exdn, rhdn; static integer iret; static doublereal told, rate, rhsm; static integer newq; static doublereal exsm, rhup, exup, rh1it; static integer i__, j, m; extern int cfode_(); static doublereal r__, alpha; static integer iredo, i1; static doublereal pnorm; static integer jb; static doublereal rh, rm, dm1, dm2; static integer lm1, lm2; extern doublereal vmnorm_(); static doublereal rh1, rh2, del, ddn; static integer ncf; static doublereal pdh, dsm, dup, exm1, exm2; static integer nqm1, nqm2; --neq; --y; yh_dim1 = *nyh; yh_offset = yh_dim1 + 1; yh -= yh_offset; --yh1; --ewt; --savf; --acor; --wm; --iwm; (ls0001_._6) .kflag = 0; told = (ls0001_._6) .tn; ncf = 0; (ls0001_._6) .ierpj = 0; (ls0001_._6) .iersl = 0; (ls0001_._6) .jcur = 0; (ls0001_._6) .icf = 0; if ((ls0001_._6) .jstart > 0) { goto L200; } if ((ls0001_._6) .jstart == -1) { goto L100; } if ((ls0001_._6) .jstart == -2) { goto L160; } (ls0001_._6) .lmax = (ls0001_._6) .maxord + 1; (ls0001_._6) .nq = 1; (ls0001_._6) .l = 2; (ls0001_._6) .ialth = 2; (ls0001_._6) .rmax = 1e4; (ls0001_._6) .rc = 0.; (ls0001_._6) .el0 = 1.; (ls0001_._6) .crate = .7; delp = 0.; (ls0001_._6) .hold = (ls0001_._6) .h__; (ls0001_._6) .nslp = 0; (ls0001_._6) .ipup = (ls0001_._6) .miter; iret = 3; (lsa001_._4) .icount = 20; (lsa001_._4) .irflag = 0; (lsa001_._4) .pdest = 0.; (lsa001_._4) .pdlast = 0.; (lsa001_._4) .ratio = 5.; cfode_(&c__2, (ls0001_._6) .elco, (ls0001_._6) .tesco); for (i__ = 1; i__ <= 5; ++i__) { (lsa001_._4) .cm2[i__ - 1] = (ls0001_._6) .tesco[i__ * 3 - 2] * (ls0001_._6) .elco[ i__ + 1 + i__ * 13 - 14]; } cfode_(&c__1, (ls0001_._6) .elco, (ls0001_._6) .tesco); for (i__ = 1; i__ <= 12; ++i__) { (lsa001_._4) .cm1[i__ - 1] = (ls0001_._6) .tesco[i__ * 3 - 2] * (ls0001_._6) .elco[ i__ + 1 + i__ * 13 - 14]; } goto L150; L100: (ls0001_._6) .ipup = (ls0001_._6) .miter; (ls0001_._6) .lmax = (ls0001_._6) .maxord + 1; if ((ls0001_._6) .ialth == 1) { (ls0001_._6) .ialth = 2; } if ((ls0001_._6) .meth == (lsa001_._4) .mused) { goto L160; } cfode_(& (ls0001_._6) .meth, (ls0001_._6) .elco, (ls0001_._6) .tesco); (ls0001_._6) .ialth = (ls0001_._6) .l; iret = 1; L150: i__1 = (ls0001_._6) .l; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._6) .el[i__ - 1] = (ls0001_._6) .elco[i__ + (ls0001_._6) .nq * 13 - 14]; } (ls0001_._6) .nqnyh = (ls0001_._6) .nq * *nyh; (ls0001_._6) .rc = (ls0001_._6) .rc * (ls0001_._6) .el[0] / (ls0001_._6) .el0; (ls0001_._6) .el0 = (ls0001_._6) .el[0]; (ls0001_._6) .conit = .5 / (doublereal) ((ls0001_._6) .nq + 2); switch ((int)iret) { case 1: goto L160; case 2: goto L170; case 3: goto L200; } L160: if ((ls0001_._6) .h__ == (ls0001_._6) .hold) { goto L200; } rh = (ls0001_._6) .h__ / (ls0001_._6) .hold; (ls0001_._6) .h__ = (ls0001_._6) .hold; iredo = 3; goto L175; L170: d__1 = rh, d__2 = (ls0001_._6) .hmin / (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ; rh = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; L175: rh = (( rh ) <= ( (ls0001_._6) .rmax ) ? ( rh ) : ( (ls0001_._6) .rmax )) ; d__1 = 1., d__2 = (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) * (ls0001_._6) .hmxi * rh; rh /= (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if ((ls0001_._6) .meth == 2) { goto L178; } (lsa001_._4) .irflag = 0; d__1 = (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) * (lsa001_._4) .pdlast; pdh = (( d__1 ) >= ( 1e-6 ) ? ( d__1 ) : ( 1e-6 )) ; if (rh * pdh * 1.00001 < sm1[(ls0001_._6) .nq - 1]) { goto L178; } rh = sm1[(ls0001_._6) .nq - 1] / pdh; (lsa001_._4) .irflag = 1; L178: r__ = 1.; i__1 = (ls0001_._6) .l; for (j = 2; j <= i__1; ++j) { r__ *= rh; i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { yh[i__ + j * yh_dim1] *= r__; } } (ls0001_._6) .h__ *= rh; (ls0001_._6) .rc *= rh; (ls0001_._6) .ialth = (ls0001_._6) .l; if (iredo == 0) { goto L690; } L200: if ((d__1 = (ls0001_._6) .rc - 1., (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (ls0001_._6) .ccmax) { (ls0001_._6) .ipup = (ls0001_._6) .miter; } if ((ls0001_._6) .nst >= (ls0001_._6) .nslp + (ls0001_._6) .msbp) { (ls0001_._6) .ipup = (ls0001_._6) .miter; } (ls0001_._6) .tn += (ls0001_._6) .h__; i1 = (ls0001_._6) .nqnyh + 1; i__2 = (ls0001_._6) .nq; for (jb = 1; jb <= i__2; ++jb) { i1 -= *nyh; i__1 = (ls0001_._6) .nqnyh; for (i__ = i1; i__ <= i__1; ++i__) { yh1[i__] += yh1[i__ + *nyh]; } } pnorm = vmnorm_(& (ls0001_._6) .n, &yh1[1], &ewt[1]); L220: m = 0; rate = 0.; del = 0.; i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] = yh[i__ + yh_dim1]; } (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._6) .nfe; if ((ls0001_._6) .ipup <= 0) { goto L250; } (ls0001_._6) .ipup = 0; (ls0001_._6) .rc = 1.; (ls0001_._6) .nslp = (ls0001_._6) .nst; (ls0001_._6) .crate = .7; (*pjac)(&neq[1], &y[1], &yh[yh_offset], nyh, &ewt[1], &acor[1], &savf[1], &wm[1], &iwm[1], f, jac); if (ierode_ .iero > 0) { return 0; } if ((ls0001_._6) .ierpj != 0) { goto L430; } L250: i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { acor[i__] = 0.; } L270: if ((ls0001_._6) .miter != 0) { goto L350; } i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { savf[i__] = (ls0001_._6) .h__ * savf[i__] - yh[i__ + (yh_dim1 << 1)]; y[i__] = savf[i__] - acor[i__]; } del = vmnorm_(& (ls0001_._6) .n, &y[1], &ewt[1]); i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] = yh[i__ + yh_dim1] + (ls0001_._6) .el[0] * savf[i__]; acor[i__] = savf[i__]; } goto L400; L350: i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] = (ls0001_._6) .h__ * savf[i__] - (yh[i__ + (yh_dim1 << 1)] + acor[ i__]); } (*slvs)(&wm[1], &iwm[1], &y[1], &savf[1]); if ((ls0001_._6) .iersl < 0) { goto L430; } if ((ls0001_._6) .iersl > 0) { goto L410; } del = vmnorm_(& (ls0001_._6) .n, &y[1], &ewt[1]); i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { acor[i__] += y[i__]; y[i__] = yh[i__ + yh_dim1] + (ls0001_._6) .el[0] * acor[i__]; } L400: if (del <= pnorm * 100. * (ls0001_._6) .uround) { goto L450; } if (m == 0 && (ls0001_._6) .meth == 1) { goto L405; } if (m == 0) { goto L402; } rm = 1024.; if (del <= delp * 1024.) { rm = del / delp; } rate = (( rate ) >= ( rm ) ? ( rate ) : ( rm )) ; d__1 = (ls0001_._6) .crate * .2; (ls0001_._6) .crate = (( d__1 ) >= ( rm ) ? ( d__1 ) : ( rm )) ; L402: d__1 = 1., d__2 = (ls0001_._6) .crate * 1.5; dcon = del * (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) / ((ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 2] * (ls0001_._6) .conit); if (dcon > 1.) { goto L405; } d__2 = (lsa001_._4) .pdest, d__3 = rate / (d__1 = (ls0001_._6) .h__ * (ls0001_._6) .el[0] , (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); (lsa001_._4) .pdest = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; if ((lsa001_._4) .pdest != 0.) { (lsa001_._4) .pdlast = (lsa001_._4) .pdest; } goto L450; L405: ++m; if (m == (ls0001_._6) .maxcor) { goto L410; } if (m >= 2 && del > delp * 2.) { goto L410; } delp = del; (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._6) .nfe; goto L270; L410: if ((ls0001_._6) .miter == 0 || (ls0001_._6) .jcur == 1) { goto L430; } (ls0001_._6) .icf = 1; (ls0001_._6) .ipup = (ls0001_._6) .miter; goto L220; L430: (ls0001_._6) .icf = 2; ++ncf; (ls0001_._6) .rmax = 2.; (ls0001_._6) .tn = told; i1 = (ls0001_._6) .nqnyh + 1; i__2 = (ls0001_._6) .nq; for (jb = 1; jb <= i__2; ++jb) { i1 -= *nyh; i__1 = (ls0001_._6) .nqnyh; for (i__ = i1; i__ <= i__1; ++i__) { yh1[i__] -= yh1[i__ + *nyh]; } } if ((ls0001_._6) .ierpj < 0 || (ls0001_._6) .iersl < 0) { goto L680; } if ((( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) <= (ls0001_._6) .hmin * 1.00001) { goto L670; } if (ncf == (ls0001_._6) .mxncf) { goto L670; } rh = .25; (ls0001_._6) .ipup = (ls0001_._6) .miter; iredo = 1; goto L170; L450: (ls0001_._6) .jcur = 0; if (m == 0) { dsm = del / (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 2]; } if (m > 0) { dsm = vmnorm_(& (ls0001_._6) .n, &acor[1], &ewt[1]) / (ls0001_._6) .tesco[ (ls0001_._6) .nq * 3 - 2]; } if (dsm > 1.) { goto L500; } (ls0001_._6) .kflag = 0; iredo = 0; ++ (ls0001_._6) .nst; (ls0001_._6) .hu = (ls0001_._6) .h__; (ls0001_._6) .nqu = (ls0001_._6) .nq; (lsa001_._4) .mused = (ls0001_._6) .meth; i__2 = (ls0001_._6) .l; for (j = 1; j <= i__2; ++j) { i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + j * yh_dim1] += (ls0001_._6) .el[j - 1] * acor[i__]; } } -- (lsa001_._4) .icount; if ((lsa001_._4) .icount >= 0) { goto L488; } if ((ls0001_._6) .meth == 2) { goto L480; } if ((ls0001_._6) .nq > 5) { goto L488; } if (dsm > pnorm * 100. * (ls0001_._6) .uround && (lsa001_._4) .pdest != 0.) { goto L470; } if ((lsa001_._4) .irflag == 0) { goto L488; } rh2 = 2.; nqm2 = (( (ls0001_._6) .nq ) <= ( (lsa001_._4) .mxords ) ? ( (ls0001_._6) .nq ) : ( (lsa001_._4) .mxords )) ; goto L478; L470: exsm = 1. / (doublereal) (ls0001_._6) .l; rh1 = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6); rh1it = rh1 * 2.; pdh = (lsa001_._4) .pdlast * (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ; if (pdh * rh1 > 1e-5) { rh1it = sm1[(ls0001_._6) .nq - 1] / pdh; } rh1 = (( rh1 ) <= ( rh1it ) ? ( rh1 ) : ( rh1it )) ; if ((ls0001_._6) .nq <= (lsa001_._4) .mxords) { goto L474; } nqm2 = (lsa001_._4) .mxords; lm2 = (lsa001_._4) .mxords + 1; exm2 = 1. / (doublereal) lm2; lm2p1 = lm2 + 1; dm2 = vmnorm_(& (ls0001_._6) .n, &yh[lm2p1 * yh_dim1 + 1], &ewt[1]) / (lsa001_._4) .cm2[(lsa001_._4) .mxords - 1]; rh2 = 1. / (pow_dd(&dm2, &exm2) * 1.2 + 1.2e-6); goto L476; L474: dm2 = dsm * ((lsa001_._4) .cm1[(ls0001_._6) .nq - 1] / (lsa001_._4) .cm2[(ls0001_._6) .nq - 1] ); rh2 = 1. / (pow_dd(&dm2, &exsm) * 1.2 + 1.2e-6); nqm2 = (ls0001_._6) .nq; L476: if (rh2 < (lsa001_._4) .ratio * rh1) { goto L488; } L478: rh = rh2; (lsa001_._4) .icount = 20; (ls0001_._6) .meth = 2; (ls0001_._6) .miter = (lsa001_._4) .jtyp; (lsa001_._4) .pdlast = 0.; (ls0001_._6) .nq = nqm2; (ls0001_._6) .l = (ls0001_._6) .nq + 1; goto L170; L480: exsm = 1. / (doublereal) (ls0001_._6) .l; if ((lsa001_._4) .mxordn >= (ls0001_._6) .nq) { goto L484; } nqm1 = (lsa001_._4) .mxordn; lm1 = (lsa001_._4) .mxordn + 1; exm1 = 1. / (doublereal) lm1; lm1p1 = lm1 + 1; dm1 = vmnorm_(& (ls0001_._6) .n, &yh[lm1p1 * yh_dim1 + 1], &ewt[1]) / (lsa001_._4) .cm1[(lsa001_._4) .mxordn - 1]; rh1 = 1. / (pow_dd(&dm1, &exm1) * 1.2 + 1.2e-6); goto L486; L484: dm1 = dsm * ((lsa001_._4) .cm2[(ls0001_._6) .nq - 1] / (lsa001_._4) .cm1[(ls0001_._6) .nq - 1] ); rh1 = 1. / (pow_dd(&dm1, &exsm) * 1.2 + 1.2e-6); nqm1 = (ls0001_._6) .nq; exm1 = exsm; L486: rh1it = rh1 * 2.; pdh = (lsa001_._4) .pdnorm * (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ; if (pdh * rh1 > 1e-5) { rh1it = sm1[nqm1 - 1] / pdh; } rh1 = (( rh1 ) <= ( rh1it ) ? ( rh1 ) : ( rh1it )) ; rh2 = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6); if (rh1 * (lsa001_._4) .ratio < rh2 * 5.) { goto L488; } alpha = (( .001 ) >= ( rh1 ) ? ( .001 ) : ( rh1 )) ; dm1 = pow_dd(&alpha, &exm1) * dm1; if (dm1 <= (ls0001_._6) .uround * 1e3 * pnorm) { goto L488; } rh = rh1; (lsa001_._4) .icount = 20; (ls0001_._6) .meth = 1; (ls0001_._6) .miter = 0; (lsa001_._4) .pdlast = 0.; (ls0001_._6) .nq = nqm1; (ls0001_._6) .l = (ls0001_._6) .nq + 1; goto L170; L488: -- (ls0001_._6) .ialth; if ((ls0001_._6) .ialth == 0) { goto L520; } if ((ls0001_._6) .ialth > 1) { goto L700; } if ((ls0001_._6) .l == (ls0001_._6) .lmax) { goto L700; } i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + (ls0001_._6) .lmax * yh_dim1] = acor[i__]; } goto L700; L500: -- (ls0001_._6) .kflag; (ls0001_._6) .tn = told; i1 = (ls0001_._6) .nqnyh + 1; i__1 = (ls0001_._6) .nq; for (jb = 1; jb <= i__1; ++jb) { i1 -= *nyh; i__2 = (ls0001_._6) .nqnyh; for (i__ = i1; i__ <= i__2; ++i__) { yh1[i__] -= yh1[i__ + *nyh]; } } (ls0001_._6) .rmax = 2.; if ((( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) <= (ls0001_._6) .hmin * 1.00001) { goto L660; } if ((ls0001_._6) .kflag <= -3) { goto L640; } iredo = 2; rhup = 0.; goto L540; L520: rhup = 0.; if ((ls0001_._6) .l == (ls0001_._6) .lmax) { goto L540; } i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { savf[i__] = acor[i__] - yh[i__ + (ls0001_._6) .lmax * yh_dim1]; } dup = vmnorm_(& (ls0001_._6) .n, &savf[1], &ewt[1]) / (ls0001_._6) .tesco[ (ls0001_._6) .nq * 3 - 1]; exup = 1. / (doublereal) ((ls0001_._6) .l + 1); rhup = 1. / (pow_dd(&dup, &exup) * 1.4 + 1.4e-6); L540: exsm = 1. / (doublereal) (ls0001_._6) .l; rhsm = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6); rhdn = 0.; if ((ls0001_._6) .nq == 1) { goto L550; } ddn = vmnorm_(& (ls0001_._6) .n, &yh[(ls0001_._6) .l * yh_dim1 + 1], &ewt[1]) / (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 3]; exdn = 1. / (doublereal) (ls0001_._6) .nq; rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6); L550: if ((ls0001_._6) .meth == 2) { goto L560; } d__1 = (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) * (lsa001_._4) .pdlast; pdh = (( d__1 ) >= ( 1e-6 ) ? ( d__1 ) : ( 1e-6 )) ; if ((ls0001_._6) .l < (ls0001_._6) .lmax) { d__1 = rhup, d__2 = sm1[(ls0001_._6) .l - 1] / pdh; rhup = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } d__1 = rhsm, d__2 = sm1[(ls0001_._6) .nq - 1] / pdh; rhsm = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; if ((ls0001_._6) .nq > 1) { d__1 = rhdn, d__2 = sm1[(ls0001_._6) .nq - 2] / pdh; rhdn = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } (lsa001_._4) .pdest = 0.; L560: if (rhsm >= rhup) { goto L570; } if (rhup > rhdn) { goto L590; } goto L580; L570: if (rhsm < rhdn) { goto L580; } newq = (ls0001_._6) .nq; rh = rhsm; goto L620; L580: newq = (ls0001_._6) .nq - 1; rh = rhdn; if ((ls0001_._6) .kflag < 0 && rh > 1.) { rh = 1.; } goto L620; L590: newq = (ls0001_._6) .l; rh = rhup; if (rh < 1.1) { goto L610; } r__ = (ls0001_._6) .el[(ls0001_._6) .l - 1] / (doublereal) (ls0001_._6) .l; i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + (newq + 1) * yh_dim1] = acor[i__] * r__; } goto L630; L610: (ls0001_._6) .ialth = 3; goto L700; L620: if ((ls0001_._6) .meth == 2) { goto L622; } if (rh * pdh * 1.00001 >= sm1[newq - 1]) { goto L625; } L622: if ((ls0001_._6) .kflag == 0 && rh < 1.1) { goto L610; } L625: if ((ls0001_._6) .kflag <= -2) { rh = (( rh ) <= ( .2 ) ? ( rh ) : ( .2 )) ; } if (newq == (ls0001_._6) .nq) { goto L170; } L630: (ls0001_._6) .nq = newq; (ls0001_._6) .l = (ls0001_._6) .nq + 1; iret = 2; goto L150; L640: if ((ls0001_._6) .kflag == -10) { goto L660; } rh = .1; d__1 = (ls0001_._6) .hmin / (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ; rh = (( d__1 ) >= ( rh ) ? ( d__1 ) : ( rh )) ; (ls0001_._6) .h__ *= rh; i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = yh[i__ + yh_dim1]; } (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._6) .nfe; i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + (yh_dim1 << 1)] = (ls0001_._6) .h__ * savf[i__]; } (ls0001_._6) .ipup = (ls0001_._6) .miter; (ls0001_._6) .ialth = 5; if ((ls0001_._6) .nq == 1) { goto L200; } (ls0001_._6) .nq = 1; (ls0001_._6) .l = 2; iret = 3; goto L150; L660: (ls0001_._6) .kflag = -1; goto L720; L670: (ls0001_._6) .kflag = -2; goto L720; L680: (ls0001_._6) .kflag = -3; goto L720; L690: (ls0001_._6) .rmax = 10.; L700: r__ = 1. / (ls0001_._6) .tesco[(ls0001_._6) .nqu * 3 - 2]; i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { acor[i__] *= r__; } L720: (ls0001_._6) .hold = (ls0001_._6) .h__; (ls0001_._6) .jstart = 1; return 0; } int stode_(neq, y, yh, nyh, yh1, ewt, savf, acor, wm, iwm, f, jac, pjac, slvs) integer *neq; doublereal *y, *yh; integer *nyh; doublereal *yh1, *ewt, *savf, *acor, *wm; integer *iwm; int (*f) (), (*jac) (), (*pjac) (), (*slvs) (); { integer yh_dim1, yh_offset, i__1, i__2; doublereal d__1, d__2, d__3; double pow_dd(); static doublereal dcon, delp, rhdn, exdn; static integer iret; static doublereal told, rhsm; static integer newq; static doublereal exsm, rhup, exup; static integer i__, j, m; extern int cfode_(); static doublereal r__; static integer iredo, i1; extern doublereal vnorm_(); static integer jb; static doublereal rh, del, ddn; static integer ncf; static doublereal dsm, dup; --neq; --y; yh_dim1 = *nyh; yh_offset = yh_dim1 + 1; yh -= yh_offset; --yh1; --ewt; --savf; --acor; --wm; --iwm; (ls0001_._6) .kflag = 0; told = (ls0001_._6) .tn; ncf = 0; (ls0001_._6) .ierpj = 0; (ls0001_._6) .iersl = 0; (ls0001_._6) .jcur = 0; (ls0001_._6) .icf = 0; if ((ls0001_._6) .jstart > 0) { goto L200; } if ((ls0001_._6) .jstart == -1) { goto L100; } if ((ls0001_._6) .jstart == -2) { goto L160; } (ls0001_._6) .lmax = (ls0001_._6) .maxord + 1; (ls0001_._6) .nq = 1; (ls0001_._6) .l = 2; (ls0001_._6) .ialth = 2; (ls0001_._6) .rmax = 1e4; (ls0001_._6) .rc = 0.; (ls0001_._6) .el0 = 1.; (ls0001_._6) .crate = .7; delp = 0.; (ls0001_._6) .hold = (ls0001_._6) .h__; (ls0001_._6) .meo = (ls0001_._6) .meth; (ls0001_._6) .nslp = 0; (ls0001_._6) .ipup = (ls0001_._6) .miter; iret = 3; goto L140; L100: (ls0001_._6) .ipup = (ls0001_._6) .miter; (ls0001_._6) .lmax = (ls0001_._6) .maxord + 1; if ((ls0001_._6) .ialth == 1) { (ls0001_._6) .ialth = 2; } if ((ls0001_._6) .meth == (ls0001_._6) .meo) { goto L110; } cfode_(& (ls0001_._6) .meth, (ls0001_._6) .elco, (ls0001_._6) .tesco); (ls0001_._6) .meo = (ls0001_._6) .meth; if ((ls0001_._6) .nq > (ls0001_._6) .maxord) { goto L120; } (ls0001_._6) .ialth = (ls0001_._6) .l; iret = 1; goto L150; L110: if ((ls0001_._6) .nq <= (ls0001_._6) .maxord) { goto L160; } L120: (ls0001_._6) .nq = (ls0001_._6) .maxord; (ls0001_._6) .l = (ls0001_._6) .lmax; i__1 = (ls0001_._6) .l; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._6) .el[i__ - 1] = (ls0001_._6) .elco[i__ + (ls0001_._6) .nq * 13 - 14]; } (ls0001_._6) .nqnyh = (ls0001_._6) .nq * *nyh; (ls0001_._6) .rc = (ls0001_._6) .rc * (ls0001_._6) .el[0] / (ls0001_._6) .el0; (ls0001_._6) .el0 = (ls0001_._6) .el[0]; (ls0001_._6) .conit = .5 / (doublereal) ((ls0001_._6) .nq + 2); ddn = vnorm_(& (ls0001_._6) .n, &savf[1], &ewt[1]) / (ls0001_._6) .tesco[(ls0001_._6) .l * 3 - 3]; exdn = 1. / (doublereal) (ls0001_._6) .l; rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6); rh = (( rhdn ) <= ( 1. ) ? ( rhdn ) : ( 1. )) ; iredo = 3; if ((ls0001_._6) .h__ == (ls0001_._6) .hold) { goto L170; } d__2 = rh, d__3 = (d__1 = (ls0001_._6) .h__ / (ls0001_._6) .hold, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); rh = (( d__2 ) <= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; (ls0001_._6) .h__ = (ls0001_._6) .hold; goto L175; L140: cfode_(& (ls0001_._6) .meth, (ls0001_._6) .elco, (ls0001_._6) .tesco); L150: i__1 = (ls0001_._6) .l; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._6) .el[i__ - 1] = (ls0001_._6) .elco[i__ + (ls0001_._6) .nq * 13 - 14]; } (ls0001_._6) .nqnyh = (ls0001_._6) .nq * *nyh; (ls0001_._6) .rc = (ls0001_._6) .rc * (ls0001_._6) .el[0] / (ls0001_._6) .el0; (ls0001_._6) .el0 = (ls0001_._6) .el[0]; (ls0001_._6) .conit = .5 / (doublereal) ((ls0001_._6) .nq + 2); switch ((int)iret) { case 1: goto L160; case 2: goto L170; case 3: goto L200; } L160: if ((ls0001_._6) .h__ == (ls0001_._6) .hold) { goto L200; } rh = (ls0001_._6) .h__ / (ls0001_._6) .hold; (ls0001_._6) .h__ = (ls0001_._6) .hold; iredo = 3; goto L175; L170: d__1 = rh, d__2 = (ls0001_._6) .hmin / (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ; rh = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; L175: rh = (( rh ) <= ( (ls0001_._6) .rmax ) ? ( rh ) : ( (ls0001_._6) .rmax )) ; d__1 = 1., d__2 = (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) * (ls0001_._6) .hmxi * rh; rh /= (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; r__ = 1.; i__1 = (ls0001_._6) .l; for (j = 2; j <= i__1; ++j) { r__ *= rh; i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { yh[i__ + j * yh_dim1] *= r__; } } (ls0001_._6) .h__ *= rh; (ls0001_._6) .rc *= rh; (ls0001_._6) .ialth = (ls0001_._6) .l; if (iredo == 0) { goto L690; } L200: if ((d__1 = (ls0001_._6) .rc - 1., (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (ls0001_._6) .ccmax) { (ls0001_._6) .ipup = (ls0001_._6) .miter; } if ((ls0001_._6) .nst >= (ls0001_._6) .nslp + (ls0001_._6) .msbp) { (ls0001_._6) .ipup = (ls0001_._6) .miter; } (ls0001_._6) .tn += (ls0001_._6) .h__; i1 = (ls0001_._6) .nqnyh + 1; i__2 = (ls0001_._6) .nq; for (jb = 1; jb <= i__2; ++jb) { i1 -= *nyh; i__1 = (ls0001_._6) .nqnyh; for (i__ = i1; i__ <= i__1; ++i__) { yh1[i__] += yh1[i__ + *nyh]; } } L220: m = 0; i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] = yh[i__ + yh_dim1]; } (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._6) .nfe; if ((ls0001_._6) .ipup <= 0) { goto L250; } (ls0001_._6) .ipup = 0; (ls0001_._6) .rc = 1.; (ls0001_._6) .nslp = (ls0001_._6) .nst; (ls0001_._6) .crate = .7; (*pjac)(&neq[1], &y[1], &yh[yh_offset], nyh, &ewt[1], &acor[1], &savf[1], &wm[1], &iwm[1], f, jac); if (ierode_ .iero > 0) { return 0; } if ((ls0001_._6) .ierpj != 0) { goto L430; } L250: i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { acor[i__] = 0.; } L270: if ((ls0001_._6) .miter != 0) { goto L350; } i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { savf[i__] = (ls0001_._6) .h__ * savf[i__] - yh[i__ + (yh_dim1 << 1)]; y[i__] = savf[i__] - acor[i__]; } del = vnorm_(& (ls0001_._6) .n, &y[1], &ewt[1]); i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] = yh[i__ + yh_dim1] + (ls0001_._6) .el[0] * savf[i__]; acor[i__] = savf[i__]; } goto L400; L350: i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { y[i__] = (ls0001_._6) .h__ * savf[i__] - (yh[i__ + (yh_dim1 << 1)] + acor[ i__]); } (*slvs)(&wm[1], &iwm[1], &y[1], &savf[1]); if ((ls0001_._6) .iersl < 0) { goto L430; } if ((ls0001_._6) .iersl > 0) { goto L410; } del = vnorm_(& (ls0001_._6) .n, &y[1], &ewt[1]); i__2 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__2; ++i__) { acor[i__] += y[i__]; y[i__] = yh[i__ + yh_dim1] + (ls0001_._6) .el[0] * acor[i__]; } L400: if (m != 0) { d__1 = (ls0001_._6) .crate * .2, d__2 = del / delp; (ls0001_._6) .crate = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } d__1 = 1., d__2 = (ls0001_._6) .crate * 1.5; dcon = del * (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) / ((ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 2] * (ls0001_._6) .conit); if (dcon <= 1.) { goto L450; } ++m; if (m == (ls0001_._6) .maxcor) { goto L410; } if (m >= 2 && del > delp * 2.) { goto L410; } delp = del; (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._6) .nfe; goto L270; L410: if ((ls0001_._6) .miter == 0 || (ls0001_._6) .jcur == 1) { goto L430; } (ls0001_._6) .icf = 1; (ls0001_._6) .ipup = (ls0001_._6) .miter; goto L220; L430: (ls0001_._6) .icf = 2; ++ncf; (ls0001_._6) .rmax = 2.; (ls0001_._6) .tn = told; i1 = (ls0001_._6) .nqnyh + 1; i__2 = (ls0001_._6) .nq; for (jb = 1; jb <= i__2; ++jb) { i1 -= *nyh; i__1 = (ls0001_._6) .nqnyh; for (i__ = i1; i__ <= i__1; ++i__) { yh1[i__] -= yh1[i__ + *nyh]; } } if ((ls0001_._6) .ierpj < 0 || (ls0001_._6) .iersl < 0) { goto L680; } if ((( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) <= (ls0001_._6) .hmin * 1.00001) { goto L670; } if (ncf == (ls0001_._6) .mxncf) { goto L670; } rh = .25; (ls0001_._6) .ipup = (ls0001_._6) .miter; iredo = 1; goto L170; L450: (ls0001_._6) .jcur = 0; if (m == 0) { dsm = del / (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 2]; } if (m > 0) { dsm = vnorm_(& (ls0001_._6) .n, &acor[1], &ewt[1]) / (ls0001_._6) .tesco[ (ls0001_._6) .nq * 3 - 2]; } if (dsm > 1.) { goto L500; } (ls0001_._6) .kflag = 0; iredo = 0; ++ (ls0001_._6) .nst; (ls0001_._6) .hu = (ls0001_._6) .h__; (ls0001_._6) .nqu = (ls0001_._6) .nq; i__2 = (ls0001_._6) .l; for (j = 1; j <= i__2; ++j) { i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + j * yh_dim1] += (ls0001_._6) .el[j - 1] * acor[i__]; } } -- (ls0001_._6) .ialth; if ((ls0001_._6) .ialth == 0) { goto L520; } if ((ls0001_._6) .ialth > 1) { goto L700; } if ((ls0001_._6) .l == (ls0001_._6) .lmax) { goto L700; } i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + (ls0001_._6) .lmax * yh_dim1] = acor[i__]; } goto L700; L500: -- (ls0001_._6) .kflag; (ls0001_._6) .tn = told; i1 = (ls0001_._6) .nqnyh + 1; i__1 = (ls0001_._6) .nq; for (jb = 1; jb <= i__1; ++jb) { i1 -= *nyh; i__2 = (ls0001_._6) .nqnyh; for (i__ = i1; i__ <= i__2; ++i__) { yh1[i__] -= yh1[i__ + *nyh]; } } (ls0001_._6) .rmax = 2.; if ((( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) <= (ls0001_._6) .hmin * 1.00001) { goto L660; } if ((ls0001_._6) .kflag <= -3) { goto L640; } iredo = 2; rhup = 0.; goto L540; L520: rhup = 0.; if ((ls0001_._6) .l == (ls0001_._6) .lmax) { goto L540; } i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { savf[i__] = acor[i__] - yh[i__ + (ls0001_._6) .lmax * yh_dim1]; } dup = vnorm_(& (ls0001_._6) .n, &savf[1], &ewt[1]) / (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 1]; exup = 1. / (doublereal) ((ls0001_._6) .l + 1); rhup = 1. / (pow_dd(&dup, &exup) * 1.4 + 1.4e-6); L540: exsm = 1. / (doublereal) (ls0001_._6) .l; rhsm = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6); rhdn = 0.; if ((ls0001_._6) .nq == 1) { goto L560; } ddn = vnorm_(& (ls0001_._6) .n, &yh[(ls0001_._6) .l * yh_dim1 + 1], &ewt[1]) / (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 3]; exdn = 1. / (doublereal) (ls0001_._6) .nq; rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6); L560: if (rhsm >= rhup) { goto L570; } if (rhup > rhdn) { goto L590; } goto L580; L570: if (rhsm < rhdn) { goto L580; } newq = (ls0001_._6) .nq; rh = rhsm; goto L620; L580: newq = (ls0001_._6) .nq - 1; rh = rhdn; if ((ls0001_._6) .kflag < 0 && rh > 1.) { rh = 1.; } goto L620; L590: newq = (ls0001_._6) .l; rh = rhup; if (rh < 1.1) { goto L610; } r__ = (ls0001_._6) .el[(ls0001_._6) .l - 1] / (doublereal) (ls0001_._6) .l; i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + (newq + 1) * yh_dim1] = acor[i__] * r__; } goto L630; L610: (ls0001_._6) .ialth = 3; goto L700; L620: if ((ls0001_._6) .kflag == 0 && rh < 1.1) { goto L610; } if ((ls0001_._6) .kflag <= -2) { rh = (( rh ) <= ( .2 ) ? ( rh ) : ( .2 )) ; } if (newq == (ls0001_._6) .nq) { goto L170; } L630: (ls0001_._6) .nq = newq; (ls0001_._6) .l = (ls0001_._6) .nq + 1; iret = 2; goto L150; L640: if ((ls0001_._6) .kflag == -10) { goto L660; } rh = .1; d__1 = (ls0001_._6) .hmin / (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ; rh = (( d__1 ) >= ( rh ) ? ( d__1 ) : ( rh )) ; (ls0001_._6) .h__ *= rh; i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__] = yh[i__ + yh_dim1]; } (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._6) .nfe; i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + (yh_dim1 << 1)] = (ls0001_._6) .h__ * savf[i__]; } (ls0001_._6) .ipup = (ls0001_._6) .miter; (ls0001_._6) .ialth = 5; if ((ls0001_._6) .nq == 1) { goto L200; } (ls0001_._6) .nq = 1; (ls0001_._6) .l = 2; iret = 3; goto L150; L660: (ls0001_._6) .kflag = -1; goto L720; L670: (ls0001_._6) .kflag = -2; goto L720; L680: (ls0001_._6) .kflag = -3; goto L720; L690: (ls0001_._6) .rmax = 10.; L700: r__ = 1. / (ls0001_._6) .tesco[(ls0001_._6) .nqu * 3 - 2]; i__1 = (ls0001_._6) .n; for (i__ = 1; i__ <= i__1; ++i__) { acor[i__] *= r__; } L720: (ls0001_._6) .hold = (ls0001_._6) .h__; (ls0001_._6) .jstart = 1; return 0; } int stodi_(neq, y, yh, nyh, yh1, ewt, savf, savr, acor, wm, iwm, res, adda, jac, pjac, slvs) integer *neq; doublereal *y, *yh; integer *nyh; doublereal *yh1, *ewt, *savf, *savr, *acor, *wm; integer *iwm; int (*res) (), (*adda) (), (*jac) (), (*pjac) (), (*slvs) (); { integer yh_dim1, yh_offset, i__1, i__2; doublereal d__1, d__2, d__3; double pow_dd(); static doublereal dcon, delp, eljh, rhdn, exdn; static integer ires, iret; static doublereal told, rhsm; static integer newq; static doublereal exsm, rhup, exup; static integer i__, j, m; extern int cfode_(); static doublereal r__; static integer iredo, i1; extern doublereal vnorm_(); static integer jb; static doublereal rh, del, ddn; static integer ncf, kgo; static doublereal dsm, dup, el1h; --neq; --y; yh_dim1 = *nyh; yh_offset = yh_dim1 + 1; yh -= yh_offset; --yh1; --ewt; --savf; --savr; --acor; --wm; --iwm; (ls0001_._7) .kflag = 0; told = (ls0001_._7) .tn; ncf = 0; (ls0001_._7) .ierpj = 0; (ls0001_._7) .iersl = 0; (ls0001_._7) .jcur = 0; (ls0001_._7) .icf = 0; delp = 0.; if ((ls0001_._7) .jstart > 0) { goto L200; } if ((ls0001_._7) .jstart == -1) { goto L100; } if ((ls0001_._7) .jstart == -2) { goto L160; } (ls0001_._7) .lmax = (ls0001_._7) .maxord + 1; (ls0001_._7) .nq = 1; (ls0001_._7) .l = 2; (ls0001_._7) .ialth = 2; (ls0001_._7) .rmax = 1e4; (ls0001_._7) .rc = 0.; (ls0001_._7) .el0 = 1.; (ls0001_._7) .crate = .7; (ls0001_._7) .hold = (ls0001_._7) .h__; (ls0001_._7) .meo = (ls0001_._7) .meth; (ls0001_._7) .nslp = 0; (ls0001_._7) .ipup = (ls0001_._7) .miter; iret = 3; goto L140; L100: (ls0001_._7) .ipup = (ls0001_._7) .miter; (ls0001_._7) .lmax = (ls0001_._7) .maxord + 1; if ((ls0001_._7) .ialth == 1) { (ls0001_._7) .ialth = 2; } if ((ls0001_._7) .meth == (ls0001_._7) .meo) { goto L110; } cfode_(& (ls0001_._7) .meth, (ls0001_._7) .elco, (ls0001_._7) .tesco); (ls0001_._7) .meo = (ls0001_._7) .meth; if ((ls0001_._7) .nq > (ls0001_._7) .maxord) { goto L120; } (ls0001_._7) .ialth = (ls0001_._7) .l; iret = 1; goto L150; L110: if ((ls0001_._7) .nq <= (ls0001_._7) .maxord) { goto L160; } L120: (ls0001_._7) .nq = (ls0001_._7) .maxord; (ls0001_._7) .l = (ls0001_._7) .lmax; i__1 = (ls0001_._7) .l; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._7) .el[i__ - 1] = (ls0001_._7) .elco[i__ + (ls0001_._7) .nq * 13 - 14]; } (ls0001_._7) .nqnyh = (ls0001_._7) .nq * *nyh; (ls0001_._7) .rc = (ls0001_._7) .rc * (ls0001_._7) .el[0] / (ls0001_._7) .el0; (ls0001_._7) .el0 = (ls0001_._7) .el[0]; (ls0001_._7) .conit = .5 / (doublereal) ((ls0001_._7) .nq + 2); ddn = vnorm_(& (ls0001_._7) .n, &savf[1], &ewt[1]) / (ls0001_._7) .tesco[(ls0001_._7) .l * 3 - 3]; exdn = 1. / (doublereal) (ls0001_._7) .l; rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6); rh = (( rhdn ) <= ( 1. ) ? ( rhdn ) : ( 1. )) ; iredo = 3; if ((ls0001_._7) .h__ == (ls0001_._7) .hold) { goto L170; } d__2 = rh, d__3 = (d__1 = (ls0001_._7) .h__ / (ls0001_._7) .hold, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); rh = (( d__2 ) <= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; (ls0001_._7) .h__ = (ls0001_._7) .hold; goto L175; L140: cfode_(& (ls0001_._7) .meth, (ls0001_._7) .elco, (ls0001_._7) .tesco); L150: i__1 = (ls0001_._7) .l; for (i__ = 1; i__ <= i__1; ++i__) { (ls0001_._7) .el[i__ - 1] = (ls0001_._7) .elco[i__ + (ls0001_._7) .nq * 13 - 14]; } (ls0001_._7) .nqnyh = (ls0001_._7) .nq * *nyh; (ls0001_._7) .rc = (ls0001_._7) .rc * (ls0001_._7) .el[0] / (ls0001_._7) .el0; (ls0001_._7) .el0 = (ls0001_._7) .el[0]; (ls0001_._7) .conit = .5 / (doublereal) ((ls0001_._7) .nq + 2); switch ((int)iret) { case 1: goto L160; case 2: goto L170; case 3: goto L200; } L160: if ((ls0001_._7) .h__ == (ls0001_._7) .hold) { goto L200; } rh = (ls0001_._7) .h__ / (ls0001_._7) .hold; (ls0001_._7) .h__ = (ls0001_._7) .hold; iredo = 3; goto L175; L170: d__1 = rh, d__2 = (ls0001_._7) .hmin / (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) ; rh = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; L175: rh = (( rh ) <= ( (ls0001_._7) .rmax ) ? ( rh ) : ( (ls0001_._7) .rmax )) ; d__1 = 1., d__2 = (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) * (ls0001_._7) .hmxi * rh; rh /= (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; r__ = 1.; i__1 = (ls0001_._7) .l; for (j = 2; j <= i__1; ++j) { r__ *= rh; i__2 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__2; ++i__) { yh[i__ + j * yh_dim1] *= r__; } } (ls0001_._7) .h__ *= rh; (ls0001_._7) .rc *= rh; (ls0001_._7) .ialth = (ls0001_._7) .l; if (iredo == 0) { goto L690; } L200: if ((d__1 = (ls0001_._7) .rc - 1., (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (ls0001_._7) .ccmax) { (ls0001_._7) .ipup = (ls0001_._7) .miter; } if ((ls0001_._7) .nst >= (ls0001_._7) .nslp + (ls0001_._7) .msbp) { (ls0001_._7) .ipup = (ls0001_._7) .miter; } (ls0001_._7) .tn += (ls0001_._7) .h__; i1 = (ls0001_._7) .nqnyh + 1; i__2 = (ls0001_._7) .nq; for (jb = 1; jb <= i__2; ++jb) { i1 -= *nyh; i__1 = (ls0001_._7) .nqnyh; for (i__ = i1; i__ <= i__1; ++i__) { yh1[i__] += yh1[i__ + *nyh]; } } L220: m = 0; i__2 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__2; ++i__) { savf[i__] = yh[i__ + (yh_dim1 << 1)] / (ls0001_._7) .h__; y[i__] = yh[i__ + yh_dim1]; } if ((ls0001_._7) .ipup <= 0) { goto L240; } (ls0001_._7) .ipup = 0; (ls0001_._7) .rc = 1.; (ls0001_._7) .nslp = (ls0001_._7) .nst; (ls0001_._7) .crate = .7; (*pjac)(&neq[1], &y[1], &yh[yh_offset], nyh, &ewt[1], &acor[1], &savr[1], &savf[1], &wm[1], &iwm[1], res, jac, adda); if (ierode_ .iero > 0) { return 0; } if ((ls0001_._7) .ierpj == 0) { goto L250; } ires = (ls0001_._7) .ierpj; switch ((int)ires) { case 1: goto L430; case 2: goto L435; case 3: goto L430; } L240: ires = 1; (*res)(&neq[1], & (ls0001_._7) .tn, &y[1], &savf[1], &savr[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._7) .nre; kgo = (( ires ) >= 0 ? ( ires ) : -( ires )) ; switch ((int)kgo) { case 1: goto L250; case 2: goto L435; case 3: goto L430; } L250: i__2 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__2; ++i__) { acor[i__] = 0.; } L270: (*slvs)(&wm[1], &iwm[1], &savr[1], &savf[1]); if ((ls0001_._7) .iersl < 0) { goto L430; } if ((ls0001_._7) .iersl > 0) { goto L410; } el1h = (ls0001_._7) .el[0] * (ls0001_._7) .h__; del = vnorm_(& (ls0001_._7) .n, &savr[1], &ewt[1]) * (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) ; i__2 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__2; ++i__) { acor[i__] += savr[i__]; savf[i__] = acor[i__] + yh[i__ + (yh_dim1 << 1)] / (ls0001_._7) .h__; y[i__] = yh[i__ + yh_dim1] + el1h * acor[i__]; } if (m != 0) { d__1 = (ls0001_._7) .crate * .2, d__2 = del / delp; (ls0001_._7) .crate = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } d__1 = 1., d__2 = (ls0001_._7) .crate * 1.5; dcon = del * (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) / ((ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 2] * (ls0001_._7) .conit); if (dcon <= 1.) { goto L460; } ++m; if (m == (ls0001_._7) .maxcor) { goto L410; } if (m >= 2 && del > delp * 2.) { goto L410; } delp = del; ires = 1; (*res)(&neq[1], & (ls0001_._7) .tn, &y[1], &savf[1], &savr[1], &ires); if (ierode_ .iero > 0) { return 0; } ++ (ls0001_._7) .nre; kgo = (( ires ) >= 0 ? ( ires ) : -( ires )) ; switch ((int)kgo) { case 1: goto L270; case 2: goto L435; case 3: goto L410; } L410: (ls0001_._7) .icf = 1; if ((ls0001_._7) .jcur == 1) { goto L430; } (ls0001_._7) .ipup = (ls0001_._7) .miter; goto L220; L430: (ls0001_._7) .icf = 2; ++ncf; (ls0001_._7) .rmax = 2.; L435: (ls0001_._7) .tn = told; i1 = (ls0001_._7) .nqnyh + 1; i__2 = (ls0001_._7) .nq; for (jb = 1; jb <= i__2; ++jb) { i1 -= *nyh; i__1 = (ls0001_._7) .nqnyh; for (i__ = i1; i__ <= i__1; ++i__) { yh1[i__] -= yh1[i__ + *nyh]; } } if (ires == 2) { goto L680; } if ((ls0001_._7) .ierpj < 0 || (ls0001_._7) .iersl < 0) { goto L685; } if ((( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) <= (ls0001_._7) .hmin * 1.00001) { goto L450; } if (ncf == (ls0001_._7) .mxncf) { goto L450; } rh = .25; (ls0001_._7) .ipup = (ls0001_._7) .miter; iredo = 1; goto L170; L450: if (ires == 3) { goto L680; } goto L670; L460: (ls0001_._7) .jcur = 0; if (m == 0) { dsm = del / (ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 2]; } if (m > 0) { dsm = (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) * vnorm_(& (ls0001_._7) .n, &acor[1], &ewt[1]) / (ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 2]; } if (dsm > 1.) { goto L500; } (ls0001_._7) .kflag = 0; iredo = 0; ++ (ls0001_._7) .nst; (ls0001_._7) .hu = (ls0001_._7) .h__; (ls0001_._7) .nqu = (ls0001_._7) .nq; i__2 = (ls0001_._7) .l; for (j = 1; j <= i__2; ++j) { eljh = (ls0001_._7) .el[j - 1] * (ls0001_._7) .h__; i__1 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + j * yh_dim1] += eljh * acor[i__]; } } -- (ls0001_._7) .ialth; if ((ls0001_._7) .ialth == 0) { goto L520; } if ((ls0001_._7) .ialth > 1) { goto L700; } if ((ls0001_._7) .l == (ls0001_._7) .lmax) { goto L700; } i__1 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + (ls0001_._7) .lmax * yh_dim1] = acor[i__]; } goto L700; L500: -- (ls0001_._7) .kflag; (ls0001_._7) .tn = told; i1 = (ls0001_._7) .nqnyh + 1; i__1 = (ls0001_._7) .nq; for (jb = 1; jb <= i__1; ++jb) { i1 -= *nyh; i__2 = (ls0001_._7) .nqnyh; for (i__ = i1; i__ <= i__2; ++i__) { yh1[i__] -= yh1[i__ + *nyh]; } } (ls0001_._7) .rmax = 2.; if ((( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) <= (ls0001_._7) .hmin * 1.00001) { goto L660; } if ((ls0001_._7) .kflag <= -7) { goto L660; } iredo = 2; rhup = 0.; goto L540; L520: rhup = 0.; if ((ls0001_._7) .l == (ls0001_._7) .lmax) { goto L540; } i__1 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__1; ++i__) { savf[i__] = acor[i__] - yh[i__ + (ls0001_._7) .lmax * yh_dim1]; } dup = (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) * vnorm_(& (ls0001_._7) .n, &savf[1], &ewt[1]) / (ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 1]; exup = 1. / (doublereal) ((ls0001_._7) .l + 1); rhup = 1. / (pow_dd(&dup, &exup) * 1.4 + 1.4e-6); L540: exsm = 1. / (doublereal) (ls0001_._7) .l; rhsm = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6); rhdn = 0.; if ((ls0001_._7) .nq == 1) { goto L560; } ddn = vnorm_(& (ls0001_._7) .n, &yh[(ls0001_._7) .l * yh_dim1 + 1], &ewt[1]) / (ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 3]; exdn = 1. / (doublereal) (ls0001_._7) .nq; rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6); L560: if (rhsm >= rhup) { goto L570; } if (rhup > rhdn) { goto L590; } goto L580; L570: if (rhsm < rhdn) { goto L580; } newq = (ls0001_._7) .nq; rh = rhsm; goto L620; L580: newq = (ls0001_._7) .nq - 1; rh = rhdn; if ((ls0001_._7) .kflag < 0 && rh > 1.) { rh = 1.; } goto L620; L590: newq = (ls0001_._7) .l; rh = rhup; if (rh < 1.1) { goto L610; } r__ = (ls0001_._7) .h__ * (ls0001_._7) .el[(ls0001_._7) .l - 1] / (doublereal) (ls0001_._7) .l; i__1 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__1; ++i__) { yh[i__ + (newq + 1) * yh_dim1] = acor[i__] * r__; } goto L630; L610: (ls0001_._7) .ialth = 3; goto L700; L620: if ((ls0001_._7) .kflag == 0 && rh < 1.1) { goto L610; } if ((ls0001_._7) .kflag <= -2) { rh = (( rh ) <= ( .1 ) ? ( rh ) : ( .1 )) ; } if (newq == (ls0001_._7) .nq) { goto L170; } L630: (ls0001_._7) .nq = newq; (ls0001_._7) .l = (ls0001_._7) .nq + 1; iret = 2; goto L150; L660: (ls0001_._7) .kflag = -1; goto L720; L670: (ls0001_._7) .kflag = -2; goto L720; L680: (ls0001_._7) .kflag = -1 - ires; goto L720; L685: (ls0001_._7) .kflag = -5; goto L720; L690: (ls0001_._7) .rmax = 10.; L700: r__ = (ls0001_._7) .h__ / (ls0001_._7) .tesco[(ls0001_._7) .nqu * 3 - 2]; i__1 = (ls0001_._7) .n; for (i__ = 1; i__ <= i__1; ++i__) { acor[i__] *= r__; } L720: (ls0001_._7) .hold = (ls0001_._7) .h__; (ls0001_._7) .jstart = 1; return 0; } int svcar1_(rsav, isav) doublereal *rsav, *isav; { static integer lenrls = 219; static integer lenils = 39; static integer lenrla = 22; static integer lenila = 9; static integer lenrlr = 5; static integer lenilr = 9; integer i__1; static integer i__, l; extern int dcopy_(); --isav; --rsav; l = 1; dcopy_(&lenrls, (ls0001_._5) .rls, &c__1, &rsav[l], &c__1); l += lenrls; dcopy_(&lenrla, (lsa001_._3) .rlsa, &c__1, &rsav[l], &c__1); l += lenrla; dcopy_(&lenrlr, (lsr001_._4) .rlsr, &c__1, &rsav[l], &c__1); l = 0; i__1 = lenils; for (i__ = 1; i__ <= i__1; ++i__) { isav[l + i__] = (doublereal) (ls0001_._5) .ils[i__ - 1]; } l += lenils; i__1 = lenila; for (i__ = 1; i__ <= i__1; ++i__) { isav[l + i__] = (doublereal) (lsa001_._3) .ilsa[i__ - 1]; } l += lenila; i__1 = lenilr; for (i__ = 1; i__ <= i__1; ++i__) { isav[l + i__] = (doublereal) (lsr001_._4) .ilsr[i__ - 1]; } l += lenilr; isav[l + 1] = (doublereal) (eh0001_._1) .ieh[0]; isav[l + 2] = (doublereal) (eh0001_._1) .ieh[1]; return 0; } int svcma1_(rsav, isav) doublereal *rsav, *isav; { static integer lenrls = 219; static integer lenils = 39; static integer lenrla = 22; static integer lenila = 9; integer i__1; static integer i__; --isav; --rsav; i__1 = lenrls; for (i__ = 1; i__ <= i__1; ++i__) { rsav[i__] = (ls0001_._5) .rls[i__ - 1]; } i__1 = lenrla; for (i__ = 1; i__ <= i__1; ++i__) { rsav[lenrls + i__] = (lsa001_._3) .rlsa[i__ - 1]; } i__1 = lenils; for (i__ = 1; i__ <= i__1; ++i__) { isav[i__] = (doublereal) (ls0001_._5) .ils[i__ - 1]; } i__1 = lenila; for (i__ = 1; i__ <= i__1; ++i__) { isav[lenils + i__] = (doublereal) (lsa001_._3) .ilsa[i__ - 1]; } isav[lenils + lenila + 1] = (doublereal) (eh0001_._1) .ieh[0]; isav[lenils + lenila + 2] = (doublereal) (eh0001_._1) .ieh[1]; return 0; } int svcom1_(rsav, isav) doublereal *rsav, *isav; { static integer lenrls = 219; static integer lenils = 39; integer i__1; static integer i__; --isav; --rsav; i__1 = lenrls; for (i__ = 1; i__ <= i__1; ++i__) { rsav[i__] = (ls0001_._5) .rls[i__ - 1]; } i__1 = lenils; for (i__ = 1; i__ <= i__1; ++i__) { isav[i__] = (doublereal) (ls0001_._5) .ils[i__ - 1]; } isav[lenils + 1] = (doublereal) (eh0001_._1) .ieh[0]; isav[lenils + 2] = (doublereal) (eh0001_._1) .ieh[1]; return 0; } doublereal vmnorm_(n, v, w) integer *n; doublereal *v, *w; { integer i__1; doublereal ret_val, d__1, d__2, d__3; static integer i__; static doublereal vm; --w; --v; vm = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__2 = vm, d__3 = (d__1 = v[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * w[i__]; vm = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } ret_val = vm; return ret_val; } doublereal vnorm_(n, v, w) integer *n; doublereal *v, *w; { integer i__1; doublereal ret_val, d__1; double sqrt(); static integer i__; static doublereal sum; --w; --v; sum = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = v[i__] * w[i__]; sum += d__1 * d__1; } ret_val = sqrt(sum / (doublereal) (*n)); return ret_val; } int xerrwv_(msg, nmes, nerr, iert, ni, i1, i2, nr, r1, r2, msg_len) char *msg; integer *nmes, *nerr, *iert, *ni, *i1, *i2, *nr; doublereal *r1, *r2; ftnlen msg_len; { static char fmt_10[] = "(1x,80a1)"; static char fmt_20[] = "(6x,\002where i1 is : \002,i10)"; static char fmt_30[] = "(6x,\002where i1 is : \002,i10,3x,\002 and i2 : \002,i10)"; static char fmt_40[] = "(6x,\002where i1 is : \002,d21.13)"; static char fmt_50[] = "(6x,\002where i1 is : \002,d21.13,3x,\002and r2 : \002,d21.13)"; integer i__1; integer i_len(), s_wsfe(), do_fio(), e_wsfe(); int s_stop(); static integer i__, nch, lun; static cilist io___1759 = { 0, 0, 0, fmt_10, 0 }; static cilist io___1761 = { 0, 0, 0, fmt_20, 0 }; static cilist io___1762 = { 0, 0, 0, fmt_30, 0 }; static cilist io___1763 = { 0, 0, 0, fmt_40, 0 }; static cilist io___1764 = { 0, 0, 0, fmt_50, 0 }; if ((eh0001_._2) .mesflg == 0) { goto L100; } lun = (eh0001_._2) .lunit; i__1 = i_len(msg, msg_len); nch = (( i__1 ) <= ( 80 ) ? ( i__1 ) : ( 80 )) ; io___1759.ciunit = lun; s_wsfe(&io___1759); i__1 = nch; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, msg + (i__ - 1), 1L); } e_wsfe(); if (*ni == 1) { io___1761.ciunit = lun; s_wsfe(&io___1761); do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer)); e_wsfe(); } if (*ni == 2) { io___1762.ciunit = lun; s_wsfe(&io___1762); do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*i2), (ftnlen)sizeof(integer)); e_wsfe(); } if (*nr == 1) { io___1763.ciunit = lun; s_wsfe(&io___1763); do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*nr == 2) { io___1764.ciunit = lun; s_wsfe(&io___1764); do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*r2), (ftnlen)sizeof(doublereal)); e_wsfe(); } L100: if (*iert != 2) { return 0; } s_stop("", 0L); } int xsetf_(mflag) integer *mflag; { if (*mflag == 0 || *mflag == 1) { (eh0001_._2) .mesflg = *mflag; } return 0; } int xsetun_(lun) integer *lun; { if (*lun > 0) { (eh0001_._2) .lunit = *lun; } return 0; } int ajour_(mode, n, nc, nr, h__, w, indi) integer *mode, *n, *nc, *nr; doublereal *h__, *w; integer *indi; { integer i__1, i__2; doublereal d__1; static doublereal a, b, c__; static integer i__, j, k; static doublereal u, v, h1; static integer nsaut, i1; static doublereal h2, ai, di; static integer ii, ij, ik, nh, nj, nk, nl, ko; static doublereal wi; static integer nw; static doublereal di1; static integer nh1, nr1, nr2, inc; static doublereal hij; static integer nii, nkk, nrr, inc1; --indi; --w; --h__; inc = indi[*nc]; nr1 = *nr + 1; nr2 = *nr - 1; nrr = *n - *nr; nii = *n - inc; nkk = *nr - inc; if (*mode == -1) { goto L240; } nsaut = nii + 1; nh = inc * (*n + 1) - inc * (inc + 1) / 2; nw = *n; if (inc == *n) { goto L20; } i__1 = nii; for (i__ = 1; i__ <= i__1; ++i__) { w[nw] = h__[nh]; --nw; --nh; } L20: w[nr1] = h__[nh]; --nh; if (inc == nr1) { goto L60; } i__1 = inc - nr1; for (i__ = 1; i__ <= i__1; ++i__) { nl = nii + i__ - 1; if (nl == 0) { goto L35; } i__2 = nl; for (j = 1; j <= i__2; ++j) { h__[nh + nsaut] = h__[nh]; --nh; } L35: w[nw] = h__[nh]; --nw; --nh; ++nsaut; } i__1 = inc - nr1; for (j = 1; j <= i__1; ++j) { h__[nh + nsaut] = h__[nh]; --nh; } L60: --nw; nsaut = 1; if (*nr == 0) { goto L125; } if (inc == *n) { goto L80; } i__1 = nii; for (i__ = 1; i__ <= i__1; ++i__) { h__[nh + nsaut] = h__[nh]; --nh; } L80: if (*nr == 1) { goto L110; } i__1 = nr2; for (i__ = 1; i__ <= i__1; ++i__) { w[nw] = h__[nh]; --nw; --nh; ++nsaut; if (*n == nr1) { goto L100; } i__2 = *n - nr1; for (j = 1; j <= i__2; ++j) { h__[nh + nsaut] = h__[nh]; --nh; } L100: ; } L110: w[nw] = h__[nh]; --nh; ++nsaut; if (inc == nr1) { goto L125; } i__1 = inc - nr1; for (i__ = 1; i__ <= i__1; ++i__) { h__[nh + nsaut] = h__[nh]; --nh; } L125: if (*nr != 0) { goto L130; } if (w[1] > 0.) { goto L220; } *mode = -1; return 0; L130: if (*nr == 1) { goto L160; } i__1 = *nr; for (i__ = 2; i__ <= i__1; ++i__) { ij = i__; i1 = i__ - 1; v = w[i__]; i__2 = i1; for (j = 1; j <= i__2; ++j) { v -= h__[ij] * w[j]; ij = ij + *nr - j; } w[i__] = v; } L160: ij = 1; v = w[nr1]; i__1 = *nr; for (i__ = 1; i__ <= i__1; ++i__) { wi = w[i__]; hij = h__[ij]; d__1 = wi; v -= d__1 * d__1 / hij; w[i__] = wi / hij; ij = ij + nr1 - i__; } if (v > 0.) { goto L180; } *mode = -1; return 0; L180: w[nr1] = v; nh = *nr * (*nr + 1) / 2; nw = nr1; nsaut = nw; h__[nh + nsaut] = w[nw]; --nw; --nsaut; if (*nr == 1) { goto L220; } i__1 = nr2; for (i__ = 1; i__ <= i__1; ++i__) { h__[nh + nsaut] = w[nw]; --nw; --nsaut; i__2 = i__; for (j = 1; j <= i__2; ++j) { h__[nh + nsaut] = h__[nh]; --nh; } } L220: h__[nr1] = w[1]; if (*n == nr1) { goto L233; } nh1 = *nr * (*n + 1) - *nr * (*nr + 1) / 2 + 1; nw = nr1; i__1 = *n - nr1; for (i__ = 1; i__ <= i__1; ++i__) { h__[nh1 + i__] = w[nw + i__]; } L233: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ii = indi[i__]; if (ii <= *nr || ii >= inc) { goto L235; } indi[i__] = ii + 1; L235: ; } ++(*nr); indi[*nc] = *nr; *mode = 0; return 0; L240: i__1 = *nr; for (i__ = 1; i__ <= i__1; ++i__) { ik = i__; ij = inc; ii = 1; ko = (( ik ) <= ( inc ) ? ( ik ) : ( inc )) ; v = 0.; if (ko == 1) { goto L252; } i__2 = ko - 1; for (k = 1; k <= i__2; ++k) { nk = nr1 - k; v += h__[ij] * h__[ik] * h__[ii]; ij = ij + nk - 1; ii += nk; ik = ik + nk - 1; } L252: a = 1.; b = 1.; if (ko == i__) { goto L253; } a = h__[ik]; L253: if (ko == inc) { goto L260; } b = h__[ij]; L260: w[i__] = v + a * b * h__[ii]; } if (inc == *nr) { goto L315; } inc1 = inc - 1; nh = inc1 * nr1 - inc1 * inc / 2 + 2; nh1 = nh + nkk; di = h__[nh - 1]; i__1 = nkk; for (j = 1; j <= i__1; ++j) { di1 = h__[nh1]; ++nh1; a = h__[nh]; ai = a * di; d__1 = a; c__ = d__1 * d__1 * di + di1; h__[nh] = c__; ++nh; if (j == nkk) { goto L315; } i__2 = nkk - j; for (i__ = 1; i__ <= i__2; ++i__) { h1 = h__[nh]; h2 = h__[nh1]; u = ai * h1 + h2 * di1; h__[nh] = u / c__; h__[nh1] = -h1 + a * h2; ++nh; ++nh1; } ++nh; di = di * di1 / c__; } L315: nh = inc + 1; nsaut = 1; nj = *nr - 2; if (inc == 1) { ++nj; } if (*nr == 1) { goto L440; } i__1 = nr2; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = nj; for (j = 1; j <= i__2; ++j) { h__[nh - nsaut] = h__[nh]; ++nh; } ++nsaut; ++nh; if (i__ == inc - 1) { goto L430; } --nj; if (nj == 0) { goto L440; } L430: ; } L440: nh = *nr * nr2 / 2 + 1; nw = 1; nsaut = *nr; if (inc == 1) { goto L470; } i__1 = inc - 1; for (i__ = 1; i__ <= i__1; ++i__) { h__[nh] = w[nw]; ++nw; --nsaut; if (*n == *nr) { goto L455; } i__2 = nrr; for (j = 1; j <= i__2; ++j) { h__[nh + j] = h__[nh + nsaut + j]; } L455: nh = nh + nrr + 1; } L470: ++nw; if (*nr == *n) { goto L485; } i__1 = nrr; for (i__ = 1; i__ <= i__1; ++i__) { w[*nr + i__] = h__[nh + nsaut + i__ - 1]; } nsaut += nrr; L485: if (inc == *nr) { goto L510; } i__1 = nkk; for (i__ = 1; i__ <= i__1; ++i__) { --nsaut; h__[nh] = w[nw]; ++nw; if (*nr == *n) { goto L495; } i__2 = nrr; for (j = 1; j <= i__2; ++j) { h__[nh + j] = h__[nh + nsaut + j]; } L495: nh = nh + nrr + 1; } L510: h__[nh] = w[inc]; if (*nr == *n) { goto L540; } i__1 = nrr; for (i__ = 1; i__ <= i__1; ++i__) { h__[nh + i__] = w[*nr + i__]; } L540: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ii = indi[i__]; if (ii <= inc || ii > *nr) { goto L550; } indi[i__] = ii - 1; L550: ; } indi[*nc] = *nr; --(*nr); *mode = 0; return 0; } int anfm01_(q, iq, r__, ir, x, w, n, m, ind, io) doublereal *q; integer *iq; doublereal *r__; integer *ir; doublereal *x, *w; integer *n, *m, *ind, *io; { integer q_dim1, q_offset, r_dim1, r_offset, i__1; doublereal d__1; double pow_dd(), d_sign(), sqrt(); extern doublereal ddot_(), dnrm2_(); static integer i__, j, k; static doublereal s, t; extern int dscal_(), dcopy_(), daxpy_(); static integer m1; extern doublereal dlamch_(); static integer nm; static doublereal rnorma, eps; q_dim1 = *iq; q_offset = q_dim1 + 1; q -= q_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --x; --w; m1 = *m - 1; nm = *n - m1; k = 0; if (*ind < 0) { k = 1; *ind = -(*ind); } if (*ind == 0) { i__1 = m1; for (i__ = 1; i__ <= i__1; ++i__) { r__[i__ + *m * r_dim1] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &x[ 1], &c__1); } i__1 = *n; for (i__ = *m; i__ <= i__1; ++i__) { w[i__ - m1] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &x[1], &c__1); } } else { dcopy_(&m1, &q[*ind + q_dim1], iq, &r__[*m * r_dim1 + 1], &c__1); dcopy_(&nm, &q[*ind + *m * q_dim1], iq, &w[1], &c__1); } if (k == 1) { i__1 = m1; for (i__ = 1; i__ <= i__1; ++i__) { r__[i__ + *m * r_dim1] = -r__[i__ + *m * r_dim1]; } i__1 = nm; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = -w[i__]; } } rnorma = dnrm2_(&nm, &w[1], &c__1); d__1 = dlamch_("p", 1L); eps = pow_dd(&d__1, &c_b5732); if (rnorma < eps) { *ind = -1; return 0; } *ind = 0; if (*m == *n) { r__[*m + *m * r_dim1] = w[1]; return 0; } if (w[1] != 0.) { rnorma = d_sign(&rnorma, &w[1]); } w[1] = rnorma + w[1]; s = sqrt(w[1] * rnorma); s = 1 / s; dscal_(&nm, &s, &w[1], &c__1); i__1 = *n; for (j = 1; j <= i__1; ++j) { t = -ddot_(&nm, &w[1], &c__1, &q[j + *m * q_dim1], iq); daxpy_(&nm, &t, &w[1], &c__1, &q[j + *m * q_dim1], iq); } r__[*m + *m * r_dim1] = -rnorma; } int anfm02_(q, iq, r__, ir, n, m, icol, io) doublereal *q; integer *iq; doublereal *r__; integer *ir, *n, *m, *icol, *io; { integer q_dim1, q_offset, r_dim1, r_offset, i__1, i__2; doublereal d__1; double d_sign(); extern doublereal dnrm2_(); static doublereal a; static integer i__, j; static doublereal s, t; extern int dscal_(), dcopy_(); static integer i1; static doublereal s1, s2; extern doublereal dlamch_(); static doublereal epsmch; q_dim1 = *iq; q_offset = q_dim1 + 1; q -= q_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; if (*m == *icol) { return 0; } epsmch = dlamch_("p", 1L); i__1 = *m; for (i__ = *icol + 1; i__ <= i__1; ++i__) { if (r__[i__ + i__ * r_dim1] != 0.) { i1 = i__ - 1; a = dnrm2_(&c__2, &r__[i1 + i__ * r_dim1], &c__1); if (a > epsmch) { if (r__[i1 + i__ * r_dim1] != 0.) { a = d_sign(&a, &r__[i1 + i__ * r_dim1]); } d__1 = 1. / a; dscal_(&c__2, &d__1, &r__[i1 + i__ * r_dim1], &c__1); r__[i1 + i__ * r_dim1] += 1.; s1 = r__[i1 + i__ * r_dim1]; s2 = r__[i__ + i__ * r_dim1]; s = s2 / s1; i__2 = *n; for (j = 1; j <= i__2; ++j) { t = -q[j + i1 * q_dim1] - q[j + i__ * q_dim1] * s; q[j + i1 * q_dim1] += t * s1; q[j + i__ * q_dim1] += t * s2; } i__2 = *m; for (j = i__ + 1; j <= i__2; ++j) { t = -r__[i1 + j * r_dim1] - r__[i__ + j * r_dim1] * s; r__[i1 + j * r_dim1] += t * s1; r__[i__ + j * r_dim1] += t * s2; } r__[i1 + i__ * r_dim1] = -a; } } } i__1 = *m; for (j = *icol + 1; j <= i__1; ++j) { i1 = j - 1; dcopy_(&i1, &r__[j * r_dim1 + 1], &c__1, &r__[i1 * r_dim1 + 1], &c__1) ; } } int anfm03_(h__, ih, r__, ir, z__, iz, w, ipvt, n, m, ind, modo, io) doublereal *h__; integer *ih; doublereal *r__; integer *ir; doublereal *z__; integer *iz; doublereal *w; integer *ipvt, *n, *m, *ind, *modo, *io; { integer h_dim1, h_offset, r_dim1, r_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; double sqrt(); static doublereal beta; static integer ndim; extern doublereal ddot_(); static doublereal smax; extern doublereal zthz_(); static integer i__, j, k, l; static doublereal s; static integer i1; static doublereal s1; static integer ii, ij, ik, kk, in; extern doublereal dlamch_(); static integer nj, iibeta; static doublereal sk, epsmch; extern int dipvtf_(); static integer ik0, nm1; static doublereal rii, rik, eps, eps0; h_dim1 = *ih; h_offset = h_dim1 + 1; h__ -= h_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; z_dim1 = *iz; z_offset = z_dim1 + 1; z__ -= z_offset; --w; --ipvt; epsmch = dlamch_("p", 1L); eps = epsmch * 10.; if (*ind == 0) { ndim = *m; i__1 = ndim; for (i__ = 1; i__ <= i__1; ++i__) { ipvt[i__] = i__; } } else { ndim = *m - *ind; } smax = 1.; nm1 = *m + 1; i__1 = ndim; for (i__ = 1; i__ <= i__1; ++i__) { if (*ind == 0) { nj = nm1 - i__; ii = i__; } else { nj = nm1 - ipvt[i__]; ii = *ind + i__; } s = zthz_(&h__[h_offset], ih, &z__[z_offset], iz, n, &nj, &nj); if (*ind > 0) { s -= ddot_(ind, &r__[i__ * r_dim1 + 1], &c__1, &r__[i__ * r_dim1 + 1], &c__1); } if (*modo == 0 && s < -eps) { *ind = *n; return 0; } r__[ii + i__ * r_dim1] = s; s = (( s ) >= 0 ? ( s ) : -( s )) ; smax = (( s ) >= ( smax ) ? ( s ) : ( smax )) ; } if (ndim == 1) { ik = *ind + 1; s = r__[ik + r_dim1]; if (s > eps) { r__[ik + r_dim1] = sqrt(s); *ind = 0; } else if (s < -eps) { *ind = -1; } else { *ind = 1; } return 0; } eps0 = epsmch * smax; eps = eps0 * *ind; d__1 = eps0 * ndim * 10, d__2 = sqrt(smax) * 1.2; beta = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; iibeta = 0; s1 = 0.; i__1 = ndim - 1; for (k = 1; k <= i__1; ++k) { eps += eps0; kk = k + 1; ik = k; if (*ind > 0) { ik = k + *ind; } ik0 = ik - 1; sk = r__[ik + k * r_dim1]; if (s1 <= beta) { j = k; s = sk; i__2 = ndim; for (i__ = kk; i__ <= i__2; ++i__) { ii = i__ + *ind; rii = r__[ii + i__ * r_dim1]; if (rii > s) { j = i__; s = rii; } } } else { s = -1.; iibeta = 1; } if (s > eps) { dipvtf_(&r__[r_offset], ir, &ipvt[1], &ik0, &k, &j); r__[*ind + j + j * r_dim1] = sk; l = nm1 - ipvt[k]; sk = sqrt(s); r__[ik + k * r_dim1] = sk; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { s = ddot_(&i__, &h__[i__ + h_dim1], ih, &z__[l * z_dim1 + 1], &c__1); if (i__ < *n) { i1 = i__ + 1; i__3 = *n - i__; w[i__] = s + ddot_(&i__3, &h__[i1 + i__ * h_dim1], &c__1, &z__[i1 + l * z_dim1], &c__1); } } w[*n] = s; s1 = 0.; i__2 = ndim; for (i__ = kk; i__ <= i__2; ++i__) { j = nm1 - ipvt[i__]; s = ddot_(n, &z__[j * z_dim1 + 1], &c__1, &w[1], &c__1); if (ik0 > 0) { s -= ddot_(&ik0, &r__[i__ * r_dim1 + 1], &c__1, &r__[k * r_dim1 + 1], &c__1); } rik = s / sk; d__1 = s1, d__2 = (( rik ) >= 0 ? ( rik ) : -( rik )) ; s1 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; r__[ik + i__ * r_dim1] = rik; ii = i__; if (*ind > 0) { ii += *ind; } r__[ii + i__ * r_dim1] -= rik * rik; } } else { s = sk; j = k; i__2 = ndim; for (i__ = kk; i__ <= i__2; ++i__) { ii = *ind + i__; rii = r__[ii + i__ * r_dim1]; if (rii < s) { j = i__; s = rii; } } if (s < -eps) { if (*modo == 0) { *ind = *n; return 0; } dipvtf_(&r__[r_offset], ir, &ipvt[1], &ik0, &k, &j); r__[ik + k * r_dim1] = s; r__[*ind + j + j * r_dim1] = sk; *ind = -k; if (iibeta == 1) { *ind -= *iz * 10; } return 0; } else { i__2 = ndim - 1; for (j = k; j <= i__2; ++j) { nj = nm1 - ipvt[j]; ij = j + *ind; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { s1 = ddot_(&i__, &h__[i__ + h_dim1], ih, &z__[nj * z_dim1 + 1], &c__1); if (i__ < *n) { i1 = i__ + 1; i__4 = *n - i__; w[i__] = s1 + ddot_(&i__4, &h__[i1 + i__ * h_dim1] , &c__1, &z__[i1 + nj * z_dim1], &c__1); } } w[*n] = s1; i__3 = ndim; for (i__ = j + 1; i__ <= i__3; ++i__) { s1 = ddot_(n, &w[1], &c__1, &z__[(nm1 - ipvt[i__]) * z_dim1 + 1], &c__1); if (ik0 > 0) { s1 -= ddot_(&ik0, &r__[i__ * r_dim1 + 1], &c__1, & r__[j * r_dim1 + 1], &c__1); } r__[ij + i__ * r_dim1] = s1; s1 = (( s1 ) >= 0 ? ( s1 ) : -( s1 )) ; if (s1 > s) { s = s1; l = i__; } } if (s > eps) { if (*modo == 0) { *ind = *n; return 0; } dipvtf_(&r__[r_offset], ir, &ipvt[1], &ik0, &j, &k); dipvtf_(&r__[r_offset], ir, &ipvt[1], &ik0, &l, &kk); r__[ik + kk * r_dim1] = r__[ij + l * r_dim1]; *ind = -ndim - k; return 0; } } *ind = ndim - k + 1; return 0; } } } eps = eps0 + eps; in = ndim + *ind; s = r__[in + ndim * r_dim1]; if (s > eps) { r__[in + ndim * r_dim1] = sqrt(s); *ind = 0; } else if (s < -eps) { *ind = -ndim; } else { *ind = 1; } } int anfm04_(q, iq, r__, ir, x, w, ipvt, n, m, ind, io) doublereal *q; integer *iq; doublereal *r__; integer *ir; doublereal *x, *w; integer *ipvt, *n, *m, *ind, *io; { integer q_dim1, q_offset, r_dim1, r_offset, i__1, i__2; double pow_dd(), sqrt(); extern doublereal ddot_(), dnrm2_(); static doublereal a, b, c__; static integer i__, j, k; static doublereal s, t; extern int dcopy_(); static integer i1, j1, k1, k2, m1, m2, m3, n1, j2; extern doublereal dlamch_(); static integer nm; static doublereal epsmch, rnorma; static integer nm1; static doublereal eps, eps0; q_dim1 = *iq; q_offset = q_dim1 + 1; q -= q_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --x; --w; --ipvt; epsmch = dlamch_("p", 1L); eps = pow_dd(&epsmch, &c_b5779); eps0 = pow_dd(&epsmch, &c_b5732); nm = *n - *m; nm1 = nm + 1; m1 = *m - 1; m2 = (nm << 1) + 1; m3 = m2 - *m; n1 = *n + 1; k = 0; if (*ind < 0) { k = 1; *ind = -(*ind); } if (*ind == 0) { i__1 = m1; for (i__ = 1; i__ <= i__1; ++i__) { r__[i__ + *m * r_dim1] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &x[ 1], &c__1); } i__1 = *n; for (i__ = *m; i__ <= i__1; ++i__) { w[m3 + i__] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &x[1], &c__1); } } else { dcopy_(&m1, &q[*ind + q_dim1], iq, &r__[*m * r_dim1 + 1], &c__1); dcopy_(&nm1, &q[*ind + *m * q_dim1], iq, &w[m2], &c__1); } if (k == 1) { i__1 = m1; for (i__ = 1; i__ <= i__1; ++i__) { r__[i__ + *m * r_dim1] = -r__[i__ + *m * r_dim1]; } i__1 = m2 + nm; for (i__ = m2; i__ <= i__1; ++i__) { w[i__] = -w[i__]; } } rnorma = dnrm2_(&nm1, &w[m2], &c__1); if (rnorma < eps0) { *ind = -1; return 0; } *ind = 0; if (*m == *n) { r__[*m + *m * r_dim1] = w[m2]; return 0; } k1 = n1 - ipvt[1]; i__1 = nm1; for (i__ = 2; i__ <= i__1; ++i__) { i1 = i__ - 1; k2 = n1 - ipvt[i__]; if (k2 < k1) { j = k1; k1 = k2; k2 = j; } j1 = m3 + k1; j2 = m3 + k2; t = sqrt(w[j1] * w[j1] + w[j2] * w[j2]); if (t < eps) { w[i1] = 1.; w[nm + i1] = 0.; i__2 = *n; for (j = 1; j <= i__2; ++j) { q[j + k2 * q_dim1] = -q[j + k2 * q_dim1]; } } else { c__ = w[j1] / t; s = w[j2] / t; w[j1] = t; w[j2] = 0.; i__2 = *n; for (j = 1; j <= i__2; ++j) { a = q[j + k1 * q_dim1]; b = q[j + k2 * q_dim1]; q[j + k1 * q_dim1] = a * c__ + b * s; q[j + k2 * q_dim1] = a * s - b * c__; } w[i1] = c__; w[nm + i1] = s; } } r__[*m + *m * r_dim1] = t; } int anfm05_(h__, ih, r__, ir, z__, iz, p, w, ipvt, x, n, m, np, ind, modo, io) doublereal *h__; integer *ih; doublereal *r__; integer *ir; doublereal *z__; integer *iz; doublereal *p, *w; integer *ipvt; doublereal *x; integer *n, *m, *np, *ind, *modo, *io; { integer h_dim1, h_offset, r_dim1, r_offset, z_dim1, z_offset, i__1, i__2; doublereal d__1; double sqrt(); static doublereal c__; static integer i__, j, k, l; static doublereal s; extern int anfm03_(), dcopy_(), dswap_(); static integer i1, j1, k1, k2, m1, n1, m2, n2, m3; static doublereal s1; static integer ni; extern doublereal dlamch_(); static doublereal pi, ri; static integer iibeta; static doublereal epsmch; extern int dipvtf_(); static integer ni1; static doublereal ri1; static integer nm2; static doublereal rj1, rij, pni; h_dim1 = *ih; h_offset = h_dim1 + 1; h__ -= h_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; z_dim1 = *iz; z_offset = z_dim1 + 1; z__ -= z_offset; --p; --w; --ipvt; n1 = *n + 1; epsmch = dlamch_("p", 1L); if (*ind == n1) { --(*ind); return 0; } if (*ind > 0 && *ind <= n1) { m2 = n1 - *ind; } else { m2 = *m; } m1 = m2 + 1; n2 = n1 + 1; nm2 = n1 + m2; k1 = ipvt[1]; if (m2 > 0) { w[1] = *x; } else { w[1] = 1.; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__ + 1; ni1 = n1 + i1; k2 = ipvt[i1]; ni = *n + i__; pni = p[ni]; pi = p[i__]; if (i__ < m2) { l = i1; } else { l = m2; } dcopy_(&l, &r__[i__ * r_dim1 + 1], &c__1, &w[n2], &c__1); if (k1 < k2) { j = k1; k1 = k2; k2 = j; i__2 = i1; for (k = m1; k <= i__2; ++k) { w[n1 + k] = 0.; } if (i__ > *m) { w[ni1] = 1.; } dswap_(&i1, &w[1], &c__1, &w[n2], &c__1); j = -1; } else { j = 0; } if (i__ < m2) { --l; } ipvt[i__] = k2; i__2 = l; for (k = 2; k <= i__2; ++k) { r__[k - 1 + i__ * r_dim1] = w[k] * pni - w[n1 + k] * pi; } if (i__ < *m) { if (i__ < m2) { r__[i1 + i__ * r_dim1] = w[1] * pni - w[n2] * pi; } else { r__[m2 + i__ * r_dim1] = w[1] * pni - w[n2] * pi; } i__2 = l; for (k = 1; k <= i__2; ++k) { w[k] = w[k] * pi + w[n1 + k] * pni; } } if (i__ < m2) { if (j == 0) { r__[i__ + i__ * r_dim1] = -pi * w[ni1]; w[i1] = pni * w[ni1]; } else { r__[i__ + i__ * r_dim1] = pni * w[i1]; w[i1] = pi * w[i1]; } } else if (i__ >= *m) { r__[m2 + i__ * r_dim1] = w[1] * pni - w[n2] * pi; i__2 = l; for (k = 1; k <= i__2; ++k) { w[k] = w[k] * pi + w[n1 + k] * pni; } } } m3 = m2 - 1; i__1 = m3; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__ + 1; ri = r__[i__ + i__ * r_dim1]; ri1 = r__[i1 + i__ * r_dim1]; if ((( ri1 ) >= 0 ? ( ri1 ) : -( ri1 )) > epsmch) { s1 = sqrt(ri1 * ri1 + ri * ri); s = ri1 / s1; c__ = ri / s1; r__[i__ + i__ * r_dim1] = s1; i__2 = *n; for (j = i1; j <= i__2; ++j) { if (j <= m3) { j1 = j + 1; } else { j1 = m2; } rj1 = r__[j1 + j * r_dim1]; rij = r__[i__ + j * r_dim1]; r__[i__ + j * r_dim1] = c__ * rij + s * rj1; r__[j1 + j * r_dim1] = s * rij - c__ * rj1; } } } if (*ind > 0 && *ind <= n1) { j = m2; s = (d__1 = r__[m2 + m2 * r_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); i__1 = *n; for (i__ = m2 + 1; i__ <= i__1; ++i__) { s1 = (d__1 = r__[m2 + i__ * r_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (s1 > s) { s = s1; j = i__; } } if (r__[m2 + j * r_dim1] < -epsmch) { i__1 = *n; for (i__ = m2; i__ <= i__1; ++i__) { r__[m2 + i__ * r_dim1] = -r__[m2 + i__ * r_dim1]; } } if (j != m2) { dipvtf_(&r__[r_offset], ir, &ipvt[1], &m2, &m2, &j); } } if (*ind >= 0 && *ind <= n1) { if (*ind > 0 && r__[m2 + m2 * r_dim1] > epsmch) { --(*ind); } return 0; } *ind = m3; anfm03_(&h__[h_offset], ih, &r__[m2 * r_dim1 + 1], ir, &z__[z_offset], iz, &w[1], &ipvt[m2], np, n, ind, modo, io); if (*ind <= *iz * -10) { iibeta = 1; *ind += *iz * 10; } else { iibeta = 0; } k2 = *n - m3; if (*ind < 0 && *ind >= -k2) { *ind -= m3; } else if (*ind < -k2) { *ind -= m3 << 1; } if (iibeta == 1) { *ind -= *iz * 10; } } int anfm06_(z__, iz, r__, ir, w, ipvt, n, m, ind, io) doublereal *z__; integer *iz; doublereal *r__; integer *ir; doublereal *w; integer *ipvt, *n, *m, *ind, *io; { integer z_dim1, z_offset, r_dim1, r_offset, i__1, i__2; doublereal d__1; double pow_dd(), sqrt(); extern doublereal ddot_(), dnrm2_(); static integer i__, j, k; static doublereal s; extern int anrs01_(), dcopy_(); static integer i1, k1, m1, n1, m2, m3; extern doublereal dlamch_(); static integer nm; static doublereal epsmch; extern int dipvtf_(); static doublereal rnorma; static integer nm1; z_dim1 = *iz; z_offset = z_dim1 + 1; z__ -= z_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --w; --ipvt; d__1 = dlamch_("p", 1L); epsmch = pow_dd(&d__1, &c_b5779); n1 = *n + 1; m1 = *m + 1; m2 = m1 + 1; nm = n1 - *m; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__ + 1; s = ddot_(&i__, &r__[i__ + r_dim1], ir, &z__[z_dim1 + 1], &c__1); if (i__ < *n) { i__2 = *n - i__; w[i__] = s + ddot_(&i__2, &r__[i1 + i__ * r_dim1], &c__1, &z__[i1 + z_dim1], &c__1); } } w[*n] = s; s = ddot_(n, &w[1], &c__1, &z__[z_dim1 + 1], &c__1); k = 0; i__1 = nm + *m - 1; for (i__ = nm; i__ <= i__1; ++i__) { ++k; dcopy_(&k, &r__[(i__ + 1) * r_dim1 + 1], &c__1, &r__[i__ * r_dim1 + 1] , &c__1); } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { r__[i__ + n1 * r_dim1] = ddot_(n, &w[1], &c__1, &z__[(m2 - i__) * z_dim1 + 1], &c__1); } i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = r__[ipvt[i__] + n1 * r_dim1]; } ipvt[m1] = m1; m3 = *m - *ind; if (m3 > 0) { anrs01_(&r__[nm * r_dim1 + 1], ir, &m3, &w[1], &r__[n1 * r_dim1 + 1], &c__1, io); s -= ddot_(&m3, &r__[n1 * r_dim1 + 1], &c__1, &r__[n1 * r_dim1 + 1], & c__1); } k1 = 0; if (*ind > 0) { k = *n - *ind; if (m3 > 0) { i__1 = *ind; for (i__ = 1; i__ <= i__1; ++i__) { j = m3 + i__; r__[j + n1 * r_dim1] = w[j] - ddot_(ind, &r__[(k + i__) * r_dim1 + 1], &c__1, &r__[n1 * r_dim1 + 1], &c__1); } } else { dcopy_(ind, &w[1], &c__1, &r__[n1 * r_dim1 + 1], &c__1); } rnorma = dnrm2_(ind, &r__[m3 + 1 + n1 * r_dim1], &c__1); if (rnorma < epsmch) { k1 = 1; } } if (s > epsmch) { s = sqrt(s); r__[m1 + n1 * r_dim1] = s; if (*ind > 0) { if (k1 == 0) { i__1 = *m; for (i__ = m3 + 1; i__ <= i__1; ++i__) { r__[i__ + n1 * r_dim1] /= s; } *ind += m1 << 1; } m2 = m3 + 1; dipvtf_(&r__[nm * r_dim1 + 1], ir, &ipvt[1], &m3, &m1, &m2); nm1 = n1 - *m; r__[m2 + (m2 + *n - *m) * r_dim1] = s; i__1 = *m; for (i__ = m2; i__ <= i__1; ++i__) { r__[m2 + (i__ + nm1) * r_dim1] = r__[i__ + n1 * r_dim1]; } } } else { r__[m1 + n1 * r_dim1] = s; if (s < -epsmch) { if (*ind == 0) { *ind = -m1; } else { *ind = *ind + 1 + m1; } } else { if (*ind == 0) { *ind = 1; } else if (k1 == 1) { ++(*ind); } else { *ind = *ind + 1 + m1; } } } *m = m1; } int anrs01_(r__, ir, m, b, x, ind, io) doublereal *r__; integer *ir, *m; doublereal *b, *x; integer *ind, *io; { integer r_dim1, r_offset, i__1; extern doublereal ddot_(); static integer i__, j, k, i1, j1, j2, j3; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --b; --x; if (*ind == 1) { j = 1; } else { j = *m; } x[j] = b[j] / r__[j + j * r_dim1]; if (*m == 1) { return 0; } i__1 = *m; for (i__ = 2; i__ <= i__1; ++i__) { i1 = i__ - 1; if (*ind == 1) { j = i__; j1 = 1; j2 = i__; j3 = 1; k = 1; } else { j = *m - i1; j1 = j; j2 = j + 1; j3 = j2; k = *ir; } x[j] = (b[j] - ddot_(&i1, &r__[j1 + j2 * r_dim1], &k, &x[j3], &c__1)) / r__[j + j * r_dim1]; } } int anrs02_(a, ia, b, w, ipvt, n, io) doublereal *a; integer *ia; doublereal *b, *w; integer *ipvt, *n, *io; { integer a_dim1, a_offset, i__1; static integer i__; extern int anrs01_(); static integer ind; a_dim1 = *ia; a_offset = a_dim1 + 1; a -= a_offset; --b; --w; --ipvt; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = b[ipvt[i__]]; } ind = 1; anrs01_(&a[a_offset], ia, n, &w[1], &w[1], &ind, io); ind = 2; anrs01_(&a[a_offset], ia, n, &w[1], &w[1], &ind, io); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { b[ipvt[i__]] = w[i__]; } } int aux003_(a, ia, x, b, q, iq, r__, ir, w, ire, ipvt, nmd, mif, mdf, midf, n, m, ind, io) doublereal *a; integer *ia; doublereal *x, *b, *q; integer *iq; doublereal *r__; integer *ir; doublereal *w; integer *ire, *ipvt, *nmd, *mif, *mdf, *midf, *n, *m, *ind, *io; { integer a_dim1, a_offset, q_dim1, q_offset, r_dim1, r_offset, i__1; doublereal d__1; double pow_dd(); extern doublereal ddot_(); static integer info, i__; static doublereal s; extern int anfm01_(); static integer m1, mf, ni; extern doublereal dlamch_(); static doublereal eps; a_dim1 = *ia; a_offset = a_dim1 + 1; a -= a_offset; --x; --b; q_dim1 = *iq; q_offset = q_dim1 + 1; q -= q_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --w; --ire; --ipvt; d__1 = dlamch_("p", 1L); eps = pow_dd(&d__1, &c_b5779); mf = *midf + 1; info = 1; i__1 = *mif; for (i__ = 1; i__ <= i__1; ++i__) { if (ire[i__] != 1) { s = ddot_(n, &a[i__ * a_dim1 + 1], &c__1, &x[1], &c__1) - b[i__]; if ((( s ) >= 0 ? ( s ) : -( s )) < eps) { if (*m < *n && *ind == 0) { m1 = *m + 1; anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &a[i__ * a_dim1 + 1], &w[mf], n, &m1, ind, io); if (*ind < 0) { ire[i__] = 0; *ind = 0; } else { *m = m1; ipvt[*m] = *nmd + i__; ire[i__] = 1; } } else { if (ire[i__] != 0) { info = 0; } ire[i__] = 0; } } else if (s >= eps) { ire[i__] = 2; w[i__] = s; } else { ire[i__] = -2; w[i__] = s; } } } i__1 = *mdf; for (i__ = 1; i__ <= i__1; ++i__) { ni = *mif + i__; if (ire[ni] != 1) { s = ddot_(n, &a[ni * a_dim1 + 1], &c__1, &x[1], &c__1) - b[ni]; if (s > eps) { ire[ni] = 2; } else if (s < -eps || *ind == 1) { if (ire[ni] != 0) { info = 0; } ire[ni] = 0; } else { if (*m < *n) { m1 = *m + 1; anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &a[ni * a_dim1 + 1], &w[mf], n, &m1, ind, io); if (*ind < 0) { ire[ni] = 0; *ind = 0; } else { *m = m1; ipvt[*m] = *nmd + ni; ire[ni] = 1; } } else { ire[ni] = 0; } } w[ni] = s; } } if (*ind == 1) { *ind = info; } } int auxo01_(c__, ic, ci, cs, b, x, w, ire, ira, n, md, ind, fun, iv) doublereal *c__; integer *ic; doublereal *ci, *cs, *b, *x, *w; integer *ire, *ira, *n, *md, *ind; doublereal *fun; integer *iv; { integer c_dim1, c_offset, i__1, i__2; doublereal d__1; double pow_dd(), sqrt(); extern int ddif_(); extern doublereal ddot_(); static integer i__, ia, ij, ni; extern doublereal dlamch_(); static doublereal xi; static integer nw; static doublereal gigant, cii, csi, eps; static integer nwi; static doublereal gig1; c_dim1 = *ic; c_offset = c_dim1 + 1; c__ -= c_offset; --ci; --cs; --b; --x; --w; --ire; if (*ind == 1) { *fun = 0.; } *iv = 0; d__1 = dlamch_("p", 1L); eps = pow_dd(&d__1, &c_b5779); gigant = dlamch_("o", 1L); gig1 = sqrt(gigant); if (*ind == 1) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = 0.; } nw = *n * 3; } else { nw = 0; } if (*ira > 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xi = x[i__]; ij = 0; ia = (i__2 = ire[i__], (( i__2 ) >= 0 ? ( i__2 ) : -( i__2 )) ); if (*ira != 2) { cii = ci[i__]; if (cii >= -gig1 && ia != 1) { if (xi < cii - eps) { *iv = 1; if (*ind == 1) { *fun = *fun + cii - xi; ire[i__] = -2; w[i__] = 1.; ij = 1; } else { return 0; } } else if (*ind == 1) { ire[i__] = 0; } } } if (*ira >= 2) { csi = cs[i__]; if (csi <= gig1 && ij == 0 && ia != 1) { if (xi > csi + eps) { *iv = 1; if (*ind == 1) { *fun = *fun + xi - csi; ire[i__] = 2; w[i__] = -1.; } else { return 0; } } else if (*ind == 1) { ire[i__] = 0; } } } } } if (*md > 0) { i__1 = *md; for (i__ = 1; i__ <= i__1; ++i__) { nwi = nw + i__; ni = *n + i__; if (ire[ni] != 1) { w[nwi] = ddot_(n, &c__[i__ * c_dim1 + 1], &c__1, &x[1], &c__1) - b[i__]; if (w[nwi] > eps) { *iv = 1; if (*ind == 1) { ire[ni] = 2; ddif_(n, &c__[i__ * c_dim1 + 1], &c__1, &w[1], &c__1); *fun += w[nwi]; } else { return 0; } } else if (*ind == 1) { ire[ni] = 0; } } } } } int bfgsd_(diag, n, nt, np, y, s, ys, condm, param, zero, index) doublereal *diag; integer *n, *nt, *np; doublereal *y, *s, *ys, *condm, *param, *zero; integer *index; { integer y_dim1, y_offset, s_dim1, s_offset, i__1; doublereal d__1, d__2; double log(), pow_dd(); static doublereal dmin__, omeg, dmax__; static integer i__; static doublereal dd, dd1, ys1; static integer inp; static doublereal sds, sds1; --diag; --index; --ys; s_dim1 = *nt; s_offset = s_dim1 + 1; s -= s_offset; y_dim1 = *nt; y_offset = y_dim1 + 1; y -= y_offset; inp = index[*np]; ys1 = (float)1. / ys[inp]; sds = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = s[inp + i__ * s_dim1]; sds += diag[i__] * (d__1 * d__1); } sds1 = (float)1. / sds; dmin__ = (float)1e25; dmax__ = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dd1 = *param * diag[i__]; dd1 += *zero * (float)1e3; d__1 = y[inp + i__ * y_dim1]; d__2 = diag[i__] * s[inp + i__ * s_dim1]; dd = diag[i__] + ys1 * (d__1 * d__1) - sds1 * (d__2 * d__2); diag[i__] = dd; if (dd <= dd1) { diag[i__] = dd1; } if (diag[i__] < dmin__) { dmin__ = diag[i__]; } if (diag[i__] > dmax__) { dmax__ = diag[i__]; } } if (*condm * dmin__ / dmax__ > 1.) { return 0; } omeg = log(*condm) / log(dmax__ / dmin__); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { diag[i__] = pow_dd(&diag[i__], &omeg); } return 0; } int calbx_(n, index, indic, nt, np, y, s, ys, z__, zs, x, diag, bx) integer *n, *index, *indic, *nt, *np; doublereal *y, *s, *ys, *z__, *zs, *x, *diag, *bx; { integer y_dim1, y_offset, s_dim1, s_offset, z_dim1, z_offset, i__1, i__2; static integer i__, j, ii; static doublereal yx, zx; --bx; --diag; --x; --indic; --zs; z_dim1 = *nt; z_offset = z_dim1 + 1; z__ -= z_offset; --ys; s_dim1 = *nt; s_offset = s_dim1 + 1; s -= s_offset; y_dim1 = *nt; y_offset = y_dim1 + 1; y -= y_offset; --index; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L100; } bx[i__] = diag[i__] * x[i__]; L100: ; } i__1 = *np; for (i__ = 1; i__ <= i__1; ++i__) { ii = index[i__]; yx = 0.; zx = 0.; i__2 = *n; for (j = 1; j <= i__2; ++j) { if (indic[j] > 0) { goto L120; } yx += y[ii + j * y_dim1] * x[j]; zx += z__[ii + j * z_dim1] * x[j]; L120: ; } i__2 = *n; for (j = 1; j <= i__2; ++j) { if (indic[j] > 0) { goto L130; } bx[j] = bx[j] + yx * y[ii + j * y_dim1] / ys[ii] - zx * z__[ii + j * z_dim1] / zs[ii]; L130: ; } } return 0; } int calmaj_(dh, n, g1, sig, w, ir, mk, epsmc, nfac) doublereal *dh; integer *n; doublereal *g1, *sig, *w; integer *ir, *mk; doublereal *epsmc; integer *nfac; { integer i__1, i__2; static integer nfac1, n2fac, i__, j, k, nnfac; extern int majour_(); --w; --g1; --dh; if (*nfac == *n) { goto L50; } nfac1 = *nfac + 1; nnfac = *n - *nfac; n2fac = *nfac * nfac1 / 2; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = g1[i__] * *sig; } k = n2fac; if (*nfac == 0) { goto L25; } i__1 = *nfac; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = nfac1; i__ <= i__2; ++i__) { ++k; dh[k] += g1[i__] * w[j]; } } L25: k = n2fac + *nfac * nnfac; i__2 = *n; for (j = nfac1; j <= i__2; ++j) { i__1 = *n; for (i__ = j; i__ <= i__1; ++i__) { ++k; dh[k] += g1[i__] * w[j]; } } L50: *ir = *nfac; if (*nfac == 0) { return 0; } majour_(&dh[1], &g1[1], &w[1], nfac, sig, ir, mk, epsmc); return 0; } int desr03_(z__, iz, r__, ir, g, w, d__, alfa, ipvt, n, ng, ind, info, id, ro, io) doublereal *z__; integer *iz; doublereal *r__; integer *ir; doublereal *g, *w, *d__, *alfa; integer *ipvt, *n, *ng, *ind, *info, *id; doublereal *ro; integer *io; { integer z_dim1, z_offset, r_dim1, r_offset, i__1, i__2; doublereal d__1; double pow_dd(); extern doublereal ddot_(), dnrm2_(); static integer i__, j, k, m; static doublereal s; extern int dscal_(); static doublereal x; extern int anrs01_(), anrs02_(), dcopy_(), daxpy_(); static integer m1, n1, m2, m3, mj; extern doublereal dlamch_(); static doublereal eps; z_dim1 = *iz; z_offset = z_dim1 + 1; z__ -= z_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --g; --w; --d__; --ipvt; *id = 0; d__1 = dlamch_("p", 1L); eps = pow_dd(&d__1, &c_b5779); n1 = *n + 1; if (*ind >= 0) { *ro = 1.; if (*info == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = -ddot_(ng, &z__[(n1 - i__) * z_dim1 + 1], &c__1, &g[ 1], &c__1); } } else if (*info == 1) { x = -ddot_(ng, &z__[z_offset], &c__1, &g[1], &c__1); } else if (*info == 10) { *info = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = -w[i__]; } } } if (*ind == 0) { *id = 1; if (*info == 0) { if (*alfa != 1.) { d__1 = 1. / *alfa; dscal_(n, &d__1, &w[1], &c__1); } anrs02_(&r__[r_offset], ir, &w[1], &d__[1], &ipvt[1], n, io); } else { i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = 0.; } w[*n] = -1.; anrs01_(&r__[r_offset], ir, n, &w[1], &d__[1], &c__2, io); s = x * d__[*n]; if (s > 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[ipvt[i__]] = d__[i__]; } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[ipvt[i__]] = -d__[i__]; } s = -s; } if (*alfa != 1.) { *ro = s / *alfa; } else { *ro = s; } } } else if (*ind < -1 && *ind >= -(*n)) { m = -(*ind); m2 = m - 1; i__1 = m2; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = -r__[i__ + m * r_dim1]; } anrs01_(&r__[r_offset], ir, &m2, &d__[1], &d__[1], &c__2, io); } else if (*ind < -(*n)) { m = -(*ind) - *n; m1 = m + 1; s = r__[m + m1 * r_dim1]; i__1 = m - 1; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = s * r__[i__ + m * r_dim1] - r__[i__ + m1 * r_dim1]; } if (m > 1) { i__1 = m - 1; anrs01_(&r__[r_offset], ir, &i__1, &w[1], &d__[1], &c__2, io); } d__[m] = -s; m2 = m; } else if (*ind > 0 && *ind < *n) { k = 0; m = *n - *ind; if (*info == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[*n + i__] = w[ipvt[i__]]; } } i__1 = m; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = 0.; } i__1 = *ind; for (j = 1; j <= i__1; ++j) { mj = m + j; anrs01_(&r__[r_offset], ir, &m, &r__[mj * r_dim1 + 1], &w[1], & c__2, io); if (*info == 0) { s = ddot_(&m, &w[1], &c__1, &w[n1], &c__1) - w[mj + *n]; } else { i__ = 1; if (*n != ipvt[i__]) { L5010: ++i__; if (*n != ipvt[i__]) { goto L5010; } } if (i__ == mj) { s = -x; } else if (i__ <= m) { s = w[i__] * x; } else { s = 0.; } } if ((( s ) >= 0 ? ( s ) : -( s )) > eps) { k = 1; daxpy_(&m, &s, &w[1], &c__1, &d__[1], &c__1); d__[mj] = -s; } } if (k == 0) { *id = 1; if (*info == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[ipvt[i__]] = w[*n + i__]; } if (*alfa != 1.) { d__1 = 1 / *alfa; dscal_(n, &d__1, &w[1], &c__1); } anrs02_(&r__[r_offset], ir, &w[1], &d__[1], &ipvt[1], &m, io); i__1 = *n; for (i__ = m + 1; i__ <= i__1; ++i__) { w[ipvt[i__]] = 0.; } } else { d__[m] = -1.; i__1 = m - 1; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = 0.; } anrs01_(&r__[r_offset], ir, &m, &d__[1], &d__[1], &c__2, io); i__1 = *n; for (i__ = m + 1; i__ <= i__1; ++i__) { d__[i__] = 0.; } } } if (k == 1 || *info == 1) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[ipvt[i__]] = d__[i__]; } } } else if (*ind > *n && *ind <= *n << 1) { m = (*n << 1) - *ind; m3 = m + 1; if (m > 0) { m1 = *n - m3; i__1 = m; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = ddot_(&m1, &r__[i__ + m3 * r_dim1], ir, &r__[m3 + * n * r_dim1], &c__1) - r__[i__ + *n * r_dim1]; } anrs01_(&r__[r_offset], ir, &m, &d__[1], &d__[1], &c__2, io); } i__1 = *n - 1; for (i__ = m3; i__ <= i__1; ++i__) { d__[i__] = -r__[i__ + *n * r_dim1]; } d__[*n] = 1.; if (x < 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = -d__[i__]; } } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[ipvt[i__]] = d__[i__]; } } else if (*ind > *n << 1) { m2 = *ind - (*n << 1); m = *n - m2; m3 = m + 1; i__1 = m - 1; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = -ddot_(&m2, &r__[i__ + m3 * r_dim1], ir, &r__[m + m3 * r_dim1], ir); } s = dnrm2_(&m2, &r__[m + m3 * r_dim1], ir); d__[m] = -s * s; anrs01_(&r__[r_offset], ir, &m, &d__[1], &d__[1], &c__2, io); i__1 = *n; for (i__ = m3; i__ <= i__1; ++i__) { d__[i__] = -r__[m + i__ * r_dim1]; } s = d__[m] * x; if (s < 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = -d__[i__]; } } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[ipvt[i__]] = d__[i__]; } } if (*ind < 0) { if (*n > 1) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = 0.; } if (*ind < -1) { i__1 = m2; for (i__ = 1; i__ <= i__1; ++i__) { w[ipvt[i__]] = d__[i__]; } w[ipvt[m2 + 1]] = 1.; } } } if (*ind == *n && *info == 1) { if ((( x ) >= 0 ? ( x ) : -( x )) > eps) { i__1 = *ng; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = x * z__[i__ + z_dim1]; } } else { *id = 1; i__1 = *ng; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = 0.; } } } else if (*ind == -1) { dcopy_(ng, &z__[(n1 - ipvt[1]) * z_dim1 + 1], &c__1, &d__[1], &c__1); } else { if (*ind == *n) { s = dnrm2_(n, &w[1], &c__1); if (s <= eps) { *id = 1; i__1 = *ng; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = 0.; } } } if (*ind != *n || *ind == *n && *id == 0) { i__1 = *ng; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = -(*iz); d__[i__] = ddot_(n, &z__[i__ + z_dim1], &i__2, &w[1], &c__1); } } } if (*ind < 0 || *id == 1 && *info == 1 && *ind > 0) { s = ddot_(ng, &d__[1], &c__1, &g[1], &c__1); if (*id == 1) { if (s > 0.) { i__2 = *ng; for (i__ = 1; i__ <= i__2; ++i__) { d__[i__] = -d__[i__]; } } else { s = -s; } if (*alfa != 1.) { *ro = s / *alfa; } else { *ro = s; } } else if (s > 0.) { i__2 = *ng; for (i__ = 1; i__ <= i__2; ++i__) { d__[i__] = -d__[i__]; } } } } int dimp03_(x, w, ire, ipvt, s, i1, i2, i3, i4, i5, i6, i7, i8, i9, ind, imp, io, iter) doublereal *x, *w; integer *ire, *ipvt; doublereal *s; integer *i1, *i2, *i3, *i4, *i5, *i6, *i7, *i8, *i9, *ind, *imp, *io, *iter; { static char fmt_5000[] = "(//,10x,a,(t31,sp,e22.16))"; static char fmt_4000[] = "(////,80(\002-\002),///,10x,\002ITERATION: \002,i4)"; static char fmt_3000[] = "(///,10x,a,i4)"; static char fmt_8000[] = "(//,10x,a,//,(10x,11(2x,i4),/))"; static char fmt_1000[] = "(////,80(\002*\002),///,10x,a,2(/,10x,a),i5)"; static char fmt_7000[] = "(/,10x,a,e22.16)"; static char fmt_9000[] = "(/,10x,a,/,(10x,4(2x,e14.8)))"; static char fmt_2000[] = "(////,80(\002*\002),///,10x,a,/,10x,a,i5)"; static char fmt_6000[] = "(/,10x,a,t41,e22.16)"; integer i__1; int s_copy(); integer s_wsfe(), do_fio(), e_wsfe(); extern doublereal dnrm0_(); static integer i__, j; static doublereal s1; static integer ii2, ii7; static char car[30]; static cilist io___1968 = { 0, 0, 0, fmt_5000, 0 }; static cilist io___1970 = { 0, 0, 0, fmt_4000, 0 }; static cilist io___1972 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1973 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1975 = { 0, 0, 0, fmt_8000, 0 }; static cilist io___1976 = { 0, 0, 0, fmt_8000, 0 }; static cilist io___1977 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1978 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1979 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1980 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1982 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1983 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___1984 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1985 = { 0, 0, 0, fmt_5000, 0 }; static cilist io___1986 = { 0, 0, 0, fmt_7000, 0 }; static cilist io___1987 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1988 = { 0, 0, 0, fmt_8000, 0 }; static cilist io___1989 = { 0, 0, 0, fmt_9000, 0 }; static cilist io___1990 = { 0, 0, 0, fmt_7000, 0 }; static cilist io___1991 = { 0, 6, 0, fmt_1000, 0 }; static cilist io___1992 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___1993 = { 0, 0, 0, fmt_2000, 0 }; static cilist io___1994 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___1995 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___1996 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___1997 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___1998 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___1999 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2000 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___2002 = { 0, 0, 0, fmt_6000, 0 }; static cilist io___2003 = { 0, 0, 0, fmt_6000, 0 }; static cilist io___2004 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___2005 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2006 = { 0, 0, 0, fmt_3000, 0 }; --ipvt; --ire; --w; --x; s_copy(car, "END OF OPTR03.", 30L, 14L); if (*ind == 2) { if (*imp >= 10) { io___1968.ciunit = *io; s_wsfe(&io___1968); do_fio(&c__1, "POINT COMPUTED: ", 16L); i__1 = *i1; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal)); } e_wsfe(); } io___1970.ciunit = *io; s_wsfe(&io___1970); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); e_wsfe(); if (*i2 != 0) { ii2 = *i2; if (*i2 > *i1) { ii2 = *i2 + *i9; } io___1972.ciunit = *io; s_wsfe(&io___1972); do_fio(&c__1, "DELETED CONSTRAINT: ", 20L); do_fio(&c__1, (char *)&ii2, (ftnlen)sizeof(integer)); e_wsfe(); } io___1973.ciunit = *io; s_wsfe(&io___1973); do_fio(&c__1, "NUMBER OF ACTIVE CONSTRAINTS:", 29L); do_fio(&c__1, (char *)&(*i3), (ftnlen)sizeof(integer)); e_wsfe(); i__1 = *i9; for (i__ = 1; i__ <= i__1; ++i__) { ipvt[i__] += *i1; } i__1 = *i3; for (i__ = *i9 + 1; i__ <= i__1; ++i__) { j = ipvt[i__]; if (j > *i1) { ipvt[i__] = j + *i8; } } io___1975.ciunit = *io; s_wsfe(&io___1975); do_fio(&c__1, "ACTIVE CONSTRAINTS:", 19L); i__1 = *i3; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&ipvt[i__], (ftnlen)sizeof(integer)); } e_wsfe(); i__1 = *i9; for (i__ = 1; i__ <= i__1; ++i__) { ipvt[i__] -= *i1; } i__1 = *i3; for (i__ = *i9 + 1; i__ <= i__1; ++i__) { j = ipvt[i__]; if (j > *i1) { ipvt[i__] = j - *i8; } } if (*i4 > 0) { io___1976.ciunit = *io; s_wsfe(&io___1976); do_fio(&c__1, "-CONSTRAINTS ASSOCIATED TO THE OBJECTIVE FUNCTION:" , 50L); i__1 = *i4; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&ire[i__], (ftnlen)sizeof(integer)); } e_wsfe(); } if (*i5 == 1) { io___1977.ciunit = *io; s_wsfe(&io___1977); do_fio(&c__1, "A DESCENT DIRECTION OF POSITIVE CURVATURE HAS BEEN COMPUTED.", 60L); e_wsfe(); } else if (*i5 == 0) { io___1978.ciunit = *io; s_wsfe(&io___1978); do_fio(&c__1, "A DESCENT DIRECTION OF NULL CURVATURE HAS BEEN COMPUTED.", 56L); e_wsfe(); } else { io___1979.ciunit = *io; s_wsfe(&io___1979); do_fio(&c__1, "A DESCENT DIRECTION OF NEGATIVE CURVATURE HAS BEEN COMPUTED.", 60L); e_wsfe(); } if (*i6 != 0) { io___1980.ciunit = *io; s_wsfe(&io___1980); do_fio(&c__1, "A DEGENERATED POINT HAS BEEN COMPUTED.", 38L); e_wsfe(); } if (*i7 != 0) { ii7 = *i7; if (ii7 > *i1) { ii7 += *i9; } io___1982.ciunit = *io; s_wsfe(&io___1982); do_fio(&c__1, "ADDED CONSTRAINT: ", 18L); do_fio(&c__1, (char *)&ii7, (ftnlen)sizeof(integer)); e_wsfe(); } } else if (*ind == 0) { io___1983.ciunit = *io; s_wsfe(&io___1983); do_fio(&c__1, car, 30L); do_fio(&c__1, "A LOCAL MINIMUM HAS BEEN FOUND.", 31L); e_wsfe(); if (*imp >= 8) { io___1984.ciunit = *io; s_wsfe(&io___1984); do_fio(&c__1, "NUMBER OF ITERATIONS: ", 22L); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); e_wsfe(); io___1985.ciunit = *io; s_wsfe(&io___1985); do_fio(&c__1, "POINT COMPUTED: ", 16L); i__1 = *i1; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal)); } e_wsfe(); io___1986.ciunit = *io; s_wsfe(&io___1986); do_fio(&c__1, "NORM OF THE KUHN-TUCKER VECTOR: ", 32L); do_fio(&c__1, (char *)&(*s), (ftnlen)sizeof(doublereal)); e_wsfe(); io___1987.ciunit = *io; s_wsfe(&io___1987); do_fio(&c__1, "NUMBER OF ACTIVE CONSTRAINTS:", 29L); do_fio(&c__1, (char *)&(*i2), (ftnlen)sizeof(integer)); e_wsfe(); i__1 = *i9; for (i__ = 1; i__ <= i__1; ++i__) { ipvt[i__] += *i1; } i__1 = *i2; for (i__ = *i9 + 1; i__ <= i__1; ++i__) { j = ipvt[i__]; if (j > *i1) { ipvt[i__] = j + *i8; } } io___1988.ciunit = *io; s_wsfe(&io___1988); do_fio(&c__1, "ACTIVE CONSTRAINTS:", 19L); i__1 = *i2; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&ipvt[i__], (ftnlen)sizeof(integer)); } e_wsfe(); i__1 = *i9; for (i__ = 1; i__ <= i__1; ++i__) { ipvt[i__] -= *i1; } i__1 = *i2; for (i__ = *i9 + 1; i__ <= i__1; ++i__) { j = ipvt[i__]; if (j > *i1) { ipvt[i__] = j - *i8; } } io___1989.ciunit = *io; s_wsfe(&io___1989); do_fio(&c__1, "LAGRANGE MULTIPLIERS:", 21L); i__1 = *i3 + *i2 - 1; for (i__ = *i3; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&w[i__], (ftnlen)sizeof(doublereal)); } e_wsfe(); if (*i4 != 0) { io___1990.ciunit = *io; s_wsfe(&io___1990); do_fio(&c__1, "OBJECTIVE FUNCTION: ", 20L); do_fio(&c__1, (char *)&w[*i4], (ftnlen)sizeof(doublereal)); e_wsfe(); } } } else if (*ind == -4) { if (*io <= 0) { s_wsfe(&io___1991); do_fio(&c__1, car, 30L); do_fio(&c__1, "INVALID NUMBER FOR THE OUTPUT CHANEL NUMBER.", 44L) ; e_wsfe(); } else if (*imp >= 7) { io___1992.ciunit = *io; s_wsfe(&io___1992); do_fio(&c__1, car, 30L); do_fio(&c__1, "INVALID INTEGER VARIABLES.", 26L); e_wsfe(); } } else if (*ind == -24) { io___1993.ciunit = *io; s_wsfe(&io___1993); do_fio(&c__1, car, 30L); do_fio(&c__1, "CI(I).GT.CS(I) FOR I= ", 22L); do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer)); e_wsfe(); } else if (*ind == -34) { io___1994.ciunit = *io; s_wsfe(&io___1994); do_fio(&c__1, car, 30L); do_fio(&c__1, "INCORRECT VECTOR IRE.", 21L); e_wsfe(); } else if (*ind < -10) { io___1995.ciunit = *io; s_wsfe(&io___1995); do_fio(&c__1, car, 30L); do_fio(&c__1, "OPTR01 HAS NOT FOUND A FEASIBLE POINT.IND OF", 44L); do_fio(&c__1, "OPTR01=", 7L); i__1 = *ind + 10; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfe(); } else if (*ind == -1) { io___1996.ciunit = *io; s_wsfe(&io___1996); do_fio(&c__1, car, 30L); do_fio(&c__1, "PROBLEM UNBOUNDED FROM BELOW", 28L); e_wsfe(); } else if (*ind == -2) { io___1997.ciunit = *io; s_wsfe(&io___1997); do_fio(&c__1, car, 30L); do_fio(&c__1, "A DEGENERATED POINT CYCLING HAS BEEN FOUND.", 43L); e_wsfe(); if (*imp >= 8) { io___1998.ciunit = *io; s_wsfe(&io___1998); do_fio(&c__1, "NUMBER OF ITERATIONS:", 21L); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); e_wsfe(); } } else if (*ind == -3) { io___1999.ciunit = *io; s_wsfe(&io___1999); do_fio(&c__1, car, 30L); do_fio(&c__1, "THE DISTANCE BETWEEN THE POINTS OF TWO CONSECUTIVE ITERATIONS ", 62L); do_fio(&c__1, "IS \"TOO BIG\".", 13L); e_wsfe(); io___2000.ciunit = *io; s_wsfe(&io___2000); do_fio(&c__1, "PROBABLY PROBLEM UNBOUNDED FROM BELOW.", 38L); e_wsfe(); if (*imp >= 8) { s1 = dnrm0_(i1, &x[1], &c__1); io___2002.ciunit = *io; s_wsfe(&io___2002); do_fio(&c__1, "-NORM OF THE POINT COMPUTED:", 28L); do_fio(&c__1, (char *)&s1, (ftnlen)sizeof(doublereal)); e_wsfe(); io___2003.ciunit = *io; s_wsfe(&io___2003); do_fio(&c__1, "-OBJECTIVE FUNCTION:", 20L); do_fio(&c__1, (char *)&w[*i2], (ftnlen)sizeof(doublereal)); e_wsfe(); io___2004.ciunit = *io; s_wsfe(&io___2004); do_fio(&c__1, "NUMBER OF ITERATIONS:", 21L); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); e_wsfe(); } } else if (*ind == 1) { io___2005.ciunit = *io; s_wsfe(&io___2005); do_fio(&c__1, car, 30L); do_fio(&c__1, "THE LIMIT FOR THE ITERATION NUMBER HAS BEEN PASSED.", 51L); e_wsfe(); if (*imp >= 8) { io___2006.ciunit = *io; s_wsfe(&io___2006); do_fio(&c__1, "NUMBER OF ITERATIONS:", 21L); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); e_wsfe(); } } } int dipvtf_(r__, ir, ipvt, n, i1, i2) doublereal *r__; integer *ir, *ipvt, *n, *i1, *i2; { integer r_dim1, r_offset; static integer i__; extern int dswap_(); r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --ipvt; if (*i1 == *i2) { return 0; } dswap_(n, &r__[*i1 * r_dim1 + 1], &c__1, &r__[*i2 * r_dim1 + 1], &c__1); i__ = ipvt[*i1]; ipvt[*i1] = ipvt[*i2]; ipvt[*i2] = i__; } doublereal dnrm0_(n, x, incx) integer *n; doublereal *x; integer *incx; { doublereal ret_val, d__1; static integer i__; extern integer idamax_(); --x; ret_val = 0.; if (*n < 1) { return ret_val; } i__ = idamax_(n, &x[1], incx); ret_val = (d__1 = x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); return ret_val; } int dogleg_(n, r__, lr, diag, qtb, delta, x, wa1, wa2) integer *n; doublereal *r__; integer *lr; doublereal *diag, *qtb, *delta, *x, *wa1, *wa2; { static doublereal one = 1.; static doublereal zero = 0.; integer i__1, i__2; doublereal d__1, d__2, d__3, d__4; double sqrt(); static doublereal temp; static integer i__, j, k, l; static doublereal alpha, bnorm; extern doublereal enorm_(); static doublereal gnorm, qnorm; static integer jj; extern doublereal dlamch_(); static doublereal epsmch, sgnorm; static integer jp1; static doublereal sum; --wa2; --wa1; --x; --qtb; --diag; --r__; epsmch = dlamch_("p", 1L); jj = *n * (*n + 1) / 2 + 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { j = *n - k + 1; jp1 = j + 1; jj -= k; l = jj + 1; sum = zero; if (*n < jp1) { goto L20; } i__2 = *n; for (i__ = jp1; i__ <= i__2; ++i__) { sum += r__[l] * x[i__]; ++l; } L20: temp = r__[jj]; if (temp != zero) { goto L40; } l = j; i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { d__2 = temp, d__3 = (d__1 = r__[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); temp = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; l = l + *n - i__; } temp = epsmch * temp; if (temp == zero) { temp = epsmch; } L40: x[j] = (qtb[j] - sum) / temp; } i__1 = *n; for (j = 1; j <= i__1; ++j) { wa1[j] = zero; wa2[j] = diag[j] * x[j]; } qnorm = enorm_(n, &wa2[1]); if (qnorm <= *delta) { goto L140; } l = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = qtb[j]; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { wa1[i__] += r__[l] * temp; ++l; } wa1[j] /= diag[j]; } gnorm = enorm_(n, &wa1[1]); sgnorm = zero; alpha = *delta / qnorm; if (gnorm == zero) { goto L120; } i__1 = *n; for (j = 1; j <= i__1; ++j) { wa1[j] = wa1[j] / gnorm / diag[j]; } l = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = zero; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { sum += r__[l] * wa1[i__]; ++l; } wa2[j] = sum; } temp = enorm_(n, &wa2[1]); sgnorm = gnorm / temp / temp; alpha = zero; if (sgnorm >= *delta) { goto L120; } bnorm = enorm_(n, &qtb[1]); temp = bnorm / gnorm * (bnorm / qnorm) * (sgnorm / *delta); d__1 = sgnorm / *delta; d__2 = temp - *delta / qnorm; d__3 = *delta / qnorm; d__4 = sgnorm / *delta; temp = temp - *delta / qnorm * (d__1 * d__1) + sqrt(d__2 * d__2 + (one - d__3 * d__3) * (one - d__4 * d__4)); d__1 = sgnorm / *delta; alpha = *delta / qnorm * (one - d__1 * d__1) / temp; L120: temp = (one - alpha) * (( sgnorm ) <= ( *delta ) ? ( sgnorm ) : ( *delta )) ; i__1 = *n; for (j = 1; j <= i__1; ++j) { x[j] = temp * wa1[j] + alpha * x[j]; } L140: return 0; } doublereal enorm_(n, x) integer *n; doublereal *x; { static doublereal one = 1.; static doublereal zero = 0.; static doublereal rdwarf = 3.834e-20; static doublereal rgiant = 1.304e19; integer i__1; doublereal ret_val, d__1; double sqrt(); static doublereal xabs, x1max, x3max; static integer i__; static doublereal s1, s2, s3, agiant, floatn; --x; s1 = zero; s2 = zero; s3 = zero; x1max = zero; x3max = zero; floatn = (doublereal) (*n); agiant = rgiant / floatn; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xabs = (d__1 = x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (xabs > rdwarf && xabs < agiant) { goto L70; } if (xabs <= rdwarf) { goto L30; } if (xabs <= x1max) { goto L10; } d__1 = x1max / xabs; s1 = one + s1 * (d__1 * d__1); x1max = xabs; goto L20; L10: d__1 = xabs / x1max; s1 += d__1 * d__1; L20: goto L60; L30: if (xabs <= x3max) { goto L40; } d__1 = x3max / xabs; s3 = one + s3 * (d__1 * d__1); x3max = xabs; goto L50; L40: if (xabs != zero) { d__1 = xabs / x3max; s3 += d__1 * d__1; } L50: L60: goto L80; L70: d__1 = xabs; s2 += d__1 * d__1; L80: ; } if (s1 == zero) { goto L100; } ret_val = x1max * sqrt(s1 + s2 / x1max / x1max); goto L130; L100: if (s2 == zero) { goto L110; } if (s2 >= x3max) { ret_val = sqrt(s2 * (one + x3max / s2 * (x3max * s3))); } if (s2 < x3max) { ret_val = sqrt(x3max * (s2 / x3max + x3max * s3)); } goto L120; L110: ret_val = x3max * sqrt(s3); L120: L130: return ret_val; } int fdjac1_(fcn, n, x, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn, wa1, wa2) int (*fcn) (); integer *n; doublereal *x, *fvec, *fjac; integer *ldfjac, *iflag, *ml, *mu; doublereal *epsfcn, *wa1, *wa2; { static doublereal zero = 0.; integer fjac_dim1, fjac_offset, i__1, i__2, i__3, i__4; doublereal d__1; double sqrt(); static doublereal temp; static integer msum; static doublereal h__; static integer i__, j, k; extern doublereal dlamch_(); static doublereal epsmch, eps; --wa2; --wa1; --fvec; --x; fjac_dim1 = *ldfjac; fjac_offset = fjac_dim1 + 1; fjac -= fjac_offset; epsmch = dlamch_("p", 1L); eps = sqrt(((( *epsfcn ) >= ( epsmch ) ? ( *epsfcn ) : ( epsmch )) )); msum = *ml + *mu + 1; if (msum < *n) { goto L40; } i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[j]; h__ = eps * (( temp ) >= 0 ? ( temp ) : -( temp )) ; if (h__ == zero) { h__ = eps; } x[j] = temp + h__; (*fcn)(n, &x[1], &wa1[1], iflag); if (*iflag < 0) { goto L30; } x[j] = temp; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { fjac[i__ + j * fjac_dim1] = (wa1[i__] - fvec[i__]) / h__; } } L30: goto L110; L40: i__1 = msum; for (k = 1; k <= i__1; ++k) { i__2 = *n; i__3 = msum; for (j = k; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) { wa2[j] = x[j]; h__ = eps * (d__1 = wa2[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (h__ == zero) { h__ = eps; } x[j] = wa2[j] + h__; } (*fcn)(n, &x[1], &wa1[1], iflag); if (*iflag < 0) { goto L100; } i__3 = *n; i__2 = msum; for (j = k; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) { x[j] = wa2[j]; h__ = eps * (d__1 = wa2[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (h__ == zero) { h__ = eps; } i__4 = *n; for (i__ = 1; i__ <= i__4; ++i__) { fjac[i__ + j * fjac_dim1] = zero; if (i__ >= j - *mu && i__ <= j + *ml) { fjac[i__ + j * fjac_dim1] = (wa1[i__] - fvec[i__]) / h__; } } } } L100: L110: return 0; } int fdjac2_(fcn, m, n, x, fvec, fjac, ldfjac, iflag, epsfcn, wa) int (*fcn) (); integer *m, *n; doublereal *x, *fvec, *fjac; integer *ldfjac, *iflag; doublereal *epsfcn, *wa; { static doublereal zero = 0.; integer fjac_dim1, fjac_offset, i__1, i__2; double sqrt(); static doublereal temp, h__; static integer i__, j; extern doublereal dlamch_(); static doublereal epsmch, eps; --wa; --fvec; --x; fjac_dim1 = *ldfjac; fjac_offset = fjac_dim1 + 1; fjac -= fjac_offset; epsmch = dlamch_("p", 1L); eps = sqrt(((( *epsfcn ) >= ( epsmch ) ? ( *epsfcn ) : ( epsmch )) )); i__1 = *n; for (j = 1; j <= i__1; ++j) { temp = x[j]; h__ = eps * (( temp ) >= 0 ? ( temp ) : -( temp )) ; if (h__ == zero) { h__ = eps; } x[j] = temp + h__; (*fcn)(m, n, &x[1], &wa[1], iflag); if (*iflag < 0) { goto L30; } x[j] = temp; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { fjac[i__ + j * fjac_dim1] = (wa[i__] - fvec[i__]) / h__; } } L30: return 0; } int ffinf1_(n, nv, jc, xpr, p, s) integer *n, *nv, *jc; doublereal *xpr, *p, *s; { integer i__1, i__2; static integer i__, j, k; static doublereal ps; static integer nij; --s; --xpr; --jc; --p; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ps = 0.; i__2 = *nv; for (k = 1; k <= i__2; ++k) { j = jc[k] - 1; if (j == 0) { goto L910; } nij = (j - 1) * *n + i__; ps += xpr[k] * p[nij]; L910: ; } s[i__] = ps; } return 0; } int fmulb1_(n, h__, x, hx, tabaux, nmisaj, prosca, izs, rzs, dzs) integer *n; doublereal *h__, *x, *hx, *tabaux; integer *nmisaj; int (*prosca) (); integer *izs; real *rzs; doublereal *dzs; { integer i__1; static integer ptnu, k; static doublereal gamma, sigma; static integer compt, is, iu; static doublereal mu, nu, sscalx, uscalx; static integer memsup; static doublereal eta; --tabaux; --hx; --x; --h__; --izs; --rzs; --dzs; memsup = (*n << 1) + 2; i__1 = *n; for (k = 1; k <= i__1; ++k) { hx[k] = x[k]; } if (*nmisaj == 0) { return 0; } else { ptnu = 1; compt = 1; } L2000: iu = ptnu + 1; is = iu + *n; i__1 = *n; for (k = 1; k <= i__1; ++k) { tabaux[k] = h__[iu + k]; } (*prosca)(n, &tabaux[1], &x[1], &uscalx, &izs[1], &rzs[1], &dzs[1]); i__1 = *n; for (k = 1; k <= i__1; ++k) { tabaux[k] = h__[is + k]; } (*prosca)(n, &tabaux[1], &x[1], &sscalx, &izs[1], &rzs[1], &dzs[1]); nu = h__[ptnu]; eta = h__[ptnu + 1]; if (compt == 1) { gamma = eta / nu; i__1 = *n; for (k = 1; k <= i__1; ++k) { hx[k] = gamma * hx[k]; } mu = sscalx / nu; sigma = -(sscalx * 2. / eta) + uscalx / nu; } else { mu = sscalx / eta; sigma = -(nu / eta + 1.) * mu + uscalx / eta; } i__1 = *n; for (k = 1; k <= i__1; ++k) { hx[k] = hx[k] - mu * h__[iu + k] - sigma * h__[is + k]; } ++compt; if (compt <= *nmisaj) { ptnu += memsup; goto L2000; } else { return 0; } } int fmuls1_(n, h__, x, hx) integer *n; doublereal *h__, *x, *hx; { integer i__1, i__2; static integer j, k, kj, km1; static doublereal aux1; --hx; --x; --h__; i__1 = *n; for (k = 1; k <= i__1; ++k) { aux1 = 0.; kj = k; km1 = k - 1; if (km1 >= 1) { i__2 = km1; for (j = 1; j <= i__2; ++j) { aux1 += h__[kj] * x[j]; kj += *n - j; } } i__2 = *n; for (j = k; j <= i__2; ++j) { aux1 += h__[kj] * x[j]; ++kj; } hx[k] = aux1; } return 0; } int fpq2_(inout, x, cx, fx, gx, d__, sthalf, penlty, iyflag, y, cy, fy, gy, z__, cz, fz, gz, gg, hh, s) integer *inout; doublereal *x, *cx, *fx, *gx, *d__, *sthalf, *penlty; integer *iyflag; doublereal *y, *cy, *fy, *gy, *z__, *cz, *fz, *gz, *gg, *hh, *s; { static doublereal zero = 0.; static doublereal half = .5; doublereal d__1, d__2; double d_sign(); static doublereal absd, p, denom, absgx, smallh, dlower, dupper, gyplus, xminsy; absd = (( *d__ ) >= 0 ? ( *d__ ) : -( *d__ )) ; if (*inout == 0) { *iyflag = 0; *gg = zero; *hh = zero; *s = absd; if (*sthalf <= zero || *sthalf >= half) { *sthalf = half * half; } if (*penlty <= zero) { *penlty = half + half; } if (*gx != zero) { *d__ = -d_sign(&absd, gx); } *inout = 1; } else { if (*cz > zero || *fz >= *fx) { *inout = 3; if (*iyflag == 0) { *gg = (*gz - *gx) / *d__; *hh = *gg; *s = *sthalf / absd; *iyflag = 1; } else { *hh = (*gz - *gy) / (*d__ - (*y - *x)); } *y = *z__; *cy = *cz; *fy = *fz; *gy = *gz; } else { if (*gx * *gz < zero) { *inout = 2; *hh = *gg; if (*iyflag == 0) { *gg = (*gz - *gx) / *d__; *s = *sthalf / absd; *iyflag = 1; } else { *gg = (*gz - *gy) / (*d__ - (*y - *x)); } *y = *x; *cy = *cx; *fy = *fx; *gy = *gx; } else { *inout = 1; *gg = (*gz - *gx) / *d__; } *x = *z__; *cx = *cz; *fx = *fz; *gx = *gz; } if (*iyflag == 0) { dlower = *s; dupper = absd / *sthalf; xminsy = -(*d__); } else { xminsy = *x - *y; smallh = (( zero ) <= ( *hh ) ? ( zero ) : ( *hh )) * xminsy * half; gyplus = *gy + smallh; p = *fx - *fy - gyplus * xminsy; denom = (d__1 = gyplus + smallh - *gx, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (p >= zero) { goto L500; } p = zero; *s = *sthalf / (( xminsy ) >= 0 ? ( xminsy ) : -( xminsy )) ; L500: dlower = *s * xminsy * xminsy; dupper = (( xminsy ) >= 0 ? ( xminsy ) : -( xminsy )) - dlower; if ((( p ) >= 0 ? ( p ) : -( p )) < denom * dupper) { d__1 = dlower, d__2 = p / denom; dupper = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } } absgx = (( *gx ) >= 0 ? ( *gx ) : -( *gx )) ; absd = dupper; if (absgx < *gg * dupper) { d__1 = dlower, d__2 = absgx / *gg; absd = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } *d__ = -d_sign(&absd, &xminsy); } *z__ = *x + *d__; return 0; } int fprf2_(iflag, ntot, nv, io, zero, s2, eps, al, imp, u, eta, mm1, jc, ic, r__, a, e, rr, xpr, y, w1, w2) integer *iflag, *ntot, *nv, *io; doublereal *zero, *s2, *eps, *al; integer *imp; doublereal *u, *eta; integer *mm1, *jc, *ic; doublereal *r__, *a, *e, *rr, *xpr, *y, *w1, *w2; { static char fmt_1001[] = "(\002 epsilon smaller than a\002)"; static char fmt_1003[] = "(\002 a=\002,10d10.3,/(6x,10d10.3))"; static char fmt_1004[] = "(\002 (g,g)=\002,10d10.3,/(7x,10d10.3))"; static char fmt_1005[] = "(\002 start with variables 1 and\002,i4)"; static char fmt_1006[] = "(\002 (s,s)=\002,d12.4,\002 variable\002,i4,\002 (\002,d12.4,\002) coming in.\002)"; static char fmt_1007[] = "(\002 variable\002,i4,\002 (\002,i4,\002) =\002,d11.3,\002 going out.\002,\002 feasible (s,s)=\002,d11.4,\002 unfeasible=\002,d11.4)"; static char fmt_1008[] = "(\002 initial corral\002/(20i6))"; static char fmt_1010[] = "(\002 epsilon =\002,d10.3)"; static char fmt_1011[] = "(\002 x=\002,10d11.3,/(3x,10d11.3))"; static char fmt_1012[] = "(\002 choleski,\002,10d11.3,/(10x,10d11.3))"; static char fmt_1013[] = "(\002 duplicate variable \002,i3)"; static char fmt_1014[] = "(\002 finished with\002,i3,\002 gradients\002,i3,\002 variables.\002/\002 (s,s)=\002,d11.4,\002 test=\002,d11.4/\002 cost of the extra constraint u=\002,d12.5)"; static char fmt_1015[] = "(20i6)"; static char fmt_1016[] = "(\002 fprf2 is apparently looping\002)"; static char fmt_1018[] = "(//)"; static char fmt_1019[] = "(\002 error from fprf2. old solution already optimal\002)"; static char fmt_1020[] = "(\002 (s,s)=\002,d12.4,\002 u1=\002,d12.3,\002 variable 1 coming in.\002)"; integer i__1, i__2, i__3, i__4; doublereal d__1; integer s_wsfe(), do_fio(), e_wsfe(); double sqrt(); static doublereal gama; static integer mek01, mekk, incr; static doublereal teta; static integer ment, i__, j, k, l, niter, itmax, j0, j1, j2, k1, k0; static doublereal u2, v1, v2; static integer k00, jj, jk, kk; static doublereal ps, sp; static integer nt1; static doublereal ps1; static integer nv1; static doublereal ps0, ps2, w1s, w2s; static integer mej, mek; static doublereal det, dmu, ps12, w12s; static cilist io___2097 = { 0, 0, 0, fmt_1003, 0 }; static cilist io___2099 = { 0, 0, 0, fmt_1010, 0 }; static cilist io___2101 = { 0, 0, 0, fmt_1004, 0 }; static cilist io___2103 = { 0, 0, 0, fmt_1008, 0 }; static cilist io___2109 = { 0, 0, 0, fmt_1019, 0 }; static cilist io___2111 = { 0, 0, 0, fmt_1001, 0 }; static cilist io___2113 = { 0, 0, 0, fmt_1005, 0 }; static cilist io___2114 = { 0, 0, 0, fmt_1011, 0 }; static cilist io___2115 = { 0, 0, 0, fmt_1016, 0 }; static cilist io___2120 = { 0, 0, 0, fmt_1006, 0 }; static cilist io___2121 = { 0, 0, 0, fmt_1020, 0 }; static cilist io___2123 = { 0, 0, 0, fmt_1013, 0 }; static cilist io___2128 = { 0, 0, 0, fmt_1012, 0 }; static cilist io___2130 = { 0, 0, 0, fmt_1012, 0 }; static cilist io___2138 = { 0, 0, 0, fmt_1007, 0 }; static cilist io___2142 = { 0, 0, 0, fmt_1014, 0 }; static cilist io___2143 = { 0, 0, 0, fmt_1015, 0 }; static cilist io___2144 = { 0, 0, 0, fmt_1018, 0 }; --al; --w2; --w1; --y; --xpr; --rr; --e; --a; --ic; --jc; --r__; niter = 0; nt1 = *ntot + 1; itmax = *ntot * 10; incr = 0; k00 = 1; w1s = 0.; w2s = 0.; w12s = 0.; gama = .99; if (*imp <= 7) { goto L100; } io___2097.ciunit = *io; s_wsfe(&io___2097); i__1 = nt1; for (j = 1; j <= i__1; ++j) { do_fio(&c__1, (char *)&a[j], (ftnlen)sizeof(doublereal)); } e_wsfe(); io___2099.ciunit = *io; s_wsfe(&io___2099); do_fio(&c__1, (char *)&(*eps), (ftnlen)sizeof(doublereal)); e_wsfe(); i__1 = nt1; for (j = 1; j <= i__1; ++j) { mej = (j - 1) * *mm1; io___2101.ciunit = *io; s_wsfe(&io___2101); i__2 = j; for (jj = 1; jj <= i__2; ++jj) { do_fio(&c__1, (char *)&r__[mej + jj], (ftnlen)sizeof(doublereal)); } e_wsfe(); } L100: if (*iflag != 3) { goto L110; } if (*imp > 6) { io___2103.ciunit = *io; s_wsfe(&io___2103); i__1 = *nv; for (k = 1; k <= i__1; ++k) { do_fio(&c__1, (char *)&jc[k], (ftnlen)sizeof(integer)); } e_wsfe(); } j0 = nt1; ps = fprf2c_ .u1 * (a[nt1] - *eps); ment = (nt1 - 1) * *mm1; i__1 = *nv; for (k = 1; k <= i__1; ++k) { jk = ment + jc[k]; ps += xpr[k] * r__[jk]; } if (ps < *s2) { goto L107; } if (*imp > 0) { io___2109.ciunit = *io; s_wsfe(&io___2109); e_wsfe(); } *iflag = 1; return 0; L107: ++(*nv); ++ fprf2c_ .nc; jc[*nv] = j0; niter = 1; goto L300; L110: if (*iflag <= 1) { goto L140; } i__1 = nt1; for (i__ = 1; i__ <= i__1; ++i__) { ic[i__] = 0; } i__1 = *nv; for (k = 1; k <= i__1; ++k) { jk = jc[k]; ic[jk] = 1; } ic[nt1] = 1; L140: jc[1] = 1; *nv = 2; fprf2c_ .nc = 1; jc[2] = 0; i__1 = nt1; for (j = 2; j <= i__1; ++j) { if (a[j] > *eps) { goto L150; } jc[2] = j; L150: ; } if (jc[2] > 0) { goto L160; } if (*imp > 0) { io___2111.ciunit = *io; s_wsfe(&io___2111); e_wsfe(); } *iflag = 2; return 0; L160: j = jc[2]; rr[1] = 1.; jj = (j - 1) * *mm1 + j; ps = r__[jj] + 1.; if (ps > 0.) { goto L170; } *iflag = 3; return 0; L170: rr[2] = sqrt(ps); r__[2] = a[j]; i__1 = nt1; for (i__ = 1; i__ <= i__1; ++i__) { xpr[i__] = 0.; } xpr[1] = *eps - a[j]; xpr[2] = 1.; fprf2c_ .u1 = 0.; u2 = -r__[jj]; if (*imp > 6) { io___2113.ciunit = *io; s_wsfe(&io___2113); do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); e_wsfe(); } L200: ++niter; if (*imp > 6) { io___2114.ciunit = *io; s_wsfe(&io___2114); i__1 = *nv; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&xpr[i__], (ftnlen)sizeof(doublereal)); } e_wsfe(); } if (niter <= itmax) { goto L205; } if (*imp > 0) { io___2115.ciunit = *io; s_wsfe(&io___2115); e_wsfe(); } *iflag = 4; return 0; L205: *s2 = -(*eps) * fprf2c_ .u1 - u2; if (*s2 <= *eta) { goto L900; } sp = gama * *s2; j0 = 0; i__1 = nt1; for (j = 2; j <= i__1; ++j) { ps = fprf2c_ .u1 * (a[j] - *eps); i__2 = *nv; for (k = 1; k <= i__2; ++k) { jj = jc[k]; if (jj == 1) { goto L210; } j1 = (( j ) >= ( jj ) ? ( j ) : ( jj )) ; j2 = (( j ) <= ( jj ) ? ( j ) : ( jj )) ; jj = (j1 - 1) * *mm1 + j2; ps += xpr[k] * r__[jj]; L210: ; } y[j] = ps; if (*iflag != 2) { goto L220; } if (ic[j] != 1) { goto L220; } if (ps >= sp) { goto L220; } j0 = j; sp = ps; L220: ; } if (j0 == 0) { goto L240; } if (sp >= gama * *s2) { goto L240; } ps1 = (d__1 = fprf2c_ .u1 * (*eps - a[j0]), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); i__1 = *nv; for (k = 1; k <= i__1; ++k) { j = jc[k]; if (j == j0) { goto L240; } if (j == 1) { goto L230; } j1 = (( j0 ) >= ( j ) ? ( j0 ) : ( j )) ; j2 = (( j0 ) <= ( j ) ? ( j0 ) : ( j )) ; jj = (j1 - 1) * *mm1 + j2; ps1 += xpr[k] * (d__1 = fprf2c_ .u1 * (*eps * 2. - a[j]) + y[j] * 2. - r__[jj], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); L230: ; } ps1 = ps1 * 1e3 * *zero; if (sp > *s2 - ps1) { goto L240; } ic[j0] = 0; goto L280; L240: j0 = 0; sp = gama * *s2; i__1 = nt1; for (j = 2; j <= i__1; ++j) { if (*iflag == 2 && ic[j] == 1) { goto L260; } if (y[j] >= sp) { goto L260; } sp = y[j]; j0 = j; L260: ; } if (j0 == 0) { goto L290; } ps1 = (d__1 = fprf2c_ .u1 * (*eps - a[j0]), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); i__1 = *nv; for (k = 1; k <= i__1; ++k) { j = jc[k]; if (j == 1) { goto L270; } j1 = (( j0 ) >= ( j ) ? ( j0 ) : ( j )) ; j2 = (( j0 ) <= ( j ) ? ( j0 ) : ( j )) ; jj = (j1 - 1) * *mm1 + j2; ps1 += xpr[k] * (d__1 = fprf2c_ .u1 * (*eps * 2. - a[j]) + y[j] * 2. - r__[jj], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); L270: ; } ps1 = ps1 * 1e3 * *zero; if (sp > *s2 - ps1) { goto L290; } L280: ++ fprf2c_ .nc; ++(*nv); jc[*nv] = j0; if (*imp > 6) { io___2120.ciunit = *io; s_wsfe(&io___2120); do_fio(&c__1, (char *)&(*s2), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&j0, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&sp, (ftnlen)sizeof(doublereal)); e_wsfe(); } goto L300; L290: if (fprf2c_ .u1 >= -((doublereal) (*nv)) * *zero) { goto L900; } j0 = 1; ++(*nv); jc[*nv] = 1; if (*imp > 6) { io___2121.ciunit = *io; s_wsfe(&io___2121); do_fio(&c__1, (char *)&(*s2), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)& fprf2c_ .u1, (ftnlen)sizeof(doublereal)); e_wsfe(); } L300: nv1 = *nv - 1; i__1 = nv1; for (k = 1; k <= i__1; ++k) { if (jc[k] != j0) { goto L305; } if (*imp > 0) { io___2123.ciunit = *io; s_wsfe(&io___2123); do_fio(&c__1, (char *)&j0, (ftnlen)sizeof(integer)); e_wsfe(); } *iflag = 3; return 0; L305: ; } j = jc[1]; j1 = (( j ) >= ( j0 ) ? ( j ) : ( j0 )) ; j2 = (( j ) <= ( j0 ) ? ( j ) : ( j0 )) ; jj = (j1 - 1) * *mm1 + j2; r__[*nv] = (a[j] * a[j0] + e[j] * e[j0] + r__[jj]) / rr[1]; ps0 = r__[*nv] * r__[*nv]; if (nv1 == 1) { goto L330; } i__1 = nv1; for (k = 2; k <= i__1; ++k) { j = jc[k]; j1 = (( j ) >= ( j0 ) ? ( j ) : ( j0 )) ; j2 = (( j ) <= ( j0 ) ? ( j ) : ( j0 )) ; jj = (j1 - 1) * *mm1 + j2; ps = a[j] * a[j0] + e[j] * e[j0] + r__[jj]; k1 = k - 1; i__2 = k1; for (kk = 1; kk <= i__2; ++kk) { j1 = (kk - 1) * *mm1 + k; j2 = (kk - 1) * *mm1 + *nv; ps -= r__[j1] * r__[j2]; } mek = k1 * *mm1 + *nv; r__[mek] = ps / rr[k]; ps0 += r__[mek] * r__[mek]; } jj = (j0 - 1) * *mm1 + j0; ps0 = a[j0] * a[j0] + e[j0] * e[j0] + r__[jj] - ps0; if (ps0 > 0.) { goto L330; } *iflag = 3; return 0; L330: rr[*nv] = sqrt(ps0); if (niter <= 1) { goto L400; } incr = 1; k00 = *nv; L400: k = k00; if (k > *nv) { goto L430; } if (*imp <= 7) { goto L410; } io___2128.ciunit = *io; s_wsfe(&io___2128); do_fio(&c__1, (char *)&rr[1], (ftnlen)sizeof(doublereal)); e_wsfe(); if (*nv == 1) { goto L410; } i__1 = *nv; for (l = 2; l <= i__1; ++l) { k1 = l - 1; io___2130.ciunit = *io; s_wsfe(&io___2130); i__2 = k1; for (kk = 1; kk <= i__2; ++kk) { do_fio(&c__1, (char *)&r__[(kk - 1) * *mm1 + l], (ftnlen)sizeof( doublereal)); } do_fio(&c__1, (char *)&rr[l], (ftnlen)sizeof(doublereal)); e_wsfe(); } L410: j = jc[k]; ps1 = a[j]; ps2 = e[j]; if (k == 1) { goto L420; } k1 = k - 1; i__1 = k1; for (kk = 1; kk <= i__1; ++kk) { jj = (kk - 1) * *mm1 + k; ps0 = r__[jj]; ps1 -= ps0 * w1[kk]; ps2 -= ps0 * w2[kk]; } L420: ps0 = rr[k]; w1[k] = ps1 / ps0; w2[k] = ps2 / ps0; ++k; if (k <= *nv) { goto L410; } L430: k = 1; if (incr == 1) { k = *nv; } L440: w1s += w1[k] * w1[k]; w2s += w2[k] * w2[k]; w12s += w1[k] * w2[k]; ++k; if (k <= *nv) { goto L440; } det = w1s * w2s - w12s * w12s; ps2 = w2s * *eps - w12s; ps1 = w1s - w12s * *eps; v1 = ps2 / det; v2 = ps1 / det; fprf2c_ .u1 = *eps - v1; u2 = 1. - v2; if (*nv == fprf2c_ .nc + 1) { fprf2c_ .u1 = 0.; } y[*nv] = (v1 * w1[*nv] + v2 * w2[*nv]) / rr[*nv]; if (*nv == 1) { goto L500; } i__1 = *nv; for (l = 2; l <= i__1; ++l) { k = *nv - l + 1; k1 = k + 1; ps = v1 * w1[k] + v2 * w2[k]; mek = (k - 1) * *mm1; i__2 = *nv; for (kk = k1; kk <= i__2; ++kk) { mej = mek + kk; ps -= r__[mej] * y[kk]; } y[k] = ps / rr[k]; } L500: dmu = -(*zero) * *eps; i__1 = *nv; for (k = 1; k <= i__1; ++k) { if (jc[k] == 1) { goto L520; } if (y[k] <= *zero) { goto L550; } goto L530; L520: if (y[k] <= dmu) { goto L550; } L530: ; } i__1 = *nv; for (k = 1; k <= i__1; ++k) { xpr[k] = y[k]; } goto L200; L550: teta = 0.; k0 = k; i__1 = *nv; for (k = 1; k <= i__1; ++k) { if (y[k] >= 0.) { goto L560; } ps = y[k] / (y[k] - xpr[k]); if (teta >= ps) { goto L560; } teta = ps; k0 = k; L560: ; } i__1 = *nv; for (k = 1; k <= i__1; ++k) { ps = teta * xpr[k] + (1. - teta) * y[k]; if (ps <= *zero) { ps = 0.; } xpr[k] = ps; } if (*imp <= 6) { goto L600; } ps1 = 0.; ps2 = 0.; i__1 = *nv; for (k = 1; k <= i__1; ++k) { i__2 = *nv; for (kk = 1; kk <= i__2; ++kk) { i__3 = jc[k], i__4 = jc[kk]; j1 = (( i__3 ) >= ( i__4 ) ? ( i__3 ) : ( i__4 )) ; i__3 = jc[k], i__4 = jc[kk]; j2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ; jj = (j1 - 1) * *mm1 + j2; ps1 += xpr[k] * xpr[kk] * r__[jj]; ps2 += y[k] * y[kk] * r__[jj]; } } L600: --(*nv); incr = 0; k00 = k0; w1s = 0.; w2s = 0.; w12s = 0.; l = jc[k0]; if (l != 1) { -- fprf2c_ .nc; } if (*imp > 6) { io___2138.ciunit = *io; s_wsfe(&io___2138); do_fio(&c__1, (char *)&k0, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&l, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&y[k0], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&ps1, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&ps2, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (k0 > *nv) { goto L400; } k1 = k0 - 1; i__2 = *nv; for (k = k0; k <= i__2; ++k) { xpr[k] = xpr[k + 1]; if (k0 == 1) { goto L620; } i__1 = k1; for (kk = 1; kk <= i__1; ++kk) { mek = (kk - 1) * *mm1 + k; r__[mek] = r__[mek + 1]; } L620: jc[k] = jc[k + 1]; } xpr[*nv + 1] = 0.; L630: mek = (k0 - 1) * *mm1 + k0 + 1; ps = r__[mek]; ps12 = rr[k0 + 1]; ps0 = sqrt(ps * ps + ps12 * ps12); ps /= ps0; ps12 /= ps0; rr[k0] = ps0; if (k0 == *nv) { goto L400; } k1 = k0 + 1; mek01 = (k0 - 1) * *mm1; mek = k0 * *mm1; mekk = mek - *mm1; i__2 = *nv; for (k = k1; k <= i__2; ++k) { j1 = mekk + k; j2 = mek + k; r__[j1] = ps * r__[j1 + 1] + ps12 * r__[j2 + 1]; if (k > k1) { r__[j2] = ps2; } ps2 = -ps12 * r__[j1 + 1] + ps * r__[j2 + 1]; } r__[j2 + 1] = ps2; ++k0; goto L630; L900: *iflag = 0; i__2 = *ntot; for (j = 1; j <= i__2; ++j) { al[j] = 0.; } i__2 = *nv; for (k = 1; k <= i__2; ++k) { j = jc[k] - 1; if (j != 0) { al[j] = xpr[k]; } } *u = fprf2c_ .u1; if (*imp <= 5) { return 0; } io___2142.ciunit = *io; s_wsfe(&io___2142); do_fio(&c__1, (char *)& fprf2c_ .nc, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nv), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*s2), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&sp, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)& fprf2c_ .u1, (ftnlen)sizeof(doublereal)); e_wsfe(); io___2143.ciunit = *io; s_wsfe(&io___2143); i__2 = *nv; for (k = 1; k <= i__2; ++k) { do_fio(&c__1, (char *)&jc[k], (ftnlen)sizeof(integer)); } e_wsfe(); io___2144.ciunit = *io; s_wsfe(&io___2144); e_wsfe(); return 0; } int frdf1_(prosca, n, ntot, ninf, kgrad, al, q, s, epsn, aps, anc, mm1, r__, e, ic, izs, rzs, dzs) int (*prosca) (); integer *n, *ntot, *ninf, *kgrad; doublereal *al, *q, *s, *epsn, *aps, *anc; integer *mm1; doublereal *r__, *e; integer *ic, *izs; real *rzs; doublereal *dzs; { integer i__1, i__2; static integer i__, j, k; static doublereal z__, z1, z2; static integer nj, nn, nt1, njk; --s; --q; --ic; --e; --anc; --aps; --epsn; --al; --r__; --izs; --rzs; --dzs; if (*ntot <= *ninf) { goto L900; } if (*ninf > 0) { goto L100; } *ntot = 0; *kgrad = 0; goto L900; L100: nt1 = 0; i__1 = *ntot; for (j = 1; j <= i__1; ++j) { if (al[j] == 0. && epsn[j] != 0.) { goto L150; } ++nt1; ic[nt1] = j; if (j == nt1) { goto L130; } nj = *n * (j - 1); nn = *n * (nt1 - 1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { ++nn; ++nj; q[nn] = q[nj]; } al[nt1] = al[j]; epsn[nt1] = epsn[j]; aps[nt1] = aps[j]; anc[nt1] = anc[j]; e[nt1 + 1] = e[j + 1]; L130: if (epsn[j] == 0.) { *kgrad = nt1; } nn = nt1 * *mm1 + 1; nj = j * *mm1 + 1; i__2 = nt1; for (k = 1; k <= i__2; ++k) { njk = nj + ic[k]; ++nn; r__[nn] = r__[njk]; } L150: ; } *ntot = nt1; if (*ntot <= *ninf) { goto L900; } (*prosca)(n, &s[1], &s[1], &r__[*mm1 + 2], &izs[1], &rzs[1], &dzs[1]); e[2] = 1.; z__ = 0.; z1 = 0.; z2 = 0.; i__1 = *ntot; for (k = 1; k <= i__1; ++k) { z1 += al[k] * aps[k]; z2 += al[k] * anc[k]; z__ += al[k] * epsn[k]; } aps[1] = z1; anc[1] = z2; epsn[1] = z__; if (*ninf > 1) { goto L400; } *ntot = 1; *kgrad = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { q[i__] = s[i__]; } goto L900; L400: nn = (*kgrad - 1) * *n; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { nj = *n + i__; ++nn; q[nj] = q[nn]; q[i__] = s[i__]; } e[3] = 1.; nn = (*mm1 + 1) * *kgrad + 1; r__[(*mm1 << 1) + 3] = r__[nn]; (*prosca)(n, &q[*n + 1], &s[1], &r__[(*mm1 << 1) + 2], &izs[1], &rzs[1], & dzs[1]); aps[2] = 0.; anc[2] = 0.; epsn[2] = 0.; *kgrad = 2; *ntot = 2; L900: return 0; } int fremf1_(prosca, iflag, n, ntot, nta, mm1, p, alfa, e, a, r__, izs, rzs, dzs) int (*prosca) (); integer *iflag, *n, *ntot, *nta, *mm1; doublereal *p, *alfa, *e, *a, *r__; integer *izs; real *rzs; doublereal *dzs; { integer i__1, i__2; static integer mekk, i__, j, jj, kk, ni, nj, nt1, mej, nij, nta1, nta2; --alfa; --a; --e; --p; --r__; --izs; --rzs; --dzs; nt1 = *ntot + 1; nta1 = *nta + 1; if (*iflag > 0) { goto L50; } i__1 = *ntot; for (j = 1; j <= i__1; ++j) { jj = (j - 1) * *mm1 + 1; r__[jj] = 0.; } a[1] = 1.; e[1] = 0.; if (nta1 == 1) { goto L50; } i__1 = nta1; for (j = 2; j <= i__1; ++j) { e[j] = 1.; nj = (j - 2) * *n; mej = (j - 1) * *mm1; i__2 = j; for (i__ = 2; i__ <= i__2; ++i__) { ni = (i__ - 2) * *n; nij = mej + i__; (*prosca)(n, &p[ni + 1], &p[nj + 1], &r__[nij], &izs[1], &rzs[1], &dzs[1]); } } L50: nta2 = *nta + 2; if (nta2 > nt1) { goto L100; } i__2 = nt1; for (kk = nta2; kk <= i__2; ++kk) { mekk = (kk - 1) * *mm1; e[kk] = 1.; r__[mekk + 1] = 0.; nj = (kk - 2) * *n; i__1 = kk; for (i__ = 2; i__ <= i__1; ++i__) { ni = (i__ - 2) * *n; nij = mekk + i__; (*prosca)(n, &p[ni + 1], &p[nj + 1], &r__[nij], &izs[1], &rzs[1], &dzs[1]); } } i__1 = nt1; for (i__ = 2; i__ <= i__1; ++i__) { a[i__] = alfa[i__ - 1]; } L100: return 0; } int fuclid_(n, a, b, ps, izs, rzs, dzs) integer *n; doublereal *a, *b, *ps; integer *izs; real *rzs; doublereal *dzs; { extern doublereal ddot_(); *ps = ddot_(n, a, &c__1, b, &c__1); } int gcbd_(indgc, simul, nomf, n, x, f, g, imp, io, zero, napmax, itmax, epsf, epsg, epsx, df0, binf, bsup, nfac, vect, nvect, ivect, nivect, izs, rzs, dzs, nomf_len) integer *indgc; int (*simul) (); char *nomf; integer *n; doublereal *x, *f, *g; integer *imp, *io; doublereal *zero; integer *napmax, *itmax; doublereal *epsf, *epsg, *epsx, *df0, *binf, *bsup; integer *nfac; doublereal *vect; integer *nvect, *ivect, *nivect, *izs; real *rzs; doublereal *dzs; ftnlen nomf_len; { static char fmt_123[] = "(\002 gcbd : retour avec indgc=\002,i8)"; static char fmt_1000[] = "(\002 gcbd:insuffisance memoire; nvect=\002,i5,\002devrait etre:\002,i5)"; static char fmt_2000[] = "(\002 gcbd:insuffisance memoire; nivect=\002,i5,\002devrait etre:\002,i5)"; integer i__1; doublereal d__1, d__2; integer s_wsfe(), do_fio(), e_wsfe(); static integer ialg[15], nfin, ndir, i__, ndiag; extern int zgcbd_(); static doublereal aa; static integer ii, nd, ng, ns, nt, nindic, ny, nz, nindex, nx2; static doublereal alg[15]; static integer nys, nzs; static cilist io___2171 = { 0, 0, 0, fmt_123, 0 }; static cilist io___2174 = { 0, 0, 0, fmt_123, 0 }; static cilist io___2186 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2189 = { 0, 0, 0, fmt_2000, 0 }; --bsup; --binf; --epsx; --g; --x; --vect; --ivect; --izs; --rzs; --dzs; nt = 2; alg[0] = 1e-5; alg[1] = 1e6; alg[5] = .5; alg[8] = .5; ialg[0] = 1; ialg[1] = 0; ialg[2] = 2; ialg[3] = 0; ialg[4] = 0; ialg[5] = 2; ialg[6] = 1; ialg[7] = 4; ialg[8] = 12; i__1 = (( *n ) <= ( *napmax ) ? ( *n ) : ( *napmax )) ; ii = (( i__1 ) <= ( *itmax ) ? ( i__1 ) : ( *itmax )) ; if (ii > 0) { goto L10; } *indgc = -11; if (*imp > 0) { io___2171.ciunit = *io; s_wsfe(&io___2171); do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L10: d__1 = (( *zero ) <= ( *epsg ) ? ( *zero ) : ( *epsg )) ; aa = (( d__1 ) <= ( *df0 ) ? ( d__1 ) : ( *df0 )) ; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = aa, d__2 = epsx[i__]; aa = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if (aa > 0.) { goto L12; } *indgc = -12; if (*imp > 0) { io___2174.ciunit = *io; s_wsfe(&io___2174); do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L12: ny = 1; ns = nt * *n + ny; nz = nt * *n + ns; nys = nt * *n + nz; nzs = nt + nys; nd = nt + nzs; ng = *n + nd; nx2 = *n + ng; ndir = *n + nx2; ndiag = *n + ndir; nfin = *n + ndiag; if (nfin > *nvect) { io___2186.ciunit = *io; s_wsfe(&io___2186); do_fio(&c__1, (char *)&nfin, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nvect), (ftnlen)sizeof(integer)); e_wsfe(); *indgc = -14; return 0; } nindic = 1; nindex = *n + nindic; nfin = nt + nindex; if (nfin > *nivect) { io___2189.ciunit = *io; s_wsfe(&io___2189); do_fio(&c__1, (char *)&nfin, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nivect), (ftnlen)sizeof(integer)); e_wsfe(); *indgc = -14; return 0; } zgcbd_(simul, n, &binf[1], &bsup[1], &x[1], f, &g[1], zero, napmax, itmax, indgc, &ivect[nindic], nfac, imp, io, &epsx[1], epsf, epsg, & vect[ndir], df0, &vect[ndiag], &vect[nx2], &izs[1], &rzs[1], &dzs[ 1], &vect[ny], &vect[ns], &vect[nz], &vect[nys], &vect[nzs], &nt, &ivect[nindex], &vect[nd], &vect[ng], alg, ialg, nomf, 6L); return 0; } int gcp_(n, index, indic, np, nt, y, s, z__, ys, zs, diag, b, x, d__, g, eps) integer *n, *index, *indic, *np, *nt; doublereal *y, *s, *z__, *ys, *zs, *diag, *b, *x, *d__, *g, *eps; { integer y_dim1, y_offset, s_dim1, s_offset, z_dim1, z_offset, i__1; static doublereal beta; static integer iter, i__; extern int calbx_(); static integer itmax; static doublereal s0, s1, s2, dg, ro, d2a, eps0, eps1; --g; --d__; --x; --b; --diag; --indic; --zs; --ys; z_dim1 = *nt; z_offset = z_dim1 + 1; z__ -= z_offset; s_dim1 = *nt; s_offset = s_dim1 + 1; s -= s_offset; y_dim1 = *nt; y_offset = y_dim1 + 1; y -= y_offset; --index; eps0 = (float)1e-5; eps1 = (float)1e-5; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L100; } x[i__] = -b[i__] / diag[i__]; L100: ; } calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1] , &z__[z_offset], &zs[1], &x[1], &diag[1], &g[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L110; } g[i__] += b[i__]; L110: ; } s0 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L120; } s0 += g[i__] * g[i__] / diag[i__]; L120: ; } if (s0 < 1e-18) { return 0; } s1 = s0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L130; } d__[i__] = -g[i__] / diag[i__]; L130: ; } dg = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L135; } dg += d__[i__] * g[i__]; L135: ; } calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1] , &z__[z_offset], &zs[1], &d__[1], &diag[1], &g[1]); d2a = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L140; } d2a += d__[i__] * g[i__]; L140: ; } ro = -dg / d2a; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L150; } x[i__] += ro * d__[i__]; L150: ; } calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1] , &z__[z_offset], &zs[1], &x[1], &diag[1], &g[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L170; } g[i__] += b[i__]; L170: ; } iter = 0; itmax = *np << 1; L10: ++iter; if (iter > itmax) { return 0; } s2 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L200; } s2 += g[i__] * g[i__] / diag[i__]; L200: ; } if (s2 / s0 < *eps) { return 0; } beta = s2 / s1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L210; } d__[i__] = -g[i__] / diag[i__] + beta * d__[i__]; L210: ; } s1 = s2; dg = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L215; } dg += d__[i__] * g[i__]; L215: ; } calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1] , &z__[z_offset], &zs[1], &d__[1], &diag[1], &g[1]); d2a = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L220; } d2a += d__[i__] * g[i__]; L220: ; } ro = -dg / d2a; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L230; } x[i__] += ro * d__[i__]; L230: ; } calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1] , &z__[z_offset], &zs[1], &x[1], &diag[1], &g[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > 0) { goto L240; } g[i__] += b[i__]; L240: ; } goto L10; } int hybrd_(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, factor, nprint, info, nfev, fjac, ldfjac, r__, lr, qtf, wa1, wa2, wa3, wa4) int (*fcn) (); integer *n; doublereal *x, *fvec, *xtol; integer *maxfev, *ml, *mu; doublereal *epsfcn, *diag; integer *mode; doublereal *factor; integer *nprint, *info, *nfev; doublereal *fjac; integer *ldfjac; doublereal *r__; integer *lr; doublereal *qtf, *wa1, *wa2, *wa3, *wa4; { static doublereal one = 1.; static doublereal p1 = .1; static doublereal p5 = .5; static doublereal p001 = .001; static doublereal p0001 = 1e-4; static doublereal zero = 0.; integer fjac_dim1, fjac_offset, i__1, i__2; doublereal d__1, d__2; static logical sing; static integer iter; static doublereal temp; static integer msum, i__, j, l, iflag; static doublereal delta; extern int qrfac_(); static logical jeval; static integer ncsuc; static doublereal ratio; extern doublereal enorm_(); static doublereal fnorm; extern int qform_(), fdjac1_(); static doublereal pnorm, xnorm, fnorm1; extern int r1updt_(); static integer nslow1, nslow2; extern doublereal dlamch_(); extern int r1mpyq_(); static integer ncfail; extern int dogleg_(); static doublereal actred, epsmch, prered; static integer jm1, iwa[1]; static doublereal sum; --wa4; --wa3; --wa2; --wa1; --qtf; --diag; --fvec; --x; fjac_dim1 = *ldfjac; fjac_offset = fjac_dim1 + 1; fjac -= fjac_offset; --r__; epsmch = dlamch_("p", 1L); *info = 0; iflag = 0; *nfev = 0; if (*n <= 0 || *xtol < zero || *maxfev <= 0 || *ml < 0 || *mu < 0 || * factor <= zero || *ldfjac < *n || *lr < *n * (*n + 1) / 2) { goto L300; } if (*mode != 2) { goto L20; } i__1 = *n; for (j = 1; j <= i__1; ++j) { if (diag[j] <= zero) { goto L300; } } L20: iflag = 1; (*fcn)(n, &x[1], &fvec[1], &iflag); *nfev = 1; if (iflag < 0) { goto L300; } fnorm = enorm_(n, &fvec[1]); i__1 = *ml + *mu + 1; msum = (( i__1 ) <= ( *n ) ? ( i__1 ) : ( *n )) ; iter = 1; ncsuc = 0; ncfail = 0; nslow1 = 0; nslow2 = 0; L30: jeval = (1) ; iflag = 2; fdjac1_(fcn, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag, ml, mu, epsfcn, &wa1[1], &wa2[1]); *nfev += msum; if (iflag < 0) { goto L300; } qrfac_(n, n, &fjac[fjac_offset], ldfjac, &c_false, iwa, &c__1, &wa1[1], & wa2[1], &wa3[1]); if (iter != 1) { goto L70; } if (*mode == 2) { goto L50; } i__1 = *n; for (j = 1; j <= i__1; ++j) { diag[j] = wa2[j]; if (wa2[j] == zero) { diag[j] = one; } } L50: i__1 = *n; for (j = 1; j <= i__1; ++j) { wa3[j] = diag[j] * x[j]; } xnorm = enorm_(n, &wa3[1]); delta = *factor * xnorm; if (delta == zero) { delta = *factor; } L70: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { qtf[i__] = fvec[i__]; } i__1 = *n; for (j = 1; j <= i__1; ++j) { if (fjac[j + j * fjac_dim1] == zero) { goto L110; } sum = zero; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { sum += fjac[i__ + j * fjac_dim1] * qtf[i__]; } temp = -sum / fjac[j + j * fjac_dim1]; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { qtf[i__] += fjac[i__ + j * fjac_dim1] * temp; } L110: ; } sing = (0) ; i__1 = *n; for (j = 1; j <= i__1; ++j) { l = j; jm1 = j - 1; if (jm1 < 1) { goto L140; } i__2 = jm1; for (i__ = 1; i__ <= i__2; ++i__) { r__[l] = fjac[i__ + j * fjac_dim1]; l = l + *n - i__; } L140: r__[l] = wa1[j]; if (wa1[j] == zero) { sing = (1) ; } } qform_(n, n, &fjac[fjac_offset], ldfjac, &wa1[1]); if (*mode == 2) { goto L170; } i__1 = *n; for (j = 1; j <= i__1; ++j) { d__1 = diag[j], d__2 = wa2[j]; diag[j] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } L170: L180: if (*nprint <= 0) { goto L190; } iflag = 0; if ((iter - 1) % *nprint == 0) { (*fcn)(n, &x[1], &fvec[1], &iflag); } if (iflag < 0) { goto L300; } L190: dogleg_(n, &r__[1], lr, &diag[1], &qtf[1], &delta, &wa1[1], &wa2[1], &wa3[ 1]); i__1 = *n; for (j = 1; j <= i__1; ++j) { wa1[j] = -wa1[j]; wa2[j] = x[j] + wa1[j]; wa3[j] = diag[j] * wa1[j]; } pnorm = enorm_(n, &wa3[1]); if (iter == 1) { delta = (( delta ) <= ( pnorm ) ? ( delta ) : ( pnorm )) ; } iflag = 1; (*fcn)(n, &wa2[1], &wa4[1], &iflag); ++(*nfev); if (iflag < 0) { goto L300; } fnorm1 = enorm_(n, &wa4[1]); actred = -one; if (fnorm1 < fnorm) { d__1 = fnorm1 / fnorm; actred = one - d__1 * d__1; } l = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sum = zero; i__2 = *n; for (j = i__; j <= i__2; ++j) { sum += r__[l] * wa1[j]; ++l; } wa3[i__] = qtf[i__] + sum; } temp = enorm_(n, &wa3[1]); prered = zero; if (temp < fnorm) { d__1 = temp / fnorm; prered = one - d__1 * d__1; } ratio = zero; if (prered > zero) { ratio = actred / prered; } if (ratio >= p1) { goto L230; } ncsuc = 0; ++ncfail; delta = p5 * delta; goto L240; L230: ncfail = 0; ++ncsuc; if (ratio >= p5 || ncsuc > 1) { d__1 = delta, d__2 = pnorm / p5; delta = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if ((d__1 = ratio - one, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= p1) { delta = pnorm / p5; } L240: if (ratio < p0001) { goto L260; } i__1 = *n; for (j = 1; j <= i__1; ++j) { x[j] = wa2[j]; wa2[j] = diag[j] * x[j]; fvec[j] = wa4[j]; } xnorm = enorm_(n, &wa2[1]); fnorm = fnorm1; ++iter; L260: ++nslow1; if (actred >= p001) { nslow1 = 0; } if (jeval) { ++nslow2; } if (actred >= p1) { nslow2 = 0; } if (delta <= *xtol * xnorm || fnorm == zero) { *info = 1; } if (*info != 0) { goto L300; } if (*nfev >= *maxfev) { *info = 2; } d__1 = p1 * delta; if (p1 * (( d__1 ) >= ( pnorm ) ? ( d__1 ) : ( pnorm )) <= epsmch * xnorm) { *info = 3; } if (nslow2 == 5) { *info = 4; } if (nslow1 == 10) { *info = 5; } if (*info != 0) { goto L300; } if (ncfail == 2) { goto L290; } i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = zero; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { sum += fjac[i__ + j * fjac_dim1] * wa4[i__]; } wa2[j] = (sum - wa3[j]) / pnorm; wa1[j] = diag[j] * (diag[j] * wa1[j] / pnorm); if (ratio >= p0001) { qtf[j] = sum; } } r1updt_(n, n, &r__[1], lr, &wa1[1], &wa2[1], &wa3[1], &sing); r1mpyq_(n, n, &fjac[fjac_offset], ldfjac, &wa2[1], &wa3[1]); r1mpyq_(&c__1, n, &qtf[1], &c__1, &wa2[1], &wa3[1]); jeval = (0) ; goto L180; L290: goto L30; L300: if (iflag < 0) { *info = iflag; } iflag = 0; if (*nprint > 0) { (*fcn)(n, &x[1], &fvec[1], &iflag); } return 0; } int hybrd1_(fcn, n, x, fvec, tol, info, wa, lwa) int (*fcn) (); integer *n; doublereal *x, *fvec, *tol; integer *info; doublereal *wa; integer *lwa; { static doublereal factor = 100.; static doublereal one = 1.; static doublereal zero = 0.; integer i__1; static integer mode, nfev; static doublereal xtol; static integer j, index; extern int hybrd_(); static integer ml, lr, mu; static doublereal epsfcn; static integer maxfev, nprint; --fvec; --x; --wa; *info = 0; if (*n <= 0 || *tol < zero || *lwa < *n * (*n * 3 + 13) / 2) { goto L20; } maxfev = (*n + 1) * 200; xtol = *tol; ml = *n - 1; mu = *n - 1; epsfcn = zero; mode = 2; i__1 = *n; for (j = 1; j <= i__1; ++j) { wa[j] = one; } nprint = 0; lr = *n * (*n + 1) / 2; index = *n * 6 + lr; hybrd_(fcn, n, &x[1], &fvec[1], &xtol, &maxfev, &ml, &mu, &epsfcn, &wa[1], &mode, &factor, &nprint, info, &nfev, &wa[index + 1], n, &wa[*n * 6 + 1], &lr, &wa[*n + 1], &wa[(*n << 1) + 1], &wa[*n * 3 + 1], & wa[(*n << 2) + 1], &wa[*n * 5 + 1]); if (*info == 5) { *info = 4; } L20: return 0; } int hybrj_(fcn, n, x, fvec, fjac, ldfjac, xtol, maxfev, diag, mode, factor, nprint, info, nfev, njev, r__, lr, qtf, wa1, wa2, wa3, wa4) int (*fcn) (); integer *n; doublereal *x, *fvec, *fjac; integer *ldfjac; doublereal *xtol; integer *maxfev; doublereal *diag; integer *mode; doublereal *factor; integer *nprint, *info, *nfev, *njev; doublereal *r__; integer *lr; doublereal *qtf, *wa1, *wa2, *wa3, *wa4; { static doublereal one = 1.; static doublereal p1 = .1; static doublereal p5 = .5; static doublereal p001 = .001; static doublereal p0001 = 1e-4; static doublereal zero = 0.; integer fjac_dim1, fjac_offset, i__1, i__2; doublereal d__1, d__2; static logical sing; static integer iter; static doublereal temp; static integer i__, j, l, iflag; static doublereal delta; extern int qrfac_(); static logical jeval; static integer ncsuc; static doublereal ratio; extern doublereal enorm_(); static doublereal fnorm; extern int qform_(); static doublereal pnorm, xnorm, fnorm1; extern int r1updt_(); static integer nslow1, nslow2; extern doublereal dlamch_(); extern int r1mpyq_(); static integer ncfail; extern int dogleg_(); static doublereal actred, epsmch, prered; static integer jm1, iwa[1]; static doublereal sum; --wa4; --wa3; --wa2; --wa1; --qtf; --diag; --fvec; --x; fjac_dim1 = *ldfjac; fjac_offset = fjac_dim1 + 1; fjac -= fjac_offset; --r__; epsmch = dlamch_("p", 1L); *info = 0; iflag = 0; *nfev = 0; *njev = 0; if (*n <= 0 || *ldfjac < *n || *xtol < zero || *maxfev <= 0 || *factor <= zero || *lr < *n * (*n + 1) / 2) { goto L300; } if (*mode != 2) { goto L20; } i__1 = *n; for (j = 1; j <= i__1; ++j) { if (diag[j] <= zero) { goto L300; } } L20: iflag = 1; (*fcn)(n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag); *nfev = 1; if (iflag < 0) { goto L300; } fnorm = enorm_(n, &fvec[1]); iter = 1; ncsuc = 0; ncfail = 0; nslow1 = 0; nslow2 = 0; L30: jeval = (1) ; iflag = 2; (*fcn)(n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag); ++(*njev); if (iflag < 0) { goto L300; } qrfac_(n, n, &fjac[fjac_offset], ldfjac, &c_false, iwa, &c__1, &wa1[1], & wa2[1], &wa3[1]); if (iter != 1) { goto L70; } if (*mode == 2) { goto L50; } i__1 = *n; for (j = 1; j <= i__1; ++j) { diag[j] = wa2[j]; if (wa2[j] == zero) { diag[j] = one; } } L50: i__1 = *n; for (j = 1; j <= i__1; ++j) { wa3[j] = diag[j] * x[j]; } xnorm = enorm_(n, &wa3[1]); delta = *factor * xnorm; if (delta == zero) { delta = *factor; } L70: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { qtf[i__] = fvec[i__]; } i__1 = *n; for (j = 1; j <= i__1; ++j) { if (fjac[j + j * fjac_dim1] == zero) { goto L110; } sum = zero; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { sum += fjac[i__ + j * fjac_dim1] * qtf[i__]; } temp = -sum / fjac[j + j * fjac_dim1]; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { qtf[i__] += fjac[i__ + j * fjac_dim1] * temp; } L110: ; } sing = (0) ; i__1 = *n; for (j = 1; j <= i__1; ++j) { l = j; jm1 = j - 1; if (jm1 < 1) { goto L140; } i__2 = jm1; for (i__ = 1; i__ <= i__2; ++i__) { r__[l] = fjac[i__ + j * fjac_dim1]; l = l + *n - i__; } L140: r__[l] = wa1[j]; if (wa1[j] == zero) { sing = (1) ; } } qform_(n, n, &fjac[fjac_offset], ldfjac, &wa1[1]); if (*mode == 2) { goto L170; } i__1 = *n; for (j = 1; j <= i__1; ++j) { d__1 = diag[j], d__2 = wa2[j]; diag[j] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } L170: L180: if (*nprint <= 0) { goto L190; } iflag = 0; if ((iter - 1) % *nprint == 0) { (*fcn)(n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag); } if (iflag < 0) { goto L300; } L190: dogleg_(n, &r__[1], lr, &diag[1], &qtf[1], &delta, &wa1[1], &wa2[1], &wa3[ 1]); i__1 = *n; for (j = 1; j <= i__1; ++j) { wa1[j] = -wa1[j]; wa2[j] = x[j] + wa1[j]; wa3[j] = diag[j] * wa1[j]; } pnorm = enorm_(n, &wa3[1]); if (iter == 1) { delta = (( delta ) <= ( pnorm ) ? ( delta ) : ( pnorm )) ; } iflag = 1; (*fcn)(n, &wa2[1], &wa4[1], &fjac[fjac_offset], ldfjac, &iflag); ++(*nfev); if (iflag < 0) { goto L300; } fnorm1 = enorm_(n, &wa4[1]); actred = -one; if (fnorm1 < fnorm) { d__1 = fnorm1 / fnorm; actred = one - d__1 * d__1; } l = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sum = zero; i__2 = *n; for (j = i__; j <= i__2; ++j) { sum += r__[l] * wa1[j]; ++l; } wa3[i__] = qtf[i__] + sum; } temp = enorm_(n, &wa3[1]); prered = zero; if (temp < fnorm) { d__1 = temp / fnorm; prered = one - d__1 * d__1; } ratio = zero; if (prered > zero) { ratio = actred / prered; } if (ratio >= p1) { goto L230; } ncsuc = 0; ++ncfail; delta = p5 * delta; goto L240; L230: ncfail = 0; ++ncsuc; if (ratio >= p5 || ncsuc > 1) { d__1 = delta, d__2 = pnorm / p5; delta = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if ((d__1 = ratio - one, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= p1) { delta = pnorm / p5; } L240: if (ratio < p0001) { goto L260; } i__1 = *n; for (j = 1; j <= i__1; ++j) { x[j] = wa2[j]; wa2[j] = diag[j] * x[j]; fvec[j] = wa4[j]; } xnorm = enorm_(n, &wa2[1]); fnorm = fnorm1; ++iter; L260: ++nslow1; if (actred >= p001) { nslow1 = 0; } if (jeval) { ++nslow2; } if (actred >= p1) { nslow2 = 0; } if (delta <= *xtol * xnorm || fnorm == zero) { *info = 1; } if (*info != 0) { goto L300; } if (*nfev >= *maxfev) { *info = 2; } d__1 = p1 * delta; if (p1 * (( d__1 ) >= ( pnorm ) ? ( d__1 ) : ( pnorm )) <= epsmch * xnorm) { *info = 3; } if (nslow2 == 5) { *info = 4; } if (nslow1 == 10) { *info = 5; } if (*info != 0) { goto L300; } if (ncfail == 2) { goto L290; } i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = zero; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { sum += fjac[i__ + j * fjac_dim1] * wa4[i__]; } wa2[j] = (sum - wa3[j]) / pnorm; wa1[j] = diag[j] * (diag[j] * wa1[j] / pnorm); if (ratio >= p0001) { qtf[j] = sum; } } r1updt_(n, n, &r__[1], lr, &wa1[1], &wa2[1], &wa3[1], &sing); r1mpyq_(n, n, &fjac[fjac_offset], ldfjac, &wa2[1], &wa3[1]); r1mpyq_(&c__1, n, &qtf[1], &c__1, &wa2[1], &wa3[1]); jeval = (0) ; goto L180; L290: goto L30; L300: if (iflag < 0) { *info = iflag; } iflag = 0; if (*nprint > 0) { (*fcn)(n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag); } return 0; } int hybrj1_(fcn, n, x, fvec, fjac, ldfjac, tol, info, wa, lwa) int (*fcn) (); integer *n; doublereal *x, *fvec, *fjac; integer *ldfjac; doublereal *tol; integer *info; doublereal *wa; integer *lwa; { static doublereal factor = 100.; static doublereal one = 1.; static doublereal zero = 0.; integer fjac_dim1, fjac_offset, i__1; static integer mode, nfev, njev; static doublereal xtol; static integer j; extern int hybrj_(); static integer lr, maxfev, nprint; --fvec; --x; fjac_dim1 = *ldfjac; fjac_offset = fjac_dim1 + 1; fjac -= fjac_offset; --wa; *info = 0; if (*n <= 0 || *ldfjac < *n || *tol < zero || *lwa < *n * (*n + 13) / 2) { goto L20; } maxfev = (*n + 1) * 100; xtol = *tol; mode = 2; i__1 = *n; for (j = 1; j <= i__1; ++j) { wa[j] = one; } nprint = 0; lr = *n * (*n + 1) / 2; hybrj_(fcn, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &xtol, & maxfev, &wa[1], &mode, &factor, &nprint, info, &nfev, &njev, &wa[* n * 6 + 1], &lr, &wa[*n + 1], &wa[(*n << 1) + 1], &wa[*n * 3 + 1], &wa[(*n << 2) + 1], &wa[*n * 5 + 1]); if (*info == 5) { *info = 4; } L20: return 0; } int icscof_(ico, ntob, nex, nob, yob, ob, cof) integer *ico, *ntob, *nex, *nob; doublereal *yob, *ob, *cof; { integer yob_dim1, yob_offset, ob_dim1, ob_dim2, ob_offset, cof_dim1, cof_offset, i__1, i__2, i__3; doublereal d__1; static integer i__, j, k; cof_dim1 = *nob; cof_offset = cof_dim1 + 1; cof -= cof_offset; ob_dim1 = *nex; ob_dim2 = *ntob; ob_offset = ob_dim1 * (ob_dim2 + 1) + 1; ob -= ob_offset; yob_dim1 = *nob; yob_offset = yob_dim1 + 1; yob -= yob_offset; i__1 = *nob; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *ntob; for (j = 1; j <= i__2; ++j) { cof[i__ + j * cof_dim1] = 0.; } } if (*ico == 1) { i__2 = *nob; for (i__ = 1; i__ <= i__2; ++i__) { i__1 = *ntob; for (j = 1; j <= i__1; ++j) { i__3 = *nex; for (k = 1; k <= i__3; ++k) { cof[i__ + j * cof_dim1] += (d__1 = ob[k + (j + i__ * ob_dim2) * ob_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } } } i__3 = *nob; for (i__ = 1; i__ <= i__3; ++i__) { i__1 = *ntob; for (j = 1; j <= i__1; ++j) { cof[i__ + j * cof_dim1] = (doublereal) (*nex) / cof[i__ + j * cof_dim1]; } } } else { i__1 = *nob; for (i__ = 1; i__ <= i__1; ++i__) { i__3 = *ntob; for (j = 1; j <= i__3; ++j) { i__2 = *nex; for (k = 1; k <= i__2; ++k) { d__1 = yob[i__ + j * yob_dim1] - ob[k + (j + i__ * ob_dim2) * ob_dim1]; cof[i__ + j * cof_dim1] += d__1 * d__1; } } } i__2 = *nob; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = *ntob; for (j = 1; j <= i__3; ++j) { cof[i__ + j * cof_dim1] = .5 / cof[i__ + j * cof_dim1]; } } } return 0; } int icse_(ind, nu, u, co, g, itv, rtv, dtv, icsef, icsec2, icsei) integer *ind, *nu; doublereal *u, *co, *g; integer *itv; real *rtv; doublereal *dtv; int (*icsef) (), (*icsec2) (), (*icsei) (); { static char fmt_8003[] = "(1x,\002icse : taille des tableaux itv,dtv insuffisante\002,/,8x,\002valeurs minimales \002,i6,2x,i6)"; integer i__1, i__2; integer s_wsfe(), do_fio(), e_wsfe(); static integer lech, lcof, indi, lobs, ltob, ldmy, lyob, ldtu, litu, mdtv, mitv, lsmy, ldif1, ldif2, ldif3; extern int icse1_(), icse2_(); static integer lipv1, lipv2, mdtv1, mdtv2, mitv1, mitv2, i__, ludep, litob, loldp, lyold, lytob, ldtvt, lyerr, lyint, litvt, lytot, lb, ld, lf, lp, ly, lsmold, loldmu, lp0, ly0, lob, ldm, lfu, lui, nui, lfy, lgt, lc2y, ly0u; static cilist io___2339 = { 0, 6, 0, fmt_8003, 0 }; --g; --u; --itv; --rtv; --dtv; if ((icsez_._1) .iu[1] > 0) { i__1 = *nu, i__2 = (icsez_._1) .nuc + 1; lui = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } if ((icsez_._1) .iu[0] > 0) { lui = 1; } nui = (icsez_._1) .iu[0] * (icsez_._1) .nuc + (icsez_._1) .iu[1] * (icsez_._1) .nuv * ( (icsez_._1) .nti + (icsez_._1) .ntf + 1); litu = 1; litvt = litu + (icsez_._1) .nitu; ldtu = 1; ly0 = ldtu + (icsez_._1) .ndtu; ltob = ly0 + (icsez_._1) .ny; lobs = ltob + (icsez_._1) .ntob; lob = lobs + (icsez_._1) .nob * (icsez_._1) .ny; lech = lob + (icsez_._1) .nex * (icsez_._1) .ntob * (icsez_._1) .nob; lcof = lech + *nu; lb = lcof + (icsez_._1) .nob * (icsez_._1) .ntob; lfy = lb + (icsez_._1) .ny; lfu = lfy + (icsez_._1) .ny * (icsez_._1) .ny; ludep = lfu + (icsez_._1) .ny * ((icsez_._1) .nuc + (icsez_._1) .nuv); lytot = ludep + *nu; lf = lytot + (icsez_._1) .ny * ((icsez_._1) .nti + (icsez_._1) .ntf); ldtvt = lf + (icsez_._1) .ny; lipv1 = litvt; mitv1 = lipv1 + (icsez_._1) .ny - 1; litob = litvt; lipv2 = litob + (icsez_._1) .ntob; mitv2 = lipv2 + (icsez_._1) .ny - 1; mitv = (( mitv1 ) >= ( mitv2 ) ? ( mitv1 ) : ( mitv2 )) ; ldm = ldtvt; lyold = ldm + (icsez_._1) .ny * (icsez_._1) .ny; lsmold = lyold + (icsez_._1) .ny; lyint = lsmold + (icsez_._1) .ny; lyerr = lyint + (icsez_._1) .ny; ldif1 = lyerr + (icsez_._1) .ny; ldif2 = ldif1 + (icsez_._1) .ny; ldif3 = ldif2 + (icsez_._1) .ny; mdtv1 = ldif3 + (icsez_._1) .ny - 1; lytob = ldtvt; lc2y = lytob + (icsez_._1) .ny * (icsez_._1) .ntob; ly0u = lc2y + (icsez_._1) .ny * (icsez_._1) .ntob; ldmy = ly0u + (icsez_._1) .ny * *nu; lsmy = ldmy + (icsez_._1) .ny * (icsez_._1) .ny; loldmu = lsmy + (icsez_._1) .ny * (icsez_._1) .ny; ly = loldmu + (icsez_._1) .ny * ((icsez_._1) .nuc + (icsez_._1) .nuv); loldp = ly + (icsez_._1) .ny; lp = loldp + (icsez_._1) .ny; lp0 = lp + (icsez_._1) .ny; lgt = lp0 + (icsez_._1) .ny; i__1 = (icsez_._1) .nuc + (icsez_._1) .nuv; lyob = lgt + (( i__1 ) >= ( nui ) ? ( i__1 ) : ( nui )) ; ld = lyob + (icsez_._1) .nob * (icsez_._1) .ntob; mdtv2 = ld + (icsez_._1) .nob - 1; mdtv = (( mdtv1 ) >= ( mdtv2 ) ? ( mdtv1 ) : ( mdtv2 )) ; if (mitv > (nird_._1) .nitv || mdtv > (nird_._1) .ndtv) { if ((nird_._1) .nitv + (nird_._1) .ndtv > 0) { s_wsfe(&io___2339); do_fio(&c__1, (char *)&mitv, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&mdtv, (ftnlen)sizeof(integer)); e_wsfe(); } (nird_._1) .nitv = mitv; (nird_._1) .ndtv = mdtv; return 0; } i__1 = *nu; for (i__ = 1; i__ <= i__1; ++i__) { dtv[ludep + i__ - 1] = u[i__]; u[i__] = dtv[lech + i__ - 1] * u[i__]; } if ((icsez_._1) .iu[0] > 0) { indi = 1; (*icsei)(&indi, &nui, &u[lui], &dtv[ly0], &dtv[ly0u], &itv[litu], & dtv[ldtu], & (icsez_._1) .t0, & (icsez_._1) .tf, & (icsez_._1) .dti, & (icsez_._1) .dtf, & (icsez_._1) .ermx, (icsez_._1) .iu, & (icsez_._1) .nuc, & (icsez_._1) .nuv, & (icsez_._1) .ilin, & (icsez_._1) .nti, & (icsez_._1) .ntf, & (icsez_._1) .ny, & (icsez_._1) .nea, & (icsez_._1) .itmx, & (icsez_._1) .nex, & (icsez_._1) .nob, & (icsez_._1) .ntob, & (icsez_._1) .ntobi, & (icsez_._1) .nitu, & (icsez_._1) .ndtu); if (indi <= 0) { *ind = indi; return 0; } } icse1_(ind, nu, &u[1], icsef, &dtv[ly0], &dtv[lytot], &dtv[lf], &dtv[lb], &dtv[lfy], &dtv[lfu], &itv[lipv1], &dtv[ldm], &dtv[lyold], &dtv[ lsmold], &dtv[lyint], &dtv[lyerr], &dtv[ldif1], &dtv[ldif2], &dtv[ ldif3], &itv[litu], &dtv[ldtu], & (icsez_._1) .t0, & (icsez_._1) .tf, & (icsez_._1) .dti, & (icsez_._1) .dtf, & (icsez_._1) .ermx, (icsez_._1) .iu, & (icsez_._1) .nuc, & (icsez_._1) .nuv, & (icsez_._1) .ilin, & (icsez_._1) .nti, & (icsez_._1) .ntf, & (icsez_._1) .ny, & (icsez_._1) .nea, & (icsez_._1) .itmx, & (icsez_._1) .nex, & (icsez_._1) .nob, & (icsez_._1) .ntob, & (icsez_._1) .ntobi, & (icsez_._1) .nitu, & (icsez_._1) .ndtu); if (*ind <= 0) { return 0; } icse2_(ind, nu, &u[1], co, &g[1], icsef, icsec2, icsei, &dtv[ly0], &dtv[ ltob], &dtv[lobs], &dtv[lob], &dtv[lytot], &dtv[lf], &dtv[lb], & dtv[lfy], &dtv[lfu], &itv[lipv2], &itv[litob], &dtv[lcof], &dtv[ lytob], &dtv[lc2y], &dtv[ly0u], &dtv[ldmy], &dtv[lsmy], &dtv[ loldmu], &dtv[ly], &dtv[loldp], &dtv[lp], &dtv[lp0], &dtv[lgt], & dtv[lyob], &dtv[ld], &itv[litu], &dtv[ldtu], & (icsez_._1) .t0, & (icsez_._1) .tf, & (icsez_._1) .dti, & (icsez_._1) .dtf, & (icsez_._1) .ermx, (icsez_._1) .iu, & (icsez_._1) .nuc, & (icsez_._1) .nuv, & (icsez_._1) .ilin, & (icsez_._1) .nti, & (icsez_._1) .ntf, & (icsez_._1) .ny, & (icsez_._1) .nea, & (icsez_._1) .itmx, & (icsez_._1) .nex, & (icsez_._1) .nob, & (icsez_._1) .ntob, & (icsez_._1) .ntobi, & (icsez_._1) .nitu, & (icsez_._1) .ndtu); i__1 = *nu; for (i__ = 1; i__ <= i__1; ++i__) { g[i__] = dtv[lech + i__ - 1] * g[i__]; u[i__] = dtv[ludep + i__ - 1]; } return 0; } int icse0_(nu, t0, tf, dti, dtf, ermx, iu, nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nitv, nrtv, ndtv) integer *nu; doublereal *t0, *tf, *dti, *dtf, *ermx; integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, * ntob, *ntobi, *nitu, *ndtu, *nitv, *nrtv, *ndtv; { extern int icse_(); static integer i__; static doublereal zz; static integer ind; --iu; (icsez_._2) .t00 = *t0; (icsez_._2) .tf0 = *tf; (icsez_._2) .dti0 = *dti; (icsez_._2) .dtf0 = *dtf; (icsez_._2) .ermx0 = *ermx; for (i__ = 1; i__ <= 5; ++i__) { (icsez_._2) .iu0[i__ - 1] = iu[i__]; } (icsez_._2) .nuc0 = *nuc; (icsez_._2) .nuv0 = *nuv; (icsez_._2) .ilin0 = *ilin; (icsez_._2) .nti0 = *nti; (icsez_._2) .ntf0 = *ntf; (icsez_._2) .ny0 = *ny; (icsez_._2) .nea0 = *nea; (icsez_._2) .itmx0 = *itmx; (icsez_._2) .nex0 = *nex; (icsez_._2) .nob0 = *nob; (icsez_._2) .ntob0 = *ntob; (icsez_._2) .ntobi0 = *ntobi; (icsez_._2) .nitu0 = *nitu; (icsez_._2) .ndtu0 = *ndtu; (nird_._2) .nitv0 = 0; (nird_._2) .nrtv0 = 0; (nird_._2) .ndtv0 = 0; ind = 0; icse_(&ind, nu, &zz, &zz, &zz, &zz, &zz, &zz, &zz, &zz, &zz); *nitv = (( 1 ) >= ( (nird_._2) .nitv0 ) ? ( 1 ) : ( (nird_._2) .nitv0 )) ; *nrtv = (( 1 ) >= ( (nird_._2) .nrtv0 ) ? ( 1 ) : ( (nird_._2) .nrtv0 )) ; *ndtv = (( 1 ) >= ( (nird_._2) .ndtv0 ) ? ( 1 ) : ( (nird_._2) .ndtv0 )) ; return 0; } int icse1_(ind, nu, u, icsef, y0, ytot, f, b, fy, fu, ipv1, dm, yold, smold, yint, yerr, dif1, dif2, dif3, itu, dtu, t0, tf, dti, dtf, ermx, iu, nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu) integer *ind, *nu; doublereal *u; int (*icsef) (); doublereal *y0, *ytot, *f, *b, *fy, *fu; integer *ipv1; doublereal *dm, *yold, *smold, *yint, *yerr, *dif1, *dif2, *dif3; integer *itu; doublereal *dtu, *t0, *tf, *dti, *dtf, *ermx; integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, * ntob, *ntobi, *nitu, *ndtu; { integer ytot_dim1, ytot_offset, fy_dim1, fy_offset, fu_dim1, fu_offset, dm_dim1, dm_offset, i__1, i__2, i__3; doublereal d__1; integer s_wsle(), do_lio(), e_wsle(); static integer indf, info; static doublereal told; extern doublereal dnrm2_(); extern int dgefa_(); static integer i__, j; static doublereal t; extern int dscal_(), dgesl_(), dcopy_(); static doublereal dtinv; extern int daxpy_(); static doublereal dt; static integer it, kt; static doublereal err; static integer luv; extern int dadd_(); static cilist io___2357 = { 0, 6, 0, 0, 0 }; --u; --iu; --dif3; --dif2; --dif1; --yerr; --yint; --smold; --yold; dm_dim1 = *ny; dm_offset = dm_dim1 + 1; dm -= dm_offset; --ipv1; fu_dim1 = *ny; fu_offset = fu_dim1 + 1; fu -= fu_offset; fy_dim1 = *ny; fy_offset = fy_dim1 + 1; fy -= fy_offset; --b; --f; ytot_dim1 = *ny; ytot_offset = ytot_dim1 + 1; ytot -= ytot_offset; --y0; --itu; --dtu; t = *t0; dcopy_(ny, &y0[1], &c__1, &yold[1], &c__1); i__1 = *nti + *ntf; for (kt = 1; kt <= i__1; ++kt) { i__2 = *nu, i__3 = *nuc + 1 + (kt - 1) * *nuv; luv = (( i__2 ) <= ( i__3 ) ? ( i__2 ) : ( i__3 )) ; told = t; if (kt <= *nti) { t = kt * *dti + *t0; dt = *dti; } else { t = *nti * *dti + (kt - *nti) * *dtf + *t0; dt = *dtf; } dtinv = 1. / dt; if (kt == 1 || kt == *nti + 1 || *ilin <= 1) { indf = 2; if (kt == 1 || *ilin <= 1) { (*icsef)(&indf, &told, &yold[1], &u[1], &u[luv], &f[1], &fy[ fy_offset], &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu) ; } if (indf <= 0) { *ind = indf; return 0; } i__2 = *ny; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = *ny; for (j = 1; j <= i__3; ++j) { dm[i__ + j * dm_dim1] = -fy[i__ + j * fy_dim1] / 2.; } } i__3 = *ny; for (i__ = *nea + 1; i__ <= i__3; ++i__) { dm[i__ + i__ * dm_dim1] += dtinv; } dgefa_(&dm[dm_offset], ny, ny, &ipv1[1], &info); } it = 1; if (kt == 1) { indf = 1; (*icsef)(&indf, &told, &yold[1], &u[1], &u[luv], &smold[1], &fy[ fy_offset], &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu); if (indf <= 0) { *ind = indf; return 0; } } if (*nea > 0) { i__3 = *nea; for (i__ = 1; i__ <= i__3; ++i__) { smold[i__] = 0.; } } dcopy_(ny, &smold[1], &c__1, &dif1[1], &c__1); dscal_(ny, &dt, &dif1[1], &c__1); i__3 = *nu, i__2 = *nuc + 1 + kt * *nuv; luv = (( i__3 ) <= ( i__2 ) ? ( i__3 ) : ( i__2 )) ; dcopy_(ny, &yold[1], &c__1, &yint[1], &c__1); dadd_(ny, &dif1[1], &c__1, &yint[1], &c__1); indf = 1; (*icsef)(&indf, &t, &yint[1], &u[1], &u[luv], &dif2[1], &fy[fy_offset] , &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu); if (indf <= 0) { *ind = indf; return 0; } dadd_(ny, &smold[1], &c__1, &dif2[1], &c__1); dscal_(ny, &c_b806, &dif2[1], &c__1); d__1 = -dtinv; daxpy_(ny, &d__1, &dif1[1], &c__1, &dif2[1], &c__1); dcopy_(ny, &dif1[1], &c__1, &dif3[1], &c__1); L50: dgesl_(&dm[dm_offset], ny, ny, &ipv1[1], &dif2[1], &c__0); dadd_(ny, &dif2[1], &c__1, &dif3[1], &c__1); dcopy_(ny, &yold[1], &c__1, &yerr[1], &c__1); dadd_(ny, &dif3[1], &c__1, &yerr[1], &c__1); if (*ermx < 0.) { goto L55; } indf = 1; (*icsef)(&indf, &t, &yerr[1], &u[1], &u[luv], &dif1[1], &fy[fy_offset] , &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu); if (indf <= 0) { *ind = indf; return 0; } dcopy_(ny, &dif1[1], &c__1, &dif2[1], &c__1); dadd_(ny, &smold[1], &c__1, &dif2[1], &c__1); dscal_(ny, &c_b806, &dif2[1], &c__1); i__3 = *ny - *nea; d__1 = -dtinv; daxpy_(&i__3, &d__1, &dif3[*nea + 1], &c__1, &dif2[*nea + 1], &c__1); err = dnrm2_(ny, &dif2[1], &c__1); if (err > *ermx && *ilin == 0) { ++it; if (it > *itmx) { *ind = -1; s_wsle(&io___2357); do_lio(&c__9, &c__1, " icse : integration de l etat impossible", 40L); e_wsle(); return 0; } goto L50; } L55: dcopy_(ny, &yerr[1], &c__1, &yold[1], &c__1); dcopy_(ny, &yold[1], &c__1, &ytot[kt * ytot_dim1 + 1], &c__1); dcopy_(ny, &dif1[1], &c__1, &smold[1], &c__1); } return 0; } int icse2_(ind, nu, u, co, g, icsef, icsec2, icsei, y0, tob, obs, ob, ytot, f, b, fy, fu, ipv2, itob, cof, ytob, c2y, y0u, dmy, smy, oldmu, y, oldp, p, p0, gt, yob, d__, itu, dtu, t0, tf, dti, dtf, ermx, iu, nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, nomf_len, nomc_len, nomi_len) integer *ind, *nu; doublereal *u, *co, *g; int (*icsef) (), (*icsec2) (), (*icsei) (); doublereal *y0, *tob, *obs, *ob, *ytot, *f, *b, *fy, *fu; integer *ipv2, *itob; doublereal *cof, *ytob, *c2y, *y0u, *dmy, *smy, *oldmu, *y, *oldp, *p, *p0, * gt, *yob, *d__; integer *itu; doublereal *dtu, *t0, *tf, *dti, *dtf, *ermx; integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, * ntob, *ntobi, *nitu, *ndtu; char *nomf, *nomc, *nomi; ftnlen nomf_len; ftnlen nomc_len; ftnlen nomi_len; { integer obs_dim1, obs_offset, ob_dim1, ob_dim2, ob_offset, ytot_dim1, ytot_offset, fy_dim1, fy_offset, fu_dim1, fu_offset, cof_dim1, cof_offset, ytob_dim1, ytob_offset, c2y_dim1, c2y_offset, y0u_dim1, y0u_offset, dmy_dim1, dmy_offset, smy_dim1, smy_offset, oldmu_dim1, oldmu_offset, yob_dim1, yob_offset, i__1, i__2; static integer indc, indf, indi; extern int dset_(); static integer ktob, info; extern int dgefa_(); static integer i__, j; static doublereal t; extern int dscal_(), dgesl_(), dcopy_(), dmmul_(); static doublereal dt2new, dt; static integer kt; static doublereal dt2; static integer lui, nui, luv; extern int dadd_(); --gt; --g; --u; --iu; --p0; --p; --oldp; --y; oldmu_dim1 = *ny; oldmu_offset = oldmu_dim1 + 1; oldmu -= oldmu_offset; smy_dim1 = *ny; smy_offset = smy_dim1 + 1; smy -= smy_offset; dmy_dim1 = *ny; dmy_offset = dmy_dim1 + 1; dmy -= dmy_offset; y0u_dim1 = *ny; y0u_offset = y0u_dim1 + 1; y0u -= y0u_offset; --ipv2; fu_dim1 = *ny; fu_offset = fu_dim1 + 1; fu -= fu_offset; fy_dim1 = *ny; fy_offset = fy_dim1 + 1; fy -= fy_offset; --b; --f; ytot_dim1 = *ny; ytot_offset = ytot_dim1 + 1; ytot -= ytot_offset; --y0; --d__; obs_dim1 = *nob; obs_offset = obs_dim1 + 1; obs -= obs_offset; yob_dim1 = *nob; yob_offset = yob_dim1 + 1; yob -= yob_offset; c2y_dim1 = *ny; c2y_offset = c2y_dim1 + 1; c2y -= c2y_offset; ytob_dim1 = *ny; ytob_offset = ytob_dim1 + 1; ytob -= ytob_offset; cof_dim1 = *nob; cof_offset = cof_dim1 + 1; cof -= cof_offset; --itob; ob_dim1 = *nex; ob_dim2 = *ntob; ob_offset = ob_dim1 * (ob_dim2 + 1) + 1; ob -= ob_offset; --tob; --itu; --dtu; dset_(nu, &c_b61, &g[1], &c__1); dset_(ny, &c_b61, &p[1], &c__1); kt = *nti + *ntf; ktob = *ntob; if (iu[2] > 0) { i__1 = *nu, i__2 = *nuc + 1; lui = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; } if (iu[1] > 0) { lui = 1; } nui = iu[1] * *nuc + iu[2] * *nuv * (*nti + *ntf + 1); i__1 = *ntobi; for (j = 1; j <= i__1; ++j) { itob[j] = (integer) ((tob[j] - *t0) / *dti + .5); } if (*ntobi < *ntob) { itob[*ntobi + 1] = *nti + (integer) ((tob[*ntobi + 1] - *t0 - *nti * * dti) / *dtf + .5); } if (*ntobi + 1 < *ntob) { i__1 = *ntob; for (j = *ntobi + 2; j <= i__1; ++j) { itob[j] = itob[*ntobi + 1] + (integer) ((tob[j] - tob[*ntobi + 1]) / *dtf + .5); } } i__1 = *ntob; for (j = 1; j <= i__1; ++j) { i__2 = *ny; for (i__ = 1; i__ <= i__2; ++i__) { dcopy_(ny, &ytot[itob[j] * ytot_dim1 + 1], &c__1, &ytob[j * ytob_dim1 + 1], &c__1); } } if (*ind != 3) { indc = 1; (*icsec2)(&indc, nu, &tob[1], &obs[obs_offset], &cof[cof_offset], & ytob[ytob_offset], &ob[ob_offset], &u[1], co, &c2y[c2y_offset] , &g[1], &yob[yob_offset], &d__[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L); if (indc <= 0) { *ind = indc; return 0; } } if (*ind == 2) { return 0; } indc = 2; (*icsec2)(&indc, nu, &tob[1], &obs[obs_offset], &cof[cof_offset], &ytob[ ytob_offset], &ob[ob_offset], &u[1], co, &c2y[c2y_offset], &g[1], &yob[yob_offset], &d__[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L); if (indc <= 0) { *ind = indc; return 0; } for (kt = *nti + *ntf; kt >= 1; --kt) { dcopy_(ny, &p[1], &c__1, &oldp[1], &c__1); i__2 = *nu, i__1 = *nuc + 1 + kt * *nuv; luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ; dcopy_(ny, &ytot[kt * ytot_dim1 + 1], &c__1, &y[1], &c__1); if (kt < *nti) { t = kt * *dti + *t0; dt = *dti; } else { t = *nti * *dti + (kt - *nti) * *dtf + *t0; dt = *dtf; } dt2 = dt / 2.; if (kt != *nti) { dt2new = dt2; } else { dt2new = *dti / 2.; } if (*ilin <= 1) { indf = 2; (*icsef)(&indf, &t, &y[1], &u[1], &u[luv], &f[1], &fy[fy_offset], &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L); if (indf <= 0) { *ind = indf; return 0; } } if (kt != *nti + *ntf) { if (*ilin <= 1 || kt == *nti + *ntf - 1 || kt == *nti - 1) { i__2 = *ny; for (i__ = 1; i__ <= i__2; ++i__) { i__1 = *ny; for (j = 1; j <= i__1; ++j) { smy[i__ + j * smy_dim1] = dt2 * fy[i__ + j * fy_dim1]; } } i__1 = *ny; for (i__ = 1; i__ <= i__1; ++i__) { smy[i__ + i__ * smy_dim1] += 1.; } } if (*nea > 0) { i__1 = *nea; for (i__ = 1; i__ <= i__1; ++i__) { p[i__] = 0.; } } dmmul_(&p[1], &c__1, &smy[smy_offset], ny, &p0[1], &c__1, &c__1, ny, ny); dcopy_(ny, &p0[1], &c__1, &p[1], &c__1); } if (ktob > 0) { if (kt == itob[ktob]) { i__1 = *ny; for (i__ = 1; i__ <= i__1; ++i__) { p[i__] += c2y[i__ + ktob * c2y_dim1]; } --ktob; } } if (*ilin <= 1 || kt == *nti + *ntf || kt == *nti) { i__1 = *ny; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *ny; for (j = 1; j <= i__2; ++j) { dmy[i__ + j * dmy_dim1] = -dt2new * fy[i__ + j * fy_dim1]; } } i__2 = *ny; for (i__ = *nea + 1; i__ <= i__2; ++i__) { dmy[i__ + i__ * dmy_dim1] += 1.; } dgefa_(&dmy[dmy_offset], ny, ny, &ipv2[1], &info); } dgesl_(&dmy[dmy_offset], ny, ny, &ipv2[1], &p[1], &c__1); if (*nuv > 0 || iu[3] == 1) { indf = 3; (*icsef)(&indf, &t, &y[1], &u[1], &u[luv], &f[1], &fy[fy_offset], &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L); if (indf <= 0) { *ind = indf; return 0; } if (kt < *nti + *ntf) { i__2 = *nuc + *nuv; dmmul_(&oldp[1], &c__1, &oldmu[oldmu_offset], ny, >[1], & c__1, &c__1, ny, &i__2); i__2 = *nuc + *nuv; dscal_(&i__2, &dt2, >[1], &c__1); if (iu[3] > 0) { dadd_(nuc, >[1], &c__1, &g[1], &c__1); } if (*nuv > 0) { i__2 = *nu, i__1 = *nuc + 1 + (kt + 1) * *nuv; luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ; dadd_(nuv, >[*nuc + 1], &c__1, &g[luv], &c__1); } if (*nea > 0) { i__2 = *nea; for (i__ = 1; i__ <= i__2; ++i__) { oldp[i__] = 0.; } } i__2 = *nuc + *nuv; dmmul_(&oldp[1], &c__1, &fu[fu_offset], ny, >[1], &c__1, & c__1, ny, &i__2); i__2 = *nuc + *nuv; dscal_(&i__2, &dt2, >[1], &c__1); if (iu[3] > 0) { dadd_(nuc, >[1], &c__1, &g[1], &c__1); } if (*nuv > 0) { i__2 = *nu, i__1 = *nuc + 1 + kt * *nuv; luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ; dadd_(nuv, >[*nuc + 1], &c__1, &g[luv], &c__1); } } i__2 = *ny * (*nuc + *nuv); dcopy_(&i__2, &fu[fu_offset], &c__1, &oldmu[oldmu_offset], &c__1); if (kt == 1) { t = *t0; dt2 = *dti / 2.; dcopy_(ny, &y0[1], &c__1, &y[1], &c__1); indf = 3; (*icsef)(&indf, &t, &y[1], &u[1], &u[luv], &f[1], &fy[ fy_offset], &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L); if (indf <= 0) { *ind = indf; return 0; } i__2 = *nuc + *nuv; dmmul_(&p[1], &c__1, &oldmu[oldmu_offset], ny, >[1], &c__1, &c__1, ny, &i__2); i__2 = *nuc + *nuv; dscal_(&i__2, &dt2, >[1], &c__1); if (iu[3] > 0) { dadd_(nuc, >[1], &c__1, &g[1], &c__1); } if (*nuv > 0) { i__2 = *nu, i__1 = *nuc + 1 + *nuv; luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ; dadd_(nuv, >[*nuc + 1], &c__1, &g[luv], &c__1); } if (*nea > 0) { i__2 = *nea; for (i__ = 1; i__ <= i__2; ++i__) { p[i__] = 0.; } } i__2 = *nuc + *nuv; dmmul_(&p[1], &c__1, &fu[fu_offset], ny, >[1], &c__1, &c__1, ny, &i__2); i__2 = *nuc + *nuv; dscal_(&i__2, &dt2, >[1], &c__1); if (iu[3] > 0) { dadd_(nuc, >[1], &c__1, &g[1], &c__1); } if (*nuv > 0) { i__2 = *nu, i__1 = *nuc + 1; luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ; dadd_(nuv, >[*nuc + 1], &c__1, &g[luv], &c__1); } } } } if ((( iu[1] ) >= ( iu[2] ) ? ( iu[1] ) : ( iu[2] )) > 0) { indf = 2; (*icsef)(&indf, &t, &y[1], &u[1], &u[luv], &f[1], &fy[fy_offset], &fu[ fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, & iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L); if (indf == 0) { *ind = indf; return 0; } i__2 = *ny; for (i__ = 1; i__ <= i__2; ++i__) { i__1 = *ny; for (j = 1; j <= i__1; ++j) { smy[i__ + j * smy_dim1] = dt2 * fy[i__ + j * fy_dim1]; } } i__1 = *ny; for (i__ = 1; i__ <= i__1; ++i__) { smy[i__ + i__ * smy_dim1] += 1.; } if (*nea > 0) { i__1 = *nea; for (i__ = 1; i__ <= i__1; ++i__) { p[i__] = 0.; } } dmmul_(&p[1], &c__1, &smy[smy_offset], ny, &p0[1], &c__1, &c__1, ny, ny); indi = 2; (*icsei)(&indi, &nui, &u[lui], &y0[1], &y0u[y0u_offset], &itu[1], & dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L); if (indi <= 0) { *ind = indi; return 0; } dmmul_(&p0[1], &c__1, &y0u[y0u_offset], ny, >[1], &c__1, &c__1, & nui, &nui); i__1 = nui; for (i__ = 1; i__ <= i__1; ++i__) { g[lui + i__ - 1] += gt[i__]; } } } int icsec2_(indc, nu, tob, obs, cof, ytob, ob, u, c__, cy, g, yob, d__, itu, dtu, t0, tf, dti, dtf, ermx, iu, nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu) integer *indc, *nu; doublereal *tob, *obs, *cof, *ytob, *ob, *u, *c__, *cy, *g, *yob, *d__; integer *itu; doublereal *dtu, *t0, *tf, *dti, *dtf, *ermx; integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, * ntob, *ntobi, *nitu, *ndtu; { integer obs_dim1, obs_offset, cof_dim1, cof_offset, ytob_dim1, ytob_offset, ob_dim1, ob_dim2, ob_offset, cy_dim1, cy_offset, yob_dim1, yob_offset, i__1, i__2, i__3; doublereal d__1; static integer i__, j, k; extern int dmmul_(); --g; --u; --iu; --d__; obs_dim1 = *nob; obs_offset = obs_dim1 + 1; obs -= obs_offset; yob_dim1 = *nob; yob_offset = yob_dim1 + 1; yob -= yob_offset; cy_dim1 = *ny; cy_offset = cy_dim1 + 1; cy -= cy_offset; ob_dim1 = *nex; ob_dim2 = *ntob; ob_offset = ob_dim1 * (ob_dim2 + 1) + 1; ob -= ob_offset; ytob_dim1 = *ny; ytob_offset = ytob_dim1 + 1; ytob -= ytob_offset; cof_dim1 = *nob; cof_offset = cof_dim1 + 1; cof -= cof_offset; --tob; --itu; --dtu; dmmul_(&obs[obs_offset], nob, &ytob[ytob_offset], ny, &yob[yob_offset], nob, nob, ny, ntob); if (*indc == 1) { *c__ = 0.; i__1 = *nob; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *ntob; for (j = 1; j <= i__2; ++j) { i__3 = *nex; for (k = 1; k <= i__3; ++k) { d__1 = yob[i__ + j * yob_dim1] - ob[k + (j + i__ * ob_dim2) * ob_dim1]; *c__ += cof[i__ + j * cof_dim1] * .5 * (d__1 * d__1); } } } } else { i__1 = *ntob; for (j = 1; j <= i__1; ++j) { i__2 = *nob; for (i__ = 1; i__ <= i__2; ++i__) { d__[i__] = 0.; i__3 = *nex; for (k = 1; k <= i__3; ++k) { d__[i__] += cof[i__ + j * cof_dim1] * (yob[i__ + j * yob_dim1] - ob[k + (j + i__ * ob_dim2) * ob_dim1]) ; } } dmmul_(&d__[1], &c__1, &obs[obs_offset], nob, &cy[j * cy_dim1 + 1] , &c__1, &c__1, nob, ny); } } } int icsei_(indi, nui, u, y0, y0u, itu, dtu, t0, tf, dti, dtf, ermx, iu, nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu) integer *indi, *nui; doublereal *u, *y0, *y0u; integer *itu; doublereal *dtu, *t0, *tf, *dti, *dtf, *ermx; integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, * ntob, *ntobi, *nitu, *ndtu; { integer y0u_dim1, y0u_offset, i__1; extern int dset_(); static integer i__; --u; --iu; y0u_dim1 = *ny; y0u_offset = y0u_dim1 + 1; y0u -= y0u_offset; --y0; --itu; --dtu; if (*indi == 1) { i__1 = *ny; for (i__ = 1; i__ <= i__1; ++i__) { y0[i__] = u[i__]; } } if (*indi == 2) { i__1 = *ny * *nui; dset_(&i__1, &c_b61, &y0u[y0u_offset], &c__1); i__1 = *ny; for (i__ = 1; i__ <= i__1; ++i__) { y0u[i__ + i__ * y0u_dim1] = 1.; } } } int majour_(hm, hd, dd, n, hno, ir, indic, eps) doublereal *hm, *hd, *dd; integer *n; doublereal *hno; integer *ir, *indic; doublereal *eps; { integer i__1, i__2; doublereal d__1; static doublereal honm, b; static integer i__, j; static doublereal r__, y; static integer iplus; static doublereal gm; static integer ll, mm, np; static doublereal del, hml, hon; --hm; --dd; --hd; if (*n == 1) { goto L100; } np = *n + 1; if (*hno > 0.) { goto L99; } if (*hno == 0.) { goto L999; } if (*ir == 0) { goto L999; } hon = 1. / *hno; ll = 1; if (*indic == 0) { goto L1; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (hm[ll] == 0.) { goto L2; } d__1 = dd[i__]; hon += d__1 * d__1 / hm[ll]; L2: ll = ll + np - i__; } goto L3; L1: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dd[i__] = hd[i__]; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { iplus = i__ + 1; del = dd[i__]; if (hm[ll] > 0.) { goto L6; } dd[i__] = 0.; ll = ll + np - i__; goto L5; L6: d__1 = del; hon += d__1 * d__1 / hm[ll]; if (i__ == *n) { goto L7; } i__2 = *n; for (j = iplus; j <= i__2; ++j) { ++ll; dd[j] -= del * hm[ll]; } L7: ++ll; L5: ; } L3: if (*ir <= 0) { goto L9; } if (hon > 0.) { goto L10; } if (*indic - 1 <= 0) { goto L99; } else { goto L11; } L9: hon = 0.; *ir = -(*ir) - 1; goto L11; L10: hon = *eps / *hno; if (*eps == 0.) { --(*ir); } L11: mm = 1; honm = hon; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { j = np - i__; ll -= i__; if (hm[ll] != 0.) { d__1 = dd[j]; honm = hon - d__1 * d__1 / hm[ll]; } dd[j] = hon; hon = honm; } goto L13; L99: mm = 0; honm = 1. / *hno; L13: ll = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { iplus = i__ + 1; del = hd[i__]; if (hm[ll] > 0.) { goto L14; } if (*ir > 0) { goto L15; } if (*hno < 0.) { goto L15; } if (del == 0.) { goto L15; } *ir = 1 - *ir; d__1 = del; hm[ll] = d__1 * d__1 / honm; if (i__ == *n) { goto L999; } i__2 = *n; for (j = iplus; j <= i__2; ++j) { ++ll; hm[ll] = hd[j] / del; } goto L999; L15: hon = honm; ll = ll + np - i__; goto L98; L14: hml = del / hm[ll]; if (mm <= 0) { goto L17; } else { goto L18; } L17: hon = honm + del * hml; goto L19; L18: hon = dd[i__]; L19: r__ = hon / honm; hm[ll] *= r__; if (r__ == 0.) { goto L20; } if (i__ == *n) { goto L20; } b = hml / hon; if (r__ > 4.) { goto L21; } i__2 = *n; for (j = iplus; j <= i__2; ++j) { ++ll; hd[j] -= del * hm[ll]; hm[ll] += b * hd[j]; } goto L23; L21: gm = honm / hon; i__2 = *n; for (j = iplus; j <= i__2; ++j) { ++ll; y = hm[ll]; hm[ll] = b * hd[j] + y * gm; hd[j] -= del * y; } L23: honm = hon; ++ll; L98: ; } L20: if (*ir < 0) { *ir = -(*ir); } goto L999; L100: d__1 = hd[1]; hm[1] += *hno * (d__1 * d__1); *ir = 1; if (hm[1] > 0.) { goto L999; } hm[1] = 0.; *ir = 0; L999: return 0; } int majysa_(n, nt, np, y, s, ys, lb, g, x, g1, x1, index, ialg, nb) integer *n, *nt, *np; doublereal *y, *s, *ys; integer *lb; doublereal *g, *x, *g1, *x1; integer *index, *ialg, *nb; { integer y_dim1, y_offset, s_dim1, s_offset, i__1; static integer i__, ij; --index; --x1; --g1; --x; --g; --ys; s_dim1 = *nt; s_offset = s_dim1 + 1; s -= s_offset; y_dim1 = *nt; y_offset = y_dim1 + 1; y -= y_offset; --ialg; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { y[*lb + i__ * y_dim1] = g[i__] - g1[i__]; s[*lb + i__ * s_dim1] = x[i__] - x1[i__]; } ys[*lb] = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ys[*lb] += y[*lb + i__ * y_dim1] * s[*lb + i__ * s_dim1]; } if (ialg[8] == 5 && *np > 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { y[i__ * y_dim1 + 1] += y[*lb + i__ * y_dim1]; s[i__ * s_dim1 + 1] += s[*lb + i__ * s_dim1]; } ys[1] = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ys[1] += y[i__ * y_dim1 + 1] * s[i__ * s_dim1 + 1]; } } if (*np < *nt) { ++(*np); index[*lb] = *np; } else { ij = *lb; i__1 = *nt; for (i__ = *nb; i__ <= i__1; ++i__) { ++ij; if (ij > *nt) { ij = *nb; } index[i__] = ij; } } if (*lb == *nt) { *lb = *nb; } else { ++(*lb); } return 0; } int majz_(n, np, nt, y, s, z__, ys, zs, diag, index) integer *n, *np, *nt; doublereal *y, *s, *z__, *ys, *zs, *diag; integer *index; { integer y_dim1, y_offset, s_dim1, s_offset, z_dim1, z_offset, i__1, i__2, i__3; static integer i__, j, l, jj, jl; static doublereal psy, psz; --diag; --index; --zs; --ys; z_dim1 = *nt; z_offset = z_dim1 + 1; z__ -= z_offset; s_dim1 = *nt; s_offset = s_dim1 + 1; s -= s_offset; y_dim1 = *nt; y_offset = y_dim1 + 1; y -= y_offset; l = index[1]; i__1 = *n; for (jj = 1; jj <= i__1; ++jj) { z__[l + jj * z_dim1] = diag[jj] * s[l + jj * s_dim1]; } zs[l] = 0.; i__1 = *n; for (jj = 1; jj <= i__1; ++jj) { zs[l] += z__[l + jj * z_dim1] * s[l + jj * s_dim1]; } if (*np == 1) { return 0; } i__1 = *np; for (i__ = 2; i__ <= i__1; ++i__) { l = index[i__]; i__2 = *n; for (jj = 1; jj <= i__2; ++jj) { z__[l + jj * z_dim1] = diag[jj] * s[l + jj * s_dim1]; } i__2 = i__ - 1; for (j = 1; j <= i__2; ++j) { psy = 0.; psz = 0.; jl = index[j]; i__3 = *n; for (jj = 1; jj <= i__3; ++jj) { psy += y[jl + jj * y_dim1] * s[l + jj * s_dim1]; psz += z__[jl + jj * z_dim1] * s[l + jj * s_dim1]; } i__3 = *n; for (jj = 1; jj <= i__3; ++jj) { z__[l + jj * z_dim1] = z__[l + jj * z_dim1] + psy * y[jl + jj * y_dim1] / ys[jl] - psz * z__[jl + jj * z_dim1] / zs[ jl]; } } zs[l] = 0.; i__2 = *n; for (jj = 1; jj <= i__2; ++jj) { zs[l] += z__[l + jj * z_dim1] * s[l + jj * s_dim1]; } } return 0; } int n1fc1_(simul, prosca, n, xn, fn, g, dxmin, df1, epsf, zero, imp, io, mode, iter, nsim, memax, iz, rz, dz, izs, rzs, dzs) int (*simul) (), (*prosca) (); integer *n; doublereal *xn, *fn, *g, *dxmin, *df1, *epsf, *zero; integer *imp, *io, *mode, *iter, *nsim, *memax, *iz; doublereal *rz, *dz; integer *izs; real *rzs; doublereal *dzs; { static char fmt_1001[] = "(\002 n1fc1 appel incoherent\002)"; static char fmt_1000[] = "(\002 entree dans n1fc1. n=\002,i4,\002 memax=\002,i3/\002 dimensions minimales\002,2x,\002iz(\002,i4,\002) rz(\002,i6,\002) dz(\002,i6,\002)\002/)"; integer i__1; integer s_wsfe(), e_wsfe(), do_fio(); static integer nanc, nxga, naps, ntot, i__; extern int n1fc1a_(); static integer na, ne, nq, nr, ns, nx, ny, npoids, nw1, nw2, ngd, nic, nal, ngg, njc, nsa, ndz, nrr, niz, nrz; static cilist io___2400 = { 0, 0, 0, fmt_1001, 0 }; static cilist io___2424 = { 0, 0, 0, fmt_1000, 0 }; --g; --xn; --iz; --rz; --dz; --izs; --rzs; --dzs; if (*n > 0 && *df1 > 0. && *epsf >= 0. && *zero >= 0. && *iter >= 0 && * nsim >= 0 && *memax >= 1 && *dxmin > 0.) { goto L10; } *mode = 2; io___2400.ciunit = *io; s_wsfe(&io___2400); e_wsfe(); goto L999; L10: ns = 1; ngd = ns + *n; nx = ngd + *n; nsa = nx + *n; ngg = nsa + *n; nal = ngg + *n; naps = nal + *memax; nanc = naps + *memax; npoids = nanc + *memax; nq = npoids + *memax; njc = 1; nic = njc + *memax + 1; nr = 1; na = nr + (*memax + 1) * (*memax + 1); ne = na + *memax + 1; nrr = ne + *memax + 1; nxga = nrr + *memax + 1; ny = nxga + *memax + 1; nw1 = ny + *memax + 1; nw2 = nw1 + *memax + 1; niz = *memax + 1 << 1; nrz = nq + *n * *memax - 1; ndz = nw2 + *memax; if (*imp > 0) { io___2424.ciunit = *io; s_wsfe(&io___2424); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*memax), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&niz, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nrz, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ndz, (ftnlen)sizeof(integer)); e_wsfe(); } i__1 = niz; for (i__ = 1; i__ <= i__1; ++i__) { iz[i__] = 0; } i__1 = nrz; for (i__ = 1; i__ <= i__1; ++i__) { rz[i__] = 0.; } i__1 = ndz; for (i__ = 1; i__ <= i__1; ++i__) { dz[i__] = 0.; } n1fc1a_(simul, prosca, n, mode, &xn[1], fn, &g[1], df1, epsf, dxmin, imp, zero, io, &ntot, iter, nsim, memax, &rz[ns], &rz[ngd], &rz[nx], & rz[nsa], &rz[ngg], &rz[nal], &rz[naps], &rz[nanc], &rz[npoids], & rz[nq], &iz[njc], &iz[nic], &dz[nr], &dz[na], &dz[ne], &dz[nrr], & dz[nxga], &dz[ny], &dz[nw1], &dz[nw2], &izs[1], &rzs[1], &dzs[1]); iz[1] = ntot; L999: return 0; } int n1fc1a_(simul, prosca, n, mode, xn, fn, g, df0, eps0, dx, imp, zero, io, ntot, iter, nsim, memax, s, gd, x, sa, gg, al, aps, anc, poids, q, jc, ic, r__, a, e, rr, xga, y, w1, w2, izs, rzs, dzs) int (*simul) (), (*prosca) (); integer *n, *mode; doublereal *xn, *fn, *g, *df0, *eps0, *dx; integer *imp; doublereal *zero; integer *io, *ntot, *iter, *nsim, *memax; doublereal *s, *gd, *x, *sa, *gg, *al, *aps, *anc, *poids, *q; integer *jc, *ic; doublereal *r__, *a, *e, *rr, *xga, *y, *w1, *w2; integer *izs; real *rzs; doublereal *dzs; { static char fmt_1000[] = "(\002 n1fc1 iter nsim\002,6x,\002fn\002,11x,\002eps\002,7x,\002s2\002,9x,\002u\002,5x,\002nv\002)"; static char fmt_1002[] = "(/\002 n1fc1\002,\002 tableau des poids\002/(\002 n1fc1\002,3x,7d10.3))"; static char fmt_1004[] = "(\002 n1fc1\002,i7,i5,d16.7,\002 convergence a\002,d10.3,\002 pres\002,\002 (\002,d9.2,\002)\002)"; static char fmt_1005[] = "(\002 n1fc1\002,i7,i5,d16.7,\002 faisceau reduit a\002,i3,\002 gradients\002)"; static char fmt_1006[] = "(/\002 n1fc1 fin sur nsim\002)"; static char fmt_1007[] = "(\002 n1fc1\002,3x,i4,i5,2x,d14.7,3d10.2,i3)"; static char fmt_1009[] = "(\002 n1fc1\002,10x,\002logic=\002,i2,4x,\002ro=\002,d10.3,4x,\002tps=\002,d10.3,4x,\002tnc=\002,d10.3)"; static char fmt_1010[] = "(\002 n1fc1\002,12x,\002diam2=\002,d10.3,4x,\002eta2=\002,d10.3,4x,\002ap=\002,d10.3)"; static char fmt_1011[] = "(/\002 n1fc1 la direction ne pivote plus\002)"; static char fmt_1012[] = "(/\002 n1fc1 fin sur iter =\002,i4)"; static char fmt_1013[] = "(/\002 n1fc1 fin anormale de fprf2\002)"; static char fmt_1014[] = "(/\002 n1fc1 fin sur dxmin\002)"; static char fmt_1015[] = "(/\002 n1fc1 attention on bute sur tmax, reduire l'echelle\002)"; static char fmt_1016[] = "(/\002 n1fc1 fin normale\002)"; static char fmt_1017[] = "(1x)"; static char fmt_1018[] = "(/\002 n1fc1 fin sur indic=0\002)"; integer i__1, i__2; doublereal d__1, d__2, d__3; integer s_wsfe(), e_wsfe(), do_fio(); double sqrt(); static doublereal alfa, beta, epsm, tmin, tmax, diam2; extern int frdf1_(), fprf2_(), nlis2_(); static doublereal f; static integer i__, k, j, iflag; static doublereal u; static integer indic, kgrad; static doublereal z__; static integer logic, itmax, itimp; static doublereal ajust, s2, s3; extern int ffinf1_(); static doublereal z1, z2; static integer logic2; extern int fremf1_(); static integer memax1; static doublereal fa, df, ap; static integer nk, mm; static doublereal ro; static integer nv, napmax, nt1; static doublereal s3n, roa; static integer nta; static doublereal eps, fpn, tnc; static integer nki; static doublereal tol, tps, eta2; static cilist io___2444 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2445 = { 0, 0, 0, fmt_1012, 0 }; static cilist io___2452 = { 0, 0, 0, fmt_1013, 0 }; static cilist io___2456 = { 0, 0, 0, fmt_1004, 0 }; static cilist io___2457 = { 0, 0, 0, fmt_1016, 0 }; static cilist io___2459 = { 0, 0, 0, fmt_1017, 0 }; static cilist io___2460 = { 0, 0, 0, fmt_1007, 0 }; static cilist io___2461 = { 0, 0, 0, fmt_1002, 0 }; static cilist io___2463 = { 0, 0, 0, fmt_1011, 0 }; static cilist io___2473 = { 0, 0, 0, fmt_1014, 0 }; static cilist io___2474 = { 0, 0, 0, fmt_1006, 0 }; static cilist io___2475 = { 0, 0, 0, fmt_1018, 0 }; static cilist io___2476 = { 0, 0, 0, fmt_1015, 0 }; static cilist io___2478 = { 0, 0, 0, fmt_1010, 0 }; static cilist io___2480 = { 0, 0, 0, fmt_1005, 0 }; static cilist io___2481 = { 0, 0, 0, fmt_1009, 0 }; --gg; --sa; --x; --gd; --s; --g; --xn; --poids; --anc; --aps; --al; --q; --jc; --ic; --r__; --a; --e; --rr; --xga; --y; --w1; --w2; --izs; --rzs; --dzs; itmax = *iter; *iter = 0; itimp = 0; napmax = *nsim; *nsim = 1; logic = 1; logic2 = 0; tmax = 1e20; eps = *df0; epsm = eps; df = *df0; *mode = 1; *ntot = 0; iflag = 0; aps[1] = 0.; anc[1] = 0.; poids[1] = 0.; nta = 0; kgrad = 1; memax1 = *memax + 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { q[i__] = -g[i__]; } (*prosca)(n, &g[1], &g[1], &diam2, &izs[1], &rzs[1], &dzs[1]); diam2 = *df0 * 100. * *df0 / diam2; eta2 = *eps0 * .01 * *eps0 / diam2; ap = *zero * *df0 / diam2; if (*imp > 2) { io___2444.ciunit = *io; s_wsfe(&io___2444); e_wsfe(); } L100: ++(*iter); ++itimp; if (*iter < itmax) { goto L110; } if (*imp > 0) { io___2445.ciunit = *io; s_wsfe(&io___2445); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); e_wsfe(); } *mode = 4; goto L900; L110: ++(*ntot); if (logic == 3) { ro *= sqrt(s2); } if (itimp != -(*imp)) { goto L200; } itimp = 0; indic = 1; (*simul)(&indic, n, &xn[1], &f, &g[1], &izs[1], &rzs[1], &dzs[1]); L200: eps = (( eps ) <= ( epsm ) ? ( eps ) : ( epsm )) ; eps = (( eps ) >= ( *eps0 ) ? ( eps ) : ( *eps0 )) ; fremf1_(prosca, &iflag, n, ntot, &nta, &memax1, &q[1], &poids[1], &e[1], & a[1], &r__[1], &izs[1], &rzs[1], &dzs[1]); fprf2_(&iflag, ntot, &nv, io, zero, &s2, &eps, &al[1], imp, &u, &eta2, & memax1, &jc[1], &ic[1], &r__[1], &a[1], &e[1], &rr[1], &xga[1], & y[1], &w1[1], &w2[1]); if (iflag == 0) { goto L250; } if (*imp > 0) { io___2452.ciunit = *io; s_wsfe(&io___2452); e_wsfe(); } *mode = 7; goto L900; L250: nta = *ntot; ffinf1_(n, &nv, &jc[1], &xga[1], &q[1], &s[1]); u = (( u ) >= ( 0. ) ? ( u ) : ( 0. )) ; s2 = (( s2 ) >= ( 0. ) ? ( s2 ) : ( 0. )) ; if (s2 > eta2) { goto L300; } z__ = 0.; i__1 = nv; for (k = 1; k <= i__1; ++k) { j = jc[k] - 1; if (j > 0) { z__ += xga[k] * poids[j]; } } epsm = (( epsm ) <= ( z__ ) ? ( epsm ) : ( z__ )) ; if (*imp >= 2) { io___2456.ciunit = *io; s_wsfe(&io___2456); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*fn), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&epsm, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&s2, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (epsm > *eps0) { goto L270; } *mode = 1; if (*imp > 0) { io___2457.ciunit = *io; s_wsfe(&io___2457); e_wsfe(); } goto L900; L270: d__1 = epsm * .1; epsm = (( d__1 ) >= ( *eps0 ) ? ( d__1 ) : ( *eps0 )) ; eps = epsm; if (logic == 3) { tol = eps * .01; } iflag = 2; goto L200; L300: if (*imp > 3) { io___2459.ciunit = *io; s_wsfe(&io___2459); e_wsfe(); } if (*imp > 2) { io___2460.ciunit = *io; s_wsfe(&io___2460); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*fn), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&s2, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&u, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&nv, (ftnlen)sizeof(integer)); e_wsfe(); } if (*imp >= 6) { io___2461.ciunit = *io; s_wsfe(&io___2461); i__1 = *ntot; for (i__ = 1; i__ <= i__1; ++i__) { do_fio(&c__1, (char *)&poids[i__], (ftnlen)sizeof(doublereal)); } e_wsfe(); } if (logic != 3) { goto L350; } z__ = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { z1 = s[i__] - sa[i__]; z__ += z1 * z1; } if (z__ > *zero * 10. * *zero * s2) { goto L350; } if (*imp > 0) { io___2463.ciunit = *io; s_wsfe(&io___2463); e_wsfe(); } *mode = 8; goto L900; L350: iflag = 3; s3 = s2 + u * eps; if (logic == 3) { goto L365; } ro = df * 2. / s3; tol = eps * .01; goto L370; L365: ro /= sqrt(s2); d__1 = tol * .6, d__2 = *eps0 * .01; tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; L370: fa = *fn; alfa = .2; beta = .1; fpn = -s3; if (*memax == 1) { tol = 0.; } tmin = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__2 = tmin, d__3 = (d__1 = s[i__] / *dx, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); tmin = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } tmin = 1. / tmin; if (*iter == 1) { roa = ro; } nlis2_(simul, prosca, n, &xn[1], fn, &fpn, &ro, &tmin, &tmax, &s[1], &s2, &g[1], &gd[1], &alfa, &beta, imp, io, &logic, nsim, &napmax, &x[1] , &tol, &ap, &tps, &tnc, &gg[1], &izs[1], &rzs[1], &dzs[1]); if (logic == 0 || logic == 2 || logic == 3) { goto L380; } if (*imp <= 0) { goto L375; } if (logic == 6 || logic < 0) { io___2473.ciunit = *io; s_wsfe(&io___2473); e_wsfe(); } if (logic == 4) { io___2474.ciunit = *io; s_wsfe(&io___2474); e_wsfe(); } if (logic == 5) { io___2475.ciunit = *io; s_wsfe(&io___2475); e_wsfe(); } if (logic == 1) { io___2476.ciunit = *io; s_wsfe(&io___2476); e_wsfe(); } L375: if (logic == 1) { *mode = 3; } if (logic == 4) { *mode = 5; } if (logic == 5) { *mode = 0; } if (logic == 6) { *mode = 6; } if (logic < 0) { *mode = logic; } goto L900; L380: if (logic != 3) { goto L385; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sa[i__] = s[i__]; } L385: if (*iter > 1) { goto L390; } if (logic == 0) { tps = *fn - fa - ro * fpn; } ap = *zero * *zero * (( tps ) >= 0 ? ( tps ) : -( tps )) / (s2 * ro * ro); ajust = ro / roa; if (logic != 3) { diam2 = diam2 * ajust * ajust; } if (logic != 3) { eta2 /= ajust * ajust; } if (*imp >= 2) { io___2478.ciunit = *io; s_wsfe(&io___2478); do_fio(&c__1, (char *)&diam2, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&eta2, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&ap, (ftnlen)sizeof(doublereal)); e_wsfe(); } L390: mm = *memax - 1; if (logic == 2) { mm = *memax - 2; } if (*ntot <= mm) { goto L400; } frdf1_(prosca, n, ntot, &mm, &kgrad, &al[1], &q[1], &s[1], &poids[1], & aps[1], &anc[1], &memax1, &r__[1], &e[1], &ic[1], &izs[1], &rzs[1] , &dzs[1]); iflag = 1; nta = *ntot; if (*imp >= 2) { io___2480.ciunit = *io; s_wsfe(&io___2480); do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*fn), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*ntot), (ftnlen)sizeof(integer)); e_wsfe(); } L400: if (*imp >= 5) { io___2481.ciunit = *io; s_wsfe(&io___2481); do_fio(&c__1, (char *)&logic, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ro, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&tps, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&tnc, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (logic == 3) { goto L500; } iflag = (( iflag ) <= ( 2 ) ? ( iflag ) : ( 2 )) ; df = fa - *fn; if (*ntot == 0) { goto L500; } s3n = ro * sqrt(s2); i__1 = *ntot; for (k = 1; k <= i__1; ++k) { nk = (k - 1) * *n; z__ = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { nki = nk + i__; z__ += q[nki] * s[i__]; } y[k] = z__; z1 = (d__1 = aps[k] + (-df + ro * z__), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); z2 = anc[k] + s3n; d__1 = z1, d__2 = ap * z2 * z2; poids[k] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; aps[k] = z1; anc[k] = z2; } eps = ro * s3; kgrad = *ntot + 1; L500: nt1 = *ntot + 1; if (logic == 3) { goto L510; } aps[nt1] = 0.; anc[nt1] = 0.; poids[nt1] = 0.; goto L520; L510: aps[nt1] = tps; anc[nt1] = sqrt(tnc); d__1 = tps, d__2 = ap * tnc; poids[nt1] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; L520: nk = *ntot * *n; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { nki = nk + i__; q[nki] = -g[i__]; } if (logic != 2) { goto L550; } ++(*ntot); logic = 3; logic2 = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { g[i__] = gd[i__]; } goto L390; L550: logic -= logic2; logic2 = 0; goto L100; L900: if (*iter <= 1) { goto L990; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { g[i__] = -s[i__]; } L990: return 0; } int n1gc2_(simul, prosca, n, x, f, g, dxmin, df1, epsrel, imp, io, mode, niter, nsim, rz, nrz, izs, rzs, dzs) int (*simul) (), (*prosca) (); integer *n; doublereal *x, *f, *g, *dxmin, *df1, *epsrel; integer *imp, *io, *mode, *niter, *nsim; doublereal *rz; integer *nrz, *izs; real *rzs; doublereal *dzs; { static char fmt_1[] = "(\002 entree dans n1gc2:\002,6x,\002dimension du probleme \002,i3/2x,\002nrz=\002,i4,4x,\002niter=\002,i3,4x,\002nsim=\002,i4,4x,\002imp=\002,i3/2x,\002epsrel=\002,d8.2,4x,\002df1=\002,d8.2,4x,\002dxmin=\002,d8.2)"; static char fmt_3[] = "(/,\002 n1gc2 appel incoherent\002)"; static char fmt_2[] = "(/,\002 n1gc2 rz insuffisamment dimensionne\002)" ; static char fmt_4[] = "(/,\002 n1gc2 fin sur dxmin\002)"; static char fmt_5[] = "(/,\002 sortie de n1gc2\002,7x,\002norme de g =\002,d15.9/9x,\002niter=\002,i4,4x,\002nsim=\002,i5)"; integer s_wsfe(), do_fio(), e_wsfe(); static integer memh, iaux; extern int n1gc2a_(); static integer id, ig, ih, ix; static cilist io___2487 = { 0, 0, 0, fmt_1, 0 }; static cilist io___2488 = { 0, 0, 0, fmt_3, 0 }; static cilist io___2495 = { 0, 0, 0, fmt_2, 0 }; static cilist io___2496 = { 0, 0, 0, fmt_4, 0 }; static cilist io___2497 = { 0, 0, 0, fmt_5, 0 }; --g; --x; --rz; --izs; --rzs; --dzs; if (*imp > 0) { io___2487.ciunit = *io; s_wsfe(&io___2487); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nrz), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*imp), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*df1), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*dxmin), (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*n <= 0 || *niter <= 0 || *nsim <= 0 || *dxmin <= 0. || *df1 <= 0. || *epsrel <= 0. || *epsrel > 1.) { *mode = 2; if (*imp > 0) { io___2488.ciunit = *io; s_wsfe(&io___2488); e_wsfe(); } return 0; } id = 1; ix = id + *n; ig = ix + *n; iaux = ig + *n; ih = iaux + *n; memh = *nrz - (*n << 2); if (memh <= 0) { *mode = 3; goto L100; } else { } n1gc2a_(simul, prosca, n, &x[1], f, &g[1], dxmin, df1, epsrel, imp, io, niter, nsim, mode, &memh, &rz[id], &rz[ix], &rz[ig], &rz[iaux], & rz[ih], &izs[1], &rzs[1], &dzs[1]); L100: if (*imp > 0) { if (*mode == 3) { io___2495.ciunit = *io; s_wsfe(&io___2495); e_wsfe(); } else if (*mode == 6) { io___2496.ciunit = *io; s_wsfe(&io___2496); e_wsfe(); } else { io___2497.ciunit = *io; s_wsfe(&io___2497); do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer)); e_wsfe(); } } return 0; } int n1gc2a_(simul, prosca, n, x, f, g, dx, df1, eps, imp, io, niter, nsim, info, memh, d__, xx, gg, tabaux, h__, izs, rzs, dzs) int (*simul) (), (*prosca) (); integer *n; doublereal *x, *f, *g, *dx, *df1, *eps; integer *imp, *io, *niter, *nsim, *info, *memh; doublereal *d__, *xx, *gg, *tabaux, *h__; integer *izs; real *rzs; doublereal *dzs; { static char fmt_1[] = "(\002 methode de quasi-newton. nrz utile=\002,i7)"; static char fmt_2[] = "(\002 methode du gradient conjugue avec\002,i3,\002 mises a jour.\002,\002 nrz utile=\002,i7)"; static char fmt_6003[] = "()"; static char fmt_6002[] = "(4x,\002 n1gc2\002,3x,i4,\002 iters\002,3x,i4,\002 simuls\002,\002 necessite d'un redemarrage total\002)"; static char fmt_6001[] = "(4x,\002 n1gc2\002,3x,i4,\002 iters\002,3x,i4,\002 simuls\002,3x,\002f=\002,d15.9)"; static char fmt_10101[] = "(\002 n1gc2a erreur dans la hessienne dg=\002,d9.2)"; integer i__1, i__2; doublereal d__1; integer s_wsfe(), do_fio(), e_wsfe(); double sqrt(); static integer ieta, iter, i__, j, k, m; extern int n1gc2b_(); static integer l; static doublereal alpha, omega; static logical redem; static doublereal sigma; static logical termi; static doublereal normg; extern int fmulb1_(); static doublereal normg0; extern int fmuls1_(); static logical gc; static doublereal dg; static integer kj, lk, is, iu; static doublereal mu, gcarre, ggcarr, nu, sscaek, sscalg, uscalg; static integer nmisaj; static logical redfor; static doublereal dg1; static integer memuti; static logical intfor, iterqn; static integer ntotap, memsup, km1, kp1, retour, nrzuti; static doublereal eta; static integer inu; static doublereal aux1, aux2; static cilist io___2502 = { 0, 0, 0, fmt_1, 0 }; static cilist io___2504 = { 0, 0, 0, fmt_2, 0 }; static cilist io___2518 = { 0, 0, 0, fmt_6003, 0 }; static cilist io___2519 = { 0, 0, 0, fmt_6002, 0 }; static cilist io___2523 = { 0, 0, 0, fmt_6001, 0 }; static cilist io___2546 = { 0, 0, 0, fmt_10101, 0 }; --tabaux; --gg; --xx; --d__; --g; --x; --h__; --izs; --rzs; --dzs; memuti = *n * (*n + 1) / 2; memsup = (*n << 1) + 2; if (*memh >= memuti) { gc = (0) ; nrzuti = memuti + (*n << 2); if (*imp > 1) { io___2502.ciunit = *io; s_wsfe(&io___2502); do_fio(&c__1, (char *)&nrzuti, (ftnlen)sizeof(integer)); e_wsfe(); } } else if (*memh < memsup) { *info = 3; return 0; } else { gc = (1) ; m = *memh / memsup; memuti = m * memsup; nrzuti = memuti + (*n << 2); if (*imp > 1) { io___2504.ciunit = *io; s_wsfe(&io___2504); do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nrzuti, (ftnlen)sizeof(integer)); e_wsfe(); } } iter = 0; ntotap = 1; L3000: i__ = 0; nmisaj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { d__[j] = -g[j]; } (*prosca)(n, &g[1], &d__[1], &dg1, &izs[1], &rzs[1], &dzs[1]); normg0 = sqrt(((( dg1 ) >= 0 ? ( dg1 ) : -( dg1 )) )); if (iter == 1) { omega = *eps * normg0; } L4000: if (iter == *niter) { *info = 4; goto L99999; } ++iter; ++i__; if (gc) { iterqn = i__ <= m && 2 <= i__; } if (iter == 2) { alpha = *df1 * 2. / (-dg1); } else if (gc) { if (i__ == 1) { alpha = 1. / normg0; } else { if (iterqn) { alpha = 1.; } else { alpha = alpha * dg / dg1; } } } else { alpha = 1.; } dg = dg1; intfor = gc && ! iterqn || ! gc && i__ == 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { xx[j] = x[j]; gg[j] = g[j]; } n1gc2b_(n, simul, prosca, &xx[1], f, &dg, &alpha, &d__[1], &x[1], &g[1], imp, io, &retour, &ntotap, nsim, &intfor, dx, eps, &izs[1], &rzs[ 1], &dzs[1]); if (*imp > 3) { io___2518.ciunit = *io; s_wsfe(&io___2518); e_wsfe(); } if (retour == 4 || retour == 1 && i__ == 1) { *info = 6; return 0; } else if (retour == 1) { if (*imp > 1) { io___2519.ciunit = *io; s_wsfe(&io___2519); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ntotap, (ftnlen)sizeof(integer)); e_wsfe(); } goto L3000; } else { if (i__ > 1 && gc) { ggcarr = gcarre; } (*prosca)(n, &g[1], &g[1], &gcarre, &izs[1], &rzs[1], &dzs[1]); normg = sqrt(gcarre); if (*imp > 2) { io___2523.ciunit = *io; s_wsfe(&io___2523); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ntotap, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); e_wsfe(); } if (retour == 2) { *info = 0; goto L99999; } else if (retour == 3) { *info = 5; goto L99999; } } termi = normg < omega; if (termi) { *info = 1; goto L99999; } else { } redfor = gc && (i__ == 1 || i__ == m + *n); if (redfor) { redem = (1) ; } else if (gc && ! iterqn) { (*prosca)(n, &g[1], &gg[1], &aux1, &izs[1], &rzs[1], &dzs[1]); redem = (( aux1 ) >= 0 ? ( aux1 ) : -( aux1 )) > (d__1 = ggcarr * .2, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } else { redem = (0) ; } i__1 = *n; for (j = 1; j <= i__1; ++j) { d__[j] = alpha * d__[j]; xx[j] = g[j] - gg[j]; } if (redem) { i__ = 1; nmisaj = 1; inu = 1; ieta = inu + 1; iu = ieta; is = iu + *n; i__1 = *n; for (j = 1; j <= i__1; ++j) { h__[iu + j] = xx[j]; h__[is + j] = d__[j]; } (*prosca)(n, &xx[1], &xx[1], &nu, &izs[1], &rzs[1], &dzs[1]); h__[inu] = nu; (*prosca)(n, &d__[1], &xx[1], &eta, &izs[1], &rzs[1], &dzs[1]); h__[ieta] = eta; fmulb1_(n, &h__[1], &g[1], &xx[1], &tabaux[1], &nmisaj, prosca, &izs[ 1], &rzs[1], &dzs[1]); } else if (gc) { fmulb1_(n, &h__[1], &xx[1], &gg[1], &tabaux[1], &nmisaj, prosca, &izs[ 1], &rzs[1], &dzs[1]); (*prosca)(n, &xx[1], &gg[1], &nu, &izs[1], &rzs[1], &dzs[1]); (*prosca)(n, &d__[1], &xx[1], &eta, &izs[1], &rzs[1], &dzs[1]); (*prosca)(n, &d__[1], &g[1], &sscalg, &izs[1], &rzs[1], &dzs[1]); (*prosca)(n, &gg[1], &g[1], &uscalg, &izs[1], &rzs[1], &dzs[1]); sigma = (uscalg - (nu / eta + 1.) * sscalg) / eta; mu = sscalg / eta; fmulb1_(n, &h__[1], &g[1], &xx[1], &tabaux[1], &nmisaj, prosca, &izs[ 1], &rzs[1], &dzs[1]); i__1 = *n; for (j = 1; j <= i__1; ++j) { xx[j] = xx[j] - mu * gg[j] - sigma * d__[j]; } if (iterqn) { ++nmisaj; inu += memsup; ieta = inu + 1; iu = ieta; is = iu + *n; i__1 = *n; for (j = 1; j <= i__1; ++j) { h__[iu + j] = gg[j]; h__[is + j] = d__[j]; } h__[inu] = nu; h__[ieta] = eta; } } else { (*prosca)(n, &d__[1], &xx[1], &eta, &izs[1], &rzs[1], &dzs[1]); if (i__ == 1) { (*prosca)(n, &xx[1], &xx[1], &nu, &izs[1], &rzs[1], &dzs[1]); kj = 1; aux1 = eta / nu; i__1 = *n; for (k = 1; k <= i__1; ++k) { h__[kj] = aux1; ++kj; kp1 = k + 1; if (*n >= kp1) { i__2 = *n; for (j = kp1; j <= i__2; ++j) { h__[kj] = 0.; ++kj; } } gg[k] = aux1 * xx[k]; } nu = eta; } else { fmuls1_(n, &h__[1], &xx[1], &gg[1]); (*prosca)(n, &xx[1], &gg[1], &nu, &izs[1], &rzs[1], &dzs[1]); } aux1 = nu / eta + 1.; kj = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { lk = k; km1 = k - 1; if (k >= 2) { i__2 = km1; for (l = 1; l <= i__2; ++l) { tabaux[l] = h__[lk]; lk += *n - l; } } i__2 = *n; for (l = k; l <= i__2; ++l) { tabaux[l] = h__[lk]; ++lk; } (*prosca)(n, &xx[1], &tabaux[1], &aux2, &izs[1], &rzs[1], &dzs[1]) ; i__2 = *n; for (l = 1; l <= i__2; ++l) { tabaux[l] = 0.; } tabaux[k] = 1.; (*prosca)(n, &tabaux[1], &d__[1], &sscaek, &izs[1], &rzs[1], &dzs[ 1]); kj = k - *n; i__2 = k; for (j = 1; j <= i__2; ++j) { kj = kj + *n - j + 1; h__[kj] -= ((aux2 - aux1 * sscaek) * d__[j] + sscaek * gg[j]) / eta; } } } if (gc) { i__1 = *n; for (j = 1; j <= i__1; ++j) { d__[j] = -xx[j]; } } else { fmuls1_(n, &h__[1], &g[1], &d__[1]); i__1 = *n; for (j = 1; j <= i__1; ++j) { d__[j] = -d__[j]; } } (*prosca)(n, &d__[1], &g[1], &dg1, &izs[1], &rzs[1], &dzs[1]); if (dg1 >= 0.) { *info = 7; if (*imp > 1) { io___2546.ciunit = *io; s_wsfe(&io___2546); do_fio(&c__1, (char *)&dg1, (ftnlen)sizeof(doublereal)); e_wsfe(); } goto L99999; } else { goto L4000; } L99999: *niter = iter; *nsim = ntotap; if (i__ == 0) { *eps = normg0; } else { *eps = normg; } } int n1gc2b_(n, simul, prosca, xinit, f, dg, alpha, d__, xfinal, gfinal, imp, io, retour, ntotap, nsim, intfor, dx, eps, izs, rzs, dzs) integer *n; int (*simul) (), (*prosca) (); doublereal *xinit, *f, *dg, *alpha, *d__, *xfinal, *gfinal; integer *imp, *io, *retour, *ntotap, *nsim; logical *intfor; doublereal *dx, *eps; integer *izs; real *rzs; doublereal *dzs; { static char fmt_1[] = "(\002 n1gc2b\002,6x,\002 pas\002,d10.3,\002 dg=\002,d9.2)"; static char fmt_1001[] = "(\002 n1gc2b fin sur dx\002)"; static char fmt_2001[] = "(\002 n1gc2b\002,20x,d10.3,\002 indic=\002,i3)" ; static char fmt_2002[] = "(\002 n1gc2b\002,20x,d10.3,2d11.3)"; integer i__1; doublereal d__1; integer s_wsfe(), do_fio(), e_wsfe(); double sqrt(); static doublereal bsup; static integer j, indic; static doublereal delta; static logical depas; static doublereal finit, ap, dp, at, fp; static logical encadr, accept, rfinie; static integer nappel; static logical maxpas; static doublereal dal, pas, aux1, aux2; static cilist io___2554 = { 0, 0, 0, fmt_1, 0 }; static cilist io___2556 = { 0, 0, 0, fmt_1001, 0 }; static cilist io___2559 = { 0, 0, 0, fmt_2001, 0 }; static cilist io___2563 = { 0, 0, 0, fmt_2002, 0 }; --gfinal; --xfinal; --d__; --xinit; --izs; --rzs; --dzs; depas = (0) ; bsup = 0.; finit = *f; nappel = 0; ap = 0.; fp = finit; dp = *dg; if (*imp > 3) { io___2554.ciunit = *io; s_wsfe(&io___2554); do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*dg), (ftnlen)sizeof(doublereal)); e_wsfe(); } (*prosca)(n, &d__[1], &d__[1], &pas, &izs[1], &rzs[1], &dzs[1]); pas = sqrt(pas); L1000: if (*alpha * pas <= *dx) { if (*imp > 3) { io___2556.ciunit = *io; s_wsfe(&io___2556); e_wsfe(); } *retour = 1; return 0; } else if (*ntotap == *nsim) { *retour = 3; return 0; } else { } i__1 = *n; for (j = 1; j <= i__1; ++j) { xfinal[j] = xinit[j] + *alpha * d__[j]; } indic = 4; (*simul)(&indic, n, &xfinal[1], f, &gfinal[1], &izs[1], &rzs[1], &dzs[1]); ++nappel; ++(*ntotap); if (indic < 0) { depas = (1) ; if (*imp > 3) { io___2559.ciunit = *io; s_wsfe(&io___2559); do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer)); e_wsfe(); } delta = *alpha - ap; if (delta <= *dx) { *retour = 4; return 0; } else { bsup = *alpha; *alpha = delta * .1 + ap; goto L1000; } } (*prosca)(n, &d__[1], &gfinal[1], &dal, &izs[1], &rzs[1], &dzs[1]); if (*imp > 3) { aux2 = *f - finit; io___2563.ciunit = *io; s_wsfe(&io___2563); do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&aux2, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&dal, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (indic == 0) { *retour = 2; return 0; } maxpas = *f > finit && dal < 0.; if (maxpas) { *alpha /= 3.; ap = 0.; fp = finit; dp = *dg; rfinie = (0) ; } else { aux1 = finit + *alpha * 1e-4 * *dg; aux2 = (d__1 = dal / *dg, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); accept = *f <= aux1 && aux2 <= .9; if (accept) { rfinie = nappel > 1 || ! (*intfor) || aux2 <= *eps; } else { rfinie = (0) ; } if (! rfinie) { aux1 = dp + dal - (fp - *f) * 3. / (ap - *alpha); aux2 = aux1 * aux1 - dp * dal; if (aux2 <= 0.) { aux2 = 0.; } else { aux2 = sqrt(aux2); } if (dal - dp + aux2 * 2. == 0.) { *retour = 4; return 0; } at = *alpha - (*alpha - ap) * (dal + aux2 - aux1) / (dal - dp + aux2 * 2.); encadr = dal / dp <= 0.; if (encadr) { if ((d__1 = *alpha - ap, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= *dx) { *retour = 4; return 0; } aux1 = (( *alpha ) <= ( ap ) ? ( *alpha ) : ( ap )) * 1.01; aux2 = (( *alpha ) >= ( ap ) ? ( *alpha ) : ( ap )) * .99; if (at < aux1 || at > aux2) { at = (*alpha + ap) / 2.; } } else { aux1 = (( ap ) <= ( *alpha ) ? ( ap ) : ( *alpha )) * .99; if (dal <= 0. || at <= 0. || at >= aux1) { aux1 = (( ap ) >= ( *alpha ) ? ( ap ) : ( *alpha )) * 1.01; if (dal > 0. || at <= aux1) { if (dal <= 0.) { at = (( ap ) >= ( *alpha ) ? ( ap ) : ( *alpha )) * 2.; } else { at = (( ap ) <= ( *alpha ) ? ( ap ) : ( *alpha )) / 2.; } } } } if (depas && at >= bsup) { delta = bsup - *alpha; if (delta <= *dx) { *retour = 4; return 0; } else { at = *alpha + delta * .1; } } ap = *alpha; fp = *f; dp = dal; *alpha = at; } } if (rfinie) { *retour = 0; return 0; } else { goto L1000; } } int n1qn1_(simul, n, x, f, g, var, eps, mode, niter, nsim, imp, lp, zm, izs, rzs, dzs) int (*simul) (); integer *n; doublereal *x, *f, *g, *var, *eps; integer *mode, *niter, *nsim, *imp, *lp; doublereal *zm; integer *izs; real *rzs; doublereal *dzs; { static char fmt_1000[] = "(\0021entree dans n1qn1. dimension du probleme\002,i4,\002, de zm\002,i6)"; static char fmt_1003[] = "(\002 mode\002,i2,\002 eps=\002,d10.2,\002 niter=\002,i4,\002 nsim=\002,i5,\002 imp=\002,i3)"; static char fmt_1100[] = "(\002 sortie de n1qn1\002,\002. norme gradient carre =\002,d15.7)"; integer s_wsfe(), do_fio(), e_wsfe(); extern int n1qn1a_(); static integer nd, nw, nga, ngb, nxa, nxb; static cilist io___2571 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2572 = { 0, 0, 0, fmt_1003, 0 }; static cilist io___2578 = { 0, 0, 0, fmt_1100, 0 }; --var; --g; --x; --zm; --izs; --rzs; --dzs; if (*imp <= 0) { goto L10; } nw = *n * (*n + 13) / 2; io___2571.ciunit = *lp; s_wsfe(&io___2571); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nw, (ftnlen)sizeof(integer)); e_wsfe(); io___2572.ciunit = *lp; s_wsfe(&io___2572); do_fio(&c__1, (char *)&(*mode), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*eps), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*imp), (ftnlen)sizeof(integer)); e_wsfe(); L10: nd = *n * (*n + 1) / 2 + 1; nw = nd + *n; nxa = nw + *n; nga = nxa + *n; nxb = nga + *n; ngb = nxb + *n; n1qn1a_(simul, n, &x[1], f, &g[1], &var[1], eps, mode, niter, nsim, imp, lp, &zm[1], &zm[nd], &zm[nw], &zm[nxa], &zm[nga], &zm[nxb], &zm[ ngb], &izs[1], &rzs[1], &dzs[1]); if (*imp > 0) { io___2578.ciunit = *lp; s_wsfe(&io___2578); do_fio(&c__1, (char *)&(*eps), (ftnlen)sizeof(doublereal)); e_wsfe(); } return 0; } int n1qn1a_(simul, n, x, f, g, scale, acc, mode, niter, nsim, iprint, lp, h__, d__, w, xa, ga, xb, gb, izs, rzs, dzs) int (*simul) (); integer *n; doublereal *x, *f, *g, *scale, *acc; integer *mode, *niter, *nsim, *iprint, *lp; doublereal *h__, *d__, *w, *xa, *ga, *xb, *gb; integer *izs; real *rzs; doublereal *dzs; { static char fmt_1000[] = "(\002 n1qn1 ne peut demarrer (contrainte implicite)\002)"; static char fmt_1001[] = "(\002 n1qn1 termine par voeu de l'utilisateur\002)"; static char fmt_1010[] = "(\002 n1qn1 remplace le hessien initial (qui n'est\002,\002 pas defini positif)\002/\002 par une diagonale positive\002)"; static char fmt_1019[] = "(\002+\002,51x,\002deriv init =\002,d11.4)"; static char fmt_1020[] = "(\002 n1qn1\002,i4,\002 iters\002,i6,\002 simuls\002,\002 f=\002,d15.7)"; static char fmt_1021[] = "(\002 n1qn1\002,13x,\002pas\002,d12.5,\002 diff f =\002,d11.4,\002 deriv =\002,d11.4)"; static char fmt_1022[] = "(\002 n1qn1\002,13x,\002pas\002,d12.5,\002 indic =\002,i2)"; static char fmt_1023[] = "(\002 n1qn1 bute sur une contrainte implicite\002)"; integer i__1, i__2, i__3; doublereal d__1, d__2, d__3, d__4; integer s_wsfe(), e_wsfe(), do_fio(); double sqrt(); static doublereal fmin, gmin; static integer nfun, isfv; static doublereal step, c__; static integer i__, j, k; static doublereal s; static integer indic; static doublereal v; static integer iecri, i1; static doublereal stmin, cc, fa, fb, hh; static integer ii, ij, ik, jk, ni, ip, ir, np; static doublereal stepbd, steplb; extern int majour_(); static doublereal gl1, gl2, dga, dgb, dff; static integer ial, nip, itr; static cilist io___2580 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2581 = { 0, 0, 0, fmt_1001, 0 }; static cilist io___2597 = { 0, 0, 0, fmt_1010, 0 }; static cilist io___2612 = { 0, 0, 0, fmt_1020, 0 }; static cilist io___2613 = { 0, 0, 0, fmt_1019, 0 }; static cilist io___2615 = { 0, 0, 0, fmt_1001, 0 }; static cilist io___2616 = { 0, 0, 0, fmt_1022, 0 }; static cilist io___2617 = { 0, 0, 0, fmt_1023, 0 }; static cilist io___2622 = { 0, 0, 0, fmt_1021, 0 }; static cilist io___2623 = { 0, 0, 0, fmt_1020, 0 }; static cilist io___2625 = { 0, 0, 0, fmt_1023, 0 }; --gb; --xb; --ga; --xa; --w; --d__; --scale; --g; --x; --h__; --izs; --rzs; --dzs; indic = 4; (*simul)(&indic, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]); if (indic > 0) { goto L13; } if (*iprint == 0) { goto L12; } if (indic < 0) { io___2580.ciunit = *lp; s_wsfe(&io___2580); e_wsfe(); } if (indic == 0) { io___2581.ciunit = *lp; s_wsfe(&io___2581); e_wsfe(); } L12: *acc = 0.; *niter = 1; *nsim = 1; return 0; L13: nfun = 1; iecri = 0; itr = 0; np = *n + 1; if (*mode >= 2) { goto L60; } L20: c__ = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__2 = c__, d__3 = (d__1 = g[i__] * scale[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); c__ = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } if (c__ <= 0.) { c__ = 1.; } k = *n * np / 2; i__1 = k; for (i__ = 1; i__ <= i__1; ++i__) { h__[i__] = 0.; } k = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { h__[k] = c__ * .01 / (scale[i__] * scale[i__]); k = k + np - i__; } goto L100; L60: if (*mode >= 3) { goto L80; } k = *n; if (*n > 1) { goto L300; } if (h__[1] > 0.) { goto L305; } h__[1] = 0.; k = 0; goto L305; L300: np = *n + 1; ii = 1; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { hh = h__[ii]; ni = ii + np - i__; if (hh > 0.) { goto L301; } h__[ii] = 0.; --k; ii = ni + 1; goto L304; L301: ip = ii + 1; ii = ni + 1; jk = ii; i__2 = ni; for (ij = ip; ij <= i__2; ++ij) { v = h__[ij] / hh; i__3 = ni; for (ik = ij; ik <= i__3; ++ik) { h__[jk] -= h__[ik] * v; ++jk; } h__[ij] = v; } L304: ; } if (h__[ii] > 0.) { goto L305; } h__[ii] = 0.; --k; L305: if (k >= *n) { goto L100; } L70: if (*iprint != 0) { io___2597.ciunit = *lp; s_wsfe(&io___2597); e_wsfe(); } goto L20; L80: k = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (h__[k] <= 0.) { goto L70; } k = k + np - i__; } L100: dff = 0.; L110: fa = *f; isfv = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xa[i__] = x[i__]; ga[i__] = g[i__]; } L130: ++itr; ial = 0; if (itr > *niter) { goto L250; } ++iecri; if (iecri != -(*iprint)) { goto L140; } iecri = 0; indic = 1; (*simul)(&indic, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]); L140: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = -ga[i__]; } w[1] = d__[1]; if (*n > 1) { goto L400; } d__[1] /= h__[1]; goto L412; L400: i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { ij = i__; i1 = i__ - 1; v = d__[i__]; i__2 = i1; for (j = 1; j <= i__2; ++j) { v -= h__[ij] * d__[j]; ij = ij + *n - j; } w[i__] = v; d__[i__] = v; } d__[*n] /= h__[ij]; np = *n + 1; i__1 = *n; for (nip = 2; nip <= i__1; ++nip) { i__ = np - nip; ii = ij - nip; v = d__[i__] / h__[ii]; ip = i__ + 1; ij = ii; i__2 = *n; for (j = ip; j <= i__2; ++j) { ++ii; v -= h__[ii] * d__[j]; } d__[i__] = v; } L412: c__ = 0.; dga = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__2 = c__, d__3 = (d__1 = d__[i__] / scale[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); c__ = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; dga += ga[i__] * d__[i__]; } if (dga >= 0.) { goto L240; } stmin = 0.; stepbd = 0.; steplb = *acc / c__; fmin = fa; gmin = dga; step = 1.; if (dff <= 0.) { d__1 = step, d__2 = 1. / c__; step = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if (dff > 0.) { d__1 = step, d__2 = (dff + dff) / (-dga); step = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if (*iprint >= 2) { io___2612.ciunit = *lp; s_wsfe(&io___2612); do_fio(&c__1, (char *)&itr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nfun, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&fa, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*iprint >= 3) { io___2613.ciunit = *lp; s_wsfe(&io___2613); do_fio(&c__1, (char *)&dga, (ftnlen)sizeof(doublereal)); e_wsfe(); } L170: c__ = stmin + step; if (nfun >= *nsim) { goto L250; } ++nfun; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xb[i__] = xa[i__] + c__ * d__[i__]; } indic = 4; (*simul)(&indic, n, &xb[1], &fb, &gb[1], &izs[1], &rzs[1], &dzs[1]); if (indic > 0) { goto L185; } if (indic < 0) { goto L183; } if (*iprint > 0) { io___2615.ciunit = *lp; s_wsfe(&io___2615); e_wsfe(); } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = xb[i__]; g[i__] = gb[i__]; } goto L250; L183: stepbd = step; ial = 1; step /= 10.; if (*iprint >= 3) { io___2616.ciunit = *lp; s_wsfe(&io___2616); do_fio(&c__1, (char *)&c__, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer)); e_wsfe(); } if (stepbd > steplb) { goto L170; } if (*iprint != 0 && isfv < 2) { io___2617.ciunit = *lp; s_wsfe(&io___2617); e_wsfe(); } goto L240; L185: isfv = (( 2 ) <= ( isfv ) ? ( 2 ) : ( isfv )) ; if (fb > *f) { goto L220; } if (fb < *f) { goto L200; } gl1 = 0.; gl2 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = scale[i__] * g[i__]; gl1 += d__1 * d__1; d__1 = scale[i__] * gb[i__]; gl2 += d__1 * d__1; } if (gl2 >= gl1) { goto L220; } L200: isfv = 3; *f = fb; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = xb[i__]; g[i__] = gb[i__]; } L220: dgb = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dgb += gb[i__] * d__[i__]; } if (*iprint < 3) { goto L231; } s = fb - fa; io___2622.ciunit = *lp; s_wsfe(&io___2622); do_fio(&c__1, (char *)&c__, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&s, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&dgb, (ftnlen)sizeof(doublereal)); e_wsfe(); L231: if (fb - fa <= c__ * .1 * dga) { goto L280; } ial = 0; if (step > steplb) { goto L270; } L240: if (isfv >= 2) { goto L110; } L250: if (*iprint > 0) { io___2623.ciunit = *lp; s_wsfe(&io___2623); do_fio(&c__1, (char *)&itr, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&nfun, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); e_wsfe(); } *acc = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { *acc += g[i__] * g[i__]; } *niter = itr; *nsim = nfun; return 0; L270: stepbd = step; c__ = gmin + dgb - (fb - fmin) * 3. / step; cc = (( c__ ) >= 0 ? ( c__ ) : -( c__ )) - gmin * (dgb / (( c__ ) >= 0 ? ( c__ ) : -( c__ )) ); cc = sqrt(((( c__ ) >= 0 ? ( c__ ) : -( c__ )) )) * sqrt(((( 0. ) >= ( cc ) ? ( 0. ) : ( cc )) )); c__ = (c__ - gmin + cc) / (dgb - gmin + cc + cc); step *= (( .1 ) >= ( c__ ) ? ( .1 ) : ( c__ )) ; goto L170; L280: if (ial == 0) { goto L285; } if (stepbd > steplb) { goto L285; } if (*iprint != 0 && isfv < 2) { io___2625.ciunit = *lp; s_wsfe(&io___2625); e_wsfe(); } goto L240; L285: stepbd -= step; stmin = c__; fmin = fb; gmin = dgb; step = stmin * 9.; if (stepbd > 0.) { step = stepbd * .5; } c__ = dga + dgb * 3. - (fb - fa) * 4. / stmin; if (c__ > 0.) { d__3 = 1., d__4 = -dgb / c__; d__1 = step, d__2 = stmin * (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ; step = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if (dgb < dga * .7) { goto L170; } isfv = 4 - isfv; if (stmin + step <= steplb) { goto L240; } ir = -(*n); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xa[i__] = xb[i__]; xb[i__] = ga[i__]; d__[i__] = gb[i__] - ga[i__]; ga[i__] = gb[i__]; } d__1 = 1. / dga; majour_(&h__[1], &xb[1], &w[1], n, &d__1, &ir, &c__1, &c_b61); ir = -ir; d__1 = 1. / (stmin * (dgb - dga)); majour_(&h__[1], &d__[1], &d__[1], n, &d__1, &ir, &c__1, &c_b61); if (ir < *n) { goto L250; } dff = fa - fb; fa = fb; goto L130; } int n1qn2_(simul, prosca, n, x, f, g, dxmin, df1, epsg, impres, io, mode, niter, nsim, dz, ndz, izs, rzs, dzs) int (*simul) (), (*prosca) (); integer *n; doublereal *x, *f, *g, *dxmin, *df1, *epsg; integer *impres, *io, *mode, *niter, *nsim; doublereal *dz; integer *ndz, *izs; real *rzs; doublereal *dzs; { static char fmt_900[] = "(/,\002 n1qn2: point d'entree\002,/,5x,\002dimension du probleme (n) :\002,i6,/,5x,\002precision absolue en x (dxmin) :\002,d9.2,/,5x,\002decroissance attendue pour f (df1) :\002,d9.2,/,5x,\002precision relative en g (epsg) :\002,d9.2,/,5x,\002nombre maximal d'iterations (niter) :\002,i6,/,5x,\002nombre maximal d'appels a simul (nsim) :\002,i6,/,5x,\002niveau d'impression (impres) :\002,i4)"; static char fmt_901[] = "(/,\002 >>> n1qn2 : appel incoherent\002)"; static char fmt_902[] = "(/,\002 >>> n1qn2: memoire allouee insuffisante\002)"; static char fmt_903[] = "(/5x,\002memoire allouee (ndz) :\002,i7,/,5x,\002memoire utilisee :\002,i7,/,5x,\002nombre de mises a jour :\002,i6,/)"; static char fmt_905[] = "(/,1x,79(\002-\002),/,/,1x,\002n1qn2 : sortie en mode \002,i2,/,5x,\002nombre d'iterations : \002,i4,/,5x,\002nombre d'appels a simul : \002,i6,/,5x,\002precision relative atteinte sur g: \002,d9.2)"; static char fmt_906[] = "(5x,\002norme de x = \002,d15.8,/,5x,\002f = \002,d15.8,/,5x,\002norme de g = \002,d15.8)"; integer s_wsfe(), do_fio(), e_wsfe(); double sqrt(); static integer iaux, ndzu, m, isbar; extern int n1qn2a_(); static integer iybar; static doublereal r1, r2; static integer l1memo, id, ialpha; static doublereal ps; static integer igg; static cilist io___2627 = { 0, 0, 0, fmt_900, 0 }; static cilist io___2628 = { 0, 0, 0, fmt_901, 0 }; static cilist io___2629 = { 0, 0, 0, fmt_902, 0 }; static cilist io___2633 = { 0, 0, 0, fmt_903, 0 }; static cilist io___2640 = { 0, 0, 0, fmt_905, 0 }; static cilist io___2644 = { 0, 0, 0, fmt_906, 0 }; --dzs; --rzs; --izs; --dz; --g; --x; if (*impres >= 1) { io___2627.ciunit = *io; s_wsfe(&io___2627); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*dxmin), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*df1), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*epsg), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*impres), (ftnlen)sizeof(integer)); e_wsfe(); } if (*n <= 0 || *niter <= 0 || *nsim <= 0 || *dxmin <= 0. || *epsg <= 0. || *epsg > 1.) { *mode = 2; if (*impres >= 1) { io___2628.ciunit = *io; s_wsfe(&io___2628); e_wsfe(); } goto L904; } if (*ndz < *n * 5 + 1) { *mode = 2; if (*impres >= 1) { io___2629.ciunit = *io; s_wsfe(&io___2629); e_wsfe(); } goto L904; } ndzu = *ndz - *n * 3; l1memo = (*n << 1) + 1; m = ndzu / l1memo; ndzu = m * l1memo + *n * 3; if (*impres >= 1) { io___2633.ciunit = *io; s_wsfe(&io___2633); do_fio(&c__1, (char *)&(*ndz), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ndzu, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer)); e_wsfe(); } id = 1; igg = id + *n; iaux = igg + *n; ialpha = iaux + *n; iybar = ialpha + m; isbar = iybar + *n * m; n1qn2a_(simul, prosca, n, &x[1], f, &g[1], dxmin, df1, epsg, impres, io, mode, niter, nsim, &m, &dz[id], &dz[igg], &dz[iaux], &dz[ialpha], &dz[iybar], &dz[isbar], &izs[1], &rzs[1], &dzs[1]); L904: if (*impres >= 1) { io___2640.ciunit = *io; s_wsfe(&io___2640); do_fio(&c__1, (char *)&(*mode), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*epsg), (ftnlen)sizeof(doublereal)); e_wsfe(); } (*prosca)(n, &x[1], &x[1], &ps, &izs[1], &rzs[1], &dzs[1]); r1 = sqrt(ps); (*prosca)(n, &g[1], &g[1], &ps, &izs[1], &rzs[1], &dzs[1]); r2 = sqrt(ps); if (*impres >= 1) { io___2644.ciunit = *io; s_wsfe(&io___2644); do_fio(&c__1, (char *)&r1, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&r2, (ftnlen)sizeof(doublereal)); e_wsfe(); } return 0; } int n1qn2a_(simul, prosca, n, x, f, g, dxmin, df1, epsg, impres, io, mode, niter, nsim, m, d__, gg, aux, alpha, ybar, sbar, izs, rzs, dzs) int (*simul) (), (*prosca) (); integer *n; doublereal *x, *f, *g, *dxmin, *df1, *epsg; integer *impres, *io, *mode, *niter, *nsim, *m; doublereal *d__, *gg, *aux, *alpha, *ybar, *sbar; integer *izs; real *rzs; doublereal *dzs; { static char fmt_900[] = "(5x,\002f = \002,d15.8,/,5x,\002norme de g = \002,d15.8)"; static char fmt_899[] = "(/,\002 n1qn2a: direction de descente -g: precon = \002,d10.3)"; static char fmt_901[] = "(/,1x,79(\002-\002))"; static char fmt_9010[] = "(1x)"; static char fmt_902[] = "(\002 n1qn2: iter \002,i3,\002, simul \002,i3,\002, f=\002,d15.8,\002, h'(0)=\002,d12.5)"; static char fmt_903[] = "(/,\002 n1qn2: recherche lineaire\002)"; static char fmt_904[] = "(/,\002 >>> n1qn2 (iteration \002,i3,\002): recherche lineaire bloquee sur tmax: \002,\002reduire l'echelle\002)"; static char fmt_905[] = "(/,\002 n1qn2: test d'arret sur g: \002,d12.5)"; static char fmt_906[] = "(/,\002 >>> n1qn2 (iteration \002,i3,\002): nombre maximal d'iterations atteint\002)"; static char fmt_907[] = "(/,\002 >>> n1qn2 (iteration \002,i3,\002): \002,i6,\002 appels a simul (nombre maximal atteint)\002)"; static char fmt_908[] = "(/,\002 >>> n1qn2 (iteration \002,i2,\002): le produit scalaire (y,s) = \002,d12.5,/,27x,\002n'est pas positif\002)"; static char fmt_909[] = "(/,\002 n1qn2: mise a jour: (y,s) = \002,d10.3,\002 Oren-Spedicato = \002,d10.3)"; static char fmt_910[] = "(/,\002 >>> n1qn2 (iteration \002,i2,\002): \002,/,5x,\002la direction de recherche d n'est pas de \002,\002descente: (g,d) = \002,d12.5)"; static char fmt_911[] = "(/,\002 n1qn2: direction de descente d: \002,\002angle(-g,d) = \002,f5.1,\002 degres\002)"; integer ybar_dim1, ybar_offset, sbar_dim1, sbar_offset, i__1; doublereal d__1, d__2, d__3; double sqrt(); integer s_wsfe(), do_fio(), e_wsfe(); double acos(); static integer jmin, jmax, isim, iter; static doublereal tmin, tmax; extern int nlis0_(); static integer i__; static real r__; static doublereal t; static integer indic; static doublereal gnorm, d1, ff, ps; static integer moderl; static doublereal precon; extern int strang_(); static doublereal hp0, ps2, eps1; static cilist io___2649 = { 0, 0, 0, fmt_900, 0 }; static cilist io___2652 = { 0, 0, 0, fmt_899, 0 }; static cilist io___2653 = { 0, 0, 0, fmt_901, 0 }; static cilist io___2654 = { 0, 0, 0, fmt_9010, 0 }; static cilist io___2655 = { 0, 0, 0, fmt_901, 0 }; static cilist io___2661 = { 0, 0, 0, fmt_901, 0 }; static cilist io___2662 = { 0, 0, 0, fmt_9010, 0 }; static cilist io___2663 = { 0, 0, 0, fmt_902, 0 }; static cilist io___2665 = { 0, 0, 0, fmt_903, 0 }; static cilist io___2670 = { 0, 0, 0, fmt_904, 0 }; static cilist io___2672 = { 0, 0, 0, fmt_905, 0 }; static cilist io___2673 = { 0, 0, 0, fmt_906, 0 }; static cilist io___2674 = { 0, 0, 0, fmt_907, 0 }; static cilist io___2675 = { 0, 0, 0, fmt_908, 0 }; static cilist io___2676 = { 0, 0, 0, fmt_909, 0 }; static cilist io___2677 = { 0, 0, 0, fmt_910, 0 }; static cilist io___2680 = { 0, 0, 0, fmt_911, 0 }; --aux; --gg; --d__; --g; --x; sbar_dim1 = *n; sbar_offset = sbar_dim1 + 1; sbar -= sbar_offset; ybar_dim1 = *n; ybar_offset = ybar_dim1 + 1; ybar -= ybar_offset; --alpha; --izs; --rzs; --dzs; iter = 0; isim = 1; (*prosca)(n, &g[1], &g[1], &ps, &izs[1], &rzs[1], &dzs[1]); gnorm = sqrt(ps); if (*impres >= 1) { io___2649.ciunit = *io; s_wsfe(&io___2649); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&gnorm, (ftnlen)sizeof(doublereal)); e_wsfe(); } d__1 = gnorm; precon = *df1 * 2. / (d__1 * d__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = -g[i__] * precon; } if (*impres >= 5) { io___2652.ciunit = *io; s_wsfe(&io___2652); do_fio(&c__1, (char *)&precon, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*impres == 3) { io___2653.ciunit = *io; s_wsfe(&io___2653); e_wsfe(); io___2654.ciunit = *io; s_wsfe(&io___2654); e_wsfe(); } if (*impres == 4) { io___2655.ciunit = *io; s_wsfe(&io___2655); e_wsfe(); } tmax = 1e20; (*prosca)(n, &d__[1], &g[1], &hp0, &izs[1], &rzs[1], &dzs[1]); jmin = 1; jmax = 0; L100: ++iter; if (*impres < 0) { if (iter % (-(*impres)) == 0) { indic = 1; (*simul)(&indic, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]); goto L100; } } if (*impres >= 5) { io___2661.ciunit = *io; s_wsfe(&io___2661); e_wsfe(); } if (*impres >= 4) { io___2662.ciunit = *io; s_wsfe(&io___2662); e_wsfe(); } if (*impres >= 3) { io___2663.ciunit = *io; s_wsfe(&io___2663); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&isim, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&hp0, (ftnlen)sizeof(doublereal)); e_wsfe(); } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { gg[i__] = g[i__]; } ff = *f; if (*impres >= 5) { io___2665.ciunit = *io; s_wsfe(&io___2665); e_wsfe(); } tmin = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__2 = tmin, d__3 = (d__1 = d__[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); tmin = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ; } tmin = *dxmin / tmin; t = 1.; d1 = hp0; nlis0_(n, simul, prosca, &x[1], f, &d1, &t, &tmin, &tmax, &d__[1], &g[1], &c_b5732, &c_b5340, impres, io, &moderl, &isim, nsim, &aux[1], & izs[1], &rzs[1], &dzs[1]); if (moderl != 0) { if (moderl < 0) { *mode = moderl; } else if (moderl == 1) { *mode = 3; if (*impres >= 1) { io___2670.ciunit = *io; s_wsfe(&io___2670); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); e_wsfe(); } } else if (moderl == 4) { *mode = 5; } else if (moderl == 5) { *mode = 0; } else if (moderl == 6) { *mode = 6; } goto L1000; } (*prosca)(n, &g[1], &g[1], &ps, &izs[1], &rzs[1], &dzs[1]); eps1 = sqrt(ps) / gnorm; if (*impres >= 5) { io___2672.ciunit = *io; s_wsfe(&io___2672); do_fio(&c__1, (char *)&eps1, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (eps1 < *epsg) { *mode = 1; goto L1000; } if (iter == *niter) { *mode = 4; if (*impres >= 1) { io___2673.ciunit = *io; s_wsfe(&io___2673); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); e_wsfe(); } goto L1000; } if (isim >= *nsim) { *mode = 5; if (*impres >= 1) { io___2674.ciunit = *io; s_wsfe(&io___2674); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&isim, (ftnlen)sizeof(integer)); e_wsfe(); } goto L1000; } ++jmax; if (iter > *m) { ++jmin; if (jmin > *m) { jmin -= *m; } if (jmax > *m) { jmax -= *m; } } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sbar[i__ + jmax * sbar_dim1] = t * d__[i__]; ybar[i__ + jmax * ybar_dim1] = g[i__] - gg[i__]; } (*prosca)(n, &ybar[jmax * ybar_dim1 + 1], &sbar[jmax * sbar_dim1 + 1], & d1, &izs[1], &rzs[1], &dzs[1]); if (d1 <= 0.) { *mode = 7; if (*impres >= 1) { io___2675.ciunit = *io; s_wsfe(&io___2675); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&d1, (ftnlen)sizeof(doublereal)); e_wsfe(); } goto L1000; } (*prosca)(n, &ybar[jmax * ybar_dim1 + 1], &ybar[jmax * ybar_dim1 + 1], & ps, &izs[1], &rzs[1], &dzs[1]); precon = d1 / ps; if (*impres >= 5) { io___2676.ciunit = *io; s_wsfe(&io___2676); do_fio(&c__1, (char *)&d1, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&precon, (ftnlen)sizeof(doublereal)); e_wsfe(); } d1 = sqrt(1. / d1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sbar[i__ + jmax * sbar_dim1] = d1 * sbar[i__ + jmax * sbar_dim1]; ybar[i__ + jmax * ybar_dim1] = d1 * ybar[i__ + jmax * ybar_dim1]; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__[i__] = -g[i__]; } strang_(prosca, n, m, &d__[1], &jmin, &jmax, &precon, &alpha[1], &ybar[ ybar_offset], &sbar[sbar_offset], &izs[1], &rzs[1], &dzs[1]); (*prosca)(n, &d__[1], &g[1], &hp0, &izs[1], &rzs[1], &dzs[1]); if (hp0 >= 0.) { *mode = 7; if (*impres >= 1) { io___2677.ciunit = *io; s_wsfe(&io___2677); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&hp0, (ftnlen)sizeof(doublereal)); e_wsfe(); } goto L1000; } if (*impres >= 5) { (*prosca)(n, &g[1], &g[1], &ps, &izs[1], &rzs[1], &dzs[1]); ps = sqrt(ps); (*prosca)(n, &d__[1], &d__[1], &ps2, &izs[1], &rzs[1], &dzs[1]); ps2 = sqrt(ps2); ps = hp0 / ps / ps2; d__1 = -ps; ps = (( d__1 ) <= ( 1. ) ? ( d__1 ) : ( 1. )) ; ps = acos(ps); r__ = (real) (ps * (float)180. / 3.1415927); io___2680.ciunit = *io; s_wsfe(&io___2680); do_fio(&c__1, (char *)&r__, (ftnlen)sizeof(real)); e_wsfe(); } goto L100; L1000: *epsg = eps1; *niter = iter; *nsim = isim; return 0; } int nlis0_(n, simul, prosca, xn, fn, fpn, t, tmin, tmax, d__, g, amd, amf, imp, io, logic, nap, napmax, x, izs, rzs, dzs) integer *n; int (*simul) (), (*prosca) (); doublereal *xn, *fn, *fpn, *t, *tmin, *tmax, *d__, *g, *amd, *amf; integer *imp, *io, *logic, *nap, *napmax; doublereal *x; integer *izs; real *rzs; doublereal *dzs; { static char fmt_1000[] = "(/,4x,\002 nlis0 fpn=\002,d10.3,\002 d2=\002,d9.2,\002 tmin=\002,d9.2,\002 tmax=\002,d9.2)"; static char fmt_1001[] = "(/,4x,\002 nlis0\002,3x,\002fin sur tmin\002,8x,\002pas\002,12x,\002fonctions\002,5x,\002derivees\002)"; static char fmt_1002[] = "(4x,\002 nlis0\002,37x,d10.3,2d11.3)"; static char fmt_1003[] = "(4x,\002 nlis0\002,d14.3,2d11.3)"; static char fmt_1004[] = "(4x,\002 nlis0\002,37x,d10.3,\002 indic=\002,i3)"; static char fmt_1005[] = "(4x,\002 nlis0\002,14x,2d18.8,d11.3)"; static char fmt_1006[] = "(4x,\002 nlis0\002,14x,d18.8,\002 indic=\002,i3)"; static char fmt_1007[] = "(/,4x,\002 nlis0\002,10x,\002tmin force a tmax\002)"; integer i__1; doublereal d__1, d__2, d__3, d__4; integer s_wsfe(), e_wsfe(), do_fio(); double sqrt(); static doublereal tesd, tesf, test, f; static integer i__, indic; static doublereal z__, d2, z1, fa, fd, fg, ta, fp; static integer indica; static doublereal td; static integer indicd; static doublereal tg, fpa, ffn, fpd, fpg; static cilist io___2691 = { 0, 0, 0, fmt_1007, 0 }; static cilist io___2693 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2698 = { 0, 0, 0, fmt_1004, 0 }; static cilist io___2703 = { 0, 0, 0, fmt_1002, 0 }; static cilist io___2704 = { 0, 0, 0, fmt_1003, 0 }; static cilist io___2708 = { 0, 0, 0, fmt_1001, 0 }; static cilist io___2709 = { 0, 0, 0, fmt_1005, 0 }; static cilist io___2710 = { 0, 0, 0, fmt_1005, 0 }; static cilist io___2711 = { 0, 0, 0, fmt_1006, 0 }; --x; --g; --d__; --xn; --izs; --rzs; --dzs; if (*n > 0 && *fpn < 0. && *t > 0. && *tmax > 0. && *amf > 0. && *amd > * amf && *amd < 1.) { goto L5; } *logic = 6; goto L999; L5: tesf = *amf * *fpn; tesd = *amd * *fpn; td = 0.; tg = 0.; fg = *fn; fpg = *fpn; ta = 0.; fa = *fn; fpa = *fpn; (*prosca)(n, &d__[1], &d__[1], &d2, &izs[1], &rzs[1], &dzs[1]); if (*t > *tmin) { goto L20; } *t = *tmin; if (*t <= *tmax) { goto L20; } if (*imp > 0) { io___2691.ciunit = *io; s_wsfe(&io___2691); e_wsfe(); } *tmin = *tmax; L20: if (*fn + *t * *fpn < *fn + *t * .9 * *fpn) { goto L30; } *t *= 2.; goto L20; L30: indica = 1; *logic = 0; if (*t > *tmax) { *t = *tmax; *logic = 1; } if (*imp >= 4) { io___2693.ciunit = *io; s_wsfe(&io___2693); do_fio(&c__1, (char *)&(*fpn), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&d2, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*tmin), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*tmax), (ftnlen)sizeof(doublereal)); e_wsfe(); } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = xn[i__] + *t * d__[i__]; } L100: ++(*nap); if (*nap > *napmax) { *logic = 4; *fn = fg; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] += tg * d__[i__]; } goto L999; } indic = 4; (*simul)(&indic, n, &x[1], &f, &g[1], &izs[1], &rzs[1], &dzs[1]); if (indic == 0) { *logic = 5; *fn = f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] = x[i__]; } goto L999; } if (indic < 0) { td = *t; indicd = indic; *logic = 0; if (*imp >= 4) { io___2698.ciunit = *io; s_wsfe(&io___2698); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer)); e_wsfe(); } *t = tg + (td - tg) * .1; goto L905; } (*prosca)(n, &d__[1], &g[1], &fp, &izs[1], &rzs[1], &dzs[1]); ffn = f - *fn; if (ffn > *t * tesf) { td = *t; fd = f; fpd = fp; indicd = indic; *logic = 0; if (*imp >= 4) { io___2703.ciunit = *io; s_wsfe(&io___2703); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&ffn, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&fp, (ftnlen)sizeof(doublereal)); e_wsfe(); } goto L500; } if (*imp >= 4) { io___2704.ciunit = *io; s_wsfe(&io___2704); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&ffn, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&fp, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (fp > tesd) { *logic = 0; goto L320; } if (*logic == 0) { goto L350; } L320: *fn = f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] = x[i__]; } goto L999; L350: tg = *t; fg = f; fpg = fp; if (td != 0.) { goto L500; } ta = *t; *t = tg * 9.; z__ = *fpn + fp * 3. - ffn * 4. / tg; if (z__ > 0.) { d__3 = 1., d__4 = -fp / z__; d__1 = *t, d__2 = tg * (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ; *t = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } *t = tg + *t; if (*t < *tmax) { goto L900; } *logic = 1; *t = *tmax; goto L900; L500: if (indica <= 0) { ta = *t; *t = tg * .9 + td * .1; goto L900; } z__ = fp + fpa - (fa - f) * 3. / (ta - *t); z1 = z__ * z__ - fp * fpa; if (z1 < 0.) { ta = *t; *t = (td + tg) * .5; goto L900; } if (*t < ta) { z1 = z__ - sqrt(z1); } if (*t > ta) { z1 = z__ + sqrt(z1); } z__ = fp / (fp + z1); z__ = *t + z__ * (ta - *t); ta = *t; test = (td - tg) * .1; d__1 = z__, d__2 = tg + test; *t = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; d__1 = *t, d__2 = td - test; *t = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; L900: fa = f; fpa = fp; L905: indica = indic; if (td == 0.) { goto L950; } if (td - tg < *tmin) { goto L920; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { z__ = xn[i__] + *t * d__[i__]; if (z__ != xn[i__] && z__ != x[i__]) { goto L950; } } L920: *logic = 6; if (indicd < 0) { *logic = indicd; } if (tg == 0.) { goto L940; } *fn = fg; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] += tg * d__[i__]; } L940: if (*imp <= 0) { goto L999; } io___2708.ciunit = *io; s_wsfe(&io___2708); e_wsfe(); io___2709.ciunit = *io; s_wsfe(&io___2709); do_fio(&c__1, (char *)&tg, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&fg, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&fpg, (ftnlen)sizeof(doublereal)); e_wsfe(); if (*logic == 6) { io___2710.ciunit = *io; s_wsfe(&io___2710); do_fio(&c__1, (char *)&td, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&fd, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&fpd, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*logic == 7) { io___2711.ciunit = *io; s_wsfe(&io___2711); do_fio(&c__1, (char *)&td, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&indicd, (ftnlen)sizeof(integer)); e_wsfe(); } goto L999; L950: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = xn[i__] + *t * d__[i__]; } goto L100; L999: return 0; } int nlis2_(simul, prosca, n, xn, fn, fpn, t, tmin, tmax, d__, d2, g, gd, amd, amf, imp, io, logic, nap, napmax, x, tol, a, tps, tnc, gg, izs, rzs, dzs) int (*simul) (), (*prosca) (); integer *n; doublereal *xn, *fn, *fpn, *t, *tmin, *tmax, *d__, *d2, *g, *gd, *amd, *amf; integer *imp, *io, *logic, *nap, *napmax; doublereal *x, *tol, *a, *tps, *tnc, *gg; integer *izs; real *rzs; doublereal *dzs; { static char fmt_1000[] = "(/4x,\002 nlis2 \002,4x,\002fpn=\002,d10.3,\002 d2=\002,d9.2,\002 tmin=\002,d9.2,\002 tmax=\002,d9.2)"; static char fmt_1001[] = "(/4x,\002 nlis2\002,10x,\002tmin force a tmax\002)"; static char fmt_1002[] = "(4x,\002 nlis2\002,36x,\002i\002,d10.3,2d11.3)"; static char fmt_1003[] = "(4x,\002 nlis2\002,d13.3,2d11.3,\002 i\002)"; static char fmt_1004[] = "(4x,\002 nlis2\002,36x,\002i\002,d10.3,\002 indic=\002,i3)"; static char fmt_1006[] = "(4x,\002 nlis2\002,3x,\002contrainte implicite\002,i4,\002 active\002)"; static char fmt_1007[] = "(/4x,\002 nlis2\002,3x,\002fin sur tmin\002)"; static char fmt_1010[] = "(/4x,\002 nlis2\002,3x,i5,\002 simulations atteintes\002)"; static char fmt_1011[] = "(/4x,\002 nlis2\002,3x,\002arret demande par l'utilisateur\002)"; integer i__1; doublereal d__1; integer s_wsfe(), e_wsfe(), do_fio(); static doublereal tesd, tesf, step, f; static integer i__; static doublereal p, s; static integer indic; static doublereal z__; static integer inout; static doublereal fa, fd, fg, hh, ta, fp; static integer indica; static doublereal td; static integer indicd; static doublereal tg, cx, cy, fx, gx, fy, gy, cz, fz, gz; static integer iyflag; static doublereal tx, ty, sthalf, penlty, ggg, fpa, ffn, fpd, fpg; extern int fpq2_(); static cilist io___2729 = { 0, 0, 0, fmt_1001, 0 }; static cilist io___2730 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2744 = { 0, 0, 0, fmt_1010, 0 }; static cilist io___2747 = { 0, 0, 0, fmt_1011, 0 }; static cilist io___2749 = { 0, 0, 0, fmt_1004, 0 }; static cilist io___2754 = { 0, 0, 0, fmt_1002, 0 }; static cilist io___2756 = { 0, 0, 0, fmt_1003, 0 }; static cilist io___2758 = { 0, 0, 0, fmt_1006, 0 }; static cilist io___2759 = { 0, 0, 0, fmt_1007, 0 }; --gg; --x; --gd; --g; --d__; --xn; --izs; --rzs; --dzs; tesf = *amf * *fpn; tesd = *amd * *fpn; td = 0.; tg = 0.; fg = *fn; fpg = *fpn; ta = 0.; fa = *fn; fpa = *fpn; indica = 1; *logic = 0; tx = 0.; cx = 0.; fx = *fn; gx = *fpn; step = *t; sthalf = (float).1; penlty = 0.; if (*t > *tmin) { goto L20; } *t = *tmin; if (*t <= *tmax) { goto L20; } if (*imp > 0) { io___2729.ciunit = *io; s_wsfe(&io___2729); e_wsfe(); } *tmin = *tmax; L20: if (*fn + *t * *fpn < *fn + *t * .9 * *fpn) { goto L30; } *t *= 2.; goto L20; L30: if (*t < *tmax) { goto L40; } *t = *tmax; *logic = 1; L40: if (*imp >= 4) { io___2730.ciunit = *io; s_wsfe(&io___2730); do_fio(&c__1, (char *)&(*fpn), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*d2), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*tmin), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*tmax), (ftnlen)sizeof(doublereal)); e_wsfe(); } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = xn[i__] + *t * d__[i__]; } inout = 0; fpq2_(&inout, &tx, &cx, &fx, &gx, &step, &sthalf, &penlty, &iyflag, &ty, & cy, &fy, &gy, t, &cz, &fz, &gz, &ggg, &hh, &s); L100: ++(*nap); if (*nap <= *napmax) { goto L150; } *logic = 4; if (*imp >= 4) { io___2744.ciunit = *io; s_wsfe(&io___2744); do_fio(&c__1, (char *)&(*nap), (ftnlen)sizeof(integer)); e_wsfe(); } if (tg == 0.) { goto L999; } *fn = fg; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { g[i__] = gg[i__]; xn[i__] += tg * d__[i__]; } goto L999; L150: indic = 4; (*simul)(&indic, n, &x[1], &f, &g[1], &izs[1], &rzs[1], &dzs[1]); if (indic != 0) { goto L200; } *logic = 5; *fn = f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] = x[i__]; } if (*imp >= 4) { io___2747.ciunit = *io; s_wsfe(&io___2747); e_wsfe(); } goto L999; L200: if (indic > 0) { goto L210; } td = *t; indicd = indic; *logic = 0; if (*imp >= 4) { io___2749.ciunit = *io; s_wsfe(&io___2749); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer)); e_wsfe(); } *t = tg + (td - tg) * .1; goto L905; L210: (*prosca)(n, &d__[1], &g[1], &fp, &izs[1], &rzs[1], &dzs[1]); ffn = f - *fn; if (ffn <= *t * tesf) { goto L300; } td = *t; fd = f; fpd = fp; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { gd[i__] = g[i__]; } indicd = indic; *logic = 0; cz = ffn - *t * tesf; fz = f; gz = fp; if (*imp >= 4) { io___2754.ciunit = *io; s_wsfe(&io___2754); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&ffn, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&fp, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (tg != 0.) { goto L500; } if (fpd < tesd) { goto L500; } *tps = *fn - f + td * fpd; *tnc = *d2 * td * td; d__1 = *a * *tnc; p = (( d__1 ) >= ( *tps ) ? ( d__1 ) : ( *tps )) ; if (p > *tol) { goto L500; } *logic = 3; goto L999; L300: if (*imp >= 4) { io___2756.ciunit = *io; s_wsfe(&io___2756); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&ffn, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&fp, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (fp < tesd) { goto L320; } *logic = 0; *fn = f; *fpn = fp; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] = x[i__]; } goto L999; L320: if (*logic == 0) { goto L350; } *fn = f; *fpn = fp; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] = x[i__]; } goto L999; L350: tg = *t; fg = f; fpg = fp; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { gg[i__] = g[i__]; } cz = 0.; fz = f; gz = fp; if (td != 0.) { goto L500; } fpq2_(&inout, &tx, &cx, &fx, &gx, &step, &sthalf, &penlty, &iyflag, &ty, & cy, &fy, &gy, t, &cz, &fz, &gz, &ggg, &hh, &s); if (*t < *tmax) { goto L900; } *logic = 1; *t = *tmax; goto L900; L500: fpq2_(&inout, &tx, &cx, &fx, &gx, &step, &sthalf, &penlty, &iyflag, &ty, & cy, &fy, &gy, t, &cz, &fz, &gz, &ggg, &hh, &s); L900: fa = f; fpa = fp; L905: indica = indic; if (td == 0.) { goto L920; } if (indicd < 0) { goto L920; } if (td - tg > *tmin * 10.) { goto L920; } if (fpd < tesd) { goto L920; } *tps = fg - fd + (td - tg) * fpd; *tnc = *d2 * (td - tg) * (td - tg); d__1 = *a * *tnc; p = (( d__1 ) >= ( *tps ) ? ( d__1 ) : ( *tps )) ; if (p > *tol) { goto L920; } *logic = 2; *fn = fg; *fpn = fpg; *t = tg; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] += tg * d__[i__]; g[i__] = gg[i__]; } goto L999; L920: if (td == 0.) { goto L990; } if (td - tg <= *tmin) { goto L950; } if ((d__1 = ty - tx, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= *tmin) { goto L950; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { z__ = xn[i__] + *t * d__[i__]; if (z__ != x[i__] && z__ != xn[i__]) { goto L990; } } L950: *logic = 6; if (indicd < 0) { *logic = indicd; } if (tg == 0.) { goto L970; } *fn = fg; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] += tg * d__[i__]; g[i__] = gg[i__]; } L970: if (*imp <= 0) { goto L999; } if (*logic < 0) { io___2758.ciunit = *io; s_wsfe(&io___2758); do_fio(&c__1, (char *)&(*logic), (ftnlen)sizeof(integer)); e_wsfe(); } if (*logic == 6) { io___2759.ciunit = *io; s_wsfe(&io___2759); e_wsfe(); } goto L999; L990: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = xn[i__] + *t * d__[i__]; } goto L100; L999: return 0; } int nvkt03_(a, ia, c__, ic, g, v, w, ipvt, dnorma, n, m, mi1, mi, nmd, ndf) doublereal *a; integer *ia; doublereal *c__; integer *ic; doublereal *g, *v, *w; integer *ipvt; doublereal *dnorma; integer *n, *m, *mi1, *mi, *nmd, *ndf; { integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; extern doublereal ddot_(), dnrm2_(); static integer i__, j, m1, ij, ni, mi2; extern int dadd_(); a_dim1 = *ia; a_offset = a_dim1 + 1; a -= a_offset; c_dim1 = *ic; c_offset = c_dim1 + 1; c__ -= c_offset; --g; --v; --w; --ipvt; m1 = *m + 1; mi2 = *mi1 + 1; ni = *mi - *n; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *mi1; for (j = 1; j <= i__2; ++j) { w[j] = c__[i__ + ipvt[j] * c_dim1]; } i__2 = *m; for (j = mi2; j <= i__2; ++j) { ij = ipvt[j]; if (ij < 0) { if (i__ == -ij) { w[j] = -1.; } else { w[j] = 0.; } } else if (ij <= *n) { if (i__ == ij) { w[j] = 1.; } else { w[j] = 0.; } } else if (ij <= *nmd) { w[j] = c__[i__ + (ij + ni) * c_dim1]; } else if (ij < *ndf) { w[j] = a[i__ + (ij - *nmd) * a_dim1]; } } w[*m + i__] = ddot_(m, &w[1], &c__1, &v[1], &c__1); } dadd_(n, &g[1], &c__1, &w[m1], &c__1); *dnorma = dnrm2_(n, &w[m1], &c__1); } int optr01_(c__, ic, q, iq, r__, ir, ci, cs, b, x, w, ipvt, ire, ira, n, m, mi, mi1, md, ind, imp, io, modo) doublereal *c__; integer *ic; doublereal *q; integer *iq; doublereal *r__; integer *ir; doublereal *ci, *cs, *b, *x, *w; integer *ipvt, *ire, *ira, *n, *m, *mi, *mi1, *md, *ind, *imp, *io, *modo; { static char fmt_1000[] = "(/,80(\002*\002),/,10x,a,/,10x,a)"; static char fmt_2000[] = "(/,80(\002*\002),/,10x,a,/,10x,a,i5)"; static char fmt_3000[] = "(/,80(\002*\002),/,10x,\002THE INDEPENDENT LINEAR EQUALITY CONSTRAINTS ARE:\002,/,(10x,20(2x,i4),/))"; static char fmt_7000[] = "(/,10x,\002CALCULATED POINT:\002,/,(t31,sp,e22.16))"; static char fmt_4000[] = "(/,10x,a,i4)"; static char fmt_5000[] = "(/,80(\002*\002),/,10x,a,/,10x,\002THERE ARE NOT FEASIBLE POINTS.\002)"; static char fmt_6000[] = "(/,80(\002-\002),/,10x,\002ITERATION:\002,i4,/,10x,\002OBJECTIVE FUNCTION :\002,f24.15)"; static char fmt_8000[] = "(/,10x,\002SMALLEST LAGRANGE MULTIPLIER :\002,f19.14)"; static char fmt_9000[] = "(/,80(\002*\002),/,10x,a,/,10x,\002INDEFINITE CICLE ON A DEGENERATED POINT.\002)"; static char fmt_10000[] = "(/,80(\002*\002),/,10x,a,/,10x,\002THE LIMIT FOR THE ITERATION NUMBER HAS BEEN PASSED WITHOUT\002,/,10x,\002FINDING A FEASIBLE POINT.\002)"; integer c_dim1, c_offset, q_dim1, q_offset, r_dim1, r_offset, i__1, i__2; doublereal d__1; int s_copy(); integer s_wsfe(), do_fio(), e_wsfe(); double sqrt(), pow_dd(); static integer iira, icol, nmid, irei; extern doublereal ddot_(); static integer indx, iopt, icol1, icol2, icol3; extern doublereal dnrm0_(), dnrm2_(); static doublereal test0; static integer i__, j, k, l; static doublereal s; extern int anfm01_(), anfm02_(), anrs01_(); static integer ireni, icont; extern int auxo01_(), dcopy_(), dmmul_(), daxpy_(); static integer i1, i2, m1, n1, n2, n3; static doublereal r1, s1, r2; static integer ia, ii, icicla, jj; extern doublereal dlamch_(); static integer ni, nm, in, mr, iv; static doublereal xi; static integer ml; static doublereal gigant; static integer itemax; static doublereal cii; static char car[30]; static integer mid, inf, ipc, nmd, nii; static doublereal csi; static integer mni; static doublereal eps, fun, wii, gig1; extern int dadd_(); static cilist io___2767 = { 0, 6, 0, fmt_1000, 0 }; static cilist io___2768 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2774 = { 0, 0, 0, fmt_2000, 0 }; static cilist io___2775 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2776 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2795 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2796 = { 0, 0, 0, fmt_3000, 0 }; static cilist io___2798 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2802 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2803 = { 0, 0, 0, fmt_7000, 0 }; static cilist io___2812 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2814 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___2815 = { 0, 0, 0, fmt_7000, 0 }; static cilist io___2816 = { 0, 0, 0, fmt_4000, 0 }; static cilist io___2817 = { 0, 0, 0, fmt_5000, 0 }; static cilist io___2818 = { 0, 0, 0, fmt_6000, 0 }; static cilist io___2819 = { 0, 0, 0, fmt_7000, 0 }; static cilist io___2822 = { 0, 0, 0, fmt_5000, 0 }; static cilist io___2823 = { 0, 0, 0, fmt_8000, 0 }; static cilist io___2827 = { 0, 0, 0, fmt_9000, 0 }; static cilist io___2838 = { 0, 0, 0, fmt_4000, 0 }; static cilist io___2839 = { 0, 0, 0, fmt_10000, 0 }; c_dim1 = *ic; c_offset = c_dim1 + 1; c__ -= c_offset; q_dim1 = *iq; q_offset = q_dim1 + 1; q -= q_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --ci; --cs; --b; --x; --w; --ipvt; --ire; s_copy(car, "END OF OPTR01.", 30L, 15L); if (*mi < 0 || *md < 0 || *ira < 0 || *ira > 3 || *io < 1 || *n <= 1 || * modo < 1 || *modo > 22 || *ic < *n && (*mi > 0 || *md > 0) || *iq < *n || *ir < *n) { if (*io <= 0) { s_wsfe(&io___2767); do_fio(&c__1, car, 30L); do_fio(&c__1, "INVALID NUMBER FOR THE WRITING CHANEL.", 38L); e_wsfe(); } if (*io > 0) { io___2768.ciunit = *io; s_wsfe(&io___2768); do_fio(&c__1, car, 30L); do_fio(&c__1, "INVALID INTEGER VARIABLES.", 26L); e_wsfe(); } *ind = -5; return 0; } gigant = dlamch_("o", 1L); gig1 = sqrt(gigant); test0 = pow_dd(&gigant, &c_b7108); d__1 = dlamch_("p", 1L); eps = pow_dd(&d__1, &c_b5779); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (*ira == 3) { if (ci[i__] >= -gig1 && cs[i__] <= gig1 && ci[i__] > cs[i__]) { io___2774.ciunit = *io; s_wsfe(&io___2774); do_fio(&c__1, car, 30L); do_fio(&c__1, "CI(I).GT.CS(I) FOR I=", 21L); do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); e_wsfe(); *ind = -5; return 0; } } if ((*modo == 2 || *modo == 4 || *modo == 12 || *modo == 14 || *modo == 22) && *ira > 0) { if (ire[i__] < -1 || ire[i__] > 1) { io___2775.ciunit = *io; s_wsfe(&io___2775); do_fio(&c__1, car, 30L); do_fio(&c__1, "INCORRECT VECTOR IRE.", 21L); e_wsfe(); *ind = -5; return 0; } } else { ire[i__] = 0; } } i__1 = *n + *md; for (i__ = *n + 1; i__ <= i__1; ++i__) { if (*modo == 2 || *modo == 4 || *modo == 12 || *modo == 14 || *modo == 22) { if (ire[i__] < 0 || ire[i__] > 1) { io___2776.ciunit = *io; s_wsfe(&io___2776); do_fio(&c__1, car, 30L); do_fio(&c__1, "INCORRECT VECTOR IRE.", 21L); e_wsfe(); *ind = -5; return 0; } } else { ire[i__] = 0; } } n1 = *n + 1; n2 = n1 + *n; n3 = n2 + *n; nmd = n3 + *md; mni = *mi + 1; *ind = 0; icont = 0; icicla = 0; icol1 = 0; icol2 = 0; mid = *mi + *md; nmid = *n + mid; itemax = nmid << 2; s = dnrm0_(n, &x[1], &c__1); if (s == 0.) { indx = 0; } else { indx = 1; } iopt = 0; inf = 0; if (*modo > 20) { *modo += -20; inf = 1; } else if (*modo > 10) { *modo += -10; } else { iopt = 1; } if (*modo <= 2) { if (*mi == 0) { *m = 0; } *mi1 = *mi; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = 0.; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = 1.; dcopy_(n, &w[1], &c__1, &q[i__ * q_dim1 + 1], &c__1); w[i__] = 0.; } } if (*modo <= 2 && *mi >= 1) { *mi1 = 1; i2 = *mi; i__1 = *mi; for (i__ = 1; i__ <= i__1; ++i__) { anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &c__[i__ * c_dim1 + 1], &w[1], n, mi1, ind, io); if (*ind < 0) { ipvt[i2] = i__; *ind = 0; --i2; } else { ipvt[*mi1] = i__; ++(*mi1); } } --(*mi1); if (*mi1 > 0) { if (indx == 1) { i__1 = *mi1; for (i__ = 1; i__ <= i__1; ++i__) { l = ipvt[i__]; w[i__] = b[l] - ddot_(n, &c__[l * c_dim1 + 1], &c__1, &x[ 1], &c__1); } } else { i__1 = *mi1; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = b[ipvt[i__]]; } } *ind = 1; anrs01_(&r__[r_offset], ir, mi1, &w[1], &w[n1], ind, io); *ind = 0; dmmul_(&q[q_offset], iq, &w[n1], mi1, &w[n2], n, n, mi1, &c__1); if (indx == 1) { dadd_(n, &w[n2], &c__1, &x[1], &c__1); } else { dcopy_(n, &w[n2], &c__1, &x[1], &c__1); } } if (*mi1 < *mi) { i__1 = *mi; for (i__ = *mi1 + 1; i__ <= i__1; ++i__) { l = ipvt[i__]; if (*mi1 > 0) { s = b[l] - ddot_(n, &x[1], &c__1, &c__[l * c_dim1 + 1], & c__1); } else { s = b[l]; } if ((( s ) >= 0 ? ( s ) : -( s )) > eps) { *ind = -1; if (*imp >= 11) { io___2795.ciunit = *io; s_wsfe(&io___2795); do_fio(&c__1, car, 30L); do_fio(&c__1, "THE SYSTEM OF EQUALITY CONSTRAINTS HAS NOT SOLUTION", 51L); e_wsfe(); } return 0; } } } *m = *mi1; } if (*imp >= 12 && *mi1 > 0) { io___2796.ciunit = *io; s_wsfe(&io___2796); i__1 = *mi1; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n + ipvt[i__]; do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer)); } e_wsfe(); } if (*modo == 2) { if (*ira > 0) { i__ = 1; if (i__ <= *n && *m < *n) { L500: if (ire[i__] == 1) { *ind = i__; } if (ire[i__] == -1) { *ind = -i__; } if (*ind != 0) { m1 = *m + 1; anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &w[1], &w[1] , n, &m1, ind, io); if (*ind < 0) { *ind = 0; ire[i__] = 0; } else { *m = m1; ipvt[*m] = ire[i__] * i__; } } ++i__; if (i__ <= *n && *m < *n) { goto L500; } } } if (*md > 0) { i__ = 1; if (i__ <= *md && *m < *n) { L525: if (ire[*n + i__] == 1) { m1 = *m + 1; anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &c__[(*mi + i__) * c_dim1 + 1], &w[1], n, &m1, ind, io); if (*ind < 0) { *ind = 0; ire[*n + i__] = 0; } else { *m = m1; ipvt[*m] = *n + i__; } } ++i__; if (i__ <= *md && *m < *n) { goto L525; } } } } if (*modo == 2 && inf == 1) { if (*imp >= 11) { io___2798.ciunit = *io; s_wsfe(&io___2798); do_fio(&c__1, car, 30L); do_fio(&c__1, "THE FACTORIZATION QR HAS BEEN OBTAINED.", 41L); e_wsfe(); } return 0; } mr = 0; if (inf == 0) { i__2 = *mi1; for (i__ = 1; i__ <= i__2; ++i__) { w[i__] = b[ipvt[i__]]; } i__2 = *m; for (i__ = *mi1 + 1; i__ <= i__2; ++i__) { l = ipvt[i__]; if (l < 0) { w[i__] = -ci[-l]; } else if (l <= *n) { w[i__] = cs[l]; } else { w[i__] = b[*mi + l - *n]; } } mr = *m; if (iopt == 1) { if (*m > 0 && (*modo > 2 || *m > *mi1)) { *ind = 1; anrs01_(&r__[r_offset], ir, m, &w[1], &w[n1], ind, io); dmmul_(&q[q_offset], iq, &w[n1], m, &x[1], n, n, m, &c__1); *ind = 0; } *ind = 0; auxo01_(&c__[mni * c_dim1 + 1], ic, &ci[1], &cs[1], &b[mni], &x[1] , &w[n3], &ire[1], ira, n, md, ind, &fun, &iv); if (iv == 0) { if (*imp >= 11) { io___2802.ciunit = *io; s_wsfe(&io___2802); do_fio(&c__1, car, 30L); do_fio(&c__1, "A FEASIBLE POINT HAS BEEN FOUND (1)", 35L); e_wsfe(); } if (*imp >= 13) { io___2803.ciunit = *io; s_wsfe(&io___2803); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof( doublereal)); } e_wsfe(); } return 0; } } } if (*ira > 0) { i__ = 1; if (i__ <= *n && *m < *n) { L550: iira = 0; if ((*ira == 1 || *ira == 3) && x[i__] <= ci[i__]) { iira = 1; *ind = -i__; } if (iira == 0 && *ira >= 2 && x[i__] >= cs[i__]) { iira = 1; *ind = i__; } if (iira > 0) { m1 = *m + 1; k = *ind; anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &w[1], &w[n1], n, &m1, ind, io); if (*ind < 0) { *ind = 0; } else { *m = m1; ipvt[*m] = k; if (k < 0) { ire[i__] = -1; } else { ire[i__] = 1; } } } ++i__; if (i__ <= *n && *m < *n) { goto L550; } } } if (*md > 0 && *m < *n) { i__ = *mi + 1; nii = *n - *mi; if (i__ <= mid && *m < *n) { L575: s = b[i__] - ddot_(n, &c__[i__ * c_dim1 + 1], &c__1, &x[1], &c__1) ; if (s <= eps) { m1 = *m + 1; anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &c__[i__ * c_dim1 + 1], &w[n1], n, &m1, ind, io); if (*ind < 0) { *ind = 0; } else { ni = nii + i__; *m = m1; ire[ni] = 1; ipvt[*m] = ni; } } ++i__; if (i__ <= mid && *m < *n) { goto L575; } } } if (*ira > 0 && *m < *n && iopt == 0) { i__ = 1; if (i__ <= *n && *m < *n) { L600: j = ire[i__]; if (j == 0) { iira = 0; if (*ira == 1 && ci[i__] >= -gig1) { *ind = -i__; iira = 1; } else if (*ira == 2 && cs[i__] <= gig1) { *ind = i__; iira = 1; } else { cii = ci[i__]; csi = cs[i__]; if (cii >= -gig1 || csi <= gig1) { xi = x[i__]; iira = 1; if (xi - cii < csi - xi) { *ind = -i__; } else { *ind = i__; } } } if (iira > 0) { m1 = *m + 1; k = *ind; anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &w[1], &w[ n1], n, &m1, ind, io); if (*ind < 0) { *ind = 0; } else { *m = m1; ipvt[*m] = k; if (k > 0) { ire[i__] = 1; } else { ire[i__] = -1; } } } } ++i__; if (i__ <= *n && *m < *n) { goto L600; } } } i__ = *mi + 1; if (i__ <= mid && *m < *n && iopt == 0) { L625: ni = nii + i__; j = ire[ni]; if (j == 0) { m1 = *m + 1; anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &c__[i__ * c_dim1 + 1], &w[n1], n, &m1, ind, io); if (*ind < 0) { *ind = 0; } else { *m = m1; ire[ni] = 1; ipvt[*m] = ni; } } ++i__; if (i__ <= mid && *m < *n && iopt == 0) { goto L625; } } if (*modo == 1 && inf == 1) { if (*imp >= 11) { io___2812.ciunit = *io; s_wsfe(&io___2812); do_fio(&c__1, car, 30L); do_fio(&c__1, "THE FACTORIZATION QR HAS BEEN OBTAINED.", 41L); e_wsfe(); } return 0; } m1 = *m + 1; i__2 = *m; for (i__ = mr + 1; i__ <= i__2; ++i__) { l = ipvt[i__]; if (l < 0) { w[i__] = -ci[-l]; } else if (l <= *n) { w[i__] = cs[l]; } else { w[i__] = b[*mi + l - *n]; } } if (iopt == 1 && mr < *m || iopt == 0) { *ind = 1; anrs01_(&r__[r_offset], ir, m, &w[1], &w[1], ind, io); dmmul_(&q[q_offset], iq, &w[1], m, &x[1], n, n, m, &c__1); } *ind = 0; nm = *n - *m; if (icont <= itemax) { L650: if (icicla == 0) { *ind = 1; auxo01_(&c__[mni * c_dim1 + 1], ic, &ci[1], &cs[1], &b[mni], &x[1] , &w[1], &ire[1], ira, n, md, ind, &fun, &iv); *ind = 0; if (iv == 0) { if (*imp >= 11) { io___2814.ciunit = *io; s_wsfe(&io___2814); do_fio(&c__1, car, 30L); do_fio(&c__1, "A FEASIBLE POINT HAS BEEN FOUND", 31L); e_wsfe(); } if (*imp >= 13) { io___2815.ciunit = *io; s_wsfe(&io___2815); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof( doublereal)); } e_wsfe(); } if (*imp >= 12) { io___2816.ciunit = *io; s_wsfe(&io___2816); do_fio(&c__1, "NUMBER OF ITERATIONS:", 21L); do_fio(&c__1, (char *)&icont, (ftnlen)sizeof(integer)); e_wsfe(); } return 0; } else if (iv == 1 && *mi1 == *m) { *ind = -2; if (*imp >= 11) { io___2817.ciunit = *io; s_wsfe(&io___2817); do_fio(&c__1, car, 30L); e_wsfe(); } return 0; } else { if (*imp >= 13) { io___2818.ciunit = *io; s_wsfe(&io___2818); do_fio(&c__1, (char *)&icont, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&fun, (ftnlen)sizeof(doublereal)); e_wsfe(); if (*imp >= 14) { io___2819.ciunit = *io; s_wsfe(&io___2819); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof( doublereal)); } e_wsfe(); } } } } ++icont; if (*m < *n) { j = n2; i__2 = *n; for (i__ = m1; i__ <= i__2; ++i__) { w[j] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &w[1], &c__1); ++j; } i__2 = *n - *m; s = dnrm2_(&i__2, &w[n2], &c__1); s = (( s ) >= 0 ? ( s ) : -( s )) ; } else { s = 0.; } if (s < eps) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { w[*n + i__] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &w[1], & c__1); } *ind = 2; anrs01_(&r__[r_offset], ir, m, &w[n1], &w[n2], ind, io); *ind = 0; icol = *mi1 + 1; s1 = w[n2 + *mi1]; i__2 = *m - 1; for (i__ = *mi1 + 1; i__ <= i__2; ++i__) { j = n2 + i__; if (w[j] < s1) { s1 = w[j]; icol = i__ + 1; } } if (s1 > -eps) { if (*imp >= 11) { io___2822.ciunit = *io; s_wsfe(&io___2822); do_fio(&c__1, car, 30L); e_wsfe(); io___2823.ciunit = *io; s_wsfe(&io___2823); do_fio(&c__1, (char *)&s1, (ftnlen)sizeof(doublereal)); e_wsfe(); } *ind = -2; return 0; } anfm02_(&q[q_offset], iq, &r__[r_offset], ir, n, m, &icol, io); s1 = ddot_(n, &q[*n * q_dim1 + 1], &c__1, &w[1], &c__1); dcopy_(n, &q[*n * q_dim1 + 1], &c__1, &w[n1], &c__1); if (s1 < 0.) { i__2 = n2 - 1; for (i__ = n1; i__ <= i__2; ++i__) { w[i__] = -w[i__]; } } else { s1 = -s1; } } else { i__2 = *n - *m; i__1 = *n - *m; dmmul_(&q[m1 * q_dim1 + 1], iq, &w[n2], &i__2, &w[n1], n, n, & i__1, &c__1); s1 = -ddot_(n, &w[1], &c__1, &w[n1], &c__1); icol = n1; } k = 0; if (*ira > 0) { i__ = 0; if (i__ < *n && k == 0) { L675: ++i__; ii = *n + i__; if (*ira > 1) { if (cs[i__] <= gig1 && ire[i__] == 0 && w[ii] > eps && x[ i__] >= cs[i__] - eps) { k = 1; icol3 = i__; } } if (k == 0 && *ira != 2) { if (ci[i__] >= -gig1 && ire[i__] == 0 && w[ii] < -eps && x[i__] <= ci[i__] + eps) { k = 1; icol3 = -i__; } } if (i__ < *n && k == 0) { goto L675; } } } i__ = 0; if (i__ < *md && k == 0) { L700: ii = nmd + i__; in = n3 + i__; ++i__; ni = *n + i__; if (ire[ni] != 1) { w[ii] = ddot_(n, &c__[(*mi + i__) * c_dim1 + 1], &c__1, &w[n1] , &c__1); if (ire[ni] == 0 && w[in] >= -eps && w[ii] > eps) { k = 1; icol3 = ni; } } if (i__ < *md && k == 0) { goto L700; } } if (k == 1) { ++icicla; if (icol < n1) { if (icicla > *m || icol3 == icol1 && icol == *m) { if (*imp >= 11) { io___2827.ciunit = *io; s_wsfe(&io___2827); do_fio(&c__1, car, 30L); e_wsfe(); } *ind = -3; return 0; } icol1 = icol2; icol2 = icol3; i__ = ipvt[icol]; if (i__ > *n) { w[n2 + i__] = ddot_(n, &c__[(i__ - *n + *mi) * c_dim1 + 1] , &c__1, &x[1], &c__1) - b[i__ - *n + *mi]; } } } else if (icicla > 0) { icicla = 0; icol1 = 0; icol2 = 0; } k = 0; if (*ira > 0) { i__ = 0; if (i__ < *n && icicla == 0) { L725: i1 = i__ + 1; j = 0; ii = n1 + i__; wii = w[ii]; irei = ire[i1]; if (*ira > 1) { if (cs[i1] <= gig1 && (irei == 0 && wii > eps || irei == 2 && wii < -eps)) { w[n2 + k] = (cs[i1] - x[i1]) / wii; ++k; ipvt[*m + k] = i1; j = 1; } } if (j == 0 && *ira != 2) { if (ci[i1] >= -gig1 && (irei == 0 && wii < -eps || irei == -2 && wii > eps)) { w[n2 + k] = (ci[i1] - x[i1]) / wii; ++k; ipvt[*m + k] = -i1; } } i__ = i1; if (i__ < *n && icicla == 0) { goto L725; } } } if (icol < n1) { ipc = ipvt[icol]; ia = (( ipc ) >= 0 ? ( ipc ) : -( ipc )) ; if (icicla == 0 && ia <= *n && *ira == 3) { cii = ci[ia]; csi = cs[ia]; if (cii >= -gig1 && csi <= gig1) { ++k; if (ipc < 0) { w[n2 + k - 1] = (csi - x[ia]) / w[*n + ia]; ipvt[*m + k] = ia; } else { w[n2 + k - 1] = (cii - x[ia]) / w[*n + ia]; ipvt[*m + k] = -ia; } } } } i__ = 0; if (i__ < *md && icicla == 0) { L750: i1 = i__ + 1; ii = nmd + i__; ni = *n + i1; ireni = ire[ni]; wii = w[ii]; if (ireni == 0 && wii > eps || ireni == 2 && wii < -eps) { w[n2 + k] = -w[n3 + i__] / wii; ++k; ipvt[*m + k] = ni; } i__ = i1; if (i__ < *md && icicla == 0) { goto L750; } } r2 = 0.; if (icicla == 0 && s1 < -eps) { L775: l = 0; r1 = r2; r2 = gigant; i__2 = k; for (i__ = 1; i__ <= i__2; ++i__) { ii = n2 + i__ - 1; wii = w[ii]; if (wii <= r2 && wii > r1) { if (wii < r2) { l = 0; } r2 = wii; w[ii] = w[n2 + l]; w[n2 + l] = r2; ni = *m + i__; ++l; j = ipvt[ni]; ml = *m + l; ipvt[ni] = ipvt[ml]; ipvt[ml] = j; } } icol3 = ipvt[m1]; i__2 = l; for (i__ = 1; i__ <= i__2; ++i__) { j = ipvt[*m + i__]; if (j < 0) { j = -j; jj = *n + j; if (ire[j] == -2) { s1 += w[jj]; if (*ira == 3) { if (ci[j] >= -gig1 && cs[j] <= gig1) { ire[j] = 0; ipvt[*m + i__] = j; w[n2 + i__ - 1] = (cs[j] - x[j]) / w[*n + j]; } } } else { s1 -= w[jj]; } } else if (j < n1) { jj = *n + j; if (ire[j] == 2) { s1 -= w[jj]; if (*ira == 3) { if (ci[j] >= -gig1 && cs[i__] <= gig1) { ire[j] = 0; ipvt[*m + i__] = -j; w[n2 + i__ - 1] = (ci[j] - x[j]) / w[*n + j]; } } } else { s1 += w[jj]; } } else if (j > *n) { jj = nmd + j - n1; if (ire[j] == 2) { s1 -= w[jj]; } if (ire[j] == 0) { s1 += w[jj]; } } } if (icicla == 0 && s1 < -eps) { goto L775; } } if (icicla == 0) { ipvt[m1] = icol3; daxpy_(n, &r2, &w[n1], &c__1, &x[1], &c__1); } if (icol3 < 0) { ire[-icol3] = -1; } else { ire[icol3] = 1; } if (icol < n1) { ire[ia] = 0; i__2 = *m - 1; for (j = icol; j <= i__2; ++j) { ipvt[j] = ipvt[j + 1]; } ipvt[*m] = icol3; } else { icicla = 0; *m = m1; ++m1; } if (icol3 <= *n) { *ind = icol3; } else { dcopy_(n, &c__[(*mi + icol3 - *n) * c_dim1 + 1], &c__1, &w[n1], & c__1); } anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &w[n1], &w[n2], n, m, ind, io); *ind = 0; if (icicla != 0 && *imp >= 13) { io___2838.ciunit = *io; s_wsfe(&io___2838); do_fio(&c__1, "A DEGENERATED POINT HAS BEEN FOUND IN THE ITERATION:", 52L); do_fio(&c__1, (char *)&icont, (ftnlen)sizeof(integer)); e_wsfe(); } if (icont <= itemax) { goto L650; } } if (*imp >= 11) { io___2839.ciunit = *io; s_wsfe(&io___2839); do_fio(&c__1, car, 30L); e_wsfe(); } *ind = -4; } int optr03_(a, ia, c__, ic, q, iq, r__, ir, p, b, d__, ci, cs, x, w, iw, ire, ipvt, jpvt, alfa, ira, n, m, mi, mi1, md, mif, mdf, modo, ind, imp, io, iter) doublereal *a; integer *ia; doublereal *c__; integer *ic; doublereal *q; integer *iq; doublereal *r__; integer *ir; doublereal *p, *b, *d__, *ci, *cs, *x, *w; integer *iw, *ire, *ipvt, *jpvt; doublereal *alfa; integer *ira, *n, *m, *mi, *mi1, *md, *mif, *mdf, *modo, *ind, *imp, *io, * iter; { integer c_dim1, c_offset, a_dim1, a_offset, q_dim1, q_offset, r_dim1, r_offset, i__1, i__2; doublereal d__1, d__2; double pow_dd(), sqrt(); static integer iadd; extern int ddif_(); static integer midf, ides, icol, nmdi, indm; extern doublereal ddot_(); static integer info; extern int tol03_(); static integer iver, inul, icol1, icol2, icol3; extern int aux003_(); extern doublereal dnrm0_(), dnrm2_(); static integer i__, j, k, l; static doublereal s; extern int anfm01_(), anfm03_(), dscal_(), anfm02_(), anfm06_(), anfm04_(), dimp03_(), anfm05_(); static integer iicol; extern int desr03_(), anrs01_(), pasr03_(); static integer icont; extern int auxo01_(), dmmul_(), dcopy_(); extern doublereal opvf03_(); extern int optr01_(), nvkt03_(), daxpy_(); static integer i1, j1, m0, m1, n1, n2, n3, m2; static doublereal s1, s2, s3; static integer id, n10, nd, ii, icicla, il; extern doublereal dlamch_(); static integer ni, ip, nm, iv, iibeta; static doublereal ro; extern integer idamax_(); static integer jj, in; static doublereal sj, sk; static integer nf; static doublereal gigant, sw, epsmch, dnorma; static integer itemax, minimo, nd1, nm1; static doublereal xi1; static integer iad, icd; static doublereal cii; static integer mid, nmd; static doublereal csi; static integer nmf, idw; static doublereal eps, fun, gig1; static integer ind1; static doublereal eps0; extern int dadd_(); a_dim1 = *ia; a_offset = a_dim1 + 1; a -= a_offset; c_dim1 = *ic; c_offset = c_dim1 + 1; c__ -= c_offset; q_dim1 = *iq; q_offset = q_dim1 + 1; q -= q_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; --p; --b; --d__; --ci; --cs; --x; --w; --ire; --ipvt; --jpvt; if (*ic < *n && (*mi > 0 || *md > 0) || *n <= 1 || *ir < *n || (*mif > 0 || *mdf > 0) && *ia < *n || *iq < *n || *modo < -1 || *modo > 6 || *mi < 0 || *md < 0 || *mif < 0 || *mdf < 0 || *ira < 0 || *ira > 3 || *io < 1) { *ind = -4; dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0, &c__0, & c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter); return 0; } epsmch = dlamch_("p", 1L); eps = pow_dd(&epsmch, &c_b5779); eps0 = pow_dd(&epsmch, &c_b5732); gigant = dlamch_("o", 1L); gig1 = sqrt(gigant); if (*ira > 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (*ira == 3) { if (ci[i__] >= -gig1 && cs[i__] <= gig1 && ci[i__] > cs[i__]) { if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &i__, & c__0, &c__0, &c__0, &c__0, &c__0, &c__0, & c__0, &c__0, &c_n24, imp, io, iter); } *ind = -4; return 0; } } if (*modo == 3 || *modo == 5 || *modo <= 0) { if (ire[i__] < -1 || ire[i__] > 1) { if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, & c__0, &c__0, &c__0, &c__0, &c__0, &c__0, & c__0, &c__0, &c_n34, imp, io, iter); } *ind = -4; return 0; } } } } if (*modo == 3 || *modo == 5 || *modo <= 0) { i__1 = *n + *md + *mif + *mdf; for (i__ = *n + 1; i__ <= i__1; ++i__) { if ((ire[i__] < 0 || ire[i__] > 1) && i__ <= *n + *md || (ire[i__] < -2 || ire[i__] > 2) && i__ > *n + *md) { if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c_n34, imp, io, iter); } *ind = -4; return 0; } } } if (*modo > 3) { iver = 1; if (*modo == 6) { *modo = 1; } else { *modo += -2; } } else { iver = -1; } n1 = *n + 1; n2 = n1 + *n; n3 = n2 + *n; n10 = *iq * 10; if (*modo != 3 || *modo != 0) { *mi1 = *mi; } mid = *mi + *md; midf = *mif + *mdf; nmd = *n + *md; nmdi = nmd + *mif; nd1 = nmd + 1; nd = nmd + midf + 1; icd = nd + *n; iad = icd + *md; idw = iad + midf; *iter = 0; id = 0; *ind = 0; icicla = 0; il = 0; icol = 0; icol1 = 0; icol2 = 0; iicol = 0; info = 0; itemax = *n + mid + midf << 2; icont = 0; if (*ira == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ire[i__] = 0; } } if (*modo == -1) { if (*mi == 0) { *m = 0; } if (mid == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (i__ == j) { q[i__ + j * q_dim1] = 1.; } else { q[i__ + j * q_dim1] = 0.; } } } } if (mid == 0 && *ira > 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (ire[i__] == 1) { *ind = i__; } if (ire[i__] == -1) { *ind = -i__; } if (*ind != 0) { ++(*m); anfm01_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &w[ 1], &w[1], n, m, ind, io); ipvt[*m] = ire[i__] * i__; } } } else if (mid > 0) { *modo = 22; optr01_(&c__[c_offset], ic, &q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &ci[1], &cs[1], &d__[1], &x[1], &w[1], &ipvt[1], &ire[1], ira, n, m, mi, mi1, md, ind, imp, io, modo); *modo = -1; } if (midf > 0) { i__ = 1; if (i__ <= midf && *m < *n) { L1000: ni = nmd + i__; if (ire[ni] == 1) { m1 = *m + 1; *ind = 0; anfm01_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &a[ i__ * a_dim1 + 1], &w[1], n, &m1, ind, io); if (*ind < 0) { ire[ni] = 0; } else { *m = m1; ipvt[*m] = ni; } } ++i__; if (i__ <= midf && *m < *n) { goto L1000; } } } } if (*modo <= 0) { i1 = idamax_(n, &x[1], &c__1); s1 = x[i1]; if (s1 == 0.) { i__1 = *mi1; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] = d__[ipvt[i__]]; } i__1 = *m; for (i__ = *mi1 + 1; i__ <= i__1; ++i__) { l = ipvt[i__]; if (l < 0) { w[i__] = -ci[-l]; } else if (l <= *n) { w[i__] = cs[l]; } else if (l <= nmd) { w[i__] = d__[*mi + l - *n]; } else { w[i__] = b[l - nmd]; } } } else { i__1 = *mi1; for (i__ = 1; i__ <= i__1; ++i__) { l = ipvt[i__]; w[i__] = d__[l] - ddot_(n, &c__[l * c_dim1 + 1], &c__1, &x[1], &c__1); } i__1 = *m; for (i__ = *mi1 + 1; i__ <= i__1; ++i__) { l = ipvt[i__]; if (l < 0) { w[i__] = -ci[-l] + x[-l]; } else if (l <= *n) { w[i__] = cs[l] - x[l]; } else if (l <= nmd) { ni = *mi + l - *n; w[i__] = d__[ni] - ddot_(n, &c__[ni * c_dim1 + 1], &c__1, &x[1], &c__1); } else { ni = l - nmd; w[i__] = b[ni] - ddot_(n, &a[ni * a_dim1 + 1], &c__1, &x[ 1], &c__1); } } } *ind = 1; anrs01_(&r__[(r_dim1 << 1) + 1], ir, m, &w[1], &w[n1], ind, io); *ind = 0; dmmul_(&q[q_offset], iq, &w[n1], m, &w[1], n, n, m, &c__1); dadd_(n, &x[1], &c__1, &w[1], &c__1); iv = 0; if (mid > 0 || *ira > 0) { i1 = *mi + 1; auxo01_(&c__[i1 * c_dim1 + 1], ic, &ci[1], &cs[1], &d__[i1], &w[1] , &w[n1], &ire[1], ira, n, md, ind, &fun, &iv); } if (iv == 0) { dcopy_(n, &w[1], &c__1, &x[1], &c__1); } else { *modo = 2; } } if (mid == 0 && (*modo == 2 || *modo == 1 && *ira == 0)) { *m = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (i__ == j) { q[i__ + j * q_dim1] = 1.; } else { q[i__ + j * q_dim1] = 0.; } } } } if (*modo == 1) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = 0.; } if (mid > 0 || *ira > 0) { if (iver == 1) { *modo = 11; } optr01_(&c__[c_offset], ic, &q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &ci[1], &cs[1], &d__[1], &x[1], &w[1], &ipvt[1], &ire[1], ira, n, m, mi, mi1, md, ind, imp, io, modo); if (iver == 1) { *modo = 1; } if (*ind < 0) { *ind += -10; if (*imp >= 7 && *imp <= 10) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter); } return 0; } dcopy_(md, &w[n3], &c__1, &w[n1], &c__1); } } if (*modo == 2) { *m = 0; if (*ira >= 1) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ire[i__] = 0; if (*ira != 2) { if (ci[i__] >= -gig1) { if (x[i__] < ci[i__] + eps) { x[i__] = ci[i__]; ire[i__] = -1; if (mid == 0) { ++(*m); ip = -i__; anfm01_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &x[1], &w[1], n, m, &ip, io) ; ipvt[*m] = -i__; } } } } if (*ira >= 2) { if (cs[i__] <= gig1 && ire[i__] == 0) { if (x[i__] > cs[i__] - eps) { x[i__] = cs[i__]; ire[i__] = 1; if (mid == 0) { ++(*m); ip = i__; anfm01_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &x[1], &w[1], n, m, &ip, io) ; ipvt[*m] = i__; } } } } } } i__1 = *md; for (i__ = 1; i__ <= i__1; ++i__) { ii = *mi + i__; s = ddot_(n, &c__[ii * c_dim1 + 1], &c__1, &x[1], &c__1) - d__[ii] ; ni = *n + i__; if (s > -eps) { ire[ni] = 1; } else { ire[ni] = 0; } w[ni] = s; } if (mid > 0) { *modo = 22; optr01_(&c__[c_offset], ic, &q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &ci[1], &cs[1], &d__[1], &x[1], &w[nd1], &ipvt[ 1], &ire[1], ira, n, m, mi, mi1, md, ind, imp, io, modo); *modo = 2; } } iv = 0; if (iver == 1) { iv = *m; iver = *m; } if (*modo == 3) { i__1 = *md; for (i__ = 1; i__ <= i__1; ++i__) { ii = *mi + i__; ni = *n + i__; w[ni] = 0.; if (ire[ni] == 0) { w[ni] = ddot_(n, &c__[ii * c_dim1 + 1], &c__1, &x[1], &c__1) - d__[ii]; } } i__1 = midf; for (i__ = 1; i__ <= i__1; ++i__) { ii = (i__2 = ire[nmd + i__], (( i__2 ) >= 0 ? ( i__2 ) : -( i__2 )) ); if (i__ <= *mif && ii == 2 || ii != 1) { w[nmd + i__] = ddot_(n, &a[i__ * a_dim1 + 1], &c__1, &x[1], & c__1) - b[i__]; } else { w[nmd + i__] = 0.; } } } else { i__1 = midf; for (i__ = 1; i__ <= i__1; ++i__) { w[nmd + i__] = 0.; } *ind = 0; if (*modo > 0) { i__1 = nmd + midf; for (i__ = nd1; i__ <= i__1; ++i__) { ire[i__] = 0; } } aux003_(&a[a_offset], ia, &x[1], &b[1], &q[q_offset], iq, &r__[( r_dim1 << 1) + 1], ir, &w[nd1], &ire[nd1], &ipvt[1], &nmd, mif, mdf, &midf, n, m, ind, io); } if (*m == *n) { minimo = 1; id = 2; nm = 0; } else { minimo = 0; } if (minimo == 0 && *modo != -2) { m1 = *m + 1; nm = *n - *m; *ind = 0; i__1 = iver - iv; anfm03_(&r__[r_offset], ir, &r__[(m1 + 1) * r_dim1 + 1], ir, &q[m1 * q_dim1 + 1], iq, &w[1], &jpvt[1], n, &nm, ind, &i__1, io); if (*ind <= -n10) { *ind += n10; iibeta = 1; } else { iibeta = 0; } if (*ind == *n && iver == iv) { *ind = -1; if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0, & c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter); } return 0; } } else if (minimo == 0) { nm = *n - *m; } if (*iter <= itemax) { L2000: iadd = 0; ind1 = 0; il = 0; if (iicol == 1) { id = 2; } if (icicla == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__ + 1; s = ddot_(&i__, &r__[i__ + r_dim1], ir, &x[1], &c__1); if (i__ < *n) { i__2 = *n - i__; w[i__] = s + ddot_(&i__2, &r__[i1 + i__ * r_dim1], &c__1, &x[i1], &c__1); } } w[*n] = s; dadd_(n, &p[1], &c__1, &w[1], &c__1); if (*alfa != 1.) { dscal_(n, alfa, &w[1], &c__1); } i__1 = *mif; for (i__ = 1; i__ <= i__1; ++i__) { ni = nmd + i__; if (ire[ni] == 2) { dadd_(n, &a[i__ * a_dim1 + 1], &c__1, &w[1], &c__1); } else if (ire[ni] == -2) { ddif_(n, &a[i__ * a_dim1 + 1], &c__1, &w[1], &c__1); } } i__1 = midf; for (i__ = *mif + 1; i__ <= i__1; ++i__) { if (ire[i__ + nmd] == 2) { dadd_(n, &a[i__ * a_dim1 + 1], &c__1, &w[1], &c__1); } } } s1 = gigant; s2 = 0.; inul = 0; if (id >= 2) { i1 = icd - 1; i__1 = nm; for (i__ = 1; i__ <= i__1; ++i__) { w[i1 + i__] = ddot_(n, &q[(n1 - i__) * q_dim1 + 1], &c__1, &w[ 1], &c__1); } if (minimo == 0) { s2 = dnrm2_(&nm, &w[icd], &c__1) / (dnrm0_(n, &x[1], &c__1) + 1); } if (s2 >= eps0) { info = 10; ++icont; } else if (icont > 0) { icont = 0; } if ((*m > *mi1 || (*imp >= 8 || *iw == 1) && *m > 0) && (icont == 0 || icont == 3)) { i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { w[nd + i__ - 1] = -ddot_(n, &q[i__ * q_dim1 + 1], &c__1, & w[1], &c__1); } anrs01_(&r__[(r_dim1 << 1) + 1], ir, m, &w[nd], &w[nd], &c__2, io); if (*m > *mi1) { indm = 1; if (indm == 1) { L3000: icol = 0; j = nd - 1 + *mi1; i__1 = *m; for (i__ = *mi1 + 1; i__ <= i__1; ++i__) { ++j; k = ipvt[i__]; if (k <= nmd) { s = w[j]; } else if (k > nmd && k <= nmdi) { s = 1. - (d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } else { sw = w[j]; d__1 = sw, d__2 = 1. - sw; s = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } if (s < s1) { s1 = s; icol = i__; } } if (icol != 0) { if (ipvt[icol] > nmd) { inul = 1; } } if (s1 < -eps || s1 <= eps && inul == 0) { if (inul == 0 && (( s1 ) >= 0 ? ( s1 ) : -( s1 )) <= eps) { dcopy_(m, &w[nd], &c__1, &w[icd], &c__1); } if (icont > 0) { icont = 0; } if (*m > 1) { anfm02_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, n, m, &icol, io); } m1 = *m - 1; il = ipvt[icol]; if (il > *n) { w[il] = 0.; } s = w[nd + icol - 1]; ire[(( il ) >= 0 ? ( il ) : -( il )) ] = 0; i__1 = m1; for (j = icol; j <= i__1; ++j) { ipvt[j] = ipvt[j + 1]; } if (minimo == 1) { *ind = 0; nm = 0; } anfm06_(&q[*m * q_dim1 + 1], iq, &r__[r_offset], ir, &w[nd], &jpvt[1], n, &nm, ind, io); info = 1; *m = m1; if (iver != -1 && il <= nmd) { --iver; } else if (iver == iv && *ind < 0) { *ind = -1; if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], & s, &c__0, &c__0, &c__0, &c__0, & c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter); } return 0; } } if (*ind < 0 || *ind > nm || (( s1 ) >= 0 ? ( s1 ) : -( s1 )) > eps) { indm = 0; } else { s1 = gigant; i__1 = icol - 1; dcopy_(&i__1, &w[icd], &c__1, &w[nd], &c__1); j1 = nd + icol - 1; i__1 = icd + *m; for (j = icd + icol; j <= i__1; ++j) { w[j1] = w[j]; ++j1; } } if (indm == 1) { goto L3000; } } } } } if (id >= 2 && (s1 > eps || s1 >= -eps && inul == 1) && (s2 < eps0 || icont >= 3)) { tol03_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &c__[ c_offset], ic, &d__[1], &a[a_offset], ia, &b[1], &ci[1], & cs[1], &x[1], &w[nd + *m], &ipvt[1], n, m, mi, mi1, &nmd, io); *ind = 0; if (*iw != 0) { *iw = nd + *m; w[*iw] = opvf03_(&r__[r_offset], ir, &a[a_offset], ia, &p[1], &b[1], &x[1], &w[1], alfa, &nd, n, mif, mdf); } if (*imp >= 8) { if (*iw != 0) { s = w[*iw]; } nvkt03_(&a[a_offset], ia, &c__[c_offset], ic, &w[1], &w[nd], & w[nd + *m], &ipvt[1], &dnorma, n, m, mi1, mi, &nmd, & nd); if (*iw != 0) { w[*iw] = s; w[*iw + 1] = dnorma; } } if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &dnorma, n, m, &nd, iw, &c__0, &c__0, &c__0, mi, mi1, ind, imp, io, iter); } return 0; } if (il > nmd) { k = il - nmd; if (s > 0.) { dadd_(n, &a[k * a_dim1 + 1], &c__1, &w[1], &c__1); } else if (s < 0. && il <= nmdi) { ddif_(n, &a[k * a_dim1 + 1], &c__1, &w[1], &c__1); } } m1 = *m + 1; m2 = m1 + 1; desr03_(&q[m1 * q_dim1 + 1], iq, &r__[m2 * r_dim1 + 1], ir, &w[1], &w[ icd], &w[nd], alfa, &jpvt[1], &nm, n, ind, &info, &id, &ro, io); if (*imp >= 9) { if (id == 1) { ides = 1; } else if (*ind > 0 && *ind <= nm) { ides = 0; } else { ides = -1; } } k = 0; if (iver == -1 || iver != iv) { if (*ira > 0) { i__ = 0; if (i__ < *n && k == 0) { L4000: i1 = i__ + 1; ii = i__ + nd; xi1 = x[i1]; if (*ira > 1) { csi = cs[i1]; if (csi <= gig1 && ire[i1] == 0 && w[ii] > eps && xi1 >= csi - eps) { s2 = dnrm2_(&nm, &q[i1 + m1 * q_dim1], iq); if (s2 >= epsmch) { k = 1; ipvt[m1] = i1; } else { w[ii] = 0.; } } } if (k == 0 && *ira != 2) { cii = ci[i1]; if (cii >= -gig1 && ire[i1] == 0 && w[ii] < -eps && xi1 <= cii + eps) { s2 = dnrm2_(&nm, &q[i1 + m1 * q_dim1], iq); if (s2 >= epsmch) { k = 1; ipvt[m1] = -i1; } else { w[ii] = 0.; } } } i__ = i1; if (i__ < *n && k == 0) { goto L4000; } } } i__ = 0; if (i__ < *md && k == 0) { L5000: ii = icd + i__; ++i__; ni = *n + i__; if (ire[ni] != 1) { w[ii] = ddot_(n, &c__[(*mi + i__) * c_dim1 + 1], &c__1, & w[nd], &c__1); if (w[ni] >= -eps && w[ii] > eps) { jj = idw; i__1 = *n; for (j = m1; j <= i__1; ++j) { w[jj] = ddot_(n, &q[j * q_dim1 + 1], &c__1, &c__[( *mi + i__) * c_dim1 + 1], &c__1); ++jj; } s2 = dnrm2_(&nm, &w[idw], &c__1); if (s2 >= epsmch) { k = 1; ipvt[m1] = ni; } else { w[ii] = 0.; } } } if (i__ < *md && k == 0) { goto L5000; } } } else { i__1 = icd + *md - 1; for (i__ = icd; i__ <= i__1; ++i__) { w[i__] = 0.; } } i__ = 0; if (i__ < midf && k == 0) { L6000: i1 = i__ + 1; in = nmd + i1; if (ire[in] != 1) { ii = iad + i__; w[ii] = ddot_(n, &a[i1 * a_dim1 + 1], &c__1, &w[nd], &c__1); if (ire[in] == 0 && in != il) { if (i1 <= *mif && (d__1 = w[ii], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > eps || i1 > *mif && w[ii] > eps && w[in] >= -eps) { if (il == 0) { m0 = m1; } else { m0 = *m + 2; } jj = idw; i__1 = *n; for (i__ = m0; i__ <= i__1; ++i__) { w[jj] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &a[ i1 * a_dim1 + 1], &c__1); ++jj; } s2 = dnrm2_(&nm, &w[idw], &c__1); if (s2 >= epsmch) { k = 1; ipvt[m1] = in; } else if (il == 0) { w[ii] = 0.; } else { sj = ddot_(n, &q[m1 * q_dim1 + 1], &c__1, &a[i1 * a_dim1 + 1], &c__1); if ((( sj ) >= 0 ? ( sj ) : -( sj )) >= epsmch) { if (id != 1) { ind1 = 10; } if (il < 0) { sj = -sj / q[-il + m1 * q_dim1]; } else if (il <= *n) { sj /= q[il + m1 * q_dim1]; } else if (il <= nmd) { s2 = ddot_(n, &q[m1 * q_dim1 + 1], &c__1, &c__[(*mi + il - *n) * c_dim1 + 1] , &c__1); sj /= s2; } else { s2 = ddot_(n, &q[m1 * q_dim1 + 1], &c__1, &a[(il - nmd) * a_dim1 + 1], & c__1); sj /= s2; } sk = 0.; s3 = -1.; if (i1 <= *mif) { s2 = (( sj ) >= 0 ? ( sj ) : -( sj )) ; if (il <= nmd || il > nmdi && s < -eps) { s3 = s2 + s; if (sj > eps) { sk = -1.; } else { sk = 1.; } } else { s3 = s2 - (( s ) >= 0 ? ( s ) : -( s )) + 1.; if (s < -eps && sj > eps || s > eps && sj < -eps) { sk = -1.; } else { sk = 1.; } } } else { if (sj < -eps && (il <= nmd || il > nmdi && s < -eps)) { s3 = s - sj; sk = 1.; } else if (sj > eps && il > nmd && s > eps) { s3 = sj + s1; sk = 1.; } else if (sj < -eps && il > nmd && il <= nmdi && s < -eps) { s3 = s1 - sj; sk = 1.; } } if (s3 > eps) { ipvt[m1] = nmd + i1; if (id == 1) { id = 2; k = 1; } else { ind1 = 11; } } else if (id == 1) { if (s > 0.) { s1 = -s + 1; } else if (s < 0. && il <= nmdi && il > nmd) { s1 = -s - 1; } else { s1 = -s; } s = sk * sj / s1 + 1.; if (info == 0) { dscal_(n, &s, &w[nd], &c__1); } else { ro = s * ro; } if (sk == 1.) { dadd_(n, &a[i1 * a_dim1 + 1], &c__1, & w[1], &c__1); } else if (sk == -1.) { ddif_(n, &a[i1 * a_dim1 + 1], &c__1, & w[1], &c__1); } w[ii] = 0.; } } else { w[ii] = 0.; } } } } } i__ = i1; if (i__ < midf && k == 0) { goto L6000; } } if (k == 0) { if (id == 0 && *ind <= nm && *ind > 0) { id = 2; } if (ind1 == 11 && id != 1) { id += 100; } if (ind1 == 10 && id != 1) { id += 10; } pasr03_(&a[a_offset], ia, &b[1], &ci[1], &cs[1], &x[1], &ro, &w[1] , &ire[1], &ipvt[m1], ira, n, md, mif, mdf, m, &id, io); if (id == -1) { *ind = -1; if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter); } return 0; } else if (id == 0) { id = 2; k = 1; } if (id == 1 || id == 3 || id == 11) { icol3 = ipvt[m1]; if (*imp >= 9) { iadd = icol3; } } } if (k == 1) { ++icicla; icol3 = ipvt[m1]; if (*imp >= 9) { iadd = icol3; } if (icicla > *m && *m > 0 || icol3 == icol1 && icol == *m) { *ind = -2; if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter); } return 0; } icol1 = icol2; icol2 = icol3; } else if (icicla > 0) { icicla = 0; icol1 = 0; icol2 = 0; } if (*imp >= 9) { dimp03_(&x[1], &w[1], &ire[nd1], &ipvt[1], &s, n, &il, m, &midf, & ides, &icicla, &iadd, mi, mi1, &c__2, imp, io, iter); } if (icicla == 0) { i1 = icd - 1; i__1 = *md; for (i__ = 1; i__ <= i__1; ++i__) { ni = *n + i__; if (ire[ni] == 0 && (iver != iv || iver == -1) && id < 10) { if (ro == 1.) { w[ni] += w[i1 + i__]; } else { w[ni] += ro * w[i1 + i__]; } } } if (ro == 1.) { dadd_(n, &w[nd], &c__1, &x[1], &c__1); } else { daxpy_(n, &ro, &w[nd], &c__1, &x[1], &c__1); } i1 = nd - 1; } if (icicla != 0 || id == 1 || id == 11 || id == 3) { if (il == -icol3) { iicol = 1; } else { iicol = 0; } s = r__[m2 * r_dim1 + 1]; nm1 = nm - 1; *m = m1; if (icol3 < 0) { ire[-icol3] = -1; } else { ire[icol3] = 1; } if (icol3 <= *n) { ip = icol3; anfm04_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &w[1], &w[nd], &jpvt[1], n, m, &ip, io); } else { ip = 0; if (icol3 <= nmd) { anfm04_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, & c__[(*mi + icol3 - *n) * c_dim1 + 1], &w[nd], & jpvt[1], n, m, &ip, io); } else { anfm04_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &a[ (icol3 - nmd) * a_dim1 + 1], &w[nd], &jpvt[1], n, m, &ip, io); } } if (icol3 <= nmd && iver != -1) { ++iver; } if (nm > 1) { if (iibeta == 1 && *ind == -2) { *ind = -1; } if (*ind > nm << 1 && *ind < nm * 3) { nf = nm * 3 - *ind; } else if (*ind > nm && *ind < nm << 1) { nf = (nm << 1) - *ind; } else if (*ind < -1 && *ind >= -nm) { nf = -(*ind) - 1; } else if (*ind == -1 || *ind == -nm - 1 || *ind == nm * 3 || *ind == nm << 1) { *ind = 0; i__1 = iver - iv; anfm03_(&r__[r_offset], ir, &r__[(*m + 2) * r_dim1 + 1], ir, &q[(*m + 1) * q_dim1 + 1], iq, &w[nd], &jpvt[ 1], n, &nm1, ind, &i__1, io); nf = 0; } else if (*ind >= 0) { nf = nm; } else { nf = -nm - *ind - 1; } if (nf != 0) { nmf = nm1 - nf; if (*ind > nm) { ii = nmf + i1; } else if (*ind < 0) { ii = nmf * (nmf + 1) / 2 + i1; } if (iibeta == 1) { --nf; } i__1 = iver - iv; anfm05_(&r__[r_offset], ir, &r__[(*m + 2) * r_dim1 + 1], ir, &q[(*m + 1) * q_dim1 + 1], iq, &w[nd], &w[nd + (nm1 << 1)], &jpvt[1], &s, &nm1, &nf, n, ind, & i__1, io); } if (*ind <= -n10) { iibeta = 1; *ind += n10; } else { iibeta = 0; } if (*ind == *n) { *ind = -1; if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, & c__0, &c__0, &c__0, &c__0, &c__0, &c__0, & c__0, &c__0, ind, imp, io, iter); } return 0; } nm = nm1; } } if (icicla == 0 && midf > 0) { i1 = 1; aux003_(&a[a_offset], ia, &x[1], &b[1], &q[q_offset], iq, &r__[( r_dim1 << 1) + 1], ir, &w[nd1], &ire[nd1], &ipvt[1], &nmd, mif, mdf, &midf, n, m, &i1, io); if (i1 == 0) { info = 0; } } if (info == 1 && id != 2) { if (jpvt[nm] != nm || *ind < 0 && *ind != -(*n) && *ind != *n * -2 + 1 || *ind > *n) { info = 0; } } if (id == 11) { *iw = nd + *m; w[*iw] = opvf03_(&r__[r_offset], ir, &a[a_offset], ia, &p[1], &b[ 1], &x[1], &w[1], alfa, &nd, n, mif, mdf); *ind = -3; if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, n, iw, &c__0, & c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter); } return 0; } if (*m == *n) { minimo = 1; id = 2; nm = 0; } else { minimo = 0; } ++(*iter); if (*iter <= itemax) { goto L2000; } } *ind = 1; if (*imp >= 7) { dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &il, &ides, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter); } } doublereal opvf03_(r__, ir, a, ia, p, b, x, w, alfa, nd, n, mif, mdf) doublereal *r__; integer *ir; doublereal *a; integer *ia; doublereal *p, *b, *x, *w, *alfa; integer *nd, *n, *mif, *mdf; { integer r_dim1, r_offset, a_dim1, a_offset, i__1, i__2; doublereal ret_val, d__1; extern doublereal ddot_(); static integer i__; extern int dscal_(); static integer i1; static doublereal s1; static integer ii, ni; extern int dadd_(); r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; a_dim1 = *ia; a_offset = a_dim1 + 1; a -= a_offset; --p; --b; --x; --w; ni = *nd + *n - 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__ + 1; ii = ni + i__; w[ii] = ddot_(&i__, &r__[i__ + r_dim1], ir, &x[1], &c__1); if (i__ < *n) { i__2 = *n - i__; w[ii] += ddot_(&i__2, &r__[i1 + i__ * r_dim1], &c__1, &x[i1], & c__1); } } s1 = .5; dscal_(n, &s1, &w[ni + 1], &c__1); dadd_(n, &p[1], &c__1, &w[ni + 1], &c__1); ret_val = ddot_(n, &x[1], &c__1, &w[ni + 1], &c__1); if (*alfa != 1.) { ret_val *= *alfa; } i__1 = *mif; for (i__ = 1; i__ <= i__1; ++i__) { ret_val += (d__1 = ddot_(n, &a[i__ * a_dim1 + 1], &c__1, &x[1], &c__1) - b[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } i__1 = *mif + *mdf; for (i__ = *mif + 1; i__ <= i__1; ++i__) { s1 = ddot_(n, &a[i__ * a_dim1 + 1], &c__1, &x[1], &c__1) - b[i__]; if (s1 > 0.) { ret_val += s1; } } return ret_val; } int pasr03_(a, ia, b, ci, cs, x, ro, w, ire, ipvt, ira, n, md, mif, mdf, m, id, io) doublereal *a; integer *ia; doublereal *b, *ci, *cs, *x, *ro, *w; integer *ire, *ipvt, *ira, *n, *md, *mif, *mdf, *m, *id, *io; { integer a_dim1, a_offset, i__1, i__2; doublereal d__1; double pow_dd(), sqrt(); extern doublereal ddot_(), dnrm0_(); static integer i__, j, k, l; static doublereal s, delta; static integer i1, i2, k1, j1; static doublereal s0, r1, r2, r3, s1; static integer nd, ii; static doublereal sd; extern doublereal dlamch_(); static integer ip, ni; static doublereal gigant; static integer id1, nd0, nd1, ip3; static doublereal ro1; static integer idi, ndf, nmd, iip; static doublereal eps; static integer iad0, icd0; static doublereal gig1; static integer ind1; a_dim1 = *ia; a_offset = a_dim1 + 1; a -= a_offset; --b; --ci; --cs; --x; --w; --ire; --ipvt; nmd = *n + *md; nd1 = nmd + 1; ndf = nmd + *mif; nd0 = ndf + *mdf; nd = nd0 + 1; icd0 = nd0 + *n; iad0 = icd0 + *md; d__1 = dlamch_("p", 1L); eps = pow_dd(&d__1, &c_b5779); gigant = dlamch_("o", 1L); gig1 = sqrt(gigant); ind1 = 0; if (*id >= 100) { ind1 = 2; *id += -100; } else if (*id >= 10) { ind1 = 1; *id += -10; } idi = *id; if (*id != 1) { sd = dnrm0_(n, &w[nd], &c__1) + 1; delta = 1e8; } else { s0 = *ro; } r1 = 0.; r2 = gigant; k = 0; if (*ira > 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ii = nd0 + i__; j = 0; if (*ira > 1) { if (cs[i__] <= gig1 && (ire[i__] == 0 && w[ii] > eps)) { s = (cs[i__] - x[i__]) / w[ii]; if (s < r2 && s > r1) { r2 = s; ip = i__; } j = 1; } } if (j == 0 && *ira != 2) { if (ci[i__] >= -gig1 && (ire[i__] == 0 && w[ii] < -eps)) { s = (ci[i__] - x[i__]) / w[ii]; if (s < r2 && s > r1) { ip = -i__; r2 = s; } } } } } i__1 = *md; for (i__ = 1; i__ <= i__1; ++i__) { ni = *n + i__; i2 = icd0 + i__; if (ire[ni] == 0) { if (w[i2] > eps) { s = -w[ni] / w[i2]; if (s <= r2 && s > r1) { r2 = s; ip = ni; } } } } if (r2 == gigant && *id == 0) { *id = -1; return 0; } r3 = r2; *ro = r2; i__1 = *mif; for (i__ = 1; i__ <= i__1; ++i__) { k1 = k + 1; ni = nmd + i__; ii = iad0 + i__; if ((i__2 = ire[ni], (( i__2 ) >= 0 ? ( i__2 ) : -( i__2 )) ) == 2) { s = w[ii]; } if (ire[ni] == 2 && s < -eps || ire[ni] == -2 && s > eps) { s1 = -w[ni] / s; if (s1 <= r2 && s1 > r1) { if (r3 == gigant && *id == 2) { w[nmd + k1] = s1; k = k1; ipvt[k] = ni; if (s1 < *ro) { *ro = s1; ip = ni; } } else { r2 = s1; ip3 = ni; } } } } i__1 = *mdf; for (i__ = 1; i__ <= i__1; ++i__) { k1 = k + 1; ni = ndf + i__; if (ire[ni] != 1) { s = w[iad0 + *mif + i__]; } if (ire[ni] == 2 && s < -eps || ire[ni] == 0 && s > eps) { s1 = -w[ni] / s; if (s1 <= r2 && s1 > r1) { if (r3 == gigant && *id == 2) { w[nmd + k1] = s1; k = k1; ipvt[k] = ni; if (s1 < *ro) { *ro = s1; ip = ni; } } else { r2 = s1; ip3 = ni; } } } } if (r3 == gigant && *id == 2) { s = ddot_(n, &w[1], &c__1, &w[nd], &c__1); if (k > 0) { id1 = iad0 - nmd; ro1 = 0.; if (s < -eps && ro1 < r2) { L5010: l = 0; r1 = ro1; ro1 = r2; i__1 = k; for (i__ = 1; i__ <= i__1; ++i__) { ii = nmd + i__; if (w[ii] <= ro1 && w[ii] > r1) { if (w[ii] < ro1) { l = 0; } ro1 = w[ii]; w[ii] = w[nd1 + l]; w[nd1 + l] = ro1; ++l; j = ipvt[i__]; ipvt[i__] = ipvt[l]; ipvt[l] = j; } } i__1 = l; for (i__ = 1; i__ <= i__1; ++i__) { j = ipvt[i__]; ii = i__ - 1; i1 = nmd + i__; j1 = j - nmd; if (j <= ndf) { if (ire[j] == 2) { s -= w[j + id1] * 2; } else if (ire[j] == -2) { s += w[j + id1] * 2; } } else { if (ire[j] == 0) { s += w[j + id1]; } else if (ire[j] == 2) { s -= w[j + id1]; } } } if (s >= -eps && ind1 == 1) { iip = ipvt[*m + 1] - nmd; s1 = ddot_(n, &w[nd], &c__1, &a[iip * a_dim1 + 1], &c__1); if (iip > ndf || s1 > eps) { s += s1; } ind1 = 11; } if (s < -eps && ro1 < r2) { goto L5010; } } } if (s < -eps) { *id = -1; return 0; } else { if (ind1 == 2) { *id = 0; return 0; } else { ipvt[1] = ip; *id = 1; } } } else { if (r2 < r3) { ip = ip3; } if (*id == 1) { s = (( r2 ) <= ( s0 ) ? ( r2 ) : ( s0 )) ; if (s == s0) { *id = 2; if (r2 == s0) { *id = 3; ipvt[1] = ip; } } else { ipvt[1] = ip; } *ro = s; } else { if (ind1 == 2) { *id = 0; return 0; } *ro = r2; *id = 1; ipvt[1] = ip; } } if (idi != 1) { s = *ro * sd; if (s > delta) { *id += 10; } } } int plcbas_(h__, p, c__, d__, ci, cs, ira, mi, md, x, f, w, iv, lagr, imp, io, n, modo, info) doublereal *h__, *p, *c__, *d__, *ci, *cs; integer *ira, *mi, *md; doublereal *x, *f, *w; integer *iv; doublereal *lagr; integer *imp, *io, *n, *modo, *info; { integer h_dim1, h_offset, c_dim1, c_offset, i__1, i__2; integer s_wsfe(), e_wsfe(); static doublereal alfa; static integer nmid, iter, nmul, modo1; static doublereal b; static integer i__, j, k, m; extern int dcopy_(), optr03_(); static integer n1, nipvt, njpvt, nl, iw, nw, mi1, mdf, mid, ind, mif, nmd; static cilist io___2949 = { 0, 0, 0, "(/10X,'START OF PLCBAS ')", 0 }; --p; --d__; --ci; --cs; --x; --w; --iv; --lagr; c_dim1 = *n; c_offset = c_dim1 + 1; c__ -= c_offset; h_dim1 = *n; h_offset = h_dim1 + 1; h__ -= h_offset; if (*imp > 6) { io___2949.ciunit = *io; s_wsfe(&io___2949); e_wsfe(); } iw = 1; alfa = 1.; mif = 0; mdf = 0; n1 = *n + 1; k = n1; mid = *mi + *md; nmd = *n + *md; nmid = *n + mid; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { --k; j = *n * (i__ - 1) + i__; dcopy_(&k, &h__[i__ + i__ * h_dim1], &c__1, &w[j], &c__1); } nipvt = nmd + 1; njpvt = nipvt + nmid + 1; nw = *n * n1 + 1; modo1 = *modo; if (*modo == 1) { *modo = 6; } if (*modo == 2) { *modo = 1; } if (*modo == 3) { *modo = 2; } optr03_(&w[1], &c__1, &c__[c_offset], n, &h__[h_offset], n, &w[1], n, &p[ 1], &b, &d__[1], &ci[1], &cs[1], &x[1], &w[nw], &iw, &iv[1], &iv[ nipvt], &iv[njpvt], &alfa, ira, n, &m, mi, &mi1, md, &mif, &mdf, modo, &ind, imp, io, &iter); *modo = modo1; *info = ind; k = n1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { --k; j = *n * (i__ - 1) + i__; dcopy_(&k, &w[j], &c__1, &h__[i__ + i__ * h_dim1], &c__1); } i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { h__[i__ + j * h_dim1] = h__[j + i__ * h_dim1]; } } if (ind != 0) { return 0; } if (ind == 0) { *f = w[nw + iw - 1]; nmul = nmd + nw; if (*ira > 0) { nl = *n; } else { nl = 0; } i__1 = nl + mid; for (i__ = 1; i__ <= i__1; ++i__) { lagr[i__] = 0.; } k = nipvt; i__1 = mi1; for (i__ = 1; i__ <= i__1; ++i__) { j = iv[k] + nl; lagr[j] = w[nmul]; ++nmul; ++k; } i__1 = m; for (i__ = mi1 + 1; i__ <= i__1; ++i__) { j = iv[k]; if (j < 0) { lagr[-j] = -w[nmul]; } else if (j <= *n) { lagr[j] = w[nmul]; } else { if (*ira == 0) { j -= *n; } lagr[j + *mi] = w[nmul]; } ++nmul; ++k; } } } int proj_(n, binf, bsup, x) integer *n; doublereal *binf, *bsup, *x; { integer i__1; doublereal d__1, d__2, d__3, d__4; static integer i__; --x; --bsup; --binf; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__3 = x[i__], d__4 = bsup[i__]; d__1 = binf[i__], d__2 = (( d__3 ) <= ( d__4 ) ? ( d__3 ) : ( d__4 )) ; x[i__] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } return 0; } int qform_(m, n, q, ldq, wa) integer *m, *n; doublereal *q; integer *ldq; doublereal *wa; { static doublereal one = 1.; static doublereal zero = 0.; integer q_dim1, q_offset, i__1, i__2, i__3; static doublereal temp; static integer i__, j, k, l, minmn, jm1, np1; static doublereal sum; --wa; q_dim1 = *ldq; q_offset = q_dim1 + 1; q -= q_offset; minmn = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; if (minmn < 2) { goto L30; } i__1 = minmn; for (j = 2; j <= i__1; ++j) { jm1 = j - 1; i__2 = jm1; for (i__ = 1; i__ <= i__2; ++i__) { q[i__ + j * q_dim1] = zero; } } L30: np1 = *n + 1; if (*m < np1) { goto L60; } i__1 = *m; for (j = np1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { q[i__ + j * q_dim1] = zero; } q[j + j * q_dim1] = one; } L60: i__1 = minmn; for (l = 1; l <= i__1; ++l) { k = minmn - l + 1; i__2 = *m; for (i__ = k; i__ <= i__2; ++i__) { wa[i__] = q[i__ + k * q_dim1]; q[i__ + k * q_dim1] = zero; } q[k + k * q_dim1] = one; if (wa[k] == zero) { goto L110; } i__2 = *m; for (j = k; j <= i__2; ++j) { sum = zero; i__3 = *m; for (i__ = k; i__ <= i__3; ++i__) { sum += q[i__ + j * q_dim1] * wa[i__]; } temp = sum / wa[k]; i__3 = *m; for (i__ = k; i__ <= i__3; ++i__) { q[i__ + j * q_dim1] -= temp * wa[i__]; } } L110: ; } return 0; } int qnbd_(indqn, simul, n, x, f, g, imp, io, zero, napmax, itmax, epsf, epsg, epsx, df0, binf, bsup, nfac, trav, ntrav, itrav, nitrav, izs, rzs, dzs) integer *indqn; int (*simul) (); integer *n; doublereal *x, *f, *g; integer *imp, *io; doublereal *zero; integer *napmax, *itmax; doublereal *epsf, *epsg, *epsx, *df0, *binf, *bsup; integer *nfac; doublereal *trav; integer *ntrav, *itrav, *nitrav, *izs; real *rzs; doublereal *dzs; { static char fmt_1010[] = "(\002 *********** qnbd ****************\002)"; static char fmt_110[] = "(\002 qnbd : ntrav=\002,i8,\002 devrait valoir \002,i8)"; static char fmt_111[] = "(\002 qnbd : nitrav=\002,i8,\002devrait valoir\002,i8)"; integer s_wsfe(), e_wsfe(), do_fio(); static integer iact, izag, irel, ieps1; extern int zqnbd_(); static integer n1, n2, n3, n4, n5, ig, in; static doublereal epsrel; static integer ni1, ni2; static cilist io___2984 = { 0, 0, 0, fmt_1010, 0 }; static cilist io___2997 = { 0, 0, 0, fmt_110, 0 }; static cilist io___3000 = { 0, 0, 0, fmt_111, 0 }; --bsup; --binf; --epsx; --g; --x; --trav; --itrav; --izs; --rzs; --dzs; if (*imp >= 1) { io___2984.ciunit = *io; s_wsfe(&io___2984); e_wsfe(); } ig = 0; in = 0; irel = 1; epsrel = .5; izag = 0; iact = 1; ieps1 = 0; n1 = *n * (*n + 1) / 2 + 1; n2 = n1 + *n; n3 = n2 + *n; n4 = n3 + *n; n5 = n4 + *n - 1; if (*ntrav < n5) { if (*imp > 0) { io___2997.ciunit = *io; s_wsfe(&io___2997); do_fio(&c__1, (char *)&(*ntrav), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n5, (ftnlen)sizeof(integer)); e_wsfe(); } *indqn = -11; return 0; } ni1 = *n + 1; if (*nitrav < *n << 1) { ni2 = *n << 1; if (*imp > 0) { io___3000.ciunit = *io; s_wsfe(&io___3000); do_fio(&c__1, (char *)&(*nitrav), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ni2, (ftnlen)sizeof(integer)); e_wsfe(); } *indqn = -12; return 0; } zqnbd_(indqn, simul, &trav[1], n, &binf[1], &bsup[1], &x[1], f, &g[1], zero, napmax, itmax, &itrav[1], &itrav[ni1], nfac, imp, io, &epsx[ 1], epsf, epsg, &trav[n1], &trav[n2], &trav[n3], &trav[n4], df0, & ig, &in, &irel, &izag, &iact, &epsrel, &ieps1, &izs[1], &rzs[1], & dzs[1]); return 0; } int qrfac_(m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm, wa) integer *m, *n; doublereal *a; integer *lda; logical *pivot; integer *ipvt, *lipvt; doublereal *rdiag, *acnorm, *wa; { static doublereal one = 1.; static doublereal p05 = .05; static doublereal zero = 0.; integer a_dim1, a_offset, i__1, i__2, i__3; doublereal d__1, d__2, d__3; double sqrt(); static integer kmax; static doublereal temp; static integer i__, j, k, minmn; extern doublereal enorm_(), dlamch_(); static doublereal epsmch, ajnorm; static integer jp1; static doublereal sum; --wa; --acnorm; --rdiag; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --ipvt; epsmch = dlamch_("p", 1L); i__1 = *n; for (j = 1; j <= i__1; ++j) { acnorm[j] = enorm_(m, &a[j * a_dim1 + 1]); rdiag[j] = acnorm[j]; wa[j] = rdiag[j]; if (*pivot) { ipvt[j] = j; } } minmn = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; i__1 = minmn; for (j = 1; j <= i__1; ++j) { if (! (*pivot)) { goto L40; } kmax = j; i__2 = *n; for (k = j; k <= i__2; ++k) { if (rdiag[k] > rdiag[kmax]) { kmax = k; } } if (kmax == j) { goto L40; } i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = a[i__ + j * a_dim1]; a[i__ + j * a_dim1] = a[i__ + kmax * a_dim1]; a[i__ + kmax * a_dim1] = temp; } rdiag[kmax] = rdiag[j]; wa[kmax] = wa[j]; k = ipvt[j]; ipvt[j] = ipvt[kmax]; ipvt[kmax] = k; L40: i__2 = *m - j + 1; ajnorm = enorm_(&i__2, &a[j + j * a_dim1]); if (ajnorm == zero) { goto L100; } if (a[j + j * a_dim1] < zero) { ajnorm = -ajnorm; } i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] /= ajnorm; } a[j + j * a_dim1] += one; jp1 = j + 1; if (*n < jp1) { goto L100; } i__2 = *n; for (k = jp1; k <= i__2; ++k) { sum = zero; i__3 = *m; for (i__ = j; i__ <= i__3; ++i__) { sum += a[i__ + j * a_dim1] * a[i__ + k * a_dim1]; } temp = sum / a[j + j * a_dim1]; i__3 = *m; for (i__ = j; i__ <= i__3; ++i__) { a[i__ + k * a_dim1] -= temp * a[i__ + j * a_dim1]; } if (! (*pivot) || rdiag[k] == zero) { goto L80; } temp = a[j + k * a_dim1] / rdiag[k]; d__3 = temp; d__1 = zero, d__2 = one - d__3 * d__3; rdiag[k] *= sqrt(((( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) )); d__1 = rdiag[k] / wa[k]; if (p05 * (d__1 * d__1) > epsmch) { goto L80; } i__3 = *m - j; rdiag[k] = enorm_(&i__3, &a[jp1 + k * a_dim1]); wa[k] = rdiag[k]; L80: ; } L100: rdiag[j] = -ajnorm; } return 0; } int r1mpyq_(m, n, a, lda, v, w) integer *m, *n; doublereal *a; integer *lda; doublereal *v, *w; { static doublereal one = 1.; integer a_dim1, a_offset, i__1, i__2; doublereal d__1, d__2; double sqrt(); static doublereal temp; static integer i__, j, nm1, nmj; static doublereal cos__, sin__; --w; --v; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; nm1 = *n - 1; if (nm1 < 1) { goto L50; } i__1 = nm1; for (nmj = 1; nmj <= i__1; ++nmj) { j = *n - nmj; if ((d__1 = v[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > one) { cos__ = one / v[j]; } if ((d__1 = v[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > one) { d__2 = cos__; sin__ = sqrt(one - d__2 * d__2); } if ((d__1 = v[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= one) { sin__ = v[j]; } if ((d__1 = v[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= one) { d__2 = sin__; cos__ = sqrt(one - d__2 * d__2); } i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = cos__ * a[i__ + j * a_dim1] - sin__ * a[i__ + *n * a_dim1]; a[i__ + *n * a_dim1] = sin__ * a[i__ + j * a_dim1] + cos__ * a[ i__ + *n * a_dim1]; a[i__ + j * a_dim1] = temp; } } i__1 = nm1; for (j = 1; j <= i__1; ++j) { if ((d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > one) { cos__ = one / w[j]; } if ((d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > one) { d__2 = cos__; sin__ = sqrt(one - d__2 * d__2); } if ((d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= one) { sin__ = w[j]; } if ((d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= one) { d__2 = sin__; cos__ = sqrt(one - d__2 * d__2); } i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { temp = cos__ * a[i__ + j * a_dim1] + sin__ * a[i__ + *n * a_dim1]; a[i__ + *n * a_dim1] = -sin__ * a[i__ + j * a_dim1] + cos__ * a[ i__ + *n * a_dim1]; a[i__ + j * a_dim1] = temp; } } L50: return 0; } int r1updt_(m, n, s, ls, u, v, w, sing) integer *m, *n; doublereal *s; integer *ls; doublereal *u, *v, *w; logical *sing; { static doublereal one = 1.; static doublereal p5 = .5; static doublereal p25 = .25; static doublereal zero = 0.; integer i__1, i__2; doublereal d__1, d__2; double sqrt(); static doublereal temp; static integer i__, j, l; static doublereal giant, cotan; static integer jj; extern doublereal dlamch_(); static integer nm1; static doublereal tan__; static integer nmj; static doublereal cos__, sin__, tau; --w; --u; --v; --s; giant = dlamch_("o", 1L); jj = *n * ((*m << 1) - *n + 1) / 2 - (*m - *n); l = jj; i__1 = *m; for (i__ = *n; i__ <= i__1; ++i__) { w[i__] = s[l]; ++l; } nm1 = *n - 1; if (nm1 < 1) { goto L70; } i__1 = nm1; for (nmj = 1; nmj <= i__1; ++nmj) { j = *n - nmj; jj -= *m - j + 1; w[j] = zero; if (v[j] == zero) { goto L50; } if ((d__1 = v[*n], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= (d__2 = v[j], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) { goto L20; } cotan = v[*n] / v[j]; d__1 = cotan; sin__ = p5 / sqrt(p25 + p25 * (d__1 * d__1)); cos__ = sin__ * cotan; tau = one; if ((( cos__ ) >= 0 ? ( cos__ ) : -( cos__ )) * giant > one) { tau = one / cos__; } goto L30; L20: tan__ = v[j] / v[*n]; d__1 = tan__; cos__ = p5 / sqrt(p25 + p25 * (d__1 * d__1)); sin__ = cos__ * tan__; tau = sin__; L30: v[*n] = sin__ * v[j] + cos__ * v[*n]; v[j] = tau; l = jj; i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { temp = cos__ * s[l] - sin__ * w[i__]; w[i__] = sin__ * s[l] + cos__ * w[i__]; s[l] = temp; ++l; } L50: ; } L70: i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { w[i__] += v[*n] * u[i__]; } *sing = (0) ; if (nm1 < 1) { goto L140; } i__1 = nm1; for (j = 1; j <= i__1; ++j) { if (w[j] == zero) { goto L120; } if ((d__1 = s[jj], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= (d__2 = w[j], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) { goto L90; } cotan = s[jj] / w[j]; d__1 = cotan; sin__ = p5 / sqrt(p25 + p25 * (d__1 * d__1)); cos__ = sin__ * cotan; tau = one; if ((( cos__ ) >= 0 ? ( cos__ ) : -( cos__ )) * giant > one) { tau = one / cos__; } goto L100; L90: tan__ = w[j] / s[jj]; d__1 = tan__; cos__ = p5 / sqrt(p25 + p25 * (d__1 * d__1)); sin__ = cos__ * tan__; tau = sin__; L100: l = jj; i__2 = *m; for (i__ = j; i__ <= i__2; ++i__) { temp = cos__ * s[l] + sin__ * w[i__]; w[i__] = -sin__ * s[l] + cos__ * w[i__]; s[l] = temp; ++l; } w[j] = tau; L120: if (s[jj] == zero) { *sing = (1) ; } jj += *m - j + 1; } L140: l = jj; i__1 = *m; for (i__ = *n; i__ <= i__1; ++i__) { s[l] = w[i__]; ++l; } if (s[jj] == zero) { *sing = (1) ; } return 0; } doublereal rednor_(n, binf, bsup, x, epsx, g) integer *n; doublereal *binf, *bsup, *x, *epsx, *g; { integer i__1; doublereal ret_val, d__1; double sqrt(); static integer i__; static doublereal aa; --g; --epsx; --x; --bsup; --binf; ret_val = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { aa = g[i__]; if (x[i__] - binf[i__] <= epsx[i__]) { aa = (( 0. ) <= ( aa ) ? ( 0. ) : ( aa )) ; } if (bsup[i__] - x[i__] <= epsx[i__]) { aa = (( 0. ) >= ( aa ) ? ( 0. ) : ( aa )) ; } d__1 = aa; ret_val += d__1 * d__1; } ret_val = sqrt(ret_val); return ret_val; } int relvar_(ind, n, x, binf, bsup, x2, g, diag, imp, io, ibloc, izag, iter, nfac, irit) integer *ind, *n; doublereal *x, *binf, *bsup, *x2, *g, *diag; integer *imp, *io, *ibloc, *izag, *iter, *nfac, *irit; { static char fmt_322[] = "(\002 relvar1. valeur de eps1=\002,d15.7)"; static char fmt_336[] = "(\002 defactorisation de x(\002,i3,\002)=\002,d15.7)"; static char fmt_339[] = "(\002 on factorise l indice \002,i3)"; static char fmt_350[] = "(\002 relvar1 . nbre fact\002,i3,\002 nbre defact\002,i3,\002 nbre var factorisees\002,i3)"; integer i__1; doublereal d__1; integer s_wsfe(), do_fio(), e_wsfe(); static integer ifac; static doublereal frac; extern int proj_(); static integer izag1, idfac, i__, k; static doublereal d1, d2, dd, bi, bs, ep, eps1; static cilist io___3043 = { 0, 0, 0, fmt_322, 0 }; static cilist io___3054 = { 0, 0, 0, fmt_336, 0 }; static cilist io___3056 = { 0, 0, 0, fmt_339, 0 }; static cilist io___3057 = { 0, 0, 0, fmt_350, 0 }; --ibloc; --diag; --g; --x2; --bsup; --binf; --x; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x2[i__] = x[i__] - (d__1 = g[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * g[i__] / diag[i__]; } proj_(n, &binf[1], &bsup[1], &x2[1]); eps1 = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { eps1 += (d__1 = x2[i__] - x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } if (*imp > 2) { io___3043.ciunit = *io; s_wsfe(&io___3043); do_fio(&c__1, (char *)&eps1, (ftnlen)sizeof(doublereal)); e_wsfe(); } ifac = 0; idfac = 0; k = 0; frac = (float).10000000000000001; i__1 = *n; for (k = 1; k <= i__1; ++k) { bi = binf[k]; bs = bsup[k]; d1 = x[k] - bi; d2 = bs - x[k]; dd = (bs - bi) * frac; ep = (( eps1 ) <= ( dd ) ? ( eps1 ) : ( dd )) ; if (d1 > ep) { goto L324; } if (g[k] > (float)0.) { goto L330; } goto L335; L324: if (d2 > ep) { goto L335; } if (g[k] > (float)0.) { goto L335; } goto L330; L330: if (ibloc[k] > 0) { goto L340; } ibloc[k] = *iter; ++idfac; --(*nfac); *ind = 1; if (*imp >= 4) { io___3054.ciunit = *io; s_wsfe(&io___3054); do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&x[k], (ftnlen)sizeof(doublereal)); e_wsfe(); } goto L340; L335: if (*irit == 0) { goto L340; } if (ibloc[k] <= 0) { goto L340; } izag1 = *iter - ibloc[k]; if (*izag >= izag1) { goto L340; } ++ifac; ++(*nfac); ibloc[k] = -(*iter); if (*imp >= 4) { io___3056.ciunit = *io; s_wsfe(&io___3056); do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); e_wsfe(); } L340: ; } if (*imp >= 2 && (ifac > 0 || idfac > 0)) { io___3057.ciunit = *io; s_wsfe(&io___3057); do_fio(&c__1, (char *)&ifac, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&idfac, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nfac), (ftnlen)sizeof(integer)); e_wsfe(); } *ind = 1; if (ifac == 0 && idfac == 0) { *ind = 0; } return 0; } int rlbd_(indrl, n, simul, x, binf, bsup, f, hp, t, tmax, d__, gn, tproj, amd, amf, imp, io, zero, nap, napmax, xn, izs, rzs, dzs) integer *indrl, *n; int (*simul) (); doublereal *x, *binf, *bsup, *f, *hp, *t, *tmax, *d__, *gn, *tproj, *amd, * amf; integer *imp, *io; doublereal *zero; integer *nap, *napmax; doublereal *xn; integer *izs; real *rzs; doublereal *dzs; { static char fmt_14050[] = "(\002 rlbd tp=\002,e11.4,\002 tmax=\002,e11.4,\002 dh0/dt=\002,e11.4)"; static char fmt_15000[] = "(a3,\002 t=\002,e11.4,\002 h=\002,e11.4,\002 dh/dt=\002,e11.4,\002 dfh/dt=\002,e11.4,\002 dt\002,e8.1)"; static char fmt_15020[] = "(3x,\002 t=\002,e11.4,\002 h=\002,e11.4,\002 dh/dt=\002,e11.4,\002 dfh/dt=\002,e11.4,\002 dt\002,e8.1)"; static char fmt_16000[] = "(\002 rlbd : sortie du domaine : indic=\002,i2,\002 t=\002,e11.4)"; static char fmt_3330[] = "(\002toutes les variables sont saturees:tmaxp= \002,e11.4)"; integer i__1; doublereal d__1, d__2; int s_copy(); integer s_wsfe(), do_fio(), e_wsfe(); double sqrt(); static integer icoi, icop, icos, imax; static doublereal hptd, hptg; extern int proj_(); static doublereal epst, text, topt, hpta1, a, b, e; static integer i__, k; static doublereal p, r__; static integer indic; static doublereal difhp, a1, extra; static integer iproj; static doublereal f0, tmaxp, h1, ttmin; extern int satur_(); static doublereal extrp, t1, t2, ttsup, fa, f11, di, fn, ta, td, tg, cofder, fa1, ta1, hpa, hpd, ftd, hpg, ftg, div, hpn, eps, tmi, xni; static integer ico1; static doublereal eps1; static char var2[3]; static cilist io___3079 = { 0, 0, 0, fmt_14050, 0 }; static cilist io___3083 = { 0, 0, 0, fmt_16000, 0 }; static cilist io___3089 = { 0, 0, 0, fmt_3330, 0 }; static cilist io___3114 = { 0, 0, 0, fmt_15000, 0 }; static cilist io___3115 = { 0, 0, 0, fmt_15020, 0 }; --xn; --gn; --d__; --bsup; --binf; --x; --izs; --rzs; --dzs; *indrl = 1; eps1 = .9; eps = .1; epst = .1; extrp = 100.; extra = 10.; cofder = (float)100.; s_copy(var2, " ", 3L, 3L); ta1 = 0.; f0 = *f; fa1 = *f; hpta1 = *hp; imax = 0; hptg = *hp; ftg = *f; tg = 0.; td = 0.; icos = 0; icoi = 0; icop = 0; *tproj = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = d__[i__]) < 0.) { goto L4; } else if (d__1 == 0) { goto L7; } else { goto L5; } L4: t2 = (binf[i__] - x[i__]) / d__[i__]; goto L6; L5: t2 = (bsup[i__] - x[i__]) / d__[i__]; L6: if (t2 <= 0.) { goto L7; } if (*tproj == 0.) { *tproj = t2; } if (t2 > *tproj) { goto L7; } *tproj = t2; icop = i__; L7: ; } if (*imp >= 3) { io___3079.ciunit = *io; s_wsfe(&io___3079); do_fio(&c__1, (char *)&(*tproj), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*tmax), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*hp), (ftnlen)sizeof(doublereal)); e_wsfe(); } L200: if (*nap >= *napmax) { k = 3; goto L1000; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] = x[i__] + *t * d__[i__]; } proj_(n, &binf[1], &bsup[1], &xn[1]); if (icos > 0) { xn[icos] = bsup[icos]; } if (icoi > 0) { xn[icoi] = binf[icoi]; } indic = 4; (*simul)(&indic, n, &xn[1], &fn, &gn[1], &izs[1], &rzs[1], &dzs[1]); ++(*nap); if (indic < 0) { if (*imp >= 3) { io___3083.ciunit = *io; s_wsfe(&io___3083); do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*nap >= *napmax) { goto L1000; } *t = tg + (*t - tg) / 4.; *tmax = *t; imax = 1; icoi = 0; icos = 0; s_copy(var2, "dd ", 3L, 3L); goto L800; } if (indic == 0) { *indrl = 0; goto L1010; } hpg = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xn[i__] = x[i__] + *t * d__[i__]; } if (icoi > 0) { xn[icoi] = bsup[icoi]; } if (icos > 0) { xn[icos] = bsup[icos]; } proj_(n, &binf[1], &bsup[1], &xn[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xni = xn[i__]; if (binf[i__] < xni && xni < bsup[i__]) { hpg += d__[i__] * gn[i__]; } } hpd = hpg; if (icoi > 0) { hpg += d__[icoi] * gn[icoi]; } if (icos > 0) { hpg += d__[icos] * gn[icos]; } icoi = 0; icos = 0; if (hpd != 0. || hpg != 0.) { goto L360; } tmaxp = 0.; ico1 = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = d__[i__]) < 0.) { goto L310; } else if (d__1 == 0) { goto L350; } else { goto L320; } L310: t2 = (binf[i__] - x[i__]) / d__[i__]; goto L330; L320: t2 = (bsup[i__] - x[i__]) / d__[i__]; L330: if (t2 <= 0.) { goto L350; } if (tmaxp == 0.) { tmaxp = t2; } if (tmaxp > t2) { goto L350; } tmaxp = t2; ico1 = i__; L350: ; } if (*t < tmaxp) { if (fn <= *f + *amf * *hp * *t) { goto L1010; } *t /= 10.; s_copy(var2, "d ", 3L, 3L); goto L800; } icos = ico1; icoi = 0; if (d__[ico1] < 0.) { icoi = ico1; icos = 0; } if (*imp >= 3) { io___3089.ciunit = *io; s_wsfe(&io___3089); do_fio(&c__1, (char *)&tmaxp, (ftnlen)sizeof(doublereal)); e_wsfe(); } *t = tmaxp; if (fn < *f + *amf * *hp * tmaxp) { *indrl = 8; goto L1010; } hpg = d__[ico1] * gn[ico1]; if (fn < *f && hpg < 0.) { *indrl = 8; goto L1010; } L360: a = *f + *amf * *hp * *t; if (fn > a) { td = *t; t1 = *t - ta1; h1 = (fn - fa1) / t1; ftd = fn; hptd = hpg; ta = tg; hpn = hptd; hpa = hptg; fa = ftg; } else { if (hpd >= *amd * *hp) { goto L1010; } tg = *t; t1 = *t - ta1; h1 = (fn - fa1) / t1; ftg = fn; hptg = hpd; ta = td; hpn = hptg; hpa = hptd; fa = ftd; if (td == 0.) { goto L700; } a1 = (d__1 = hptd / *hp, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (a1 > cofder && ftd > *f && hptg > *hp * (float).99) { hpta1 = *hp; fa1 = *f; ta1 = 0.; goto L700; } } a1 = (d__1 = hpn / *hp, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (tg != 0. || fn <= *f || a1 <= cofder || hpn < 0.) { if (td <= *tproj) { goto L600; } goto L500; } ta1 = *t; fa1 = fn; div = *hp - hptd; text = *t / 10.; if ((( div ) >= 0 ? ( div ) : -( div )) > *zero) { text = *t * (*hp / div); } if (text > *tproj) { text = *t / 10.; } d__1 = text, d__2 = *t / (extrp * extra); text = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; d__1 = text, d__2 = *t * eps1; *t = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; ttsup = *t * 1.5; extrp = (float)10.; if (*tproj > ta1) { s_copy(var2, "id ", 3L, 3L); goto L800; } ttmin = *t * .7; tmi = *t; topt = 0.; iproj = 0; satur_(n, &x[1], &binf[1], &bsup[1], &d__[1], &ttmin, &ttsup, &topt, &tg, &td, &tmi, &icoi, &icos, &iproj); s_copy(var2, "id ", 3L, 3L); if (topt != 0.) { *t = topt; s_copy(var2, "ids", 3L, 3L); } goto L800; L500: if (td <= *tproj) { goto L600; } topt = 0.; iproj = 1; ta1 = *t; fa1 = fn; ttmin = tg + eps * (td - tg); ttsup = td - eps * (td - tg); tmi = (td + tg) / 2.; satur_(n, &x[1], &binf[1], &bsup[1], &d__[1], &ttmin, &ttsup, &topt, &tg, &td, &tmi, &icoi, &icos, &iproj); if (topt == 0.) { goto L600; } *t = topt; s_copy(var2, "s ", 3L, 3L); if (*t == ttsup || *t == ttmin) { s_copy(var2, "sb ", 3L, 3L); } goto L800; L600: if (td - tg < *zero * 100.) { k = 4; goto L1000; } b = 1.; p = hpn + hpa - (fn - fa) * 3. / (*t - ta); di = p * p - hpn * hpa; if (di < 0.) { goto L690; } if (*t - ta < 0.) { b = -1.; } div = hpn + p + b * sqrt(di); if ((( div ) >= 0 ? ( div ) : -( div )) <= *zero) { goto L690; } r__ = hpn / div; topt = *t - r__ * (*t - ta); if (topt < tg || topt > td) { goto L690; } e = epst * (td - tg); s_copy(var2, "ic ", 3L, 3L); if (topt > td - e) { topt = td - e; s_copy(var2, "icb", 3L, 3L); } if (topt < tg + e) { topt = tg + e; s_copy(var2, "icb", 3L, 3L); } ta1 = *t; fa1 = fn; *t = topt; goto L800; L690: ta1 = *t; fa1 = fn; *t = (tg + td) * .5; s_copy(var2, "d ", 3L, 3L); goto L800; L700: if (imax >= 1) { k = 2; goto L1000; } text = *t * 10.; difhp = hptg - hpta1; if (difhp > *zero) { text = (*amd * *hp / 3. - hptg) * ((tg - ta1) / difhp) + tg; if (td != 0. && text >= td) { goto L600; } d__1 = text, d__2 = extra * extrp * *t; text = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; d__1 = text, d__2 = *t * 2.5; text = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; } else { text = extra * extrp * *t; } ta1 = *t; fa1 = fn; hpta1 = hpn; extrp = (float)10.; if (text >= *tmax / 2.) { text = *tmax; imax = 1; } if (*t < *tproj && text > *tproj) { d__1 = *tproj, d__2 = *t * 2.5; *t = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; icoi = 0; icos = icop; if (d__[icop] < 0.) { icoi = icop; icos = 0; } s_copy(var2, "es ", 3L, 3L); goto L800; } d__1 = text * 1.5; ttsup = (( d__1 ) <= ( *tmax ) ? ( d__1 ) : ( *tmax )) ; if (ttsup < *tproj) { goto L785; } ttmin = *t * 2; iproj = 0; tmi = text; topt = 0.; satur_(n, &x[1], &binf[1], &bsup[1], &d__[1], &ttmin, &ttsup, &topt, &tg, &td, &tmi, &icoi, &icos, &iproj); if (topt > 0.) { *t = topt; s_copy(var2, "es ", 3L, 3L); goto L800; } L785: *t = text; s_copy(var2, "e ", 3L, 3L); L800: f11 = fn - *f; if (*imp >= 3 && indic > 0) { io___3114.ciunit = *io; s_wsfe(&io___3114); do_fio(&c__1, var2, 3L); do_fio(&c__1, (char *)&ta1, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&f11, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&hpn, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&h1, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&t1, (ftnlen)sizeof(doublereal)); e_wsfe(); } if ((d__1 = ta1 - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= *zero * 100.) { goto L200; } k = 4; L1000: if (indic < 0) { *indrl = 13; if (tg == 0.) { *indrl = indic - 1000; } fn = ftg; hpn = hptg; *t = tg; goto L1010; } if (fn <= ftg) { *indrl = k; *t = tg; goto L1010; } if (tg == 0.) { *indrl = -k; goto L1010; } *indrl = k + 10; *t = tg; fn = ftg; hpn = hptg; L1010: *f = fn; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] += *t * d__[i__]; } proj_(n, &binf[1], &bsup[1], &x[1]); if (icos > 0) { x[icos] = bsup[icos]; } if (icoi > 0) { x[icoi] = binf[icoi]; } if (*indrl < 0) { ++(*nap); indic = 4; (*simul)(&indic, n, &x[1], f, &gn[1], &izs[1], &rzs[1], &dzs[1]); } t1 = *t - ta1; if (t1 == 0.) { t1 = (float)1.; } h1 = (fn - fa1) / t1; *hp = hpd; f0 = *f - f0; if (*imp >= 3) { io___3115.ciunit = *io; s_wsfe(&io___3115); do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&f0, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&hpd, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&h1, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&t1, (ftnlen)sizeof(doublereal)); e_wsfe(); } return 0; } int satur_(n, x, binf, bsup, d__, ttmin, ttsup, topt, tg, td, tmi, icoi, icos, iproj) integer *n; doublereal *x, *binf, *bsup, *d__, *ttmin, *ttsup, *topt, *tg, *td, *tmi; integer *icoi, *icos, *iproj; { integer i__1; doublereal d__1; static doublereal e; static integer i__; static doublereal ep, tb; static integer inf; --d__; --bsup; --binf; --x; *icoi = 0; *icos = 0; ep = *tmi; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { inf = 0; if ((d__1 = d__[i__]) < 0.) { goto L61; } else if (d__1 == 0) { goto L70; } else { goto L62; } L61: tb = (binf[i__] - x[i__]) / d__[i__]; inf = 1; goto L63; L62: tb = (bsup[i__] - x[i__]) / d__[i__]; L63: if (tb > *ttsup || tb < *ttmin) { if (*iproj == 0 || tb < *tg || tb > *td) { goto L70; } tb = (( tb ) >= ( *ttmin ) ? ( tb ) : ( *ttmin )) ; tb = (( tb ) <= ( *ttsup ) ? ( tb ) : ( *ttsup )) ; inf = 2; } e = (d__1 = tb - *tmi, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (e >= ep) { goto L70; } *topt = tb; ep = e; *icoi = 0; *icos = 0; if (inf == 0) { *icos = i__; } if (inf == 1) { *icoi = i__; } L70: ; } return 0; } int shanph_(diag, n, nt, np, y, s, ys, scal, index, io, imp) doublereal *diag; integer *n, *nt, *np; doublereal *y, *s, *ys, *scal; integer *index, *io, *imp; { static char fmt_1203[] = "(\002 gcbd. facteur d echelle=\002,d15.7)"; integer y_dim1, y_offset, s_dim1, s_offset, i__1; doublereal d__1; integer s_wsfe(), do_fio(), e_wsfe(); static integer i__; static doublereal cof; static integer inp; static cilist io___3124 = { 0, 0, 0, fmt_1203, 0 }; --diag; --index; --ys; s_dim1 = *nt; s_offset = s_dim1 + 1; s -= s_offset; y_dim1 = *nt; y_offset = y_dim1 + 1; y -= y_offset; inp = index[*np]; cof = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = y[inp + i__ * y_dim1]; cof += d__1 * d__1 / diag[i__]; } cof /= ys[inp]; if (*imp > 3) { io___3124.ciunit = *io; s_wsfe(&io___3124); do_fio(&c__1, (char *)&cof, (ftnlen)sizeof(doublereal)); e_wsfe(); } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { diag[i__] = cof * diag[i__]; } *scal = (float)0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { *scal += diag[i__]; } *scal = *n / *scal; return 0; } int strang_(prosca, n, m, depl, jmin, jmax, precon, alpha, ybar, sbar, izs, rzs, dzs) int (*prosca) (); integer *n, *m; doublereal *depl; integer *jmin, *jmax; doublereal *precon, *alpha, *ybar, *sbar; integer *izs; real *rzs; doublereal *dzs; { integer ybar_dim1, ybar_offset, sbar_dim1, sbar_offset, i__1, i__2; static integer jfin, i__, j; static doublereal r__; static integer jp; static doublereal ps; --depl; sbar_dim1 = *n; sbar_offset = sbar_dim1 + 1; sbar -= sbar_offset; ybar_dim1 = *n; ybar_offset = ybar_dim1 + 1; ybar -= ybar_offset; --alpha; --izs; --rzs; --dzs; jfin = *jmax; if (jfin < *jmin) { jfin = *jmax + *m; } i__1 = *jmin; for (j = jfin; j >= i__1; --j) { jp = j; if (jp > *m) { jp -= *m; } (*prosca)(n, &depl[1], &sbar[jp * sbar_dim1 + 1], &ps, &izs[1], &rzs[ 1], &dzs[1]); alpha[jp] = ps; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { depl[i__] -= ps * ybar[i__ + jp * ybar_dim1]; } } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { depl[i__] *= *precon; } i__1 = jfin; for (j = *jmin; j <= i__1; ++j) { jp = j; if (jp > *m) { jp -= *m; } (*prosca)(n, &depl[1], &ybar[jp * ybar_dim1 + 1], &ps, &izs[1], &rzs[ 1], &dzs[1]); r__ = alpha[jp] - ps; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { depl[i__] += r__ * sbar[i__ + jp * sbar_dim1]; } } return 0; } int tol03_(q, iq, r__, ir, c__, ic, d__, a, ia, b, ci, cs, x, w, ipvt, n, m, mi, mi1, nmd, io) doublereal *q; integer *iq; doublereal *r__; integer *ir; doublereal *c__; integer *ic; doublereal *d__, *a; integer *ia; doublereal *b, *ci, *cs, *x, *w; integer *ipvt, *n, *m, *mi, *mi1, *nmd, *io; { integer q_dim1, q_offset, r_dim1, r_offset, c_dim1, c_offset, a_dim1, a_offset, i__1; doublereal d__1; double pow_dd(); extern doublereal ddot_(); static integer i__, j; static doublereal s; extern int anrs01_(), dmmul_(); static integer m1; static doublereal dj; extern doublereal dlamch_(); static integer ind; static doublereal eps; extern int dadd_(); q_dim1 = *iq; q_offset = q_dim1 + 1; q -= q_offset; r_dim1 = *ir; r_offset = r_dim1 + 1; r__ -= r_offset; c_dim1 = *ic; c_offset = c_dim1 + 1; c__ -= c_offset; --d__; a_dim1 = *ia; a_offset = a_dim1 + 1; a -= a_offset; --b; --ci; --cs; --x; --w; --ipvt; d__1 = dlamch_("p", 1L); eps = pow_dd(&d__1, &c_b5779); ind = 0; m1 = *m + 1; i__1 = *mi1; for (i__ = 1; i__ <= i__1; ++i__) { j = ipvt[i__]; dj = d__[j]; s = dj - ddot_(n, &c__[j * c_dim1 + 1], &c__1, &x[1], &c__1); w[i__] = s; if (ind == 0) { s = (( s ) >= 0 ? ( s ) : -( s )) / ((( dj ) >= 0 ? ( dj ) : -( dj )) + 1); if (s > eps) { ind = 1; } } } i__1 = *m; for (i__ = *mi1 + 1; i__ <= i__1; ++i__) { j = ipvt[i__]; if (j < 0) { j = -j; dj = ci[j]; s = x[j] - dj; } else if (j <= *n) { dj = cs[j]; s = dj - x[j]; } else if (j <= *nmd) { j = *mi + j - *n; dj = d__[j]; s = dj - ddot_(n, &c__[j * c_dim1 + 1], &c__1, &x[1], &c__1); } else { j -= *nmd; dj = b[j]; s = dj - ddot_(n, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); } w[i__] = s; if (ind == 0) { s = (( s ) >= 0 ? ( s ) : -( s )) / ((( dj ) >= 0 ? ( dj ) : -( dj )) + 1.); if (s > eps) { ind = 1; } } } if (ind == 0) { return 0; } anrs01_(&r__[r_offset], ir, m, &w[1], &w[1], &ind, io); dmmul_(&q[q_offset], iq, &w[1], m, &w[m1], n, n, m, &c__1); dadd_(n, &w[m1], &c__1, &x[1], &c__1); } int zgcbd_(simul, n, binf, bsup, x, f, g, zero, napmax, itmax, indgc, ibloc, nfac, imp, io, epsx, epsf, epsg, dir, df0, diag, x2, izs, rzs, dzs, y, s, z__, ys, zs, nt, index, wk1, wk2, alg, ialg, nomf, nomf_len) int (*simul) (); integer *n; doublereal *binf, *bsup, *x, *f, *g, *zero; integer *napmax, *itmax, *indgc, *ibloc, *nfac, *imp, *io; doublereal *epsx, *epsf, *epsg, *dir, *df0, *diag, *x2; integer *izs; real *rzs; doublereal *dzs, *y, *s, *z__, *ys, *zs; integer *nt, *index; doublereal *wk1, *wk2, *alg; integer *ialg; char *nomf; ftnlen nomf_len; { static char fmt_10000[] = "(\002 dans gcbd. algorithme utilise: \002)"; static char fmt_10001[] = "(\002 emploi correction de powell \002)" ; static char fmt_10002[] = "(\002 mise a jour de diag par la methode bfgs\002)"; static char fmt_10003[] = "(\002 mise a echelle de diag par methode de shanno-phua\002)"; static char fmt_10004[] = "(\002 mise a echelle de diag seulement a la 2e iter\002)"; static char fmt_10005[] = "(\002 memorisation pour choix iteration \002)"; static char fmt_10006[] = "(\002 memorisation par variable\002)"; static char fmt_10007[] = "(\002 relachememt de variables a toutes les iteration\002)"; static char fmt_10008[] = "(\002 relachement de vars si decroissance g_norme\002)"; static char fmt_10009[] = "(\002 relachement de vars si dec f % iter_init du cycle\002)"; static char fmt_10010[] = "(\002 relachement de vars si dec f % dec du cycle\002)"; static char fmt_10011[] = "(\002 choix de vars a relacher par bertsekas modifiee\002)"; static char fmt_10012[] = "(\002 choix de dir descente par methode de gradient\002)"; static char fmt_10013[] = "(\002 choix de dir descente par methode qn\002)"; static char fmt_10014[] = "(\002 choix de dir descente par qn sans memoire.nt depl\002)"; static char fmt_10015[] = "(\002 choix de dir descente par qn -mem,redem,sans acc.\002)"; static char fmt_10016[] = "(\002 choix de dir descente par qn -mem,redem,avec acc.\002)"; static char fmt_10017[] = "(\002 redem si relachement de vars\002)"; static char fmt_10018[] = "(\002 redem si dec f % dec iter_init du cycle\002)"; static char fmt_10019[] = "(\002 redem si dec f % dec totale du cycle.\002)"; static char fmt_10020[] = "(\002 redem si diminution du gradient des var libres d un\002,\002facteur\002,d11.4)"; static char fmt_123[] = "(\002 gcbd : retour avec indgc=\002,i8)"; static char fmt_1210[] = "(/\002 dans gcbd iter=\002,i3,\002 f=\002,d15.7)"; static char fmt_1270[] = "(\002 gcbd. emploi correction powell (y,s)=\002,d11.4)"; static char fmt_1280[] = "(\002 erreur relative correction powell =\002,d11.4)"; static char fmt_1000[] = "(\002 redemarrage. icycl=\002,i5)"; static char fmt_1712[] = "(\002 gcbd : restauration dir ; fp,zero\002,2d11.4)"; static char fmt_750[] = "(\002 retour mlibd indrl=\002,i6,\002 pas= \002,d11.4,\002 f= \002,d11.4)"; static char fmt_777[] = "(\002 i=\002,i2,\002 xgd \002,3f11.4)"; static char fmt_755[] = "(\002 gcbd max appels simul\002)"; static char fmt_1805[] = "(\002 gcbd. retour apres convergence sur x\002)" ; static char fmt_860[] = "(\002 gcbd. epsg,difg=\002,2d11.4,\002 epsf,diff=\002,2d11.4,\002 nap=\002,i3)"; static char fmt_1910[] = "(\002 arret impose par la recherche lineaire. cf notice rlbd\002,/,\002 indicateur de rlbd=\002,i6)"; static char fmt_950[] = "(\002 f,norme grad,nap,iter,indgc=\002,2e11.4,3i6)"; static char fmt_2001[] = "(1x,a6,2e11.4,2i5,f6.2,i5)"; integer y_dim1, y_offset, s_dim1, s_offset, z_dim1, z_offset, i__1; doublereal d__1, d__2; integer s_wsfe(), e_wsfe(), do_fio(); double sqrt(); static doublereal diff, difg, scal; static integer ired; extern int rlbd_(); static doublereal diri; static integer nred, izag; extern doublereal ddot_(); static integer napm; static doublereal teta; extern int majz_(); static integer iter, irit; extern int proj_(); static doublereal tmax, ceps0; static integer izag1, napm1; static doublereal teta1, znog0; static integer i__; extern int bfgsd_(); static doublereal t, condm, param; static integer icycl, napav, indrl; static doublereal tetaq; extern int dcopy_(); static doublereal epsxi, tproj; static integer indgc1; static doublereal dfred1, param1, dfrit1, aa; static integer lb, nb; static doublereal fn, difred; static integer np; static doublereal xi, sy, epsgcp; extern int shanph_(); static integer indsim; extern int majysa_(); static doublereal znglib, difrit; extern doublereal rednor_(); static doublereal zngred; extern int relvar_(); static integer iresul; static doublereal zngrit, ys1, amd, amf; extern int gcp_(); static integer ind; static doublereal dfp; static integer nap, ifp, irl, inp; static doublereal bss, zng, zrl; static integer imp1; static doublereal eps0, bss2; static cilist io___3138 = { 0, 0, 0, fmt_10000, 0 }; static cilist io___3139 = { 0, 0, 0, fmt_10001, 0 }; static cilist io___3140 = { 0, 0, 0, fmt_10002, 0 }; static cilist io___3141 = { 0, 0, 0, fmt_10003, 0 }; static cilist io___3142 = { 0, 0, 0, fmt_10004, 0 }; static cilist io___3143 = { 0, 0, 0, fmt_10005, 0 }; static cilist io___3144 = { 0, 0, 0, fmt_10006, 0 }; static cilist io___3145 = { 0, 0, 0, fmt_10007, 0 }; static cilist io___3146 = { 0, 0, 0, fmt_10008, 0 }; static cilist io___3147 = { 0, 0, 0, fmt_10009, 0 }; static cilist io___3148 = { 0, 0, 0, fmt_10010, 0 }; static cilist io___3149 = { 0, 0, 0, fmt_10011, 0 }; static cilist io___3150 = { 0, 0, 0, fmt_10012, 0 }; static cilist io___3151 = { 0, 0, 0, fmt_10013, 0 }; static cilist io___3152 = { 0, 0, 0, fmt_10014, 0 }; static cilist io___3153 = { 0, 0, 0, fmt_10015, 0 }; static cilist io___3154 = { 0, 0, 0, fmt_10016, 0 }; static cilist io___3155 = { 0, 0, 0, fmt_10017, 0 }; static cilist io___3156 = { 0, 0, 0, fmt_10018, 0 }; static cilist io___3157 = { 0, 0, 0, fmt_10019, 0 }; static cilist io___3158 = { 0, 0, 0, fmt_10020, 0 }; static cilist io___3167 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3186 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3188 = { 0, 0, 0, fmt_1210, 0 }; static cilist io___3194 = { 0, 0, 0, fmt_1270, 0 }; static cilist io___3198 = { 0, 0, 0, fmt_1280, 0 }; static cilist io___3208 = { 0, 0, 0, fmt_1000, 0 }; static cilist io___3215 = { 0, 0, 0, fmt_1712, 0 }; static cilist io___3224 = { 0, 0, 0, fmt_750, 0 }; static cilist io___3225 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3226 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3227 = { 0, 0, 0, fmt_777, 0 }; static cilist io___3228 = { 0, 0, 0, fmt_755, 0 }; static cilist io___3229 = { 0, 0, 0, fmt_1805, 0 }; static cilist io___3231 = { 0, 0, 0, fmt_860, 0 }; static cilist io___3233 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3234 = { 0, 0, 0, fmt_1910, 0 }; static cilist io___3235 = { 0, 0, 0, fmt_950, 0 }; static cilist io___3237 = { 0, 0, 0, fmt_2001, 0 }; --wk2; --wk1; --x2; --diag; --dir; --epsx; --ibloc; --g; --x; --bsup; --binf; --izs; --rzs; --dzs; --index; --zs; --ys; z_dim1 = *nt; z_offset = z_dim1 + 1; z__ -= z_offset; s_dim1 = *nt; s_offset = s_dim1 + 1; s -= s_offset; y_dim1 = *nt; y_offset = y_dim1 + 1; y -= y_offset; --alg; --ialg; if (*imp >= 4) { io___3138.ciunit = *io; s_wsfe(&io___3138); e_wsfe(); if (ialg[1] == 1) { io___3139.ciunit = *io; s_wsfe(&io___3139); e_wsfe(); } if (ialg[2] == 1) { io___3140.ciunit = *io; s_wsfe(&io___3140); e_wsfe(); } if (ialg[3] == 1) { io___3141.ciunit = *io; s_wsfe(&io___3141); e_wsfe(); } if (ialg[3] == 2) { io___3142.ciunit = *io; s_wsfe(&io___3142); e_wsfe(); } if (ialg[4] == 1) { io___3143.ciunit = *io; s_wsfe(&io___3143); e_wsfe(); } if (ialg[5] == 1) { io___3144.ciunit = *io; s_wsfe(&io___3144); e_wsfe(); } if (ialg[6] == 1) { io___3145.ciunit = *io; s_wsfe(&io___3145); e_wsfe(); } if (ialg[6] == 2) { io___3146.ciunit = *io; s_wsfe(&io___3146); e_wsfe(); } if (ialg[6] == 10) { io___3147.ciunit = *io; s_wsfe(&io___3147); e_wsfe(); } if (ialg[6] == 11) { io___3148.ciunit = *io; s_wsfe(&io___3148); e_wsfe(); } if (ialg[7] == 1) { io___3149.ciunit = *io; s_wsfe(&io___3149); e_wsfe(); } if (ialg[8] == 1) { io___3150.ciunit = *io; s_wsfe(&io___3150); e_wsfe(); } if (ialg[8] == 2) { io___3151.ciunit = *io; s_wsfe(&io___3151); e_wsfe(); } if (ialg[8] == 3) { io___3152.ciunit = *io; s_wsfe(&io___3152); e_wsfe(); } if (ialg[8] == 4) { io___3153.ciunit = *io; s_wsfe(&io___3153); e_wsfe(); } if (ialg[8] == 5) { io___3154.ciunit = *io; s_wsfe(&io___3154); e_wsfe(); } if (ialg[9] == 2) { io___3155.ciunit = *io; s_wsfe(&io___3155); e_wsfe(); } if (ialg[9] == 10) { io___3156.ciunit = *io; s_wsfe(&io___3156); e_wsfe(); } if (ialg[9] == 11) { io___3157.ciunit = *io; s_wsfe(&io___3157); e_wsfe(); } if (ialg[9] == 12) { io___3158.ciunit = *io; s_wsfe(&io___3158); do_fio(&c__1, (char *)&alg[9], (ftnlen)sizeof(doublereal)); e_wsfe(); } } epsgcp = 1e-5; indsim = 4; indrl = 1; irl = 0; irl = 0; nred = 1; icycl = 1; iresul = 1; proj_(n, &binf[1], &bsup[1], &x[1]); indsim = 4; (*simul)(&indsim, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]); ++nap; if (indsim > 0) { goto L99; } *indgc = -1; if (indsim == 0) { *indgc = 0; } if (*imp > 0) { io___3167.ciunit = *io; s_wsfe(&io___3167); do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer)); e_wsfe(); } goto L900; L99: ceps0 = 20.; eps0 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { eps0 += epsx[i__]; } eps0 = ceps0 * eps0 / *n; znog0 = rednor_(n, &binf[1], &bsup[1], &x[1], &epsx[1], &g[1]); zng = znog0; zngrit = znog0; zngred = znog0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { ibloc[i__] = 0; } izag = 3; izag1 = izag; nap = 0; iter = 0; scal = 1.; *nfac = *n; np = 0; lb = 1; nb = 2; if (ialg[8] == 3) { nb = 1; } i__1 = *nt; for (i__ = 1; i__ <= i__1; ++i__) { index[i__] = i__; } tetaq = alg[9]; condm = alg[2]; param = alg[1]; indgc1 = *indgc; if (*indgc == 1 || *indgc >= 100) { goto L150; } if (*indgc == 2) { goto L180; } *indgc = -13; if (*imp > 0) { io___3186.ciunit = *io; s_wsfe(&io___3186); do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer)); e_wsfe(); } goto L900; L150: sy = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = g[i__] * epsx[i__]; sy += d__1 * d__1; } sy /= *df0 * 2.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = epsx[i__]; diag[i__] = (sy + *zero) / (d__1 * d__1 + *zero); } L180: L200: ++iter; *indgc = 1; if (iter > *itmax) { *indgc = 5; goto L900; } if (*imp >= 2) { io___3188.ciunit = *io; s_wsfe(&io___3188); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); e_wsfe(); } if (iter == 1) { irit = 1; goto L301; } majysa_(n, nt, &np, &y[y_offset], &s[s_offset], &ys[1], &lb, &g[1], &x[1], &wk2[1], &wk1[1], &index[1], &ialg[1], &nb); inp = index[np]; if (ialg[1] != 1) { goto L290; } param1 = (float)1. - param; bss = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = s[inp + i__ * s_dim1]; bss += diag[i__] * (d__1 * d__1); } bss2 = param * bss; if (ys[inp] > bss2) { goto L290; } if (*imp > 2) { io___3194.ciunit = *io; s_wsfe(&io___3194); do_fio(&c__1, (char *)&ys[inp], (ftnlen)sizeof(doublereal)); e_wsfe(); } teta = param1 * bss / (bss - ys[inp]); teta1 = 1. - teta; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { y[inp + i__ * y_dim1] = teta * y[inp + i__ * y_dim1] + teta1 * diag[ i__] * s[inp + i__ * s_dim1]; } ys[inp] = bss2; ys1 = ddot_(n, &s[inp + s_dim1], &c__1, &y[inp + y_dim1], &c__1); ys1 = (d__1 = bss2 - ys1, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / bss2; if (*imp > 2) { io___3198.ciunit = *io; s_wsfe(&io___3198); do_fio(&c__1, (char *)&ys1, (ftnlen)sizeof(doublereal)); e_wsfe(); } L290: if (ialg[2] == 1) { bfgsd_(&diag[1], n, nt, &np, &y[y_offset], &s[s_offset], &ys[1], & condm, ¶m, zero, &index[1]); } if (ialg[3] == 1 || ialg[3] == 2 && iter == 2) { shanph_(&diag[1], n, nt, &np, &y[y_offset], &s[s_offset], &ys[1], & scal, &index[1], io, imp); } majz_(n, &np, nt, &y[y_offset], &s[s_offset], &z__[z_offset], &ys[1], &zs[ 1], &diag[1], &index[1]); irit = 0; if (ialg[6] == 1) { irit = 1; } if (ialg[6] == 2 && znglib <= alg[6] * zngrit) { irit = 1; } if (ialg[6] == 10 && diff <= dfrit1 * alg[6]) { irit = 1; } if (ialg[6] == 11 && diff <= difrit * alg[6]) { irit = 1; } if (irit == 1) { ++nred; } imp1 = *imp; L301: if (ialg[7] == 1) { relvar_(&ind, n, &x[1], &binf[1], &bsup[1], &x2[1], &g[1], &diag[1], imp, io, &ibloc[1], &izag, &iter, nfac, &irit); } if (np == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dir[i__] = -g[i__] / diag[i__]; } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dir[i__] = -scal * g[i__]; } gcp_(n, &index[1], &ibloc[1], &np, nt, &y[y_offset], &s[s_offset], & z__[z_offset], &ys[1], &zs[1], &diag[1], &g[1], &dir[1], &wk1[ 1], &wk2[1], &epsgcp); } if (ialg[8] == 4 || ialg[8] == 5) { ired = 0; if (ialg[9] == 2 && ind == 1) { ired = 1; } if (ialg[9] == 10 && diff < dfred1 * tetaq) { ired = 1; } if (ialg[9] == 11 && diff < difred * tetaq) { ired = 1; } if (ialg[9] == 12 && znglib <= tetaq * zngred) { ired = 1; } if (ired == 1) { ++icycl; np = 0; lb = 1; if (*imp > 2) { io___3208.ciunit = *io; s_wsfe(&io___3208); do_fio(&c__1, (char *)&icycl, (ftnlen)sizeof(integer)); e_wsfe(); } } } if (ialg[6] == 1) { goto L640; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (ibloc[i__] > 0) { dir[i__] = 0.; } } L640: dcopy_(n, &x[1], &c__1, &wk1[1], &c__1); dcopy_(n, &g[1], &c__1, &wk2[1], &c__1); ifp = 0; fn = *f; znog0 = zng; L702: dfp = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { epsxi = epsx[i__]; xi = x[i__]; diri = dir[i__]; if (xi - binf[i__] <= epsxi && diri < 0.) { dir[i__] = 0.; } if (bsup[i__] - xi <= epsxi && diri > 0.) { dir[i__] = 0.; } } dfp = ddot_(n, &g[1], &c__1, &dir[1], &c__1); if (-dfp > 0.) { goto L715; } if (ifp == 1) { *indgc = 6; goto L900; } if (*imp >= 3) { io___3215.ciunit = *io; s_wsfe(&io___3215); do_fio(&c__1, (char *)&dfp, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*zero), (ftnlen)sizeof(doublereal)); e_wsfe(); } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dir[i__] = -scal * g[i__]; } ifp = 1; goto L702; L715: t = diff * -2. / dfp; if (iter == 1) { t = *df0 * -2. / dfp; } tmax = 1e10; t = (( t ) <= ( tmax ) ? ( t ) : ( tmax )) ; d__1 = t, d__2 = *zero * 1e10; t = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; napm = 15; napm1 = nap + napm; if (napm1 > *napmax) { napm1 = *napmax; } napav = nap; amd = .7; amf = .1; rlbd_(&indrl, n, simul, &x[1], &binf[1], &bsup[1], f, &dfp, &t, &tmax, & dir[1], &g[1], &tproj, &amd, &amf, imp, io, zero, &nap, &napm1, & x2[1], &izs[1], &rzs[1], &dzs[1]); if (*imp > 2) { io___3224.ciunit = *io; s_wsfe(&io___3224); do_fio(&c__1, (char *)&indrl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&t, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); e_wsfe(); } if (nap - napav >= 5) { ++irl; } if (indrl >= 10) { indsim = 4; ++nap; (*simul)(&indsim, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]); if (indsim <= 0) { *indgc = -3; if (indsim == 0) { *indgc = 0; } if (*imp > 0) { io___3225.ciunit = *io; s_wsfe(&io___3225); do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer)); e_wsfe(); } goto L900; } } if (indrl <= 0) { *indgc = 10; if (indrl == 0) { *indgc = 0; } if (indrl == -3) { *indgc = 13; } if (indrl == -4) { *indgc = 12; } if (indrl <= -1000) { *indgc = 11; } if (*imp > 0) { io___3226.ciunit = *io; s_wsfe(&io___3226); do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer)); e_wsfe(); } goto L900; } if (*imp >= 5) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (*imp > 2) { io___3227.ciunit = *io; s_wsfe(&io___3227); do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&g[i__], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&dir[i__], (ftnlen)sizeof(doublereal)); e_wsfe(); } } } if (nap < *napmax) { goto L758; } if (*imp > 0) { io___3228.ciunit = *io; s_wsfe(&io___3228); e_wsfe(); } *indgc = 4; goto L900; L758: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = x[i__] - wk1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > epsx[i__]) { goto L806; } } if (*imp > 0) { io___3229.ciunit = *io; s_wsfe(&io___3229); e_wsfe(); } *indgc = 3; goto L900; L806: difg = rednor_(n, &binf[1], &bsup[1], &x[1], &epsx[1], &g[1]); diff = fn - *f; if (*imp >= 2) { io___3231.ciunit = *io; s_wsfe(&io___3231); do_fio(&c__1, (char *)&(*epsg), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*epsf), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&diff, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&nap, (ftnlen)sizeof(integer)); e_wsfe(); } if (diff <= *epsf) { *indgc = 2; goto L900; } if (difg <= *epsg) { *indgc = 1; goto L900; } if (irit == 1) { difrit = diff; dfrit1 = diff; } else { difrit += diff; } if (ired == 1) { difred = diff; dfred1 = diff; } else { difred += diff; } znglib = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (ibloc[i__] > 0) { goto L884; } aa = g[i__]; if (x[i__] - binf[i__] <= epsx[i__]) { aa = (( 0. ) <= ( aa ) ? ( 0. ) : ( aa )) ; } if (bsup[i__] - x[i__] <= epsx[i__]) { aa = (( 0. ) >= ( aa ) ? ( 0. ) : ( aa )) ; } d__1 = aa; znglib += d__1 * d__1; L884: ; } znglib = sqrt(znglib); if (ired == 1) { zngred = znglib; } if (irit == 1) { zngrit = znglib; } goto L200; L900: if (indrl == 0) { *indgc = 0; } if (*indgc == 1 && indrl <= 0) { *indgc = indrl; } if (*imp > 0) { io___3233.ciunit = *io; s_wsfe(&io___3233); do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer)); e_wsfe(); } if (*imp >= 1 && (doublereal) indrl <= *zero) { io___3234.ciunit = *io; s_wsfe(&io___3234); do_fio(&c__1, (char *)&indrl, (ftnlen)sizeof(integer)); e_wsfe(); } if (*imp >= 1) { io___3235.ciunit = *io; s_wsfe(&io___3235); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&nap, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer)); e_wsfe(); } if (indgc1 < 100) { return 0; } zrl = (float)0.; if (iter > 0) { zrl = (doublereal) nap / (doublereal) iter; } io___3237.ciunit = *io; s_wsfe(&io___3237); do_fio(&c__1, nomf, 6L); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&nap, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&zrl, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&irl, (ftnlen)sizeof(integer)); e_wsfe(); } int zqnbd_(indqn, simul, dh, n, binf, bsup, x, f, g, zero, napmax, itmax, indic, izig, nfac, imp, io, epsx, epsf, epsg, x1, x2, g1, dir, df0, ig, in, irel, izag, iact, epsrel, ieps1, izs, rzs, dzs) integer *indqn; int (*simul) (); doublereal *dh; integer *n; doublereal *binf, *bsup, *x, *f, *g, *zero; integer *napmax, *itmax, *indic, *izig, *nfac, *imp, *io; doublereal *epsx, *epsf, *epsg, *x1, *x2, *g1, *dir, *df0; integer *ig, *in, *irel, *izag, *iact; doublereal *epsrel; integer *ieps1, *izs; real *rzs; doublereal *dzs; { static char fmt_1020[] = "(\002 qnbd : izag,ig,in,irel,iact,epsrel=\002,5i3,f11.4)"; static char fmt_110[] = "(\002 test sur gradient pour sortie ib\002)"; static char fmt_111[] = "(\002 test sur nombre de defactorisations pour sortie ib\002)"; static char fmt_112[] = "(\002 memorisation de variables izag=\002,i3)"; static char fmt_114[] = "(\002 methode de minimisations incompletes ; epsrel=\002,d11.4)"; static char fmt_116[] = "(\002 blocage des variables dans ib\002)"; static char fmt_118[] = "(\002 parametre eps1 nul\002)"; static char fmt_119[] = "(\002 parametre eps1 grand\002)"; static char fmt_120[] = "(\002 parametre eps1=eps(x) calcule avec cscal1=\002,d11.4)"; static char fmt_105[] = "(\002 qnbd : valeur non admissible de indqn \002,i5)"; static char fmt_123[] = "(\002 qnbd : indqn=\002,i8)"; static char fmt_1202[] = "(\002 qnbd : maximum d iterations atteint\002)"; static char fmt_1210[] = "(/\002 qnbd : iter=\002,i3,\002 f=\002,d15.7)"; static char fmt_1203[] = "(\002 qnbd : facteur d echelle=\002,d11.4)"; static char fmt_1272[] = "(\002 qnbd : pb (bs,s) negatif=\002,d11.4)"; static char fmt_1270[] = "(\002 qnbd : emploi truc powell (y,s)=\002,d11.4)"; static char fmt_282[] = "(\002 qnbd : pb dans appel majour\002)"; static char fmt_322[] = "(\002 qnbd : val de eps1 servant a partitionner les variables\002,d11.4)"; static char fmt_1320[] = "(\002 qnbd : redemarrage ; difg0,epsrel,difg1=\002,3d11.4)"; static char fmt_336[] = "(\002 defactorisation de \002,i3)"; static char fmt_333[] = "(\002 qnbd : pb dans ajour. mode=\002,i3)"; static char fmt_339[] = "(\002 on factorise l indice \002,i3)"; static char fmt_350[] = "(\002 qnbd : nbre fact\002,i3,\002 defact\002,i3,\002 total var factorisees\002,i3)"; static char fmt_650[] = "(\002 qnbd : pb num dans mult par inverse\002)"; static char fmt_1705[] = "(\002 qnbd : arret fpn non negatif=\002,d11.4)"; static char fmt_777[] = "(\002 i=\002,i2,\002 xgd \002,3f11.4)"; static char fmt_755[] = "(\002 qnbd : retour cause max appels simul\002,i9)"; static char fmt_1805[] = "(\002 qnbd : retour apres convergence de x\002)" ; static char fmt_860[] = "(\002 qnbd : epsg,difg=\002,2d11.4,\002 epsf,diff=\002,2d11.4,\002 nap=\002,i3)"; static char fmt_1865[] = "(\002 qnbd : retour cause decroissance f trop petite=\002,d11.4)"; static char fmt_1900[] = "(\002 qnbd : retour cause gradient projete petit=\002,d11.4)"; integer i__1, i__2; doublereal d__1, d__2; integer s_wsfe(), do_fio(), e_wsfe(); double sqrt(); static integer ifac; static doublereal diff, difg, scal; extern int rlbd_(); static integer mode, napm; static doublereal teta; static integer iter, irit; extern int proj_(); static doublereal tmax; static integer nfac1; static doublereal difg0, difg1; static integer n2fac; static doublereal scal1; static integer napm1; static doublereal teta1, zsig1; static integer idfac, i__, j, k; static doublereal t; static integer nnfac; static doublereal v, y, epsmc; static integer indrl, iconv; extern int ajour_(); static doublereal d1, tiers, d2; static integer i1; static doublereal tproj; static integer n1, n3; static doublereal t1, cscal1, aa, dd, bi; static integer ic, ii, ij; static doublereal fn, bs, ep; static integer ip, mk, ir; extern int calmaj_(); static doublereal gr; static integer np, indsim, nm1; static doublereal amd, amf; static integer ndh, nap, ifp; static doublereal sig, fpn; static integer nip; static doublereal cof1, cof2, sig1, eps0, eps1; static cilist io___3238 = { 0, 0, 0, fmt_1020, 0 }; static cilist io___3239 = { 0, 0, 0, fmt_110, 0 }; static cilist io___3240 = { 0, 0, 0, fmt_111, 0 }; static cilist io___3241 = { 0, 0, 0, fmt_112, 0 }; static cilist io___3242 = { 0, 0, 0, fmt_114, 0 }; static cilist io___3243 = { 0, 0, 0, fmt_116, 0 }; static cilist io___3244 = { 0, 0, 0, fmt_118, 0 }; static cilist io___3245 = { 0, 0, 0, fmt_119, 0 }; static cilist io___3247 = { 0, 0, 0, fmt_120, 0 }; static cilist io___3253 = { 0, 0, 0, fmt_105, 0 }; static cilist io___3254 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3259 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3263 = { 0, 0, 0, fmt_1202, 0 }; static cilist io___3264 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3265 = { 0, 0, 0, fmt_1210, 0 }; static cilist io___3267 = { 0, 0, 0, fmt_1203, 0 }; static cilist io___3281 = { 0, 0, 0, fmt_1272, 0 }; static cilist io___3282 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3283 = { 0, 0, 0, fmt_1270, 0 }; static cilist io___3291 = { 0, 0, 0, fmt_282, 0 }; static cilist io___3292 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3295 = { 0, 0, 0, fmt_322, 0 }; static cilist io___3302 = { 0, 0, 0, fmt_1320, 0 }; static cilist io___3312 = { 0, 0, 0, fmt_336, 0 }; static cilist io___3313 = { 0, 0, 0, fmt_333, 0 }; static cilist io___3314 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3315 = { 0, 0, 0, fmt_339, 0 }; static cilist io___3316 = { 0, 0, 0, fmt_333, 0 }; static cilist io___3317 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3318 = { 0, 0, 0, fmt_350, 0 }; static cilist io___3321 = { 0, 0, 0, fmt_650, 0 }; static cilist io___3322 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3326 = { 0, 0, 0, fmt_1705, 0 }; static cilist io___3327 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3338 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3339 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3340 = { 0, 0, 0, fmt_777, 0 }; static cilist io___3341 = { 0, 0, 0, fmt_755, 0 }; static cilist io___3342 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3343 = { 0, 0, 0, fmt_1805, 0 }; static cilist io___3344 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3346 = { 0, 0, 0, fmt_860, 0 }; static cilist io___3347 = { 0, 0, 0, fmt_1865, 0 }; static cilist io___3348 = { 0, 0, 0, fmt_123, 0 }; static cilist io___3349 = { 0, 0, 0, fmt_1900, 0 }; static cilist io___3350 = { 0, 0, 0, fmt_123, 0 }; --dh; --dir; --g1; --x2; --x1; --epsx; --izig; --indic; --g; --x; --bsup; --binf; --izs; --rzs; --dzs; if (*imp < 4) { goto L3; } io___3238.ciunit = *io; s_wsfe(&io___3238); do_fio(&c__1, (char *)&(*izag), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*ig), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*in), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*irel), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*iact), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal)); e_wsfe(); if (*ig == 1) { io___3239.ciunit = *io; s_wsfe(&io___3239); e_wsfe(); } if (*in == 1) { io___3240.ciunit = *io; s_wsfe(&io___3240); e_wsfe(); } if (*izag != 0) { io___3241.ciunit = *io; s_wsfe(&io___3241); do_fio(&c__1, (char *)&(*izag), (ftnlen)sizeof(integer)); e_wsfe(); } if (*irel == 1) { io___3242.ciunit = *io; s_wsfe(&io___3242); do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*iact == 1) { io___3243.ciunit = *io; s_wsfe(&io___3243); e_wsfe(); } if (*ieps1 == 1) { io___3244.ciunit = *io; s_wsfe(&io___3244); e_wsfe(); } if (*ieps1 == 2) { io___3245.ciunit = *io; s_wsfe(&io___3245); e_wsfe(); } cscal1 = 1e8; if (*ieps1 == 2) { io___3247.ciunit = *io; s_wsfe(&io___3247); do_fio(&c__1, (char *)&cscal1, (ftnlen)sizeof(doublereal)); e_wsfe(); } L3: difg0 = 1.; difg1 = 0.; eps0 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { izig[i__] = 0; eps0 += epsx[i__]; } eps0 = eps0 * (float)10. / *n; proj_(n, &binf[1], &bsup[1], &x[1]); ndh = *n * (*n + 1) / 2; if (*indqn == 1) { goto L10; } if (*indqn == 2) { goto L30; } if (*imp > 0) { io___3253.ciunit = *io; s_wsfe(&io___3253); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } *indqn = -105; if (*imp > 0) { io___3254.ciunit = *io; s_wsfe(&io___3254); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L10: *nfac = 0; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { indic[i__] = i__; } i__1 = ndh; for (i__ = 1; i__ <= i__1; ++i__) { dh[i__] = 0.; } L30: iter = 0; scal = 1.; nap = 1; indsim = 4; if (*indqn == 1) { (*simul)(&indsim, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]); } if (indsim <= 0) { *indqn = -1; if (indsim == 0) { *indqn = 0; } if (*imp > 0) { io___3259.ciunit = *io; s_wsfe(&io___3259); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; } if (*indqn != 1) { goto L200; } cof1 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = g[i__] * epsx[i__]; cof1 += d__1 * d__1; } cof1 /= *df0 * 2.; i1 = -(*n); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i1 + *n + 2 - i__; d__1 = epsx[i__]; dh[i1] = (cof1 + *zero) / (d__1 * d__1 + *zero); } iconv = 0; L200: ++iter; if (iter <= *itmax) { goto L202; } if (*imp > 0) { io___3263.ciunit = *io; s_wsfe(&io___3263); e_wsfe(); } *indqn = 5; if (*imp > 0) { io___3264.ciunit = *io; s_wsfe(&io___3264); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L202: if (*imp >= 2) { io___3265.ciunit = *io; s_wsfe(&io___3265); do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal)); e_wsfe(); } if (iter == 1) { goto L300; } cof1 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x1[i__] = x[i__] - x1[i__]; g1[i__] = g[i__] - g1[i__]; cof1 += x1[i__] * g1[i__]; } if (cof1 <= *zero) { goto L250; } if (iter > 2 || *indqn != 1) { goto L250; } cof2 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { d__1 = g1[i__]; cof2 += d__1 * d__1; } cof2 /= cof1; if (*imp > 3) { io___3267.ciunit = *io; s_wsfe(&io___3267); do_fio(&c__1, (char *)&cof2, (ftnlen)sizeof(doublereal)); e_wsfe(); } dh[1] = cof2; i1 = 1; i__1 = *nfac; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i1 + *n + 1 - i__; dh[i1] = cof2; } scal = 1. / cof2; L250: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = indic[i__]; x2[i1] = g1[i__]; dir[i1] = x1[i__]; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { g1[i__] = x2[i__]; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = indic[i__]; x2[i1] = x1[i__]; } if (*nfac == 0) { goto L2312; } if (*nfac > 1) { goto L2300; } dir[1] *= dh[1]; goto L2312; L2300: np = *nfac + 1; ii = 1; n1 = *nfac - 1; i__1 = n1; for (i__ = 1; i__ <= i__1; ++i__) { y = dir[i__]; if (dh[ii] == 0.) { goto L2302; } ij = ii; ip = i__ + 1; i__2 = *nfac; for (j = ip; j <= i__2; ++j) { ++ij; y += dir[j] * dh[ij]; } L2302: dir[i__] = y * dh[ii]; ii = ii + np - i__; } dir[*nfac] *= dh[ii]; i__1 = n1; for (k = 1; k <= i__1; ++k) { i__ = *nfac - k; ii = ii - np + i__; if (dir[i__] == 0.) { goto L2311; } ip = i__ + 1; ij = ii; y = dir[i__]; i__2 = *nfac; for (j = ip; j <= i__2; ++j) { ++ij; dir[j] += dh[ij] * dir[i__]; } L2311: ; } L2312: nfac1 = *nfac + 1; n2fac = *nfac * nfac1 / 2; nnfac = *n - *nfac; k = n2fac; if (*nfac == *n) { goto L268; } i__1 = *n; for (i__ = nfac1; i__ <= i__1; ++i__) { dir[i__] = 0.; } if (*nfac == 0) { goto L265; } i__1 = *nfac; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = nfac1; j <= i__2; ++j) { ++k; if (x2[j] == (float)0.) { goto L260; } dir[i__] += dh[k] * x2[j]; L260: ; } } k = n2fac; i__2 = *nfac; for (j = 1; j <= i__2; ++j) { i__1 = *n; for (i__ = nfac1; i__ <= i__1; ++i__) { ++k; dir[i__] += dh[k] * x2[j]; } } L265: k = n2fac + *nfac * nnfac; i__1 = *n; for (j = nfac1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { ++k; if (x2[j] == (float)0.) { goto L266; } dir[i__] += dh[k] * x2[j]; L266: ; } } if (*nfac == *n - 1) { goto L268; } nm1 = *n - 1; k = n2fac + *nfac * nnfac; i__2 = nm1; for (i__ = nfac1; i__ <= i__2; ++i__) { ++k; i1 = i__ + 1; i__1 = *n; for (j = i1; j <= i__1; ++j) { ++k; if (x2[j] == (float)0.) { goto L267; } dir[i__] += dh[k] * x2[j]; L267: ; } } L268: sig1 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { sig1 += dir[i__] * x2[i__]; } if (sig1 > 0.) { goto L272; } if (*imp > 2) { io___3281.ciunit = *io; s_wsfe(&io___3281); do_fio(&c__1, (char *)&sig1, (ftnlen)sizeof(doublereal)); e_wsfe(); } *indqn = 8; if (iter == 1) { *indqn = -5; } if (*imp > 0) { io___3282.ciunit = *io; s_wsfe(&io___3282); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L272: sig1 = -1. / sig1; if (cof1 > *zero) { goto L277; } if (*imp > 2) { io___3283.ciunit = *io; s_wsfe(&io___3283); do_fio(&c__1, (char *)&cof1, (ftnlen)sizeof(doublereal)); e_wsfe(); } teta = -1. / sig1; teta = teta * (float).8 / (teta - cof1); teta1 = 1. - teta; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { g1[i__] = teta * g1[i__] + teta1 * dir[i__]; } cof1 = (float)-.2 / sig1; L277: sig = 1. / cof1; zsig1 = 1. / sig1; mk = 0; ir = *nfac; epsmc = 1e-9; calmaj_(&dh[1], n, &g1[1], &sig, &x2[1], &ir, &mk, &epsmc, nfac); if (ir != *nfac) { goto L280; } calmaj_(&dh[1], n, &dir[1], &sig1, &x2[1], &ir, &mk, &epsmc, nfac); if (ir != *nfac) { goto L280; } goto L300; L280: if (*imp > 0) { io___3291.ciunit = *io; s_wsfe(&io___3291); e_wsfe(); } *indqn = 8; if (iter == 1) { *indqn = -5; } if (*imp > 0) { io___3292.ciunit = *io; s_wsfe(&io___3292); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L300: scal1 = scal; if (*ieps1 == 1) { scal1 = 0.; } if (*ieps1 == 2) { scal1 = scal * cscal1; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x1[i__] = x[i__] - scal1 * (d__1 = g[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * g[i__]; } proj_(n, &binf[1], &bsup[1], &x1[1]); eps1 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { eps1 += (d__1 = x1[i__] - x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } eps1 = (( eps0 ) <= ( eps1 ) ? ( eps0 ) : ( eps1 )) ; if (*ieps1 == 1) { eps1 = 0.; } if (*ieps1 == 2) { eps1 *= 1e4; } if (*imp > 3) { io___3295.ciunit = *io; s_wsfe(&io___3295); do_fio(&c__1, (char *)&eps1, (ftnlen)sizeof(doublereal)); e_wsfe(); } ifac = 0; idfac = 0; k = 0; gr = 0.; if (*ig == 1) { gr = difg * (float).2 / *n; } n3 = *n; if (*in == 1) { n3 = *n / 10; } irit = 0; if (difg1 <= *epsrel * difg0) { irit = 1; } if (*irel == 0 || iter == 1) { irit = 1; } if (irit * *irel > 0 && *imp > 3) { io___3302.ciunit = *io; s_wsfe(&io___3302); do_fio(&c__1, (char *)&difg0, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&difg1, (ftnlen)sizeof(doublereal)); e_wsfe(); } tiers = .33333333333333331; i__1 = *n; for (k = 1; k <= i__1; ++k) { --izig[k]; if (izig[k] <= 0) { izig[k] = 0; } bi = binf[k]; bs = bsup[k]; ic = indic[k]; d1 = x[k] - bi; d2 = bs - x[k]; dd = (bs - bi) * tiers; ep = (( eps1 ) <= ( dd ) ? ( eps1 ) : ( dd )) ; if (d1 > ep) { goto L324; } if (g[k] > (float)0.) { goto L330; } goto L335; L324: if (d2 > ep) { goto L335; } if (g[k] > (float)0.) { goto L335; } goto L330; L330: if (ic > *nfac) { goto L340; } ++idfac; mode = -1; if (*imp >= 4) { io___3312.ciunit = *io; s_wsfe(&io___3312); do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); e_wsfe(); } izig[k] += *izag; ajour_(&mode, n, &k, nfac, &dh[1], &x2[1], &indic[1]); if (mode == 0) { goto L340; } if (*imp > 0) { io___3313.ciunit = *io; s_wsfe(&io___3313); do_fio(&c__1, (char *)&mode, (ftnlen)sizeof(integer)); e_wsfe(); } *indqn = 8; if (iter == 1) { *indqn = -5; } if (*imp > 0) { io___3314.ciunit = *io; s_wsfe(&io___3314); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L335: if (irit == 0) { goto L340; } if (ic <= *nfac) { goto L340; } if (izig[k] >= 1) { goto L340; } mode = 1; if (ifac >= n3 && iter > 1) { goto L340; } if ((d__1 = g[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= gr) { goto L340; } ++ifac; if (*imp >= 4) { io___3315.ciunit = *io; s_wsfe(&io___3315); do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); e_wsfe(); } ajour_(&mode, n, &k, nfac, &dh[1], &x2[1], &indic[1]); if (mode == 0) { goto L340; } if (*imp > 0) { io___3316.ciunit = *io; s_wsfe(&io___3316); do_fio(&c__1, (char *)&mode, (ftnlen)sizeof(integer)); e_wsfe(); } *indqn = 8; if (iter == 1) { *indqn = -5; } if (*imp > 0) { io___3317.ciunit = *io; s_wsfe(&io___3317); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L340: ; } if (*imp >= 2) { io___3318.ciunit = *io; s_wsfe(&io___3318); do_fio(&c__1, (char *)&ifac, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&idfac, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*nfac), (ftnlen)sizeof(integer)); e_wsfe(); } if (iconv == 1) { return 0; } ir = *nfac; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = indic[i__]; x2[i1] = g[i__]; } if (ir < *nfac) { goto L412; } if (*nfac > 1) { goto L400; } x2[1] /= dh[1]; goto L412; L400: i__1 = *nfac; for (i__ = 2; i__ <= i__1; ++i__) { ij = i__; i1 = i__ - 1; v = x2[i__]; i__2 = i1; for (j = 1; j <= i__2; ++j) { v -= dh[ij] * x2[j]; ij = ij + *nfac - j; } x2[i__] = v; x2[i__] = v; } x2[*nfac] /= dh[ij]; np = *nfac + 1; i__1 = *nfac; for (nip = 2; nip <= i__1; ++nip) { i__ = np - nip; ii = ij - nip; v = x2[i__] / dh[ii]; ip = i__ + 1; ij = ii; i__2 = *nfac; for (j = ip; j <= i__2; ++j) { ++ii; v -= dh[ii] * x2[j]; } x2[i__] = v; } L412: if (ir == *nfac) { goto L660; } if (*imp > 0) { io___3321.ciunit = *io; s_wsfe(&io___3321); e_wsfe(); } *indqn = 7; if (iter == 1) { *indqn = -6; } if (*imp > 0) { io___3322.ciunit = *io; s_wsfe(&io___3322); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L660: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i1 = indic[i__]; dir[i__] = -g[i__] * scal; if (i1 <= *nfac) { dir[i__] = -x2[i1]; } } if (*iact != 1) { goto L675; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (izig[i__] > 0) { dir[i__] = (float)0.; } if (indic[i__] > *nfac) { dir[i__] = 0.; } } L675: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { g1[i__] = g[i__]; x1[i__] = x[i__]; } ifp = 0; fn = *f; L709: fpn = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (x[i__] - binf[i__] <= epsx[i__] && dir[i__] < (float)0.) { dir[i__] = 0.; } if (bsup[i__] - x[i__] <= epsx[i__] && dir[i__] > (float)0.) { dir[i__] = 0.; } fpn += g[i__] * dir[i__]; } if (fpn > 0.) { if (ifp == 1) { if (*imp > 0) { io___3326.ciunit = *io; s_wsfe(&io___3326); do_fio(&c__1, (char *)&fpn, (ftnlen)sizeof(doublereal)); e_wsfe(); } *indqn = 6; if (iter == 1) { *indqn = -3; } if (*imp > 0) { io___3327.ciunit = *io; s_wsfe(&io___3327); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; } else { ifp = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (izig[i__] > 0) { dir[i__] = -scal * g[i__]; } } irit = 1; goto L709; } } t1 = t; if (iter == 1) { diff = *df0; } t = diff * -2. / fpn; if (t > .3 && t < 3.) { t = 1.; } if (eps1 < eps0) { t = 1.; } if (*indqn == 2) { t = 1.; } if (iter > 1 && t1 > .01 && t1 < 100.) { t = 1.; } tmax = 1e10; t = (( t ) <= ( tmax ) ? ( t ) : ( tmax )) ; d__1 = t, d__2 = *zero * (float)10.; t = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; amd = (float).7; amf = (float).1; napm = 15; napm1 = nap + napm; if (napm1 > *napmax) { napm1 = *napmax; } rlbd_(&indrl, n, simul, &x[1], &binf[1], &bsup[1], &fn, &fpn, &t, &tmax, & dir[1], &g[1], &tproj, &amd, &amf, imp, io, zero, &nap, &napm1, & x2[1], &izs[1], &rzs[1], &dzs[1]); if (indrl >= 10) { indsim = 4; ++nap; (*simul)(&indsim, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]); if (indsim <= 0) { *indqn = -3; if (indsim == 0) { *indqn = 0; } if (*imp > 0) { io___3338.ciunit = *io; s_wsfe(&io___3338); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; } } if (indrl <= 0) { *indqn = 10; if (indrl == 0) { *indqn = 0; } if (indrl == -3) { *indqn = 13; } if (indrl == -4) { *indqn = 12; } if (indrl <= -1000) { *indqn = 11; } if (*imp > 0) { io___3339.ciunit = *io; s_wsfe(&io___3339); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; } if (*imp < 6) { goto L778; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { io___3340.ciunit = *io; s_wsfe(&io___3340); do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&g[i__], (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&dir[i__], (ftnlen)sizeof(doublereal)); e_wsfe(); } L778: if (nap < *napmax) { goto L758; } *f = fn; if (*imp > 0) { io___3341.ciunit = *io; s_wsfe(&io___3341); do_fio(&c__1, (char *)&(*napmax), (ftnlen)sizeof(integer)); e_wsfe(); } *indqn = 4; if (*imp > 0) { io___3342.ciunit = *io; s_wsfe(&io___3342); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L758: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if ((d__1 = x[i__] - x1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > epsx[i__]) { goto L806; } } *f = fn; if (*imp > 0) { io___3343.ciunit = *io; s_wsfe(&io___3343); e_wsfe(); } *indqn = 3; if (*imp > 0) { io___3344.ciunit = *io; s_wsfe(&io___3344); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; L806: difg = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { aa = g[i__]; if (x[i__] - binf[i__] <= epsx[i__]) { aa = (( 0. ) <= ( aa ) ? ( 0. ) : ( aa )) ; } if (bsup[i__] - x[i__] <= epsx[i__]) { aa = (( 0. ) >= ( aa ) ? ( 0. ) : ( aa )) ; } d__1 = aa; difg += d__1 * d__1; } difg1 = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (indic[i__] > *nfac) { goto L820; } aa = g[i__]; if (x[i__] - binf[i__] <= epsx[i__]) { aa = (( 0. ) <= ( aa ) ? ( 0. ) : ( aa )) ; } if (bsup[i__] - x[i__] <= epsx[i__]) { aa = (( 0. ) >= ( aa ) ? ( 0. ) : ( aa )) ; } d__1 = aa; difg1 += d__1 * d__1; L820: ; } difg1 = sqrt(difg1); difg = sqrt(difg); difg /= sqrt((real) (*n)); diff = (d__1 = *f - fn, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); *df0 = -diff; if (irit == 1) { difg0 = difg1; } *f = fn; if (*imp >= 2) { io___3346.ciunit = *io; s_wsfe(&io___3346); do_fio(&c__1, (char *)&(*epsg), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&(*epsf), (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&diff, (ftnlen)sizeof(doublereal)); do_fio(&c__1, (char *)&nap, (ftnlen)sizeof(integer)); e_wsfe(); } if (diff < *epsf) { *indqn = 2; if (*imp > 0) { io___3347.ciunit = *io; s_wsfe(&io___3347); do_fio(&c__1, (char *)&diff, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*imp > 0) { io___3348.ciunit = *io; s_wsfe(&io___3348); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; } if (difg > *epsg) { goto L200; } *indqn = 1; if (*imp > 0) { io___3349.ciunit = *io; s_wsfe(&io___3349); do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal)); e_wsfe(); } if (*imp > 0) { io___3350.ciunit = *io; s_wsfe(&io___3350); do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer)); e_wsfe(); } return 0; } doublereal zthz_(h__, ih, z__, iz, n, i1, i2) doublereal *h__; integer *ih; doublereal *z__; integer *iz, *n, *i1, *i2; { integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2; doublereal ret_val; extern doublereal ddot_(); static integer j; static doublereal s; static integer jj; h_dim1 = *ih; h_offset = h_dim1 + 1; h__ -= h_offset; z_dim1 = *iz; z_offset = z_dim1 + 1; z__ -= z_offset; ret_val = 0.; i__1 = *n; for (j = 1; j <= i__1; ++j) { jj = j + 1; s = ddot_(&j, &h__[j + h_dim1], ih, &z__[*i2 * z_dim1 + 1], &c__1); i__2 = *n - j; s += ddot_(&i__2, &h__[jj + j * h_dim1], &c__1, &z__[jj + *i2 * z_dim1], &c__1); ret_val += s * z__[j + *i1 * z_dim1]; } return ret_val; } int bezout_(a, da, b, db, f, df, v, dv, ip) doublereal *a; integer *da; doublereal *b; integer *db; doublereal *f; integer *df; doublereal *v; integer *dv, *ip; { integer i__1, i__2; doublereal d__1, d__2; double sqrt(); static doublereal fact; extern int dset_(); static doublereal c__[2]; static integer i__, k, n; extern int dscal_(); static doublereal x[2]; extern doublereal dasum_(); extern int dcopy_(); static integer k1, k2, l1, l2, na; static doublereal lambda; static integer jf[2], nb; extern doublereal dlamch_(); static integer jv[2]; static doublereal xs[2]; static integer inc; static doublereal eps; dv -= 3; --v; --df; --f; --b; --a; eps = dlamch_("p", 1L) * 10.; *ip = 0; i__1 = *da + 1; xs[0] = dasum_(&i__1, &a[1], &c__1); i__1 = *db + 1; xs[1] = dasum_(&i__1, &b[1], &c__1); x[0] = xs[0]; x[1] = xs[1]; if (xs[0] == 0.) { xs[0] = 1.; } if (xs[1] == 0.) { xs[1] = 1.; } na = *da + 1; L10: --na; if ((d__1 = a[na + 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps * (( xs[0] ) >= 0 ? ( xs[0] ) : -( xs[0] )) && na >= 1) { goto L10; } nb = *db + 1; L11: --nb; if ((d__1 = b[nb + 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps * (( xs[1] ) >= 0 ? ( xs[1] ) : -( xs[1] )) && nb >= 1) { goto L11; } jf[0] = 1; jf[1] = *da + 2; i__1 = *da + *db + 2; dset_(&i__1, &c_b61, &f[1], &c__1); i__1 = na + 1; dcopy_(&i__1, &a[1], &c__1, &f[1], &c__1); i__1 = na + 1; d__1 = 1. / xs[0]; dscal_(&i__1, &d__1, &f[1], &c__1); i__1 = nb + 1; dcopy_(&i__1, &b[1], &c__1, &f[jf[1]], &c__1); i__1 = nb + 1; d__1 = 1. / xs[1]; dscal_(&i__1, &d__1, &f[jf[1]], &c__1); df[1] = na; df[2] = nb; i__1 = *da + *db + 2 << 1; dset_(&i__1, &c_b61, &v[1], &c__1); jv[0] = 1; jv[1] = *db + 3 + *da; inc = *db + 1; v[1] = 1.; v[jv[1] + inc] = 1.; dv[3] = 0; dv[4] = 0; dv[5] = 0; dv[6] = 0; c__[0] = 1.; c__[1] = 1.; k1 = 1; k2 = 2; if ((( x[0] ) >= 0 ? ( x[0] ) : -( x[0] )) <= eps * (( x[1] ) >= 0 ? ( x[1] ) : -( x[1] )) ) { goto L35; } if ((( x[1] ) >= 0 ? ( x[1] ) : -( x[1] )) <= eps * (( x[0] ) >= 0 ? ( x[0] ) : -( x[0] )) ) { goto L50; } x[0] = 1.; x[1] = 1.; L20: if ((i__1 = df[k1] - df[k2]) < 0) { goto L22; } else if (i__1 == 0) { goto L21; } else { goto L23; } L21: if ((d__1 = f[jf[k1 - 1] + df[k1]], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < (d__2 = f[jf[k2 - 1] + df[k2]], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) { goto L23; } L22: k1 = 3 - k1; k2 = 3 - k2; L23: fact = c__[0] + c__[1]; fact *= fact; if ((d__1 = x[k2 - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps * fact) { df[k2] = 0; goto L40; } n = df[k2] + 1; l2 = n + jf[k2 - 1]; L24: --l2; if (n == 0) { goto L30; } --n; if ((d__1 = f[l2], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps * (d__2 = x[k1 - 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) { goto L24; } df[k2] = n; lambda = f[jf[k1 - 1] + df[k1]] / f[jf[k2 - 1] + df[k2]]; n = df[k1] - df[k2]; fact = sqrt(lambda * lambda + 1.); l2 = jf[k2 - 1]; l1 = jf[k1 - 1] + n; i__1 = df[k2]; for (i__ = 0; i__ <= i__1; ++i__) { f[l1 + i__] -= lambda * f[l2 + i__]; } l2 = jv[k2 - 1]; l1 = jv[k1 - 1] + n; c__[k1 - 1] = 0.; for (k = 1; k <= 2; ++k) { if (dv[k + (k2 << 1)] == 0 && v[l2] == 0.) { goto L27; } i__1 = dv[k + (k2 << 1)]; for (i__ = 0; i__ <= i__1; ++i__) { v[l1 + i__] -= lambda * v[l2 + i__]; } i__1 = dv[k + (k1 << 1)], i__2 = n + dv[k + (k2 << 1)]; dv[k + (k1 << 1)] = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; i__1 = dv[k + (k1 << 1)] + 1; c__[k1 - 1] += dasum_(&i__1, &v[jv[k1 - 1]], &c__1); L27: l1 += inc; l2 += inc; } n = df[k1]; l1 = jf[k1 - 1]; i__1 = n + 1; x[k1 - 1] = dasum_(&i__1, &f[l1], &c__1); f[l1 + n] = 0.; df[k1] = n - 1; goto L20; L30: if (k1 == 1) { *ip = 1; } goto L50; L35: *ip = 1; goto L50; L40: if (k2 == 1) { *ip = 1; } L50: l2 = jv[1]; l1 = jv[0]; for (k = 1; k <= 2; ++k) { i__1 = dv[k + 2] + 1; d__1 = 1. / xs[k - 1]; dscal_(&i__1, &d__1, &v[l1], &c__1); i__1 = dv[k + 4] + 1; d__1 = 1. / xs[k - 1]; dscal_(&i__1, &d__1, &v[l2], &c__1); l1 += inc; l2 += inc; } } int bezstp_(p1, n1, p2, n2, a, na, u, nu, l, x, v, w, best, ipb, errr) doublereal *p1; integer *n1; doublereal *p2; integer *n2; doublereal *a; integer *na; doublereal *u; integer *nu, *l; doublereal *x, *v, *w, *best; integer *ipb; doublereal *errr; { integer a_dim1, a_offset, u_dim1, u_offset, x_dim1, x_offset, v_dim1, v_offset, i__1, i__2; doublereal d__1, d__2; extern int ddif_(); static doublereal fact; extern doublereal ddot_(); static doublereal errd, erri; extern int drot_(); static doublereal c__; static integer k; static doublereal s; extern int dscal_(); static doublereal z__; static integer ifree; extern int dcopy_(), dpmul_(), daxpy_(); static integer n0, m1, m2; extern int dpmul1_(); static integer nb; extern doublereal dlamch_(); static integer ll; static doublereal mm; static integer nn, np, iw, nw; static doublereal dt0; static integer iw1; extern int giv_(); static doublereal eps; static integer iuv, ixy; extern int dadd_(); --p1; --p2; x_dim1 = *na; x_offset = x_dim1 + 1; x -= x_offset; a_dim1 = *na; a_offset = a_dim1 + 1; a -= a_offset; v_dim1 = *nu; v_offset = v_dim1 + 1; v -= v_offset; u_dim1 = *nu; u_offset = u_dim1 + 1; u -= u_offset; --w; --best; --ipb; eps = dlamch_("p", 1L); n0 = (( *n1 ) >= ( *n2 ) ? ( *n1 ) : ( *n2 )) + 1; i__1 = *n1 - *n2; m1 = (( i__1 ) >= ( 0 ) ? ( i__1 ) : ( 0 )) ; i__1 = *n2 - *n1; m2 = (( i__1 ) >= ( 0 ) ? ( i__1 ) : ( 0 )) ; ll = *l << 1; iuv = 1; ixy = iuv + ll; iw1 = ixy + ll; iw = iw1 + n0; ifree = iw + (n0 << 1); i__1 = *l; for (k = 1; k <= i__1; ++k) { giv_(&a[k + (n0 + 1 - k) * a_dim1], &a[k + 1 + (n0 + 1 - k) * a_dim1], &c__, &s); drot_(&n0, &a[k + a_dim1], na, &a[k + 1 + a_dim1], na, &c__, &s); a[k + 1 + (n0 + 1 - k) * a_dim1] = 0.; drot_(&ll, &u[k + u_dim1], nu, &u[k + 1 + u_dim1], nu, &c__, &s); if (k == 1 && *l < n0) { i__2 = n0 - 1; dcopy_(&i__2, &a[a_dim1 + 2], na, &x[x_offset], na); dcopy_(&ll, &u[u_dim1 + 2], nu, &v[v_offset], nu); } } dcopy_(&ll, &u[*l + u_dim1], nu, &w[iuv], &c__1); dcopy_(&ll, &u[*l + 1 + u_dim1], nu, &w[ixy], &c__1); if (*l <= (i__1 = *n1 - *n2, (( i__1 ) >= 0 ? ( i__1 ) : -( i__1 )) )) { goto L99; } fact = a[*l + (n0 - *l + 1) * a_dim1]; if (*l > 1) { d__1 = w[ixy + (m1 << 1)]; d__2 = w[ixy + 1 + (m2 << 1)]; mm = d__1 * d__1 + d__2 * d__2; z__ = w[iuv + (m1 << 1)] * w[ixy + (m1 << 1)] + w[iuv + 1 + (m2 << 1)] * w[ixy + 1 + (m2 << 1)]; } else { d__1 = w[ixy + (m1 << 1)]; mm = d__1 * d__1; z__ = w[iuv + (m1 << 1)] * w[ixy + (m1 << 1)]; } if (mm != 0.) { z__ = -z__ / mm; daxpy_(&ll, &z__, &w[ixy], &c__1, &w[iuv], &c__1); } if (fact == 0.) { goto L99; } d__1 = 1. / fact; dscal_(&ll, &d__1, &w[iuv], &c__1); dt0 = w[ixy + (*l - 1 << 1)] * w[iuv + (*l << 1) - 1] - w[ixy + (*l << 1) - 1] * w[iuv + (*l - 1 << 1)]; if (dt0 == 0.) { goto L99; } d__1 = 1. / dt0; dscal_(&ll, &d__1, &w[ixy], &c__1); dt0 = 1.; i__1 = *l - m1; dcopy_(&i__1, &w[ixy + (m1 << 1)], &c__2, &w[iw1], &c_n1); i__1 = *l - 1 - m1; dpmul1_(&p1[1], n1, &w[iw1], &i__1, &w[iw]); nw = *n1 + *l - 1 - m1; i__1 = *l - m2; dcopy_(&i__1, &w[ixy + 1 + (m2 << 1)], &c__2, &w[iw1], &c_n1); i__1 = *l - 1 - m2; dpmul_(&p2[1], n2, &w[iw1], &i__1, &w[iw], &nw); i__1 = nw + 1; errd = ddot_(&i__1, &w[iw], &c__1, &w[iw], &c__1); if (*l - 1 - m1 > 0) { i__1 = *l - 1 - m1; dcopy_(&i__1, &w[iuv + 2 + (m1 << 1)], &c__2, &w[iw1], &c_n1); i__1 = *l - 2 - m1; dpmul1_(&p1[1], n1, &w[iw1], &i__1, &w[iw]); nw = *n1 + *l - 2 - m1; } else { dpmul1_(&p1[1], n1, &w[iuv + (m1 << 1)], &c__0, &w[iw]); nw = *n1; } if (*l - 1 - m2 > 0) { i__1 = *l - 1 - m2; dcopy_(&i__1, &w[iuv + 3 + (m2 << 1)], &c__2, &w[iw1], &c_n1); i__1 = *l - 2 - m2; dpmul_(&p2[1], n2, &w[iw1], &i__1, &w[iw], &nw); } else { dpmul_(&p2[1], n2, &w[iuv + 1 + (m2 << 1)], &c__0, &w[iw], &nw); } np = n0 - *l; i__1 = np + 1; dcopy_(&i__1, &a[*l + a_dim1], na, &w[iw1], &c__1); daxpy_(&np, &z__, &a[*l + 1 + a_dim1], na, &w[iw1], &c__1); i__1 = np + 1; d__1 = 1. / fact; dscal_(&i__1, &d__1, &w[iw1], &c__1); i__1 = np + 1; ddif_(&i__1, &w[iw1], &c__1, &w[iw], &c__1); i__1 = nw + 1; errd += ddot_(&i__1, &w[iw], &c__1, &w[iw], &c__1); i__1 = *n1 - np + 1; dcopy_(&i__1, &w[ixy + 1 + (m2 << 1)], &c__2, &w[iw], &c_n1); i__1 = *n1 - np; dpmul1_(&w[iw1], &np, &w[iw], &i__1, &w[iw]); i__1 = *n1 + 1; dadd_(&i__1, &p1[1], &c__1, &w[iw], &c__1); i__1 = *n1 + 1; erri = ddot_(&i__1, &w[iw], &c__1, &w[iw], &c__1); i__1 = *n2 - np + 1; dcopy_(&i__1, &w[ixy + (m1 << 1)], &c__2, &w[iw], &c_n1); i__1 = *n2 - np; dpmul1_(&w[iw1], &np, &w[iw], &i__1, &w[iw]); i__1 = *n2 + 1; ddif_(&i__1, &p2[1], &c__1, &w[iw], &c__1); i__1 = *n2 + 1; erri += ddot_(&i__1, &w[iw], &c__1, &w[iw], &c__1); if ((( erri ) >= ( errd ) ? ( erri ) : ( errd )) < *errr) { *errr = (( erri ) >= ( errd ) ? ( erri ) : ( errd )) ; i__1 = 0, i__2 = n0 - *l; nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; ipb[1] = 1; i__1 = nb + 1; dcopy_(&i__1, &a[*l + a_dim1], na, &best[ipb[1]], &c__1); if (*l > 1) { i__1 = nb + 1; daxpy_(&i__1, &z__, &a[*l + 1 + a_dim1], na, &best[ipb[1]], &c__1) ; } i__1 = nb + 1; d__1 = 1. / fact; dscal_(&i__1, &d__1, &best[ipb[1]], &c__1); ipb[2] = ipb[1] + nb + 1; if (*l > 1) { i__1 = *n2 - nb; nn = (( i__1 ) >= ( 1 ) ? ( i__1 ) : ( 1 )) ; dcopy_(&nn, &w[iuv + (*l - nn << 1)], &c__2, &best[ipb[2]], &c_n1) ; ipb[3] = ipb[2] + nn; i__1 = *n1 - nb; nn = (( i__1 ) >= ( 1 ) ? ( i__1 ) : ( 1 )) ; dcopy_(&nn, &w[iuv + 1 + (*l - nn << 1)], &c__2, &best[ipb[3]], & c_n1); ipb[4] = ipb[3] + nn; } else { best[ipb[2]] = w[iuv]; ipb[3] = ipb[2] + 1; best[ipb[3]] = w[iuv + 1]; ipb[4] = ipb[3] + 1; } nn = *n2 + 1 - nb; dcopy_(&nn, &w[ixy + (*l - nn << 1)], &c__2, &best[ipb[4]], &c_n1); ipb[5] = ipb[4] + nn; nn = *n1 + 1 - nb; dcopy_(&nn, &w[ixy + 1 + (*l - nn << 1)], &c__2, &best[ipb[5]], &c_n1) ; ipb[6] = ipb[5] + nn; } L99: return 0; } int dimin_(lig1, col1, v1, d1, v2, d2, lig2, col2, ligr, colr, ierr) integer *lig1, *col1, *v1, *d1, *v2, *d2, *lig2, *col2, *ligr, *colr, *ierr; { integer i__1; static integer i__, noo1, noo2; --v2; --v1; if (*d1 == 0 || *d2 == 0) { *ierr = 1; return 0; } if (*d1 > 0 && *d2 > 0) { goto L5; } if (*d1 < 0 && *d2 < 0) { if (*lig1 != *lig2 || *col1 != *col2) { *ierr = 2; return 0; } *ligr = *lig1; *colr = *col1; goto L999; } if (*d1 < 0) { noo2 = 0; i__1 = *d2; for (i__ = 1; i__ <= i__1; ++i__) { if (v2[i__] > noo2) { noo2 = v2[i__]; } } *ligr = (( *lig1 ) >= ( 1 ) ? ( *lig1 ) : ( 1 )) ; *colr = (( *col1 ) >= ( noo2 ) ? ( *col1 ) : ( noo2 )) ; goto L999; } if (*d2 < 0) { noo1 = 0; i__1 = *d1; for (i__ = 1; i__ <= i__1; ++i__) { if (v1[i__] > noo1) { noo1 = v1[i__]; } } *ligr = (( *lig1 ) >= ( noo1 ) ? ( *lig1 ) : ( noo1 )) ; *colr = (( *col1 ) >= ( 1 ) ? ( *col1 ) : ( 1 )) ; goto L999; } L5: if (*d1 != *lig2 || *d2 != *col2) { *ierr = 2; return 0; } noo1 = 0; i__1 = *d1; for (i__ = 1; i__ <= i__1; ++i__) { if (v1[i__] > noo1) { noo1 = v1[i__]; } } noo2 = 0; i__1 = *d2; for (i__ = 1; i__ <= i__1; ++i__) { if (v2[i__] > noo2) { noo2 = v2[i__]; } } *ligr = (( *lig1 ) >= ( noo1 ) ? ( *lig1 ) : ( noo1 )) ; *colr = (( *col1 ) >= ( noo2 ) ? ( *col1 ) : ( noo2 )) ; L999: *ierr = 0; return 0; } int dmdsp_(x, nx, m, n, maxc, mode, ll, lunit, cw, iw, cw_len) doublereal *x; integer *nx, *m, *n, *maxc, *mode, *ll, *lunit; char *cw; integer *iw; ftnlen cw_len; { static char fmt_130[] = "(\002(1pd\002,i2,\002.\002,i2,\002)\002)"; static char fmt_120[] = "(\002(f\002,i2,\002.\002,i2,\002)\002)"; address a__1[2], a__2[4]; integer i__1, i__2, i__3, i__4[2], i__5[4]; doublereal d__1; char ch__1[20], ch__2[27]; icilist ici__1; int s_copy(); integer s_wsfi(), do_fio(), e_wsfi(); double d_lg10(), pow_di(); int s_cat(); static integer ldef; static doublereal fact; static integer imin, imax, ifmt; static char form[10*2]; static doublereal a; static integer i__, j, k, l, s, lbloc, nbloc; static doublereal a1, a2; static integer k1, k2, l1, n1, n2, l0, ib; static char dl[1]; static integer fl, lf, nf; extern doublereal dlamch_(); static integer io, lp; extern int basout_(); static integer nl1, lgh; extern int fmt_(); static doublereal eps; static char sgn[1]; static integer typ; static icilist io___3400 = { 0, form, 0, fmt_130, 10, 1 }; --iw; --x; eps = dlamch_("p", 1L); s_copy(cw, " ", cw_len, 1L); s_wsfi(&io___3400); do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer)); i__1 = *maxc - 7; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfi(); *(unsigned char *)dl = ' '; if (*m * *n > 1) { *(unsigned char *)dl = '!'; } fact = 1.; a1 = 0.; if (*m * *n == 1) { goto L10; } a2 = (( x[1] ) >= 0 ? ( x[1] ) : -( x[1] )) ; l = -(*nx); i__1 = *n; for (j = 1; j <= i__1; ++j) { l += *nx; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { a = (d__1 = x[l + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (a == 0. || a > dlamch_("o", 1L)) { goto L5; } a1 = (( a1 ) >= ( a ) ? ( a1 ) : ( a )) ; a2 = (( a2 ) <= ( a ) ? ( a2 ) : ( a )) ; L5: ; } } imax = 0; imin = 0; if (a1 > 0.) { imax = (integer) d_lg10(&a1); } if (a2 > 0.) { imin = (integer) d_lg10(&a2); } if (imax * imin <= 0) { goto L10; } imax = (imax + imin) / 2; if ((( imax ) >= 0 ? ( imax ) : -( imax )) >= *maxc - 2) { i__2 = -imax; fact = pow_di(&c_b8137, &i__2); } L10: eps = a1 * fact * eps; lbloc = *n; lf = lbloc + *n + 1; nbloc = 1; iw[lbloc + nbloc] = *n; lp = -(*nx); ldef = lf; s = 0; i__2 = *n; for (k = 1; k <= i__2; ++k) { iw[k] = 0; lp += *nx; i__1 = *m; for (l = 1; l <= i__1; ++l) { a = (d__1 = x[lp + l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * fact; if (a < eps && *mode != 0) { a = 0.; } typ = 1; if (*mode == 1) { fmt_(&a, maxc, &typ, &n1, &n2); } if (typ == 2) { fl = n1; iw[ldef] = n2 + (n1 << 5); } else if (typ < 0) { iw[ldef] = typ; fl = 3; } else { iw[ldef] = 1; fl = *maxc; n2 = *maxc - 7; } lgh = fl + 3; ++ldef; i__3 = iw[k]; iw[k] = (( i__3 ) >= ( lgh ) ? ( i__3 ) : ( lgh )) ; } s += iw[k]; if (s > *ll - 2) { iw[lbloc + nbloc] = k - 1; ++nbloc; iw[lbloc + nbloc] = *n; s = iw[k]; } } if (fact != 1.) { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 12; ici__1.iciunit = cw; ici__1.icifmt = "(1x,1pd9.1,' *')"; s_wsfi(&ici__1); d__1 = 1. / fact; do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal)); e_wsfi(); basout_(&io, lunit, cw, 12L); basout_(&io, lunit, " ", 1L); if (io == -1) { goto L99; } } k1 = 1; i__2 = nbloc; for (ib = 1; ib <= i__2; ++ib) { k2 = iw[lbloc + ib]; if (nbloc != 1) { if (k1 == k2) { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 4; ici__1.iciunit = cw; ici__1.icifmt = "(i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__4[0] = 16, a__1[0] = " column "; i__4[1] = 4, a__1[1] = cw; s_cat(ch__1, a__1, i__4, &c__2, 20L); basout_(&io, lunit, ch__1, 20L); } else { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 8; ici__1.iciunit = cw; ici__1.icifmt = "(2i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__5[0] = 16, a__2[0] = " columns "; i__5[1] = 4, a__2[1] = cw; i__5[2] = 3, a__2[2] = " to"; i__5[3] = 4, a__2[3] = cw + 4; s_cat(ch__2, a__2, i__5, &c__4, 27L); basout_(&io, lunit, ch__2, 27L); basout_(&io, lunit, " ", 1L); } basout_(&io, lunit, " ", 1L); if (io == -1) { goto L99; } } *(unsigned char *)cw = *(unsigned char *)dl; i__1 = *m; for (l = 1; l <= i__1; ++l) { ldef = lf + l - 1 + (k1 - 1) * *m; l1 = 2; i__3 = k2; for (k = k1; k <= i__3; ++k) { a = x[l + (k - 1) * *nx] * fact; if ((( a ) >= 0 ? ( a ) : -( a )) < eps && *mode != 0) { a = 0.; } l0 = l1; ifmt = iw[ldef]; *(unsigned char *)sgn = ' '; if (a < 0.) { *(unsigned char *)sgn = '-'; } a = (( a ) >= 0 ? ( a ) : -( a )) ; i__4[0] = 1, a__1[0] = " "; i__4[1] = 1, a__1[1] = sgn; s_cat(cw + (l1 - 1), a__1, i__4, &c__2, 2L); l1 += 2; if (ifmt == 1) { nf = 1; fl = *maxc; n2 = 1; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = l1 + fl - 1 - (l1 - 1); ici__1.iciunit = cw + (l1 - 1); ici__1.icifmt = form + (nf - 1) * 10; s_wsfi(&ici__1); do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal)); e_wsfi(); } else if (ifmt >= 0) { nf = 2; n1 = ifmt / 32; n2 = ifmt - (n1 << 5); fl = n1; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 10; ici__1.iciunit = form + (nf - 1) * 10; ici__1.icifmt = fmt_120; s_wsfi(&ici__1); do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer)); e_wsfi(); ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = l1 + fl - 1 - (l1 - 1); ici__1.iciunit = cw + (l1 - 1); ici__1.icifmt = form + (nf - 1) * 10; s_wsfi(&ici__1); do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal)); e_wsfi(); } else if (ifmt == -1) { fl = 3; s_copy(cw + (l1 - 1), "Inf", l1 + fl - 1 - (l1 - 1), 3L); } else if (ifmt == -2) { fl = 3; s_copy(cw + (l1 - 1), "Nan", l1 + fl - 1 - (l1 - 1), 3L); } l1 += fl; nl1 = l0 + iw[k] - 1; s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L); l1 = nl1 + 1; ldef += *m; } *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; basout_(&io, lunit, cw, l1); if (io == -1) { goto L99; } } k1 = k2 + 1; } L99: return 0; } int dmdspf_(x, nx, m, n, maxc, ll, lunit) doublereal *x; integer *nx, *m, *n, *maxc, *ll, *lunit; { static char fmt_130[] = "(\002(1x,\002,i2,\002(1pd\002,i2,\002.\002,i2,\002,2x))\002)"; address a__1[2], a__2[4]; integer i__1, i__2, i__3[2], i__4[4], i__5; char ch__1[21], ch__2[28]; integer s_wsfi(), do_fio(), e_wsfi(); int s_cat(); static integer ncol; static char form[20]; static integer k, l, nbloc, k1, k2, ib, io; static char cw[20]; extern int basout_(); static char buf[80]; static icilist io___3437 = { 0, form, 0, fmt_130, 20, 1 }; static icilist io___3442 = { 0, cw, 0, "(i4)", 4, 1 }; static icilist io___3443 = { 0, cw, 0, "(2i4)", 8, 1 }; static icilist io___3446 = { 0, buf, 0, form, 80, 1 }; --x; io = 0; ncol = *ll / (*maxc + 2); nbloc = (*n + ncol - 1) / ncol; s_wsfi(&io___3437); do_fio(&c__1, (char *)&ncol, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer)); i__1 = *maxc - 7; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfi(); k1 = 1; i__1 = nbloc; for (ib = 1; ib <= i__1; ++ib) { i__2 = k1 - 1 + ncol; k2 = (( i__2 ) <= ( *n ) ? ( i__2 ) : ( *n )) ; if (nbloc != 1) { if (k1 == k2) { s_wsfi(&io___3442); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__3[0] = 17, a__1[0] = " colonne "; i__3[1] = 4, a__1[1] = cw; s_cat(ch__1, a__1, i__3, &c__2, 21L); basout_(&io, lunit, ch__1, 21L); } else { s_wsfi(&io___3443); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__4[0] = 17, a__2[0] = " colonnes "; i__4[1] = 4, a__2[1] = cw; i__4[2] = 3, a__2[2] = " a "; i__4[3] = 4, a__2[3] = cw + 4; s_cat(ch__2, a__2, i__4, &c__4, 28L); basout_(&io, lunit, ch__2, 28L); basout_(&io, lunit, " ", 1L); } basout_(&io, lunit, " ", 1L); if (io == -1) { goto L99; } } i__2 = *m; for (l = 1; l <= i__2; ++l) { s_wsfi(&io___3446); i__5 = k2; for (k = k1; k <= i__5; ++k) { do_fio(&c__1, (char *)&x[l + (k - 1) * *nx], (ftnlen)sizeof( doublereal)); } e_wsfi(); basout_(&io, lunit, buf, 80L); if (io == -1) { goto L99; } } k1 = k2 + 1; } L99: return 0; } int dmp2pm_(mp, d__, nl, pm, deg, m, n) doublereal *mp; integer *d__, *nl; doublereal *pm; integer *deg, *m, *n; { integer i__1, i__2, i__3, i__4; extern int dset_(); static integer k, l; extern int dcopy_(); static integer mn, kij, imp, ipm; --pm; --d__; --mp; mn = *m * *n; i__1 = mn * (*deg + 1); dset_(&i__1, &c_b61, &pm[1], &c__1); imp = -(*nl); ipm = -(*m); i__1 = *n; for (k = 1; k <= i__1; ++k) { imp += *nl; ipm += *m; i__2 = *m; for (l = 1; l <= i__2; ++l) { i__3 = *deg + 1, i__4 = d__[imp + l + 1] - d__[imp + l]; kij = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ; dcopy_(&kij, &mp[d__[imp + l]], &c__1, &pm[l + ipm], &mn); } } return 0; } int dmpad_(pm1, d1, l1, pm2, d2, l2, pm3, d3, m, n) doublereal *pm1; integer *d1, *l1; doublereal *pm2; integer *d2, *l2; doublereal *pm3; integer *d3, *m, *n; { integer i__1, i__2, i__3; doublereal d__1, d__2, d__3, d__4; static integer i__, j, k; static doublereal w; static integer i1, i2, k1, n1, n2, n3, k3, k2; extern doublereal dlamch_(); static integer mn; static doublereal eps; --d3; --pm3; --d2; --pm2; --d1; --pm1; eps = dlamch_("p", 1L); mn = *m * *n; d3[1] = 1; i1 = -(*l1); i2 = -(*l2); k3 = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { i1 += *l1; i2 += *l2; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { k1 = d1[i1 + i__] - 1; k2 = d2[i2 + i__] - 1; n1 = d1[i1 + i__ + 1] - d1[i1 + i__]; n2 = d2[i2 + i__ + 1] - d2[i2 + i__]; if (n1 > n2) { goto L30; } i__3 = n1; for (k = 1; k <= i__3; ++k) { w = pm1[k1 + k] + pm2[k2 + k]; d__3 = (d__1 = pm1[k1 + k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__4 = (d__2 = pm2[k2 + k], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ); if ((( w ) >= 0 ? ( w ) : -( w )) > (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) * eps) { pm3[k3 + k] = w; } else { pm3[k3 + k] = 0.; } } if (n1 == n2) { goto L23; } n3 = n1 + 1; i__3 = n2; for (k = n3; k <= i__3; ++k) { pm3[k3 + k] = pm2[k2 + k]; } L23: n3 = n2; d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3; goto L38; L30: i__3 = n2; for (k = 1; k <= i__3; ++k) { w = pm1[k1 + k] + pm2[k2 + k]; d__3 = (d__1 = pm1[k1 + k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__4 = (d__2 = pm2[k2 + k], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ); if ((( w ) >= 0 ? ( w ) : -( w )) > (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) * eps) { pm3[k3 + k] = w; } else { pm3[k3 + k] = 0.; } } n3 = n2 + 1; i__3 = n1; for (k = n3; k <= i__3; ++k) { pm3[k3 + k] = pm1[k1 + k]; } n3 = n1; d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3; L38: k1 += n1; k2 += n2; k3 += n3; } } return 0; } int dmpadj_(pm1, d1, m, n) doublereal *pm1; integer *d1, *m, *n; { integer i__1; static integer j; extern int dcopy_(); static integer k1, n1, dj, kk; --d1; --pm1; kk = 1; dj = 1; i__1 = *m * *n; for (j = 1; j <= i__1; ++j) { k1 = dj - 1; n1 = d1[j + 1] - dj + 1; L10: --n1; if (pm1[k1 + n1] == 0. && n1 > 1) { goto L10; } if (kk != k1 + 1) { dcopy_(&n1, &pm1[k1 + 1], &c__1, &pm1[kk], &c__1); } kk += n1; dj = d1[j + 1]; d1[j + 1] = kk; } return 0; } int dmpcle_(pm1, d1, m, n, d2, epsr, epsa) doublereal *pm1; integer *d1, *m, *n, *d2; doublereal *epsr, *epsa; { integer i__1, i__2; doublereal d__1, d__2; static integer lmin, lmax, ivol; static doublereal norm; static integer k, l; extern int dcopy_(); static integer count, l1, ll; static logical ok; static integer mn, ld1; static doublereal eps; --d2; --d1; --pm1; mn = *m * *n; ld1 = mn + 1; if (mn == 1) { lmin = d1[1]; lmax = d1[2] - 1; norm = 0.; i__1 = lmax; for (l = lmin; l <= i__1; ++l) { norm += (d__1 = pm1[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } d__1 = *epsa, d__2 = *epsr * norm; eps = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; ll = lmax + 1; count = 0; ok = (0) ; i__1 = lmax; for (k = lmin; k <= i__1; ++k) { --ll; if ((d__1 = pm1[ll], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps) { pm1[ll] = 0.; if (ll == lmax) { ok = (1) ; } if (ok == (1) ) { ++count; } } else { ok = (0) ; } } d1[2] -= count; if (d1[2] <= d1[1]) { d1[2] = d1[1] + 1; } return 0; } i__1 = ld1; for (k = 1; k <= i__1; ++k) { d2[k] = d1[k]; } i__1 = mn; for (k = 1; k <= i__1; ++k) { lmin = d2[k]; lmax = d2[k + 1] - 1; norm = 0.; i__2 = lmax; for (l = lmin; l <= i__2; ++l) { norm += (d__1 = pm1[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); } d__1 = *epsa, d__2 = *epsr * norm; eps = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; ll = lmax + 1; count = 0; ok = (0) ; i__2 = lmax; for (l = lmin; l <= i__2; ++l) { --ll; if ((d__1 = pm1[ll], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps) { if (ll == lmax) { ok = (1) ; } if (ok == (1) ) { ++count; } pm1[ll] = 0.; } else { ok = (0) ; } } d1[k + 1] = d1[k] + d2[k + 1] - d2[k] - count; if (d1[k + 1] <= d1[k]) { d1[k + 1] = d1[k] + 1; } } l1 = d1[2]; i__1 = mn; for (k = 2; k <= i__1; ++k) { lmin = d2[k]; ivol = d1[k + 1] - d1[k]; dcopy_(&ivol, &pm1[lmin], &c__1, &pm1[l1], &c__1); l1 += ivol; } return 0; } int dmpcnc_(pm1, d1, ld1, pm2, d2, ld2, pm3, d3, l, m, n, job) doublereal *pm1; integer *d1, *ld1; doublereal *pm2; integer *d2, *ld2; doublereal *pm3; integer *d3, *l, *m, *n, *job; { integer i__1, i__2; static integer i__, j; extern int dcopy_(); static integer i1, i2, i3, np; --d3; --pm3; --d2; --pm2; --d1; --pm1; i3 = 1; d3[1] = 1; i1 = 1 - *ld1; i2 = 1 - *ld2; if (*job < 0) { goto L30; } i__1 = *m; for (j = 1; j <= i__1; ++j) { i1 += *ld1; np = d1[i1 + *l] - d1[i1]; dcopy_(&np, &pm1[d1[i1]], &c__1, &pm3[d3[i3]], &c__1); i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1]; } } i__1 = *n; for (j = 1; j <= i__1; ++j) { i2 += *ld2; np = d2[i2 + *l] - d2[i2]; dcopy_(&np, &pm2[d2[i2]], &c__1, &pm3[d3[i3]], &c__1); i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1]; } } return 0; L30: i__1 = *n; for (j = 1; j <= i__1; ++j) { i1 += *ld1; i2 += *ld2; np = d1[i1 + *l] - d1[i1]; dcopy_(&np, &pm1[d1[i1]], &c__1, &pm3[d3[i3]], &c__1); i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1]; } np = d2[i2 + *m] - d2[i2]; dcopy_(&np, &pm2[d2[i2]], &c__1, &pm3[d3[i3]], &c__1); i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1]; } } return 0; } int dmpdsp_(mp, d__, nl, m, n, var, lvar, maxc, mode, ll, lunit, cw, iw, var_len, cw_len) doublereal *mp; integer *d__, *nl, *m, *n; char *var; integer *lvar, *maxc, *mode, *ll, *lunit; char *cw; integer *iw; ftnlen var_len; ftnlen cw_len; { static char fmt_130[] = "(\002(1pd\002,i2,\002.\002,i2,\002)\002)"; static char fmt_120[] = "(\002(f\002,i2,\002.\002,i2,\002)\002)"; static char fmt_110[] = "(\002(i\002,i2,\002)\002)"; address a__1[2], a__2[4]; integer i__1, i__2, i__3, i__4[2], i__5[4], i__6, i__7; real r__1; doublereal d__1; char ch__1[20], ch__2[27]; icilist ici__1; int s_copy(); integer s_wsfi(), do_fio(), e_wsfi(); double r_lg10(); int s_cat(); integer s_cmp(); static integer ldef, ifmt; static char fexp[10], form[10*2], expo[10]; static doublereal a; static integer i__, j, k, l, lbloc, nbloc, lines, c1, c2; static logical first; static integer k0, k1, k2, n1, n2, l1, l2, l0, ib; static char dl[1]; static integer fl, lf, nd, nf, io, lp, sk, sl, np; extern int basout_(); static integer ll1, nl1, ldg, lgh; extern int fmt_(); static char sgn[1]; static integer typ; static icilist io___3493 = { 0, form, 0, fmt_130, 10, 1 }; static icilist io___3533 = { 0, fexp, 0, fmt_110, 10, 1 }; static icilist io___3535 = { 0, expo, 0, fexp, 10, 1 }; --iw; --d__; --mp; s_copy(cw, " ", cw_len, 1L); s_wsfi(&io___3493); do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer)); i__1 = *maxc - 7; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfi(); *(unsigned char *)dl = ' '; if (*m * *n > 1) { *(unsigned char *)dl = '!'; } lines = 0; lbloc = *n; lf = lbloc + 2 + *n; nbloc = 1; iw[lbloc + nbloc] = *n; sk = 0; ldg = -(*nl); ldef = lf; k0 = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { sl = 0; iw[k] = 0; ldg += *nl; i__2 = *m; for (l = 1; l <= i__2; ++l) { lp = d__[ldg + l] - 1; np = d__[ldg + l + 1] - d__[ldg + l]; lgh = 0; first = (1) ; i__3 = np; for (i__ = 1; i__ <= i__3; ++i__) { a = (d__1 = mp[lp + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); iw[ldef] = 0; if (a == 0.) { goto L9; } first = (0) ; typ = 1; if (*mode == 1) { fmt_(&a, maxc, &typ, &n1, &n2); } if (typ == 2) { fl = n1; iw[ldef] = n2 + (n1 << 5); } else if (typ < 0) { iw[ldef] = typ; fl = 3; } else { iw[ldef] = 1; fl = *maxc; n2 = *maxc - 7; } lgh = lgh + fl + 2; if (n2 == 0) { --lgh; if (i__ != 1 && (integer) (a + (float).1) == 1) { --lgh; } } if (i__ != 1) { lgh += *lvar; } L9: ++ldef; } r__1 = np + (float).5; nd = (integer) r_lg10(&r__1) + 1; lgh += nd; if (first) { lgh = 4; } i__3 = iw[k]; iw[k] = (( i__3 ) >= ( lgh ) ? ( i__3 ) : ( lgh )) ; sl = sl + lgh / (*ll - 2) + 1; } sk += iw[k]; if (sk > *ll - 2) { if (k == k0) { iw[lbloc + nbloc] = k; sk = 0; k0 = k + 1; } else { iw[lbloc + nbloc] = k - 1; sk = iw[k]; k0 = k; } ++nbloc; iw[lbloc + nbloc] = *n; lines = lines + (sl << 1) + *m + 2; } } nbloc = (( nbloc ) <= ( *n ) ? ( nbloc ) : ( *n )) ; k1 = 1; i__1 = nbloc; for (ib = 1; ib <= i__1; ++ib) { k2 = iw[lbloc + ib]; ll1 = 0; if (nbloc != 1) { if (k1 == k2) { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 4; ici__1.iciunit = cw; ici__1.icifmt = "(i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__4[0] = 16, a__1[0] = " column "; i__4[1] = 4, a__1[1] = cw; s_cat(ch__1, a__1, i__4, &c__2, 20L); basout_(&io, lunit, ch__1, 20L); } else { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 8; ici__1.iciunit = cw; ici__1.icifmt = "(2i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__5[0] = 16, a__2[0] = " columns "; i__5[1] = 4, a__2[1] = cw; i__5[2] = 3, a__2[2] = " to"; i__5[3] = 4, a__2[3] = cw + 4; s_cat(ch__2, a__2, i__5, &c__4, 27L); basout_(&io, lunit, ch__2, 27L); basout_(&io, lunit, " ", 1L); } if (io == -1) { goto L99; } } *(unsigned char *)cw = *(unsigned char *)dl; c1 = 2; i__2 = *ll; s_copy(cw + i__2, dl, *ll + 1 - i__2, 1L); c2 = *ll + 2; i__2 = *m; for (l = 1; l <= i__2; ++l) { l1 = c1; l2 = c2; if (iw[k1] > *ll - 2) { ll1 = *ll; } i__3 = k2; for (k = k1; k <= i__3; ++k) { ldg = (k - 1) * *nl + l; lp = d__[ldg] - 1; np = d__[ldg + 1] - d__[ldg]; ldef = lf - 1 + d__[ldg] - d__[1]; first = (1) ; l0 = l1; i__6 = np; for (j = 1; j <= i__6; ++j) { ifmt = iw[ldef + j]; if (ifmt == 0) { goto L45; } *(unsigned char *)sgn = '+'; if (first) { *(unsigned char *)sgn = ' '; } first = (0) ; if (mp[lp + j] < 0.) { *(unsigned char *)sgn = '-'; } a = (d__1 = mp[lp + j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (ifmt == 1) { nf = 1; fl = *maxc; n2 = 1; } else if (ifmt >= 0) { nf = 2; n1 = ifmt / 32; n2 = ifmt - (n1 << 5); fl = n1; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 10; ici__1.iciunit = form + (nf - 1) * 10; ici__1.icifmt = fmt_120; s_wsfi(&ici__1); do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer)); e_wsfi(); } else if (ifmt < 0) { fl = 3; n2 = 1; } nd = 0; if (j > 2) { r__1 = j + (float).5; nd = (integer) r_lg10(&r__1) + 1; } if (l2 + fl + 2 + *lvar + nd > c2 + *ll - 2) { if (l1 <= *ll - 1) { s_copy(cw + (l1 - 1), " ", *ll - 1 - (l1 - 1), 1L) ; } if (l2 <= c2 + *ll - 3) { s_copy(cw + (l2 - 1), " ", c2 + *ll - 3 - (l2 - 1) , 1L); } *(unsigned char *)&cw[*ll - 1] = *(unsigned char *)dl; i__7 = c1 - 2; basout_(&io, lunit, cw + i__7, *ll - i__7); i__7 = c2 + *ll - 3; s_copy(cw + i__7, dl, c2 + *ll - 2 - i__7, 1L); i__7 = c2 - 2; basout_(&io, lunit, cw + i__7, c2 + *ll - 2 - i__7); if (io == -1) { goto L99; } s_copy(cw + (c2 - 1), " ", 10L, 1L); l2 = c2 + 10; s_copy(cw + (c1 - 1), " ", 10L, 1L); l1 = c1 + 10; } i__4[0] = 1, a__1[0] = " "; i__4[1] = 1, a__1[1] = sgn; s_cat(cw + (l2 - 1), a__1, i__4, &c__2, 2L); ++l2; if (ifmt >= 0) { i__7 = l2; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = l2 + fl - i__7; ici__1.iciunit = cw + i__7; ici__1.icifmt = form + (nf - 1) * 10; s_wsfi(&ici__1); do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal)); e_wsfi(); } else if (ifmt == -1) { i__7 = l2; s_copy(cw + i__7, "Inf", l2 + fl - i__7, 3L); } else if (ifmt == -2) { i__7 = l2; s_copy(cw + i__7, "Nan", l2 + fl - i__7, 3L); } l2 += fl; if (n2 == 0) { --l2; } if (j > 1) { if (n2 == 0 && (integer) (a + (float).1) == 1) { --l2; } i__7 = l2; s_copy(cw + i__7, var, l2 + *lvar - i__7, (*lvar)); l2 += *lvar; } nl1 = l2 + c1 - c2; s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L); if (j > 2) { s_wsfi(&io___3533); do_fio(&c__1, (char *)&nd, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___3535); i__7 = j - 1; do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(integer)); e_wsfi(); i__7 = nl1; s_copy(cw + i__7, expo, nl1 + nd - i__7, nd); l1 = nl1 + nd; } ++l1; ++l2; L45: ; } if (first) { s_copy(cw + (l1 - 1), " ", 4L, 1L); s_copy(cw + (l2 - 1), " 0", 4L, 4L); l1 += 4; l2 += 4; nd = 0; } if (nd != 0) { s_copy(cw + (l2 - 1), " ", l2 + nd - 1 - (l2 - 1), 1L); } nl1 = l0 + iw[k]; if (ll1 == *ll) { nl1 = *ll - 1; } s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L); l1 = nl1 + 1; s_copy(cw + (l2 - 1), " ", c2 + nl1 - c1 - (l2 - 1), 1L); l2 = c2 + nl1 - c1 + 1; } if (s_cmp(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 1L) != 0) { *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; i__3 = c1 - 2; basout_(&io, lunit, cw + i__3, l1 - i__3); } *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl; i__3 = c2 - 2; basout_(&io, lunit, cw + i__3, l2 - i__3); if (l != *m) { s_copy(cw + (c2 - 1), " ", l2 - 1 - (c2 - 1), 1L); i__3 = c2 - 2; basout_(&io, lunit, cw + i__3, l2 - i__3); } if (io == -1) { goto L99; } } k1 = k2 + 1; } L99: return 0; } int dmpext_(mp, d__, m, n, row, nr, col, nc, mp1, d1, job, ierr) doublereal *mp; integer *d__, *m, *n, *row, *nr, *col, *nc; doublereal *mp1; integer *d1, *job, *ierr; { integer i__1, i__2, i__3; static integer i__, j; extern int dcopy_(); static integer id, id1, idi; --d1; --mp1; --col; --row; --d__; --mp; if (*nr * *nc == 0) { return 0; } if (*m <= 0 || *n <= 0) { return 0; } if (*nr < 0) { goto L40; } if (*nc < 0) { goto L50; } i__1 = *nc; for (j = 1; j <= i__1; ++j) { if (col[j] <= 0 || col[j] > *n) { goto L100; } } i__1 = *nr; for (i__ = 1; i__ <= i__1; ++i__) { if (row[i__] <= 0 || row[i__] > *m) { goto L100; } } if (*job == 1) { goto L25; } d1[1] = 1; id1 = 1; i__1 = *nc; for (j = 1; j <= i__1; ++j) { id = *m * (col[j] - 1) + 1; i__2 = *nr; for (i__ = 1; i__ <= i__2; ++i__) { ++id1; d1[id1] = d1[id1 - 1] + d__[id + row[i__]] - d__[id + row[i__] - 1]; } } if (*job == 0) { return 0; } L25: id1 = 1; i__2 = *nc; for (j = 1; j <= i__2; ++j) { id = *m * (col[j] - 1); i__1 = *nr; for (i__ = 1; i__ <= i__1; ++i__) { ++id1; i__3 = d1[id1] - d1[id1 - 1]; dcopy_(&i__3, &mp[d__[id + row[i__]]], &c__1, &mp1[d1[id1 - 1]], & c__1); } } return 0; L40: if (*nc < 0) { goto L60; } i__1 = *nc; for (j = 1; j <= i__1; ++j) { if (col[j] <= 0 || col[j] > *n) { goto L100; } } if (*job == 1) { goto L45; } id1 = 1; d1[id1] = 1; i__1 = *nc; for (j = 1; j <= i__1; ++j) { id = *m * (col[j] - 1) + 1; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { ++id1; d1[id1] = d1[id1 - 1] + d__[id + i__] - d__[id + i__ - 1]; } } if (*job == 0) { return 0; } L45: id1 = 1; i__2 = *nc; for (j = 1; j <= i__2; ++j) { id = *m * (col[j] - 1) + 1; i__1 = d__[id + *m] - d__[id]; dcopy_(&i__1, &mp[d__[id]], &c__1, &mp1[d1[id1]], &c__1); id1 += *m; } return 0; L50: i__2 = *nr; for (i__ = 1; i__ <= i__2; ++i__) { if (row[i__] <= 0 || row[i__] > *m) { goto L100; } } if (*job == 1) { goto L55; } id1 = 1; d1[1] = 1; id = 1 - *m; i__2 = *n; for (j = 1; j <= i__2; ++j) { id += *m; i__1 = *nr; for (i__ = 1; i__ <= i__1; ++i__) { ++id1; d1[id1] = d1[id1 - 1] + d__[id + row[i__]] - d__[id + row[i__] - 1]; } } if (*job == 0) { return 0; } L55: id1 = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { id = (j - 1) * *m; i__2 = *nr; for (i__ = 1; i__ <= i__2; ++i__) { idi = id + row[i__]; i__3 = d__[idi + 1] - d__[idi]; dcopy_(&i__3, &mp[d__[idi]], &c__1, &mp1[d1[id1]], &c__1); ++id1; } } return 0; L60: if (*job == 1) { goto L65; } i__2 = *m * *n + 1; for (i__ = 1; i__ <= i__2; ++i__) { d1[i__] = d__[i__]; } if (*job == 0) { return 0; } L65: i__2 = d__[*m * *n + 1] - 1; dcopy_(&i__2, &mp[1], &c__1, &mp1[1], &c__1); return 0; L100: *ierr = 1; return 0; } int dmpins_(mat1, dep1, lig1, col1, mat2, dep2, lig2, col2, matr, depr, ligr, colr) doublereal *mat1; integer *dep1, *lig1, *col1; doublereal *mat2; integer *dep2, *lig2, *col2; doublereal *matr; integer *depr, *ligr, *colr; { integer i__1, i__2; static integer i__, j, l; extern int dcopy_(); static integer l1, l2, kr, lr; --depr; --matr; --dep2; --mat2; --dep1; --mat1; depr[1] = 1; kr = 1; i__1 = *colr; for (j = 1; j <= i__1; ++j) { i__2 = *ligr; for (i__ = 1; i__ <= i__2; ++i__) { ++kr; lr = depr[kr]; if (lr < 0) { goto L11; } else if (lr == 0) { goto L12; } else { goto L13; } L11: l2 = -lr; l = dep2[l2 + 1] - dep2[l2]; dcopy_(&l, &mat2[dep2[l2]], &c__1, &matr[depr[kr - 1]], &c__1); depr[kr] = depr[kr - 1] + l; goto L20; L12: matr[depr[kr - 1]] = 0.; depr[kr] = depr[kr - 1] + 1; goto L20; L13: l1 = lr; l = dep1[l1 + 1] - dep1[l1]; dcopy_(&l, &mat1[dep1[l1]], &c__1, &matr[depr[kr - 1]], &c__1); depr[kr] = depr[kr - 1] + l; L20: ; } } return 0; } int dmpmu_(mp1, d1, nl1, mp2, d2, nl2, mp3, d3, l, m, n) doublereal *mp1; integer *d1, *nl1; doublereal *mp2; integer *d2, *nl2; doublereal *mp3; integer *d3, *l, *m, *n; { integer i__1, i__2, i__3; static integer i__, j, k; extern int dpmul_(); static integer k1, k2, k3, p1, p2, p3; --d3; --mp3; --d2; --mp2; --d1; --mp1; d3[1] = 1; if (*l == 0 || *m == 0 || *n == 0) { goto L500; } p2 = -(*nl2); p3 = -(*l); i__1 = *n; for (j = 1; j <= i__1; ++j) { p2 += *nl2; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { mp3[d3[p3 + i__]] = 0.; k3 = 0; p1 = i__ - *nl1; i__3 = *m; for (k = 1; k <= i__3; ++k) { p1 += *nl1; k2 = d2[p2 + k + 1] - d2[p2 + k] - 1; k1 = d1[p1 + 1] - d1[p1] - 1; dpmul_(&mp1[d1[p1]], &k1, &mp2[d2[p2 + k]], &k2, &mp3[d3[p3 + i__]], &k3); } d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L500: if (*l == 0) { goto L600; } if (*m == 0) { goto L700; } p1 = -(*nl1); p3 = -(*l); k2 = d2[2] - d2[1] - 1; i__1 = *m; for (j = 1; j <= i__1; ++j) { p1 += *nl1; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { k3 = 0; k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1; mp3[d3[p3 + i__]] = 0.; dpmul_(&mp1[d1[p1 + i__]], &k1, &mp2[1], &k2, &mp3[d3[p3 + i__]], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L600: k1 = d1[2] - d1[1] - 1; p2 = -(*nl2); p3 = -(*m); i__2 = *n; for (j = 1; j <= i__2; ++j) { p2 += *nl2; p3 += *m; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { k3 = 0; k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1; mp3[d3[p3 + i__]] = 0.; dpmul_(&mp1[1], &k1, &mp2[d2[p2 + i__]], &k2, &mp3[d3[p3 + i__]], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L700: p1 = -(*nl1); p2 = -(*nl2); p3 = -(*l); i__1 = *n; for (j = 1; j <= i__1; ++j) { p1 += *nl1; p2 += *nl2; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1; k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1; mp3[d3[p3 + i__]] = 0.; k3 = 0; dpmul_(&mp1[d1[p1 + i__]], &k1, &mp2[d2[p2 + i__]], &k2, &mp3[d3[ p3 + i__]], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; } int dmptld_(pm1, d1, ld1, pm2, d2, m, n) doublereal *pm1; integer *d1, *ld1; doublereal *pm2; integer *d2, *m, *n; { integer i__1, i__2, i__3; doublereal d__1; extern int dset_(); static integer nmax; static doublereal norm; static integer i__, j; extern doublereal dasum_(); extern int dcopy_(); static integer i1, i2, l1, l2, n1; --d2; --pm2; --d1; --pm1; d2[1] = 1; nmax = 0; i2 = 1; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__; i__2 = *n; for (j = 1; j <= i__2; ++j) { l1 = d1[i1]; n1 = d1[i1 + 1] - l1 + 1; i__3 = n1 - 1; norm = dasum_(&i__3, &pm1[l1], &c__1); L10: --n1; if ((d__1 = pm1[l1 + n1 - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + norm <= norm) { goto L10; } i1 += *ld1; ++i2; d2[i2] = n1; nmax = (( nmax ) >= ( n1 ) ? ( nmax ) : ( n1 )) ; } } d2[1] = 1; i2 = 1; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__; i__2 = *n; for (j = 1; j <= i__2; ++j) { n1 = d2[i2 + 1]; l2 = d2[i2]; if (n1 < nmax) { i__3 = nmax - n1; dset_(&i__3, &c_b61, &pm2[l2], &c__1); } dcopy_(&n1, &pm1[d1[i1]], &c__1, &pm2[l2 + nmax - n1], &c_n1); i1 += *ld1; ++i2; d2[i2] = l2 + nmax; } } return 0; } int dmptra_(pm1, d1, ld1, pm2, d2, m, n) doublereal *pm1; integer *d1, *ld1; doublereal *pm2; integer *d2, *m, *n; { integer i__1, i__2; static integer i__, j; extern int dcopy_(); static integer i1, i2, l1, l2, n1; --d2; --pm2; --d1; --pm1; d2[1] = 1; i2 = 1; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__; i__2 = *n; for (j = 1; j <= i__2; ++j) { l1 = d1[i1]; n1 = d1[i1 + 1] - l1; l2 = d2[i2]; dcopy_(&n1, &pm1[l1], &c__1, &pm2[l2], &c__1); i1 += *ld1; ++i2; d2[i2] = l2 + n1; } } return 0; } int dmrdsp_(mpn, dn, mpd, dd, nl, m, n, var, lvar, maxc, mode, ll, lunit, cw, iw, var_len, cw_len) doublereal *mpn; integer *dn; doublereal *mpd; integer *dd, *nl, *m, *n; char *var; integer *lvar, *maxc, *mode, *ll, *lunit; char *cw; integer *iw; ftnlen var_len; ftnlen cw_len; { static integer nind = 5; static char fmt_130[] = "(\002(1pd\002,i2,\002.\002,i2,\002)\002)"; static char fmt_120[] = "(\002(f\002,i2,\002.\002,i2,\002)\002)"; static char fmt_110[] = "(\002(i\002,i2,\002)\002)"; address a__1[2], a__2[4]; integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2], i__8[4]; real r__1; doublereal d__1; char ch__1[15], ch__2[24]; icilist ici__1; int s_copy(); integer s_wsfi(), do_fio(), e_wsfi(); double r_lg10(); int s_cat(); integer s_cmp(); static integer ideb, ldeb, lghd, ifin, lcol, lfin, lghn, ifmt; static char fexp[10], form[10*2], expo[10]; static doublereal a; static integer i__, j, k, l, ldefd, ldefn, lbloc, nbloc, lines, c1, c2; static logical first; static integer k0, k1, k2, n1, n2, l1, l2, l0, ib; static char dl[1]; static integer fl, nd, nf, io, sk, sl, idelta, ldelta, ndelta; extern int basout_(); static integer ll1, nl1, lfd, ldg, lfn, lpd, npd; extern int fmt_(); static char sgn[1]; static integer lpn, npn, typ, jjb1; static icilist io___3575 = { 0, form, 0, fmt_130, 10, 1 }; static icilist io___3626 = { 0, fexp, 0, fmt_110, 10, 1 }; static icilist io___3628 = { 0, expo, 0, fexp, 10, 1 }; static icilist io___3632 = { 0, fexp, 0, fmt_110, 10, 1 }; static icilist io___3633 = { 0, expo, 0, fexp, 10, 1 }; --iw; --dd; --mpd; --dn; --mpn; s_copy(cw, " ", cw_len, 1L); s_wsfi(&io___3575); do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer)); i__1 = *maxc - 7; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfi(); *(unsigned char *)dl = ' '; if (*m * *n > 1) { *(unsigned char *)dl = '!'; } lcol = 1; lbloc = lcol + *n - 1; lfn = lbloc + *n + 2; lfd = lfn + dn[*n * *m + 1]; ldelta = lfd + dd[*n * *m + 1]; ldeb = ldelta + *m * *n; lfin = ldeb + *n; lines = 0; nbloc = 1; iw[lbloc + nbloc] = *n; sk = 0; ldefn = lfn; ldg = -(*nl); ldefd = lfd; idelta = ldelta; k0 = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { sl = 0; iw[lcol - 1 + k] = 0; ldg += *nl; i__2 = *m; for (l = 1; l <= i__2; ++l) { lpn = dn[ldg + l] - 1; npn = dn[ldg + l + 1] - dn[ldg + l]; lghn = 0; first = (1) ; i__3 = npn; for (i__ = 1; i__ <= i__3; ++i__) { a = (d__1 = mpn[lpn + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); iw[ldefn] = 0; if (a != 0.) { first = (0) ; typ = 1; if (*mode == 1) { fmt_(&a, maxc, &typ, &n1, &n2); } if (typ == 2) { fl = n1; iw[ldefn] = n2 + (n1 << 5); } else if (typ < 0) { iw[ldefn] = typ; n2 = 1; fl = 3; } else { iw[ldefn] = 1; fl = *maxc; n2 = *maxc - 7; } lghn = lghn + fl + 2; if (n2 == 0) { --lghn; if (i__ != 1 && (integer) (a + (float).1) == 1) { --lghn; } } if (i__ != 1) { lghn += *lvar; } } ++ldefn; } r__1 = npn + (float).5; nd = (integer) r_lg10(&r__1) + 1; lghn += nd; if (first) { lghn = 4; } lpd = dd[ldg + l] - 1; npd = dd[ldg + l + 1] - dd[ldg + l]; lghd = 0; first = (1) ; i__3 = npd; for (i__ = 1; i__ <= i__3; ++i__) { a = (d__1 = mpd[lpd + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); iw[ldefd] = 0; if (a != 0.) { first = (0) ; typ = 1; if (*mode == 1) { fmt_(&a, maxc, &typ, &n1, &n2); } if (typ == 2) { fl = n1; iw[ldefd] = n2 + (n1 << 5); } else if (typ < 0) { iw[ldefd] = typ; n2 = 1; fl = 3; } else { iw[ldefd] = 1; fl = *maxc; n2 = *maxc - 7; } lghd = lghd + fl + 2; if (n2 == 0) { --lghd; if (i__ != 1 && (integer) (a + (float).1) == 1) { --lghd; } } if (i__ != 1) { lghd += *lvar; } } ++ldefd; } r__1 = npd + (float).5; nd = (integer) r_lg10(&r__1) + 1; lghd += nd; if (first) { lghd = 4; } i__3 = iw[k], i__3 = (( i__3 ) >= ( lghn ) ? ( i__3 ) : ( lghn )) ; iw[k] = (( i__3 ) >= ( lghd ) ? ( i__3 ) : ( lghd )) ; sl = sl + lghn / (*ll - 10) + lghd / (*ll - 10) + 2; i__3 = lghn, i__4 = *ll - 2; i__5 = lghd, i__6 = *ll - 2; iw[idelta] = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) - (( i__5 ) <= ( i__6 ) ? ( i__5 ) : ( i__6 )) ; ++idelta; } sk += iw[k]; if (sk > *ll - 2) { if (k == k0) { iw[lbloc + nbloc] = k; sk = 0; k0 = k + 1; } else { iw[lbloc + nbloc] = k - 1; sk = iw[k]; k0 = k; } ++nbloc; iw[lbloc + nbloc] = *n; } } nbloc = (( nbloc ) <= ( *n ) ? ( nbloc ) : ( *n )) ; k1 = 1; i__1 = nbloc; for (ib = 1; ib <= i__1; ++ib) { k2 = iw[lbloc + ib]; ll1 = 0; if (nbloc != 1) { if (k1 == k2) { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 4; ici__1.iciunit = cw; ici__1.icifmt = "(i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__7[0] = 11, a__1[0] = " column "; i__7[1] = 4, a__1[1] = cw; s_cat(ch__1, a__1, i__7, &c__2, 15L); basout_(&io, lunit, ch__1, 15L); } else { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 8; ici__1.iciunit = cw; ici__1.icifmt = "(2i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__8[0] = 12, a__2[0] = " columns "; i__8[1] = 4, a__2[1] = cw; i__8[2] = 4, a__2[2] = " to "; i__8[3] = 4, a__2[3] = cw + 4; s_cat(ch__2, a__2, i__8, &c__4, 24L); basout_(&io, lunit, ch__2, 24L); basout_(&io, lunit, " ", 1L); } if (io == -1) { goto L99; } } *(unsigned char *)cw = *(unsigned char *)dl; c1 = 2; i__2 = *ll; s_copy(cw + i__2, dl, *ll + 1 - i__2, 1L); i__2 = *ll + 3, i__3 = nind + *maxc + 15; c2 = (( i__2 ) >= ( i__3 ) ? ( i__2 ) : ( i__3 )) ; i__2 = *m; for (l = 1; l <= i__2; ++l) { l1 = c1; l2 = c2; if (iw[k1] > *ll - 2) { ll1 = *ll; } i__3 = k2; for (k = k1; k <= i__3; ++k) { l0 = l1; idelta = ldelta - 1 + l + (k - 1) * *m; ndelta = 0; if (iw[idelta] < -1) { ndelta = -iw[idelta] / 2; s_copy(cw + (l1 - 1), " ", l1 + ndelta - 1 - (l1 - 1), 1L) ; s_copy(cw + (l2 - 1), " ", l2 + ndelta - 1 - (l2 - 1), 1L) ; l1 += ndelta; l2 += ndelta; } ldg = (k - 1) * *nl + l; lpn = dn[ldg] - 1; npn = dn[ldg + 1] - dn[ldg]; ldefn = lfn - 1 + dn[ldg] - dn[1]; first = (1) ; iw[ldeb - 1 + k] = l2; iw[lfin - 1 + k] = 0; i__4 = npn; for (j = 1; j <= i__4; ++j) { ifmt = iw[ldefn + j]; if (ifmt == 0) { goto L40; } *(unsigned char *)sgn = '+'; if (first) { *(unsigned char *)sgn = ' '; } first = (0) ; if (mpn[lpn + j] < 0.) { *(unsigned char *)sgn = '-'; } a = (d__1 = mpn[lpn + j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (ifmt == 1) { nf = 1; fl = *maxc; n2 = 1; } else if (ifmt >= 0) { nf = 2; n1 = ifmt / 32; n2 = ifmt - (n1 << 5); fl = n1; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 10; ici__1.iciunit = form + (nf - 1) * 10; ici__1.icifmt = fmt_120; s_wsfi(&ici__1); do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer)); e_wsfi(); } else if (ifmt < 0) { fl = 3; n2 = 1; } nd = 0; if (j > 2) { r__1 = j + (float).5; nd = (integer) r_lg10(&r__1) + 1; } if (l2 + fl + 2 + *lvar + nd > c2 + *ll - 2) { if (l1 <= *ll - 1) { s_copy(cw + (l1 - 1), " ", *ll - 1 - (l1 - 1), 1L) ; l1 = *ll; } if (l2 <= c2 + *ll - 2) { s_copy(cw + (l2 - 1), " ", c2 + *ll - 2 - (l2 - 1) , 1L); l2 = c2 + *ll - 2; } iw[lfin - 1 + k] = l2 - 1; *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; i__5 = c1 - 2; basout_(&io, lunit, cw + i__5, l1 - i__5); *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl; i__5 = c2 - 2; s_copy(cw + i__5, dl, c2 - 1 - i__5, 1L); i__5 = c2 - 2; basout_(&io, lunit, cw + i__5, l2 - i__5); if (io == -1) { goto L99; } i__5 = c2 - 2; s_copy(cw + i__5, " ", c2 + nind - 1 - i__5, 1L); i__5 = c2 - 2; s_copy(cw + i__5, dl, c2 - 1 - i__5, 1L); l2 = c2 + nind; i__5 = c1 - 2; s_copy(cw + i__5, " ", c1 + nind - 1 - i__5, 1L); i__5 = c1 - 2; s_copy(cw + i__5, dl, c1 - 1 - i__5, 1L); l1 = c1 + nind; } i__7[0] = 1, a__1[0] = " "; i__7[1] = 1, a__1[1] = sgn; s_cat(cw + (l2 - 1), a__1, i__7, &c__2, 2L); ++l2; if (ifmt >= 0) { i__5 = l2; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = l2 + fl - i__5; ici__1.iciunit = cw + i__5; ici__1.icifmt = form + (nf - 1) * 10; s_wsfi(&ici__1); do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal)); e_wsfi(); } else if (ifmt == -1) { i__5 = l2; s_copy(cw + i__5, "Inf", l2 + fl - i__5, 3L); } else if (ifmt == -2) { i__5 = l2; s_copy(cw + i__5, "Nan", l2 + fl - i__5, 3L); } l2 += fl; if (n2 == 0) { --l2; } if (j > 1) { if (n2 == 0 && (integer) (a + (float).1) == 1) { --l2; } i__5 = l2; s_copy(cw + i__5, var, l2 + *lvar - i__5, (*lvar)); l2 += *lvar; } nl1 = l2 + c1 - c2; s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L); if (j > 2) { s_wsfi(&io___3626); do_fio(&c__1, (char *)&nd, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___3628); i__5 = j - 1; do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer)); e_wsfi(); i__5 = nl1; s_copy(cw + i__5, expo, nl1 + nd - i__5, nd); l1 = nl1 + nd; } ++l1; ++l2; L40: ; } if (first) { s_copy(cw + (l1 - 1), " ", 4L, 1L); s_copy(cw + (l2 - 1), " 0", 4L, 4L); l1 += 4; l2 += 4; nd = 0; } if (iw[lfin - 1 + k] == 0) { iw[lfin - 1 + k] = l2; } if (nd != 0) { s_copy(cw + (l2 - 1), " ", l2 + nd - 1 - (l2 - 1), 1L); } nl1 = l0 + iw[k]; if (ll1 == *ll) { nl1 = *ll - 1; } s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L); l1 = nl1 + 1; s_copy(cw + (l2 - 1), " ", c2 + nl1 - c1 - (l2 - 1), 1L); l2 = c2 + nl1 - c1 + 1; } if (s_cmp(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 1L) != 0) { *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; i__3 = c1 - 2; basout_(&io, lunit, cw + i__3, l1 - i__3); } *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl; i__3 = c2 - 2; s_copy(cw + i__3, dl, c2 - 1 - i__3, 1L); i__3 = c2 - 2; basout_(&io, lunit, cw + i__3, l2 - i__3); if (io == -1) { goto L99; } s_copy(cw + (c2 - 1), " ", l2 - 1 - (c2 - 1), 1L); jjb1 = c2; i__3 = k2; for (k = k1; k <= i__3; ++k) { idelta = ldelta - 1 + l + (k - 1) * *m; i__4 = 0, i__5 = -iw[idelta] / 2; ndelta = (( i__4 ) >= ( i__5 ) ? ( i__4 ) : ( i__5 )) ; i__4 = jjb1, i__5 = iw[ldeb - 1 + k] - ndelta + 2; ideb = (( i__4 ) >= ( i__5 ) ? ( i__4 ) : ( i__5 )) ; ifin = iw[lfin - 1 + k] + ndelta - 2; if (ifin - ideb + 1 == 2) { --ideb; } i__4 = ifin; for (i__ = ideb; i__ <= i__4; ++i__) { i__5 = i__; s_copy(cw + i__5, "-", i__ + 1 - i__5, 1L); } jjb1 = iw[lfin - 1 + k] + 1; } *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl; i__3 = c2 - 2; basout_(&io, lunit, cw + i__3, l2 - i__3); if (io == -1) { goto L99; } l1 = c1; l2 = c2; i__3 = k2; for (k = k1; k <= i__3; ++k) { l0 = l1; idelta = ldelta - 1 + l + (k - 1) * *m; ndelta = 0; if (iw[idelta] > 1) { ndelta = iw[idelta] / 2; s_copy(cw + (l1 - 1), " ", l1 + ndelta - 1 - (l1 - 1), 1L) ; s_copy(cw + (l2 - 1), " ", l2 + ndelta - 1 - (l2 - 1), 1L) ; l1 += ndelta; l2 += ndelta; } ldg = (k - 1) * *nl + l; lpd = dd[ldg] - 1; npd = dd[ldg + 1] - dd[ldg]; ldefd = lfd - 1 + dd[ldg] - dd[1]; first = (1) ; i__4 = npd; for (j = 1; j <= i__4; ++j) { ifmt = iw[ldefd + j]; if (ifmt == 0) { goto L50; } *(unsigned char *)sgn = '+'; if (first) { *(unsigned char *)sgn = ' '; } first = (0) ; if (mpd[lpd + j] < 0.) { *(unsigned char *)sgn = '-'; } a = (d__1 = mpd[lpd + j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (ifmt == 1) { nf = 1; fl = *maxc; n2 = 1; } else if (ifmt >= 0) { nf = 2; n1 = ifmt / 32; n2 = ifmt - (n1 << 5); fl = n1; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 10; ici__1.iciunit = form + (nf - 1) * 10; ici__1.icifmt = fmt_120; s_wsfi(&ici__1); do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer)); e_wsfi(); } else if (ifmt < 0) { fl = 3; n2 = 1; } nd = 0; if (j > 2) { r__1 = j + (float).5; nd = (integer) r_lg10(&r__1) + 1; } if (l2 + fl + 2 + *lvar + nd > c2 + *ll - 2) { if (l1 <= *ll - 1) { s_copy(cw + (l1 - 1), " ", *ll - 1 - (l1 - 1), 1L) ; l1 = *ll; } if (l2 <= c2 + *ll - 2) { s_copy(cw + (l2 - 1), " ", c2 + *ll - 2 - (l2 - 1) , 1L); l2 = c2 + *ll - 2; } *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; i__5 = c1 - 2; basout_(&io, lunit, cw + i__5, l1 - i__5); *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl; i__5 = c2 - 2; basout_(&io, lunit, cw + i__5, l2 - i__5); if (io == -1) { goto L99; } s_copy(cw + (c2 - 1), " ", c2 - 1 + nind - (c2 - 1), 1L); i__5 = c2 - 2; s_copy(cw + i__5, dl, c2 - 1 - i__5, 1L); l2 = c2 + nind; s_copy(cw + (c1 - 1), " ", c1 - 1 + nind - (c1 - 1), 1L); i__5 = c1 - 2; s_copy(cw + i__5, dl, c1 - 1 - i__5, 1L); l1 = c1 + nind; } i__7[0] = 1, a__1[0] = " "; i__7[1] = 1, a__1[1] = sgn; s_cat(cw + (l2 - 1), a__1, i__7, &c__2, 2L); ++l2; if (ifmt >= 0) { i__5 = l2; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = l2 + fl - i__5; ici__1.iciunit = cw + i__5; ici__1.icifmt = form + (nf - 1) * 10; s_wsfi(&ici__1); do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal)); e_wsfi(); } else if (ifmt == -1) { i__5 = l2; s_copy(cw + i__5, "Inf", l2 + fl - i__5, 3L); } else if (ifmt == -2) { i__5 = l2; s_copy(cw + i__5, "Nan", l2 + fl - i__5, 3L); } l2 += fl; if (n2 == 0) { --l2; } if (j > 1) { if (n2 == 0 && (integer) (a + (float).1) == 1) { --l2; } i__5 = l2; s_copy(cw + i__5, var, l2 + *lvar - i__5, (*lvar)); l2 += *lvar; } nl1 = l2 + c1 - c2; s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L); if (j > 2) { s_wsfi(&io___3632); do_fio(&c__1, (char *)&nd, (ftnlen)sizeof(integer)); e_wsfi(); s_wsfi(&io___3633); i__5 = j - 1; do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer)); e_wsfi(); i__5 = nl1; s_copy(cw + i__5, expo, nl1 + nd - i__5, nd); l1 = nl1 + nd; } ++l1; ++l2; L50: ; } if (first) { s_copy(cw + (l1 - 1), " ", 4L, 1L); s_copy(cw + (l2 - 1), " 0", 4L, 4L); l1 += 4; l2 += 4; nd = 0; } if (nd != 0) { s_copy(cw + (l2 - 1), " ", l2 + nd - 1 - (l2 - 1), 1L); } nl1 = l0 + iw[k]; if (ll1 == *ll) { nl1 = *ll - 1; } s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L); l1 = nl1 + 1; s_copy(cw + (l2 - 1), " ", c2 + nl1 - c1 - (l2 - 1), 1L); l2 = c2 + nl1 - c1 + 1; } if (s_cmp(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 1L) != 0) { *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; i__3 = c1 - 2; basout_(&io, lunit, cw + i__3, l1 - i__3); } *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl; i__3 = c2 - 2; s_copy(cw + i__3, dl, c2 - 1 - i__3, 1L); i__3 = c2 - 2; basout_(&io, lunit, cw + i__3, l2 - i__3); s_copy(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 1L); *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; if (io == -1) { goto L99; } if (l != *m) { i__3 = c1 - 2; basout_(&io, lunit, cw + i__3, l1 - i__3); if (io == -1) { goto L99; } } } k1 = k2 + 1; } L99: return 0; } int dpmul_(p1, d1, p2, d2, p3, d3) doublereal *p1; integer *d1; doublereal *p2; integer *d2; doublereal *p3; integer *d3; { integer i__1, i__2; doublereal d__1, d__2, d__3; static integer dmin__, dmax__; extern doublereal ddot_(); static integer dsum, i__, j, k, l; static doublereal w; static integer e1, e2; static doublereal w1; extern doublereal dlamch_(); static doublereal eps; --p3; --p2; --p1; eps = dlamch_("p", 1L); dsum = *d1 + *d2; dmax__ = *d1; if (*d2 > *d1) { dmax__ = *d2; } dmin__ = dsum - dmax__; if (*d3 >= dsum) { goto L1; } e1 = *d3 + 2; e2 = dsum + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { p3[i__] = 0.; } *d3 = dsum; L1: if (*d1 == 0 || *d2 == 0) { goto L53; } e1 = 1; e2 = dmin__ + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { w = ddot_(&i__, &p1[1], &c__1, &p2[1], &c_n1); w1 = p3[i__] + w; d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ; if ((( w1 ) >= 0 ? ( w1 ) : -( w1 )) > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) { p3[i__] = w1; } else { p3[i__] = 0.; } } k = 1; if (*d1 == *d2) { goto L21; } e1 = dmin__ + 2; e2 = dmax__ + 1; if (*d1 < *d2) { goto L25; } i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { ++k; i__2 = dmin__ + 1; w = ddot_(&i__2, &p1[k], &c__1, &p2[1], &c_n1); w1 = p3[i__] + w; d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ; if ((( w1 ) >= 0 ? ( w1 ) : -( w1 )) > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) { p3[i__] = w1; } else { p3[i__] = 0.; } } L21: e1 = dmax__ + 2; e2 = dsum + 1; l = 1; j = dmin__ + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { --j; ++k; ++l; w = ddot_(&j, &p1[k], &c__1, &p2[l], &c_n1); w1 = p3[i__] + w; d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ; if ((( w1 ) >= 0 ? ( w1 ) : -( w1 )) > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) { p3[i__] = w1; } else { p3[i__] = 0.; } } return 0; L25: i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { ++k; i__2 = dmin__ + 1; w = ddot_(&i__2, &p2[k], &c_n1, &p1[1], &c__1); w1 = p3[i__] + w; d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ; if ((( w1 ) >= 0 ? ( w1 ) : -( w1 )) > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) { p3[i__] = w1; } else { p3[i__] = 0.; } } e1 = dmax__ + 2; e2 = dsum + 1; l = 1; j = dmin__ + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { --j; ++k; ++l; w = ddot_(&j, &p1[l], &c__1, &p2[k], &c_n1); w1 = p3[i__] + w; d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ; if ((( w1 ) >= 0 ? ( w1 ) : -( w1 )) > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) { p3[i__] = w1; } else { p3[i__] = 0.; } } return 0; L53: if (*d1 == 0 && *d2 == 0) { goto L100; } e1 = 1; if (*d1 == 0) { goto L60; } e2 = *d1 + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { w = p1[i__] * p2[1]; w1 = p3[i__] + w; d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ; if ((( w1 ) >= 0 ? ( w1 ) : -( w1 )) > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) { p3[i__] = w1; } else { p3[i__] = 0.; } } return 0; L60: e2 = *d2 + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { w = p2[i__] * p1[1]; w1 = p3[i__] + w; d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ; if ((( w1 ) >= 0 ? ( w1 ) : -( w1 )) > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) { p3[i__] = w1; } else { p3[i__] = 0.; } } return 0; L100: p3[1] += p1[1] * p2[1]; return 0; } int dpmul1_(p1, d1, p2, d2, p3) doublereal *p1; integer *d1; doublereal *p2; integer *d2; doublereal *p3; { integer i__1; extern doublereal ddot_(); static integer k, l, d3, l1, l2, l3, m3; --p3; --p2; --p1; l = 1; l1 = *d1 + 1; l2 = *d2 + 1; d3 = *d1 + *d2; l3 = d3 + 1; m3 = (( l1 ) <= ( l2 ) ? ( l1 ) : ( l2 )) ; i__1 = m3; for (k = 1; k <= i__1; ++k) { p3[l3] = ddot_(&l, &p1[l1], &c__1, &p2[l2], &c_n1); ++l; --l3; --l1; --l2; } --l; if (l1 == 0) { goto L30; } m3 = l1; i__1 = m3; for (k = 1; k <= i__1; ++k) { p3[l3] = ddot_(&l, &p1[l1], &c__1, &p2[1], &c_n1); --l1; --l3; } goto L40; L30: if (l2 == 0) { goto L40; } m3 = l2; i__1 = m3; for (k = 1; k <= i__1; ++k) { p3[l3] = ddot_(&l, &p1[1], &c__1, &p2[l2], &c_n1); --l2; --l3; } L40: if (l3 == 0) { return 0; } m3 = l3; i__1 = m3; for (k = 1; k <= i__1; ++k) { --l; p3[l3] = ddot_(&l, &p1[1], &c__1, &p2[1], &c_n1); --l3; } return 0; } int dpodiv_(a, b, na, nb) doublereal *a, *b; integer *na, *nb; { integer i__1; static integer i__, l, n; static doublereal q; static integer n1, n2, nb1; --b; --a; l = *na - *nb + 1; L2: if (l <= 0) { goto L5; } else { goto L3; } L3: n = l + *nb; q = a[n] / b[*nb + 1]; nb1 = *nb + 1; i__1 = nb1; for (i__ = 1; i__ <= i__1; ++i__) { n1 = *nb - i__ + 2; n2 = n - i__ + 1; a[n2] -= b[n1] * q; } a[n] = q; --l; goto L2; L5: return 0; } int dprxc_(n, roots, coeff) integer *n; doublereal *roots, *coeff; { integer i__1; doublereal d__1; extern int dset_(); static integer j; extern int daxpy_(); static integer nj; --roots; --coeff; dset_(n, &c_b61, &coeff[1], &c__1); coeff[*n + 1] = 1.; i__1 = *n; for (j = 1; j <= i__1; ++j) { nj = *n + 1 - j; d__1 = -roots[j]; daxpy_(&j, &d__1, &coeff[nj + 1], &c__1, &coeff[nj], &c__1); } return 0; } int dpsimp_(a, na, b, nb, a1, na1, b1, nb1, w, ierr) doublereal *a; integer *na; doublereal *b; integer *nb; doublereal *a1; integer *na1; doublereal *b1; integer *nb1; doublereal *w; integer *ierr; { integer i__1; doublereal d__1; static integer nden; extern int dset_(); static integer maxw, nnum; static doublereal t; extern int dscal_(); static integer lfree; extern int dcopy_(); static integer n0; static doublereal er; static integer lw, nz; extern int recbez_(); static integer la0, lb0, ipb[6]; --a; --b; --a1; --b1; --w; lw = (*na + *nb << 1) + 1 + (( *na ) <= ( *nb ) ? ( *na ) : ( *nb )) + 3; maxw = *ierr; *ierr = 0; la0 = 0; L10: ++la0; if (la0 > *na + 1) { goto L20; } if (a[la0] == 0.) { goto L10; } *na1 = *na - (la0 - 1); nz = la0 - 1; lb0 = 0; L11: ++lb0; if (lb0 > *nb + 1) { *ierr = 1; return 0; } if (b[lb0] == 0.) { goto L11; } *nb1 = *nb - (lb0 - 1); nz -= lb0 - 1; n0 = (( *na1 ) >= ( *nb1 ) ? ( *na1 ) : ( *nb1 )) + 1; lfree = lw + n0 * 10 + n0 * 3 * n0; if (lfree >= maxw && *na1 > 0 && *nb1 > 0) { *ierr = 2; } if (lfree >= maxw || *na1 == 0 || *nb1 == 0) { goto L30; } recbez_(&a[la0], na1, &b[lb0], nb1, &w[1], ipb, &w[lw], &er); if (er > .001) { goto L30; } nden = ipb[4] - ipb[3]; nnum = ipb[5] - ipb[4]; if (*na1 != nnum - 1) { t = w[ipb[4] - 1]; t = 1. / t; if (nz == 0) { dcopy_(&nnum, &w[ipb[4]], &c__1, &a1[1], &c__1); d__1 = -t; dscal_(&nnum, &d__1, &a1[1], &c__1); dcopy_(&nden, &w[ipb[3]], &c__1, &b1[1], &c__1); dscal_(&nden, &t, &b1[1], &c__1); } else if (nz > 0) { dcopy_(&nnum, &w[ipb[4]], &c__1, &a1[nz + 1], &c__1); dset_(&nz, &c_b61, &a1[1], &c__1); d__1 = -t; dscal_(&nnum, &d__1, &a1[nz + 1], &c__1); nnum += nz; dcopy_(&nden, &w[ipb[3]], &c__1, &b1[1], &c__1); dscal_(&nden, &t, &b1[1], &c__1); } else if (nz < 0) { nz = -nz; dcopy_(&nnum, &w[ipb[4]], &c__1, &a1[1], &c__1); d__1 = -t; dscal_(&nnum, &d__1, &a1[1], &c__1); dcopy_(&nden, &w[ipb[3]], &c__1, &b1[nz + 1], &c__1); dset_(&nz, &c_b61, &b1[1], &c__1); dscal_(&nden, &t, &b1[nz + 1], &c__1); nden += nz; } } else { if (nz == 0) { dcopy_(&nnum, &a[la0], &c__1, &a1[1], &c__1); dcopy_(&nden, &b[lb0], &c__1, &b1[1], &c__1); } else if (nz > 0) { dcopy_(&nnum, &a[la0], &c__1, &a1[nz + 1], &c__1); dset_(&nz, &c_b61, &a1[1], &c__1); nnum += nz; dcopy_(&nden, &b[lb0], &c__1, &b1[1], &c__1); } else { nz = -nz; dcopy_(&nnum, &a[la0], &c__1, &a1[1], &c__1); dcopy_(&nden, &b[lb0], &c__1, &b1[nz + 1], &c__1); dset_(&nz, &c_b61, &b1[1], &c__1); nden += nz; } } *na1 = nnum; *nb1 = nden; return 0; L20: a1[1] = 0.; b1[1] = 1.; *na1 = 1; *nb1 = 1; return 0; L30: if (nz == 0) { i__1 = *na1 + 1; dcopy_(&i__1, &a[la0], &c__1, &a1[1], &c__1); i__1 = *nb1 + 1; dcopy_(&i__1, &b[lb0], &c__1, &b1[1], &c__1); } else if (nz > 0) { dset_(&nz, &c_b61, &a1[1], &c__1); i__1 = *na1 + 1; dcopy_(&i__1, &a[la0], &c__1, &a1[nz + 1], &c__1); i__1 = *nb1 + 1; dcopy_(&i__1, &b[lb0], &c__1, &b1[1], &c__1); *na1 += nz; } else { i__1 = *na1 + 1; dcopy_(&i__1, &a[la0], &c__1, &a1[1], &c__1); i__1 = -nz; dset_(&i__1, &c_b61, &b1[1], &c__1); i__1 = *nb1 + 1; dcopy_(&i__1, &b[lb0], &c__1, &b1[-nz + 1], &c__1); *nb1 -= nz; } ++(*na1); ++(*nb1); return 0; } int dwmpmu_(mp1r, d1, nl1, mp2r, mp2i, d2, nl2, mp3r, mp3i, d3, l, m, n) doublereal *mp1r; integer *d1, *nl1; doublereal *mp2r, *mp2i; integer *d2, *nl2; doublereal *mp3r, *mp3i; integer *d3, *l, *m, *n; { integer i__1, i__2, i__3; static integer i__, j, k; extern int dpmul_(); static integer k1, k2, k3, p1, p2, p3, kk; --d3; --mp3i; --mp3r; --d2; --mp2i; --mp2r; --d1; --mp1r; d3[1] = 1; if (*l == 0 || *m == 0 || *n == 0) { goto L500; } p2 = -(*nl2); p3 = -(*l); i__1 = *n; for (j = 1; j <= i__1; ++j) { p2 += *nl2; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { mp3r[d3[p3 + i__]] = 0.; mp3i[d3[p3 + i__]] = 0.; k3 = 0; p1 = i__ - *nl1; i__3 = *m; for (k = 1; k <= i__3; ++k) { p1 += *nl1; k2 = d2[p2 + k + 1] - d2[p2 + k] - 1; k1 = d1[p1 + 1] - d1[p1] - 1; kk = k3; dpmul_(&mp1r[d1[p1]], &k1, &mp2r[d2[p2 + k]], &k2, &mp3r[d3[ p3 + i__]], &kk); dpmul_(&mp1r[d1[p1]], &k1, &mp2i[d2[p2 + k]], &k2, &mp3i[d3[ p3 + i__]], &k3); } d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L500: if (*l == 0) { goto L600; } if (*m == 0) { goto L700; } p1 = -(*nl1); p3 = -(*l); k2 = d2[2] - d2[1] - 1; i__1 = *m; for (j = 1; j <= i__1; ++j) { p1 += *nl1; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { k3 = 0; k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; kk = k3; dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2r[1], &k2, &mp3r[d3[p3 + i__] ], &kk); mp3i[d3[p3 + i__]] = 0.; dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2i[1], &k2, &mp3i[d3[p3 + i__] ], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L600: k1 = d1[2] - d1[1] - 1; p2 = -(*nl2); p3 = -(*m); i__2 = *n; for (j = 1; j <= i__2; ++j) { p2 += *nl2; p3 += *m; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { k3 = 0; k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; kk = k3; dpmul_(&mp1r[1], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3r[d3[p3 + i__] ], &kk); mp3i[d3[p3 + i__]] = 0.; dpmul_(&mp1r[1], &k1, &mp2i[d2[p2 + i__]], &k2, &mp3i[d3[p3 + i__] ], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L700: p1 = -(*nl1); p2 = -(*nl2); p3 = -(*l); i__1 = *n; for (j = 1; j <= i__1; ++j) { p1 += *nl1; p2 += *nl2; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1; k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; k3 = 0; dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3r[ d3[p3 + i__]], &k3); mp3i[d3[p3 + i__]] = 0.; k3 = 0; dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2i[d2[p2 + i__]], &k2, &mp3i[ d3[p3 + i__]], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; } int fmt_(a, maxc, typ, n1, n2) doublereal *a; integer *maxc, *typ, *n1, *n2; { integer i__1, i__2; doublereal d__1; double d_mod(), d_lg10(), pow_di(); static integer ndgt, m; static logical v; static doublereal a1; extern doublereal round_(); static logical t1, t2; extern doublereal dlamch_(); static doublereal dec, ent; v = (0) ; t1 = *a <= 1.; t2 = *a >= 1.; if (! t1 && ! t2) { v = (1) ; } if (v) { *typ = -2; return 0; } else if (*a > dlamch_("o", 1L)) { *typ = -1; return 0; } if (*maxc - 3 <= 0) { goto L30; } if (*a < 1.) { goto L20; } a1 = d_mod(a, &c_b8137); ent = *a - a1 + (integer) a1; dec = *a - ent; ndgt = (integer) d_lg10(&ent) + 1; if (ndgt < 0) { ndgt = *maxc; } if (ndgt <= *maxc - 2) { goto L10; } if (*maxc - 7 < 0) { goto L30; } *typ = 1; *n1 = *maxc; *n2 = *maxc - 7; return 0; L10: *n1 = ndgt + 2; *typ = 2; ndgt = *maxc - *n1; *n2 = 0; i__1 = ndgt + 1; a1 = dec * pow_di(&c_b8137, &i__1); d__1 = a1 / 10.; dec = round_(&d__1); if (dec == 0.) { return 0; } *n2 = ndgt; L11: if (d_mod(&dec, &c_b8137) != 0.) { goto L12; } --(*n2); dec /= 10.; goto L11; L12: *n1 += *n2; return 0; L20: ndgt = 0; if (*a == 0.) { goto L26; } m = (integer) (1 - d_lg10(a)); ndgt = *maxc - 3 + m; if (m >= *maxc - 3) { goto L25; } d__1 = *a * pow_di(&c_b8137, &ndgt); dec = round_(&d__1); L21: if (d_mod(&dec, &c_b8137) != 0.) { goto L22; } dec /= 10.; --ndgt; goto L21; L22: if (ndgt <= *maxc - 3) { goto L26; } *n1 = *maxc - 3; i__1 = *maxc - 7, i__2 = ndgt - m; *n2 = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; if (*n1 >= *n2) { goto L26; } L25: if (*maxc - 7 < 0) { goto L26; } *typ = 1; *n1 = *maxc; *n2 = *maxc - 7; return 0; L26: *typ = 2; i__1 = ndgt, i__2 = *maxc - 3; *n2 = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ; *n1 = *n2 + 3; return 0; L30: *typ = 2; *n1 = *maxc; *n2 = 0; return 0; } int horner_(p, dp, xr, xi, vr, vi) doublereal *p; integer *dp; doublereal *xr, *xi, *vr, *vi; { integer i__1; static integer i__; static doublereal t; static integer ip; --p; ip = *dp + 1; *vr = p[ip]; *vi = 0.; if (*dp == 0) { return 0; } if (*xi != 0.) { goto L20; } i__1 = *dp; for (i__ = 1; i__ <= i__1; ++i__) { *vr = *vr * *xr + p[ip - i__]; } return 0; L20: i__1 = *dp; for (i__ = 1; i__ <= i__1; ++i__) { t = *vr * *xr - *vi * *xi + p[ip - i__]; *vi = *vi * *xr + *vr * *xi; *vr = t; } return 0; } int idegre_(a, majo, nvrai) doublereal *a; integer *majo, *nvrai; { integer i__1; doublereal d__1; static doublereal test; static integer k; extern doublereal dasum_(); static doublereal an; static integer kk; --a; i__1 = *majo + 1; an = dasum_(&i__1, &a[1], &c__1); if (an == 0.) { goto L20; } if (*majo == 0) { goto L20; } i__1 = *majo + 1; for (k = 1; k <= i__1; ++k) { kk = *majo + 2 - k; test = (d__1 = a[kk], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / an; if (test + 1. != 1.) { *nvrai = kk - 1; return 0; } } L20: *nvrai = 0; return 0; } int impcnc_(pm1, d1, ld1, pm2, d2, ld2, pm3, d3, l, m, n, job) integer *pm1, *d1, *ld1, *pm2, *d2, *ld2, *pm3, *d3, *l, *m, *n, *job; { integer i__1, i__2; static integer i__, j; extern int icopy_(); static integer i1, i2, i3, np; --d3; --pm3; --d2; --pm2; --d1; --pm1; i3 = 1; d3[1] = 1; i1 = 1 - *ld1; i2 = 1 - *ld2; if (*job < 0) { goto L30; } i__1 = *m; for (j = 1; j <= i__1; ++j) { i1 += *ld1; np = d1[i1 + *l] - d1[i1]; icopy_(&np, &pm1[d1[i1]], &c__1, &pm3[d3[i3]], &c__1); i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1]; } } i__1 = *n; for (j = 1; j <= i__1; ++j) { i2 += *ld2; np = d2[i2 + *l] - d2[i2]; icopy_(&np, &pm2[d2[i2]], &c__1, &pm3[d3[i3]], &c__1); i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1]; } } return 0; L30: i__1 = *n; for (j = 1; j <= i__1; ++j) { i1 += *ld1; i2 += *ld2; np = d1[i1 + *l] - d1[i1]; icopy_(&np, &pm1[d1[i1]], &c__1, &pm3[d3[i3]], &c__1); i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1]; } np = d2[i2 + *m] - d2[i2]; icopy_(&np, &pm2[d2[i2]], &c__1, &pm3[d3[i3]], &c__1); i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1]; } } return 0; } int impext_(mp, d__, m, n, row, nr, col, nc, mp1, d1, job, ierr) integer *mp, *d__, *m, *n, *row, *nr, *col, *nc, *mp1, *d1, *job, *ierr; { integer i__1, i__2, i__3; static integer i__, j; extern int icopy_(); static integer id, id1, idi; --d1; --mp1; --col; --row; --d__; --mp; if (*nr * *nc == 0) { return 0; } if (*m <= 0 || *n <= 0) { return 0; } if (*nr < 0) { goto L40; } if (*nc < 0) { goto L50; } i__1 = *nc; for (j = 1; j <= i__1; ++j) { if (col[j] <= 0 || col[j] > *n) { goto L100; } } i__1 = *nr; for (i__ = 1; i__ <= i__1; ++i__) { if (row[i__] <= 0 || row[i__] > *m) { goto L100; } } if (*job == 1) { goto L25; } d1[1] = 1; id1 = 1; i__1 = *nc; for (j = 1; j <= i__1; ++j) { id = *m * (col[j] - 1) + 1; i__2 = *nr; for (i__ = 1; i__ <= i__2; ++i__) { ++id1; d1[id1] = d1[id1 - 1] + d__[id + row[i__]] - d__[id + row[i__] - 1]; } } if (*job == 0) { return 0; } L25: id1 = 1; i__2 = *nc; for (j = 1; j <= i__2; ++j) { id = *m * (col[j] - 1); i__1 = *nr; for (i__ = 1; i__ <= i__1; ++i__) { ++id1; i__3 = d1[id1] - d1[id1 - 1]; icopy_(&i__3, &mp[d__[id + row[i__]]], &c__1, &mp1[d1[id1 - 1]], & c__1); } } return 0; L40: if (*nc < 0) { goto L60; } i__1 = *nc; for (j = 1; j <= i__1; ++j) { if (col[j] <= 0 || col[j] > *n) { goto L100; } } if (*job == 1) { goto L45; } id1 = 1; d1[id1] = 1; i__1 = *nc; for (j = 1; j <= i__1; ++j) { id = *m * (col[j] - 1) + 1; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { ++id1; d1[id1] = d1[id1 - 1] + d__[id + i__] - d__[id + i__ - 1]; } } if (*job == 0) { return 0; } L45: id1 = 1; i__2 = *nc; for (j = 1; j <= i__2; ++j) { id = *m * (col[j] - 1) + 1; i__1 = d__[id + *m] - d__[id]; icopy_(&i__1, &mp[d__[id]], &c__1, &mp1[d1[id1]], &c__1); id1 += *m; } return 0; L50: i__2 = *nr; for (i__ = 1; i__ <= i__2; ++i__) { if (row[i__] <= 0 || row[i__] > *m) { goto L100; } } if (*job == 1) { goto L55; } id1 = 1; d1[1] = 1; id = 1 - *m; i__2 = *n; for (j = 1; j <= i__2; ++j) { id += *m; i__1 = *nr; for (i__ = 1; i__ <= i__1; ++i__) { ++id1; d1[id1] = d1[id1 - 1] + d__[id + row[i__]] - d__[id + row[i__] - 1]; } } if (*job == 0) { return 0; } L55: id1 = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { id = (j - 1) * *m; i__2 = *nr; for (i__ = 1; i__ <= i__2; ++i__) { idi = id + row[i__]; i__3 = d__[idi + 1] - d__[idi]; icopy_(&i__3, &mp[d__[idi]], &c__1, &mp1[d1[id1]], &c__1); ++id1; } } return 0; L60: if (*job == 1) { goto L65; } i__2 = *m * *n + 1; for (i__ = 1; i__ <= i__2; ++i__) { d1[i__] = d__[i__]; } if (*job == 0) { return 0; } L65: i__2 = d__[*m * *n + 1] - 1; icopy_(&i__2, &mp[1], &c__1, &mp1[1], &c__1); return 0; L100: *ierr = 1; return 0; } int impins_(mat1, dep1, lig1, col1, mat2, dep2, lig2, col2, matr, depr, ligr, colr) integer *mat1, *dep1, *lig1, *col1, *mat2, *dep2, *lig2, *col2, *matr, *depr, *ligr, *colr; { integer i__1, i__2; static integer i__, j, l; extern int icopy_(); static integer l1, l2, kr, lr; --depr; --matr; --dep2; --mat2; --dep1; --mat1; depr[1] = 1; kr = 1; i__1 = *colr; for (j = 1; j <= i__1; ++j) { i__2 = *ligr; for (i__ = 1; i__ <= i__2; ++i__) { ++kr; lr = depr[kr]; if (lr < 0) { goto L11; } else if (lr == 0) { goto L12; } else { goto L13; } L11: l2 = -lr; l = dep2[l2 + 1] - dep2[l2]; icopy_(&l, &mat2[dep2[l2]], &c__1, &matr[depr[kr - 1]], &c__1); depr[kr] = depr[kr - 1] + l; goto L20; L12: matr[depr[kr - 1]] = 40; depr[kr] = depr[kr - 1] + 1; goto L20; L13: l1 = lr; l = dep1[l1 + 1] - dep1[l1]; icopy_(&l, &mat1[dep1[l1]], &c__1, &matr[depr[kr - 1]], &c__1); depr[kr] = depr[kr - 1] + l; L20: ; } } return 0; } int imptra_(pm1, d1, ld1, pm2, d2, m, n) integer *pm1, *d1, *ld1, *pm2, *d2, *m, *n; { integer i__1, i__2; static integer i__, j; extern int icopy_(); static integer i1, i2, l1, l2, n1; --d2; --pm2; --d1; --pm1; d2[1] = 1; i2 = 1; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__; i__2 = *n; for (j = 1; j <= i__2; ++j) { l1 = d1[i1]; n1 = d1[i1 + 1] - l1; l2 = d2[i2]; icopy_(&n1, &pm1[l1], &c__1, &pm2[l2], &c__1); i1 += *ld1; ++i2; d2[i2] = l2 + n1; } } return 0; } int matra_(pm1, d1, ld1, pm2, d2, m, n) integer *pm1, *d1, *ld1, *pm2, *d2, *m, *n; { integer i__1, i__2; static integer i__, j; extern int icopy_(); static integer i1, i2, l1, l2, n1; --d2; --pm2; --d1; --pm1; d2[1] = 1; i2 = 1; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__; i__2 = *n; for (j = 1; j <= i__2; ++j) { l1 = d1[i1]; n1 = d1[i1 + 1] - l1; l2 = d2[i2]; icopy_(&n1, &pm1[l1], &c__1, &pm2[l2], &c__1); i1 += *ld1; ++i2; d2[i2] = l2 + n1; } } return 0; } int mpdegr_(d__, nl, deg, m, n) integer *d__, *nl, *deg, *m, *n; { integer i__1, i__2, i__3, i__4; static integer i__, k, ip; --d__; *deg = 0; ip = -(*nl); i__1 = *n; for (k = 1; k <= i__1; ++k) { ip += *nl; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = *deg, i__4 = d__[ip + i__ + 1] - d__[ip + i__] - 1; *deg = (( i__3 ) >= ( i__4 ) ? ( i__3 ) : ( i__4 )) ; } } return 0; } int mpdiag_(d__, m, n, diag, dd, mr, nr) integer *d__, *m, *n, *diag, *dd, *mr, *nr; { integer i__1; static integer k, l, kk, mn; --dd; --d__; if (*n <= 0) { goto L20; } *nr = 1; mn = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ; k = -(*diag) + 1; if (*diag >= 0) { k = *diag * *m + 1; } *mr = *diag + *m; if (*diag + *m >= mn) { *mr = mn; } if (*diag >= *n - mn) { *mr = *n - *diag; } l = 0; if (*mr <= 0) { goto L11; } i__1 = *mr + 1; for (kk = 2; kk <= i__1; ++kk) { dd[kk] = k; l = l + d__[k + 1] - d__[k]; k = k + *m + 1; } L11: dd[1] = l; return 0; L20: *mr = *m; *nr = *m; l = 0; if (*diag >= 0) { *nr += *diag; } else { *mr -= *diag; } i__1 = *mr * *nr + 1; for (k = 2; k <= i__1; ++k) { dd[k] = 0; } kk = 1 - *diag; if (*diag >= 0) { kk = *diag * *mr + 1; } i__1 = *m; for (k = 1; k <= i__1; ++k) { dd[kk + 1] = k; kk = kk + *mr + 1; l = d__[k + 1] - d__[k] + l; } dd[1] = l + *mr * *nr - *m; return 0; } int mpinsp_(dep1, lig1, col1, v1, d1, v2, d2, dep2, lig2, col2, depr, ligr, colr, ierr) integer *dep1, *lig1, *col1, *v1, *d1, *v2, *d2, *dep2, *lig2, *col2, *depr, * ligr, *colr, *ierr; { integer i__1, i__2, i__3; static integer volr, i__, k1, k2, ir, jr, kr, id1, id2; --depr; --dep2; --v2; --v1; --dep1; *ierr = 0; volr = 0; if (*d1 == 0 || *d2 == 0) { return 0; } if (*d1 > 0 || *d2 > 0) { goto L10; } if (*lig1 != *lig2 || *col1 != *col2) { goto L50; } ir = *lig1 * *col1 + 1; i__1 = ir; for (i__ = 1; i__ <= i__1; ++i__) { depr[i__ + 1] = -i__; } volr = dep2[ir] - dep2[1]; goto L999; L10: if (*d1 < 0) { if ((( 1 ) >= ( *lig1 ) ? ( 1 ) : ( *lig1 )) != *lig2) { goto L50; } kr = 1; volr = 0; i__1 = *colr; for (jr = 1; jr <= i__1; ++jr) { id2 = 0; i__2 = *d2; for (i__ = 1; i__ <= i__2; ++i__) { if (v2[i__] == jr) { id2 = i__; } } if (id2 == 0) { goto L13; } k2 = *lig2 * (id2 - 1); i__2 = *ligr; for (ir = 1; ir <= i__2; ++ir) { ++kr; depr[kr] = -(k2 + ir); } volr = volr + dep2[k2 + *ligr + 1] - dep2[k2 + 1]; goto L16; L13: if (jr <= *col1) { k1 = (jr - 1) * *lig1; i__2 = *ligr; for (ir = 1; ir <= i__2; ++ir) { ++kr; depr[kr] = k1 + ir; } volr = volr + dep1[k1 + *ligr + 1] - dep1[k1 + 1]; goto L16; } i__2 = *ligr; for (ir = 1; ir <= i__2; ++ir) { ++kr; depr[kr] = 0; } volr += *ligr; L16: ; } goto L999; } if (*d2 < 0) { if (*col1 != (( 1 ) >= ( *col2 ) ? ( 1 ) : ( *col2 )) ) { goto L50; } i__1 = *ligr; for (ir = 1; ir <= i__1; ++ir) { kr = ir + 1 - *ligr; id1 = 0; i__2 = *d1; for (i__ = 1; i__ <= i__2; ++i__) { if (v1[i__] == ir) { id1 = i__; } } if (id1 == 0) { goto L23; } k2 = id1 - *lig2; i__2 = *colr; for (jr = 1; jr <= i__2; ++jr) { kr += *ligr; k2 += *lig2; depr[kr] = -k2; volr = volr + dep2[k2 + 1] - dep2[k2]; } goto L26; L23: if (ir <= *lig1) { k1 = ir - *lig1; i__2 = *colr; for (jr = 1; jr <= i__2; ++jr) { kr += *ligr; k1 += *lig1; volr = volr + dep1[k1 + 1] - dep1[k1]; depr[kr] = k1; } goto L26; } i__2 = *colr; for (jr = 1; jr <= i__2; ++jr) { kr += *ligr; depr[kr] = 0; } volr += *colr; L26: ; } goto L999; } kr = 2; i__1 = *colr; for (jr = 1; jr <= i__1; ++jr) { id2 = 0; i__2 = *d2; for (i__ = 1; i__ <= i__2; ++i__) { if (v2[i__] == jr) { id2 = i__; } } if (id2 == 0) { goto L35; } i__2 = *ligr; for (ir = 1; ir <= i__2; ++ir) { id1 = 0; i__3 = *d1; for (i__ = 1; i__ <= i__3; ++i__) { if (v1[i__] == ir) { id1 = i__; } } if (id1 == 0) { goto L32; } k2 = id1 + *lig2 * (id2 - 1); depr[kr] = -k2; ++kr; volr = volr + dep2[k2 + 1] - dep2[k2]; goto L34; L32: if (ir > *lig1 || jr > *col1) { goto L33; } k1 = ir + *lig1 * (jr - 1); depr[kr] = k1; ++kr; volr = volr + dep1[k1 + 1] - dep1[k1]; goto L34; L33: depr[kr] = 0; ++kr; ++volr; L34: ; } goto L40; L35: if (jr > *col1) { goto L38; } k1 = (jr - 1) * *lig1; i__2 = *lig1; for (ir = 1; ir <= i__2; ++ir) { depr[kr] = k1 + ir; ++kr; } volr = volr + dep1[k1 + *lig1 + 1] - dep1[k1 + 1]; if (*lig1 >= *ligr) { goto L40; } i__2 = *ligr; for (ir = *lig1 + 1; ir <= i__2; ++ir) { depr[kr] = 0; ++kr; } volr = volr + *ligr - *lig1; goto L40; L38: i__2 = *ligr; for (ir = 1; ir <= i__2; ++ir) { depr[kr] = 0; ++kr; } volr += *ligr; L40: ; } L999: depr[1] = volr; return 0; L50: *ierr = 1; return 0; } int mptri_(d__, m, n, diag, dd, job) integer *d__, *m, *n, *diag, *dd, *job; { integer i__1; extern int iset_(); static integer i__, j, l, ll, nn, ls; --dd; --d__; i__1 = *m * *n + 1; for (i__ = 2; i__ <= i__1; ++i__) { dd[i__] = i__ - 1; } if (*job == 0) { goto L15; } if (*diag <= 0) { goto L11; } i__1 = *m * *diag; iset_(&i__1, &c__0, &dd[2], &c__1); ls = *m * *diag + 2; nn = *n - *diag; ll = *m - 1; goto L12; L11: ls = 2 - *diag; nn = *n; ll = *m - 1 + *diag; L12: i__1 = nn; for (j = 1; j <= i__1; ++j) { if (ll <= 0) { goto L20; } iset_(&ll, &c__0, &dd[ls + 1], &c__1); --ll; ls = ls + *m + 1; } goto L20; L15: nn = *n; if (*diag < 0) { goto L16; } ls = *m * (*diag + 1) + 1; nn = *n - *diag - 1; ll = 1; goto L17; L16: ls = 1; ll = -(*diag); nn = *n; L17: i__1 = nn; for (j = 1; j <= i__1; ++j) { if (ll > *m) { ll = *m; } iset_(&ll, &c__0, &dd[ls + 1], &c__1); ls += *m; ++ll; } L20: l = 0; i__1 = *m * *n + 1; for (i__ = 2; i__ <= i__1; ++i__) { if (dd[i__] == 0) { ++l; } else { l = l + d__[dd[i__] + 1] - d__[dd[i__]]; } } dd[1] = l; return 0; } int recbez_(p1, n1, p2, n2, best, ipb, w, err) doublereal *p1; integer *n1; doublereal *p2; integer *n2; doublereal *best; integer *ipb; doublereal *w, *err; { integer i__1; extern int dset_(); static integer l, ifree; extern int dcopy_(); static integer n0, ia, la, na, n02; extern doublereal dlamch_(); static integer iu, np, iw, lu, nu; extern int bezstp_(); static integer nn1, nn2; --p1; --p2; --best; --ipb; --w; *err = dlamch_("o", 1L); ia = 1; nn1 = *n1; nn2 = *n2; ++nn1; L1: --nn1; if (nn1 < 0) { goto L30; } if (p1[nn1 + 1] == 0.) { goto L1; } ++nn2; L2: --nn2; if (nn2 < 0) { goto L30; } if (p2[nn2 + 1] == 0.) { goto L2; } n0 = (( nn1 ) >= ( nn2 ) ? ( nn1 ) : ( nn2 )) + 1; n02 = n0 * (n0 + 1); na = n0 + 1; dset_(&n02, &c_b61, &w[ia], &c__1); iu = ia + n02; nu = n0 + 1; i__1 = n02 << 1; dset_(&i__1, &c_b61, &w[iu], &c__1); iw = iu + (n02 << 1); ifree = iw + n0 * 7; la = ia + na - 1; lu = iu + nu - 1 + (n0 << 1) * nu; i__1 = nn1 + 1; dcopy_(&i__1, &p1[1], &c__1, &w[la - 1], &na); i__1 = nn2 + 1; dcopy_(&i__1, &p2[1], &c__1, &w[la], &na); i__1 = nu + 1; dset_(&c__2, &c_b89, &w[lu - 1 - (nu << 1)], &i__1); i__1 = n0; for (l = 1; l <= i__1; ++l) { --la; lu = lu - 1 - (nu << 1); bezstp_(&p1[1], &nn1, &p2[1], &nn2, &w[la], &na, &w[lu], &nu, &l, &w[ la - 1 + na], &w[lu - 1 - (nu << 1)], &w[iw], &best[1], &ipb[ 1], err); } return 0; L30: *err = 0.; ipb[1] = 1; if ((( nn1 ) <= ( nn2 ) ? ( nn1 ) : ( nn2 )) == 0) { goto L70; } if ((i__1 = nn1 - nn2) < 0) { goto L40; } else if (i__1 == 0) { goto L50; } else { goto L60; } L40: np = nn2; i__1 = nn2 + 1; dcopy_(&i__1, &p2[1], &c__1, &best[1], &c__1); ipb[2] = ipb[1] + nn2 + 1; best[ipb[2]] = 0.; ipb[3] = ipb[2] + 1; best[ipb[3]] = 1.; ipb[4] = ipb[3] + 1; best[ipb[4]] = 1.; ipb[5] = ipb[4] + 1; best[ipb[5]] = 0.; ipb[6] = ipb[5] + 1; return 0; L50: np = 0; best[1] = 0.; ipb[2] = ipb[1] + 1; best[ipb[2]] = 1.; ipb[3] = ipb[2] + 1; best[ipb[3]] = 0.; ipb[4] = ipb[3] + 1; best[ipb[4]] = 0.; ipb[5] = ipb[4] + 1; best[ipb[5]] = 1.; ipb[6] = ipb[5] + 1; return 0; L60: np = nn1; i__1 = nn1 + 1; dcopy_(&i__1, &p1[1], &c__1, &best[1], &c__1); ipb[2] = ipb[1] + nn1 + 1; best[ipb[2]] = 1.; ipb[3] = ipb[2] + 1; best[ipb[3]] = 0.; ipb[4] = ipb[3] + 1; best[ipb[4]] = 0.; ipb[5] = ipb[4] + 1; best[ipb[5]] = 1.; ipb[6] = ipb[5] + 1; return 0; L70: best[1] = 1.; ipb[2] = 2; if ((i__1 = nn1 - nn2) < 0) { goto L90; } else if (i__1 == 0) { goto L95; } else { goto L100; } L90: best[ipb[2]] = 1. / p1[1]; ipb[3] = ipb[2] + 1; best[ipb[3]] = 0.; ipb[4] = ipb[3] + 1; i__1 = nn2 + 1; dcopy_(&i__1, &p2[1], &c__1, &best[ipb[4]], &c__1); ipb[5] = ipb[4] + nn2 + 1; best[ipb[5]] = -p1[1]; ipb[6] = ipb[5] + 1; return 0; L95: if ((( p1[1] ) >= 0 ? ( p1[1] ) : -( p1[1] )) > (( p2[1] ) >= 0 ? ( p2[1] ) : -( p2[1] )) ) { goto L90; } L100: best[ipb[2]] = 0.; ipb[3] = ipb[2] + 1; best[ipb[3]] = 1. / p2[1]; ipb[4] = ipb[3] + 1; best[ipb[4]] = -p2[1]; ipb[5] = ipb[4] + 1; i__1 = nn1 + 1; dcopy_(&i__1, &p1[1], &c__1, &best[ipb[5]], &c__1); ipb[6] = ipb[5] + nn1 + 1; return 0; } int residu_(p, np, a, na, b, nb, v, tol, ierr) doublereal *p; integer *np; doublereal *a; integer *na; doublereal *b; integer *nb; doublereal *v, *tol; integer *ierr; { integer i__1, i__2; static integer k; static doublereal r__, b1; extern int idegre_(), dpodiv_(); static integer nbb, nit, npp; --b; --a; --p; *v = 0.; *ierr = 0; npp = *np; idegre_(&a[1], na, na); idegre_(&b[1], nb, nb); if (*na == 0) { return 0; } if (*nb == 0) { b1 = b[1]; if (b1 == 0.) { *ierr = 1; return 0; } if (npp >= *na - 1) { *v = p[*na] / a[*na + 1] / b1; return 0; } else { *v = 0.; return 0; } } if (*na <= *np) { dpodiv_(&p[1], &a[1], np, na); i__1 = *na - 1; idegre_(&p[1], &i__1, np); } if (*na <= *nb) { dpodiv_(&b[1], &a[1], nb, na); i__1 = *na - 1; idegre_(&b[1], &i__1, nb); } if (*na == 1) { b1 = b[1]; if ((( b1 ) >= 0 ? ( b1 ) : -( b1 )) <= *tol) { *ierr = 1; return 0; } *v = p[*na] / a[*na + 1] / b1; return 0; } i__2 = *na - 1; i__1 = (( i__2 ) <= ( *nb ) ? ( i__2 ) : ( *nb )) ; idegre_(&b[1], &i__1, nb); if (*nb == 0) { b1 = b[1]; if ((( b1 ) >= 0 ? ( b1 ) : -( b1 )) <= *tol) { *ierr = 1; return 0; } if (npp >= *na - 1) { *v = p[*na] / a[*na + 1] / b1; return 0; } else { *v = 0.; return 0; } } nit = 0; L20: if (nit >= 1) { *na = nbb; } ++nit; nbb = *nb; dpodiv_(&a[1], &b[1], na, nb); i__1 = *nb - 1; idegre_(&a[1], &i__1, na); dpodiv_(&p[1], &b[1], np, nb); i__1 = *nb - 1; idegre_(&p[1], &i__1, np); i__1 = *nb + 1; for (k = 1; k <= i__1; ++k) { r__ = b[k]; b[k] = -a[k]; a[k] = r__; } idegre_(&b[1], na, nb); if (*nb == 0) { b1 = b[1]; if ((( b1 ) >= 0 ? ( b1 ) : -( b1 )) <= *tol) { *ierr = 1; *v = 0.; return 0; } *v = p[nbb] / a[nbb + 1] / b1; return 0; } goto L20; } int sfact1_(b, n, w, maxit, ierr) doublereal *b; integer *n; doublereal *w; integer *maxit, *ierr; { integer i__1, i__2, i__3; doublereal d__1; double sqrt(), d_lg10(); integer i_dnnt(); static integer leta; static doublereal best, temp; static integer i__, j, k; static doublereal s; static integer lbold, lomeg, lsave; extern int dcopy_(); static doublereal a0, b0, b00; static integer lb, lambda; extern doublereal dlamch_(); static integer lalpha; static doublereal eps; static integer lro; --b; --w; eps = dlamch_("p", 1L) * 10.; lb = *n + 1; *ierr = 0; lomeg = 1; lalpha = lomeg + lb; lro = lalpha + lb; leta = lro + lb; lbold = leta + lb; lambda = lbold + lb; lsave = lambda + lb; dcopy_(&lb, &b[1], &c_n1, &w[lbold], &c__1); dcopy_(&lb, &w[lbold], &c__1, &b[1], &c__1); b00 = w[lbold]; if (b00 <= 0.) { goto L91; } b0 = sqrt(b00); i__1 = lb; for (j = 1; j <= i__1; ++j) { w[lalpha - 1 + j] = b[j] / b0; } i__1 = *maxit; for (i__ = 1; i__ <= i__1; ++i__) { dcopy_(&lb, &w[lbold], &c__1, &b[1], &c__1); dcopy_(&lb, &w[lalpha], &c__1, &w[lomeg], &c__1); i__2 = lb - 1; for (k = 1; k <= i__2; ++k) { i__3 = lb - k + 1; dcopy_(&i__3, &w[lalpha], &c_n1, &w[lro], &c__1); w[lambda + k - 1] = w[lalpha + lb - k] / w[lro + lb - k]; i__3 = lb - k; for (j = 1; j <= i__3; ++j) { w[lalpha - 1 + j] -= w[lambda + k - 1] * w[lro + j - 1]; } a0 = w[lalpha]; w[leta + lb - k] = b[lb - k + 1] * 2. / a0; if (k < lb - 1) { i__3 = lb - k; for (j = 2; j <= i__3; ++j) { b[j] -= w[leta + lb - k] * .5 * w[lalpha + lb - k - j + 1] ; } } } w[leta] = b[1] / w[lalpha]; for (k = lb - 1; k >= 1; --k) { i__2 = lb - k + 1; dcopy_(&i__2, &w[leta], &c_n1, &b[1], &c__1); i__2 = lb - k + 1; for (j = 1; j <= i__2; ++j) { w[leta + j - 1] -= w[lambda + k - 1] * b[j]; } } s = 0.; i__2 = lb; for (j = 1; j <= i__2; ++j) { w[lalpha - 1 + j] = (w[leta + j - 1] + w[lomeg + j - 1]) * .5; s += w[lalpha - 1 + j] * w[lalpha - 1 + j]; } temp = (d__1 = s - b00, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / b00; if (temp <= eps) { goto L50; } if (i__ == 1) { best = temp; } if (temp < best) { dcopy_(&lb, &w[lalpha], &c__1, &w[lsave], &c__1); best = temp; } } goto L90; L50: i__1 = lb; for (i__ = 1; i__ <= i__1; ++i__) { b[i__] = w[lalpha - 1 + i__]; } return 0; L90: if (best <= .001) { dcopy_(&lb, &w[lsave], &c__1, &b[1], &c__1); d__1 = d_lg10(&best); *ierr = i_dnnt(&d__1); } else { *ierr = 1; } return 0; L91: *ierr = 2; return 0; } int sfact2_(b, l, n, matg, maxit, ierr) doublereal *b; integer *l, *n; doublereal *matg; integer *maxit, *ierr; { integer b_dim1, b_offset, i__1, i__2, i__3, i__4; doublereal d__1; double sqrt(); static integer iter, j, k, p, q, r__; static doublereal sigma; static integer k0, j1, j2, jj, q22, kk, id0; static doublereal tr1, tr2, acu; static integer nel; b_dim1 = *l; b_offset = b_dim1 + 1; b -= b_offset; --matg; p = *n * *l; q = p + *l; q22 = (q << 1) + 2; nel = q * (q + 1) / 2; i__1 = nel; for (j = 1; j <= i__1; ++j) { matg[j] = 0.; } i__1 = q; for (j = p + 1; j <= i__1; ++j) { i__2 = q; for (r__ = j; r__ <= i__2; ++r__) { matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2] = b[r__ - p + (j - p) * b_dim1]; } } id0 = p + 1; k0 = p; iter = 0; j = p; goto L20; L10: i__2 = p; for (j = id0; j <= i__2; ++j) { j1 = (j - 1) / *l; j2 = j - j1 * *l; jj = (*n - j1) * *l + j2; if (matg[j - j + 1 + (q22 - j) * (j - 1) / 2] == 0.) { goto L60; } i__1 = q; for (r__ = p + 1; r__ <= i__1; ++r__) { sigma = 0.; if (j == id0) { goto L12; } i__3 = j - 1; for (k = id0; k <= i__3; ++k) { sigma += matg[j - k + 1 + (q22 - k) * (k - 1) / 2] * matg[r__ - k + 1 + (q22 - k) * (k - 1) / 2]; } L12: matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2] = (b[r__ - p + jj * b_dim1] - sigma) / matg[j - j + 1 + (q22 - j) * (j - 1) / 2]; } } i__2 = q; for (j = p + 1; j <= i__2; ++j) { i__1 = q; for (r__ = j; r__ <= i__1; ++r__) { sigma = 0.; i__3 = p; for (k = id0; k <= i__3; ++k) { sigma += matg[r__ - k + 1 + (q22 - k) * (k - 1) / 2] * matg[j - k + 1 + (q22 - k) * (k - 1) / 2]; } matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2] = b[r__ - p + (j - p) * b_dim1] - sigma; } } L20: i__2 = q; for (j = p + 1; j <= i__2; ++j) { sigma = matg[j - j + 1 + (q22 - j) * (j - 1) / 2]; if (j == p + 1) { goto L22; } i__1 = j - 1; for (k = p + 1; k <= i__1; ++k) { sigma -= matg[j - k + 1 + (q22 - k) * (k - 1) / 2] * matg[j - k + 1 + (q22 - k) * (k - 1) / 2]; } L22: if (sigma <= 0.) { goto L60; } matg[j - j + 1 + (q22 - j) * (j - 1) / 2] = sqrt(sigma); if (j == q) { goto L26; } i__1 = q; for (r__ = j + 1; r__ <= i__1; ++r__) { sigma = matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2]; if (j == p + 1) { goto L24; } i__3 = j - 1; for (k = p + 1; k <= i__3; ++k) { sigma -= matg[j - k + 1 + (q22 - k) * (k - 1) / 2] * matg[r__ - k + 1 + (q22 - k) * (k - 1) / 2]; } L24: matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2] = sigma / matg[j - j + 1 + (q22 - j) * (j - 1) / 2]; } L26: ; } if (*n == 0) { goto L50; } tr2 = 0.; i__2 = q; for (jj = p + 1; jj <= i__2; ++jj) { tr2 += matg[jj - jj + 1 + (q22 - jj) * (jj - 1) / 2]; } if (iter == 1) { goto L40; } acu = (d__1 = tr1 - tr2, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); if (acu + (( tr2 ) >= 0 ? ( tr2 ) : -( tr2 )) <= (( tr2 ) >= 0 ? ( tr2 ) : -( tr2 )) ) { goto L50; } if (iter >= *maxit) { goto L50; } L40: i__2 = id0 - *l; id0 = (( i__2 ) >= ( 1 ) ? ( i__2 ) : ( 1 )) ; i__2 = p; for (jj = id0; jj <= i__2; ++jj) { i__1 = jj; for (kk = id0; kk <= i__1; ++kk) { i__3 = jj + *l; i__4 = kk + *l; matg[jj - kk + 1 + (q22 - kk) * (kk - 1) / 2] = matg[i__3 - i__4 + 1 + (q22 - i__4) * (i__4 - 1) / 2]; } } tr1 = tr2; ++iter; goto L10; L50: i__1 = *l; for (r__ = 1; r__ <= i__1; ++r__) { i__2 = *l; for (j = r__; j <= i__2; ++j) { b[r__ + j * b_dim1] = 0.; i__3 = p + j; i__4 = p + r__; b[j + r__ * b_dim1] = matg[i__3 - i__4 + 1 + (q22 - i__4) * (i__4 - 1) / 2]; } if (*n == 0) { goto L53; } i__3 = q; for (j = *l + 1; j <= i__3; ++j) { j1 = (j - 1) / *l; j2 = j - j1 * *l; jj = (*n - j1) * *l + j2; i__4 = p + r__; b[r__ + j * b_dim1] = matg[i__4 - jj + 1 + (q22 - jj) * (jj - 1) / 2]; } L53: ; } *ierr = 0; if (iter >= *maxit) { *ierr = -1; } return 0; L60: *ierr = 1; return 0; } int strdsp_(mat, d__, lig, col, ll, lunit, iw, cw, cw_len) integer *mat, *d__, *lig, *col, *ll, *lunit, *iw; char *cw; ftnlen cw_len; { static integer nind = 5; address a__1[2], a__2[4]; integer i__1, i__2, i__3, i__4[2], i__5[4], i__6, i__7; char ch__1[15], ch__2[24]; icilist ici__1; integer s_wsfi(), do_fio(), e_wsfi(); int s_cat(), s_copy(); static integer lcol, i__, k, l, lbloc, nbloc, lines, c1, k0, k1, k2, l1, l0; extern int cvstr_(); static integer ib; static char dl[1]; static integer il, io, lp, sk, sl, np, indent; extern int basout_(); static integer ll1, np1, ldg, lgh; --iw; --d__; --mat; *(unsigned char *)dl = ' '; if (*lig * *col > 1) { *(unsigned char *)dl = '!'; } lcol = 1; lines = 0; lbloc = lcol + *col - 1; nbloc = 1; iw[lbloc + nbloc] = *col; sk = 0; if (*col == 0 || *lig == 0) { return 0; } l = 1; k0 = 1; i__1 = *col; for (k = 1; k <= i__1; ++k) { sl = 0; iw[k] = 0; i__2 = *lig; for (i__ = 1; i__ <= i__2; ++i__) { lgh = d__[l + 1] - d__[l] + 2; i__3 = iw[k]; iw[k] = (( i__3 ) >= ( lgh ) ? ( i__3 ) : ( lgh )) ; sl = sl + lgh / (*ll - 2) + 1; ++l; } sk += iw[k]; if (sk > *ll - 2) { if (k == k0) { iw[lbloc + nbloc] = k; sk = 0; k0 = k + 1; } else { iw[lbloc + nbloc] = k - 1; sk = iw[k]; k0 = k; } ++nbloc; iw[lbloc + nbloc] = *col; } } nbloc = (( nbloc ) <= ( *col ) ? ( nbloc ) : ( *col )) ; k1 = 1; i__1 = nbloc; for (ib = 1; ib <= i__1; ++ib) { k2 = iw[lbloc + ib]; ll1 = 0; if (nbloc != 1) { if (k1 == k2) { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 4; ici__1.iciunit = cw; ici__1.icifmt = "(i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__4[0] = 11, a__1[0] = " column "; i__4[1] = 4, a__1[1] = cw; s_cat(ch__1, a__1, i__4, &c__2, 15L); basout_(&io, lunit, ch__1, 15L); } else { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 8; ici__1.iciunit = cw; ici__1.icifmt = "(2i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__5[0] = 12, a__2[0] = " columns "; i__5[1] = 4, a__2[1] = cw; i__5[2] = 4, a__2[2] = " to "; i__5[3] = 4, a__2[3] = cw + 4; s_cat(ch__2, a__2, i__5, &c__4, 24L); basout_(&io, lunit, ch__2, 24L); basout_(&io, lunit, " ", 1L); } if (io == -1) { goto L99; } } *(unsigned char *)cw = *(unsigned char *)dl; c1 = 2; i__2 = *lig; for (l = 1; l <= i__2; ++l) { l1 = c1; i__3 = k2; for (k = k1; k <= i__3; ++k) { l0 = l1; ldg = (k - 1) * *lig + l; lp = d__[ldg]; np = d__[ldg + 1] - d__[ldg]; ll1 = 0; indent = 0; L40: i__6 = np, i__7 = *ll - 2 - indent; np1 = (( i__6 ) <= ( i__7 ) ? ( i__6 ) : ( i__7 )) ; cvstr_(&np1, &mat[lp], cw + (l1 - 1), &c__1, l1 + np1 - 1 - ( l1 - 1)); l1 += np1; if (np1 != np) { ll1 = *ll; if (l1 <= *ll - 1) { s_copy(cw + (l1 - 1), " ", *ll - 1 - (l1 - 1), 1L); } *(unsigned char *)&cw[*ll - 1] = *(unsigned char *)dl; i__6 = c1 - 2; basout_(&io, lunit, cw + i__6, *ll - i__6); if (io == -1) { goto L99; } s_copy(cw + (c1 - 1), " ", c1 + nind - 1 - (c1 - 1), 1L); l1 = c1 + nind; indent = nind; lp += np1; np -= np1; if (np > 0) { goto L40; } } i__6 = iw[k], i__7 = *ll - 2; il = (( i__6 ) <= ( i__7 ) ? ( i__6 ) : ( i__7 )) ; if (l0 + il >= l1) { s_copy(cw + (l1 - 1), " ", l0 + il - (l1 - 1), 1L); l1 = l0 + il; } } if (ll1 == *ll) { if (l1 <= *ll) { s_copy(cw + (l1 - 1), " ", *ll - (l1 - 1), 1L); l1 = *ll; } } *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; i__3 = c1 - 2; basout_(&io, lunit, cw + i__3, l1 - i__3); if (io == -1) { goto L99; } if (l != *lig) { s_copy(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 2L); i__3 = c1 - 2; basout_(&io, lunit, cw + i__3, l1 - i__3); if (io == -1) { goto L99; } } } k1 = k2 + 1; } L99: return 0; } int wdmpad_(pm1r, pm1i, d1, l1, pm2r, d2, l2, pm3r, pm3i, d3, m, n) doublereal *pm1r, *pm1i; integer *d1, *l1; doublereal *pm2r; integer *d2, *l2; doublereal *pm3r, *pm3i; integer *d3, *m, *n; { integer i__1, i__2, i__3; static integer i__, j, k, i1, i2, k1, n1, n2, n3, k3, k2, mn; --d3; --pm3i; --pm3r; --d2; --pm2r; --d1; --pm1i; --pm1r; mn = *m * *n; d3[1] = 1; i1 = -(*l1); i2 = -(*l2); k3 = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { i1 += *l1; i2 += *l2; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { k1 = d1[i1 + i__] - 1; k2 = d2[i2 + i__] - 1; n1 = d1[i1 + i__ + 1] - d1[i1 + i__]; n2 = d2[i2 + i__ + 1] - d2[i2 + i__]; if (n1 > n2) { goto L15; } i__3 = n1; for (k = 1; k <= i__3; ++k) { pm3r[k3 + k] = pm1r[k1 + k] + pm2r[k2 + k]; pm3i[k3 + k] = pm1i[k1 + k]; } if (n1 == n2) { goto L14; } n3 = n1 + 1; i__3 = n2; for (k = n3; k <= i__3; ++k) { pm3r[k3 + k] = pm2r[k2 + k]; pm3i[k3 + k] = 0.; } L14: n3 = n2; d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3; goto L18; L15: i__3 = n2; for (k = 1; k <= i__3; ++k) { pm3r[k3 + k] = pm1r[k1 + k] + pm2r[k2 + k]; pm3i[k3 + k] = pm1i[k1 + k]; } n3 = n2 + 1; i__3 = n1; for (k = n3; k <= i__3; ++k) { pm3r[k3 + k] = pm1r[k1 + k]; pm3i[k3 + k] = pm1i[k1 + k]; } n3 = n1; d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3; L18: k1 += n1; k2 += n2; k3 += n3; } } return 0; } int wdmpmu_(mp1r, mp1i, d1, nl1, mp2r, d2, nl2, mp3r, mp3i, d3, l, m, n) doublereal *mp1r, *mp1i; integer *d1, *nl1; doublereal *mp2r; integer *d2, *nl2; doublereal *mp3r, *mp3i; integer *d3, *l, *m, *n; { integer i__1, i__2, i__3; static integer i__, j, k; extern int dpmul_(); static integer k1, k2, k3, p1, p2, p3, kk; --d3; --mp3i; --mp3r; --d2; --mp2r; --d1; --mp1i; --mp1r; d3[1] = 1; if (*l == 0 || *m == 0 || *n == 0) { goto L500; } p2 = -(*nl2); p3 = -(*l); i__1 = *n; for (j = 1; j <= i__1; ++j) { p2 += *nl2; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { mp3r[d3[p3 + i__]] = 0.; mp3i[d3[p3 + i__]] = 0.; k3 = 0; p1 = i__ - *nl1; i__3 = *m; for (k = 1; k <= i__3; ++k) { p1 += *nl1; k2 = d2[p2 + k + 1] - d2[p2 + k] - 1; k1 = d1[p1 + 1] - d1[p1] - 1; kk = k3; dpmul_(&mp1r[d1[p1]], &k1, &mp2r[d2[p2 + k]], &k2, &mp3r[d3[ p3 + i__]], &kk); dpmul_(&mp1i[d1[p1]], &k1, &mp2r[d2[p2 + k]], &k2, &mp3i[d3[ p3 + i__]], &k3); } d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L500: if (*l == 0) { goto L600; } if (*m == 0) { goto L700; } p1 = -(*nl1); p3 = -(*l); k2 = d2[2] - d2[1] - 1; i__1 = *m; for (j = 1; j <= i__1; ++j) { p1 += *nl1; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { k3 = 0; k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; kk = k3; dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2r[1], &k2, &mp3r[d3[p3 + i__] ], &kk); mp3i[d3[p3 + i__]] = 0.; dpmul_(&mp1i[d1[p1 + i__]], &k1, &mp2r[1], &k2, &mp3i[d3[p3 + i__] ], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L600: k1 = d1[2] - d1[1] - 1; p2 = -(*nl2); p3 = -(*m); i__2 = *n; for (j = 1; j <= i__2; ++j) { p2 += *nl2; p3 += *m; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { k3 = 0; k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; kk = k3; dpmul_(&mp1r[1], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3r[d3[p3 + i__] ], &kk); mp3i[d3[p3 + i__]] = 0.; dpmul_(&mp1i[1], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3i[d3[p3 + i__] ], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L700: p1 = -(*nl1); p2 = -(*nl2); p3 = -(*l); i__1 = *n; for (j = 1; j <= i__1; ++j) { p1 += *nl1; p2 += *nl2; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1; k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; k3 = 0; dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3r[ d3[p3 + i__]], &k3); mp3i[d3[p3 + i__]] = 0.; k3 = 0; dpmul_(&mp1i[d1[p1 + i__]], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3i[ d3[p3 + i__]], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; } int wmdsp_(xr, xi, nx, m, n, maxc, mode, ll, lunit, cw, iw, cw_len) doublereal *xr, *xi; integer *nx, *m, *n, *maxc, *mode, *ll, *lunit; char *cw; integer *iw; ftnlen cw_len; { static char fmt_130[] = "(\002(1pd\002,i2,\002.\002,i2,\002)\002)"; static char fmt_120[] = "(\002(f\002,i2,\002.\002,i2,\002)\002)"; address a__1[2], a__2[4]; integer i__1, i__2, i__3, i__4[2], i__5[4], i__6; doublereal d__1, d__2; char ch__1[20], ch__2[27]; icilist ici__1; int s_copy(); integer s_wsfi(), do_fio(), e_wsfi(); double d_lg10(), pow_di(); int s_cat(); integer s_cmp(); static integer ldef; static doublereal fact; static integer imin, imax, ifmt; static char form[10*2]; static integer lvar; static doublereal a; static integer i__, j, k, l, s, lbloc, nbloc; static doublereal a1, a2; static integer k1, k2, l1, n1, n2, l0, ib; static char dl[1]; static integer fl, lf, nf, li, io, lp; extern int basout_(); static integer nl1, lgh; extern int fmt_(); static char sgn[1], var[4]; static integer typ; static icilist io___3861 = { 0, form, 0, fmt_130, 10, 1 }; --iw; --xi; --xr; s_copy(var, "i", 4L, 1L); lvar = 1; s_copy(cw, " ", cw_len, 1L); s_wsfi(&io___3861); do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer)); i__1 = *maxc - 7; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfi(); *(unsigned char *)dl = ' '; if (*m * *n > 1) { *(unsigned char *)dl = '!'; } fact = 1.; if (*m * *n == 1) { goto L2; } a1 = 0.; a2 = (( xr[1] ) >= 0 ? ( xr[1] ) : -( xr[1] )) + (( xi[1] ) >= 0 ? ( xi[1] ) : -( xi[1] )) ; l = -(*nx); i__1 = *n; for (j = 1; j <= i__1; ++j) { l += *nx; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { a = (d__1 = xr[l + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = xi[l + i__], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ); if (a == 0.) { goto L1; } a1 = (( a1 ) >= ( a ) ? ( a1 ) : ( a )) ; a2 = (( a2 ) <= ( a ) ? ( a2 ) : ( a )) ; L1: ; } } imax = 0; imin = 0; if (a1 > 0.) { imax = (integer) d_lg10(&a1); } if (a2 > 0.) { imin = (integer) d_lg10(&a2); } if (imax * imin <= 0) { goto L2; } imax = (imax + imin) / 2; if ((( imax ) >= 0 ? ( imax ) : -( imax )) >= *maxc - 2) { i__2 = -imax; fact = pow_di(&c_b8137, &i__2); } L2: lbloc = *n; lf = lbloc + 1 + *n; nbloc = 1; iw[lbloc + nbloc] = *n; s = 0; lp = -(*nx); ldef = lf; i__2 = *n; for (k = 1; k <= i__2; ++k) { lp += *nx; iw[k] = 0; i__1 = *m; for (l = 1; l <= i__1; ++l) { lgh = 0; for (i__ = 1; i__ <= 2; ++i__) { a = xr[lp + l] * fact; if (i__ == 2) { a = xi[lp + l] * fact; } iw[ldef] = 0; if (a == 0.) { goto L10; } typ = 1; if (*mode == 1) { d__1 = (( a ) >= 0 ? ( a ) : -( a )) ; fmt_(&d__1, maxc, &typ, &n1, &n2); } if (typ == 2) { fl = n1; iw[ldef] = n2 + (n1 << 5); } else if (typ < 0) { iw[ldef] = typ; fl = 3; } else { iw[ldef] = 1; fl = *maxc; n2 = *maxc - 7; } lgh = fl + 2 + lgh; L10: ++ldef; } if (iw[ldef - 1] != 0) { lgh += lvar; } if (lgh == 0) { lgh = 4; } ++lgh; i__3 = iw[k]; iw[k] = (( i__3 ) >= ( lgh ) ? ( i__3 ) : ( lgh )) ; } s += iw[k]; if (s > *ll - 2) { iw[lbloc + nbloc] = k - 1; ++nbloc; iw[lbloc + nbloc] = *n; s = iw[k]; } } if (fact != 1.) { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 12; ici__1.iciunit = cw; ici__1.icifmt = "(1x,1pd9.1,' *')"; s_wsfi(&ici__1); d__1 = 1. / fact; do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal)); e_wsfi(); basout_(&io, lunit, cw, 12L); basout_(&io, lunit, " ", 1L); if (io == -1) { goto L99; } } k1 = 1; i__2 = nbloc; for (ib = 1; ib <= i__2; ++ib) { k2 = iw[lbloc + ib]; if (nbloc != 1) { if (k1 == k2) { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 4; ici__1.iciunit = cw; ici__1.icifmt = "(i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__4[0] = 16, a__1[0] = " column "; i__4[1] = 4, a__1[1] = cw; s_cat(ch__1, a__1, i__4, &c__2, 20L); basout_(&io, lunit, ch__1, 20L); } else { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 8; ici__1.iciunit = cw; ici__1.icifmt = "(2i4)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer)); e_wsfi(); basout_(&io, lunit, " ", 1L); i__5[0] = 16, a__2[0] = " columns "; i__5[1] = 4, a__2[1] = cw; i__5[2] = 3, a__2[2] = " to"; i__5[3] = 4, a__2[3] = cw + 4; s_cat(ch__2, a__2, i__5, &c__4, 27L); basout_(&io, lunit, ch__2, 27L); basout_(&io, lunit, " ", 1L); } basout_(&io, lunit, " ", 1L); if (io == -1) { goto L99; } } *(unsigned char *)cw = *(unsigned char *)dl; i__1 = *m; for (l = 1; l <= i__1; ++l) { ldef = lf + (l - 1 + (k1 - 1) * *m << 1); l1 = 2; i__3 = k2; for (k = k1; k <= i__3; ++k) { lp = (k - 1) * *nx + l; li = (k - 1) * *m + l; l0 = l1; for (i__ = 1; i__ <= 2; ++i__) { ifmt = iw[ldef + i__ - 1]; if (ifmt == 0) { goto L42; } a = xr[lp]; if (i__ == 2) { a = xi[lp]; } *(unsigned char *)sgn = ' '; if (i__ == 2 && iw[ldef] != 0) { *(unsigned char *)sgn = '+'; } if (a < 0.) { *(unsigned char *)sgn = '-'; } a = (( a ) >= 0 ? ( a ) : -( a )) * fact; a = (( a ) >= 0 ? ( a ) : -( a )) ; i__4[0] = 1, a__1[0] = " "; i__4[1] = 1, a__1[1] = sgn; s_cat(cw + (l1 - 1), a__1, i__4, &c__2, 2L); l1 += 2; if (ifmt == 1) { nf = 1; fl = *maxc; n2 = 1; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = l1 + fl - 1 - (l1 - 1); ici__1.iciunit = cw + (l1 - 1); ici__1.icifmt = form + (nf - 1) * 10; s_wsfi(&ici__1); do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal)); e_wsfi(); } else if (ifmt >= 0) { nf = 2; n1 = ifmt / 32; n2 = ifmt - (n1 << 5); fl = n1; ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 10; ici__1.iciunit = form + (nf - 1) * 10; ici__1.icifmt = fmt_120; s_wsfi(&ici__1); do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer)); e_wsfi(); ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = l1 + fl - 1 - (l1 - 1); ici__1.iciunit = cw + (l1 - 1); ici__1.icifmt = form + (nf - 1) * 10; s_wsfi(&ici__1); do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal)); e_wsfi(); } else if (ifmt == -1) { fl = 3; s_copy(cw + (l1 - 1), "Inf", l1 + fl - 1 - (l1 - 1), 3L); } else if (ifmt == -2) { fl = 3; s_copy(cw + (l1 - 1), "Nan", l1 + fl - 1 - (l1 - 1), 3L); } l1 += fl; L42: ; } if (iw[ldef + 1] == 0) { goto L43; } i__6 = l1 - 3; if (fl == 3 && s_cmp(cw + i__6, "1.", l1 - 1 - i__6, 2L) == 0) { l1 += -2; } s_copy(cw + (l1 - 1), var, l1 - 1 + lvar - (l1 - 1), lvar); l1 += lvar; goto L44; L43: if (iw[ldef] != 0) { goto L44; } s_copy(cw + (l1 - 1), " 0.", 4L, 5L); l1 += 4; L44: nl1 = l0 + iw[k] - 1; s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L); l1 = nl1 + 1; ldef += *m << 1; } *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl; basout_(&io, lunit, cw, l1); if (io == -1) { goto L99; } } k1 = k2 + 1; } L99: return 0; } int wmpad_(pm1r, pm1i, d1, l1, pm2r, pm2i, d2, l2, pm3r, pm3i, d3, m, n) doublereal *pm1r, *pm1i; integer *d1, *l1; doublereal *pm2r, *pm2i; integer *d2, *l2; doublereal *pm3r, *pm3i; integer *d3, *m, *n; { integer i__1, i__2, i__3; static integer i__, j, k, i1, i2, k1, n1, n2, n3, k3, k2, mn; --d3; --pm3i; --pm3r; --d2; --pm2i; --pm2r; --d1; --pm1i; --pm1r; mn = *m * *n; d3[1] = 1; i1 = -(*l1); i2 = -(*l2); k3 = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { i1 += *l1; i2 += *l2; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { k1 = d1[i1 + i__] - 1; k2 = d2[i2 + i__] - 1; n1 = d1[i1 + i__ + 1] - d1[i1 + i__]; n2 = d2[i2 + i__ + 1] - d2[i2 + i__]; if (n1 > n2) { goto L15; } i__3 = n1; for (k = 1; k <= i__3; ++k) { pm3r[k3 + k] = pm1r[k1 + k] + pm2r[k2 + k]; pm3i[k3 + k] = pm1i[k1 + k] + pm2i[k2 + k]; } if (n1 == n2) { goto L14; } n3 = n1 + 1; i__3 = n2; for (k = n3; k <= i__3; ++k) { pm3r[k3 + k] = pm2r[k2 + k]; pm3i[k3 + k] = pm2i[k2 + k]; } L14: n3 = n2; d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3; goto L18; L15: i__3 = n2; for (k = 1; k <= i__3; ++k) { pm3r[k3 + k] = pm1r[k1 + k] + pm2r[k2 + k]; pm3i[k3 + k] = pm1i[k1 + k] + pm2i[k2 + k]; } n3 = n2 + 1; i__3 = n1; for (k = n3; k <= i__3; ++k) { pm3r[k3 + k] = pm1r[k1 + k]; pm3i[k3 + k] = pm1i[k1 + k]; } n3 = n1; d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3; L18: k1 += n1; k2 += n2; k3 += n3; } } return 0; } int wmpadj_(pm1r, pm1i, d1, m, n) doublereal *pm1r, *pm1i; integer *d1, *m, *n; { integer i__1; doublereal d__1, d__2; static integer j; extern int dcopy_(); static integer k1, n1, dj, kk; --d1; --pm1i; --pm1r; kk = 1; dj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { k1 = dj - 1; n1 = d1[j + 1] - dj + 1; L10: --n1; if ((d__1 = pm1r[k1 + n1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = pm1i[k1 + n1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) == 0. && n1 > 1) { goto L10; } if (kk != k1 + 1) { dcopy_(&n1, &pm1r[k1 + 1], &c__1, &pm1r[kk], &c__1); dcopy_(&n1, &pm1i[k1 + 1], &c__1, &pm1i[kk], &c__1); } kk += n1; dj = d1[j + 1]; d1[j + 1] = kk; } return 0; } int wmpcle_(pm1r, pm1i, d1, m, n, d2, epsr, epsa) doublereal *pm1r, *pm1i; integer *d1, *m, *n, *d2; doublereal *epsr, *epsa; { integer i__1, i__2; doublereal d__1, d__2; static integer lmin, lmax; static doublereal norm; static integer k, l; static doublereal normi, normr; static integer mn; static doublereal eps; --d2; --d1; --pm1i; --pm1r; mn = *m * *n; i__1 = mn; for (k = 1; k <= i__1; ++k) { lmin = d1[k]; lmax = d1[k + 1] - 1; normr = 0.; normi = 0.; i__2 = lmax; for (l = lmin; l <= i__2; ++l) { normr += (d__1 = pm1r[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); normi += (d__1 = pm1i[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ); norm = normr + normi; } d__1 = *epsa, d__2 = *epsr * norm; eps = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ; i__2 = lmax; for (l = lmin; l <= i__2; ++l) { if ((d__1 = pm1r[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps) { pm1r[l] = 0.; } if ((d__1 = pm1i[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps) { pm1i[l] = 0.; } } } return 0; } int wmpcnc_(mp1r, mp1i, d1, ld1, mp2r, mp2i, d2, ld2, mp3r, mp3i, d3, l, m, n, job) doublereal *mp1r, *mp1i; integer *d1, *ld1; doublereal *mp2r, *mp2i; integer *d2, *ld2; doublereal *mp3r, *mp3i; integer *d3, *l, *m, *n, *job; { integer i__1, i__2; extern int dset_(); static integer i__, j; extern int dcopy_(); static integer i1, i2, i3, np; --d3; --mp3i; --mp3r; --d2; --mp2i; --mp2r; --d1; --mp1i; --mp1r; i3 = 1; d3[1] = 1; i1 = 1 - *ld1; i2 = 1 - *ld2; if (*job < 0) { goto L30; } i__1 = *m; for (j = 1; j <= i__1; ++j) { i1 += *ld1; np = d1[i1 + *l] - d1[i1]; dcopy_(&np, &mp1r[d1[i1]], &c__1, &mp3r[d3[i3]], &c__1); if (*job != 2) { dcopy_(&np, &mp1i[d1[i1]], &c__1, &mp3i[d3[i3]], &c__1); } if (*job == 2) { dset_(&np, &c_b61, &mp3i[d3[i3]], &c__1); } i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1]; } } i__1 = *n; for (j = 1; j <= i__1; ++j) { i2 += *ld2; np = d2[i2 + *l] - d2[i2]; dcopy_(&np, &mp2r[d2[i2]], &c__1, &mp3r[d3[i3]], &c__1); if (*job != 3) { dcopy_(&np, &mp2i[d2[i2]], &c__1, &mp3i[d3[i3]], &c__1); } if (*job == 3) { dset_(&np, &c_b61, &mp3i[d3[i3]], &c__1); } i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1]; } } return 0; L30: i__1 = *n; for (j = 1; j <= i__1; ++j) { i1 += *ld1; i2 += *ld2; np = d1[i1 + *l] - d1[i1]; dcopy_(&np, &mp1r[d1[i1]], &c__1, &mp3r[d3[i3]], &c__1); if (*job != -2) { dcopy_(&np, &mp1i[d1[i1]], &c__1, &mp3i[d3[i3]], &c__1); } if (*job == -2) { dset_(&np, &c_b61, &mp3i[d3[i3]], &c__1); } i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1]; } np = d2[i2 + *m] - d2[i2]; dcopy_(&np, &mp2r[d2[i2]], &c__1, &mp3r[d3[i3]], &c__1); if (*job != -3) { dcopy_(&np, &mp2i[d2[i2]], &c__1, &mp3i[d3[i3]], &c__1); } if (*job == -3) { dset_(&np, &c_b61, &mp3i[d3[i3]], &c__1); } i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { ++i3; d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1]; } } return 0; } int wmpins_(mat1r, mat1i, dep1, lig1, col1, mat2r, mat2i, dep2, lig2, col2, matrr, matri, depr, ligr, colr) doublereal *mat1r, *mat1i; integer *dep1, *lig1, *col1; doublereal *mat2r, *mat2i; integer *dep2, *lig2, *col2; doublereal *matrr, *matri; integer *depr, *ligr, *colr; { integer i__1, i__2; static integer i__, j, l; extern int dcopy_(); static integer l1, l2, kr, lr; --depr; --matri; --matrr; --dep2; --mat2i; --mat2r; --dep1; --mat1i; --mat1r; depr[1] = 1; kr = 1; i__1 = *colr; for (j = 1; j <= i__1; ++j) { i__2 = *ligr; for (i__ = 1; i__ <= i__2; ++i__) { ++kr; lr = depr[kr]; if (lr < 0) { goto L11; } else if (lr == 0) { goto L12; } else { goto L13; } L11: l2 = -lr; l = dep2[l2 + 1] - dep2[l2]; dcopy_(&l, &mat2r[dep2[l2]], &c__1, &matrr[depr[kr - 1]], &c__1); dcopy_(&l, &mat2i[dep2[l2]], &c__1, &matri[depr[kr - 1]], &c__1); depr[kr] = depr[kr - 1] + l; goto L20; L12: matrr[depr[kr - 1]] = 0.; matri[depr[kr - 1]] = 0.; depr[kr] = depr[kr - 1] + 1; goto L20; L13: l1 = lr; l = dep1[l1 + 1] - dep1[l1]; dcopy_(&l, &mat1r[dep1[l1]], &c__1, &matrr[depr[kr - 1]], &c__1); dcopy_(&l, &mat1i[dep1[l1]], &c__1, &matri[depr[kr - 1]], &c__1); depr[kr] = depr[kr - 1] + l; L20: ; } } return 0; } int wmpmu_(mp1r, mp1i, d1, nl1, mp2r, mp2i, d2, nl2, mp3r, mp3i, d3, l, m, n) doublereal *mp1r, *mp1i; integer *d1, *nl1; doublereal *mp2r, *mp2i; integer *d2, *nl2; doublereal *mp3r, *mp3i; integer *d3, *l, *m, *n; { integer i__1, i__2, i__3; static integer i__, j, k, k1, k2, k3, p1, p2, p3; extern int wpmul_(); --d3; --mp3i; --mp3r; --d2; --mp2i; --mp2r; --d1; --mp1i; --mp1r; d3[1] = 1; if (*l == 0 || *m == 0 || *n == 0) { goto L500; } p2 = -(*nl2); p3 = -(*l); i__1 = *n; for (j = 1; j <= i__1; ++j) { p2 += *nl2; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { mp3r[d3[p3 + i__]] = 0.; mp3i[d3[p3 + i__]] = 0.; k3 = 0; p1 = i__ - *nl1; i__3 = *m; for (k = 1; k <= i__3; ++k) { p1 += *nl1; k2 = d2[p2 + k + 1] - d2[p2 + k] - 1; k1 = d1[p1 + 1] - d1[p1] - 1; wpmul_(&mp1r[d1[p1]], &mp1i[d1[p1]], &k1, &mp2r[d2[p2 + k]], & mp2i[d2[p2 + k]], &k2, &mp3r[d3[p3 + i__]], &mp3i[d3[ p3 + i__]], &k3); } d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L500: if (*l == 0) { goto L600; } if (*m == 0) { goto L700; } p1 = -(*nl1); p3 = -(*l); k2 = d2[2] - d2[1] - 1; i__1 = *m; for (j = 1; j <= i__1; ++j) { p1 += *nl1; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { k3 = 0; k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; mp3i[d3[p3 + i__]] = 0.; wpmul_(&mp1r[d1[p1 + i__]], &mp1i[d1[p1 + i__]], &k1, &mp2r[1], & mp2i[1], &k2, &mp3r[d3[p3 + i__]], &mp3i[d3[p3 + i__]], & k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L600: k1 = d1[2] - d1[1] - 1; p2 = -(*nl2); p3 = -(*m); i__2 = *n; for (j = 1; j <= i__2; ++j) { p2 += *nl2; p3 += *m; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { k3 = 0; k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; mp3i[d3[p3 + i__]] = 0.; wpmul_(&mp1r[1], &mp1i[1], &k1, &mp2r[d2[p2 + i__]], &mp2i[d2[p2 + i__]], &k2, &mp3r[d3[p3 + i__]], &mp3i[d3[p3 + i__]], & k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; L700: p1 = -(*nl1); p2 = -(*nl2); p3 = -(*l); i__1 = *n; for (j = 1; j <= i__1; ++j) { p1 += *nl1; p2 += *nl2; p3 += *l; i__2 = *l; for (i__ = 1; i__ <= i__2; ++i__) { k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1; k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1; mp3r[d3[p3 + i__]] = 0.; mp3i[d3[p3 + i__]] = 0.; k3 = 0; wpmul_(&mp1r[d1[p1 + i__]], &mp1i[d1[p1 + i__]], &k1, &mp2r[d2[p2 + i__]], &mp2i[d2[p2 + i__]], &k2, &mp3r[d3[p3 + i__]], & mp3i[d3[p3 + i__]], &k3); d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1; } } return 0; } int wmptld_(pm1r, pm1i, d1, ld1, pm2r, pm2i, d2, m, n) doublereal *pm1r, *pm1i; integer *d1, *ld1; doublereal *pm2r, *pm2i; integer *d2, *m, *n; { integer i__1, i__2, i__3; doublereal d__1, d__2; extern int dset_(); static integer nmax; static doublereal norm; static integer i__, j; extern int dscal_(), dcopy_(); static integer i1, i2; extern doublereal wasum_(); static integer l1, l2, n1; --d2; --pm2i; --pm2r; --d1; --pm1i; --pm1r; d2[1] = 1; nmax = 0; i2 = 1; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__; i__2 = *n; for (j = 1; j <= i__2; ++j) { l1 = d1[i1]; n1 = d1[i1 + 1] - l1 + 1; i__3 = n1 - 1; norm = wasum_(&i__3, &pm1r[l1], &pm1i[l1], &c__1); L10: --n1; if ((d__1 = pm1r[l1 + n1 - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = pm1i[l1 + n1 - 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + norm <= norm) { goto L10; } i1 += *ld1; ++i2; d2[i2] = n1; nmax = (( nmax ) >= ( n1 ) ? ( nmax ) : ( n1 )) ; } } d2[1] = 1; i2 = 1; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__; i__2 = *n; for (j = 1; j <= i__2; ++j) { n1 = d2[i2 + 1]; l2 = d2[i2]; if (n1 >= nmax) { goto L30; } i__3 = nmax - n1; dset_(&i__3, &c_b61, &pm2r[l2], &c__1); i__3 = nmax - n1; dset_(&i__3, &c_b61, &pm2i[l2], &c__1); L30: dcopy_(&n1, &pm1r[l1], &c__1, &pm2r[l2], &c_n1); dcopy_(&n1, &pm1i[l1], &c__1, &pm2i[l2], &c_n1); i1 += *ld1; ++i2; d2[i2] = l2 + nmax; } } i__1 = d2[*m * *n + 1] - 1; dscal_(&i__1, &c_b418, &pm2i[1], &c__1); return 0; } int wmptra_(pm1r, pm1i, d1, ld1, pm2r, pm2i, d2, m, n) doublereal *pm1r, *pm1i; integer *d1, *ld1; doublereal *pm2r, *pm2i; integer *d2, *m, *n; { integer i__1, i__2; static integer i__, j; extern int dscal_(), dcopy_(); static integer i1, i2, l1, l2, n1; --d2; --pm2i; --pm2r; --d1; --pm1i; --pm1r; d2[1] = 1; i2 = 1; i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { i1 = i__; i__2 = *n; for (j = 1; j <= i__2; ++j) { l1 = d1[i1]; n1 = d1[i1 + 1] - l1; l2 = d2[i2]; dcopy_(&n1, &pm1r[l1], &c__1, &pm2r[l2], &c__1); dcopy_(&n1, &pm1i[l1], &c__1, &pm2i[l2], &c__1); i1 += *ld1; ++i2; d2[i2] = l2 + n1; } } i__1 = d2[*m * *n + 1] - 1; dscal_(&i__1, &c_b418, &pm2i[1], &c__1); return 0; } int wpmul_(p1r, p1i, d1, p2r, p2i, d2, p3r, p3i, d3) doublereal *p1r, *p1i; integer *d1; doublereal *p2r, *p2i; integer *d2; doublereal *p3r, *p3i; integer *d3; { integer i__1, i__2, i__3; static integer dmin__, dmax__; extern doublereal ddot_(); static integer dsum, i__, j, k, l, e1, e2; --p3i; --p3r; --p2i; --p2r; --p1i; --p1r; dsum = *d1 + *d2; dmax__ = *d1; if (*d2 > *d1) { dmax__ = *d2; } dmin__ = dsum - dmax__; if (*d3 >= dsum) { goto L1; } e1 = *d3 + 2; e2 = dsum + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { p3r[i__] = 0.; p3i[i__] = 0.; } *d3 = dsum; L1: if (*d1 == 0 || *d2 == 0) { goto L53; } e1 = 1; e2 = dmin__ + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { p3r[i__] = p3r[i__] + ddot_(&i__, &p1r[1], &c__1, &p2r[1], &c_n1) - ddot_(&i__, &p1i[1], &c__1, &p2i[1], &c_n1); p3i[i__] = p3i[i__] + ddot_(&i__, &p1r[1], &c__1, &p2i[1], &c_n1) + ddot_(&i__, &p1i[1], &c__1, &p2r[1], &c_n1); } k = 1; if (*d1 == *d2) { goto L21; } e1 = dmin__ + 2; e2 = dmax__ + 1; if (*d1 < *d2) { goto L25; } i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { ++k; i__2 = dmin__ + 1; i__3 = dmin__ + 1; p3r[i__] = p3r[i__] + ddot_(&i__2, &p1r[k], &c__1, &p2r[1], &c_n1) - ddot_(&i__3, &p1i[k], &c__1, &p2i[1], &c_n1); i__2 = dmin__ + 1; i__3 = dmin__ + 1; p3i[i__] = p3i[i__] + ddot_(&i__2, &p1r[k], &c__1, &p2i[1], &c_n1) + ddot_(&i__3, &p1i[k], &c__1, &p2r[1], &c_n1); } L21: e1 = dmax__ + 2; e2 = dsum + 1; l = 1; j = dmin__ + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { --j; ++k; ++l; p3r[i__] = p3r[i__] + ddot_(&j, &p1r[k], &c__1, &p2r[l], &c_n1) - ddot_(&j, &p1i[k], &c__1, &p2i[l], &c_n1); p3i[i__] = p3i[i__] + ddot_(&j, &p1r[k], &c__1, &p2i[l], &c_n1) + ddot_(&j, &p1i[k], &c__1, &p2r[l], &c_n1); } return 0; L25: i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { ++k; i__2 = dmin__ + 1; i__3 = dmin__ + 1; p3r[i__] = p3r[i__] + ddot_(&i__2, &p2r[k], &c_n1, &p1r[1], &c__1) - ddot_(&i__3, &p2i[k], &c_n1, &p1i[1], &c__1); i__2 = dmin__ + 1; i__3 = dmin__ + 1; p3i[i__] = p3i[i__] + ddot_(&i__2, &p2r[k], &c_n1, &p1i[1], &c__1) + ddot_(&i__3, &p2i[k], &c_n1, &p1r[1], &c__1); } e1 = dmax__ + 2; e2 = dsum + 1; l = 1; j = dmin__ + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { --j; ++k; ++l; p3r[i__] = p3r[i__] + ddot_(&j, &p1r[l], &c__1, &p2r[k], &c_n1) - ddot_(&j, &p1i[l], &c__1, &p2i[k], &c_n1); p3i[i__] = p3i[i__] + ddot_(&j, &p1r[l], &c__1, &p2i[k], &c_n1) + ddot_(&j, &p1i[l], &c__1, &p2r[k], &c_n1); } return 0; L53: if (*d1 == 0 && *d2 == 0) { goto L100; } e1 = 1; if (*d1 == 0) { goto L60; } e2 = *d1 + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { p3r[i__] = p3r[i__] + p1r[i__] * p2r[1] - p1i[i__] * p2i[1]; p3i[i__] = p3i[i__] + p1r[i__] * p2i[1] + p1i[i__] * p2r[1]; } return 0; L60: e2 = *d2 + 1; i__1 = e2; for (i__ = e1; i__ <= i__1; ++i__) { p3r[i__] = p3r[i__] + p2r[i__] * p1r[1] - p2i[i__] * p1i[1]; p3i[i__] = p3i[i__] + p2r[i__] * p1i[1] + p2i[i__] * p1r[1]; } return 0; L100: p3r[1] = p3r[1] + p1r[1] * p2r[1] - p1i[1] * p2i[1]; p3i[1] = p3i[1] + p1r[1] * p2i[1] + p1i[1] * p2r[1]; return 0; } int wpmul1_(p1r, p1i, d1, p2r, p2i, d2, p3r, p3i) doublereal *p1r, *p1i; integer *d1; doublereal *p2r, *p2i; integer *d2; doublereal *p3r, *p3i; { integer i__1; extern doublereal ddot_(); static integer k, l, d3, l1, l2, l3, m3; static doublereal si, sr; --p3i; --p3r; --p2i; --p2r; --p1i; --p1r; l = 1; l1 = *d1 + 1; l2 = *d2 + 1; d3 = *d1 + *d2; l3 = d3 + 1; m3 = (( l1 ) <= ( l2 ) ? ( l1 ) : ( l2 )) ; i__1 = m3; for (k = 1; k <= i__1; ++k) { sr = ddot_(&l, &p1r[l1], &c__1, &p2r[l2], &c_n1) - ddot_(&l, &p1i[l1], &c__1, &p2i[l2], &c_n1); si = ddot_(&l, &p1r[l1], &c__1, &p2i[l2], &c_n1) + ddot_(&l, &p1i[l1], &c__1, &p2r[l2], &c_n1); p3r[l3] = sr; p3i[l3] = si; ++l; --l3; --l1; --l2; } --l; if (l1 == 0) { goto L30; } m3 = l1; i__1 = m3; for (k = 1; k <= i__1; ++k) { sr = ddot_(&l, &p1r[l1], &c__1, &p2r[1], &c_n1) - ddot_(&l, &p1i[l1], &c__1, &p2i[1], &c_n1); si = ddot_(&l, &p1r[l1], &c__1, &p2i[1], &c_n1) + ddot_(&l, &p1i[l1], &c__1, &p2r[1], &c_n1); p3r[l3] = sr; p3i[l3] = si; --l1; --l3; } goto L40; L30: if (l2 == 0) { goto L40; } m3 = l2; i__1 = m3; for (k = 1; k <= i__1; ++k) { sr = ddot_(&l, &p1r[1], &c__1, &p2r[l2], &c_n1) - ddot_(&l, &p1i[1], & c__1, &p2i[l2], &c_n1); si = ddot_(&l, &p1r[1], &c__1, &p2i[l2], &c_n1) + ddot_(&l, &p1i[1], & c__1, &p2r[l2], &c_n1); p3r[l3] = sr; p3i[l3] = si; --l2; --l3; } L40: if (l3 == 0) { return 0; } m3 = l3; i__1 = m3; for (k = 1; k <= i__1; ++k) { --l; sr = ddot_(&l, &p1r[1], &c__1, &p2r[1], &c_n1) - ddot_(&l, &p1i[1], & c__1, &p2i[1], &c_n1); si = ddot_(&l, &p1r[1], &c__1, &p2i[1], &c_n1) + ddot_(&l, &p1i[1], & c__1, &p2r[1], &c_n1); p3r[l3] = sr; p3i[l3] = si; --l3; } return 0; } int wpodiv_(ar, ai, br, bi, na, nb) doublereal *ar, *ai, *br, *bi; integer *na, *nb; { integer i__1; extern int wdiv_(), wmul_(); static integer i__, l, n, n1, n2; static doublereal qi, wi, qr, wr; static integer nb1; --bi; --br; --ai; --ar; l = *na - *nb + 1; L2: if (l <= 0) { goto L5; } else { goto L3; } L3: n = l + *nb; wdiv_(&ar[n], &ai[n], &br[*nb + 1], &bi[*nb + 1], &qr, &qi); nb1 = *nb + 1; i__1 = nb1; for (i__ = 1; i__ <= i__1; ++i__) { n1 = *nb - i__ + 2; n2 = n - i__ + 1; wmul_(&br[n1], &bi[n1], &qr, &qi, &wr, &wi); ar[n2] -= wr; ai[n2] -= wi; } ar[n] = qr; ai[n] = qi; --l; goto L2; L5: return 0; } int wprxc_(n, rootr, rooti, coeffr, coeffi) integer *n; doublereal *rootr, *rooti, *coeffr, *coeffi; { integer i__1; doublereal d__1, d__2; extern int dset_(); static integer j; extern int waxpy_(); static integer nj; --rooti; --rootr; --coeffr; --coeffi; dset_(n, &c_b61, &coeffr[1], &c__1); i__1 = *n + 1; dset_(&i__1, &c_b61, &coeffi[1], &c__1); coeffr[*n + 1] = 1.; i__1 = *n; for (j = 1; j <= i__1; ++j) { nj = *n + 1 - j; d__1 = -rootr[j]; d__2 = -rooti[j]; waxpy_(&j, &d__1, &d__2, &coeffr[nj + 1], &coeffi[nj + 1], &c__1, & coeffr[nj], &coeffi[nj], &c__1); } return 0; }