297 integer u1_dim1, u1_offset, u2_dim1, u2_offset, v1t_dim1, v1t_offset, v2t_dim1, v2t_offset, x11_dim1, x11_offset, x12_dim1, x12_offset, x21_dim1, x21_offset, x22_dim1, x22_offset, i__1, i__2, i__3, i__4, i__5, i__6;
300 integer lworkmin, lworkopt, i__, j, childinfo, lbbcsdwork, lorbdbwork, lorglqwork, lorgqrwork, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, iphi;
302 extern logical lsame_(
char *,
char *);
304 integer lbbcsdworkmin, itaup1, itaup2, itauq1, itauq2, lorbdbworkmin, lbbcsdworkopt;
308 int sbbcsd_(
char *,
char *,
char *,
char *,
char * ,
integer *,
integer *,
integer *,
real *,
real *,
real *,
integer *,
real *,
integer *,
real *,
integer *,
real *,
integer * ,
real *,
real *,
real *,
real *,
real *,
real *,
real *,
real *,
real *,
integer *,
integer *);
309 integer iorbdb, lorglqworkmin, lorgqrworkmin;
311 int sorbdb_(
char *,
char *,
integer *,
integer *,
integer *,
real *,
integer *,
real *,
integer *,
real *,
integer * ,
real *,
integer *,
real *,
real *,
real *,
real *,
real *,
real *,
real *,
integer *,
integer *), xerbla_(
char *,
integer *);
312 integer lorglqworkopt, lorgqrworkopt;
317 int slapmr_(
logical *,
integer *,
integer *,
real *,
integer *,
integer *), slapmt_(
logical *,
integer *,
integer *,
real *,
integer *,
integer *);
325 logical lquery, wantv1t, wantv2t;
351 x11_offset = 1 + x11_dim1;
354 x12_offset = 1 + x12_dim1;
357 x21_offset = 1 + x21_dim1;
360 x22_offset = 1 + x22_dim1;
364 u1_offset = 1 + u1_dim1;
367 u2_offset = 1 + u2_dim1;
370 v1t_offset = 1 + v1t_dim1;
373 v2t_offset = 1 + v2t_dim1;
379 wantu1 = lsame_(jobu1,
"Y");
380 wantu2 = lsame_(jobu2,
"Y");
381 wantv1t = lsame_(jobv1t,
"Y");
382 wantv2t = lsame_(jobv2t,
"Y");
383 colmajor = ! lsame_(trans,
"T");
384 defaultsigns = ! lsame_(signs,
"O");
385 lquery = *lwork == -1;
390 else if (*p < 0 || *p > *m)
394 else if (*q < 0 || *q > *m)
398 else if (colmajor && *ldx11 < max(1,*p))
402 else if (! colmajor && *ldx11 < max(1,*q))
406 else if (colmajor && *ldx12 < max(1,*p))
415 if (! colmajor && *ldx12 < max(i__1,i__2))
424 if (colmajor && *ldx21 < max(i__1,i__2))
428 else if (! colmajor && *ldx21 < max(1,*q))
437 if (colmajor && *ldx22 < max(i__1,i__2))
446 if (! colmajor && *ldx22 < max(i__1,i__2))
450 else if (wantu1 && *ldu1 < *p)
454 else if (wantu2 && *ldu2 < *m - *p)
458 else if (wantv1t && *ldv1t < *q)
462 else if (wantv2t && *ldv2t < *m - *q)
477 if (*info == 0 && min(i__1,i__2) < min(i__3,i__4))
481 *(
unsigned char *)transt =
'T';
485 *(
unsigned char *)transt =
'N';
489 *(
unsigned char *)signst =
'O';
493 *(
unsigned char *)signst =
'D';
495 sorcsd_(jobv1t, jobv2t, jobu1, jobu2, transt, signst, m, q, p, &x11[ x11_offset], ldx11, &x21[x21_offset], ldx21, &x12[x12_offset], ldx12, &x22[x22_offset], ldx22, &theta[1], &v1t[v1t_offset], ldv1t, &v2t[v2t_offset], ldv2t, &u1[u1_offset], ldu1, &u2[ u2_offset], ldu2, &work[1], lwork, &iwork[1], info);
502 if (*info == 0 && *m - *q < *q)
506 *(
unsigned char *)signst =
'O';
510 *(
unsigned char *)signst =
'D';
514 sorcsd_(jobu2, jobu1, jobv2t, jobv1t, trans, signst, m, &i__1, &i__2, &x22[x22_offset], ldx22, &x21[x21_offset], ldx21, &x12[ x12_offset], ldx12, &x11[x11_offset], ldx11, &theta[1], &u2[ u2_offset], ldu2, &u1[u1_offset], ldu1, &v2t[v2t_offset], ldv2t, &v1t[v1t_offset], ldv1t, &work[1], lwork, &iwork[1], info);
524 itaup1 = iphi + max(i__1,i__2);
525 itaup2 = itaup1 + max(1,*p);
529 itauq1 = itaup2 + max(i__1,i__2);
530 itauq2 = itauq1 + max(1,*q);
534 iorgqr = itauq2 + max(i__1,i__2);
541 i__4 = max(i__5,i__6);
542 sorgqr_fla(&i__1, &i__2, &i__3, dummy, &i__4, dummy, &work[1], &c_n1, & childinfo);
543 lorgqrworkopt = (
integer) work[1];
547 lorgqrworkmin = max(i__1,i__2);
551 iorglq = itauq2 + max(i__1,i__2);
558 i__4 = max(i__5,i__6);
559 sorglq_fla(&i__1, &i__2, &i__3, dummy, &i__4, dummy, &work[1], &c_n1, & childinfo);
560 lorglqworkopt = (
integer) work[1];
564 lorglqworkmin = max(i__1,i__2);
568 iorbdb = itauq2 + max(i__1,i__2);
569 sorbdb_(trans, signs, m, p, q, &x11[x11_offset], ldx11, &x12[ x12_offset], ldx12, &x21[x21_offset], ldx21, &x22[x22_offset], ldx22, dummy, dummy, dummy, dummy, dummy, dummy, &work[1], & c_n1, &childinfo);
570 lorbdbworkopt = (
integer) work[1];
571 lorbdbworkmin = lorbdbworkopt;
575 ib11d = itauq2 + max(i__1,i__2);
576 ib11e = ib11d + max(1,*q);
580 ib12d = ib11e + max(i__1,i__2);
581 ib12e = ib12d + max(1,*q);
585 ib21d = ib12e + max(i__1,i__2);
586 ib21e = ib21d + max(1,*q);
590 ib22d = ib21e + max(i__1,i__2);
591 ib22e = ib22d + max(1,*q);
595 ibbcsd = ib22e + max(i__1,i__2);
596 sbbcsd_(jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, dummy, dummy, & u1[u1_offset], ldu1, &u2[u2_offset], ldu2, &v1t[v1t_offset], ldv1t, &v2t[v2t_offset], ldv2t, dummy, dummy, dummy, dummy, dummy, dummy, dummy, dummy, &work[1], &c_n1, &childinfo);
597 lbbcsdworkopt = (
integer) work[1];
598 lbbcsdworkmin = lbbcsdworkopt;
600 i__1 = iorgqr + lorgqrworkopt, i__2 = iorglq + lorglqworkopt, i__1 = max(i__1,i__2), i__2 = iorbdb + lorbdbworkopt;
601 i__1 = max( i__1,i__2);
602 i__2 = ibbcsd + lbbcsdworkopt;
603 lworkopt = max(i__1,i__2) - 1;
605 i__1 = iorgqr + lorgqrworkmin, i__2 = iorglq + lorglqworkmin, i__1 = max(i__1,i__2), i__2 = iorbdb + lorbdbworkopt;
606 i__1 = max( i__1,i__2);
607 i__2 = ibbcsd + lbbcsdworkmin;
608 lworkmin = max(i__1,i__2) - 1;
609 work[1] = (
real) max(lworkopt,lworkmin);
610 if (*lwork < lworkmin && ! lquery)
616 lorgqrwork = *lwork - iorgqr + 1;
617 lorglqwork = *lwork - iorglq + 1;
618 lorbdbwork = *lwork - iorbdb + 1;
619 lbbcsdwork = *lwork - ibbcsd + 1;
626 xerbla_(
"SORCSD", &i__1);
634 sorbdb_(trans, signs, m, p, q, &x11[x11_offset], ldx11, &x12[x12_offset], ldx12, &x21[x21_offset], ldx21, &x22[x22_offset], ldx22, &theta[1] , &work[iphi], &work[itaup1], &work[itaup2], &work[itauq1], &work[ itauq2], &work[iorbdb], &lorbdbwork, &childinfo);
638 if (wantu1 && *p > 0)
640 slacpy_(
"L", p, q, &x11[x11_offset], ldx11, &u1[u1_offset], ldu1);
641 sorgqr_fla(p, p, q, &u1[u1_offset], ldu1, &work[itaup1], &work[ iorgqr], &lorgqrwork, info);
643 if (wantu2 && *m - *p > 0)
646 slacpy_(
"L", &i__1, q, &x21[x21_offset], ldx21, &u2[u2_offset], ldu2);
649 sorgqr_fla(&i__1, &i__2, q, &u2[u2_offset], ldu2, &work[itaup2], & work[iorgqr], &lorgqrwork, info);
651 if (wantv1t && *q > 0)
655 slacpy_(
"U", &i__1, &i__2, &x11[(x11_dim1 << 1) + 1], ldx11, &v1t[ (v1t_dim1 << 1) + 2], ldv1t);
656 v1t[v1t_dim1 + 1] = 1.f;
662 v1t[j * v1t_dim1 + 1] = 0.f;
663 v1t[j + v1t_dim1] = 0.f;
668 sorglq_fla(&i__1, &i__2, &i__3, &v1t[(v1t_dim1 << 1) + 2], ldv1t, & work[itauq1], &work[iorglq], &lorglqwork, info);
670 if (wantv2t && *m - *q > 0)
673 slacpy_(
"U", p, &i__1, &x12[x12_offset], ldx12, &v2t[v2t_offset], ldv2t);
676 slacpy_(
"U", &i__1, &i__2, &x22[*q + 1 + (*p + 1) * x22_dim1], ldx22, &v2t[*p + 1 + (*p + 1) * v2t_dim1], ldv2t);
680 sorglq_fla(&i__1, &i__2, &i__3, &v2t[v2t_offset], ldv2t, &work[ itauq2], &work[iorglq], &lorglqwork, info);
685 if (wantu1 && *p > 0)
687 slacpy_(
"U", q, p, &x11[x11_offset], ldx11, &u1[u1_offset], ldu1);
688 sorglq_fla(p, p, q, &u1[u1_offset], ldu1, &work[itaup1], &work[ iorglq], &lorglqwork, info);
690 if (wantu2 && *m - *p > 0)
693 slacpy_(
"U", q, &i__1, &x21[x21_offset], ldx21, &u2[u2_offset], ldu2);
696 sorglq_fla(&i__1, &i__2, q, &u2[u2_offset], ldu2, &work[itaup2], & work[iorglq], &lorglqwork, info);
698 if (wantv1t && *q > 0)
702 slacpy_(
"L", &i__1, &i__2, &x11[x11_dim1 + 2], ldx11, &v1t[( v1t_dim1 << 1) + 2], ldv1t);
703 v1t[v1t_dim1 + 1] = 1.f;
709 v1t[j * v1t_dim1 + 1] = 0.f;
710 v1t[j + v1t_dim1] = 0.f;
715 sorgqr_fla(&i__1, &i__2, &i__3, &v1t[(v1t_dim1 << 1) + 2], ldv1t, & work[itauq1], &work[iorgqr], &lorgqrwork, info);
717 if (wantv2t && *m - *q > 0)
720 slacpy_(
"L", &i__1, p, &x12[x12_offset], ldx12, &v2t[v2t_offset], ldv2t);
723 slacpy_(
"L", &i__1, &i__2, &x22[*p + 1 + (*q + 1) * x22_dim1], ldx22, &v2t[*p + 1 + (*p + 1) * v2t_dim1], ldv2t);
727 sorgqr_fla(&i__1, &i__2, &i__3, &v2t[v2t_offset], ldv2t, &work[ itauq2], &work[iorgqr], &lorgqrwork, info);
731 sbbcsd_(jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, &theta[1], &work[ iphi], &u1[u1_offset], ldu1, &u2[u2_offset], ldu2, &v1t[ v1t_offset], ldv1t, &v2t[v2t_offset], ldv2t, &work[ib11d], &work[ ib11e], &work[ib12d], &work[ib12e], &work[ib21d], &work[ib21e], & work[ib22d], &work[ib22e], &work[ibbcsd], &lbbcsdwork, info);
736 if (*q > 0 && wantu2)
743 iwork[i__] = *m - *p - *q + i__;
750 iwork[i__] = i__ - *q;
756 slapmt_(&c_false, &i__1, &i__2, &u2[u2_offset], ldu2, &iwork[1]);
762 slapmr_(&c_false, &i__1, &i__2, &u2[u2_offset], ldu2, &iwork[1]);
765 if (*m > 0 && wantv2t)
772 iwork[i__] = *m - *p - *q + i__;
779 iwork[i__] = i__ - *p;
785 slapmt_(&c_false, &i__1, &i__2, &v2t[v2t_offset], ldv2t, &iwork[1] );
791 slapmr_(&c_false, &i__1, &i__2, &v2t[v2t_offset], ldv2t, &iwork[1] );
int sorcsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, char *signs, integer *m, integer *p, integer *q, real *x11, integer *ldx11, real *x12, integer *ldx12, real *x21, integer *ldx21, real *x22, integer *ldx22, real *theta, real *u1, integer *ldu1, real *u2, integer *ldu2, real *v1t, integer *ldv1t, real *v2t, integer *ldv2t, real *work, integer *lwork, integer *iwork, integer *info)
Definition: sorcsd.c:294
int sorglq_fla(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info)
Definition: sorglq.c:122
float real
Definition: FLA_f2c.h:30
int logical
Definition: FLA_f2c.h:36
int integer
Definition: FLA_f2c.h:25
int sorgqr_fla(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info)
Definition: sorgqr.c:123