1 SUBROUTINE blk3d(a, bm1, bp1, srces, mblk, nblocks)
11 INTEGER,
PARAMETER :: bytes_per_rprec = 8
15 INTEGER,
INTENT(in) :: nblocks, mblk
16 REAL(rprec),
DIMENSION(mblk,mblk,nblocks),
INTENT(in) ::
18 REAL(rprec),
DIMENSION(mblk,nblocks),
INTENT(inout) :: srces
24 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: ipiv
25 REAL(rprec),
DIMENSION(:,:),
ALLOCATABLE :: ainv
26 REAL(rprec),
DIMENSION(:,:,:),
ALLOCATABLE :: ql
30 EXTERNAL la_getrf, la_getrs
87 ALLOCATE (ql(mblk,mblk, nblocks), ainv(mblk,mblk), ipiv(mblk),
89 IF (ier .ne. 0) stop
'Allocation error in blk3d'
103 ainv = a(:,:,nblocks)
107 blocks:
DO k = nblocks, 1, -1
111 CALL la_getrf (mblk, mblk, ainv, mblk, ipiv, ier)
112 IF (ier .ne. 0)
GOTO 200
115 ql(:,:,k) = bm1(:,:,k)
116 CALL la_getrs(
'n', mblk, mblk, ainv,
117 1 mblk, ipiv, ql(1,1,k), mblk, ier)
118 CALL la_getrs(
'n', mblk, 1, ainv,
119 1 mblk,ipiv,srces(1,k),mblk,ier)
124 CALL la_getrs(
'n', mblk, 1, ainv,
125 1 mblk,ipiv,srces(1,k),mblk,ier)
134 ainv = a(:,:,k1) - matmul(bp1(:,:,k1), ql(:,:,k))
135 srces(:,k1) = srces(:,k1) - matmul(bp1(:,:,k1),srces(:,k))
146 srces(:,k) = srces(:,k) - matmul(ql(:,:,k),srces(:,k-1))
154 WRITE (6,
'(a,i4)')
' Error factoring matrix in blk3d: block = '
155 1 , k,
' error id = ', ier
161 WRITE (6,
'(a)')
' BLK3D: error in I/O routine WRDISK'
163 WRITE (6,
'(a)')
' BLK3D: error in I/O routine RDDISK'
166 WRITE (6,
'(2/a,i4,2/)')
' BLK3D: error detected: ier =',
176 DEALLOCATE (ainv, ql, ipiv)