Newsgroups: comp.lang.apl
Path: watmath!watserv2.uwaterloo.ca!torn!howland.reston.ans.net!darwin.sura.net!news-feed-1.peachnet.edu!umn.edu!csus.edu!sfsuvax1.sfsu.edu!vpcsc4
From: vpcsc4@sfsuvax1.sfsu.edu (Emmett McLean)
Subject: svd and LinkJ : An example
Message-ID: <1993May4.230746.21063@csus.edu>
Sender: news@csus.edu
Organization: San Francisco State University
Date: Tue, 4 May 1993 23:07:46 GMT
Lines: 486


Here is a start on an svd routine for J.
Feel free to make suggestions.

Aside from the matrix in the sample run this has not
been rigorously tested.

Attached are :

1. a sample run,
2. the associated LinkJ
3. svd.c (thanks to Bob Craig at kat3@ihlpe.att.com)

Emmett

$ j
   c =. |:"2@>:@i. 3 5
   c
1  6 11
2  7 12
3  8 13
4  9 14
5 10 15
   10!:0 c
+-------------------------------+-----------+-----------------------------+
|_0.354557  _0.688687   0.624735|    35.1272|_0.201665  0.890317 _0.408248|
|_0.398696  _0.375555  _0.539982|     2.4654|_0.516831  0.257332  0.816497|
|_0.442836 _0.0624224  _0.432713|2.50334e_16|_0.831996 _0.375654 _0.408248|
|_0.486975    0.25071 _0.0135666|          0|        0         0         0|
|_0.531114   0.563842   0.361527|          0|        0         0         0|
+-------------------------------+-----------+-----------------------------+
  
===================main.c======================== 
#include <stdio.h>
#include <string.h>
#include "lj.h"
#include <math.h>
typedef enum boolean { false, true} boolean;
#define max(x,y) (x>y)?x:y

static F1(svdcall){A u,v,sigma,z, *pvz;
	I i, j, m, n, nm;
	int h, svd();
    m = AS(y)[0];
    n = AS(y)[1];
    nm = max(n,m);

    ASSERT((BOOL+INT+FL)&AT(y),EVDOMAIN);
    ASSERT(2==AR(y),EVRANK);
    if(FL!=AT(y))y=(A)cvt(FL,y); 
    RZ(u=jma(FL,(n*m),2L));
    RZ(v=jma(FL,(n*m),2L));
    AS(v)[0]=AS(u)[0]=nm;
    AS(v)[1]=AS(u)[1]=n;
    RZ(sigma=jma(FL,m,2L));
    AS(sigma)[0]=m; AS(sigma)[1]=1L;

	h = svd(m, n, nm, AV(y), AV(sigma), true, AV(u), true,AV(v));
    RZ(z=jma(BOX,3L,1L));
    AS(z)[0]=3L;
    pvz=(A*)AV(z);
    *pvz++=u;
    *pvz++=sigma;
    *pvz++=v;
     R z;
}

C jc(k,f1,f2)I k;AF*f1,*f2;
{ switch(k){
  case 0:
   *f1=svdcall;                  /* monad of 10!:0                          */
   *f2=NULL;                     /* dyad  of 10!:0                          */
   R 1;                         /* indicate no error                       */
  default:
   ASSERT(0,EVNONCE);           /* 10!:k where k is not 0. error for now.  */
  }
}

main()
{A t;C s[456];
 jinit();
 while(1)
 {
  printf("   ");
  if(NULL==gets(s)||'\004'==*(s+strlen(s)-1))exit(0);
  t=jx(s);
  if(jerr)printf("jerr: %d\n",jerr); else if(!asgn)jpr(t);
 }
}
===================svd.c======================== 
#define MAX(X,Y)    (X>Y) ? X:Y
#define SIGN(X,Y)    ((Y<0) ? -fabs(X):fabs(X))
extern char *malloc();
extern void free();

typedef enum boolean { false, true} boolean;

/*
   constant which limits the number of iterations to determine
   the singular values.
*/

#define MAXIT 30

int
svd(m, n, nm, a, w, matu, u, matv, v)
int m, n, nm;
double *a, *w, *u, *v;
boolean matu, matv;
{

	/*
	  This function is a translation of the algol procedure svd.
	  Num. Math. 14, 403-420(1970) by Golub and Reinsch.  Handbook
	  for Auto. Comp., Vol 2-Linear Algebra, 143-151 (1971).

	  The function determines the singular value decomposition
	        a = usv'
	  of a real m by n rectangular matrix.  Housholder
	  bidiagonalization and a variant of the qr algorithm are used.

	  Input: nm = row dimension of two dimensional array parameters
	            as declared in the calling program.  Note that
	            nm must be at least as large as the max of n
	            and m.
	         m = number of rows in a (and u).
	         n = number of columns in a (and u) and the order of v.
	         a = the rectangular input matrix to be decomposed
	            [nm by n].
	         matu = true if the u matrix in the decomposition is
	            required, and false otherwise.
	         matv = true if the v matrix in the decomposition is
	            required, and false otherwise.

	  Output: a = unaltered unless overwritten by u or v.
	          w = the n (non-negative) singular values of a (the
	            diagonal elements of s).  They are unordered.
	            if an error return is made, the singular values
	            should be correct for return_value,
	            return_value+1, ..., n-1.
	          u = the matrix u (orthogonal column vectors) of the
	            decomposition matrix if matu has been set to
	            true, otherwise u is used as a temporary array.
	            u may coincide with a.  If an error return is
	            made, the columns of u corresponding to indices
	            of correct singular values should be correct.
	          v = the matrix v (orthogonal) of the decomposition
	            if matv has been set to true, otherwise v is
	            not referenced.  v may also coincide with a
	            if u is not needed.  If an error return is made,
	            the columns of v corresponding to indices of
	            correct singular values should be correct.

	  Return values:  0 => normal return.
	                  k+1 => kth singular value has not been
	                     determined after MAXIT iterations.

	  Remark:  The calling routine must declare a[nm][n], u[nm][n]
		and v[nm][n].

	  Programmer:  R. J. Craig
		       kat3@ihlpe.att.com
		       (708) 979-1822
		       AT&T Bell Labs
		       1200 E. Warrenville Rd.
		       Room:  1C365
		       Naperville, IL.  60566

	  Last modified:  July 19, 1988.
			  Sep. 25, 1989 - Changed so that sqrt(a*a+b*b)
					  will not overflow.
			  Nov. 10, 1989 - Fix problem with m < n.
			  Nov. 14, 1989 - Fixed so 2.0*h*y would not
					  underflow.
			  Aug. 12, 1990 - line 270 changed != to ==
			  Aug. 12, 1990 = line 286 changes " * " to " + "
			  Jun. 14, 1992 = line 261 change 'goto cancel' to
						'break.'
			  Jun. 14, 1992 - line 266 remove statement label
						'cancel.'
	*/

	int i, j, k, l, i1, k1, l1, mn, its;
	double *rv1, c, f, g, h, s, x, y, z, scale, anorm;
	double fabs(), sqrt(), hypot();
	double *ptr, *ptr1, *ptr2, *ptr3, *ptr4, *ptr5, *ptr6, *ptr7, *ptr8;

	/* initialization */

	rv1 = (double *) malloc(n*sizeof(double));
	for (i=0, ptr=u, ptr1=a; i<m; i++)
	    for (j=0; j<n; j++, ptr++, ptr1++)
	        *ptr = *ptr1;

	/* Housholder reduction to bidiagonal form */

	g = scale = anorm = 0.0;

	/*
	 The following pointers are used as follows.
	    ptr5 - points to the ith row of u.
	    ptr  - points to the ith column of u.
	    ptr2 - points to the ith diagonal of u.
	*/

	for (i=0, ptr5=ptr2=ptr=u; i<n; i++, ptr5 += n, ptr++, ptr2 += n+1) {
	    l = i + 1;
	    rv1[i] = scale*g;
	    g = s = scale = 0.0;
	    if (i < m) {
	        for (k=i, ptr1=ptr2; k<m; k++, ptr1 += n)
	            scale += fabs(*ptr1);
	        if (scale != 0.0) {
	            for (k=i, ptr1=ptr2; k<m; k++, ptr1 += n) {
	                *ptr1 /= scale;
	                s += (*ptr1)*(*ptr1);
	            }
	            f = *ptr2;
	            g = -SIGN(sqrt(s),f);
	            h = f*g - s;
	            *ptr2 = f - g;
	            if (i != n-1)
	                for (j=l, ptr3=ptr2+1; j<n; j++, ptr3++) {
	                    s = 0.0;
	                    for (k=i, ptr1=ptr2, ptr4=ptr3; k<m; k++, ptr1 += n,
	                        ptr4 += n)
	                        s += (*ptr1)*(*ptr4);
	                    f = s/h;
	                    for (k=i, ptr1=ptr2, ptr4=ptr3; k<m; k++, ptr1 += n,
	                        ptr4 += n)
	                        *ptr4 += f*(*ptr1);
	                }
	            for (k=i, ptr1=ptr2; k<m; k++, ptr1 += n)
	                *ptr1 *= scale;
	        }
	    }
	    w[i] = scale*g;
	    g = s = scale = 0.0;
	    if (i<m && i<n-1) {
	        for (k=l, ptr1=ptr2+1; k<n; k++, ptr1++)
	            scale += fabs(*ptr1);
	        if (scale != 0.0) {
	            for (k=l, ptr1=ptr2+1; k<n; k++, ptr1++) {
	                *ptr1 /= scale;
	                s += (*ptr1)*(*ptr1);
	            }
	            f = *(ptr2+1);
	            g = -SIGN(sqrt(s),f);
	            h = f*g - s;
	            *(ptr2+1) = f - g;
	            for (k=l, ptr1=ptr2+1; k<n; k++, ptr1++)
	                rv1[k] = (*ptr1)/h;
	            if (i < m-1)
	                for (j=l, ptr1=ptr2+n+1; j<m; j++, ptr1 += n) {
	                    s = 0.0;
	                    for (k=l, ptr3=ptr1, ptr4=ptr2+1; k<n; k++, ptr3++,
	                        ptr4++)
	                        s += (*ptr3)*(*ptr4);
	                    for (k=l, ptr3=ptr1; k<n; k++, ptr3++)
	                        *ptr3 += s*rv1[k];
	                }
	            for (k=l, ptr1=ptr2+1; k<n; k++, ptr1++)
	                *ptr1 *= scale;
	        }
	    }
	    anorm = MAX(anorm, fabs(w[i]) + fabs(rv1[i]));
	}

	/* accumulate right hand transformations */

	if (matv) {

	/*
	  The pointers are used as follows:
	    ptr - points to the ith diagonal of v.
	    ptr2 - points to the ith diagonal of u.
	*/

	    for (i=n-1, ptr=v+n*n-1, ptr2=u+n*n-1; i>=0; i--, ptr -= n+1,
	        ptr2 -= n+1) {
	        if (i < n-1) {
	            if (g != 0.0) {
	                for (j=l, ptr1=ptr+n, ptr4=ptr3=ptr2+1; j<n; j++,
	                    ptr1 += n, ptr3++)

	/* double division avoids possible underflow */

	                    *ptr1 = (*ptr3)/(*ptr4)/g;
	                for (j=l, ptr1=ptr+n+1; j<n; j++, ptr1++) {
	                    s = 0.0;
	                    for (k=l, ptr3=ptr2+1, ptr4=ptr1; k<n; k++, ptr3++,
	                        ptr4 += n)
	                        s += (*ptr3)*(*ptr4);
	                    for (k=l, ptr4=ptr1, ptr5=ptr+n; k<n; k++,
	                        ptr4 += n, ptr5 += n)
	                        *ptr4 += s*(*ptr5);
	                }
	            }
	            for (j=l, ptr1=ptr+1, ptr3=ptr+n; j<n; j++, ptr1++,
	                ptr3 += n)
	                *ptr1 = (*ptr3) = 0.0;
	        }
	        *ptr = 1.0;
	        g = rv1[i];
	        l=i;
	    }
	}

	if (matu) {
	    mn = (m < n) ? m:n;
	    for (i=mn-1, ptr=u+(mn-1)*(n+1); i>=0; i--, ptr -= n+1) {
	        l = i + 1;
	        g=w[i];
	        if (i != n-1)
	            for (j=l, ptr1=ptr+1; j<n; j++, ptr1++)
	                *ptr1 = 0.0;
	        if (g != 0.0) {
	            if (i != mn-1) {
	                for (j=l, ptr2=ptr+n+1, ptr3=ptr2-n; j<n; j++,
	                    ptr2++, ptr3++) {
	                    s = 0.0;
	                    for (k=l, ptr1=ptr+n, ptr4=ptr2; k<m; k++,
	                        ptr1 += n, ptr4 += n)
	                        s += (*ptr1)*(*ptr4);

	/* double division avoids possible underflow */

	                    f = s/(*ptr)/g;
	                    for (k=i, ptr1=ptr, ptr4=ptr3; k<m; k++, ptr1 += n,
	                        ptr4 += n)
	                        *ptr4 += f*(*ptr1);
	                }
	            }
	            for (j=i, ptr1=ptr; j<m; j++, ptr1 += n)
	                *ptr1 /= g;
	        } else
	            for (j=i, ptr1=ptr; j<m; j++, ptr1 += n)
	                *ptr1 = 0.0;
	        *ptr += 1.0;
	    }
	}


	/* accumulation of left-hand transformations */
	/* diagonalization of bidiagonal form */

	for (k=n-1; k>=0; k--) {
	    k1 = k - 1;
	    its = 0;

	/* test for splitting */

split:	    for (l=k, ptr=u+l, ptr1=ptr-1, ptr6=v+l; l>=0; l--, ptr--,
	        ptr1--, ptr6--) {
	        l1 = l - 1;

	/* There is no exit from the bottom of this loop since rv1[0] == 0 */

	        if (fabs(rv1[l]) + anorm == anorm)
	            goto convrg;
	        if (fabs(w[l1]) + anorm == anorm)
		    break;
	    }

	/* cancellation of rv1[l] if l > 0 */

	    c = 0.0;
	    s = 1.0;
	    for (i=l, ptr2=ptr; i<=k; i++, ptr2++) {
	        f = s*rv1[i];
	        rv1[i] *= c;
	        if (fabs(f) + anorm == anorm)
	            break;
	        g = w[i];

	/* rotation can be arbitrary if h == 0.0 */

		if ((w[i] = h = hypot(f, g)) != 0.0) {
		        c = g/h;
		        s = -f/h;
		}
	        if (matu)
	            for (j=0, ptr3=ptr1, ptr4=ptr2; j<m; j++, ptr3 += n,
	                ptr4 += n) {
	                y = *ptr3;
	                z = *ptr4;
	                *ptr3 = y*c + z*s;
	                *ptr4 = -y*s + z*c;
	            }
	    }

	/* test for convergence */

convrg:	    z = w[k];
	    if (l != k) {

	/*
	  return error -- no convergence to a singular value after
	  MAXIT iterations.
	*/

	        if (its == MAXIT) {
	            free ((char *) rv1);
	            return(k+1);
	        }

	/* shift from bottom 2 by 2 minor */

	        its++;
	        x = w[l];
	        y = w[k1];
	        g = rv1[k1];
	        h = rv1[k];

	/* double division avoids possible underflow */

	        f = ((y - z)*(y + z) + (g - h)*(g + h))/(2.0*h)/y;

		g = hypot(f, 1.0);
	        f = ((x - z)*(x + z) + h*(y/(f + SIGN(g,f)) - h))/x;

	/* next qr transformation */

	        c = s = 1.0;
	        for (i1=l, ptr2=ptr, ptr4=ptr2+1, ptr3=ptr6, ptr5=ptr3+1;
	            i1<=k1; i1++, ptr2++, ptr3++, ptr4++, ptr5++) {
	            i = i1 + 1;
	            g = rv1[i];
	            y = w[i];
	            h = s*g;
	            g *= c;

	/* rotation can be arbitrary if z == 0.0 */

	            if ((rv1[i1] = z = hypot(f, h)) != 0.0) {
	                c = f/z;
	                s = h/z;
	            }
	            f = x*c + g*s;
	            g = -x*s + g*c;
	            h = y*s;
	            y *= c;
	            if (matv)
	                for (j=0, ptr7=ptr3, ptr8=ptr5; j<n; j++, ptr7 += n,
	                    ptr8 += n) {
	                    x = *ptr7;
	                    z = *ptr8;
	                    *ptr7 = x*c + z*s;
	                    *ptr8 = -x*s + z*c;
	                }

	/* rotation can be arbitrary if z == 0.0 */

	            if ((w[i1] = z = hypot(f, h)) != 0.0) {
	                c = f/z;
	                s = h/z;
	            }
	            f = c*g + s*y;
	            x = -s*g + c*y;
	            if (matu)
	                for (j=0, ptr7=ptr2, ptr8=ptr4; j<m; j++, ptr7 += n,
	                    ptr8 += n) {
	                    y = *ptr7;
	                    z = *ptr8;
	                    *ptr7 = y*c + z*s;
	                    *ptr8 = -y*s + z*c;
	                }
	        }
	        rv1[l] = 0.0;
	        rv1[k] = f;
	        w[k] = x;
	        goto split;
	    }

	/* convergence */

	    if (z < 0.0) {
	        w[k] = -z;
	        if (matv)
	            for (j=0, ptr1=v+k; j<n; j++, ptr1 += n)
	                *ptr1 *= -1.0;
	    }
	}
	free((char *) rv1);
	return(0);
}
