Commit df628451 authored by Claus Kleinwort's avatar Claus Kleinwort
Browse files

Checking global parameters for disjoint blocks (-> block diagonal global matrix)

git-svn-id: http://svnsrv.desy.de/public/MillepedeII/trunk@183 3547b9b0-65b8-46d3-b95d-921b3f43af62
parent 7bcad0e0
...@@ -34,12 +34,12 @@ MODULE mpdalc ...@@ -34,12 +34,12 @@ MODULE mpdalc
!> allocate array !> allocate array
INTERFACE mpalloc INTERFACE mpalloc
MODULE PROCEDURE mpallocdvec, mpallocfvec, mpallocivec, & MODULE PROCEDURE mpallocdvec, mpallocfvec, mpallocivec, mpalloclvec, &
mpallocfarr, mpallociarr, mpalloclarr, mpalloclist, mpalloccvec mpallocfarr, mpallociarr, mpalloclarr, mpalloclist, mpalloccvec
END INTERFACE mpalloc END INTERFACE mpalloc
!> deallocate array !> deallocate array
INTERFACE mpdealloc INTERFACE mpdealloc
MODULE PROCEDURE mpdeallocdvec, mpdeallocfvec, mpdeallocivec, & MODULE PROCEDURE mpdeallocdvec, mpdeallocfvec, mpdeallocivec, mpdealloclvec, &
mpdeallocfarr, mpdeallociarr, mpdealloclarr, mpdealloclist, mpdealloccvec mpdeallocfarr, mpdeallociarr, mpdealloclarr, mpdealloclist, mpdealloccvec
END INTERFACE mpdealloc END INTERFACE mpdealloc
...@@ -78,6 +78,17 @@ CONTAINS ...@@ -78,6 +78,17 @@ CONTAINS
CALL mpalloccheck(ifail,length,text) CALL mpalloccheck(ifail,length,text)
END SUBROUTINE mpallocivec END SUBROUTINE mpallocivec
!> allocate (1D) large integer array
SUBROUTINE mpalloclvec(array,length,text)
INTEGER(mpl), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
INTEGER(mpl), INTENT(IN) :: length
CHARACTER (LEN=*), INTENT(IN) :: text
INTEGER(mpi) :: ifail
ALLOCATE (array(length),stat=ifail)
CALL mpalloccheck(ifail,length,text)
END SUBROUTINE mpalloclvec
!> allocate (2D) single precision array !> allocate (2D) single precision array
SUBROUTINE mpallocfarr(array,rows,cols,text) SUBROUTINE mpallocfarr(array,rows,cols,text)
REAL(mps), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array REAL(mps), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
...@@ -191,7 +202,18 @@ CONTAINS ...@@ -191,7 +202,18 @@ CONTAINS
CALL mpdealloccheck(ifail,isize) CALL mpdealloccheck(ifail,isize)
END SUBROUTINE mpdeallocivec END SUBROUTINE mpdeallocivec
!> allocate (2D) single precision array !> deallocate (1D) large integer array
SUBROUTINE mpdealloclvec(array)
INTEGER(mpl), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: array
INTEGER(mpi) :: ifail
INTEGER(mpl) :: isize
isize = size(array,kind=mpl)
DEALLOCATE (array,stat=ifail)
CALL mpdealloccheck(ifail,isize)
END SUBROUTINE mpdealloclvec
!> deallocate (2D) single precision array
SUBROUTINE mpdeallocfarr(array) SUBROUTINE mpdeallocfarr(array)
REAL(mps), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array REAL(mps), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
...@@ -202,7 +224,7 @@ CONTAINS ...@@ -202,7 +224,7 @@ CONTAINS
CALL mpdealloccheck(ifail,isize) CALL mpdealloccheck(ifail,isize)
END SUBROUTINE mpdeallocfarr END SUBROUTINE mpdeallocfarr
!> allocate (2D) integer array !> deallocate (2D) integer array
SUBROUTINE mpdeallociarr(array) SUBROUTINE mpdeallociarr(array)
INTEGER(mpi), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array INTEGER(mpi), DIMENSION(:,:), INTENT(IN OUT), ALLOCATABLE :: array
......
...@@ -32,7 +32,7 @@ MODULE mpmod ...@@ -32,7 +32,7 @@ MODULE mpmod
! steering parameters ! steering parameters
INTEGER(mpi) :: ictest=0 !< test mode '-t' INTEGER(mpi) :: ictest=0 !< test mode '-t'
INTEGER(mpi) :: metsol=0 !< solution method (1: inversion, 2: diagonalization, 3: \ref minresqlpmodule::minresqlp "MINRES-QLP") INTEGER(mpi) :: metsol=0 !< solution method (1: inversion, 2: diagonalization, 3: \ref minresqlpmodule::minresqlp "MINRES-QLP")
INTEGER(mpi) :: matsto=2 !< (global) matrix storage mode (1: full, 2: sparse) INTEGER(mpi) :: matsto=2 !< (global) matrix storage mode (1: full, 2: sparse, 3: block diagonal)
INTEGER(mpi) :: mprint=1 !< print flag (0: minimal, 1: normal, >1: more) INTEGER(mpi) :: mprint=1 !< print flag (0: minimal, 1: normal, >1: more)
INTEGER(mpi) :: mdebug=0 !< debug flag (number of records to print) INTEGER(mpi) :: mdebug=0 !< debug flag (number of records to print)
INTEGER(mpi) :: mdebg2=10 !< number of measurements for record debug printout INTEGER(mpi) :: mdebg2=10 !< number of measurements for record debug printout
...@@ -121,6 +121,7 @@ MODULE mpmod ...@@ -121,6 +121,7 @@ MODULE mpmod
INTEGER(mpi) :: nfgb !< number of fit parameters INTEGER(mpi) :: nfgb !< number of fit parameters
INTEGER(mpi) :: ncgb !< number of constraints INTEGER(mpi) :: ncgb !< number of constraints
INTEGER(mpi) :: ncgbe !< number of empty constraints (no variable parameters) INTEGER(mpi) :: ncgbe !< number of empty constraints (no variable parameters)
INTEGER(mpi) :: npblck !< number of (disjoint) parameter blocks
INTEGER(mpi) :: ncblck !< number of (disjoint) constraint blocks INTEGER(mpi) :: ncblck !< number of (disjoint) constraint blocks
INTEGER(mpi) :: mszcon !< (integrated block) matrix size for constraint matrix INTEGER(mpi) :: mszcon !< (integrated block) matrix size for constraint matrix
INTEGER(mpi) :: mszprd !< (integrated block) matrix size for (constraint) product matrix INTEGER(mpi) :: mszprd !< (integrated block) matrix size for (constraint) product matrix
...@@ -243,6 +244,10 @@ MODULE mpmod ...@@ -243,6 +244,10 @@ MODULE mpmod
INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: backIndexUsage !< list of global par in record INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: backIndexUsage !< list of global par in record
INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: appearanceCounter !< appearance statistics for global par (first/last file,record) INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: appearanceCounter !< appearance statistics for global par (first/last file,record)
INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: pairCounter !< number of paired parameters (in equations) INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: pairCounter !< number of paired parameters (in equations)
! global parameter usage from all records
INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: globalIndexRanges !< global par ranges
INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matParBlockOffsets !< global par block offsets (parameter, constraint blocks)
INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: vecParBlockOffsets !< global par block offsets (global matrix)
! local fit ! local fit
REAL(mpd), DIMENSION(:), ALLOCATABLE::blvec !< local fit vector 'b' (in A*x=b), replaced by 'x' REAL(mpd), DIMENSION(:), ALLOCATABLE::blvec !< local fit vector 'b' (in A*x=b), replaced by 'x'
REAL(mpd), DIMENSION(:), ALLOCATABLE::clmat !< local fit matrix 'A' (in A*x=b) REAL(mpd), DIMENSION(:), ALLOCATABLE::clmat !< local fit matrix 'A' (in A*x=b)
......
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
!! 675 Mass Ave, Cambridge, MA 02139, USA. !! 675 Mass Ave, Cambridge, MA 02139, USA.
!! !!
!! QL decomposition of constraints matrix by Householder transformations !! QL decomposition of constraints matrix by Householder transformations
!! for solution by elimination. !! for solution by elimination. Optionally split into disjoint blocks.
!! !!
!> QL data. !> QL data.
...@@ -30,9 +30,13 @@ MODULE mpqldec ...@@ -30,9 +30,13 @@ MODULE mpqldec
INTEGER(mpi) :: npar !< number of parameters INTEGER(mpi) :: npar !< number of parameters
INTEGER(mpi) :: ncon !< number of constraints INTEGER(mpi) :: ncon !< number of constraints
INTEGER(mpi) :: nblock !< number of blocks
INTEGER(mpi) :: iblock !< active block
REAL(mpd), DIMENSION(:), ALLOCATABLE :: matV !< unit normals (v_i) of Householder reflectors REAL(mpd), DIMENSION(:), ALLOCATABLE :: matV !< unit normals (v_i) of Householder reflectors
REAL(mpd), DIMENSION(:), ALLOCATABLE :: matL !< lower diagonal matrix L REAL(mpd), DIMENSION(:), ALLOCATABLE :: matL !< lower diagonal matrix L
REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecN !< normal vector REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecN !< normal vector
INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: nparBlock !< number of parameters in block
INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: ioffBlock !< block offset (1. constraint -1)
END MODULE mpqldec END MODULE mpqldec
...@@ -40,8 +44,9 @@ END MODULE mpqldec ...@@ -40,8 +44,9 @@ END MODULE mpqldec
!! !!
!! \param [in] n number of rows (parameters) !! \param [in] n number of rows (parameters)
!! \param [in] m number of columns (constraints) !! \param [in] m number of columns (constraints)
!! \param [in] l number of disjoint blocks
!! !!
SUBROUTINE qlini(n,m) SUBROUTINE qlini(n,m,l)
USE mpqldec USE mpqldec
USE mpdalc USE mpdalc
...@@ -50,20 +55,29 @@ SUBROUTINE qlini(n,m) ...@@ -50,20 +55,29 @@ SUBROUTINE qlini(n,m)
INTEGER(mpi), INTENT(IN) :: n INTEGER(mpi), INTENT(IN) :: n
INTEGER(mpi), INTENT(IN) :: m INTEGER(mpi), INTENT(IN) :: m
INTEGER(mpi), INTENT(IN) :: l
npar=n npar=n
ncon=m ncon=m
nblock=l
iblock=1
! allocate ! allocate
length=npar*ncon length=npar*ncon
CALL mpalloc(matV,length,'QLDEC: V') CALL mpalloc(matV,length,'QLDEC: V')
length=ncon*ncon length=ncon*ncon
CALL mpalloc(matL,length,'QLDEC: L') CALL mpalloc(matL,length,'QLDEC: L')
length=npar length=npar
CALL mpalloc(vecN,length,'QLDEC: v') CALL mpalloc(vecN,length,'QLDEC: v')
length=nblock
CALL mpalloc(nparBlock,length,'QLDEC: npar in block')
nparBlock=0
length=nblock+1
CALL mpalloc(ioffBlock,length,'QLDEC: ioff for block')
ioffBlock=0
END SUBROUTINE qlini END SUBROUTINE qlini
! 141217 C. Kleinwort, DESY-FH1 ! 141217 C. Kleinwort, DESY-FH1
!> QL decomposition. !> QL decomposition (as single block).
!! !!
!! QL decomposition with Householder transformations. !! QL decomposition with Householder transformations.
!! Decompose N-By-M matrix A into orthogonal N-by-N matrix Q and a !! Decompose N-By-M matrix A into orthogonal N-by-N matrix Q and a
...@@ -103,6 +117,10 @@ SUBROUTINE qldec(a) ...@@ -103,6 +117,10 @@ SUBROUTINE qldec(a)
length=npar*ncon length=npar*ncon
matV=a(1:length) matV=a(1:length)
matL=0.0_mpd matL=0.0_mpd
! implemented as single block
nblock=1
nparBlock(1)=npar
ioffBlock(2)=ncon
! Householder procedure ! Householder procedure
DO k=ncon,1,-1 DO k=ncon,1,-1
...@@ -155,11 +173,11 @@ END SUBROUTINE qldec ...@@ -155,11 +173,11 @@ END SUBROUTINE qldec
!! normal vectors v_i of the hyperplanes (Householder reflectors) defining Q. !! normal vectors v_i of the hyperplanes (Householder reflectors) defining Q.
!! The lower triangular matrix L is stored in the M-by-M matrix matL. !! The lower triangular matrix L is stored in the M-by-M matrix matL.
!! !!
!! \param [in] a block compressed Npar-by-Ncon matrix !! \param [in] a block compressed Npar-by-Ncon matrix
!! \param [in] nb number of blocks !! \param [in] bpar 3-by-NparBlock+1 matrix (with parameter block definition)
!! \param [in] b 3-by-Ncon+1 matrix (with block definition) !! \param [in] bcon 3-by-NconBlock+1 matrix (with constraint block definition)
!! !!
SUBROUTINE qldecb(a,nb,b) SUBROUTINE qldecb(a,bpar,bcon)
USE mpqldec USE mpqldec
USE mpdalc USE mpdalc
...@@ -167,12 +185,17 @@ SUBROUTINE qldecb(a,nb,b) ...@@ -167,12 +185,17 @@ SUBROUTINE qldecb(a,nb,b)
IMPLICIT NONE IMPLICIT NONE
INTEGER(mpi) :: i INTEGER(mpi) :: i
INTEGER(mpi) :: ib INTEGER(mpi) :: ibcon
INTEGER(mpi) :: ibpar
INTEGER(mpi) :: ifirst INTEGER(mpi) :: ifirst
INTEGER(mpi) :: ilast INTEGER(mpi) :: ilast
INTEGER(mpl) :: ioff1 INTEGER(mpl) :: ioff1
INTEGER(mpl) :: ioff2 INTEGER(mpl) :: ioff2
INTEGER(mpl) :: ioff3 INTEGER(mpl) :: ioff3
INTEGER(mpi) :: iclast
INTEGER(mpi) :: icoff
INTEGER(mpi) :: iplast
INTEGER(mpi) :: ipoff
INTEGER(mpi) :: k INTEGER(mpi) :: k
INTEGER(mpi) :: k1 INTEGER(mpi) :: k1
INTEGER(mpi) :: kn INTEGER(mpi) :: kn
...@@ -183,99 +206,111 @@ SUBROUTINE qldecb(a,nb,b) ...@@ -183,99 +206,111 @@ SUBROUTINE qldecb(a,nb,b)
REAL(mpd) :: sp REAL(mpd) :: sp
REAL(mpd), INTENT(IN) :: a(*) REAL(mpd), INTENT(IN) :: a(*)
INTEGER(mpi), INTENT(IN) :: nb INTEGER(mpi), INTENT(IN) :: bpar(2,*)
INTEGER(mpi), INTENT(IN) :: b(3,*) INTEGER(mpi), INTENT(IN) :: bcon(3,*)
! prepare ! prepare
length=npar*ncon length=npar*ncon
matV=0.0_mpd matV=0.0_mpd
matL=0.0_mpd matL=0.0_mpd
! expand a into matV
ioff1=0 ioff1=0
ioff2=0 ioff2=0
DO ib=1,nb icoff=0
ncb=b(1,ib+1)-b(1,ib) ! number of constraints in block DO ibpar=1,nblock ! parameter block
npb=b(3,ib)+1-b(2,ib) ! number of parameters in block DO ibcon=bpar(2,ibpar)+1, bpar(2,ibpar+1)! constraint block
ifirst=b(2,ib) ncb=bcon(1,ibcon+1)-bcon(1,ibcon) ! number of constraints in constraint block
ilast=b(3,ib) npb=bcon(3,ibcon)+1-bcon(2,ibcon) ! number of parameters in constraint block
DO i=1,ncb ifirst=bcon(2,ibcon)
matV(ioff1+ifirst:ioff1+ilast)=a(ioff2+1:ioff2+npb) ilast=bcon(3,ibcon)
ioff1=ioff1+npar DO i=1,ncb
ioff2=ioff2+npb matV(ioff1+ifirst:ioff1+ilast)=a(ioff2+1:ioff2+npb)
END DO ioff1=ioff1+npar
ioff2=ioff2+npb
END DO
icoff=icoff+ncb
END DO
nparBlock(ibpar)=bpar(1,ibpar+1)-bpar(1,ibpar)
ioffBlock(ibpar+1)=icoff
END DO END DO
ib=nb ! start with last block DO ibpar=1,nblock ! parameter block
k1=b(1,ib) ! first constraint in block ipoff=bpar(1,ibpar) ! parameter offset in parameter block
! Householder procedure iplast=bpar(1,ibpar+1) ! last parameter in parameter block
DO k=ncon,1,-1 icoff=ioffBlock(ibpar) ! constraint offset in parameter block
kn=npar+k-ncon iclast=ioffBlock(ibpar+1) ! last constraint in parameter block
! different block? ibcon=bpar(2,ibpar+1) ! start with last constraint block
IF (k < k1) THEN k1=bcon(1,ibcon) ! first constraint in block
ib=ib-1 ! Householder procedure
k1=b(1,ib) DO k=iclast,icoff+1,-1
END IF kn=iplast+k-iclast
! index if first non-zero element ! different constraint block?
ifirst=b(2,ib) IF (k < k1) THEN
IF (ifirst > kn) CYCLE ibcon=ibcon-1
! index of last element k1=bcon(1,ibcon)
ilast=min(b(3,ib),kn) END IF
! column offsets ! index if first non-zero element
ioff1=(k-1)*npar ifirst=bcon(2,ibcon)
ioff2=(k1-1)*npar IF (ifirst > kn) CYCLE
! get column ! index of last element
vecN(kn)=0.0_mpd ilast=min(bcon(3,ibcon),kn)
vecN(ifirst:ilast)=matV(ioff1+ifirst:ioff1+ilast) ! column offsets
nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast))) ioff1=(k-1)*npar
IF (nrm == 0.0_mpd) CYCLE ioff2=(k1-1)*npar
! ! get column
IF (vecN(kn) >= 0.0_mpd) THEN vecN(kn)=0.0_mpd
vecN(kn)=vecN(kn)+nrm vecN(ifirst:ilast)=matV(ioff1+ifirst:ioff1+ilast)
ELSE
vecN(kn)=vecN(kn)-nrm
END IF
IF (ilast < kn) THEN
! create normal vector
nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast))+vecN(kn)*vecN(kn))
vecN(ifirst:ilast)=vecN(ifirst:ilast)/nrm
vecN(kn)=vecN(kn)/nrm
! transformation
DO i=k1,k
sp=dot_product(vecN(ifirst:ilast),matV(ioff2+ifirst:ioff2+ilast))
matV(ioff2+ifirst:ioff2+ilast)=matV(ioff2+ifirst:ioff2+ilast)-2.0_mpd*vecN(ifirst:ilast)*sp
matV(ioff2+kn)=-2.0_mpd*vecN(kn)*sp
ioff2=ioff2+npar
END DO
ELSE
! create normal vector
nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast))) nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast)))
vecN(ifirst:ilast)=vecN(ifirst:ilast)/nrm IF (nrm == 0.0_mpd) CYCLE
! transformation !
DO i=k1,k IF (vecN(kn) >= 0.0_mpd) THEN
sp=dot_product(vecN(ifirst:ilast),matV(ioff2+ifirst:ioff2+ilast)) vecN(kn)=vecN(kn)+nrm
matV(ioff2+ifirst:ioff2+ilast)=matV(ioff2+ifirst:ioff2+ilast)-2.0_mpd*vecN(ifirst:ilast)*sp ELSE
ioff2=ioff2+npar vecN(kn)=vecN(kn)-nrm
END DO END IF
END IF
IF (ilast < kn) THEN
! create normal vector
nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast))+vecN(kn)*vecN(kn))
vecN(ifirst:ilast)=vecN(ifirst:ilast)/nrm
vecN(kn)=vecN(kn)/nrm
! transformation
DO i=k1,k
sp=dot_product(vecN(ifirst:ilast),matV(ioff2+ifirst:ioff2+ilast))
matV(ioff2+ifirst:ioff2+ilast)=matV(ioff2+ifirst:ioff2+ilast)-2.0_mpd*vecN(ifirst:ilast)*sp
matV(ioff2+kn)=-2.0_mpd*vecN(kn)*sp
ioff2=ioff2+npar
END DO
ELSE
! create normal vector
nrm = SQRT(dot_product(vecN(ifirst:ilast),vecN(ifirst:ilast)))
vecN(ifirst:ilast)=vecN(ifirst:ilast)/nrm
! transformation
DO i=k1,k
sp=dot_product(vecN(ifirst:ilast),matV(ioff2+ifirst:ioff2+ilast))
matV(ioff2+ifirst:ioff2+ilast)=matV(ioff2+ifirst:ioff2+ilast)-2.0_mpd*vecN(ifirst:ilast)*sp
ioff2=ioff2+npar
END DO
END IF
! store column of L ! store column of L
ioff3=(k-1)*ncon ioff3=(k-1)*ncon
matL(ioff3+k:ioff3+ncon)=matV(ioff1+kn:ioff1+npar) matL(ioff3+k-icoff:ioff3+iclast-icoff)=matV(ioff1+kn:ioff1+iplast)
! store normal vector ! store normal vector
matV(ioff1+1:ioff1+npar)=0.0_mpd matV(ioff1+1:ioff1+npar)=0.0_mpd
matV(ioff1+ifirst:ioff1+ilast)=vecN(ifirst:ilast) matV(ioff1+ifirst-ipoff:ioff1+ilast-ipoff)=vecN(ifirst:ilast)
matV(ioff1+kn)=vecN(kn) matV(ioff1+kn-ipoff)=vecN(kn)
END DO
END DO END DO
END SUBROUTINE qldecb END SUBROUTINE qldecb
!> Multiply left by Q(t). !> Multiply left by Q(t) (per block).
!! !!
!! Multiply left by Q(t) from QL decomposition. !! Multiply left by Q(t) from QL decomposition.
!! !!
!! \param [in,out] x Npar-by-M matrix, overwritten with Q*X (t=false) or Q^t*X (t=true) !! \param [in,out] x NparBlock-by-M matrix, overwritten with Q*X (t=false) or Q^t*X (t=true)
!! \param [in] m number of columns !! \param [in] m number of columns
!! \param [in] t use transposed of Q !! \param [in] t use transposed of Q
!! !!
...@@ -286,29 +321,37 @@ SUBROUTINE qlmlq(x,m,t) ...@@ -286,29 +321,37 @@ SUBROUTINE qlmlq(x,m,t)
IMPLICIT NONE IMPLICIT NONE
INTEGER(mpi) :: i INTEGER(mpi) :: i
INTEGER(mpi) :: icoff
INTEGER(mpi) :: iclast
INTEGER(mpl) :: ioff1 INTEGER(mpl) :: ioff1
INTEGER(mpl) :: ioff2 INTEGER(mpl) :: ioff2
INTEGER(mpi) :: j INTEGER(mpi) :: j
INTEGER(mpi) :: k INTEGER(mpi) :: k
INTEGER(mpi) :: kn INTEGER(mpi) :: kn
INTEGER(mpi) :: nconb
INTEGER(mpi) :: nparb
REAL(mpd) :: sp REAL(mpd) :: sp
REAL(mpd), INTENT(IN OUT) :: x(*) REAL(mpd), INTENT(IN OUT) :: x(*)
INTEGER(mpi), INTENT(IN) :: m INTEGER(mpi), INTENT(IN) :: m
LOGICAL, INTENT(IN) :: t LOGICAL, INTENT(IN) :: t
DO j=1,ncon icoff=ioffBlock(iblock) ! constraint offset in parameter block
iclast=ioffBlock(iblock+1) ! last constraint in parameter block
nconb=iclast-icoff ! number of constraints in block
nparb=nparBlock(iblock) ! number of parameters in block
DO j=1,nconb
k=j k=j
IF (t) k=ncon+1-j IF (t) k=nconb+1-j
kn=npar+k-ncon kn=nparb+k-nconb
! column offset ! column offset
ioff1=(k-1)*npar ioff1=(k-1+icoff)*npar
! transformation ! transformation
ioff2=0 ioff2=0
DO i=1,m DO i=1,m
sp=dot_product(matV(ioff1+1:ioff1+kn),x(ioff2+1:ioff2+kn)) sp=dot_product(matV(ioff1+1:ioff1+kn),x(ioff2+1:ioff2+kn))
x(ioff2+1:ioff2+kn)=x(ioff2+1:ioff2+kn)-2.0_mpd*matV(ioff1+1:ioff1+kn)*sp x(ioff2+1:ioff2+kn)=x(ioff2+1:ioff2+kn)-2.0_mpd*matV(ioff1+1:ioff1+kn)*sp
ioff2=ioff2+npar ioff2=ioff2+nparb
END DO END DO
END DO END DO
...@@ -424,13 +467,19 @@ SUBROUTINE qlssq(aprod,A,t) ...@@ -424,13 +467,19 @@ SUBROUTINE qlssq(aprod,A,t)
IMPLICIT NONE IMPLICIT NONE
INTEGER(mpi) :: i INTEGER(mpi) :: i
INTEGER(mpi) :: ibpar
INTEGER(mpi) :: icoff
INTEGER(mpi) :: iclast
INTEGER(mpl) :: ioff1 INTEGER(mpl) :: ioff1
INTEGER(mpl) :: ioff2 INTEGER(mpl) :: ioff2
INTEGER(mpl) :: ioffb
INTEGER(mpi) :: j INTEGER(mpi) :: j
INTEGER(mpi) :: k INTEGER(mpi) :: k
INTEGER(mpi) :: kn INTEGER(mpi) :: kn
INTEGER(mpi) :: l INTEGER(mpi) :: l
INTEGER(mpl) :: length INTEGER(mpl) :: length
INTEGER(mpi) :: nconb
INTEGER(mpi) :: nparb
REAL(mpd) :: vtAv REAL(mpd) :: vtAv
REAL(mpd), DIMENSION(:), ALLOCATABLE :: Av REAL(mpd), DIMENSION(:), ALLOCATABLE :: Av
...@@ -438,9 +487,10 @@ SUBROUTINE qlssq(aprod,A,t) ...@@ -438,9 +487,10 @@ SUBROUTINE qlssq(aprod,A,t)
LOGICAL, INTENT(IN) :: t LOGICAL, INTENT(IN) :: t
INTERFACE INTERFACE
SUBROUTINE aprod(n,x,y) ! y=A*x SUBROUTINE aprod(n,l,x,y) ! y=A*x
USE mpdef USE mpdef
INTEGER(mpi), INTENT(in) :: n INTEGER(mpi), INTENT(in) :: n
INTEGER(mpl), INTENT(in) :: l
REAL(mpd), INTENT(IN) :: x(n) REAL(mpd), INTENT(IN) :: x(n)
REAL(mpd), INTENT(OUT) :: y(n) REAL(mpd), INTENT(OUT) :: y(n)
END SUBROUTINE aprod END SUBROUTINE aprod
...@@ -449,33 +499,43 @@ SUBROUTINE qlssq(aprod,A,t) ...@@ -449,33 +499,43 @@ SUBROUTINE qlssq(aprod,A,t)
length=npar length=npar
CALL mpalloc(Av,length,'qlssq: A*v') CALL mpalloc(Av,length,'qlssq: A*v')
DO j=1,ncon ioffb=0 ! block offset