/***** This code is part of the AFNI software package, which is ***** ***** partly in the public domain and partly covered by the GPL. ***** ***** See http://afni.nimh.nih.gov/afni for more information. *****/ #include #include #include #include #include "f2c.h" /*---------------------------------------------------------------------------*/ /**--- prototypes for functions in translated part of this file, at end ----**/ static int wnnls_fort(real *w, integer *mdw, integer *me, integer *ma, integer *n, integer *l, real *prgopt, real *x, real *rnorm, integer * mode, integer *iwork, real *work) ; static int h12_(integer *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *, integer *); static int lsi_(real *, integer *, integer *, integer *, integer *, real *, real *, real *, integer *, real *, integer *); static real sdot_(integer *, real *, integer *, real *, integer *); static real snrm2_(integer *, real *, integer *); static int sscal_(integer *, real *, real *, integer *); static real sasum_(integer *, real *, integer *); static int sswap_(integer *, real *, integer *, real *, integer *); static int scopy_(integer *, real *, integer *, real *, integer *); static int saxpy_(integer *, real *, real *, integer *, real *, integer *); static int srotm_(integer *, real *, integer *, real *, integer *, real *); static integer isamax_(integer *, real *, integer *); static int srotmg_(real *, real *, real *, real *, real *); static int hfti_(real *, integer *, integer *, integer *, real *, integer *, integer *, real *, integer *, real *, real *, real *, integer *); static int lpdp_(real *, integer *, integer *, integer *, integer *, real *, real *, real *, integer *, real *, integer *); static int wnlsm_(real *, integer *, integer *, integer * , integer *, integer *, real *, real *, real *, integer *, integer *, integer *, real *, real *, real *, real *, real *, real *); static int wnlit_(real *, integer *, integer *, integer *, integer *, integer *, integer *, real *, real *, real *, integer * , real *, logical *); /****************************************************************************/ /*-------------------------------------------------------------------------- Approximately (L2) solve equations j=nvec-1 z[i] = SUM A[j][i] * y[j] (i=0..ndim-1) j=0 for y[j] (j=0..nvec-1), subject to constraints (based on y[j] input) If input cony != 0, then you can supply sign constraints on the values of the output y[j] by putting values into the input y[j]: input y[j] = 0 ==> unconstrained = 1 ==> y[j] must be non-negative on output = -1 ==> y[j] must be non-positive on output If cony == 0, then the input y[j] is ignored. (But see note below for the case cony == 0!) The return value of the function is E = size of residuals >= 0.0f, if everything worked, and is a negative number if an error occured. ** If cony == 0, there is no real reason to call this function, since it will only then do standard least squares fitting, which a number of other AFNI library functions do (e.g., lsqfit). ** Also see the analogous cl1_solve() function in cl1.c, which does the same thing but with an L1 cost function instead of L2. ** Also see thd_fitter.c which can handle both L1 and L2 fitting, with and without constraints. *//*------------------------------------------------------------------------*/ float cl2_solve( int ndim, int nvec, float *z, float **A, float *y, int cony ) { int ii,jj,kk ; /* local loop counters */ /* rmap[j] = index of input column #j in wnnls_fort call */ /* vmap[j] = index of wnnls_fort column #j in input */ /* rsgn[j] = whether to flip the sign of input column #j */ /* nres = number of restraints */ int nres=0, *vmap=NULL, *rmap=NULL, *rsgn=NULL ; /* parameters for call to wnnls_fort() */ real *w=NULL , prgopt[1] , *x=NULL , rnorm , *work=NULL ; integer mdw , me , ma , n , l , mode , *iwork=NULL ; #undef FREEIF #define FREEIF(x) do{ if( (x) != NULL ) free((x)); } while(0) #undef CLEANUP #define CLEANUP do{ FREEIF(w) ; FREEIF(x) ; \ FREEIF(work); FREEIF(iwork); \ FREEIF(rmap); FREEIF(rsgn) ; FREEIF(vmap); } while(0) /* check inputs */ if( ndim < 1 || nvec < 1 ) return -7.0f ; if( A == NULL || y == NULL || z == NULL ) return -8.0f ; for( jj=0 ; jj < nvec ; jj++ ) if( A[jj] == NULL ) return -9.0f ; /* compute reordering of input columns for wnnls_fort, which requires all the restraints be at the end of the list */ if( cony ){ /* count number of restraints */ for( jj=0 ; jj < nvec ; jj++ ) if( y[jj] != 0.0f ) nres++ ; } if( nres > 0 ){ rmap = (int *)calloc(sizeof(int),nvec) ; vmap = (int *)calloc(sizeof(int),nvec) ; rsgn = (int *)calloc(sizeof(int),nvec) ; for( ii=jj=0 ; jj < nvec ; jj++ ){ /* unconstrained goes first */ if( y[jj] == 0.0f ) rmap[jj] = ii++ ; } for( jj=0 ; jj < nvec ; jj++ ){ /* constrained go afterwards */ if( y[jj] != 0.0f ){ rmap[jj] = ii++; rsgn[jj] = (y[jj]>0.0f) ? 1 : -1; } } for( jj=0 ; jj < nvec ; jj++ ){ /* find the inverse map */ for( ii=0 ; ii < nvec ; ii++ ){ if( rmap[ii] == jj ){ vmap[jj] = ii; break; } } if( ii == nvec ) fprintf(stderr,"** ERROR cl2_solve: vmap[%d] is bad\n",jj) ; } } /* setup call to wnnls_fort() */ ma = ndim ; me = 0 ; /* no equality constraints */ n = nvec ; l = nvec - nres ; /* number of unconstrained outputs */ x = (real *)calloc(sizeof(real),nvec+1) ; jj = 2*(ndim+5*nvec+1) ; /* workspaces */ work = (real *)calloc(sizeof(real),jj) ; iwork = (integer *)calloc(sizeof(integer),jj) ; iwork[0] = iwork[1] = jj ; prgopt[0] = 1.0 ; /* indicates no options being set in wnnls_fort */ /* load matrix and vector */ mdw = ndim+1 ; w = (real *)calloc(sizeof(real),(nvec+1)*mdw) ; if( nres > 0 ){ /* reordering of matrix columns needed */ for( jj=0 ; jj < nvec ; jj++ ){ kk = rmap[jj] ; /* input col #jj goes to wnnls col #kk */ if( rsgn[jj] >= 0 ){ /* with sign given by rsgn[jj] */ for( ii=0 ; ii < ndim ; ii++ ) w[ii+kk*mdw] = A[jj][ii] ; } else { for( ii=0 ; ii < ndim ; ii++ ) w[ii+kk*mdw] = -A[jj][ii] ; } } } else { /* no reordering needed */ for( jj=0 ; jj < nvec ; jj++ ) for( ii=0 ; ii < ndim ; ii++ ) w[ii+jj*mdw] = A[jj][ii] ; } for( ii=0 ; ii < ndim ; ii++ ) w[ii+nvec*mdw] = z[ii] ; /* RHS vector */ /****** solve system of equations ******/ mode = 0 ; (void)wnnls_fort( w , &mdw , &me , &ma , &n , &l , prgopt , x , &rnorm , &mode , iwork , work ) ; if( mode != 0 ){ CLEANUP; return (float)(-mode); } /* put result back in output vector y */ if( nres == 0 ){ for( jj=0 ; jj < nvec ; jj++ ) y[jj] = x[jj] ; } else { for( jj=0 ; jj < nvec ; jj++ ){ kk = vmap[jj] ; /* wnnls col #jj goes to input col #kk */ y[kk] = (rsgn[kk] >= 0) ? x[jj] : -x[jj] ; } } CLEANUP ; return (float)rnorm ; } /*====================================================================== Translated from the TOMS library algorithm #587 ========================================================================*/ /* cl2.f -- translated by f2c (version 20030320). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ #undef INLINE #ifdef __GNUC__ # define INLINE __inline__ #else # define INLINE /*nada*/ #endif /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< REAL FUNCTION DIFF(X,Y) >*/ static INLINE real diff_(real *x, real *y) { /* System generated locals */ real ret_val; /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (APPLY CHANGES TO ENTIRE PROGRAM UNIT.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/ */ /* C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUNE 7 */ /* TO APPEAR IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974 */ /*< REAL X, Y >*/ /*< DIFF=X-Y >*/ #line 3059 "cl2.f" ret_val = *x - *y; /*< RETURN >*/ #line 3060 "cl2.f" return ret_val; /*< END >*/ } /* diff_ */ #line 1 "cl2.f" /* Table of constant values */ static integer c__1 = 1; static integer c__2 = 2; static integer c__0 = 0; /* ALGORITHM 587, COLLECTED ALGORITHMS FROM ACM. */ /* ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL. 8, NO. 3, */ /* SEP., 1982, P.323. */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< >*/ static /* Subroutine */ int lsei_(real *w, integer *mdw, integer *me, integer *ma, integer *mg, integer *n, real *prgopt, real *x, real *rnorme, real * rnorml, integer *mode, real *ws, integer *ip) { /* Initialized data */ static real zero = 0.f; static real srelpr = 0.f; static real half = .5f; static real one = 1.f; /* Format strings */ static char fmt_90[] = ""; /* System generated locals */ integer w_dim1, w_offset, i__1, i__2, i__3; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, k, l, m; static real t; static integer n1, n2; static integer ii; static real rb; static integer kk, jj; static real uj, rn, sn, vj, up; static integer jp1, np1; static real gam; static logical cov; static real tau; static integer key, mep1, lchk, mend, link, imax, last, nerr; static real size; static integer iopt, next, nopt, igo990; static integer mdeqc; static integer nlink; static real enorm, fnorm, rnmax, snmax; static real xnrme; static real xnorm; static integer mapke1, kranke, ntimes; /* Assigned format variables */ static char *igo990_fmt; /* DIMENSION W(MDW,N+1),PRGOPT(*),X(N), */ /* WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) */ /* ABOVE, K=MAX(MA+MG,N). */ /* ABSTRACT */ /* THIS SUBPROGRAM SOLVES A LINEARLY CONSTRAINED LEAST SQUARES */ /* PROBLEM WITH BOTH EQUALITY AND INEQUALITY CONSTRAINTS, AND, IF THE */ /* USER REQUESTS, OBTAINS A COVARIANCE MATRIX OF THE SOLUTION */ /* PARAMETERS. */ /* SUPPOSE THERE ARE GIVEN MATRICES E, A AND G OF RESPECTIVE */ /* DIMENSIONS ME BY N, MA BY N AND MG BY N, AND VECTORS F, B AND H OF */ /* RESPECTIVE LENGTHS ME, MA AND MG. THIS SUBROUTINE SOLVES THE */ /* LINEARLY CONSTRAINED LEAST SQUARES PROBLEM */ /* EX = F, (E ME BY N) (EQUATIONS TO BE EXACTLY */ /* SATISFIED) */ /* AX = B, (A MA BY N) (EQUATIONS TO BE */ /* APPROXIMATELY SATISFIED, */ /* LEAST SQUARES SENSE) */ /* GX.GE.H,(G MG BY N) (INEQUALITY CONSTRAINTS) */ /* THE INEQUALITIES GX.GE.H MEAN THAT EVERY COMPONENT OF THE PRODUCT */ /* GX MUST BE .GE. THE CORRESPONDING COMPONENT OF H. */ /* IN CASE THE EQUALITY CONSTRAINTS CANNOT BE SATISFIED, A */ /* GENERALIZED INVERSE SOLUTION RESIDUAL VECTOR LENGTH IS OBTAINED */ /* FOR F-EX. THIS IS THE MINIMAL LENGTH POSSIBLE FOR F-EX. */ /* ANY VALUES ME.GE.0, MA.GE.0, OR MG.GE.0 ARE PERMITTED. THE */ /* RANK OF THE MATRIX E IS ESTIMATED DURING THE COMPUTATION. WE CALL */ /* THIS VALUE KRANKE. IT IS AN OUTPUT PARAMETER IN IP(1) DEFINED */ /* BELOW. USING A GENERALIZED INVERSE SOLUTION OF EX=F, A REDUCED */ /* LEAST SQUARES PROBLEM WITH INEQUALITY CONSTRAINTS IS OBTAINED. */ /* THE TOLERANCES USED IN THESE TESTS FOR DETERMINING THE RANK */ /* OF E AND THE RANK OF THE REDUCED LEAST SQUARES PROBLEM ARE */ /* GIVEN IN SANDIA TECH. REPT. SAND 78-1290. THEY CAN BE */ /* MODIFIED BY THE USER IF NEW VALUES ARE PROVIDED IN */ /* THE OPTION LIST OF THE ARRAY PRGOPT(*). */ /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (START EDITING AT LINE WITH C++ IN COLS. 1-3.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/,/SDOT/DDOT/, */ /* /SNRM2/DNRM2/,/ SQRT/ DSQRT/,/ ABS/ DABS/,/AMAX1/DMAX1/, */ /* /SCOPY/DCOPY/,/SSCAL/DSCAL/,/SAXPY/DAXPY/,/SSWAP/DSWAP/,/E0/D0/, */ /* /, DUMMY/,SNGL(DUMMY)/,/SRELPR/DRELPR/ */ /* WRITTEN BY R. J. HANSON AND K. H. HASKELL. FOR FURTHER MATH. */ /* AND ALGORITHMIC DETAILS SEE SANDIA LABORATORIES TECH. REPTS. */ /* SAND 77-0552, (1978), SAND 78-1290, (1979), AND */ /* MATH. PROGRAMMING, VOL. 21, (1981), P.98-118. */ /* THE USER MUST DIMENSION ALL ARRAYS APPEARING IN THE CALL LIST.. */ /* W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) */ /* WHERE K=MAX(MA+MG,N). THIS ALLOWS FOR A SOLUTION OF A RANGE OF */ /* PROBLEMS IN THE GIVEN WORKING SPACE. THE DIMENSION OF WS(*) */ /* GIVEN IS A NECESSARY OVERESTIMATE. ONCE A PARTICULAR PROBLEM */ /* HAS BEEN RUN, THE OUTPUT PARAMETER IP(3) GIVES THE ACTUAL */ /* DIMENSION REQUIRED FOR THAT PROBLEM. */ /* THE PARAMETERS FOR LSEI( ) ARE */ /* INPUT.. */ /* W(*,*),MDW, THE ARRAY W(*,*) IS DOUBLY SUBSCRIPTED WITH */ /* ME,MA,MG,N FIRST DIMENSIONING PARAMETER EQUAL TO MDW. */ /* FOR THIS DISCUSSION LET US CALL M = ME+MA+MG. THEN */ /* MDW MUST SATISFY MDW.GE.M. THE CONDITION */ /* MDW.LT.M IS AN ERROR. */ /* THE ARRAY W(*,*) CONTAINS THE MATRICES AND VECTORS */ /* (E F) */ /* (A B) */ /* (G H) */ /* IN ROWS AND COLUMNS 1,...,M AND 1,...,N+1 */ /* RESPECTIVELY. */ /* THE INTEGERS ME, MA, AND MG ARE THE */ /* RESPECTIVE MATRIX ROW DIMENSIONS */ /* OF E, A AND G. EACH MATRIX HAS N COLUMNS. */ /* PRGOPT(*) THIS ARRAY IS THE OPTION VECTOR. */ /* IF THE USER IS SATISFIED WITH THE NOMINAL */ /* SUBPROGRAM FEATURES SET */ /* PRGOPT(1)=1 (OR PRGOPT(1)=1.0) */ /* OTHERWISE PRGOPT(*) IS A LINKED LIST CONSISTING OF */ /* GROUPS OF DATA OF THE FOLLOWING FORM */ /* LINK */ /* KEY */ /* DATA SET */ /* THE PARAMETERS LINK AND KEY ARE EACH ONE WORD. */ /* THE DATA SET CAN BE COMPRISED OF SEVERAL WORDS. */ /* THE NUMBER OF ITEMS DEPENDS ON THE VALUE OF KEY. */ /* THE VALUE OF LINK POINTS TO THE FIRST */ /* ENTRY OF THE NEXT GROUP OF DATA WITHIN */ /* PRGOPT(*). THE EXCEPTION IS WHEN THERE ARE */ /* NO MORE OPTIONS TO CHANGE. IN THAT */ /* CASE LINK=1 AND THE VALUES KEY AND DATA SET */ /* ARE NOT REFERENCED. THE GENERAL LAYOUT OF */ /* PRGOPT(*) IS AS FOLLOWS. */ /* ...PRGOPT(1)=LINK1 (LINK TO FIRST ENTRY OF NEXT GROUP) */ /* . PRGOPT(2)=KEY1 (KEY TO THE OPTION CHANGE) */ /* . PRGOPT(3)=DATA VALUE (DATA VALUE FOR THIS CHANGE) */ /* . . */ /* . . */ /* . . */ /* ...PRGOPT(LINK1)=LINK2 (LINK TO THE FIRST ENTRY OF */ /* . NEXT GROUP) */ /* . PRGOPT(LINK1+1)=KEY2 (KEY TO THE OPTION CHANGE) */ /* . PRGOPT(LINK1+2)=DATA VALUE */ /* ... . */ /* . . */ /* . . */ /* ...PRGOPT(LINK)=1 (NO MORE OPTIONS TO CHANGE) */ /* VALUES OF LINK THAT ARE NONPOSITIVE ARE ERRORS. */ /* A VALUE OF LINK.GT.NLINK=100000 IS ALSO AN ERROR. */ /* THIS HELPS PREVENT USING INVALID BUT POSITIVE */ /* VALUES OF LINK THAT WILL PROBABLY EXTEND */ /* BEYOND THE PROGRAM LIMITS OF PRGOPT(*). */ /* UNRECOGNIZED VALUES OF KEY ARE IGNORED. THE */ /* ORDER OF THE OPTIONS IS ARBITRARY AND ANY NUMBER */ /* OF OPTIONS CAN BE CHANGED WITH THE FOLLOWING */ /* RESTRICTION. TO PREVENT CYCLING IN THE */ /* PROCESSING OF THE OPTION ARRAY A COUNT OF THE */ /* NUMBER OF OPTIONS CHANGED IS MAINTAINED. */ /* WHENEVER THIS COUNT EXCEEDS NOPT=1000 AN ERROR */ /* MESSAGE IS PRINTED AND THE SUBPROGRAM RETURNS. */ /* OPTIONS.. */ /* KEY=1 */ /* COMPUTE IN W(*,*) THE N BY N */ /* COVARIANCE MATRIX OF THE SOLUTION VARIABLES */ /* AS AN OUTPUT PARAMETER. NOMINALLY THE */ /* COVARIANCE MATRIX WILL NOT BE COMPUTED. */ /* (THIS REQUIRES NO USER INPUT.) */ /* THE DATA SET FOR THIS OPTION IS A SINGLE VALUE. */ /* IT MUST BE NONZERO WHEN THE COVARIANCE MATRIX */ /* IS DESIRED. IF IT IS ZERO, THE COVARIANCE */ /* MATRIX IS NOT COMPUTED. WHEN THE COVARIANCE MATRIX */ /* IS COMPUTED, THE FIRST DIMENSIONING PARAMETER */ /* OF THE ARRAY W(*,*) MUST SATISFY MDW.GE.MAX0(M,N). */ /* KEY=2 */ /* SCALE THE NONZERO COLUMNS OF THE */ /* ENTIRE DATA MATRIX. */ /* (E) */ /* (A) */ /* (G) */ /* TO HAVE LENGTH ONE. THE DATA SET FOR THIS */ /* OPTION IS A SINGLE VALUE. IT MUST BE */ /* NONZERO IF UNIT LENGTH COLUMN SCALING */ /* IS DESIRED. */ /* KEY=3 */ /* SCALE COLUMNS OF THE ENTIRE DATA MATRIX */ /* (E) */ /* (A) */ /* (G) */ /* WITH A USER-PROVIDED DIAGONAL MATRIX. */ /* THE DATA SET FOR THIS OPTION CONSISTS */ /* OF THE N DIAGONAL SCALING FACTORS, ONE FOR */ /* EACH MATRIX COLUMN. */ /* KEY=4 */ /* CHANGE THE RANK DETERMINATION TOLERANCE FOR */ /* THE EQUALITY CONSTRAINT EQUATIONS FROM */ /* THE NOMINAL VALUE OF SQRT(SRELPR). THIS QUANTITY CAN */ /* BE NO SMALLER THAN SRELPR, THE ARITHMETIC- */ /* STORAGE PRECISION. THE QUANTITY SRELPR IS THE */ /* LARGEST POSITIVE NUMBER SUCH THAT T=1.+SRELPR */ /* SATISFIES T.EQ.1. THE QUANTITY USED */ /* HERE IS INTERNALLY RESTRICTED TO BE AT */ /* LEAST SRELPR. THE DATA SET FOR THIS OPTION */ /* IS THE NEW TOLERANCE. */ /* KEY=5 */ /* CHANGE THE RANK DETERMINATION TOLERANCE FOR */ /* THE REDUCED LEAST SQUARES EQUATIONS FROM */ /* THE NOMINAL VALUE OF SQRT(SRELPR). THIS QUANTITY CAN */ /* BE NO SMALLER THAN SRELPR, THE ARITHMETIC- */ /* STORAGE PRECISION. THE QUANTITY USED */ /* HERE IS INTERNALLY RESTRICTED TO BE AT */ /* LEAST SRELPR. THE DATA SET FOR THIS OPTION */ /* IS THE NEW TOLERANCE. */ /* FOR EXAMPLE, SUPPOSE WE WANT TO CHANGE */ /* THE TOLERANCE FOR THE REDUCED LEAST SQUARES */ /* PROBLEM, COMPUTE THE COVARIANCE MATRIX OF */ /* THE SOLUTION PARAMETERS, AND PROVIDE */ /* COLUMN SCALING FOR THE DATA MATRIX. FOR */ /* THESE OPTIONS THE DIMENSION OF PRGOPT(*) */ /* MUST BE AT LEAST N+9. THE FORTRAN STATEMENTS */ /* DEFINING THESE OPTIONS WOULD BE AS FOLLOWS. */ /* PRGOPT(1)=4 (LINK TO ENTRY 4 IN PRGOPT(*)) */ /* PRGOPT(2)=1 (COVARIANCE MATRIX KEY) */ /* PRGOPT(3)=1 (COVARIANCE MATRIX WANTED) */ /* PRGOPT(4)=7 (LINK TO ENTRY 7 IN PRGOPT(*)) */ /* PRGOPT(5)=5 (LEAST SQUARES EQUAS. TOLERANCE KEY) */ /* PRGOPT(6)=... (NEW VALUE OF THE TOLERANCE) */ /* PRGOPT(7)=N+9 (LINK TO ENTRY N+9 IN PRGOPT(*)) */ /* PRGOPT(8)=3 (USER-PROVIDED COLUMN SCALING KEY) */ /* CALL SCOPY(N,D,1,PRGOPT(9),1) (COPY THE N */ /* SCALING FACTORS FROM THE USER ARRAY D(*) */ /* TO PRGOPT(9)-PRGOPT(N+8)) */ /* PRGOPT(N+9)=1 (NO MORE OPTIONS TO CHANGE) */ /* THE CONTENTS OF PRGOPT(*) ARE NOT MODIFIED */ /* BY THE SUBPROGRAM. */ /* THE OPTIONS FOR WNNLS( ) CAN ALSO BE INCLUDED */ /* IN THIS ARRAY. THE VALUES OF KEY RECOGNIZED */ /* BY WNNLS( ) ARE 6, 7 AND 8. THEIR FUNCTIONS */ /* ARE DOCUMENTED IN THE USAGE INSTRUCTIONS FOR */ /* SUBROUTINE WNNLS( ). NORMALLY THESE OPTIONS */ /* DO NOT NEED TO BE MODIFIED WHEN USING LSEI( ). */ /* IP(1), THE AMOUNTS OF WORKING STORAGE ACTUALLY */ /* IP(2) ALLOCATED FOR THE WORKING ARRAYS WS(*) AND */ /* IP(*), RESPECTIVELY. THESE QUANTITIES ARE */ /* COMPARED WITH THE ACTUAL AMOUNTS OF STORAGE */ /* NEEDED BY LSEI( ). INSUFFICIENT STORAGE */ /* ALLOCATED FOR EITHER WS(*) OR IP(*) IS AN */ /* ERROR. THIS FEATURE WAS INCLUDED IN LSEI( ) */ /* BECAUSE MISCALCULATING THE STORAGE FORMULAS */ /* FOR WS(*) AND IP(*) MIGHT VERY WELL LEAD TO */ /* SUBTLE AND HARD-TO-FIND EXECUTION ERRORS. */ /* THE LENGTH OF WS(*) MUST BE AT LEAST */ /* LW = 2*(ME+N)+K+(MG+2)*(N+7) */ /* WHERE K = MAX(MA+MG,N) */ /* THIS TEST WILL NOT BE MADE IF IP(1).LE.0. */ /* THE LENGTH OF IP(*) MUST BE AT LEAST */ /* LIP = MG+2*N+2 */ /* THIS TEST WILL NOT BE MADE IF IP(2).LE.0. */ /* OUTPUT.. */ /* X(*),RNORME, THE ARRAY X(*) CONTAINS THE SOLUTION PARAMETERS */ /* RNORML IF THE INTEGER OUTPUT FLAG MODE = 0 OR 1. */ /* THE DEFINITION OF MODE IS GIVEN DIRECTLY BELOW. */ /* WHEN MODE = 0 OR 1, RNORME AND RNORML */ /* RESPECTIVELY CONTAIN THE RESIDUAL VECTOR */ /* EUCLIDEAN LENGTHS OF F - EX AND B - AX. WHEN */ /* MODE=1 THE EQUALITY CONSTRAINT EQUATIONS EX=F */ /* ARE CONTRADICTORY, SO RNORME.NE.0. THE RESIDUAL */ /* VECTOR F-EX HAS MINIMAL EUCLIDEAN LENGTH. FOR */ /* MODE.GE.2, NONE OF THESE PARAMETERS ARE */ /* DEFINED. */ /* MODE INTEGER FLAG THAT INDICATES THE SUBPROGRAM */ /* STATUS AFTER COMPLETION. IF MODE.GE.2, NO */ /* SOLUTION HAS BEEN COMPUTED. */ /* MODE = */ /* 0 BOTH EQUALITY AND INEQUALITY CONSTRAINTS */ /* ARE COMPATIBLE AND HAVE BEEN SATISFIED. */ /* 1 EQUALITY CONSTRAINTS ARE CONTRADICTORY. */ /* A GENERALIZED INVERSE SOLUTION OF EX=F WAS USED */ /* TO MINIMIZE THE RESIDUAL VECTOR LENGTH F-EX. */ /* IN THIS SENSE, THE SOLUTION IS STILL MEANINGFUL. */ /* 2 INEQUALITY CONSTRAINTS ARE CONTRADICTORY. */ /* 3 BOTH EQUALITY AND INEQUALITY CONSTRAINTS */ /* ARE CONTRADICTORY. */ /* THE FOLLOWING INTERPRETATION OF */ /* MODE=1,2 OR 3 MUST BE MADE. THE */ /* SETS CONSISTING OF ALL SOLUTIONS */ /* OF THE EQUALITY CONSTRAINTS EX=F */ /* AND ALL VECTORS SATISFYING GX.GE.H */ /* HAVE NO POINTS ON COMMON. (IN */ /* PARTICULAR THIS DOES NOT SAY THAT */ /* EACH INDIVIDUAL SET HAS NO POINTS */ /* AT ALL, ALTHOUGH THIS COULD BE THE */ /* CASE.) */ /* 4 USAGE ERROR OCCURRED. THE VALUE */ /* OF MDW IS .LT. ME+MA+MG, MDW IS */ /* .LT. N AND A COVARIANCE MATRIX IS */ /* REQUESTED, THE OPTION VECTOR */ /* PRGOPT(*) IS NOT PROPERLY DEFINED, */ /* OR THE LENGTHS OF THE WORKING ARRAYS */ /* WS(*) AND IP(*), WHEN SPECIFIED IN */ /* IP(1) AND IP(2) RESPECTIVELY, ARE NOT */ /* LONG ENOUGH. */ /* W(*,*) THE ARRAY W(*,*) CONTAINS THE N BY N SYMMETRIC */ /* COVARIANCE MATRIX OF THE SOLUTION PARAMETERS, */ /* PROVIDED THIS WAS REQUESTED ON INPUT WITH */ /* THE OPTION VECTOR PRGOPT(*) AND THE OUTPUT */ /* FLAG IS RETURNED WITH MODE = 0 OR 1. */ /* IP(*) THE INTEGER WORKING ARRAY HAS THREE ENTRIES */ /* THAT PROVIDE RANK AND WORKING ARRAY LENGTH */ /* INFORMATION AFTER COMPLETION. */ /* IP(1) = RANK OF EQUALITY CONSTRAINT */ /* MATRIX. DEFINE THIS QUANTITY */ /* AS KRANKE. */ /* IP(2) = RANK OF REDUCED LEAST SQUARES */ /* PROBLEM. */ /* IP(3) = THE AMOUNT OF STORAGE IN THE */ /* WORKING ARRAY WS(*) THAT WAS */ /* ACTUALLY USED BY THE SUBPROGRAM. */ /* THE FORMULA GIVEN ABOVE FOR THE LENGTH */ /* OF WS(*) IS A NECESSARY OVERESTIMATE. */ /* USER DESIGNATED */ /* WORKING ARRAYS.. */ /* WS(*),IP(*) THESE ARE RESP. TYPE FLOATING POINT */ /* AND TYPE INTEGER WORKING ARRAYS. */ /* THEIR REQUIRED MINIMAL LENGTHS ARE */ /* GIVEN ABOVE. */ /* SUBROUTINES CALLED */ /* LSI PART OF THIS PACKAGE. SOLVES A */ /* CONSTRAINED LEAST SQUARES PROBLEM WITH */ /* INEQUALITY CONSTRAINTS. */ /* ++ */ /* SDOT,SSCAL, SUBROUTINES FROM THE BLAS PACKAGE. */ /* SAXPY,SASUM, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. */ /* SCOPY,SNRM2, */ /* SSWAP */ /* H12 SUBROUTINE TO CONSTRUCT AND APPLY A */ /* HOUSEHOLDER TRANSFORMATION. */ /* XERROR FROM SLATEC ERROR PROCESSING PACKAGE. */ /* THIS IS DOCUMENTED IN SANDIA TECH. REPT., */ /* SAND78-1189. */ /* SUBROUTINE LSEI(W,MDW,ME,MA,MG,N,PRGOPT,X,RNORME,RNORML,MODE,WS, */ /* 1 IP) */ /* REVISED OCT. 1, 1981. */ /*< REAL W(MDW,1), PRGOPT(1), X(1), WS(1), RNORME, RNORML >*/ /*< INTEGER IP(3) >*/ /*< >*/ /*< REAL SASUM, SDOT, SNRM2, SQRT, ABS, AMAX1 >*/ /*< LOGICAL COV >*/ /*< DATA ZERO /0.E0/, SRELPR /0.E0/, HALF /0.5E0/, ONE /1.E0/ >*/ #line 384 "cl2.f" /* Parameter adjustments */ #line 384 "cl2.f" w_dim1 = *mdw; #line 384 "cl2.f" w_offset = 1 + w_dim1; #line 384 "cl2.f" w -= w_offset; #line 384 "cl2.f" --prgopt; #line 384 "cl2.f" --x; #line 384 "cl2.f" --ws; #line 384 "cl2.f" --ip; #line 384 "cl2.f" #line 384 "cl2.f" /* Function Body */ /* CHECK THAT ENOUGH STORAGE WAS ALLOCATED IN WS(*) AND IP(*). */ /*< IF (.NOT.(IP(1).GT.0)) GO TO 20 >*/ #line 387 "cl2.f" if (! (ip[1] > 0)) { #line 387 "cl2.f" goto L20; #line 387 "cl2.f" } /*< LCHK = 2*(ME+N) + MAX0(MA+MG,N) + (MG+2)*(N+7) >*/ /* Computing MAX */ #line 388 "cl2.f" i__1 = *ma + *mg; #line 388 "cl2.f" lchk = (*me + *n << 1) + max(i__1,*n) + (*mg + 2) * (*n + 7); /*< IF (.NOT.(IP(1).LT.LCHK)) GO TO 10 >*/ #line 389 "cl2.f" if (! (ip[1] < lchk)) { #line 389 "cl2.f" goto L10; #line 389 "cl2.f" } /*< MODE = 4 >*/ #line 390 "cl2.f" *mode = 4; /*< NERR = 2 >*/ #line 391 "cl2.f" nerr = 2; /*< IOPT = 1 >*/ #line 392 "cl2.f" iopt = 1; /* cc CALL XERRWV(67HLSEI( ), INSUFFICIENT STORAGE ALLOCATED FOR WS(*), */ /* cc *NEED LW=I1 BELOW, 67, NERR, IOPT, 1, LCHK, 0, */ /* cc * 0, DUMMY, DUMMY) */ /*< RETURN >*/ #line 396 "cl2.f" return 0; /*< 10 CONTINUE >*/ #line 397 "cl2.f" L10: /*< 20 IF (.NOT.(IP(2).GT.0)) GO TO 40 >*/ #line 398 "cl2.f" L20: #line 398 "cl2.f" if (! (ip[2] > 0)) { #line 398 "cl2.f" goto L40; #line 398 "cl2.f" } /*< LCHK = MG + 2*N + 2 >*/ #line 399 "cl2.f" lchk = *mg + (*n << 1) + 2; /*< IF (.NOT.(IP(2).LT.LCHK)) GO TO 30 >*/ #line 400 "cl2.f" if (! (ip[2] < lchk)) { #line 400 "cl2.f" goto L30; #line 400 "cl2.f" } /*< MODE = 4 >*/ #line 401 "cl2.f" *mode = 4; /*< NERR = 2 >*/ #line 402 "cl2.f" nerr = 2; /*< IOPT = 1 >*/ #line 403 "cl2.f" iopt = 1; /* cc CALL XERRWV(68HLSEI( ), INSUFFICIENT STORAGE ALLOCATED FOR IP(*), */ /* cc *NEED LIP=I1 BELOW, 68, NERR, IOPT, 1, LCHK, 0, */ /* cc * 0, DUMMY, DUMMY) */ /*< RETURN >*/ #line 407 "cl2.f" return 0; /*< 30 CONTINUE >*/ #line 408 "cl2.f" L30: /* COMPUTE MACHINE PRECISION=SRELPR ONLY WHEN NECESSARY. */ /*< 40 IF (.NOT.(SRELPR.EQ.ZERO)) GO TO 70 >*/ #line 411 "cl2.f" L40: #line 411 "cl2.f" if (! (srelpr == zero)) { #line 411 "cl2.f" goto L70; #line 411 "cl2.f" } /*< SRELPR = ONE >*/ #line 412 "cl2.f" srelpr = one; /*< 50 IF (ONE+SRELPR.EQ.ONE) GO TO 60 >*/ #line 413 "cl2.f" L50: #line 413 "cl2.f" if (one + srelpr == one) { #line 413 "cl2.f" goto L60; #line 413 "cl2.f" } /*< SRELPR = SRELPR*HALF >*/ #line 414 "cl2.f" srelpr *= half; /*< GO TO 50 >*/ #line 415 "cl2.f" goto L50; /*< 60 SRELPR = SRELPR + SRELPR >*/ #line 416 "cl2.f" L60: #line 416 "cl2.f" srelpr += srelpr; /* COMPUTE NUMBER OF POSSIBLE RIGHT MULTIPLYING HOUSEHOLDER */ /* TRANSFORMATIONS. */ /*< 70 M = ME + MA + MG >*/ #line 420 "cl2.f" L70: #line 420 "cl2.f" m = *me + *ma + *mg; /*< MODE = 0 >*/ #line 421 "cl2.f" *mode = 0; /*< IF (N.LE.0 .OR. M.LE.0) RETURN >*/ #line 422 "cl2.f" if (*n <= 0 || m <= 0) { #line 422 "cl2.f" return 0; #line 422 "cl2.f" } /*< IF (.NOT.(MDW.LT.M)) GO TO 80 >*/ #line 423 "cl2.f" if (! (*mdw < m)) { #line 423 "cl2.f" goto L80; #line 423 "cl2.f" } /*< NERR = 1 >*/ #line 424 "cl2.f" nerr = 1; /*< IOPT = 1 >*/ #line 425 "cl2.f" iopt = 1; /* cc CALL XERROR(36HLSEI( ), MDW.LT.ME+MA+MG IS AN ERROR, 36, NERR, */ /* cc * IOPT) */ /*< MODE = 4 >*/ #line 428 "cl2.f" *mode = 4; /*< RETURN >*/ #line 429 "cl2.f" return 0; /*< 80 NP1 = N + 1 >*/ #line 430 "cl2.f" L80: #line 430 "cl2.f" np1 = *n + 1; /*< KRANKE = MIN0(ME,N) >*/ #line 431 "cl2.f" kranke = min(*me,*n); /*< N1 = 2*KRANKE + 1 >*/ #line 432 "cl2.f" n1 = (kranke << 1) + 1; /*< N2 = N1 + N >*/ #line 433 "cl2.f" n2 = n1 + *n; /* PROCESS-OPTION-VECTOR */ /*< ASSIGN 90 TO IGO990 >*/ #line 436 "cl2.f" igo990 = 0; #line 436 "cl2.f" igo990_fmt = fmt_90; /*< GO TO 480 >*/ #line 437 "cl2.f" goto L480; /*< 90 IF (.NOT.(COV .AND. MDW.LT.N)) GO TO 100 >*/ #line 438 "cl2.f" L90: #line 438 "cl2.f" if (! (cov && *mdw < *n)) { #line 438 "cl2.f" goto L100; #line 438 "cl2.f" } /*< NERR = 2 >*/ #line 439 "cl2.f" nerr = 2; /*< IOPT = 1 >*/ #line 440 "cl2.f" iopt = 1; /* cc CALL XERROR( */ /* cc * 54HLSEI( ), MDW.LT.N, WHEN COV MATRIX NEEDED, IS AN ERROR, 54, */ /* cc * NERR, IOPT) */ /*< MODE = 4 >*/ #line 444 "cl2.f" *mode = 4; /*< RETURN >*/ #line 445 "cl2.f" return 0; /*< 100 L = KRANKE >*/ #line 446 "cl2.f" L100: #line 446 "cl2.f" l = kranke; /* COMPUTE NORM OF EQUALITY CONSTRAINT MATRIX AND RT SIDE. */ /*< ENORM = ZERO >*/ #line 449 "cl2.f" enorm = zero; /*< DO 110 J=1,N >*/ #line 450 "cl2.f" i__1 = *n; #line 450 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< ENORM = AMAX1(ENORM,SASUM(ME,W(1,J),1)) >*/ /* Computing MAX */ #line 451 "cl2.f" r__1 = enorm, r__2 = sasum_(me, &w[j * w_dim1 + 1], &c__1); #line 451 "cl2.f" enorm = max(r__1,r__2); /*< 110 CONTINUE >*/ #line 452 "cl2.f" /* L110: */ #line 452 "cl2.f" } /*< FNORM = SASUM(ME,W(1,NP1),1) >*/ #line 453 "cl2.f" fnorm = sasum_(me, &w[np1 * w_dim1 + 1], &c__1); /*< IF (.NOT.(L.GT.0)) GO TO 190 >*/ #line 454 "cl2.f" if (! (l > 0)) { #line 454 "cl2.f" goto L190; #line 454 "cl2.f" } /*< SNMAX = ZERO >*/ #line 455 "cl2.f" snmax = zero; /*< RNMAX = ZERO >*/ #line 456 "cl2.f" rnmax = zero; /*< DO 180 I=1,L >*/ #line 457 "cl2.f" i__1 = l; #line 457 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /* COMPUTE MAXIMUM RATIO OF VECTOR LENGTHS. PARTITION */ /* IS AT COL. I. */ /*< DO 150 K=I,ME >*/ #line 461 "cl2.f" i__2 = *me; #line 461 "cl2.f" for (k = i__; k <= i__2; ++k) { /*< SN = SDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) >*/ #line 462 "cl2.f" i__3 = *n - i__ + 1; #line 462 "cl2.f" sn = sdot_(&i__3, &w[k + i__ * w_dim1], mdw, &w[k + i__ * w_dim1], mdw); /*< RN = SDOT(I-1,W(K,1),MDW,W(K,1),MDW) >*/ #line 463 "cl2.f" i__3 = i__ - 1; #line 463 "cl2.f" rn = sdot_(&i__3, &w[k + w_dim1], mdw, &w[k + w_dim1], mdw); /*< IF (.NOT.(RN.EQ.ZERO .AND. SN.GT.SNMAX)) GO TO 120 >*/ #line 464 "cl2.f" if (! (rn == zero && sn > snmax)) { #line 464 "cl2.f" goto L120; #line 464 "cl2.f" } /*< SNMAX = SN >*/ #line 465 "cl2.f" snmax = sn; /*< IMAX = K >*/ #line 466 "cl2.f" imax = k; /*< GO TO 140 >*/ #line 467 "cl2.f" goto L140; /*< 120 IF (.NOT.(K.EQ.I .OR. (SN*RNMAX.GT.RN*SNMAX))) GO TO 130 >*/ #line 468 "cl2.f" L120: #line 468 "cl2.f" if (! (k == i__ || sn * rnmax > rn * snmax)) { #line 468 "cl2.f" goto L130; #line 468 "cl2.f" } /*< SNMAX = SN >*/ #line 469 "cl2.f" snmax = sn; /*< RNMAX = RN >*/ #line 470 "cl2.f" rnmax = rn; /*< IMAX = K >*/ #line 471 "cl2.f" imax = k; /*< 130 CONTINUE >*/ #line 472 "cl2.f" L130: /*< 140 CONTINUE >*/ #line 473 "cl2.f" L140: /*< 150 CONTINUE >*/ #line 474 "cl2.f" /* L150: */ #line 474 "cl2.f" ; #line 474 "cl2.f" } /* INTERCHANGE ROWS IF NECESSARY. */ /*< IF (I.NE.IMAX) CALL SSWAP(NP1, W(I,1), MDW, W(IMAX,1), MDW) >*/ #line 477 "cl2.f" if (i__ != imax) { #line 477 "cl2.f" sswap_(&np1, &w[i__ + w_dim1], mdw, &w[imax + w_dim1], mdw); #line 477 "cl2.f" } /*< IF (.NOT.(SNMAX.GT.TAU**2*RNMAX)) GO TO 160 >*/ /* Computing 2nd power */ #line 478 "cl2.f" r__1 = tau; #line 478 "cl2.f" if (! (snmax > r__1 * r__1 * rnmax)) { #line 478 "cl2.f" goto L160; #line 478 "cl2.f" } /* ELIMINATE ELEMS I+1,...,N IN ROW I. */ /*< >*/ #line 481 "cl2.f" i__2 = i__ + 1; #line 481 "cl2.f" i__3 = m - i__; #line 481 "cl2.f" h12_(&c__1, &i__, &i__2, n, &w[i__ + w_dim1], mdw, &ws[i__], &w[i__ + 1 + w_dim1], mdw, &c__1, &i__3); /*< GO TO 170 >*/ #line 483 "cl2.f" goto L170; /*< 160 KRANKE = I - 1 >*/ #line 484 "cl2.f" L160: #line 484 "cl2.f" kranke = i__ - 1; /*< GO TO 200 >*/ #line 485 "cl2.f" goto L200; /*< 170 CONTINUE >*/ #line 486 "cl2.f" L170: /*< 180 CONTINUE >*/ #line 487 "cl2.f" /* L180: */ #line 487 "cl2.f" ; #line 487 "cl2.f" } /*< 190 CONTINUE >*/ #line 488 "cl2.f" L190: /*< 200 CONTINUE >*/ #line 489 "cl2.f" L200: /* SAVE DIAG. TERMS OF LOWER TRAP. MATRIX. */ /*< CALL SCOPY(KRANKE, W, MDW+1, WS(KRANKE+1), 1) >*/ #line 492 "cl2.f" i__1 = *mdw + 1; #line 492 "cl2.f" scopy_(&kranke, &w[w_offset], &i__1, &ws[kranke + 1], &c__1); /* USE HOUSEHOLDER TRANS FROM LEFT TO ACHIEVE KRANKE BY KRANKE UPPER */ /* TRIANGULAR FORM. */ /*< IF (.NOT.(KRANKE.GT.0 .AND. KRANKE.LT.ME)) GO TO 220 >*/ #line 496 "cl2.f" if (! (kranke > 0 && kranke < *me)) { #line 496 "cl2.f" goto L220; #line 496 "cl2.f" } /*< DO 210 KK=1,KRANKE >*/ #line 497 "cl2.f" i__1 = kranke; #line 497 "cl2.f" for (kk = 1; kk <= i__1; ++kk) { /*< K = KRANKE + 1 - KK >*/ #line 498 "cl2.f" k = kranke + 1 - kk; /* APPLY TRANFORMATION TO MATRIX COLS. 1,...,K-1. */ /*< CALL H12(1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, K-1) >*/ #line 501 "cl2.f" i__2 = kranke + 1; #line 501 "cl2.f" i__3 = k - 1; #line 501 "cl2.f" h12_(&c__1, &k, &i__2, me, &w[k * w_dim1 + 1], &c__1, &up, &w[ w_offset], &c__1, mdw, &i__3); /* APPLY TO RT SIDE VECTOR. */ /*< CALL H12(2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, 1, 1) >*/ #line 504 "cl2.f" i__2 = kranke + 1; #line 504 "cl2.f" h12_(&c__2, &k, &i__2, me, &w[k * w_dim1 + 1], &c__1, &up, &w[np1 * w_dim1 + 1], &c__1, &c__1, &c__1); /*< 210 CONTINUE >*/ #line 505 "cl2.f" /* L210: */ #line 505 "cl2.f" } /*< 220 IF (.NOT.(KRANKE.GT.0)) GO TO 240 >*/ #line 506 "cl2.f" L220: #line 506 "cl2.f" if (! (kranke > 0)) { #line 506 "cl2.f" goto L240; #line 506 "cl2.f" } /* SOLVE FOR VARIABLES 1,...,KRANKE IN NEW COORDINATES. */ /*< CALL SCOPY(KRANKE, W(1,NP1), 1, X, 1) >*/ #line 509 "cl2.f" scopy_(&kranke, &w[np1 * w_dim1 + 1], &c__1, &x[1], &c__1); /*< DO 230 I=1,KRANKE >*/ #line 510 "cl2.f" i__1 = kranke; #line 510 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< X(I) = (X(I)-SDOT(I-1,W(I,1),MDW,X,1))/W(I,I) >*/ #line 511 "cl2.f" i__2 = i__ - 1; #line 511 "cl2.f" x[i__] = (x[i__] - sdot_(&i__2, &w[i__ + w_dim1], mdw, &x[1], &c__1)) / w[i__ + i__ * w_dim1]; /*< 230 CONTINUE >*/ #line 512 "cl2.f" /* L230: */ #line 512 "cl2.f" } /* COMPUTE RESIDUALS FOR REDUCED PROBLEM. */ /*< 240 MEP1 = ME + 1 >*/ #line 515 "cl2.f" L240: #line 515 "cl2.f" mep1 = *me + 1; /*< RNORML = ZERO >*/ #line 516 "cl2.f" *rnorml = zero; /*< IF (.NOT.(ME.LT.M)) GO TO 270 >*/ #line 517 "cl2.f" if (! (*me < m)) { #line 517 "cl2.f" goto L270; #line 517 "cl2.f" } /*< DO 260 I=MEP1,M >*/ #line 518 "cl2.f" i__1 = m; #line 518 "cl2.f" for (i__ = mep1; i__ <= i__1; ++i__) { /*< W(I,NP1) = W(I,NP1) - SDOT(KRANKE,W(I,1),MDW,X,1) >*/ #line 519 "cl2.f" w[i__ + np1 * w_dim1] -= sdot_(&kranke, &w[i__ + w_dim1], mdw, &x[1], &c__1); /*< SN = SDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) >*/ #line 520 "cl2.f" sn = sdot_(&kranke, &w[i__ + w_dim1], mdw, &w[i__ + w_dim1], mdw); /*< RN = SDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) >*/ #line 521 "cl2.f" i__2 = *n - kranke; #line 521 "cl2.f" rn = sdot_(&i__2, &w[i__ + (kranke + 1) * w_dim1], mdw, &w[i__ + ( kranke + 1) * w_dim1], mdw); /*< IF (.NOT.(RN.LE.TAU**2*SN .AND. KRANKE.LT.N)) GO TO 250 >*/ /* Computing 2nd power */ #line 522 "cl2.f" r__1 = tau; #line 522 "cl2.f" if (! (rn <= r__1 * r__1 * sn && kranke < *n)) { #line 522 "cl2.f" goto L250; #line 522 "cl2.f" } /*< W(I,KRANKE+1) = ZERO >*/ #line 523 "cl2.f" w[i__ + (kranke + 1) * w_dim1] = zero; /*< CALL SCOPY(N-KRANKE, W(I,KRANKE+1), 0, W(I,KRANKE+1), MDW) >*/ #line 524 "cl2.f" i__2 = *n - kranke; #line 524 "cl2.f" scopy_(&i__2, &w[i__ + (kranke + 1) * w_dim1], &c__0, &w[i__ + ( kranke + 1) * w_dim1], mdw); /*< 250 CONTINUE >*/ #line 525 "cl2.f" L250: /*< 260 CONTINUE >*/ #line 526 "cl2.f" /* L260: */ #line 526 "cl2.f" ; #line 526 "cl2.f" } /* COMPUTE EQUAL. CONSTRAINT EQUAS. RESIDUAL LENGTH. */ /*< 270 RNORME = SNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) >*/ #line 529 "cl2.f" L270: #line 529 "cl2.f" i__1 = *me - kranke; #line 529 "cl2.f" *rnorme = snrm2_(&i__1, &w[kranke + 1 + np1 * w_dim1], &c__1); /* MOVE REDUCED PROBLEM DATA UPWARD IF KRANKE.LT.ME. */ /*< IF (.NOT.(KRANKE.LT.ME)) GO TO 290 >*/ #line 532 "cl2.f" if (! (kranke < *me)) { #line 532 "cl2.f" goto L290; #line 532 "cl2.f" } /*< DO 280 J=1,NP1 >*/ #line 533 "cl2.f" i__1 = np1; #line 533 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< CALL SCOPY(M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) >*/ #line 534 "cl2.f" i__2 = m - *me; #line 534 "cl2.f" scopy_(&i__2, &w[*me + 1 + j * w_dim1], &c__1, &w[kranke + 1 + j * w_dim1], &c__1); /*< 280 CONTINUE >*/ #line 535 "cl2.f" /* L280: */ #line 535 "cl2.f" } /* COMPUTE SOLN OF REDUCED PROBLEM. */ /*< >*/ #line 538 "cl2.f" L290: #line 538 "cl2.f" i__1 = *n - kranke; #line 538 "cl2.f" lsi_(&w[kranke + 1 + (kranke + 1) * w_dim1], mdw, ma, mg, &i__1, &prgopt[ 1], &x[kranke + 1], rnorml, mode, &ws[n2], &ip[2]); /*< IF (.NOT.(ME.GT.0)) GO TO 330 >*/ #line 540 "cl2.f" if (! (*me > 0)) { #line 540 "cl2.f" goto L330; #line 540 "cl2.f" } /* TEST FOR CONSISTENCY OF EQUALITY CONSTRAINTS. */ /*< MDEQC = 0 >*/ #line 543 "cl2.f" mdeqc = 0; /*< XNRME = SASUM(KRANKE,W(1,NP1),1) >*/ #line 544 "cl2.f" xnrme = sasum_(&kranke, &w[np1 * w_dim1 + 1], &c__1); /*< IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 >*/ #line 545 "cl2.f" if (*rnorme > tau * (enorm * xnrme + fnorm)) { #line 545 "cl2.f" mdeqc = 1; #line 545 "cl2.f" } /*< MODE = MODE + MDEQC >*/ #line 546 "cl2.f" *mode += mdeqc; /* CHECK IF SOLN TO EQUAL. CONSTRAINTS SATISFIES INEQUAL. */ /* CONSTRAINTS WHEN THERE ARE NO DEGREES OF FREEDOM LEFT. */ /*< IF (.NOT.(KRANKE.EQ.N .AND. MG.GT.0)) GO TO 320 >*/ #line 550 "cl2.f" if (! (kranke == *n && *mg > 0)) { #line 550 "cl2.f" goto L320; #line 550 "cl2.f" } /*< XNORM = SASUM(N,X,1) >*/ #line 551 "cl2.f" xnorm = sasum_(n, &x[1], &c__1); /*< MAPKE1 = MA + KRANKE + 1 >*/ #line 552 "cl2.f" mapke1 = *ma + kranke + 1; /*< MEND = MA + KRANKE + MG >*/ #line 553 "cl2.f" mend = *ma + kranke + *mg; /*< DO 310 I=MAPKE1,MEND >*/ #line 554 "cl2.f" i__1 = mend; #line 554 "cl2.f" for (i__ = mapke1; i__ <= i__1; ++i__) { /*< SIZE = SASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) >*/ #line 555 "cl2.f" size = sasum_(n, &w[i__ + w_dim1], mdw) * xnorm + (r__1 = w[i__ + np1 * w_dim1], abs(r__1)); /*< IF (.NOT.(W(I,NP1).GT.TAU*SIZE)) GO TO 300 >*/ #line 556 "cl2.f" if (! (w[i__ + np1 * w_dim1] > tau * size)) { #line 556 "cl2.f" goto L300; #line 556 "cl2.f" } /*< MODE = MODE + 2 >*/ #line 557 "cl2.f" *mode += 2; /*< GO TO 450 >*/ #line 558 "cl2.f" goto L450; /*< 300 CONTINUE >*/ #line 559 "cl2.f" L300: /*< 310 CONTINUE >*/ #line 560 "cl2.f" /* L310: */ #line 560 "cl2.f" ; #line 560 "cl2.f" } /*< 320 CONTINUE >*/ #line 561 "cl2.f" L320: /*< 330 IF (.NOT.(KRANKE.GT.0)) GO TO 420 >*/ #line 562 "cl2.f" L330: #line 562 "cl2.f" if (! (kranke > 0)) { #line 562 "cl2.f" goto L420; #line 562 "cl2.f" } /* REPLACE DIAG. TERMS OF LOWER TRAP. MATRIX. */ /*< CALL SCOPY(KRANKE, WS(KRANKE+1), 1, W, MDW+1) >*/ #line 565 "cl2.f" i__1 = *mdw + 1; #line 565 "cl2.f" scopy_(&kranke, &ws[kranke + 1], &c__1, &w[w_offset], &i__1); /* REAPPLY TRANS TO PUT SOLN IN ORIGINAL COORDINATES. */ /*< DO 340 II=1,KRANKE >*/ #line 568 "cl2.f" i__1 = kranke; #line 568 "cl2.f" for (ii = 1; ii <= i__1; ++ii) { /*< I = KRANKE + 1 - II >*/ #line 569 "cl2.f" i__ = kranke + 1 - ii; /*< CALL H12(2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) >*/ #line 570 "cl2.f" i__2 = i__ + 1; #line 570 "cl2.f" h12_(&c__2, &i__, &i__2, n, &w[i__ + w_dim1], mdw, &ws[i__], &x[1], & c__1, &c__1, &c__1); /*< 340 CONTINUE >*/ #line 571 "cl2.f" /* L340: */ #line 571 "cl2.f" } /* COMPUTE COV MATRIX OF EQUAL. CONSTRAINED PROBLEM. */ /*< IF (.NOT.(COV)) GO TO 410 >*/ #line 574 "cl2.f" if (! cov) { #line 574 "cl2.f" goto L410; #line 574 "cl2.f" } /*< DO 400 JJ=1,KRANKE >*/ #line 575 "cl2.f" i__1 = kranke; #line 575 "cl2.f" for (jj = 1; jj <= i__1; ++jj) { /*< J = KRANKE + 1 - JJ >*/ #line 576 "cl2.f" j = kranke + 1 - jj; /*< IF (.NOT.(J.LT.N)) GO TO 390 >*/ #line 577 "cl2.f" if (! (j < *n)) { #line 577 "cl2.f" goto L390; #line 577 "cl2.f" } /*< RB = WS(J)*W(J,J) >*/ #line 578 "cl2.f" rb = ws[j] * w[j + j * w_dim1]; /*< IF (RB.NE.ZERO) RB = ONE/RB >*/ #line 579 "cl2.f" if (rb != zero) { #line 579 "cl2.f" rb = one / rb; #line 579 "cl2.f" } /*< JP1 = J + 1 >*/ #line 580 "cl2.f" jp1 = j + 1; /*< DO 350 I=JP1,N >*/ #line 581 "cl2.f" i__2 = *n; #line 581 "cl2.f" for (i__ = jp1; i__ <= i__2; ++i__) { /*< W(I,J) = SDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW)*RB >*/ #line 582 "cl2.f" i__3 = *n - j; #line 582 "cl2.f" w[i__ + j * w_dim1] = sdot_(&i__3, &w[i__ + jp1 * w_dim1], mdw, & w[j + jp1 * w_dim1], mdw) * rb; /*< 350 CONTINUE >*/ #line 583 "cl2.f" /* L350: */ #line 583 "cl2.f" } /*< GAM = SDOT(N-J,W(JP1,J),1,W(J,JP1),MDW)*RB >*/ #line 584 "cl2.f" i__2 = *n - j; #line 584 "cl2.f" gam = sdot_(&i__2, &w[jp1 + j * w_dim1], &c__1, &w[j + jp1 * w_dim1], mdw) * rb; /*< GAM = HALF*GAM >*/ #line 585 "cl2.f" gam = half * gam; /*< CALL SAXPY(N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) >*/ #line 586 "cl2.f" i__2 = *n - j; #line 586 "cl2.f" saxpy_(&i__2, &gam, &w[j + jp1 * w_dim1], mdw, &w[jp1 + j * w_dim1], & c__1); /*< DO 370 I=JP1,N >*/ #line 587 "cl2.f" i__2 = *n; #line 587 "cl2.f" for (i__ = jp1; i__ <= i__2; ++i__) { /*< DO 360 K=I,N >*/ #line 588 "cl2.f" i__3 = *n; #line 588 "cl2.f" for (k = i__; k <= i__3; ++k) { /*< W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) >*/ #line 589 "cl2.f" w[i__ + k * w_dim1] = w[i__ + k * w_dim1] + w[j + i__ * w_dim1] * w[k + j * w_dim1] + w[i__ + j * w_dim1] * w[ j + k * w_dim1]; /*< W(K,I) = W(I,K) >*/ #line 590 "cl2.f" w[k + i__ * w_dim1] = w[i__ + k * w_dim1]; /*< 360 CONTINUE >*/ #line 591 "cl2.f" /* L360: */ #line 591 "cl2.f" } /*< 370 CONTINUE >*/ #line 592 "cl2.f" /* L370: */ #line 592 "cl2.f" } /*< UJ = WS(J) >*/ #line 593 "cl2.f" uj = ws[j]; /*< VJ = GAM*UJ >*/ #line 594 "cl2.f" vj = gam * uj; /*< W(J,J) = UJ*VJ + UJ*VJ >*/ #line 595 "cl2.f" w[j + j * w_dim1] = uj * vj + uj * vj; /*< DO 380 I=JP1,N >*/ #line 596 "cl2.f" i__2 = *n; #line 596 "cl2.f" for (i__ = jp1; i__ <= i__2; ++i__) { /*< W(J,I) = UJ*W(I,J) + VJ*W(J,I) >*/ #line 597 "cl2.f" w[j + i__ * w_dim1] = uj * w[i__ + j * w_dim1] + vj * w[j + i__ * w_dim1]; /*< 380 CONTINUE >*/ #line 598 "cl2.f" /* L380: */ #line 598 "cl2.f" } /*< CALL SCOPY(N-J, W(J,JP1), MDW, W(JP1,J), 1) >*/ #line 599 "cl2.f" i__2 = *n - j; #line 599 "cl2.f" scopy_(&i__2, &w[j + jp1 * w_dim1], mdw, &w[jp1 + j * w_dim1], &c__1); /*< 390 CONTINUE >*/ #line 600 "cl2.f" L390: /*< 400 CONTINUE >*/ #line 601 "cl2.f" /* L400: */ #line 601 "cl2.f" ; #line 601 "cl2.f" } /*< 410 CONTINUE >*/ #line 602 "cl2.f" L410: /* APPLY THE SCALING TO THE COVARIANCE MATRIX. */ /*< 420 IF (.NOT.(COV)) GO TO 440 >*/ #line 605 "cl2.f" L420: #line 605 "cl2.f" if (! cov) { #line 605 "cl2.f" goto L440; #line 605 "cl2.f" } /*< DO 430 I=1,N >*/ #line 606 "cl2.f" i__1 = *n; #line 606 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< L = N1 + I >*/ #line 607 "cl2.f" l = n1 + i__; /*< CALL SSCAL(N, WS(L-1), W(I,1), MDW) >*/ #line 608 "cl2.f" sscal_(n, &ws[l - 1], &w[i__ + w_dim1], mdw); /*< CALL SSCAL(N, WS(L-1), W(1,I), 1) >*/ #line 609 "cl2.f" sscal_(n, &ws[l - 1], &w[i__ * w_dim1 + 1], &c__1); /*< 430 CONTINUE >*/ #line 610 "cl2.f" /* L430: */ #line 610 "cl2.f" } /*< 440 CONTINUE >*/ #line 611 "cl2.f" L440: /*< 450 CONTINUE >*/ #line 612 "cl2.f" L450: /* RESCALE SOLN. VECTOR. */ /*< IF (.NOT.(MODE.LE.1)) GO TO 470 >*/ #line 615 "cl2.f" if (! (*mode <= 1)) { #line 615 "cl2.f" goto L470; #line 615 "cl2.f" } /*< DO 460 J=1,N >*/ #line 616 "cl2.f" i__1 = *n; #line 616 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< L = N1 + J >*/ #line 617 "cl2.f" l = n1 + j; /*< X(J) = X(J)*WS(L-1) >*/ #line 618 "cl2.f" x[j] *= ws[l - 1]; /*< 460 CONTINUE >*/ #line 619 "cl2.f" /* L460: */ #line 619 "cl2.f" } /*< 470 IP(1) = KRANKE >*/ #line 620 "cl2.f" L470: #line 620 "cl2.f" ip[1] = kranke; /*< IP(3) = IP(3) + 2*KRANKE + N >*/ #line 621 "cl2.f" ip[3] = ip[3] + (kranke << 1) + *n; /*< RETURN >*/ #line 622 "cl2.f" return 0; /*< 480 CONTINUE >*/ #line 623 "cl2.f" L480: /* TO PROCESS-OPTION-VECTOR */ /* THE NOMINAL TOLERANCE USED IN THE CODE */ /* FOR THE EQUALITY CONSTRAINT EQUATIONS. */ /*< TAU = SQRT(SRELPR) >*/ #line 628 "cl2.f" tau = sqrt(srelpr); /* THE NOMINAL COLUMN SCALING USED IN THE CODE IS */ /* THE IDENTITY SCALING. */ /*< WS(N1) = ONE >*/ #line 632 "cl2.f" ws[n1] = one; /*< CALL SCOPY(N, WS(N1), 0, WS(N1), 1) >*/ #line 633 "cl2.f" scopy_(n, &ws[n1], &c__0, &ws[n1], &c__1); /* NO COVARIANCE MATRIX IS NOMINALLY COMPUTED. */ /*< COV = .FALSE. >*/ #line 636 "cl2.f" cov = FALSE_; /* DEFINE BOUND FOR NUMBER OF OPTIONS TO CHANGE. */ /*< NOPT = 1000 >*/ #line 639 "cl2.f" nopt = 1000; /*< NTIMES = 0 >*/ #line 640 "cl2.f" ntimes = 0; /* DEFINE BOUND FOR POSITIVE VALUES OF LINK. */ /*< NLINK = 100000 >*/ #line 643 "cl2.f" nlink = 100000; /*< LAST = 1 >*/ #line 644 "cl2.f" last = 1; /*< LINK = PRGOPT(1) >*/ #line 645 "cl2.f" link = prgopt[1]; /*< IF (.NOT.(LINK.LE.0 .OR. LINK.GT.NLINK)) GO TO 490 >*/ #line 646 "cl2.f" if (! (link <= 0 || link > nlink)) { #line 646 "cl2.f" goto L490; #line 646 "cl2.f" } /*< NERR = 3 >*/ #line 647 "cl2.f" nerr = 3; /*< IOPT = 1 >*/ #line 648 "cl2.f" iopt = 1; /* cc CALL XERROR(38HLSEI( ) THE OPTION VECTOR IS UNDEFINED, 38, NERR, */ /* cc * IOPT) */ /*< MODE = 4 >*/ #line 651 "cl2.f" *mode = 4; /*< RETURN >*/ #line 652 "cl2.f" return 0; /*< 490 IF (.NOT.(LINK.GT.1)) GO TO 540 >*/ #line 653 "cl2.f" L490: #line 653 "cl2.f" if (! (link > 1)) { #line 653 "cl2.f" goto L540; #line 653 "cl2.f" } /*< NTIMES = NTIMES + 1 >*/ #line 654 "cl2.f" ++ntimes; /*< IF (.NOT.(NTIMES.GT.NOPT)) GO TO 500 >*/ #line 655 "cl2.f" if (! (ntimes > nopt)) { #line 655 "cl2.f" goto L500; #line 655 "cl2.f" } /*< NERR = 3 >*/ #line 656 "cl2.f" nerr = 3; /*< IOPT = 1 >*/ #line 657 "cl2.f" iopt = 1; /* cc CALL XERROR( */ /* cc * 52HLSEI( ). THE LINKS IN THE OPTION VECTOR ARE CYCLING., 52, */ /* cc * NERR, IOPT) */ /*< MODE = 4 >*/ #line 661 "cl2.f" *mode = 4; /*< RETURN >*/ #line 662 "cl2.f" return 0; /*< 500 KEY = PRGOPT(LAST+1) >*/ #line 663 "cl2.f" L500: #line 663 "cl2.f" key = prgopt[last + 1]; /*< IF (KEY.EQ.1) COV = PRGOPT(LAST+2).NE.ZERO >*/ #line 664 "cl2.f" if (key == 1) { #line 664 "cl2.f" cov = prgopt[last + 2] != zero; #line 664 "cl2.f" } /*< IF (.NOT.(KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.ZERO)) GO TO 520 >*/ #line 665 "cl2.f" if (! (key == 2 && prgopt[last + 2] != zero)) { #line 665 "cl2.f" goto L520; #line 665 "cl2.f" } /*< DO 510 J=1,N >*/ #line 666 "cl2.f" i__1 = *n; #line 666 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< T = SNRM2(M,W(1,J),1) >*/ #line 667 "cl2.f" t = snrm2_(&m, &w[j * w_dim1 + 1], &c__1); /*< IF (T.NE.ZERO) T = ONE/T >*/ #line 668 "cl2.f" if (t != zero) { #line 668 "cl2.f" t = one / t; #line 668 "cl2.f" } /*< L = N1 + J >*/ #line 669 "cl2.f" l = n1 + j; /*< WS(L-1) = T >*/ #line 670 "cl2.f" ws[l - 1] = t; /*< 510 CONTINUE >*/ #line 671 "cl2.f" /* L510: */ #line 671 "cl2.f" } /*< 520 IF (KEY.EQ.3) CALL SCOPY(N, PRGOPT(LAST+2), 1, WS(N1), 1) >*/ #line 672 "cl2.f" L520: #line 672 "cl2.f" if (key == 3) { #line 672 "cl2.f" scopy_(n, &prgopt[last + 2], &c__1, &ws[n1], &c__1); #line 672 "cl2.f" } /*< IF (KEY.EQ.4) TAU = AMAX1(SRELPR,PRGOPT(LAST+2)) >*/ #line 673 "cl2.f" if (key == 4) { /* Computing MAX */ #line 673 "cl2.f" r__1 = srelpr, r__2 = prgopt[last + 2]; #line 673 "cl2.f" tau = max(r__1,r__2); #line 673 "cl2.f" } /*< NEXT = PRGOPT(LINK) >*/ #line 674 "cl2.f" next = prgopt[link]; /*< IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.NLINK)) GO TO 530 >*/ #line 675 "cl2.f" if (! (next <= 0 || next > nlink)) { #line 675 "cl2.f" goto L530; #line 675 "cl2.f" } /*< NERR = 3 >*/ #line 676 "cl2.f" nerr = 3; /*< IOPT = 1 >*/ #line 677 "cl2.f" iopt = 1; /* cc CALL XERROR(38HLSEI( ) THE OPTION VECTOR IS UNDEFINED, 38, NERR, */ /* cc * IOPT) */ /*< MODE = 4 >*/ #line 680 "cl2.f" *mode = 4; /*< RETURN >*/ #line 681 "cl2.f" return 0; /*< 530 LAST = LINK >*/ #line 682 "cl2.f" L530: #line 682 "cl2.f" last = link; /*< LINK = NEXT >*/ #line 683 "cl2.f" link = next; /*< GO TO 490 >*/ #line 684 "cl2.f" goto L490; /*< 540 DO 550 J=1,N >*/ #line 685 "cl2.f" L540: #line 685 "cl2.f" i__1 = *n; #line 685 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< L = N1 + J >*/ #line 686 "cl2.f" l = n1 + j; /*< CALL SSCAL(M, WS(L-1), W(1,J), 1) >*/ #line 687 "cl2.f" sscal_(&m, &ws[l - 1], &w[j * w_dim1 + 1], &c__1); /*< 550 CONTINUE >*/ #line 688 "cl2.f" /* L550: */ #line 688 "cl2.f" } /*< GO TO 560 >*/ #line 689 "cl2.f" goto L560; /*< 560 GO TO IGO990, (90) >*/ #line 690 "cl2.f" L560: #line 690 "cl2.f" switch (igo990) { #line 690 "cl2.f" case 0: goto L90; #line 690 "cl2.f" } /*< END >*/ } /* lsei_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE LSI(W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, IP) >*/ static /* Subroutine */ int lsi_(real *w, integer *mdw, integer *ma, integer *mg, integer *n, real *prgopt, real *x, real *rnorm, integer *mode, real * ws, integer *ip) { /* Initialized data */ static real zero = 0.f; static real srelpr = 0.f; static real one = 1.f; static real half = .5f; /* Format strings */ static char fmt_40[] = ""; static char fmt_60[] = ""; /* System generated locals */ integer w_dim1, w_offset, i__1, i__2, i__3, i__4; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, k, l, m, n1, n2, n3; static integer ii; static real rb; static integer il, im1, ip1, np1; static real fac, gam, tau; static logical cov; static integer key; static real tol; static integer map1, krm1, krp1; static integer link; static integer last; static integer next, igo990, igo994; static integer krank; static real anorm; static real xnorm; static integer minman, mdlpdp; /* Assigned format variables */ static char *igo994_fmt, *igo990_fmt; /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (START EDITING AT LINE WITH C++ IN COLS. 1-3.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/,/SDOT/DDOT/, */ /* / SQRT/ DSQRT/,/AMAX1/DMAX1/,/SSWAP/DSWAP/, */ /* /SCOPY/DCOPY/,/SSCAL/DSCAL/,/SAXPY/DAXPY/,/E0/D0/,/SRELPR/DRELPR/ */ /* THIS IS A COMPANION SUBPROGRAM TO LSEI( ). */ /* THE DOCUMENTATION FOR LSEI( ) HAS MORE COMPLETE */ /* USAGE INSTRUCTIONS. */ /* WRITTEN BY R. J. HANSON, SLA. */ /* SOLVE.. */ /* AX = B, A MA BY N (LEAST SQUARES EQUATIONS) */ /* SUBJECT TO.. */ /* GX.GE.H, G MG BY N (INEQUALITY CONSTRAINTS) */ /* INPUT.. */ /* W(*,*) CONTAINS (A B) IN ROWS 1,...,MA+MG, COLS 1,...,N+1. */ /* (G H) */ /* MDW,MA,MG,N */ /* CONTAIN (RESP) VAR. DIMENSION OF W(*,*), */ /* AND MATRIX DIMENSIONS. */ /* PRGOPT(*), */ /* PROGRAM OPTION VECTOR. */ /* OUTPUT.. */ /* X(*),RNORM */ /* SOLUTION VECTOR(UNLESS MODE=2), LENGTH OF AX-B. */ /* MODE */ /* =0 INEQUALITY CONSTRAINTS ARE COMPATIBLE. */ /* =2 INEQUALITY CONSTRAINTS CONTRADICTORY. */ /* WS(*), */ /* WORKING STORAGE OF DIMENSION K+N+(MG+2)*(N+7), */ /* WHERE K=MAX(MA+MG,N). */ /* IP(MG+2*N+1) */ /* INTEGER WORKING STORAGE */ /* REVISED OCT. 1, 1981. */ /* SUBROUTINES CALLED */ /* LPDP THIS SUBPROGRAM MINIMIZES A SUM OF SQUARES */ /* OF UNKNOWNS SUBJECT TO LINEAR INEQUALITY */ /* CONSTRAINTS. PART OF THIS PACKAGE. */ /* ++ */ /* SDOT,SSCAL SUBROUTINES FROM THE BLAS PACKAGE. */ /* SAXPY,SASUM, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. */ /* SCOPY,SSWAP */ /* HFTI SOLVES AN UNCONSTRAINED LINEAR LEAST SQUARES */ /* PROBLEM. PART OF THIS PACKAGE. */ /* H12 SUBROUTINE TO CONSTRUCT AND APPLY A HOUSEHOLDER */ /* TRANSFORMATION. */ /* SUBROUTINE LSI(W,MDW,MA,MG,N,PRGOPT,X,RNORM,MODE,WS,IP) */ /*< REAL W(MDW,1), PRGOPT(1), RNORM, WS(1), X(1) >*/ /*< INTEGER IP(1) >*/ /*< >*/ /*< REAL SASUM, SDOT, SQRT, AMAX1 >*/ /*< LOGICAL COV >*/ /*< DATA ZERO /0.E0/, SRELPR /0.E0/, ONE /1.E0/, HALF /.5E0/ >*/ #line 771 "cl2.f" /* Parameter adjustments */ #line 771 "cl2.f" w_dim1 = *mdw; #line 771 "cl2.f" w_offset = 1 + w_dim1; #line 771 "cl2.f" w -= w_offset; #line 771 "cl2.f" --prgopt; #line 771 "cl2.f" --x; #line 771 "cl2.f" --ws; #line 771 "cl2.f" --ip; #line 771 "cl2.f" #line 771 "cl2.f" /* Function Body */ /* COMPUTE MACHINE PRECISION=SRELPR ONLY WHEN NECESSARY. */ /*< IF (.NOT.(SRELPR.EQ.ZERO)) GO TO 30 >*/ #line 774 "cl2.f" if (! (srelpr == zero)) { #line 774 "cl2.f" goto L30; #line 774 "cl2.f" } /*< SRELPR = ONE >*/ #line 775 "cl2.f" srelpr = one; /*< 10 IF (ONE+SRELPR.EQ.ONE) GO TO 20 >*/ #line 776 "cl2.f" L10: #line 776 "cl2.f" if (one + srelpr == one) { #line 776 "cl2.f" goto L20; #line 776 "cl2.f" } /*< SRELPR = SRELPR*HALF >*/ #line 777 "cl2.f" srelpr *= half; /*< GO TO 10 >*/ #line 778 "cl2.f" goto L10; /*< 20 SRELPR = SRELPR + SRELPR >*/ #line 779 "cl2.f" L20: #line 779 "cl2.f" srelpr += srelpr; /*< 30 MODE = 0 >*/ #line 780 "cl2.f" L30: #line 780 "cl2.f" *mode = 0; /*< RNORM = ZERO >*/ #line 781 "cl2.f" *rnorm = zero; /*< M = MA + MG >*/ #line 782 "cl2.f" m = *ma + *mg; /*< NP1 = N + 1 >*/ #line 783 "cl2.f" np1 = *n + 1; /*< KRANK = 0 >*/ #line 784 "cl2.f" krank = 0; /*< IF (N.LE.0 .OR. M.LE.0) GO TO 70 >*/ #line 785 "cl2.f" if (*n <= 0 || m <= 0) { #line 785 "cl2.f" goto L70; #line 785 "cl2.f" } /*< ASSIGN 40 TO IGO994 >*/ #line 786 "cl2.f" igo994 = 0; #line 786 "cl2.f" igo994_fmt = fmt_40; /*< GO TO 500 >*/ #line 787 "cl2.f" goto L500; /* PROCESS-OPTION-VECTOR */ /* COMPUTE MATRIX NORM OF LEAST SQUARES EQUAS. */ /*< 40 ANORM = ZERO >*/ #line 792 "cl2.f" L40: #line 792 "cl2.f" anorm = zero; /*< DO 50 J=1,N >*/ #line 793 "cl2.f" i__1 = *n; #line 793 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< ANORM = AMAX1(ANORM,SASUM(MA,W(1,J),1)) >*/ /* Computing MAX */ #line 794 "cl2.f" r__1 = anorm, r__2 = sasum_(ma, &w[j * w_dim1 + 1], &c__1); #line 794 "cl2.f" anorm = max(r__1,r__2); /*< 50 CONTINUE >*/ #line 795 "cl2.f" /* L50: */ #line 795 "cl2.f" } /* SET TOL FOR HFTI( ) RANK TEST. */ /*< TAU = TOL*ANORM >*/ #line 798 "cl2.f" tau = tol * anorm; /* COMPUTE HOUSEHOLDER ORTHOGONAL DECOMP OF MATRIX. */ /*< IF (N.GT.0) WS(1) = ZERO >*/ #line 801 "cl2.f" if (*n > 0) { #line 801 "cl2.f" ws[1] = zero; #line 801 "cl2.f" } /*< CALL SCOPY(N, WS, 0, WS, 1) >*/ #line 802 "cl2.f" scopy_(n, &ws[1], &c__0, &ws[1], &c__1); /*< CALL SCOPY(MA, W(1,NP1), 1, WS, 1) >*/ #line 803 "cl2.f" scopy_(ma, &w[np1 * w_dim1 + 1], &c__1, &ws[1], &c__1); /*< K = MAX0(M,N) >*/ #line 804 "cl2.f" k = max(m,*n); /*< MINMAN = MIN0(MA,N) >*/ #line 805 "cl2.f" minman = min(*ma,*n); /*< N1 = K + 1 >*/ #line 806 "cl2.f" n1 = k + 1; /*< N2 = N1 + N >*/ #line 807 "cl2.f" n2 = n1 + *n; /*< >*/ #line 808 "cl2.f" hfti_(&w[w_offset], mdw, ma, n, &ws[1], &c__1, &c__1, &tau, &krank, rnorm, &ws[n2], &ws[n1], &ip[1]); /*< FAC = ONE >*/ #line 810 "cl2.f" fac = one; /*< GAM=MA-KRANK >*/ #line 811 "cl2.f" gam = (real) (*ma - krank); /*< IF (KRANK.LT.MA) FAC = RNORM**2/GAM >*/ #line 812 "cl2.f" if (krank < *ma) { /* Computing 2nd power */ #line 812 "cl2.f" r__1 = *rnorm; #line 812 "cl2.f" fac = r__1 * r__1 / gam; #line 812 "cl2.f" } /*< ASSIGN 60 TO IGO990 >*/ #line 813 "cl2.f" igo990 = 0; #line 813 "cl2.f" igo990_fmt = fmt_60; /*< GO TO 80 >*/ #line 814 "cl2.f" goto L80; /* REDUCE-TO-LPDP-AND-SOLVE */ /*< 60 CONTINUE >*/ #line 817 "cl2.f" L60: /*< 70 IP(1) = KRANK >*/ #line 818 "cl2.f" L70: #line 818 "cl2.f" ip[1] = krank; /*< IP(2) = N + MAX0(M,N) + (MG+2)*(N+7) >*/ #line 819 "cl2.f" ip[2] = *n + max(m,*n) + (*mg + 2) * (*n + 7); /*< RETURN >*/ #line 820 "cl2.f" return 0; /*< 80 CONTINUE >*/ #line 821 "cl2.f" L80: /* TO REDUCE-TO-LPDP-AND-SOLVE */ /*< MAP1 = MA + 1 >*/ #line 824 "cl2.f" map1 = *ma + 1; /* COMPUTE INEQ. RT-HAND SIDE FOR LPDP. */ /*< IF (.NOT.(MA.LT.M)) GO TO 260 >*/ #line 827 "cl2.f" if (! (*ma < m)) { #line 827 "cl2.f" goto L260; #line 827 "cl2.f" } /*< IF (.NOT.(MINMAN.GT.0)) GO TO 160 >*/ #line 828 "cl2.f" if (! (minman > 0)) { #line 828 "cl2.f" goto L160; #line 828 "cl2.f" } /*< DO 90 I=MAP1,M >*/ #line 829 "cl2.f" i__1 = m; #line 829 "cl2.f" for (i__ = map1; i__ <= i__1; ++i__) { /*< W(I,NP1) = W(I,NP1) - SDOT(N,W(I,1),MDW,WS,1) >*/ #line 830 "cl2.f" w[i__ + np1 * w_dim1] -= sdot_(n, &w[i__ + w_dim1], mdw, &ws[1], & c__1); /*< 90 CONTINUE >*/ #line 831 "cl2.f" /* L90: */ #line 831 "cl2.f" } /*< DO 100 I=1,MINMAN >*/ #line 832 "cl2.f" i__1 = minman; #line 832 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< J = IP(I) >*/ #line 833 "cl2.f" j = ip[i__]; /* APPLY PERMUTATIONS TO COLS OF INEQ. CONSTRAINT MATRIX. */ /*< CALL SSWAP(MG, W(MAP1,I), 1, W(MAP1,J), 1) >*/ #line 836 "cl2.f" sswap_(mg, &w[map1 + i__ * w_dim1], &c__1, &w[map1 + j * w_dim1], & c__1); /*< 100 CONTINUE >*/ #line 837 "cl2.f" /* L100: */ #line 837 "cl2.f" } /* APPLY HOUSEHOLDER TRANSFORMATIONS TO CONSTRAINT MATRIX. */ /*< IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 120 >*/ #line 840 "cl2.f" if (! (0 < krank && krank < *n)) { #line 840 "cl2.f" goto L120; #line 840 "cl2.f" } /*< DO 110 II=1,KRANK >*/ #line 841 "cl2.f" i__1 = krank; #line 841 "cl2.f" for (ii = 1; ii <= i__1; ++ii) { /*< I = KRANK + 1 - II >*/ #line 842 "cl2.f" i__ = krank + 1 - ii; /*< L = N1 + I >*/ #line 843 "cl2.f" l = n1 + i__; /*< >*/ #line 844 "cl2.f" i__2 = krank + 1; #line 844 "cl2.f" h12_(&c__2, &i__, &i__2, n, &w[i__ + w_dim1], mdw, &ws[l - 1], &w[ map1 + w_dim1], mdw, &c__1, mg); /*< 110 CONTINUE >*/ #line 846 "cl2.f" /* L110: */ #line 846 "cl2.f" } /* COMPUTE PERMUTED INEQ. CONSTR. MATRIX TIMES R-INVERSE. */ /*< 120 DO 150 I=MAP1,M >*/ #line 849 "cl2.f" L120: #line 849 "cl2.f" i__1 = m; #line 849 "cl2.f" for (i__ = map1; i__ <= i__1; ++i__) { /*< IF (.NOT.(0.LT.KRANK)) GO TO 140 >*/ #line 850 "cl2.f" if (! (0 < krank)) { #line 850 "cl2.f" goto L140; #line 850 "cl2.f" } /*< DO 130 J=1,KRANK >*/ #line 851 "cl2.f" i__2 = krank; #line 851 "cl2.f" for (j = 1; j <= i__2; ++j) { /*< W(I,J) = (W(I,J)-SDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) >*/ #line 852 "cl2.f" i__3 = j - 1; #line 852 "cl2.f" w[i__ + j * w_dim1] = (w[i__ + j * w_dim1] - sdot_(&i__3, &w[j * w_dim1 + 1], &c__1, &w[i__ + w_dim1], mdw)) / w[j + j * w_dim1]; /*< 130 CONTINUE >*/ #line 853 "cl2.f" /* L130: */ #line 853 "cl2.f" } /*< 140 CONTINUE >*/ #line 854 "cl2.f" L140: /*< 150 CONTINUE >*/ #line 855 "cl2.f" /* L150: */ #line 855 "cl2.f" ; #line 855 "cl2.f" } /* SOLVE THE REDUCED PROBLEM WITH LPDP ALGORITHM, */ /* THE LEAST PROJECTED DISTANCE PROBLEM. */ /*< >*/ #line 859 "cl2.f" L160: #line 859 "cl2.f" i__1 = *n - krank; #line 859 "cl2.f" lpdp_(&w[map1 + w_dim1], mdw, mg, &krank, &i__1, &prgopt[1], &x[1], & xnorm, &mdlpdp, &ws[n2], &ip[*n + 1]); /*< IF (.NOT.(MDLPDP.EQ.1)) GO TO 240 >*/ #line 861 "cl2.f" if (! (mdlpdp == 1)) { #line 861 "cl2.f" goto L240; #line 861 "cl2.f" } /*< IF (.NOT.(KRANK.GT.0)) GO TO 180 >*/ #line 862 "cl2.f" if (! (krank > 0)) { #line 862 "cl2.f" goto L180; #line 862 "cl2.f" } /* COMPUTE SOLN IN ORIGINAL COORDINATES. */ /*< DO 170 II=1,KRANK >*/ #line 865 "cl2.f" i__1 = krank; #line 865 "cl2.f" for (ii = 1; ii <= i__1; ++ii) { /*< I = KRANK + 1 - II >*/ #line 866 "cl2.f" i__ = krank + 1 - ii; /*< X(I) = (X(I)-SDOT(II-1,W(I,I+1),MDW,X(I+1),1))/W(I,I) >*/ #line 867 "cl2.f" i__2 = ii - 1; #line 867 "cl2.f" x[i__] = (x[i__] - sdot_(&i__2, &w[i__ + (i__ + 1) * w_dim1], mdw, &x[ i__ + 1], &c__1)) / w[i__ + i__ * w_dim1]; /*< 170 CONTINUE >*/ #line 868 "cl2.f" /* L170: */ #line 868 "cl2.f" } /* APPLY HOUSEHOLDER TRANS. TO SOLN VECTOR. */ /*< 180 IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 200 >*/ #line 871 "cl2.f" L180: #line 871 "cl2.f" if (! (0 < krank && krank < *n)) { #line 871 "cl2.f" goto L200; #line 871 "cl2.f" } /*< DO 190 I=1,KRANK >*/ #line 872 "cl2.f" i__1 = krank; #line 872 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< L = N1 + I >*/ #line 873 "cl2.f" l = n1 + i__; /*< CALL H12(2, I, KRANK+1, N, W(I,1), MDW, WS(L-1), X, 1, 1, 1) >*/ #line 874 "cl2.f" i__2 = krank + 1; #line 874 "cl2.f" h12_(&c__2, &i__, &i__2, n, &w[i__ + w_dim1], mdw, &ws[l - 1], &x[1], &c__1, &c__1, &c__1); /*< 190 CONTINUE >*/ #line 875 "cl2.f" /* L190: */ #line 875 "cl2.f" } /*< 200 IF (.NOT.(MINMAN.GT.0)) GO TO 230 >*/ #line 876 "cl2.f" L200: #line 876 "cl2.f" if (! (minman > 0)) { #line 876 "cl2.f" goto L230; #line 876 "cl2.f" } /* REPERMUTE VARIABLES TO THEIR INPUT ORDER. */ /*< DO 210 II=1,MINMAN >*/ #line 879 "cl2.f" i__1 = minman; #line 879 "cl2.f" for (ii = 1; ii <= i__1; ++ii) { /*< I = MINMAN + 1 - II >*/ #line 880 "cl2.f" i__ = minman + 1 - ii; /*< J = IP(I) >*/ #line 881 "cl2.f" j = ip[i__]; /*< CALL SSWAP(1, X(I), 1, X(J), 1) >*/ #line 882 "cl2.f" sswap_(&c__1, &x[i__], &c__1, &x[j], &c__1); /*< 210 CONTINUE >*/ #line 883 "cl2.f" /* L210: */ #line 883 "cl2.f" } /* VARIABLES ARE NOW IN ORIG. COORDINATES. */ /* ADD SOLN OF UNSCONSTRAINED PROB. */ /*< DO 220 I=1,N >*/ #line 887 "cl2.f" i__1 = *n; #line 887 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< X(I) = X(I) + WS(I) >*/ #line 888 "cl2.f" x[i__] += ws[i__]; /*< 220 CONTINUE >*/ #line 889 "cl2.f" /* L220: */ #line 889 "cl2.f" } /* COMPUTE THE RESIDUAL VECTOR NORM. */ /*< RNORM = SQRT(RNORM**2+XNORM**2) >*/ /* Computing 2nd power */ #line 892 "cl2.f" r__1 = *rnorm; /* Computing 2nd power */ #line 892 "cl2.f" r__2 = xnorm; #line 892 "cl2.f" *rnorm = sqrt(r__1 * r__1 + r__2 * r__2); /*< 230 GO TO 250 >*/ #line 893 "cl2.f" L230: #line 893 "cl2.f" goto L250; /*< 240 MODE = 2 >*/ #line 894 "cl2.f" L240: #line 894 "cl2.f" *mode = 2; /*< 250 GO TO 270 >*/ #line 895 "cl2.f" L250: #line 895 "cl2.f" goto L270; /*< 260 CALL SCOPY(N, WS, 1, X, 1) >*/ #line 896 "cl2.f" L260: #line 896 "cl2.f" scopy_(n, &ws[1], &c__1, &x[1], &c__1); /*< 270 IF (.NOT.(COV .AND. KRANK.GT.0)) GO TO 490 >*/ #line 897 "cl2.f" L270: #line 897 "cl2.f" if (! (cov && krank > 0)) { #line 897 "cl2.f" goto L490; #line 897 "cl2.f" } /* COMPUTE COVARIANCE MATRIX BASED ON THE ORTHOGONAL DECOMP. */ /* FROM HFTI( ). */ /*< KRM1 = KRANK - 1 >*/ #line 902 "cl2.f" krm1 = krank - 1; /*< KRP1 = KRANK + 1 >*/ #line 903 "cl2.f" krp1 = krank + 1; /* COPY DIAG. TERMS TO WORKING ARRAY. */ /*< CALL SCOPY(KRANK, W, MDW+1, WS(N2), 1) >*/ #line 906 "cl2.f" i__1 = *mdw + 1; #line 906 "cl2.f" scopy_(&krank, &w[w_offset], &i__1, &ws[n2], &c__1); /* RECIPROCATE DIAG. TERMS. */ /*< DO 280 J=1,KRANK >*/ #line 909 "cl2.f" i__1 = krank; #line 909 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< W(J,J) = ONE/W(J,J) >*/ #line 910 "cl2.f" w[j + j * w_dim1] = one / w[j + j * w_dim1]; /*< 280 CONTINUE >*/ #line 911 "cl2.f" /* L280: */ #line 911 "cl2.f" } /*< IF (.NOT.(KRANK.GT.1)) GO TO 310 >*/ #line 912 "cl2.f" if (! (krank > 1)) { #line 912 "cl2.f" goto L310; #line 912 "cl2.f" } /* INVERT THE UPPER TRIANGULAR QR FACTOR ON ITSELF. */ /*< DO 300 I=1,KRM1 >*/ #line 915 "cl2.f" i__1 = krm1; #line 915 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< IP1 = I + 1 >*/ #line 916 "cl2.f" ip1 = i__ + 1; /*< DO 290 J=IP1,KRANK >*/ #line 917 "cl2.f" i__2 = krank; #line 917 "cl2.f" for (j = ip1; j <= i__2; ++j) { /*< W(I,J) = -SDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) >*/ #line 918 "cl2.f" i__3 = j - i__; #line 918 "cl2.f" w[i__ + j * w_dim1] = -sdot_(&i__3, &w[i__ + i__ * w_dim1], mdw, & w[i__ + j * w_dim1], &c__1) * w[j + j * w_dim1]; /*< 290 CONTINUE >*/ #line 919 "cl2.f" /* L290: */ #line 919 "cl2.f" } /*< 300 CONTINUE >*/ #line 920 "cl2.f" /* L300: */ #line 920 "cl2.f" } /* COMPUTE THE INVERTED FACTOR TIMES ITS TRANSPOSE. */ /*< 310 DO 330 I=1,KRANK >*/ #line 923 "cl2.f" L310: #line 923 "cl2.f" i__1 = krank; #line 923 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< DO 320 J=I,KRANK >*/ #line 924 "cl2.f" i__2 = krank; #line 924 "cl2.f" for (j = i__; j <= i__2; ++j) { /*< W(I,J) = SDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) >*/ #line 925 "cl2.f" i__3 = krank + 1 - j; #line 925 "cl2.f" w[i__ + j * w_dim1] = sdot_(&i__3, &w[i__ + j * w_dim1], mdw, &w[ j + j * w_dim1], mdw); /*< 320 CONTINUE >*/ #line 926 "cl2.f" /* L320: */ #line 926 "cl2.f" } /*< 330 CONTINUE >*/ #line 927 "cl2.f" /* L330: */ #line 927 "cl2.f" } /*< IF (.NOT.(KRANK.LT.N)) GO TO 450 >*/ #line 928 "cl2.f" if (! (krank < *n)) { #line 928 "cl2.f" goto L450; #line 928 "cl2.f" } /* ZERO OUT LOWER TRAPEZOIDAL PART. */ /* COPY UPPER TRI. TO LOWER TRI. PART. */ /*< DO 340 J=1,KRANK >*/ #line 932 "cl2.f" i__1 = krank; #line 932 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< CALL SCOPY(J, W(1,J), 1, W(J,1), MDW) >*/ #line 933 "cl2.f" scopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[j + w_dim1], mdw); /*< 340 CONTINUE >*/ #line 934 "cl2.f" /* L340: */ #line 934 "cl2.f" } /*< DO 350 I=KRP1,N >*/ #line 935 "cl2.f" i__1 = *n; #line 935 "cl2.f" for (i__ = krp1; i__ <= i__1; ++i__) { /*< W(I,1) = ZERO >*/ #line 936 "cl2.f" w[i__ + w_dim1] = zero; /*< CALL SCOPY(I, W(I,1), 0, W(I,1), MDW) >*/ #line 937 "cl2.f" scopy_(&i__, &w[i__ + w_dim1], &c__0, &w[i__ + w_dim1], mdw); /*< 350 CONTINUE >*/ #line 938 "cl2.f" /* L350: */ #line 938 "cl2.f" } /* APPLY RIGHT SIDE TRANSFORMATIONS TO LOWER TRI. */ /*< N3 = N2 + KRP1 >*/ #line 941 "cl2.f" n3 = n2 + krp1; /*< DO 430 I=1,KRANK >*/ #line 942 "cl2.f" i__1 = krank; #line 942 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< L = N1 + I >*/ #line 943 "cl2.f" l = n1 + i__; /*< K = N2 + I >*/ #line 944 "cl2.f" k = n2 + i__; /*< RB = WS(L-1)*WS(K-1) >*/ #line 945 "cl2.f" rb = ws[l - 1] * ws[k - 1]; /*< IF (.NOT.(RB.LT.ZERO)) GO TO 420 >*/ #line 946 "cl2.f" if (! (rb < zero)) { #line 946 "cl2.f" goto L420; #line 946 "cl2.f" } /* IF RB.GE.ZERO, TRANSFORMATION CAN BE REGARDED AS ZERO. */ /*< RB = ONE/RB >*/ #line 949 "cl2.f" rb = one / rb; /* STORE UNSCALED RANK-ONE HOUSEHOLDER UPDATE IN WORK ARRAY. */ /*< WS(N3) = ZERO >*/ #line 952 "cl2.f" ws[n3] = zero; /*< CALL SCOPY(N, WS(N3), 0, WS(N3), 1) >*/ #line 953 "cl2.f" scopy_(n, &ws[n3], &c__0, &ws[n3], &c__1); /*< L = N1 + I >*/ #line 954 "cl2.f" l = n1 + i__; /*< K = N3 + I >*/ #line 955 "cl2.f" k = n3 + i__; /*< WS(K-1) = WS(L-1) >*/ #line 956 "cl2.f" ws[k - 1] = ws[l - 1]; /*< DO 360 J=KRP1,N >*/ #line 957 "cl2.f" i__2 = *n; #line 957 "cl2.f" for (j = krp1; j <= i__2; ++j) { /*< K = N3 + J >*/ #line 958 "cl2.f" k = n3 + j; /*< WS(K-1) = W(I,J) >*/ #line 959 "cl2.f" ws[k - 1] = w[i__ + j * w_dim1]; /*< 360 CONTINUE >*/ #line 960 "cl2.f" /* L360: */ #line 960 "cl2.f" } /*< DO 370 J=1,N >*/ #line 961 "cl2.f" i__2 = *n; #line 961 "cl2.f" for (j = 1; j <= i__2; ++j) { /*< L = N3 + I >*/ #line 962 "cl2.f" l = n3 + i__; /*< K = N3 + J >*/ #line 963 "cl2.f" k = n3 + j; /*< >*/ #line 964 "cl2.f" i__3 = j - i__; #line 964 "cl2.f" i__4 = *n - j + 1; #line 964 "cl2.f" ws[j] = sdot_(&i__3, &w[j + i__ * w_dim1], mdw, &ws[l - 1], &c__1) + sdot_(&i__4, &w[j + j * w_dim1], &c__1, &ws[k - 1], & c__1); /*< WS(J) = WS(J)*RB >*/ #line 966 "cl2.f" ws[j] *= rb; /*< 370 CONTINUE >*/ #line 967 "cl2.f" /* L370: */ #line 967 "cl2.f" } /*< L = N3 + I >*/ #line 968 "cl2.f" l = n3 + i__; /*< GAM = SDOT(N-I+1,WS(L-1),1,WS(I),1)*RB >*/ #line 969 "cl2.f" i__2 = *n - i__ + 1; #line 969 "cl2.f" gam = sdot_(&i__2, &ws[l - 1], &c__1, &ws[i__], &c__1) * rb; /*< GAM = GAM*HALF >*/ #line 970 "cl2.f" gam *= half; /*< CALL SAXPY(N-I+1, GAM, WS(L-1), 1, WS(I), 1) >*/ #line 971 "cl2.f" i__2 = *n - i__ + 1; #line 971 "cl2.f" saxpy_(&i__2, &gam, &ws[l - 1], &c__1, &ws[i__], &c__1); /*< DO 410 J=I,N >*/ #line 972 "cl2.f" i__2 = *n; #line 972 "cl2.f" for (j = i__; j <= i__2; ++j) { /*< IF (.NOT.(I.GT.1)) GO TO 390 >*/ #line 973 "cl2.f" if (! (i__ > 1)) { #line 973 "cl2.f" goto L390; #line 973 "cl2.f" } /*< IM1 = I - 1 >*/ #line 974 "cl2.f" im1 = i__ - 1; /*< K = N3 + J >*/ #line 975 "cl2.f" k = n3 + j; /*< DO 380 L=1,IM1 >*/ #line 976 "cl2.f" i__3 = im1; #line 976 "cl2.f" for (l = 1; l <= i__3; ++l) { /*< W(J,L) = W(J,L) + WS(K-1)*WS(L) >*/ #line 977 "cl2.f" w[j + l * w_dim1] += ws[k - 1] * ws[l]; /*< 380 CONTINUE >*/ #line 978 "cl2.f" /* L380: */ #line 978 "cl2.f" } /*< 390 K = N3 + J >*/ #line 979 "cl2.f" L390: #line 979 "cl2.f" k = n3 + j; /*< DO 400 L=I,J >*/ #line 980 "cl2.f" i__3 = j; #line 980 "cl2.f" for (l = i__; l <= i__3; ++l) { /*< IL = N3 + L >*/ #line 981 "cl2.f" il = n3 + l; /*< W(J,L) = W(J,L) + WS(J)*WS(IL-1) + WS(L)*WS(K-1) >*/ #line 982 "cl2.f" w[j + l * w_dim1] = w[j + l * w_dim1] + ws[j] * ws[il - 1] + ws[l] * ws[k - 1]; /*< 400 CONTINUE >*/ #line 983 "cl2.f" /* L400: */ #line 983 "cl2.f" } /*< 410 CONTINUE >*/ #line 984 "cl2.f" /* L410: */ #line 984 "cl2.f" } /*< 420 CONTINUE >*/ #line 985 "cl2.f" L420: /*< 430 CONTINUE >*/ #line 986 "cl2.f" /* L430: */ #line 986 "cl2.f" ; #line 986 "cl2.f" } /* COPY LOWER TRI. TO UPPER TRI. TO SYMMETRIZE THE COVARIANCE MATRIX. */ /*< DO 440 I=1,N >*/ #line 989 "cl2.f" i__1 = *n; #line 989 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< CALL SCOPY(I, W(I,1), MDW, W(1,I), 1) >*/ #line 990 "cl2.f" scopy_(&i__, &w[i__ + w_dim1], mdw, &w[i__ * w_dim1 + 1], &c__1); /*< 440 CONTINUE >*/ #line 991 "cl2.f" /* L440: */ #line 991 "cl2.f" } /* REPERMUTE ROWS AND COLS. */ /*< 450 DO 470 II=1,MINMAN >*/ #line 994 "cl2.f" L450: #line 994 "cl2.f" i__1 = minman; #line 994 "cl2.f" for (ii = 1; ii <= i__1; ++ii) { /*< I = MINMAN + 1 - II >*/ #line 995 "cl2.f" i__ = minman + 1 - ii; /*< K = IP(I) >*/ #line 996 "cl2.f" k = ip[i__]; /*< IF (.NOT.(I.NE.K)) GO TO 460 >*/ #line 997 "cl2.f" if (! (i__ != k)) { #line 997 "cl2.f" goto L460; #line 997 "cl2.f" } /*< CALL SSWAP(1, W(I,I), 1, W(K,K), 1) >*/ #line 998 "cl2.f" sswap_(&c__1, &w[i__ + i__ * w_dim1], &c__1, &w[k + k * w_dim1], & c__1); /*< CALL SSWAP(I-1, W(1,I), 1, W(1,K), 1) >*/ #line 999 "cl2.f" i__2 = i__ - 1; #line 999 "cl2.f" sswap_(&i__2, &w[i__ * w_dim1 + 1], &c__1, &w[k * w_dim1 + 1], &c__1); /*< CALL SSWAP(K-I-1, W(I,I+1), MDW, W(I+1,K), 1) >*/ #line 1000 "cl2.f" i__2 = k - i__ - 1; #line 1000 "cl2.f" sswap_(&i__2, &w[i__ + (i__ + 1) * w_dim1], mdw, &w[i__ + 1 + k * w_dim1], &c__1); /*< CALL SSWAP(N-K, W(I,K+1), MDW, W(K,K+1), MDW) >*/ #line 1001 "cl2.f" i__2 = *n - k; #line 1001 "cl2.f" sswap_(&i__2, &w[i__ + (k + 1) * w_dim1], mdw, &w[k + (k + 1) * w_dim1], mdw); /*< 460 CONTINUE >*/ #line 1002 "cl2.f" L460: /*< 470 CONTINUE >*/ #line 1003 "cl2.f" /* L470: */ #line 1003 "cl2.f" ; #line 1003 "cl2.f" } /* PUT IN NORMALIZED RESIDUAL SUM OF SQUARES SCALE FACTOR */ /* AND SYMMETRIZE THE RESULTING COVARIANCE MARIX. */ /*< DO 480 J=1,N >*/ #line 1007 "cl2.f" i__1 = *n; #line 1007 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< CALL SSCAL(J, FAC, W(1,J), 1) >*/ #line 1008 "cl2.f" sscal_(&j, &fac, &w[j * w_dim1 + 1], &c__1); /*< CALL SCOPY(J, W(1,J), 1, W(J,1), MDW) >*/ #line 1009 "cl2.f" scopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[j + w_dim1], mdw); /*< 480 CONTINUE >*/ #line 1010 "cl2.f" /* L480: */ #line 1010 "cl2.f" } /*< 490 GO TO 540 >*/ #line 1011 "cl2.f" L490: #line 1011 "cl2.f" goto L540; /*< 500 CONTINUE >*/ #line 1012 "cl2.f" L500: /* TO PROCESS-OPTION-VECTOR */ /* THE NOMINAL TOLERANCE USED IN THE CODE, */ /*< TOL = SQRT(SRELPR) >*/ #line 1017 "cl2.f" tol = sqrt(srelpr); /*< COV = .FALSE. >*/ #line 1018 "cl2.f" cov = FALSE_; /*< LAST = 1 >*/ #line 1019 "cl2.f" last = 1; /*< LINK = PRGOPT(1) >*/ #line 1020 "cl2.f" link = prgopt[1]; /*< 510 IF (.NOT.(LINK.GT.1)) GO TO 520 >*/ #line 1021 "cl2.f" L510: #line 1021 "cl2.f" if (! (link > 1)) { #line 1021 "cl2.f" goto L520; #line 1021 "cl2.f" } /*< KEY = PRGOPT(LAST+1) >*/ #line 1022 "cl2.f" key = prgopt[last + 1]; /*< IF (KEY.EQ.1) COV = PRGOPT(LAST+2).NE.ZERO >*/ #line 1023 "cl2.f" if (key == 1) { #line 1023 "cl2.f" cov = prgopt[last + 2] != zero; #line 1023 "cl2.f" } /*< IF (KEY.EQ.5) TOL = AMAX1(SRELPR,PRGOPT(LAST+2)) >*/ #line 1024 "cl2.f" if (key == 5) { /* Computing MAX */ #line 1024 "cl2.f" r__1 = srelpr, r__2 = prgopt[last + 2]; #line 1024 "cl2.f" tol = max(r__1,r__2); #line 1024 "cl2.f" } /*< NEXT = PRGOPT(LINK) >*/ #line 1025 "cl2.f" next = prgopt[link]; /*< LAST = LINK >*/ #line 1026 "cl2.f" last = link; /*< LINK = NEXT >*/ #line 1027 "cl2.f" link = next; /*< GO TO 510 >*/ #line 1028 "cl2.f" goto L510; /*< 520 GO TO 530 >*/ #line 1029 "cl2.f" L520: #line 1029 "cl2.f" goto L530; /*< 530 GO TO IGO994, (40) >*/ #line 1030 "cl2.f" L530: #line 1030 "cl2.f" switch (igo994) { #line 1030 "cl2.f" case 0: goto L40; #line 1030 "cl2.f" } /*< 540 GO TO IGO990, (60) >*/ #line 1031 "cl2.f" L540: #line 1031 "cl2.f" switch (igo990) { #line 1031 "cl2.f" case 0: goto L60; #line 1031 "cl2.f" } /*< END >*/ } /* lsi_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE LPDP(A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, IS) >*/ static /* Subroutine */ int lpdp_(real *a, integer *mda, integer *m, integer *n1, integer *n2, real *prgopt, real *x, real *wnorm, integer *mode, real * ws, integer *is) { /* Initialized data */ static real zero = 0.f; static real one = 1.f; static real fac = .1f; /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; /* Local variables */ static integer i__, j, l, n; static real sc; static integer iw, ix, np1; static integer modew; static real rnorm; static real ynorm; /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (START EDITING AT LINE WITH C++ IN COLS. 1-3.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/,/SNRM2/DNRM2/,/SDOT/DDOT/, */ /* /SCOPY/DCOPY/,/SSCAL/DSCAL/,/ABS(/DABS(/, ABS/, DABS/,/E0/D0/ */ /* DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), */ /* WHERE N=N1+N2. THIS IS A SLIGHT OVERESTIMATE FOR WS(*). */ /* WRITTEN BY R. J. HANSON AND K. H. HASKELL, SANDIA LABS */ /* REVISED OCT. 1, 1981. */ /* DETERMINE AN N1-VECTOR W, AND */ /* AN N2-VECTOR Z */ /* WHICH MINIMIZES THE EUCLIDEAN LENGTH OF W */ /* SUBJECT TO G*W+H*Z .GE. Y. */ /* THIS IS THE LEAST PROJECTED DISTANCE PROBLEM, LPDP. */ /* THE MATRICES G AND H ARE OF RESPECTIVE */ /* DIMENSIONS M BY N1 AND M BY N2. */ /* CALLED BY SUBPROGRAM LSI( ). */ /* THE MATRIX */ /* (G H Y) */ /* OCCUPIES ROWS 1,...,M AND COLS 1,...,N1+N2+1 OF A(*,*). */ /* THE SOLUTION (W) IS RETURNED IN X(*). */ /* (Z) */ /* THE VALUE OF MODE INDICATES THE STATUS OF */ /* THE COMPUTATION AFTER RETURNING TO THE USER. */ /* MODE=1 THE SOLUTION WAS SUCCESSFULLY OBTAINED. */ /* MODE=2 THE INEQUALITIES ARE INCONSISTENT. */ /* SUBROUTINES CALLED */ /* WNNLS SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST */ /* SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS. */ /* PART OF THIS PACKAGE. */ /* ++ */ /* SDOT, SUBROUTINES FROM THE BLAS PACKAGE. */ /* SSCAL,SNRM2, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. */ /* SCOPY */ /*< REAL A(MDA,1), PRGOPT(1), WS(1), WNORM, X(1) >*/ /*< INTEGER IS(1) >*/ /*< REAL FAC, ONE, RNORM, SC, YNORM, ZERO >*/ /*< REAL SDOT, SNRM2, ABS >*/ /*< DATA ZERO, ONE /0.E0,1.E0/, FAC /0.1E0/ >*/ #line 1091 "cl2.f" /* Parameter adjustments */ #line 1091 "cl2.f" a_dim1 = *mda; #line 1091 "cl2.f" a_offset = 1 + a_dim1; #line 1091 "cl2.f" a -= a_offset; #line 1091 "cl2.f" --prgopt; #line 1091 "cl2.f" --x; #line 1091 "cl2.f" --ws; #line 1091 "cl2.f" --is; #line 1091 "cl2.f" #line 1091 "cl2.f" /* Function Body */ /*< N = N1 + N2 >*/ #line 1092 "cl2.f" n = *n1 + *n2; /*< MODE = 1 >*/ #line 1093 "cl2.f" *mode = 1; /*< IF (.NOT.(M.LE.0)) GO TO 20 >*/ #line 1094 "cl2.f" if (! (*m <= 0)) { #line 1094 "cl2.f" goto L20; #line 1094 "cl2.f" } /*< IF (.NOT.(N.GT.0)) GO TO 10 >*/ #line 1095 "cl2.f" if (! (n > 0)) { #line 1095 "cl2.f" goto L10; #line 1095 "cl2.f" } /*< X(1) = ZERO >*/ #line 1096 "cl2.f" x[1] = zero; /*< CALL SCOPY(N, X, 0, X, 1) >*/ #line 1097 "cl2.f" scopy_(&n, &x[1], &c__0, &x[1], &c__1); /*< 10 WNORM = ZERO >*/ #line 1098 "cl2.f" L10: #line 1098 "cl2.f" *wnorm = zero; /*< RETURN >*/ #line 1099 "cl2.f" return 0; /*< 20 NP1 = N + 1 >*/ #line 1100 "cl2.f" L20: #line 1100 "cl2.f" np1 = n + 1; /* SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. */ /*< DO 40 I=1,M >*/ #line 1103 "cl2.f" i__1 = *m; #line 1103 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< SC = SNRM2(N,A(I,1),MDA) >*/ #line 1104 "cl2.f" sc = snrm2_(&n, &a[i__ + a_dim1], mda); /*< IF (.NOT.(SC.NE.ZERO)) GO TO 30 >*/ #line 1105 "cl2.f" if (! (sc != zero)) { #line 1105 "cl2.f" goto L30; #line 1105 "cl2.f" } /*< SC = ONE/SC >*/ #line 1106 "cl2.f" sc = one / sc; /*< CALL SSCAL(NP1, SC, A(I,1), MDA) >*/ #line 1107 "cl2.f" sscal_(&np1, &sc, &a[i__ + a_dim1], mda); /*< 30 CONTINUE >*/ #line 1108 "cl2.f" L30: /*< 40 CONTINUE >*/ #line 1109 "cl2.f" /* L40: */ #line 1109 "cl2.f" ; #line 1109 "cl2.f" } /* SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). */ /*< YNORM = SNRM2(M,A(1,NP1),1) >*/ #line 1112 "cl2.f" ynorm = snrm2_(m, &a[np1 * a_dim1 + 1], &c__1); /*< IF (.NOT.(YNORM.NE.ZERO)) GO TO 50 >*/ #line 1113 "cl2.f" if (! (ynorm != zero)) { #line 1113 "cl2.f" goto L50; #line 1113 "cl2.f" } /*< SC = ONE/YNORM >*/ #line 1114 "cl2.f" sc = one / ynorm; /*< CALL SSCAL(M, SC, A(1,NP1), 1) >*/ #line 1115 "cl2.f" sscal_(m, &sc, &a[np1 * a_dim1 + 1], &c__1); /* SCALE COLS OF MATRIX H. */ /*< 50 J = N1 + 1 >*/ #line 1118 "cl2.f" L50: #line 1118 "cl2.f" j = *n1 + 1; /*< 60 IF (.NOT.(J.LE.N)) GO TO 70 >*/ #line 1119 "cl2.f" L60: #line 1119 "cl2.f" if (! (j <= n)) { #line 1119 "cl2.f" goto L70; #line 1119 "cl2.f" } /*< SC = SNRM2(M,A(1,J),1) >*/ #line 1120 "cl2.f" sc = snrm2_(m, &a[j * a_dim1 + 1], &c__1); /*< IF (SC.NE.ZERO) SC = ONE/SC >*/ #line 1121 "cl2.f" if (sc != zero) { #line 1121 "cl2.f" sc = one / sc; #line 1121 "cl2.f" } /*< CALL SSCAL(M, SC, A(1,J), 1) >*/ #line 1122 "cl2.f" sscal_(m, &sc, &a[j * a_dim1 + 1], &c__1); /*< X(J) = SC >*/ #line 1123 "cl2.f" x[j] = sc; /*< J = J + 1 >*/ #line 1124 "cl2.f" ++j; /*< GO TO 60 >*/ #line 1125 "cl2.f" goto L60; /*< 70 IF (.NOT.(N1.GT.0)) GO TO 130 >*/ #line 1126 "cl2.f" L70: #line 1126 "cl2.f" if (! (*n1 > 0)) { #line 1126 "cl2.f" goto L130; #line 1126 "cl2.f" } /* COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). */ /*< IW = 0 >*/ #line 1129 "cl2.f" iw = 0; /*< DO 80 I=1,M >*/ #line 1130 "cl2.f" i__1 = *m; #line 1130 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /* MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. */ /*< CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) >*/ #line 1133 "cl2.f" scopy_(n2, &a[i__ + (*n1 + 1) * a_dim1], mda, &ws[iw + 1], &c__1); /*< IW = IW + N2 >*/ #line 1134 "cl2.f" iw += *n2; /* MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. */ /*< CALL SCOPY(N1, A(I,1), MDA, WS(IW+1), 1) >*/ #line 1137 "cl2.f" scopy_(n1, &a[i__ + a_dim1], mda, &ws[iw + 1], &c__1); /*< IW = IW + N1 >*/ #line 1138 "cl2.f" iw += *n1; /* MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. */ /*< WS(IW+1) = A(I,NP1) >*/ #line 1141 "cl2.f" ws[iw + 1] = a[i__ + np1 * a_dim1]; /*< IW = IW + 1 >*/ #line 1142 "cl2.f" ++iw; /*< 80 CONTINUE >*/ #line 1143 "cl2.f" /* L80: */ #line 1143 "cl2.f" } /*< WS(IW+1) = ZERO >*/ #line 1144 "cl2.f" ws[iw + 1] = zero; /*< CALL SCOPY(N, WS(IW+1), 0, WS(IW+1), 1) >*/ #line 1145 "cl2.f" scopy_(&n, &ws[iw + 1], &c__0, &ws[iw + 1], &c__1); /*< IW = IW + N >*/ #line 1146 "cl2.f" iw += n; /*< WS(IW+1) = ONE >*/ #line 1147 "cl2.f" ws[iw + 1] = one; /*< IW = IW + 1 >*/ #line 1148 "cl2.f" ++iw; /* SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE */ /* MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR */ /* F = TRANSPOSE OF (0,...,0,1). */ /*< IX = IW + 1 >*/ #line 1153 "cl2.f" ix = iw + 1; /*< IW = IW + M >*/ #line 1154 "cl2.f" iw += *m; /* DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). */ /*< IS(1) = 0 >*/ #line 1157 "cl2.f" is[1] = 0; /*< IS(2) = 0 >*/ #line 1158 "cl2.f" is[2] = 0; /*< >*/ #line 1159 "cl2.f" i__1 = np1 - *n2; #line 1159 "cl2.f" wnnls_fort(&ws[1], &np1, n2, &i__1, m, &c__0, &prgopt[1], &ws[ix], &rnorm, & modew, &is[1], &ws[iw + 1]); /* COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. */ /*< SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1) >*/ #line 1163 "cl2.f" sc = one - sdot_(m, &a[np1 * a_dim1 + 1], &c__1, &ws[ix], &c__1); /*< IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 110 >*/ #line 1164 "cl2.f" if (! (one + fac * abs(sc) != one && rnorm > zero)) { #line 1164 "cl2.f" goto L110; #line 1164 "cl2.f" } /*< SC = ONE/SC >*/ #line 1165 "cl2.f" sc = one / sc; /*< DO 90 J=1,N1 >*/ #line 1166 "cl2.f" i__1 = *n1; #line 1166 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< X(J) = SC*SDOT(M,A(1,J),1,WS(IX),1) >*/ #line 1167 "cl2.f" x[j] = sc * sdot_(m, &a[j * a_dim1 + 1], &c__1, &ws[ix], &c__1); /*< 90 CONTINUE >*/ #line 1168 "cl2.f" /* L90: */ #line 1168 "cl2.f" } /* COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS VECTOR. */ /*< DO 100 I=1,M >*/ #line 1171 "cl2.f" i__1 = *m; #line 1171 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< A(I,NP1) = A(I,NP1) - SDOT(N1,A(I,1),MDA,X,1) >*/ #line 1172 "cl2.f" a[i__ + np1 * a_dim1] -= sdot_(n1, &a[i__ + a_dim1], mda, &x[1], & c__1); /*< 100 CONTINUE >*/ #line 1173 "cl2.f" /* L100: */ #line 1173 "cl2.f" } /*< GO TO 120 >*/ #line 1174 "cl2.f" goto L120; /*< 110 MODE = 2 >*/ #line 1175 "cl2.f" L110: #line 1175 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1176 "cl2.f" return 0; /*< 120 CONTINUE >*/ #line 1177 "cl2.f" L120: /*< 130 IF (.NOT.(N2.GT.0)) GO TO 180 >*/ #line 1178 "cl2.f" L130: #line 1178 "cl2.f" if (! (*n2 > 0)) { #line 1178 "cl2.f" goto L180; #line 1178 "cl2.f" } /* COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). */ /*< IW = 0 >*/ #line 1181 "cl2.f" iw = 0; /*< DO 140 I=1,M >*/ #line 1182 "cl2.f" i__1 = *m; #line 1182 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) >*/ #line 1183 "cl2.f" scopy_(n2, &a[i__ + (*n1 + 1) * a_dim1], mda, &ws[iw + 1], &c__1); /*< IW = IW + N2 >*/ #line 1184 "cl2.f" iw += *n2; /*< WS(IW+1) = A(I,NP1) >*/ #line 1185 "cl2.f" ws[iw + 1] = a[i__ + np1 * a_dim1]; /*< IW = IW + 1 >*/ #line 1186 "cl2.f" ++iw; /*< 140 CONTINUE >*/ #line 1187 "cl2.f" /* L140: */ #line 1187 "cl2.f" } /*< WS(IW+1) = ZERO >*/ #line 1188 "cl2.f" ws[iw + 1] = zero; /*< CALL SCOPY(N2, WS(IW+1), 0, WS(IW+1), 1) >*/ #line 1189 "cl2.f" scopy_(n2, &ws[iw + 1], &c__0, &ws[iw + 1], &c__1); /*< IW = IW + N2 >*/ #line 1190 "cl2.f" iw += *n2; /*< WS(IW+1) = ONE >*/ #line 1191 "cl2.f" ws[iw + 1] = one; /*< IW = IW + 1 >*/ #line 1192 "cl2.f" ++iw; /*< IX = IW + 1 >*/ #line 1193 "cl2.f" ix = iw + 1; /*< IW = IW + M >*/ #line 1194 "cl2.f" iw += *m; /* SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE */ /* OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE */ /* OF (0,...,0,1)). */ /* DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). */ /*< IS(1) = 0 >*/ #line 1201 "cl2.f" is[1] = 0; /*< IS(2) = 0 >*/ #line 1202 "cl2.f" is[2] = 0; /*< >*/ #line 1203 "cl2.f" i__1 = *n2 + 1; #line 1203 "cl2.f" i__2 = *n2 + 1; #line 1203 "cl2.f" wnnls_fort(&ws[1], &i__1, &c__0, &i__2, m, &c__0, &prgopt[1], &ws[ix], &rnorm, &modew, &is[1], &ws[iw + 1]); /* COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. */ /*< SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1) >*/ #line 1207 "cl2.f" sc = one - sdot_(m, &a[np1 * a_dim1 + 1], &c__1, &ws[ix], &c__1); /*< IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 160 >*/ #line 1208 "cl2.f" if (! (one + fac * abs(sc) != one && rnorm > zero)) { #line 1208 "cl2.f" goto L160; #line 1208 "cl2.f" } /*< SC = ONE/SC >*/ #line 1209 "cl2.f" sc = one / sc; /*< DO 150 J=1,N2 >*/ #line 1210 "cl2.f" i__1 = *n2; #line 1210 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< L = N1 + J >*/ #line 1211 "cl2.f" l = *n1 + j; /*< X(L) = SC*SDOT(M,A(1,L),1,WS(IX),1)*X(L) >*/ #line 1212 "cl2.f" x[l] = sc * sdot_(m, &a[l * a_dim1 + 1], &c__1, &ws[ix], &c__1) * x[l] ; /*< 150 CONTINUE >*/ #line 1213 "cl2.f" /* L150: */ #line 1213 "cl2.f" } /*< GO TO 170 >*/ #line 1214 "cl2.f" goto L170; /*< 160 MODE = 2 >*/ #line 1215 "cl2.f" L160: #line 1215 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1216 "cl2.f" return 0; /*< 170 CONTINUE >*/ #line 1217 "cl2.f" L170: /* ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. */ /*< 180 CALL SSCAL(N, YNORM, X, 1) >*/ #line 1220 "cl2.f" L180: #line 1220 "cl2.f" sscal_(&n, &ynorm, &x[1], &c__1); /*< WNORM = SNRM2(N1,X,1) >*/ #line 1221 "cl2.f" *wnorm = snrm2_(n1, &x[1], &c__1); /*< RETURN >*/ #line 1222 "cl2.f" return 0; /*< END >*/ } /* lpdp_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< >*/ static /* Subroutine */ int wnnls_fort(real *w, integer *mdw, integer *me, integer *ma, integer *n, integer *l, real *prgopt, real *x, real *rnorm, integer * mode, integer *iwork, real *work) { /* System generated locals */ integer w_dim1, w_offset; /* Local variables */ static integer l1, l2, l3, l4, l5, lw, liw, nerr, iopt; /* DIMENSION W(MDW,N+1),PRGOPT(*),X(N),IWORK(M+N),WORK(M+5*N) */ /* ABSTRACT */ /* THIS SUBPROGRAM SOLVES A LINEARLY CONSTRAINED LEAST SQUARES */ /* PROBLEM. SUPPOSE THERE ARE GIVEN MATRICES E AND A OF */ /* RESPECTIVE DIMENSIONS ME BY N AND MA BY N, AND VECTORS F */ /* AND B OF RESPECTIVE LENGTHS ME AND MA. THIS SUBROUTINE */ /* SOLVES THE PROBLEM */ /* EX = F, (EQUATIONS TO BE EXACTLY SATISFIED) */ /* AX = B, (EQUATIONS TO BE APPROXIMATELY SATISFIED, */ /* IN THE LEAST SQUARES SENSE) */ /* SUBJECT TO COMPONENTS L+1,...,N NONNEGATIVE */ /* ANY VALUES ME.GE.0, MA.GE.0 AND 0.LE. L .LE.N ARE PERMITTED. */ /* THE PROBLEM IS REPOSED AS PROBLEM WNNLS */ /* (WT*E)X = (WT*F) */ /* ( A) ( B), (LEAST SQUARES) */ /* SUBJECT TO COMPONENTS L+1,...,N NONNEGATIVE. */ /* THE SUBPROGRAM CHOOSES THE HEAVY WEIGHT (OR PENALTY PARAMETER) WT. */ /* THE PARAMETERS FOR WNNLS ARE */ /* INPUT.. */ /* W(*,*),MDW, THE ARRAY W(*,*) IS DOUBLE SUBSCRIPTED WITH FIRST */ /* ME,MA,N,L DIMENSIONING PARAMETER EQUAL TO MDW. FOR THIS */ /* DISCUSSION LET US CALL M = ME + MA. THEN MDW */ /* MUST SATISFY MDW.GE.M. THE CONDITION MDW.LT.M */ /* IS AN ERROR. */ /* THE ARRAY W(*,*) CONTAINS THE MATRICES AND VECTORS */ /* (E F) */ /* (A B) */ /* IN ROWS AND COLUMNS 1,...,M AND 1,...,N+1 */ /* RESPECTIVELY. COLUMNS 1,...,L CORRESPOND TO */ /* UNCONSTRAINED VARIABLES X(1),...,X(L). THE */ /* REMAINING VARIABLES ARE CONSTRAINED TO BE */ /* NONNEGATIVE. THE CONDITION L.LT.0 .OR. L.GT.N IS */ /* AN ERROR. */ /* PRGOPT(*) THIS ARRAY IS THE OPTION VECTOR. */ /* IF THE USER IS SATISFIED WITH THE NOMINAL */ /* SUBPROGRAM FEATURES SET */ /* PRGOPT(1)=1 (OR PRGOPT(1)=1.0) */ /* OTHERWISE PRGOPT(*) IS A LINKED LIST CONSISTING OF */ /* GROUPS OF DATA OF THE FOLLOWING FORM */ /* LINK */ /* KEY */ /* DATA SET */ /* THE PARAMETERS LINK AND KEY ARE EACH ONE WORD. */ /* THE DATA SET CAN BE COMPRISED OF SEVERAL WORDS. */ /* THE NUMBER OF ITEMS DEPENDS ON THE VALUE OF KEY. */ /* THE VALUE OF LINK POINTS TO THE FIRST */ /* ENTRY OF THE NEXT GROUP OF DATA WITHIN */ /* PRGOPT(*). THE EXCEPTION IS WHEN THERE ARE */ /* NO MORE OPTIONS TO CHANGE. IN THAT */ /* CASE LINK=1 AND THE VALUES KEY AND DATA SET */ /* ARE NOT REFERENCED. THE GENERAL LAYOUT OF */ /* PRGOPT(*) IS AS FOLLOWS. */ /* ...PRGOPT(1)=LINK1 (LINK TO FIRST ENTRY OF NEXT GROUP) */ /* . PRGOPT(2)=KEY1 (KEY TO THE OPTION CHANGE) */ /* . PRGOPT(3)=DATA VALUE (DATA VALUE FOR THIS CHANGE) */ /* . . */ /* . . */ /* . . */ /* ...PRGOPT(LINK1)=LINK2 (LINK TO THE FIRST ENTRY OF */ /* . NEXT GROUP) */ /* . PRGOPT(LINK1+1)=KEY2 (KEY TO THE OPTION CHANGE) */ /* . PRGOPT(LINK1+2)=DATA VALUE */ /* ... . */ /* . . */ /* . . */ /* ...PRGOPT(LINK)=1 (NO MORE OPTIONS TO CHANGE) */ /* VALUES OF LINK THAT ARE NONPOSITIVE ARE ERRORS. */ /* A VALUE OF LINK.GT.NLINK=100000 IS ALSO AN ERROR. */ /* THIS HELPS PREVENT USING INVALID BUT POSITIVE */ /* VALUES OF LINK THAT WILL PROBABLY EXTEND */ /* BEYOND THE PROGRAM LIMITS OF PRGOPT(*). */ /* UNRECOGNIZED VALUES OF KEY ARE IGNORED. THE */ /* ORDER OF THE OPTIONS IS ARBITRARY AND ANY NUMBER */ /* OF OPTIONS CAN BE CHANGED WITH THE FOLLOWING */ /* RESTRICTION. TO PREVENT CYCLING IN THE */ /* PROCESSING OF THE OPTION ARRAY A COUNT OF THE */ /* NUMBER OF OPTIONS CHANGED IS MAINTAINED. */ /* WHENEVER THIS COUNT EXCEEDS NOPT=1000 AN ERROR */ /* MESSAGE IS PRINTED AND THE SUBPROGRAM RETURNS. */ /* OPTIONS.. */ /* KEY=6 */ /* SCALE THE NONZERO COLUMNS OF THE */ /* ENTIRE DATA MATRIX */ /* (E) */ /* (A) */ /* TO HAVE LENGTH ONE. THE DATA SET FOR */ /* THIS OPTION IS A SINGLE VALUE. IT MUST */ /* BE NONZERO IF UNIT LENGTH COLUMN SCALING IS */ /* DESIRED. */ /* KEY=7 */ /* SCALE COLUMNS OF THE ENTIRE DATA MATRIX */ /* (E) */ /* (A) */ /* WITH A USER-PROVIDED DIAGONAL MATRIX. */ /* THE DATA SET FOR THIS OPTION CONSISTS */ /* OF THE N DIAGONAL SCALING FACTORS, ONE FOR */ /* EACH MATRIX COLUMN. */ /* KEY=8 */ /* CHANGE THE RANK DETERMINATION TOLERANCE FROM */ /* THE NOMINAL VALUE OF SQRT(EPS). THIS QUANTITY CAN */ /* BE NO SMALLER THAN EPS, THE ARITHMETIC- */ /* STORAGE PRECISION. THE QUANTITY USED */ /* HERE IS INTERNALLY RESTRICTED TO BE AT */ /* LEAST EPS. THE DATA SET FOR THIS OPTION */ /* IS THE NEW TOLERANCE. */ /* KEY=9 */ /* CHANGE THE BLOW-UP PARAMETER FROM THE */ /* NOMINAL VALUE OF SQRT(EPS). THE RECIPROCAL OF */ /* THIS PARAMETER IS USED IN REJECTING SOLUTION */ /* COMPONENTS AS TOO LARGE WHEN A VARIABLE IS */ /* FIRST BROUGHT INTO THE ACTIVE SET. TOO LARGE */ /* MEANS THAT THE PROPOSED COMPONENT TIMES THE */ /* RECIPROCAL OF THE PARAMETERIS NOT LESS THAN */ /* THE RATIO OF THE NORMS OF THE RIGHT-SIDE */ /* VECTOR AND THE DATA MATRIX. */ /* THIS PARAMETER CAN BE NO SMALLER THAN EPS, */ /* THE ARITHMETIC-STORAGE PRECISION. */ /* FOR EXAMPLE, SUPPOSE WE WANT TO PROVIDE */ /* A DIAGONAL MATRIX TO SCALE THE PROBLEM */ /* MATRIX AND CHANGE THE TOLERANCE USED FOR */ /* DETERMINING LINEAR DEPENDENCE OF DROPPED COL */ /* VECTORS. FOR THESE OPTIONS THE DIMENSIONS OF */ /* PRGOPT(*) MUST BE AT LEAST N+6. THE FORTRAN */ /* STATEMENTS DEFINING THESE OPTIONS WOULD */ /* BE AS FOLLOWS. */ /* PRGOPT(1)=N+3 (LINK TO ENTRY N+3 IN PRGOPT(*)) */ /* PRGOPT(2)=7 (USER-PROVIDED SCALING KEY) */ /* CALL SCOPY(N,D,1,PRGOPT(3),1) (COPY THE N */ /* SCALING FACTORS FROM A USER ARRAY CALLED D(*) */ /* INTO PRGOPT(3)-PRGOPT(N+2)) */ /* PRGOPT(N+3)=N+6 (LINK TO ENTRY N+6 OF PRGOPT(*)) */ /* PRGOPT(N+4)=8 (LINEAR DEPENDENCE TOLERANCE KEY) */ /* PRGOPT(N+5)=... (NEW VALUE OF THE TOLERANCE) */ /* PRGOPT(N+6)=1 (NO MORE OPTIONS TO CHANGE) */ /* IWORK(1), THE AMOUNTS OF WORKING STORAGE ACTUALLY ALLOCATED */ /* IWORK(2) FOR THE WORKING ARRAYS WORK(*) AND IWORK(*), */ /* RESPECTIVELY. THESE QUANTITIES ARE COMPARED WITH */ /* THE ACTUAL AMOUNTS OF STORAGE NEEDED FOR WNNLS( ). */ /* INSUFFICIENT STORAGE ALLOCATED FOR EITHER WORK(*) */ /* OR IWORK(*) IS CONSIDERED AN ERROR. THIS FEATURE */ /* WAS INCLUDED IN WNNLS( ) BECAUSE MISCALCULATING */ /* THE STORAGE FORMULAS FOR WORK(*) AND IWORK(*) */ /* MIGHT VERY WELL LEAD TO SUBTLE AND HARD-TO-FIND */ /* EXECUTION ERRORS. */ /* THE LENGTH OF WORK(*) MUST BE AT LEAST */ /* LW = ME+MA+5*N */ /* THIS TEST WILL NOT BE MADE IF IWORK(1).LE.0. */ /* THE LENGTH OF IWORK(*) MUST BE AT LEAST */ /* LIW = ME+MA+N */ /* THIS TEST WILL NOT BE MADE IF IWORK(2).LE.0. */ /* OUTPUT.. */ /* X(*) AN ARRAY DIMENSIONED AT LEAST N, WHICH WILL */ /* CONTAIN THE N COMPONENTS OF THE SOLUTION VECTOR */ /* ON OUTPUT. */ /* RNORM THE RESIDUAL NORM OF THE SOLUTION. THE VALUE OF */ /* RNORM CONTAINS THE RESIDUAL VECTOR LENGTH OF THE */ /* EQUALITY CONSTRAINTS AND LEAST SQUARES EQUATIONS. */ /* MODE THE VALUE OF MODE INDICATES THE SUCCESS OR FAILURE */ /* OF THE SUBPROGRAM. */ /* MODE = 0 SUBPROGRAM COMPLETED SUCCESSFULLY. */ /* = 1 MAX. NUMBER OF ITERATIONS (EQUAL TO */ /* 3*(N-L)) EXCEEDED. NEARLY ALL PROBLEMS */ /* SHOULD COMPLETE IN FEWER THAN THIS */ /* NUMBER OF ITERATIONS. AN APPROXIMATE */ /* SOLUTION AND ITS CORRESPONDING RESIDUAL */ /* VECTOR LENGTH ARE IN X(*) AND RNORM. */ /* = 2 USAGE ERROR OCCURRED. THE OFFENDING */ /* CONDITION IS NOTED WITH THE ERROR */ /* PROCESSING SUBPROGRAM, XERROR( ). */ /* USER-DESIGNATED */ /* WORKING ARRAYS.. */ /* WORK(*) A WORKING ARRAY OF LENGTH AT LEAST */ /* M + 5*N. */ /* IWORK(*) AN INTEGER-VALUED WORKING ARRAY OF LENGTH AT LEAST */ /* M+N. */ /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (START AT LINE WITH C++ IN COLS. 1-3.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/,/, DUMMY/,SNGL(DUMMY)/ */ /* WRITTEN BY KAREN H. HASKELL, SANDIA LABORATORIES, */ /* AND R.J. HANSON, SANDIA LABORATORIES. */ /* REVISED FEB.25, 1982. */ /* SUBROUTINES CALLED BY WNNLS( ) */ /* ++ */ /* WNLSM COMPANION SUBROUTINE TO WNNLS( ), WHERE */ /* MOST OF THE COMPUTATION TAKES PLACE. */ /* XERROR,XERRWV FROM SLATEC ERROR PROCESSING PACKAGE. */ /* THIS IS DOCUMENTED IN SANDIA TECH. REPT., */ /* SAND78-1189. */ /* REFERENCES */ /* 1. SOLVING LEAST SQUARES PROBLEMS, BY C.L. LAWSON */ /* AND R.J. HANSON. PRENTICE-HALL, INC. (1974). */ /* 2. BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE, BY */ /* C.L. LAWSON, R.J. HANSON, D.R. KINCAID, AND F.T. KROGH. */ /* TOMS, V. 5, NO. 3, P. 308. ALSO AVAILABLE AS */ /* SANDIA TECHNICAL REPORT NO. SAND77-0898. */ /* 3. AN ALGORITHM FOR LINEAR LEAST SQUARES WITH EQUALITY */ /* AND NONNEGATIVITY CONSTRAINTS, BY K.H. HASKELL AND */ /* R.J. HANSON. AVAILABLE AS SANDIA TECHNICAL REPORT NO. */ /* SAND77-0552, AND MATH. PROGRAMMING, VOL. 21, (1981), P. 98-118. */ /* 4. SLATEC COMMON MATH. LIBRARY ERROR HANDLING */ /* PACKAGE. BY R. E. JONES. AVAILABLE AS SANDIA */ /* TECHNICAL REPORT SAND78-1189. */ /*< REAL DUMMY, W(MDW,1), PRGOPT(1), X(1), WORK(1), RNORM >*/ /*< INTEGER IWORK(1) >*/ /*< MODE = 0 >*/ #line 1496 "cl2.f" /* Parameter adjustments */ #line 1496 "cl2.f" w_dim1 = *mdw; #line 1496 "cl2.f" w_offset = 1 + w_dim1; #line 1496 "cl2.f" w -= w_offset; #line 1496 "cl2.f" --prgopt; #line 1496 "cl2.f" --x; #line 1496 "cl2.f" --iwork; #line 1496 "cl2.f" --work; #line 1496 "cl2.f" #line 1496 "cl2.f" /* Function Body */ #line 1496 "cl2.f" *mode = 0; /*< IF (MA+ME.LE.0 .OR. N.LE.0) RETURN >*/ #line 1497 "cl2.f" if (*ma + *me <= 0 || *n <= 0) { #line 1497 "cl2.f" return 0; #line 1497 "cl2.f" } /*< IF (.NOT.(IWORK(1).GT.0)) GO TO 20 >*/ #line 1498 "cl2.f" if (! (iwork[1] > 0)) { #line 1498 "cl2.f" goto L20; #line 1498 "cl2.f" } /*< LW = ME + MA + 5*N >*/ #line 1499 "cl2.f" lw = *me + *ma + *n * 5; /*< IF (.NOT.(IWORK(1).LT.LW)) GO TO 10 >*/ #line 1500 "cl2.f" if (! (iwork[1] < lw)) { #line 1500 "cl2.f" goto L10; #line 1500 "cl2.f" } /*< NERR = 2 >*/ #line 1501 "cl2.f" nerr = 2; /*< IOPT = 1 >*/ #line 1502 "cl2.f" iopt = 1; /* cc CALL XERRWV(70HWNNLS( ), INSUFFICIENT STORAGE ALLOCATED FOR WORK(* */ /* cc *), NEED LW=I1 BELOW, 70, NERR, IOPT, 1, LW, 0, 0, DUMMY, DUMMY) */ /*< MODE = 2 >*/ #line 1505 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1506 "cl2.f" return 0; /*< 10 CONTINUE >*/ #line 1507 "cl2.f" L10: /*< 20 IF (.NOT.(IWORK(2).GT.0)) GO TO 40 >*/ #line 1508 "cl2.f" L20: #line 1508 "cl2.f" if (! (iwork[2] > 0)) { #line 1508 "cl2.f" goto L40; #line 1508 "cl2.f" } /*< LIW = ME + MA + N >*/ #line 1509 "cl2.f" liw = *me + *ma + *n; /*< IF (.NOT.(IWORK(2).LT.LIW)) GO TO 30 >*/ #line 1510 "cl2.f" if (! (iwork[2] < liw)) { #line 1510 "cl2.f" goto L30; #line 1510 "cl2.f" } /*< NERR = 2 >*/ #line 1511 "cl2.f" nerr = 2; /*< IOPT = 1 >*/ #line 1512 "cl2.f" iopt = 1; /* cc CALL XERRWV(72HWNNLS( ), INSUFFICIENT STORAGE ALLOCATED FOR IWORK( */ /* cc **), NEED LIW=I1 BELOW, 72, NERR, IOPT, 1, LIW, 0, 0, DUMMY, DUMMY) */ /*< MODE = 2 >*/ #line 1515 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1516 "cl2.f" return 0; /*< 30 CONTINUE >*/ #line 1517 "cl2.f" L30: /*< 40 IF (.NOT.(MDW.LT.ME+MA)) GO TO 50 >*/ #line 1518 "cl2.f" L40: #line 1518 "cl2.f" if (! (*mdw < *me + *ma)) { #line 1518 "cl2.f" goto L50; #line 1518 "cl2.f" } /*< NERR = 1 >*/ #line 1519 "cl2.f" nerr = 1; /*< IOPT = 1 >*/ #line 1520 "cl2.f" iopt = 1; /* cc CALL XERROR(44HWNNLS( ), THE VALUE MDW.LT.ME+MA IS AN ERROR, 44, */ /* cc * NERR, IOPT) */ /*< MODE = 2 >*/ #line 1523 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1524 "cl2.f" return 0; /*< 50 IF (0.LE.L .AND. L.LE.N) GO TO 60 >*/ #line 1525 "cl2.f" L50: #line 1525 "cl2.f" if (0 <= *l && *l <= *n) { #line 1525 "cl2.f" goto L60; #line 1525 "cl2.f" } /*< NERR = 2 >*/ #line 1526 "cl2.f" nerr = 2; /*< IOPT = 1 >*/ #line 1527 "cl2.f" iopt = 1; /* cc CALL XERROR(39HWNNLS( ), L.LE.0.AND.L.LE.N IS REQUIRED, 39, NERR, */ /* cc * IOPT) */ /*< MODE = 2 >*/ #line 1530 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1531 "cl2.f" return 0; /* THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS */ /* WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS */ /* REQUIRED BY THE MAIN SUBROUTINE WNLSM( ). */ /*< 60 L1 = N + 1 >*/ #line 1537 "cl2.f" L60: #line 1537 "cl2.f" l1 = *n + 1; /*< L2 = L1 + N >*/ #line 1538 "cl2.f" l2 = l1 + *n; /*< L3 = L2 + ME + MA >*/ #line 1539 "cl2.f" l3 = l2 + *me + *ma; /*< L4 = L3 + N >*/ #line 1540 "cl2.f" l4 = l3 + *n; /*< L5 = L4 + N >*/ #line 1541 "cl2.f" l5 = l4 + *n; /*< >*/ #line 1543 "cl2.f" wnlsm_(&w[w_offset], mdw, me, ma, n, l, &prgopt[1], &x[1], rnorm, mode, & iwork[1], &iwork[l1], &work[1], &work[l1], &work[l2], &work[l3], & work[l4], &work[l5]); /*< RETURN >*/ #line 1546 "cl2.f" return 0; /*< END >*/ } /* wnnls_fort */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< >*/ static /* Subroutine */ int wnlsm_(real *w, integer *mdw, integer *mme, integer *ma, integer *n, integer *l, real *prgopt, real *x, real *rnorm, integer * mode, integer *ipivot, integer *itype, real *wd, real *h__, real * scale, real *z__, real *temp, real *d__) { /* Initialized data */ static real zero = 0.f; static real one = 1.f; static real two = 2.f; static real srelpr = 0.f; /* Format strings */ static char fmt_10[] = ""; static char fmt_20[] = ""; static char fmt_30[] = ""; static char fmt_40[] = ""; static char fmt_60[] = ""; static char fmt_90[] = ""; static char fmt_220[] = ""; static char fmt_310[] = ""; static char fmt_460[] = ""; static char fmt_480[] = ""; static char fmt_500[] = ""; static char fmt_520[] = ""; static char fmt_880[] = ""; static char fmt_900[] = ""; static char fmt_1010[] = ""; /* System generated locals */ integer w_dim1, w_offset, i__1, i__2; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, m; static real t; static integer l1; static real z2; static integer me, jj, jp; static real sm, zz; static integer jm1, nm1, lp1, np1; static real fac; static integer key; static real tau; static integer niv; static logical pos; static integer mep1, krp1, niv1, nsp1; static logical done; static real amax, dope[4]; static integer jcon, link, imax; static real alsq; static integer last, iter, nerr, isol, iopt; static real wmax; static integer next, nopt, igo980, igo991, igo983, igo938, igo958, igo995, igo986, igo977, igo998, igo897; static real alpha; static integer idope[8]; static integer krank, nlink; static real bnorm; static integer itemp, itmax, iwmax; static integer nsoln; static real alamda; static logical feasbl; static real eanorm; static real sparam[5]; static logical hitcon; static integer ntimes; static real blowup; /* Assigned format variables */ static char *igo998_fmt, *igo995_fmt, *igo991_fmt, *igo986_fmt, * igo983_fmt, *igo980_fmt, *igo977_fmt, *igo958_fmt, *igo938_fmt, * igo897_fmt; /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (START CHANGES AT LINE WITH C++ IN COLS. 1-3.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/,/SROTMG/DROTMG/, */ /* /SNRM2/DNRM2/,/ SQRT/ DSQRT/,/SROTM/DROTM/,/AMAX1/DMAX1/, */ /* /SCOPY/DCOPY/,/SSCAL/DSCAL/,/SAXPY/DAXPY/,/E0/D0/,/SSWAP/DSWAP/, */ /* /ISAMAX/IDAMAX/,/SRELPR/DRELPR/,/.E-/.D-/ REMK */ /* THIS IS A COMPANION SUBPROGRAM TO WNNLS( ). */ /* THE DOCUMENTATION FOR WNNLS( ) HAS MORE COMPLETE */ /* USAGE INSTRUCTIONS. */ /* WRITTEN BY KAREN H. HASKELL, SANDIA LABORATORIES, */ /* WITH THE HELP OF R.J. HANSON, SANDIA LABORATORIES, */ /* DECEMBER 1976 - JANUARY 1978. */ /* REVISED MAR. 4, 1982. */ /* IN ADDITION TO THE PARAMETERS DISCUSSED IN THE PROLOGUE TO */ /* SUBROUTINE WNNLS, THE FOLLOWING WORK ARRAYS ARE USED IN */ /* SUBROUTINE WNLSM (THEY ARE PASSED THROUGH THE CALLING */ /* SEQUENCE FROM WNNLS FOR PURPOSES OF VARIABLE DIMENSIONING). */ /* THEIR CONTENTS WILL IN GENERAL BE OF NO INTEREST TO THE USER. */ /* IPIVOT(*) */ /* AN ARRAY OF LENGTH N. UPON COMPLETION IT CONTAINS THE */ /* PIVOTING INFORMATION FOR THE COLS OF W(*,*). */ /* ITYPE(*) */ /* AN ARRAY OF LENGTH M WHICH IS USED TO KEEP TRACK */ /* OF THE CLASSIFICATION OF THE EQUATIONS. ITYPE(I)=0 */ /* DENOTES EQUATION I AS AN EQUALITY CONSTRAINT. */ /* ITYPE(I)=1 DENOTES EQUATION I AS A LEAST SQUARES */ /* EQUATION. */ /* WD(*) */ /* AN ARRAY OF LENGTH N. UPON COMPLETION IT CONTAINS THE */ /* DUAL SOLUTION VECTOR. */ /* H(*) */ /* AN ARRAY OF LENGTH N. UPON COMPLETION IT CONTAINS THE */ /* PIVOT SCALARS OF THE HOUSEHOLDER TRANSFORMATIONS PERFORMED */ /* IN THE CASE KRANK.LT.L. */ /* SCALE(*) */ /* AN ARRAY OF LENGTH M WHICH IS USED BY THE SUBROUTINE */ /* TO STORE THE DIAGONAL MATRIX OF WEIGHTS. */ /* THESE ARE USED TO APPLY THE MODIFIED GIVENS */ /* TRANSFORMATIONS. */ /* Z(*),TEMP(*) */ /* WORKING ARRAYS OF LENGTH N. */ /* D(*) */ /* AN ARRAY OF LENGTH N THAT CONTAINS THE */ /* COLUMN SCALING FOR THE MATRIX (E). */ /* (A) */ /* SUBROUTINE WNLSM (W,MDW,MME,MA,N,L,PRGOPT,X,RNORM,MODE, */ /* 1 IPIVOT,ITYPE,WD,H,SCALE,Z,TEMP,D) */ /* ++ */ /*< REAL W(MDW,1), X(1), WD(1), H(1), SCALE(1), DOPE(4) >*/ /*< REAL Z(1), TEMP(1), PRGOPT(1), D(1), SPARAM(5) >*/ /*< REAL ALAMDA, ALPHA, ALSQ, AMAX, BNORM, EANORM >*/ /*< REAL SRELPR, FAC, ONE, BLOWUP >*/ /*< REAL RNORM, SM, T, TAU, TWO, WMAX, ZERO, ZZ, Z2 >*/ /*< REAL AMAX1, SQRT, SNRM2, SASUM >*/ /*< INTEGER IPIVOT(1), ITYPE(1), ISAMAX, IDOPE(8) >*/ /*< LOGICAL HITCON, FEASBL, DONE, POS >*/ /*< DATA ZERO /0.E0/, ONE /1.E0/, TWO /2.E0/, SRELPR /0.E0/ >*/ #line 1624 "cl2.f" /* Parameter adjustments */ #line 1624 "cl2.f" w_dim1 = *mdw; #line 1624 "cl2.f" w_offset = 1 + w_dim1; #line 1624 "cl2.f" w -= w_offset; #line 1624 "cl2.f" --prgopt; #line 1624 "cl2.f" --x; #line 1624 "cl2.f" --ipivot; #line 1624 "cl2.f" --itype; #line 1624 "cl2.f" --wd; #line 1624 "cl2.f" --h__; #line 1624 "cl2.f" --scale; #line 1624 "cl2.f" --z__; #line 1624 "cl2.f" --temp; #line 1624 "cl2.f" --d__; #line 1624 "cl2.f" #line 1624 "cl2.f" /* Function Body */ /* INITIALIZE-VARIABLES */ /*< ASSIGN 10 TO IGO998 >*/ #line 1627 "cl2.f" igo998 = 0; #line 1627 "cl2.f" igo998_fmt = fmt_10; /*< GO TO 180 >*/ #line 1628 "cl2.f" goto L180; /* PERFORM INITIAL TRIANGULARIZATION IN THE SUBMATRIX */ /* CORRESPONDING TO THE UNCONSTRAINED VARIABLES USING */ /* THE PROCEDURE INITIALLY-TRIANGULARIZE. */ /*< 10 ASSIGN 20 TO IGO995 >*/ #line 1633 "cl2.f" L10: #line 1633 "cl2.f" igo995 = 0; #line 1633 "cl2.f" igo995_fmt = fmt_20; /*< GO TO 280 >*/ #line 1634 "cl2.f" goto L280; /* PERFORM WNNLS ALGORITHM USING THE FOLLOWING STEPS. */ /* UNTIL(DONE) */ /* COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT */ /* WHEN (HITCON) ADD-CONSTRAINTS */ /* ELSE PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT */ /* FIN */ /* COMPUTE-FINAL-SOLUTION */ /*< 20 IF (DONE) GO TO 80 >*/ #line 1650 "cl2.f" L20: #line 1650 "cl2.f" if (done) { #line 1650 "cl2.f" goto L80; #line 1650 "cl2.f" } /*< ASSIGN 30 TO IGO991 >*/ #line 1652 "cl2.f" igo991 = 0; #line 1652 "cl2.f" igo991_fmt = fmt_30; /*< GO TO 300 >*/ #line 1653 "cl2.f" goto L300; /* COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT */ /*< 30 IF (.NOT.(HITCON)) GO TO 50 >*/ #line 1657 "cl2.f" L30: #line 1657 "cl2.f" if (! hitcon) { #line 1657 "cl2.f" goto L50; #line 1657 "cl2.f" } /*< ASSIGN 40 TO IGO986 >*/ #line 1658 "cl2.f" igo986 = 0; #line 1658 "cl2.f" igo986_fmt = fmt_40; /*< GO TO 370 >*/ #line 1659 "cl2.f" goto L370; /*< 40 GO TO 70 >*/ #line 1660 "cl2.f" L40: #line 1660 "cl2.f" goto L70; /* WHEN (HITCON) ADD-CONSTRAINTS */ /*< 50 ASSIGN 60 TO IGO983 >*/ #line 1664 "cl2.f" L50: #line 1664 "cl2.f" igo983 = 0; #line 1664 "cl2.f" igo983_fmt = fmt_60; /*< GO TO 640 >*/ #line 1665 "cl2.f" goto L640; /*< 60 CONTINUE >*/ #line 1666 "cl2.f" L60: /* ELSE PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT */ /*< 70 GO TO 20 >*/ #line 1670 "cl2.f" L70: #line 1670 "cl2.f" goto L20; /*< 80 ASSIGN 90 TO IGO980 >*/ #line 1672 "cl2.f" L80: #line 1672 "cl2.f" igo980 = 0; #line 1672 "cl2.f" igo980_fmt = fmt_90; /*< GO TO 1000 >*/ #line 1673 "cl2.f" goto L1000; /* COMPUTE-FINAL-SOLUTION */ /*< 90 RETURN >*/ #line 1677 "cl2.f" L90: #line 1677 "cl2.f" return 0; /*< 100 CONTINUE >*/ #line 1678 "cl2.f" L100: /* TO PROCESS-OPTION-VECTOR */ /*< FAC = 1.E-4 >*/ #line 1681 "cl2.f" fac = 1e-4f; /* THE NOMINAL TOLERANCE USED IN THE CODE, */ /*< TAU = SQRT(SRELPR) >*/ #line 1684 "cl2.f" tau = sqrt(srelpr); /* THE NOMINAL BLOW-UP FACTOR USED IN THE CODE. */ /*< BLOWUP = TAU >*/ #line 1687 "cl2.f" blowup = tau; /* THE NOMINAL COLUMN SCALING USED IN THE CODE IS */ /* THE IDENTITY SCALING. */ /*< D(1) = ONE >*/ #line 1691 "cl2.f" d__[1] = one; /*< CALL SCOPY(N, D, 0, D, 1) >*/ #line 1692 "cl2.f" scopy_(n, &d__[1], &c__0, &d__[1], &c__1); /* DEFINE BOUND FOR NUMBER OF OPTIONS TO CHANGE. */ /*< NOPT = 1000 >*/ #line 1695 "cl2.f" nopt = 1000; /* DEFINE BOUND FOR POSITIVE VALUE OF LINK. */ /*< NLINK = 100000 >*/ #line 1698 "cl2.f" nlink = 100000; /*< NTIMES = 0 >*/ #line 1699 "cl2.f" ntimes = 0; /*< LAST = 1 >*/ #line 1700 "cl2.f" last = 1; /*< LINK = PRGOPT(1) >*/ #line 1701 "cl2.f" link = prgopt[1]; /*< IF (.NOT.(LINK.LE.0 .OR. LINK.GT.NLINK)) GO TO 110 >*/ #line 1702 "cl2.f" if (! (link <= 0 || link > nlink)) { #line 1702 "cl2.f" goto L110; #line 1702 "cl2.f" } /*< NERR = 3 >*/ #line 1703 "cl2.f" nerr = 3; /*< IOPT = 1 >*/ #line 1704 "cl2.f" iopt = 1; /* cc CALL XERROR(39HWNNLS( ) THE OPTION VECTOR IS UNDEFINED, 39, NERR, */ /* cc * IOPT) */ /*< MODE = 2 >*/ #line 1707 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1708 "cl2.f" return 0; /*< 110 IF (.NOT.(LINK.GT.1)) GO TO 160 >*/ #line 1709 "cl2.f" L110: #line 1709 "cl2.f" if (! (link > 1)) { #line 1709 "cl2.f" goto L160; #line 1709 "cl2.f" } /*< NTIMES = NTIMES + 1 >*/ #line 1710 "cl2.f" ++ntimes; /*< IF (.NOT.(NTIMES.GT.NOPT)) GO TO 120 >*/ #line 1711 "cl2.f" if (! (ntimes > nopt)) { #line 1711 "cl2.f" goto L120; #line 1711 "cl2.f" } /*< NERR = 3 >*/ #line 1712 "cl2.f" nerr = 3; /*< IOPT = 1 >*/ #line 1713 "cl2.f" iopt = 1; /* cc CALL XERROR( */ /* cc * 53HWNNLS( ). THE LINKS IN THE OPTION VECTOR ARE CYCLING., 53, */ /* cc * NERR, IOPT) */ /*< MODE = 2 >*/ #line 1717 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1718 "cl2.f" return 0; /*< 120 KEY = PRGOPT(LAST+1) >*/ #line 1719 "cl2.f" L120: #line 1719 "cl2.f" key = prgopt[last + 1]; /*< IF (.NOT.(KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.ZERO)) GO TO 140 >*/ #line 1720 "cl2.f" if (! (key == 6 && prgopt[last + 2] != zero)) { #line 1720 "cl2.f" goto L140; #line 1720 "cl2.f" } /*< DO 130 J=1,N >*/ #line 1721 "cl2.f" i__1 = *n; #line 1721 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< T = SNRM2(M,W(1,J),1) >*/ #line 1722 "cl2.f" t = snrm2_(&m, &w[j * w_dim1 + 1], &c__1); /*< IF (T.NE.ZERO) T = ONE/T >*/ #line 1723 "cl2.f" if (t != zero) { #line 1723 "cl2.f" t = one / t; #line 1723 "cl2.f" } /*< D(J) = T >*/ #line 1724 "cl2.f" d__[j] = t; /*< 130 CONTINUE >*/ #line 1725 "cl2.f" /* L130: */ #line 1725 "cl2.f" } /*< 140 IF (KEY.EQ.7) CALL SCOPY(N, PRGOPT(LAST+2), 1, D, 1) >*/ #line 1726 "cl2.f" L140: #line 1726 "cl2.f" if (key == 7) { #line 1726 "cl2.f" scopy_(n, &prgopt[last + 2], &c__1, &d__[1], &c__1); #line 1726 "cl2.f" } /*< IF (KEY.EQ.8) TAU = AMAX1(SRELPR,PRGOPT(LAST+2)) >*/ #line 1727 "cl2.f" if (key == 8) { /* Computing MAX */ #line 1727 "cl2.f" r__1 = srelpr, r__2 = prgopt[last + 2]; #line 1727 "cl2.f" tau = max(r__1,r__2); #line 1727 "cl2.f" } /*< IF (KEY.EQ.9) BLOWUP = AMAX1(SRELPR,PRGOPT(LAST+2)) >*/ #line 1728 "cl2.f" if (key == 9) { /* Computing MAX */ #line 1728 "cl2.f" r__1 = srelpr, r__2 = prgopt[last + 2]; #line 1728 "cl2.f" blowup = max(r__1,r__2); #line 1728 "cl2.f" } /*< NEXT = PRGOPT(LINK) >*/ #line 1729 "cl2.f" next = prgopt[link]; /*< IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.NLINK)) GO TO 150 >*/ #line 1730 "cl2.f" if (! (next <= 0 || next > nlink)) { #line 1730 "cl2.f" goto L150; #line 1730 "cl2.f" } /*< NERR = 3 >*/ #line 1731 "cl2.f" nerr = 3; /*< IOPT = 1 >*/ #line 1732 "cl2.f" iopt = 1; /* cc CALL XERROR(39HWNNLS( ) THE OPTION VECTOR IS UNDEFINED, 39, NERR, */ /* cc * IOPT) */ /*< MODE = 2 >*/ #line 1735 "cl2.f" *mode = 2; /*< RETURN >*/ #line 1736 "cl2.f" return 0; /*< 150 LAST = LINK >*/ #line 1737 "cl2.f" L150: #line 1737 "cl2.f" last = link; /*< LINK = NEXT >*/ #line 1738 "cl2.f" link = next; /*< GO TO 110 >*/ #line 1739 "cl2.f" goto L110; /*< 160 DO 170 J=1,N >*/ #line 1740 "cl2.f" L160: #line 1740 "cl2.f" i__1 = *n; #line 1740 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< CALL SSCAL(M, D(J), W(1,J), 1) >*/ #line 1741 "cl2.f" sscal_(&m, &d__[j], &w[j * w_dim1 + 1], &c__1); /*< 170 CONTINUE >*/ #line 1742 "cl2.f" /* L170: */ #line 1742 "cl2.f" } /*< GO TO 1260 >*/ #line 1743 "cl2.f" goto L1260; /*< 180 CONTINUE >*/ #line 1744 "cl2.f" L180: /* TO INITIALIZE-VARIABLES */ /* SRELPR IS THE PRECISION FOR THE PARTICULAR MACHINE */ /* BEING USED. THIS LOGIC AVOIDS RECOMPUTING IT EVERY ENTRY. */ /*< IF (.NOT.(SRELPR.EQ.ZERO)) GO TO 210 >*/ #line 1750 "cl2.f" if (! (srelpr == zero)) { #line 1750 "cl2.f" goto L210; #line 1750 "cl2.f" } /*< SRELPR = ONE >*/ #line 1751 "cl2.f" srelpr = one; /*< 190 IF (ONE+SRELPR.EQ.ONE) GO TO 200 >*/ #line 1752 "cl2.f" L190: #line 1752 "cl2.f" if (one + srelpr == one) { #line 1752 "cl2.f" goto L200; #line 1752 "cl2.f" } /*< SRELPR = SRELPR/TWO >*/ #line 1753 "cl2.f" srelpr /= two; /*< GO TO 190 >*/ #line 1754 "cl2.f" goto L190; /*< 200 SRELPR = SRELPR*TWO >*/ #line 1755 "cl2.f" L200: #line 1755 "cl2.f" srelpr *= two; /*< 210 M = MA + MME >*/ #line 1756 "cl2.f" L210: #line 1756 "cl2.f" m = *ma + *mme; /*< ME = MME >*/ #line 1757 "cl2.f" me = *mme; /*< MEP1 = ME + 1 >*/ #line 1758 "cl2.f" mep1 = me + 1; /*< ASSIGN 220 TO IGO977 >*/ #line 1759 "cl2.f" igo977 = 0; #line 1759 "cl2.f" igo977_fmt = fmt_220; /*< GO TO 100 >*/ #line 1760 "cl2.f" goto L100; /* PROCESS-OPTION-VECTOR */ /*< 220 DONE = .FALSE. >*/ #line 1763 "cl2.f" L220: #line 1763 "cl2.f" done = FALSE_; /*< ITER = 0 >*/ #line 1764 "cl2.f" iter = 0; /*< ITMAX = 3*(N-L) >*/ #line 1765 "cl2.f" itmax = (*n - *l) * 3; /*< MODE = 0 >*/ #line 1766 "cl2.f" *mode = 0; /*< LP1 = L + 1 >*/ #line 1767 "cl2.f" lp1 = *l + 1; /*< NSOLN = L >*/ #line 1768 "cl2.f" nsoln = *l; /*< NSP1 = NSOLN + 1 >*/ #line 1769 "cl2.f" nsp1 = nsoln + 1; /*< NP1 = N + 1 >*/ #line 1770 "cl2.f" np1 = *n + 1; /*< NM1 = N - 1 >*/ #line 1771 "cl2.f" nm1 = *n - 1; /*< L1 = MIN0(M,L) >*/ #line 1772 "cl2.f" l1 = min(m,*l); /* COMPUTE SCALE FACTOR TO APPLY TO EQUAL. CONSTRAINT EQUAS. */ /*< DO 230 J=1,N >*/ #line 1775 "cl2.f" i__1 = *n; #line 1775 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< WD(J) = SASUM(M,W(1,J),1) >*/ #line 1776 "cl2.f" wd[j] = sasum_(&m, &w[j * w_dim1 + 1], &c__1); /*< 230 CONTINUE >*/ #line 1777 "cl2.f" /* L230: */ #line 1777 "cl2.f" } /*< IMAX = ISAMAX(N,WD,1) >*/ #line 1778 "cl2.f" imax = isamax_(n, &wd[1], &c__1); /*< EANORM = WD(IMAX) >*/ #line 1779 "cl2.f" eanorm = wd[imax]; /*< BNORM = SASUM(M,W(1,NP1),1) >*/ #line 1780 "cl2.f" bnorm = sasum_(&m, &w[np1 * w_dim1 + 1], &c__1); /*< ALAMDA = EANORM/(SRELPR*FAC) >*/ #line 1781 "cl2.f" alamda = eanorm / (srelpr * fac); /* DEFINE SCALING DIAG MATRIX FOR MOD GIVENS USAGE AND */ /* CLASSIFY EQUATION TYPES. */ /*< ALSQ = ALAMDA**2 >*/ /* Computing 2nd power */ #line 1785 "cl2.f" r__1 = alamda; #line 1785 "cl2.f" alsq = r__1 * r__1; /*< DO 260 I=1,M >*/ #line 1786 "cl2.f" i__1 = m; #line 1786 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /* WHEN EQU I IS HEAVILY WEIGHTED ITYPE(I)=0, ELSE ITYPE(I)=1. */ /*< IF (.NOT.(I.LE.ME)) GO TO 240 >*/ #line 1789 "cl2.f" if (! (i__ <= me)) { #line 1789 "cl2.f" goto L240; #line 1789 "cl2.f" } /*< T = ALSQ >*/ #line 1790 "cl2.f" t = alsq; /*< ITEMP = 0 >*/ #line 1791 "cl2.f" itemp = 0; /*< GO TO 250 >*/ #line 1792 "cl2.f" goto L250; /*< 240 T = ONE >*/ #line 1793 "cl2.f" L240: #line 1793 "cl2.f" t = one; /*< ITEMP = 1 >*/ #line 1794 "cl2.f" itemp = 1; /*< 250 SCALE(I) = T >*/ #line 1795 "cl2.f" L250: #line 1795 "cl2.f" scale[i__] = t; /*< ITYPE(I) = ITEMP >*/ #line 1796 "cl2.f" itype[i__] = itemp; /*< 260 CONTINUE >*/ #line 1797 "cl2.f" /* L260: */ #line 1797 "cl2.f" } /* SET THE SOLN VECTOR X(*) TO ZERO AND THE COL INTERCHANGE */ /* MATRIX TO THE IDENTITY. */ /*< X(1) = ZERO >*/ #line 1801 "cl2.f" x[1] = zero; /*< CALL SCOPY(N, X, 0, X, 1) >*/ #line 1802 "cl2.f" scopy_(n, &x[1], &c__0, &x[1], &c__1); /*< DO 270 I=1,N >*/ #line 1803 "cl2.f" i__1 = *n; #line 1803 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< IPIVOT(I) = I >*/ #line 1804 "cl2.f" ipivot[i__] = i__; /*< 270 CONTINUE >*/ #line 1805 "cl2.f" /* L270: */ #line 1805 "cl2.f" } /*< GO TO 1230 >*/ #line 1806 "cl2.f" goto L1230; /*< 280 CONTINUE >*/ #line 1807 "cl2.f" L280: /* TO INITIALLY-TRIANGULARIZE */ /* SET FIRST L COMPS. OF DUAL VECTOR TO ZERO BECAUSE */ /* THESE CORRESPOND TO THE UNCONSTRAINED VARIABLES. */ /*< IF (.NOT.(L.GT.0)) GO TO 290 >*/ #line 1813 "cl2.f" if (! (*l > 0)) { #line 1813 "cl2.f" goto L290; #line 1813 "cl2.f" } /*< WD(1) = ZERO >*/ #line 1814 "cl2.f" wd[1] = zero; /*< CALL SCOPY(L, WD, 0, WD, 1) >*/ #line 1815 "cl2.f" scopy_(l, &wd[1], &c__0, &wd[1], &c__1); /* THE ARRAYS IDOPE(*) AND DOPE(*) ARE USED TO PASS */ /* INFORMATION TO WNLIT(). THIS WAS DONE TO AVOID */ /* A LONG CALLING SEQUENCE OR THE USE OF COMMON. */ /*< 290 IDOPE(1) = ME >*/ #line 1820 "cl2.f" L290: #line 1820 "cl2.f" idope[0] = me; /*< IDOPE(2) = MEP1 >*/ #line 1821 "cl2.f" idope[1] = mep1; /*< IDOPE(3) = 0 >*/ #line 1822 "cl2.f" idope[2] = 0; /*< IDOPE(4) = 1 >*/ #line 1823 "cl2.f" idope[3] = 1; /*< IDOPE(5) = NSOLN >*/ #line 1824 "cl2.f" idope[4] = nsoln; /*< IDOPE(6) = 0 >*/ #line 1825 "cl2.f" idope[5] = 0; /*< IDOPE(7) = 1 >*/ #line 1826 "cl2.f" idope[6] = 1; /*< IDOPE(8) = L1 >*/ #line 1827 "cl2.f" idope[7] = l1; /*< DOPE(1) = ALSQ >*/ #line 1829 "cl2.f" dope[0] = alsq; /*< DOPE(2) = EANORM >*/ #line 1830 "cl2.f" dope[1] = eanorm; /*< DOPE(3) = FAC >*/ #line 1831 "cl2.f" dope[2] = fac; /*< DOPE(4) = TAU >*/ #line 1832 "cl2.f" dope[3] = tau; /*< >*/ #line 1833 "cl2.f" wnlit_(&w[w_offset], mdw, &m, n, l, &ipivot[1], &itype[1], &h__[1], & scale[1], rnorm, idope, dope, &done); /*< ME = IDOPE(1) >*/ #line 1835 "cl2.f" me = idope[0]; /*< MEP1 = IDOPE(2) >*/ #line 1836 "cl2.f" mep1 = idope[1]; /*< KRANK = IDOPE(3) >*/ #line 1837 "cl2.f" krank = idope[2]; /*< KRP1 = IDOPE(4) >*/ #line 1838 "cl2.f" krp1 = idope[3]; /*< NSOLN = IDOPE(5) >*/ #line 1839 "cl2.f" nsoln = idope[4]; /*< NIV = IDOPE(6) >*/ #line 1840 "cl2.f" niv = idope[5]; /*< NIV1 = IDOPE(7) >*/ #line 1841 "cl2.f" niv1 = idope[6]; /*< L1 = IDOPE(8) >*/ #line 1842 "cl2.f" l1 = idope[7]; /*< GO TO 1240 >*/ #line 1843 "cl2.f" goto L1240; /*< 300 CONTINUE >*/ #line 1844 "cl2.f" L300: /* TO COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT */ /* SOLVE THE TRIANGULAR SYSTEM OF CURRENTLY NON-ACTIVE */ /* VARIABLES AND STORE THE SOLUTION IN Z(*). */ /* SOLVE-SYSTEM */ /*< ASSIGN 310 TO IGO958 >*/ #line 1852 "cl2.f" igo958 = 0; #line 1852 "cl2.f" igo958_fmt = fmt_310; /*< GO TO 1110 >*/ #line 1853 "cl2.f" goto L1110; /* INCREMENT ITERATION COUNTER AND CHECK AGAINST MAX. NUMBER */ /* OF ITERATIONS. */ /*< 310 ITER = ITER + 1 >*/ #line 1857 "cl2.f" L310: #line 1857 "cl2.f" ++iter; /*< IF (.NOT.(ITER.GT.ITMAX)) GO TO 320 >*/ #line 1858 "cl2.f" if (! (iter > itmax)) { #line 1858 "cl2.f" goto L320; #line 1858 "cl2.f" } /*< MODE = 1 >*/ #line 1859 "cl2.f" *mode = 1; /*< DONE = .TRUE. >*/ #line 1860 "cl2.f" done = TRUE_; /* CHECK TO SEE IF ANY CONSTRAINTS HAVE BECOME ACTIVE. */ /* IF SO, CALCULATE AN INTERPOLATION FACTOR SO THAT ALL */ /* ACTIVE CONSTRAINTS ARE REMOVED FROM THE BASIS. */ /*< 320 ALPHA = TWO >*/ #line 1865 "cl2.f" L320: #line 1865 "cl2.f" alpha = two; /*< HITCON = .FALSE. >*/ #line 1866 "cl2.f" hitcon = FALSE_; /*< IF (.NOT.(L.LT.NSOLN)) GO TO 360 >*/ #line 1867 "cl2.f" if (! (*l < nsoln)) { #line 1867 "cl2.f" goto L360; #line 1867 "cl2.f" } /*< DO 350 J=LP1,NSOLN >*/ #line 1868 "cl2.f" i__1 = nsoln; #line 1868 "cl2.f" for (j = lp1; j <= i__1; ++j) { /*< ZZ = Z(J) >*/ #line 1869 "cl2.f" zz = z__[j]; /*< IF (.NOT.(ZZ.LE.ZERO)) GO TO 340 >*/ #line 1870 "cl2.f" if (! (zz <= zero)) { #line 1870 "cl2.f" goto L340; #line 1870 "cl2.f" } /*< T = X(J)/(X(J)-ZZ) >*/ #line 1871 "cl2.f" t = x[j] / (x[j] - zz); /*< IF (.NOT.(T.LT.ALPHA)) GO TO 330 >*/ #line 1872 "cl2.f" if (! (t < alpha)) { #line 1872 "cl2.f" goto L330; #line 1872 "cl2.f" } /*< ALPHA = T >*/ #line 1873 "cl2.f" alpha = t; /*< JCON = J >*/ #line 1874 "cl2.f" jcon = j; /*< 330 HITCON = .TRUE. >*/ #line 1875 "cl2.f" L330: #line 1875 "cl2.f" hitcon = TRUE_; /*< 340 CONTINUE >*/ #line 1876 "cl2.f" L340: /*< 350 CONTINUE >*/ #line 1877 "cl2.f" /* L350: */ #line 1877 "cl2.f" ; #line 1877 "cl2.f" } /*< 360 GO TO 1220 >*/ #line 1878 "cl2.f" L360: #line 1878 "cl2.f" goto L1220; /*< 370 CONTINUE >*/ #line 1879 "cl2.f" L370: /* TO ADD-CONSTRAINTS */ /* USE COMPUTED ALPHA TO INTERPOLATE BETWEEN LAST */ /* FEASIBLE SOLUTION X(*) AND CURRENT UNCONSTRAINED */ /* (AND INFEASIBLE) SOLUTION Z(*). */ /*< IF (.NOT.(LP1.LE.NSOLN)) GO TO 390 >*/ #line 1886 "cl2.f" if (! (lp1 <= nsoln)) { #line 1886 "cl2.f" goto L390; #line 1886 "cl2.f" } /*< DO 380 J=LP1,NSOLN >*/ #line 1887 "cl2.f" i__1 = nsoln; #line 1887 "cl2.f" for (j = lp1; j <= i__1; ++j) { /*< X(J) = X(J) + ALPHA*(Z(J)-X(J)) >*/ #line 1888 "cl2.f" x[j] += alpha * (z__[j] - x[j]); /*< 380 CONTINUE >*/ #line 1889 "cl2.f" /* L380: */ #line 1889 "cl2.f" } /*< 390 FEASBL = .FALSE. >*/ #line 1890 "cl2.f" L390: #line 1890 "cl2.f" feasbl = FALSE_; /*< GO TO 410 >*/ #line 1891 "cl2.f" goto L410; /*< 400 IF (FEASBL) GO TO 610 >*/ #line 1892 "cl2.f" L400: #line 1892 "cl2.f" if (feasbl) { #line 1892 "cl2.f" goto L610; #line 1892 "cl2.f" } /* REMOVE COL JCON AND SHIFT COLS JCON+1 THROUGH N TO THE */ /* LEFT. SWAP COL JCON INTO THE N-TH POSITION. THIS ACHIEVES */ /* UPPER HESSENBERG FORM FOR THE NONACTIVE CONSTRAINTS AND */ /* LEAVES AN UPPER HESSENBERG MATRIX TO RETRIANGULARIZE. */ /*< 410 DO 420 I=1,M >*/ #line 1898 "cl2.f" L410: #line 1898 "cl2.f" i__1 = m; #line 1898 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< T = W(I,JCON) >*/ #line 1899 "cl2.f" t = w[i__ + jcon * w_dim1]; /*< CALL SCOPY(N-JCON, W(I,JCON+1), MDW, W(I,JCON), MDW) >*/ #line 1900 "cl2.f" i__2 = *n - jcon; #line 1900 "cl2.f" scopy_(&i__2, &w[i__ + (jcon + 1) * w_dim1], mdw, &w[i__ + jcon * w_dim1], mdw); /*< W(I,N) = T >*/ #line 1901 "cl2.f" w[i__ + *n * w_dim1] = t; /*< 420 CONTINUE >*/ #line 1902 "cl2.f" /* L420: */ #line 1902 "cl2.f" } /* UPDATE PERMUTED INDEX VECTOR TO REFLECT THIS SHIFT AND SWAP. */ /*< ITEMP = IPIVOT(JCON) >*/ #line 1905 "cl2.f" itemp = ipivot[jcon]; /*< IF (.NOT.(JCON.LT.N)) GO TO 440 >*/ #line 1906 "cl2.f" if (! (jcon < *n)) { #line 1906 "cl2.f" goto L440; #line 1906 "cl2.f" } /*< DO 430 I=JCON,NM1 >*/ #line 1907 "cl2.f" i__1 = nm1; #line 1907 "cl2.f" for (i__ = jcon; i__ <= i__1; ++i__) { /*< IPIVOT(I) = IPIVOT(I+1) >*/ #line 1908 "cl2.f" ipivot[i__] = ipivot[i__ + 1]; /*< 430 CONTINUE >*/ #line 1909 "cl2.f" /* L430: */ #line 1909 "cl2.f" } /*< 440 IPIVOT(N) = ITEMP >*/ #line 1910 "cl2.f" L440: #line 1910 "cl2.f" ipivot[*n] = itemp; /* SIMILARLY REPERMUTE X(*) VECTOR. */ /*< CALL SCOPY(N-JCON, X(JCON+1), 1, X(JCON), 1) >*/ #line 1913 "cl2.f" i__1 = *n - jcon; #line 1913 "cl2.f" scopy_(&i__1, &x[jcon + 1], &c__1, &x[jcon], &c__1); /*< X(N) = ZERO >*/ #line 1914 "cl2.f" x[*n] = zero; /*< NSP1 = NSOLN >*/ #line 1915 "cl2.f" nsp1 = nsoln; /*< NSOLN = NSOLN - 1 >*/ #line 1916 "cl2.f" --nsoln; /*< NIV1 = NIV >*/ #line 1917 "cl2.f" niv1 = niv; /*< NIV = NIV - 1 >*/ #line 1918 "cl2.f" --niv; /* RETRIANGULARIZE UPPER HESSENBERG MATRIX AFTER ADDING CONSTRAINTS. */ /*< J = JCON >*/ #line 1921 "cl2.f" j = jcon; /*< I = KRANK + JCON - L >*/ #line 1922 "cl2.f" i__ = krank + jcon - *l; /*< 450 IF (.NOT.(J.LE.NSOLN)) GO TO 570 >*/ #line 1923 "cl2.f" L450: #line 1923 "cl2.f" if (! (j <= nsoln)) { #line 1923 "cl2.f" goto L570; #line 1923 "cl2.f" } /*< IF (.NOT.(ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0)) GO TO 470 >*/ #line 1924 "cl2.f" if (! (itype[i__] == 0 && itype[i__ + 1] == 0)) { #line 1924 "cl2.f" goto L470; #line 1924 "cl2.f" } /*< ASSIGN 460 TO IGO938 >*/ #line 1925 "cl2.f" igo938 = 0; #line 1925 "cl2.f" igo938_fmt = fmt_460; /*< GO TO 620 >*/ #line 1926 "cl2.f" goto L620; /* (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) ZERO-IP1-TO-I-IN-COL-J */ /*< 460 GO TO 560 >*/ #line 1929 "cl2.f" L460: #line 1929 "cl2.f" goto L560; /*< 470 IF (.NOT.(ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1)) GO TO 490 >*/ #line 1930 "cl2.f" L470: #line 1930 "cl2.f" if (! (itype[i__] == 1 && itype[i__ + 1] == 1)) { #line 1930 "cl2.f" goto L490; #line 1930 "cl2.f" } /*< ASSIGN 480 TO IGO938 >*/ #line 1931 "cl2.f" igo938 = 1; #line 1931 "cl2.f" igo938_fmt = fmt_480; /*< GO TO 620 >*/ #line 1932 "cl2.f" goto L620; /* (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) ZERO-IP1-TO-I-IN-COL-J */ /*< 480 GO TO 560 >*/ #line 1935 "cl2.f" L480: #line 1935 "cl2.f" goto L560; /*< 490 IF (.NOT.(ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0)) GO TO 510 >*/ #line 1936 "cl2.f" L490: #line 1936 "cl2.f" if (! (itype[i__] == 1 && itype[i__ + 1] == 0)) { #line 1936 "cl2.f" goto L510; #line 1936 "cl2.f" } /*< CALL SSWAP(NP1, W(I,1), MDW, W(I+1,1), MDW) >*/ #line 1937 "cl2.f" sswap_(&np1, &w[i__ + w_dim1], mdw, &w[i__ + 1 + w_dim1], mdw); /*< CALL SSWAP(1, SCALE(I), 1, SCALE(I+1), 1) >*/ #line 1938 "cl2.f" sswap_(&c__1, &scale[i__], &c__1, &scale[i__ + 1], &c__1); /*< ITEMP = ITYPE(I+1) >*/ #line 1939 "cl2.f" itemp = itype[i__ + 1]; /*< ITYPE(I+1) = ITYPE(I) >*/ #line 1940 "cl2.f" itype[i__ + 1] = itype[i__]; /*< ITYPE(I) = ITEMP >*/ #line 1941 "cl2.f" itype[i__] = itemp; /* SWAPPED ROW WAS FORMERLY A PIVOT ELT., SO IT WILL */ /* BE LARGE ENOUGH TO PERFORM ELIM. */ /*< ASSIGN 500 TO IGO938 >*/ #line 1945 "cl2.f" igo938 = 2; #line 1945 "cl2.f" igo938_fmt = fmt_500; /*< GO TO 620 >*/ #line 1946 "cl2.f" goto L620; /* ZERO-IP1-TO-I-IN-COL-J */ /*< 500 GO TO 560 >*/ #line 1949 "cl2.f" L500: #line 1949 "cl2.f" goto L560; /*< 510 IF (.NOT.(ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1)) GO TO 550 >*/ #line 1950 "cl2.f" L510: #line 1950 "cl2.f" if (! (itype[i__] == 0 && itype[i__ + 1] == 1)) { #line 1950 "cl2.f" goto L550; #line 1950 "cl2.f" } /*< T = SCALE(I)*W(I,J)**2/ALSQ >*/ /* Computing 2nd power */ #line 1951 "cl2.f" r__1 = w[i__ + j * w_dim1]; #line 1951 "cl2.f" t = scale[i__] * (r__1 * r__1) / alsq; /*< IF (.NOT.(T.GT.TAU**2*EANORM**2)) GO TO 530 >*/ /* Computing 2nd power */ #line 1952 "cl2.f" r__1 = tau; /* Computing 2nd power */ #line 1952 "cl2.f" r__2 = eanorm; #line 1952 "cl2.f" if (! (t > r__1 * r__1 * (r__2 * r__2))) { #line 1952 "cl2.f" goto L530; #line 1952 "cl2.f" } /*< ASSIGN 520 TO IGO938 >*/ #line 1953 "cl2.f" igo938 = 3; #line 1953 "cl2.f" igo938_fmt = fmt_520; /*< GO TO 620 >*/ #line 1954 "cl2.f" goto L620; /*< 520 GO TO 540 >*/ #line 1955 "cl2.f" L520: #line 1955 "cl2.f" goto L540; /*< 530 CALL SSWAP(NP1, W(I,1), MDW, W(I+1,1), MDW) >*/ #line 1956 "cl2.f" L530: #line 1956 "cl2.f" sswap_(&np1, &w[i__ + w_dim1], mdw, &w[i__ + 1 + w_dim1], mdw); /*< CALL SSWAP(1, SCALE(I), 1, SCALE(I+1), 1) >*/ #line 1957 "cl2.f" sswap_(&c__1, &scale[i__], &c__1, &scale[i__ + 1], &c__1); /*< ITEMP = ITYPE(I+1) >*/ #line 1958 "cl2.f" itemp = itype[i__ + 1]; /*< ITYPE(I+1) = ITYPE(I) >*/ #line 1959 "cl2.f" itype[i__ + 1] = itype[i__]; /*< ITYPE(I) = ITEMP >*/ #line 1960 "cl2.f" itype[i__] = itemp; /*< W(I+1,J) = ZERO >*/ #line 1961 "cl2.f" w[i__ + 1 + j * w_dim1] = zero; /*< 540 CONTINUE >*/ #line 1962 "cl2.f" L540: /*< 550 CONTINUE >*/ #line 1963 "cl2.f" L550: /*< 560 I = I + 1 >*/ #line 1964 "cl2.f" L560: #line 1964 "cl2.f" ++i__; /*< J = J + 1 >*/ #line 1965 "cl2.f" ++j; /*< GO TO 450 >*/ #line 1966 "cl2.f" goto L450; /* SEE IF THE REMAINING COEFFS IN THE SOLN SET ARE FEASIBLE. THEY */ /* SHOULD BE BECAUSE OF THE WAY ALPHA WAS DETERMINED. IF ANY ARE */ /* INFEASIBLE IT IS DUE TO ROUNDOFF ERROR. ANY THAT ARE NON- */ /* POSITIVE WILL BE SET TO ZERO AND REMOVED FROM THE SOLN SET. */ /*< 570 IF (.NOT.(LP1.LE.NSOLN)) GO TO 590 >*/ #line 1972 "cl2.f" L570: #line 1972 "cl2.f" if (! (lp1 <= nsoln)) { #line 1972 "cl2.f" goto L590; #line 1972 "cl2.f" } /*< DO 580 JCON=LP1,NSOLN >*/ #line 1973 "cl2.f" i__1 = nsoln; #line 1973 "cl2.f" for (jcon = lp1; jcon <= i__1; ++jcon) { /*< IF (X(JCON).LE.ZERO) GO TO 600 >*/ #line 1974 "cl2.f" if (x[jcon] <= zero) { #line 1974 "cl2.f" goto L600; #line 1974 "cl2.f" } /*< 580 CONTINUE >*/ #line 1975 "cl2.f" /* L580: */ #line 1975 "cl2.f" } /*< 590 FEASBL = .TRUE. >*/ #line 1976 "cl2.f" L590: #line 1976 "cl2.f" feasbl = TRUE_; /*< 600 CONTINUE >*/ #line 1977 "cl2.f" L600: /*< GO TO 400 >*/ #line 1978 "cl2.f" goto L400; /*< 610 GO TO 1200 >*/ #line 1979 "cl2.f" L610: #line 1979 "cl2.f" goto L1200; /*< 620 CONTINUE >*/ #line 1980 "cl2.f" L620: /* TO ZERO-IP1-TO-I-IN-COL-J */ /*< IF (.NOT.(W(I+1,J).NE.ZERO)) GO TO 630 >*/ #line 1983 "cl2.f" if (! (w[i__ + 1 + j * w_dim1] != zero)) { #line 1983 "cl2.f" goto L630; #line 1983 "cl2.f" } /*< CALL SROTMG(SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), SPARAM) >*/ #line 1984 "cl2.f" srotmg_(&scale[i__], &scale[i__ + 1], &w[i__ + j * w_dim1], &w[i__ + 1 + j * w_dim1], sparam); /*< W(I+1,J) = ZERO >*/ #line 1985 "cl2.f" w[i__ + 1 + j * w_dim1] = zero; /*< CALL SROTM(NP1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, SPARAM) >*/ #line 1986 "cl2.f" i__1 = np1 - j; #line 1986 "cl2.f" srotm_(&i__1, &w[i__ + (j + 1) * w_dim1], mdw, &w[i__ + 1 + (j + 1) * w_dim1], mdw, sparam); /*< 630 GO TO 1290 >*/ #line 1987 "cl2.f" L630: #line 1987 "cl2.f" goto L1290; /*< 640 CONTINUE >*/ #line 1988 "cl2.f" L640: /* TO PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT */ /*< CALL SCOPY(NSOLN, Z, 1, X, 1) >*/ #line 1991 "cl2.f" scopy_(&nsoln, &z__[1], &c__1, &x[1], &c__1); /*< IF (.NOT.(NSOLN.LT.N)) GO TO 650 >*/ #line 1992 "cl2.f" if (! (nsoln < *n)) { #line 1992 "cl2.f" goto L650; #line 1992 "cl2.f" } /*< X(NSP1) = ZERO >*/ #line 1993 "cl2.f" x[nsp1] = zero; /*< CALL SCOPY(N-NSOLN, X(NSP1), 0, X(NSP1), 1) >*/ #line 1994 "cl2.f" i__1 = *n - nsoln; #line 1994 "cl2.f" scopy_(&i__1, &x[nsp1], &c__0, &x[nsp1], &c__1); /*< 650 I = NIV1 >*/ #line 1995 "cl2.f" L650: #line 1995 "cl2.f" i__ = niv1; /*< 660 IF (.NOT.(I.LE.ME)) GO TO 690 >*/ #line 1996 "cl2.f" L660: #line 1996 "cl2.f" if (! (i__ <= me)) { #line 1996 "cl2.f" goto L690; #line 1996 "cl2.f" } /* RECLASSIFY LEAST SQUARES EQATIONS AS EQUALITIES AS */ /* NECESSARY. */ /*< IF (.NOT.(ITYPE(I).EQ.0)) GO TO 670 >*/ #line 2000 "cl2.f" if (! (itype[i__] == 0)) { #line 2000 "cl2.f" goto L670; #line 2000 "cl2.f" } /*< I = I + 1 >*/ #line 2001 "cl2.f" ++i__; /*< GO TO 680 >*/ #line 2002 "cl2.f" goto L680; /*< 670 CALL SSWAP(NP1, W(I,1), MDW, W(ME,1), MDW) >*/ #line 2003 "cl2.f" L670: #line 2003 "cl2.f" sswap_(&np1, &w[i__ + w_dim1], mdw, &w[me + w_dim1], mdw); /*< CALL SSWAP(1, SCALE(I), 1, SCALE(ME), 1) >*/ #line 2004 "cl2.f" sswap_(&c__1, &scale[i__], &c__1, &scale[me], &c__1); /*< ITEMP = ITYPE(I) >*/ #line 2005 "cl2.f" itemp = itype[i__]; /*< ITYPE(I) = ITYPE(ME) >*/ #line 2006 "cl2.f" itype[i__] = itype[me]; /*< ITYPE(ME) = ITEMP >*/ #line 2007 "cl2.f" itype[me] = itemp; /*< MEP1 = ME >*/ #line 2008 "cl2.f" mep1 = me; /*< ME = ME - 1 >*/ #line 2009 "cl2.f" --me; /*< 680 GO TO 660 >*/ #line 2010 "cl2.f" L680: #line 2010 "cl2.f" goto L660; /* FORM INNER PRODUCT VECTOR WD(*) OF DUAL COEFFS. */ /*< 690 IF (.NOT.(NSP1.LE.N)) GO TO 730 >*/ #line 2013 "cl2.f" L690: #line 2013 "cl2.f" if (! (nsp1 <= *n)) { #line 2013 "cl2.f" goto L730; #line 2013 "cl2.f" } /*< DO 720 J=NSP1,N >*/ #line 2014 "cl2.f" i__1 = *n; #line 2014 "cl2.f" for (j = nsp1; j <= i__1; ++j) { /*< SM = ZERO >*/ #line 2015 "cl2.f" sm = zero; /*< IF (.NOT.(NSOLN.LT.M)) GO TO 710 >*/ #line 2016 "cl2.f" if (! (nsoln < m)) { #line 2016 "cl2.f" goto L710; #line 2016 "cl2.f" } /*< DO 700 I=NSP1,M >*/ #line 2017 "cl2.f" i__2 = m; #line 2017 "cl2.f" for (i__ = nsp1; i__ <= i__2; ++i__) { /*< SM = SM + SCALE(I)*W(I,J)*W(I,NP1) >*/ #line 2018 "cl2.f" sm += scale[i__] * w[i__ + j * w_dim1] * w[i__ + np1 * w_dim1]; /*< 700 CONTINUE >*/ #line 2019 "cl2.f" /* L700: */ #line 2019 "cl2.f" } /*< 710 WD(J) = SM >*/ #line 2020 "cl2.f" L710: #line 2020 "cl2.f" wd[j] = sm; /*< 720 CONTINUE >*/ #line 2021 "cl2.f" /* L720: */ #line 2021 "cl2.f" } /*< 730 GO TO 750 >*/ #line 2022 "cl2.f" L730: #line 2022 "cl2.f" goto L750; /*< 740 IF (POS .OR. DONE) GO TO 970 >*/ #line 2023 "cl2.f" L740: #line 2023 "cl2.f" if (pos || done) { #line 2023 "cl2.f" goto L970; #line 2023 "cl2.f" } /* FIND J SUCH THAT WD(J)=WMAX IS MAXIMUM. THIS DETERMINES */ /* THAT THE INCOMING COL J WILL REDUCE THE RESIDUAL VECTOR */ /* AND BE POSITIVE. */ /*< 750 WMAX = ZERO >*/ #line 2028 "cl2.f" L750: #line 2028 "cl2.f" wmax = zero; /*< IWMAX = NSP1 >*/ #line 2029 "cl2.f" iwmax = nsp1; /*< IF (.NOT.(NSP1.LE.N)) GO TO 780 >*/ #line 2030 "cl2.f" if (! (nsp1 <= *n)) { #line 2030 "cl2.f" goto L780; #line 2030 "cl2.f" } /*< DO 770 J=NSP1,N >*/ #line 2031 "cl2.f" i__1 = *n; #line 2031 "cl2.f" for (j = nsp1; j <= i__1; ++j) { /*< IF (.NOT.(WD(J).GT.WMAX)) GO TO 760 >*/ #line 2032 "cl2.f" if (! (wd[j] > wmax)) { #line 2032 "cl2.f" goto L760; #line 2032 "cl2.f" } /*< WMAX = WD(J) >*/ #line 2033 "cl2.f" wmax = wd[j]; /*< IWMAX = J >*/ #line 2034 "cl2.f" iwmax = j; /*< 760 CONTINUE >*/ #line 2035 "cl2.f" L760: /*< 770 CONTINUE >*/ #line 2036 "cl2.f" /* L770: */ #line 2036 "cl2.f" ; #line 2036 "cl2.f" } /*< 780 IF (.NOT.(WMAX.LE.ZERO)) GO TO 790 >*/ #line 2037 "cl2.f" L780: #line 2037 "cl2.f" if (! (wmax <= zero)) { #line 2037 "cl2.f" goto L790; #line 2037 "cl2.f" } /*< DONE = .TRUE. >*/ #line 2038 "cl2.f" done = TRUE_; /*< GO TO 960 >*/ #line 2039 "cl2.f" goto L960; /* SET DUAL COEFF TO ZERO FOR INCOMING COL. */ /*< 790 WD(IWMAX) = ZERO >*/ #line 2042 "cl2.f" L790: #line 2042 "cl2.f" wd[iwmax] = zero; /* WMAX .GT. ZERO, SO OKAY TO MOVE COL IWMAX TO SOLN SET. */ /* PERFORM TRANSFORMATION TO RETRIANGULARIZE, AND TEST */ /* FOR NEAR LINEAR DEPENDENCE. */ /* SWAP COL IWMAX INTO NSOLN-TH POSITION TO MAINTAIN UPPER */ /* HESSENBERG FORM OF ADJACENT COLS, AND ADD NEW COL TO */ /* TRIANGULAR DECOMPOSITION. */ /*< NSOLN = NSP1 >*/ #line 2050 "cl2.f" nsoln = nsp1; /*< NSP1 = NSOLN + 1 >*/ #line 2051 "cl2.f" nsp1 = nsoln + 1; /*< NIV = NIV1 >*/ #line 2052 "cl2.f" niv = niv1; /*< NIV1 = NIV + 1 >*/ #line 2053 "cl2.f" niv1 = niv + 1; /*< IF (.NOT.(NSOLN.NE.IWMAX)) GO TO 800 >*/ #line 2054 "cl2.f" if (! (nsoln != iwmax)) { #line 2054 "cl2.f" goto L800; #line 2054 "cl2.f" } /*< CALL SSWAP(M, W(1,NSOLN), 1, W(1,IWMAX), 1) >*/ #line 2055 "cl2.f" sswap_(&m, &w[nsoln * w_dim1 + 1], &c__1, &w[iwmax * w_dim1 + 1], &c__1); /*< WD(IWMAX) = WD(NSOLN) >*/ #line 2056 "cl2.f" wd[iwmax] = wd[nsoln]; /*< WD(NSOLN) = ZERO >*/ #line 2057 "cl2.f" wd[nsoln] = zero; /*< ITEMP = IPIVOT(NSOLN) >*/ #line 2058 "cl2.f" itemp = ipivot[nsoln]; /*< IPIVOT(NSOLN) = IPIVOT(IWMAX) >*/ #line 2059 "cl2.f" ipivot[nsoln] = ipivot[iwmax]; /*< IPIVOT(IWMAX) = ITEMP >*/ #line 2060 "cl2.f" ipivot[iwmax] = itemp; /* REDUCE COL NSOLN SO THAT THE MATRIX OF NONACTIVE */ /* CONSTRAINTS VARIABLES IS TRIANGULAR. */ /*< 800 J = M >*/ #line 2064 "cl2.f" L800: #line 2064 "cl2.f" j = m; /*< 810 IF (.NOT.(J.GT.NIV)) GO TO 870 >*/ #line 2065 "cl2.f" L810: #line 2065 "cl2.f" if (! (j > niv)) { #line 2065 "cl2.f" goto L870; #line 2065 "cl2.f" } /*< JM1 = J - 1 >*/ #line 2066 "cl2.f" jm1 = j - 1; /*< JP = JM1 >*/ #line 2067 "cl2.f" jp = jm1; /* WHEN OPERATING NEAR THE ME LINE, TEST TO SEE IF THE PIVOT ELT. */ /* IS NEAR ZERO. IF SO, USE THE LARGEST ELT. ABOVE IT AS THE PIVOT. */ /* THIS IS TO MAINTAIN THE SHARP INTERFACE BETWEEN WEIGHTED AND */ /* NON-WEIGHTED ROWS IN ALL CASES. */ /*< IF (.NOT.(J.EQ.MEP1)) GO TO 850 >*/ #line 2073 "cl2.f" if (! (j == mep1)) { #line 2073 "cl2.f" goto L850; #line 2073 "cl2.f" } /*< IMAX = ME >*/ #line 2074 "cl2.f" imax = me; /*< AMAX = SCALE(ME)*W(ME,NSOLN)**2 >*/ /* Computing 2nd power */ #line 2075 "cl2.f" r__1 = w[me + nsoln * w_dim1]; #line 2075 "cl2.f" amax = scale[me] * (r__1 * r__1); /*< 820 IF (.NOT.(JP.GE.NIV)) GO TO 840 >*/ #line 2076 "cl2.f" L820: #line 2076 "cl2.f" if (! (jp >= niv)) { #line 2076 "cl2.f" goto L840; #line 2076 "cl2.f" } /*< T = SCALE(JP)*W(JP,NSOLN)**2 >*/ /* Computing 2nd power */ #line 2077 "cl2.f" r__1 = w[jp + nsoln * w_dim1]; #line 2077 "cl2.f" t = scale[jp] * (r__1 * r__1); /*< IF (.NOT.(T.GT.AMAX)) GO TO 830 >*/ #line 2078 "cl2.f" if (! (t > amax)) { #line 2078 "cl2.f" goto L830; #line 2078 "cl2.f" } /*< IMAX = JP >*/ #line 2079 "cl2.f" imax = jp; /*< AMAX = T >*/ #line 2080 "cl2.f" amax = t; /*< 830 JP = JP - 1 >*/ #line 2081 "cl2.f" L830: #line 2081 "cl2.f" --jp; /*< GO TO 820 >*/ #line 2082 "cl2.f" goto L820; /*< 840 JP = IMAX >*/ #line 2083 "cl2.f" L840: #line 2083 "cl2.f" jp = imax; /*< 850 IF (.NOT.(W(J,NSOLN).NE.ZERO)) GO TO 860 >*/ #line 2084 "cl2.f" L850: #line 2084 "cl2.f" if (! (w[j + nsoln * w_dim1] != zero)) { #line 2084 "cl2.f" goto L860; #line 2084 "cl2.f" } /*< CALL SROTMG(SCALE(JP), SCALE(J), W(JP,NSOLN), W(J,NSOLN), SPARAM) >*/ #line 2085 "cl2.f" srotmg_(&scale[jp], &scale[j], &w[jp + nsoln * w_dim1], &w[j + nsoln * w_dim1], sparam); /*< W(J,NSOLN) = ZERO >*/ #line 2086 "cl2.f" w[j + nsoln * w_dim1] = zero; /*< CALL SROTM(NP1-NSOLN, W(JP,NSP1), MDW, W(J,NSP1), MDW, SPARAM) >*/ #line 2087 "cl2.f" i__1 = np1 - nsoln; #line 2087 "cl2.f" srotm_(&i__1, &w[jp + nsp1 * w_dim1], mdw, &w[j + nsp1 * w_dim1], mdw, sparam); /*< 860 J = JM1 >*/ #line 2088 "cl2.f" L860: #line 2088 "cl2.f" j = jm1; /*< GO TO 810 >*/ #line 2089 "cl2.f" goto L810; /* SOLVE FOR Z(NSOLN)=PROPOSED NEW VALUE FOR X(NSOLN). */ /* TEST IF THIS IS NONPOSITIVE OR TOO LARGE. */ /* IF THIS WAS TRUE OR IF THE PIVOT TERM WAS ZERO REJECT */ /* THE COL AS DEPENDENT. */ /*< 870 IF (.NOT.(W(NIV,NSOLN).NE.ZERO)) GO TO 890 >*/ #line 2095 "cl2.f" L870: #line 2095 "cl2.f" if (! (w[niv + nsoln * w_dim1] != zero)) { #line 2095 "cl2.f" goto L890; #line 2095 "cl2.f" } /*< ISOL = NIV >*/ #line 2096 "cl2.f" isol = niv; /*< ASSIGN 880 TO IGO897 >*/ #line 2097 "cl2.f" igo897 = 0; #line 2097 "cl2.f" igo897_fmt = fmt_880; /*< GO TO 980 >*/ #line 2098 "cl2.f" goto L980; /* TEST-PROPOSED-NEW-COMPONENT */ /*< 880 GO TO 940 >*/ #line 2101 "cl2.f" L880: #line 2101 "cl2.f" goto L940; /*< 890 IF (.NOT.(NIV.LE.ME .AND. W(MEP1,NSOLN).NE.ZERO)) GO TO 920 >*/ #line 2102 "cl2.f" L890: #line 2102 "cl2.f" if (! (niv <= me && w[mep1 + nsoln * w_dim1] != zero)) { #line 2102 "cl2.f" goto L920; #line 2102 "cl2.f" } /* TRY TO ADD ROW MEP1 AS AN ADDITIONAL EQUALITY CONSTRAINT. */ /* CHECK SIZE OF PROPOSED NEW SOLN COMPONENT. */ /* REJECT IT IF IT IS TOO LARGE. */ /*< ISOL = MEP1 >*/ #line 2107 "cl2.f" isol = mep1; /*< ASSIGN 900 TO IGO897 >*/ #line 2108 "cl2.f" igo897 = 1; #line 2108 "cl2.f" igo897_fmt = fmt_900; /*< GO TO 980 >*/ #line 2109 "cl2.f" goto L980; /* TEST-PROPOSED-NEW-COMPONENT */ /*< 900 IF (.NOT.(POS)) GO TO 910 >*/ #line 2112 "cl2.f" L900: #line 2112 "cl2.f" if (! pos) { #line 2112 "cl2.f" goto L910; #line 2112 "cl2.f" } /* SWAP ROWS MEP1 AND NIV, AND SCALE FACTORS FOR THESE ROWS. */ /*< CALL SSWAP(NP1, W(MEP1,1), MDW, W(NIV,1), MDW) >*/ #line 2115 "cl2.f" sswap_(&np1, &w[mep1 + w_dim1], mdw, &w[niv + w_dim1], mdw); /*< CALL SSWAP(1, SCALE(MEP1), 1, SCALE(NIV), 1) >*/ #line 2116 "cl2.f" sswap_(&c__1, &scale[mep1], &c__1, &scale[niv], &c__1); /*< ITEMP = ITYPE(MEP1) >*/ #line 2117 "cl2.f" itemp = itype[mep1]; /*< ITYPE(MEP1) = ITYPE(NIV) >*/ #line 2118 "cl2.f" itype[mep1] = itype[niv]; /*< ITYPE(NIV) = ITEMP >*/ #line 2119 "cl2.f" itype[niv] = itemp; /*< ME = MEP1 >*/ #line 2120 "cl2.f" me = mep1; /*< MEP1 = ME + 1 >*/ #line 2121 "cl2.f" mep1 = me + 1; /*< 910 GO TO 930 >*/ #line 2122 "cl2.f" L910: #line 2122 "cl2.f" goto L930; /*< 920 POS = .FALSE. >*/ #line 2123 "cl2.f" L920: #line 2123 "cl2.f" pos = FALSE_; /*< 930 CONTINUE >*/ #line 2124 "cl2.f" L930: /*< 940 IF (POS) GO TO 950 >*/ #line 2125 "cl2.f" L940: #line 2125 "cl2.f" if (pos) { #line 2125 "cl2.f" goto L950; #line 2125 "cl2.f" } /*< NSP1 = NSOLN >*/ #line 2126 "cl2.f" nsp1 = nsoln; /*< NSOLN = NSOLN - 1 >*/ #line 2127 "cl2.f" --nsoln; /*< NIV1 = NIV >*/ #line 2128 "cl2.f" niv1 = niv; /*< NIV = NIV - 1 >*/ #line 2129 "cl2.f" --niv; /*< 950 CONTINUE >*/ #line 2130 "cl2.f" L950: /*< 960 GO TO 740 >*/ #line 2131 "cl2.f" L960: #line 2131 "cl2.f" goto L740; /*< 970 GO TO 1250 >*/ #line 2132 "cl2.f" L970: #line 2132 "cl2.f" goto L1250; /*< 980 CONTINUE >*/ #line 2133 "cl2.f" L980: /* TO TEST-PROPOSED-NEW-COMPONENT */ /*< Z2 = W(ISOL,NP1)/W(ISOL,NSOLN) >*/ #line 2136 "cl2.f" z2 = w[isol + np1 * w_dim1] / w[isol + nsoln * w_dim1]; /*< Z(NSOLN) = Z2 >*/ #line 2137 "cl2.f" z__[nsoln] = z2; /*< POS = Z2.GT.ZERO >*/ #line 2138 "cl2.f" pos = z2 > zero; /*< IF (.NOT.(Z2*EANORM.GE.BNORM .AND. POS)) GO TO 990 >*/ #line 2139 "cl2.f" if (! (z2 * eanorm >= bnorm && pos)) { #line 2139 "cl2.f" goto L990; #line 2139 "cl2.f" } /*< POS = .NOT.(BLOWUP*Z2*EANORM.GE.BNORM) >*/ #line 2140 "cl2.f" pos = ! (blowup * z2 * eanorm >= bnorm); /*< 990 GO TO 1280 >*/ #line 2141 "cl2.f" L990: #line 2141 "cl2.f" goto L1280; /*< 1000 CONTINUE >*/ #line 2142 "cl2.f" L1000: /* TO COMPUTE-FINAL-SOLUTION */ /* SOLVE SYSTEM, STORE RESULTS IN X(*). */ /*< ASSIGN 1010 TO IGO958 >*/ #line 2147 "cl2.f" igo958 = 1; #line 2147 "cl2.f" igo958_fmt = fmt_1010; /*< GO TO 1110 >*/ #line 2148 "cl2.f" goto L1110; /* SOLVE-SYSTEM */ /*< 1010 CALL SCOPY(NSOLN, Z, 1, X, 1) >*/ #line 2150 "cl2.f" L1010: #line 2150 "cl2.f" scopy_(&nsoln, &z__[1], &c__1, &x[1], &c__1); /* APPLY HOUSEHOLDER TRANSFORMATIONS TO X(*) IF KRANK.LT.L */ /*< IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.L)) GO TO 1030 >*/ #line 2153 "cl2.f" if (! (0 < krank && krank < *l)) { #line 2153 "cl2.f" goto L1030; #line 2153 "cl2.f" } /*< DO 1020 I=1,KRANK >*/ #line 2154 "cl2.f" i__1 = krank; #line 2154 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< CALL H12(2, I, KRP1, L, W(I,1), MDW, H(I), X, 1, 1, 1) >*/ #line 2155 "cl2.f" h12_(&c__2, &i__, &krp1, l, &w[i__ + w_dim1], mdw, &h__[i__], &x[1], & c__1, &c__1, &c__1); /*< 1020 CONTINUE >*/ #line 2156 "cl2.f" /* L1020: */ #line 2156 "cl2.f" } /* FILL IN TRAILING ZEROES FOR CONSTRAINED VARIABLES NOT IN SOLN. */ /*< 1030 IF (.NOT.(NSOLN.LT.N)) GO TO 1040 >*/ #line 2159 "cl2.f" L1030: #line 2159 "cl2.f" if (! (nsoln < *n)) { #line 2159 "cl2.f" goto L1040; #line 2159 "cl2.f" } /*< X(NSP1) = ZERO >*/ #line 2160 "cl2.f" x[nsp1] = zero; /*< CALL SCOPY(N-NSOLN, X(NSP1), 0, X(NSP1), 1) >*/ #line 2161 "cl2.f" i__1 = *n - nsoln; #line 2161 "cl2.f" scopy_(&i__1, &x[nsp1], &c__0, &x[nsp1], &c__1); /* REPERMUTE SOLN VECTOR TO NATURAL ORDER. */ /*< 1040 DO 1070 I=1,N >*/ #line 2164 "cl2.f" L1040: #line 2164 "cl2.f" i__1 = *n; #line 2164 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< J = I >*/ #line 2165 "cl2.f" j = i__; /*< 1050 IF (IPIVOT(J).EQ.I) GO TO 1060 >*/ #line 2166 "cl2.f" L1050: #line 2166 "cl2.f" if (ipivot[j] == i__) { #line 2166 "cl2.f" goto L1060; #line 2166 "cl2.f" } /*< J = J + 1 >*/ #line 2167 "cl2.f" ++j; /*< GO TO 1050 >*/ #line 2168 "cl2.f" goto L1050; /*< 1060 IPIVOT(J) = IPIVOT(I) >*/ #line 2169 "cl2.f" L1060: #line 2169 "cl2.f" ipivot[j] = ipivot[i__]; /*< IPIVOT(I) = J >*/ #line 2170 "cl2.f" ipivot[i__] = j; /*< CALL SSWAP(1, X(J), 1, X(I), 1) >*/ #line 2171 "cl2.f" sswap_(&c__1, &x[j], &c__1, &x[i__], &c__1); /*< 1070 CONTINUE >*/ #line 2172 "cl2.f" /* L1070: */ #line 2172 "cl2.f" } /* RESCALE THE SOLN USING THE COL SCALING. */ /*< DO 1080 J=1,N >*/ #line 2175 "cl2.f" i__1 = *n; #line 2175 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< X(J) = X(J)*D(J) >*/ #line 2176 "cl2.f" x[j] *= d__[j]; /*< 1080 CONTINUE >*/ #line 2177 "cl2.f" /* L1080: */ #line 2177 "cl2.f" } /* IF (.NOT.(NSOLN.LT.M)) GO TO 1100 REMK */ /* DO 1090 I=NSP1,M REMK */ /*< IF (.NOT.(NIV.LT.M)) GO TO 1100 >*/ #line 2180 "cl2.f" if (! (niv < m)) { #line 2180 "cl2.f" goto L1100; #line 2180 "cl2.f" } /*< DO 1090 I = NIV1,M >*/ #line 2181 "cl2.f" i__1 = m; #line 2181 "cl2.f" for (i__ = niv1; i__ <= i__1; ++i__) { /*< T = W(I,NP1) >*/ #line 2182 "cl2.f" t = w[i__ + np1 * w_dim1]; /*< IF (I.LE.ME) T = T/ALAMDA >*/ #line 2183 "cl2.f" if (i__ <= me) { #line 2183 "cl2.f" t /= alamda; #line 2183 "cl2.f" } /*< T = (SCALE(I)*T)*T >*/ #line 2184 "cl2.f" t = scale[i__] * t * t; /*< RNORM = RNORM + T >*/ #line 2185 "cl2.f" *rnorm += t; /*< 1090 CONTINUE >*/ #line 2186 "cl2.f" /* L1090: */ #line 2186 "cl2.f" } /*< 1100 RNORM = SQRT(RNORM) >*/ #line 2187 "cl2.f" L1100: #line 2187 "cl2.f" *rnorm = sqrt(*rnorm); /*< GO TO 1210 >*/ #line 2188 "cl2.f" goto L1210; /* TO SOLVE-SYSTEM */ /*< 1110 CONTINUE >*/ #line 2192 "cl2.f" L1110: /*< IF (.NOT.(DONE)) GO TO 1120 >*/ #line 2193 "cl2.f" if (! done) { #line 2193 "cl2.f" goto L1120; #line 2193 "cl2.f" } /*< ISOL = 1 >*/ #line 2194 "cl2.f" isol = 1; /*< GO TO 1130 >*/ #line 2195 "cl2.f" goto L1130; /*< 1120 ISOL = LP1 >*/ #line 2196 "cl2.f" L1120: #line 2196 "cl2.f" isol = lp1; /*< 1130 IF (.NOT.(NSOLN.GE.ISOL)) GO TO 1190 >*/ #line 2197 "cl2.f" L1130: #line 2197 "cl2.f" if (! (nsoln >= isol)) { #line 2197 "cl2.f" goto L1190; #line 2197 "cl2.f" } /* COPY RT. HAND SIDE INTO TEMP VECTOR TO USE OVERWRITING METHOD. */ /*< CALL SCOPY(NIV, W(1,NP1), 1, TEMP, 1) >*/ #line 2200 "cl2.f" scopy_(&niv, &w[np1 * w_dim1 + 1], &c__1, &temp[1], &c__1); /*< DO 1180 JJ=ISOL,NSOLN >*/ #line 2201 "cl2.f" i__1 = nsoln; #line 2201 "cl2.f" for (jj = isol; jj <= i__1; ++jj) { /*< J = NSOLN - JJ + ISOL >*/ #line 2202 "cl2.f" j = nsoln - jj + isol; /*< IF (.NOT.(J.GT.KRANK)) GO TO 1140 >*/ #line 2203 "cl2.f" if (! (j > krank)) { #line 2203 "cl2.f" goto L1140; #line 2203 "cl2.f" } /*< I = NIV - JJ + ISOL >*/ #line 2204 "cl2.f" i__ = niv - jj + isol; /*< GO TO 1150 >*/ #line 2205 "cl2.f" goto L1150; /*< 1140 I = J >*/ #line 2206 "cl2.f" L1140: #line 2206 "cl2.f" i__ = j; /*< 1150 IF (.NOT.(J.GT.KRANK .AND. J.LE.L)) GO TO 1160 >*/ #line 2207 "cl2.f" L1150: #line 2207 "cl2.f" if (! (j > krank && j <= *l)) { #line 2207 "cl2.f" goto L1160; #line 2207 "cl2.f" } /*< Z(J) = ZERO >*/ #line 2208 "cl2.f" z__[j] = zero; /*< GO TO 1170 >*/ #line 2209 "cl2.f" goto L1170; /*< 1160 Z(J) = TEMP(I)/W(I,J) >*/ #line 2210 "cl2.f" L1160: #line 2210 "cl2.f" z__[j] = temp[i__] / w[i__ + j * w_dim1]; /*< CALL SAXPY(I-1, -Z(J), W(1,J), 1, TEMP, 1) >*/ #line 2211 "cl2.f" i__2 = i__ - 1; #line 2211 "cl2.f" r__1 = -z__[j]; #line 2211 "cl2.f" saxpy_(&i__2, &r__1, &w[j * w_dim1 + 1], &c__1, &temp[1], &c__1); /*< 1170 CONTINUE >*/ #line 2212 "cl2.f" L1170: /*< 1180 CONTINUE >*/ #line 2213 "cl2.f" /* L1180: */ #line 2213 "cl2.f" ; #line 2213 "cl2.f" } /*< 1190 GO TO 1270 >*/ #line 2214 "cl2.f" L1190: #line 2214 "cl2.f" goto L1270; /*< 1200 GO TO IGO986, (40) >*/ #line 2215 "cl2.f" L1200: #line 2215 "cl2.f" switch (igo986) { #line 2215 "cl2.f" case 0: goto L40; #line 2215 "cl2.f" } /*< 1210 GO TO IGO980, (90) >*/ #line 2216 "cl2.f" L1210: #line 2216 "cl2.f" switch (igo980) { #line 2216 "cl2.f" case 0: goto L90; #line 2216 "cl2.f" } /*< 1220 GO TO IGO991, (30) >*/ #line 2217 "cl2.f" L1220: #line 2217 "cl2.f" switch (igo991) { #line 2217 "cl2.f" case 0: goto L30; #line 2217 "cl2.f" } /*< 1230 GO TO IGO998, (10) >*/ #line 2218 "cl2.f" L1230: #line 2218 "cl2.f" switch (igo998) { #line 2218 "cl2.f" case 0: goto L10; #line 2218 "cl2.f" } /*< 1240 GO TO IGO995, (20) >*/ #line 2219 "cl2.f" L1240: #line 2219 "cl2.f" switch (igo995) { #line 2219 "cl2.f" case 0: goto L20; #line 2219 "cl2.f" } /*< 1250 GO TO IGO983, (60) >*/ #line 2220 "cl2.f" L1250: #line 2220 "cl2.f" switch (igo983) { #line 2220 "cl2.f" case 0: goto L60; #line 2220 "cl2.f" } /*< 1260 GO TO IGO977, (220) >*/ #line 2221 "cl2.f" L1260: #line 2221 "cl2.f" switch (igo977) { #line 2221 "cl2.f" case 0: goto L220; #line 2221 "cl2.f" } /*< 1270 GO TO IGO958, (310, 1010) >*/ #line 2222 "cl2.f" L1270: #line 2222 "cl2.f" switch (igo958) { #line 2222 "cl2.f" case 0: goto L310; #line 2222 "cl2.f" case 1: goto L1010; #line 2222 "cl2.f" } /*< 1280 GO TO IGO897, (880, 900) >*/ #line 2223 "cl2.f" L1280: #line 2223 "cl2.f" switch (igo897) { #line 2223 "cl2.f" case 0: goto L880; #line 2223 "cl2.f" case 1: goto L900; #line 2223 "cl2.f" } /*< 1290 GO TO IGO938, (460, 480, 500, 520) >*/ #line 2224 "cl2.f" L1290: #line 2224 "cl2.f" switch (igo938) { #line 2224 "cl2.f" case 0: goto L460; #line 2224 "cl2.f" case 1: goto L480; #line 2224 "cl2.f" case 2: goto L500; #line 2224 "cl2.f" case 3: goto L520; #line 2224 "cl2.f" } /*< END >*/ } /* wnlsm_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< >*/ static /* Subroutine */ int wnlit_(real *w, integer *mdw, integer *m, integer *n, integer *l, integer *ipivot, integer *itype, real *h__, real *scale, real *rnorm, integer *idope, real *dope, logical *done) { /* Initialized data */ static real tenm3 = .001f; static real zero = 0.f; static real one = 1.f; /* Format strings */ static char fmt_20[] = ""; static char fmt_30[] = ""; static char fmt_40[] = ""; static char fmt_120[] = ""; static char fmt_190[] = ""; static char fmt_200[] = ""; static char fmt_240[] = ""; static char fmt_320[] = ""; static char fmt_330[] = ""; /* System generated locals */ integer w_dim1, w_offset, i__1, i__2; real r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, k; static real t; static integer i1, j1, l1; static integer ic, lb, me, jj, kk, jp, ir; static real rn, sn; static integer jm1, ip1, lp1, np1, max__; static real tau; static integer niv, mep1, irp1, krp1, niv1; static real hbar; static integer lend, mend; static real alsq; static integer igo990, igo993, igo996; static logical indep; static integer krank, itemp, nsoln; static logical recalc; static real factor, eanorm; static real sparam[5]; /* Assigned format variables */ static char *igo996_fmt, *igo993_fmt, *igo990_fmt; /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (BEGIN CHANGES AT LINE WITH C++ IN COLS. 1-3.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/,/SROTM/DROTM/, */ /* /SSCAL/DSCAL/,/SQRT/DSQRT/, REMK */ /* /SSWAP/DSWAP/,/AMAX1/DMAX1/,/ISAMAX/IDAMAX/,/.E-/.D-/,/E0/D0/ */ /* THIS IS A COMPANION SUBPROGRAM TO WNNLS( ). */ /* THE DOCUMENTATION FOR WNNLS( ) HAS MORE COMPLETE */ /* USAGE INSTRUCTIONS. */ /* NOTE THE M BY (N+1) MATRIX W( , ) CONTAINS THE RT. HAND SIDE */ /* B AS THE (N+1)ST COL. */ /* TRIANGULARIZE L1 BY L1 SUBSYSTEM, WHERE L1=MIN(M,L), WITH */ /* COL INTERCHANGES. */ /* REVISED MARCH 4, 1982 */ /* ++ */ /*< REAL W(MDW,1), H(1), SCALE(1), DOPE(4), SPARAM(5) >*/ /* REAL ALSQ, AMAX, EANORM, FAC, FACTOR, HBAR, ONE, RN */ /*< REAL ALSQ, EANORM, FACTOR, HBAR, ONE, RN >*/ /*< REAL RNORM, SN, T, TAU, TENM3, ZERO >*/ /*< REAL AMAX1 >*/ /*< INTEGER ITYPE(1), IPIVOT(1), IDOPE(8) >*/ /*< INTEGER ISAMAX >*/ /*< LOGICAL INDEP, DONE, RECALC >*/ /*< DATA TENM3 /1.E-3/, ZERO /0.E0/, ONE /1.E0/ >*/ #line 2261 "cl2.f" /* Parameter adjustments */ #line 2261 "cl2.f" w_dim1 = *mdw; #line 2261 "cl2.f" w_offset = 1 + w_dim1; #line 2261 "cl2.f" w -= w_offset; #line 2261 "cl2.f" --ipivot; #line 2261 "cl2.f" --itype; #line 2261 "cl2.f" --h__; #line 2261 "cl2.f" --scale; #line 2261 "cl2.f" --idope; #line 2261 "cl2.f" --dope; #line 2261 "cl2.f" #line 2261 "cl2.f" /* Function Body */ /*< ME = IDOPE(1) >*/ #line 2263 "cl2.f" me = idope[1]; /*< MEP1 = IDOPE(2) >*/ #line 2264 "cl2.f" mep1 = idope[2]; /*< KRANK = IDOPE(3) >*/ #line 2265 "cl2.f" krank = idope[3]; /*< KRP1 = IDOPE(4) >*/ #line 2266 "cl2.f" krp1 = idope[4]; /*< NSOLN = IDOPE(5) >*/ #line 2267 "cl2.f" nsoln = idope[5]; /*< NIV = IDOPE(6) >*/ #line 2268 "cl2.f" niv = idope[6]; /*< NIV1 = IDOPE(7) >*/ #line 2269 "cl2.f" niv1 = idope[7]; /*< L1 = IDOPE(8) >*/ #line 2270 "cl2.f" l1 = idope[8]; /*< ALSQ = DOPE(1) >*/ #line 2272 "cl2.f" alsq = dope[1]; /*< EANORM = DOPE(2) >*/ #line 2273 "cl2.f" eanorm = dope[2]; /* FAC = DOPE(3) REMK */ /*< TAU = DOPE(4) >*/ #line 2275 "cl2.f" tau = dope[4]; /*< NP1 = N + 1 >*/ #line 2276 "cl2.f" np1 = *n + 1; /*< LB = MIN0(M-1,L) >*/ /* Computing MIN */ #line 2277 "cl2.f" i__1 = *m - 1; #line 2277 "cl2.f" lb = min(i__1,*l); /*< RECALC = .TRUE. >*/ #line 2278 "cl2.f" recalc = TRUE_; /*< RNORM = ZERO >*/ #line 2279 "cl2.f" *rnorm = zero; /*< KRANK = 0 >*/ #line 2280 "cl2.f" krank = 0; /* WE SET FACTOR=1.E0 SO THAT THE HEAVY WEIGHT ALAMDA WILL BE */ /* INCLUDED IN THE TEST FOR COL INDEPENDENCE. */ /*< FACTOR = 1.E0 >*/ #line 2283 "cl2.f" factor = 1.f; /*< I = 1 >*/ #line 2284 "cl2.f" i__ = 1; /*< IP1 = 2 >*/ #line 2285 "cl2.f" ip1 = 2; /*< LEND = L >*/ #line 2286 "cl2.f" lend = *l; /*< 10 IF (.NOT.(I.LE.LB)) GO TO 150 >*/ #line 2287 "cl2.f" L10: #line 2287 "cl2.f" if (! (i__ <= lb)) { #line 2287 "cl2.f" goto L150; #line 2287 "cl2.f" } /*< IF (.NOT.(I.LE.ME)) GO TO 130 >*/ #line 2288 "cl2.f" if (! (i__ <= me)) { #line 2288 "cl2.f" goto L130; #line 2288 "cl2.f" } /* SET IR TO POINT TO THE I-TH ROW. */ /*< IR = I >*/ #line 2291 "cl2.f" ir = i__; /*< MEND = M >*/ #line 2292 "cl2.f" mend = *m; /*< ASSIGN 20 TO IGO996 >*/ #line 2293 "cl2.f" igo996 = 0; #line 2293 "cl2.f" igo996_fmt = fmt_20; /*< GO TO 460 >*/ #line 2294 "cl2.f" goto L460; /* UPDATE-COL-SS-AND-FIND-PIVOT-COL */ /*< 20 ASSIGN 30 TO IGO993 >*/ #line 2297 "cl2.f" L20: #line 2297 "cl2.f" igo993 = 0; #line 2297 "cl2.f" igo993_fmt = fmt_30; /*< GO TO 560 >*/ #line 2298 "cl2.f" goto L560; /* PERFORM-COL-INTERCHANGE */ /* SET IC TO POINT TO I-TH COL. */ /*< 30 IC = I >*/ #line 2303 "cl2.f" L30: #line 2303 "cl2.f" ic = i__; /*< ASSIGN 40 TO IGO990 >*/ #line 2304 "cl2.f" igo990 = 0; #line 2304 "cl2.f" igo990_fmt = fmt_40; /*< GO TO 520 >*/ #line 2305 "cl2.f" goto L520; /* TEST-INDEP-OF-INCOMING-COL */ /*< 40 IF (.NOT.(INDEP)) GO TO 110 >*/ #line 2308 "cl2.f" L40: #line 2308 "cl2.f" if (! indep) { #line 2308 "cl2.f" goto L110; #line 2308 "cl2.f" } /* ELIMINATE I-TH COL BELOW DIAG. USING MOD. GIVENS TRANSFORMATIONS */ /* APPLIED TO (A B). */ /*< J = M >*/ #line 2312 "cl2.f" j = *m; /*< DO 100 JJ=IP1,M >*/ #line 2313 "cl2.f" i__1 = *m; #line 2313 "cl2.f" for (jj = ip1; jj <= i__1; ++jj) { /*< JM1 = J - 1 >*/ #line 2314 "cl2.f" jm1 = j - 1; /*< JP = JM1 >*/ #line 2315 "cl2.f" jp = jm1; /* WHEN OPERATING NEAR THE ME LINE, USE THE LARGEST ELT. REMK */ /* ABOVE IT AS THE PIVOT. REMK */ /* IF (.NOT.(J.EQ.MEP1)) GO TO 80 REMK */ /* IMAX = ME REMK */ /* AMAX = SCALE(ME)*W(ME,I)**2 REMK */ /* 50 IF (.NOT.(JP.GE.I)) GO TO 70 REMK */ /* T = SCALE(JP)*W(JP,I)**2 REMK */ /* IF (.NOT.(T.GT.AMAX)) GO TO 60 REMK */ /* IMAX = JP REMK */ /* AMAX = T REMK */ /* 60 JP = JP - 1 REMK */ /* GO TO 50 REMK */ /* 70 JP = IMAX REMK */ /*< IF (.NOT. (JJ.EQ.M)) GO TO 70 >*/ #line 2329 "cl2.f" if (! (jj == *m)) { #line 2329 "cl2.f" goto L70; #line 2329 "cl2.f" } /*< IF (.NOT. (I.LT.MEP1)) GO TO 80 >*/ #line 2330 "cl2.f" if (! (i__ < mep1)) { #line 2330 "cl2.f" goto L80; #line 2330 "cl2.f" } /*< J = MEP1 >*/ #line 2331 "cl2.f" j = mep1; /*< JP = I >*/ #line 2332 "cl2.f" jp = i__; /*< T = SCALE(JP)*W(JP,I)**2*TAU**2 >*/ /* Computing 2nd power */ #line 2333 "cl2.f" r__1 = w[jp + i__ * w_dim1]; /* Computing 2nd power */ #line 2333 "cl2.f" r__2 = tau; #line 2333 "cl2.f" t = scale[jp] * (r__1 * r__1) * (r__2 * r__2); /*< IF (.NOT.(T.GT.SCALE(J)*W(J,I)**2)) GO TO 130 >*/ /* Computing 2nd power */ #line 2334 "cl2.f" r__1 = w[j + i__ * w_dim1]; #line 2334 "cl2.f" if (! (t > scale[j] * (r__1 * r__1))) { #line 2334 "cl2.f" goto L130; #line 2334 "cl2.f" } /*< GO TO 80 >*/ #line 2335 "cl2.f" goto L80; /*< 70 IF (.NOT.(J.EQ.MEP1)) GO TO 80 >*/ #line 2336 "cl2.f" L70: #line 2336 "cl2.f" if (! (j == mep1)) { #line 2336 "cl2.f" goto L80; #line 2336 "cl2.f" } /*< J = JM1 >*/ #line 2337 "cl2.f" j = jm1; /*< JM1 = J - 1 >*/ #line 2338 "cl2.f" jm1 = j - 1; /*< JP = JM1 >*/ #line 2339 "cl2.f" jp = jm1; /*< 80 IF (.NOT.(W(J,I).NE.ZERO)) GO TO 90 >*/ #line 2340 "cl2.f" L80: #line 2340 "cl2.f" if (! (w[j + i__ * w_dim1] != zero)) { #line 2340 "cl2.f" goto L90; #line 2340 "cl2.f" } /*< CALL SROTMG(SCALE(JP), SCALE(J), W(JP,I), W(J,I), SPARAM) >*/ #line 2341 "cl2.f" srotmg_(&scale[jp], &scale[j], &w[jp + i__ * w_dim1], &w[j + i__ * w_dim1], sparam); /*< W(J,I) = ZERO >*/ #line 2342 "cl2.f" w[j + i__ * w_dim1] = zero; /*< CALL SROTM(NP1-I, W(JP,IP1), MDW, W(J,IP1), MDW, SPARAM) >*/ #line 2343 "cl2.f" i__2 = np1 - i__; #line 2343 "cl2.f" srotm_(&i__2, &w[jp + ip1 * w_dim1], mdw, &w[j + ip1 * w_dim1], mdw, sparam); /*< 90 J = JM1 >*/ #line 2344 "cl2.f" L90: #line 2344 "cl2.f" j = jm1; /*< 100 CONTINUE >*/ #line 2345 "cl2.f" /* L100: */ #line 2345 "cl2.f" } /*< GO TO 140 >*/ #line 2346 "cl2.f" goto L140; /*< 110 CONTINUE >*/ #line 2347 "cl2.f" L110: /*< IF (.NOT.(LEND.GT.I)) GO TO 130 >*/ #line 2348 "cl2.f" if (! (lend > i__)) { #line 2348 "cl2.f" goto L130; #line 2348 "cl2.f" } /* COL I IS DEPENDENT. SWAP WITH COL LEND. */ /*< MAX = LEND >*/ #line 2351 "cl2.f" max__ = lend; /* PERFORM-COL-INTERCHANGE */ /*< ASSIGN 120 TO IGO993 >*/ #line 2354 "cl2.f" igo993 = 1; #line 2354 "cl2.f" igo993_fmt = fmt_120; /*< GO TO 560 >*/ #line 2355 "cl2.f" goto L560; /*< 120 CONTINUE >*/ #line 2356 "cl2.f" L120: /*< LEND = LEND - 1 >*/ #line 2357 "cl2.f" --lend; /* FIND COL IN REMAINING SET WITH LARGEST SS. */ /*< MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1 >*/ #line 2360 "cl2.f" i__1 = lend - i__ + 1; #line 2360 "cl2.f" max__ = isamax_(&i__1, &h__[i__], &c__1) + i__ - 1; /*< HBAR = H(MAX) >*/ #line 2361 "cl2.f" hbar = h__[max__]; /*< GO TO 30 >*/ #line 2362 "cl2.f" goto L30; /*< 130 CONTINUE >*/ #line 2363 "cl2.f" L130: /*< KRANK = I - 1 >*/ #line 2364 "cl2.f" krank = i__ - 1; /*< GO TO 160 >*/ #line 2365 "cl2.f" goto L160; /*< 140 I = IP1 >*/ #line 2366 "cl2.f" L140: #line 2366 "cl2.f" i__ = ip1; /*< IP1 = IP1 + 1 >*/ #line 2367 "cl2.f" ++ip1; /*< GO TO 10 >*/ #line 2368 "cl2.f" goto L10; /*< 150 KRANK = L1 >*/ #line 2369 "cl2.f" L150: #line 2369 "cl2.f" krank = l1; /*< 160 CONTINUE >*/ #line 2370 "cl2.f" L160: /*< KRP1 = KRANK + 1 >*/ #line 2371 "cl2.f" krp1 = krank + 1; /*< IF (.NOT.(KRANK.LT.ME)) GO TO 290 >*/ #line 2372 "cl2.f" if (! (krank < me)) { #line 2372 "cl2.f" goto L290; #line 2372 "cl2.f" } /*< FACTOR = ALSQ >*/ #line 2373 "cl2.f" factor = alsq; /*< DO 170 I=KRP1,ME >*/ #line 2374 "cl2.f" i__1 = me; #line 2374 "cl2.f" for (i__ = krp1; i__ <= i__1; ++i__) { /*< IF (L.GT.0) W(I,1) = ZERO >*/ #line 2375 "cl2.f" if (*l > 0) { #line 2375 "cl2.f" w[i__ + w_dim1] = zero; #line 2375 "cl2.f" } /*< CALL SCOPY(L, W(I,1), 0, W(I,1), MDW) >*/ #line 2376 "cl2.f" scopy_(l, &w[i__ + w_dim1], &c__0, &w[i__ + w_dim1], mdw); /*< 170 CONTINUE >*/ #line 2377 "cl2.f" /* L170: */ #line 2377 "cl2.f" } /* DETERMINE THE RANK OF THE REMAINING EQUALITY CONSTRAINT */ /* EQUATIONS BY ELIMINATING WITHIN THE BLOCK OF CONSTRAINED */ /* VARIABLES. REMOVE ANY REDUNDANT CONSTRAINTS. */ /*< IR = KRP1 >*/ #line 2382 "cl2.f" ir = krp1; /*< IF (.NOT. (L.LT.N)) GO TO 245 >*/ #line 2383 "cl2.f" if (! (*l < *n)) { #line 2383 "cl2.f" goto L245; #line 2383 "cl2.f" } /*< LP1 = L + 1 >*/ #line 2384 "cl2.f" lp1 = *l + 1; /*< RECALC = .TRUE. >*/ #line 2385 "cl2.f" recalc = TRUE_; /*< LB = MIN0(L+ME-KRANK,N) >*/ /* Computing MIN */ #line 2386 "cl2.f" i__1 = *l + me - krank; #line 2386 "cl2.f" lb = min(i__1,*n); /*< I = LP1 >*/ #line 2387 "cl2.f" i__ = lp1; /*< IP1 = I + 1 >*/ #line 2388 "cl2.f" ip1 = i__ + 1; /*< 180 IF (.NOT.(I.LE.LB)) GO TO 280 >*/ #line 2389 "cl2.f" L180: #line 2389 "cl2.f" if (! (i__ <= lb)) { #line 2389 "cl2.f" goto L280; #line 2389 "cl2.f" } /*< IR = KRANK + I - L >*/ #line 2390 "cl2.f" ir = krank + i__ - *l; /*< LEND = N >*/ #line 2391 "cl2.f" lend = *n; /*< MEND = ME >*/ #line 2392 "cl2.f" mend = me; /*< ASSIGN 190 TO IGO996 >*/ #line 2393 "cl2.f" igo996 = 1; #line 2393 "cl2.f" igo996_fmt = fmt_190; /*< GO TO 460 >*/ #line 2394 "cl2.f" goto L460; /* UPDATE-COL-SS-AND-FIND-PIVOT-COL */ /*< 190 ASSIGN 200 TO IGO993 >*/ #line 2397 "cl2.f" L190: #line 2397 "cl2.f" igo993 = 2; #line 2397 "cl2.f" igo993_fmt = fmt_200; /*< GO TO 560 >*/ #line 2398 "cl2.f" goto L560; /* PERFORM-COL-INTERCHANGE */ /* ELIMINATE ELEMENTS IN THE I-TH COL. */ /*< 200 J = ME >*/ #line 2403 "cl2.f" L200: #line 2403 "cl2.f" j = me; /*< 210 IF (.NOT.(J.GT.IR)) GO TO 230 >*/ #line 2404 "cl2.f" L210: #line 2404 "cl2.f" if (! (j > ir)) { #line 2404 "cl2.f" goto L230; #line 2404 "cl2.f" } /*< JM1 = J - 1 >*/ #line 2405 "cl2.f" jm1 = j - 1; /*< IF (.NOT.(W(J,I).NE.ZERO)) GO TO 220 >*/ #line 2406 "cl2.f" if (! (w[j + i__ * w_dim1] != zero)) { #line 2406 "cl2.f" goto L220; #line 2406 "cl2.f" } /*< CALL SROTMG(SCALE(JM1), SCALE(J), W(JM1,I), W(J,I), SPARAM) >*/ #line 2407 "cl2.f" srotmg_(&scale[jm1], &scale[j], &w[jm1 + i__ * w_dim1], &w[j + i__ * w_dim1], sparam); /*< W(J,I) = ZERO >*/ #line 2408 "cl2.f" w[j + i__ * w_dim1] = zero; /*< CALL SROTM(NP1-I, W(JM1,IP1), MDW, W(J,IP1), MDW, SPARAM) >*/ #line 2409 "cl2.f" i__1 = np1 - i__; #line 2409 "cl2.f" srotm_(&i__1, &w[jm1 + ip1 * w_dim1], mdw, &w[j + ip1 * w_dim1], mdw, sparam); /*< 220 J = JM1 >*/ #line 2410 "cl2.f" L220: #line 2410 "cl2.f" j = jm1; /*< GO TO 210 >*/ #line 2411 "cl2.f" goto L210; /* SET IC=I=COL BEING ELIMINATED */ /*< 230 IC = I >*/ #line 2414 "cl2.f" L230: #line 2414 "cl2.f" ic = i__; /*< ASSIGN 240 TO IGO990 >*/ #line 2415 "cl2.f" igo990 = 1; #line 2415 "cl2.f" igo990_fmt = fmt_240; /*< GO TO 520 >*/ #line 2416 "cl2.f" goto L520; /* TEST-INDEP-OF-INCOMING-COL */ /*< 240 IF (INDEP) GO TO 270 >*/ #line 2419 "cl2.f" L240: #line 2419 "cl2.f" if (indep) { #line 2419 "cl2.f" goto L270; #line 2419 "cl2.f" } /* REMOVE ANY REDUNDANT OR DEPENDENT EQUALITY CONSTRAINTS. */ /*< 245 CONTINUE >*/ #line 2422 "cl2.f" L245: /*< JJ = IR >*/ #line 2423 "cl2.f" jj = ir; /*< 250 IF (.NOT.(IR.LE.ME)) GO TO 260 >*/ #line 2424 "cl2.f" L250: #line 2424 "cl2.f" if (! (ir <= me)) { #line 2424 "cl2.f" goto L260; #line 2424 "cl2.f" } /*< W(IR,1) = ZERO >*/ #line 2425 "cl2.f" w[ir + w_dim1] = zero; /*< CALL SCOPY(N, W(IR,1), 0, W(IR,1), MDW) >*/ #line 2426 "cl2.f" scopy_(n, &w[ir + w_dim1], &c__0, &w[ir + w_dim1], mdw); /*< RNORM = RNORM + (SCALE(IR)*W(IR,NP1)/ALSQ)*W(IR,NP1) >*/ #line 2427 "cl2.f" *rnorm += scale[ir] * w[ir + np1 * w_dim1] / alsq * w[ir + np1 * w_dim1]; /*< W(IR,NP1) = ZERO >*/ #line 2428 "cl2.f" w[ir + np1 * w_dim1] = zero; /*< SCALE(IR) = ONE >*/ #line 2429 "cl2.f" scale[ir] = one; /* RECLASSIFY THE ZEROED ROW AS A LEAST SQUARES EQUATION. */ /*< ITYPE(IR) = 1 >*/ #line 2431 "cl2.f" itype[ir] = 1; /*< IR = IR + 1 >*/ #line 2432 "cl2.f" ++ir; /*< GO TO 250 >*/ #line 2433 "cl2.f" goto L250; /* REDUCE ME TO REFLECT ANY DISCOVERED DEPENDENT EQUALITY */ /* CONSTRAINTS. */ /*< 260 CONTINUE >*/ #line 2437 "cl2.f" L260: /*< ME = JJ - 1 >*/ #line 2438 "cl2.f" me = jj - 1; /*< MEP1 = ME + 1 >*/ #line 2439 "cl2.f" mep1 = me + 1; /*< GO TO 300 >*/ #line 2440 "cl2.f" goto L300; /*< 270 I = IP1 >*/ #line 2441 "cl2.f" L270: #line 2441 "cl2.f" i__ = ip1; /*< IP1 = IP1 + 1 >*/ #line 2442 "cl2.f" ++ip1; /*< GO TO 180 >*/ #line 2443 "cl2.f" goto L180; /*< 280 CONTINUE >*/ #line 2444 "cl2.f" L280: /*< 290 CONTINUE >*/ #line 2445 "cl2.f" L290: /*< 300 CONTINUE >*/ #line 2446 "cl2.f" L300: /*< IF (.NOT.(KRANK.LT.L1)) GO TO 420 >*/ #line 2447 "cl2.f" if (! (krank < l1)) { #line 2447 "cl2.f" goto L420; #line 2447 "cl2.f" } /* TRY TO DETERMINE THE VARIABLES KRANK+1 THROUGH L1 FROM THE */ /* LEAST SQUARES EQUATIONS. CONTINUE THE TRIANGULARIZATION WITH */ /* PIVOT ELEMENT W(MEP1,I). */ /*< RECALC = .TRUE. >*/ #line 2453 "cl2.f" recalc = TRUE_; /* SET FACTOR=ALSQ TO REMOVE EFFECT OF HEAVY WEIGHT FROM */ /* TEST FOR COL INDEPENDENCE. */ /*< FACTOR = ALSQ >*/ #line 2457 "cl2.f" factor = alsq; /*< KK = KRP1 >*/ #line 2458 "cl2.f" kk = krp1; /*< I = KK >*/ #line 2459 "cl2.f" i__ = kk; /*< IP1 = I + 1 >*/ #line 2460 "cl2.f" ip1 = i__ + 1; /*< 310 IF (.NOT.(I.LE.L1)) GO TO 410 >*/ #line 2461 "cl2.f" L310: #line 2461 "cl2.f" if (! (i__ <= l1)) { #line 2461 "cl2.f" goto L410; #line 2461 "cl2.f" } /* SET IR TO POINT TO THE MEP1-ST ROW. */ /*< IR = MEP1 >*/ #line 2464 "cl2.f" ir = mep1; /*< LEND = L >*/ #line 2465 "cl2.f" lend = *l; /*< MEND = M >*/ #line 2466 "cl2.f" mend = *m; /*< ASSIGN 320 TO IGO996 >*/ #line 2467 "cl2.f" igo996 = 2; #line 2467 "cl2.f" igo996_fmt = fmt_320; /*< GO TO 460 >*/ #line 2468 "cl2.f" goto L460; /* UPDATE-COL-SS-AND-FIND-PIVOT-COL */ /*< 320 ASSIGN 330 TO IGO993 >*/ #line 2471 "cl2.f" L320: #line 2471 "cl2.f" igo993 = 3; #line 2471 "cl2.f" igo993_fmt = fmt_330; /*< GO TO 560 >*/ #line 2472 "cl2.f" goto L560; /* PERFORM-COL-INTERCHANGE */ /* ELIMINATE I-TH COL BELOW THE IR-TH ELEMENT. */ /*< 330 IRP1 = IR + 1 >*/ #line 2477 "cl2.f" L330: #line 2477 "cl2.f" irp1 = ir + 1; /*< IF (.NOT.(IRP1.LE.M)) GO TO 355 >*/ #line 2478 "cl2.f" if (! (irp1 <= *m)) { #line 2478 "cl2.f" goto L355; #line 2478 "cl2.f" } /*< J = M >*/ #line 2479 "cl2.f" j = *m; /*< DO 350 JJ=IRP1,M >*/ #line 2480 "cl2.f" i__1 = *m; #line 2480 "cl2.f" for (jj = irp1; jj <= i__1; ++jj) { /*< JM1 = J - 1 >*/ #line 2481 "cl2.f" jm1 = j - 1; /*< IF (.NOT.(W(J,I).NE.ZERO)) GO TO 340 >*/ #line 2482 "cl2.f" if (! (w[j + i__ * w_dim1] != zero)) { #line 2482 "cl2.f" goto L340; #line 2482 "cl2.f" } /*< CALL SROTMG(SCALE(JM1), SCALE(J), W(JM1,I), W(J,I), SPARAM) >*/ #line 2483 "cl2.f" srotmg_(&scale[jm1], &scale[j], &w[jm1 + i__ * w_dim1], &w[j + i__ * w_dim1], sparam); /*< W(J,I) = ZERO >*/ #line 2484 "cl2.f" w[j + i__ * w_dim1] = zero; /*< CALL SROTM(NP1-I, W(JM1,IP1), MDW, W(J,IP1), MDW, SPARAM) >*/ #line 2485 "cl2.f" i__2 = np1 - i__; #line 2485 "cl2.f" srotm_(&i__2, &w[jm1 + ip1 * w_dim1], mdw, &w[j + ip1 * w_dim1], mdw, sparam); /*< 340 J = JM1 >*/ #line 2486 "cl2.f" L340: #line 2486 "cl2.f" j = jm1; /*< 350 CONTINUE >*/ #line 2487 "cl2.f" /* L350: */ #line 2487 "cl2.f" } /*< 355 CONTINUE >*/ #line 2488 "cl2.f" L355: /* TEST IF NEW PIVOT ELEMENT IS NEAR ZERO. IF SO, THE COL IS */ /* DEPENDENT. */ /*< T = SCALE(IR)*W(IR,I)**2 >*/ /* Computing 2nd power */ #line 2492 "cl2.f" r__1 = w[ir + i__ * w_dim1]; #line 2492 "cl2.f" t = scale[ir] * (r__1 * r__1); /*< INDEP = T.GT.TAU**2*EANORM**2 >*/ /* Computing 2nd power */ #line 2493 "cl2.f" r__1 = tau; /* Computing 2nd power */ #line 2493 "cl2.f" r__2 = eanorm; #line 2493 "cl2.f" indep = t > r__1 * r__1 * (r__2 * r__2); /*< IF (.NOT.INDEP) GO TO 380 >*/ #line 2494 "cl2.f" if (! indep) { #line 2494 "cl2.f" goto L380; #line 2494 "cl2.f" } /* COL TEST PASSED. NOW MUST PASS ROW NORM TEST TO BE CLASSIFIED */ /* AS INDEPENDENT. */ /*< RN = ZERO >*/ #line 2498 "cl2.f" rn = zero; /*< DO 370 I1=IR,M >*/ #line 2499 "cl2.f" i__1 = *m; #line 2499 "cl2.f" for (i1 = ir; i1 <= i__1; ++i1) { /*< DO 360 J1=IP1,N >*/ #line 2500 "cl2.f" i__2 = *n; #line 2500 "cl2.f" for (j1 = ip1; j1 <= i__2; ++j1) { /*< RN = AMAX1(RN,SCALE(I1)*W(I1,J1)**2) >*/ /* Computing MAX */ /* Computing 2nd power */ #line 2501 "cl2.f" r__3 = w[i1 + j1 * w_dim1]; #line 2501 "cl2.f" r__1 = rn, r__2 = scale[i1] * (r__3 * r__3); #line 2501 "cl2.f" rn = max(r__1,r__2); /*< 360 CONTINUE >*/ #line 2502 "cl2.f" /* L360: */ #line 2502 "cl2.f" } /*< 370 CONTINUE >*/ #line 2503 "cl2.f" /* L370: */ #line 2503 "cl2.f" } /*< INDEP = T.GT.TAU**2*RN >*/ /* Computing 2nd power */ #line 2504 "cl2.f" r__1 = tau; #line 2504 "cl2.f" indep = t > r__1 * r__1 * rn; /* IF INDEPENDENT, SWAP THE IR-TH AND KRP1-ST ROWS TO MAINTAIN THE */ /* TRIANGULAR FORM. UPDATE THE RANK INDICATOR KRANK AND THE */ /* EQUALITY CONSTRAINT POINTER ME. */ /*< 380 IF (.NOT.(INDEP)) GO TO 390 >*/ #line 2509 "cl2.f" L380: #line 2509 "cl2.f" if (! indep) { #line 2509 "cl2.f" goto L390; #line 2509 "cl2.f" } /*< CALL SSWAP(NP1, W(KRP1,1), MDW, W(IR,1), MDW) >*/ #line 2510 "cl2.f" sswap_(&np1, &w[krp1 + w_dim1], mdw, &w[ir + w_dim1], mdw); /*< CALL SSWAP(1, SCALE(KRP1), 1, SCALE(IR), 1) >*/ #line 2511 "cl2.f" sswap_(&c__1, &scale[krp1], &c__1, &scale[ir], &c__1); /* RECLASSIFY THE LEAST SQ. EQUATION AS AN EQUALITY CONSTRAINT AND */ /* RESCALE IT. */ /*< ITYPE(IR) = 0 >*/ #line 2514 "cl2.f" itype[ir] = 0; /*< T = SQRT(SCALE(KRP1)) >*/ #line 2515 "cl2.f" t = sqrt(scale[krp1]); /*< CALL SSCAL(NP1, T, W(KRP1,1), MDW) >*/ #line 2516 "cl2.f" sscal_(&np1, &t, &w[krp1 + w_dim1], mdw); /*< SCALE(KRP1) = ALSQ >*/ #line 2517 "cl2.f" scale[krp1] = alsq; /*< ME = MEP1 >*/ #line 2518 "cl2.f" me = mep1; /*< MEP1 = ME + 1 >*/ #line 2519 "cl2.f" mep1 = me + 1; /*< KRANK = KRP1 >*/ #line 2520 "cl2.f" krank = krp1; /*< KRP1 = KRANK + 1 >*/ #line 2521 "cl2.f" krp1 = krank + 1; /*< GO TO 400 >*/ #line 2522 "cl2.f" goto L400; /*< 390 GO TO 430 >*/ #line 2523 "cl2.f" L390: #line 2523 "cl2.f" goto L430; /*< 400 I = IP1 >*/ #line 2524 "cl2.f" L400: #line 2524 "cl2.f" i__ = ip1; /*< IP1 = IP1 + 1 >*/ #line 2525 "cl2.f" ++ip1; /*< GO TO 310 >*/ #line 2526 "cl2.f" goto L310; /*< 410 CONTINUE >*/ #line 2527 "cl2.f" L410: /*< 420 CONTINUE >*/ #line 2528 "cl2.f" L420: /*< 430 CONTINUE >*/ #line 2529 "cl2.f" L430: /* IF PSEUDORANK IS LESS THAN L, APPLY HOUSEHOLDER TRANS. */ /* FROM RIGHT. */ /*< IF (.NOT.(KRANK.LT.L)) GO TO 450 >*/ #line 2533 "cl2.f" if (! (krank < *l)) { #line 2533 "cl2.f" goto L450; #line 2533 "cl2.f" } /*< DO 440 I=1,KRANK >*/ #line 2534 "cl2.f" i__1 = krank; #line 2534 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< J = KRP1 - I >*/ #line 2535 "cl2.f" j = krp1 - i__; /*< CALL H12(1, J, KRP1, L, W(J,1), MDW, H(J), W, MDW, 1, J-1) >*/ #line 2536 "cl2.f" i__2 = j - 1; #line 2536 "cl2.f" h12_(&c__1, &j, &krp1, l, &w[j + w_dim1], mdw, &h__[j], &w[w_offset], mdw, &c__1, &i__2); /*< 440 CONTINUE >*/ #line 2537 "cl2.f" /* L440: */ #line 2537 "cl2.f" } /*< 450 NIV = KRANK + NSOLN - L >*/ #line 2538 "cl2.f" L450: #line 2538 "cl2.f" niv = krank + nsoln - *l; /*< NIV1 = NIV + 1 >*/ #line 2539 "cl2.f" niv1 = niv + 1; /*< IF (L.EQ.N) DONE = .TRUE. >*/ #line 2540 "cl2.f" if (*l == *n) { #line 2540 "cl2.f" *done = TRUE_; #line 2540 "cl2.f" } /* END OF INITIAL TRIANGULARIZATION. */ /*< IDOPE(1) = ME >*/ #line 2543 "cl2.f" idope[1] = me; /*< IDOPE(2) = MEP1 >*/ #line 2544 "cl2.f" idope[2] = mep1; /*< IDOPE(3) = KRANK >*/ #line 2545 "cl2.f" idope[3] = krank; /*< IDOPE(4) = KRP1 >*/ #line 2546 "cl2.f" idope[4] = krp1; /*< IDOPE(5) = NSOLN >*/ #line 2547 "cl2.f" idope[5] = nsoln; /*< IDOPE(6) = NIV >*/ #line 2548 "cl2.f" idope[6] = niv; /*< IDOPE(7) = NIV1 >*/ #line 2549 "cl2.f" idope[7] = niv1; /*< IDOPE(8) = L1 >*/ #line 2550 "cl2.f" idope[8] = l1; /*< RETURN >*/ #line 2551 "cl2.f" return 0; /*< 460 CONTINUE >*/ #line 2552 "cl2.f" L460: /* TO UPDATE-COL-SS-AND-FIND-PIVOT-COL */ /* THE COL SS VECTOR WILL BE UPDATED AT EACH STEP. WHEN */ /* NUMERICALLY NECESSARY, THESE VALUES WILL BE RECOMPUTED. */ /*< IF (.NOT.(IR.NE.1 .AND. (.NOT.RECALC))) GO TO 480 >*/ #line 2559 "cl2.f" if (! (ir != 1 && ! recalc)) { #line 2559 "cl2.f" goto L480; #line 2559 "cl2.f" } /* UPDATE COL SS =SUM OF SQUARES. */ /*< DO 470 J=I,LEND >*/ #line 2561 "cl2.f" i__1 = lend; #line 2561 "cl2.f" for (j = i__; j <= i__1; ++j) { /*< H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 >*/ /* Computing 2nd power */ #line 2562 "cl2.f" r__1 = w[ir - 1 + j * w_dim1]; #line 2562 "cl2.f" h__[j] -= scale[ir - 1] * (r__1 * r__1); /*< 470 CONTINUE >*/ #line 2563 "cl2.f" /* L470: */ #line 2563 "cl2.f" } /* TEST FOR NUMERICAL ACCURACY. */ /*< MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1 >*/ #line 2566 "cl2.f" i__1 = lend - i__ + 1; #line 2566 "cl2.f" max__ = isamax_(&i__1, &h__[i__], &c__1) + i__ - 1; /*< RECALC = HBAR + TENM3*H(MAX).EQ.HBAR >*/ #line 2567 "cl2.f" recalc = hbar + tenm3 * h__[max__] == hbar; /* IF REQUIRED, RECALCULATE COL SS, USING ROWS IR THROUGH MEND. */ /*< 480 IF (.NOT.(RECALC)) GO TO 510 >*/ #line 2570 "cl2.f" L480: #line 2570 "cl2.f" if (! recalc) { #line 2570 "cl2.f" goto L510; #line 2570 "cl2.f" } /*< DO 500 J=I,LEND >*/ #line 2571 "cl2.f" i__1 = lend; #line 2571 "cl2.f" for (j = i__; j <= i__1; ++j) { /*< H(J) = ZERO >*/ #line 2572 "cl2.f" h__[j] = zero; /*< DO 490 K=IR,MEND >*/ #line 2573 "cl2.f" i__2 = mend; #line 2573 "cl2.f" for (k = ir; k <= i__2; ++k) { /*< H(J) = H(J) + SCALE(K)*W(K,J)**2 >*/ /* Computing 2nd power */ #line 2574 "cl2.f" r__1 = w[k + j * w_dim1]; #line 2574 "cl2.f" h__[j] += scale[k] * (r__1 * r__1); /*< 490 CONTINUE >*/ #line 2575 "cl2.f" /* L490: */ #line 2575 "cl2.f" } /*< 500 CONTINUE >*/ #line 2576 "cl2.f" /* L500: */ #line 2576 "cl2.f" } /* FIND COL WITH LARGEST SS. */ /*< MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1 >*/ #line 2579 "cl2.f" i__1 = lend - i__ + 1; #line 2579 "cl2.f" max__ = isamax_(&i__1, &h__[i__], &c__1) + i__ - 1; /*< HBAR = H(MAX) >*/ #line 2580 "cl2.f" hbar = h__[max__]; /*< 510 GO TO 600 >*/ #line 2581 "cl2.f" L510: #line 2581 "cl2.f" goto L600; /*< 520 CONTINUE >*/ #line 2582 "cl2.f" L520: /* TO TEST-INDEP-OF-INCOMING-COL */ /* TEST THE COL IC TO DETERMINE IF IT IS LINEARLY INDEPENDENT */ /* OF THE COLS ALREADY IN THE BASIS. IN THE INIT TRI */ /* STEP, WE USUALLY WANT THE HEAVY WEIGHT ALAMDA TO */ /* BE INCLUDED IN THE TEST FOR INDEPENDENCE. IN THIS CASE THE */ /* VALUE OF FACTOR WILL HAVE BEEN SET TO 1.E0 BEFORE THIS */ /* PROCEDURE IS INVOKED. IN THE POTENTIALLY RANK DEFICIENT */ /* PROBLEM, THE VALUE OF FACTOR WILL HAVE BEEN */ /* SET TO ALSQ=ALAMDA**2 TO REMOVE THE EFFECT OF THE HEAVY WEIGHT */ /* FROM THE TEST FOR INDEPENDENCE. */ /* WRITE NEW COL AS PARTITIONED VECTOR */ /* (A1) NUMBER OF COMPONENTS IN SOLN SO FAR = NIV */ /* (A2) M-NIV COMPONENTS */ /* AND COMPUTE SN = INVERSE WEIGHTED LENGTH OF A1 */ /* RN = INVERSE WEIGHTED LENGTH OF A2 */ /* CALL THE COL INDEPENDENT WHEN RN .GT. TAU*SN */ /*< SN = ZERO >*/ #line 2602 "cl2.f" sn = zero; /*< RN = ZERO >*/ #line 2603 "cl2.f" rn = zero; /*< DO 550 J=1,MEND >*/ #line 2604 "cl2.f" i__1 = mend; #line 2604 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< T = SCALE(J) >*/ #line 2605 "cl2.f" t = scale[j]; /*< IF (J.LE.ME) T = T/FACTOR >*/ #line 2606 "cl2.f" if (j <= me) { #line 2606 "cl2.f" t /= factor; #line 2606 "cl2.f" } /*< T = T*W(J,IC)**2 >*/ /* Computing 2nd power */ #line 2607 "cl2.f" r__1 = w[j + ic * w_dim1]; #line 2607 "cl2.f" t *= r__1 * r__1; /*< IF (.NOT.(J.LT.IR)) GO TO 530 >*/ #line 2608 "cl2.f" if (! (j < ir)) { #line 2608 "cl2.f" goto L530; #line 2608 "cl2.f" } /*< SN = SN + T >*/ #line 2609 "cl2.f" sn += t; /*< GO TO 540 >*/ #line 2610 "cl2.f" goto L540; /*< 530 RN = RN + T >*/ #line 2611 "cl2.f" L530: #line 2611 "cl2.f" rn += t; /*< 540 CONTINUE >*/ #line 2612 "cl2.f" L540: /*< 550 CONTINUE >*/ #line 2613 "cl2.f" /* L550: */ #line 2613 "cl2.f" ; #line 2613 "cl2.f" } /*< INDEP = RN.GT.TAU**2*SN >*/ /* Computing 2nd power */ #line 2614 "cl2.f" r__1 = tau; #line 2614 "cl2.f" indep = rn > r__1 * r__1 * sn; /*< GO TO 590 >*/ #line 2615 "cl2.f" goto L590; /*< 560 CONTINUE >*/ #line 2616 "cl2.f" L560: /* TO PERFORM-COL-INTERCHANGE */ /*< IF (.NOT.(MAX.NE.I)) GO TO 570 >*/ #line 2620 "cl2.f" if (! (max__ != i__)) { #line 2620 "cl2.f" goto L570; #line 2620 "cl2.f" } /* EXCHANGE ELEMENTS OF PERMUTED INDEX VECTOR AND PERFORM COL */ /* INTERCHANGES. */ /*< ITEMP = IPIVOT(I) >*/ #line 2623 "cl2.f" itemp = ipivot[i__]; /*< IPIVOT(I) = IPIVOT(MAX) >*/ #line 2624 "cl2.f" ipivot[i__] = ipivot[max__]; /*< IPIVOT(MAX) = ITEMP >*/ #line 2625 "cl2.f" ipivot[max__] = itemp; /*< CALL SSWAP(M, W(1,MAX), 1, W(1,I), 1) >*/ #line 2626 "cl2.f" sswap_(m, &w[max__ * w_dim1 + 1], &c__1, &w[i__ * w_dim1 + 1], &c__1); /*< T = H(MAX) >*/ #line 2627 "cl2.f" t = h__[max__]; /*< H(MAX) = H(I) >*/ #line 2628 "cl2.f" h__[max__] = h__[i__]; /*< H(I) = T >*/ #line 2629 "cl2.f" h__[i__] = t; /*< 570 GO TO 580 >*/ #line 2630 "cl2.f" L570: #line 2630 "cl2.f" goto L580; /*< 580 GO TO IGO993, (30, 200, 330, 120) >*/ #line 2631 "cl2.f" L580: #line 2631 "cl2.f" switch (igo993) { #line 2631 "cl2.f" case 0: goto L30; #line 2631 "cl2.f" case 1: goto L120; #line 2631 "cl2.f" case 2: goto L200; #line 2631 "cl2.f" case 3: goto L330; #line 2631 "cl2.f" } /*< 590 GO TO IGO990, (40, 240) >*/ #line 2632 "cl2.f" L590: #line 2632 "cl2.f" switch (igo990) { #line 2632 "cl2.f" case 0: goto L40; #line 2632 "cl2.f" case 1: goto L240; #line 2632 "cl2.f" } /*< 600 GO TO IGO996, (20, 190, 320) >*/ #line 2633 "cl2.f" L600: #line 2633 "cl2.f" switch (igo996) { #line 2633 "cl2.f" case 0: goto L20; #line 2633 "cl2.f" case 1: goto L190; #line 2633 "cl2.f" case 2: goto L320; #line 2633 "cl2.f" } /*< END >*/ } /* wnlit_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< >*/ static /* Subroutine */ int hfti_(real *a, integer *mda, integer *m, integer *n, real *b, integer *mdb, integer *nb, real *tau, integer *krank, real * rnorm, real *h__, real *g, integer *ip) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; real r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, k, l; static integer jb, ii, jj; static real sm; static integer ip1, kp1; static real sm1, tmp; static integer jcol; static real hmax; static integer lmax, nerr, iopt; static real zero; static integer ldiag; static real factor; /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (BEGIN CHANGES AT LINE WITH C++ IN COLS. 1-3.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/,/ SQRT/ DSQRT/, */ /* /, ABS/, DABS/,/ABS(/DABS(/,/E0/D0/ */ /* DIMENSION A(MDA,N),(B(MDB,NB) OR B(M)),RNORM(NB),H(N),G(N),IP(N) */ /* WRITTEN BY C. L. LAWSON AND R. J. HANSON. FROM THE BOOK SOLVING */ /* LEAST SQUARES PROBLEMS, PRENTICE-HALL, INC. (1974). FOR FURTHER */ /* ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14. */ /* ABSTRACT */ /* THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF */ /* LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT */ /* RIGHT-SIDE VECTORS. THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX */ /* A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU */ /* WHOSE USAGE IS DESCRIBED BELOW. THE NB COLUMN VECTORS OF B */ /* REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES */ /* PROBLEMS. */ /* THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST */ /* SQUARES PROBLEM */ /* AX = B, */ /* WHERE X IS THE N BY NB SOLUTION MATRIX. */ /* NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE */ /* PSEUDO-INVERSE OF A. */ /* THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A */ /* MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH */ /* COLUMN INTERCHANGES. ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE */ /* ZERO AND ITS DIAGONAL ELEMENTS SATISFY */ /* ABS(R(I,I)).GE.ABS(R(I+1,I+1)), */ /* I = 1,...,L-1, WHERE */ /* L = MIN(M,N). */ /* THE SUBROUTINE WILL COMPUTE AN INTEGER, KRANK, EQUAL TO THE NUMBER */ /* OF DIAGONAL TERMS OF R THAT EXCEED TAU IN MAGNITUDE. THEN A */ /* SOLUTION OF MINIMUM EUCLIDEAN LENGTH IS COMPUTED USING THE FIRST */ /* KRANK ROWS OF (R C). */ /* TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY */ /* COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF */ /* MAGNITUDES. */ /* NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/ */ /* NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO */ /* EPS*(NORM OF A). */ /* THE USER MUST DIMENSION ALL ARRAYS APPEARING IN THE CALL LIST.. */ /* A(MDA,N),(B(MDB,NB) OR B(M)),RNORM(NB),H(N),G(N),IP(N). THIS */ /* PERMITS THE SOLUTION OF A RANGE OF PROBLEMS IN THE SAME ARRAY */ /* SPACE. */ /* THE ENTIRE SET OF PARAMETERS FOR HFTI ARE */ /* INPUT.. */ /* A(*,*),MDA,M,N THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N */ /* MATRIX A OF THE LEAST SQUARES PROBLEM AX = B. */ /* THE FIRST DIMENSIONING PARAMETER OF THE ARRAY */ /* A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M */ /* EITHER M.GE.N OR M.LT.N IS PERMITTED. THERE */ /* IS NO RESTRICTION ON THE RANK OF A. THE */ /* CONDITION MDA.LT.M IS CONSIDERED AN ERROR. */ /* B(*),MDB,NB IF NB = 0 THE SUBROUTINE WILL PERFORM THE */ /* ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO */ /* REFERENCES TO THE ARRAY B(*). IF NB.GT.0 */ /* THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY */ /* NB MATRIX B OF THE LEAST SQUARES PROBLEM AX = */ /* B. IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY */ /* SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER */ /* MDB.GE.MAX(M,N). IF NB = 1 THE ARRAY B(*) MAY */ /* BE EITHER DOUBLY OR SINGLY SUBSCRIPTED. IN */ /* THE LATTER CASE THE VALUE OF MDB IS ARBITRARY */ /* BUT IT SHOULD BE SET TO SOME VALID INTEGER */ /* VALUE SUCH AS MDB = M. */ /* THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N) */ /* IS CONSIDERED AN ERROR. */ /* TAU ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER */ /* FOR PSEUDORANK DETERMINATION. */ /* H(*),G(*),IP(*) ARRAYS OF WORKING SPACE USED BY HFTI. */ /* OUTPUT.. */ /* A(*,*) THE CONTENTS OF THE ARRAY A(*,*) WILL BE */ /* MODIFIED BY THE SUBROUTINE. THESE CONTENTS */ /* ARE NOT GENERALLY REQUIRED BY THE USER. */ /* B(*) ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY */ /* NB SOLUTION MATRIX X. */ /* KRANK SET BY THE SUBROUTINE TO INDICATE THE */ /* PSEUDORANK OF A. */ /* RNORM(*) ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN */ /* NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM */ /* DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY */ /* B(*,*) FOR J = 1,...,NB. */ /* H(*),G(*) ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN */ /* ELEMENTS OF THE PRE- AND POST-MULTIPLYING */ /* HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE */ /* THE MINIMUM EUCLIDEAN LENGTH SOLUTION. */ /* IP(*) ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES */ /* DESCRIBING THE PERMUTATION OF COLUMN VECTORS. */ /* THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*) */ /* ARE NOT GENERALLY REQUIRED BY THE USER. */ /* ++ */ /*< REAL A(MDA,N), B(MDB,1), H(N), G(N), RNORM(NB), TAU >*/ /*< REAL FACTOR, HMAX, SM1, ZERO, SM, TMP >*/ /*< REAL DIFF, SQRT, ABS >*/ /*< INTEGER IP(N) >*/ /*< ZERO = 0.E0 >*/ #line 2768 "cl2.f" /* Parameter adjustments */ #line 2768 "cl2.f" --ip; #line 2768 "cl2.f" --g; #line 2768 "cl2.f" --h__; #line 2768 "cl2.f" a_dim1 = *mda; #line 2768 "cl2.f" a_offset = 1 + a_dim1; #line 2768 "cl2.f" a -= a_offset; #line 2768 "cl2.f" b_dim1 = *mdb; #line 2768 "cl2.f" b_offset = 1 + b_dim1; #line 2768 "cl2.f" b -= b_offset; #line 2768 "cl2.f" --rnorm; #line 2768 "cl2.f" #line 2768 "cl2.f" /* Function Body */ #line 2768 "cl2.f" zero = 0.f; /*< FACTOR = 0.001E0 >*/ #line 2769 "cl2.f" factor = .001f; /*< K = 0 >*/ #line 2771 "cl2.f" k = 0; /*< LDIAG = MIN0(M,N) >*/ #line 2772 "cl2.f" ldiag = min(*m,*n); /*< IF (LDIAG.LE.0) GO TO 310 >*/ #line 2773 "cl2.f" if (ldiag <= 0) { #line 2773 "cl2.f" goto L310; #line 2773 "cl2.f" } /*< IF (.NOT.MDA.LT.M) GO TO 10 >*/ #line 2774 "cl2.f" if (! (*mda < *m)) { #line 2774 "cl2.f" goto L10; #line 2774 "cl2.f" } /*< NERR = 2 >*/ #line 2775 "cl2.f" nerr = 2; /*< IOPT = 2 >*/ #line 2776 "cl2.f" iopt = 2; /* cc CALL XERROR(31HHFTI MDA.LT.M.. PROBABLE ERROR., 31, NERR, IOPT) */ /* cc RETURN */ /*< 10 CONTINUE >*/ #line 2779 "cl2.f" L10: /*< IF (.NOT.(NB.GT.1 .AND. MAX0(M,N).GT.MDB)) GO TO 20 >*/ #line 2781 "cl2.f" if (! (*nb > 1 && max(*m,*n) > *mdb)) { #line 2781 "cl2.f" goto L20; #line 2781 "cl2.f" } /*< NERR = 2 >*/ #line 2782 "cl2.f" nerr = 2; /*< IOPT = 2 >*/ #line 2783 "cl2.f" iopt = 2; /* cc CALL XERROR(49HHFTI MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR., */ /* cc * 49, NERR, IOPT) */ /*< RETURN >*/ #line 2786 "cl2.f" return 0; /*< 20 CONTINUE >*/ #line 2787 "cl2.f" L20: /*< DO 100 J=1,LDIAG >*/ #line 2789 "cl2.f" i__1 = ldiag; #line 2789 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< IF (J.EQ.1) GO TO 40 >*/ #line 2790 "cl2.f" if (j == 1) { #line 2790 "cl2.f" goto L40; #line 2790 "cl2.f" } /* UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX */ /* .. */ /*< LMAX = J >*/ #line 2794 "cl2.f" lmax = j; /*< DO 30 L=J,N >*/ #line 2795 "cl2.f" i__2 = *n; #line 2795 "cl2.f" for (l = j; l <= i__2; ++l) { /*< H(L) = H(L) - A(J-1,L)**2 >*/ /* Computing 2nd power */ #line 2796 "cl2.f" r__1 = a[j - 1 + l * a_dim1]; #line 2796 "cl2.f" h__[l] -= r__1 * r__1; /*< IF (H(L).GT.H(LMAX)) LMAX = L >*/ #line 2797 "cl2.f" if (h__[l] > h__[lmax]) { #line 2797 "cl2.f" lmax = l; #line 2797 "cl2.f" } /*< 30 CONTINUE >*/ #line 2798 "cl2.f" /* L30: */ #line 2798 "cl2.f" } /*< IF (DIFF(HMAX+FACTOR*H(LMAX),HMAX)) 40, 40, 70 >*/ #line 2799 "cl2.f" r__1 = hmax + factor * h__[lmax]; #line 2799 "cl2.f" if (diff_(&r__1, &hmax) <= 0.f) { #line 2799 "cl2.f" goto L40; #line 2799 "cl2.f" } else { #line 2799 "cl2.f" goto L70; #line 2799 "cl2.f" } /* COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX */ /* .. */ /*< 40 LMAX = J >*/ #line 2803 "cl2.f" L40: #line 2803 "cl2.f" lmax = j; /*< DO 60 L=J,N >*/ #line 2804 "cl2.f" i__2 = *n; #line 2804 "cl2.f" for (l = j; l <= i__2; ++l) { /*< H(L) = ZERO >*/ #line 2805 "cl2.f" h__[l] = zero; /*< DO 50 I=J,M >*/ #line 2806 "cl2.f" i__3 = *m; #line 2806 "cl2.f" for (i__ = j; i__ <= i__3; ++i__) { /*< H(L) = H(L) + A(I,L)**2 >*/ /* Computing 2nd power */ #line 2807 "cl2.f" r__1 = a[i__ + l * a_dim1]; #line 2807 "cl2.f" h__[l] += r__1 * r__1; /*< 50 CONTINUE >*/ #line 2808 "cl2.f" /* L50: */ #line 2808 "cl2.f" } /*< IF (H(L).GT.H(LMAX)) LMAX = L >*/ #line 2809 "cl2.f" if (h__[l] > h__[lmax]) { #line 2809 "cl2.f" lmax = l; #line 2809 "cl2.f" } /*< 60 CONTINUE >*/ #line 2810 "cl2.f" /* L60: */ #line 2810 "cl2.f" } /*< HMAX = H(LMAX) >*/ #line 2811 "cl2.f" hmax = h__[lmax]; /* .. */ /* LMAX HAS BEEN DETERMINED */ /* DO COLUMN INTERCHANGES IF NEEDED. */ /* .. */ /*< 70 CONTINUE >*/ #line 2817 "cl2.f" L70: /*< IP(J) = LMAX >*/ #line 2818 "cl2.f" ip[j] = lmax; /*< IF (IP(J).EQ.J) GO TO 90 >*/ #line 2819 "cl2.f" if (ip[j] == j) { #line 2819 "cl2.f" goto L90; #line 2819 "cl2.f" } /*< DO 80 I=1,M >*/ #line 2820 "cl2.f" i__2 = *m; #line 2820 "cl2.f" for (i__ = 1; i__ <= i__2; ++i__) { /*< TMP = A(I,J) >*/ #line 2821 "cl2.f" tmp = a[i__ + j * a_dim1]; /*< A(I,J) = A(I,LMAX) >*/ #line 2822 "cl2.f" a[i__ + j * a_dim1] = a[i__ + lmax * a_dim1]; /*< A(I,LMAX) = TMP >*/ #line 2823 "cl2.f" a[i__ + lmax * a_dim1] = tmp; /*< 80 CONTINUE >*/ #line 2824 "cl2.f" /* L80: */ #line 2824 "cl2.f" } /*< H(LMAX) = H(J) >*/ #line 2825 "cl2.f" h__[lmax] = h__[j]; /*< 90 JCOL = MIN0(J+1,N) >*/ #line 2826 "cl2.f" L90: /* Computing MIN */ #line 2826 "cl2.f" i__2 = j + 1; #line 2826 "cl2.f" jcol = min(i__2,*n); /* COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B. */ /* .. */ /*< CALL H12(1, J, J+1, M, A(1,J), 1, H(J), A(1,JCOL), 1, MDA, N-J) >*/ #line 2830 "cl2.f" i__2 = j + 1; #line 2830 "cl2.f" i__3 = *n - j; #line 2830 "cl2.f" h12_(&c__1, &j, &i__2, m, &a[j * a_dim1 + 1], &c__1, &h__[j], &a[jcol * a_dim1 + 1], &c__1, mda, &i__3); /*< CALL H12(2, J, J+1, M, A(1,J), 1, H(J), B, 1, MDB, NB) >*/ #line 2831 "cl2.f" i__2 = j + 1; #line 2831 "cl2.f" h12_(&c__2, &j, &i__2, m, &a[j * a_dim1 + 1], &c__1, &h__[j], &b[ b_offset], &c__1, mdb, nb); /*< 100 CONTINUE >*/ #line 2832 "cl2.f" /* L100: */ #line 2832 "cl2.f" } /* DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU. */ /* .. */ /*< DO 110 J=1,LDIAG >*/ #line 2836 "cl2.f" i__1 = ldiag; #line 2836 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< IF (ABS(A(J,J)).LE.TAU) GO TO 120 >*/ #line 2837 "cl2.f" if ((r__1 = a[j + j * a_dim1], abs(r__1)) <= *tau) { #line 2837 "cl2.f" goto L120; #line 2837 "cl2.f" } /*< 110 CONTINUE >*/ #line 2838 "cl2.f" /* L110: */ #line 2838 "cl2.f" } /*< K = LDIAG >*/ #line 2839 "cl2.f" k = ldiag; /*< GO TO 130 >*/ #line 2840 "cl2.f" goto L130; /*< 120 K = J - 1 >*/ #line 2841 "cl2.f" L120: #line 2841 "cl2.f" k = j - 1; /*< 130 KP1 = K + 1 >*/ #line 2842 "cl2.f" L130: #line 2842 "cl2.f" kp1 = k + 1; /* COMPUTE THE NORMS OF THE RESIDUAL VECTORS. */ /*< IF (NB.LE.0) GO TO 170 >*/ #line 2846 "cl2.f" if (*nb <= 0) { #line 2846 "cl2.f" goto L170; #line 2846 "cl2.f" } /*< DO 160 JB=1,NB >*/ #line 2847 "cl2.f" i__1 = *nb; #line 2847 "cl2.f" for (jb = 1; jb <= i__1; ++jb) { /*< TMP = ZERO >*/ #line 2848 "cl2.f" tmp = zero; /*< IF (KP1.GT.M) GO TO 150 >*/ #line 2849 "cl2.f" if (kp1 > *m) { #line 2849 "cl2.f" goto L150; #line 2849 "cl2.f" } /*< DO 140 I=KP1,M >*/ #line 2850 "cl2.f" i__2 = *m; #line 2850 "cl2.f" for (i__ = kp1; i__ <= i__2; ++i__) { /*< TMP = TMP + B(I,JB)**2 >*/ /* Computing 2nd power */ #line 2851 "cl2.f" r__1 = b[i__ + jb * b_dim1]; #line 2851 "cl2.f" tmp += r__1 * r__1; /*< 140 CONTINUE >*/ #line 2852 "cl2.f" /* L140: */ #line 2852 "cl2.f" } /*< 150 RNORM(JB) = SQRT(TMP) >*/ #line 2853 "cl2.f" L150: #line 2853 "cl2.f" rnorm[jb] = sqrt(tmp); /*< 160 CONTINUE >*/ #line 2854 "cl2.f" /* L160: */ #line 2854 "cl2.f" } /*< 170 CONTINUE >*/ #line 2855 "cl2.f" L170: /* SPECIAL FOR PSEUDORANK = 0 */ /*< IF (K.GT.0) GO TO 200 >*/ #line 2857 "cl2.f" if (k > 0) { #line 2857 "cl2.f" goto L200; #line 2857 "cl2.f" } /*< IF (NB.LE.0) GO TO 310 >*/ #line 2858 "cl2.f" if (*nb <= 0) { #line 2858 "cl2.f" goto L310; #line 2858 "cl2.f" } /*< DO 190 JB=1,NB >*/ #line 2859 "cl2.f" i__1 = *nb; #line 2859 "cl2.f" for (jb = 1; jb <= i__1; ++jb) { /*< DO 180 I=1,N >*/ #line 2860 "cl2.f" i__2 = *n; #line 2860 "cl2.f" for (i__ = 1; i__ <= i__2; ++i__) { /*< B(I,JB) = ZERO >*/ #line 2861 "cl2.f" b[i__ + jb * b_dim1] = zero; /*< 180 CONTINUE >*/ #line 2862 "cl2.f" /* L180: */ #line 2862 "cl2.f" } /*< 190 CONTINUE >*/ #line 2863 "cl2.f" /* L190: */ #line 2863 "cl2.f" } /*< GO TO 310 >*/ #line 2864 "cl2.f" goto L310; /* IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER */ /* DECOMPOSITION OF FIRST K ROWS. */ /* .. */ /*< 200 IF (K.EQ.N) GO TO 220 >*/ #line 2869 "cl2.f" L200: #line 2869 "cl2.f" if (k == *n) { #line 2869 "cl2.f" goto L220; #line 2869 "cl2.f" } /*< DO 210 II=1,K >*/ #line 2870 "cl2.f" i__1 = k; #line 2870 "cl2.f" for (ii = 1; ii <= i__1; ++ii) { /*< I = KP1 - II >*/ #line 2871 "cl2.f" i__ = kp1 - ii; /*< CALL H12(1, I, KP1, N, A(I,1), MDA, G(I), A, MDA, 1, I-1) >*/ #line 2872 "cl2.f" i__2 = i__ - 1; #line 2872 "cl2.f" h12_(&c__1, &i__, &kp1, n, &a[i__ + a_dim1], mda, &g[i__], &a[ a_offset], mda, &c__1, &i__2); /*< 210 CONTINUE >*/ #line 2873 "cl2.f" /* L210: */ #line 2873 "cl2.f" } /*< 220 CONTINUE >*/ #line 2874 "cl2.f" L220: /*< IF (NB.LE.0) GO TO 310 >*/ #line 2877 "cl2.f" if (*nb <= 0) { #line 2877 "cl2.f" goto L310; #line 2877 "cl2.f" } /*< DO 300 JB=1,NB >*/ #line 2878 "cl2.f" i__1 = *nb; #line 2878 "cl2.f" for (jb = 1; jb <= i__1; ++jb) { /* SOLVE THE K BY K TRIANGULAR SYSTEM. */ /* .. */ /*< DO 250 L=1,K >*/ #line 2882 "cl2.f" i__2 = k; #line 2882 "cl2.f" for (l = 1; l <= i__2; ++l) { /*< SM = ZERO >*/ #line 2883 "cl2.f" sm = zero; /*< I = KP1 - L >*/ #line 2884 "cl2.f" i__ = kp1 - l; /*< IF (I.EQ.K) GO TO 240 >*/ #line 2885 "cl2.f" if (i__ == k) { #line 2885 "cl2.f" goto L240; #line 2885 "cl2.f" } /*< IP1 = I + 1 >*/ #line 2886 "cl2.f" ip1 = i__ + 1; /*< DO 230 J=IP1,K >*/ #line 2887 "cl2.f" i__3 = k; #line 2887 "cl2.f" for (j = ip1; j <= i__3; ++j) { /*< SM = SM + A(I,J)*B(J,JB) >*/ #line 2888 "cl2.f" sm += a[i__ + j * a_dim1] * b[j + jb * b_dim1]; /*< 230 CONTINUE >*/ #line 2889 "cl2.f" /* L230: */ #line 2889 "cl2.f" } /*< 240 SM1 = SM >*/ #line 2890 "cl2.f" L240: #line 2890 "cl2.f" sm1 = sm; /*< B(I,JB) = (B(I,JB)-SM1)/A(I,I) >*/ #line 2891 "cl2.f" b[i__ + jb * b_dim1] = (b[i__ + jb * b_dim1] - sm1) / a[i__ + i__ * a_dim1]; /*< 250 CONTINUE >*/ #line 2892 "cl2.f" /* L250: */ #line 2892 "cl2.f" } /* COMPLETE COMPUTATION OF SOLUTION VECTOR. */ /* .. */ /*< IF (K.EQ.N) GO TO 280 >*/ #line 2896 "cl2.f" if (k == *n) { #line 2896 "cl2.f" goto L280; #line 2896 "cl2.f" } /*< DO 260 J=KP1,N >*/ #line 2897 "cl2.f" i__2 = *n; #line 2897 "cl2.f" for (j = kp1; j <= i__2; ++j) { /*< B(J,JB) = ZERO >*/ #line 2898 "cl2.f" b[j + jb * b_dim1] = zero; /*< 260 CONTINUE >*/ #line 2899 "cl2.f" /* L260: */ #line 2899 "cl2.f" } /*< DO 270 I=1,K >*/ #line 2900 "cl2.f" i__2 = k; #line 2900 "cl2.f" for (i__ = 1; i__ <= i__2; ++i__) { /*< CALL H12(2, I, KP1, N, A(I,1), MDA, G(I), B(1,JB), 1, MDB, 1) >*/ #line 2901 "cl2.f" h12_(&c__2, &i__, &kp1, n, &a[i__ + a_dim1], mda, &g[i__], &b[jb * b_dim1 + 1], &c__1, mdb, &c__1); /*< 270 CONTINUE >*/ #line 2902 "cl2.f" /* L270: */ #line 2902 "cl2.f" } /* RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE */ /* COLUMN INTERCHANGES. */ /* .. */ /*< 280 DO 290 JJ=1,LDIAG >*/ #line 2907 "cl2.f" L280: #line 2907 "cl2.f" i__2 = ldiag; #line 2907 "cl2.f" for (jj = 1; jj <= i__2; ++jj) { /*< J = LDIAG + 1 - JJ >*/ #line 2908 "cl2.f" j = ldiag + 1 - jj; /*< IF (IP(J).EQ.J) GO TO 290 >*/ #line 2909 "cl2.f" if (ip[j] == j) { #line 2909 "cl2.f" goto L290; #line 2909 "cl2.f" } /*< L = IP(J) >*/ #line 2910 "cl2.f" l = ip[j]; /*< TMP = B(L,JB) >*/ #line 2911 "cl2.f" tmp = b[l + jb * b_dim1]; /*< B(L,JB) = B(J,JB) >*/ #line 2912 "cl2.f" b[l + jb * b_dim1] = b[j + jb * b_dim1]; /*< B(J,JB) = TMP >*/ #line 2913 "cl2.f" b[j + jb * b_dim1] = tmp; /*< 290 CONTINUE >*/ #line 2914 "cl2.f" L290: #line 2914 "cl2.f" ; #line 2914 "cl2.f" } /*< 300 CONTINUE >*/ #line 2915 "cl2.f" /* L300: */ #line 2915 "cl2.f" } /* .. */ /* THE SOLUTION VECTORS, X, ARE NOW */ /* IN THE FIRST N ROWS OF THE ARRAY B(,). */ /*< 310 KRANK = K >*/ #line 2920 "cl2.f" L310: #line 2920 "cl2.f" *krank = k; /*< RETURN >*/ #line 2921 "cl2.f" return 0; /*< END >*/ } /* hfti_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV) >*/ static /* Subroutine */ int h12_(integer *mode, integer *lpivot, integer *l1, integer *m, real *u, integer *iue, real *up, real *c__, integer *ice, integer *icv, integer *ncv) { /* System generated locals */ integer u_dim1, u_offset, i__1, i__2; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static real b; static integer i__, j, i2, i3, i4; static real cl, sm; static integer kl1, kl2, l1m1; static real one; static integer klp, incr; static real ul1m1; static integer mml1p2; static real clinv; /* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */ /* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */ /* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */ /* (START CHANGES AT LINE WITH C++ IN COLS. 1-3.) */ /* /REAL (12 BLANKS)/DOUBLE PRECISION/,/SDOT/DDOT/,/ABS,/DABS,/, */ /* /SSWAP/DSWAP/,/SQRT/DSQRT/,/ABS(/ DABS(/,/AMAX1/DMAX1/, */ /* /SAXPY/DAXPY/,/E0/D0/ */ /* C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUN 12 */ /* TO APPEAR IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974 */ /* MODIFIED AT SANDIA LABS., MAY 1977, TO -- */ /* 1) REMOVE DOUBLE PRECISION ACCUMULATION, AND */ /* 2) INCLUDE USAGE OF THE BASIC LINEAR ALGEBRA PACKAGE FOR */ /* VECTORS LONGER THAN A PARTICULAR THRESHOLD. */ /* CONSTRUCTION AND/OR APPLICATION OF A SINGLE */ /* HOUSEHOLDER TRANSFORMATION.. Q = I + U*(U**T)/B */ /* MODE = 1 OR 2 TO SELECT ALGORITHM H1 OR H2 . */ /* LPIVOT IS THE INDEX OF THE PIVOT ELEMENT. */ /* L1,M IF L1 .LE. M THE TRANSFORMATION WILL BE CONSTRUCTED TO */ /* ZERO ELEMENTS INDEXED FROM L1 THROUGH M. IF L1 GT. M */ /* THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. */ /* U(),IUE,UP ON ENTRY TO H1 U() CONTAINS THE PIVOT VECTOR. */ /* IUE IS THE STORAGE INCREMENT BETWEEN ELEMENTS. */ /* ON EXIT FROM H1 U() AND UP */ /* CONTAIN QUANTITIES DEFINING THE VECTOR U OF THE */ /* HOUSEHOLDER TRANSFORMATION. ON ENTRY TO H2 U() */ /* AND UP SHOULD CONTAIN QUANTITIES PREVIOUSLY COMPUTED */ /* BY H1. THESE WILL NOT BE MODIFIED BY H2. */ /* C() ON ENTRY TO H1 OR H2 C() CONTAINS A MATRIX WHICH WILL BE */ /* REGARDED AS A SET OF VECTORS TO WHICH THE HOUSEHOLDER */ /* TRANSFORMATION IS TO BE APPLIED. ON EXIT C() CONTAINS THE */ /* SET OF TRANSFORMED VECTORS. */ /* ICE STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C(). */ /* ICV STORAGE INCREMENT BETWEEN VECTORS IN C(). */ /* NCV NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0 */ /* NO OPERATIONS WILL BE DONE ON C(). */ /* SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV) */ /* ++ */ /*< REAL U(IUE,M), C(1), UP >*/ /*< REAL B, CL, CLINV, ONE, SM, UL1M1 >*/ /*< REAL ABS, AMAX1, SQRT, SDOT >*/ /*< ONE=1.E0 >*/ #line 2975 "cl2.f" /* Parameter adjustments */ #line 2975 "cl2.f" u_dim1 = *iue; #line 2975 "cl2.f" u_offset = 1 + u_dim1; #line 2975 "cl2.f" u -= u_offset; #line 2975 "cl2.f" --c__; #line 2975 "cl2.f" #line 2975 "cl2.f" /* Function Body */ #line 2975 "cl2.f" one = 1.f; /*< IF (0.GE.LPIVOT.OR.LPIVOT.GE.L1.OR.L1.GT.M) RETURN >*/ #line 2977 "cl2.f" if (0 >= *lpivot || *lpivot >= *l1 || *l1 > *m) { #line 2977 "cl2.f" return 0; #line 2977 "cl2.f" } /*< CL=ABS(U(1,LPIVOT)) >*/ #line 2978 "cl2.f" cl = (r__1 = u[*lpivot * u_dim1 + 1], abs(r__1)); /*< IF (MODE.EQ.2) GO TO 60 >*/ #line 2979 "cl2.f" if (*mode == 2) { #line 2979 "cl2.f" goto L60; #line 2979 "cl2.f" } /* ****** CONSTRUCT THE TRANSFORMATION. ****** */ /*< DO 10 J=L1,M >*/ #line 2981 "cl2.f" i__1 = *m; #line 2981 "cl2.f" for (j = *l1; j <= i__1; ++j) { /*< 10 CL=AMAX1(ABS(U(1,J)),CL) >*/ #line 2982 "cl2.f" /* L10: */ /* Computing MAX */ #line 2982 "cl2.f" r__2 = (r__1 = u[j * u_dim1 + 1], abs(r__1)); #line 2982 "cl2.f" cl = max(r__2,cl); #line 2982 "cl2.f" } /*< IF (CL) 130,130,20 >*/ #line 2983 "cl2.f" if (cl <= 0.f) { #line 2983 "cl2.f" goto L130; #line 2983 "cl2.f" } else { #line 2983 "cl2.f" goto L20; #line 2983 "cl2.f" } /*< 20 CLINV=ONE/CL >*/ #line 2984 "cl2.f" L20: #line 2984 "cl2.f" clinv = one / cl; /*< SM=(U(1,LPIVOT)*CLINV)**2 >*/ /* Computing 2nd power */ #line 2985 "cl2.f" r__1 = u[*lpivot * u_dim1 + 1] * clinv; #line 2985 "cl2.f" sm = r__1 * r__1; /*< DO 30 J=L1,M >*/ #line 2986 "cl2.f" i__1 = *m; #line 2986 "cl2.f" for (j = *l1; j <= i__1; ++j) { /*< 30 SM=SM+(U(1,J)*CLINV)**2 >*/ #line 2987 "cl2.f" /* L30: */ /* Computing 2nd power */ #line 2987 "cl2.f" r__1 = u[j * u_dim1 + 1] * clinv; #line 2987 "cl2.f" sm += r__1 * r__1; #line 2987 "cl2.f" } /*< CL=CL*SQRT(SM) >*/ #line 2988 "cl2.f" cl *= sqrt(sm); /*< IF (U(1,LPIVOT)) 50,50,40 >*/ #line 2989 "cl2.f" if (u[*lpivot * u_dim1 + 1] <= 0.f) { #line 2989 "cl2.f" goto L50; #line 2989 "cl2.f" } else { #line 2989 "cl2.f" goto L40; #line 2989 "cl2.f" } /*< 40 CL=-CL >*/ #line 2990 "cl2.f" L40: #line 2990 "cl2.f" cl = -cl; /*< 50 UP=U(1,LPIVOT)-CL >*/ #line 2991 "cl2.f" L50: #line 2991 "cl2.f" *up = u[*lpivot * u_dim1 + 1] - cl; /*< U(1,LPIVOT)=CL >*/ #line 2992 "cl2.f" u[*lpivot * u_dim1 + 1] = cl; /*< GO TO 70 >*/ #line 2993 "cl2.f" goto L70; /* ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** */ /*< 60 IF (CL) 130,130,70 >*/ #line 2996 "cl2.f" L60: #line 2996 "cl2.f" if (cl <= 0.f) { #line 2996 "cl2.f" goto L130; #line 2996 "cl2.f" } else { #line 2996 "cl2.f" goto L70; #line 2996 "cl2.f" } /*< 70 IF (NCV.LE.0) RETURN >*/ #line 2997 "cl2.f" L70: #line 2997 "cl2.f" if (*ncv <= 0) { #line 2997 "cl2.f" return 0; #line 2997 "cl2.f" } /*< B=UP*U(1,LPIVOT) >*/ #line 2998 "cl2.f" b = *up * u[*lpivot * u_dim1 + 1]; /* B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. */ /*< IF (B) 80,130,130 >*/ #line 3001 "cl2.f" if (b >= 0.f) { #line 3001 "cl2.f" goto L130; #line 3001 "cl2.f" } else { #line 3001 "cl2.f" goto L80; #line 3001 "cl2.f" } /*< 80 B=ONE/B >*/ #line 3002 "cl2.f" L80: #line 3002 "cl2.f" b = one / b; /*< MML1P2=M-L1+2 >*/ #line 3003 "cl2.f" mml1p2 = *m - *l1 + 2; /*< IF (MML1P2.GT.20) GO TO 140 >*/ #line 3004 "cl2.f" if (mml1p2 > 20) { #line 3004 "cl2.f" goto L140; #line 3004 "cl2.f" } /*< I2=1-ICV+ICE*(LPIVOT-1) >*/ #line 3005 "cl2.f" i2 = 1 - *icv + *ice * (*lpivot - 1); /*< INCR=ICE*(L1-LPIVOT) >*/ #line 3006 "cl2.f" incr = *ice * (*l1 - *lpivot); /*< DO 120 J=1,NCV >*/ #line 3007 "cl2.f" i__1 = *ncv; #line 3007 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< I2=I2+ICV >*/ #line 3008 "cl2.f" i2 += *icv; /*< I3=I2+INCR >*/ #line 3009 "cl2.f" i3 = i2 + incr; /*< I4=I3 >*/ #line 3010 "cl2.f" i4 = i3; /*< SM=C(I2)*UP >*/ #line 3011 "cl2.f" sm = c__[i2] * *up; /*< DO 90 I=L1,M >*/ #line 3012 "cl2.f" i__2 = *m; #line 3012 "cl2.f" for (i__ = *l1; i__ <= i__2; ++i__) { /*< SM=SM+C(I3)*U(1,I) >*/ #line 3013 "cl2.f" sm += c__[i3] * u[i__ * u_dim1 + 1]; /*< 90 I3=I3+ICE >*/ #line 3014 "cl2.f" /* L90: */ #line 3014 "cl2.f" i3 += *ice; #line 3014 "cl2.f" } /*< IF (SM) 100,120,100 >*/ #line 3015 "cl2.f" if (sm != 0.f) { #line 3015 "cl2.f" goto L100; #line 3015 "cl2.f" } else { #line 3015 "cl2.f" goto L120; #line 3015 "cl2.f" } /*< 100 SM=SM*B >*/ #line 3016 "cl2.f" L100: #line 3016 "cl2.f" sm *= b; /*< C(I2)=C(I2)+SM*UP >*/ #line 3017 "cl2.f" c__[i2] += sm * *up; /*< DO 110 I=L1,M >*/ #line 3018 "cl2.f" i__2 = *m; #line 3018 "cl2.f" for (i__ = *l1; i__ <= i__2; ++i__) { /*< C(I4)=C(I4)+SM*U(1,I) >*/ #line 3019 "cl2.f" c__[i4] += sm * u[i__ * u_dim1 + 1]; /*< 110 I4=I4+ICE >*/ #line 3020 "cl2.f" /* L110: */ #line 3020 "cl2.f" i4 += *ice; #line 3020 "cl2.f" } /*< 120 CONTINUE >*/ #line 3021 "cl2.f" L120: #line 3021 "cl2.f" ; #line 3021 "cl2.f" } /*< 130 RETURN >*/ #line 3022 "cl2.f" L130: #line 3022 "cl2.f" return 0; /*< 140 CONTINUE >*/ #line 3023 "cl2.f" L140: /*< L1M1=L1-1 >*/ #line 3024 "cl2.f" l1m1 = *l1 - 1; /*< KL1=1+(L1M1-1)*ICE >*/ #line 3025 "cl2.f" kl1 = (l1m1 - 1) * *ice + 1; /*< KL2=KL1 >*/ #line 3026 "cl2.f" kl2 = kl1; /*< KLP=1+(LPIVOT-1)*ICE >*/ #line 3027 "cl2.f" klp = (*lpivot - 1) * *ice + 1; /*< UL1M1=U(1,L1M1) >*/ #line 3028 "cl2.f" ul1m1 = u[l1m1 * u_dim1 + 1]; /*< U(1,L1M1)=UP >*/ #line 3029 "cl2.f" u[l1m1 * u_dim1 + 1] = *up; /*< IF (LPIVOT.EQ.L1M1) GO TO 150 >*/ #line 3030 "cl2.f" if (*lpivot == l1m1) { #line 3030 "cl2.f" goto L150; #line 3030 "cl2.f" } /*< CALL SSWAP(NCV,C(KL1),ICV,C(KLP),ICV) >*/ #line 3031 "cl2.f" sswap_(ncv, &c__[kl1], icv, &c__[klp], icv); /*< 150 CONTINUE >*/ #line 3032 "cl2.f" L150: /*< DO 160 J=1,NCV >*/ #line 3033 "cl2.f" i__1 = *ncv; #line 3033 "cl2.f" for (j = 1; j <= i__1; ++j) { /*< SM=SDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) >*/ #line 3034 "cl2.f" sm = sdot_(&mml1p2, &u[l1m1 * u_dim1 + 1], iue, &c__[kl1], ice); /*< SM=SM*B >*/ #line 3035 "cl2.f" sm *= b; /*< CALL SAXPY (MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) >*/ #line 3036 "cl2.f" saxpy_(&mml1p2, &sm, &u[l1m1 * u_dim1 + 1], iue, &c__[kl1], ice); /*< KL1=KL1+ICV >*/ #line 3037 "cl2.f" kl1 += *icv; /*< 160 CONTINUE >*/ #line 3038 "cl2.f" /* L160: */ #line 3038 "cl2.f" } /*< U(1,L1M1)=UL1M1 >*/ #line 3039 "cl2.f" u[l1m1 * u_dim1 + 1] = ul1m1; /*< IF (LPIVOT.EQ.L1M1) RETURN >*/ #line 3040 "cl2.f" if (*lpivot == l1m1) { #line 3040 "cl2.f" return 0; #line 3040 "cl2.f" } /*< KL1=KL2 >*/ #line 3041 "cl2.f" kl1 = kl2; /*< CALL SSWAP(NCV,C(KL1),ICV,C(KLP),ICV) >*/ #line 3042 "cl2.f" sswap_(ncv, &c__[kl1], icv, &c__[klp], icv); /*< RETURN >*/ #line 3043 "cl2.f" return 0; /*< END >*/ } /* h12_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE SROTMG (SD1,SD2,SX1,SY1,SPARAM) >*/ static /* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real *sparam) { /* Initialized data */ static real zero = 0.f; static real one = 1.f; static real two = 2.f; static integer iflag = 1; static real gam = 4096.f; static real gamsq = 1.678e7f; static real rgam = 2.441e-4f; static real rgamsq = 5.96e-8f; /* Format strings */ static char fmt_120[] = ""; static char fmt_150[] = ""; static char fmt_180[] = ""; static char fmt_210[] = ""; /* System generated locals */ real r__1; /* Local variables */ static real su, sp1, sp2, sq2, sq1, sh11, sh21, sh12, sh22; static integer igo; static real sflag, stemp; /* Assigned format variables */ static char *igo_fmt; /* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ /* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */ /* SY2)**T. */ /* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ /* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ /* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ /* H=( ) ( ) ( ) ( ) */ /* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ /* END OF ABSTRACT */ /*< DIMENSION SPARAM(5) >*/ /*< DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/,IFLAG/1/ >*/ #line 3081 "cl2.f" /* Parameter adjustments */ #line 3081 "cl2.f" --sparam; #line 3081 "cl2.f" #line 3081 "cl2.f" /* Function Body */ /*< DATA GAM,GAMSQ,RGAM,RGAMSQ/4096.E0,1.678E7,2.441E-4,5.960E-8/ >*/ /*< IF(.NOT. SD1 .LT. ZERO) GO TO 10 >*/ #line 3084 "cl2.f" if (! (*sd1 < zero)) { #line 3084 "cl2.f" goto L10; #line 3084 "cl2.f" } /* GO ZERO-H-D-AND-SX1.. */ /*< GO TO 60 >*/ #line 3086 "cl2.f" goto L60; /*< 10 CONTINUE >*/ #line 3087 "cl2.f" L10: /* CASE-SD1-NONNEGATIVE */ /*< SP2=SD2*SY1 >*/ #line 3089 "cl2.f" sp2 = *sd2 * *sy1; /*< IF(.NOT. SP2 .EQ. ZERO) GO TO 20 >*/ #line 3090 "cl2.f" if (! (sp2 == zero)) { #line 3090 "cl2.f" goto L20; #line 3090 "cl2.f" } /*< SFLAG=-TWO >*/ #line 3091 "cl2.f" sflag = -two; /*< GO TO 260 >*/ #line 3092 "cl2.f" goto L260; /* REGULAR-CASE.. */ /*< 20 CONTINUE >*/ #line 3094 "cl2.f" L20: /*< SP1=SD1*SX1 >*/ #line 3095 "cl2.f" sp1 = *sd1 * *sx1; /*< SQ2=SP2*SY1 >*/ #line 3096 "cl2.f" sq2 = sp2 * *sy1; /*< SQ1=SP1*SX1 >*/ #line 3097 "cl2.f" sq1 = sp1 * *sx1; /*< IF(.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40 >*/ #line 3099 "cl2.f" if (! (abs(sq1) > abs(sq2))) { #line 3099 "cl2.f" goto L40; #line 3099 "cl2.f" } /*< SH21=-SY1/SX1 >*/ #line 3100 "cl2.f" sh21 = -(*sy1) / *sx1; /*< SH12=SP2/SP1 >*/ #line 3101 "cl2.f" sh12 = sp2 / sp1; /*< SU=ONE-SH12*SH21 >*/ #line 3103 "cl2.f" su = one - sh12 * sh21; /*< IF(.NOT. SU .LE. ZERO) GO TO 30 >*/ #line 3105 "cl2.f" if (! (su <= zero)) { #line 3105 "cl2.f" goto L30; #line 3105 "cl2.f" } /* GO ZERO-H-D-AND-SX1.. */ /*< GO TO 60 >*/ #line 3107 "cl2.f" goto L60; /*< 30 CONTINUE >*/ #line 3108 "cl2.f" L30: /*< SFLAG=ZERO >*/ #line 3109 "cl2.f" sflag = zero; /*< SD1=SD1/SU >*/ #line 3110 "cl2.f" *sd1 /= su; /*< SD2=SD2/SU >*/ #line 3111 "cl2.f" *sd2 /= su; /*< SX1=SX1*SU >*/ #line 3112 "cl2.f" *sx1 *= su; /* GO SCALE-CHECK.. */ /*< GO TO 100 >*/ #line 3114 "cl2.f" goto L100; /*< 40 CONTINUE >*/ #line 3115 "cl2.f" L40: /*< IF(.NOT. SQ2 .LT. ZERO) GO TO 50 >*/ #line 3116 "cl2.f" if (! (sq2 < zero)) { #line 3116 "cl2.f" goto L50; #line 3116 "cl2.f" } /* GO ZERO-H-D-AND-SX1.. */ /*< GO TO 60 >*/ #line 3118 "cl2.f" goto L60; /*< 50 CONTINUE >*/ #line 3119 "cl2.f" L50: /*< SFLAG=ONE >*/ #line 3120 "cl2.f" sflag = one; /*< SH11=SP1/SP2 >*/ #line 3121 "cl2.f" sh11 = sp1 / sp2; /*< SH22=SX1/SY1 >*/ #line 3122 "cl2.f" sh22 = *sx1 / *sy1; /*< SU=ONE+SH11*SH22 >*/ #line 3123 "cl2.f" su = one + sh11 * sh22; /*< STEMP=SD2/SU >*/ #line 3124 "cl2.f" stemp = *sd2 / su; /*< SD2=SD1/SU >*/ #line 3125 "cl2.f" *sd2 = *sd1 / su; /*< SD1=STEMP >*/ #line 3126 "cl2.f" *sd1 = stemp; /*< SX1=SY1*SU >*/ #line 3127 "cl2.f" *sx1 = *sy1 * su; /* GO SCALE-CHECK */ /*< GO TO 100 >*/ #line 3129 "cl2.f" goto L100; /* PROCEDURE..ZERO-H-D-AND-SX1.. */ /*< 60 CONTINUE >*/ #line 3131 "cl2.f" L60: /*< SFLAG=-ONE >*/ #line 3132 "cl2.f" sflag = -one; /*< SH11=ZERO >*/ #line 3133 "cl2.f" sh11 = zero; /*< SH12=ZERO >*/ #line 3134 "cl2.f" sh12 = zero; /*< SH21=ZERO >*/ #line 3135 "cl2.f" sh21 = zero; /*< SH22=ZERO >*/ #line 3136 "cl2.f" sh22 = zero; /*< SD1=ZERO >*/ #line 3138 "cl2.f" *sd1 = zero; /*< SD2=ZERO >*/ #line 3139 "cl2.f" *sd2 = zero; /*< SX1=ZERO >*/ #line 3140 "cl2.f" *sx1 = zero; /* RETURN.. */ /*< GO TO 220 >*/ #line 3142 "cl2.f" goto L220; /* PROCEDURE..FIX-H.. */ /*< 70 CONTINUE >*/ #line 3144 "cl2.f" L70: /*< IF(.NOT. SFLAG .GE. ZERO) GO TO 90 >*/ #line 3145 "cl2.f" if (! (sflag >= zero)) { #line 3145 "cl2.f" goto L90; #line 3145 "cl2.f" } /*< IF(.NOT. SFLAG .EQ. ZERO) GO TO 80 >*/ #line 3147 "cl2.f" if (! (sflag == zero)) { #line 3147 "cl2.f" goto L80; #line 3147 "cl2.f" } /*< SH11=ONE >*/ #line 3148 "cl2.f" sh11 = one; /*< SH22=ONE >*/ #line 3149 "cl2.f" sh22 = one; /*< SFLAG=-ONE >*/ #line 3150 "cl2.f" sflag = -one; /*< GO TO 90 >*/ #line 3151 "cl2.f" goto L90; /*< 80 CONTINUE >*/ #line 3152 "cl2.f" L80: /*< SH21=-ONE >*/ #line 3153 "cl2.f" sh21 = -one; /*< SH12=ONE >*/ #line 3154 "cl2.f" sh12 = one; /*< SFLAG=-ONE >*/ #line 3155 "cl2.f" sflag = -one; /*< 90 CONTINUE >*/ #line 3156 "cl2.f" L90: /*< GO TO IGO,(120,150,180,210) >*/ #line 3157 "cl2.f" switch (igo) { #line 3157 "cl2.f" case 0: goto L120; #line 3157 "cl2.f" case 1: goto L150; #line 3157 "cl2.f" case 2: goto L180; #line 3157 "cl2.f" case 3: goto L210; #line 3157 "cl2.f" } /* PROCEDURE..SCALE-CHECK */ /*< 100 CONTINUE >*/ #line 3159 "cl2.f" L100: /*< IF(.NOT. IFLAG.EQ.1) GO TO 105 >*/ #line 3160 "cl2.f" if (! (iflag == 1)) { #line 3160 "cl2.f" goto L105; #line 3160 "cl2.f" } /* RECOMPUTE RESCALING PARAMETERS */ /* MORE ACCURATELY.. */ /*< RGAM = ONE/GAM >*/ #line 3165 "cl2.f" rgam = one / gam; /*< GAMSQ = GAM**2 >*/ /* Computing 2nd power */ #line 3166 "cl2.f" r__1 = gam; #line 3166 "cl2.f" gamsq = r__1 * r__1; /*< RGAMSQ = RGAM**2 >*/ /* Computing 2nd power */ #line 3167 "cl2.f" r__1 = rgam; #line 3167 "cl2.f" rgamsq = r__1 * r__1; /*< IFLAG = 2 >*/ #line 3168 "cl2.f" iflag = 2; /*< 105 CONTINUE >*/ #line 3169 "cl2.f" L105: /*< 110 CONTINUE >*/ #line 3170 "cl2.f" L110: /*< IF(.NOT. SD1 .LE. RGAMSQ) GO TO 130 >*/ #line 3171 "cl2.f" if (! (*sd1 <= rgamsq)) { #line 3171 "cl2.f" goto L130; #line 3171 "cl2.f" } /*< IF(SD1 .EQ. ZERO) GO TO 160 >*/ #line 3172 "cl2.f" if (*sd1 == zero) { #line 3172 "cl2.f" goto L160; #line 3172 "cl2.f" } /*< ASSIGN 120 TO IGO >*/ #line 3173 "cl2.f" igo = 0; #line 3173 "cl2.f" igo_fmt = fmt_120; /* FIX-H.. */ /*< GO TO 70 >*/ #line 3175 "cl2.f" goto L70; /*< 120 CONTINUE >*/ #line 3176 "cl2.f" L120: /*< SD1=SD1*GAMSQ >*/ #line 3177 "cl2.f" *sd1 *= gamsq; /*< SX1=SX1*RGAM >*/ #line 3178 "cl2.f" *sx1 *= rgam; /*< SH11=SH11*RGAM >*/ #line 3179 "cl2.f" sh11 *= rgam; /*< SH12=SH12*RGAM >*/ #line 3180 "cl2.f" sh12 *= rgam; /*< GO TO 110 >*/ #line 3181 "cl2.f" goto L110; /*< 130 CONTINUE >*/ #line 3182 "cl2.f" L130: /*< 140 CONTINUE >*/ #line 3183 "cl2.f" L140: /*< IF(.NOT. SD1 .GE. GAMSQ) GO TO 160 >*/ #line 3184 "cl2.f" if (! (*sd1 >= gamsq)) { #line 3184 "cl2.f" goto L160; #line 3184 "cl2.f" } /*< ASSIGN 150 TO IGO >*/ #line 3185 "cl2.f" igo = 1; #line 3185 "cl2.f" igo_fmt = fmt_150; /* FIX-H.. */ /*< GO TO 70 >*/ #line 3187 "cl2.f" goto L70; /*< 150 CONTINUE >*/ #line 3188 "cl2.f" L150: /*< SD1=SD1*RGAMSQ >*/ #line 3189 "cl2.f" *sd1 *= rgamsq; /*< SX1=SX1*GAM >*/ #line 3190 "cl2.f" *sx1 *= gam; /*< SH11=SH11*GAM >*/ #line 3191 "cl2.f" sh11 *= gam; /*< SH12=SH12*GAM >*/ #line 3192 "cl2.f" sh12 *= gam; /*< GO TO 140 >*/ #line 3193 "cl2.f" goto L140; /*< 160 CONTINUE >*/ #line 3194 "cl2.f" L160: /*< 170 CONTINUE >*/ #line 3195 "cl2.f" L170: /*< IF(.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190 >*/ #line 3196 "cl2.f" if (! (abs(*sd2) <= rgamsq)) { #line 3196 "cl2.f" goto L190; #line 3196 "cl2.f" } /*< IF(SD2 .EQ. ZERO) GO TO 220 >*/ #line 3197 "cl2.f" if (*sd2 == zero) { #line 3197 "cl2.f" goto L220; #line 3197 "cl2.f" } /*< ASSIGN 180 TO IGO >*/ #line 3198 "cl2.f" igo = 2; #line 3198 "cl2.f" igo_fmt = fmt_180; /* FIX-H.. */ /*< GO TO 70 >*/ #line 3200 "cl2.f" goto L70; /*< 180 CONTINUE >*/ #line 3201 "cl2.f" L180: /*< SD2=SD2*GAMSQ >*/ #line 3202 "cl2.f" *sd2 *= gamsq; /*< SH21=SH21*RGAM >*/ #line 3203 "cl2.f" sh21 *= rgam; /*< SH22=SH22*RGAM >*/ #line 3204 "cl2.f" sh22 *= rgam; /*< GO TO 170 >*/ #line 3205 "cl2.f" goto L170; /*< 190 CONTINUE >*/ #line 3206 "cl2.f" L190: /*< 200 CONTINUE >*/ #line 3207 "cl2.f" L200: /*< IF(.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220 >*/ #line 3208 "cl2.f" if (! (abs(*sd2) >= gamsq)) { #line 3208 "cl2.f" goto L220; #line 3208 "cl2.f" } /*< ASSIGN 210 TO IGO >*/ #line 3209 "cl2.f" igo = 3; #line 3209 "cl2.f" igo_fmt = fmt_210; /* FIX-H.. */ /*< GO TO 70 >*/ #line 3211 "cl2.f" goto L70; /*< 210 CONTINUE >*/ #line 3212 "cl2.f" L210: /*< SD2=SD2*RGAMSQ >*/ #line 3213 "cl2.f" *sd2 *= rgamsq; /*< SH21=SH21*GAM >*/ #line 3214 "cl2.f" sh21 *= gam; /*< SH22=SH22*GAM >*/ #line 3215 "cl2.f" sh22 *= gam; /*< GO TO 200 >*/ #line 3216 "cl2.f" goto L200; /*< 220 CONTINUE >*/ #line 3217 "cl2.f" L220: /*< IF(SFLAG)250,230,240 >*/ #line 3218 "cl2.f" if (sflag < 0.f) { #line 3218 "cl2.f" goto L250; #line 3218 "cl2.f" } else if (sflag == 0) { #line 3218 "cl2.f" goto L230; #line 3218 "cl2.f" } else { #line 3218 "cl2.f" goto L240; #line 3218 "cl2.f" } /*< 230 CONTINUE >*/ #line 3219 "cl2.f" L230: /*< SPARAM(3)=SH21 >*/ #line 3220 "cl2.f" sparam[3] = sh21; /*< SPARAM(4)=SH12 >*/ #line 3221 "cl2.f" sparam[4] = sh12; /*< GO TO 260 >*/ #line 3222 "cl2.f" goto L260; /*< 240 CONTINUE >*/ #line 3223 "cl2.f" L240: /*< SPARAM(2)=SH11 >*/ #line 3224 "cl2.f" sparam[2] = sh11; /*< SPARAM(5)=SH22 >*/ #line 3225 "cl2.f" sparam[5] = sh22; /*< GO TO 260 >*/ #line 3226 "cl2.f" goto L260; /*< 250 CONTINUE >*/ #line 3227 "cl2.f" L250: /*< SPARAM(2)=SH11 >*/ #line 3228 "cl2.f" sparam[2] = sh11; /*< SPARAM(3)=SH21 >*/ #line 3229 "cl2.f" sparam[3] = sh21; /*< SPARAM(4)=SH12 >*/ #line 3230 "cl2.f" sparam[4] = sh12; /*< SPARAM(5)=SH22 >*/ #line 3231 "cl2.f" sparam[5] = sh22; /*< 260 CONTINUE >*/ #line 3232 "cl2.f" L260: /*< SPARAM(1)=SFLAG >*/ #line 3233 "cl2.f" sparam[1] = sflag; /*< RETURN >*/ #line 3234 "cl2.f" return 0; /*< END >*/ } /* srotmg_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) >*/ static /* Subroutine */ int scopy_(integer *n, real *sx, integer *incx, real *sy, integer *incy) { /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer i__, m, ix, iy, ns, mp1; /* COPY SINGLE PRECISION SX TO SINGLE PRECISION SY. */ /* END OF ABSTRACT */ /*< REAL SX(1),SY(1) >*/ /*< IF(N.LE.0)RETURN >*/ #line 3246 "cl2.f" /* Parameter adjustments */ #line 3246 "cl2.f" --sy; #line 3246 "cl2.f" --sx; #line 3246 "cl2.f" #line 3246 "cl2.f" /* Function Body */ #line 3246 "cl2.f" if (*n <= 0) { #line 3246 "cl2.f" return 0; #line 3246 "cl2.f" } /*< IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 >*/ #line 3247 "cl2.f" if (*incx == *incy) { #line 3247 "cl2.f" if ((i__1 = *incx - 1) < 0) { #line 3247 "cl2.f" goto L5; #line 3247 "cl2.f" } else if (i__1 == 0) { #line 3247 "cl2.f" goto L20; #line 3247 "cl2.f" } else { #line 3247 "cl2.f" goto L60; #line 3247 "cl2.f" } #line 3247 "cl2.f" } /*< 5 CONTINUE >*/ #line 3248 "cl2.f" L5: /* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. */ /*< IX = 1 >*/ #line 3252 "cl2.f" ix = 1; /*< IY = 1 >*/ #line 3253 "cl2.f" iy = 1; /*< IF(INCX.LT.0)IX = (-N+1)*INCX + 1 >*/ #line 3254 "cl2.f" if (*incx < 0) { #line 3254 "cl2.f" ix = (-(*n) + 1) * *incx + 1; #line 3254 "cl2.f" } /*< IF(INCY.LT.0)IY = (-N+1)*INCY + 1 >*/ #line 3255 "cl2.f" if (*incy < 0) { #line 3255 "cl2.f" iy = (-(*n) + 1) * *incy + 1; #line 3255 "cl2.f" } /*< DO 10 I = 1,N >*/ #line 3256 "cl2.f" i__1 = *n; #line 3256 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< SY(IY) = SX(IX) >*/ #line 3257 "cl2.f" sy[iy] = sx[ix]; /*< IX = IX + INCX >*/ #line 3258 "cl2.f" ix += *incx; /*< IY = IY + INCY >*/ #line 3259 "cl2.f" iy += *incy; /*< 10 CONTINUE >*/ #line 3260 "cl2.f" /* L10: */ #line 3260 "cl2.f" } /*< RETURN >*/ #line 3261 "cl2.f" return 0; /* CODE FOR BOTH INCREMENTS EQUAL TO 1 */ /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. */ /*< 20 M = N - (N/7)*7 >*/ #line 3268 "cl2.f" L20: #line 3268 "cl2.f" m = *n - *n / 7 * 7; /*< IF( M .EQ. 0 ) GO TO 40 >*/ #line 3269 "cl2.f" if (m == 0) { #line 3269 "cl2.f" goto L40; #line 3269 "cl2.f" } /*< DO 30 I = 1,M >*/ #line 3270 "cl2.f" i__1 = m; #line 3270 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< SY(I) = SX(I) >*/ #line 3271 "cl2.f" sy[i__] = sx[i__]; /*< 30 CONTINUE >*/ #line 3272 "cl2.f" /* L30: */ #line 3272 "cl2.f" } /*< IF( N .LT. 7 ) RETURN >*/ #line 3273 "cl2.f" if (*n < 7) { #line 3273 "cl2.f" return 0; #line 3273 "cl2.f" } /*< 40 MP1 = M + 1 >*/ #line 3274 "cl2.f" L40: #line 3274 "cl2.f" mp1 = m + 1; /*< DO 50 I = MP1,N,7 >*/ #line 3275 "cl2.f" i__1 = *n; #line 3275 "cl2.f" for (i__ = mp1; i__ <= i__1; i__ += 7) { /*< SY(I) = SX(I) >*/ #line 3276 "cl2.f" sy[i__] = sx[i__]; /*< SY(I + 1) = SX(I + 1) >*/ #line 3277 "cl2.f" sy[i__ + 1] = sx[i__ + 1]; /*< SY(I + 2) = SX(I + 2) >*/ #line 3278 "cl2.f" sy[i__ + 2] = sx[i__ + 2]; /*< SY(I + 3) = SX(I + 3) >*/ #line 3279 "cl2.f" sy[i__ + 3] = sx[i__ + 3]; /*< SY(I + 4) = SX(I + 4) >*/ #line 3280 "cl2.f" sy[i__ + 4] = sx[i__ + 4]; /*< SY(I + 5) = SX(I + 5) >*/ #line 3281 "cl2.f" sy[i__ + 5] = sx[i__ + 5]; /*< SY(I + 6) = SX(I + 6) >*/ #line 3282 "cl2.f" sy[i__ + 6] = sx[i__ + 6]; /*< 50 CONTINUE >*/ #line 3283 "cl2.f" /* L50: */ #line 3283 "cl2.f" } /*< RETURN >*/ #line 3284 "cl2.f" return 0; /* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. */ /*< 60 CONTINUE >*/ #line 3288 "cl2.f" L60: /*< NS = N*INCX >*/ #line 3289 "cl2.f" ns = *n * *incx; /*< DO 70 I=1,NS,INCX >*/ #line 3290 "cl2.f" i__1 = ns; #line 3290 "cl2.f" i__2 = *incx; #line 3290 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< SY(I) = SX(I) >*/ #line 3291 "cl2.f" sy[i__] = sx[i__]; /*< 70 CONTINUE >*/ #line 3292 "cl2.f" /* L70: */ #line 3292 "cl2.f" } /*< RETURN >*/ #line 3293 "cl2.f" return 0; /*< END >*/ } /* scopy_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE SSWAP (N,SX,INCX,SY,INCY) >*/ static /* Subroutine */ int sswap_(integer *n, real *sx, integer *incx, real *sy, integer *incy) { /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer i__, m, ix, iy, ns, mp1; static real stemp1, stemp2, stemp3; /* INTERCHANGE SINGLE PRECISION SX AND SINGLE PRECISION SY. */ /* END OF ABSTRACT */ /*< REAL SX(1),SY(1),STEMP1,STEMP2,STEMP3 >*/ /*< IF(N.LE.0)RETURN >*/ #line 3305 "cl2.f" /* Parameter adjustments */ #line 3305 "cl2.f" --sy; #line 3305 "cl2.f" --sx; #line 3305 "cl2.f" #line 3305 "cl2.f" /* Function Body */ #line 3305 "cl2.f" if (*n <= 0) { #line 3305 "cl2.f" return 0; #line 3305 "cl2.f" } /*< IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 >*/ #line 3306 "cl2.f" if (*incx == *incy) { #line 3306 "cl2.f" if ((i__1 = *incx - 1) < 0) { #line 3306 "cl2.f" goto L5; #line 3306 "cl2.f" } else if (i__1 == 0) { #line 3306 "cl2.f" goto L20; #line 3306 "cl2.f" } else { #line 3306 "cl2.f" goto L60; #line 3306 "cl2.f" } #line 3306 "cl2.f" } /*< 5 CONTINUE >*/ #line 3307 "cl2.f" L5: /* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. */ /*< IX = 1 >*/ #line 3311 "cl2.f" ix = 1; /*< IY = 1 >*/ #line 3312 "cl2.f" iy = 1; /*< IF(INCX.LT.0)IX = (-N+1)*INCX + 1 >*/ #line 3313 "cl2.f" if (*incx < 0) { #line 3313 "cl2.f" ix = (-(*n) + 1) * *incx + 1; #line 3313 "cl2.f" } /*< IF(INCY.LT.0)IY = (-N+1)*INCY + 1 >*/ #line 3314 "cl2.f" if (*incy < 0) { #line 3314 "cl2.f" iy = (-(*n) + 1) * *incy + 1; #line 3314 "cl2.f" } /*< DO 10 I = 1,N >*/ #line 3315 "cl2.f" i__1 = *n; #line 3315 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< STEMP1 = SX(IX) >*/ #line 3316 "cl2.f" stemp1 = sx[ix]; /*< SX(IX) = SY(IY) >*/ #line 3317 "cl2.f" sx[ix] = sy[iy]; /*< SY(IY) = STEMP1 >*/ #line 3318 "cl2.f" sy[iy] = stemp1; /*< IX = IX + INCX >*/ #line 3319 "cl2.f" ix += *incx; /*< IY = IY + INCY >*/ #line 3320 "cl2.f" iy += *incy; /*< 10 CONTINUE >*/ #line 3321 "cl2.f" /* L10: */ #line 3321 "cl2.f" } /*< RETURN >*/ #line 3322 "cl2.f" return 0; /* CODE FOR BOTH INCREMENTS EQUAL TO 1 */ /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. */ /*< 20 M = N - (N/3)*3 >*/ #line 3329 "cl2.f" L20: #line 3329 "cl2.f" m = *n - *n / 3 * 3; /*< IF( M .EQ. 0 ) GO TO 40 >*/ #line 3330 "cl2.f" if (m == 0) { #line 3330 "cl2.f" goto L40; #line 3330 "cl2.f" } /*< DO 30 I = 1,M >*/ #line 3331 "cl2.f" i__1 = m; #line 3331 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< STEMP1 = SX(I) >*/ #line 3332 "cl2.f" stemp1 = sx[i__]; /*< SX(I) = SY(I) >*/ #line 3333 "cl2.f" sx[i__] = sy[i__]; /*< SY(I) = STEMP1 >*/ #line 3334 "cl2.f" sy[i__] = stemp1; /*< 30 CONTINUE >*/ #line 3335 "cl2.f" /* L30: */ #line 3335 "cl2.f" } /*< IF( N .LT. 3 ) RETURN >*/ #line 3336 "cl2.f" if (*n < 3) { #line 3336 "cl2.f" return 0; #line 3336 "cl2.f" } /*< 40 MP1 = M + 1 >*/ #line 3337 "cl2.f" L40: #line 3337 "cl2.f" mp1 = m + 1; /*< DO 50 I = MP1,N,3 >*/ #line 3338 "cl2.f" i__1 = *n; #line 3338 "cl2.f" for (i__ = mp1; i__ <= i__1; i__ += 3) { /*< STEMP1 = SX(I) >*/ #line 3339 "cl2.f" stemp1 = sx[i__]; /*< STEMP2 = SX(I+1) >*/ #line 3340 "cl2.f" stemp2 = sx[i__ + 1]; /*< STEMP3 = SX(I+2) >*/ #line 3341 "cl2.f" stemp3 = sx[i__ + 2]; /*< SX(I) = SY(I) >*/ #line 3342 "cl2.f" sx[i__] = sy[i__]; /*< SX(I+1) = SY(I+1) >*/ #line 3343 "cl2.f" sx[i__ + 1] = sy[i__ + 1]; /*< SX(I+2) = SY(I+2) >*/ #line 3344 "cl2.f" sx[i__ + 2] = sy[i__ + 2]; /*< SY(I) = STEMP1 >*/ #line 3345 "cl2.f" sy[i__] = stemp1; /*< SY(I+1) = STEMP2 >*/ #line 3346 "cl2.f" sy[i__ + 1] = stemp2; /*< SY(I+2) = STEMP3 >*/ #line 3347 "cl2.f" sy[i__ + 2] = stemp3; /*< 50 CONTINUE >*/ #line 3348 "cl2.f" /* L50: */ #line 3348 "cl2.f" } /*< RETURN >*/ #line 3349 "cl2.f" return 0; /*< 60 CONTINUE >*/ #line 3350 "cl2.f" L60: /* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. */ /*< NS = N*INCX >*/ #line 3354 "cl2.f" ns = *n * *incx; /*< DO 70 I=1,NS,INCX >*/ #line 3355 "cl2.f" i__1 = ns; #line 3355 "cl2.f" i__2 = *incx; #line 3355 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< STEMP1 = SX(I) >*/ #line 3356 "cl2.f" stemp1 = sx[i__]; /*< SX(I) = SY(I) >*/ #line 3357 "cl2.f" sx[i__] = sy[i__]; /*< SY(I) = STEMP1 >*/ #line 3358 "cl2.f" sy[i__] = stemp1; /*< 70 CONTINUE >*/ #line 3359 "cl2.f" /* L70: */ #line 3359 "cl2.f" } /*< RETURN >*/ #line 3360 "cl2.f" return 0; /*< END >*/ } /* sswap_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< REAL FUNCTION SNRM2 ( N, SX, INCX) >*/ static real snrm2_(integer *n, real *sx, integer *incx) { /* Initialized data */ static real zero = 0.f; static real one = 1.f; static real cutlo = 4.441e-16f; static real cuthi = 1.304e19f; /* Format strings */ static char fmt_30[] = ""; static char fmt_50[] = ""; static char fmt_70[] = ""; static char fmt_110[] = ""; /* System generated locals */ integer i__1, i__2; real ret_val, r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, nn; static real sum, xmax; static integer next; static real hitest; /* Assigned format variables */ static char *next_fmt; /*< INTEGER NEXT >*/ /*< REAL SX(1), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE >*/ /*< DATA ZERO, ONE /0.0E0, 1.0E0/ >*/ #line 3368 "cl2.f" /* Parameter adjustments */ #line 3368 "cl2.f" --sx; #line 3368 "cl2.f" #line 3368 "cl2.f" /* Function Body */ /* EUCLIDEAN NORM OF THE N-VECTOR STORED IN SX() WITH STORAGE */ /* INCREMENT INCX . */ /* IF N .LE. 0 RETURN WITH RESULT = 0. */ /* IF N .GE. 1 THEN INCX MUST BE .GE. 1 */ /* C.L.LAWSON, 1978 JAN 08 */ /* FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE */ /* HOPEFULLY APPLICABLE TO ALL MACHINES. */ /* CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. */ /* CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. */ /* WHERE */ /* EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. */ /* U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) */ /* V = LARGEST NO. (OVERFLOW LIMIT) */ /* BRIEF OUTLINE OF ALGORITHM.. */ /* PHASE 1 SCANS ZERO COMPONENTS. */ /* MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO */ /* MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO */ /* MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M */ /* WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. */ /* VALUES FOR CUTLO AND CUTHI.. */ /* FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER */ /* DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. */ /* CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE */ /* UNIVAC AND DEC AT 2**(-103) */ /* THUS CUTLO = 2**(-51) = 4.44089E-16 */ /* CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. */ /* THUS CUTHI = 2**(63.5) = 1.30438E19 */ /* CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. */ /* THUS CUTLO = 2**(-33.5) = 8.23181D-11 */ /* CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 */ /* DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / */ /* DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / */ /* END OF ABSTRACT */ /*< DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / >*/ /*< IF(N .GT. 0) GO TO 10 >*/ #line 3410 "cl2.f" if (*n > 0) { #line 3410 "cl2.f" goto L10; #line 3410 "cl2.f" } /*< SNRM2 = ZERO >*/ #line 3411 "cl2.f" ret_val = zero; /*< GO TO 300 >*/ #line 3412 "cl2.f" goto L300; /*< 10 ASSIGN 30 TO NEXT >*/ #line 3414 "cl2.f" L10: #line 3414 "cl2.f" next = 0; #line 3414 "cl2.f" next_fmt = fmt_30; /*< SUM = ZERO >*/ #line 3415 "cl2.f" sum = zero; /*< NN = N * INCX >*/ #line 3416 "cl2.f" nn = *n * *incx; /* BEGIN MAIN LOOP */ /*< I = 1 >*/ #line 3418 "cl2.f" i__ = 1; /*< 20 GO TO NEXT,(30, 50, 70, 110) >*/ #line 3419 "cl2.f" L20: #line 3419 "cl2.f" switch (next) { #line 3419 "cl2.f" case 0: goto L30; #line 3419 "cl2.f" case 1: goto L50; #line 3419 "cl2.f" case 2: goto L70; #line 3419 "cl2.f" case 3: goto L110; #line 3419 "cl2.f" } /*< 30 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 >*/ #line 3420 "cl2.f" L30: #line 3420 "cl2.f" if ((r__1 = sx[i__], abs(r__1)) > cutlo) { #line 3420 "cl2.f" goto L85; #line 3420 "cl2.f" } /*< ASSIGN 50 TO NEXT >*/ #line 3421 "cl2.f" next = 1; #line 3421 "cl2.f" next_fmt = fmt_50; /*< XMAX = ZERO >*/ #line 3422 "cl2.f" xmax = zero; /* PHASE 1. SUM IS ZERO */ /*< 50 IF( SX(I) .EQ. ZERO) GO TO 200 >*/ #line 3426 "cl2.f" L50: #line 3426 "cl2.f" if (sx[i__] == zero) { #line 3426 "cl2.f" goto L200; #line 3426 "cl2.f" } /*< IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 >*/ #line 3427 "cl2.f" if ((r__1 = sx[i__], abs(r__1)) > cutlo) { #line 3427 "cl2.f" goto L85; #line 3427 "cl2.f" } /* PREPARE FOR PHASE 2. */ /*< ASSIGN 70 TO NEXT >*/ #line 3430 "cl2.f" next = 2; #line 3430 "cl2.f" next_fmt = fmt_70; /*< GO TO 105 >*/ #line 3431 "cl2.f" goto L105; /* PREPARE FOR PHASE 4. */ /*< 100 I = J >*/ #line 3435 "cl2.f" L100: #line 3435 "cl2.f" i__ = j; /*< ASSIGN 110 TO NEXT >*/ #line 3436 "cl2.f" next = 3; #line 3436 "cl2.f" next_fmt = fmt_110; /*< SUM = (SUM / SX(I)) / SX(I) >*/ #line 3437 "cl2.f" sum = sum / sx[i__] / sx[i__]; /*< 105 XMAX = ABS(SX(I)) >*/ #line 3438 "cl2.f" L105: #line 3438 "cl2.f" xmax = (r__1 = sx[i__], abs(r__1)); /*< GO TO 115 >*/ #line 3439 "cl2.f" goto L115; /* PHASE 2. SUM IS SMALL. */ /* SCALE TO AVOID DESTRUCTIVE UNDERFLOW. */ /*< 70 IF( ABS(SX(I)) .GT. CUTLO ) GO TO 75 >*/ #line 3444 "cl2.f" L70: #line 3444 "cl2.f" if ((r__1 = sx[i__], abs(r__1)) > cutlo) { #line 3444 "cl2.f" goto L75; #line 3444 "cl2.f" } /* COMMON CODE FOR PHASES 2 AND 4. */ /* IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. */ /*< 110 IF( ABS(SX(I)) .LE. XMAX ) GO TO 115 >*/ #line 3449 "cl2.f" L110: #line 3449 "cl2.f" if ((r__1 = sx[i__], abs(r__1)) <= xmax) { #line 3449 "cl2.f" goto L115; #line 3449 "cl2.f" } /*< SUM = ONE + SUM * (XMAX / SX(I))**2 >*/ /* Computing 2nd power */ #line 3450 "cl2.f" r__1 = xmax / sx[i__]; #line 3450 "cl2.f" sum = one + sum * (r__1 * r__1); /*< XMAX = ABS(SX(I)) >*/ #line 3451 "cl2.f" xmax = (r__1 = sx[i__], abs(r__1)); /*< GO TO 200 >*/ #line 3452 "cl2.f" goto L200; /*< 115 SUM = SUM + (SX(I)/XMAX)**2 >*/ #line 3454 "cl2.f" L115: /* Computing 2nd power */ #line 3454 "cl2.f" r__1 = sx[i__] / xmax; #line 3454 "cl2.f" sum += r__1 * r__1; /*< GO TO 200 >*/ #line 3455 "cl2.f" goto L200; /* PREPARE FOR PHASE 3. */ /*< 75 SUM = (SUM * XMAX) * XMAX >*/ #line 3460 "cl2.f" L75: #line 3460 "cl2.f" sum = sum * xmax * xmax; /* FOR REAL OR D.P. SET HITEST = CUTHI/N */ /* FOR COMPLEX SET HITEST = CUTHI/(2*N) */ /*< 85 HITEST = CUTHI/FLOAT( N ) >*/ #line 3466 "cl2.f" L85: #line 3466 "cl2.f" hitest = cuthi / (real) (*n); /* PHASE 3. SUM IS MID-RANGE. NO SCALING. */ /*< DO 95 J =I,NN,INCX >*/ #line 3470 "cl2.f" i__1 = nn; #line 3470 "cl2.f" i__2 = *incx; #line 3470 "cl2.f" for (j = i__; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /*< IF(ABS(SX(J)) .GE. HITEST) GO TO 100 >*/ #line 3471 "cl2.f" if ((r__1 = sx[j], abs(r__1)) >= hitest) { #line 3471 "cl2.f" goto L100; #line 3471 "cl2.f" } /*< 95 SUM = SUM + SX(J)**2 >*/ #line 3472 "cl2.f" /* L95: */ /* Computing 2nd power */ #line 3472 "cl2.f" r__1 = sx[j]; #line 3472 "cl2.f" sum += r__1 * r__1; #line 3472 "cl2.f" } /*< SNRM2 = SQRT( SUM ) >*/ #line 3473 "cl2.f" ret_val = sqrt(sum); /*< GO TO 300 >*/ #line 3474 "cl2.f" goto L300; /*< 200 CONTINUE >*/ #line 3476 "cl2.f" L200: /*< I = I + INCX >*/ #line 3477 "cl2.f" i__ += *incx; /*< IF ( I .LE. NN ) GO TO 20 >*/ #line 3478 "cl2.f" if (i__ <= nn) { #line 3478 "cl2.f" goto L20; #line 3478 "cl2.f" } /* END OF MAIN LOOP. */ /* COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. */ /*< SNRM2 = XMAX * SQRT(SUM) >*/ #line 3484 "cl2.f" ret_val = xmax * sqrt(sum); /*< 300 CONTINUE >*/ #line 3485 "cl2.f" L300: /*< RETURN >*/ #line 3486 "cl2.f" return ret_val; /*< END >*/ } /* snrm2_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< REAL FUNCTION SASUM(N,SX,INCX) >*/ static real sasum_(integer *n, real *sx, integer *incx) { /* System generated locals */ integer i__1, i__2; real ret_val, r__1, r__2, r__3, r__4, r__5, r__6; /* Local variables */ static integer i__, m, ns, mp1; /* RETURNS SUM OF MAGNITUDES OF SINGLE PRECISION SX. */ /* END OF ABSTRACT */ /*< REAL SX(1) >*/ /*< SASUM = 0.0E0 >*/ #line 3498 "cl2.f" /* Parameter adjustments */ #line 3498 "cl2.f" --sx; #line 3498 "cl2.f" #line 3498 "cl2.f" /* Function Body */ #line 3498 "cl2.f" ret_val = 0.f; /*< IF(N.LE.0)RETURN >*/ #line 3499 "cl2.f" if (*n <= 0) { #line 3499 "cl2.f" return ret_val; #line 3499 "cl2.f" } /*< IF(INCX.EQ.1)GOTO 20 >*/ #line 3500 "cl2.f" if (*incx == 1) { #line 3500 "cl2.f" goto L20; #line 3500 "cl2.f" } /* CODE FOR INCREMENTS NOT EQUAL TO 1. */ /*< NS = N*INCX >*/ #line 3504 "cl2.f" ns = *n * *incx; /*< DO 10 I=1,NS,INCX >*/ #line 3505 "cl2.f" i__1 = ns; #line 3505 "cl2.f" i__2 = *incx; #line 3505 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< SASUM = SASUM + ABS(SX(I)) >*/ #line 3506 "cl2.f" ret_val += (r__1 = sx[i__], abs(r__1)); /*< 10 CONTINUE >*/ #line 3507 "cl2.f" /* L10: */ #line 3507 "cl2.f" } /*< RETURN >*/ #line 3508 "cl2.f" return ret_val; /* CODE FOR INCREMENTS EQUAL TO 1. */ /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. */ /*< 20 M = N - (N/6)*6 >*/ #line 3515 "cl2.f" L20: #line 3515 "cl2.f" m = *n - *n / 6 * 6; /*< IF( M .EQ. 0 ) GO TO 40 >*/ #line 3516 "cl2.f" if (m == 0) { #line 3516 "cl2.f" goto L40; #line 3516 "cl2.f" } /*< DO 30 I = 1,M >*/ #line 3517 "cl2.f" i__2 = m; #line 3517 "cl2.f" for (i__ = 1; i__ <= i__2; ++i__) { /*< SASUM = SASUM + ABS(SX(I)) >*/ #line 3518 "cl2.f" ret_val += (r__1 = sx[i__], abs(r__1)); /*< 30 CONTINUE >*/ #line 3519 "cl2.f" /* L30: */ #line 3519 "cl2.f" } /*< IF( N .LT. 6 ) RETURN >*/ #line 3520 "cl2.f" if (*n < 6) { #line 3520 "cl2.f" return ret_val; #line 3520 "cl2.f" } /*< 40 MP1 = M + 1 >*/ #line 3521 "cl2.f" L40: #line 3521 "cl2.f" mp1 = m + 1; /*< DO 50 I = MP1,N,6 >*/ #line 3522 "cl2.f" i__2 = *n; #line 3522 "cl2.f" for (i__ = mp1; i__ <= i__2; i__ += 6) { /*< >*/ #line 3523 "cl2.f" ret_val = ret_val + (r__1 = sx[i__], abs(r__1)) + (r__2 = sx[i__ + 1], abs(r__2)) + (r__3 = sx[i__ + 2], abs(r__3)) + (r__4 = sx[ i__ + 3], abs(r__4)) + (r__5 = sx[i__ + 4], abs(r__5)) + ( r__6 = sx[i__ + 5], abs(r__6)); /*< 50 CONTINUE >*/ #line 3525 "cl2.f" /* L50: */ #line 3525 "cl2.f" } /*< RETURN >*/ #line 3526 "cl2.f" return ret_val; /*< END >*/ } /* sasum_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE SSCAL(N,SA,SX,INCX) >*/ static /* Subroutine */ int sscal_(integer *n, real *sa, real *sx, integer *incx) { /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer i__, m, ns, mp1; /* REPLACE SINGLE PRECISION SX BY SINGLE PRECISION SA*SX. */ /* END OF ABSTRACT */ /*< REAL SA,SX(1) >*/ /*< IF(N.LE.0)RETURN >*/ #line 3538 "cl2.f" /* Parameter adjustments */ #line 3538 "cl2.f" --sx; #line 3538 "cl2.f" #line 3538 "cl2.f" /* Function Body */ #line 3538 "cl2.f" if (*n <= 0) { #line 3538 "cl2.f" return 0; #line 3538 "cl2.f" } /*< IF(INCX.EQ.1)GOTO 20 >*/ #line 3539 "cl2.f" if (*incx == 1) { #line 3539 "cl2.f" goto L20; #line 3539 "cl2.f" } /* CODE FOR INCREMENTS NOT EQUAL TO 1. */ /*< NS = N*INCX >*/ #line 3543 "cl2.f" ns = *n * *incx; /*< DO 10 I = 1,NS,INCX >*/ #line 3544 "cl2.f" i__1 = ns; #line 3544 "cl2.f" i__2 = *incx; #line 3544 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< SX(I) = SA*SX(I) >*/ #line 3545 "cl2.f" sx[i__] = *sa * sx[i__]; /*< 10 CONTINUE >*/ #line 3546 "cl2.f" /* L10: */ #line 3546 "cl2.f" } /*< RETURN >*/ #line 3547 "cl2.f" return 0; /* CODE FOR INCREMENTS EQUAL TO 1. */ /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. */ /*< 20 M = N - (N/5)*5 >*/ #line 3554 "cl2.f" L20: #line 3554 "cl2.f" m = *n - *n / 5 * 5; /*< IF( M .EQ. 0 ) GO TO 40 >*/ #line 3555 "cl2.f" if (m == 0) { #line 3555 "cl2.f" goto L40; #line 3555 "cl2.f" } /*< DO 30 I = 1,M >*/ #line 3556 "cl2.f" i__2 = m; #line 3556 "cl2.f" for (i__ = 1; i__ <= i__2; ++i__) { /*< SX(I) = SA*SX(I) >*/ #line 3557 "cl2.f" sx[i__] = *sa * sx[i__]; /*< 30 CONTINUE >*/ #line 3558 "cl2.f" /* L30: */ #line 3558 "cl2.f" } /*< IF( N .LT. 5 ) RETURN >*/ #line 3559 "cl2.f" if (*n < 5) { #line 3559 "cl2.f" return 0; #line 3559 "cl2.f" } /*< 40 MP1 = M + 1 >*/ #line 3560 "cl2.f" L40: #line 3560 "cl2.f" mp1 = m + 1; /*< DO 50 I = MP1,N,5 >*/ #line 3561 "cl2.f" i__2 = *n; #line 3561 "cl2.f" for (i__ = mp1; i__ <= i__2; i__ += 5) { /*< SX(I) = SA*SX(I) >*/ #line 3562 "cl2.f" sx[i__] = *sa * sx[i__]; /*< SX(I + 1) = SA*SX(I + 1) >*/ #line 3563 "cl2.f" sx[i__ + 1] = *sa * sx[i__ + 1]; /*< SX(I + 2) = SA*SX(I + 2) >*/ #line 3564 "cl2.f" sx[i__ + 2] = *sa * sx[i__ + 2]; /*< SX(I + 3) = SA*SX(I + 3) >*/ #line 3565 "cl2.f" sx[i__ + 3] = *sa * sx[i__ + 3]; /*< SX(I + 4) = SA*SX(I + 4) >*/ #line 3566 "cl2.f" sx[i__ + 4] = *sa * sx[i__ + 4]; /*< 50 CONTINUE >*/ #line 3567 "cl2.f" /* L50: */ #line 3567 "cl2.f" } /*< RETURN >*/ #line 3568 "cl2.f" return 0; /*< END >*/ } /* sscal_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< INTEGER FUNCTION ISAMAX(N,SX,INCX) >*/ static integer isamax_(integer *n, real *sx, integer *incx) { /* System generated locals */ integer ret_val, i__1, i__2; real r__1; /* Local variables */ static integer i__, ii, ns; static real xmag, smax; /* FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF SINGLE PRECISION SX. */ /* END OF ABSTRACT */ /*< REAL SX(1),SMAX,XMAG >*/ /*< ISAMAX = 0 >*/ #line 3580 "cl2.f" /* Parameter adjustments */ #line 3580 "cl2.f" --sx; #line 3580 "cl2.f" #line 3580 "cl2.f" /* Function Body */ #line 3580 "cl2.f" ret_val = 0; /*< IF(N.LE.0) RETURN >*/ #line 3581 "cl2.f" if (*n <= 0) { #line 3581 "cl2.f" return ret_val; #line 3581 "cl2.f" } /*< ISAMAX = 1 >*/ #line 3582 "cl2.f" ret_val = 1; /*< IF(N.LE.1)RETURN >*/ #line 3583 "cl2.f" if (*n <= 1) { #line 3583 "cl2.f" return ret_val; #line 3583 "cl2.f" } /*< IF(INCX.EQ.1)GOTO 20 >*/ #line 3584 "cl2.f" if (*incx == 1) { #line 3584 "cl2.f" goto L20; #line 3584 "cl2.f" } /* CODE FOR INCREMENTS NOT EQUAL TO 1. */ /*< SMAX = ABS(SX(1)) >*/ #line 3588 "cl2.f" smax = abs(sx[1]); /*< NS = N*INCX >*/ #line 3589 "cl2.f" ns = *n * *incx; /*< II = 1 >*/ #line 3590 "cl2.f" ii = 1; /*< DO 10 I=1,NS,INCX >*/ #line 3591 "cl2.f" i__1 = ns; #line 3591 "cl2.f" i__2 = *incx; #line 3591 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< XMAG = ABS(SX(I)) >*/ #line 3592 "cl2.f" xmag = (r__1 = sx[i__], abs(r__1)); /*< IF(XMAG.LE.SMAX) GO TO 5 >*/ #line 3593 "cl2.f" if (xmag <= smax) { #line 3593 "cl2.f" goto L5; #line 3593 "cl2.f" } /*< ISAMAX = II >*/ #line 3594 "cl2.f" ret_val = ii; /*< SMAX = XMAG >*/ #line 3595 "cl2.f" smax = xmag; /*< 5 II = II + 1 >*/ #line 3596 "cl2.f" L5: #line 3596 "cl2.f" ++ii; /*< 10 CONTINUE >*/ #line 3597 "cl2.f" /* L10: */ #line 3597 "cl2.f" } /*< RETURN >*/ #line 3598 "cl2.f" return ret_val; /* CODE FOR INCREMENTS EQUAL TO 1. */ /*< 20 SMAX = ABS(SX(1)) >*/ #line 3602 "cl2.f" L20: #line 3602 "cl2.f" smax = abs(sx[1]); /*< DO 30 I = 2,N >*/ #line 3603 "cl2.f" i__2 = *n; #line 3603 "cl2.f" for (i__ = 2; i__ <= i__2; ++i__) { /*< XMAG = ABS(SX(I)) >*/ #line 3604 "cl2.f" xmag = (r__1 = sx[i__], abs(r__1)); /*< IF(XMAG.LE.SMAX) GO TO 30 >*/ #line 3605 "cl2.f" if (xmag <= smax) { #line 3605 "cl2.f" goto L30; #line 3605 "cl2.f" } /*< ISAMAX = I >*/ #line 3606 "cl2.f" ret_val = i__; /*< SMAX = XMAG >*/ #line 3607 "cl2.f" smax = xmag; /*< 30 CONTINUE >*/ #line 3608 "cl2.f" L30: #line 3608 "cl2.f" ; #line 3608 "cl2.f" } /*< RETURN >*/ #line 3609 "cl2.f" return ret_val; /*< END >*/ } /* isamax_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) >*/ static real sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy) { /* System generated locals */ integer i__1, i__2; real ret_val; /* Local variables */ static integer i__, m, ix, iy, ns, mp1; /* RETURNS THE DOT PRODUCT OF SINGLE PRECISION SX AND SY. */ /*< REAL SX(1),SY(1) >*/ /*< SDOT = 0.0E0 >*/ #line 3619 "cl2.f" /* Parameter adjustments */ #line 3619 "cl2.f" --sy; #line 3619 "cl2.f" --sx; #line 3619 "cl2.f" #line 3619 "cl2.f" /* Function Body */ #line 3619 "cl2.f" ret_val = 0.f; /*< IF(N.LE.0)RETURN >*/ #line 3620 "cl2.f" if (*n <= 0) { #line 3620 "cl2.f" return ret_val; #line 3620 "cl2.f" } /*< IF(INCX.EQ.INCY) IF(INCX-1)5,20,60 >*/ #line 3621 "cl2.f" if (*incx == *incy) { #line 3621 "cl2.f" if ((i__1 = *incx - 1) < 0) { #line 3621 "cl2.f" goto L5; #line 3621 "cl2.f" } else if (i__1 == 0) { #line 3621 "cl2.f" goto L20; #line 3621 "cl2.f" } else { #line 3621 "cl2.f" goto L60; #line 3621 "cl2.f" } #line 3621 "cl2.f" } /*< 5 CONTINUE >*/ #line 3622 "cl2.f" L5: /* CODE FOR UNEQUAL INCREMENTS OR NONPOSITIVE INCREMENTS. */ /*< IX = 1 >*/ #line 3626 "cl2.f" ix = 1; /*< IY = 1 >*/ #line 3627 "cl2.f" iy = 1; /*< IF(INCX.LT.0)IX = (-N+1)*INCX + 1 >*/ #line 3628 "cl2.f" if (*incx < 0) { #line 3628 "cl2.f" ix = (-(*n) + 1) * *incx + 1; #line 3628 "cl2.f" } /*< IF(INCY.LT.0)IY = (-N+1)*INCY + 1 >*/ #line 3629 "cl2.f" if (*incy < 0) { #line 3629 "cl2.f" iy = (-(*n) + 1) * *incy + 1; #line 3629 "cl2.f" } /*< DO 10 I = 1,N >*/ #line 3630 "cl2.f" i__1 = *n; #line 3630 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< SDOT = SDOT + SX(IX)*SY(IY) >*/ #line 3631 "cl2.f" ret_val += sx[ix] * sy[iy]; /*< IX = IX + INCX >*/ #line 3632 "cl2.f" ix += *incx; /*< IY = IY + INCY >*/ #line 3633 "cl2.f" iy += *incy; /*< 10 CONTINUE >*/ #line 3634 "cl2.f" /* L10: */ #line 3634 "cl2.f" } /*< RETURN >*/ #line 3635 "cl2.f" return ret_val; /* CODE FOR BOTH INCREMENTS EQUAL TO 1 */ /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. */ /*< 20 M = N - (N/5)*5 >*/ #line 3642 "cl2.f" L20: #line 3642 "cl2.f" m = *n - *n / 5 * 5; /*< IF( M .EQ. 0 ) GO TO 40 >*/ #line 3643 "cl2.f" if (m == 0) { #line 3643 "cl2.f" goto L40; #line 3643 "cl2.f" } /*< DO 30 I = 1,M >*/ #line 3644 "cl2.f" i__1 = m; #line 3644 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< SDOT = SDOT + SX(I)*SY(I) >*/ #line 3645 "cl2.f" ret_val += sx[i__] * sy[i__]; /*< 30 CONTINUE >*/ #line 3646 "cl2.f" /* L30: */ #line 3646 "cl2.f" } /*< IF( N .LT. 5 ) RETURN >*/ #line 3647 "cl2.f" if (*n < 5) { #line 3647 "cl2.f" return ret_val; #line 3647 "cl2.f" } /*< 40 MP1 = M + 1 >*/ #line 3648 "cl2.f" L40: #line 3648 "cl2.f" mp1 = m + 1; /*< DO 50 I = MP1,N,5 >*/ #line 3649 "cl2.f" i__1 = *n; #line 3649 "cl2.f" for (i__ = mp1; i__ <= i__1; i__ += 5) { /*< >*/ #line 3650 "cl2.f" ret_val = ret_val + sx[i__] * sy[i__] + sx[i__ + 1] * sy[i__ + 1] + sx[i__ + 2] * sy[i__ + 2] + sx[i__ + 3] * sy[i__ + 3] + sx[ i__ + 4] * sy[i__ + 4]; /*< 50 CONTINUE >*/ #line 3652 "cl2.f" /* L50: */ #line 3652 "cl2.f" } /*< RETURN >*/ #line 3653 "cl2.f" return ret_val; /* CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. */ /*< 60 CONTINUE >*/ #line 3657 "cl2.f" L60: /*< NS=N*INCX >*/ #line 3658 "cl2.f" ns = *n * *incx; /*< DO 70 I=1,NS,INCX >*/ #line 3659 "cl2.f" i__1 = ns; #line 3659 "cl2.f" i__2 = *incx; #line 3659 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< SDOT = SDOT + SX(I)*SY(I) >*/ #line 3660 "cl2.f" ret_val += sx[i__] * sy[i__]; /*< 70 CONTINUE >*/ #line 3661 "cl2.f" /* L70: */ #line 3661 "cl2.f" } /*< RETURN >*/ #line 3662 "cl2.f" return ret_val; /*< END >*/ } /* sdot_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) >*/ static /* Subroutine */ int saxpy_(integer *n, real *sa, real *sx, integer *incx, real *sy, integer *incy) { /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer i__, m, ix, iy, ns, mp1; /* OVERWRITE SINGLE PRECISION SY WITH SINGLE PRECISION SA*SX +SY. */ /*< REAL SX(1),SY(1),SA >*/ /*< IF(N.LE.0.OR.SA.EQ.0.E0) RETURN >*/ #line 3672 "cl2.f" /* Parameter adjustments */ #line 3672 "cl2.f" --sy; #line 3672 "cl2.f" --sx; #line 3672 "cl2.f" #line 3672 "cl2.f" /* Function Body */ #line 3672 "cl2.f" if (*n <= 0 || *sa == 0.f) { #line 3672 "cl2.f" return 0; #line 3672 "cl2.f" } /*< IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 >*/ #line 3673 "cl2.f" if (*incx == *incy) { #line 3673 "cl2.f" if ((i__1 = *incx - 1) < 0) { #line 3673 "cl2.f" goto L5; #line 3673 "cl2.f" } else if (i__1 == 0) { #line 3673 "cl2.f" goto L20; #line 3673 "cl2.f" } else { #line 3673 "cl2.f" goto L60; #line 3673 "cl2.f" } #line 3673 "cl2.f" } /*< 5 CONTINUE >*/ #line 3674 "cl2.f" L5: /* CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. */ /*< IX = 1 >*/ #line 3678 "cl2.f" ix = 1; /*< IY = 1 >*/ #line 3679 "cl2.f" iy = 1; /*< IF(INCX.LT.0)IX = (-N+1)*INCX + 1 >*/ #line 3680 "cl2.f" if (*incx < 0) { #line 3680 "cl2.f" ix = (-(*n) + 1) * *incx + 1; #line 3680 "cl2.f" } /*< IF(INCY.LT.0)IY = (-N+1)*INCY + 1 >*/ #line 3681 "cl2.f" if (*incy < 0) { #line 3681 "cl2.f" iy = (-(*n) + 1) * *incy + 1; #line 3681 "cl2.f" } /*< DO 10 I = 1,N >*/ #line 3682 "cl2.f" i__1 = *n; #line 3682 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< SY(IY) = SY(IY) + SA*SX(IX) >*/ #line 3683 "cl2.f" sy[iy] += *sa * sx[ix]; /*< IX = IX + INCX >*/ #line 3684 "cl2.f" ix += *incx; /*< IY = IY + INCY >*/ #line 3685 "cl2.f" iy += *incy; /*< 10 CONTINUE >*/ #line 3686 "cl2.f" /* L10: */ #line 3686 "cl2.f" } /*< RETURN >*/ #line 3687 "cl2.f" return 0; /* CODE FOR BOTH INCREMENTS EQUAL TO 1 */ /* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. */ /*< 20 M = N - (N/4)*4 >*/ #line 3694 "cl2.f" L20: #line 3694 "cl2.f" m = *n - (*n / 4 << 2); /*< IF( M .EQ. 0 ) GO TO 40 >*/ #line 3695 "cl2.f" if (m == 0) { #line 3695 "cl2.f" goto L40; #line 3695 "cl2.f" } /*< DO 30 I = 1,M >*/ #line 3696 "cl2.f" i__1 = m; #line 3696 "cl2.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< SY(I) = SY(I) + SA*SX(I) >*/ #line 3697 "cl2.f" sy[i__] += *sa * sx[i__]; /*< 30 CONTINUE >*/ #line 3698 "cl2.f" /* L30: */ #line 3698 "cl2.f" } /*< IF( N .LT. 4 ) RETURN >*/ #line 3699 "cl2.f" if (*n < 4) { #line 3699 "cl2.f" return 0; #line 3699 "cl2.f" } /*< 40 MP1 = M + 1 >*/ #line 3700 "cl2.f" L40: #line 3700 "cl2.f" mp1 = m + 1; /*< DO 50 I = MP1,N,4 >*/ #line 3701 "cl2.f" i__1 = *n; #line 3701 "cl2.f" for (i__ = mp1; i__ <= i__1; i__ += 4) { /*< SY(I) = SY(I) + SA*SX(I) >*/ #line 3702 "cl2.f" sy[i__] += *sa * sx[i__]; /*< SY(I + 1) = SY(I + 1) + SA*SX(I + 1) >*/ #line 3703 "cl2.f" sy[i__ + 1] += *sa * sx[i__ + 1]; /*< SY(I + 2) = SY(I + 2) + SA*SX(I + 2) >*/ #line 3704 "cl2.f" sy[i__ + 2] += *sa * sx[i__ + 2]; /*< SY(I + 3) = SY(I + 3) + SA*SX(I + 3) >*/ #line 3705 "cl2.f" sy[i__ + 3] += *sa * sx[i__ + 3]; /*< 50 CONTINUE >*/ #line 3706 "cl2.f" /* L50: */ #line 3706 "cl2.f" } /*< RETURN >*/ #line 3707 "cl2.f" return 0; /* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. */ /*< 60 CONTINUE >*/ #line 3711 "cl2.f" L60: /*< NS = N*INCX >*/ #line 3712 "cl2.f" ns = *n * *incx; /*< DO 70 I=1,NS,INCX >*/ #line 3713 "cl2.f" i__1 = ns; #line 3713 "cl2.f" i__2 = *incx; #line 3713 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< SY(I) = SA*SX(I) + SY(I) >*/ #line 3714 "cl2.f" sy[i__] = *sa * sx[i__] + sy[i__]; /*< 70 CONTINUE >*/ #line 3715 "cl2.f" /* L70: */ #line 3715 "cl2.f" } /*< RETURN >*/ #line 3716 "cl2.f" return 0; /*< END >*/ } /* saxpy_ */ /* CC */ /* CC---------------------------------------------------------------------------- */ /* CC */ /*< SUBROUTINE SROTM (N,SX,INCX,SY,INCY,SPARAM) >*/ static /* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy, integer *incy, real *sparam) { /* Initialized data */ static real zero = 0.f; static real two = 2.f; /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer i__; static real w, z__; static integer kx, ky; static real sh11, sh12, sh21, sh22, sflag; static integer nsteps; /* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ /* (SX(1) SX(N)) */ /* ( ... ) */ /* (SY(1) SY(N)) */ /* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ /* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ /* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ /* H=( ) ( ) ( ) ( ) */ /* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ /*< DIMENSION SX(1),SY(1),SPARAM(5) >*/ /*< DATA ZERO,TWO /0.E0,2.E0/ >*/ #line 3738 "cl2.f" /* Parameter adjustments */ #line 3738 "cl2.f" --sparam; #line 3738 "cl2.f" --sy; #line 3738 "cl2.f" --sx; #line 3738 "cl2.f" #line 3738 "cl2.f" /* Function Body */ /*< SFLAG=SPARAM(1) >*/ #line 3740 "cl2.f" sflag = sparam[1]; /*< IF(N .LE. 0 .OR.(SFLAG+TWO.EQ.ZERO)) GO TO 140 >*/ #line 3741 "cl2.f" if (*n <= 0 || sflag + two == zero) { #line 3741 "cl2.f" goto L140; #line 3741 "cl2.f" } /*< IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 >*/ #line 3742 "cl2.f" if (! (*incx == *incy && *incx > 0)) { #line 3742 "cl2.f" goto L70; #line 3742 "cl2.f" } /*< NSTEPS=N*INCX >*/ #line 3744 "cl2.f" nsteps = *n * *incx; /*< IF(SFLAG) 50,10,30 >*/ #line 3745 "cl2.f" if (sflag < 0.f) { #line 3745 "cl2.f" goto L50; #line 3745 "cl2.f" } else if (sflag == 0) { #line 3745 "cl2.f" goto L10; #line 3745 "cl2.f" } else { #line 3745 "cl2.f" goto L30; #line 3745 "cl2.f" } /*< 10 CONTINUE >*/ #line 3746 "cl2.f" L10: /*< SH12=SPARAM(4) >*/ #line 3747 "cl2.f" sh12 = sparam[4]; /*< SH21=SPARAM(3) >*/ #line 3748 "cl2.f" sh21 = sparam[3]; /*< DO 20 I=1,NSTEPS,INCX >*/ #line 3749 "cl2.f" i__1 = nsteps; #line 3749 "cl2.f" i__2 = *incx; #line 3749 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< W=SX(I) >*/ #line 3750 "cl2.f" w = sx[i__]; /*< Z=SY(I) >*/ #line 3751 "cl2.f" z__ = sy[i__]; /*< SX(I)=W+Z*SH12 >*/ #line 3752 "cl2.f" sx[i__] = w + z__ * sh12; /*< SY(I)=W*SH21+Z >*/ #line 3753 "cl2.f" sy[i__] = w * sh21 + z__; /*< 20 CONTINUE >*/ #line 3754 "cl2.f" /* L20: */ #line 3754 "cl2.f" } /*< GO TO 140 >*/ #line 3755 "cl2.f" goto L140; /*< 30 CONTINUE >*/ #line 3756 "cl2.f" L30: /*< SH11=SPARAM(2) >*/ #line 3757 "cl2.f" sh11 = sparam[2]; /*< SH22=SPARAM(5) >*/ #line 3758 "cl2.f" sh22 = sparam[5]; /*< DO 40 I=1,NSTEPS,INCX >*/ #line 3759 "cl2.f" i__2 = nsteps; #line 3759 "cl2.f" i__1 = *incx; #line 3759 "cl2.f" for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { /*< W=SX(I) >*/ #line 3760 "cl2.f" w = sx[i__]; /*< Z=SY(I) >*/ #line 3761 "cl2.f" z__ = sy[i__]; /*< SX(I)=W*SH11+Z >*/ #line 3762 "cl2.f" sx[i__] = w * sh11 + z__; /*< SY(I)=-W+SH22*Z >*/ #line 3763 "cl2.f" sy[i__] = -w + sh22 * z__; /*< 40 CONTINUE >*/ #line 3764 "cl2.f" /* L40: */ #line 3764 "cl2.f" } /*< GO TO 140 >*/ #line 3765 "cl2.f" goto L140; /*< 50 CONTINUE >*/ #line 3766 "cl2.f" L50: /*< SH11=SPARAM(2) >*/ #line 3767 "cl2.f" sh11 = sparam[2]; /*< SH12=SPARAM(4) >*/ #line 3768 "cl2.f" sh12 = sparam[4]; /*< SH21=SPARAM(3) >*/ #line 3769 "cl2.f" sh21 = sparam[3]; /*< SH22=SPARAM(5) >*/ #line 3770 "cl2.f" sh22 = sparam[5]; /*< DO 60 I=1,NSTEPS,INCX >*/ #line 3771 "cl2.f" i__1 = nsteps; #line 3771 "cl2.f" i__2 = *incx; #line 3771 "cl2.f" for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { /*< W=SX(I) >*/ #line 3772 "cl2.f" w = sx[i__]; /*< Z=SY(I) >*/ #line 3773 "cl2.f" z__ = sy[i__]; /*< SX(I)=W*SH11+Z*SH12 >*/ #line 3774 "cl2.f" sx[i__] = w * sh11 + z__ * sh12; /*< SY(I)=W*SH21+Z*SH22 >*/ #line 3775 "cl2.f" sy[i__] = w * sh21 + z__ * sh22; /*< 60 CONTINUE >*/ #line 3776 "cl2.f" /* L60: */ #line 3776 "cl2.f" } /*< GO TO 140 >*/ #line 3777 "cl2.f" goto L140; /*< 70 CONTINUE >*/ #line 3778 "cl2.f" L70: /*< KX=1 >*/ #line 3779 "cl2.f" kx = 1; /*< KY=1 >*/ #line 3780 "cl2.f" ky = 1; /*< IF(INCX .LT. 0) KX=1+(1-N)*INCX >*/ #line 3781 "cl2.f" if (*incx < 0) { #line 3781 "cl2.f" kx = (1 - *n) * *incx + 1; #line 3781 "cl2.f" } /*< IF(INCY .LT. 0) KY=1+(1-N)*INCY >*/ #line 3782 "cl2.f" if (*incy < 0) { #line 3782 "cl2.f" ky = (1 - *n) * *incy + 1; #line 3782 "cl2.f" } /*< IF(SFLAG)120,80,100 >*/ #line 3784 "cl2.f" if (sflag < 0.f) { #line 3784 "cl2.f" goto L120; #line 3784 "cl2.f" } else if (sflag == 0) { #line 3784 "cl2.f" goto L80; #line 3784 "cl2.f" } else { #line 3784 "cl2.f" goto L100; #line 3784 "cl2.f" } /*< 80 CONTINUE >*/ #line 3785 "cl2.f" L80: /*< SH12=SPARAM(4) >*/ #line 3786 "cl2.f" sh12 = sparam[4]; /*< SH21=SPARAM(3) >*/ #line 3787 "cl2.f" sh21 = sparam[3]; /*< DO 90 I=1,N >*/ #line 3788 "cl2.f" i__2 = *n; #line 3788 "cl2.f" for (i__ = 1; i__ <= i__2; ++i__) { /*< W=SX(KX) >*/ #line 3789 "cl2.f" w = sx[kx]; /*< Z=SY(KY) >*/ #line 3790 "cl2.f" z__ = sy[ky]; /*< SX(KX)=W+Z*SH12 >*/ #line 3791 "cl2.f" sx[kx] = w + z__ * sh12; /*< SY(KY)=W*SH21+Z >*/ #line 3792 "cl2.f" sy[ky] = w * sh21 + z__; /*< KX=KX+INCX >*/ #line 3793 "cl2.f" kx += *incx; /*< KY=KY+INCY >*/ #line 3794 "cl2.f" ky += *incy; /*< 90 CONTINUE >*/ #line 3795 "cl2.f" /* L90: */ #line 3795 "cl2.f" } /*< GO TO 140 >*/ #line 3796 "cl2.f" goto L140; /*< 100 CONTINUE >*/ #line 3797 "cl2.f" L100: /*< SH11=SPARAM(2) >*/ #line 3798 "cl2.f" sh11 = sparam[2]; /*< SH22=SPARAM(5) >*/ #line 3799 "cl2.f" sh22 = sparam[5]; /*< DO 110 I=1,N >*/ #line 3800 "cl2.f" i__2 = *n; #line 3800 "cl2.f" for (i__ = 1; i__ <= i__2; ++i__) { /*< W=SX(KX) >*/ #line 3801 "cl2.f" w = sx[kx]; /*< Z=SY(KY) >*/ #line 3802 "cl2.f" z__ = sy[ky]; /*< SX(KX)=W*SH11+Z >*/ #line 3803 "cl2.f" sx[kx] = w * sh11 + z__; /*< SY(KY)=-W+SH22*Z >*/ #line 3804 "cl2.f" sy[ky] = -w + sh22 * z__; /*< KX=KX+INCX >*/ #line 3805 "cl2.f" kx += *incx; /*< KY=KY+INCY >*/ #line 3806 "cl2.f" ky += *incy; /*< 110 CONTINUE >*/ #line 3807 "cl2.f" /* L110: */ #line 3807 "cl2.f" } /*< GO TO 140 >*/ #line 3808 "cl2.f" goto L140; /*< 120 CONTINUE >*/ #line 3809 "cl2.f" L120: /*< SH11=SPARAM(2) >*/ #line 3810 "cl2.f" sh11 = sparam[2]; /*< SH12=SPARAM(4) >*/ #line 3811 "cl2.f" sh12 = sparam[4]; /*< SH21=SPARAM(3) >*/ #line 3812 "cl2.f" sh21 = sparam[3]; /*< SH22=SPARAM(5) >*/ #line 3813 "cl2.f" sh22 = sparam[5]; /*< DO 130 I=1,N >*/ #line 3814 "cl2.f" i__2 = *n; #line 3814 "cl2.f" for (i__ = 1; i__ <= i__2; ++i__) { /*< W=SX(KX) >*/ #line 3815 "cl2.f" w = sx[kx]; /*< Z=SY(KY) >*/ #line 3816 "cl2.f" z__ = sy[ky]; /*< SX(KX)=W*SH11+Z*SH12 >*/ #line 3817 "cl2.f" sx[kx] = w * sh11 + z__ * sh12; /*< SY(KY)=W*SH21+Z*SH22 >*/ #line 3818 "cl2.f" sy[ky] = w * sh21 + z__ * sh22; /*< KX=KX+INCX >*/ #line 3819 "cl2.f" kx += *incx; /*< KY=KY+INCY >*/ #line 3820 "cl2.f" ky += *incy; /*< 130 CONTINUE >*/ #line 3821 "cl2.f" /* L130: */ #line 3821 "cl2.f" } /*< 140 CONTINUE >*/ #line 3822 "cl2.f" L140: /*< RETURN >*/ #line 3823 "cl2.f" return 0; /*< END >*/ } /* srotm_ */