55
56
57
58
59
60
61 INTEGER NUNIT
62 CHARACTER*3 PATH
63
64
65
66
67
68 INTEGER NMAX
69 parameter( nmax = 4 )
70
71
72 INTEGER I, INFO, J, RANK
73
74
75 DOUBLE PRECISION A( NMAX, NMAX ), WORK( 2*NMAX )
76 INTEGER PIV( NMAX )
77
78
80
81
82 INTEGER INFOT, NOUT
83 LOGICAL LERR, OK
84 CHARACTER*32 SRNAMT
85
86
87 COMMON / infoc / infot, nout, ok, lerr
88 COMMON / srnamc / srnamt
89
90
91 INTRINSIC dble
92
93
94
95 nout = nunit
96 WRITE( nout, fmt = * )
97
98
99
100 DO 110 j = 1, nmax
101 DO 100 i = 1, nmax
102 a( i, j ) = 1.d0 / dble( i+j )
103
104 100 CONTINUE
105 piv( j ) = j
106 work( j ) = 0.d0
107 work( nmax+j ) = 0.d0
108
109 110 CONTINUE
110 ok = .true.
111
112
113
114
115
116
117
118 srnamt = 'DPSTRF'
119 infot = 1
120 CALL dpstrf(
'/', 0, a, 1, piv, rank, -1.d0, work, info )
121 CALL chkxer(
'DPSTRF', infot, nout, lerr, ok )
122 infot = 2
123 CALL dpstrf(
'U', -1, a, 1, piv, rank, -1.d0, work, info )
124 CALL chkxer(
'DPSTRF', infot, nout, lerr, ok )
125 infot = 4
126 CALL dpstrf(
'U', 2, a, 1, piv, rank, -1.d0, work, info )
127 CALL chkxer(
'DPSTRF', infot, nout, lerr, ok )
128
129
130
131 srnamt = 'DPSTF2'
132 infot = 1
133 CALL dpstf2(
'/', 0, a, 1, piv, rank, -1.d0, work, info )
134 CALL chkxer(
'DPSTF2', infot, nout, lerr, ok )
135 infot = 2
136 CALL dpstf2(
'U', -1, a, 1, piv, rank, -1.d0, work, info )
137 CALL chkxer(
'DPSTF2', infot, nout, lerr, ok )
138 infot = 4
139 CALL dpstf2(
'U', 2, a, 1, piv, rank, -1.d0, work, info )
140 CALL chkxer(
'DPSTF2', infot, nout, lerr, ok )
141
142
143
144
145 CALL alaesm( path, ok, nout )
146
147 RETURN
148
149
150
subroutine alaesm(path, ok, nout)
ALAESM
subroutine chkxer(srnamt, infot, nout, lerr, ok)
subroutine dpstf2(uplo, n, a, lda, piv, rank, tol, work, info)
DPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric positive semide...
subroutine dpstrf(uplo, n, a, lda, piv, rank, tol, work, info)
DPSTRF computes the Cholesky factorization with complete pivoting of a real symmetric positive semide...