OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
lpq.f
Go to the documentation of this file.
1  SUBROUTINE zgetf2( M, N, A, LDA, IPIV, INFO )
2  INTEGER INFO, LDA, M, N
3  INTEGER IPIV( * )
4  COMPLEX*32 A( LDA, * )
5  COMPLEX*32 ONE, ZERO
6  parameter( one = ( 1.0q+0, 0.0q+0 ),
7  $ zero = ( 0.0q+0, 0.0q+0 ) )
8  INTEGER J, JP
9  INTEGER IZAMAX
10  EXTERNAL izamax
11  EXTERNAL xerbla, zgeru, zscal, zswap
12  INTRINSIC max, min
13  info = 0
14  IF( m.LT.0 ) THEN
15  info = -1
16  ELSE IF( n.LT.0 ) THEN
17  info = -2
18  ELSE IF( lda.LT.max( 1, m ) ) THEN
19  info = -4
20  END IF
21  IF( info.NE.0 ) THEN
22  CALL xerbla( 'ZGETF2', -info )
23  RETURN
24  END IF
25  IF( m.EQ.0 .OR. n.EQ.0 )
26  $ RETURN
27  DO 10 j = 1, min( m, n )
28  jp = j - 1 + izamax( m-j+1, a( j, j ), 1 )
29  ipiv( j ) = jp
30  IF( a( jp, j ).NE.zero ) THEN
31  IF( jp.NE.j )
32  $ CALL zswap( n, a( j, 1 ), lda, a( jp, 1 ), lda )
33  IF( j.LT.m )
34  $ CALL zscal( m-j, one / a( j, j ), a( j+1, j ), 1 )
35  ELSE IF( info.EQ.0 ) THEN
36  info = j
37  END IF
38  IF( j.LT.min( m, n ) ) THEN
39  CALL zgeru( m-j, n-j, -one, a( j+1, j ), 1, a( j, j+1 ),
40  $ lda, a( j+1, j+1 ), lda )
41  END IF
42  10 CONTINUE
43  RETURN
44  END
45 
46  SUBROUTINE zgetrf( M, N, A, LDA, IPIV, INFO )
47  INTEGER INFO, LDA, M, N
48  INTEGER IPIV( * )
49  COMPLEX*32 A( LDA, * )
50  COMPLEX*32 ONE
51  parameter( one = ( 1.0q+0, 0.0q+0 ) )
52  INTEGER I, IINFO, J, JB, NB
53  EXTERNAL xerbla, zgemm, zgetf2, zlaswp, ztrsm
54  INTEGER ILAENV
55  EXTERNAL ilaenv
56  INTRINSIC max, min
57  info = 0
58  IF( m.LT.0 ) THEN
59  info = -1
60  ELSE IF( n.LT.0 ) THEN
61  info = -2
62  ELSE IF( lda.LT.max( 1, m ) ) THEN
63  info = -4
64  END IF
65  IF( info.NE.0 ) THEN
66  CALL xerbla( 'ZGETRF', -info )
67  RETURN
68  END IF
69  IF( m.EQ.0 .OR. n.EQ.0 )
70  $ RETURN
71  nb = ilaenv( 1, 'ZGETRF', ' ', m, n, -1, -1 )
72  IF( nb.LE.1 .OR. nb.GE.min( m, n ) ) THEN
73  CALL zgetf2( m, n, a, lda, ipiv, info )
74  ELSE
75  DO 20 j = 1, min( m, n ), nb
76  jb = min( min( m, n )-j+1, nb )
77  CALL zgetf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
78  IF( info.EQ.0 .AND. iinfo.GT.0 )
79  $ info = iinfo + j - 1
80  DO 10 i = j, min( m, j+jb-1 )
81  ipiv( i ) = j - 1 + ipiv( i )
82  10 CONTINUE
83  CALL zlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 )
84  IF( j+jb.LE.n ) THEN
85  CALL zlaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,
86  $ ipiv, 1 )
87  CALL ztrsm( 'Left', 'Lower', 'No transpose', 'Unit', jb,
88  $ n-j-jb+1, one, a( j, j ), lda, a( j, j+jb ),
89  $ lda )
90  IF( j+jb.LE.m ) THEN
91  CALL zgemm( 'No transpose', 'No transpose', m-j-jb+1,
92  $ n-j-jb+1, jb, -one, a( j+jb, j ), lda,
93  $ a( j, j+jb ), lda, one, a( j+jb, j+jb ),
94  $ lda )
95  END IF
96  END IF
97  20 CONTINUE
98  END IF
99  RETURN
100  END
101 
102  SUBROUTINE zlaswp( N, A, LDA, K1, K2, IPIV, INCX )
103  INTEGER INCX, K1, K2, LDA, N
104  INTEGER IPIV( * )
105  COMPLEX*32 A( LDA, * )
106  INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
107  COMPLEX*32 TEMP
108  IF( incx.GT.0 ) THEN
109  ix0 = k1
110  i1 = k1
111  i2 = k2
112  inc = 1
113  ELSE IF( incx.LT.0 ) THEN
114  ix0 = 1 + ( 1-k2 )*incx
115  i1 = k2
116  i2 = k1
117  inc = -1
118  ELSE
119  RETURN
120  END IF
121  n32 = ( n / 32 )*32
122  IF( n32.NE.0 ) THEN
123  DO 30 j = 1, n32, 32
124  ix = ix0
125  DO 20 i = i1, i2, inc
126  ip = ipiv( ix )
127  IF( ip.NE.i ) THEN
128  DO 10 k = j, j + 31
129  temp = a( i, k )
130  a( i, k ) = a( ip, k )
131  a( ip, k ) = temp
132  10 CONTINUE
133  END IF
134  ix = ix + incx
135  20 CONTINUE
136  30 CONTINUE
137  END IF
138  IF( n32.NE.n ) THEN
139  n32 = n32 + 1
140  ix = ix0
141  DO 50 i = i1, i2, inc
142  ip = ipiv( ix )
143  IF( ip.NE.i ) THEN
144  DO 40 k = n32, n
145  temp = a( i, k )
146  a( i, k ) = a( ip, k )
147  a( ip, k ) = temp
148  40 CONTINUE
149  END IF
150  ix = ix + incx
151  50 CONTINUE
152  END IF
153  RETURN
154  END
155 
156  INTEGER FUNCTION ieeeck( ISPEC, ZERO, ONE )
157  INTEGER ispec
158  REAL one, zero
159  REAL nan1, nan2, nan3, nan4, nan5, nan6, neginf,
160  $ negzro, newzro, posinf
161  ieeeck = 1
162  posinf = one / zero
163  IF( posinf.LE.one ) THEN
164  ieeeck = 0
165  RETURN
166  END IF
167  neginf = -one / zero
168  IF( neginf.GE.zero ) THEN
169  ieeeck = 0
170  RETURN
171  END IF
172  negzro = one / ( neginf+one )
173  IF( negzro.NE.zero ) THEN
174  ieeeck = 0
175  RETURN
176  END IF
177  neginf = one / negzro
178  IF( neginf.GE.zero ) THEN
179  ieeeck = 0
180  RETURN
181  END IF
182  newzro = negzro + zero
183  IF( newzro.NE.zero ) THEN
184  ieeeck = 0
185  RETURN
186  END IF
187  posinf = one / newzro
188  IF( posinf.LE.one ) THEN
189  ieeeck = 0
190  RETURN
191  END IF
192  neginf = neginf*posinf
193  IF( neginf.GE.zero ) THEN
194  ieeeck = 0
195  RETURN
196  END IF
197  posinf = posinf*posinf
198  IF( posinf.LE.one ) THEN
199  ieeeck = 0
200  RETURN
201  END IF
202  IF( ispec.EQ.0 )
203  $ RETURN
204  nan1 = posinf + neginf
205  nan2 = posinf / neginf
206  nan3 = posinf / posinf
207  nan4 = posinf*zero
208  nan5 = neginf*negzro
209  nan6 = nan5*0.0
210  IF( nan1.EQ.nan1 ) THEN
211  ieeeck = 0
212  RETURN
213  END IF
214  IF( nan2.EQ.nan2 ) THEN
215  ieeeck = 0
216  RETURN
217  END IF
218  IF( nan3.EQ.nan3 ) THEN
219  ieeeck = 0
220  RETURN
221  END IF
222  IF( nan4.EQ.nan4 ) THEN
223  ieeeck = 0
224  RETURN
225  END IF
226  IF( nan5.EQ.nan5 ) THEN
227  ieeeck = 0
228  RETURN
229  END IF
230  IF( nan6.EQ.nan6 ) THEN
231  ieeeck = 0
232  RETURN
233  END IF
234  RETURN
235  END
236 
237  INTEGER FUNCTION ilaenv( ISPEC, NAME, OPTS, N1, N2, N3,
238  $ N4 )
239  CHARACTER*( * ) name, opts
240  INTEGER ispec, n1, n2, n3, n4
241  LOGICAL cname, sname
242  CHARACTER*1 c1
243  CHARACTER*2 c2, c4
244  CHARACTER*3 c3
245  CHARACTER*6 subnam
246  INTEGER i, ic, iz, nb, nbmin, nx
247  INTRINSIC char, ichar, int, min, real
248  INTEGER ieeeck
249  EXTERNAL ieeeck
250  GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000,
251  $ 1100 ) ispec
252  ilaenv = -1
253  RETURN
254  100 CONTINUE
255  ilaenv = 1
256  subnam = name
257  ic = ichar( subnam( 1:1 ) )
258  iz = ichar( 'Z' )
259  IF( iz.EQ.90 .OR. iz.EQ.122 ) THEN
260  IF( ic.GE.97 .AND. ic.LE.122 ) THEN
261  subnam( 1:1 ) = char( ic-32 )
262  DO 10 i = 2, 6
263  ic = ichar( subnam( i:i ) )
264  IF( ic.GE.97 .AND. ic.LE.122 )
265  $ subnam( i:i ) = char( ic-32 )
266  10 CONTINUE
267  END IF
268  ELSE IF( iz.EQ.233 .OR. iz.EQ.169 ) THEN
269  IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
270  $ ( ic.GE.145 .AND. ic.LE.153 ) .OR.
271  $ ( ic.GE.162 .AND. ic.LE.169 ) ) THEN
272  subnam( 1:1 ) = char( ic+64 )
273  DO 20 i = 2, 6
274  ic = ichar( subnam( i:i ) )
275  IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
276  $ ( ic.GE.145 .AND. ic.LE.153 ) .OR.
277  $ ( ic.GE.162 .AND. ic.LE.169 ) )
278  $ subnam( i:i ) = char( ic+64 )
279  20 CONTINUE
280  END IF
281  ELSE IF( iz.EQ.218 .OR. iz.EQ.250 ) THEN
282  IF( ic.GE.225 .AND. ic.LE.250 ) THEN
283  subnam( 1:1 ) = char( ic-32 )
284  DO 30 i = 2, 6
285  ic = ichar( subnam( i:i ) )
286  IF( ic.GE.225 .AND. ic.LE.250 )
287  $ subnam( i:i ) = char( ic-32 )
288  30 CONTINUE
289  END IF
290  END IF
291  c1 = subnam( 1:1 )
292  sname = c1.EQ.'S' .OR. c1.EQ.'D'
293  cname = c1.EQ.'C' .OR. c1.EQ.'Z'
294  IF( .NOT.( cname .OR. sname ) )
295  $ RETURN
296  c2 = subnam( 2:3 )
297  c3 = subnam( 4:6 )
298  c4 = c3( 2:3 )
299  GO TO ( 110, 200, 300 ) ispec
300  110 CONTINUE
301  nb = 1
302  IF( c2.EQ.'GE' ) THEN
303  IF( c3.EQ.'TRF' ) THEN
304  IF( sname ) THEN
305  nb = 64
306  ELSE
307  nb = 64
308  END IF
309  ELSE IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR.
310  $ c3.EQ.'QLF' ) THEN
311  IF( sname ) THEN
312  nb = 32
313  ELSE
314  nb = 32
315  END IF
316  ELSE IF( c3.EQ.'HRD' ) THEN
317  IF( sname ) THEN
318  nb = 32
319  ELSE
320  nb = 32
321  END IF
322  ELSE IF( c3.EQ.'BRD' ) THEN
323  IF( sname ) THEN
324  nb = 32
325  ELSE
326  nb = 32
327  END IF
328  ELSE IF( c3.EQ.'TRI' ) THEN
329  IF( sname ) THEN
330  nb = 64
331  ELSE
332  nb = 64
333  END IF
334  END IF
335  ELSE IF( c2.EQ.'PO' ) THEN
336  IF( c3.EQ.'TRF' ) THEN
337  IF( sname ) THEN
338  nb = 64
339  ELSE
340  nb = 64
341  END IF
342  END IF
343  ELSE IF( c2.EQ.'SY' ) THEN
344  IF( c3.EQ.'TRF' ) THEN
345  IF( sname ) THEN
346  nb = 64
347  ELSE
348  nb = 64
349  END IF
350  ELSE IF( sname .AND. c3.EQ.'TRD' ) THEN
351  nb = 32
352  ELSE IF( sname .AND. c3.EQ.'GST' ) THEN
353  nb = 64
354  END IF
355  ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
356  IF( c3.EQ.'TRF' ) THEN
357  nb = 64
358  ELSE IF( c3.EQ.'TRD' ) THEN
359  nb = 32
360  ELSE IF( c3.EQ.'GST' ) THEN
361  nb = 64
362  END IF
363  ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
364  IF( c3( 1:1 ).EQ.'G' ) THEN
365  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
366  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
367  $ c4.EQ.'BR' ) THEN
368  nb = 32
369  END IF
370  ELSE IF( c3( 1:1 ).EQ.'M' ) THEN
371  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
372  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
373  $ c4.EQ.'BR' ) THEN
374  nb = 32
375  END IF
376  END IF
377  ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
378  IF( c3( 1:1 ).EQ.'G' ) THEN
379  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
380  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
381  $ c4.EQ.'BR' ) THEN
382  nb = 32
383  END IF
384  ELSE IF( c3( 1:1 ).EQ.'M' ) THEN
385  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
386  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
387  $ c4.EQ.'BR' ) THEN
388  nb = 32
389  END IF
390  END IF
391  ELSE IF( c2.EQ.'GB' ) THEN
392  IF( c3.EQ.'TRF' ) THEN
393  IF( sname ) THEN
394  IF( n4.LE.64 ) THEN
395  nb = 1
396  ELSE
397  nb = 32
398  END IF
399  ELSE
400  IF( n4.LE.64 ) THEN
401  nb = 1
402  ELSE
403  nb = 32
404  END IF
405  END IF
406  END IF
407  ELSE IF( c2.EQ.'PB' ) THEN
408  IF( c3.EQ.'TRF' ) THEN
409  IF( sname ) THEN
410  IF( n2.LE.64 ) THEN
411  nb = 1
412  ELSE
413  nb = 32
414  END IF
415  ELSE
416  IF( n2.LE.64 ) THEN
417  nb = 1
418  ELSE
419  nb = 32
420  END IF
421  END IF
422  END IF
423  ELSE IF( c2.EQ.'TR' ) THEN
424  IF( c3.EQ.'TRI' ) THEN
425  IF( sname ) THEN
426  nb = 64
427  ELSE
428  nb = 64
429  END IF
430  END IF
431  ELSE IF( c2.EQ.'LA' ) THEN
432  IF( c3.EQ.'UUM' ) THEN
433  IF( sname ) THEN
434  nb = 64
435  ELSE
436  nb = 64
437  END IF
438  END IF
439  ELSE IF( sname .AND. c2.EQ.'ST' ) THEN
440  IF( c3.EQ.'EBZ' ) THEN
441  nb = 1
442  END IF
443  END IF
444  ilaenv = nb
445  RETURN
446  200 CONTINUE
447  nbmin = 2
448  IF( c2.EQ.'GE' ) THEN
449  IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR.
450  $ c3.EQ.'QLF' ) THEN
451  IF( sname ) THEN
452  nbmin = 2
453  ELSE
454  nbmin = 2
455  END IF
456  ELSE IF( c3.EQ.'HRD' ) THEN
457  IF( sname ) THEN
458  nbmin = 2
459  ELSE
460  nbmin = 2
461  END IF
462  ELSE IF( c3.EQ.'BRD' ) THEN
463  IF( sname ) THEN
464  nbmin = 2
465  ELSE
466  nbmin = 2
467  END IF
468  ELSE IF( c3.EQ.'TRI' ) THEN
469  IF( sname ) THEN
470  nbmin = 2
471  ELSE
472  nbmin = 2
473  END IF
474  END IF
475  ELSE IF( c2.EQ.'SY' ) THEN
476  IF( c3.EQ.'TRF' ) THEN
477  IF( sname ) THEN
478  nbmin = 8
479  ELSE
480  nbmin = 8
481  END IF
482  ELSE IF( sname .AND. c3.EQ.'TRD' ) THEN
483  nbmin = 2
484  END IF
485  ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
486  IF( c3.EQ.'TRD' ) THEN
487  nbmin = 2
488  END IF
489  ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
490  IF( c3( 1:1 ).EQ.'G' ) THEN
491  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
492  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
493  $ c4.EQ.'BR' ) THEN
494  nbmin = 2
495  END IF
496  ELSE IF( c3( 1:1 ).EQ.'M' ) THEN
497  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
498  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
499  $ c4.EQ.'BR' ) THEN
500  nbmin = 2
501  END IF
502  END IF
503  ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
504  IF( c3( 1:1 ).EQ.'G' ) THEN
505  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
506  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
507  $ c4.EQ.'BR' ) THEN
508  nbmin = 2
509  END IF
510  ELSE IF( c3( 1:1 ).EQ.'M' ) THEN
511  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
512  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
513  $ c4.EQ.'BR' ) THEN
514  nbmin = 2
515  END IF
516  END IF
517  END IF
518  ilaenv = nbmin
519  RETURN
520  300 CONTINUE
521  nx = 0
522  IF( c2.EQ.'GE' ) THEN
523  IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR.
524  $ c3.EQ.'QLF' ) THEN
525  IF( sname ) THEN
526  nx = 128
527  ELSE
528  nx = 128
529  END IF
530  ELSE IF( c3.EQ.'HRD' ) THEN
531  IF( sname ) THEN
532  nx = 128
533  ELSE
534  nx = 128
535  END IF
536  ELSE IF( c3.EQ.'BRD' ) THEN
537  IF( sname ) THEN
538  nx = 128
539  ELSE
540  nx = 128
541  END IF
542  END IF
543  ELSE IF( c2.EQ.'SY' ) THEN
544  IF( sname .AND. c3.EQ.'TRD' ) THEN
545  nx = 32
546  END IF
547  ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
548  IF( c3.EQ.'TRD' ) THEN
549  nx = 32
550  END IF
551  ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
552  IF( c3( 1:1 ).EQ.'G' ) THEN
553  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
554  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
555  $ c4.EQ.'BR' ) THEN
556  nx = 128
557  END IF
558  END IF
559  ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
560  IF( c3( 1:1 ).EQ.'G' ) THEN
561  IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR.
562  $ c4.EQ.'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR.
563  $ c4.EQ.'BR' ) THEN
564  nx = 128
565  END IF
566  END IF
567  END IF
568  ilaenv = nx
569  RETURN
570  400 CONTINUE
571  ilaenv = 6
572  RETURN
573  500 CONTINUE
574  ilaenv = 2
575  RETURN
576  600 CONTINUE
577  ilaenv = int( real( min( n1, n2 ) )*1.6e0 )
578  RETURN
579  700 CONTINUE
580  ilaenv = 1
581  RETURN
582  800 CONTINUE
583  ilaenv = 50
584  RETURN
585  900 CONTINUE
586  ilaenv = 25
587  RETURN
588  1000 CONTINUE
589  ilaenv = 1
590  IF( ilaenv.EQ.1 ) THEN
591  ilaenv = ieeeck( 0, 0.0, 1.0 )
592  END IF
593  RETURN
594  1100 CONTINUE
595  ilaenv = 1
596  IF( ilaenv.EQ.1 ) THEN
597  ilaenv = ieeeck( 1, 0.0, 1.0 )
598  END IF
599  RETURN
600  END
601 
602  SUBROUTINE xerbla( SRNAME, INFO )
603  CHARACTER*6 SRNAME
604  INTEGER INFO
605  WRITE( *, fmt = 9999 )srname, info
606  stop
607  9999 FORMAT( ' ** On entry to ', a6, ' parameter number ', i2, ' had ',
608  $ 'an illegal value' )
609  END
610 
611  SUBROUTINE zgetri( N, A, LDA, IPIV, WORK, LWORK, INFO )
612  INTEGER INFO, LDA, LWORK, N
613  INTEGER IPIV( * )
614  COMPLEX*32 A( LDA, * ), WORK( * )
615  COMPLEX*32 ZERO, ONE
616  parameter( zero = ( 0.0q+0, 0.0q+0 ),
617  $ one = ( 1.0q+0, 0.0q+0 ) )
618  LOGICAL LQUERY
619  INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
620  $ nbmin, nn
621  INTEGER ILAENV
622  EXTERNAL ilaenv
623  EXTERNAL xerbla, zgemm, zgemv, zswap, ztrsm, ztrtri
624  INTRINSIC max, min
625  info = 0
626  nb = ilaenv( 1, 'ZGETRI', ' ', n, -1, -1, -1 )
627  lwkopt = n*nb
628  work( 1 ) = lwkopt
629  lquery = ( lwork.EQ.-1 )
630  IF( n.LT.0 ) THEN
631  info = -1
632  ELSE IF( lda.LT.max( 1, n ) ) THEN
633  info = -3
634  ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
635  info = -6
636  END IF
637  IF( info.NE.0 ) THEN
638  CALL xerbla( 'ZGETRI', -info )
639  RETURN
640  ELSE IF( lquery ) THEN
641  RETURN
642  END IF
643  IF( n.EQ.0 )
644  $ RETURN
645  CALL ztrtri( 'Upper', 'Non-unit', n, a, lda, info )
646  IF( info.GT.0 )
647  $ RETURN
648  nbmin = 2
649  ldwork = n
650  IF( nb.GT.1 .AND. nb.LT.n ) THEN
651  iws = max( ldwork*nb, 1 )
652  IF( lwork.LT.iws ) THEN
653  nb = lwork / ldwork
654  nbmin = max( 2, ilaenv( 2, 'ZGETRI', ' ', n, -1, -1, -1 ) )
655  END IF
656  ELSE
657  iws = n
658  END IF
659  IF( nb.LT.nbmin .OR. nb.GE.n ) THEN
660  DO 20 j = n, 1, -1
661  DO 10 i = j + 1, n
662  work( i ) = a( i, j )
663  a( i, j ) = zero
664  10 CONTINUE
665  IF( j.LT.n )
666  $ CALL zgemv( 'No transpose', n, n-j, -one, a( 1, j+1 ),
667  $ lda, work( j+1 ), 1, one, a( 1, j ), 1 )
668  20 CONTINUE
669  ELSE
670  nn = ( ( n-1 ) / nb )*nb + 1
671  DO 50 j = nn, 1, -nb
672  jb = min( nb, n-j+1 )
673  DO 40 jj = j, j + jb - 1
674  DO 30 i = jj + 1, n
675  work( i+( jj-j )*ldwork ) = a( i, jj )
676  a( i, jj ) = zero
677  30 CONTINUE
678  40 CONTINUE
679  IF( j+jb.LE.n )
680  $ CALL zgemm( 'No transpose', 'No transpose', n, jb,
681  $ n-j-jb+1, -one, a( 1, j+jb ), lda,
682  $ work( j+jb ), ldwork, one, a( 1, j ), lda )
683  CALL ztrsm( 'Right', 'Lower', 'No transpose', 'Unit', n, jb,
684  $ one, work( j ), ldwork, a( 1, j ), lda )
685  50 CONTINUE
686  END IF
687  DO 60 j = n - 1, 1, -1
688  jp = ipiv( j )
689  IF( jp.NE.j )
690  $ CALL zswap( n, a( 1, j ), 1, a( 1, jp ), 1 )
691  60 CONTINUE
692  work( 1 ) = iws
693  RETURN
694  END
695 
696  SUBROUTINE ztrti2( UPLO, DIAG, N, A, LDA, INFO )
697  CHARACTER DIAG, UPLO
698  INTEGER INFO, LDA, N
699  COMPLEX*32 A( LDA, * )
700  COMPLEX*32 ONE
701  parameter( one = ( 1.0q+0, 0.0q+0 ) )
702  LOGICAL NOUNIT, UPPER
703  INTEGER J
704  COMPLEX*32 AJJ
705  LOGICAL LSAME
706  EXTERNAL lsame
707  EXTERNAL xerbla, zscal, ztrmv
708  INTRINSIC max
709  info = 0
710  upper = lsame( uplo, 'U' )
711  nounit = lsame( diag, 'N' )
712  IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
713  info = -1
714  ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
715  info = -2
716  ELSE IF( n.LT.0 ) THEN
717  info = -3
718  ELSE IF( lda.LT.max( 1, n ) ) THEN
719  info = -5
720  END IF
721  IF( info.NE.0 ) THEN
722  CALL xerbla( 'ZTRTI2', -info )
723  RETURN
724  END IF
725  IF( upper ) THEN
726  DO 10 j = 1, n
727  IF( nounit ) THEN
728  a( j, j ) = one / a( j, j )
729  ajj = -a( j, j )
730  ELSE
731  ajj = -one
732  END IF
733  CALL ztrmv( 'Upper', 'No transpose', diag, j-1, a, lda,
734  $ a( 1, j ), 1 )
735  CALL zscal( j-1, ajj, a( 1, j ), 1 )
736  10 CONTINUE
737  ELSE
738  DO 20 j = n, 1, -1
739  IF( nounit ) THEN
740  a( j, j ) = one / a( j, j )
741  ajj = -a( j, j )
742  ELSE
743  ajj = -one
744  END IF
745  IF( j.LT.n ) THEN
746  CALL ztrmv( 'Lower', 'No transpose', diag, n-j,
747  $ a( j+1, j+1 ), lda, a( j+1, j ), 1 )
748  CALL zscal( n-j, ajj, a( j+1, j ), 1 )
749  END IF
750  20 CONTINUE
751  END IF
752  RETURN
753  END
754 
755  SUBROUTINE ztrtri( UPLO, DIAG, N, A, LDA, INFO )
756  CHARACTER DIAG, UPLO
757  INTEGER INFO, LDA, N
758  COMPLEX*32 A( LDA, * )
759  COMPLEX*32 ONE, ZERO
760  parameter( one = ( 1.0q+0, 0.0q+0 ),
761  $ zero = ( 0.0q+0, 0.0q+0 ) )
762  LOGICAL NOUNIT, UPPER
763  INTEGER J, JB, NB, NN
764  LOGICAL LSAME
765  INTEGER ILAENV
766  EXTERNAL lsame, ilaenv
767  EXTERNAL xerbla, ztrmm, ztrsm, ztrti2
768  INTRINSIC max, min
769  info = 0
770  upper = lsame( uplo, 'U' )
771  nounit = lsame( diag, 'N' )
772  IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
773  info = -1
774  ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
775  info = -2
776  ELSE IF( n.LT.0 ) THEN
777  info = -3
778  ELSE IF( lda.LT.max( 1, n ) ) THEN
779  info = -5
780  END IF
781  IF( info.NE.0 ) THEN
782  CALL xerbla( 'ZTRTRI', -info )
783  RETURN
784  END IF
785  IF( n.EQ.0 )
786  $ RETURN
787  IF( nounit ) THEN
788  DO 10 info = 1, n
789  IF( a( info, info ).EQ.zero )
790  $ RETURN
791  10 CONTINUE
792  info = 0
793  END IF
794  nb = ilaenv( 1, 'ZTRTRI', uplo // diag, n, -1, -1, -1 )
795  IF( nb.LE.1 .OR. nb.GE.n ) THEN
796  CALL ztrti2( uplo, diag, n, a, lda, info )
797  ELSE
798  IF( upper ) THEN
799  DO 20 j = 1, n, nb
800  jb = min( nb, n-j+1 )
801  CALL ztrmm( 'Left', 'Upper', 'No transpose', diag, j-1,
802  $ jb, one, a, lda, a( 1, j ), lda )
803  CALL ztrsm( 'Right', 'Upper', 'No transpose', diag, j-1,
804  $ jb, -one, a( j, j ), lda, a( 1, j ), lda )
805  CALL ztrti2( 'Upper', diag, jb, a( j, j ), lda, info )
806  20 CONTINUE
807  ELSE
808  nn = ( ( n-1 ) / nb )*nb + 1
809  DO 30 j = nn, 1, -nb
810  jb = min( nb, n-j+1 )
811  IF( j+jb.LE.n ) THEN
812  CALL ztrmm( 'Left', 'Lower', 'No transpose', diag,
813  $ n-j-jb+1, jb, one, a( j+jb, j+jb ), lda,
814  $ a( j+jb, j ), lda )
815  CALL ztrsm( 'Right', 'Lower', 'No transpose', diag,
816  $ n-j-jb+1, jb, -one, a( j, j ), lda,
817  $ a( j+jb, j ), lda )
818  END IF
819  CALL ztrti2( 'Lower', diag, jb, a( j, j ), lda, info )
820  30 CONTINUE
821  END IF
822  END IF
823  RETURN
824  END
825 
826  LOGICAL FUNCTION lsame( CA, CB )
827  CHARACTER ca, cb
828  INTRINSIC ichar
829  INTEGER inta, intb, zcode
830  lsame = ca.EQ.cb
831  IF( lsame )
832  $ RETURN
833  zcode = ichar( 'Z' )
834  inta = ichar( ca )
835  intb = ichar( cb )
836  IF( zcode.EQ.90 .OR. zcode.EQ.122 ) THEN
837  IF( inta.GE.97 .AND. inta.LE.122 ) inta = inta - 32
838  IF( intb.GE.97 .AND. intb.LE.122 ) intb = intb - 32
839  ELSE IF( zcode.EQ.233 .OR. zcode.EQ.169 ) THEN
840  IF( inta.GE.129 .AND. inta.LE.137 .OR.
841  $ inta.GE.145 .AND. inta.LE.153 .OR.
842  $ inta.GE.162 .AND. inta.LE.169 ) inta = inta + 64
843  IF( intb.GE.129 .AND. intb.LE.137 .OR.
844  $ intb.GE.145 .AND. intb.LE.153 .OR.
845  $ intb.GE.162 .AND. intb.LE.169 ) intb = intb + 64
846  ELSE IF( zcode.EQ.218 .OR. zcode.EQ.250 ) THEN
847  IF( inta.GE.225 .AND. inta.LE.250 ) inta = inta - 32
848  IF( intb.GE.225 .AND. intb.LE.250 ) intb = intb - 32
849  END IF
850  lsame = inta.EQ.intb
851  END
852 
853  integer function izamax(n,zx,incx)
854  complex*32 zx(*)
855  real*16 smax
856  integer i,incx,ix,n
857  real*16 dcabs1
858  izamax = 0
859  if( n.lt.1 .or. incx.le.0 )return
860  izamax = 1
861  if(n.eq.1)return
862  if(incx.eq.1)go to 20
863  ix = 1
864  smax = dcabs1(zx(1))
865  ix = ix + incx
866  do 10 i = 2,n
867  if(dcabs1(zx(ix)).le.smax) go to 5
868  izamax = i
869  smax = dcabs1(zx(ix))
870  5 ix = ix + incx
871  10 continue
872  return
873  20 smax = dcabs1(zx(1))
874  do 30 i = 2,n
875  if(dcabs1(zx(i)).le.smax) go to 30
876  izamax = i
877  smax = dcabs1(zx(i))
878  30 continue
879  return
880  end
881 
882  real*16 function dcabs1(z)
883  complex*32 z,zz
884  real*16 t(2)
885  equivalence(zz,t(1))
886  zz = z
887  dcabs1 = qabs(t(1)) + qabs(t(2))
888  return
889  end
890 
891  subroutine zswap (n,zx,incx,zy,incy)
892  complex*32 zx(*),zy(*),ztemp
893  integer i,incx,incy,ix,iy,n
894  if(n.le.0)return
895  if(incx.eq.1.and.incy.eq.1)go to 20
896  ix = 1
897  iy = 1
898  if(incx.lt.0)ix = (-n+1)*incx + 1
899  if(incy.lt.0)iy = (-n+1)*incy + 1
900  do 10 i = 1,n
901  ztemp = zx(ix)
902  zx(ix) = zy(iy)
903  zy(iy) = ztemp
904  ix = ix + incx
905  iy = iy + incy
906  10 continue
907  return
908  20 do 30 i = 1,n
909  ztemp = zx(i)
910  zx(i) = zy(i)
911  zy(i) = ztemp
912  30 continue
913  return
914  end
915 
916  subroutine zscal(n,za,zx,incx)
917  complex*32 za,zx(*)
918  integer i,incx,ix,n
919  if( n.le.0 .or. incx.le.0 )return
920  if(incx.eq.1)go to 20
921  ix = 1
922  do 10 i = 1,n
923  zx(ix) = za*zx(ix)
924  ix = ix + incx
925  10 continue
926  return
927  20 do 30 i = 1,n
928  zx(i) = za*zx(i)
929  30 continue
930  return
931  end
932 
933  SUBROUTINE zgeru ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
934  COMPLEX*32 ALPHA
935  INTEGER INCX, INCY, LDA, M, N
936  COMPLEX*32 A( LDA, * ), X( * ), Y( * )
937  COMPLEX*32 ZERO
938  parameter( zero = ( 0.0q+0, 0.0q+0 ) )
939  COMPLEX*32 TEMP
940  INTEGER I, INFO, IX, J, JY, KX
941  EXTERNAL xerbla
942  INTRINSIC max
943  info = 0
944  IF ( m.LT.0 )THEN
945  info = 1
946  ELSE IF( n.LT.0 )THEN
947  info = 2
948  ELSE IF( incx.EQ.0 )THEN
949  info = 5
950  ELSE IF( incy.EQ.0 )THEN
951  info = 7
952  ELSE IF( lda.LT.max( 1, m ) )THEN
953  info = 9
954  END IF
955  IF( info.NE.0 )THEN
956  CALL xerbla( 'ZGERU ', info )
957  RETURN
958  END IF
959  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.( alpha.EQ.zero ) )
960  $ RETURN
961  IF( incy.GT.0 )THEN
962  jy = 1
963  ELSE
964  jy = 1 - ( n - 1 )*incy
965  END IF
966  IF( incx.EQ.1 )THEN
967  DO 20, j = 1, n
968  IF( y( jy ).NE.zero )THEN
969  temp = alpha*y( jy )
970  DO 10, i = 1, m
971  a( i, j ) = a( i, j ) + x( i )*temp
972  10 CONTINUE
973  END IF
974  jy = jy + incy
975  20 CONTINUE
976  ELSE
977  IF( incx.GT.0 )THEN
978  kx = 1
979  ELSE
980  kx = 1 - ( m - 1 )*incx
981  END IF
982  DO 40, j = 1, n
983  IF( y( jy ).NE.zero )THEN
984  temp = alpha*y( jy )
985  ix = kx
986  DO 30, i = 1, m
987  a( i, j ) = a( i, j ) + x( ix )*temp
988  ix = ix + incx
989  30 CONTINUE
990  END IF
991  jy = jy + incy
992  40 CONTINUE
993  END IF
994  RETURN
995  END
996 
997  SUBROUTINE ztrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
998  $ B, LDB )
999  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
1000  INTEGER M, N, LDA, LDB
1001  COMPLEX*32 ALPHA
1002  COMPLEX*32 A( LDA, * ), B( LDB, * )
1003  LOGICAL LSAME
1004  EXTERNAL lsame
1005  EXTERNAL xerbla
1006  INTRINSIC qconjg, max
1007  LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER
1008  INTEGER I, INFO, J, K, NROWA
1009  COMPLEX*32 TEMP
1010  COMPLEX*32 ONE
1011  parameter( one = ( 1.0q+0, 0.0q+0 ) )
1012  COMPLEX*32 ZERO
1013  parameter( zero = ( 0.0q+0, 0.0q+0 ) )
1014  lside = lsame( side , 'L' )
1015  IF( lside )THEN
1016  nrowa = m
1017  ELSE
1018  nrowa = n
1019  END IF
1020  noconj = lsame( transa, 'T' )
1021  nounit = lsame( diag , 'N' )
1022  upper = lsame( uplo , 'U' )
1023  info = 0
1024  IF( ( .NOT.lside ).AND.
1025  $ ( .NOT.lsame( side , 'R' ) ) )THEN
1026  info = 1
1027  ELSE IF( ( .NOT.upper ).AND.
1028  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
1029  info = 2
1030  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
1031  $ ( .NOT.lsame( transa, 'T' ) ).AND.
1032  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
1033  info = 3
1034  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
1035  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
1036  info = 4
1037  ELSE IF( m .LT.0 )THEN
1038  info = 5
1039  ELSE IF( n .LT.0 )THEN
1040  info = 6
1041  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
1042  info = 9
1043  ELSE IF( ldb.LT.max( 1, m ) )THEN
1044  info = 11
1045  END IF
1046  IF( info.NE.0 )THEN
1047  CALL xerbla( 'ZTRSM ', info )
1048  RETURN
1049  END IF
1050  IF( n.EQ.0 )
1051  $ RETURN
1052  IF( alpha.EQ.zero )THEN
1053  DO 20, j = 1, n
1054  DO 10, i = 1, m
1055  b( i, j ) = zero
1056  10 CONTINUE
1057  20 CONTINUE
1058  RETURN
1059  END IF
1060  IF( lside )THEN
1061  IF( lsame( transa, 'N' ) )THEN
1062  IF( upper )THEN
1063  DO 60, j = 1, n
1064  IF( alpha.NE.one )THEN
1065  DO 30, i = 1, m
1066  b( i, j ) = alpha*b( i, j )
1067  30 CONTINUE
1068  END IF
1069  DO 50, k = m, 1, -1
1070  IF( b( k, j ).NE.zero )THEN
1071  IF( nounit )
1072  $ b( k, j ) = b( k, j )/a( k, k )
1073  DO 40, i = 1, k - 1
1074  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
1075  40 CONTINUE
1076  END IF
1077  50 CONTINUE
1078  60 CONTINUE
1079  ELSE
1080  DO 100, j = 1, n
1081  IF( alpha.NE.one )THEN
1082  DO 70, i = 1, m
1083  b( i, j ) = alpha*b( i, j )
1084  70 CONTINUE
1085  END IF
1086  DO 90 k = 1, m
1087  IF( b( k, j ).NE.zero )THEN
1088  IF( nounit )
1089  $ b( k, j ) = b( k, j )/a( k, k )
1090  DO 80, i = k + 1, m
1091  b( i, j ) = b( i, j ) - b( k, j )*a( i, k )
1092  80 CONTINUE
1093  END IF
1094  90 CONTINUE
1095  100 CONTINUE
1096  END IF
1097  ELSE
1098  IF( upper )THEN
1099  DO 140, j = 1, n
1100  DO 130, i = 1, m
1101  temp = alpha*b( i, j )
1102  IF( noconj )THEN
1103  DO 110, k = 1, i - 1
1104  temp = temp - a( k, i )*b( k, j )
1105  110 CONTINUE
1106  IF( nounit )
1107  $ temp = temp/a( i, i )
1108  ELSE
1109  DO 120, k = 1, i - 1
1110  temp = temp - qconjg( a( k, i ) )*b( k, j )
1111  120 CONTINUE
1112  IF( nounit )
1113  $ temp = temp/qconjg( a( i, i ) )
1114  END IF
1115  b( i, j ) = temp
1116  130 CONTINUE
1117  140 CONTINUE
1118  ELSE
1119  DO 180, j = 1, n
1120  DO 170, i = m, 1, -1
1121  temp = alpha*b( i, j )
1122  IF( noconj )THEN
1123  DO 150, k = i + 1, m
1124  temp = temp - a( k, i )*b( k, j )
1125  150 CONTINUE
1126  IF( nounit )
1127  $ temp = temp/a( i, i )
1128  ELSE
1129  DO 160, k = i + 1, m
1130  temp = temp - qconjg( a( k, i ) )*b( k, j )
1131  160 CONTINUE
1132  IF( nounit )
1133  $ temp = temp/qconjg( a( i, i ) )
1134  END IF
1135  b( i, j ) = temp
1136  170 CONTINUE
1137  180 CONTINUE
1138  END IF
1139  END IF
1140  ELSE
1141  IF( lsame( transa, 'N' ) )THEN
1142  IF( upper )THEN
1143  DO 230, j = 1, n
1144  IF( alpha.NE.one )THEN
1145  DO 190, i = 1, m
1146  b( i, j ) = alpha*b( i, j )
1147  190 CONTINUE
1148  END IF
1149  DO 210, k = 1, j - 1
1150  IF( a( k, j ).NE.zero )THEN
1151  DO 200, i = 1, m
1152  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
1153  200 CONTINUE
1154  END IF
1155  210 CONTINUE
1156  IF( nounit )THEN
1157  temp = one/a( j, j )
1158  DO 220, i = 1, m
1159  b( i, j ) = temp*b( i, j )
1160  220 CONTINUE
1161  END IF
1162  230 CONTINUE
1163  ELSE
1164  DO 280, j = n, 1, -1
1165  IF( alpha.NE.one )THEN
1166  DO 240, i = 1, m
1167  b( i, j ) = alpha*b( i, j )
1168  240 CONTINUE
1169  END IF
1170  DO 260, k = j + 1, n
1171  IF( a( k, j ).NE.zero )THEN
1172  DO 250, i = 1, m
1173  b( i, j ) = b( i, j ) - a( k, j )*b( i, k )
1174  250 CONTINUE
1175  END IF
1176  260 CONTINUE
1177  IF( nounit )THEN
1178  temp = one/a( j, j )
1179  DO 270, i = 1, m
1180  b( i, j ) = temp*b( i, j )
1181  270 CONTINUE
1182  END IF
1183  280 CONTINUE
1184  END IF
1185  ELSE
1186  IF( upper )THEN
1187  DO 330, k = n, 1, -1
1188  IF( nounit )THEN
1189  IF( noconj )THEN
1190  temp = one/a( k, k )
1191  ELSE
1192  temp = one/qconjg( a( k, k ) )
1193  END IF
1194  DO 290, i = 1, m
1195  b( i, k ) = temp*b( i, k )
1196  290 CONTINUE
1197  END IF
1198  DO 310, j = 1, k - 1
1199  IF( a( j, k ).NE.zero )THEN
1200  IF( noconj )THEN
1201  temp = a( j, k )
1202  ELSE
1203  temp = qconjg( a( j, k ) )
1204  END IF
1205  DO 300, i = 1, m
1206  b( i, j ) = b( i, j ) - temp*b( i, k )
1207  300 CONTINUE
1208  END IF
1209  310 CONTINUE
1210  IF( alpha.NE.one )THEN
1211  DO 320, i = 1, m
1212  b( i, k ) = alpha*b( i, k )
1213  320 CONTINUE
1214  END IF
1215  330 CONTINUE
1216  ELSE
1217  DO 380, k = 1, n
1218  IF( nounit )THEN
1219  IF( noconj )THEN
1220  temp = one/a( k, k )
1221  ELSE
1222  temp = one/qconjg( a( k, k ) )
1223  END IF
1224  DO 340, i = 1, m
1225  b( i, k ) = temp*b( i, k )
1226  340 CONTINUE
1227  END IF
1228  DO 360, j = k + 1, n
1229  IF( a( j, k ).NE.zero )THEN
1230  IF( noconj )THEN
1231  temp = a( j, k )
1232  ELSE
1233  temp = qconjg( a( j, k ) )
1234  END IF
1235  DO 350, i = 1, m
1236  b( i, j ) = b( i, j ) - temp*b( i, k )
1237  350 CONTINUE
1238  END IF
1239  360 CONTINUE
1240  IF( alpha.NE.one )THEN
1241  DO 370, i = 1, m
1242  b( i, k ) = alpha*b( i, k )
1243  370 CONTINUE
1244  END IF
1245  380 CONTINUE
1246  END IF
1247  END IF
1248  END IF
1249  RETURN
1250  END
1251 
1252  SUBROUTINE zgemm ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
1253  $ BETA, C, LDC )
1254  CHARACTER*1 TRANSA, TRANSB
1255  INTEGER M, N, K, LDA, LDB, LDC
1256  COMPLEX*32 ALPHA, BETA
1257  COMPLEX*32 A( LDA, * ), B( LDB, * ), C( LDC, * )
1258  LOGICAL LSAME
1259  EXTERNAL lsame
1260  EXTERNAL xerbla
1261  INTRINSIC qconjg, max
1262  LOGICAL CONJA, CONJB, NOTA, NOTB
1263  INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
1264  COMPLEX*32 TEMP
1265  COMPLEX*32 ONE
1266  parameter( one = ( 1.0q+0, 0.0q+0 ) )
1267  COMPLEX*32 ZERO
1268  parameter( zero = ( 0.0q+0, 0.0q+0 ) )
1269  nota = lsame( transa, 'N' )
1270  notb = lsame( transb, 'N' )
1271  conja = lsame( transa, 'C' )
1272  conjb = lsame( transb, 'C' )
1273  IF( nota )THEN
1274  nrowa = m
1275  ncola = k
1276  ELSE
1277  nrowa = k
1278  ncola = m
1279  END IF
1280  IF( notb )THEN
1281  nrowb = k
1282  ELSE
1283  nrowb = n
1284  END IF
1285  info = 0
1286  IF( ( .NOT.nota ).AND.
1287  $ ( .NOT.conja ).AND.
1288  $ ( .NOT.lsame( transa, 'T' ) ) )THEN
1289  info = 1
1290  ELSE IF( ( .NOT.notb ).AND.
1291  $ ( .NOT.conjb ).AND.
1292  $ ( .NOT.lsame( transb, 'T' ) ) )THEN
1293  info = 2
1294  ELSE IF( m .LT.0 )THEN
1295  info = 3
1296  ELSE IF( n .LT.0 )THEN
1297  info = 4
1298  ELSE IF( k .LT.0 )THEN
1299  info = 5
1300  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
1301  info = 8
1302  ELSE IF( ldb.LT.max( 1, nrowb ) )THEN
1303  info = 10
1304  ELSE IF( ldc.LT.max( 1, m ) )THEN
1305  info = 13
1306  END IF
1307  IF( info.NE.0 )THEN
1308  CALL xerbla( 'ZGEMM ', info )
1309  RETURN
1310  END IF
1311  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
1312  $ ( ( ( alpha.EQ.zero ).OR.( k.EQ.0 ) ).AND.( beta.EQ.one ) ) )
1313  $ RETURN
1314  IF( alpha.EQ.zero )THEN
1315  IF( beta.EQ.zero )THEN
1316  DO 20, j = 1, n
1317  DO 10, i = 1, m
1318  c( i, j ) = zero
1319  10 CONTINUE
1320  20 CONTINUE
1321  ELSE
1322  DO 40, j = 1, n
1323  DO 30, i = 1, m
1324  c( i, j ) = beta*c( i, j )
1325  30 CONTINUE
1326  40 CONTINUE
1327  END IF
1328  RETURN
1329  END IF
1330  IF( notb )THEN
1331  IF( nota )THEN
1332  DO 90, j = 1, n
1333  IF( beta.EQ.zero )THEN
1334  DO 50, i = 1, m
1335  c( i, j ) = zero
1336  50 CONTINUE
1337  ELSE IF( beta.NE.one )THEN
1338  DO 60, i = 1, m
1339  c( i, j ) = beta*c( i, j )
1340  60 CONTINUE
1341  END IF
1342  DO 80, l = 1, k
1343  IF( b( l, j ).NE.zero )THEN
1344  temp = alpha*b( l, j )
1345  DO 70, i = 1, m
1346  c( i, j ) = c( i, j ) + temp*a( i, l )
1347  70 CONTINUE
1348  END IF
1349  80 CONTINUE
1350  90 CONTINUE
1351  ELSE IF( conja )THEN
1352  DO 120, j = 1, n
1353  DO 110, i = 1, m
1354  temp = zero
1355  DO 100, l = 1, k
1356  temp = temp + qconjg( a( l, i ) )*b( l, j )
1357  100 CONTINUE
1358  IF( beta.EQ.zero )THEN
1359  c( i, j ) = alpha*temp
1360  ELSE
1361  c( i, j ) = alpha*temp + beta*c( i, j )
1362  END IF
1363  110 CONTINUE
1364  120 CONTINUE
1365  ELSE
1366  DO 150, j = 1, n
1367  DO 140, i = 1, m
1368  temp = zero
1369  DO 130, l = 1, k
1370  temp = temp + a( l, i )*b( l, j )
1371  130 CONTINUE
1372  IF( beta.EQ.zero )THEN
1373  c( i, j ) = alpha*temp
1374  ELSE
1375  c( i, j ) = alpha*temp + beta*c( i, j )
1376  END IF
1377  140 CONTINUE
1378  150 CONTINUE
1379  END IF
1380  ELSE IF( nota )THEN
1381  IF( conjb )THEN
1382  DO 200, j = 1, n
1383  IF( beta.EQ.zero )THEN
1384  DO 160, i = 1, m
1385  c( i, j ) = zero
1386  160 CONTINUE
1387  ELSE IF( beta.NE.one )THEN
1388  DO 170, i = 1, m
1389  c( i, j ) = beta*c( i, j )
1390  170 CONTINUE
1391  END IF
1392  DO 190, l = 1, k
1393  IF( b( j, l ).NE.zero )THEN
1394  temp = alpha*qconjg( b( j, l ) )
1395  DO 180, i = 1, m
1396  c( i, j ) = c( i, j ) + temp*a( i, l )
1397  180 CONTINUE
1398  END IF
1399  190 CONTINUE
1400  200 CONTINUE
1401  ELSE
1402  DO 250, j = 1, n
1403  IF( beta.EQ.zero )THEN
1404  DO 210, i = 1, m
1405  c( i, j ) = zero
1406  210 CONTINUE
1407  ELSE IF( beta.NE.one )THEN
1408  DO 220, i = 1, m
1409  c( i, j ) = beta*c( i, j )
1410  220 CONTINUE
1411  END IF
1412  DO 240, l = 1, k
1413  IF( b( j, l ).NE.zero )THEN
1414  temp = alpha*b( j, l )
1415  DO 230, i = 1, m
1416  c( i, j ) = c( i, j ) + temp*a( i, l )
1417  230 CONTINUE
1418  END IF
1419  240 CONTINUE
1420  250 CONTINUE
1421  END IF
1422  ELSE IF( conja )THEN
1423  IF( conjb )THEN
1424  DO 280, j = 1, n
1425  DO 270, i = 1, m
1426  temp = zero
1427  DO 260, l = 1, k
1428  temp = temp +
1429  $ qconjg( a( l, i ) )*qconjg( b( j, l ) )
1430  260 CONTINUE
1431  IF( beta.EQ.zero )THEN
1432  c( i, j ) = alpha*temp
1433  ELSE
1434  c( i, j ) = alpha*temp + beta*c( i, j )
1435  END IF
1436  270 CONTINUE
1437  280 CONTINUE
1438  ELSE
1439  DO 310, j = 1, n
1440  DO 300, i = 1, m
1441  temp = zero
1442  DO 290, l = 1, k
1443  temp = temp + qconjg( a( l, i ) )*b( j, l )
1444  290 CONTINUE
1445  IF( beta.EQ.zero )THEN
1446  c( i, j ) = alpha*temp
1447  ELSE
1448  c( i, j ) = alpha*temp + beta*c( i, j )
1449  END IF
1450  300 CONTINUE
1451  310 CONTINUE
1452  END IF
1453  ELSE
1454  IF( conjb )THEN
1455  DO 340, j = 1, n
1456  DO 330, i = 1, m
1457  temp = zero
1458  DO 320, l = 1, k
1459  temp = temp + a( l, i )*qconjg( b( j, l ) )
1460  320 CONTINUE
1461  IF( beta.EQ.zero )THEN
1462  c( i, j ) = alpha*temp
1463  ELSE
1464  c( i, j ) = alpha*temp + beta*c( i, j )
1465  END IF
1466  330 CONTINUE
1467  340 CONTINUE
1468  ELSE
1469  DO 370, j = 1, n
1470  DO 360, i = 1, m
1471  temp = zero
1472  DO 350, l = 1, k
1473  temp = temp + a( l, i )*b( j, l )
1474  350 CONTINUE
1475  IF( beta.EQ.zero )THEN
1476  c( i, j ) = alpha*temp
1477  ELSE
1478  c( i, j ) = alpha*temp + beta*c( i, j )
1479  END IF
1480  360 CONTINUE
1481  370 CONTINUE
1482  END IF
1483  END IF
1484  RETURN
1485  END
1486 
1487  SUBROUTINE ztrmv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
1488  INTEGER INCX, LDA, N
1489  CHARACTER*1 DIAG, TRANS, UPLO
1490  COMPLEX*32 A( LDA, * ), X( * )
1491  COMPLEX*32 ZERO
1492  parameter( zero = ( 0.0q+0, 0.0q+0 ) )
1493  COMPLEX*32 TEMP
1494  INTEGER I, INFO, IX, J, JX, KX
1495  LOGICAL NOCONJ, NOUNIT
1496  LOGICAL LSAME
1497  EXTERNAL lsame
1498  EXTERNAL xerbla
1499  INTRINSIC qconjg, max
1500  info = 0
1501  IF ( .NOT.lsame( uplo , 'U' ).AND.
1502  $ .NOT.lsame( uplo , 'L' ) )THEN
1503  info = 1
1504  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
1505  $ .NOT.lsame( trans, 'T' ).AND.
1506  $ .NOT.lsame( trans, 'C' ) )THEN
1507  info = 2
1508  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
1509  $ .NOT.lsame( diag , 'N' ) )THEN
1510  info = 3
1511  ELSE IF( n.LT.0 )THEN
1512  info = 4
1513  ELSE IF( lda.LT.max( 1, n ) )THEN
1514  info = 6
1515  ELSE IF( incx.EQ.0 )THEN
1516  info = 8
1517  END IF
1518  IF( info.NE.0 )THEN
1519  CALL xerbla( 'ZTRMV ', info )
1520  RETURN
1521  END IF
1522  IF( n.EQ.0 )
1523  $ RETURN
1524  noconj = lsame( trans, 'T' )
1525  nounit = lsame( diag , 'N' )
1526  IF( incx.LE.0 )THEN
1527  kx = 1 - ( n - 1 )*incx
1528  ELSE IF( incx.NE.1 )THEN
1529  kx = 1
1530  END IF
1531  IF( lsame( trans, 'N' ) )THEN
1532  IF( lsame( uplo, 'U' ) )THEN
1533  IF( incx.EQ.1 )THEN
1534  DO 20, j = 1, n
1535  IF( x( j ).NE.zero )THEN
1536  temp = x( j )
1537  DO 10, i = 1, j - 1
1538  x( i ) = x( i ) + temp*a( i, j )
1539  10 CONTINUE
1540  IF( nounit )
1541  $ x( j ) = x( j )*a( j, j )
1542  END IF
1543  20 CONTINUE
1544  ELSE
1545  jx = kx
1546  DO 40, j = 1, n
1547  IF( x( jx ).NE.zero )THEN
1548  temp = x( jx )
1549  ix = kx
1550  DO 30, i = 1, j - 1
1551  x( ix ) = x( ix ) + temp*a( i, j )
1552  ix = ix + incx
1553  30 CONTINUE
1554  IF( nounit )
1555  $ x( jx ) = x( jx )*a( j, j )
1556  END IF
1557  jx = jx + incx
1558  40 CONTINUE
1559  END IF
1560  ELSE
1561  IF( incx.EQ.1 )THEN
1562  DO 60, j = n, 1, -1
1563  IF( x( j ).NE.zero )THEN
1564  temp = x( j )
1565  DO 50, i = n, j + 1, -1
1566  x( i ) = x( i ) + temp*a( i, j )
1567  50 CONTINUE
1568  IF( nounit )
1569  $ x( j ) = x( j )*a( j, j )
1570  END IF
1571  60 CONTINUE
1572  ELSE
1573  kx = kx + ( n - 1 )*incx
1574  jx = kx
1575  DO 80, j = n, 1, -1
1576  IF( x( jx ).NE.zero )THEN
1577  temp = x( jx )
1578  ix = kx
1579  DO 70, i = n, j + 1, -1
1580  x( ix ) = x( ix ) + temp*a( i, j )
1581  ix = ix - incx
1582  70 CONTINUE
1583  IF( nounit )
1584  $ x( jx ) = x( jx )*a( j, j )
1585  END IF
1586  jx = jx - incx
1587  80 CONTINUE
1588  END IF
1589  END IF
1590  ELSE
1591  IF( lsame( uplo, 'U' ) )THEN
1592  IF( incx.EQ.1 )THEN
1593  DO 110, j = n, 1, -1
1594  temp = x( j )
1595  IF( noconj )THEN
1596  IF( nounit )
1597  $ temp = temp*a( j, j )
1598  DO 90, i = j - 1, 1, -1
1599  temp = temp + a( i, j )*x( i )
1600  90 CONTINUE
1601  ELSE
1602  IF( nounit )
1603  $ temp = temp*qconjg( a( j, j ) )
1604  DO 100, i = j - 1, 1, -1
1605  temp = temp + qconjg( a( i, j ) )*x( i )
1606  100 CONTINUE
1607  END IF
1608  x( j ) = temp
1609  110 CONTINUE
1610  ELSE
1611  jx = kx + ( n - 1 )*incx
1612  DO 140, j = n, 1, -1
1613  temp = x( jx )
1614  ix = jx
1615  IF( noconj )THEN
1616  IF( nounit )
1617  $ temp = temp*a( j, j )
1618  DO 120, i = j - 1, 1, -1
1619  ix = ix - incx
1620  temp = temp + a( i, j )*x( ix )
1621  120 CONTINUE
1622  ELSE
1623  IF( nounit )
1624  $ temp = temp*qconjg( a( j, j ) )
1625  DO 130, i = j - 1, 1, -1
1626  ix = ix - incx
1627  temp = temp + qconjg( a( i, j ) )*x( ix )
1628  130 CONTINUE
1629  END IF
1630  x( jx ) = temp
1631  jx = jx - incx
1632  140 CONTINUE
1633  END IF
1634  ELSE
1635  IF( incx.EQ.1 )THEN
1636  DO 170, j = 1, n
1637  temp = x( j )
1638  IF( noconj )THEN
1639  IF( nounit )
1640  $ temp = temp*a( j, j )
1641  DO 150, i = j + 1, n
1642  temp = temp + a( i, j )*x( i )
1643  150 CONTINUE
1644  ELSE
1645  IF( nounit )
1646  $ temp = temp*qconjg( a( j, j ) )
1647  DO 160, i = j + 1, n
1648  temp = temp + qconjg( a( i, j ) )*x( i )
1649  160 CONTINUE
1650  END IF
1651  x( j ) = temp
1652  170 CONTINUE
1653  ELSE
1654  jx = kx
1655  DO 200, j = 1, n
1656  temp = x( jx )
1657  ix = jx
1658  IF( noconj )THEN
1659  IF( nounit )
1660  $ temp = temp*a( j, j )
1661  DO 180, i = j + 1, n
1662  ix = ix + incx
1663  temp = temp + a( i, j )*x( ix )
1664  180 CONTINUE
1665  ELSE
1666  IF( nounit )
1667  $ temp = temp*qconjg( a( j, j ) )
1668  DO 190, i = j + 1, n
1669  ix = ix + incx
1670  temp = temp + qconjg( a( i, j ) )*x( ix )
1671  190 CONTINUE
1672  END IF
1673  x( jx ) = temp
1674  jx = jx + incx
1675  200 CONTINUE
1676  END IF
1677  END IF
1678  END IF
1679  RETURN
1680  END
1681 
1682  SUBROUTINE ztrmm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
1683  $ B, LDB )
1684  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
1685  INTEGER M, N, LDA, LDB
1686  COMPLEX*32 ALPHA
1687  COMPLEX*32 A( LDA, * ), B( LDB, * )
1688  LOGICAL LSAME
1689  EXTERNAL lsame
1690  EXTERNAL xerbla
1691  INTRINSIC qconjg, max
1692  LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER
1693  INTEGER I, INFO, J, K, NROWA
1694  COMPLEX*32 TEMP
1695  COMPLEX*32 ONE
1696  parameter( one = ( 1.0q+0, 0.0q+0 ) )
1697  COMPLEX*32 ZERO
1698  parameter( zero = ( 0.0q+0, 0.0q+0 ) )
1699  lside = lsame( side , 'L' )
1700  IF( lside )THEN
1701  nrowa = m
1702  ELSE
1703  nrowa = n
1704  END IF
1705  noconj = lsame( transa, 'T' )
1706  nounit = lsame( diag , 'N' )
1707  upper = lsame( uplo , 'U' )
1708  info = 0
1709  IF( ( .NOT.lside ).AND.
1710  $ ( .NOT.lsame( side , 'R' ) ) )THEN
1711  info = 1
1712  ELSE IF( ( .NOT.upper ).AND.
1713  $ ( .NOT.lsame( uplo , 'L' ) ) )THEN
1714  info = 2
1715  ELSE IF( ( .NOT.lsame( transa, 'N' ) ).AND.
1716  $ ( .NOT.lsame( transa, 'T' ) ).AND.
1717  $ ( .NOT.lsame( transa, 'C' ) ) )THEN
1718  info = 3
1719  ELSE IF( ( .NOT.lsame( diag , 'U' ) ).AND.
1720  $ ( .NOT.lsame( diag , 'N' ) ) )THEN
1721  info = 4
1722  ELSE IF( m .LT.0 )THEN
1723  info = 5
1724  ELSE IF( n .LT.0 )THEN
1725  info = 6
1726  ELSE IF( lda.LT.max( 1, nrowa ) )THEN
1727  info = 9
1728  ELSE IF( ldb.LT.max( 1, m ) )THEN
1729  info = 11
1730  END IF
1731  IF( info.NE.0 )THEN
1732  CALL xerbla( 'ZTRMM ', info )
1733  RETURN
1734  END IF
1735  IF( n.EQ.0 )
1736  $ RETURN
1737  IF( alpha.EQ.zero )THEN
1738  DO 20, j = 1, n
1739  DO 10, i = 1, m
1740  b( i, j ) = zero
1741  10 CONTINUE
1742  20 CONTINUE
1743  RETURN
1744  END IF
1745  IF( lside )THEN
1746  IF( lsame( transa, 'N' ) )THEN
1747  IF( upper )THEN
1748  DO 50, j = 1, n
1749  DO 40, k = 1, m
1750  IF( b( k, j ).NE.zero )THEN
1751  temp = alpha*b( k, j )
1752  DO 30, i = 1, k - 1
1753  b( i, j ) = b( i, j ) + temp*a( i, k )
1754  30 CONTINUE
1755  IF( nounit )
1756  $ temp = temp*a( k, k )
1757  b( k, j ) = temp
1758  END IF
1759  40 CONTINUE
1760  50 CONTINUE
1761  ELSE
1762  DO 80, j = 1, n
1763  DO 70 k = m, 1, -1
1764  IF( b( k, j ).NE.zero )THEN
1765  temp = alpha*b( k, j )
1766  b( k, j ) = temp
1767  IF( nounit )
1768  $ b( k, j ) = b( k, j )*a( k, k )
1769  DO 60, i = k + 1, m
1770  b( i, j ) = b( i, j ) + temp*a( i, k )
1771  60 CONTINUE
1772  END IF
1773  70 CONTINUE
1774  80 CONTINUE
1775  END IF
1776  ELSE
1777  IF( upper )THEN
1778  DO 120, j = 1, n
1779  DO 110, i = m, 1, -1
1780  temp = b( i, j )
1781  IF( noconj )THEN
1782  IF( nounit )
1783  $ temp = temp*a( i, i )
1784  DO 90, k = 1, i - 1
1785  temp = temp + a( k, i )*b( k, j )
1786  90 CONTINUE
1787  ELSE
1788  IF( nounit )
1789  $ temp = temp*qconjg( a( i, i ) )
1790  DO 100, k = 1, i - 1
1791  temp = temp + qconjg( a( k, i ) )*b( k, j )
1792  100 CONTINUE
1793  END IF
1794  b( i, j ) = alpha*temp
1795  110 CONTINUE
1796  120 CONTINUE
1797  ELSE
1798  DO 160, j = 1, n
1799  DO 150, i = 1, m
1800  temp = b( i, j )
1801  IF( noconj )THEN
1802  IF( nounit )
1803  $ temp = temp*a( i, i )
1804  DO 130, k = i + 1, m
1805  temp = temp + a( k, i )*b( k, j )
1806  130 CONTINUE
1807  ELSE
1808  IF( nounit )
1809  $ temp = temp*qconjg( a( i, i ) )
1810  DO 140, k = i + 1, m
1811  temp = temp + qconjg( a( k, i ) )*b( k, j )
1812  140 CONTINUE
1813  END IF
1814  b( i, j ) = alpha*temp
1815  150 CONTINUE
1816  160 CONTINUE
1817  END IF
1818  END IF
1819  ELSE
1820  IF( lsame( transa, 'N' ) )THEN
1821  IF( upper )THEN
1822  DO 200, j = n, 1, -1
1823  temp = alpha
1824  IF( nounit )
1825  $ temp = temp*a( j, j )
1826  DO 170, i = 1, m
1827  b( i, j ) = temp*b( i, j )
1828  170 CONTINUE
1829  DO 190, k = 1, j - 1
1830  IF( a( k, j ).NE.zero )THEN
1831  temp = alpha*a( k, j )
1832  DO 180, i = 1, m
1833  b( i, j ) = b( i, j ) + temp*b( i, k )
1834  180 CONTINUE
1835  END IF
1836  190 CONTINUE
1837  200 CONTINUE
1838  ELSE
1839  DO 240, j = 1, n
1840  temp = alpha
1841  IF( nounit )
1842  $ temp = temp*a( j, j )
1843  DO 210, i = 1, m
1844  b( i, j ) = temp*b( i, j )
1845  210 CONTINUE
1846  DO 230, k = j + 1, n
1847  IF( a( k, j ).NE.zero )THEN
1848  temp = alpha*a( k, j )
1849  DO 220, i = 1, m
1850  b( i, j ) = b( i, j ) + temp*b( i, k )
1851  220 CONTINUE
1852  END IF
1853  230 CONTINUE
1854  240 CONTINUE
1855  END IF
1856  ELSE
1857  IF( upper )THEN
1858  DO 280, k = 1, n
1859  DO 260, j = 1, k - 1
1860  IF( a( j, k ).NE.zero )THEN
1861  IF( noconj )THEN
1862  temp = alpha*a( j, k )
1863  ELSE
1864  temp = alpha*qconjg( a( j, k ) )
1865  END IF
1866  DO 250, i = 1, m
1867  b( i, j ) = b( i, j ) + temp*b( i, k )
1868  250 CONTINUE
1869  END IF
1870  260 CONTINUE
1871  temp = alpha
1872  IF( nounit )THEN
1873  IF( noconj )THEN
1874  temp = temp*a( k, k )
1875  ELSE
1876  temp = temp*qconjg( a( k, k ) )
1877  END IF
1878  END IF
1879  IF( temp.NE.one )THEN
1880  DO 270, i = 1, m
1881  b( i, k ) = temp*b( i, k )
1882  270 CONTINUE
1883  END IF
1884  280 CONTINUE
1885  ELSE
1886  DO 320, k = n, 1, -1
1887  DO 300, j = k + 1, n
1888  IF( a( j, k ).NE.zero )THEN
1889  IF( noconj )THEN
1890  temp = alpha*a( j, k )
1891  ELSE
1892  temp = alpha*qconjg( a( j, k ) )
1893  END IF
1894  DO 290, i = 1, m
1895  b( i, j ) = b( i, j ) + temp*b( i, k )
1896  290 CONTINUE
1897  END IF
1898  300 CONTINUE
1899  temp = alpha
1900  IF( nounit )THEN
1901  IF( noconj )THEN
1902  temp = temp*a( k, k )
1903  ELSE
1904  temp = temp*qconjg( a( k, k ) )
1905  END IF
1906  END IF
1907  IF( temp.NE.one )THEN
1908  DO 310, i = 1, m
1909  b( i, k ) = temp*b( i, k )
1910  310 CONTINUE
1911  END IF
1912  320 CONTINUE
1913  END IF
1914  END IF
1915  END IF
1916  RETURN
1917  END
1918 
1919  SUBROUTINE zgemv ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
1920  $ BETA, Y, INCY )
1921  COMPLEX*32 ALPHA, BETA
1922  INTEGER INCX, INCY, LDA, M, N
1923  CHARACTER*1 TRANS
1924  COMPLEX*32 A( LDA, * ), X( * ), Y( * )
1925  COMPLEX*32 ONE
1926  parameter( one = ( 1.0q+0, 0.0q+0 ) )
1927  COMPLEX*32 ZERO
1928  parameter( zero = ( 0.0q+0, 0.0q+0 ) )
1929  COMPLEX*32 TEMP
1930  INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
1931  LOGICAL NOCONJ
1932  LOGICAL LSAME
1933  EXTERNAL lsame
1934  EXTERNAL xerbla
1935  INTRINSIC qconjg, max
1936  info = 0
1937  IF ( .NOT.lsame( trans, 'N' ).AND.
1938  $ .NOT.lsame( trans, 'T' ).AND.
1939  $ .NOT.lsame( trans, 'C' ) )THEN
1940  info = 1
1941  ELSE IF( m.LT.0 )THEN
1942  info = 2
1943  ELSE IF( n.LT.0 )THEN
1944  info = 3
1945  ELSE IF( lda.LT.max( 1, m ) )THEN
1946  info = 6
1947  ELSE IF( incx.EQ.0 )THEN
1948  info = 8
1949  ELSE IF( incy.EQ.0 )THEN
1950  info = 11
1951  END IF
1952  IF( info.NE.0 )THEN
1953  CALL xerbla( 'ZGEMV ', info )
1954  RETURN
1955  END IF
1956  IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
1957  $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
1958  $ RETURN
1959  noconj = lsame( trans, 'T' )
1960  IF( lsame( trans, 'N' ) )THEN
1961  lenx = n
1962  leny = m
1963  ELSE
1964  lenx = m
1965  leny = n
1966  END IF
1967  IF( incx.GT.0 )THEN
1968  kx = 1
1969  ELSE
1970  kx = 1 - ( lenx - 1 )*incx
1971  END IF
1972  IF( incy.GT.0 )THEN
1973  ky = 1
1974  ELSE
1975  ky = 1 - ( leny - 1 )*incy
1976  END IF
1977  IF( beta.NE.one )THEN
1978  IF( incy.EQ.1 )THEN
1979  IF( beta.EQ.zero )THEN
1980  DO 10, i = 1, leny
1981  y( i ) = zero
1982  10 CONTINUE
1983  ELSE
1984  DO 20, i = 1, leny
1985  y( i ) = beta*y( i )
1986  20 CONTINUE
1987  END IF
1988  ELSE
1989  iy = ky
1990  IF( beta.EQ.zero )THEN
1991  DO 30, i = 1, leny
1992  y( iy ) = zero
1993  iy = iy + incy
1994  30 CONTINUE
1995  ELSE
1996  DO 40, i = 1, leny
1997  y( iy ) = beta*y( iy )
1998  iy = iy + incy
1999  40 CONTINUE
2000  END IF
2001  END IF
2002  END IF
2003  IF( alpha.EQ.zero )
2004  $ RETURN
2005  IF( lsame( trans, 'N' ) )THEN
2006  jx = kx
2007  IF( incy.EQ.1 )THEN
2008  DO 60, j = 1, n
2009  IF( x( jx ).NE.zero )THEN
2010  temp = alpha*x( jx )
2011  DO 50, i = 1, m
2012  y( i ) = y( i ) + temp*a( i, j )
2013  50 CONTINUE
2014  END IF
2015  jx = jx + incx
2016  60 CONTINUE
2017  ELSE
2018  DO 80, j = 1, n
2019  IF( x( jx ).NE.zero )THEN
2020  temp = alpha*x( jx )
2021  iy = ky
2022  DO 70, i = 1, m
2023  y( iy ) = y( iy ) + temp*a( i, j )
2024  iy = iy + incy
2025  70 CONTINUE
2026  END IF
2027  jx = jx + incx
2028  80 CONTINUE
2029  END IF
2030  ELSE
2031  jy = ky
2032  IF( incx.EQ.1 )THEN
2033  DO 110, j = 1, n
2034  temp = zero
2035  IF( noconj )THEN
2036  DO 90, i = 1, m
2037  temp = temp + a( i, j )*x( i )
2038  90 CONTINUE
2039  ELSE
2040  DO 100, i = 1, m
2041  temp = temp + qconjg( a( i, j ) )*x( i )
2042  100 CONTINUE
2043  END IF
2044  y( jy ) = y( jy ) + alpha*temp
2045  jy = jy + incy
2046  110 CONTINUE
2047  ELSE
2048  DO 140, j = 1, n
2049  temp = zero
2050  ix = kx
2051  IF( noconj )THEN
2052  DO 120, i = 1, m
2053  temp = temp + a( i, j )*x( ix )
2054  ix = ix + incx
2055  120 CONTINUE
2056  ELSE
2057  DO 130, i = 1, m
2058  temp = temp + qconjg( a( i, j ) )*x( ix )
2059  ix = ix + incx
2060  130 CONTINUE
2061  END IF
2062  y( jy ) = y( jy ) + alpha*temp
2063  jy = jy + incy
2064  140 CONTINUE
2065  END IF
2066  END IF
2067  RETURN
2068  END
ztrmm
subroutine ztrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: lpd.f:3203
zlaswp
subroutine zlaswp(N, A, LDA, K1, K2, IPIV, INCX)
Definition: lpd.f:298
dcabs1
double precision function dcabs1(z)
Definition: lpd.f:1815
zgetf2
subroutine zgetf2(M, N, A, LDA, IPIV, INFO)
Definition: lpd.f:2
zswap
subroutine zswap(n, zx, incx, zy, incy)
Definition: lpd.f:1824
real
#define real
Definition: DbAlgOcean.cpp:26
parameter
README for MOD_PR03(V6.1.0) 2. POINTS OF CONTACT it can be either SDP Toolkit or MODIS Packet for Terra input files The orbit validation configuration parameter(LUN 600281) must be either "TRUE" or "FALSE". It needs to be "FALSE" when running in Near Real Time mode
ztrsm
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: lpd.f:2050
zscal
subroutine zscal(n, za, zx, incx)
Definition: lpd.f:1861
ieeeck
integer function ieeeck(ISPEC, ZERO, ONE)
Definition: lpd.f:418
zgetri
subroutine zgetri(N, A, LDA, IPIV, WORK, LWORK, INFO)
Definition: lpd.f:1160
zgetrf
subroutine zgetrf(M, N, A, LDA, IPIV, INFO)
Definition: lpd.f:138
zgemm
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
Definition: lpd.f:2465
max
#define max(A, B)
Definition: main_biosmap.c:61
xerbla
subroutine xerbla(SRNAME, INFO)
Definition: lpd.f:1113
min
#define min(A, B)
Definition: main_biosmap.c:62
ztrtri
subroutine ztrtri(UPLO, DIAG, N, A, LDA, INFO)
Definition: lpd.f:1501
ztrmv
subroutine ztrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: lpd.f:2880
zgeru
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
Definition: lpd.f:1891
zgemv
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
Definition: lpd.f:3596
ilaenv
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
Definition: lpd.f:567
izamax
integer function izamax(n, zx, incx)
Definition: lpd.f:1773
ztrti2
subroutine ztrti2(UPLO, DIAG, N, A, LDA, INFO)
Definition: lpd.f:1354
lsame
logical function lsame(CA, CB)
Definition: lpd.f:1680


ABOUT

Our Team

Contact Us

DATA

Get Started

Find Data

Use Data

TOOLS

SeaBASS

SeaDAS

Giovanni Data Visualizer

Worldview Mapping Interface

Level 3 Time Series Plotter

Request a SeaHawk Image

Mission Quality Monitor

HELP

Level 1 & 2 Browser Help

Level 3 & 4 Browser Help

File Search Help

Search & Download Help

Earthdata Forum

Join Mailing List

How to Cite Data

CONNECT WITH US
COMPLIANCE

Web Privacy Policy

Data & Information Policy

Communications Policy

Accessibility Policy

Freedom of Information Act

USA.gov

Responsible NASA Official: Sean Bailey
Curator: OceanColor Webmaster