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 *);
303 integer lbbcsdworkmin, itaup1, itaup2, itauq1, itauq2, lorbdbworkmin, lbbcsdworkopt;
306 int dbbcsd_(
char *,
char *,
char *,
char *,
char * ,
integer *,
integer *,
integer *,
doublereal *,
doublereal *,
doublereal *,
integer *,
doublereal *,
integer *,
doublereal *,
integer *,
doublereal *,
integer *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
integer *,
integer *);
309 int dorbdb_(
char *,
char *,
integer *,
integer *,
integer *,
doublereal *,
integer *,
doublereal *,
integer *,
doublereal *,
integer *,
doublereal *,
integer *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
doublereal *,
integer *,
integer *);
310 integer iorbdb, lorglqworkmin, lorgqrworkmin;
312 int dlacpy_(
char *,
integer *,
integer *,
doublereal *,
integer *,
doublereal *,
integer *), dlapmr_(
logical *,
integer *,
integer *,
doublereal *,
integer *,
integer *), xerbla_(
char *,
integer *), dlapmt_(
logical *,
integer *,
integer *,
doublereal *,
integer *,
integer *);
320 char signst[1], transt[1];
321 logical lquery, wantv1t, wantv2t;
345 x11_offset = 1 + x11_dim1;
348 x12_offset = 1 + x12_dim1;
351 x21_offset = 1 + x21_dim1;
354 x22_offset = 1 + x22_dim1;
358 u1_offset = 1 + u1_dim1;
361 u2_offset = 1 + u2_dim1;
364 v1t_offset = 1 + v1t_dim1;
367 v2t_offset = 1 + v2t_dim1;
373 wantu1 = lsame_(jobu1,
"Y");
374 wantu2 = lsame_(jobu2,
"Y");
375 wantv1t = lsame_(jobv1t,
"Y");
376 wantv2t = lsame_(jobv2t,
"Y");
377 colmajor = ! lsame_(trans,
"T");
378 defaultsigns = ! lsame_(signs,
"O");
379 lquery = *lwork == -1;
384 else if (*p < 0 || *p > *m)
388 else if (*q < 0 || *q > *m)
392 else if (colmajor && *ldx11 < max(1,*p))
396 else if (! colmajor && *ldx11 < max(1,*q))
400 else if (colmajor && *ldx12 < max(1,*p))
409 if (! colmajor && *ldx12 < max(i__1,i__2))
418 if (colmajor && *ldx21 < max(i__1,i__2))
422 else if (! colmajor && *ldx21 < max(1,*q))
431 if (colmajor && *ldx22 < max(i__1,i__2))
440 if (! colmajor && *ldx22 < max(i__1,i__2))
444 else if (wantu1 && *ldu1 < *p)
448 else if (wantu2 && *ldu2 < *m - *p)
452 else if (wantv1t && *ldv1t < *q)
456 else if (wantv2t && *ldv2t < *m - *q)
471 if (*info == 0 && min(i__1,i__2) < min(i__3,i__4))
475 *(
unsigned char *)transt =
'T';
479 *(
unsigned char *)transt =
'N';
483 *(
unsigned char *)signst =
'O';
487 *(
unsigned char *)signst =
'D';
489 dorcsd_(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);
496 if (*info == 0 && *m - *q < *q)
500 *(
unsigned char *)signst =
'O';
504 *(
unsigned char *)signst =
'D';
508 dorcsd_(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);
518 itaup1 = iphi + max(i__1,i__2);
519 itaup2 = itaup1 + max(1,*p);
523 itauq1 = itaup2 + max(i__1,i__2);
524 itauq2 = itauq1 + max(1,*q);
528 iorgqr = itauq2 + max(i__1,i__2);
535 i__4 = max(i__5,i__6);
536 dorgqr_fla(&i__1, &i__2, &i__3, &u1[u1_offset], &i__4, &u1[u1_offset], & work[1], &c_n1, &childinfo);
537 lorgqrworkopt = (
integer) work[1];
541 lorgqrworkmin = max(i__1,i__2);
545 iorglq = itauq2 + max(i__1,i__2);
552 i__4 = max(i__5,i__6);
553 dorglq_fla(&i__1, &i__2, &i__3, &u1[u1_offset], &i__4, &u1[u1_offset], & work[1], &c_n1, &childinfo);
554 lorglqworkopt = (
integer) work[1];
558 lorglqworkmin = max(i__1,i__2);
562 iorbdb = itauq2 + max(i__1,i__2);
563 dorbdb_(trans, signs, m, p, q, &x11[x11_offset], ldx11, &x12[ x12_offset], ldx12, &x21[x21_offset], ldx21, &x22[x22_offset], ldx22, &theta[1], &v1t[v1t_offset], &u1[u1_offset], &u2[ u2_offset], &v1t[v1t_offset], &v2t[v2t_offset], &work[1], & c_n1, &childinfo);
564 lorbdbworkopt = (
integer) work[1];
565 lorbdbworkmin = lorbdbworkopt;
569 ib11d = itauq2 + max(i__1,i__2);
570 ib11e = ib11d + max(1,*q);
574 ib12d = ib11e + max(i__1,i__2);
575 ib12e = ib12d + max(1,*q);
579 ib21d = ib12e + max(i__1,i__2);
580 ib21e = ib21d + max(1,*q);
584 ib22d = ib21e + max(i__1,i__2);
585 ib22e = ib22d + max(1,*q);
589 ibbcsd = ib22e + max(i__1,i__2);
590 dbbcsd_(jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, &theta[1], & theta[1], &u1[u1_offset], ldu1, &u2[u2_offset], ldu2, &v1t[ v1t_offset], ldv1t, &v2t[v2t_offset], ldv2t, &u1[u1_offset], & u1[u1_offset], &u1[u1_offset], &u1[u1_offset], &u1[u1_offset], &u1[u1_offset], &u1[u1_offset], &u1[u1_offset], &work[1], & c_n1, &childinfo);
591 lbbcsdworkopt = (
integer) work[1];
592 lbbcsdworkmin = lbbcsdworkopt;
594 i__1 = iorgqr + lorgqrworkopt, i__2 = iorglq + lorglqworkopt, i__1 = max(i__1,i__2), i__2 = iorbdb + lorbdbworkopt;
595 i__1 = max( i__1,i__2);
596 i__2 = ibbcsd + lbbcsdworkopt;
597 lworkopt = max(i__1,i__2) - 1;
599 i__1 = iorgqr + lorgqrworkmin, i__2 = iorglq + lorglqworkmin, i__1 = max(i__1,i__2), i__2 = iorbdb + lorbdbworkopt;
600 i__1 = max( i__1,i__2);
601 i__2 = ibbcsd + lbbcsdworkmin;
602 lworkmin = max(i__1,i__2) - 1;
603 work[1] = (
doublereal) max(lworkopt,lworkmin);
604 if (*lwork < lworkmin && ! lquery)
610 lorgqrwork = *lwork - iorgqr + 1;
611 lorglqwork = *lwork - iorglq + 1;
612 lorbdbwork = *lwork - iorbdb + 1;
613 lbbcsdwork = *lwork - ibbcsd + 1;
620 xerbla_(
"DORCSD", &i__1);
628 dorbdb_(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);
632 if (wantu1 && *p > 0)
634 dlacpy_(
"L", p, q, &x11[x11_offset], ldx11, &u1[u1_offset], ldu1);
635 dorgqr_fla(p, p, q, &u1[u1_offset], ldu1, &work[itaup1], &work[ iorgqr], &lorgqrwork, info);
637 if (wantu2 && *m - *p > 0)
640 dlacpy_(
"L", &i__1, q, &x21[x21_offset], ldx21, &u2[u2_offset], ldu2);
643 dorgqr_fla(&i__1, &i__2, q, &u2[u2_offset], ldu2, &work[itaup2], & work[iorgqr], &lorgqrwork, info);
645 if (wantv1t && *q > 0)
649 dlacpy_(
"U", &i__1, &i__2, &x11[(x11_dim1 << 1) + 1], ldx11, &v1t[ (v1t_dim1 << 1) + 2], ldv1t);
650 v1t[v1t_dim1 + 1] = 1.;
656 v1t[j * v1t_dim1 + 1] = 0.;
657 v1t[j + v1t_dim1] = 0.;
662 dorglq_fla(&i__1, &i__2, &i__3, &v1t[(v1t_dim1 << 1) + 2], ldv1t, & work[itauq1], &work[iorglq], &lorglqwork, info);
664 if (wantv2t && *m - *q > 0)
667 dlacpy_(
"U", p, &i__1, &x12[x12_offset], ldx12, &v2t[v2t_offset], ldv2t);
672 dlacpy_(
"U", &i__1, &i__2, &x22[*q + 1 + (*p + 1) * x22_dim1], ldx22, &v2t[*p + 1 + (*p + 1) * v2t_dim1], ldv2t);
679 dorglq_fla(&i__1, &i__2, &i__3, &v2t[v2t_offset], ldv2t, &work[ itauq2], &work[iorglq], &lorglqwork, info);
685 if (wantu1 && *p > 0)
687 dlacpy_(
"U", q, p, &x11[x11_offset], ldx11, &u1[u1_offset], ldu1);
688 dorglq_fla(p, p, q, &u1[u1_offset], ldu1, &work[itaup1], &work[ iorglq], &lorglqwork, info);
690 if (wantu2 && *m - *p > 0)
693 dlacpy_(
"U", q, &i__1, &x21[x21_offset], ldx21, &u2[u2_offset], ldu2);
696 dorglq_fla(&i__1, &i__2, q, &u2[u2_offset], ldu2, &work[itaup2], & work[iorglq], &lorglqwork, info);
698 if (wantv1t && *q > 0)
702 dlacpy_(
"L", &i__1, &i__2, &x11[x11_dim1 + 2], ldx11, &v1t[( v1t_dim1 << 1) + 2], ldv1t);
703 v1t[v1t_dim1 + 1] = 1.;
709 v1t[j * v1t_dim1 + 1] = 0.;
710 v1t[j + v1t_dim1] = 0.;
715 dorgqr_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 dlacpy_(
"L", &i__1, p, &x12[x12_offset], ldx12, &v2t[v2t_offset], ldv2t);
723 dlacpy_(
"L", &i__1, &i__2, &x22[*p + 1 + (*q + 1) * x22_dim1], ldx22, &v2t[*p + 1 + (*p + 1) * v2t_dim1], ldv2t);
727 dorgqr_fla(&i__1, &i__2, &i__3, &v2t[v2t_offset], ldv2t, &work[ itauq2], &work[iorgqr], &lorgqrwork, info);
731 dbbcsd_(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 dlapmt_(&c_false, &i__1, &i__2, &u2[u2_offset], ldu2, &iwork[1]);
762 dlapmr_(&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 dlapmt_(&c_false, &i__1, &i__2, &v2t[v2t_offset], ldv2t, &iwork[1] );
791 dlapmr_(&c_false, &i__1, &i__2, &v2t[v2t_offset], ldv2t, &iwork[1] );
int dorgqr_fla(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
Definition: dorgqr.c:123
int dorcsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, char *signs, integer *m, integer *p, integer *q, doublereal *x11, integer *ldx11, doublereal *x12, integer *ldx12, doublereal *x21, integer *ldx21, doublereal *x22, integer *ldx22, doublereal *theta, doublereal *u1, integer *ldu1, doublereal *u2, integer *ldu2, doublereal *v1t, integer *ldv1t, doublereal *v2t, integer *ldv2t, doublereal *work, integer *lwork, integer *iwork, integer *info)
Definition: dorcsd.c:294
double doublereal
Definition: FLA_f2c.h:31
int logical
Definition: FLA_f2c.h:36
int integer
Definition: FLA_f2c.h:25
int dorglq_fla(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
Definition: dorglq.c:122