/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:30:06 */ /*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */ #include #include "fcrt.h" #include "dprtsv.h" #include #include #include void /*FUNCTION*/ dprtsv( double *a, long mda, long m, long n, char *names, int names_s, long mode, long unit, long width) { #define A(I_,J_) (*(a+(I_)*(mda)+(J_))) #define NAMES(I_,J_) (names+(I_)*(names_s)+(J_)) LOGICAL32 blknam; long int i, j2, l, lennam, maxcol, namsiz, nblock; static char head1a[54] = " V-Matrix of the Singular Value Decomposition of A*D."; static char head1b[48] = " (Elements of V scaled up by a factor of 10**4)"; static char head2[56] = " Sequence of candidate solutions, X "; static char head[2][5]={" COL","SOLN"}; /* Copyright (c) 1996 California Institute of Technology, Pasadena, CA. * ALL RIGHTS RESERVED. * Based on Government Sponsored Research NAS7-03001. *>> 2008-11-26 DPRTSV Krogh Changed FMT2 for Fortran standard change *>> 2008-11-26 DPRTSV Krogh in how P and F interact in formats. *>> 2001-06-08 DPRTSV Krogh Increased length of FMT1 and FMT2. *>> 2001-05-25 DPRTSV Krogh Added a comma in a format. *>> 2001-01-16 DPRTSV Krogh Minor fix for fussy C compilers. *>> 1996-06-27 DPRTSV Krogh Changes to use .C. and C%%. *>> 1996-01-23 DPRTSV Krogh Got in code for C conversion. *>> 1994-10-20 DPRTSV Krogh Changes to use M77CON *>> 1992-03-22 DPRTSV CAO Deleted 4 debug statements *>> 1992-03-18 CLL Allow user to choose size of names in NAMES(). *>> 1989-03-07 DPRTSV CLL Added arguments UNIT and WIDTH *>> 1987-11-24 DPRTSV Lawson Initial code. * Prints matrix with labeling, to be called by the Singular Value * Analysis subroutine, [D/S]SVA. * ------------------------------------------------------------------ * Subroutine Arguments * All are inout arguments. None are modified by this subroutine. * * A(,) Array containing matrix to be output. * MDA First dimension of the array, A(,). * M, N No. of rows and columns, respectively in the matrix * contained in A(,). * NAMES() [character array] Array of names. * If NAMES(1) contains only blanks, the rest of the NAMES() * array will be ignored. * MODE =1 Write header for V matrix and use an F format. * =2 Write header for the candidate solutions and use * G format. * UNIT [integer] Selects output unit. If UNIT .ge. 0 then UNIT * is the output unit number. If UNIT = -1, output to * the '*' unit. * WIDTH [integer] Selects width of output lines. * Each output line from this subroutine will have at most * max(26,min(124,WIDTH)) characters plus one additional * leading character for Fortran "carriage control". The * carriage control character will always be a blank. * ------------------------------------------------------------------ * This code was originally developed by Charles L. Lawson and * Richard J. Hanson at Jet Propulsion Laboratory in 1973. The * original code was described and listed in the book, * * Solving Least Squares Problems * C. L. Lawson and R. J. Hanson * Prentice-Hall, 1974 * * Feb 1985, Mar 1987, C. L. Lawson & S. Y. Chan, JPL. * Adapted code from the Lawson & Hanson book to Fortran 77 for use * in the JPL MATH77 library. * Prefixing subprogram names with S or D for s.p. or d.p. versions. * Using generic names for intrinsic functions. * Adding calls to BLAS and MATH77 error processing subrs in some * program units. * ------------------------------------------------------------------ *--D replaces "?": ?PRTSV * ------------------------------------------------------------------ */ /*++ Code for .C. is ACTIVE */ long int j, j1, kblock; /*++ Code for ~.C. is INACTIVE * integer J, J1, KBLOCK * logical STAR * character*27 FMT1(2) * character*26 FMT2(2) * data FMT1 / '(/7x,00x,8(5x,a4,i4,1x)/)', * * '(/7x,00x,8(2x,a4,i4,4x)/)'/ * data FMT2 / '(1x,i4,1x,a00,1x,8f14.0)', * * '(1x,i4,1x,a00,1x,8g14.6 )'/ *++ End */ /* ------------------------------------------------------------------ */ if (m <= 0 || n <= 0) return; /* The LEN function returns the char length of a single element of * the NAMES() array. * */ namsiz = 1; /*++ code for ~.C. is INACTIVE * BLKNAM = NAMES(1) .eq. ' ' * LENNAM = len(NAMES(1)) *++ code for .C. is ACTIVE */ lennam = names_s; blknam = ((int)strspn(NAMES(0,0), " ") == lennam); if (!blknam) { /*++ End */ for (i = 1; i <= m; i++) { for (l = lennam; l >= (namsiz + 1); l--) { if (NAMES(i - 1,0)[l - 1] != ' ') { namsiz = l; goto L_20; } } L_20: ; } } /*++ Code for ~.C. is INACTIVE * write(FMT1(MODE)(6:7),'(i2.2)') NAMSIZ * write(FMT2(MODE)(12:13),'(i2.2)') NAMSIZ * STAR = UNIT .lt. 0 * if(STAR) then *++ End */ if (mode == 1) { printf("\n%s\n%s\n", head1a, head1b); } else { printf("\n%s\n", head2); } /*++ Code for ~.C. is INACTIVE * else * if (MODE .eq. 1) then * write (UNIT,'(/a/a)') HEAD1A, HEAD1B * else * write (UNIT,'(/a)') HEAD2 * endif * endif *++ End * * With NAMSIZ characters allowed for the "name" and MAXCOL * columns of numbers, the total line width, exclusive of a * carriage control character, will be 6 + LENNAM + 14 * MAXCOL. * */ maxcol = max( 1, min( 8, (width - 6 - namsiz)/14 ) ); nblock = (n + maxcol - 1)/maxcol; j2 = 0; /*++ Code for ~.C. is INACTIVE * do 50 KBLOCK = 1, NBLOCK * J1 = J2 + 1 * J2 = min(N, J2 + MAXCOL) * if(STAR) then * write (*,FMT1(MODE)) (HEAD(MODE),J,J=J1,J2) * else * write (UNIT,FMT1(MODE)) (HEAD(MODE),J,J=J1,J2) * endif *C * do 40 I=1,M * if(STAR) then * if(BLKNAM) then * if (MODE .eq. 1) then * write (*,FMT2(1)) I,' ',(1.D4*A(I,J),J=J1,J2) * else * write (*,FMT2(2)) I,' ',(A(I,J),J=J1,J2) * end if * else * if (MODE .eq. 1) then * write (*,FMT2(1)) I,NAMES(I),(1.D4*A(I,J),J=J1,J2) * else * write (*,FMT2(2)) I,NAMES(I),(A(I,J),J=J1,J2) * end if * endif * else * if(BLKNAM) then * write (UNIT,FMT2(MODE)) I,' ',(A(I,J),J=J1,J2) * else * write (UNIT,FMT2(MODE)) I,NAMES(I),(1.D4*A(I,J),J=J1,J2) * endif * endif * 40 continue * 50 continue *C *++ Code for .C. is ACTIVE */ for( kblock = 1L; kblock <= nblock; kblock++ ){ j1 = j2 + 1L; j2 = min( n, j2 + maxcol ); if( mode == 1L ){ printf("\n %*s", (int)namsiz, " "); for( j = j1; j <= j2; j++ ){ printf(" %4.4s%4ld ", head[0L], j); } printf("\n"); for( i = 1L; i <= m; i++ ){ if( blknam ){ printf(" %4ld %*s ", i, (int)namsiz, " "); for( j = j1; j <= j2; j++ ){ printf("%14.0f.", 1.0e4*A(j-1L,i-1L)); } printf("\n"); } else{ printf(" %4ld %-*.*s ", i, (int)namsiz, (int)namsiz, NAMES(i-1L,0L)); for( j = j1; j <= j2; j++ ){ printf("%14.0f.", 1.0e4*A(j-1L,i-1L)); } printf("\n"); } } } else{ printf("\n %*s", (int)namsiz, " "); for( j = j1; j <= j2; j++ ){ printf(" %4.4s%4ld", head[1L], j); } printf("\n"); for( i = 1L; i <= m; i++ ){ if( blknam ){ printf(" %4ld %*s ", i, (int)namsiz, " "); for( j = j1; j <= j2; j++ ){ printf("%14.6g", A(j - 1L,i - 1L)); } printf("\n"); } else{ printf(" %4ld %-*.*s", i, (int)namsiz, (int)namsiz, NAMES(i-1L,0L)); printf(" "); for( j = j1; j <= j2; j++ ){ printf("%14.6g", A(j - 1L,i - 1L)); } printf("\n"); } } } /* endif !(MODE...) */ } /* end for kblock */ return; #undef NAMES #undef A } /* end of function */ /*++ End */