pede.f90

Go to the documentation of this file.

! Code converted using TO_F90 by Alan Miller
! Date: 2012-03-16  Time: 11:06:00
 
 
 
 
 
 
 
 
PROGRAM mptwo
    USE mpmod
    USE mpdalc
    USE mptest1, ONLY: nplan,del,dvd
    USE mptest2, ONLY: nlyr,nmx,nmy,sdevx,sdevy,ntot
 
    IMPLICIT NONE
    REAL(mps) :: andf
    REAL(mps) :: c2ndf
    REAL(mps) :: deltat
    REAL(mps) :: diff
    REAL(mps) :: err
    REAL(mps) :: gbu
    REAL(mps) :: gmati
    REAL(mps) :: rej
    REAL :: rloop1
    REAL :: rloop2
    REAL :: rstext
    REAL(mps) :: secnd
    REAL :: rst
    REAL :: rstp
    REAL, DIMENSION(2) :: ta
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ii
    INTEGER(mpi) :: iopnmp
    INTEGER(mpi) :: ix
    INTEGER(mpi) :: ixv
    INTEGER(mpi) :: iy
    INTEGER(mpi) :: k
    INTEGER(mpi) :: kfl
    INTEGER(mpi) :: lun
    INTEGER :: minut
    INTEGER :: nhour
    INTEGER(mpi) :: nmxy
    INTEGER(mpi) :: nrc
    INTEGER(mpi) :: nsecnd
    INTEGER(mpi) :: ntsec
 
    CHARACTER (LEN=24) :: chdate
    CHARACTER (LEN=24) :: chost
#ifdef LAPACK64
    CHARACTER (LEN=6) :: c6
    INTEGER major, minor, patch
#endif
 
    INTEGER(mpl) :: rows
    INTEGER(mpl) :: cols
 
    REAL(mpd) :: sums(9)
    !$    INTEGER(mpi) :: OMP_GET_NUM_PROCS,OMP_GET_MAX_THREADS
    !$    INTEGER(mpi) :: MXTHRD
    !$    INTEGER(mpi) :: NPROC
 
    REAL etime
 
    SAVE
    !     ...
    rstp=etime(ta)
    CALL fdate(chdate)
 
    !     millepede monitoring file
    lunmon=0
    !     millepede.log file
    lunlog=8
    lvllog=1
    CALL mvopen(lunlog,'millepede.log')
    CALL getenv('HOSTNAME',chost)
    IF (chost(1:1) == ' ') CALL getenv('HOST',chost)
    WRITE(*,*) '($Id: c5a7342b3793f36f30ad6658bc1f72bc74250cf7 $)'
    iopnmp=0
    !$    iopnmp=1
    !$    WRITE(*,*) 'using OpenMP (TM)'
#ifdef LAPACK64
    CALL ilaver( major,minor, patch )
    WRITE(*,110) lapack64, major,minor, patch
110 FORMAT(' using LAPACK64 with ',(a),', version ',i0,'.',i0,'.',i0)
#ifdef PARDISO
    WRITE(*,*) 'using Intel oneMKL PARDISO'
#endif
#endif
#ifdef __GFORTRAN__
    WRITE(*,111)  __gnuc__ , __gnuc_minor__ , __gnuc_patchlevel__
111 FORMAT(' compiled with gcc ',i0,'.',i0,'.',i0)
#endif
#ifdef __PGIC__
    WRITE(*,111)  __pgic__ , __pgic_minor__ , __pgic_patchlevel__
111 FORMAT(' compiled with pgi ',i0,'.',i0,'.',i0)
#endif
    WRITE(*,*) ' '
    WRITE(*,*) '  <  Millepede II-P starting ... ',chdate
    WRITE(*,*) '                                 ',chost
    WRITE(*,*) ' '
 
    WRITE(8,*) '($Id: c5a7342b3793f36f30ad6658bc1f72bc74250cf7 $)'
    WRITE(8,*) ' '
    WRITE(8,*) 'Log-file Millepede II-P                        ', chdate
    WRITE(8,*) '                                               ', chost
 
    CALL peend(-1,'Still running or crashed')
    !     read command line and text files
 
    CALL filetc   ! command line and steering file analysis
    CALL filetx   ! read text files
    ! dummy call for dynamic memory allocation
    CALL gmpdef(0,nfilb,'dummy call')
 
    IF (icheck > 0) THEN
        WRITE(*,*) '!!!   Checking input only, no calculation of a solution   !!!'
        WRITE(8,*) '!!!   Checking input only, no calculation of a solution   !!!'
    END IF
    lvllog=mprint ! export print level
    IF (memdbg > 0) printflagalloc=1 ! debug memory management
    !$    WRITE(*,*)
    !$    NPROC=1
    !$    MXTHRD=1
    !$    NPROC=OMP_GET_NUM_PROCS()         ! number of processors available
    !$    CALL OMP_SET_NUM_THREADS(MTHRD)   ! set max number of threads to MTHRD
    !$    MXTHRD=OMP_GET_MAX_THREADS()      ! get max number of threads back
    !$    WRITE(*,*) 'Number of processors available:   ', NPROC
    !$    WRITE(*,*) 'Maximum number of OpenMP threads: ', MXTHRD
    !$    WRITE(*,*) 'Number of threads for processing: ', MTHRD
    !$    IF (MXREC.GT.0) MTHRDR=1          ! to get allways the same MXREC records
    !$    IF (ICHECK.GT.1) MTHRDR=1         ! to get allways the same order of records
    !$    WRITE(*,*) 'Number of threads for reading:    ', MTHRDR
    !$POMP INST INIT                        ! start profiling with ompP
#ifdef LAPACK64
    IF(iopnmp > 0) THEN
        CALL getenv('OMP_NUM_THREADS',c6)
    ELSE    
        CALL getenv(lapack64//'_NUM_THREADS',c6)
    END IF
    IF (c6(1:1) == ' ') THEN
        IF(iopnmp > 0) THEN
            WRITE(*,*) 'Number of threads for LAPACK: unkown (empty OMP_NUM_THREADS)'
        ELSE
            WRITE(*,*) 'Number of threads for LAPACK: unkown (empty ',lapack64//'_NUM_THREADS)'
        END IF
    ELSE
        WRITE(*,*) 'Number of threads for LAPACK: ', c6
    END IF  
#endif
    cols=mthrd
    CALL mpalloc(globalchi2sumd,cols,'fractional part of Chi2 sum')
    globalchi2sumd=0.0_mpd
    CALL mpalloc(globalchi2sumi,cols,'integer part of Chi2 sum')
    globalchi2sumi=0_mpl
    CALL mpalloc(globalndfsum,cols,'NDF sum')
    globalndfsum=0_mpl
    CALL mpalloc(globalndfsumw,cols,'weighted NDF sum')
    globalndfsumw=0.0_mpd
 
    IF (ncache < 0) THEN
        ncache=25000000*mthrd  ! default cache size (100 MB per thread)
    ENDIF
    rows=6; cols=mthrdr
    CALL mpalloc(readbufferinfo,rows,cols,'read buffer header')
    !     histogram file
    lun=7
    CALL mvopen(lun,'millepede.his')
    CALL hmplun(lun) ! unit for histograms
    CALL gmplun(lun) ! unit for xy data
 
    !     debugging
    IF(nrecpr /= 0.OR.nrecp2 /= 0) THEN
        CALL mvopen(1,'mpdebug.txt')
    END IF
 
    rstext=etime(ta)
    times(0)=rstext-rstp ! time for text processing
 
    !     preparation of data sub-arrays
 
    CALL loop1
    rloop1=etime(ta)
    times(1)=rloop1-rstext ! time for LOOP1
 
    CALL loop2
    IF(chicut /= 0.0) THEN
        WRITE(8,*) 'Chi square cut equiv 3 st.dev applied ...'
        WRITE(8,*) ' in  first iteration with factor',chicut
        WRITE(8,*) ' in second iteration with factor',chirem
        WRITE(8,*) ' (reduced by sqrt in next iterations)'
    END IF
    
    IF(lhuber /= 0) THEN
        WRITE(8,*) 'Down-weighting of outliers in', lhuber,' iterations'
        WRITE(8,*) 'Cut on downweight fraction',dwcut
    END IF
 
    rloop2=etime(ta)
    times(2)=rloop2-rloop1 ! time for LOOP2
 
    IF(icheck > 0) THEN
        CALL prtstat
        IF (ncgbe < 0) THEN
            CALL peend(5,'Ended without solution (empty constraints)')
        ELSE
            CALL peend(0,'Ended normally')
        END IF
        GOTO 99 ! only checking input
    END IF
 
    !     use different solution methods
 
    CALL mstart('Iteration')   ! Solution module starting
 
    CALL xloopn                ! all methods
 
    !     ------------------------------------------------------------------
 
    IF(nloopn > 2.AND.nhistp /= 0) THEN       ! last iteration
        CALL hmprnt(3)  ! scaled residual of single measurement (with global deriv.)
        CALL hmprnt(12) ! scaled residual of single measurement (no global deriv.)
        CALL hmprnt(4)  ! chi^2/Ndf
    END IF
    IF(nloopn > 2) THEN
        CALL hmpwrt(3)
        CALL hmpwrt(12)
        CALL hmpwrt(4)
        CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr
        IF (nloopn <= lfitnp) THEN
            CALL hmpwrt(13)
            CALL hmpwrt(14)
            CALL gmpwrt(5)
        END IF
    END IF
    IF(nhistp /= 0) THEN
        CALL gmprnt(1)
        CALL gmprnt(2)
    END IF
    CALL gmpwrt(1)             ! output of xy data
    CALL gmpwrt(2)             ! output of xy data
    !     'track quality' per binary file
    IF (nfilb > 1) THEN
        CALL gmpdef(6,1,'log10(#records) vs file number')
        CALL gmpdef(7,1,'final rejection fraction vs file number')
        CALL gmpdef(8,1,  &
            'final <Chi^2/Ndf> from accepted local fits vs file number')
        CALL gmpdef(9,1, '<Ndf> from accepted local fits vs file number')
  
        DO i=1,nfilb
            kfl=kfd(2,i)
            nrc=-kfd(1,i)
            IF (nrc > 0) THEN
                rej=real(nrc-jfd(kfl),mps)/real(nrc,mps)
                CALL gmpxy(6,real(kfl,mps),log10(real(nrc,mps))) ! log10(#records) vs file
                CALL gmpxy(7,real(kfl,mps),rej)    ! rejection fraction vs file
            END IF
            IF (jfd(kfl) > 0) THEN
                c2ndf=cfd(kfl)/real(jfd(kfl),mps)
                CALL gmpxy(8,real(kfl,mps),c2ndf)  ! <Chi2/NDF> vs file
                andf=real(dfd(kfl),mps)/real(jfd(kfl),mps)
                CALL gmpxy(9,real(kfl,mps),andf)  ! <NDF> vs file
            END IF
        END DO
        IF(nhistp /= 0) THEN
            CALL gmprnt(6)
            CALL gmprnt(7)
            CALL gmprnt(8)
            CALL gmprnt(9)
        END IF
        CALL gmpwrt(6)             ! output of xy data
        CALL gmpwrt(7)             ! output of xy data
        CALL gmpwrt(8)             ! output of xy data
        CALL gmpwrt(9)             ! output of xy data
    END IF
 
    IF(ictest == 1) THEN
        WRITE(*,*) ' '
        WRITE(*,*) 'Misalignment test wire chamber'
        WRITE(*,*) ' '
  
        CALL hmpdef( 9,-0.0015,+0.0015,'True - fitted displacement')
        CALL hmpdef(10,-0.0015,+0.0015,'True - fitted Vdrift')
        DO i=1,4
            sums(i)=0.0_mpd
        END DO
        DO i=1,nplan
            diff=real(-del(i)-globalparameter(i),mps)
            sums(1)=sums(1)+diff
            sums(2)=sums(2)+diff*diff
            diff=real(-dvd(i)-globalparameter(100+i),mps)
            sums(3)=sums(3)+diff
            sums(4)=sums(4)+diff*diff
        END DO
        sums(1)=0.01_mpd*sums(1)
        sums(2)=sqrt(0.01_mpd*sums(2))
        sums(3)=0.01_mpd*sums(3)
        sums(4)=sqrt(0.01_mpd*sums(4))
        WRITE(*,143) 'Parameters   1 - 100: mean =',sums(1), 'rms =',sums(2)
        WRITE(*,143) 'Parameters 101 - 200: mean =',sums(3), 'rms =',sums(4)
143     FORMAT(6x,a28,f9.6,3x,a5,f9.6)
        WRITE(*,*) ' '
        WRITE(*,*) ' '
        WRITE(*,*) '    I     label   simulated    fitted      diff'
        WRITE(*,*) '   -------------------------------------------- '
        DO i=1,100
            WRITE(*,102) i,globalparlabelindex(1,i),-del(i),globalparameter(i),-del(i)-globalparameter(i)
            diff=real(-del(i)-globalparameter(i),mps)
            CALL hmpent( 9,diff)
        END DO
        DO i=101,200
            WRITE(*,102) i,globalparlabelindex(1,i),-dvd(i-100),globalparameter(i),-dvd(i-100)-globalparameter(i)
            diff=real(-dvd(i-100)-globalparameter(i),mps)
            CALL hmpent(10,diff)
        END DO
        IF(nhistp /= 0) THEN
            CALL hmprnt( 9)
            CALL hmprnt(10)
        END IF
        CALL hmpwrt( 9)
        CALL hmpwrt(10)
    END IF
    IF(ictest > 1) THEN
        WRITE(*,*) ' '
        WRITE(*,*) 'Misalignment test Si tracker'
        WRITE(*,*) ' '
  
        CALL hmpdef( 9,-0.0025,+0.0025,'True - fitted displacement X')
        CALL hmpdef(10,-0.025,+0.025,'True - fitted displacement Y')
        DO i=1,9
            sums(i)=0.0_mpd
        END DO
        nmxy=nmx*nmy
        ix=0
        iy=ntot
        DO i=1,nlyr
            DO k=1,nmxy
                ix=ix+1
                diff=real(-sdevx((i-1)*nmxy+k)-globalparameter(ix),mps)
                sums(1)=sums(1)+1.0_mpd
                sums(2)=sums(2)+diff
                sums(3)=sums(3)+diff*diff
                ixv=globalparlabelindex(2,ix)
                IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN
                    ii=(ixv*ixv+ixv)/2
                    gmati=real(globalmatd(ii),mps)
                    err=sqrt(abs(gmati))
                    diff=diff/err
                    sums(7)=sums(7)+1.0_mpd
                    sums(8)=sums(8)+diff
                    sums(9)=sums(9)+diff*diff
                END IF
            END DO
            IF (mod(i,3) == 1) THEN
                DO k=1,nmxy
                    iy=iy+1
                    diff=-real(sdevy((i-1)*nmxy+k)-globalparameter(iy),mps)
                    sums(4)=sums(4)+1.0_mpd
                    sums(5)=sums(5)+diff
                    sums(6)=sums(6)+diff*diff
                    ixv=globalparlabelindex(2,iy)
                    IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN
                        ii=(ixv*ixv+ixv)/2
                        gmati=real(globalmatd(ii),mps)
                        err=sqrt(abs(gmati))
                        diff=diff/err
                        sums(7)=sums(7)+1.0_mpd
                        sums(8)=sums(8)+diff
                        sums(9)=sums(9)+diff*diff
                    END IF
                END DO
            END IF
        END DO
        sums(2)=sums(2)/sums(1)
        sums(3)=sqrt(sums(3)/sums(1))
        sums(5)=sums(5)/sums(4)
        sums(6)=sqrt(sums(6)/sums(4))
        WRITE(*,143) 'Parameters   1 - 500: mean =',sums(2), 'rms =',sums(3)
        WRITE(*,143) 'Parameters 501 - 700: mean =',sums(5), 'rms =',sums(6)
        IF (sums(7) > 0.5_mpd) THEN
            sums(8)=sums(8)/sums(7)
            sums(9)=sqrt(sums(9)/sums(7))
            WRITE(*,143) 'Parameter pulls, all: mean =',sums(8), 'rms =',sums(9)
        END IF
        WRITE(*,*) ' '
        WRITE(*,*) ' '
        WRITE(*,*) '    I     label   simulated    fitted      diff'
        WRITE(*,*) '   -------------------------------------------- '
        ix=0
        iy=ntot
        DO i=1,nlyr
            DO k=1,nmxy
                ix=ix+1
                diff=real(-sdevx((i-1)*nmxy+k)-globalparameter(ix),mps)
                CALL hmpent( 9,diff)
                WRITE(*,102) ix,globalparlabelindex(1,ix),-sdevx((i-1)*nmxy+k),globalparameter(ix),-diff
            END DO
        END DO
        DO i=1,nlyr
            IF (mod(i,3) == 1) THEN
                DO k=1,nmxy
                    iy=iy+1
                    diff=real(-sdevy((i-1)*nmxy+k)-globalparameter(iy),mps)
                    CALL hmpent(10,diff)
                    WRITE(*,102) iy,globalparlabelindex(1,iy),-sdevy((i-1)*nmxy+k),globalparameter(iy),-diff
                END DO
            END IF
        END DO
        IF(nhistp /= 0) THEN
            CALL hmprnt( 9)
            CALL hmprnt(10)
        END IF
        CALL hmpwrt( 9)
        CALL hmpwrt(10)
    END IF
 
    IF(nrec1+nrec2 > 0) THEN
        WRITE(8,*) ' '
        IF(nrec1 > 0) THEN
            WRITE(8,*) 'Record',nrec1,' has largest residual:',value1
        END IF
        IF(nrec2 > 0) THEN
            WRITE(8,*) 'Record',nrec2,' has largest Chi^2/Ndf:',value2
        END IF
    END IF
    IF(nrec3 < huge(nrec3)) THEN
        WRITE(8,*) 'Record',nrec3, ' is first with error (rank deficit/NaN)'
    END IF
99  WRITE(8,*) ' '
    IF (iteren > mreqenf) THEN
        WRITE(8,*) 'In total 3 +',nloopn,' loops through the data files'
    ELSE
        WRITE(8,*) 'In total 2 +',nloopn,' loops through the data files'
    ENDIF
    IF (mnrsit > 0) THEN
        WRITE(8,*) ' '
        WRITE(8,*) 'In total    ',mnrsit,' internal MINRES iterations'
    END IF
 
    WRITE(8,103) times(0),times(1),times(2),times(4),times(7),  &
        times(5),times(8),times(3),times(6)
 
    rst=etime(ta)
    deltat=rst-rstp
    ntsec=nint(deltat,mpi)
    CALL sechms(deltat,nhour,minut,secnd)
    nsecnd=nint(secnd,mpi)  ! round
    WRITE(8,*) 'Total time =',ntsec,' seconds =',nhour,' h',minut,  &
        ' m',nsecnd,' seconds'
    CALL fdate(chdate)
    WRITE(8,*) 'end                                            ', chdate
    gbu=1.0e-9*real(maxwordsalloc*(bit_size(1_mpi)/8),mps)             ! GB used
    WRITE(8,*) ' '
    WRITE(8,105) gbu
 
    !     Rejects ----------------------------------------------------------
 
    IF(sum(nrejec) /= 0) THEN
        WRITE(8,*) ' '
        WRITE(8,*) 'Data records rejected in last iteration:   '
        CALL prtrej(8)
        WRITE(8,*) ' '
    END IF
    IF (icheck <= 0) CALL explfc(8)
 
    WRITE(*,*) ' '
    WRITE(*,*) '  <  Millepede II-P ending   ... ', chdate ! with exit code',ITEXIT,' >'
    WRITE(*,*) ' '
    gbu=1.0e-9*real(maxwordsalloc*(bit_size(1_mpi)/8),mps)             ! GB used
    WRITE(*,105) gbu
#ifdef LAPACK64
#ifdef PARDISO
    IF(ipdmem > 0) WRITE(*,106) real(ipdmem,mps)*1.e-6
106 FORMAT('      PARDISO dyn. memory allocation: ',f11.6,' GB')
#endif
#endif
    WRITE(*,*) ' '
 
102 FORMAT(2x,i4,i10,2x,3f10.5)
103 FORMAT(' Times [in sec] for     text processing',f12.3/  &
        '                                  LOOP1',f12.3/  &
        '                                  LOOP2',f12.3/  &
        '   func. value                         ',f12.3,' *',f4.0/  &
        '   func. value, global matrix, solution',f12.3,' *',f4.0/  &
        '                           new solution',f12.3,' *',f4.0/)
105 FORMAT('      Peak dynamic memory allocation: ',f11.6,' GB')
END PROGRAM mptwo                              ! Mille
 
 
SUBROUTINE solglo(ivgbi)
    USE mpmod
    USE minresmodule, ONLY: minres
 
    IMPLICIT NONE
    REAL(mps) :: par
    REAL(mps) :: dpa
    REAL(mps) :: err
    REAL(mps) :: gcor2
    INTEGER(mpi) :: iph
    INTEGER(mpi) :: istop
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: itgbl
    INTEGER(mpi) :: itn
    INTEGER(mpi) :: itnlim
    INTEGER(mpi) :: nout
 
    INTEGER(mpi), INTENT(IN)                      :: ivgbi
 
    REAL(mpd) :: shift
    REAL(mpd) :: rtol
    REAL(mpd) :: anorm
    REAL(mpd) :: acond
    REAL(mpd) :: arnorm
    REAL(mpd) :: rnorm
    REAL(mpd) :: ynorm
    REAL(mpd) :: gmati
    REAL(mpd) :: diag
    REAL(mpd) :: matij
    LOGICAL :: checka
    EXTERNAL avprod, mcsolv, mvsolv
    SAVE
    DATA iph/0/
    !     ...
    IF(iph == 0) THEN
        iph=1
        WRITE(*,101)
    END IF
    itgbi=globalparvartototal(ivgbi)
    itgbl=globalparlabelindex(1,itgbi)
 
    globalvector=0.0_mpd ! reset rhs vector IGVEC
    globalvector(ivgbi)=1.0_mpd
 
    !      NOUT  =6
    nout  =0
    itnlim=200
    shift =0.0_mpd
    rtol  = mrestl ! from steering
    checka=.false.
 
 
    IF(mbandw == 0) THEN           ! default preconditioner
        CALL minres(nagb,  avprod, mcsolv, globalvector, shift, checka ,.true. , &
            globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
 
    ELSE IF(mbandw > 0) THEN       ! band matrix preconditioner
        CALL minres(nagb,  avprod, mvsolv, globalvector, shift, checka ,.true. , &
            globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
    ELSE
        CALL minres(nagb,  avprod, mvsolv, globalvector, shift, checka ,.false. , &
            globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
    END IF
 
    par=real(globalparameter(itgbi),mps)
    dpa=real(par-globalparstart(itgbi),mps)
    gmati=globalcorrections(ivgbi)
    err=sqrt(abs(real(gmati,mps)))
    IF(gmati < 0.0_mpd) err=-err
    diag=matij(ivgbi,ivgbi)
    gcor2=real(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared)
    WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor2,itn
101 FORMAT(1x,'    label     parameter    presigma      differ',  &
        '       Error gcor^2   iit'/ 1x,'---------',2x,5('-----------'),2x,'----')
102 FORMAT(i10,2x,4g12.4,f7.4,i6,i4)
END SUBROUTINE solglo
 
 
SUBROUTINE solgloqlp(ivgbi)
    USE mpmod
    USE minresqlpmodule, ONLY: minresqlp
 
    IMPLICIT NONE
    REAL(mps) :: par
    REAL(mps) :: dpa
    REAL(mps) :: err
    REAL(mps) :: gcor2
    INTEGER(mpi) :: iph
    INTEGER(mpi) :: istop
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: itgbl
    INTEGER(mpi) :: itn
    INTEGER(mpi) :: itnlim
    INTEGER(mpi) :: nout
 
    INTEGER(mpi), INTENT(IN)                      :: ivgbi
 
    REAL(mpd) :: shift
    REAL(mpd) :: rtol
    REAL(mpd) :: mxxnrm
    REAL(mpd) :: trcond
    REAL(mpd) :: gmati
    REAL(mpd) :: diag
    REAL(mpd) :: matij
 
    EXTERNAL avprod, mcsolv, mvsolv
    SAVE
    DATA iph/0/
    !     ...
    IF(iph == 0) THEN
        iph=1
        WRITE(*,101)
    END IF
    itgbi=globalparvartototal(ivgbi)
    itgbl=globalparlabelindex(1,itgbi)
 
    globalvector=0.0_mpd ! reset rhs vector IGVEC
    globalvector(ivgbi)=1.0_mpd
 
    !      NOUT  =6
    nout  =0
    itnlim=200
    shift =0.0_mpd
    rtol  = mrestl ! from steering
    mxxnrm = real(nagb,mpd)/sqrt(epsilon(mxxnrm))
    IF(mrmode == 1) THEN
        trcond = 1.0_mpd/epsilon(trcond) ! only QR
    ELSE IF(mrmode == 2) THEN
        trcond = 1.0_mpd ! only QLP
    ELSE
        trcond = mrtcnd ! QR followed by QLP
    END IF
 
    IF(mbandw == 0) THEN           ! default preconditioner
        CALL minresqlp( n=nagb, aprod=avprod, b=globalvector,  msolve=mcsolv, nout=nout, &
            itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
            x=globalcorrections, istop=istop, itn=itn)
    ELSE IF(mbandw > 0) THEN       ! band matrix preconditioner
        CALL minresqlp( n=nagb, aprod=avprod, b=globalvector,  msolve=mvsolv, nout=nout, &
            itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
            x=globalcorrections, istop=istop, itn=itn)
    ELSE
        CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, nout=nout, &
            itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
            x=globalcorrections, istop=istop, itn=itn)
    END IF
 
    par=real(globalparameter(itgbi),mps)
    dpa=real(par-globalparstart(itgbi),mps)
    gmati=globalcorrections(ivgbi)
    err=sqrt(abs(real(gmati,mps)))
    IF(gmati < 0.0_mpd) err=-err
    diag=matij(ivgbi,ivgbi)
    gcor2=real(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared)
    WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor2,itn
101 FORMAT(1x,'    label     parameter    presigma      differ',  &
        '       Error gcor^2   iit'/ 1x,'---------',2x,5('-----------'),2x,'----')
102 FORMAT(i10,2x,4g12.4,f7.4,i6,i4)
END SUBROUTINE solgloqlp
 
SUBROUTINE addcst
    USE mpmod
 
    IMPLICIT NONE
    REAL(mpd) :: climit
    REAL(mpd) :: factr
    REAL(mpd) :: sgm
 
    INTEGER(mpi) :: i
    INTEGER(mpi) :: icgb
    INTEGER(mpi) :: irhs
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: ivgb
    INTEGER(mpi) :: j
    INTEGER(mpi) :: jcgb
    INTEGER(mpi) :: l
    INTEGER(mpi) :: label
    INTEGER(mpi) :: nop
    INTEGER(mpi) :: inone
 
    REAL(mpd) :: rhs
    REAL(mpd) :: drhs(4)
    INTEGER(mpi) :: idrh (4)
    SAVE
    !     ...
    nop=0
    IF(lenconstraints == 0) RETURN  ! no constraints
    climit=1.0e-5         ! limit for printout
    irhs=0 ! number of values in DRHS(.), to be printed
 
    DO jcgb=1,ncgb
        icgb=matconssort(3,jcgb) ! unsorted constraint index
        i=vecconsstart(icgb)
        rhs=listconstraints(i  )%value ! right hand side
        sgm=listconstraints(i+1)%value ! sigma parameter
        DO j=i+2,vecconsstart(icgb+1)-1
            label=listconstraints(j)%label
            factr=listconstraints(j)%value
            itgbi=inone(label) ! -> ITGBI= index of parameter label
            ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
  
            IF(icalcm == 1.AND.nagb > nvgb.AND.ivgb > 0) THEN
                CALL mupdat(nvgb+jcgb,ivgb,factr) ! add to matrix
            END IF
  
            rhs=rhs-factr*globalparameter(itgbi)     ! reduce residuum
        END DO
        IF(abs(rhs) > climit) THEN
            irhs=irhs+1
            idrh(irhs)=jcgb
            drhs(irhs)=rhs
            nop=1
            IF(irhs == 4) THEN
                WRITE(*,101) (idrh(l),drhs(l),l=1,irhs)
                irhs=0
            END IF
        END IF
        vecconsresiduals(jcgb)=rhs
        IF (nagb > nvgb) globalvector(nvgb+jcgb)=rhs
    END DO
 
    IF(irhs /= 0) THEN
        WRITE(*,101) (idrh(l),drhs(l),l=1,irhs)
    END IF
    IF(nop == 0) RETURN
    WRITE(*,102) ' Constraints: only equation values >', climit,' are printed'
101 FORMAT('            ',4(i6,g11.3))
102 FORMAT(a,g11.2,a)
END SUBROUTINE addcst
 
SUBROUTINE grpcon
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: icgb
    INTEGER(mpi) :: icgrp
    INTEGER(mpi) :: ioff
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: j
    INTEGER(mpi) :: jcgb
    INTEGER(mpi) :: label
    INTEGER(mpi) :: labelf
    INTEGER(mpi) :: labell
    INTEGER(mpi) :: last
    INTEGER(mpi) :: line1
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: ndiff
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: inone
    INTEGER(mpi) :: itype
    INTEGER(mpi) :: ncgbd
    INTEGER(mpi) :: ncgbr
    INTEGER(mpi) :: ncgbw
    INTEGER(mpi) :: ncgrpd
    INTEGER(mpi) :: ncgrpr
    INTEGER(mpi) :: next
 
    INTEGER(mpl):: length
    INTEGER(mpl) :: rows
    
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecParConsOffsets
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecParConsList
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsParOffsets
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsParList
    INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsGroupIndex
 
    ncgb=0
    ncgbw=0
    IF(lenconstraints == 0) RETURN  ! no constraints
 
    i=0
    last=0
    itype=0
    !        find next constraint header and count nr of constraints
    DO WHILE(i < lenconstraints)
        i=i+1
        label=listconstraints(i)%label
        IF(last < 0.AND.label < 0) THEN
            ncgb=ncgb+1
            itype=-label
            IF(itype == 2) ncgbw=ncgbw+1
        END IF
        last=label
        IF(label > 0) THEN
            itgbi=inone(label) ! -> ITGBI= index of parameter label
            globalparcons(itgbi)=globalparcons(itgbi)+1
        END IF
        IF(label > 0.AND.itype == 2) THEN  ! weighted constraints
            itgbi=inone(label) ! -> ITGBI= index of parameter label
            listconstraints(i)%value=listconstraints(i)%value*globalparlabelcounter(itgbi)
        END IF
    END DO
 
    WRITE(*,*)
    IF (ncgbw == 0) THEN
        WRITE(*,*) 'GRPCON:',ncgb,' constraints found in steering files'
    ELSE
        WRITE(*,*) 'GRPCON:',ncgb,' constraints found in steering files,',ncgbw, 'weighted'
    END IF
    WRITE(*,*)
        
    ! keys and index for sorting of constraints
    length=ncgb+1; rows=3
    CALL mpalloc(matconssort,rows,length,'keys and index for sorting (I)')
    matconssort(1,ncgb+1)=ntgb+1
    ! start of constraint in list
    CALL mpalloc(vecconsstart,length,'start of constraint in list (I)')
    vecconsstart(ncgb+1)=lenconstraints+1
    ! start and parameter range of constraint groups 
    CALL mpalloc(matconsgroups,rows,length,'start of constraint groups, par. range (I)')
    ! parameter ranges (all, variable) of constraints
    length=ncgb; rows=4 
    CALL mpalloc(matconsranges,rows,length,'parameter ranges for constraint (I)') 
 
    length=ncgb; rows=3
    CALL mpalloc(matconsgroupindex,rows,length,'group index for constraint (I)')    
    matconsgroupindex=0  
    length=ncgb+1 
    CALL mpalloc(vecconsparoffsets,length,'offsets for global par list for cons. (I)')
    length=ntgb+1
    CALL mpalloc(vecparconsoffsets,length,'offsets for cons. list for global par. (I)')
    vecparconsoffsets(1)=0
    DO i=1,ntgb
        vecparconsoffsets(i+1)=vecparconsoffsets(i)+globalparcons(i)
    END DO
    globalparcons=0
    
    length=vecparconsoffsets(ntgb+1)
    CALL mpalloc(vecconsparlist,length,'global par. list for constraint (I)')
    CALL mpalloc(vecparconslist,length,'constraint list for global par. (I)')
 
    ! prepare
    i=1
    ioff=0
    vecconsparoffsets(1)=ioff
    DO icgb=1,ncgb
        ! new constraint 
        vecconsstart(icgb)=i
        line1=-listconstraints(i)%label
        npar=0
        i=i+2
        DO
            label=listconstraints(i)%label
            itgbi=inone(label) ! -> ITGBI= index of parameter label
            ! list of constraints for 'itgbi' 
            globalparcons(itgbi)=globalparcons(itgbi)+1
            vecparconslist(vecparconsoffsets(itgbi)+globalparcons(itgbi))=icgb
            npar=npar+1
            vecconsparlist(ioff+npar)=itgbi
            i=i+1
            IF(i > lenconstraints) EXIT
            IF(listconstraints(i)%label < 0) EXIT
        END DO
        ! sort to find duplicates
        CALL sort1k(vecconsparlist(ioff+1),npar)
        last=-1
        ndiff=0
        DO j=1,npar
            next=vecconsparlist(ioff+j)
            IF (next /= last) THEN
                ndiff=ndiff+1
                vecconsparlist(ioff+ndiff) = next
            END IF
            last=next
        END DO
        matconsranges(1,icgb)=vecconsparlist(ioff+1) ! min  parameter
        matconsranges(3,icgb)=vecconsparlist(ioff+1) ! min  parameter
        ioff=ioff+ndiff
        matconsranges(2,icgb)=vecconsparlist(ioff)   ! max  parameter
        matconsranges(4,icgb)=vecconsparlist(ioff)   ! max  parameter
        vecconsparoffsets(icgb+1)=ioff
    END DO
    vecconsstart(ncgb+1)=lenconstraints+1
    
    ! sort (by first, last parameter)
    DO icgb=1,ncgb
        matconssort(1,icgb)=matconsranges(1,icgb) ! first par.
        matconssort(2,icgb)=matconsranges(2,icgb) ! last par.
        matconssort(3,icgb)=icgb                 ! index
    END DO
    CALL sort2i(matconssort,ncgb)
 
    IF (icheck>1) THEN
        print *, ' Constraint #parameters  first par.   last par.  first line'
    END IF
    ! split into disjoint groups
    ncgrp=0
    globalparcons=0
    DO jcgb=1,ncgb
        icgb=matconssort(3,jcgb)
        IF (icheck>0) THEN
            npar=vecconsparoffsets(icgb+1)-vecconsparoffsets(icgb)
            line1=-listconstraints(vecconsstart(icgb))%label
            labelf=globalparlabelindex(1,matconsranges(1,icgb))
            labell=globalparlabelindex(1,matconsranges(2,icgb))
            print *, jcgb, npar, labelf, labell, line1
        END IF
        ! already part of group?
        icgrp=matconsgroupindex(1,icgb)
        IF (icgrp == 0) THEN
            ! check all parameters
            DO i=vecconsparoffsets(icgb)+1, vecconsparoffsets(icgb+1)
                itgbi=vecconsparlist(i)
                ! check all related constraints
                DO j=vecparconsoffsets(itgbi)+1,vecparconsoffsets(itgbi+1)
                    icgrp=matconsgroupindex(1,vecparconslist(j))
                    ! already part of group?
                    IF (icgrp > 0) EXIT
                END DO
                IF (icgrp > 0) EXIT
            END DO        
            IF (icgrp == 0) THEN
                ! new group
                ncgrp=ncgrp+1
                icgrp=ncgrp
            END IF
        END IF
        ! add to group
        matconsgroupindex(2,icgb)=jcgb     
        matconsgroupindex(3,icgb)=icgb     
        DO i=vecconsparoffsets(icgb)+1, vecconsparoffsets(icgb+1)
            itgbi=vecconsparlist(i)
            globalparcons(itgbi)=icgrp
            ! mark all related constraints
            DO j=vecparconsoffsets(itgbi)+1,vecparconsoffsets(itgbi+1)
                matconsgroupindex(1,vecparconslist(j))=icgrp
            END DO
        END DO
    END DO
    WRITE(*,*) 'GRPCON:',ncgrp,' disjoint constraints groups built'
 
    ! sort by group number
    CALL sort2i(matconsgroupindex,ncgb)
               
    matconsgroups(1,1:ncgrp)=0
    DO jcgb=1,ncgb
        ! set up matConsSort
        icgb=matconsgroupindex(3,jcgb)
        matconssort(1,jcgb)=matconsranges(1,icgb)
        matconssort(2,jcgb)=matconsranges(2,icgb)
        matconssort(3,jcgb)=icgb
        ! set up matConsGroups
        icgrp=matconsgroupindex(1,jcgb)
        IF (matconsgroups(1,icgrp) == 0) THEN
            matconsgroups(1,icgrp)=jcgb
            matconsgroups(2,icgrp)=matconsranges(1,icgb)     
            matconsgroups(3,icgrp)=matconsranges(2,icgb)
        ELSE    
            matconsgroups(2,icgrp)=min(matconsgroups(2,icgrp),matconsranges(1,icgb))      
            matconsgroups(3,icgrp)=max(matconsgroups(3,icgrp),matconsranges(2,icgb))
        END IF 
    END DO
    matconsgroups(1,ncgrp+1)=ncgb+1
    matconsgroups(2,ncgrp+1)=ntgb+1
    
    ! check for redundancy constraint groups
    ncgbr=0
    ncgrpr=0
    ncgbd=0
    ncgrpd=0
    IF (icheck>0) THEN
        print *
        print *, ' cons.group  first con.  first par.   last par.       #cons        #par'
    ENDIF
    DO icgrp=1,ncgrp
        npar=0
        DO i=matconsgroups(2,icgrp),matconsgroups(3,icgrp)
            IF (globalparcons(i) == icgrp) npar=npar+1
        END DO
        ncon=matconsgroups(1,icgrp+1)-matconsgroups(1,icgrp)
        IF (icheck>0) THEN
            labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
            labell=globalparlabelindex(1,matconsgroups(3,icgrp))
            print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ncon, npar
        END IF    
        ! redundancy constraints?
        IF (ncon == npar) THEN
            IF (irslvrc > 0) THEN
                ncgrpr=ncgrpr+1
                ncgbr=ncgbr+ncon
                IF (icheck > 0) THEN
                    labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
                    labell=globalparlabelindex(1,matconsgroups(3,icgrp))
                    print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ' :  cons.group resolved'
                END IF    
                ! flag redundant parameters
                DO i=matconsgroups(2,icgrp),matconsgroups(3,icgrp)
                    IF (globalparcons(i) == icgrp) globalparcons(i)=-icgrp
                END DO
                ! flag constraint group 
                matconsgroups(2,icgrp)=ntgb+1
                matconsgroups(3,icgrp)=ntgb
            ELSE
                ncgrpd=ncgrpd+1
                ncgbd=ncgbd+ncon
                IF (icheck > 0) THEN
                    labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
                    labell=globalparlabelindex(1,matconsgroups(3,icgrp))
                    print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ' :  cons.group redundant'
                END IF               
            END IF
        END IF
    END DO
    IF (ncgrpr > 0) THEN
        WRITE(*,*) 'GRPCON:',ncgbr,' redundancy constraints in ', ncgrpr, ' groups resolved'
        ! all constraint groups resolved ?
        IF (ncgrpr == ncgrp) ncgrp=0
    ENDIF
    IF (ncgrpd > 0) THEN
        WRITE(*,*) 'GRPCON:',ncgbd,' redundancy constraints in ', ncgrpd, ' groups detected'
    ENDIF
    WRITE(*,*)
         
    ! clean up
    CALL mpdealloc(vecparconslist)
    CALL mpdealloc(vecconsparlist)
    CALL mpdealloc(vecparconsoffsets)
    CALL mpdealloc(vecconsparoffsets)
    CALL mpdealloc(matconsgroupindex)    
 
END SUBROUTINE grpcon
 
 
SUBROUTINE prpcon
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: icgb
    INTEGER(mpi) :: icgrp
    INTEGER(mpi) :: ifrst
    INTEGER(mpi) :: ilast
    INTEGER(mpi) :: isblck
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: ivgb
    INTEGER(mpi) :: j
    INTEGER(mpi) :: jcgb
    INTEGER(mpi) :: jfrst
    INTEGER(mpi) :: label
    INTEGER(mpi) :: labelf
    INTEGER(mpi) :: labell
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: ngrp
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: ncnmxb
    INTEGER(mpi) :: ncnmxg
    INTEGER(mpi) :: nprmxb
    INTEGER(mpi) :: nprmxg
    INTEGER(mpi) :: inone
    INTEGER(mpi) :: nvar
 
    INTEGER(mpl):: length
    INTEGER(mpl) :: rows
    
    INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsGroupIndex
 
    ncgbe=0
    !
    ! constraint groups already built in GRPCON based on steering,
    ! now care about fixed parameters
    !
    IF(ncgrp == 0) THEN ! no constraints groups
        ncgb=0
        ncblck=0
        RETURN
    END IF
 
    length=ncgrp+1; rows=3
    ! start and parameter range of constraint blocks 
    CALL mpalloc(matconsblocks,rows,length,'start of constraint blocks, par. range (I)')
    
    length=ncgb; rows=3
    CALL mpalloc(matconsgroupindex,rows,length,'group index for constraint (I)')    
    matconsgroupindex=0   
    
    ! check for empty constraints, redefine (accepted/active) constraints and groups
    ngrp=0
    ncgb=0
    DO icgrp=1,ncgrp
        ncon=ncgb
        ! resolved group ?
        IF (matconsgroups(2,icgrp) > matconsgroups(3,icgrp)) cycle
        DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
            icgb=matconssort(3,jcgb)
            i=vecconsstart(icgb)+2
            npar=0
            nvar=0
            matconsranges(1,icgb)=ntgb
            matconsranges(2,icgb)=1
            DO
                label=listconstraints(i)%label
                itgbi=inone(label) ! -> ITGBI= index of parameter label
                ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
                npar=npar+1
                IF(ivgb > 0) THEN
                    nvar=nvar+1
                    matconsranges(1,icgb)=min(matconsranges(1,icgb),itgbi)
                    matconsranges(2,icgb)=max(matconsranges(2,icgb),itgbi)
                ENDIF
                i=i+1
                IF(i > lenconstraints) EXIT
                IF(listconstraints(i)%label < 0) EXIT
            END DO
            IF (nvar == 0) THEN
                ncgbe=ncgbe+1
                ! reset range
                matconsranges(1,icgb)=matconsranges(3,icgb)
                matconsranges(2,icgb)=matconsranges(4,icgb)
            END IF
            IF (nvar > 0 .OR. iskpec == 0) THEN
                ! constraint accepted (or kept)
                ncgb=ncgb+1
                matconsgroupindex(1,ncgb)=ngrp+1    
                matconsgroupindex(2,ncgb)=icgb
                matconsgroupindex(3,ncgb)=nvar
            END IF
        END DO
        IF (ncgb > ncon) ngrp=ngrp+1
    END DO
    ncgrp=ngrp       
            
    IF (ncgbe > 0) THEN
        IF (iskpec > 0) THEN
            WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints skipped'
        ELSE
            WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints detected, to be fixed !!!'
            WRITE(*,*) '       (use option "skipemptycons" to skip those)'
            IF (icheck == 0) THEN
                icheck=2     ! switch to '-C'
                ncgbe=-ncgbe ! indicate that
                WRITE(*,*)
                WRITE(*,*) '!!!   Switch to "-C" (checking input only), no calculation of a solution   !!!'
                WRITE(8,*) '!!!   Switch to "-C" (checking input only), no calculation of a solution   !!!'
                WRITE(*,*)
            END IF
        END IF
    END IF
    WRITE(*,*) 'PRPCON:',ncgb,' constraints accepted'
    WRITE(*,*)
    
    IF(ncgb == 0) RETURN  ! no constraints left   
 
    ! already sorted by group number
               
    matconsgroups(1,1:ncgrp)=0
    DO jcgb=1,ncgb
        ! set up matConsSort
        icgb=matconsgroupindex(2,jcgb)
        matconssort(1,jcgb)=matconsranges(1,icgb)
        matconssort(2,jcgb)=matconsranges(2,icgb)
        matconssort(3,jcgb)=icgb
        ! set up matConsGroups
        icgrp=matconsgroupindex(1,jcgb)
        IF (matconsgroups(1,icgrp) == 0) THEN
            matconsgroups(1,icgrp)=jcgb
            matconsgroups(2,icgrp)=matconsranges(1,icgb)     
            matconsgroups(3,icgrp)=matconsranges(2,icgb)
        ELSE    
            matconsgroups(2,icgrp)=min(matconsgroups(2,icgrp),matconsranges(1,icgb))      
            matconsgroups(3,icgrp)=max(matconsgroups(3,icgrp),matconsranges(2,icgb))
        END IF 
    END DO
    matconsgroups(1,ncgrp+1)=ncgb+1
    matconsgroups(2,ncgrp+1)=ntgb+1 
 
    ! loop over constraints groups, combine into non overlapping blocks
    ncblck=0
    ncnmxg=0
    nprmxg=0
    ncnmxb=0
    nprmxb=0    
    mszcon=0
    mszprd=0
    isblck=1
    ilast=0
    IF (icheck > 0) THEN
        WRITE(*,*)
        IF (icheck > 1) &
            WRITE(*,*) ' Cons. sorted       index   #var.par.  first line first label  last label'
        WRITE(*,*) ' Cons. group        index first cons.  last cons. first label  last label'
        WRITE(*,*) ' Cons. block        index first group  last group first label  last label'
    END IF
    DO icgrp=1,ncgrp 
        IF  (icheck > 1) THEN
            DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
                icgb=matconssort(3,jcgb)
                nvar=matconsgroupindex(3,jcgb)
                labelf=globalparlabelindex(1,matconssort(1,jcgb))
                labell=globalparlabelindex(1,matconssort(2,jcgb))
                IF (nvar > 0) THEN
                    WRITE(*,*) ' Cons. sorted', jcgb, nvar, &
                        -listconstraints(vecconsstart(icgb))%label, labelf, labell
                ELSE
                    WRITE(*,*) ' Cons. sorted', jcgb, '  empty (0)', &
                        -listconstraints(vecconsstart(icgb))%label, labelf, labell
                END IF
            END DO
        END IF 
        IF (icheck > 0) THEN
            !ivgb=globalParLabelIndex(2,matConsGroups(2,icgrp)) ! -> index of variable global parameter
            labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
            labell=globalparlabelindex(1,matconsgroups(3,icgrp))
            WRITE(*,*) ' Cons. group ', icgrp, matconsgroups(1,icgrp), &
                matconsgroups(1,icgrp+1)-1, labelf, labell
        ENDIF
        ! combine into non overlapping blocks
        ilast=max(ilast, matconsgroups(3,icgrp))
        IF (matconsgroups(2,icgrp+1) > ilast) THEN
            ncblck=ncblck+1
            ifrst=matconsgroups(2,isblck)
            matconsblocks(1,ncblck)=matconsgroups(1,isblck)
            matconsblocks(2,ncblck)=ifrst ! save first parameter in block
            matconsblocks(3,ncblck)=ilast ! save last parameter in block
            ! update matConsSort
            jfrst=matconsgroups(2,icgrp)
            DO i=icgrp,isblck,-1
                DO j=matconsgroups(1,i),matconsgroups(1,i+1)-1
                    ! non zero range (from group)
                    matconsranges(1,j)=matconsgroups(2,i) 
                    matconsranges(2,j)=matconsgroups(3,i)
                    ! storage range (from max group, ilast)
                    jfrst=min(jfrst,matconsgroups(2,i)) 
                    matconsranges(3,j)=jfrst 
                    matconsranges(4,j)=ilast 
                END DO 
            END DO
            IF (icheck > 0) THEN
                labelf=globalparlabelindex(1,ifrst)
                labell=globalparlabelindex(1,ilast)
                WRITE(*,*) ' Cons. block ', ncblck, isblck, icgrp, labelf, labell
            ENDIF
            ! reset for new block
            isblck=icgrp+1
        END IF 
    END DO
    matconsblocks(1,ncblck+1)=ncgb+1
 
    ! convert from total parameter index to index of variable global parameter
    DO i=1,ncblck
        ifrst=globalparlabelindex(2,matconsblocks(2,i)) ! -> index of variable global parameter
        ilast=globalparlabelindex(2,matconsblocks(3,i)) ! -> index of variable global parameter
        IF (ifrst > 0) THEN
            matconsblocks(2,i)=ifrst
            matconsblocks(3,i)=ilast
            ! statistics
            ncon=matconsblocks(1,i+1)-matconsblocks(1,i)
            npar=ilast+1-ifrst
            ncnmxb=max(ncnmxb,ncon)
            nprmxb=max(nprmxb,npar)
            ! update index ranges
            globalindexranges(ifrst)=max(globalindexranges(ifrst),ilast)
        ELSE
            ! empty
            matconsblocks(2,i)=1
            matconsblocks(3,i)=0
        END IF
    END DO
    DO icgrp=1,ncgrp
        ifrst=globalparlabelindex(2,matconsgroups(2,icgrp)) ! -> index of variable global parameter
        ilast=globalparlabelindex(2,matconsgroups(3,icgrp)) ! -> index of variable global parameter
        IF (ifrst > 0) THEN
            matconsgroups(2,icgrp)=ifrst
            matconsgroups(3,icgrp)=ilast
            DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
                DO i=1,4
                    ivgb=globalparlabelindex(2,matconsranges(i,jcgb)) ! -> index of variable global parameter
                    matconsranges(i,jcgb)=ivgb
                END DO
            END DO
            ! storage sizes, statistics
            jcgb=matconsgroups(1,icgrp) ! first cons.
            ncon=matconsgroups(1,icgrp+1)-jcgb
            npar=matconsranges(4,jcgb)+1-matconsranges(3,jcgb)
            ncnmxg=max(ncnmxg,ncon)
            nprmxg=max(nprmxg,npar)
            mszcon=mszcon+int(ncon,mpl)*int(npar,mpl)       ! (sum of) block size for constraint matrix
            mszprd=mszprd+int(ncon,mpl)*int(ncon+1,mpl)/2   ! (sum of) block size for product matrix
        ELSE
            ! empty
            matconsgroups(2,icgrp)=1
            matconsgroups(3,icgrp)=0
            DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
                matconsranges(1,jcgb)=1
                matconsranges(2,jcgb)=0
                matconsranges(3,jcgb)=1
                matconsranges(4,jcgb)=0
            END DO
        END IF
    END DO
 
    ! clean up
    CALL mpdealloc(matconsgroupindex)
 
    ! save constraint group for global parameters
    globalparcons=0
    DO icgrp=1,ncgrp
        DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
            ! index in list 
            icgb=matconssort(3,jcgb)
            DO j=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
                label=listconstraints(j)%label
                itgbi=inone(label) ! -> ITGBI= index of parameter label
                globalparcons(itgbi)=icgrp ! save constraint group
            END DO
        END DO
    END DO
          
    IF (ncgrp+icheck > 1) THEN
        WRITE(*,*)
        WRITE(*,*) 'PRPCON: constraints split into ', ncgrp, '(disjoint) groups,'
        WRITE(*,*) '        groups  combined  into ', ncblck, '(non overlapping) blocks'
        WRITE(*,*) '        max group size (cons., par.) ', ncnmxg, nprmxg
        WRITE(*,*) '        max block size (cons., par.) ', ncnmxb, nprmxb
        IF (icheck > 0) WRITE(*,*) '        total block matrix sizes     ', mszcon, mszprd
    END IF
 
END SUBROUTINE prpcon
 
 
SUBROUTINE feasma
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    REAL(mpd) :: factr
    REAL(mpd) :: sgm
    INTEGER(mpi) :: i
    INTEGER(mpi) :: icgb
    INTEGER(mpi) :: icgrp
    INTEGER(mpl) :: ij
    INTEGER(mpi) :: ifirst
    INTEGER(mpi) :: ilast
    INTEGER(mpl) :: ioffc
    INTEGER(mpl) :: ioffp
    INTEGER(mpi) :: irank
    INTEGER(mpi) :: ipar0
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: ivgb
    INTEGER(mpi) :: j
    INTEGER(mpi) :: jcgb
    INTEGER(mpl) :: ll
    INTEGER(mpi) :: label
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: nrank
    INTEGER(mpi) :: inone
 
    REAL(mpd):: rhs
    REAL(mpd):: evmax
    REAL(mpd):: evmin
    INTEGER(mpl):: length
    REAL(mpd), DIMENSION(:), ALLOCATABLE :: matConstraintsT
    REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI
    SAVE
    !     ...
 
    IF(ncgb == 0) RETURN  ! no constraints
    
    !     product matrix A A^T (A is stored as transposed)
    length=mszprd
    CALL mpalloc(matconsproduct, length, 'product matrix of constraints (blocks)')
    matconsproduct=0.0_mpd
    length=ncgb  
    CALL mpalloc(vecconsresiduals, length, 'residuals of constraints')
    CALL mpalloc(vecconssolution, length, 'solution for constraints')
    CALL mpalloc(auxvectori,length,'auxiliary array (I)')  ! int aux 1
    CALL mpalloc(auxvectord,length,'auxiliary array (D)')  ! double aux 1
    !     constraint matrix A (A is stored as transposed)
    length = mszcon
    CALL mpalloc(matconstraintst,length,'transposed matrix of constraints (blocks)')
    matconstraintst=0.0_mpd
       
    ! loop over sorted constraints, fill matrices, get rank, inverted product matrix (in groups)
    ioffc=0 ! group offset in constraint matrix
    ioffp=0 ! group offset in product matrix
    nrank=0
    DO icgrp=1,ncgrp
        ifirst=matconsgroups(1,icgrp)      ! first constraint in group
        ilast=matconsgroups(1,icgrp+1)-1   ! last constraint in group
        ncon=ilast+1-ifirst               
        ipar0=matconsranges(3,ifirst)-1    ! parameter offset
        npar=matconsranges(4,ifirst)-ipar0 ! number of parameters
        IF (npar <= 0) THEN
            WRITE(*,*) ' Constraint group, #con, rank', icgrp, ncon, 0, ' (empty)'
            cycle               ! skip empty groups/cons.
        END IF
        DO jcgb=ifirst,ilast
            ! index in list 
            icgb=matconssort(3,jcgb)
            ! fill constraint matrix
            i=vecconsstart(icgb)
            rhs=listconstraints(i  )%value ! right hand side
            sgm=listconstraints(i+1)%value ! sigma parameter
            DO j=i+2,vecconsstart(icgb+1)-1
                label=listconstraints(j)%label
                factr=listconstraints(j)%value
                itgbi=inone(label) ! -> ITGBI= index of parameter label
                ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
                IF(ivgb > 0) matconstraintst(int(jcgb-ifirst,mpl)*int(npar,mpl)+ivgb-ipar0+ioffc)= &
                    matconstraintst(int(jcgb-ifirst,mpl)*int(npar,mpl)+ivgb-ipar0+ioffc)+factr ! matrix element
                rhs=rhs-factr*globalparameter(itgbi)     ! reduce residuum
            END DO
            vecconsresiduals(jcgb)=rhs        ! constraint discrepancy
        END DO
        
        ! get rank of groups
        DO ll=ioffc+1,ioffc+npar
            ij=ioffp
            DO i=1,ncon
                DO j=1,i
                    ij=ij+1
                    matconsproduct(ij)=matconsproduct(ij)+ &                     
                        matconstraintst(int(i-1,mpl)*int(npar,mpl)+ll)* &
                        matconstraintst(int(j-1,mpl)*int(npar,mpl)+ll)
                END DO
            END DO
        END DO
        !     inversion of product matrix of constraints
        CALL sqminv(matconsproduct(ioffp+1:ij),vecconsresiduals(ifirst:ilast),ncon,irank, auxvectord, auxvectori)
        IF (icheck > 1 .OR. irank < ncon) THEN
            WRITE(*,*) ' Constraint group, #con, rank', icgrp, ncon, irank
            IF (irank < ncon) THEN
                WRITE(*,*) '  .. rank deficit !! '
                WRITE(*,*) '     E.g. fix all parameters and remove all constraints related to label ', &
                    globalparlabelindex(1,globalparvartototal(ipar0+1))
            END IF 
        END IF    
        nrank=nrank+irank
        ioffc=ioffc+int(npar,mpl)*int(ncon,mpl)
        ioffp=ij   
    END DO          
 
    nmiss1=ncgb-nrank
 
    WRITE(*,*) ' '
    WRITE(*,*) 'Rank of product matrix of constraints is',nrank,  &
        ' for',ncgb,' constraint equations'
    WRITE(8,*) 'Rank of product matrix of constraints is',nrank,  &
        ' for',ncgb,' constraint equations'
    IF(nrank < ncgb) THEN
        WRITE(*,*) 'Warning: insufficient constraint equations!'
        WRITE(8,*) 'Warning: insufficient constraint equations!'
        IF (iforce == 0) THEN
            isubit=1
            WRITE(*,*) '         --> enforcing SUBITO mode'
            WRITE(8,*) '         --> enforcing SUBITO mode'
        END IF
    END IF
    
    ! QL decomposition
    IF (nfgb < nvgb) THEN
        print *
        print *, 'QL decomposition of constraints matrix'
        ! monitor progress
        IF(monpg1 > 0) THEN
            WRITE(lunlog,*) 'QL decomposition of constraints matrix'
            CALL monini(lunlog,monpg1,monpg2)
        END IF
        IF(icelim < 2) THEN ! True unless unpacked LAPACK
            ! QL decomposition
            CALL qlini(nvgb,ncgb,npblck,mszcon,monpg1)
            ! loop over parameter blocks
            CALL qldecb(matconstraintst,matparblockoffsets,matconsblocks,matconsranges)
            ! check eignevalues of L
            CALL qlgete(evmin,evmax)
#ifdef LAPACK64
        ELSE
            CALL lpqldec(matconstraintst,evmin,evmax)
#endif
        END IF         
        IF(monpg1 > 0) CALL monend()
        print *, '   largest  |eigenvalue| of L: ', evmax
        print *, '   smallest |eigenvalue| of L: ', evmin
        IF (evmin == 0.0_mpd.AND.icheck == 0) THEN
            CALL peend(27,'Aborted, singular QL decomposition of constraints matrix')
            stop 'FEASMA: stopping due to singular QL decomposition of constraints matrix'
        END IF  
    END IF
 
    CALL mpdealloc(matconstraintst)
    CALL mpdealloc(auxvectord)
    CALL mpdealloc(auxvectori)
 
    RETURN
END SUBROUTINE feasma ! matrix for feasible solution
 
SUBROUTINE feasib(concut,iact)
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    REAL(mpd) :: factr
    REAL(mpd) :: sgm
    INTEGER(mpi) :: i
    INTEGER(mpi) :: icgb
    INTEGER(mpi) :: icgrp
    INTEGER(mpi) :: iter
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: ivgb
    INTEGER(mpi) :: ieblck
    INTEGER(mpi) :: isblck
    INTEGER(mpi) :: ifirst
    INTEGER(mpi) :: ilast
    INTEGER(mpi) :: j
    INTEGER(mpi) :: jcgb
    INTEGER(mpi) :: label
    INTEGER(mpi) :: inone
    INTEGER(mpi) :: ncon
 
    REAL(mps), INTENT(IN)     :: concut
    INTEGER(mpi), INTENT(OUT) :: iact
 
    REAL(mpd) :: rhs
    REAL(mpd) ::sum1
    REAL(mpd) ::sum2
    REAL(mpd) ::sum3
 
    REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecCorrections
    SAVE
 
    iact=0
    IF(ncgb == 0) RETURN  ! no constraints
 
    DO iter=1,2
        vecconsresiduals=0.0_mpd
  
        !      calculate right constraint equation discrepancies
        DO jcgb=1,ncgb
            icgb=matconssort(3,jcgb) ! unsorted constraint index
            i=vecconsstart(icgb)
            rhs=listconstraints(i  )%value ! right hand side
            sgm=listconstraints(i+1)%value ! sigma parameter
            DO j=i+2,vecconsstart(icgb+1)-1
                label=listconstraints(j)%label
                factr=listconstraints(j)%value
                itgbi=inone(label) ! -> ITGBI= index of parameter label
                rhs=rhs-factr*globalparameter(itgbi)     ! reduce residuum
            ENDDO
            vecconsresiduals(jcgb)=rhs        ! constraint discrepancy
        END DO
  
        !      constraint equation discrepancies -------------------------------
  
        sum1=0.0_mpd
        sum2=0.0_mpd
        sum3=0.0_mpd
        DO icgb=1,ncgb
            sum1=sum1+vecconsresiduals(icgb)**2
            sum2=sum2+abs(vecconsresiduals(icgb))
            sum3=max(sum3,abs(vecconsresiduals(icgb)))
        END DO
        sum1=sqrt(sum1/real(ncgb,mpd))
        sum2=sum2/real(ncgb,mpd)
  
        IF(iter == 1.AND.sum1 < concut) RETURN  ! do nothing if correction small
  
        IF(iter == 1.AND.ncgb <= 12) THEN
            WRITE(*,*) ' '
            WRITE(*,*) 'Constraint equation discrepancies:'
            WRITE(*,101) (icgb,vecconsresiduals(icgb),icgb=1,ncgb)
101         FORMAT(4x,4(i5,g12.4))
            WRITE(*,103) concut
103         FORMAT(10x,' Cut on rms value is',g8.1)
        END IF
  
        IF(iact == 0) THEN
            WRITE(*,*) ' '
            WRITE(*,*) 'Improve constraints'
        END IF
        iact=1
  
        WRITE(*,102) iter,sum1,sum2,sum3
102     FORMAT(i6,'   rms',g12.4,'  avrg_abs',g12.4,'  max_abs',g12.4)
  
        CALL mpalloc(veccorrections,int(nvgb,mpl),'constraint corrections')
        veccorrections=0.0_mpd
 
        !      multiply (group-wise) inverse matrix and constraint vector
        isblck=0
        DO icgrp=1,ncgrp
            ifirst=matconsgroups(1,icgrp)      ! first constraint in group
            ilast=matconsgroups(1,icgrp+1)-1   ! last constraint in group
            ncon=ilast+1-ifirst
            ieblck=isblck+(ncon*(ncon+1))/2
            CALL dbsvx(matconsproduct(isblck+1:ieblck),vecconsresiduals(ifirst:ilast),vecconssolution(ifirst:ilast),ncon)
            isblck=ieblck
        END DO    
 
        DO jcgb=1,ncgb
            icgb=matconssort(3,jcgb) ! unsorted constraint index
            i=vecconsstart(icgb)
            rhs=listconstraints(i  )%value ! right hand side
            sgm=listconstraints(i+1)%value ! sigma parameter
            DO j=i+2,vecconsstart(icgb+1)-1
                label=listconstraints(j)%label
                factr=listconstraints(j)%value
                itgbi=inone(label) ! -> ITGBI= index of parameter label
                ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
                IF(ivgb > 0) THEN
                    veccorrections(ivgb)=veccorrections(ivgb)+vecconssolution(jcgb)*factr
                END IF
            ENDDO
        END DO
 
        DO i=1,nvgb ! add corrections
            itgbi=globalparvartototal(i)
            globalparameter(itgbi)=globalparameter(itgbi)+veccorrections(i)
        END DO
 
        CALL mpdealloc(veccorrections)
 
    END DO ! iteration 1 and 2
 
END SUBROUTINE feasib ! make parameters feasible
 
SUBROUTINE peread(more)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: iact
    INTEGER(mpi) :: ierrc
    INTEGER(mpi) :: ierrf
    INTEGER(mpi) :: ioffp
    INTEGER(mpi) :: ios
    INTEGER(mpi) :: ithr
    INTEGER(mpi) :: jfile
    INTEGER(mpi) :: jrec
    INTEGER(mpi) :: k
    INTEGER(mpi) :: kfile
    INTEGER(mpi) :: l
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: mpri
    INTEGER(mpi) :: n
    INTEGER(mpi) :: nact
    INTEGER(mpi) :: nbuf
    INTEGER(mpi) :: ndata
    INTEGER(mpi) :: noff
    INTEGER(mpi) :: noffs
    INTEGER(mpi) :: npointer
    INTEGER(mpi) :: npri
    INTEGER(mpi) :: nr
    INTEGER(mpi) :: nrc
    INTEGER(mpi) :: nrd
    INTEGER(mpi) :: nrpr
    INTEGER(mpi) :: nthr
    INTEGER(mpi) :: ntot
    INTEGER(mpi) :: maxRecordSize
    INTEGER(mpi) :: maxRecordFile
 
    INTEGER(mpi), INTENT(OUT)                     :: more
 
    LOGICAL :: lprint
    LOGICAL :: floop
    LOGICAL :: eof
    REAL(mpd) :: ds0
    REAL(mpd) :: ds1
    REAL(mpd) :: ds2
    REAL(mpd) :: dw
    !$    INTEGER(mpi) :: OMP_GET_THREAD_NUM
    CHARACTER (LEN=7) :: cfile
    SAVE
 
#ifdef READ_C_FILES
    INTERFACE
        SUBROUTINE readc(bufferD, bufferF, bufferI, bufferLength, lun, err) BIND(c)
            USE iso_c_binding
            REAL(c_double), DIMENSION(*), INTENT(OUT) :: bufferD
            REAL(c_float), DIMENSION(*), INTENT(OUT) :: bufferF
            INTEGER(c_int), DIMENSION(*), INTENT(OUT) :: bufferI
            INTEGER(c_int), INTENT(INOUT) :: bufferLength
            INTEGER(c_int), INTENT(IN), VALUE :: lun
            INTEGER(c_int), INTENT(OUT) :: err
        END SUBROUTINE readc
    END INTERFACE
#endif
 
    DATA lprint/.true./
    DATA floop/.true./
    DATA npri / 0 /, mpri / 1000 /
    !     ...
    IF(ifile == 0) THEN  ! start/restart
        nrec=0
        nrecd=0
        ntot=0
        sumrecords=0
        skippedrecords=0
        numblocks=0
        minrecordsinblock=size(readbufferdatai)
        maxrecordsinblock=0
        readbufferinfo=0  ! reset management info
        nrpr=1
        nthr=mthrdr
        nact=0   ! active threads (have something still to read)
        DO k=1,nthr
            IF (ifile < nfilb) THEN
                ifile=ifile+1
                readbufferinfo(1,k)=ifile
                readbufferinfo(2,k)=nact
                nact=nact+1
            END IF
        END DO
    END IF
    npointer=size(readbufferpointer)/nact
    ndata=size(readbufferdatai)/nact
    more=-1
    DO k=1,nthr
        iact=readbufferinfo(2,k)
        readbufferinfo(4,k)=0                 ! reset counter
        readbufferinfo(5,k)=iact*ndata  ! reset offset
    END DO
    numblocks=numblocks+1 ! new block
 
    !$OMP  PARALLEL &
    !$OMP  DEFAULT(PRIVATE) &
    !$OMP  SHARED(readBufferInfo,readBufferPointer,readBufferDataI,readBufferDataD, &
    !$OMP  readBufferDataF,nPointer,nData,skippedRecords,ndimbuf,NTHR,NFILF,FLOOP, &
    !$OMP        IFD,KFD,IFILE,NFILB,WFD,XFD,icheck,keepOpen,ireeof,nrderr) &
    !$OMP  NUM_THREADS(NTHR)
 
    ithr=1
    !$ ITHR=OMP_GET_THREAD_NUM()+1     ! thread number
    jfile=readbufferinfo(1,ithr)  ! file index
    iact =readbufferinfo(2,ithr)  ! active thread number
    jrec =readbufferinfo(3,ithr)  ! records read
    ioffp=iact*npointer
    noffs=(ithr-1)*ndimbuf        ! offset for intermediate float buffer
 
    files: DO WHILE (jfile > 0)
        kfile=kfd(2,jfile)
        ! open again
        IF (keepopen < 1 .AND. readbufferinfo(3,ithr) == 0) THEN
            CALL binopn(kfile,ithr,ios)
        END IF        
        records: DO
            nbuf=readbufferinfo(4,ithr)+1
            noff=readbufferinfo(5,ithr)+2     ! 2 header words per record
            nr=ndimbuf
            IF(kfile <= nfilf) THEN ! Fortran file
                lun=kfile+10
                READ(lun,iostat=ierrf) n,(readbufferdataf(noffs+i),i=1,min(n/2,nr)),&
                    (readbufferdatai(noff+i),i=1,min(n/2,nr))
                nr=n/2
                ! convert to double
                DO i=1,nr
                    readbufferdatad(noff+i)=real(readbufferdataf(noffs+i),mpr8)
                END DO
                ! IF (ierrf < 0) REWIND lun ! end-of-file ! CHK use binrwd()
                eof=(ierrf /= 0)
            ELSE         ! C file
                lun=kfile-nfilf
                IF (keepopen < 1) lun=ithr
#ifdef READ_C_FILES
                CALL readc(readbufferdatad(noff+1),readbufferdataf(noffs+1),readbufferdatai(noff+1),nr,lun,ierrc)
                n=nr+nr
                IF (ierrc > 4) readbufferinfo(6,ithr)=readbufferinfo(6,ithr)+1
#else
                ierrc=0
#endif
                eof=(ierrc <= 0.AND.ierrc /= -4) ! allow buffer overruns -> skip record
                IF(eof.AND.ierrc < 0) THEN
                    WRITE(*,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc 
                    WRITE(8,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc
                    IF (icheck <= 0 .AND. ireeof <=0) THEN ! stop unless 'checkinput' mode or 'readerroraseof'
                        WRITE(cfile,'(I7)') kfile
                        CALL peend(18,'Aborted, read error(s) for binary file ' // cfile)
                        stop 'PEREAD: stopping due to read errors'
                    END IF
                    IF (kfd(1,jfile) == 1) THEN ! count files with read errors in first loop
                        !$OMP ATOMIC
                        nrderr=nrderr+1
                    END IF     
                END IF
            END IF
            IF(eof) EXIT records   ! end-of-files or error
 
            jrec=jrec+1
            readbufferinfo(3,ithr)=jrec
            IF(floop) THEN
                xfd(jfile)=max(xfd(jfile),n)
                IF(ithr == 1) THEN
                    CALL hmplnt(1,n)
                    IF(readbufferdatai(noff+1) /= 0) CALL hmpent(8,real(readbufferdatai(noff+1),mps))
                END IF
            END IF
 
            IF (nr <= ndimbuf) THEN
                readbufferinfo(4,ithr)=nbuf
                readbufferinfo(5,ithr)=noff+nr
 
                readbufferpointer(ioffp+nbuf)=noff       ! pointer to start of buffer
                readbufferdatai(noff  )=noff+nr          ! pointer to  end  of buffer
                readbufferdatai(noff-1)=jrec             ! local record number
                readbufferdatad(noff  )=real(kfile,mpr8) ! file number
                readbufferdatad(noff-1)=real(wfd(kfile),mpr8) ! weight
 
                IF ((noff+nr+2+ndimbuf >= ndata*(iact+1)).OR.(nbuf >= npointer)) EXIT files ! buffer full
            ELSE
                !$OMP ATOMIC
                skippedrecords=skippedrecords+1
                cycle records
            END IF
 
        END DO records
 
        readbufferinfo(1,ithr)=-jfile   ! flag eof        
        IF (keepopen < 1) THEN ! close again
            CALL bincls(kfile,ithr)
        ELSE ! rewind 
            CALL binrwd(kfile)    
        END IF
        IF (kfd(1,jfile) == 1) THEN
            print *, 'PEREAD: file ', kfile, 'read the first time, found',jrec,' records'
            kfd(1,jfile)=-jrec
        ELSE
            !PRINT *, 'PEREAD: file ', kfile, 'records', jrec, -kfd(1,jfile)
            IF (-kfd(1,jfile) /= jrec) THEN
                WRITE(cfile,'(I7)') kfile
                CALL peend(19,'Aborted, binary file modified (length) ' // cfile)
                stop 'PEREAD: file modified (length)'
            END IF   
        END IF
        !        take next file
        !$OMP CRITICAL
        IF (ifile < nfilb) THEN
            ifile=ifile+1
            jrec=0
            readbufferinfo(1,ithr)=ifile
            readbufferinfo(3,ithr)=jrec
        END IF
        !$OMP END CRITICAL
        jfile=readbufferinfo(1,ithr)
 
    END DO files
    !$OMP END PARALLEL
    !     compress pointers
    nrd=readbufferinfo(4,1) ! buffers from 1 .thread
    DO k=2,nthr
        iact =readbufferinfo(2,k)
        ioffp=iact*npointer
        nbuf=readbufferinfo(4,k)
        DO l=1,nbuf
            readbufferpointer(nrd+l)=readbufferpointer(ioffp+l)
        END DO
        nrd=nrd+nbuf
    END DO
 
    more=0
    DO k=1,nthr
        jfile=readbufferinfo(1,k)
        IF (jfile > 0) THEN ! no eof yet
            readbufferinfo(2,k)=more
            more=more+1
        ELSE
            ! no more files, thread retires
            readbufferinfo(1,k)=0
            readbufferinfo(2,k)=-1
            readbufferinfo(3,k)=0
            nrecd=nrecd+readbufferinfo(6,k)
            readbufferinfo(6,k)=0
        END IF
    END DO
    !     record limit ?
    IF (mxrec > 0.AND.(ntot+nrd) >= mxrec) THEN
        nrd=mxrec-ntot
        more=-1
        DO k=1,nthr
            jfile=readbufferinfo(1,k)
            IF (jfile > 0) THEN   ! rewind or close files
                nrc=readbufferinfo(3,k)
                IF (kfd(1,jfile) == 1) kfd(1,jfile)=-nrc
                kfile=kfd(2,jfile)
                IF (keepopen < 1) THEN ! close again
                    CALL bincls(kfile,k)
                ELSE ! rewind
                    CALL binrwd(kfile)
                END IF               
            END IF
        END DO
    END IF
 
    ntot=ntot+nrd
    nrec=ntot
    numreadbuffer=nrd
 
    sumrecords=sumrecords+nrd
    minrecordsinblock=min(minrecordsinblock,nrd)
    maxrecordsinblock=max(maxrecordsinblock,nrd)
 
    DO WHILE (nloopn == 0.AND.ntot >= nrpr)
        WRITE(*,*) ' Record ',nrpr
        IF (nrpr < 100000) THEN
            nrpr=nrpr*10
        ELSE
            nrpr=nrpr+100000
        END IF
    END DO
 
    IF (ncache > 0.AND.nloopn <= 1.AND. npri < mpri.AND.mprint > 1) THEN
        npri=npri+1
        IF (npri == 1) WRITE(*,100)
        WRITE(*,101) nrec, nrd, more ,ifile
100     FORMAT(/' PeRead        records         active      file'  &
            /'            total     block   threads    number')
101     FORMAT(' PeRead',4i10)
    END IF
 
    IF (more <= 0) THEN
        ifile=0
        IF (floop) THEN
            !           check for file weights
            ds0=0.0_mpd
            ds1=0.0_mpd
            ds2=0.0_mpd
            maxrecordsize=0
            maxrecordfile=0
            DO k=1,nfilb
                IF (xfd(k) > maxrecordsize) THEN
                    maxrecordsize=xfd(k)
                    maxrecordfile=k
                END IF
                dw=real(-kfd(1,k),mpd)
                IF (wfd(k) /= 1.0) nfilw=nfilw+1
                ds0=ds0+dw
                ds1=ds1+dw*real(wfd(k),mpd)
                ds2=ds2+dw*real(wfd(k)**2,mpd)
            END DO
            print *, 'PEREAD: file ', maxrecordfile, 'with max record size ', maxrecordsize
            IF (nfilw > 0.AND.ds0 > 0.0_mpd) THEN
                ds1=ds1/ds0
                ds2=ds2/ds0-ds1*ds1
                DO lun=6,lunlog,2
                    WRITE(lun,177) nfilw,real(ds1,mps),real(ds2,mps)
177                 FORMAT(/' !!!!!',i4,' weighted binary files',  &
                        /' !!!!! mean, variance of weights =',2g12.4)
                END DO
            END IF
            !           integrate record numbers
            DO k=2,nfilb
                ifd(k)=ifd(k-1)-kfd(1,k-1)
            END DO
            !           sort
            IF (nthr > 1) CALL sort2k(kfd,nfilb)  
            IF (skippedrecords > 0) THEN
                print *, 'PEREAD skipped records: ', skippedrecords
                ndimbuf=maxrecordsize/2 ! adjust buffer size
            END IF
        END IF
        lprint=.false.
        floop=.false.
        IF (ncache > 0.AND.nloopn <= 1.AND.mprint > 0)  &
            WRITE(*,179) numblocks, sumrecords, minrecordsinblock, maxrecordsinblock
179     FORMAT(/' Read  cache usage (#blocks,   #records, ',  &
            'min,max records/block'/17x,i10,i12,2i10)
    END IF
    RETURN
 
END SUBROUTINE peread
 
SUBROUTINE peprep(mode)
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi), INTENT(IN) :: mode
 
    INTEGER(mpi) :: ibuf
    INTEGER(mpi) :: ichunk
    INTEGER(mpi) :: ist
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jsp
    INTEGER(mpi) :: nst
    INTEGER(mpi), PARAMETER :: maxbad = 100 ! max number of bad records with print out
    INTEGER(mpi) :: nbad
    INTEGER(mpi) :: nerr
    INTEGER(mpi) :: inone
 
    IF (mode > 0) THEN
#ifdef __PGIC__
        ! to prevent "PGF90-F-0000-Internal compiler error. Could not locate uplevel instance for stblock"
        ichunk=256
#else    
        ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
#endif
        ! parallelize record loop
        !$OMP  PARALLEL DO &
        !$OMP   DEFAULT(PRIVATE) &
        !$OMP   SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,ICHUNK,iscerr,dscerr) &
        !$OMP   SCHEDULE(DYNAMIC,ICHUNK)
        DO ibuf=1,numreadbuffer ! buffer for current record
            ist=readbufferpointer(ibuf)+1
            nst=readbufferdatai(readbufferpointer(ibuf))
            DO ! loop over measurements
                CALL isjajb(nst,ist,ja,jb,jsp)
                IF(jb == 0) EXIT
                DO j=1,ist-jb
                    readbufferdatai(jb+j)=inone( readbufferdatai(jb+j) ) ! translate to index
                END DO
                ! scale error ?
                IF (iscerr > 0) THEN
                    IF (jb < ist) THEN
                        readbufferdatad(jb) = readbufferdatad(jb) * dscerr(1) ! 'global' measurement
                    ELSE
                        readbufferdatad(jb) = readbufferdatad(jb) * dscerr(2) ! 'local' measurement
                    END IF 
                END IF    
            END DO
        END DO
        !$OMP  END PARALLEL DO
    END IF
 
    !$POMP INST BEGIN(peprep)
    IF (mode <= 0) THEN
        nbad=0
        DO ibuf=1,numreadbuffer ! buffer for current record
            CALL pechk(ibuf,nerr)
            IF(nerr > 0) THEN
                nbad=nbad+1
                IF(nbad >= maxbad) EXIT
            ELSE
                ist=readbufferpointer(ibuf)+1
                nst=readbufferdatai(readbufferpointer(ibuf))
                DO ! loop over measurements
                    CALL isjajb(nst,ist,ja,jb,jsp)
                    IF(jb == 0) EXIT
                    neqn=neqn+1
                    IF(jb == ist) cycle
                    negb=negb+1
                    ndgb=ndgb+(ist-jb)
                    DO j=1,ist-jb
                        itgbi=inone( readbufferdatai(jb+j) ) ! generate index
                    END DO
                END DO
            END IF
        END DO
        IF(nbad > 0) THEN
            CALL peend(20,'Aborted, bad binary records')
            stop 'PEREAD: stopping due to bad records'
        END IF
    END IF
    !$POMP INST END(peprep)
 
END SUBROUTINE peprep
 
SUBROUTINE pechk(ibuf, nerr)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: is
    INTEGER(mpi) :: ist
    INTEGER(mpi) :: ioff
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jsp
    INTEGER(mpi) :: nan
    INTEGER(mpi) :: nst
 
    INTEGER(mpi), INTENT(IN)                      :: ibuf
    INTEGER(mpi), INTENT(OUT)                     :: nerr
    SAVE
    !     ...
 
    ist=readbufferpointer(ibuf)+1
    nst=readbufferdatai(readbufferpointer(ibuf))
    nerr=0
    is=ist
    jsp=0
    outer: DO WHILE(is < nst)
        ja=0
        jb=0
        inner1: DO
            is=is+1
            IF(is > nst) EXIT outer
            IF(readbufferdatai(is) == 0) EXIT inner1 ! found 1. marker
        END DO inner1
        ja=is
        inner2: DO
            is=is+1
            IF(is > nst) EXIT outer
            IF(readbufferdatai(is) == 0) EXIT inner2 ! found 2. marker
        END DO inner2
        jb=is        
        IF(ja+1 == jb.AND.readbufferdatad(jb) < 0.0_mpr8) THEN
            !  special data
            jsp=jb ! pointer to special data
            is=is+nint(-readbufferdatad(jb),mpi) ! skip NSP words
            cycle outer
        END IF     
        DO WHILE(readbufferdatai(is+1) /= 0.AND.is < nst)
            is=is+1
        END DO
    END DO outer
    IF(is > nst) THEN
        ioff = readbufferpointer(ibuf)
        WRITE(*,100) readbufferdatai(ioff-1), int(readbufferdatad(ioff),mpi)
100     FORMAT(' PEREAD: record ', i8,' in file ',i6, ' is broken !!!')
        nerr=nerr+1
    ENDIF
    nan=0
    DO i=ist, nst
        IF(.NOT.(readbufferdatad(i) <= 0.0_mpr8).AND..NOT.(readbufferdatad(i) > 0.0_mpr8)) nan=nan+1
    END DO
    IF(nan > 0) THEN
        ioff = readbufferpointer(ibuf)
        WRITE(*,101) readbufferdatai(ioff-1), int(readbufferdatad(ioff),mpi), nan
101     FORMAT(' PEREAD: record ', i8,' in file ',i6, ' contains ', i6, ' NaNs !!!')
        nerr= nerr+2
    ENDIF
 
END SUBROUTINE pechk
 
SUBROUTINE pepgrp
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
 
    INTEGER(mpi) :: ibuf
    INTEGER(mpi) :: ichunk
    INTEGER(mpi) :: iproc
    INTEGER(mpi) :: ioff
    INTEGER(mpi) :: ioffbi
    INTEGER(mpi) :: ist
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jsp
    INTEGER(mpi) :: nalg
    INTEGER(mpi) :: neqna
    INTEGER(mpi) :: nnz
    INTEGER(mpi) :: nst
    INTEGER(mpi) :: nzero
    INTEGER(mpi) :: inone
    INTEGER(mpl) :: length
    !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
 
    CALL useone ! make (INONE) usable
    globalparheader(-2)=-1 ! set flag to inhibit further updates
    ! need back index
    IF (mcount > 0) THEN
        length=globalparheader(-1)*mthrd
        CALL mpalloc(backindexusage,length,'global variable-index array')
        backindexusage=0
    END IF
    nzero=0
#ifdef __PGIC__
    ! to prevent "PGF90-F-0000-Internal compiler error. Could not locate uplevel instance for stblock"
    ichunk=256
#else    
    ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
#endif
    ! parallelize record loop
    !$OMP  PARALLEL DO &
    !$OMP   DEFAULT(PRIVATE) &
    !$OMP   SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,backIndexUsage,globalParHeader,ICHUNK,MCOUNT) &
    !$OMP   REDUCTION(+:NZERO) &
    !$OMP   SCHEDULE(DYNAMIC,ICHUNK)
    DO ibuf=1,numreadbuffer ! buffer for current record
        ist=readbufferpointer(ibuf)+1
        nst=readbufferdatai(readbufferpointer(ibuf))
        IF (mcount > 0) THEN
            ! count per record
            iproc=0
            !$       IPROC=OMP_GET_THREAD_NUM()         ! thread number
            ioffbi=globalparheader(-1)*iproc 
            nalg=0
            ioff=readbufferpointer(ibuf)
            DO ! loop over measurements
                CALL isjajb(nst,ist,ja,jb,jsp)
                IF(jb == 0) EXIT
                IF (ist > jb) THEN
                    DO j=1,ist-jb
                        IF (readbufferdatad(jb+j) == 0.0_mpd) THEN
                            nzero=nzero+1
                            cycle ! skip 'zero global derivatives' for counting and grouping
                        END IF
                        itgbi=inone( readbufferdatai(jb+j) ) ! translate to index
                        IF (backindexusage(ioffbi+itgbi) == 0) THEN
                            nalg=nalg+1
                            readbufferdatai(ioff+nalg)=itgbi
                            backindexusage(ioffbi+itgbi)=nalg
                        END IF
                    END DO
                END IF   
            END DO
            ! reset back index
            DO j=1,nalg
                itgbi=readbufferdatai(ioff+j)
                backindexusage(ioffbi+itgbi)=0
            END DO
            ! sort (record)
            CALL sort1k(readbufferdatai(ioff+1),nalg)
            readbufferdatai(ioff)=ioff+nalg
        ELSE   
            ! count per equation
            nalg=1 ! reserve space for counter 'nnz'
            ioff=readbufferpointer(ibuf)
            neqna=0 ! number of accepted equations
            DO ! loop over measurements
                CALL isjajb(nst,ist,ja,jb,jsp)
                IF(jb == 0) EXIT
                IF (ist > jb) THEN
                    nnz=0 ! number of non-zero derivatives
                    DO j=1,ist-jb
                        IF (readbufferdatad(jb+j) == 0.0_mpd) THEN
                            nzero=nzero+1
                            cycle ! skip 'zero global derivatives' for counting and grouping
                        END IF
                        nnz=nnz+1
                        readbufferdatai(ioff+nalg+nnz)=inone( readbufferdatai(jb+j) ) ! translate to index
                    END DO
                    IF (nnz == 0) cycle ! nothing for this equation
                    readbufferdatai(ioff+nalg)=nnz
                    ! sort (equation)
                    CALL sort1k(readbufferdatai(ioff+nalg+1),nnz)
                    nalg=nalg+nnz+1
                    ! count (accepted) equations
                    neqna=neqna+1
                END IF   
            END DO
            readbufferdatai(ioff)=neqna
        END IF               
    END DO
    !$OMP  END PARALLEL DO
    nzgb=nzgb+nzero
        
    !$POMP INST BEGIN(pepgrp)    
    DO ibuf=1,numreadbuffer ! buffer for current record
        ist=readbufferpointer(ibuf)+1
        nst=readbufferdatai(readbufferpointer(ibuf))
        IF (mcount == 0) THEN
            ! equation level
            DO j=1,nst! loop over measurements
                nnz=readbufferdatai(ist)
                CALL pargrp(ist+1,ist+nnz)
                ist=ist+nnz+1
            END DO
        ELSE
            ! record level, group     
            CALL pargrp(ist,nst)
        ENDIF
    END DO
    ! free back index
    IF (mcount > 0) THEN
        CALL mpdealloc(backindexusage)
    END IF
    !$POMP INST END(pepgrp)
    globalparheader(-2)=0 ! reset flag to reenable further updates
 
END SUBROUTINE pepgrp
 
SUBROUTINE pargrp(inds,inde)
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi) :: istart
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: j
    INTEGER(mpi) :: jstart
    INTEGER(mpi) :: jtgbi
    INTEGER(mpi) :: lstart
    INTEGER(mpi) :: ltgbi
 
    INTEGER(mpi), INTENT(IN) :: inds
    INTEGER(mpi), INTENT(IN) :: inde
            
    IF (inds > inde) RETURN
    
    ltgbi=-1
    lstart=-1
    ! build up groups
    DO j=inds,inde
        itgbi=readbufferdatai(j)
        globalparlabelcounter(itgbi)=globalparlabelcounter(itgbi)+1 ! count entries
        istart=globalparlabelindex(3,itgbi)     ! label of group start
        IF (istart == 0) THEN                   ! not yet in group
            IF (itgbi /= ltgbi+1) THEN          ! start group
                globalparlabelindex(3,itgbi)=globalparlabelindex(1,itgbi)
            ELSE
                IF (lstart == 0) THEN           ! extend group
                    globalparlabelindex(3,itgbi)=globalparlabelindex(3,ltgbi)
                ELSE                            ! start group
                    globalparlabelindex(3,itgbi)=globalparlabelindex(1,itgbi)                
                END IF    
            END IF
        END IF
        ltgbi=itgbi
        lstart=istart
    END DO
    ! split groups:
    ! - start inside group?         
    itgbi=readbufferdatai(inds)
    istart=globalparlabelindex(3,itgbi)         ! label of group start
    jstart=globalparlabelindex(1,itgbi)         ! label of first parameter
    IF (istart /= jstart) THEN                  ! start new group   
        DO WHILE (globalparlabelindex(3,itgbi) == istart)
            globalparlabelindex(3,itgbi) = jstart
            itgbi=itgbi+1
            IF (itgbi > globalparheader(-1)) EXIT
        END DO                
    END IF
    ! - not neigbours anymore
    ltgbi=readbufferdatai(inds)
    DO j=inds+1,inde
        itgbi=readbufferdatai(j)
        IF (itgbi /= ltgbi+1) THEN
            ! split after ltgbi
            lstart=globalparlabelindex(3,ltgbi) ! label of last group start
            jtgbi=ltgbi+1                       ! new group after ltgbi
            jstart=globalparlabelindex(1,jtgbi)
            DO WHILE (globalparlabelindex(3,jtgbi) == lstart)
                globalparlabelindex(3,jtgbi) = jstart
                jtgbi=jtgbi+1
                IF (jtgbi > globalparheader(-1)) EXIT
                IF (jtgbi == itgbi) jstart=globalparlabelindex(1,jtgbi)
            END DO
            ! split at itgbi
            jtgbi=itgbi                        
            istart=globalparlabelindex(3,jtgbi) ! label of group start
            jstart=globalparlabelindex(1,jtgbi) ! label of first parameter
            IF (istart /= jstart) THEN          ! start new group   
                DO WHILE (globalparlabelindex(3,jtgbi) == istart)
                    globalparlabelindex(3,jtgbi) = jstart
                    jtgbi=jtgbi+1
                    IF (jtgbi > globalparheader(-1)) EXIT
                END DO                
            END IF
        ENDIF
        ltgbi=itgbi
    END DO
    ! - end inside group?         
    itgbi=readbufferdatai(inde)
    IF (itgbi < globalparheader(-1)) THEN
        istart=globalparlabelindex(3,itgbi)     ! label of group start
        itgbi=itgbi+1
        jstart=globalparlabelindex(1,itgbi)     ! label of new group start
        DO WHILE (globalparlabelindex(3,itgbi) == istart)
            globalparlabelindex(3,itgbi) = jstart
            itgbi=itgbi+1
            IF (itgbi > globalparheader(-1)) EXIT
        END DO
    END IF                                   
 
END SUBROUTINE pargrp
 
SUBROUTINE isjajb(nst,is,ja,jb,jsp)
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi), INTENT(IN)                      :: nst
    INTEGER(mpi), INTENT(IN OUT)                  :: is
    INTEGER(mpi), INTENT(OUT)                     :: ja
    INTEGER(mpi), INTENT(OUT)                     :: jb
    INTEGER(mpi), INTENT(OUT)                     :: jsp
    SAVE
    !     ...
 
    jsp=0
    DO
        ja=0
        jb=0
        IF(is >= nst) RETURN
        DO
            is=is+1
            IF(readbufferdatai(is) == 0) EXIT
        END DO
        ja=is
        DO
            is=is+1
            IF(readbufferdatai(is) == 0) EXIT
        END DO
        jb=is
        IF(ja+1 == jb.AND.readbufferdatad(jb) < 0.0_mpr8) THEN
            !  special data
            jsp=jb ! pointer to special data
            is=is+nint(-readbufferdatad(jb),mpi) ! skip NSP words
            cycle
        END IF     
        DO WHILE(readbufferdatai(is+1) /= 0.AND.is < nst)
            is=is+1
        END DO
        EXIT
    END DO
 
END SUBROUTINE isjajb
 
 
!***********************************************************************
!                        LOOPN ...
 
SUBROUTINE loopn
    USE mpmod
 
    IMPLICIT NONE
    REAL(mpd) :: dsum
    REAL(mps) :: elmt
    REAL(mpd) :: factrj
    REAL(mpd) :: factrk
    REAL(mps) :: peakd
    REAL(mps) :: peaki
    REAL(mps) :: ratae
    REAL(mpd) :: rhs
    REAL(mps) :: rloop
    REAL(mpd) :: sgm
    REAL(mps) :: used
    REAL(mps) :: usei
    REAL(mpd) :: weight
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ioffb
    INTEGER(mpi) :: ipr
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: itgbij
    INTEGER(mpi) :: itgbik
    INTEGER(mpi) :: ivgb
    INTEGER(mpi) :: ivgbij
    INTEGER(mpi) :: ivgbik
    INTEGER(mpi) :: j
    INTEGER(mpi) :: k
    INTEGER(mpi) :: lastit
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: ncrit
    INTEGER(mpi) :: ngras
    INTEGER(mpi) :: nparl
    INTEGER(mpi) :: nr
    INTEGER(mpl) :: nrej
    INTEGER(mpi) :: inone
    INTEGER(mpi) :: ilow
    INTEGER(mpi) :: nlow
    INTEGER(mpi) :: nzero
    LOGICAL :: btest
 
    REAL(mpd):: adder
    REAL(mpd)::funref
    REAL(mpd)::matij
 
    SAVE
    !     ...
 
    !     ----- book and reset ---------------------------------------------
    IF(nloopn == 0) THEN      ! first call
        lastit=-1
        iitera=0
    END IF
 
    nloopn=nloopn+1           ! increase loop counter
    funref=0.0_mpd
 
    IF(nloopn == 1) THEN      ! book histograms for 1. iteration
        CALL gmpdef(1,4,'Function value in iterations')
        IF (metsol == 4 .OR. metsol == 5) THEN ! extend to GMRES, i.e. 6?
            CALL gmpdef(2,3,'Number of MINRES steps vs iteration nr')
        END IF
        CALL hmpdef( 5,0.0,0.0,'Number of degrees of freedom')
        CALL hmpdef(11,0.0,0.0,'Number of local parameters')
        CALL hmpdef(16,0.0,24.0,'LOG10(cond(band part decomp.)) local fit ')
        CALL hmpdef(23,0.0,0.0, 'SQRT of diagonal elements without presigma')
        CALL hmpdef(24,0.0,0.0, 'Log10 of off-diagonal elements')
        CALL hmpdef(25,0.0,0.0, 'Relative individual pre-sigma')
        CALL hmpdef(26,0.0,0.0, 'Relative global pre-sigma')
    END IF
 
 
    CALL hmpdef(3,-prange,prange, &   ! book
        'Normalized residuals of single (global) measurement')
    CALL hmpdef(12,-prange,prange, &   ! book
        'Normalized residuals of single (local) measurement')
    CALL hmpdef(13,-prange,prange, &   ! book
        'Pulls of single (global) measurement')
    CALL hmpdef(14,-prange,prange, &   ! book
        'Pulls of single (local) measurement')
    CALL hmpdef(4,0.0,0.0,'Chi^2/Ndf after local fit')
    CALL gmpdef(4,5,'location, dispersion (res.) vs record nr')
    CALL gmpdef(5,5,'location, dispersion (pull) vs record nr')
 
    !      WRITE(*,*) 'LOOPN ', NLOOPN, ' executing ICALCM=', ICALCM
 
    !     reset
 
    globalvector=0.0_mpd ! reset rhs vector              IGVEC
    globalcounter=0
    IF(icalcm == 1) THEN
        globalmatd=0.0_mpd
        globalmatf=0.
        IF (metsol >= 4.AND.metsol < 7.AND.mbandw >= 0) matprecond=0.0_mpd
    END IF
 
    IF(nloopn == 2) CALL hmpdef(6,0.0,0.0,'Down-weight fraction')
 
    newite=.false.
    IF(iterat /= lastit) THEN ! new iteration
        newite=.true.
        funref=fvalue
        IF(nloopn > 1) THEN
            nrej=sum(nrejec)
            !            CALL MEND
            IF(iterat == 1) THEN
                chicut=chirem
            ELSE IF(iterat >= 1) THEN
                chicut=sqrt(chicut)
                IF(chicut /= 0.0.AND.chicut < 1.5) chicut=1.0
                IF(chicut /= 0.0.AND.nrej == 0)    chicut=1.0
            END IF
        END IF
    !         WRITE(*,111) ! header line
    END IF
 
    nrejec=0   ! reset reject counter
    DO k=3,6
        writebufferheader(k)=0  ! cache usage
        writebufferheader(-k)=0
    END DO
    !     statistics per binary file
    DO i=1,nfilb
        jfd(i)=0
        cfd(i)=0.0
        dfd(i)=0
    END DO
    
    IF (imonit /= 0) meashists=0 ! reset monitoring histograms
    
    !     ----- read next data ----------------------------------------------
    DO
        CALL peread(nr)  ! read records
        CALL peprep(1)   ! prepare records
        CALL loopbf(nrejec,nfiles,jfd,cfd,dfd)
        IF (nr <= 0) EXIT ! next block of events ?
    END DO
    ! sum up RHS (over threads) once (reduction in LOOPBF: summation for each block)
    ioffb=0
    DO ipr=2,mthrd
        ioffb=ioffb+lenglobalvec
        DO k=1,lenglobalvec
            globalvector(k)=globalvector(k)+globalvector(ioffb+k)
            globalcounter(k)=globalcounter(k)+globalcounter(ioffb+k)
        END DO
    END DO
 
    IF (icalcm == 1) THEN
        ! PRINT *, ' cache/w ',(writeBufferHeader(-K),K=3,6),(writeBufferHeader(K),K=3,6)
        nparl=writebufferheader(3)
        ncrit=writebufferheader(4)
        used=real(writebufferheader(-5),mps)/real(writebufferheader(-3),mps)*0.1
        usei=real(writebufferheader(5),mps)/real(writebufferheader(3),mps)*0.1
        peakd=real(writebufferheader(-6),mps)*0.1
        peaki=real(writebufferheader(6),mps)*0.1
        WRITE(*,111) nparl,ncrit,usei,used,peaki,peakd
111     FORMAT(' Write cache usage (#flush,#overrun,<levels>,',  &
            'peak(levels))'/2i7,',',4(f6.1,'%'))
        ! fill part of MINRES preconditioner matrix from binary files (formerly in mgupdt)
        IF (metsol >= 4.AND.metsol < 7) THEN
            IF (mbandw == 0) THEN
                ! default preconditioner (diagonal)
                DO i=1, nvgb
                    matprecond(i)=matij(i,i)
                END DO   
            ELSE IF (mbandw > 0) THEN
                ! band matrix
                DO i=1, nvgb
                    ia=indprecond(i) ! index of diagonal element
                    DO j=max(1,i-mbandw+1),i
                        matprecond(ia-i+j)=matij(i,j)
                    END DO
                END DO
            END IF
        END IF
        IF (ichkpg > 0) THEN
            ! check parameter groups
            CALL ckpgrp
        END IF
    END IF
 
    ! check entries/counters
    nlow=0
    ilow=1
    nzero=0
    DO i=1,nvgb
        IF(globalcounter(i) == 0) nzero=nzero+1
        IF(globalcounter(i) < mreqena) THEN
            nlow=nlow+1
            IF(globalcounter(i) < globalcounter(ilow)) ilow=i
        END IF
    END DO
    IF(nlow > 0) THEN
        nalow=nalow+nlow
        IF(icalcm == 1) nxlow=max(nxlow,nlow) ! for matrix construction ?
        itgbi=globalparvartototal(ilow)
        print *
        print *, " ... warning ..." 
        print *, " global parameters with too few (< MREQENA) accepted entries: ", nlow
        print *, " minimum entries: ", globalcounter(ilow), " for label ", globalparlabelindex(1,itgbi)
        print *
    END IF   
    IF(icalcm == 1 .AND. nzero > 0) THEN
        ndefec = nzero ! rank defect
        WRITE(*,*)   'Warning: the rank defect of the symmetric',nfgb,  &
            '-by-',nfgb,' matrix is ',ndefec,' (should be zero).'
        WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfgb,  &
            '-by-',nfgb,' matrix is ',ndefec,' (should be zero).'
        IF (iforce == 0) THEN
            isubit=1
            WRITE(*,*)   '         --> enforcing SUBITO mode'
            WRITE(lun,*) '         --> enforcing SUBITO mode'
        END IF
    END IF
 
    !     ----- after end-of-data add contributions from pre-sigma ---------
 
    IF(nloopn == 1) THEN
        !        plot diagonal elements
        elmt=0.0
        DO i=1,nvgb        ! diagonal elements
            elmt=real(matij(i,i),mps)
            IF(elmt > 0.0) CALL hmpent(23,1.0/sqrt(elmt))
        END DO
    END IF
 
 
 
    !     add pre-sigma contributions to matrix diagonal
 
    !      WRITE(*,*) 'Adding to diagonal ICALCM IND6',ICALCM,IND6
 
    IF(icalcm == 1) THEN
        DO ivgb=1,nvgb                        ! add evtl. pre-sigma
            !          WRITE(*,*) 'Index ',IVGB,IVGB,QM(IND6+IVGB)
            IF(globalparpreweight(ivgb) /= 0.0) THEN
                IF(ivgb > 0) CALL mupdat(ivgb,ivgb,globalparpreweight(ivgb))
            END IF
        END DO
    END IF
 
    CALL hmpwrt(23)
    CALL hmpwrt(24)
    CALL hmpwrt(25)
    CALL hmpwrt(26)
 
 
    !     add regularization term to F and to rhs --------------------------
 
    !      WRITE(*,*) 'NREGUL ',NREGUL,NLOOPN
 
    IF(nregul /= 0) THEN ! add regularization term to F and to rhs
        DO ivgb=1,nvgb
            itgbi=globalparvartototal(ivgb) ! global parameter index
            globalvector(ivgb)=globalvector(ivgb) -globalparameter(itgbi)*globalparpreweight(ivgb)
            adder=globalparpreweight(ivgb)*globalparameter(itgbi)**2
            CALL addsums(1, adder, 0, 1.0_mpl)
        END DO
    END IF
 
 
    !     ----- add contributions from "measurement" -----------------------
 
 
    i=1
    DO WHILE (i <= lenmeasurements)
        rhs=listmeasurements(i  )%value ! right hand side
        sgm=listmeasurements(i+1)%value ! sigma parameter
        i=i+2
        weight=0.0
        IF(sgm > 0.0) weight=1.0/sgm**2
 
        dsum=-rhs
 
        !     loop over label/factor pairs
        ia=i
        DO
            i=i+1
            IF(i > lenmeasurements) EXIT
            IF(listmeasurements(i)%label < 0) EXIT
        END DO
        ib=i-1
 
        DO j=ia,ib
            factrj=listmeasurements(j)%value
            itgbij=inone(listmeasurements(j)%label) ! total parameter index
            IF(itgbij /= 0) THEN
                dsum=dsum+factrj*globalparameter(itgbij)     ! update residuum
            END IF
        END DO
        DO j=ia,ib
            factrj=listmeasurements(j)%value
            IF (factrj == 0.0_mpd) cycle ! skip zero factors
            itgbij=inone(listmeasurements(j)%label) ! total parameter index
            !      add to vector
            ivgbij=0
            IF(itgbij /= 0) ivgbij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
            IF(ivgbij > 0) THEN
                globalvector(ivgbij)=globalvector(ivgbij) -weight*dsum*factrj ! vector
                globalcounter(ivgbij)=globalcounter(ivgbij)+1
            END IF
  
            IF(icalcm == 1.AND.ivgbij > 0) THEN
                DO k=ia,j
                    factrk=listmeasurements(k)%value
                    itgbik=inone(listmeasurements(k)%label) ! total parameter index
                    !          add to matrix
                    ivgbik=0
                    IF(itgbik /= 0) ivgbik=globalparlabelindex(2,itgbik) ! -> index of variable global parameter
                    IF(ivgbij > 0.AND.ivgbik > 0) THEN    !
                        CALL mupdat(ivgbij,ivgbik,weight*factrj*factrk)
                    END IF
                END DO
            END IF
        END DO
 
        adder=weight*dsum**2
        CALL addsums(1, adder, 1, 1.0_mpl)
 
    END DO
 
    !     ----- printout ---------------------------------------------------
 
 
    ! get accurate sum (Chi^2, (w)NDF)
    CALL getsums(fvalue,ndfsum,sumndf)
 
    flines=0.5_mpd*fvalue   ! Likelihood function value
    rloop=iterat+0.01*nloopn
    actfun=real(funref-fvalue,mps)
    IF(nloopn == 1) actfun=0.0
    ngras=nint(angras,mpi)
    ratae=0.0                              !!!
    IF(delfun /= 0.0) THEN
        ratae=min(99.9,actfun/delfun)  !!!
        ratae=max(-99.9,ratae)
    END IF
 
    !     rejects ...
 
    nrej  =sum(nrejec)
    IF(nloopn == 1) THEN
        IF(nrej /= 0) THEN
            WRITE(*,*) ' '
            WRITE(*,*) 'Data records rejected in initial loop:'
            CALL prtrej(6)
        END IF
    END IF
 
    IF(newite.AND.iterat == 2) THEN
        IF(nrecpr /= 0.OR.nrecp2 /= 0) nrecer=nrec3
        IF(nrecpr < 0) THEN
            nrecpr=nrec1
        END IF
        IF(nrecp2 < 0) THEN
            nrecp2=nrec2
        END IF
    END IF
 
    IF(nloopn <= 2) THEN
        IF(nhistp /= 0) THEN
        !            CALL HMPRNT(3)  ! scaled residual of single measurement
        !            CALL HMPRNT(12) ! scaled residual of single measurement
        !            CALL HMPRNT(4)  ! chi^2/Ndf
        END IF
        CALL hmpwrt(3)
        CALL hmpwrt(12)
        CALL hmpwrt(4)
        CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr
        IF (nloopn <= lfitnp) THEN
            CALL hmpwrt(13)
            CALL hmpwrt(14)
            CALL gmpwrt(5) ! location, dispersion (pull) as a function of record nr
        END IF
    END IF
    !      IF(NLOOPN.EQ.2.AND.NHISTP.NE.0) CALL HMPRNT(6)
    IF(nloopn == 2) CALL hmpwrt(6)
    IF(nloopn <= 1) THEN
        !         IF(NHISTP.NE.0) CALL HMPRNT(5)  ! number of degrees of freedom
        !         IF(NHISTP.NE.0) CALL HMPRNT(11) ! Nlocal
        CALL hmpwrt(5)
        CALL hmpwrt(11)
        CALL hmpwrt(16)
    END IF
 
    !     local fit: band matrix structure !?
    IF (nloopn == 1.AND.nbndr(1)+nbndr(2) > 0) THEN
        DO lun=6,8,2
            WRITE(lun,*) ' '
            WRITE(lun,*) ' === local fits have bordered band matrix structure ==='
            IF (nbndr(1) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(1),'number of records (upper/left border)'
            IF (nbndr(2) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(2),'number of records (lower/right border)'
            WRITE(lun,101) ' NBDRX',nbdrx,'max border size'
            WRITE(lun,101) ' NBNDX',nbndx,'max band width'
        END DO
    END IF
 
    lastit=iterat
    
    ! monitoring of residuals
    IF (imonit < 0 .OR. (nloopn == 1 .AND. btest(imonit,0))) CALL monres
 
101 FORMAT(1x,a8,' =',i14,' = ',a)
! 101  FORMAT(' LOOPN',I6,' Function value',F22.8,10X,I6,' records')
! 102  FORMAT('   incl. constraint penalty',F22.8)
! 103  FORMAT(I13,3X,A,G12.4)
END SUBROUTINE loopn                 ! loop with fits
 
 
SUBROUTINE ploopa(lunp)
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi), INTENT(IN)                  :: lunp
    !     ..
    WRITE(lunp,*)   ' '
    WRITE(lunp,101) ! header line
    WRITE(lunp,102) ! header line
101 FORMAT(' it fc','   fcn_value dfcn_exp  slpr costh  iit st',  &
        ' ls  step cutf',1x,'rejects hhmmss FMS')
102 FORMAT(' -- --',' ----------- --------  ---- -----  --- --',  &
        ' -- ----- ----',1x,'------- ------ ---')
    RETURN
END SUBROUTINE ploopa   ! title for iteration
 
 
SUBROUTINE ploopb(lunp)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: ma
    INTEGER :: minut
    INTEGER(mpi) :: nfa
    INTEGER :: nhour
    INTEGER(mpl) :: nrej
    INTEGER(mpi) :: nsecnd
    REAL(mps) :: ratae
    REAL :: rstb
    REAL(mps) :: secnd
    REAL(mps) :: slopes(3)
    REAL(mps) :: steps(3)
    REAL, DIMENSION(2) :: ta
    REAl etime
 
    INTEGER(mpi), INTENT(IN)                  :: lunp
 
    CHARACTER (LEN=4):: ccalcm(4)
    DATA ccalcm / ' end','   S', ' F  ',' FMS' /
    SAVE
 
    nrej=sum(nrejec)    ! rejects
    IF(nrej > 9999999) nrej=9999999
    rstb=etime(ta)
    deltim=rstb-rstart
    CALL sechms(deltim,nhour,minut,secnd) ! time
    nsecnd=nint(secnd,mpi)
    IF(iterat == 0) THEN
        WRITE(lunp,103) iterat,nloopn,fvalue,  &
            chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
    ELSE
        IF (lsinfo == 10) THEN ! line search skipped
            WRITE(lunp,105) iterat,nloopn,fvalue,delfun,  &
                iitera,istopa,chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
        ELSE
            CALL ptlopt(nfa,ma,slopes,steps)  ! slopes steps
            ratae=max(-99.9,min(99.9,slopes(2)/slopes(1)))
            stepl=steps(2)
            WRITE(lunp,104) iterat,nloopn,fvalue,delfun,ratae,angras,  &
                iitera,istopa,lsinfo,stepl, chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
        ENDIF
    END IF
103 FORMAT(i3,i3,e12.5,38x,f5.1, 1x,i7,  i3,i2.2,i2.2,a4)
104 FORMAT(i3,i3,e12.5,1x,e8.2,f6.3,f6.3,i5,2i3,f6.3,f5.1,  &
        1x,i7,  i3,i2.2,i2.2,a4)
105 FORMAT(i3,i3,e12.5,1x,e8.2,12x,i5,i3,9x,f5.1,  &
        1x,i7,  i3,i2.2,i2.2,a4)
    RETURN
END SUBROUTINE ploopb ! iteration line
 
 
SUBROUTINE ploopc(lunp)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: ma
    INTEGER(mpi) :: minut
    INTEGER(mpi) :: nfa
    INTEGER(mpi) :: nhour
    INTEGER(mpl) :: nrej
    INTEGER(mpi) :: nsecnd
    REAL(mps) :: ratae
    REAL :: rstb
    REAL(mps) :: secnd
    REAL(mps) :: slopes(3)
    REAL(mps) :: steps(3)
    REAL, DIMENSION(2) :: ta
    REAL etime
 
    INTEGER(mpi), INTENT(IN)                  :: lunp
    CHARACTER (LEN=4):: ccalcm(4)
    DATA ccalcm / ' end','   S', ' F  ',' FMS' /
    SAVE
 
    nrej=sum(nrejec)    ! rejects
    IF(nrej > 9999999) nrej=9999999
    rstb=etime(ta)
    deltim=rstb-rstart
    CALL sechms(deltim,nhour,minut,secnd) ! time
    nsecnd=nint(secnd,mpi)
    IF (lsinfo == 10) THEN ! line search skipped
        WRITE(lunp,104) nloopn,fvalue,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
    ELSE
        CALL ptlopt(nfa,ma,slopes,steps)  ! slopes steps
        ratae=abs(slopes(2)/slopes(1))
        stepl=steps(2)
        WRITE(lunp,105) nloopn,fvalue, ratae,lsinfo,  &
            stepl,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
    END IF
104 FORMAT(3x,i3,e12.5,9x, 35x, i7,  i3,i2.2,i2.2,a4)
105 FORMAT(3x,i3,e12.5,9x,     f6.3,14x,i3,f6.3,6x, i7,  i3,i2.2,i2.2,a4)
    RETURN
 
END SUBROUTINE ploopc                   ! sub-iteration line
 
 
SUBROUTINE ploopd(lunp)
    USE mpmod
    IMPLICIT NONE
    INTEGER :: minut
    INTEGER :: nhour
    INTEGER(mpi) :: nsecnd
    REAL :: rstb
    REAL(mps) :: secnd
    REAL, DIMENSION(2) :: ta
    REAL etime
 
    INTEGER(mpi), INTENT(IN)                  :: lunp
    CHARACTER (LEN=4):: ccalcm(4)
    DATA ccalcm / ' end','   S', ' F  ',' FMS' /
    SAVE
    rstb=etime(ta)
    deltim=rstb-rstart
    CALL sechms(deltim,nhour,minut,secnd) ! time
    nsecnd=nint(secnd,mpi)
 
    WRITE(lunp,106) nhour,minut,nsecnd,ccalcm(lcalcm)
106 FORMAT(69x,i3,i2.2,i2.2,a4)
    RETURN
END SUBROUTINE ploopd
 
SUBROUTINE explfc(lunit)
    USE mpdef
    USE mpmod, ONLY: metsol
 
    IMPLICIT NONE
    INTEGER(mpi) :: lunit
    WRITE(lunit,*) ' '
    WRITE(lunit,102) 'Explanation of iteration table'
    WRITE(lunit,102) '=============================='
    WRITE(lunit,101) 'it',  &
        'iteration number. Global parameters are improved for it > 0.'
    WRITE(lunit,102) 'First function evaluation is called iteraton 0.'
    WRITE(lunit,101) 'fc', 'number of function evaluations.'
    WRITE(lunit,101) 'fcn_value', 'value of 2 x Likelihood function (LF).'
    WRITE(lunit,102) 'The final value is the chi^2 value of the fit and should'
    WRITE(lunit,102) 'be about equal to the NDF (see below).'
    WRITE(lunit,101) 'dfcn_exp',  &
        'expected reduction of the value of the Likelihood function (LF)'
    WRITE(lunit,101) 'slpr', 'ratio of the actual slope to inital slope.'
    WRITE(lunit,101) 'costh',  &
        'cosine of angle between search direction and -gradient'
    IF (metsol == 4) THEN
        WRITE(lunit,101) 'iit',  &
            'number of internal iterations in MINRES algorithm'
        WRITE(lunit,101) 'st', 'stop code of MINRES algorithm'
        WRITE(lunit,102) '< 0:   rhs is very special, with beta2 = 0'
        WRITE(lunit,102) '= 0:   rhs b = 0, i.e. the exact solution is  x = 0'
        WRITE(lunit,102) '= 1    requested accuracy achieved, as determined by rtol'
        WRITE(lunit,102) '= 2    reasonable accuracy achieved, given eps'
        WRITE(lunit,102) '= 3    x has converged to an eigenvector'
        WRITE(lunit,102) '= 4    matrix ill-conditioned (Acond has exceeded 0.1/eps)'
        WRITE(lunit,102) '= 5    the iteration limit was reached'
        WRITE(lunit,102) '= 6    Matrix x vector does not define a symmetric matrix'
        WRITE(lunit,102) '= 7    Preconditioner does not define a symmetric matrix'
    ELSEIF (metsol == 5) THEN
        WRITE(lunit,101) 'iit',  &
            'number of internal iterations in MINRES-QLP algorithm'
        WRITE(lunit,101) 'st', 'stop code of MINRES-QLP algorithm'
        WRITE(lunit,102) '= 1: beta_{k+1} < eps, iteration k is the final Lanczos step.'
        WRITE(lunit,102) '= 2: beta2 = 0.  If M = I, b and x are eigenvectors of A.'
        WRITE(lunit,102) '= 3: beta1 = 0.  The exact solution is  x = 0.'
        WRITE(lunit,102) '= 4: A solution to (poss. singular) Ax = b found, given rtol.'
        WRITE(lunit,102) '= 5: A solution to (poss. singular) Ax = b found, given eps.'
        WRITE(lunit,102) '= 6: Pseudoinverse solution for singular LS problem, given rtol.'
        WRITE(lunit,102) '= 7: Pseudoinverse solution for singular LS problem, given eps.'
        WRITE(lunit,102) '= 8: The iteration limit was reached.'
        WRITE(lunit,102) '= 9: The operator defined by Aprod appears to be unsymmetric.'
        WRITE(lunit,102) '=10: The operator defined by Msolve appears to be unsymmetric.'
        WRITE(lunit,102) '=11: The operator defined by Msolve appears to be indefinite.'
        WRITE(lunit,102) '=12: xnorm has exceeded maxxnorm or will exceed it next iteration.'
        WRITE(lunit,102) '=13: Acond has exceeded Acondlim or 0.1/eps.'
        WRITE(lunit,102) '=14: Least-squares problem but no converged solution yet.'
        WRITE(lunit,102) '=15: A null vector obtained, given rtol.'
    ENDIF
    WRITE(lunit,101) 'ls', 'line search info'
    WRITE(lunit,102) '< 0    recalculate function'
    WRITE(lunit,102) '= 0:   N or STP lt 0 or step not descending'
    WRITE(lunit,102) '= 1:   Linesearch convergence conditions reached'
    WRITE(lunit,102) '= 2:   interval of uncertainty at lower limit'
    WRITE(lunit,102) '= 3:   max nr of line search calls reached'
    WRITE(lunit,102) '= 4:   step at the lower bound'
    WRITE(lunit,102) '= 5:   step at the upper bound'
    WRITE(lunit,102) '= 6:   rounding error limitation'
    WRITE(lunit,101) 'step',  &
        'the factor for the Newton step during the line search. Usually'
    WRITE(lunit,102)  &
        'a value of 1 gives a sufficient reduction of the LF. Oherwise'
    WRITE(lunit,102) 'other step values are tried.'
    WRITE(lunit,101) 'cutf',  &
        'cut factor. Local fits are rejected, if their chi^2 value'
    WRITE(lunit,102)  &
        'is larger than the 3-sigma chi^2 value times the cut factor.'
    WRITE(lunit,102) 'A cut factor of 1 is used finally, but initially a larger'
    WRITE(lunit,102) 'factor may be used. A value of 0.0 means no cut.'
    WRITE(lunit,101) 'rejects', 'total number of rejected local fits.'
    WRITE(lunit,101) 'hmmsec', 'the time in hours (h), minutes (mm) and seconds.'
    WRITE(lunit,101) 'FMS', 'calculation of Function value, Matrix, Solution.'
    WRITE(lunit,*) ' '
 
101 FORMAT(a9,' =  ',a)
102 FORMAT(13x,a)
END SUBROUTINE explfc
 
 
SUBROUTINE mupdat(i,j,add)       !
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi), INTENT(IN)                      :: i
    INTEGER(mpi), INTENT(IN)                      :: j
    REAL(mpd), INTENT(IN)             :: add
 
    INTEGER(mpl):: ijadd
    INTEGER(mpl):: ijcsr3
    INTEGER(mpl):: ia
    INTEGER(mpl):: ja
    INTEGER(mpl):: ij
    !     ...
    IF(i <= 0.OR.j <= 0.OR. add == 0.0_mpd) RETURN
    ia=max(i,j)          ! larger
    ja=min(i,j)          ! smaller
    ij=0
    IF(matsto == 3) THEN
        IF(matbsz < 2) THEN               ! sparse symmetric matrix (CSR3)
            ij=ijcsr3(i,j)                ! inline code requires same time
            IF (ij > 0) globalmatd(ij)=globalmatd(ij)+add
            RETURN
        ELSE                              ! sparse symmetric matrix (BSR3)
            ! block index
            ij=ijcsr3((i-1)/matbsz+1,(j-1)/matbsz+1)
            IF (ij > 0) THEN
                ! index of first element in block
                ij=(ij-1)*matbsz*matbsz+1
                ! adjust index for position in block
                ij=ij+mod(int(ia-1,mpi),matbsz)*matbsz+mod(int(ja-1,mpi),matbsz)
                globalmatd(ij)=globalmatd(ij)+add
            ENDIF
            RETURN
        END IF
    ELSE IF(matsto == 2) THEN             ! sparse symmetric matrix (custom)
        ij=ijadd(i,j)                     ! inline code requires same time
        IF (ij == 0) RETURN               ! pair is suppressed
        IF (ij > 0) THEN
            globalmatd(ij)=globalmatd(ij)+add
        ELSE
            globalmatf(-ij)=globalmatf(-ij)+real(add,mps)
        END IF
    ELSE                             ! full or unpacked (block diagonal) symmetric matrix
        ! global (ia,ib) to local (row,col) in block
        ij=globalrowoffsets(ia)+ja
        globalmatd(ij)=globalmatd(ij)+add
    END IF
    ! MINRES preconditioner
    IF(metsol >= 4.AND.metsol < 7.AND.mbandw >= 0) THEN
        ij=0 ! no update
        IF(ia <= nvgb) THEN     ! variable global parameter
            IF(mbandw > 0) THEN ! band matrix for Cholesky decomposition
                ij=indprecond(ia)-ia+ja
                IF(ia > 1.AND.ij <= indprecond(ia-1)) ij=0
            ELSE                ! default preconditioner (diagonal)
                IF(ja == ia) ij=ia
            END IF    
        ELSE                    ! Lagrange multiplier
            ij=offprecond(ia-nvgb)+ja
        END IF
        ! bad index?
        IF(ij < 0.OR.ij > size(matprecond)) THEN
            CALL peend(23,'Aborted, bad matrix index')
            stop 'mupdat: bad index'
        END IF
        ! update?
        IF(ij /= 0) matprecond(ij)=matprecond(ij)+add
    END IF
END SUBROUTINE mupdat
 
 
 
SUBROUTINE mgupdt(i,j1,j2,il,jl,n,sub) 
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi), INTENT(IN)                      :: i
    INTEGER(mpi), INTENT(IN)                      :: j1
    INTEGER(mpi), INTENT(IN)                      :: j2
    INTEGER(mpi), INTENT(IN)                      :: il
    INTEGER(mpi), INTENT(IN)                      :: jl
    INTEGER(mpi), INTENT(IN)                      :: n
    REAL(mpd), INTENT(IN)             :: sub((n*n+n)/2)
 
    INTEGER(mpl):: ij
    INTEGER(mpl):: ioff
    INTEGER(mpi):: ia
    INTEGER(mpi):: ia1
    INTEGER(mpi):: ib
    INTEGER(mpi):: iblast
    INTEGER(mpi):: iblock
    INTEGER(mpi):: ijl
    INTEGER(mpi):: iprc
    INTEGER(mpi):: ir
    INTEGER(mpi):: ja
    INTEGER(mpi):: jb
    INTEGER(mpi):: jblast
    INTEGER(mpi):: jblock
    INTEGER(mpi):: jc
    INTEGER(mpi):: jc1
    INTEGER(mpi):: jpg
    INTEGER(mpi):: k
    INTEGER(mpi):: lr
    INTEGER(mpi):: nc
 
    INTEGER(mpl) ijcsr3
    !     ...
    IF(i <= 0.OR.j1 <= 0.OR.j2 > i) RETURN
 
    IF(matsto == 3) THEN            ! sparse symmetric matrix (CSR3, upper triangle)
        ja=globalallindexgroups(i)     ! first (global) column
        jb=globalallindexgroups(i+1)-1 ! last (global) column
        ia1=globalallindexgroups(j1)   ! first (global) row
        ! loop over groups (now in same column)
        DO jpg=j1,j2
            ia=globalallindexgroups(jpg)      ! first (global) row in group
            ib=globalallindexgroups(jpg+1)-1  ! last (global) row in group
            IF (matbsz < 2) THEN
                ! CSR3
                ij=ijcsr3(ia,ja)
                IF (ij == 0) THEN
                    print *, ' MGUPDT: ij=0', i,j1,j2,il,jl,ij,lr,iprc, matsto
                    stop
                END IF
                ioff=ij-ja                        ! offset
                DO ir=ia,ib
                    jc1=max(ir,ja)
                    k=il+jc1-ja
                    ijl=(k*k-k)/2+jl+ir-ia1       ! ISYM index offset (subtrahends matrix)
                    DO jc=jc1,jb
                        globalmatd(ioff+jc)=globalmatd(ioff+jc)-sub(ijl)
                        ijl=ijl+k
                        k=k+1
                    END DO
                    ioff=ioff+csr3rowoffsets(ir+1)-csr3rowoffsets(ir)-1
                END DO
            ELSE
                ! BSR3
                iblast=-1
                jblast=-1
                ioff=0
                DO ir=ia,ib
                    iblock=(ir-1)/matbsz+1
                    jc1=max(ir,ja)
                    k=il+jc1-ja
                    ijl=(k*k-k)/2+jl+ir-ia1       ! ISYM index offset (subtrahends matrix)
                    DO jc=jc1,jb
                        jblock=(jc-1)/matbsz+1
                        ! index of first element in (new) block
                        IF (jblock /= jblast.OR.iblock /= iblast) THEN
                            ioff=(ijcsr3(iblock,jblock)-1)*matbsz*matbsz+1
                            iblast=iblock
                            jblast=jblock
                        END IF
                        ! adjust index for position in block
                        ij=ioff+mod(int(ir-1,mpi),matbsz)+mod(int(jc-1,mpi),matbsz)*matbsz
                        globalmatd(ij)=globalmatd(ij)-sub(ijl)
                        ijl=ijl+k
                        k=k+1
                    END DO
                END DO
            END IF
        END DO
        RETURN
    END IF
 
    ! lower triangle
    ia=globalallindexgroups(i)      ! first (global) row
    ib=globalallindexgroups(i+1)-1  ! last (global) row
    ja=globalallindexgroups(j1)     ! first (global) column
    jb=globalallindexgroups(j2+1)-1 ! last (global) column
 
    IF(matsto == 2) THEN       ! sparse symmetric matrix (custom)
        CALL ijpgrp(i,j1,ij,lr,iprc)         ! index of first element of group 'j1' 
        IF (ij == 0) THEN
            print *, ' MGUPDT: ij=0', i,j1,j2,il,jl,ij,lr,iprc,matsto
            stop 
        END IF
        k=il
        ijl=(k*k-k)/2                   ! ISYM index offset (subtrahends matrix)
        DO ir=ia,ib
            nc=min(ir,jb)-ja            ! number of columns -1 
            IF (jb >= ir) THEN           ! diagonal element
                globalmatd(ir)=globalmatd(ir)-sub(ijl+jl+nc)
                nc=nc-1
            END IF 
            ! off-diagonal elements
            IF (iprc == 1) THEN
                globalmatd(ij:ij+nc)=globalmatd(ij:ij+nc)-sub(ijl+jl:ijl+jl+nc)
            ELSE
                globalmatf(ij:ij+nc)=globalmatf(ij:ij+nc)-real(sub(ijl+jl:ijl+jl+nc),mps)
            END IF 
            ij=ij+lr
            ijl=ijl+k
            k=k+1
        END DO    
    ELSE                           ! full or unpacked (block diagonal) symmetric matrix
        k=il
        ijl=(k*k-k)/2                   ! ISYM index offset (subtrahends matrix)
        DO ir=ia,ib
            ! global (ir,0) to local (row,col) in block
            ij=globalrowoffsets(ir)
            nc=min(ir,jb)-ja            ! number of columns -1 
            globalmatd(ij+ja:ij+ja+nc)=globalmatd(ij+ja:ij+ja+nc)-sub(ijl+jl:ijl+jl+nc)
            ijl=ijl+k
            k=k+1
        END DO           
    END IF
 
END SUBROUTINE mgupdt
 
 
 
SUBROUTINE loopbf(nrej,numfil,naccf,chi2f,ndff)
    USE mpmod
 
    IMPLICIT NONE
    REAL(mpd) :: cauchy
    REAL(mps) :: chichi
    REAL(mps) :: chlimt
    REAL(mps) :: chndf
    REAL(mpd) :: chuber
    REAL(mpd) :: down
    REAL(mpd) :: pull
    REAL(mpd) :: r1
    REAL(mpd) :: r2
    REAL(mps) :: rec
    REAL(mpd) :: rerr
    REAL(mpd) :: resid
    REAL(mps) :: resing
    REAL(mpd) :: resmax
    REAL(mpd) :: rmeas
    REAL(mpd) :: rmloc
    REAL(mpd) :: suwt
    REAL(mps) :: used
    REAL(mpd) :: wght
    REAL(mps) :: chindl
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ibuf
    INTEGER(mpi) :: ichunk
    INTEGER(mpl) :: icmn
    INTEGER(mpl) :: icost
    INTEGER(mpi) :: id
    INTEGER(mpi) :: idiag
    INTEGER(mpi) :: ieq
    INTEGER(mpi) :: iext
    INTEGER(mpi) :: ij
    INTEGER(mpi) :: ije
    INTEGER(mpi) :: ijn
    INTEGER(mpi) :: ik
    INTEGER(mpi) :: ike
    INTEGER(mpi) :: il
    INTEGER(mpi) :: im
    INTEGER(mpi) :: imeas
    INTEGER(mpi) :: in
    INTEGER(mpi) :: inv
    INTEGER(mpi) :: ioffb
    INTEGER(mpi) :: ioffc
    INTEGER(mpi) :: ioffd
    INTEGER(mpi) :: ioffe
    INTEGER(mpi) :: ioffi
    INTEGER(mpi) :: ioffq
    INTEGER(mpi) :: iprc
    INTEGER(mpi) :: iprcnx
    INTEGER(mpi) :: iprdbg
    INTEGER(mpi) :: iproc
    INTEGER(mpi) :: irbin
    INTEGER(mpi) :: isize
    INTEGER(mpi) :: ist
    INTEGER(mpi) :: iter
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: ivgbj
    INTEGER(mpi) :: ivgbk
    INTEGER(mpi) :: ivpgrp
    INTEGER(mpi) :: j
    INTEGER(mpi) :: j1
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jk
    INTEGER(mpi) :: jl
    INTEGER(mpi) :: jl1
    INTEGER(mpi) :: jn
    INTEGER(mpi) :: jnx
    INTEGER(mpi) :: joffd
    INTEGER(mpi) :: joffi
    INTEGER(mpi) :: jproc
    INTEGER(mpi) :: jrc
    INTEGER(mpi) :: jsp
    INTEGER(mpi) :: k
    INTEGER(mpi) :: kbdr
    INTEGER(mpi) :: kbdrx
    INTEGER(mpi) :: kbnd
    INTEGER(mpi) :: kfl
    INTEGER(mpi) :: kx
    INTEGER(mpi) :: lvpgrp
    INTEGER(mpi) :: mbdr
    INTEGER(mpi) :: mbnd
    INTEGER(mpi) :: mside
    INTEGER(mpi) :: nalc
    INTEGER(mpi) :: nalg
    INTEGER(mpi) :: nan
    INTEGER(mpi) :: nb
    INTEGER(mpi) :: ndf
    INTEGER(mpi) :: ndown
    INTEGER(mpi) :: neq
    INTEGER(mpi) :: nfred
    INTEGER(mpi) :: nfrei
    INTEGER(mpi) :: ngg
    INTEGER(mpi) :: nprdbg
    INTEGER(mpi) :: nrank
    INTEGER(mpl) :: nrc
    INTEGER(mpi) :: nst
    INTEGER(mpi) :: nter
    INTEGER(mpi) :: nweig
    INTEGER(mpi) :: ngrp
    INTEGER(mpi) :: npar
 
    INTEGER(mpl), INTENT(IN OUT)                     :: nrej(6)
    INTEGER(mpi), INTENT(IN)                         :: numfil
    INTEGER(mpi), INTENT(IN OUT)                     :: naccf(numfil)
    REAL(mps), INTENT(IN OUT)                        :: chi2f(numfil)
    INTEGER(mpi), INTENT(IN OUT)                     :: ndff(numfil)
 
    REAL(mps) :: cndl10
    REAL(mpd) :: dchi2
    REAL(mpd) :: dvar
    REAL(mpd) :: dw1
    REAL(mpd) :: dw2
    REAL(mpd) :: evdmin
    REAL(mpd) :: evdmax
    REAL(mpd) :: summ
    INTEGER(mpi) :: ijprec
 
    !$    INTEGER(mpi) OMP_GET_THREAD_NUM
 
    LOGICAL:: lprnt
    LOGICAL::lhist
 
    CHARACTER (LEN=3):: chast
    DATA chuber/1.345_mpd/  ! constant for Huber down-weighting
    DATA cauchy/2.3849_mpd/ ! constant for Cauchy down-weighting
    SAVE chuber,cauchy
    !     ...
 
    ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
    ! reset header, 3 words per thread:
    !    number of entries, offset to data, indices
    writebufferinfo=0
    writebufferdata=0.
    nprdbg=0
    iprdbg=-1
 
    ! parallelize record loop
    ! private copy of NREJ,.. for each thread, combined at end, init with 0.
    !$OMP  PARALLEL DO &
    !$OMP   DEFAULT(PRIVATE) &
    !$OMP   SHARED(numReadBuffer,readBufferPointer,readBufferDataI, &
    !$OMP      readBufferDataD,writeBufferHeader,writeBufferInfo, &
    !$OMP      writeBufferData,writeBufferIndices,writeBufferUpdates,globalVector,globalCounter, &
    !$OMP      globalParameter,globalParLabelIndex,globalIndexUsage,backIndexUsage, &
    !$OMP      measBins,numMeas,measIndex,measRes,measHists,globalAllParToGroup,globalAllIndexGroups, &
    !$OMP      localCorrections,localEquations,ifd, &
    !$OMP      NAGB,NVGB,NAGBN,ICALCM,ICHUNK,NLOOPN,NRECER,NPRDBG,IPRDBG, &
    !$OMP      NEWITE,CHICUT,LHUBER,CHUBER,ITERAT,NRECPR,MTHRD,NSPC,NAEQN, &
    !$OMP      DWCUT,CHHUGE,NRECP2,CAUCHY,LFITNP,LFITBB,IMONIT,IMONMD,MONPG1,LUNLOG,MDEBUG,CNDLMX) &
    !$OMP   REDUCTION(+:NREJ,NBNDR,NACCF,CHI2F,NDFF) &
    !$OMP   REDUCTION(MAX:NBNDX,NBDRX) &
    !$OMP   REDUCTION(MIN:NREC3) &
    !$OMP   SCHEDULE(DYNAMIC,ICHUNK)
    DO ibuf=1,numreadbuffer                       ! buffer for current record
        jrc=readbufferdatai(readbufferpointer(ibuf)-1)           ! record number in file
        kfl=nint(readbufferdatad(readbufferpointer(ibuf)),mpi)   ! file
        nrc=ifd(kfl)+jrc                                         ! global record number
        dw1=real(readbufferdatad(readbufferpointer(ibuf)-1),mpd) ! weight
        dw2=sqrt(dw1)
  
        iproc=0
        !$       IPROC=OMP_GET_THREAD_NUM()         ! thread number
        ioffb=nagb*iproc                                  ! offset 'f'.
        ioffc=nagbn*iproc                                 ! offset 'c'.
        ioffe=nvgb*iproc                                  ! offset 'e'
        ioffd=writebufferheader(-1)*iproc+writebufferinfo(2,iproc+1)  ! offset data
        ioffi=writebufferheader(1)*iproc+writebufferinfo(3,iproc+1)+3 ! offset indices
        ioffq=naeqn*iproc                                 ! offset equations (measurements)
        !     ----- reset ------------------------------------------------------
        lprnt=.false.
        lhist=(iproc == 0)
        rec=real(nrc,mps)    ! floating point value
        IF(nloopn == 1.AND.mod(nrc,100000_mpl) == 0) THEN
            WRITE(*,*) 'Record',nrc,' ... still reading'
            IF(monpg1>0) WRITE(lunlog,*) 'Record',nrc,' ... still reading'
        END IF
  
        !      printout/debug only for one thread at a time
  
  
        !      flag for record printout -----------------------------------------
  
        lprnt=.false.
        IF(newite.AND.(iterat == 1.OR.iterat == 3)) THEN
            IF(nrc == nrecpr) lprnt=.true.
            IF(nrc == nrecp2) lprnt=.true.
            IF(nrc == nrecer) lprnt=.true.
        END IF
        IF (lprnt)THEN
            !$OMP ATOMIC
            nprdbg=nprdbg+1               ! number of threads with debug
            IF (nprdbg == 1) iprdbg=iproc ! first thread with debug
            IF (iproc /= iprdbg) lprnt=.false.
        !         print *, ' LPRNT ', NRC, NPRDBG, IPRDBG, IPROC, LPRNT
        END IF
        IF(lprnt) THEN
            WRITE(1,*) ' '
            WRITE(1,*) '------------------ Loop',nloopn,  &
                ': Printout for record',nrc,iproc
            WRITE(1,*) ' '
        END IF
  
        !     ----- print data -------------------------------------------------
  
        IF(lprnt) THEN
            imeas=0              ! local derivatives
            ist=readbufferpointer(ibuf)+1
            nst=readbufferdatai(readbufferpointer(ibuf))
            DO ! loop over measurements
                CALL isjajb(nst,ist,ja,jb,jsp)
                IF(ja == 0) EXIT
                IF(imeas == 0) WRITE(1,1121)
                imeas=imeas+1
                WRITE(1,1122) imeas,readbufferdatad(ja),readbufferdatad(jb),  &
                    (readbufferdatai(ja+j),readbufferdatad(ja+j),j=1,jb-ja-1)
            END DO
1121        FORMAT(/'Measured value and local derivatives'/  &
                '  i measured std_dev  index...derivative ...')
1122        FORMAT(i3,2g12.4,3(i3,g12.4)/(27x,3(i3,g12.4)))
    
            imeas=0              ! global derivatives
            ist=readbufferpointer(ibuf)+1
            nst=readbufferdatai(readbufferpointer(ibuf))
            DO ! loop over measurements
                CALL isjajb(nst,ist,ja,jb,jsp)
                IF(ja == 0) EXIT
                IF(imeas == 0) WRITE(1,1123)
                imeas=imeas+1
                IF (jb < ist) THEN
                    IF(ist-jb > 2) THEN
                        WRITE(1,1124) imeas,(globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j),  &
                            globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
                    ELSE
                        WRITE(1,1125) imeas,(globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j),  &
                            globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
                    END IF
                END IF
            END DO
1123        FORMAT(/'Global derivatives'/  &
                '  i  label gindex vindex derivative ...')
1124        FORMAT(i3,2(i9,i7,i7,g12.4)/(3x,2(i9,i7,i7,g12.4)))
1125        FORMAT(i3,2(i9,i7,i7,g12.4))
        END IF
  
        !      ----- first loop -------------------------------------------------
        !       ------ prepare local fit ------
        !      count local and global derivates
        !      subtract actual alignment parameters from the measured data
  
        IF(lprnt) THEN
            WRITE(1,*) ' '
            WRITE(1,*) 'Data corrections using values of global parameters'
            WRITE(1,*) '=================================================='
            WRITE(1,101)
        END IF
        nalg=0                         ! count number of global derivatives
        nalc=0                         ! count number of local derivatives
        neq=0                          ! count number of equations
                    
        ist=readbufferpointer(ibuf)+1
        nst=readbufferdatai(readbufferpointer(ibuf))
        DO ! loop over measurements
            CALL isjajb(nst,ist,ja,jb,jsp)
            IF(ja == 0) EXIT
            rmeas=real(readbufferdatad(ja),mpd)     ! data
            neq=neq+1                     ! count equation
            localequations(1,ioffq+neq)=ja
            localequations(2,ioffq+neq)=jb
            localequations(3,ioffq+neq)=ist
            !         subtract global ... from measured value
            DO j=1,ist-jb                 ! global parameter loop
                itgbi=readbufferdatai(jb+j)            ! global parameter label
                rmeas=rmeas-real(readbufferdatad(jb+j),mpd)*globalparameter(itgbi) ! subtract   !!! reversed
                IF (icalcm == 1) THEN
                    ij=globalparlabelindex(2,itgbi)         ! -> index of variable global parameter
                    IF(ij > 0) THEN
                        ijn=backindexusage(ioffe+ij)        ! get index of index
                        IF(ijn == 0) THEN                   ! not yet included
                            nalg=nalg+1                     ! count
                            globalindexusage(ioffc+nalg)=ij ! store global index
                            backindexusage(ioffe+ij)=nalg   ! store back index
                        END IF
                    END IF
                END IF
            END DO
            IF(lprnt) THEN
                IF (jb < ist) WRITE(1,102) neq,readbufferdatad(ja),rmeas,readbufferdatad(jb)
            END IF
            readbufferdatad(ja)=real(rmeas,mpr8)   ! global contribution subtracted
            DO j=1,jb-ja-1              ! local parameter loop
                ij=readbufferdatai(ja+j)
                nalc=max(nalc,ij)       ! number of local parameters
            END DO
        END DO
101     FORMAT(' index measvalue   corrvalue          sigma')
102     FORMAT(i6,2x,2g12.4,' +-',g12.4)
  
        IF(nalc <= 0) GO TO 90
  
        ngg=(nalg*nalg+nalg)/2
        ngrp=0
        IF (icalcm == 1) THEN
            localglobalmatrix(:nalg*nalc)=0.0_mpd ! reset global-local matrix
            localglobalmap(:nalg*nalc)=0          ! reset global-local map
            ! store parameter group indices  
            CALL sort1k(globalindexusage(ioffc+1),nalg) ! sort global par.
            lvpgrp=-1
            npar=0
            DO k=1,nalg
                iext=globalindexusage(ioffc+k)
                backindexusage(ioffe+iext)=k      ! update back index
                ivpgrp=globalallpartogroup(iext)  ! group
                IF (ivpgrp /= lvpgrp) THEN
                    ngrp=ngrp+1
                    writebufferindices(ioffi+ngrp)=ivpgrp    ! global par group indices
                    lvpgrp=ivpgrp
                    npar=npar+globalallindexgroups(ivpgrp+1)-globalallindexgroups(ivpgrp)
                END IF    
            END DO
            ! check NPAR==NALG
            IF (npar /= nalg) THEN
                print *, '  mismatch of number of global parameters ', nrc, nalg, npar, ngrp
                print *, globalindexusage(ioffc+1:ioffc+nalg)
                print *, writebufferindices(ioffi+1:ioffi+ngrp)
                j=0
                DO k=1,ngrp
                    ivpgrp=writebufferindices(ioffi+k)
                    j=j+globalallindexgroups(ivpgrp+1)-globalallindexgroups(ivpgrp)
                    IF (globalallpartogroup(globalindexusage(ioffc+j)) /= ivpgrp) &
                        print *, ' bad group ', k, j, ivpgrp, globalindexusage(ioffc+j)
                END DO
                CALL peend(35,'Aborted, mismatch of number of global parameters')
                stop ' mismatch of number of global parameters '
            ENDIF
            ! index header
            writebufferindices(ioffi-2)=jrc       ! record number in file
            writebufferindices(ioffi-1)=nalg      ! number of global parameters
            writebufferindices(ioffi  )=ngrp      ! number of global par groups
            DO k=1,ngg
                writebufferupdates(ioffd+k)=0.0_mpd ! reset global-global matrix
            END DO
        END IF
        !      ----- iteration start and check ---------------------------------
  
        nter=1                         ! first loop without down-weighting
        IF(nloopn /= 1.AND.lhuber /= 0) nter=lhuber
        localcorrections(ioffq+1:ioffq+neq) = 0._mpd
  
        !      check matrix for bordered band structure (MBDR+MBND+1 <= NALC)
        mbnd=-1
        mbdr=nalc
        mside=-1 ! side (1: upper/left border, 2: lower/right border)
        DO i=1, 2*nalc
            ibandh(i)=0
        END DO
        idiag=1
  
        iter=0
        resmax=0.0
        DO WHILE(iter < nter)  ! outlier suppresssion iteration loop
            iter=iter+1
            resmax=0.0
            IF(lprnt) THEN
                WRITE(1,*) ' '
                WRITE(1,*) 'Outlier-suppression iteration',iter,' of',nter
                WRITE(1,*) '=========================================='
                WRITE(1,*) ' '
                imeas=0
            END IF
  
            !      ----- second loop ------------------------------------------------
            !      accumulate normal equations for local fit and determine solution
            DO i=1,nalc
                blvec(i)=0.0_mpd                  ! reset vector
            END DO
            DO i=1,(nalc*nalc+nalc)/2 ! GF: FIXME - not really, local parameter number...
                clmat(i)=0.0_mpd               ! (p)reset matrix
            END DO
            ndown=0
            nweig=0
            cndl10=0.
            DO ieq=1,neq! loop over measurements
                ja=localequations(1,ioffq+ieq)
                jb=localequations(2,ioffq+ieq)
                rmeas=real(readbufferdatad(ja),mpd)     ! data
                rerr =real(readbufferdatad(jb),mpd)     ! ... and the error
                wght =1.0_mpd/rerr**2         ! weight from error
                nweig=nweig+1
                resid=rmeas-localcorrections(ioffq+ieq)           ! subtract previous fit
                IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN
                    IF(iter <= 3) THEN
                        IF(abs(resid) > chuber*rerr) THEN     ! down-weighting
                            wght=wght*chuber*rerr/abs(resid)
                            ndown=ndown+1
                        END IF
                    ELSE       ! Cauchy
                        wght=wght/(1.0+(resid/rerr/cauchy)**2)
                    END IF
                END IF
 
                IF(lprnt.AND.iter /= 1.AND.nter /= 1) THEN
                    chast='   '
                    IF(abs(resid) > chuber*rerr) chast='*  '
                    IF(abs(resid) > 3.0*rerr) chast='** '
                    IF(abs(resid) > 6.0*rerr) chast='***'
                    IF(imeas == 0) WRITE(1,*) 'Second loop: accumulate'
                    IF(imeas == 0) WRITE(1,103)
                    imeas=imeas+1
                    down=1.0/sqrt(wght)
                    r1=resid/rerr
                    r2=resid/down
                    WRITE(1,104) imeas,rmeas,resid,rerr,r1,chast,r2
                END IF
103             FORMAT(' index corrvalue    residuum          sigma',  &
                    '     nresid     cnresid')
104             FORMAT(i6,2x,2g12.4,' +-',g12.4,f7.2,1x,a3,f8.2)
    
                DO j=1,jb-ja-1 ! normal equations, local parameter loop
                    ij=readbufferdatai(ja+j)          ! local parameter index J
                    blvec(ij)=blvec(ij)+wght*rmeas*real(readbufferdatad(ja+j),mpd)
                    DO k=1,j
                        ik=readbufferdatai(ja+k)         ! local parameter index K
                        jk=(ij*ij-ij)/2+ik        ! index in symmetric matrix
                        clmat(jk)=clmat(jk) &  ! force double precision
                            +wght*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+k),mpd)
                        !           check for band matrix substructure
                        IF (iter == 1) THEN
                            id=iabs(ij-ik)+1
                            im=min(ij,ik) ! upper/left border
                            ibandh(id)=max(ibandh(id),im)
                            im=min(nalc+1-ij,nalc+1-ik) ! lower/rght border (mirrored)
                            ibandh(nalc+id)=max(ibandh(nalc+id),im)
                        END IF
                    END DO
                END DO
            END DO
            !      for non trivial fits check for bordered band matrix structure
            IF (iter == 1.AND.nalc > 5.AND.lfitbb > 0) THEN
                kx=-1
                kbdrx=0
                icmn=int(nalc,mpl)**3 ! cost (*6) should improve by at least factor 2
                ! upper/left border ?
                kbdr=0  
                DO k=nalc,2,-1
                    kbnd=k-2
                    kbdr=max(kbdr,ibandh(k))
                    icost=6*int(nalc-kbdr,mpl)*int(kbnd+kbdr+1,mpl)**2+2*int(kbdr,mpl)**3
                    IF (icost < icmn) THEN
                        icmn=icost
                        kx=k
                        kbdrx=kbdr
                        mside=1
                    END IF
                END DO    
                IF (kx < 0) THEN
                    ! lower/right border instead?
                    kbdr=0  
                    DO k=nalc,2,-1
                        kbnd=k-2
                        kbdr=max(kbdr,ibandh(k+nalc))
                        icost=6*int(nalc-kbdr,mpl)*int(kbnd+kbdr+1,mpl)**2+2*int(kbdr,mpl)**3
                        IF (icost < icmn) THEN
                            icmn=icost
                            kx=k
                            kbdrx=kbdr
                            mside=2
                        END IF
                    END DO
                END IF
                IF (kx > 0) THEN
                    mbnd=kx-2
                    mbdr=kbdrx
                END IF
            END IF
            
            IF (mbnd >= 0) THEN
                !      fast solution for border banded matrix (inverse for ICALCM>0)
                IF (nloopn == 1) THEN
                    nbndr(mside)=nbndr(mside)+1
                    nbdrx=max(nbdrx,mbdr)
                    nbndx=max(nbndx,mbnd)
                END IF
 
                inv=0
                IF (nloopn <= lfitnp.AND.iter == 1) inv=1 ! band part of inverse (for pulls)
                IF (icalcm == 1.OR.lprnt) inv=2     ! complete inverse
                IF (mside == 1) THEN
                    CALL sqmibb(clmat,blvec,nalc,mbdr,mbnd,inv,nrank,  &
                        vbnd,vbdr,aux,vbk,vzru,scdiag,scflag,evdmin,evdmax)
                ELSE
                    CALL sqmibb2(clmat,blvec,nalc,mbdr,mbnd,inv,nrank,  &
                        vbnd,vbdr,aux,vbk,vzru,scdiag,scflag,evdmin,evdmax)
                ENDIF
                ! log10(condition of band part)
                IF (evdmin > 0.0_mpl) cndl10=log10(real(evdmax/evdmin,mps))
                IF (lhist.AND.nloopn == 1) CALL hmpent(16,cndl10)
            ELSE
                !      full inversion and solution
                inv=2
                CALL sqminv(clmat,blvec,nalc,nrank,scdiag,scflag)
            END IF
            !      check for NaNs
            nan=0
            DO k=1, nalc
                IF ((.NOT.(blvec(k) <= 0.0_mpd)).AND. (.NOT.(blvec(k) > 0.0_mpd))) nan=nan+1
            END DO
 
            IF(lprnt) THEN
                WRITE(1,*) ' '
                WRITE(1,*) 'Parameter determination:',nalc,' parameters,', ' rank=',nrank
                WRITE(1,*) '-----------------------'
                IF(ndown /= 0) WRITE(1,*) '   ',ndown,' data down-weighted'
                WRITE(1,*) ' '
            END IF
  
            !      ----- third loop -------------------------------------------------
            !      calculate single residuals remaining after local fit and chi^2
  
            summ=0.0_mpd
            suwt=0.0
            imeas=0
            DO ieq=1,neq! loop over measurements
                ja=localequations(1,ioffq+ieq)
                jb=localequations(2,ioffq+ieq)
                ist=localequations(3,ioffq+ieq)
                rmeas=real(readbufferdatad(ja),mpd)     ! data (global contrib. subtracted)
                rerr =real(readbufferdatad(jb),mpd)     ! ... and the error
                wght =1.0_mpd/rerr**2         ! weight from error
                rmloc=0.0                     ! local fit result reset
                DO j=1,jb-ja-1                ! local parameter loop
                    ij=readbufferdatai(ja+j)
                    rmloc=rmloc+real(readbufferdatad(ja+j),mpd)*blvec(ij) ! local fit result
                END DO
                localcorrections(ioffq+ieq)=rmloc   ! save local fit result
                rmeas=rmeas-rmloc             ! reduced to residual
    
                !         calculate pulls? (needs covariance matrix)
                IF(iter == 1.AND.inv > 0.AND.nloopn <= lfitnp) THEN
                    dvar=0.0_mpd
                    DO j=1,jb-ja-1
                        ij=readbufferdatai(ja+j)
                        jk=(ij*ij-ij)/2        ! index in symmetric matrix, row offset
                        ! off diagonal (symmetric)
                        DO k=1,j-1
                            ik=readbufferdatai(ja+k)
                            dvar=dvar+clmat(jk+ik)*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+k),mpd)*2.0_mpd
                        END DO
                        ! diagonal
                        dvar=dvar+clmat(jk+ij)*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+j),mpd)
                    END DO
                    !          some variance left to define a pull?
                    IF (0.999999_mpd/wght > dvar) THEN
                        pull=rmeas/sqrt(1.0_mpd/wght-dvar)
                        IF (lhist) THEN
                            IF (jb < ist) THEN
                                CALL hmpent(13,real(pull,mps)) ! histogram pull
                                CALL gmpms(5,rec,real(pull,mps))
                            ELSE
                                CALL hmpent(14,real(pull,mps)) ! histogram pull
                            END IF
                        END IF
                        !  monitoring
                        IF (imonit /= 0) THEN
                            IF (jb < ist) THEN
                                ij=readbufferdatai(jb+1) ! group by first global label
                                if (imonmd == 0) THEN
                                    irbin=min(measbins,max(1,int(pull*rerr/measres(ij)/measbinsize+0.5*real(measbins,mpd))))
                                ELSE    
                                    irbin=min(measbins,max(1,int(pull/measbinsize+0.5*real(measbins,mpd))))
                                ENDIF
                                irbin=irbin+measbins*(measindex(ij)-1+nummeas*iproc)
                                meashists(irbin)=meashists(irbin)+1
                            ENDIF
                        ENDIF
                    END IF
                END IF
    
                IF(iter == 1.AND.jb < ist.AND.lhist)  &
                    CALL gmpms(4,rec,real(rmeas/rerr,mps)) ! residual (with global deriv.)
    
                dchi2=wght*rmeas*rmeas
                !          DCHIT=DCHI2
                resid=rmeas
                IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN
                    IF(iter <= 3) THEN
                        IF(abs(resid) > chuber*rerr) THEN     ! down-weighting
                            wght=wght*chuber*rerr/abs(resid)
                            dchi2=2.0*chuber*(abs(resid)/rerr-0.5*chuber)
                        END IF
                    ELSE
                        wght=wght/(1.0_mpd+(resid/rerr/cauchy)**2)
                        dchi2=log(1.0_mpd+(resid/rerr/cauchy)**2)*cauchy**2
                    END IF
                END IF
    
                down=1.0/sqrt(wght)
 
                !          SUWT=SUWT+DCHI2/DCHIT
                suwt=suwt+rerr/down
                IF(lprnt) THEN
                    chast='   '
                    IF(abs(resid) > chuber*rerr) chast='*  '
                    IF(abs(resid) > 3.0*rerr) chast='** '
                    IF(abs(resid) > 6.0*rerr) chast='***'
                    IF(imeas == 0) WRITE(1,*) 'Third loop: single residuals'
                    IF(imeas == 0) WRITE(1,105)
                    imeas=imeas+1
                    r1=resid/rerr
                    r2=resid/down
                    IF(resid < 0.0) r1=-r1
                    IF(resid < 0.0) r2=-r2
                    WRITE(1,106) imeas,readbufferdatad(ja),rmeas,rerr,r1,chast,r2
                END IF
105             FORMAT(' index corrvalue    residuum          sigma',  &
                    '     nresid     cnresid')
106             FORMAT(i6,2x,2g12.4,' +-',g12.4,f7.2,1x,a3,f8.2)
 
                IF(iter == nter) THEN
                    readbufferdatad(ja)=real(rmeas,mpr8) ! store remaining residual
                    resmax=max(resmax,abs(rmeas)/rerr)
                END IF
 
                IF(iter == 1.AND.lhist) THEN
                    IF (jb < ist) THEN
                        CALL hmpent( 3,real(rmeas/rerr,mps)) ! histogram norm residual
                    ELSE
                        CALL hmpent(12,real(rmeas/rerr,mps)) ! histogram norm residual
                    END IF
                END IF
                summ=summ+dchi2        ! accumulate chi-square sum
            END DO
 
            ndf=neq-nrank
            resing=(real(nweig,mps)-real(suwt,mps))/real(nweig,mps)
            IF (lhist) THEN
                IF(iter == 1) CALL hmpent( 5,real(ndf,mps))  ! histogram Ndf
                IF(iter == 1) CALL hmpent(11,real(nalc,mps)) ! histogram Nlocal
                IF(nloopn == 2.AND.iter == nter) CALL hmpent(6,resing)
            END IF
            IF(lprnt) THEN
                WRITE(1,*) ' '
                WRITE(1,*) 'Chi^2=',summ,' at',ndf,' degrees of freedom: ',  &
                    '3-sigma limit is',chindl(3,ndf)*real(ndf,mps)
                WRITE(1,*) suwt,' is sum of factors, compared to',nweig,  &
                    ' Downweight fraction:',resing
            END IF
            IF(nan > 0) THEN
                nrej(1)=nrej(1)+1         ! count cases
                IF (nrec3 == huge(nrec3)) nrec3=nrc
                IF(lprnt) THEN
                    WRITE(1,*) ' NaNs ', nalc, nrank, nan
                    WRITE(1,*) '   ---> rejected!'
                END IF
                IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-1 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
                GO TO 90
            END IF
            IF(nrank /= nalc) THEN
                nrej(2)=nrej(2)+1         ! count cases
                IF (nrec3 == huge(nrec3)) nrec3=nrc
                IF(lprnt) THEN
                    WRITE(1,*) ' rank deficit', nalc, nrank
                    WRITE(1,*) '   ---> rejected!'
                END IF
                IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-2 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
                GO TO 90
            END IF
            IF(cndl10 > cndlmx) THEN
                nrej(3)=nrej(3)+1         ! count cases
                IF (nrec3 == huge(nrec3)) nrec3=nrc
                IF(lprnt) THEN
                    WRITE(1,*) ' too large condition(band part) ', nalc, nrank, cndl10
                    WRITE(1,*) '   ---> rejected!'
                END IF
                IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-3 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
                GO TO 90
            END IF
            IF(ndf <= 0) THEN
                nrej(4)=nrej(4)+1         ! count cases
                IF(lprnt) THEN
                    WRITE(1,*) ' Ndf<=0', nalc, nrank, ndf
                    WRITE(1,*) '   ---> rejected!'
                END IF
                IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-4 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
                GO TO 90
            END IF
  
            chndf=real(summ/real(ndf,mpd),mps)
  
            IF(iter == 1.AND.lhist) CALL hmpent(4,chndf) ! histogram chi^2/Ndf
        END DO  ! outlier iteration loop
  
        !      ----- reject eventually ------------------------------------------
  
        IF(newite.AND.iterat == 2) THEN ! find record with largest Chi^2/Ndf
            IF(nrecp2 < 0.AND.chndf > writebufferdata(2,iproc+1)) THEN
                writebufferdata(2,iproc+1)=chndf
                writebufferinfo(8,iproc+1)=jrc
                writebufferinfo(9,iproc+1)=kfl
            END IF
        END IF
  
        chichi=chindl(3,ndf)*real(ndf,mps)
        ! GF       IF(SUMM.GT.50.0*CHICHI) THEN ! huge
        ! CHK CHICUT<0: NO cut (1st iteration)
        IF(chicut >= 0.0) THEN
            IF(summ > chhuge*chichi) THEN ! huge
                nrej(5)=nrej(5)+1    ! count cases with huge chi^2
                IF(lprnt) THEN
                    WRITE(1,*) '   ---> rejected!'
                END IF
                GO TO 90
            END IF
 
            IF(chicut > 0.0) THEN
                chlimt=chicut*chichi
                !          WRITE(*,*) 'chi^2 ',SUMM,CHLIMT,CHICUT,CHINDL(3,NDF),NDF
                IF(summ > chlimt) THEN
                    IF(lprnt) THEN
                        WRITE(1,*) '   ---> rejected!'
                    END IF
                    !              add to FVALUE
                    dchi2=chlimt                           ! total contribution limit
                    CALL addsums(iproc+1, dchi2, ndf, dw1) ! add total contribution
                    nrej(6)=nrej(6)+1      ! count cases with large chi^2
                    GO TO 90
                END IF
            END IF
        END IF 
  
        IF(lhuber > 1.AND.dwcut /= 0.0.AND.resing > dwcut) THEN
            !         add to FVALUE
            dchi2=summ                             ! total contribution
            CALL addsums(iproc+1, dchi2, ndf, dw1) ! add total contribution
            nrej(6)=nrej(6)+1      ! count cases with large chi^2
            !          WRITE(*,*) 'Downweight fraction cut ',RESING,DWCUT,SUMM
            IF(lprnt) THEN
                WRITE(1,*) '   ---> rejected!'
            END IF
            GO TO 90
        END IF
  
        IF(newite.AND.iterat == 2) THEN ! find record with largest residual
            IF(nrecpr < 0.AND.resmax > writebufferdata(1,iproc+1)) THEN
                writebufferdata(1,iproc+1)=real(resmax,mps)
                writebufferinfo(6,iproc+1)=jrc
                writebufferinfo(7,iproc+1)=kfl
            END IF
        END IF
        !      'track quality' per binary file: accepted records
        naccf(kfl)=naccf(kfl)+1
        ndff(kfl) =ndff(kfl) +ndf
        chi2f(kfl)=chi2f(kfl)+chndf
  
        !      ----- fourth loop ------------------------------------------------
        !      update of global matrix and vector according to the "Millepede"
        !      principle, from the global/local information
    
        summ=0.0_mpd
        DO ieq=1,neq! loop over measurements
            ja=localequations(1,ioffq+ieq)
            jb=localequations(2,ioffq+ieq)
            ist=localequations(3,ioffq+ieq)    
            rmeas=real(readbufferdatad(ja),mpd)     ! data residual
            rerr =real(readbufferdatad(jb),mpd)     ! ... and the error
            wght =1.0_mpd/rerr**2         ! weight from measurement error
            dchi2=wght*rmeas*rmeas        ! least-square contribution
    
            IF(nloopn /= 1.AND.lhuber /= 0) THEN       ! check residual
                resid=abs(rmeas)
                IF(resid > chuber*rerr) THEN
                    wght=wght*chuber*rerr/resid          ! down-weighting
                    dchi2=2.0*chuber*(resid/rerr-0.5*chuber) ! modified contribution
                END IF
            END IF
            ! sum up
            summ=summ+dchi2
    
            !         global-global matrix contribution: add directly to gg-matrix
    
            DO j=1,ist-jb
                ivgbj=globalparlabelindex(2,readbufferdatai(jb+j))     ! -> index of variable global parameter
                IF (readbufferdatad(jb+j) == 0.0_mpd) cycle ! skip zero global derivatives
                IF(ivgbj > 0) THEN
                    globalvector(ioffb+ivgbj)=globalvector(ioffb+ivgbj)  &
                        +dw1*wght*rmeas*real(readbufferdatad(jb+j),mpd) ! vector  !!! reverse
                    globalcounter(ioffb+ivgbj)=globalcounter(ioffb+ivgbj)+1    
                    IF(icalcm == 1) THEN
                        ije=backindexusage(ioffe+ivgbj)        ! get index of index, non-zero
                        DO k=1,j
                            ivgbk=globalparlabelindex(2,readbufferdatai(jb+k))
                            IF(ivgbk > 0) THEN
                                ike=backindexusage(ioffe+ivgbk)        ! get index of index, non-zero
                                ia=max(ije,ike)          ! larger
                                ib=min(ije,ike)          ! smaller
                                ij=ib+(ia*ia-ia)/2
                                writebufferupdates(ioffd+ij)=writebufferupdates(ioffd+ij)  &
                                    -dw1*wght*real(readbufferdatad(jb+j),mpd)*real(readbufferdatad(jb+k),mpd)
                            END IF
                        END DO
                    END IF
                END IF
            END DO
 
            !         normal equations - rectangular matrix for global/local pars
            !         global-local matrix contribution: accumulate rectangular matrix
            IF (icalcm /= 1) cycle
            DO j=1,ist-jb
                ivgbj=globalparlabelindex(2,readbufferdatai(jb+j))           ! -> index of variable global parameter
                IF(ivgbj > 0) THEN
                    ije=backindexusage(ioffe+ivgbj)        ! get index of index, non-zero
                    DO k=1,jb-ja-1
                        ik=readbufferdatai(ja+k)           ! local index
                        jk=ik+(ije-1)*nalc       ! matrix index
                        localglobalmatrix(jk)=localglobalmatrix(jk)+ &
                            dw2*wght*real(readbufferdatad(jb+j),mpd)*real(readbufferdatad(ja+k),mpd)
                        localglobalmap(jk)=localglobalmap(jk)+1
                    END DO
                END IF
            END DO
        END DO
        ! add to total objective function
        CALL addsums(iproc+1, summ, ndf, dw1)
  
        !      ----- final matrix update ----------------------------------------
        !      update global matrices and vectors
        IF(icalcm /= 1) GO TO 90 ! matrix update
        !      (inverse local matrix) * (rectang. matrix) -> CORM
        !                                        T
        !      resulting symmetrix matrix  =   G   *   Gamma^{-1}   *   G
        
        ! check sparsity of localGlobalMatrix (with par. groups)
        isize=nalc+nalg+1 ! row/clolumn offsets
        ! check rows
        k=0 ! offset
        DO i=1, nalg
            localglobalstructure(i)=isize
            DO j=1, nalc 
                IF (localglobalmap(k+j) > 0) THEN
                    localglobalstructure(isize+1)=j    ! column
                    localglobalstructure(isize+2)=k+j  ! index
                    isize=isize+2
                ENDIF
            END DO
            k=k+nalc
        END DO
        ! <50% non-zero elements?
        IF (isize-localglobalstructure(1) < nalc*nalg) THEN
            ! check columns (too)
            DO j=1, nalc
                localglobalstructure(nalg+j)=isize
                k=0 ! offset
                DO i=1, nalg 
                    IF (localglobalmap(k+j) > 0) THEN
                        localglobalstructure(isize+1)=i    ! row
                        localglobalstructure(isize+2)=k+j  ! index
                        isize=isize+2
                    ENDIF
                    k=k+nalc
                END DO
            END DO
            localglobalstructure(nalg+nalc+1)=isize
            CALL dbavats(clmat,localglobalmatrix,localglobalstructure,writebufferupdates(ioffd+1),nalc,nalg,1,scflag)
        ELSE
            CALL dbavat(clmat,localglobalmatrix,writebufferupdates(ioffd+1),nalc,nalg,1)
        END IF
        !      (rectang. matrix) * (local param vector)   -> CORV
        !      resulting vector = G * q (q = local parameter)
        !      CALL DBGAX(DQ(IGLMA/2+1),BLVEC,DQ(ICORV/2+1),NALG,NALC)  ! not done
        !      the vector update is not done, because after local fit it is zero!
 
        !      update cache status
        writebufferinfo(1,iproc+1)=writebufferinfo(1,iproc+1)+1
        writebufferinfo(2,iproc+1)=writebufferinfo(2,iproc+1)+ngg
        writebufferinfo(3,iproc+1)=writebufferinfo(3,iproc+1)+ngrp+3
        !      check free space
        nfred=writebufferheader(-1)-writebufferinfo(2,iproc+1)-writebufferheader(-2)
        nfrei=writebufferheader(1)-writebufferinfo(3,iproc+1)-writebufferheader(2)
        IF (nfred < 0.OR.nfrei < 0) THEN ! need to flush
            nb=writebufferinfo(1,iproc+1)
            joffd=writebufferheader(-1)*iproc  ! offset data
            joffi=writebufferheader(1)*iproc+3 ! offset indices
            used=real(writebufferinfo(2,iproc+1),mps)/real(writebufferheader(-1),mps)
            writebufferinfo(4,iproc+1)=writebufferinfo(4,iproc+1) +nint(1000.0*used,mpi)
            used=real(writebufferinfo(3,iproc+1),mps)/real(writebufferheader(1),mps)
            writebufferinfo(5,iproc+1)=writebufferinfo(5,iproc+1) +nint(1000.0*used,mpi)
            !$OMP CRITICAL
            writebufferheader(-4)=writebufferheader(-4)+1
            writebufferheader(4)=writebufferheader(4)+1
 
            DO ib=1,nb
                nalg=writebufferindices(joffi-1)
                il=1 ! row in update matrix
                DO in=1,writebufferindices(joffi)
                    i=writebufferindices(joffi+in)
                    j=writebufferindices(joffi+1)                     ! 1. group
                    iprc=ijprec(i,j)                                  ! group pair precision
                    jl=1                                              ! col in update matrix
                    ! start (rows) for continous groups
                    j1=j
                    jl1=jl
                    ! other groups for row
                    DO jn=2,in
                        jl=jl+globalallindexgroups(j+1)-globalallindexgroups(j)
                        jnx=writebufferindices(joffi+jn)              ! next group
                        iprcnx=ijprec(i,jnx)                          ! group pair precision
                        ! end of continous groups?
                        IF (.NOT.((jnx == j+1).AND.(iprc == iprcnx))) THEN                            
                            CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1))  ! matrix update
                            !print *, ' update ', ib,i,j1,j,il,jl1,0,iprc,jnx,iprcnx
                            ! restart continous groups
                            j1=jnx                                    ! new 1. column
                            jl1=jl
                            iprc=iprcnx
                        END IF
                        j=jnx                                         ! last group 
                    END DO
                    CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1))          ! final matrix update
                    !print *, '.update ', ib, i,j1,j,il,jl1,1,iprc
                    il=il+globalallindexgroups(i+1)-globalallindexgroups(i)
                END DO
                joffd=joffd+(il*il-il)/2
                joffi=joffi+writebufferindices(joffi)+3
            END DO    
            !$OMP END CRITICAL
            !       reset counter, pointers
            DO k=1,3
                writebufferinfo(k,iproc+1)=0
            END DO
        END IF
 
90      IF(lprnt) THEN
            WRITE(1,*) ' '
            WRITE(1,*) '------------------ End of printout for record',nrc
            WRITE(1,*) ' '
        END IF
  
        DO i=1,nalg                 ! reset global index array
            iext=globalindexusage(ioffc+i)
            backindexusage(ioffe+iext)=0
        END DO
  
    END DO
    !$OMP END PARALLEL DO
 
    IF (icalcm == 1) THEN
        !     flush remaining matrices
        DO k=1,mthrd ! update statistics
            writebufferheader(-3)=writebufferheader(-3)+1
            used=real(writebufferinfo(2,k),mps)/real(writebufferheader(-1),mps)
            writebufferinfo(4,k)=writebufferinfo(4,k)+nint(1000.0*used,mpi)
            writebufferheader(-5)=writebufferheader(-5)+writebufferinfo(4,k)
            writebufferheader(-6)=max(writebufferheader(-6),writebufferinfo(4,k))
            writebufferinfo(4,k)=0
            writebufferheader(3)=writebufferheader(3)+1
            used=real(writebufferinfo(3,k),mps)/real(writebufferheader(1),mps)
            writebufferinfo(5,k)=writebufferinfo(5,k)+nint(1000.0*used,mpi)
            writebufferheader(5)=writebufferheader(5)+writebufferinfo(5,k)
            writebufferheader(6)=max(writebufferheader(6),writebufferinfo(5,k))
            writebufferinfo(5,k)=0
        END DO
  
        !$OMP  PARALLEL &
        !$OMP  DEFAULT(PRIVATE) &
        !$OMP  SHARED(writeBufferHeader,writeBufferInfo,writeBufferIndices,writeBufferUpdates,MTHRD) &
        !$OMP  SHARED(globalAllParToGroup,globalAllIndexGroups,nspc)
        iproc=0
        !$ IPROC=OMP_GET_THREAD_NUM()         ! thread number
        DO jproc=0,mthrd-1
            nb=writebufferinfo(1,jproc+1)
            !        print *, ' flush end ', JPROC, NRC, NB
            joffd=writebufferheader(-1)*jproc  ! offset data
            joffi=writebufferheader(1)*jproc+3 ! offset indices
            DO ib=1,nb
                !         print *, '   buf end ', JPROC,IB,writeBufferIndices(JOFFI-2),writeBufferIndices(JOFFI)
                nalg=writebufferindices(joffi-1)
                il=1 ! row in update matrix
                DO in=1,writebufferindices(joffi)
                    i=writebufferindices(joffi+in)
                    !$        IF (MOD(I,MTHRD).EQ.IPROC) THEN
                    j=writebufferindices(joffi+1)                     ! 1. group
                    iprc=ijprec(i,j)                                  ! group pair precision
                    jl=1                                              ! col in update matrix
                    ! start (rows) for continous groups
                    j1=j
                    jl1=jl
                    ! other groups for row
                    DO jn=2,in
                        jl=jl+globalallindexgroups(j+1)-globalallindexgroups(j)
                        jnx=writebufferindices(joffi+jn)              ! next group
                        iprcnx=ijprec(i,jnx)                          ! group pair precision
                        ! end of continous groups?
                        IF (.NOT.((jnx == j+1).AND.(iprc == iprcnx))) THEN                            
                            CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1))  ! matrix update
                            !print *, ' update ', ib,i,j1,j,il,jl1,0,iprc,jnx,iprcnx
                            ! restart continous groups
                            j1=jnx                                    ! new 1. column
                            jl1=jl
                            iprc=iprcnx
                        END IF
                        j=jnx                                         ! last group 
                    END DO
                    CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1))          ! final matrix update
                    !print *, '.update ', ib, i,j1,j,il,jl1,1,iprc
                    !$        END IF
                    il=il+globalallindexgroups(i+1)-globalallindexgroups(i)
                END DO
                joffd=joffd+(il*il-il)/2
                joffi=joffi+writebufferindices(joffi)+3
            END DO
        END DO
        !$OMP END PARALLEL
    END IF
 
    IF(newite.AND.iterat == 2) THEN ! get worst records (for printrecord -1 -1)
        IF (nrecpr < 0) THEN
            DO k=1,mthrd
                IF (writebufferdata(1,k) > value1) THEN
                    value1=writebufferdata(1,k)
                    nrec1 =writebufferinfo(6,k)+ifd(writebufferinfo(7,k))
                END IF
            END DO
        END IF
        IF (nrecp2 < 0) THEN
            DO k=1,mthrd
                IF (writebufferdata(2,k) > value2) THEN
                    value2=writebufferdata(2,k)
                    nrec2 =writebufferinfo(8,k)+ifd(writebufferinfo(9,k))
                END IF
            END DO
        END IF
    END IF
 
END SUBROUTINE loopbf
 
!***********************************************************************
 
SUBROUTINE prtrej(lun)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi), INTENT(IN)                      :: lun
 
    IF (nrejec(1)>0) WRITE(lun,*) nrejec(1), ' (local solution contains NaNs)'
    IF (nrejec(2)>0) WRITE(lun,*) nrejec(2), ' (local matrix with rank deficit)'
    IF (nrejec(3)>0) WRITE(lun,*) nrejec(3), ' (local matrix with ill condition)'
    IF (nrejec(4)>0) WRITE(lun,*) nrejec(4), ' (local fit with Ndf=0)'
    IF (nrejec(5)>0) WRITE(lun,*) nrejec(5), ' (local fit with huge Chi2(Ndf))'
    IF (nrejec(6)>0) WRITE(lun,*) nrejec(6), ' (local fit with large Chi2(Ndf))'
 
END SUBROUTINE prtrej
 
!***********************************************************************
 
SUBROUTINE prtglo
    USE mpmod
 
    IMPLICIT NONE
    REAL(mps):: dpa
    REAL(mps):: err
    REAL(mps):: gcor
    INTEGER(mpi) :: i
    INTEGER(mpi) :: icom
    INTEGER(mpl) :: icount
    INTEGER(mpi) :: ie
    INTEGER(mpi) :: iev
    INTEGER(mpi) :: ij
    INTEGER(mpi) :: imin
    INTEGER(mpi) :: iprlim
    INTEGER(mpi) :: isub
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: itgbl
    INTEGER(mpi) :: ivgbi
    INTEGER(mpi) :: j
    INTEGER(mpi) :: label
    INTEGER(mpi) :: lup
    REAL(mps):: par
    LOGICAL :: lowstat
 
    REAL(mpd):: diag
    REAL(mpd)::gmati
    REAL(mpd)::gcor2
    INTEGER(mpi) :: labele(3)
    REAL(mps):: compnt(3)
    SAVE
    !     ...
 
    lup=09
    CALL mvopen(lup,'millepede.res')
 
    WRITE(*,*) ' '
    WRITE(*,*) '         Result of fit for global parameters'
    WRITE(*,*) '         ==================================='
    WRITE(*,*) ' '
 
    WRITE(*,101)
 
    WRITE(lup,*) 'Parameter   ! first 3 elements per line are',  &
        ' significant (if used as input)'
 
 
    iprlim=10
    DO itgbi=1,ntgb  ! all parameter variables
        itgbl=globalparlabelindex(1,itgbi)
        ivgbi=globalparlabelindex(2,itgbi)
        icom=globalparcomments(itgbi) ! comment
        IF (icom > 0) WRITE(lup,113) listcomments(icom)%text
        par=real(globalparameter(itgbi),mps)      ! initial value
        icount=0 ! counts
        lowstat = .false.
        IF(ivgbi > 0) THEN
            icount=globalcounter(ivgbi) ! used in last iteration
            lowstat = (icount < mreqena) ! too few accepted entries
            dpa=real(globalparameter(itgbi)-globalparstart(itgbi),mps)       ! difference
            IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
                gmati=globalmatd(globalrowoffsets(ivgbi)+ivgbi)
                err=sqrt(abs(real(gmati,mps)))
                IF(gmati < 0.0_mpd) err=-err
                diag=workspacediag(ivgbi)
                gcor=-1.0
                IF(gmati*diag > 0.0_mpd) THEN   ! global correlation
                    gcor2=1.0_mpd-1.0_mpd/(gmati*diag)
                    IF(gcor2 >= 0.0_mpd.AND.gcor2 <= 1.0_mpd) gcor=real(sqrt(gcor2),mps)
                END IF
            END IF
        END IF
        IF(ipcntr > 1) icount=globalparlabelcounter(itgbi) ! from binary files
        IF(lowstat) icount=-(icount+1) ! flag 'lowstat' with icount < 0
        IF(ipcntr < 0) icount=globalparlabelzeros(itgbi) ! 'zero derivatives' from binary files
        IF(itgbi <= iprlim) THEN
            IF(ivgbi <= 0) THEN
                WRITE(*  ,102) itgbl,par,real(globalparpresigma(itgbi),mps)
            ELSE
                IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
                    IF (igcorr == 0) THEN
                        WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err
                    ELSE
                        WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor
                    END IF
                ELSE
                    WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa
                END IF
            END IF
        ELSE IF(itgbi == iprlim+1) THEN
            WRITE(*  ,*) '... (further printout suppressed, but see log file)'
        END IF
 
        !      file output
        IF(ivgbi <= 0) THEN
            IF (ipcntr /= 0) THEN
                WRITE(lup,110) itgbl,par,real(globalparpresigma(itgbi),mps),icount
            ELSE
                WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps)
            END IF               
        ELSE
            IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
                IF (ipcntr /= 0) THEN
                    WRITE(lup,112) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,icount            
                ELSE IF (igcorr /= 0) THEN
                    WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor
                ELSE
                    WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err
                END IF
            ELSE
                IF (ipcntr /= 0) THEN
                    WRITE(lup,111) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,icount
                ELSE
                    WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa
                END IF    
            END IF
        END IF
    END DO
    rewind lup
    CLOSE(unit=lup)
 
    IF(metsol == 2) THEN        ! diagonalisation: write eigenvectors
        CALL mvopen(lup,'millepede.eve')
        imin=1
        DO i=nagb,1,-1
            IF(workspaceeigenvalues(i) > 0.0_mpd) THEN
                imin=i          ! index of smallest pos. eigenvalue
                EXIT
            ENDIF
        END DO
        iev=0
  
        DO isub=0,min(15,imin-1)
            IF(isub < 10) THEN
                i=imin-isub
            ELSE
                i=isub-9
            END IF
    
            !        DO I=IMIN,MAX(1,IMIN-9),-1    ! backward loop, up to 10 vectors
            WRITE(*,*) 'Eigenvector ',i,' with eigenvalue',workspaceeigenvalues(i)
            WRITE(lup,*) 'Eigenvector ',i,' with eigenvalue',workspaceeigenvalues(i)
            DO j=1,nagb
                ij=j+(i-1)*nagb      ! index with eigenvector array
                IF(j <= nvgb) THEN
                    itgbi=globalparvartototal(j)
                    label=globalparlabelindex(1,itgbi)
                ELSE
                    label=nvgb-j             ! label negative for constraints
                END IF
                iev=iev+1
                labele(iev)=label
                compnt(iev)=real(workspaceeigenvectors(ij),mps)    ! component
                IF(iev == 3) THEN
                    WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev)
                    iev=0
                END IF
            END DO
            IF(iev /= 0) WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev)
            iev=0
            WRITE(lup,*) ' '
        END DO
  
    END IF
 
101 FORMAT(1x,'    label       parameter      presigma        differ',  &
        '         error'/ 1x,'-----------',4x,4('-------------'))
102 FORMAT(i10,2x,4g14.5,f8.3)
103 FORMAT(3(i11,f11.7,2x))
110 FORMAT(i10,2x,2g14.5,28x,i12)
111 FORMAT(i10,2x,3g14.5,14x,i12)
112 FORMAT(i10,2x,4g14.5,i12)
113 FORMAT('!',a)
END SUBROUTINE prtglo    ! print final log file
 
!***********************************************************************
 
SUBROUTINE prtstat
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    REAL(mps):: par
    REAL(mps):: presig
    INTEGER(mpi) :: icom
    INTEGER(mpl) :: icount
    INTEGER(mpi) :: ifrst
    INTEGER(mpi) :: ilast
    INTEGER(mpi) :: inext
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: itgbl
    INTEGER(mpi) :: itpgrp
    INTEGER(mpi) :: ivgbi
    INTEGER(mpi) :: lup
    INTEGER(mpi) :: icgrp
    INTEGER(mpi) :: ipgrp
    INTEGER(mpi) :: j
    INTEGER(mpi) :: jpgrp
    INTEGER(mpi) :: k
    INTEGER(mpi) :: label1
    INTEGER(mpi) :: label2
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: npair
    INTEGER(mpi) :: nstep
    CHARACTER :: c1
    
    INTEGER(mpl):: length
 
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecPairedParGroups
 
    INTERFACE ! needed for assumed-shape dummy arguments
        SUBROUTINE ggbmap(ipgrp,npair,npgrp)
            USE mpdef
            INTEGER(mpi), INTENT(IN) :: ipgrp
            INTEGER(mpi), INTENT(OUT) :: npair
            INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npgrp
        END SUBROUTINE ggbmap
    END INTERFACE
        
    SAVE
    !     ...
 
    lup=09
    CALL mvopen(lup,'millepede.res')
    WRITE(lup,*) '*** Results of checking input only, no solution performed ***'
    WRITE(lup,*) '! === global parameters ==='
    WRITE(lup,*) '! fixed-1: by pre-sigma, -2: by entries cut, -3: by iterated entries cut'
    IF (ipcntr < 0) THEN
        WRITE(lup,*) '!      Label       Value     Pre-sigma  SkippedEntries Cons. group  Status '
    ELSE
        WRITE(lup,*) '!      Label       Value     Pre-sigma         Entries Cons. group  Status '
    END IF
    !iprlim=10
    DO itgbi=1,ntgb  ! all parameter variables
        itgbl=globalparlabelindex(1,itgbi)
        ivgbi=globalparlabelindex(2,itgbi)
        icom=globalparcomments(itgbi) ! comment
        IF (icom > 0) WRITE(lup,117) listcomments(icom)%text
        c1=' '
        IF (globalparlabelindex(3,itgbi) == itgbl) c1='>'
        par=real(globalparameter(itgbi),mps)      ! initial value
        presig=real(globalparpresigma(itgbi),mps) ! initial presigma
        icount=globalparlabelcounter(itgbi) ! from binary files
        IF (ipcntr < 0) icount=globalparlabelzeros(itgbi) ! 'zero derivatives' from binary files
        icgrp=globalparcons(itgbi) ! constraints group
 
        IF (ivgbi <= 0) THEN
            ! not used
            IF (ivgbi == -4) THEN
                WRITE(lup,116) c1,itgbl,par,presig,icount,icgrp
            ELSE   
                WRITE(lup,110) c1,itgbl,par,presig,icount,icgrp,ivgbi
            END IF         
        ELSE
            ! variable
            WRITE(lup,111) c1,itgbl,par,presig,icount,icgrp
        END IF
    END DO
    ! appearance statistics
    IF (icheck > 1) THEN
        WRITE(lup,*) '!.'
        WRITE(lup,*) '!.Appearance statistics '
        WRITE(lup,*) '!.     Label  First file and record  Last file and record   #files  #paired-par'
        DO itgbi=1,ntgb
            itpgrp=globalparlabelindex(4,itgbi)
            IF (itpgrp > 0) THEN
                WRITE(lup,112) globalparlabelindex(1,itgbi), (appearancecounter(itgbi*5+k), k=-4,0), paircounter(itpgrp)
            ELSE ! 'empty' parameter
                WRITE(lup,112) globalparlabelindex(1,itgbi)
            END IF
        END DO
    END IF
    IF (ncgrp > 0) THEN
        WRITE(lup,*) '* === constraint groups ==='
        IF (icheck == 1) THEN 
            WRITE(lup,*) '*  Group  #Cons.     Entries First label  Last label'
        ELSE
            WRITE(lup,*) '*  Group  #Cons.     Entries First label  Last label   Paired label range'
            length=ntpgrp+ncgrp
            CALL mpalloc(vecpairedpargroups,length,'paired global parameter groups (I)') 
        END IF
        DO icgrp=1, ncgrp
            IF (matconsgroups(2,icgrp) <= matconsgroups(3,icgrp)) THEN
                label1=globalparlabelindex(1,globalparvartototal(matconsgroups(2,icgrp))) ! first label
                label2=globalparlabelindex(1,globalparvartototal(matconsgroups(3,icgrp))) ! last label
            ELSE ! empty group/cons.
                label1=0
                label2=0
            END IF
            ncon=matconsgroups(1,icgrp+1)-matconsgroups(1,icgrp)
            WRITE(lup,113) icgrp, ncon,vecconsgroupcounts(icgrp),label1,label2
            IF (icheck > 1 .AND. label1 > 0) THEN
                ipgrp=globalparlabelindex(4,globalparvartototal(matconsgroups(2,icgrp))) ! first par. group
                ! get paired parameter groups
                CALL ggbmap(ntpgrp+icgrp,npair,vecpairedpargroups)
                vecpairedpargroups(npair+1)=0
                ifrst=0
                nstep=1
                DO j=1, npair
                    jpgrp=vecpairedpargroups(j)
                    inext=globaltotindexgroups(1,jpgrp)
                    DO k=1,globaltotindexgroups(2,jpgrp)
                        ! end of continous region ?
                        IF (ifrst /= 0.AND.inext /= (ilast+nstep)) THEN
                            label1=globalparlabelindex(1,ifrst)
                            label2=globalparlabelindex(1,ilast)
                            WRITE(lup,114) label1, label2
                            ifrst=0
                        END IF
                        ! skip 'self-correlations' 
                        IF (globalparcons(inext) /= icgrp) THEN
                            IF (ifrst == 0) ifrst=inext
                            ilast=inext
                        END IF
                        inext=inext+1
                        nstep=1
                    END DO
                    ! skip 'empty' parameter
                    IF (jpgrp == vecpairedpargroups(j+1)-1) THEN
                        nstep=globaltotindexgroups(1,vecpairedpargroups(j+1)) &
                            -(globaltotindexgroups(1,jpgrp)+globaltotindexgroups(2,jpgrp)-1)
                    END IF     
                END DO
                IF (ifrst /= 0) THEN
                    label1=globalparlabelindex(1,ifrst)
                    label2=globalparlabelindex(1,ilast)
                    WRITE(lup,114) label1, label2
                END IF    
            END IF
        END DO
        IF (icheck > 1) THEN
            WRITE(lup,*) '*.'
            WRITE(lup,*) '*.Appearance statistics '
            WRITE(lup,*) '*.     Group  First file and record  Last file and record   #files'
            DO icgrp=1, ncgrp
                WRITE(lup,115) icgrp, (appearancecounter((ntgb+icgrp)*5+k), k=-4,0)
            END DO
        END IF
    END IF
    
    rewind lup
    CLOSE(unit=lup)
 
110 FORMAT(' !',a1,i10,2x,2g14.5,2i12,'  fixed',i2)
111 FORMAT(' !',a1,i10,2x,2g14.5,2i12,'  variable')
112 FORMAT(' !.',i10,6i11)
113 FORMAT(' * ',i6,i8,3i12)
114 FORMAT(' *:',48x,i12,' ..',i12)
115 FORMAT(' *.',i10,5i11)
116 FORMAT(' !',a1,i10,2x,2g14.5,2i12,'  redundant')
117 FORMAT(' !!',a)
END SUBROUTINE prtstat    ! print input statistics
 
 
 
SUBROUTINE avprds(n,l,x,is,ie,b)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ia2
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ib2
    INTEGER(mpi) :: in
    INTEGER(mpi) :: ipg
    INTEGER(mpi) :: iproc
    INTEGER(mpi) :: ir
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: ja2
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jb2
    INTEGER(mpi) :: jn
    INTEGER(mpi) :: lj
 
    INTEGER(mpi), INTENT(IN)          :: n
    INTEGER(mpl), INTENT(IN)          :: l
    REAL(mpd), INTENT(IN)             :: x(n)
    INTEGER(mpi), INTENT(IN)          :: is
    INTEGER(mpi), INTENT(IN)          :: ie
    REAL(mpd), INTENT(OUT)            :: b(n)
    INTEGER(mpl) :: k
    INTEGER(mpl) :: kk
    INTEGER(mpl) :: ku
    INTEGER(mpl) :: ll
    INTEGER(mpl) :: indij
    INTEGER(mpl) :: indid
    INTEGER(mpl) :: ij
    INTEGER(mpi) :: ichunk
    !$    INTEGER(mpi) OMP_GET_THREAD_NUM
    SAVE
    !     ...
 
    ichunk=min((n+mthrd-1)/mthrd/8+1,128)
    IF(matsto /= 2) THEN
        ! full or unpacked (block diagonal) symmetric matrix
        ! parallelize row loop
        ! private copy of B(N) for each thread, combined at end, init with 0.
        ! slot of 128 'I' for next idle thread
        !$OMP  PARALLEL DO &
        !$OMP  PRIVATE(J,IJ) &
        !$OMP  SCHEDULE(DYNAMIC,ichunk)
        DO i=1,n
            ij=globalrowoffsets(i+l)+l
            DO j=is,min(i,ie)
                b(i)=b(i)+globalmatd(ij+j)*x(j)
            END DO
        END DO
        !$OMP END PARALLEL DO
 
        !$OMP  PARALLEL DO &
        !$OMP  PRIVATE(J,IJ) &
        !$OMP  REDUCTION(+:B) &
        !$OMP  SCHEDULE(DYNAMIC,ichunk)
        DO i=is,ie
            ij=globalrowoffsets(i+l)+l
            DO j=1,i-1
                b(j)=b(j)+globalmatd(ij+j)*x(i)
            END DO
        END DO
        !$OMP END PARALLEL DO
    ELSE
        ! sparse, compressed matrix
        IF(sparsematrixoffsets(2,1) /= n) THEN
            CALL peend(24,'Aborted, vector/matrix size mismatch')
            stop 'AVPRDS: mismatched vector and matrix'
        END IF
        ! parallelize row (group) loop
        ! slot of 1024 'I' for next idle thread
        !$OMP PARALLEL DO &
        !$OMP  PRIVATE(I,IR,K,KK,LL,KU,INDID,INDIJ,J,JN,LJ) &
        !$OMP  PRIVATE(IA,IB,IN,JA,JB,IA2,IB2,JA2,JB2) &
        !$OMP  REDUCTION(+:B) &
        !$OMP  SCHEDULE(DYNAMIC,ichunk)
        DO ipg=1,napgrp
            iproc=0
            !$     IPROC=OMP_GET_THREAD_NUM()         ! thread number
            ! row group
            ia=globalallindexgroups(ipg)     ! first (global) row
            ib=globalallindexgroups(ipg+1)-1 ! last (global) row
            in=ib-ia+1                       ! number of rows
            ! overlap
            ia2=max(ia,is)
            ib2=min(ib,ie)
            ! diagonal elements            
            IF (ia2 <= ib2) b(ia2:ib2)=b(ia2:ib2)+globalmatd(ia2:ib2)*x(ia2:ib2)    
            ! off-diagonals double precision
            ir=ipg
            kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
            ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
            ku=sparsematrixoffsets(1,ir+1)-kk
            indid=kk
            indij=ll
            IF (ku > 0) THEN
                IF (sparsematrixcolumns(indid+1) /= 0) THEN  ! no compression
                    DO i=ia,ib
                        IF (i <= ie.AND.i >= is) THEN
                            DO k=1,ku
                                j=sparsematrixcolumns(indid+k)
                                b(j)=b(j)+globalmatd(indij+k)*x(i)
                            END DO
                        END IF
                        DO k=1,ku
                            j=sparsematrixcolumns(indid+k)
                            IF (j <= ie.AND.j >= is) THEN
                                b(i)=b(i)+globalmatd(indij+k)*x(j)
                            END IF    
                        END DO
                        indij=indij+ku
                    END DO    
                ELSE
                    ! regions of continous column groups
                    DO k=2,ku-2,2
                        j=sparsematrixcolumns(indid+k)         ! first group 
                        ja=globalallindexgroups(j)             ! first (global) column
                        lj=sparsematrixcolumns(indid+k-1)      ! region offset 
                        jn=sparsematrixcolumns(indid+k+1)-lj   ! number of columns
                        jb=ja+jn-1                             ! last (global) column
                        ja2=max(ja,is)
                        jb2=min(jb,ie) 
                        IF (ja2 <= jb2) THEN
                            lj=1                               ! index (in group region)
                            DO i=ia,ib
                                b(i)=b(i)+dot_product(globalmatd(indij+lj+ja2-ja:indij+lj+jb2-ja),x(ja2:jb2))
                                lj=lj+jn
                            END DO
                        END IF
                        IF (mextnd == 0.AND.ia2 <= ib2) THEN
                            lj=1
                            DO j=ja,jb
                                b(j)=b(j)+dot_product(globalmatd(indij+lj+jn*(ia2-ia):indij+lj+jn*(ib2-ia):jn),x(ia2:ib2))
                                lj=lj+1
                            END DO
                        END IF
                        indij=indij+in*jn
                    END DO    
                END IF
            END IF 
            ! mixed precision
            IF (nspc > 1) THEN
                ir=ipg+napgrp+1                     ! off-diagonals single precision
                kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
                ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
                ku=sparsematrixoffsets(1,ir+1)-kk
                indid=kk
                indij=ll
                IF (ku == 0) cycle
                IF (sparsematrixcolumns(indid+1) /= 0) THEN  ! no compression
                    DO i=ia,ib
                        IF (i <= ie.AND.i >= is) THEN
                            DO k=1,ku
                                j=sparsematrixcolumns(indid+k)
                                b(j)=b(j)+globalmatf(indij+k)*x(i)
                            END DO
                        END IF
                        DO k=1,ku
                            j=sparsematrixcolumns(indid+k)
                            IF (j <= ie.AND.j >= is) THEN
                                b(i)=b(i)+globalmatf(indij+k)*x(j)
                            END IF    
                        END DO
                        indij=indij+ku
                    END DO    
                ELSE
                    ! regions of continous column groups
                    DO k=2,ku-2,2
                        j=sparsematrixcolumns(indid+k)         ! first group 
                        ja=globalallindexgroups(j)             ! first (global) column
                        lj=sparsematrixcolumns(indid+k-1)      ! region offset 
                        jn=sparsematrixcolumns(indid+k+1)-lj   ! number of columns
                        jb=ja+jn-1                             ! last (global) column
                        ja2=max(ja,is)
                        jb2=min(jb,ie) 
                        IF (ja2 <= jb2) THEN
                            lj=1                               ! index (in group region)
                            DO i=ia,ib
                                b(i)=b(i)+dot_product(real(globalmatf(indij+lj+ja2-ja:indij+lj+jb2-ja),mpd),x(ja2:jb2))
                                lj=lj+jn
                            END DO
                        END IF
                        IF (mextnd == 0.AND.ia2 <= ib2) THEN
                            lj=1
                            DO j=ja,jb
                                b(j)=b(j)+dot_product(real(globalmatf(indij+lj+jn*(ia2-ia):indij+lj+jn*(ib2-ia):jn),mpd),x(ia2:ib2))
                                lj=lj+1
                            END DO
                        END IF  
                        indij=indij+in*jn
                    END DO    
                END IF    
            END IF
        END DO
    ENDIF
 
END SUBROUTINE avprds
 
 
SUBROUTINE avprd0(n,l,x,b)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: in
    INTEGER(mpi) :: ipg
    INTEGER(mpi) :: iproc
    INTEGER(mpi) :: ir
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jn
    INTEGER(mpi) :: lj
 
    INTEGER(mpi), INTENT(IN)          :: n
    INTEGER(mpl), INTENT(IN)          :: l
    REAL(mpd), INTENT(IN)             :: x(n)
    REAL(mpd), INTENT(OUT)            :: b(n)
    INTEGER(mpl) :: k
    INTEGER(mpl) :: kk
    INTEGER(mpl) :: ku
    INTEGER(mpl) :: ll
    INTEGER(mpl) :: indij
    INTEGER(mpl) :: indid
    INTEGER(mpl) :: ij
    INTEGER(mpi) :: ichunk
    !$    INTEGER(mpi) OMP_GET_THREAD_NUM
    SAVE
    !     ...
    !$ DO i=1,n
    !$    b(i)=0.0_mpd             ! reset 'global' B()
    !$ END DO
    ichunk=min((n+mthrd-1)/mthrd/8+1,1024)
    IF(matsto /= 2) THEN
        ! full or unpacked (block diagonal) symmetric matrix
        ! parallelize row loop
        ! private copy of B(N) for each thread, combined at end, init with 0.
        ! slot of 1024 'I' for next idle thread
        !$OMP  PARALLEL DO &
        !$OMP  PRIVATE(J,IJ) &
        !$OMP  REDUCTION(+:B) &
        !$OMP  SCHEDULE(DYNAMIC,ichunk)
        DO i=1,n
            ij=globalrowoffsets(i+l)+l
            b(i)=globalmatd(ij+i)*x(i)
            DO j=1,i-1
                b(j)=b(j)+globalmatd(ij+j)*x(i)
                b(i)=b(i)+globalmatd(ij+j)*x(j)
            END DO
        END DO
        !$OMP END PARALLEL DO
    ELSE
        ! sparse, compressed matrix
        IF(sparsematrixoffsets(2,1) /= n) THEN
            CALL peend(24,'Aborted, vector/matrix size mismatch')
            stop 'AVPRD0: mismatched vector and matrix'
        END IF
        ! parallelize row (group) loop
        ! slot of 1024 'I' for next idle thread
        !$OMP PARALLEL DO &
        !$OMP  PRIVATE(I,IR,K,KK,LL,KU,INDID,INDIJ,J,JN,LJ) &
        !$OMP  PRIVATE(IA,IB,IN,JA,JB) &
        !$OMP  REDUCTION(+:B) &
        !$OMP  SCHEDULE(DYNAMIC,ichunk)
        DO ipg=1,napgrp
            iproc=0
            !$     IPROC=OMP_GET_THREAD_NUM()         ! thread number
            ! row group
            ia=globalallindexgroups(ipg)     ! first (global) row
            ib=globalallindexgroups(ipg+1)-1 ! last (global) row
            in=ib-ia+1                       ! number of rows  
            !
            ! diagonal elements            
            b(ia:ib)=globalmatd(ia:ib)*x(ia:ib)       
            ! off-diagonals double precision
            ir=ipg
            kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
            ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
            ku=sparsematrixoffsets(1,ir+1)-kk
            indid=kk
            indij=ll
            IF (ku > 0) THEN
                IF (sparsematrixcolumns(indid+1) /= 0) THEN  ! no compression
                    DO i=ia,ib
                        DO k=1,ku
                            j=sparsematrixcolumns(indid+k)
                            b(j)=b(j)+globalmatd(indij+k)*x(i)
                            b(i)=b(i)+globalmatd(indij+k)*x(j)
                        END DO
                        indij=indij+ku
                    END DO    
                ELSE
                    ! regions of continous column groups
                    DO k=2,ku-2,2
                        j=sparsematrixcolumns(indid+k)         ! first group 
                        ja=globalallindexgroups(j)             ! first (global) column
                        lj=sparsematrixcolumns(indid+k-1)      ! region offset 
                        jn=sparsematrixcolumns(indid+k+1)-lj   ! number of columns
                        jb=ja+jn-1                             ! last (global) column
                        lj=1                                   ! index (in group region)
                        DO i=ia,ib
                            b(i)=b(i)+dot_product(globalmatd(indij+lj:indij+lj+jn-1),x(ja:jb))
                            lj=lj+jn
                        END DO
                        IF (mextnd == 0) THEN
                            lj=1
                            DO j=ja,jb
                                b(j)=b(j)+dot_product(globalmatd(indij+lj:indij+jn*in:jn),x(ia:ib))
                                lj=lj+1
                            END DO
                        END IF
                        indij=indij+in*jn
                    END DO    
                END IF
            END IF
            ! mixed precision
            IF (nspc > 1) THEN
                ir=ipg+napgrp+1                     ! off-diagonals single precision
                kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
                ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
                ku=sparsematrixoffsets(1,ir+1)-kk
                indid=kk
                indij=ll
                IF (ku == 0) cycle
                IF (sparsematrixcolumns(indid+1) /= 0) THEN  ! no compression
                    DO i=ia,ib
                        DO k=1,ku
                            j=sparsematrixcolumns(indid+k)
                            b(j)=b(j)+real(globalmatf(indij+k),mpd)*x(i)
                            b(i)=b(i)+real(globalmatf(indij+k),mpd)*x(j)
                        END DO
                        indij=indij+ku
                    END DO    
                ELSE
                    ! regions of continous column groups
                    DO k=2,ku-2,2
                        j=sparsematrixcolumns(indid+k)         ! first group 
                        ja=globalallindexgroups(j)             ! first (global) column
                        lj=sparsematrixcolumns(indid+k-1)      ! region offset 
                        jn=sparsematrixcolumns(indid+k+1)-lj   ! number of columns
                        jb=ja+jn-1                             ! last (global) column
                        lj=1                                   ! index (in group region)
                        DO i=ia,ib
                            b(i)=b(i)+dot_product(real(globalmatf(indij+lj:indij+lj+jn-1),mpd),x(ja:jb))
                            lj=lj+jn
                        END DO
                        IF (mextnd == 0) THEN
                            lj=1
                            DO j=ja,jb
                                b(j)=b(j)+dot_product(real(globalmatf(indij+lj:indij+jn*in:jn),mpd),x(ia:ib))
                                lj=lj+1
                            END DO
                        END IF  
                        indij=indij+in*jn
                    END DO    
                END IF    
            END IF
        END DO
    ENDIF
 
END SUBROUTINE avprd0
 
 
SUBROUTINE anasps
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ipg
    INTEGER(mpi) :: ir
    INTEGER(mpi) :: ispc
    INTEGER(mpi) :: lj
    REAL(mps) :: avg
 
 
    INTEGER(mpl) :: in
    INTEGER(mpl) :: jn
    INTEGER(mpl) :: k
    INTEGER(mpl) :: kk
    INTEGER(mpl) :: ku
    INTEGER(mpl) :: ll
    INTEGER(mpl) :: indid
    INTEGER(mpl), DIMENSION(12) :: icount
    SAVE
 
    ! require sparse storage
    IF(matsto /= 2) RETURN
    ! reset
    icount=0
    icount(4)=huge(icount(4))
    icount(7)=huge(icount(7))
    icount(10)=huge(icount(10))
    ! loop over precisions
    DO ispc=1,nspc
        ! loop over row groups
        DO ipg=1,napgrp
            ! row group
            ia=globalallindexgroups(ipg)     ! first (global) row
            ib=globalallindexgroups(ipg+1)-1 ! last (global) row
            in=ib-ia+1                       ! number of rows  
 
            ir=ipg+(ispc-1)*(napgrp+1)
            kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
            ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
            ku=sparsematrixoffsets(1,ir+1)-kk
            indid=kk
            IF (ku == 0) cycle
            IF (sparsematrixcolumns(indid+1) /= 0) THEN  ! no compression
                icount(1)=icount(1)+in
                icount(2)=icount(2)+in*ku
            ELSE
                ! regions of continous column groups
                DO k=2,ku-2,2
                    lj=sparsematrixcolumns(indid+k-1)      ! region offset 
                    jn=sparsematrixcolumns(indid+k+1)-lj   ! number of columns
                    icount(3)=icount(3)+1       ! block (region) counter
                    icount(4)=min(icount(4),jn) ! min number of columns per block (region)
                    icount(5)=icount(5)+jn      ! sum number of columns per block (region)
                    icount(6)=max(icount(6),jn) ! max number of columns per block (region)
                    icount(7)=min(icount(7),in) ! min number of rows per block (region)
                    icount(8)=icount(8)+in      ! sum number of rows per block (region)
                    icount(9)=max(icount(9),in) ! max number of rows per block (region)
                    icount(10)=min(icount(10),in*jn) ! min number of elements per block (region)
                    icount(11)=icount(11)+in*jn      ! sum number of elements per block (region)
                    icount(12)=max(icount(12),in*jn) ! max number of elements per block (region)
                END DO    
            END IF
        END DO
    END DO
    
    WRITE(*,*) "analysis of sparsity structure"
    IF (icount(1) > 0) THEN
        WRITE(*,101) "rows without compression/blocks ", icount(1)  
        WRITE(*,101) "             contained elements ", icount(2)  
    ENDIF
    WRITE(*,101) "number of block matrices          ", icount(3)
    avg=real(icount(5),mps)/real(icount(3),mps)
    WRITE(*,101) "number of columns  (min,mean,max) ", icount(4), avg, icount(6)
    avg=real(icount(8),mps)/real(icount(3),mps)
    WRITE(*,101) "number of rows     (min,mean,max) ", icount(7), avg, icount(9)
    avg=real(icount(11),mps)/real(icount(3),mps)
    WRITE(*,101) "number of elements (min,mean,max) ", icount(10), avg, icount(12)
101 FORMAT(2x,a34,i10,f10.3,i10)
    
END SUBROUTINE anasps
 
 
SUBROUTINE avprod(n,x,b)
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi), INTENT(IN)          :: n
    REAL(mpd), INTENT(IN)             :: x(n)
    REAL(mpd), INTENT(OUT)            :: b(n)
 
    SAVE
    !     ...
    IF(n > nagb) THEN
        CALL peend(24,'Aborted, vector/matrix size mismatch')
        stop 'AVPROD: mismatched vector and matrix'
    END IF
    ! input to AVPRD0
    vecxav(1:n)=x
    vecxav(n+1:nagb)=0.0_mpd
    !use elimination for constraints ?
    IF(n < nagb) CALL qlmlq(vecxav,1,.false.) ! Q*x
    ! calclulate vecBav=globalMat*vecXav
    CALL avprd0(nagb,0_mpl,vecxav,vecbav)
    !use elimination for constraints ?
    IF(n < nagb) CALL qlmlq(vecbav,1,.true.) ! Q^t*x
    ! output from AVPRD0
    b=vecbav(1:n)
 
END SUBROUTINE avprod
 
 
 
SUBROUTINE ijpgrp(itema,itemb,ij,lr,iprc)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: ispc
    INTEGER(mpi) :: item1
    INTEGER(mpi) :: item2
    INTEGER(mpi) :: itemc
    INTEGER(mpi) :: jtem
    INTEGER(mpi) :: jtemn
    INTEGER(mpi) :: np
 
    INTEGER(mpi), INTENT(IN) :: itema
    INTEGER(mpi), INTENT(IN) :: itemb
    INTEGER(mpl), INTENT(OUT) :: ij
    INTEGER(mpi), INTENT(OUT) :: lr
    INTEGER(mpi), INTENT(OUT) :: iprc   
    
    INTEGER(mpl) :: k
    INTEGER(mpl) :: kk
    INTEGER(mpl) :: kl
    INTEGER(mpl) :: ku
    INTEGER(mpl) :: ll
    !     ...
    ij=0
    lr=0
    iprc=0
    item1=max(itema,itemb)          ! larger index
    item2=min(itema,itemb)          ! smaller index
    IF(item2 <= 0.OR.item1 > napgrp) RETURN
    np=globalallindexgroups(item1+1)-globalallindexgroups(item1) ! size of group item1
    ! loop over precisions
    outer: DO ispc=1,nspc
        kk=sparsematrixoffsets(1,item1) ! offset (column lists)
        ll=sparsematrixoffsets(2,item1) ! offset (matrix)
        kl=1
        ku=sparsematrixoffsets(1,item1+1)-kk
        item1=item1+napgrp+1
        iprc=ispc
        IF (sparsematrixcolumns(kk+1) == 0) THEN     ! compression ?
            ! compressed (list of continous regions of parameter groups (pairs of offset and 1. group index)
            kl=2
            ku=ku-2
            IF(ku < kl) cycle outer  ! not found
            DO
                k=2*((kl+ku)/4)                   ! binary search
                jtem=sparsematrixcolumns(kk+k)    ! first column (group) of region
                jtemn=sparsematrixcolumns(kk+k+2) ! first column (group) after region
                IF(item2 >= jtem.AND.item2 < jtemn) THEN
                    ! length of region
                    lr=sparsematrixcolumns(kk+k+1)-sparsematrixcolumns(kk+k-1)
                    IF (globalallindexgroups(item2)-globalallindexgroups(jtem) >= lr) cycle outer ! outside region
                    EXIT ! found
                END IF    
                IF(item2 < jtem) THEN
                    ku=k-2
                ELSE IF(item2 >= jtemn) THEN
                    kl=k+2
                END IF
                IF(kl <= ku) cycle
                cycle outer ! not found
            END DO
            ! group offset in row
            ij=sparsematrixcolumns(kk+k-1)
            ! absolute offset 
            ij=ll+ij*np+globalallindexgroups(item2)-globalallindexgroups(jtem)+1
            
        ELSE
            ! simple column list
            itemc=globalallindexgroups(item2) ! first (col) index of group 
            lr=int(ku,mpi)                    ! number of columns
            IF(ku < kl) cycle outer ! not found
            DO
                k=(kl+ku)/2                  ! binary search
                jtem=sparsematrixcolumns(kk+k)
                IF(itemc == jtem) EXIT ! found
                IF(itemc < jtem) THEN
                    ku=k-1
                ELSE IF(itemc > jtem) THEN
                    kl=k+1
                END IF
                IF(kl <= ku) cycle
                cycle outer  ! not found
            END DO
            ij=ll+k
            
        END IF
        RETURN
    END DO outer
 
END SUBROUTINE ijpgrp
 
 
FUNCTION ijprec(itema,itemb)  
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi) :: lr
    INTEGER(mpl) :: ij
 
    INTEGER(mpi), INTENT(IN) :: itema
    INTEGER(mpi), INTENT(IN) :: itemb
    INTEGER(mpi) :: ijprec
    
    !     ...
    ijprec=1
    IF (matsto == 2.AND.nspc > 1) THEN ! sparse storage with mixed precision
        ! check groups
        CALL ijpgrp(itema,itemb,ij,lr,ijprec)
    END IF
 
END FUNCTION ijprec
 
 
FUNCTION ijadd(itema,itemb)      ! index using "d" and "z"
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi) :: item1
    INTEGER(mpi) :: item2
    INTEGER(mpi) :: ipg1
    INTEGER(mpi) :: ipg2
    INTEGER(mpi) :: lr
    INTEGER(mpi) :: iprc
 
    INTEGER(mpi), INTENT(IN) :: itema
    INTEGER(mpi), INTENT(IN) :: itemb
 
    INTEGER(mpl) :: ijadd
    INTEGER(mpl) :: ij
    !     ...
    ijadd=0
    item1=max(itema,itemb)          ! larger index
    item2=min(itema,itemb)          ! smaller index
    !print *, ' ijadd ', item1, item2
    IF(item2 <= 0.OR.item1 > nagb) RETURN
    IF(item1 == item2) THEN         ! diagonal element
        ijadd=item1
        RETURN
    END IF
    !                                   ! off-diagonal element
    ! get parameter groups
    ipg1=globalallpartogroup(item1)
    ipg2=globalallpartogroup(item2)
    ! get offset for groups
    CALL ijpgrp(ipg1,ipg2,ij,lr,iprc)
    IF (ij == 0) RETURN
    ! add offset inside groups
    ijadd=ij+(item2-globalallindexgroups(ipg2))+(item1-globalallindexgroups(ipg1))*lr
    ! reduced precision?
    IF (iprc > 1) ijadd=-ijadd 
 
END FUNCTION ijadd
 
 
FUNCTION ijcsr3(itema,itemb)      ! index using "d" and "z"
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi) :: item1
    INTEGER(mpi) :: item2
    INTEGER(mpi) :: jtem
 
    INTEGER(mpi), INTENT(IN) :: itema
    INTEGER(mpi), INTENT(IN) :: itemb
 
    INTEGER(mpl) :: ijcsr3
    INTEGER(mpl) :: kk
    INTEGER(mpl) :: ks
    INTEGER(mpl) :: ke
 
    !     ...
    ijcsr3=0
    item1=max(itema,itemb)          ! larger index
    item2=min(itema,itemb)          ! smaller index
    !print *, ' ijadd ', item1, item2
    IF(item2 <= 0.OR.item1 > nagb) RETURN
    ! start of column list for row
    ks=csr3rowoffsets(item2)
    ! end of column list for row
    ke=csr3rowoffsets(item2+1)-1
    ! binary search
    IF(ke < ks) THEN
        ! empty list
        print *, ' IJCSR3 empty list ', item1, item2, ks, ke
        CALL peend(23,'Aborted, bad matrix index')
        stop 'ijcsr3: empty list'
    ENDIF
    DO
        kk=(ks+ke)/2 ! center of rgion
        jtem=int(csr3columnlist(kk),mpi)
        IF(item1 == jtem) EXIT ! found
        IF(item1 < jtem) THEN
            ke=kk-1
        ELSE
            ks=kk+1
        END IF
        IF(ks <= ke) cycle
        ! not found
        print *, ' IJCSR3 not found ', item1, item2, ks, ke
        CALL peend(23,'Aborted, bad matrix index')
        stop 'ijcsr3: not found'
    END DO
    ijcsr3=kk
END FUNCTION ijcsr3
 
 
FUNCTION matij(itema,itemb)
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi) :: item1
    INTEGER(mpi) :: item2
    INTEGER(mpl) :: i
    INTEGER(mpl) :: j
    INTEGER(mpl) :: ij
    INTEGER(mpl) :: ijadd
    INTEGER(mpl) :: ijcsr3
 
    INTEGER(mpi), INTENT(IN) :: itema
    INTEGER(mpi), INTENT(IN) :: itemb
 
    REAL(mpd) :: matij
    !     ...
    matij=0.0_mpd
    item1=max(itema,itemb)          ! larger index
    item2=min(itema,itemb)          ! smaller index
    IF(item2 <= 0.OR.item1 > nagb) RETURN
 
    i=item1
    j=item2
    
    IF(matsto < 2) THEN                       ! full or unpacked (block diagonal) symmetric matrix
        ij=globalrowoffsets(i)+j
        matij=globalmatd(ij)
    ELSE IF(matsto ==2) THEN                  ! sparse symmetric matrix (custom)
        ij=ijadd(item1,item2)                 ! inline code requires same time
        IF(ij > 0) THEN
            matij=globalmatd(ij)
        ELSE IF (ij < 0) THEN
            matij=real(globalmatf(-ij),mpd)
        END IF
    ELSE                                      ! sparse symmetric matrix (CSR3)
        IF(matbsz < 2) THEN                   ! sparse symmetric matrix (CSR3)
            ij=ijcsr3(item1,item2)            ! inline code requires same time
            IF(ij > 0) matij=globalmatd(ij)
        ELSE                                  ! sparse symmetric matrix (BSR3)
            ! block index
            ij=ijcsr3((item1-1)/matbsz+1,(item2-1)/matbsz+1)
            IF (ij > 0) THEN
                ! index of first element in block
                ij=(ij-1)*matbsz*matbsz+1
                ! adjust index for position in block
                ij=ij+mod(item1-1,matbsz)*matbsz+mod(item2-1,matbsz)
                matij=globalmatd(ij)
            ENDIF
        END IF
    END IF
 
END FUNCTION matij
 
 
SUBROUTINE mhalf2
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ichunk
    INTEGER(mpi) :: in
    INTEGER(mpi) :: ipg
    INTEGER(mpi) :: ir
    INTEGER(mpi) :: ispc
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jn
    INTEGER(mpi) :: lj
 
    INTEGER(mpl) :: ij
    INTEGER(mpl) :: ijadd
    INTEGER(mpl) :: k
    INTEGER(mpl) :: kk
    INTEGER(mpl) :: ku
    INTEGER(mpl) :: ll
    !     ...
 
    ichunk=min((napgrp+mthrd-1)/mthrd/8+1,1024)
 
    DO ispc=1,nspc
        ! parallelize row loop
        ! slot of 1024 'I' for next idle thread
        !$OMP PARALLEL DO &
        !$OMP  PRIVATE(I,IR,K,KK,LL,KU,IJ,J,LJ) &
        !$OMP  PRIVATE(IA,IB,IN,JA,JB,JN) &
        !$OMP  SCHEDULE(DYNAMIC,ichunk)
        DO ipg=1,napgrp
            ! row group
            ia=globalallindexgroups(ipg)     ! first (global) row
            ib=globalallindexgroups(ipg+1)-1 ! last (global) row
            in=ib-ia+1                       ! number of rows
            !
            ir=ipg+(ispc-1)*(napgrp+1)
            kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
            ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
            ku=sparsematrixoffsets(1,ir+1)-kk
            ! regions of continous column groups
            DO k=2,ku-2,2
                j=sparsematrixcolumns(kk+k)         ! first group
                ja=globalallindexgroups(j)          ! first (global) column
                lj=sparsematrixcolumns(kk+k-1)      ! region offset
                jn=sparsematrixcolumns(kk+k+1)-lj   ! number of columns
                jb=ja+jn-1                          ! last (global) column
                ! skip first half
                IF (sparsematrixcolumns(kk+k+2) <= ipg) THEN
                    ll=ll+in*jn
                    cycle
                END IF 
                ! at diagonal or in second half  
                DO i=ia,ib                             ! loop over rows 
                    DO j=ja,jb                         ! loop over columns 
                        ll=ll+1
                        IF (j > i) THEN
                            ij=ijadd(i,j)
                            IF (ispc==1) THEN
                                globalmatd(ll)=globalmatd(ij)
                            ELSE
                                globalmatf(ll)=globalmatf(-ij)
                            END IF
                        END IF
                    END DO                    
                END DO
            END DO                 
        END DO
        !$OMP END PARALLEL DO
    END DO
 
END SUBROUTINE mhalf2
 
 
SUBROUTINE sechms(deltat,nhour,minut,secnd)
    USE mpdef
 
    IMPLICIT NONE
    REAL(mps), INTENT(IN) :: deltat
    INTEGER(mpi), INTENT(OUT) :: minut
    INTEGER(mpi), INTENT(OUT):: nhour
    REAL(mps), INTENT(OUT):: secnd
    INTEGER(mpi) :: nsecd
    !     DELTAT = time in sec  -> NHOUR,MINUT,SECND
    !     ...
    nsecd=nint(deltat,mpi) ! -> integer
    nhour=nsecd/3600
    minut=nsecd/60-60*nhour
    secnd=deltat-60*(minut+60*nhour)
END SUBROUTINE sechms
 
 
INTEGER(mpi) FUNCTION inone(item)             ! translate 1-D identifier to nrs
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi), INTENT(IN) :: item
    INTEGER(mpi) :: j
    INTEGER(mpi) :: k
    INTEGER(mpi) :: iprime
    INTEGER(mpl) :: length
    INTEGER(mpl), PARAMETER :: four = 4
 
    inone=0
    !print *, ' INONE ', item
    IF(item <= 0) RETURN
    IF(globalparheader(-1) == 0) THEN
        length=128                   ! initial number
        CALL mpalloc(globalparlabelindex,four,length,'INONE: label & index')
        CALL mpalloc(globalparlabelcounter,length,'INONE: counter') ! updated in pargrp
        CALL mpalloc(globalparhashtable,2*length,'INONE: hash pointer')
        globalparhashtable = 0
        globalparheader(-0)=int(length,mpi)       ! length of labels/indices
        globalparheader(-1)=0                 ! number of stored items
        globalparheader(-2)=0                 ! =0 during build-up
        globalparheader(-3)=int(length,mpi)       ! next number
        globalparheader(-4)=iprime(globalparheader(-0))    ! prime number
        globalparheader(-5)=0                 ! number of overflows
        globalparheader(-6)=0                 ! nr of variable parameters
        globalparheader(-8)=0                 ! number of sorted items
    END IF
    outer: DO
        j=1+mod(item,globalparheader(-4))+globalparheader(-0)
        inner: DO ! normal case: find item
            k=j
            j=globalparhashtable(k)
            IF(j == 0) EXIT inner    ! unused hash code
            IF(item == globalparlabelindex(1,j)) EXIT outer ! found
        END DO inner
        ! not found
        IF(globalparheader(-1) == globalparheader(-0).OR.globalparheader(-2) /= 0) THEN
            globalparheader(-5)=globalparheader(-5)+1 ! overflow
            j=0
            RETURN
        END IF
        globalparheader(-1)=globalparheader(-1)+1      ! increase number of elements
        globalparheader(-3)=globalparheader(-1)
        j=globalparheader(-1)
        globalparhashtable(k)=j                ! hash index
        globalparlabelindex(1,j)=item          ! add new item
        globalparlabelindex(2,j)=0             ! reset index (for variable par.)
        globalparlabelindex(3,j)=0             ! reset group info (first label)
        globalparlabelindex(4,j)=0             ! reset group info (group index)
        globalparlabelcounter(j)=0             ! reset (long) counter
        IF(globalparheader(-1) /= globalparheader(-0)) EXIT outer
        ! update with larger dimension and redefine index
        globalparheader(-3)=globalparheader(-3)*2
        CALL upone
        IF (lvllog > 1) WRITE(lunlog,*) 'INONE: array increased to',  &
            globalparheader(-3),' words'
    END DO outer
 
    ! counting now in pargrp
    !IF(globalParHeader(-2) == 0) THEN
    !    globalParLabelIndex(2,j)=globalParLabelIndex(2,j)+1 ! increase counter
    !    globalParHeader(-7)=globalParHeader(-7)+1
    !END IF
    inone=j
END FUNCTION inone
 
SUBROUTINE upone
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: j
    INTEGER(mpi) :: k
    INTEGER(mpi) :: iprime
    INTEGER(mpi) :: nused
    LOGICAL :: finalUpdate
    INTEGER(mpl) :: oldLength
    INTEGER(mpl) :: newLength
    INTEGER(mpl), PARAMETER :: four = 4
    INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArr
    INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: tempVec
    SAVE
    !     ...
    finalupdate=(globalparheader(-3) == globalparheader(-1))
    IF(finalupdate) THEN ! final (cleanup) call
        IF (globalparheader(-1) > globalparheader(-8)) THEN
            CALL sort22l(globalparlabelindex,globalparlabelcounter,globalparheader(-1)) ! sort items
            globalparheader(-8)=globalparheader(-1)
        END IF
    END IF
    ! save old LabelIndex
    nused = globalparheader(-1)
    oldlength = globalparheader(-0)
    CALL mpalloc(temparr,four,oldlength,'INONE: temp array')
    temparr(:,1:nused)=globalparlabelindex(:,1:nused)
    CALL mpalloc(tempvec,oldlength,'INONE: temp vector')
    tempvec(1:nused)=globalparlabelcounter(1:nused)
    CALL mpdealloc(globalparlabelindex)
    CALL mpdealloc(globalparlabelcounter)
    CALL mpdealloc(globalparhashtable)
    ! create new LabelIndex
    newlength = globalparheader(-3)
    CALL mpalloc(globalparlabelindex,four,newlength,'INONE: label & index')
    CALL mpalloc(globalparlabelcounter,newlength,'INONE: counter')
    CALL mpalloc(globalparhashtable,2*newlength,'INONE: hash pointer')
    globalparhashtable = 0
    globalparlabelindex(:,1:nused) = temparr(:,1:nused) ! copy back saved content
    globalparlabelcounter(1:nused) = tempvec(1:nused)   ! copy back saved content
    CALL mpdealloc(tempvec)
    CALL mpdealloc(temparr)
    globalparheader(-0)=int(newlength,mpi)   ! length of labels/indices
    globalparheader(-3)=globalparheader(-1)
    globalparheader(-4)=iprime(globalparheader(-0))          ! prime number < LNDA
    ! redefine hash
    outer: DO i=1,globalparheader(-1)
        j=1+mod(globalparlabelindex(1,i),globalparheader(-4))+globalparheader(-0)
        inner: DO
            k=j
            j=globalparhashtable(k)
            IF(j == 0) EXIT inner    ! unused hash code
            IF(j == i) cycle outer ! found
        ENDDO inner
        globalparhashtable(k)=i
    END DO outer
    IF(.NOT.finalupdate) RETURN
 
    globalparheader(-2)=1       ! set flag to inhibit further updates
    IF (lvllog > 1) THEN
        WRITE(lunlog,*) ' '
        WRITE(lunlog,*) 'INONE: array reduced to',newlength,' words'
        WRITE(lunlog,*) 'INONE:',globalparheader(-1),' items stored.'
    END IF
END SUBROUTINE upone                  ! update, redefine
 
SUBROUTINE useone
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: j
    INTEGER(mpi) :: k
    SAVE
    !     ...
    IF (globalparheader(-1) > globalparheader(-8)) THEN
        CALL sort22l(globalparlabelindex,globalparlabelcounter,globalparheader(-1)) ! sort items
        ! redefine hash
        globalparhashtable = 0
        outer: DO i=1,globalparheader(-1)
            j=1+mod(globalparlabelindex(1,i),globalparheader(-4))+globalparheader(-0)
            inner: DO
                k=j
                j=globalparhashtable(k)
                IF(j == 0) EXIT inner    ! unused hash code
                IF(j == i) cycle outer ! found
            ENDDO inner
            globalparhashtable(k)=i
        END DO outer
        globalparheader(-8)=globalparheader(-1)
    END IF
END SUBROUTINE useone                  ! make usable
 
 
INTEGER(mpi) FUNCTION iprime(n)
    USE mpdef
 
    IMPLICIT NONE
    INTEGER(mpi), INTENT(IN) :: n
    INTEGER(mpi) :: nprime
    INTEGER(mpi) :: nsqrt
    INTEGER(mpi) :: i
    !     ...
    SAVE
    nprime=n                               ! max number
    IF(mod(nprime,2) == 0) nprime=nprime+1 ! ... odd number
    outer: DO
        nprime=nprime-2                        ! next lower odd number
        nsqrt=int(sqrt(real(nprime,mps)),mpi)
        DO i=3,nsqrt,2                         !
            IF(i*(nprime/i) == nprime) cycle outer   ! test prime number
        END DO
        EXIT outer ! found
    END DO outer
    iprime=nprime
END FUNCTION iprime
 
SUBROUTINE loop1
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: idum
    INTEGER(mpi) :: in
    INTEGER(mpi) :: indab
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: itgbl
    INTEGER(mpi) :: ivgbi
    INTEGER(mpi) :: j
    INTEGER(mpi) :: jgrp
    INTEGER(mpi) :: lgrp
    INTEGER(mpi) :: mqi
    INTEGER(mpi) :: nc31
    INTEGER(mpi) :: nr
    INTEGER(mpi) :: nwrd
    INTEGER(mpi) :: inone
    REAL(mpd) :: param
    REAL(mpd) :: presg
    REAL(mpd) :: prewt
 
    INTEGER(mpl) :: length
    INTEGER(mpl) :: rows
    SAVE
    !     ...
    WRITE(lunlog,*) ' '
    WRITE(lunlog,*) 'LOOP1: starting'
    CALL mstart('LOOP1')
    
    !     add labels from parameter, constraints, measurements, comments -------------
    DO i=1, lenparameters
        idum=inone(listparameters(i)%label)
    END DO
    DO i=1, lenpresigmas
        idum=inone(listpresigmas(i)%label)
    END DO
    DO i=1, lenconstraints
        idum=inone(listconstraints(i)%label)
    END DO
    DO i=1, lenmeasurements
        idum=inone(listmeasurements(i)%label)
    END DO
    DO i=1, lencomments
        idum=inone(listcomments(i)%label)
    END DO
 
    IF(globalparheader(-1) /= 0) THEN
        WRITE(lunlog,*) 'LOOP1:',globalparheader(-1), ' labels from txt data stored'
    END IF
    WRITE(lunlog,*) 'LOOP1: reading data files'
 
    neqn=0 ! number of equations
    negb=0 ! number of equations with global parameters
    ndgb=0 ! number of global derivatives
    nzgb=0 ! number of zero global derivatives
    DO
        DO j=1,globalparheader(-1)
            globalparlabelindex(2,j)=0   ! reset count
        END DO
 
        !     read all data files and add all labels to global labels table ----
 
        IF(mprint /= 0) THEN
            WRITE(*,*) 'Read all binary data files:'
        END IF
        CALL hmpldf(1,'Number of words/record in binary file')
        CALL hmpdef(8,0.0,60.0,'not_stored data per record')
        !     define read buffer
        nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
        nwrd=nc31+1
        length=nwrd*mthrdr
        CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
        nwrd=nc31*10+2+ndimbuf
        length=nwrd*mthrdr
        CALL mpalloc(readbufferdatai,length,'read buffer, integer')
        CALL mpalloc(readbufferdatad,length,'read buffer, double')
        ! to read (old) float binary files
        length=(ndimbuf+2)*mthrdr
        CALL mpalloc(readbufferdataf,length,'read buffer, float')
 
        DO
            CALL peread(nr)  ! read records
            IF (skippedrecords == 0) THEN
                CALL peprep(0)   ! prepare records
                CALL pepgrp      ! update parameter group info
            END IF    
            IF(nr <= 0) EXIT ! end of data?
        END DO
        !     release read buffer
        CALL mpdealloc(readbufferdataf)
        CALL mpdealloc(readbufferdatad)
        CALL mpdealloc(readbufferdatai)
        CALL mpdealloc(readbufferpointer)
        IF (skippedrecords == 0) THEN
            EXIT
        ELSE
            WRITE(lunlog,*) 'LOOP1: reading data files again'
        END IF
    END DO
 
    IF(nhistp /= 0) THEN
        CALL hmprnt(1)
        CALL hmprnt(8)
    END IF
    CALL hmpwrt(1)
    CALL hmpwrt(8)
    ntgb = globalparheader(-1)     ! total number of labels/parameters
    IF (ntgb == 0) THEN
        CALL peend(21,'Aborted, no labels/parameters defined')
        stop 'LOOP1: no labels/parameters defined'
    END IF
    CALL upone ! finalize the global label table
    
    WRITE(lunlog,*) 'LOOP1:',ntgb,  &
        ' is total number NTGB of labels/parameters'
    !     histogram number of entries per label ----------------------------
    CALL hmpldf(2,'Number of entries per label')
    DO j=1,ntgb
        CALL hmplnt(2,globalparlabelindex(2,j))
    END DO
    IF(nhistp /= 0) CALL hmprnt(2) ! print histogram
    CALL hmpwrt(2) ! write to his file
 
    !     three subarrays for all global parameters ------------------------
    length=ntgb
    CALL mpalloc(globalparameter,length,'global parameters')
    globalparameter=0.0_mpd
    CALL mpalloc(globalparpresigma,length,'pre-sigmas') ! presigmas
    globalparpresigma=0.
    CALL mpalloc(globalparstart,length,'global parameters at start')
    globalparstart=0.
    CALL mpalloc(globalparcopy,length,'copy of global parameters')
    CALL mpalloc(globalparcons,length,'global parameter constraints')
    globalparcons=0
    CALL mpalloc(globalparcomments,length,'global parameter comments')
    globalparcomments=0
 
    DO i=1,lenparameters                  ! parameter start values
        param=listparameters(i)%value
        in=inone(listparameters(i)%label)
        IF(in /= 0) THEN
            globalparameter(in)=param
            globalparstart(in)=param
        ENDIF
    END DO
 
    DO i=1, lencomments
        in=inone(listcomments(i)%label)
        IF(in /= 0) globalparcomments(in)=i
    END DO
 
    npresg=0
    DO i=1,lenpresigmas                 ! pre-sigma values
        presg=listpresigmas(i)%value
        in=inone(listpresigmas(i)%label)
        IF(in /= 0) THEN
            IF(presg > 0.0) npresg=npresg+1 ! FIXME: check if enough 'entries'?
            globalparpresigma(in)=presg     ! insert pre-sigma 0 or > 0
        END IF
    END DO
    WRITE(lunlog,*) 'LOOP1:',npresg,' is number of pre-sigmas'
    WRITE(*,*) 'LOOP1:',npresg,' is number of pre-sigmas'
    IF(npresg == 0) WRITE(*,*) 'Warning: no pre-sigmas defined'
    
    ! build constraint groups, check for redundancy constrints
    CALL grpcon
 
    !     determine flag variable (active) or fixed (inactive) -------------
 
    indab=0
    DO i=1,ntgb
        IF (globalparpresigma(i) < 0.0) THEN
            globalparlabelindex(2,i)=-1     ! fixed (pre-sigma), not used in matrix (not active)
        ELSE IF(globalparlabelcounter(i) < mreqenf) THEN
            globalparlabelindex(2,i)=-2     ! fixed (entries cut), not used in matrix (not active) 
        ELSE IF (globalparcons(i) < 0) THEN           
            globalparlabelindex(2,i)=-4     ! fixed (redundant), not used in matrix (not active)        
        ELSE
            indab=indab+1
            globalparlabelindex(2,i)=indab  ! variable, used in matrix (active)        
        END IF
    END DO
    globalparheader(-6)=indab ! counted variable
    nvgb=indab  ! nr of variable parameters
    WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters'
    IF(iteren > mreqenf) THEN
        IF (mcount == 0) THEN
            CALL loop1i ! iterate entries cut
        ELSE
            WRITE(lunlog,*) 'LOOP1: counting records, NO iteration of entries cut !'
            iteren=0
        END IF
    END IF        
 
    ! --- check for parameter groups
    CALL hmpdef(15,0.0,120.0,'Number of parameters per group')
    ntpgrp=0
    DO j=1,ntgb
        IF (globalparlabelindex(3,j) == 0) cycle ! skip empty parameter
        ! new group?
        IF (globalparlabelindex(1,j) == globalparlabelindex(3,j)) ntpgrp=ntpgrp+1
        globalparlabelindex(4,j)=ntpgrp ! relation total index -> group
    END DO
    ! check variable parameters
    nvpgrp=0
    lgrp=-1
    DO j=1,ntgb
        IF (globalparlabelindex(2,j) <= 0) cycle ! skip fixed parameter
        ! new group ?
        IF (globalparlabelindex(4,j) /= lgrp) nvpgrp=nvpgrp+1
        lgrp=globalparlabelindex(4,j)
    END DO    
    length=ntpgrp; rows=2
    CALL mpalloc(globaltotindexgroups,rows,length,'parameter groups, 1. index and size')
    globaltotindexgroups=0
    ! fill 
    lgrp=-1
    DO j=1,ntgb
        IF (globalparlabelindex(3,j) == 0) cycle ! skip empty parameter
        jgrp=globalparlabelindex(4,j)
        IF (jgrp /= lgrp) globaltotindexgroups(1,jgrp)=j              ! first (total) index
        globaltotindexgroups(2,jgrp)=globaltotindexgroups(2,jgrp)+1   ! (total) size
        lgrp=jgrp
    END DO
    DO j=1,ntpgrp
        CALL hmpent(15,real(globaltotindexgroups(2,j),mps))
    END DO 
    IF(nhistp /= 0) CALL hmprnt(15) ! print histogram
    CALL hmpwrt(15) ! write to his file
    WRITE(lunlog,*) 'LOOP1:',ntpgrp,  &
        ' is total number NTPGRP of label/parameter groups' 
    !print *, ' globalTotIndexGroups ', globalTotIndexGroups   
         
    !     translation table of length NVGB of total global indices ---------
    length=nvgb
    CALL mpalloc(globalparvartototal,length,'translation table  var -> total')
    indab=0
    DO i=1,ntgb
        IF(globalparlabelindex(2,i) > 0) THEN
            indab=indab+1
            globalparvartototal(indab)=i
        END IF
    END DO
    
    !     regularization ---------------------------------------------------
    CALL mpalloc(globalparpreweight,length,'pre-sigmas weights') ! presigma weights
    WRITE(*,112) ' Default pre-sigma =',regpre,  &
        ' (if no individual pre-sigma defined)'
    WRITE(*,*)   'Pre-sigma factor is',regula
 
    IF(nregul == 0) THEN
        WRITE(*,*) 'No regularization will be done'
    ELSE
        WRITE(*,*) 'Regularization will be done, using factor',regula
    END IF
112 FORMAT(a,e9.2,a)
    IF (nvgb <= 0) THEN
        CALL peend(22,'Aborted, no variable global parameters')
        stop '... no variable global parameters'
    ENDIF
 
    DO ivgbi=1,nvgb         ! IVGBI     = index of variable global parameter
        itgbi=globalparvartototal(ivgbi)     ! ITGBI = global parameter index
        presg=globalparpresigma(itgbi)   ! get pre-sigma
        prewt=0.0              ! pre-weight
        IF(presg > 0.0) THEN
            prewt=1.0/presg**2            ! 1/presigma^2
        ELSE IF(presg == 0.0.AND.regpre > 0.0) THEN
            prewt=1.0/real(regpre**2,mpd) ! default 1/presigma^2
        END IF
        globalparpreweight(ivgbi)=regula*prewt    ! weight = factor / presigma^2
    END DO
 
    !      WRITE(*,*) 'GlPa_index  GlPa_label  array1 array6'
    DO i=1,ntgb
        itgbl=globalparlabelindex(1,i)
        ivgbi=globalparlabelindex(2,i)
        IF(ivgbi > 0) THEN
        !          WRITE(*,111) I,ITGBL,QM(IND1+I),QM(IND6+IVGBI)
        ELSE
        !          WRITE(*,111) I,ITGBL,QM(IND1+I)
        END IF
    END DO
    ! 111  FORMAT(I5,I10,F10.5,E12.4)
    WRITE(*,101) 'NTGB',ntgb,'total number of parameters'
    WRITE(*,101) 'NVGB',nvgb,'number of variable parameters'
    ! To avoid INT(mpi) overflows in diagonalization
    IF (metsol == 2.AND.nvgb >= 46340) THEN
        metsol=1
        WRITE(*,101) 'Too many variable parameters for diagonalization, fallback is inversion'
    END IF
 
    !     print overview over important numbers ----------------------------
 
    nrecal=nrec
    IF(mprint /= 0) THEN
        WRITE(*,*) ' '
        WRITE(*,101) '  NREC',nrec,'number of records'
        IF (nrecd > 0) WRITE(*,101) ' NRECD',nrec,'number of records containing doubles'
        WRITE(*,101) '  NEQN',neqn,'number of equations (measurements)'
        WRITE(*,101) '  NEGB',negb,'number of equations with global parameters'
        WRITE(*,101) '  NDGB',ndgb,'number of global derivatives'
        IF (nzgb > 0) THEN
            WRITE(*,101) '  NZGB',nzgb,'number of zero global der. (ignored in entry counts)'
        ENDIF
        IF (mcount == 0) THEN
            WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (eqns in binary files)'
        ELSE
            WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (recs in binary files)'
        ENDIF
        IF(iteren > mreqenf) &
            WRITE(*,101) 'ITEREN',iteren,'iterate cut for parameters with less entries'
        WRITE(*,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)'            
        IF (mreqpe > 1) WRITE(*,101)  &
            'MREQPE',mreqpe,'required number of pair entries'
        IF (msngpe >= 1) WRITE(*,101)  &
            'MSNGPE',msngpe,'max pair entries single prec. storage'
        WRITE(*,101) 'NTGB',ntgb,'total number of parameters'
        WRITE(*,101) 'NVGB',nvgb,'number of variable parameters'
        IF(mprint > 1) THEN
            WRITE(*,*) ' '
            WRITE(*,*) 'Global parameter labels:'
            mqi=ntgb
            IF(mqi <= 100) THEN
                WRITE(*,*) (globalparlabelindex(2,i),i=1,mqi)
            ELSE
                WRITE(*,*) (globalparlabelindex(2,i),i=1,30)
                WRITE(*,*) ' ...'
                mqi=((mqi-20)/20)*20+1
                WRITE(*,*) (globalparlabelindex(2,i),i=mqi,ntgb)
            END IF
        END IF
        WRITE(*,*) ' '
        WRITE(*,*) ' '
    END IF
    WRITE(8,*)   ' '
    WRITE(8,101) '  NREC',nrec,'number of records'
    IF (nrecd > 0) WRITE(8,101) ' NRECD',nrec,'number of records containing doubles'
    WRITE(8,101) '  NEQN',neqn,'number of equations (measurements)'
    WRITE(8,101) '  NEGB',negb,'number of equations with global parameters'
    WRITE(8,101) '  NDGB',ndgb,'number of global derivatives'
    IF (mcount == 0) THEN
        WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (eqns in binary files)'
    ELSE
        WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (recs in binary files)'
    ENDIF
    IF(iteren > mreqenf) &
        WRITE(8,101) 'ITEREN',iteren,'iterate cut for parameters with less entries'
    WRITE(8,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)'
 
    WRITE(lunlog,*) 'LOOP1: ending'
    WRITE(lunlog,*) ' '
    CALL mend
 
101 FORMAT(1x,a8,' =',i14,' = ',a)
END SUBROUTINE loop1
 
SUBROUTINE loop1i
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ibuf
    INTEGER(mpi) :: ij
    INTEGER(mpi) :: indab
    INTEGER(mpi) :: ist
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jsp
    INTEGER(mpi) :: nc31
    INTEGER(mpi) :: nr
    INTEGER(mpi) :: nlow
    INTEGER(mpi) :: nst
    INTEGER(mpi) :: nwrd
 
    INTEGER(mpl) :: length
    INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: newCounter
    SAVE
 
    !     ...
    WRITE(lunlog,*) ' '
    WRITE(lunlog,*) 'LOOP1: iterating'
    WRITE(*,*) ' '
    WRITE(*,*) 'LOOP1: iterating'
 
    length=ntgb
    CALL mpalloc(newcounter,length,'new entries counter')
    newcounter=0
 
    !     define read buffer
    nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
    nwrd=nc31+1
    length=nwrd*mthrdr
    CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
    nwrd=nc31*10+2+ndimbuf
    length=nwrd*mthrdr
    CALL mpalloc(readbufferdatai,length,'read buffer, integer')
    CALL mpalloc(readbufferdatad,length,'read buffer, double')
    ! to read (old) float binary files
    length=(ndimbuf+2)*mthrdr
    CALL mpalloc(readbufferdataf,length,'read buffer, float')
 
    DO
        CALL peread(nr)  ! read records
        CALL peprep(1)  ! prepare records
        DO ibuf=1,numreadbuffer           ! buffer for current record        
            ist=readbufferpointer(ibuf)+1
            nst=readbufferdatai(readbufferpointer(ibuf))
            nwrd=nst-ist+1
            DO ! loop over measurements
                CALL isjajb(nst,ist,ja,jb,jsp)
                IF(ja == 0.AND.jb == 0) EXIT
                IF(ja /= 0) THEN
                    nlow=0
                    DO j=1,ist-jb
                        ij=readbufferdatai(jb+j)                      ! index of global parameter
                        ij=globalparlabelindex(2,ij)        ! change to variable parameter
                        IF(ij == -2) nlow=nlow+1            ! fixed by entries cut
                    END DO
                    IF(nlow == 0) THEN
                        DO j=1,ist-jb
                            ij=readbufferdatai(jb+j)                  ! index of global parameter
                            newcounter(ij)=newcounter(ij)+1 ! count again
                        END DO
                    ENDIF
                END IF
            END DO
            ! end-of-event  
        END DO
        IF(nr <= 0) EXIT ! end of data?
    END DO
 
    !     release read buffer
    CALL mpdealloc(readbufferdataf)
    CALL mpdealloc(readbufferdatad)
    CALL mpdealloc(readbufferdatai)
    CALL mpdealloc(readbufferpointer)
 
    indab=0
    DO i=1,ntgb
        IF(globalparlabelindex(2,i) > 0) THEN
            IF(newcounter(i) >= mreqenf .OR. globalparlabelcounter(i) >= iteren) THEN
                indab=indab+1
                globalparlabelindex(2,i)=indab  ! variable, used in matrix (active)
            ELSE
                globalparlabelindex(2,i)=-3     ! fixed (iterated entries cut), not used in matrix (not active)
            END IF
        END IF
    END DO
    globalparheader(-6)=indab ! counted variable
    nvgb=indab  ! nr of variable parameters
    WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters'
    CALL mpdealloc(newcounter)
 
END SUBROUTINE loop1i
 
 
SUBROUTINE loop2
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    REAL(mps) :: chin2
    REAL(mps) :: chin3
    REAL(mps) :: cpr
    REAL(mps) :: fsum
    REAL(mps) :: gbc
    REAL(mps) :: gbu
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ibuf
    INTEGER(mpi) :: icblst
    INTEGER(mpi) :: icboff
    INTEGER(mpi) :: icgb
    INTEGER(mpi) :: icgrp
    INTEGER(mpi) :: icount
    INTEGER(mpi) :: iext
    INTEGER(mpi) :: ihis
    INTEGER(mpi) :: ij
    INTEGER(mpi) :: ij1
    INTEGER(mpi) :: ijn
    INTEGER(mpi) :: ioff
    INTEGER(mpi) :: ipoff
    INTEGER(mpi) :: iproc
    INTEGER(mpi) :: irecmm
    INTEGER(mpi) :: ist
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: itgbij
    INTEGER(mpi) :: itgbik
    INTEGER(mpi) :: ivgbij
    INTEGER(mpi) :: ivgbik
    INTEGER(mpi) :: ivpgrp
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ja
    INTEGER(mpi) :: jb
    INTEGER(mpi) :: jcgrp
    INTEGER(mpi) :: jext
    INTEGER(mpi) :: jcgb
    INTEGER(mpi) :: jrec
    INTEGER(mpi) :: jsp
    INTEGER(mpi) :: joff
    INTEGER(mpi) :: k
    INTEGER(mpi) :: kcgrp
    INTEGER(mpi) :: kfile
    INTEGER(mpi) :: l
    INTEGER(mpi) :: label
    INTEGER(mpi) :: labelf
    INTEGER(mpi) :: labell
    INTEGER(mpi) :: lvpgrp
    INTEGER(mpi) :: lu
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: maeqnf
    INTEGER(mpi) :: nall
    INTEGER(mpi) :: naeqna
    INTEGER(mpi) :: naeqnf
    INTEGER(mpi) :: naeqng
    INTEGER(mpi) :: npdblk
    INTEGER(mpi) :: nc31
    INTEGER(mpi) :: ncachd
    INTEGER(mpi) :: ncachi
    INTEGER(mpi) :: ncachr
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: nda
    INTEGER(mpi) :: ndf
    INTEGER(mpi) :: ndfmax
    INTEGER(mpi) :: nfixed
    INTEGER(mpi) :: nggd
    INTEGER(mpi) :: nggi
    INTEGER(mpi) :: nmatmo
    INTEGER(mpi) :: noff
    INTEGER(mpi) :: npair
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: nparmx
    INTEGER(mpi) :: nr
    INTEGER(mpi) :: nrece
    INTEGER(mpi) :: nrecf
    INTEGER(mpi) :: nrecmm
    INTEGER(mpi) :: nst
    INTEGER(mpi) :: nwrd
    INTEGER(mpi) :: inone
    INTEGER(mpi) :: inc
    REAL(mps) :: wgh
    REAL(mps) :: wolfc3
    REAL(mps) :: wrec
    REAL(mps) :: chindl
 
    REAL(mpd)::dstat(3)
    REAL(mpd)::rerr
    INTEGER(mpl):: nblock
    INTEGER(mpl):: nbwrds
    INTEGER(mpl):: noff8
    INTEGER(mpl):: ndimbi
    INTEGER(mpl):: ndimsa(4)
    INTEGER(mpl):: ndgn
    INTEGER(mpl):: nnzero
    INTEGER(mpl):: matsiz(2)
    INTEGER(mpl):: matwords
    INTEGER(mpl):: mbwrds
    INTEGER(mpl):: length
    INTEGER(mpl):: rows
    INTEGER(mpl):: cols
    INTEGER(mpl), PARAMETER :: two=2
    INTEGER(mpi) :: maxGlobalPar = 0
    INTEGER(mpi) :: maxLocalPar = 0
    INTEGER(mpi) :: maxEquations = 0
    
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsGroupList
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsGroupIndex
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecPairedParGroups
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecBlockCounts
 
    INTERFACE ! needed for assumed-shape dummy arguments
        SUBROUTINE ndbits(npgrp,ndims,nsparr,ihst)
            USE mpdef
            INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
            INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims
            INTEGER(mpl), DIMENSION(:,:), INTENT(OUT) :: nsparr
            INTEGER(mpi), INTENT(IN) :: ihst
        END SUBROUTINE ndbits
        SUBROUTINE ckbits(npgrp,ndims)
            USE mpdef
            INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
            INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims
        END SUBROUTINE ckbits
        SUBROUTINE spbits(npgrp,nsparr,nsparc)
            USE mpdef
            INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
            INTEGER(mpl), DIMENSION(:,:), INTENT(IN) :: nsparr
            INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: nsparc
        END SUBROUTINE spbits
        SUBROUTINE gpbmap(ngroup,npgrp,npair)
            USE mpdef
            INTEGER(mpi), INTENT(IN) :: ngroup
            INTEGER(mpi), DIMENSION(:,:), INTENT(IN) :: npgrp
            INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npair
        END SUBROUTINE gpbmap
        SUBROUTINE ggbmap(ipgrp,npair,npgrp)
            USE mpdef
            INTEGER(mpi), INTENT(IN) :: ipgrp
            INTEGER(mpi), INTENT(OUT) :: npair
            INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npgrp
        END SUBROUTINE ggbmap
        SUBROUTINE pbsbits(npgrp,ibsize,nnzero,nblock,nbkrow)
            USE mpdef
            INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
            INTEGER(mpi), INTENT(IN) :: ibsize
            INTEGER(mpl), INTENT(OUT) :: nnzero
            INTEGER(mpl), INTENT(OUT) :: nblock
            INTEGER(mpi), DIMENSION(:),INTENT(OUT) :: nbkrow
        END SUBROUTINE pbsbits
        SUBROUTINE pblbits(npgrp,ibsize,nsparr,nsparc)
            USE mpdef
            INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
            INTEGER(mpi), INTENT(IN) :: ibsize
            INTEGER(mpl), DIMENSION(:), INTENT(IN) :: nsparr
            INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparc
        END SUBROUTINE pblbits
        SUBROUTINE prbits(npgrp,nsparr)
            USE mpdef
            INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
            INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparr
        END SUBROUTINE prbits
        SUBROUTINE pcbits(npgrp,nsparr,nsparc)
            USE mpdef
            INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
            INTEGER(mpl), DIMENSION(:), INTENT(IN) :: nsparr
            INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparc
        END SUBROUTINE pcbits
    END INTERFACE
    
    SAVE
 
    !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
 
    !     ...
    WRITE(lunlog,*) ' '
    WRITE(lunlog,*) 'LOOP2: starting'
    CALL mstart('LOOP2')
 
    !     two subarrays to get the global parameter indices, used in an event
    length=nvgb
    CALL mpalloc(globalindexusage,length,'global index')
    CALL mpalloc(backindexusage,length,'back index')
    backindexusage=0
    CALL mpalloc(globalindexranges,length,'global index ranges')
    globalindexranges=0
    
    length=ntgb
    CALL mpalloc(globalparlabelzeros,length,'global label with zero der. counters')
    globalparlabelzeros=0
 
    ! prepare constraints - determine number of constraints NCGB
    !                     - sort and split into blocks
    !                     -  update globalIndexRanges
    CALL prpcon
 
    IF (metsol == 3.AND.icelim <= 0) THEN
        ! decomposition: enforce elimination
        icelim=1
        WRITE(lunlog,*) ' Elimination for constraints enforced for solution by decomposition!'
    END IF
    IF (metsol == 9.AND.icelim > 0) THEN
        ! sparsePARDISO: enforce multipliers
        icelim=0
        WRITE(lunlog,*) ' Lagrange multipliers enforced for solution by sparsePARDISO!'
    END IF
    IF (matsto > 0.AND.icelim > 1) THEN
        ! decomposition: enforce elimination
        icelim=1
        WRITE(lunlog,*) ' Elimination for constraints with mpqldec enforced (LAPACK only for unpacked storage)!'
    END IF
    IF (icelim > 0) THEN ! elimination
        nagb=nvgb          ! total number of parameters
        napgrp=nvpgrp      ! total number of parameter groups
        nfgb=nvgb-ncgb     ! number of fit parameters
        nprecond(1)=0      ! number of constraints for preconditioner
        nprecond(2)=nfgb   ! matrix size for preconditioner
        nprecond(3)=0      ! number of constraint blocks for preconditioner
    ELSE                 ! Lagrange multipliers
        nagb=nvgb+ncgb     ! total number of parameters
        napgrp=nvpgrp+ncgb ! total number of parameter groups
        nfgb=nagb          ! number of fit parameters
        nprecond(1)=ncgb   ! number of constraints for preconditioner
        nprecond(2)=nvgb   ! matrix size for preconditioner
        nprecond(3)=ncblck ! number of constraint blocks for preconditioner
    ENDIF
    noff8=int(nagb,mpl)*int(nagb-1,mpl)/2
    
    ! all (variable) parameter groups 
    length=napgrp+1
    CALL mpalloc(globalallindexgroups,length,'all parameter groups, 1. index')
    globalallindexgroups=0
    ivpgrp=0
    lvpgrp=-1
    DO i=1,ntgb
        ij=globalparlabelindex(2,i)
        IF (ij <= 0) cycle ! variable ?
        IF (globalparlabelindex(4,i) /= lvpgrp) THEN
            ivpgrp=ivpgrp+1
            globalallindexgroups(ivpgrp)=ij ! first index
            lvpgrp=globalparlabelindex(4,i)
        END IF
    END DO
    ! Lagrange multipliers
    IF (napgrp > nvpgrp) THEN
        DO jcgb=1, ncgb
            ivpgrp=ivpgrp+1
            globalallindexgroups(ivpgrp)=nvgb+jcgb
        END DO
    END IF
    globalallindexgroups(napgrp+1)=nagb+1
    ! from all (variable) parameters to group
    length=nagb
    CALL mpalloc(globalallpartogroup,length,'translation table all (var) par -> group')
    globalallpartogroup=0
    DO i=1,napgrp
        DO j=globalallindexgroups(i),globalallindexgroups(i+1)-1
            globalallpartogroup(j)=i
        END DO 
    END DO
    IF (icheck > 2) THEN
        print *
        print *, ' Variable parameter groups ', nvpgrp
        DO i=1,nvpgrp
            itgbi=globalparvartototal(globalallindexgroups(i))
            k=globalparlabelindex(4,itgbi) ! (total) group index
            print *, i,k,globalallindexgroups(i),globalallindexgroups(i+1)-globalallindexgroups(i), &
                globalparlabelindex(1,itgbi)
        END DO
        print *
    END IF 
        
    !     read all data files and add all variable index pairs -------------
 
    IF (icheck > 1) CALL clbmap(ntpgrp+ncgrp)
 
    IF(matsto == 2) THEN
        ! MINRES, sparse storage
        CALL clbits(napgrp,mreqpe,mhispe,msngpe,mextnd,ndimbi,nspc) ! get dimension for bit storage, encoding, precision info
    END IF
    IF(matsto == 3) THEN
        ! PARDISO, upper triangle (parameter groups) incl. rectangular part (constraints)
        CALL plbits(nvpgrp,nvgb,ncgb,ndimbi) ! get dimension for bit storage, global parameters and constraints
    END IF
 
    IF (imonit /= 0) THEN
        length=ntgb
        CALL mpalloc(measindex,length,'measurement counter/index')
        measindex=0
        CALL mpalloc(measres,length,'measurement resolution')
        measres=0.0_mps
        lunmon=9
        CALL mvopen(lunmon,'millepede.mon')
    ENDIF
 
    ! for checking appearance 
    IF (icheck > 1) THEN
        length=5*(ntgb+ncgrp)
        CALL mpalloc(appearancecounter,length,'appearance statistics')
        appearancecounter=0
        length=ntgb
        CALL mpalloc(paircounter,length,'pair statistics')
        paircounter=0
    END IF
    
    ! checking constraint goups
    IF (icheck > 0.AND. ncgrp > 0) THEN
        length=ncgrp
        CALL mpalloc(vecconsgroupcounts,length,'counter for constraint groups')
        vecconsgroupcounts=0
        CALL mpalloc(vecconsgrouplist,length,'constraint group list')
        CALL mpalloc(vecconsgroupindex,length,'constraint group index')
        vecconsgroupindex=0
    END IF
 
    !     reading events===reading events===reading events===reading events=
    nrece =0  ! 'empty' records (no variable global parameters)
    nrecf =0  ! records with fixed global parameters
    naeqng=0  ! count number of equations (with global der.)
    naeqnf=0  ! count number of equations ( " , fixed)
    naeqna=0  ! all
    WRITE(lunlog,*) 'LOOP2: start event reading'
    !     monitoring for sparse matrix?
    irecmm=0
    IF (matsto == 2.AND.matmon /= 0) THEN
        nmatmo=0
        IF (matmon > 0) THEN
            nrecmm=matmon
        ELSE
            nrecmm=1
        END IF
    END IF
    DO k=1,3
        dstat(k)=0.0_mpd
    END DO
    !     define read buffer
    nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
    nwrd=nc31+1
    length=nwrd*mthrdr
    CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
    nwrd=nc31*10+2+ndimbuf
    length=nwrd*mthrdr
    CALL mpalloc(readbufferdatai,length,'read buffer, integer')
    CALL mpalloc(readbufferdatad,length,'read buffer, real')
    ! to read (old) float binary files
    length=(ndimbuf+2)*mthrdr
    CALL mpalloc(readbufferdataf,length,'read buffer, float')   
 
    DO
        CALL peread(nr) ! read records
        CALL peprep(1)  ! prepare records
        ioff=0
        DO ibuf=1,numreadbuffer           ! buffer for current record
            jrec=readbufferdatai(readbufferpointer(ibuf)-1)          ! record number in file
            kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
            nrec=ifd(kfile)+jrec                                     ! global record number
            !     Printout for DEBUG
            IF(nrec <= mdebug) THEN
                nda=0
                wrec =real(readbufferdatad(readbufferpointer(ibuf)-1),mps) ! weight
                WRITE(*,*) ' '
                WRITE(*,*) 'Record number ',nrec,' from file ',kfile
                IF (wgh /= 1.0) WRITE(*,*) '       weight ',wrec
                ist=readbufferpointer(ibuf)+1
                nst=readbufferdatai(readbufferpointer(ibuf))
                DO ! loop over measurements
                    CALL isjajb(nst,ist,ja,jb,jsp)
                    IF(ja == 0) EXIT
                    nda=nda+1
                    IF(nda > mdebg2) THEN
                        IF(nda == mdebg2+1)  WRITE(*,*) '... and more data'
                        cycle
                    END IF
                    WRITE(*,*) ' '
                    WRITE(*,*) nda, ' Measured value =',readbufferdatad(ja),' +- ',readbufferdatad(jb)
                    WRITE(*,*) 'Local derivatives:'
                    WRITE(*,107) (readbufferdatai(ja+j),readbufferdatad(ja+j),j=1,jb-ja-1)
107                 FORMAT(6(i3,g12.4))
                    IF (jb < ist) THEN
                        WRITE(*,*) 'Global derivatives:'
                        WRITE(*,108) (globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j),  &
                            globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
108                     FORMAT(3i11,g12.4)
                    END IF
                    IF(nda == 1) THEN
                        WRITE(*,*) 'total_par_label  __label__   var_par_index   derivative'
                    END IF
                END DO
                WRITE(*,*) ' '
            END IF
  
            nagbn =0                     ! count number of global derivatives
            nalcn =0                     ! count number of local  derivatives
            naeqn =0                     ! count number of equations
            icgrp =0                     ! count constraint groups
            maeqnf=naeqnf
            ist=readbufferpointer(ibuf)+1
            nst=readbufferdatai(readbufferpointer(ibuf))
            nwrd=nst-ist+1
            DO ! loop over measurements
                CALL isjajb(nst,ist,ja,jb,jsp)
                IF(ja == 0.AND.jb == 0) EXIT
                naeqn=naeqn+1
                naeqna=naeqna+1
                IF(ja /= 0) THEN
                    IF (ist > jb) THEN
                        naeqng=naeqng+1
                        ! monitoring, group measurements, sum up entries and errors
                        IF (imonit /= 0) THEN
                            rerr =real(readbufferdatad(jb),mpd)     ! the error
                            ij=readbufferdatai(jb+1)               ! index of first global parameter, used to group measurements
                            measindex(ij)=measindex(ij)+1
                            measres(ij)=measres(ij)+rerr
                        END IF
                    END IF    
                    nfixed=0
                    DO j=1,ist-jb
                        ij=readbufferdatai(jb+j)                     ! index of global parameter
                        IF (nzgb > 0) THEN
                            ! count zero global derivatives
                            IF (readbufferdatad(jb+j) == 0.0_mpl) globalparlabelzeros(ij)=globalparlabelzeros(ij)+1
                        END IF
                        ! check appearance 
                        IF (icheck > 1) THEN
                            joff = 5*(ij-1)
                            kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
                            IF (appearancecounter(joff+1) == 0) THEN
                                appearancecounter(joff+1) = kfile
                                appearancecounter(joff+2) = jrec ! (local) record number
                            END IF
                            IF (appearancecounter(joff+3) /= kfile) appearancecounter(joff+5)=appearancecounter(joff+5)+1
                            appearancecounter(joff+3) = kfile
                            appearancecounter(joff+4) = jrec ! (local) record number
                            ! count pairs
                            DO k=1,j
                                CALL inbmap(globalparlabelindex(4,ij),globalparlabelindex(4,readbufferdatai(jb+k)))
                            END DO
                            jcgrp=globalparcons(ij)
                            ! correlate constraint groups with 'other' parameter groups
                            DO k=1,j
                                kcgrp=globalparcons(readbufferdatai(jb+k))
                                IF (kcgrp == jcgrp) cycle 
                                IF (jcgrp > 0) CALL inbmap(ntpgrp+jcgrp,globalparlabelindex(4,readbufferdatai(jb+k)))
                                IF (kcgrp > 0) CALL inbmap(ntpgrp+kcgrp,globalparlabelindex(4,ij))
                            END DO
                        END IF
                        ! check constraint groups
                        IF (icheck > 0.AND.ncgrp > 0) THEN
                            k=globalparcons(ij) ! constraint group
                            IF (k > 0) THEN
                                icount=naeqn
                                IF (mcount > 0) icount=1 ! count records 
                                IF (vecconsgroupindex(k) == 0) THEN
                                    ! add to list
                                    icgrp=icgrp+1
                                    vecconsgrouplist(icgrp)=k
                                    ! check appearance 
                                    IF (icheck > 1) THEN
                                        joff = 5*(ntgb+k-1)
                                        kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
                                        IF (appearancecounter(joff+1) == 0) THEN
                                            appearancecounter(joff+1) = kfile
                                            appearancecounter(joff+2) = jrec ! (local) record number
                                        END IF
                                        IF (appearancecounter(joff+3) /= kfile) appearancecounter(joff+5)=&
                                            appearancecounter(joff+5)+1
                                        appearancecounter(joff+3) = kfile
                                        appearancecounter(joff+4) = jrec ! (local) record number
                                    END IF
                                END IF
                                IF (vecconsgroupindex(k) < icount) THEN
                                    ! count
                                    vecconsgroupindex(k)=icount
                                    vecconsgroupcounts(k)=vecconsgroupcounts(k)+1
                                END IF
                            END IF
                        END IF
                        
                        ij=globalparlabelindex(2,ij)       ! change to variable parameter
                        IF(ij > 0) THEN
                            ijn=backindexusage(ij)         ! get index of index
                            IF(ijn == 0) THEN              ! not yet included
                                nagbn=nagbn+1              ! count
                                globalindexusage(nagbn)=ij ! store variable index
                                backindexusage(ij)=nagbn   ! store back index
                            END IF
                        ELSE
                            nfixed=nfixed+1
                        END IF
                    END DO
                    IF (nfixed > 0) naeqnf=naeqnf+1
                END IF
  
                IF(ja /= 0.AND.jb /= 0) THEN
                    DO j=1,jb-ja-1           ! local parameters
                        ij=readbufferdatai(ja+j)
                        nalcn=max(nalcn,ij)
                    END DO
                END IF
            END DO
              
            ! end-of-event
            IF (naeqnf > maeqnf) nrecf=nrecf+1
            irecmm=irecmm+1
            !     end-of-event-end-of-event-end-of-event-end-of-event-end-of-event-e
  
            maxglobalpar=max(nagbn,maxglobalpar) ! maximum number of global parameters
            maxlocalpar=max(nalcn,maxlocalpar)   ! maximum number of local parameters
            maxequations=max(naeqn,maxequations) ! maximum number of equations
  
            !     sample statistics for caching
            dstat(1)=dstat(1)+real((nwrd+2)*2,mpd)               ! record size
            dstat(2)=dstat(2)+real(nagbn+2,mpd)                  ! indices,
            dstat(3)=dstat(3)+real(nagbn*nagbn+nagbn,mpd)        ! data for MUPDAT
 
            ! clear constraint groups index
            DO k=1, icgrp
                vecconsgroupindex(vecconsgrouplist(k))=0
            END DO
            
            CALL sort1k(globalindexusage,nagbn) ! sort global par.
  
            IF (nagbn == 0) THEN
                nrece=nrece+1
            ELSE
                ! update parameter range
                globalindexranges(globalindexusage(1))=&
                    max(globalindexranges(globalindexusage(1)),globalindexusage(nagbn))
            ENDIF
            
            ! overwrite read buffer with lists of global labels
            ioff=ioff+1
            readbufferpointer(ibuf)=ioff
            readbufferdatai(ioff)=ioff+nagbn
            joff=ioff
            lvpgrp=-1
            DO i=1,nagbn                  ! reset global index array, store parameter groups
                iext=globalindexusage(i)
                backindexusage(iext)=0
                ivpgrp=globalallpartogroup(iext)
                !ivpgrp=iext
                IF (ivpgrp /= lvpgrp) THEN
                    joff=joff+1
                    readbufferdatai(joff)=ivpgrp
                    lvpgrp=ivpgrp
                END IF    
            END DO
            readbufferdatai(ioff)=joff
            ioff=joff
  
        END DO
        ioff=0
 
        IF (matsto == 3) THEN
            !$OMP  PARALLEL &
            !$OMP  DEFAULT(PRIVATE) &
            !$OMP  SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD)
            iproc=0
            !$ IPROC=OMP_GET_THREAD_NUM()         ! thread number
            DO ibuf=1,numreadbuffer
                ist=readbufferpointer(ibuf)+1
                nst=readbufferdatai(readbufferpointer(ibuf))
                DO i=ist,nst                 ! store all combinations
                    iext=readbufferdatai(i)             ! variable global index
                    !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN  ! distinct column per thread
                    DO l=i,nst
                        jext=readbufferdatai(l)
                        CALL inbits(iext,jext,1) ! save space
                    END DO
                    !$ ENDIF
                END DO
            END DO
            !$OMP END PARALLEL
        END IF
        IF (matsto == 2) THEN
            !$OMP  PARALLEL &
            !$OMP  DEFAULT(PRIVATE) &
            !$OMP  SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD)
            iproc=0
            !$ IPROC=OMP_GET_THREAD_NUM()         ! thread number
            DO ibuf=1,numreadbuffer
                ist=readbufferpointer(ibuf)+1
                nst=readbufferdatai(readbufferpointer(ibuf))
                DO i=ist,nst                 ! store all combinations
                    iext=readbufferdatai(i)             ! variable global index
                    !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN  ! distinct rows per thread
                    DO l=ist,i
                        jext=readbufferdatai(l)
                        CALL inbits(iext,jext,1) ! save space
                    END DO
                    !$ ENDIF
                END DO
            END DO
            !$OMP END PARALLEL
            ! monitoring
            IF (matmon /= 0.AND.  &
                (irecmm >= nrecmm.OR.irecmm == mxrec)) THEN
                IF (nmatmo == 0) THEN
                    WRITE(*,*)
                    WRITE(*,*) 'Monitoring of sparse matrix construction'
                    WRITE(*,*) ' records ........ off-diagonal elements ',  &
                        '....... compression   memory'
                    WRITE(*,*) '             non-zero used(double)  used',  &
                        '(float)       [%]       [GB]'
                END IF
                nmatmo=nmatmo+1
                CALL ckbits(globalallindexgroups,ndimsa)
                gbc=1.0e-9*real((mpi*ndimsa(2)+mpd*ndimsa(3)+mps*ndimsa(4))/mpi*(bit_size(1_mpi)/8),mps) ! GB compressed
                gbu=1.0e-9*real(((mpi+mpd)*(ndimsa(3)+ndimsa(4)))/mpi*(bit_size(1_mpi)/8),mps)             ! GB uncompressed
                cpr=100.0*gbc/gbu
                WRITE(*,1177) irecmm,ndimsa(1),ndimsa(3),ndimsa(4),cpr,gbc
1177            FORMAT(i9,3i13,f10.2,f11.6)
                DO WHILE(irecmm >= nrecmm)
                    IF (matmon > 0) THEN
                        nrecmm=nrecmm+matmon
                    ELSE
                        nrecmm=nrecmm*2
                    END IF
                END DO
            END IF
 
        END IF
 
        IF (nr <= 0) EXIT ! next block of events ?
    END DO
    !     release read buffer
    CALL mpdealloc(readbufferdataf)
    CALL mpdealloc(readbufferdatad)
    CALL mpdealloc(readbufferdatai)
    CALL mpdealloc(readbufferpointer)
 
    WRITE(lunlog,*) 'LOOP2: event reading ended - end of data'
    DO k=1,3
        dstat(k)=dstat(k)/real(nrec,mpd)
    END DO
    !     end=of=data=end=of=data=end=of=data=end=of=data=end=of=data=end=of
 
    IF (icheck > 0.AND. ncgrp > 0) THEN
        CALL mpdealloc(vecconsgroupindex)
        CALL mpdealloc(vecconsgrouplist)
    END IF
        
    IF (icheck > 1) THEN
        CALL gpbmap(ntpgrp,globaltotindexgroups,paircounter)
    END IF 
    IF (icheck > 3) THEN
        length=ntpgrp+ncgrp
        CALL mpalloc(vecpairedpargroups,length,'paired global parameter groups (I)')
        print *
        print *, ' Total parameter groups pairs', ntpgrp
        DO i=1,ntpgrp
            itgbi=globaltotindexgroups(1,i)
            CALL ggbmap(i,npair,vecpairedpargroups)
            k=globalparlabelindex(4,itgbi) ! (total) group index
            print *, i, itgbi, globalparlabelindex(1,itgbi), npair, ':', vecpairedpargroups(:npair)
        END DO
        print *
    END IF
    
    ! check constraints
    IF(matsto == 2) THEN
          
        !     constraints and index pairs with Lagrange multiplier
        inc=max(mreqpe, msngpe+1) !  keep constraints in double precision
 
        !  loop over (sorted) constraints
        DO jcgb=1,ncgb
            icgb=matconssort(3,jcgb) ! unsorted constraint index
            DO i=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
                label=listconstraints(i)%label
                itgbi=inone(label)
                ij=globalparlabelindex(2,itgbi)         ! change to variable parameter
                IF(ij > 0 .AND. nagb > nvgb) THEN
                    CALL inbits(globalallpartogroup(nvgb+jcgb),globalallpartogroup(ij),inc)
                END IF
            END DO
        END DO
    END IF
    IF(matsto == 3) THEN
        !  loop over (sorted) constraints
        DO jcgb=1,ncgb
            icgb=matconssort(3,jcgb) ! unsorted constraint index
            DO i=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
                label=listconstraints(i)%label
                itgbi=inone(label)
                ij=globalparlabelindex(2,itgbi)         ! change to variable parameter
                IF(ij > 0.AND.listconstraints(i)%value /= 0.0_mpd) THEN
                    ! non-zero coefficient
                    CALL irbits(ij,jcgb)
                END IF
            END DO
        END DO
    END IF
 
    ! check measurements
    IF(matsto == 2 .OR. matsto == 3) THEN
        !     measurements - determine index-pairs
  
        i=1
        DO WHILE (i <= lenmeasurements)
            i=i+2
            !        loop over label/factor pairs
            ia=i
            DO
                i=i+1
                IF(i > lenmeasurements) EXIT
                IF(listmeasurements(i)%label < 0) EXIT
            END DO
            ib=i-1
  
            DO j=ia,ib
                itgbij=inone(listmeasurements(j)%label) ! total parameter index
                !         first index
                ivgbij=0
                IF(itgbij /= 0) ivgbij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
                DO k=ia,j
                    itgbik=inone(listmeasurements(k)%label) ! total parameter index
                    !         second index
                    ivgbik=0
                    IF(itgbik /= 0) ivgbik=globalparlabelindex(2,itgbik) ! -> index of variable global parameter
                    IF(ivgbij > 0.AND.ivgbik > 0) THEN
                        CALL inbits(globalallpartogroup(ivgbij),globalallpartogroup(ivgbik),mreqpe)
                        IF (mprint > 1) WRITE(*,*) 'add index pair ',ivgbij,ivgbik
                    END IF
                END DO
            END DO
 
        END DO
    ELSE
        ! more checks for block diagonal structure  
        ! loop over measurements
        i=1
        DO WHILE (i <= lenmeasurements)
            i=i+2
            !        loop over label/factor pairs
            ia=i
            DO
                i=i+1
                IF(i > lenmeasurements) EXIT
                IF(listmeasurements(i)%label < 0) EXIT
            END DO
            ib=i-1
            ij1=nvgb
            ijn=1  
            DO j=ia,ib
                itgbij=inone(listmeasurements(j)%label) ! total parameter index
                !         first index
                ij=0
                IF(itgbij /= 0) ij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
                IF (ij > 0) THEN
                    ij1=min(ij1,ij)
                    ijn=max(ijn,ij)
                END IF                
            END DO
            globalindexranges(ij1)=max(globalindexranges(ij1),ijn)
        END DO
        
    END IF
 
    nummeas=0 ! number of measurement groups
    IF (imonit /= 0) THEN
        DO i=1,ntgb
            IF (measindex(i) > 0) THEN
                nummeas=nummeas+1
                measres(i) = measres(i)/real(measindex(i),mpd)
                measindex(i) = nummeas
            END IF
        END DO
        length=nummeas*mthrd*measbins
        CALL mpalloc(meashists,length,'measurement counter')
    END IF
    
    !     check for block diagonal structure, count blocks
    npblck=0
    l=0
    DO i=1,nvgb
        IF (i > l) npblck=npblck+1
        l=max(l,globalindexranges(i))
        globalindexranges(i)=npblck ! block number    
    END DO
    
    length=npblck+1; rows=2
    ! parameter blocks 
    CALL mpalloc(matparblockoffsets,rows,length,'global parameter blocks (I)')
    matparblockoffsets=0
    CALL mpalloc(vecparblockconoffsets,length,'global parameter blocks (I)')
    vecparblockconoffsets=0
    ! fill matParBlocks
    l=0
    DO i=1,nvgb
        IF (globalindexranges(i) > l) THEN
            l=globalindexranges(i) ! block number
            matparblockoffsets(1,l)=i-1 ! block offset
        END IF    
    END DO
    matparblockoffsets(1,npblck+1)=nvgb
    nparmx=0
    DO i=1,npblck
        rows=matparblockoffsets(1,i+1)-matparblockoffsets(1,i)
        nparmx=max(nparmx,int(rows,mpi))
    END DO
 
    ! connect constraint blocks
    DO i=1,ncblck
        ia=matconsblocks(2,i) ! first parameter in constraint block
        IF (ia > matconsblocks(3,i)) cycle
        ib=globalindexranges(ia) ! parameter block number
        matparblockoffsets(2,ib+1)=i
    END DO 
 
    ! use diagonal block matrix storage?
    IF (npblck > 1) THEN
        IF (icheck > 0) THEN
            WRITE(*,*)
            DO i=1,npblck
                ia=matparblockoffsets(1,i)
                ib=matparblockoffsets(1,i+1)
                ja=matparblockoffsets(2,i)
                jb=matparblockoffsets(2,i+1)            
                labelf=globalparlabelindex(1,globalparvartototal(ia+1))
                labell=globalparlabelindex(1,globalparvartototal(ib))
                WRITE(*,*) ' Parameter block', i, ib-ia, jb-ja, labelf, labell
            ENDDO    
        ENDIF
        WRITE(lunlog,*)
        WRITE(lunlog,*) 'Detected', npblck, '(disjoint) parameter blocks, max size ', nparmx     
        WRITE(*,*)
        WRITE(*,*) 'Detected', npblck, '(disjoint) parameter blocks, max size ', nparmx
        IF ((metsol == 1.OR.metsol == 3.OR.metsol>=7).AND.nagb == nvgb) THEN
            WRITE(*,*) 'Using block diagonal storage mode'
        ELSE
            ! keep single block = full matrix
            DO i=1,2
                matparblockoffsets(i,2)=matparblockoffsets(i,npblck+1) 
            END DO
            npblck=1
            DO i=1,nvgb
                globalindexranges(i)=1
            END DO
        END IF        
    END IF   
   
    !     print numbers ----------------------------------------------------
 
    IF (nagb >= 65536) THEN
        noff=int(noff8/1000,mpi)
    ELSE
        noff=int(noff8,mpi)
    END IF
    ndgn=0
    matwords=0
    IF(matsto == 2) THEN
        ihis=0
        IF (mhispe > 0) THEN
            ihis=15
            CALL hmpdef(ihis,0.0,real(mhispe,mps), 'NDBITS: #off-diagonal elements')
        END IF
        length=(napgrp+1)*nspc
        CALL mpalloc(sparsematrixoffsets,two,length, 'sparse matrix row offsets')
        CALL ndbits(globalallindexgroups,ndimsa,sparsematrixoffsets,ihis)
        ndgn=ndimsa(3)+ndimsa(4) ! actual number of off-diagonal elements
        matwords=ndimsa(2)+length*4 ! size of sparsity structure
    
        IF (mhispe > 0) THEN
            IF (nhistp /= 0) CALL hmprnt(ihis)
            CALL hmpwrt(ihis)
        END IF
    END IF
    IF (matsto == 3) THEN
        length=nagb+1
        CALL mpalloc(csr3rowoffsets,length, 'sparse matrix row offsets (CSR3)')
        IF (mpdbsz > 1) THEN
            ! BSR3, check (for optimal) block size
            mbwrds=0
            DO i=1,mpdbsz
                npdblk=(nagb-1)/ipdbsz(i)+1
                length=int(npdblk,mpl)
                CALL mpalloc(vecblockcounts,length, 'sparse matrix row offsets (CSR3)')
                CALL pbsbits(globalallindexgroups,ipdbsz(i),nnzero,nblock,vecblockcounts)
                nbwrds=2*int(nblock,mpl)*int(ipdbsz(i)*ipdbsz(i)+1,mpl) ! number of words needed
                IF ((i == 1).OR.(nbwrds < mbwrds)) THEN
                    matbsz=ipdbsz(i)
                    mbwrds=nbwrds
                    csr3rowoffsets(1)=1
                    DO k=1,npdblk
                        csr3rowoffsets(k+1)=csr3rowoffsets(k)+vecblockcounts(k)
                    END DO
                END IF
                CALL mpdealloc(vecblockcounts)
            END DO
        ELSE
            ! CSR3
            CALL prbits(globalallindexgroups,csr3rowoffsets)
            !csr3RowOffsets(nvgb+2:)=csr3RowOffsets(nvgb+1) ! Lagrange multipliers (empty)
        END IF
    END IF
 
    nagbn=maxglobalpar ! max number of global parameters in one event
    nalcn=maxlocalpar  ! max number of local parameters in one event
    naeqn=maxequations ! max number of equations in one event
    CALL mpdealloc(globalindexusage)
    CALL mpdealloc(backindexusage)
    !     matrices for event matrices
    !       split up cache
    IF (fcache(2) == 0.0) THEN ! from data (DSTAT)
        fcache(1)=real(dstat(1),mps)*fcache(1) ! leave some part free for fluctuations
        fcache(2)=real(dstat(2),mps)
        fcache(3)=real(dstat(3),mps)
    END IF
    fsum=fcache(1)+fcache(2)+fcache(3)
    DO k=1,3
        fcache(k)=fcache(k)/fsum
    END DO
    ncachr=nint(real(ncache,mps)*fcache(1),mpi) ! read cache
    !     define read buffer
    nc31=ncachr/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
    nwrd=nc31+1
    length=nwrd*mthrdr
    CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
    nwrd=nc31*10+2+ndimbuf
    length=nwrd*mthrdr
    CALL mpalloc(readbufferdatai,length,'read buffer, integer')
    CALL mpalloc(readbufferdatad,length,'read buffer, real')
    ! to read (old) float binary files
    length=(ndimbuf+2)*mthrdr
    CALL mpalloc(readbufferdataf,length,'read buffer, float')
 
    ncachi=nint(real(ncache,mps)*fcache(2),mpi) ! index cache
    ncachd=ncache-ncachr-ncachi              ! data cache
    nggd=(nagbn*nagbn+nagbn)/2+ncachd/(2*mthrd) ! number of double
    nggi=2+nagbn+ncachi/mthrd                   ! number of ints
    length=nagbn*mthrd
    CALL mpalloc(globalindexusage,length, 'global parameters (dim =max/event)')
    length=nvgb*mthrd
    CALL mpalloc(backindexusage,length,'global variable-index array')
    backindexusage=0
    length=nagbn*nalcn
    CALL mpalloc(localglobalmatrix,length,'local/global matrix, content')
    CALL mpalloc(localglobalmap,length,'local/global matrix, map (counts)')
    length=2*nagbn*nalcn+nagbn+nalcn+1
    CALL mpalloc(localglobalstructure,length,'local/global matrix, (sparsity) structure')
    length=nggd*mthrd
    CALL mpalloc(writebufferupdates,length,'symmetric update matrices')
    writebufferheader(-1)=nggd                  ! number of words per thread
    writebufferheader(-2)=(nagbn*nagbn+nagbn)/2 ! min free (double) words
    length=nggi*mthrd
    CALL mpalloc(writebufferindices,length,'symmetric update matrix indices')
    rows=9; cols=mthrd
    CALL mpalloc(writebufferinfo,rows,cols,'write buffer status (I)')
    rows=2; cols=mthrd
    CALL mpalloc(writebufferdata,rows,cols,'write buffer status (F)')
    writebufferheader(1)=nggi                  ! number of words per thread
    writebufferheader(2)=nagbn+3               ! min free words
 
    !     print all relevant dimension parameters
 
    DO lu=6,8,2  ! unit 6 and 8
  
        WRITE(lu,*) ' '
        WRITE(lu,101) 'NTGB',ntgb,'total number of parameters'
        WRITE(lu,102) '(all parameters, appearing in binary files)'
        WRITE(lu,101) 'NVGB',nvgb,'number of variable parameters'
        WRITE(lu,102) '(appearing in fit matrix/vectors)'
        WRITE(lu,101) 'NAGB',nagb,'number of all parameters'
        WRITE(lu,102) '(including Lagrange multiplier or reduced)'
        WRITE(lu,101) 'NTPGRP',ntpgrp,'total number of parameter groups'
        WRITE(lu,101) 'NVPGRP',nvpgrp,'number of variable parameter groups'
        WRITE(lu,101) 'NFGB',nfgb,'number of fit parameters'
        IF(metsol >= 4.AND. metsol <7) THEN ! band matrix as MINRES preconditioner 
            WRITE(lu,101) 'MBANDW',mbandw,'band width of preconditioner matrix'
            WRITE(lu,102) '(if <0, no preconditioner matrix)'
        END IF
        IF (nagb >= 65536) THEN
            WRITE(lu,101) 'NOFF/K',noff,'max number of off-diagonal elements'
        ELSE
            WRITE(lu,101) 'NOFF',noff,'max number of off-diagonal elements'
        END IF
        IF(ndgn /= 0) THEN
            IF (nagb >= 65536) THEN
                WRITE(lu,101) 'NDGN/K',ndgn/1000,'actual number of off-diagonal elements'
            ELSE
                WRITE(lu,101) 'NDGN',ndgn,'actual number of off-diagonal elements'
            ENDIF
        ENDIF
        WRITE(lu,101) 'NCGB',ncgb,'number of constraints'
        WRITE(lu,101) 'NAGBN',nagbn,'max number of global parameters in an event'
        WRITE(lu,101) 'NALCN',nalcn,'max number of local parameters in an event'
        WRITE(lu,101) 'NAEQN',naeqn,'max number of equations in an event'
        IF (mprint > 1) THEN
            WRITE(lu,101) 'NAEQNA',naeqna,'number of equations'
            WRITE(lu,101) 'NAEQNG',naeqng,  &
                'number of equations with       global parameters'
            WRITE(lu,101) 'NAEQNF',naeqnf,  &
                'number of equations with fixed global parameters'
            WRITE(lu,101) 'NRECF',nrecf,  &
                'number of records   with fixed global parameters'
        END IF
        IF (nrece > 0) THEN
            WRITE(lu,101) 'NRECE',nrece,  &
                'number of records without variable parameters'
        END IF        
        IF (ncache > 0) THEN
            WRITE(lu,101) 'NCACHE',ncache,'number of words for caching'
            WRITE(lu,111) (fcache(k)*100.0,k=1,3)
111         FORMAT(22x,'cache splitting ',3(f6.1,' %'))
        END IF
        WRITE(lu,*) ' '
  
        WRITE(lu,*) ' '
        WRITE(lu,*) 'Solution method and matrix-storage mode:'
        IF(metsol == 1) THEN
            WRITE(lu,*) '     METSOL = 1:  matrix inversion'
        ELSE IF(metsol == 2) THEN
            WRITE(lu,*) '     METSOL = 2:  diagonalization'
        ELSE IF(metsol == 3) THEN
            WRITE(lu,*) '     METSOL = 3:  decomposition'
        ELSE IF(metsol == 4) THEN
            WRITE(lu,*) '     METSOL = 4:  MINRES (rtol', mrestl,')'
        ELSE IF(metsol == 5) THEN
            WRITE(lu,*) '     METSOL = 5:  MINRES-QLP (rtol', mrestl,')'
        ELSE IF(metsol == 6) THEN
            WRITE(lu,*) '     METSOL = 6:  GMRES'
#ifdef LAPACK64
        ELSE IF(metsol == 7) THEN
            WRITE(lu,*) '     METSOL = 7:  LAPACK factorization'
        ELSE IF(metsol == 8) THEN
            WRITE(lu,*) '     METSOL = 8:  LAPACK factorization'
#ifdef PARDISO
        ELSE IF(metsol == 9) THEN
            WRITE(lu,*) '     METSOL = 9:  Intel oneMKL PARDISO'
#endif
#endif
        END IF
        WRITE(lu,*) '                  with',mitera,' iterations'
        IF(matsto == 0) THEN
            WRITE(lu,*) '     MATSTO = 0:  unpacked symmetric matrix, ', 'n*n elements' 
        ELSE IF(matsto == 1) THEN
            WRITE(lu,*) '     MATSTO = 1:  full symmetric matrix, ', '(n*n+n)/2 elements' 
        ELSE IF(matsto == 2) THEN
            WRITE(lu,*) '     MATSTO = 2:  sparse matrix (custom)'
        ELSE IF(matsto == 3) THEN
            IF (matbsz < 2) THEN
                WRITE(lu,*) '     MATSTO = 3:  sparse matrix (upper triangle, CSR3)'
            ELSE
                WRITE(lu,*) '     MATSTO = 3:  sparse matrix (upper triangle, BSR3)'
                WRITE(lu,*) '                  block size', matbsz
            END IF
        END IF
        IF(npblck > 1) THEN    
            WRITE(lu,*) '                  block diagonal with', npblck, ' blocks'
        END IF
        IF(mextnd>0) WRITE(lu,*) '                  with extended storage'
        IF(dflim /= 0.0) THEN
            WRITE(lu,103) 'Convergence assumed, if expected dF <',dflim
        END IF
        IF(ncgb > 0) THEN
            IF(nfgb < nvgb) THEN
                IF (icelim > 1) THEN
                    WRITE(lu,*) 'Constraints handled by elimination with LAPACK'
                ELSE    
                    WRITE(lu,*) 'Constraints handled by elimination'
                END IF    
            ELSE
                WRITE(lu,*) 'Constraints handled by Lagrange multipliers'
            ENDIF
        END IF
  
    END DO ! print loop
 
    IF(nalcn == 0) THEN
        CALL peend(28,'Aborted, no local parameters')
        stop 'LOOP2: stopping due to missing local parameters'
    END IF
 
    !     Wolfe conditions
 
    IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32
    IF(wolfc1 == 0.0) wolfc1=1.0e-4
    IF(wolfc2 == 0.0) wolfc2=0.9
    IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32
    IF(wolfc1 <= 0.0) wolfc1=1.0e-4
    IF(wolfc2 >= 1.0) wolfc2=0.9
    IF(wolfc1 > wolfc2) THEN ! exchange
        wolfc3=wolfc1
        wolfc1=wolfc2
        wolfc2=wolfc3
    ELSE
        wolfc1=1.0e-4
        wolfc2=0.9
    END IF
    WRITE(*,105) wolfc1,wolfc2
    WRITE(lun,105) wolfc1,wolfc2
105 FORMAT(' Constants C1, C2 for Wolfe conditions:',g12.4,', ',g12.4)
 
    !     prepare matrix and gradient storage ------------------------------
32  matsiz=0                  ! number of words for double, single precision storage
    IF (matsto == 3) THEN     ! sparse matrix (CSR3, BSR3)
        npdblk=(nagb-1)/matbsz+1 ! number of row blocks
        length=csr3rowoffsets(npdblk+1)-csr3rowoffsets(1)
        matsiz(1)=length*int(matbsz*matbsz,mpl)
        matwords=(length+nagb+1)*2 ! size of sparsity structure
        CALL mpalloc(csr3columnlist,length,'sparse matrix column list (CSR3)')
        IF (matbsz > 1) THEN
            CALL pblbits(globalallindexgroups,matbsz,csr3rowoffsets,csr3columnlist) ! BSR3
        ELSE
            CALL pcbits(globalallindexgroups,csr3rowoffsets,csr3columnlist)         ! CSR3
        END IF
    ELSE IF (matsto == 2) THEN     ! sparse matrix (custom)
        matsiz(1)=ndimsa(3)+nagb
        matsiz(2)=ndimsa(4)
        CALL mpalloc(sparsematrixcolumns,ndimsa(2),'sparse matrix column list')
        CALL spbits(globalallindexgroups,sparsematrixoffsets,sparsematrixcolumns)
        CALL anasps    ! analyze sparsity structure
    ELSE                      ! full or unpacked matrix, optional block diagonal
        length=nagb
        CALL mpalloc(globalrowoffsets,length,'global row offsets (full or unpacked (block) storage)')
        ! loop over blocks (multiple blocks only with elimination !)
        vecparblockconoffsets(1)=0
        DO i=1,npblck
            ipoff=matparblockoffsets(1,i)
            icboff=matparblockoffsets(2,i) ! constraint block offset
            icblst=matparblockoffsets(2,i+1) ! constraint block offset
            npar=matparblockoffsets(1,i+1)-ipoff ! size of block (number of parameters)
            IF (icblst > icboff) THEN
                ncon=matconsblocks(1,icblst+1)-matconsblocks(1,icboff+1) ! number of constraints in  (parameter) block
            ELSE
                ncon=0
            ENDIF
            vecparblockconoffsets(i+1)=vecparblockconoffsets(i)+ncon
            nall = npar; IF (icelim <= 0) nall=npar+ncon ! add Lagrange multipliers
            DO k=1,nall
                globalrowoffsets(ipoff+k)=matsiz(1)-ipoff
                IF (matsto == 1) THEN
                    matsiz(1)=matsiz(1)+k ! full ('triangular')
                ELSE
                    matsiz(1)=matsiz(1)+nall ! unpacked ('quadratic')
                END IF
            END DO
        END DO
    END IF
    matwords=matwords+matsiz(1)*2+matsiz(2) ! #words for matrix storage
 
    CALL feasma    ! prepare constraint matrices
 
    IF (icheck <= 0) CALL vmprep(matsiz)    ! prepare matrix and gradient storage
    WRITE(*,*) ' '
    IF (matwords < 250000) THEN
        WRITE(*,*) 'Size of global matrix: < 1 MB'
    ELSE
        WRITE(*,*) 'Size of global matrix:',int(real(matwords,mps)*4.0e-6,mpi),' MB'
    ENDIF
    !     print chi^2 cut tables
 
    ndfmax=naeqn-1
    WRITE(lunlog,*) ' '
    WRITE(lunlog,*) '   Cut values of Chi^2/Ndf and Chi2,'
    WRITE(lunlog,*) '   corresponding to 2 and 3 standard deviations'
    WRITE(lunlog,*) '   Ndf  Chi^2/Ndf(2)  Chi^2(2)   ',  &
        '  Chi^2/Ndf(3)  Chi^2(3)'
    ndf=0
    DO
        IF(ndf > naeqn) EXIT
        IF(ndf < 10) THEN
            ndf=ndf+1
        ELSE IF(ndf < 20) THEN
            ndf=ndf+2
        ELSE IF(ndf < 100) THEN
            ndf=ndf+5
        ELSE IF(ndf < 200) THEN
            ndf=ndf+10
        ELSE
            EXIT
        END IF
        chin2=chindl(2,ndf)
        chin3=chindl(3,ndf)
        WRITE(lunlog,106) ndf,chin2,chin2*real(ndf,mps),chin3, chin3*real(ndf,mps)
    END DO
 
    WRITE(lunlog,*) 'LOOP2: ending'
    WRITE(lunlog,*) ' '
    ! warnings from check input mode
    IF (icheck > 0) THEN
        IF (ncgbe /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,199) ' '
            WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
            WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
            WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
            WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
            WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
            WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
            WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
            WRITE(*,199) ' '
            WRITE(*,*) '        Number of empty constraints =',abs(ncgbe), ', should be 0'
            WRITE(*,*) '        => please check constraint definition, mille data'
            WRITE(*,199) ' '
            WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
            WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
            WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
            WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
            WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
            WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
            WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
            WRITE(*,199) ' '
        END IF
    END IF
    CALL mend
101 FORMAT(1x,a8,' =',i14,' = ',a)
102 FORMAT(22x,a)
103 FORMAT(1x,a,g12.4)
106 FORMAT(i6,2(3x,f9.3,f12.1,3x))
199 FORMAT(7x,a)
END SUBROUTINE loop2
 
SUBROUTINE monres
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ij
    INTEGER(mpi) :: imed
    INTEGER(mpi) :: j
    INTEGER(mpi) :: k
    INTEGER(mpi) :: nent
    INTEGER(mpi), DIMENSION(measBins) :: isuml ! location
    INTEGER(mpi), DIMENSION(measBins) :: isums ! scale
    REAL(mps) :: amed
    REAL(mps) :: amad
    
    INTEGER(mpl) :: ioff
    LOGICAL :: lfirst
    SAVE
    DATA lfirst /.true./
 
    ! combine data from threads
    ioff=0
    DO i=2,mthrd
        ioff=ioff+measbins*nummeas
        DO j=1,measbins*nummeas
            meashists(j)=meashists(j)+meashists(ioff+j)
        END DO
    END DO
    
    IF (lfirst) THEN
        IF (imonmd == 0) THEN
            WRITE(lunmon,'(A)') '*** Normalized residuals grouped by first global label (per local fit cycle) ***'
        ELSE
            WRITE(lunmon,'(A)') '*** Pulls grouped by first global label (per local fit cycle) ***'
        ENDIF
        WRITE(lunmon,'(A)') '! LFC     Label   Entries        Median  RMS(MAD)          <error>'
        lfirst=.false.
    END IF
 
    !$POMP INST BEGIN(monres)
    ! analyze histograms
    ioff=0
    DO i=1,ntgb
        IF (measindex(i) > 0) THEN
            isuml=0
            ! sum up content
            isuml(1)=meashists(ioff+1)
            DO j=2,measbins
                isuml(j)=isuml(j-1)+meashists(ioff+j)
            END DO
            nent=isuml(measbins)
            IF (nent > 0) THEN
                ! get median (for location)
                DO j=2,measbins
                    IF (2*isuml(j) > nent) EXIT
                END DO
                imed=j
                amed=real(j,mps)
                IF (isuml(j) > isuml(j-1)) amed=amed+real(nent-2*isuml(j-1),mps)/real(2*isuml(j)-2*isuml(j-1),mps)
                amed=real(measbinsize,mps)*(amed-real(measbins/2,mps))
                ! sum up differences
                isums = 0
                DO j=imed,measbins
                    k=j-imed+1
                    isums(k)=isums(k)+meashists(ioff+j)
                END DO
                DO j=imed-1,1,-1
                    k=imed-j
                    isums(k)=isums(k)+meashists(ioff+j)
                END DO
                DO j=2, measbins
                    isums(j)=isums(j)+isums(j-1)
                END DO
                ! get median (for scale)
                DO j=2,measbins
                    IF (2*isums(j) > nent) EXIT
                END DO
                amad=real(j-1,mps)
                IF (isums(j) > isums(j-1)) amad=amad+real(nent-2*isums(j-1),mps)/real(2*isums(j)-2*isums(j-1),mps)
                amad=real(measbinsize,mps)*amad
            ELSE
                amed=0.0
                amad=0.0
            END IF
            ij=globalparlabelindex(1,i)
            WRITE(lunmon,110) nloopn, ij, nent, amed, amad*1.4826, real(measres(i),mps)
            !
            ioff=ioff+measbins
        END IF
    END DO
    !$POMP INST END(monres)
 
110 FORMAT(i5,2i10,3g14.5)
END SUBROUTINE monres
 
 
 
SUBROUTINE vmprep(msize)
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ioff
    INTEGER(mpi) :: ipar0
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: nextra
#ifdef LAPACK64
    INTEGER :: nbopt, nboptx, ILAENV
#endif
                         !
    INTEGER(mpl), INTENT(IN) :: msize(2)
 
    INTEGER(mpl) :: length
    INTEGER(mpl) :: nwrdpc
    INTEGER(mpl), PARAMETER :: three = 3
    
    SAVE
    !     ...
    !                         Vector/matrix storage
    length=nagb*mthrd
    CALL mpalloc(globalvector,length,'rhs vector') ! double precision vector
    CALL mpalloc(globalcounter,length,'rhs counter') ! integer vector
    lenglobalvec=nagb
    length=naeqn*mthrd
    CALL mpalloc(localcorrections,length,'residual vector of one record')
    CALL mpalloc(localequations,three,length,'mesurements indices (ISJAJB) of one record')
    length=nalcn*nalcn
    CALL mpalloc(aux,length,' local fit scratch array: aux')
    CALL mpalloc(vbnd,length,' local fit scratch array: vbnd')
    CALL mpalloc(vbdr,length,' local fit scratch array: vbdr')
    length=((nalcn+1)*nalcn)/2
    CALL mpalloc(clmat,length,' local fit matrix: clmat')
    CALL mpalloc(vbk,length,' local fit scratch array: vbk')
    length=nalcn
    CALL mpalloc(blvec,length,' local fit vector: blvec')
    CALL mpalloc(vzru,length,' local fit scratch array: vzru')
    CALL mpalloc(scdiag,length,' local fit scratch array: scdiag')
    CALL mpalloc(scflag,length,' local fit scratch array: scflag')
    CALL mpalloc(ibandh,2*length,' local fit band width hist.: ibandh')
 
    CALL mpalloc(globalmatd,msize(1),'global matrix (D)' )
    CALL mpalloc(globalmatf,msize(2),'global matrix (F)')
 
    mszpcc=0
    IF(metsol >= 4.AND.metsol < 7.AND. mbandw >= 0) THEN                  ! GMRES/MINRES algorithms
        !        array space is:
        !           variable-width band matrix or diagonal matrix for parameters
        !           followed by symmetric matrix for constraints
        !           followed by rectangular matrix for constraints
        nwrdpc=0
        ncon=nagb-nvgb ! number of Lagrange multipliers
        ! constraint block info        
        length=4*ncblck; IF(ncon == 0) length=0
        CALL mpalloc(blockprecond,length,'preconditioner: constraint blocks')
        length=ncon
        CALL mpalloc(offprecond,length,'preconditioner: constraint offsets')                       
        !END IF
        ! variable-width band matrix ?
        IF(mbandw > 0) THEN               
            length=nagb
            CALL mpalloc(indprecond,length,'pointer-array variable-band matrix')
            nwrdpc=nwrdpc+length
            DO i=1,min(mbandw,nvgb)
                indprecond(i)=(i*i+i)/2           ! increasing number
            END DO
            DO i=min(mbandw,nvgb)+1,nvgb
                indprecond(i)=indprecond(i-1)+mbandw ! fixed band width
            END DO
            DO i=nvgb+1,nagb                ! reset
                indprecond(i)=0
            END DO
        END IF
        ! symmetric part
        length=(ncon*ncon+ncon)/2
        ! add 'band' part
        IF(mbandw > 0) THEN               ! variable-width band matrix
            length=length+indprecond(nvgb)
        ELSE                              ! default preconditioner (diagonal)
            length=length+nvgb
        END IF
        ! add rectangular part (compressed, constraint blocks)
        IF(ncon > 0) THEN
            ioff=0
            ! extra space (for forward solution in EQUDEC)
            nextra=max(0,mbandw-1)
            DO ib=1,ncblck
                ! first constraint in block
                blockprecond(ioff+1)=matconsblocks(1,ib)
                ! last constraint in block     
                blockprecond(ioff+2)=matconsblocks(1,ib+1)-1 
                ! parameter offset
                ipar0=matconsblocks(2,ib)-1
                blockprecond(ioff+3)=ipar0
                ! number of parameters (-> columns)  
                npar=matconsblocks(3,ib)-ipar0
                blockprecond(ioff+4)=npar+nextra
                DO i=blockprecond(ioff+1),blockprecond(ioff+2)
                    offprecond(i)=length-ipar0
                    length=length+npar+nextra 
                    mszpcc=mszpcc+npar+nextra 
                END DO
                ioff=ioff+4
            END DO
        ELSE
            IF(mbandw == 0) length=length+1 ! for valid precons argument matPreCond((ncon*ncon+ncon)/2+nvgb+1)    
        END IF
        ! allocate
        IF(mbandw > 0) THEN
            CALL mpalloc(matprecond,length,'variable-band preconditioner matrix')
        ELSE
            CALL mpalloc(matprecond,length,'default preconditioner matrix')
        END IF
        nwrdpc=nwrdpc+2*length
        IF (nwrdpc > 250000) THEN
            WRITE(*,*)
            WRITE(*,*) 'Size of preconditioner matrix:',int(real(nwrdpc,mps)*4.0e-6,mpi),' MB'
        END IF    
 
    END IF
 
 
    length=nagb
    CALL mpalloc(globalcorrections,length,'corrections')      ! double prec corrections
 
    length=nagb
    CALL mpalloc(workspaced,length,'auxiliary array (D1)')  ! double aux 1
    CALL mpalloc(workspacelinesearch,length,'auxiliary array (D2)')  ! double aux 2
    CALL mpalloc(workspacei, length,'auxiliary array (I)')   ! int aux 1
 
    IF(metsol == 1) THEN
        CALL mpalloc(workspacediag,length,'diagonal of global matrix)')  ! double aux 1
        CALL mpalloc(workspacerow,length,'(pivot) row of global matrix)')
    !         CALL MEGARR('t D',2*NAGB,'auxiliary array')  ! double aux 8
    END IF
 
    IF(metsol == 2) THEN
        IF(nagb>46300) THEN
            CALL peend(23,'Aborted, bad matrix index (will exceed 32bit)')
            stop 'vmprep: bad index (matrix to large for diagonalization)'
        END IF
        CALL mpalloc(workspacediag,length,'diagonal of global matrix')  ! double aux 1
        CALL mpalloc(workspacediagonalization,length,'auxiliary array (D3)')  ! double aux 3
        CALL mpalloc(workspaceeigenvalues,length,'auxiliary array (D6)')  ! double aux 6
        length=nagb*nagb
        CALL mpalloc(workspaceeigenvectors,length,'(rotation) matrix U')   ! rotation matrix
    END IF
 
    IF(metsol >= 4.AND.metsol < 7) THEN
        CALL mpalloc(vecxav,length,'vector X (AVPROD)')  ! double aux 1
        CALL mpalloc(vecbav,length,'vector B (AVPROD)')  ! double aux 1
    END IF
 
#ifdef LAPACK64
    IF(metsol == 7) THEN
        IF(nagb > nvgb) CALL mpalloc(lapackipiv, length,'IPIV for DSPTRG (L)')   ! pivot indices for DSPTRF
        IF(ilperr == 1) CALL mpalloc(workspacediag,length,'diagonal of global matrix')  ! double aux 1
    END IF
    IF(metsol == 8) THEN
        IF(nagb > nvgb) THEN
            CALL mpalloc(lapackipiv, length,'LAPACK IPIV (L)')
            nbopt = ilaenv( 1_mpl, 'DSYTRF', 'U', int(nagb,mpl), int(nagb,mpl), -1_mpl, -1_mpl ) ! optimal block size
            print *
            print *, 'LAPACK optimal block size for DSYTRF:', nbopt
            lplwrk=length*int(nbopt,mpl)
            CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (D)')
        ELSE IF(nfgb < nvgb.AND.icelim > 1) THEN
            ! elimination of constraints with LAPACK
            lplwrk=1
            DO i=1,npblck
                npar=matparblockoffsets(1,i+1)-matparblockoffsets(1,i)   ! number of parameters in block
                ncon=vecparblockconoffsets(i+1)-vecparblockconoffsets(i) ! number of constraints in block
                nbopt = ilaenv( 1_mpl, 'DORMQL', 'RN', int(npar,mpl), int(npar,mpl), int(ncon,mpl), int(npar,mpl) ) ! optimal buffer size
                IF (int(npar,mpl)*int(nbopt,mpl) > lplwrk) THEN
                    lplwrk=int(npar,mpl)*int(nbopt,mpl)
                    nboptx=nbopt
                END IF
            END DO
            print *
            print *, 'LAPACK optimal block size for DORMQL:', nboptx
            CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (D)')
        END IF
        IF(ilperr == 1) CALL mpalloc(workspacediag,length,'diagonal of global matrix')  ! double aux 1
    END IF
#endif
 
END SUBROUTINE vmprep
 
 
SUBROUTINE minver
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: icoff
    INTEGER(mpi) :: ipoff
    INTEGER(mpi) :: j
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: nfit
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: nrank
    INTEGER(mpl) :: imoff
    INTEGER(mpl) :: ioff1
    REAL(mpd) :: matij
        
    EXTERNAL avprds
 
    SAVE
    !     ...
    lun=lunlog                       ! log file
 
    IF(icalcm == 1) THEN
        ! save diagonal (for global correlation)
        DO i=1,nagb
            workspacediag(i)=matij(i,i)
        END DO
        ! use elimination for constraints ?
        IF(nfgb < nvgb) THEN
            ! monitor progress
            IF(monpg1 > 0) THEN
                WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
                CALL monini(lunlog,monpg1,monpg2)
            END IF
            CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
            IF(monpg1 > 0) CALL monend()
        END IF
    END IF
 
    ! loop over blocks (multiple blocks only with elimination !)
    DO ib=1,npblck
        ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
        npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
        icoff=vecparblockconoffsets(ib)         ! constraint offset for block
        ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
        imoff=globalrowoffsets(ipoff+1)+ipoff   ! block offset in global matrix
        nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
        ! use elimination for constraints ?
        IF(nfit < npar) THEN
            CALL qlsetb(ib)
            ! solve L^t*y=d by backward substitution
            CALL qlbsub(vecconsresiduals(icoff+1:),vecconssolution)
            ! transform, reduce rhs
            CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
            ! correction from eliminated part
            DO i=1,nfit
                DO j=1,ncon
                    ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
                    globalcorrections(i+ipoff)=globalcorrections(i+ipoff)-globalmatd(ioff1)*vecconssolution(j)
                END DO
            END DO
        END IF
 
        IF(icalcm == 1) THEN
            ! monitor progress
            IF(monpg1 > 0) THEN
                WRITE(lunlog,*) 'Inversion of global matrix (A->A^-1)'
                CALL monini(lunlog,monpg1,monpg2)
            END IF
            ! invert and solve
            CALL sqminl(globalmatd(imoff+1:), globalcorrections(ipoff+1:),nfit,nrank,  &
                workspaced,workspacei,workspacerow,monpg1)
            IF(monpg1 > 0) CALL monend()
            IF(nfit /= nrank) THEN
                WRITE(*,*)   'Warning: the rank defect of the symmetric',nfit,  &
                    '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
                WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfit,  &
                    '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
                IF (iforce == 0 .AND. isubit == 0) THEN
                    isubit=1
                    WRITE(*,*)   '         --> enforcing SUBITO mode'
                    WRITE(lun,*) '         --> enforcing SUBITO mode'
                END IF
            ELSE IF(ndefec == 0) THEN
                IF(npblck == 1) THEN
                    WRITE(lun,*) 'No rank defect of the symmetric matrix'
                ELSE
                    WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
                END IF
            END IF
            ndefec=ndefec+nfit-nrank   ! rank defect
 
        ELSE             ! multiply gradient by inverse matrix
            workspaced(:nfit)=globalcorrections(ipoff+1:ipoff+nfit)
            CALL dbsvxl(globalmatd(imoff+1:),workspaced,globalcorrections(ipoff+1:),nfit)
        END IF
 
        !use elimination for constraints ?
        IF(nfit < npar) THEN
            ! extend, transform back solution
            globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
            CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
        END IF
    END DO
    
END SUBROUTINE minver
 
 
SUBROUTINE mchdec
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: icoff
    INTEGER(mpi) :: ipoff
    INTEGER(mpi) :: j
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: nfit
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: nrank
    INTEGER(mpl) :: imoff
    INTEGER(mpl) :: ioff1
    
    REAL(mpd) :: evmax
    REAL(mpd) :: evmin
        
    EXTERNAL avprds
 
    SAVE
    !     ...
    lun=lunlog                       ! log file
 
    IF(icalcm == 1) THEN
        ! use elimination for constraints ?
        ! monitor progress
        IF(monpg1 > 0) THEN
            WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
            CALL monini(lunlog,monpg1,monpg2)
        END IF
        IF(nfgb < nvgb) CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
        IF(monpg1 > 0) CALL monend()
    END IF
 
    ! loop over blocks (multiple blocks only with elimination !)
    DO ib=1,npblck
        ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
        npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
        icoff=vecparblockconoffsets(ib)         ! constraint offset for block
        ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
        imoff=globalrowoffsets(ipoff+1)+ipoff   ! block offset in global matrix
        nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
        ! use elimination for constraints ?
        IF(nfit < npar) THEN
            CALL qlsetb(ib)
            ! solve L^t*y=d by backward substitution
            CALL qlbsub(vecconsresiduals(icoff+1:),vecconssolution)
            ! transform, reduce rhs
            CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
            ! correction from eliminated part
            DO i=1,nfit
                DO j=1,ncon
                    ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
                    globalcorrections(i+ipoff)=globalcorrections(i+ipoff)-globalmatd(ioff1)*vecconssolution(j)
                END DO
            END DO
        END IF
 
        IF(icalcm == 1) THEN
            ! monitor progress
            IF(monpg1 > 0) THEN
                WRITE(lunlog,*) 'Decomposition of global matrix (A->L*D*L^t)'
                CALL monini(lunlog,monpg1,monpg2)
            END IF
            ! decompose and solve
            CALL chdec2(globalmatd(imoff+1:),nfit,nrank,evmax,evmin,monpg1)
            IF(monpg1 > 0) CALL monend()
            IF(nfit /= nrank) THEN
                WRITE(*,*)   'Warning: the rank defect of the symmetric',nfit,  &
                    '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
                WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfit,  &
                    '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
                IF (iforce == 0 .AND. isubit == 0) THEN
                    isubit=1
                    WRITE(*,*)   '         --> enforcing SUBITO mode'
                    WRITE(lun,*) '         --> enforcing SUBITO mode'
                END IF
            ELSE IF(ndefec == 0) THEN
                IF(npblck == 1) THEN
                    WRITE(lun,*) 'No rank defect of the symmetric matrix'
                ELSE
                    WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
                END IF
                WRITE(lun,*) '   largest  diagonal element (LDLt)', evmax
                WRITE(lun,*) '   smallest diagonal element (LDLt)', evmin
            END IF
            ndefec=ndefec+nfit-nrank   ! rank defect
 
        END IF
        ! backward/forward substitution
        CALL chslv2(globalmatd(imoff+1:),globalcorrections(ipoff+1:),nfit)
 
        !use elimination for constraints ?
        IF(nfit < npar) THEN
            ! extend, transform back solution
            globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
            CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
        END IF
    END DO
    
END SUBROUTINE mchdec
 
#ifdef LAPACK64
 
 
SUBROUTINE mdptrf
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: icoff
    INTEGER(mpi) :: ipoff
    INTEGER(mpi) :: j
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: nfit
    INTEGER(mpi) :: npar
    INTEGER(mpl) :: imoff
    INTEGER(mpl) :: ioff1
    INTEGER(mpi) :: infolp
    REAL(mpd) :: matij
        
    EXTERNAL avprds
 
    SAVE
    !     ...
    lun=lunlog                       ! log file
 
    IF(icalcm == 1) THEN
        IF(ilperr == 1) THEN
            ! save diagonal (for global correlation)
            DO i=1,nagb
                workspacediag(i)=matij(i,i)
            END DO
        END IF
        ! use elimination for constraints ?
        IF(nfgb < nvgb) THEN
            ! monitor progress
            IF(monpg1 > 0) THEN
                WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
                CALL monini(lunlog,monpg1,monpg2)
            END IF
            CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
            IF(monpg1 > 0) CALL monend()
        END IF
    END IF
 
    ! loop over blocks (multiple blocks only with elimination !)
    DO ib=1,npblck
        ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
        npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
        icoff=vecparblockconoffsets(ib)         ! constraint offset for block
        ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
        imoff=globalrowoffsets(ipoff+1)+ipoff   ! block offset in global matrix
        nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
        ! use elimination for constraints ?
        IF(nfit < npar) THEN
            CALL qlsetb(ib)
            ! solve L^t*y=d by backward substitution
            CALL qlbsub(vecconsresiduals(icoff+1:),vecconssolution)
            ! transform, reduce rhs
            CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
            ! correction from eliminated part
            DO i=1,nfit
                DO j=1,ncon
                    ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
                    globalcorrections(i+ipoff)=globalcorrections(i+ipoff)-globalmatd(ioff1)*vecconssolution(j)
                END DO
            END DO
        END IF
 
        IF(icalcm == 1) THEN
            ! multipliers?
            IF (nfit > npar) THEN
                ! monitor progress
                IF(monpg1 > 0) THEN
                    WRITE(lunlog,*) 'Factorization of global matrix (A->L*D*L^t)'
                    CALL monini(lunlog,monpg1,monpg2)
                END IF
                !$POMP INST BEGIN(dsptrf)
                CALL dsptrf('U',int(nfit,mpl),globalmatd(imoff+1:),lapackipiv(ipoff+1:),infolp)
                !$POMP INST END(dsptrf)
                IF(monpg1 > 0) CALL monend()
            ELSE
                ! monitor progress
                IF(monpg1 > 0) THEN
                    WRITE(lunlog,*) 'Factorization of global matrix (A->L*L^t)'
                    CALL monini(lunlog,monpg1,monpg2)
                END IF
                !$POMP INST BEGIN(dpptrf)
                CALL dpptrf('U',int(nfit,mpl),globalmatd(imoff+1:),infolp)
                !$POMP INST END(dpptrf)
                IF(monpg1 > 0) CALL monend()
            ENDIF
            ! check result
            IF(infolp==0) THEN
                IF(npblck == 1) THEN
                    WRITE(lun,*) 'No rank defect of the symmetric matrix'
                ELSE
                    WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
                END IF
            ELSE
                ndefec=ndefec+1 ! (lower limit of) rank defect
                WRITE(*,*)   'Warning: factorization of the symmetric',nfit,  &
                    '-by-',nfit,' failed at index ', infolp
                WRITE(lun,*)   'Warning: factorization of the symmetric',nfit,  &
                    '-by-',nfit,' failed at index ', infolp
                CALL peend(29,'Aborted, factorization of global matrix failed')
                stop 'mdptrf: bad matrix'
            END IF
        END IF
        ! backward/forward substitution
        ! multipliers?
        IF (nfit > npar) THEN
            CALL dsptrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),lapackipiv(ipoff+1:),&
                globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
            IF(infolp /= 0) print *, ' DSPTRS failed: ', infolp
        ELSE
            CALL dpptrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),&
                globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
            IF(infolp /= 0) print *, ' DPPTRS failed: ', infolp
        ENDIF
 
        !use elimination for constraints ?
        IF(nfit < npar) THEN
            ! extend, transform back solution
            globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
            CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
        END IF
    END DO
    
END SUBROUTINE mdptrf
 
 
SUBROUTINE mdutrf
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: icoff
    INTEGER(mpi) :: ipoff
    INTEGER(mpi) :: j
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: nfit
    INTEGER(mpi) :: npar
    INTEGER(mpl) :: imoff
    INTEGER(mpl) :: ioff1
    INTEGER(mpl) :: iloff
    INTEGER(mpi) :: infolp
    
    REAL(mpd) :: matij
        
    EXTERNAL avprds
 
    SAVE
    !     ...
    lun=lunlog                       ! log file
 
    IF(icalcm == 1) THEN
        IF(ilperr == 1) THEN
            ! save diagonal (for global correlation)
            DO i=1,nagb
                workspacediag(i)=matij(i,i)
            END DO
        END IF
        ! use elimination for constraints ?
        IF(nfgb < nvgb) THEN
            ! monitor progress
            IF(monpg1 > 0) THEN
                WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
                CALL monini(lunlog,monpg1,monpg2)
            END IF
            IF (icelim > 1) THEN
                CALL lpavat(.true.)
            ELSE
                CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q            
            END IF    
            IF(monpg1 > 0) CALL monend()
        END IF
    END IF
 
    ! loop over blocks (multiple blocks only with elimination !)
    iloff=0 ! offset of L in lapackQL
    DO ib=1,npblck
        ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
        npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
        icoff=vecparblockconoffsets(ib)         ! constraint offset for block
        ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
        imoff=globalrowoffsets(ipoff+1)+ipoff   ! block offset in global matrix
        nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
        ! use elimination for constraints ?
        IF(nfit < npar) THEN
            IF (icelim > 1) THEN
                ! solve L^t*y=d by backward substitution
                vecconssolution(1:ncon)=vecconsresiduals(icoff+1:icoff+ncon)
                CALL dtrtrs('L','T','N',int(ncon,mpl),1_mpl,lapackql(iloff+npar-ncon+1:),int(npar,mpl),&
                    vecconssolution,int(ncon,mpl),infolp)
                IF(infolp /= 0) print *, ' DTRTRS failed: ', infolp
                ! transform, reduce rhs, Q^t*b
                CALL dormql('L','T',int(npar,mpl),1_mpl,int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
                    lapacktau(icoff+1:),globalcorrections(ipoff+1:),int(npar,mpl),lapackwork,lplwrk,infolp)
                IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
            ELSE
                CALL qlsetb(ib)
                ! solve L^t*y=d by backward substitution
                CALL qlbsub(vecconsresiduals(icoff+1:),vecconssolution)
                ! transform, reduce rhs
                CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b   
            END IF
            ! correction from eliminated part
            DO i=1,nfit
                DO j=1,ncon
                    ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
                    globalcorrections(i+ipoff)=globalcorrections(i+ipoff)-globalmatd(ioff1)*vecconssolution(j)
                END DO
            END DO
        END IF
 
        IF(icalcm == 1) THEN
            ! multipliers?
            IF (nfit > npar) THEN
                ! monitor progress
                IF(monpg1 > 0) THEN
                    WRITE(lunlog,*) 'Factorization of global matrix (A->L*D*L^t)'
                    CALL monini(lunlog,monpg1,monpg2)
                END IF
                !$POMP INST BEGIN(dsytrf)
                CALL dsytrf('U',int(nfit,mpl),globalmatd(imoff+1:),int(nfit,mpl),&
                    lapackipiv(ipoff+1:),lapackwork,lplwrk,infolp)
                !$POMP INST END(dsytrf)
                IF(monpg1 > 0) CALL monend()
            ELSE
                ! monitor progress
                IF(monpg1 > 0) THEN
                    WRITE(lunlog,*) 'Factorization of global matrix (A->L*L^t)'
                    CALL monini(lunlog,monpg1,monpg2)
                END IF
                !$POMP INST BEGIN(dpotrf)
                CALL dpotrf('U',int(nfit,mpl),globalmatd(imoff+1:),int(npar,mpl),infolp)
                !$POMP INST END(dpotrf)
                IF(monpg1 > 0) CALL monend()
            ENDIF
            ! check result
            IF(infolp==0) THEN
                IF(npblck == 1) THEN
                    WRITE(lun,*) 'No rank defect of the symmetric matrix'
                ELSE
                    WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
                END IF
            ELSE
                ndefec=ndefec+1 ! (lower limit of) rank defect
                WRITE(*,*)   'Warning: factorization of the symmetric',nfit,  &
                    '-by-',nfit,' failed at index ', infolp
                WRITE(lun,*)   'Warning: factorization of the symmetric',nfit,  &
                    '-by-',nfit,' failed at index ', infolp
                CALL peend(29,'Aborted, factorization of global matrix failed')
                stop 'mdutrf: bad matrix'
            END IF
        END IF
        ! backward/forward substitution
        ! multipliers?
        IF (nfit > npar) THEN
            CALL dsytrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),int(nfit,mpl),&
                lapackipiv(ipoff+1:),globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
            IF(infolp /= 0) print *, ' DSYTRS failed: ', infolp
        ELSE
            CALL dpotrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),int(npar,mpl),&
                globalcorrections(ipoff+1:),int(npar,mpl),infolp)
            IF(infolp /= 0) print *, ' DPOTRS failed: ', infolp
        ENDIF
 
        !use elimination for constraints ?
        IF(nfit < npar) THEN
            IF (icelim > 1) THEN
                ! correction from eliminated part
                globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
                ! extend, transform back solution, Q*x
                CALL dormql('L','N',int(npar,mpl),1_mpl,int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
                    lapacktau(icoff+1:),globalcorrections(ipoff+1:),int(npar,mpl),lapackwork,lplwrk,infolp)
                IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
            ELSE
                ! extend, transform back solution
                globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
                CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x            
            END IF    
        END IF
        iloff=iloff+int(npar,mpl)*int(ncon,mpl)
    END DO
    
END SUBROUTINE mdutrf
 
SUBROUTINE lpqldec(a,emin,emax)
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: icb
    INTEGER(mpi) :: icboff
    INTEGER(mpi) :: icblst
    INTEGER(mpi) :: icoff
    INTEGER(mpi) :: icfrst
    INTEGER(mpi) :: iclast
    INTEGER(mpi) :: ipfrst
    INTEGER(mpi) :: iplast
    INTEGER(mpi) :: ipoff
    INTEGER(mpi) :: i
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: npb
    INTEGER(mpl) :: imoff
    INTEGER(mpl) :: iloff
    INTEGER(mpi) :: infolp
    INTEGER :: nbopt, ILAENV
     
    REAL(mpd), INTENT(IN) :: a(mszcon)
    REAL(mpd), INTENT(OUT)         :: emin
    REAL(mpd), INTENT(OUT)         :: emax
    SAVE
 
    print *
    ! loop over blocks (multiple blocks only with elimination !)
    iloff=0 ! size of unpacked constraint matrix
    DO ib=1,npblck
        ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
        npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
        icoff=vecparblockconoffsets(ib)         ! constraint offset for block
        ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
        iloff=iloff+int(npar,mpl)*int(ncon,mpl)
    END DO
    ! allocate
    CALL mpalloc(lapackql, iloff, 'LAPACK QL (QL decomp.) ')
    lapackql=0.
    iloff=ncgb
    CALL mpalloc(lapacktau, iloff, 'LAPACK TAU (QL decomp.) ')
    ! fill
    iloff=0 ! offset of unpacked constraint matrix block
    imoff=0 ! offset of packed constraint matrix block
    DO ib=1,npblck
        ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
        npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
        icoff=vecparblockconoffsets(ib)         ! constraint offset for block
        ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
        IF(ncon <= 0) cycle
        ! block with constraints
        icboff=matparblockoffsets(2,ib) ! constraint block offset
        icblst=matparblockoffsets(2,ib+1) ! constraint block offset
        DO icb=icboff+1,icboff+icblst
            icfrst=matconsblocks(1,icb)       ! first constraint in block
            iclast=matconsblocks(1,icb+1)-1   ! last constraint in block
            DO j=icfrst,iclast
                ipfrst=matconsranges(3,j)-ipoff ! first (rel.) parameter
                iplast=matconsranges(4,j)-ipoff ! last  (rel.) parameters
                npb=iplast-ipfrst+1
                lapackql(iloff+ipfrst:iloff+iplast)=a(imoff+1:imoff+npb)
                imoff=imoff+npb
                iloff=iloff+npar
            END DO
        END DO
    END DO
    ! decompose
    iloff=0 ! offset of unpacked constraint matrix block
    emax=-1.
    emin=1.
    DO ib=1,npblck
        ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
        npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
        icoff=vecparblockconoffsets(ib)         ! constraint offset for block
        ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
        IF(ncon <= 0) cycle
        ! block with constraints
        nbopt = ilaenv( 1_mpl, 'DGEQLF', '', int(npar,mpl), int(ncon,mpl), int(npar,mpl), -1_mpl ) ! optimal block size
        print *, 'LAPACK optimal block size for DGEQLF:', nbopt
        lplwrk=int(ncon,mpl)*int(nbopt,mpl)
        CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (d)')
        !$POMP INST BEGIN(dgeqlf)
        CALL dgeqlf(int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
            lapacktau(icoff+1:),lapackwork,lplwrk,infolp)
        IF(infolp /= 0) print *, ' DGEQLF failed: ', infolp
        !$POMP INST END(dgeqlf)
        CALL mpdealloc(lapackwork)
        iloff=iloff+int(npar,mpl)*int(ncon,mpl)
        ! get min/max diaginal element of L
        imoff=iloff
        IF(emax < emin) THEN
            emax=lapackql(imoff)
            emin=emax
        END IF
        DO i=1,ncon
            IF (abs(emax) < abs(lapackql(imoff))) emax=lapackql(imoff)
            IF (abs(emin) > abs(lapackql(imoff))) emin=lapackql(imoff)
            imoff=imoff-npar-1
        END DO
    END DO
    print *
END SUBROUTINE lpqldec
 
SUBROUTINE lpavat(t)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: icoff
    INTEGER(mpi) :: ipoff
    INTEGER(mpi) :: j
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: npar
    INTEGER(mpl) :: imoff
    INTEGER(mpl) :: iloff
    INTEGER(mpi) :: infolp
    CHARACTER (LEN=1) :: transr, transl
                
    LOGICAL, INTENT(IN) :: t
    SAVE
 
    IF (t) THEN     ! Q^t*A*Q
        transr='N'
        transl='T'
    ELSE            ! Q*A*Q^t
        transr='T'
        transl='N'
    ENDIF
        
    ! loop over blocks (multiple blocks only with elimination !)
    iloff=0 ! offset of L in lapackQL
    DO ib=1,npblck
        ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
        npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
        icoff=vecparblockconoffsets(ib)         ! constraint offset for block
        ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
        imoff=globalrowoffsets(ipoff+1)+ipoff   ! block offset in global matrix
        IF(ncon <= 0 ) cycle
           
        !$POMP INST BEGIN(dormql)
        ! expand matrix (copy lower to upper triangle)
        ! parallelize row loop
        ! slot of 32 'I' for next idle thread
        !$OMP PARALLEL DO &
        !$OMP PRIVATE(J) &
        !$OMP SCHEDULE(DYNAMIC,32)
        DO i=ipoff+1,ipoff+npar
            DO j=ipoff+1,i-1
                globalmatd(globalrowoffsets(j)+i)=globalmatd(globalrowoffsets(i)+j)
            ENDDO
        ENDDO
        ! A*Q
        CALL dormql('R',transr,int(npar,mpl),int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),&
            int(npar,mpl),lapacktau(icoff+1:),globalmatd(imoff+1:),int(npar,mpl),&
            lapackwork,lplwrk,infolp)
        IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
        ! Q^t*(A*Q)
        CALL dormql('L',transl,int(npar,mpl),int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),&
            int(npar,mpl),lapacktau(icoff+1:),globalmatd(imoff+1:),int(npar,mpl),&
            lapackwork,lplwrk,infolp)
        IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
        !$POMP INST END(dormql)
 
        iloff=iloff+int(npar,mpl)*int(ncon,mpl)
    END DO
 
END SUBROUTINE lpavat
 
#ifdef PARDISO
include 'mkl_pardiso.f90'
!===============================================================================
! Copyright 2004-2022 Intel Corporation.
!
! This software and the related documents are Intel copyrighted  materials,  and
! your use of  them is  governed by the  express license  under which  they were
! provided to you (License).  Unless the License provides otherwise, you may not
! use, modify, copy, publish, distribute,  disclose or transmit this software or
! the related documents without Intel's prior written permission.
!
! This software and the related documents  are provided as  is,  with no express
! or implied  warranties,  other  than those  that are  expressly stated  in the
! License.
!===============================================================================
!
!   Content : Intel(R) oneAPI Math Kernel Library (oneMKL) PARDISO Fortran-90
!             use case
!
!*******************************************************************************
 
SUBROUTINE mspardiso
    USE mkl_pardiso
    USE mpmod
    USE mpdalc
    IMPLICIT NONE
 
    !.. Internal solver memory pointer
    TYPE(mkl_pardiso_handle) :: pt(64)    ! Handle to internal data structure
    !.. All other variables
    INTEGER(mpl), PARAMETER :: maxfct =1  ! Max. number of factors with identical sparsity structure kept in memory
    INTEGER(mpl), PARAMETER :: mnum = 1   ! Actual factor to use
    INTEGER(mpl), PARAMETER :: nrhs = 1   ! Number of right hand sides
 
    INTEGER(mpl) :: mtype                  ! Matrix type (symmetric, pos. def.: 2, indef.: -2)
    INTEGER(mpl) :: phase                  ! Solver phase(s) to be executed
    INTEGER(mpl) :: error                  ! Error code
    INTEGER(mpl) :: msglvl                 ! Message level
 
    INTEGER(mpi) :: i
    INTEGER(mpl) :: ij
    INTEGER(mpl) :: idum(1)
    INTEGER(mpi) :: lun
    INTEGER(mpl) :: length
    INTEGER(mpi) :: nfill
    INTEGER(mpi) :: npdblk
    REAL(mpd) :: adum(1)
    REAL(mpd) :: ddum(1)
 
    INTEGER(mpl) :: iparm(64)
    REAL(mpd), ALLOCATABLE :: b( : )       ! Right hand side (of equations system)
    REAL(mpd), ALLOCATABLE :: x( : )       ! Solution (of equations system)
    SAVE
 
    lun=lunlog                       ! log file
 
    error  = 0 ! initialize error flag
    msglvl = ipddbg ! print statistical information
    npdblk=(nfgb-1)/matbsz+1 ! number of row blocks
 
    IF(icalcm == 1) THEN
        mtype = 2                    ! positive definite symmetric matrix
        IF (nfgb > nvgb)  mtype = -2 ! indefinte symmetric matrix (Lagrange multipliers)
 
        !$POMP INST BEGIN(mspd00)
        WRITE(*,*)
        WRITE(*,*) 'MSPARDISO: number of non-zero elements = ', csr3rowoffsets(npdblk+1)-csr3rowoffsets(1)
        ! fill up last block?
        nfill = npdblk*matbsz-nfgb
        IF (nfill > 0) THEN
            WRITE(*,*) 'MSPARDISO: number of rows to fill up   = ', nfill
            ! end of last block
            ij = (csr3rowoffsets(npdblk+1)-csr3rowoffsets(1))*int(matbsz,mpl)*int(matbsz,mpl)
            DO i=1,nfill
                globalmatd(ij) = 1.0_mpd
                ij = ij-matbsz-1 ! back one row and one column in last block
            END DO
        END IF
 
        ! close previous PARADISO run
        IF (ipdmem > 0) THEN
            !.. Termination and release of memory
            phase = -1 ! release internal memory
            CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), adum, idum, idum, &
                idum, nrhs, iparm, msglvl, ddum, ddum, error)
            IF (error /= 0) THEN
                WRITE(lun,*) 'The following ERROR was detected: ', error
                WRITE(*,'(A,2I10)') ' PARDISO release failed (phase, error): ', phase, error
                IF (ipddbg == 0) WRITE(*,*) '        rerun with "debugPARDISO" for more info'
                CALL peend(40,'Aborted, other error: PARDISO release')
                stop 'MSPARDISO: stopping due to error in PARDISO release'
            END IF
            ipdmem=0
        END IF
 
        !..
        !.. Set up PARDISO control parameter
        !..
        iparm=0 ! using defaults
        iparm(2)  =  2 ! fill-in reordering from METIS
        iparm(10) =  8 ! perturb the pivot elements with 1E-8
        iparm(18) = -1 ! Output: number of nonzeros in the factor LU
        iparm(19) = -1 ! Output: Mflops for LU factorization
        iparm(21) =  1 ! pivoting for symmetric indefinite matrices
        DO i=1, lenpardiso
            iparm(listpardiso(i)%label)=listpardiso(i)%ivalue
        END DO
        IF (iparm(1) == 0) WRITE(lun,*) 'PARDISO using defaults '
        IF (iparm(43) /= 0) THEN
            WRITE(lun,*) 'PARDISO: computation of the diagonal of inverse matrix not implemented !'
            iparm(43) =  0 ! no computation of the diagonal of inverse matrix
        END IF
 
        ! necessary for the FIRST call of the PARDISO solver.
        DO i = 1, 64
            pt(i)%DUMMY =  0
        END DO
        !$POMP INST END(mspd00)
    END IF
 
    IF(icalcm == 1) THEN
        ! monitor progress
        IF(monpg1 > 0) THEN
            WRITE(lunlog,*) 'Decomposition of global matrix (A->L*D*L^t)'
            CALL monini(lunlog,monpg1,monpg2)
        END IF
        ! decompose and solve
        !.. Reordering and Symbolic Factorization, This step also allocates
        ! all memory that is necessary for the factorization
        !$POMP INST BEGIN(mspd11)
        phase = 11 ! only reordering and symbolic factorization
        IF (matbsz > 1) THEN
            iparm(1) = 1 ! non default setting
            iparm(37) = matbsz ! using BSR3 instead of CSR3
        END IF
        IF (ipddbg > 0) THEN
            DO i=1,64
                WRITE(lun,*) ' iparm(',i,') =', iparm(i)
            END DO
        END IF
        CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
            idum, nrhs, iparm, msglvl, ddum, ddum, error)
        !$POMP INST END(mspd11)
        WRITE(lun,*) 'PARDISO reordering completed ... '
        WRITE(lun,*) 'PARDISO peak memory required (KB)', iparm(15)
        IF (ipddbg > 0) THEN
            DO i=1,64
                WRITE(lun,*) ' iparm(',i,') =', iparm(i)
            END DO
        END IF
        IF (error /= 0) THEN
            WRITE(lun,*) 'The following ERROR was detected: ', error
            WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
            IF (ipddbg == 0) WRITE(*,*) '        rerun with "debugPARDISO" for more info'
            CALL peend(40,'Aborted, other error: PARDISO reordering')
            stop 'MSPARDISO: stopping due to error in PARDISO reordering'
        END IF
        IF (iparm(60) == 0) THEN
            ipdmem=ipdmem+max(iparm(15),iparm(16))+iparm(17) ! in core
        ELSE
            ipdmem=ipdmem+max(iparm(15),iparm(16))+iparm(63) ! out of core
        END IF
        WRITE(lun,*) 'Size (KB) of allocated memory  = ',ipdmem
        WRITE(lun,*) 'Number of nonzeros in factors  = ',iparm(18)
        WRITE(lun,*) 'Number of factorization MFLOPS = ',iparm(19)
 
        !.. Factorization.
        !$POMP INST BEGIN(mspd22)
        phase = 22 ! only factorization
        CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
            idum, nrhs, iparm, msglvl, ddum, ddum, error)
        !$POMP INST END(mspd22)
        WRITE(lun,*) 'PARDISO factorization completed ... '
        IF (ipddbg > 0) THEN
            DO i=1,64
                WRITE(lun,*) ' iparm(',i,') =', iparm(i)
            END DO
        END IF
        IF (error /= 0) THEN
            WRITE(lun,*) 'The following ERROR was detected: ', error
            WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
            IF (ipddbg == 0) WRITE(*,*) '        rerun with "debugPARDISO" for more info'
            CALL peend(40,'Aborted, other error: PARDISO factorization')
            stop 'MSPARDISO: stopping due to error in PARDISO factorization'
        ENDIF
        IF (mtype < 0) THEN
            IF (iparm(14) > 0) &
                WRITE(lun,*) 'Number of perturbed pivots     = ',iparm(14)
            WRITE(lun,*) 'Number of positive eigenvalues = ',iparm(22)-nfill
            WRITE(lun,*) 'Number of negative eigenvalues = ',iparm(23)
        ELSE IF (iparm(30) > 0) THEN
            WRITE(lun,*) 'Equation with bad pivot (<=0.) = ',iparm(30)
        END IF
 
        IF (monpg1 > 0) CALL monend()
    END IF
 
    ! backward/forward substitution
    !.. Back substitution and iterative refinement
    length=nfgb+nfill
    CALL mpalloc(b,length,' PARDISO r.h.s')
    CALL mpalloc(x,length,' PARDISO solution')
    b(:nfgb) = globalcorrections
    !$POMP INST BEGIN(mspd33)
    iparm(6) = 0 ! don't update r.h.s. with solution
    phase = 33 ! only solving
    CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
        idum, nrhs, iparm, msglvl, b, x, error)
    !$POMP INST END(mspd33)
    globalcorrections = x(:nfgb)
    CALL mpdealloc(x)
    CALL mpdealloc(b)
    WRITE(lun,*) 'PARDISO solve completed ... '
    IF (error /= 0) THEN
        WRITE(lun,*) 'The following ERROR was detected: ', error
        WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
        IF (ipddbg == 0) WRITE(*,*) '        rerun with "debugPARDISO" for more info'
        CALL peend(40,'Aborted, other error: PARDISO solve')
        stop 'MSPARDISO: stopping due to error in PARDISO solve'
    ENDIF
 
END SUBROUTINE mspardiso
#endif
#endif
 
SUBROUTINE mdiags
    USE mpmod
 
    IMPLICIT NONE
    REAL(mps) :: evalue
    INTEGER(mpi) :: i
    INTEGER(mpi) :: iast
    INTEGER(mpi) :: idia
    INTEGER(mpi) :: imin
    INTEGER(mpl) :: ioff1
    INTEGER(mpi) :: j
    INTEGER(mpi) :: last
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: nmax
    INTEGER(mpi) :: nmin
    INTEGER(mpi) :: ntop
    REAL(mpd) :: matij
                                       !
    EXTERNAL avprds
 
    SAVE
    !     ...
 
    lun=lunlog                       ! log file
 
    ! save diagonal (for global correlation)
    IF(icalcm == 1) THEN
        DO i=1,nagb
            workspacediag(i)=matij(i,i)
        END DO
    ENDIF
 
    !use elimination for constraints ?
    IF(nfgb < nvgb) THEN
        IF(icalcm == 1) THEN
            ! monitor progress
            IF(monpg1 > 0) THEN
                WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
                CALL monini(lunlog,monpg1,monpg2)
            END IF
            CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
            IF(monpg1 > 0) CALL monend()
        ENDIF
        ! solve L^t*y=d by backward substitution
        CALL qlbsub(vecconsresiduals,vecconssolution)
        ! transform, reduce rhs
        CALL qlmlq(globalcorrections,1,.true.) ! Q^t*b
        ! correction from eliminated part
        DO i=1,nfgb
            DO j=1,ncgb
                ioff1=globalrowoffsets(nfgb+j)+i ! global (nfit+j,i)
                globalcorrections(i)=globalcorrections(i)-globalmatd(ioff1)*vecconssolution(j)
            END DO
        END DO
    END IF
 
    IF(icalcm == 1) THEN
        !                         eigenvalues   eigenvectors   symm_input
        workspaceeigenvalues=0.0_mpd
        CALL devrot(nfgb,workspaceeigenvalues,workspaceeigenvectors,globalmatd,  &
            workspacediagonalization,workspacei)
  
        !        histogram of positive eigenvalues
  
        nmax=int(1.0+log10(real(workspaceeigenvalues(1),mps)),mpi) ! > log of largest eigenvalue
        imin=1
        DO i=nfgb,1,-1
            IF(workspaceeigenvalues(i) > 0.0_mpd) THEN
                imin=i ! index of smallest pos. eigenvalue
                EXIT
            END IF
        END DO
        nmin=int(log10(real(workspaceeigenvalues(imin),mps)),mpi)   ! log of smallest pos. eigenvalue
        ntop=nmin+6
        DO WHILE(ntop < nmax)
            ntop=ntop+3
        END DO
  
        CALL hmpdef(7,real(nmin,mps),real(ntop,mps), 'log10 of positive eigenvalues')
        DO idia=1,nfgb
            IF(workspaceeigenvalues(idia) > 0.0_mpd) THEN ! positive
                evalue=log10(real(workspaceeigenvalues(idia),mps))
                CALL hmpent(7,evalue)
            END IF
        END DO
        IF(nhistp /= 0) CALL hmprnt(7)
        CALL hmpwrt(7)
  
        iast=max(1,imin-60)
        CALL gmpdef(3,2,'low-value end of eigenvalues')
        DO i=iast,nfgb
            evalue=real(workspaceeigenvalues(i),mps)
            CALL gmpxy(3,real(i,mps),evalue)
        END DO
        IF(nhistp /= 0) CALL gmprnt(3)
        CALL gmpwrt(3)
  
        DO i=1,nfgb
            workspacediagonalization(i)=0.0_mpd
            IF(workspaceeigenvalues(i) /= 0.0_mpd) THEN
                workspacediagonalization(i)=max(0.0_mpd,log10(abs(workspaceeigenvalues(i)))+3.0_mpd)
                IF(workspaceeigenvalues(i) < 0.0_mpd) workspacediagonalization(i)=-workspacediagonalization(i)
            END IF
        END DO
        last=min(nfgb,nvgb)
        WRITE(lun,*) ' '
        WRITE(lun,*) 'The first (largest) eigenvalues ...'
        WRITE(lun,102) (workspaceeigenvalues(i),i=1,min(20,nagb))
        WRITE(lun,*) ' '
        WRITE(lun,*) 'The last eigenvalues ... up to',last
        WRITE(lun,102) (workspaceeigenvalues(i),i=max(1,last-19),last)
        WRITE(lun,*) ' '
        IF(nagb > nvgb) THEN
            WRITE(lun,*) 'The eigenvalues from',nvgb+1,' to',nagb
            WRITE(lun,102) (workspaceeigenvalues(i),i=nvgb+1,nagb)
            WRITE(lun,*) ' '
        ENDIF
        WRITE(lun,*) 'Log10 + 3 of ',nfgb,' eigenvalues in decreasing', ' order'
        WRITE(lun,*) '(for Eigenvalue < 0.001 the value 0.0 is shown)'
        WRITE(lun,101) (workspacediagonalization(i),i=1,nfgb)
        IF(workspacediagonalization(nfgb) < 0) WRITE(lun,*) 'Negative values are ',  &
            'printed for negative eigenvalues'
        CALL devsig(nfgb,workspaceeigenvalues,workspaceeigenvectors,globalvector,workspacediagonalization)
        WRITE(lun,*) ' '
        WRITE(lun,*) last,' significances: insignificant if ',  &
            'compatible with  N(0,1)'
        WRITE(lun,101) (workspacediagonalization(i),i=1,last)
  
  
101     FORMAT(10f7.1)
102     FORMAT(5e14.6)
 
    END IF
 
    !     solution ---------------------------------------------------------
    workspaced(:nfgb)=globalcorrections(:nfgb)
    !                      eigenvalues   eigenvectors
    CALL devsol(nfgb,workspaceeigenvalues,workspaceeigenvectors,workspaced,globalcorrections,workspacediagonalization)
 
    !use elimination for constraints ?
    IF(nfgb < nvgb) THEN
        ! extend, transform back solution
        globalcorrections(nfgb+1:nvgb)=vecconssolution(1:ncgb)
        CALL qlmlq(globalcorrections,1,.false.) ! Q*x
    END IF
 
END SUBROUTINE mdiags
 
SUBROUTINE zdiags
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpl) :: ioff1
    INTEGER(mpl) :: ioff2
    INTEGER(mpi) :: j
 
    !                      eigenvalue    eigenvectors  cov.matrix
    CALL devinv(nfgb,workspaceeigenvalues,workspaceeigenvectors,globalmatd)  ! inv
 
    !use elimination for constraints ?
    IF(nfgb < nvgb) THEN
        ! extend, transform eigenvectors
        ioff1=nfgb*nfgb
        ioff2=nfgb*nvgb
        workspaceeigenvectors(ioff2+1:)=0.0_mpd
        DO i=nfgb,1,-1
            ioff1=ioff1-nfgb
            ioff2=ioff2-nvgb
            DO j=nfgb,1,-1
                workspaceeigenvectors(ioff2+j)=workspaceeigenvectors(ioff1+j)
            END DO
            workspaceeigenvectors(ioff2+nfgb+1:ioff2+nvgb)=0.0_mpd
        END DO
        CALL qlmlq(workspaceeigenvectors,nvgb,.false.) ! Q*U
    END IF
 
END SUBROUTINE zdiags
 
 
SUBROUTINE mminrs
    USE mpmod
    USE minresmodule, ONLY: minres
 
    IMPLICIT NONE
    INTEGER(mpi) :: istop
    INTEGER(mpi) :: itn
    INTEGER(mpi) :: itnlim
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: nout
    INTEGER(mpi) :: nrkd
    INTEGER(mpi) :: nrkd2
 
    REAL(mpd) :: shift
    REAL(mpd) :: rtol
    REAL(mpd) :: anorm
    REAL(mpd) :: acond
    REAL(mpd) :: arnorm
    REAL(mpd) :: rnorm
    REAL(mpd) :: ynorm
    LOGICAL :: checka
    EXTERNAL avprds, avprod, mvsolv, mcsolv
    SAVE
    !     ...
    lun=lunlog                       ! log file
 
    nout=lun
    itnlim=2000    ! iteration limit
    shift =0.0_mpd   ! not used
    rtol = mrestl ! from steering
    checka=.false.
 
    workspaced = globalcorrections
    !use elimination for constraints ?
    IF(nfgb < nvgb) THEN
        ! solve L^t*y=d by backward substitution
        CALL qlbsub(vecconsresiduals,vecconssolution)
        ! input to AVPRD0
        vecxav(1:nfgb)=0.0_mpd
        vecxav(nfgb+1:nagb)=vecconssolution
        CALL qlmlq(vecxav,1,.false.) ! Q*x
        ! calclulate vecBav=globalMat*vecXav
        CALL avprd0(nagb,0_mpl,vecxav,vecbav)
        ! correction from eliminated part
        workspaced=workspaced-vecbav
        ! transform, reduce rhs
        CALL qlmlq(workspaced,1,.true.) ! Q^t*b
    END IF
 
    IF(mbandw == 0) THEN           ! default preconditioner
        IF(icalcm == 1) THEN
            IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,1,.true.) ! transform preconditioner matrix
            IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
            WRITE(lun,*) 'MMINRS: PRECONS started', nprecond(2), nprecond(1)
            CALL precons(nprecond(1),nprecond(2),nprecond(3),mszpcc,matprecond,matprecond, &
                matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),nrkd)
            WRITE(lun,*) 'MMINRS: PRECONS ended  ', nrkd
            IF(monpg1 > 0) CALL monend()                
        END IF
        CALL minres(nfgb,  avprod, mcsolv, workspaced, shift, checka ,.true. , &
            globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
    ELSE IF(mbandw > 0) THEN                          ! band matrix preconditioner
        IF(icalcm == 1) THEN
            IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,mbandw,.true.) ! transform preconditioner matrix
            IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
            WRITE(lun,*) 'MMINRS: EQUDECS started', nprecond(2), nprecond(1)
            CALL equdecs(nprecond(2),nprecond(1),nprecond(3),mszpcc,lprecm,matprecond,indprecond,blockprecond,nrkd,nrkd2)
            WRITE(lun,*) 'MMINRS: EQUDECS ended  ', nrkd, nrkd2
            IF(monpg1 > 0) CALL monend()            
        END IF
        CALL minres(nfgb,  avprod, mvsolv, workspaced, shift, checka ,.true. , &
            globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
    ELSE
        CALL minres(nfgb,  avprod, mvsolv, workspaced, shift, checka ,.false. , &
            globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
    END IF
 
    !use elimination for constraints ?
    IF(nfgb < nvgb) THEN
        ! extend, transform back solution
        globalcorrections(nfgb+1:nvgb)=vecconssolution(1:ncgb)
        CALL qlmlq(globalcorrections,1,.false.) ! Q*x
    END IF
 
    iitera=itn
    istopa=istop
    mnrsit=mnrsit+itn
 
    IF (istopa == 0) print *, 'MINRES: istop=0, exact solution x=0.'
 
END SUBROUTINE mminrs
 
 
SUBROUTINE mminrsqlp
    USE mpmod
    USE minresqlpmodule, ONLY: minresqlp
 
    IMPLICIT NONE
    INTEGER(mpi) :: istop
    INTEGER(mpi) :: itn
    INTEGER(mpi) :: itnlim
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: nout
    INTEGER(mpi) :: nrkd
    INTEGER(mpi) :: nrkd2
 
    REAL(mpd) :: rtol
    REAL(mpd) :: mxxnrm
    REAL(mpd) :: trcond
 
    EXTERNAL avprds, avprod, mvsolv, mcsolv
    SAVE
    !     ...
    lun=lunlog                       ! log file
    
    nout=lun
    itnlim=2000    ! iteration limit
    rtol = mrestl ! from steering
    mxxnrm = real(nagb,mpd)/sqrt(epsilon(mxxnrm))
    IF(mrmode == 1) THEN
        trcond = 1.0_mpd/epsilon(trcond) ! only QR
    ELSE IF(mrmode == 2) THEN
        trcond = 1.0_mpd ! only QLP
    ELSE
        trcond = mrtcnd ! QR followed by QLP
    END IF
 
    workspaced = globalcorrections
    !use elimination for constraints ?
    IF(nfgb < nvgb) THEN
        ! solve L^t*y=d by backward substitution
        CALL qlbsub(vecconsresiduals,vecconssolution)
        ! input to AVPRD0
        vecxav(1:nfgb)=0.0_mpd
        vecxav(nfgb+1:nagb)=vecconssolution
        CALL qlmlq(vecxav,1,.false.) ! Q*x
        ! calclulate vecBav=globalMat*vecXav
        CALL avprd0(nagb,0_mpl,vecxav,vecbav)
        ! correction from eliminated part
        workspaced=workspaced-vecbav
        ! transform, reduce rhs
        CALL qlmlq(workspaced,1,.true.) ! Q^t*b
    END IF
 
    IF(mbandw == 0) THEN           ! default preconditioner
        IF(icalcm == 1) THEN
            IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,1,.true.) ! transform preconditioner matrix
            IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
            WRITE(lun,*) 'MMINRS: PRECONS started', nprecond(2), nprecond(1)
            CALL precons(nprecond(1),nprecond(2),nprecond(3),mszpcc,matprecond,matprecond, &
                matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),nrkd)
            WRITE(lun,*) 'MMINRS: PRECONS ended  ', nrkd
            IF(monpg1 > 0) CALL monend()
        END IF
        CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced,  msolve=mcsolv, nout=nout, &
            itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
            x=globalcorrections, istop=istop, itn=itn)
    ELSE IF(mbandw > 0) THEN                          ! band matrix preconditioner
        IF(icalcm == 1) THEN
            IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,mbandw,.true.) ! transform preconditioner matrix
            IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
            WRITE(lun,*) 'MMINRS: EQUDECS started', nprecond(2), nprecond(1)
            CALL equdecs(nprecond(2),nprecond(1),nprecond(3),mszpcc,lprecm,matprecond,indprecond,blockprecond,nrkd,nrkd2)
            WRITE(lun,*) 'MMINRS: EQUDECS ended  ', nrkd, nrkd2
            IF(monpg1 > 0) CALL monend()
        END IF
 
        CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced,  msolve=mvsolv, nout=nout, &
            itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
            x=globalcorrections, istop=istop, itn=itn)
    ELSE
        CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, nout=nout, &
            itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
            x=globalcorrections, istop=istop, itn=itn)
    END IF
 
    !use elimination for constraints ?
    IF(nfgb < nvgb) THEN
        ! extend, transform back solution
        globalcorrections(nfgb+1:nvgb)=vecconssolution(1:ncgb)
        CALL qlmlq(globalcorrections,1,.false.) ! Q*x
    END IF
 
    iitera=itn
    istopa=istop
    mnrsit=mnrsit+itn
 
    IF (istopa == 3) print *, 'MINRES: istop=0, exact solution x=0.'
 
END SUBROUTINE mminrsqlp
 
 
SUBROUTINE mcsolv(n,x,y)         !  solve M*y = x
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi),INTENT(IN) :: n
    REAL(mpd), INTENT(IN)  :: x(n)
    REAL(mpd), INTENT(OUT) :: y(n)
    SAVE
    !     ...
    CALL presols(nprecond(1),nprecond(2),nprecond(3),mszpcc,matprecond, &
        matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),y,x)   
END SUBROUTINE mcsolv
 
 
SUBROUTINE mvsolv(n,x,y)         !  solve M*y = x
    USE mpmod
 
    IMPLICIT NONE
 
    INTEGER(mpi), INTENT(IN) :: n
    REAL(mpd), INTENT(IN)  :: x(n)
    REAL(mpd), INTENT(OUT) :: y(n)
    
    SAVE
    !     ...
    y=x                    ! copy to output vector
 
    CALL equslvs(nprecond(2),nprecond(1),nprecond(3),mszpcc,matprecond,indprecond,blockprecond,y)
END SUBROUTINE mvsolv
 
 
 
!***********************************************************************
 
 
SUBROUTINE xloopn                !
    USE mpmod
 
    IMPLICIT NONE
    REAL(mps) :: catio
    REAL(mps) :: concu2
    REAL(mps) :: concut
    REAL, DIMENSION(2) :: ta
    REAL etime
    INTEGER(mpi) :: i
    INTEGER(mpi) :: iact
    INTEGER(mpi) :: iagain
    INTEGER(mpi) :: idx
    INTEGER(mpi) :: info
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ipoff
    INTEGER(mpi) :: icoff
    INTEGER(mpl) :: ioff
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: ivgbi
    INTEGER(mpi) :: jcalcm
    INTEGER(mpi) :: k
    INTEGER(mpi) :: labelg
    INTEGER(mpi) :: litera
    INTEGER(mpl) :: lrej
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: lunp
    INTEGER(mpi) :: minf
    INTEGER(mpi) :: mrati
    INTEGER(mpi) :: nan
    INTEGER(mpi) :: ncon
    INTEGER(mpi) :: nfaci
    INTEGER(mpi) :: nloopsol
    INTEGER(mpi) :: npar
    INTEGER(mpi) :: nrati
    INTEGER(mpl) :: nrej
    INTEGER(mpi) :: nsol
    INTEGER(mpi) :: inone
#ifdef LAPACK64    
    INTEGER(mpi) :: infolp
    INTEGER(mpi) :: nfit
    INTEGER(mpl) :: imoff
#endif
 
    REAL(mpd) :: stp
    REAL(mpd) :: dratio
    REAL(mpd) :: dwmean
    REAL(mpd) :: db
    REAL(mpd) :: db1
    REAL(mpd) :: db2
    REAL(mpd) :: dbdot
    REAL(mpd) :: dbsig
    LOGICAL :: btest
    LOGICAL :: warner
    LOGICAL :: warners
    LOGICAL :: warnerss
    LOGICAL :: warners3
    LOGICAL :: lsflag
    CHARACTER (LEN=7) :: cratio
    CHARACTER (LEN=7) :: cfacin
    CHARACTER (LEN=7) :: crjrat
    EXTERNAL avprds
    SAVE
    !     ...
 
    !     Printout of algorithm for solution and important parameters ------
 
    lun=lunlog                       ! log file
 
    DO lunp=6,lunlog,lunlog-6
        WRITE(lunp,*) ' '
        WRITE(lunp,*) 'Solution algorithm: '
        WRITE(lunp,121) '=================================================== '
  
        IF(metsol == 1) THEN
            WRITE(lunp,121) 'solution method:','matrix inversion'
        ELSE IF(metsol == 2) THEN
            WRITE(lunp,121) 'solution method:','diagonalization'
        ELSE IF(metsol == 3) THEN
            WRITE(lunp,121) 'solution method:','decomposition'
        ELSE IF(metsol == 4) THEN
            WRITE(lunp,121) 'solution method:', 'minres (Paige/Saunders)'
        ELSE IF(metsol == 5) THEN
            WRITE(lunp,121) 'solution method:', 'minres-qlp (Choi/Paige/Saunders)'
            IF(mrmode == 1) THEN
                WRITE(lunp,121) ' ', '   using QR factorization' ! only QR
            ELSE IF(mrmode == 2) THEN
                WRITE(lunp,121) ' ', '   using QLP factorization' ! only QLP
            ELSE
                WRITE(lunp,121) ' ', '   using QR and QLP factorization' ! QR followed by QLP
                WRITE(lunp,123) 'transition condition', mrtcnd
            END IF
        ELSE IF(metsol == 6) THEN
            WRITE(lunp,121) 'solution method:',  &
                'gmres (generalized minimzation of residuals)'
#ifdef LAPACK64
        ELSE IF(metsol == 7) THEN
            IF (nagb > nvgb) THEN
                WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DSPTRF)'
            ELSE
                WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DPPTRF)'
            ENDIF
            IF(ilperr == 1) WRITE(lunp,121) ' ', 'with error calculation (D??TRI)'
        ELSE IF(metsol == 8) THEN
            IF (nagb > nvgb) THEN
                WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DSYTRF)'
            ELSE
                WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DPOTRF)'
            ENDIF
            IF(ilperr == 1) WRITE(lunp,121) ' ', 'with error calculation (D??TRI)'
#ifdef PARDISO
        ELSE IF(metsol == 9) THEN
            IF (matbsz < 2) THEN
                WRITE(lunp,121) 'solution method:', 'Intel oneMKL PARDISO (sparse matrix (CSR3))'
            ELSE
                WRITE(lunp,121) 'solution method:', 'Intel oneMKL PARDISO (sparse matrix (BSR3))'
            ENDIF
#endif
#endif
        END IF
        WRITE(lunp,123) 'convergence limit at Delta F=',dflim
        WRITE(lunp,122) 'maximum number of iterations=',mitera
        matrit=min(matrit,mitera)
        IF(matrit > 1) THEN
            WRITE(lunp,122) 'matrix recalculation up to ',matrit, '. iteration'
        END IF
        IF(metsol >= 4.AND.metsol < 7) THEN
            IF(matsto == 1) THEN
                WRITE(lunp,121) 'matrix storage:','full'
            ELSE IF(matsto == 2) THEN
                WRITE(lunp,121) 'matrix storage:','sparse'
            END IF
            WRITE(lunp,122) 'pre-con band-width parameter=',mbandw
            IF(mbandw == 0) THEN
                WRITE(lunp,121) 'pre-conditioning:','default'
            ELSE IF(mbandw < 0) THEN
                WRITE(lunp,121) 'pre-conditioning:','none!'
            ELSE IF(mbandw > 0) THEN
                IF(lprecm > 0) THEN
                    WRITE(lunp,121) 'pre-conditioning=','skyline-matrix (rank preserving)'
                ELSE
                    WRITE(lunp,121) 'pre-conditioning=','band-matrix'
                ENDIF
            END IF
        END IF
        IF(regpre == 0.0_mpd.AND.npresg == 0) THEN
            WRITE(lunp,121) 'using pre-sigmas:','no'
        ELSE
            ! FIXME: NPRESG contains parameters that failed the 'entries' cut...
            WRITE(lunp,124) 'pre-sigmas defined for',  &
                REAL(100*npresg,mps)/REAL(nvgb,mps),' % of variable parameters'
            WRITE(lunp,123) 'default pre-sigma=',regpre
        END IF
        IF(nregul == 0) THEN
            WRITE(lunp,121) 'regularization:','no'
        ELSE
            WRITE(lunp,121) 'regularization:','yes'
            WRITE(lunp,123) 'regularization factor=',regula
        END IF
  
        IF(chicut /= 0.0) THEN
            WRITE(lunp,121) 'Chi square cut equiv 3 st.dev applied'
            WRITE(lunp,123) '... in first iteration with factor',chicut
            WRITE(lunp,123) '... in second iteration with factor',chirem
            WRITE(lunp,121) ' (reduced by sqrt in next iterations)'
        END IF
        IF(iscerr > 0) THEN
            WRITE(lunp,121) 'Scaling of measurement errors applied'
            WRITE(lunp,123) '... factor for "global" measuements',dscerr(1)
            WRITE(lunp,123) '... factor for "local"  measuements',dscerr(2)
        END IF
        IF(lhuber /= 0) THEN
            WRITE(lunp,122) 'Down-weighting of outliers in', lhuber,' iterations'
            WRITE(lunp,123) 'Cut on downweight fraction',dwcut
        END IF
  
  
121     FORMAT(1x,a40,3x,a)
122     FORMAT(1x,a40,3x,i0,a)
123     FORMAT(1x,a40,2x,e9.2)
124     FORMAT(1x,a40,3x,f5.1,a)
    END DO
 
    !     initialization of iterations -------------------------------------
 
    iitera=0
    nsol  =0                  ! counter for solutions
    info  =0
    lsinfo=0
    stp   =0.0_mpd
    stepl =real(stp,mps)
    concut=1.0e-12            ! initial constraint accuracy
    concu2=1.0e-06            ! constraint accuracy
    icalcm=1                  ! require matrix calculation
    iterat=0                  ! iteration counter
    iterat=-1
    litera=-2
    nloopsol=0                ! (new) solution from this nloopn
    nrej=0                    ! reset number of rejects
    IF(metsol == 1) THEN
        wolfc2=0.5             ! not accurate
        minf=1
    ELSE IF(metsol == 2) THEN
        wolfc2=0.5             ! not acurate
        minf=2
    ELSE IF(metsol == 3) THEN
        wolfc2=0.5             ! not acurate
        minf=1
    ELSE IF(metsol == 4) THEN
        wolfc2=0.1             ! accurate
        minf=3
    ELSE IF(metsol == 5) THEN
        wolfc2=0.1             ! accurate
        minf=3
    ELSE IF(metsol == 6) THEN
        wolfc2=0.1             ! accurate
        minf=3
    ELSE
        wolfc2=0.5             ! not accurate
        minf=1
    END IF
 
    !     check initial feasibility of constraint equations ----------------
 
    WRITE(*,*) ' '
    IF(nofeas == 0) THEN        ! make parameter feasible
        WRITE(lunlog,*) 'Checking feasibility of parameters:'
        WRITE(*,*) 'Checking feasibility of parameters:'
        CALL feasib(concut,iact) ! check feasibility
        IF(iact /= 0) THEN       ! done ...
            WRITE(*,102) concut
            WRITE(*,*) '   parameters are made feasible'
            WRITE(lunlog,102) concut
            WRITE(lunlog,*) '   parameters are made feasible'
        ELSE                     ! ... was OK
            WRITE(*,*) '   parameters are feasible  (i.e. satisfy constraints)'
            WRITE(lunlog,*) '   parameters are feasible  (i.e. satisfy constraints)'
        END IF
        concut=concu2            ! cut for constraint check
    END IF
    iact=1                      ! set flag for new data loop
    nofeas=0                    ! set check-feasibility flag
 
    WRITE(*,*) ' '
    WRITE(*,*)'Reading files and accumulating vectors/matrices ...'
    WRITE(*,*) ' '
    IF(monpg1>0) THEN
        WRITE(lunlog,*)
        WRITE(lunlog,*)'Reading files and accumulating vectors/matrices ...'
        WRITE(lunlog,*)
    END IF
 
    rstart=etime(ta)
    iterat=-1
    litera= 0
    jcalcm=-1
    iagain= 0
 
    icalcm=1
 
    !     Block 1: data loop with vector (and matrix) calculation ----------
 
    DO
        IF(iterat >= 0) THEN
            lcalcm=jcalcm+3 ! mode (1..4) of last loop
            IF(jcalcm+1 /= 0) THEN
                IF(iterat == 0) THEN
                    CALL ploopa(6) ! header
                    CALL ploopb(6)
                    CALL ploopa(lunlog) ! iteration line
                    CALL ploopb(lunlog)
                    iterat=1
                    CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta)
                ELSE
                    IF(iterat /= litera) THEN
                        CALL ploopb(6)
                        !                  CALL PLOOPA(LUNLOG)
                        CALL ploopb(lunlog)
                        litera=iterat
                        CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,delfun) ! fcn-value (with expected)
                        IF(metsol == 4 .OR. metsol == 5) THEN ! extend to 6, i.e. GMRES?
                            CALL gmpxy(2,real(iterat,mps),real(iitera,mps)) ! MINRES iterations
                        END IF
                    ELSE
                        CALL ploopc(6) ! sub-iteration line
                        CALL ploopc(lunlog)
                        CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta)
                    END IF
                END IF
            ELSE
                CALL ploopd(6) ! solution line
                CALL ploopd(lunlog)
            END IF
            rstart=etime(ta)
            ! CHK
            IF (iabs(jcalcm) <= 1) THEN
                idx=jcalcm+4
                times(idx  )=(times(idx  )*times(idx+3)+deltim) /(times(idx+3)+1.0)
                times(idx+3)= times(idx+3)+1.0
            END IF
        END IF
        jcalcm=icalcm
 
        IF(icalcm >= 0) THEN             ! ICALCM = +1 & 0
            CALL loopn                       ! data loop
            CALL addcst                      ! constraints
            lrej=nrej
            nrej=sum(nrejec) ! total number of rejects
            IF(3*nrej > nrecal) THEN
                WRITE(*,*) ' '
                WRITE(*,*) 'Data records rejected in previous loop:   '
                CALL prtrej(6)
                WRITE(*,*) 'Too many rejects (>33.3%) - stop'
                CALL peend(26,'Aborted, too many rejects')
                stop
            END IF
            ! fill second half (j>i) of global matrix for extended storage, experimental
            IF (icalcm == 1.AND.mextnd > 0)  CALL mhalf2()
        END IF
          !     Block 2: new iteration with calculation of solution --------------
        IF(abs(icalcm) == 1) THEN    ! ICALCM = +1 & -1
            DO i=1,nagb
                globalcorrections(i)=globalvector(i)     ! copy rhs
            END DO
            DO i=1,nvgb
                itgbi=globalparvartototal(i)
                workspacelinesearch(i)=globalparameter(itgbi)  ! copy X for line search
            END DO
 
            iterat=iterat+1                  ! increase iteration count
            IF(metsol == 1) THEN
                CALL minver                   ! inversion
            ELSE IF(metsol == 2) THEN
                CALL mdiags                   ! diagonalization
            ELSE IF(metsol == 3) THEN
                CALL mchdec                   ! decomposition
            ELSE IF(metsol == 4) THEN
                CALL mminrs                   ! MINRES
            ELSE IF(metsol == 5) THEN
                CALL mminrsqlp                ! MINRES-QLP
            ELSE IF(metsol == 6) THEN
                WRITE(*,*) '... reserved for GMRES (not yet!)'
                CALL mminrs                   ! GMRES not yet
#ifdef LAPACK64
            ELSE IF(metsol == 7) THEN
                CALL mdptrf                   ! LAPACK (packed storage)
            ELSE IF(metsol == 8) THEN
                CALL mdutrf                   ! LAPACK (unpacked storage)
#ifdef PARDISO
            ELSE IF(metsol == 9) THEN
                CALL mspardiso                ! Intel oneMKL PARDISO (sparse matrix (CSR3, upper triangle))
#endif
#endif
            END IF
            nloopsol=nloopn                   ! (new) solution for this nloopn
 
            !     check feasibility and evtl. make step vector feasible
 
            DO i=1,nvgb
                itgbi=globalparvartototal(i)
                globalparcopy(itgbi)=globalparameter(itgbi)               ! save
                globalparameter(itgbi)=globalparameter(itgbi)+globalcorrections(i) ! update
            END DO
            CALL feasib(concut,iact)  ! improve constraints
            concut=concu2             ! new cut for constraint check
            DO i=1,nvgb
                itgbi=globalparvartototal(i)
                globalcorrections(i)=globalparameter(itgbi)-globalparcopy(itgbi) ! feasible stp
                globalparameter(itgbi)=globalparcopy(itgbi)               ! restore
            END DO
                
            db=dbdot(nvgb,globalcorrections,globalvector)
            db1=dbdot(nvgb,globalcorrections,globalcorrections)
            db2=dbdot(nvgb,globalvector,globalvector)
            delfun=real(db,mps)
            angras=real(db/sqrt(db1*db2),mps)
            dbsig=16.0_mpd*sqrt(max(db1,db2))*epsilon(db) ! significant change
 
            ! do line search for this iteration/solution ?
            ! lsearch >2: all, =2: all with (next) chicut =1., =1: last, <1: none
            lsflag=(lsearch > 2 .OR. (lsearch == 2 .AND. chicut < 2.25) .OR. &
                (lsearch == 1 .AND. chicut < 2.25 .AND. (delfun <= dflim .OR. iterat >= mitera)))
            lsflag=lsflag .AND. (db > dbsig) ! require significant change
            IF (lsflag) THEN
                ! initialize line search based on slopes and prepare next
                CALL ptldef(wolfc2, 10.0, minf,10)
                IF(metsol == 1) THEN
                    wolfc2=0.5            ! not accurate
                    minf=3
                ELSE IF(metsol == 2) THEN
                    wolfc2=0.5            ! not acurate
                    minf=3
                ELSE IF(metsol == 3) THEN
                    wolfc2=0.5            ! not acurate
                    minf=3
                ELSE IF(metsol == 4) THEN
                    wolfc2=0.1            ! accurate
                    minf=4
                ELSE IF(metsol == 5) THEN
                    wolfc2=0.1            ! accurate
                    minf=4
                ELSE IF(metsol == 6) THEN
                    wolfc2=0.1            ! accurate
                    minf=4
                ELSE
                    wolfc2=0.5            ! not accurate
                    minf=3
                END IF
            ENDIF
 
            ! change significantly negative ?
            IF(db <= -dbsig) THEN
                WRITE(*,*) 'Function not decreasing:',db
                IF(db > -1.0e-3_mpd) THEN ! 100311, VB/CK: allow some margin for numerics
                    iagain=iagain+1
                    IF (iagain <= 1) THEN
                        WRITE(*,*) '... again matrix calculation'
                        icalcm=1
                        cycle
                    ELSE
                        WRITE(*,*) '... aborting iterations'
                        GO TO 90
                    END IF
                ELSE
                    WRITE(*,*) '... stopping iterations'
                    iagain=-1
                    GO TO 90
                END IF
            ELSE
                iagain=0
            END IF
            icalcm=0                         ! switch
        ENDIF
        !     Block 3: line searching ------------------------------------------
 
        IF(icalcm+2 == 0) EXIT
        IF (lsflag) THEN
            CALL ptline(nvgb,workspacelinesearch, &   ! current parameter values
                flines, &          ! chi^2 function value
                globalvector, &    ! gradient
                globalcorrections, &   ! step vector stp
                stp, &             ! returned step factor
                info)              ! returned information
        !      WRITE(*,*) 'PTLINE returns INFO, STP=',INFO, STP
        ELSE ! skip line search
            info=10
            stepl=1.0
            IF (nloopn == nloopsol) THEN  ! new solution: update corrections
                workspacelinesearch=workspacelinesearch+globalcorrections
            ENDIF
        ENDIF
        lsinfo=info
 
        stepl=real(stp,mps)
        nan=0
        DO i=1,nvgb
            itgbi=globalparvartototal(i)
            IF ((.NOT.(workspacelinesearch(i) <= 0.0_mpd)).AND.  &
                (.NOT.(workspacelinesearch(i) > 0.0_mpd))) nan=nan+1
            globalparameter(itgbi)=workspacelinesearch(i) ! current parameter values
        END DO
 
        IF (nan > 0) THEN
            WRITE(*,*) 'Result vector containes ', nan,' NaNs - stop'
            CALL peend(25,'Aborted, result vector contains NaNs')
            stop
        END IF
 
        !     subito exit, if required -----------------------------------------
 
        IF(isubit /= 0) THEN ! subito
            WRITE(*,*) 'Subito!     Exit after first step.'
            GO TO 90
        END IF
 
        IF(info == 0) THEN
            WRITE(*,*) 'INFO=0 should not happen (line search input err)'
            IF (iagain <= 0) THEN
                icalcm=1
                cycle
            ENDIF
        END IF
        IF(info < 0 .OR. nloopn == nloopsol) cycle
        !     Block 4: line search convergence ---------------------------------
 
        CALL ptlprt(lunlog)
        CALL feasib(concut,iact)               ! check constraints
        IF(iact /= 0.OR.chicut > 1.0) THEN
            icalcm=-1
            IF(iterat < matrit) icalcm=+1
            cycle ! iterate
        END IF
        IF(delfun <= dflim)  GO TO 90           ! convergence
        IF(iterat >= mitera) GO TO 90           ! ending
        icalcm=-1
        IF(iterat < matrit) icalcm=+1
        cycle                                ! next iteration
 
        !     Block 5: iteration ending ----------------------------------------
 
90      icalcm=-2
    END DO
    IF(sum(nrejec) /= 0) THEN
        WRITE(*,*) ' '
        WRITE(*,*) 'Data records rejected in last loop:   '
        CALL prtrej(6)
    END IF
    
    ! monitoring of residuals
    IF (imonit > 0 .AND. btest(imonit,1)) CALL monres
    IF (lunmon > 0) CLOSE(unit=lunmon)
    
    ! construct inverse from diagonalization
    IF(metsol == 2) CALL zdiags
 
    IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
#ifdef LAPACK64
        IF (metsol == 7.OR.metsol == 8) THEN
            ! inverse from factorization
            ! loop over blocks (multiple blocks only with elimination !)
            DO ib=1,npblck
                ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
                npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
                icoff=vecparblockconoffsets(ib)         ! constraint offset for block
                ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
                imoff=globalrowoffsets(ipoff+1)+ipoff   ! block offset in global matrix
                nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
                IF (nfit > npar) THEN
                    ! monitor progress
                    IF(monpg1 > 0) THEN
                        WRITE(lunlog,*) 'Inverse of global matrix from LDLt factorization'
                        CALL monini(lunlog,monpg1,monpg2)
                    END IF
                    IF (matsto == 1) THEN
                        !$POMP INST BEGIN(dsptri)
                        CALL dsptri('U',int(nfit,mpl),globalmatd(imoff+1:),lapackipiv(ipoff+1:),workspaced,infolp)
                        IF(infolp /= 0) print *, ' DSPTRI failed: ', infolp
                         !$POMP INST END(dsptri)
                        IF(monpg1 > 0) CALL monend()
                    ELSE
                        !$POMP INST BEGIN(dsytri)
                        CALL dsytri('U',int(nfit,mpl),globalmatd(imoff+1:),int(nfit,mpl),&
                            lapackipiv(ipoff+1:),workspaced,infolp)
                        IF(infolp /= 0) print *, ' DSYTRI failed: ', infolp
                        !$POMP INST END(dsytri)
                        IF(monpg1 > 0) CALL monend()
                    END IF
                ELSE
                    IF(monpg1 > 0) THEN
                        WRITE(lunlog,*) 'Inverse of global matrix from LLt factorization'
                        CALL monini(lunlog,monpg1,monpg2)
                    END IF
                    IF (matsto == 1) THEN
                        !$POMP INST BEGIN(dpptri)
                        CALL dpptri('U',int(nfit,mpl),globalmatd(imoff+1:),infolp)
                        IF(infolp /= 0) print *, ' DPPTRI failed: ', infolp
                        !$POMP INST END(dpptri)
                    ELSE
                        !$POMP INST BEGIN(dpotri)
                        CALL dpotri('U',int(nfit,mpl),globalmatd(imoff+1:),int(npar,mpl),infolp)
                        IF(infolp /= 0) print *, ' DPOTRI failed: ', infolp
                        !$POMP INST END(dpotri)
                    END IF
                    IF(monpg1 > 0) CALL monend()
                END IF
            END DO
        END IF
#endif
        !use elimination for constraints ?
        IF(nfgb < nvgb) THEN
            ! extend, transform matrix
            ! loop over blocks
            DO ib=1,npblck
                ipoff=matparblockoffsets(1,ib)          ! parameter offset for block
                npar=matparblockoffsets(1,ib+1)-ipoff   ! number of parameters in block
                icoff=vecparblockconoffsets(ib)         ! constraint offset for block
                ncon=vecparblockconoffsets(ib+1)-icoff  ! number of constraints in block
                DO i=npar-ncon+1,npar
                    ioff=globalrowoffsets(i+ipoff)+ipoff
                    globalmatd(ioff+1:ioff+i)=0.0_mpd
                END DO
            END DO
            ! monitor progress
            IF(monpg1 > 0) THEN
                WRITE(lunlog,*) 'Expansion of global matrix (A->Q*A*Q^t)'
                CALL monini(lunlog,monpg1,monpg2)
            END IF
            IF(icelim < 2) THEN
                CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.false.) ! Q*A*Q^t
#ifdef LAPACK64                    
            ELSE ! unpack storage, use LAPACK
                CALL lpavat(.false.)
#endif
            END IF
            IF(monpg1 > 0) CALL monend()
        END IF
    END IF
 
    dwmean=sumndf/real(ndfsum,mpd)
    dratio=fvalue/dwmean/real(ndfsum-nfgb,mpd)
    catio=real(dratio,mps)
    IF(nloopn /= 1.AND.lhuber /= 0) THEN
        catio=catio/0.9326  ! correction Huber downweighting (in global chi2)
    END IF
    mrati=nint(100.0*catio,mpi)
 
    DO lunp=6,lunlog,lunlog-6
        WRITE(lunp,*) ' '
        IF (nfilw <= 0) THEN
            WRITE(lunp,*) 'Sum(Chi^2)/Sum(Ndf) =',fvalue
            WRITE(lunp,*) '                    / (',ndfsum,'-',nfgb,')'
            WRITE(lunp,*) '                    =',dratio
        ELSE
            WRITE(lunp,*) 'Sum(W*Chi^2)/Sum(Ndf)/<W> =',fvalue
            WRITE(lunp,*) '                          / (',ndfsum,'-', nfgb,')'
            WRITE(lunp,*) '                          /',dwmean
            WRITE(lunp,*) '                          =',dratio
        END IF
        WRITE(lunp,*) ' '
        IF(nloopn /= 1.AND.lhuber /= 0) WRITE(lunp,*)  &
            '            with correction for down-weighting   ',catio
    END DO
    nrej=sum(nrejec) ! total number of rejects
 
    !     ... the end with exit code ???????????????????????????????????????
 
    !      WRITE(*,199)              ! write exit code
    !     + '-----------------------------------------------------------'
    !      IF(ITEXIT.EQ.0) WRITE(*,199)
    !     +  'Exit code = 0:  Convergence reached'
    !      IF(ITEXIT.EQ.1) WRITE(*,199)
    !     +  'Exit code = 1:  No improvement in last iteration'
    !      IF(ITEXIT.EQ.2) WRITE(*,199)
    !     +  'Exit code = 2:  Maximum number of iterations reached'
    !      IF(ITEXIT.EQ.3) WRITE(*,199)
    !     +  'Exit code = 3:  Failure'
    !      WRITE(*,199)
    !     + '-----------------------------------------------------------'
    !      WRITE(*,199) ' '
 
 
    nrati=nint(10000.0*real(nrej,mps)/real(nrecal,mps),mpi)
    WRITE(crjrat,197) 0.01_mpd*real(nrati,mpd)
    nfaci=nint(100.0*sqrt(catio),mpi)
 
    WRITE(cratio,197) 0.01_mpd*real(mrati,mpd)
    WRITE(cfacin,197) 0.01_mpd*real(nfaci,mpd)
 
    warner=.false. ! warnings
    IF(mrati < 90.OR.mrati > 110) warner=.true.
    IF(nrati > 100) warner=.true.
    IF(ncgbe /= 0) warner=.true.
    warners = .false. ! severe warnings
    IF(nalow /= 0) warners=.true.
    warnerss = .false. ! more severe warnings
    IF(nmiss1 /= 0) warnerss=.true.
    IF(iagain /= 0) warnerss=.true.
    IF(ndefec /= 0) warnerss=.true.
    IF(ndefpg /= 0) warnerss=.true.
    warners3 = .false. ! more severe warnings
    IF(nrderr /= 0) warners3=.true.
 
    IF(warner.OR.warners.OR.warnerss.Or.warners3) THEN
        WRITE(*,199) ' '
        WRITE(*,199) ' '
        WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
        WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
        WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
        WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
        WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
        WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
        WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
 
        IF(mrati < 90.OR.mrati > 110) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Chi^2/Ndf = ',cratio, '  (should be close to 1)'
            WRITE(*,*) '        => multiply all input standard ',  &
                'deviations by factor',cfacin
        END IF
 
        IF(nrati > 100) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Fraction of rejects =',crjrat,' %',  &
                '  (should be far below 1 %)'
            WRITE(*,*) '        => please provide correct mille data'
            CALL chkrej ! check (and print) rejection details
        END IF
 
        IF(iagain /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Matrix not positiv definite '//  &
                '(function not decreasing)'
            WRITE(*,*) '        => please provide correct mille data'
        END IF
 
        IF(ndefec /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Rank defect =',ndefec,  &
                '  for global matrix, should be 0'
            WRITE(*,*) '        => please provide correct mille data'
        END IF
 
        IF(ndefpg /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Rank defect for',ndefpg,  &
                ' parameter groups, should be 0'
            WRITE(*,*) '        => please provide correct mille data'
        END IF
 
        IF(nmiss1 /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Rank defect =',nmiss1,  &
                '  for constraint equations, should be 0'
            WRITE(*,*) '        => please correct constraint definition'
        END IF
                
        IF(ncgbe /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Number of empty constraints =',ncgbe, ', should be 0'
            WRITE(*,*) '        => please check constraint definition, mille data'
        END IF
 
        IF(nxlow /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Possible rank defects =',nxlow, ' for global matrix'
            WRITE(*,*) '        (too few accepted entries)'
            WRITE(*,*) '        => please check mille data and ENTRIES cut'
        END IF
            
        IF(nalow /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Possible bad elements =',nalow, ' in global vector'
            WRITE(*,*) '        (toos few accepted entries)'
            IF(ipcntr > 0) WRITE(*,*) '        (indicated in millepede.res by counts<0)'
            WRITE(*,*) '        => please check mille data and ENTRIES cut'
        END IF
        
        IF(nrderr /= 0) THEN
            WRITE(*,199) ' '
            WRITE(*,*) '        Binary file(s) with read errors =',nrderr, ' (treated as EOF)'
            WRITE(*,*) '        => please check mille data'
        END IF
        
        WRITE(*,199) ' '
        WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
        WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
        WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
        WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
        WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
        WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
        WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
        WRITE(*,199) ' '
 
    ENDIF
 
    CALL mend                ! modul ending
 
    !     ------------------------------------------------------------------
 
    IF(metsol == 1) THEN
 
    ELSE IF(metsol == 2) THEN
        ! CALL zdiags moved up (before qlssq)
    ELSE IF(metsol == 3) THEN
        ! decomposition - nothing foreseen yet
    ELSE IF(metsol == 4 .OR. metsol == 5) THEN
        !        errors and correlations from MINRES
        DO  k=1,mnrsel
            labelg=lbmnrs(k)
            IF(labelg == 0) cycle
            itgbi=inone(labelg)
            ivgbi=0
            IF(itgbi /= 0) ivgbi=globalparlabelindex(2,itgbi)
            IF(ivgbi < 0) ivgbi=0
            IF(ivgbi == 0) cycle
            !          determine error and global correlation for parameter IVGBI
            IF (metsol == 4) THEN
                CALL solglo(ivgbi)
            ELSE
                CALL solgloqlp(ivgbi)
            ENDIF
        END DO
  
    ELSE IF(metsol == 6) THEN
 
#ifdef LAPACK64
    ELSE IF(metsol == 7) THEN
        ! LAPACK - nothing foreseen yet
#endif
    END IF
 
    CALL prtglo              ! print result
 
    IF (warners3) THEN
        CALL peend(4,'Ended with severe warnings (bad binary file(s))')
    ELSE IF (warnerss) THEN
        CALL peend(3,'Ended with severe warnings (bad global matrix)')
    ELSE IF (warners) THEN
        CALL peend(2,'Ended with severe warnings (insufficient measurements)')
    ELSE IF (warner) THEN
        CALL peend(1,'Ended with warnings (bad measurements)')
    ELSE
        CALL peend(0,'Ended normally')
    END IF
 
102 FORMAT(' Call FEASIB with cut=',g10.3)
    ! 103  FORMAT(1X,A,G12.4)
197 FORMAT(f7.2)
199 FORMAT(7x,a)
END SUBROUTINE xloopn                ! standard solution
 
 
 
SUBROUTINE chkrej
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: kfl
    INTEGER(mpi) :: kmin
    INTEGER(mpi) :: kmax
    INTEGER(mpi) :: nrc
    INTEGER(mpl) :: nrej
    
    REAL(mps) :: fmax
    REAL(mps) :: fmin
    REAL(mps) :: frac
 
    REAL(mpd) :: sumallw
    REAL(mpd) :: sumrejw
    
    sumallw=0.; sumrejw=0.;
    kmin=0; kmax=0;
    fmax=-1.; fmin=2;
    
    DO i=1,nfilb
        kfl=kfd(2,i)
        nrc=-kfd(1,i)
        IF (nrc > 0) THEN
            nrej=nrc-jfd(kfl)
            sumallw=sumallw+real(nrc,mpd)*wfd(kfl)
            sumrejw=sumrejw+real(nrej,mpd)*wfd(kfl)
            frac=real(nrej,mps)/real(nrc,mps)
            IF (frac > fmax) THEN
                kmax=kfl
                fmax=frac
            END IF
            IF (frac < fmin) THEN
                kmin=kfl
                fmin=frac
            END IF
        END IF
    END DO
    IF (nfilw > 0) &
        WRITE(*,"('         Weighted fraction  =',F8.2,' %')") 100.*sumrejw/sumallw
    IF (nfilb > 1) THEN
        WRITE(*,"('         File with max. fraction ',I6,' :',F8.2,' %')") kmax, 100.*fmax
        WRITE(*,"('         File with min. fraction ',I6,' :',F8.2,' %')") kmin, 100.*fmin
    END IF
 
END SUBROUTINE chkrej
 
 
SUBROUTINE filetc
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: iargc
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ie
    INTEGER(mpi) :: ierrf
    INTEGER(mpi) :: ieq
    INTEGER(mpi) :: ifilb
    INTEGER(mpi) :: ioff
    INTEGER(mpi) :: iopt
    INTEGER(mpi) :: ios
    INTEGER(mpi) :: iosum
    INTEGER(mpi) :: it
    INTEGER(mpi) :: k
    INTEGER(mpi) :: mat
    INTEGER(mpi) :: nab
    INTEGER(mpi) :: nline
    INTEGER(mpi) :: npat
    INTEGER(mpi) :: ntext
    INTEGER(mpi) :: nu
    INTEGER(mpi) :: nuf
    INTEGER(mpi) :: nums
    INTEGER(mpi) :: nufile
    INTEGER(mpi) :: lenfileInfo
    INTEGER(mpi) :: lenFileNames
    INTEGER(mpi) :: matint
    INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: vecfileInfo
    INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArray
    INTEGER(mpl) :: rows
    INTEGER(mpl) :: cols
    INTEGER(mpl) :: newcols
    INTEGER(mpl) :: length
 
    CHARACTER (LEN=1024) :: text
    CHARACTER (LEN=1024) :: fname
    CHARACTER (LEN=14) :: bite(3)
    CHARACTER (LEN=32) :: keystx
    INTEGER(mpi), PARAMETER :: mnum=100
    REAL(mpd) :: dnum(mnum)
 
#ifdef READ_C_FILES
    INTERFACE
        SUBROUTINE initc(nfiles) BIND(c)
            USE iso_c_binding
            INTEGER(c_int), INTENT(IN), VALUE :: nfiles
        END SUBROUTINE initc
    END INTERFACE
#endif
 
    SAVE
    DATA bite/'C_binary','text  ','Fortran_binary'/
    !     ...
    CALL mstart('FILETC/X')
 
    nuf=1  ! C binary is default
    DO i=1,8
        times(i)=0.0
    END DO
 
    !     read command line options ----------------------------------------
 
    filnam=' '   ! print command line options and find steering file
    DO i=1,iargc()
        IF(i == 1) THEN
            WRITE(*,*) ' '
            WRITE(*,*) 'Command line options: '
            WRITE(*,*) '--------------------- '
        END IF
        CALL getarg(i,text)         ! get I.th text from command line
        CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
        WRITE(*,101) i,text(1:nab)  ! echo print
        IF(text(ia:ia) /= '-') THEN
            nu=nufile(text(ia:ib))   ! inquire on file existence
            IF(nu == 2) THEN         ! existing text file
                IF(filnam /= ' ') THEN
                    WRITE(*,*) 'Second text file in command line - stop'
                    CALL peend(12,'Aborted, second text file in command line')
                    stop
                ELSE
                    filnam=text
                END IF
            ELSE
                WRITE(*,*) 'Open error for file:',text(ia:ib),' - stop'
                CALL peend(16,'Aborted, open error for file')
                IF(text(ia:ia) /= '/') THEN
                    CALL getenv('PWD',text)
                    CALL rltext(text,ia,ib,nab)
                    WRITE(*,*) 'PWD:',text(ia:ib)
                END IF
                stop
            END IF
        ELSE
            IF(index(text(ia:ib),'b') /= 0) THEN
                mdebug=3 ! debug flag
                WRITE(*,*) 'Debugging requested'
            END IF
            it=index(text(ia:ib),'t')
            IF(it /= 0) THEN
                ictest=1  ! internal test files
                ieq=index(text(ia+it:ib),'=')+it
                IF (it /= ieq) THEN
                    IF (index(text(ia+ieq:ib),'SL0' ) /= 0) ictest=2
                    IF (index(text(ia+ieq:ib),'SLE' ) /= 0) ictest=3
                    IF (index(text(ia+ieq:ib),'BP'  ) /= 0) ictest=4
                    IF (index(text(ia+ieq:ib),'BRLF') /= 0) ictest=5
                    IF (index(text(ia+ieq:ib),'BRLC') /= 0) ictest=6
                END IF
            END IF
            IF(index(text(ia:ib),'s') /= 0) isubit=1  ! like "subito"
            IF(index(text(ia:ib),'f') /= 0) iforce=1  ! like "force"
            IF(index(text(ia:ib),'c') /= 0) icheck=1  ! like "checkinput"
            IF(index(text(ia:ib),'C') /= 0) icheck=2  ! like "checkinput 2"
        END IF
        IF(i == iargc()) WRITE(*,*) '--------------------- '
    END DO
 
 
    !     create test files for option -t ----------------------------------
 
    IF(ictest >= 1) THEN
        WRITE(*,*) ' '
        IF (ictest == 1) THEN
            CALL mptest ! 'wire chamber'
        ELSE
            CALL mptst2(ictest-2) ! 'silicon tracker'
        END IF
        IF(filnam == ' ') filnam='mp2str.txt'
        WRITE(*,*) ' '
    END IF
 
    !     check default steering file with file-name "steerfile" -----------
 
    IF(filnam == ' ') THEN  ! check default steering file
        text='steerfile'
        CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
        nu=nufile(text(ia:ib))      ! inquire on file existence and type
        IF(nu > 0) THEN
            filnam=text
        ELSE
            CALL peend(10,'Aborted, no steering file')
            stop 'in FILETC: no steering file.                      .'
        END IF
    END IF
 
 
    !     open, read steering file:
    !                               end
    !                               fortranfiles
    !                               cfiles
 
 
    CALL rltext(filnam,ia,ib,nfnam) ! return indices for non-blank area
    WRITE(*,*) ' '
    WRITE(*,*) 'Listing of steering file: ',filnam(1:nfnam)
    WRITE(*,*) '-------------------------'
    OPEN(10,file=filnam(1:nfnam),iostat=ios)
    IF(ios /= 0) THEN
        WRITE(*,*) 'Open error for steering file - stop'
        CALL peend(11,'Aborted, open error for steering file')
        IF(filnam(1:1) /= '/') THEN
            CALL getenv('PWD',text)
            CALL rltext(text,ia,ib,nab)
            WRITE(*,*) 'PWD:',text(ia:ib)
        END IF
        stop
    END IF
    ifile =0
    nfiles=0
 
    lenfileinfo=2
    lenfilenames=0
    rows=6; cols=lenfileinfo
    CALL mpalloc(vecfileinfo,rows,cols,'file info from steering')
    nline=0
    DO
        READ(10,102,iostat=ierrf) text        ! read steering file
        IF (ierrf < 0) EXIT ! eof
        CALL rltext(text,ia,ib,nab)     ! return indices for non-blank area
        nline=nline+1
        IF(nline <= 50) THEN   ! print up to 50 lines
            WRITE(*,101) nline,text(1:nab)
            IF(nline == 50)  WRITE(*,*) '     ...'
        END IF
        IF(ia == 0) cycle      ! skip empty lines
 
        CALL rltext(text,ia,ib,nab)        ! test content   'end'
        IF(ib == ia+2) THEN
            mat=matint(text(ia:ib),'end',npat,ntext)
            IF(mat == max(npat,ntext)) THEN ! exact matching
                text=' '
                CALL intext(text,nline)
                WRITE(*,*) '    end-statement after',nline,' text lines'
                EXIT
            END IF
        END IF
        
        keystx='fortranfiles'
        mat=matint(text(ia:ib),keystx,npat,ntext)
        IF(mat == max(npat,ntext)) THEN ! exact matching
            nuf=3
            !         WRITE(*,*) 'Fortran files'
            cycle
        END IF
 
        keystx='Cfiles'
        mat=matint(text(ia:ib),keystx,npat,ntext)
        IF(mat == max(npat,ntext)) THEN ! exact matching
            nuf=1
            !         WRITE(*,*) 'Cfiles'
            cycle
        END IF
 
        keystx='closeandreopen' ! don't keep binary files open
        mat=matint(text(ia:ib),keystx,npat,ntext)
        IF(mat == max(npat,ntext)) THEN ! exact matching
            keepopen=0
            cycle
        END IF
 
        ! file names
        !     check for file options (' -- ')
        ie=ib
        iopt=index(text(ia:ib),' -- ')
        IF (iopt > 0) ie=iopt-1
 
        IF(nab == 0) cycle
        nu=nufile(text(ia:ie))           ! inquire on file existence
        IF(nu > 0) THEN                  ! existing file
            IF (nfiles == lenfileinfo) THEN ! increase length
                CALL mpalloc(temparray,rows,cols,'temp file info from steering')
                temparray=vecfileinfo
                CALL mpdealloc(vecfileinfo)
                lenfileinfo=lenfileinfo*2
                newcols=lenfileinfo
                CALL mpalloc(vecfileinfo,rows,newcols,'file info from steering')
                vecfileinfo(:,1:cols)=temparray(:,1:cols)
                CALL mpdealloc(temparray)
                cols=newcols
            ENDIF
            nfiles=nfiles+1              ! count number of files
            IF(nu == 1) nu=nuf           !
            lenfilenames=lenfilenames+ie-ia+1 ! total length of file names
            vecfileinfo(1,nfiles)=nline  ! line number
            vecfileinfo(2,nfiles)=nu     ! cbinary =1, text =2, fbinary=3
            vecfileinfo(3,nfiles)=ia     ! file name start
            vecfileinfo(4,nfiles)=ie     ! file name end
            vecfileinfo(5,nfiles)=iopt   ! option start
            vecfileinfo(6,nfiles)=ib     ! option end
        ELSE
        !         WRITE(*,*) 'Open error for file ',TEXT(IA:IB)
        !         STOP
        END IF
    END DO
    rewind 10
    ! read again to fill dynamic arrays with file info
    length=nfiles
    CALL mpalloc(mfd,length,'file type')
    CALL mpalloc(nfd,length,'file line (in steering)')
    CALL mpalloc(lfd,length,'file name length')
    CALL mpalloc(ofd,length,'file option')
    length=lenfilenames
    CALL mpalloc(tfd,length,'file name')
    nline=0
    i=1
    ioff=0
    DO
        READ(10,102,iostat=ierrf) text        ! read steering file
        IF (ierrf < 0) EXIT ! eof
        nline=nline+1
        IF (nline == vecfileinfo(1,i)) THEN
            nfd(i)=vecfileinfo(1,i)
            mfd(i)=vecfileinfo(2,i)
            ia=vecfileinfo(3,i)-1
            lfd(i)=vecfileinfo(4,i)-ia ! length file name
            DO k=1,lfd(i)
                tfd(ioff+k)=text(ia+k:ia+k)
            END DO
            !            tfd(i)=text(vecFileInfo(3,i):vecFileInfo(4,i))      ! file name
            ioff=ioff+lfd(i)
            ofd(i)=1.0              ! option for file
            IF (vecfileinfo(5,i) > 0) THEN
                CALL ratext(text(vecfileinfo(5,i)+4:vecfileinfo(6,i)),nums,dnum,mnum) ! translate text to DP numbers
                IF (nums > 0) ofd(i)=real(dnum(1),mps)
            END IF
            i=i+1
            IF (i > nfiles) EXIT
        ENDIF
    ENDDO
    CALL mpdealloc(vecfileinfo)
    rewind 10
    ! additional info for binary files
    length=nfiles; rows=2
    CALL mpalloc(ifd,length,'integrated record numbers (=offset)')
    CALL mpalloc(jfd,length,'number of accepted records')
    CALL mpalloc(kfd,rows,length,'number of records in file, file order')
    CALL mpalloc(dfd,length,'ndf sum')
    CALL mpalloc(xfd,length,'max. record size')
    CALL mpalloc(wfd,length,'file weight')
    CALL mpalloc(cfd,length,'chi2 sum')
    CALL mpalloc(sfd,rows,length,'start, end of file name in TFD')
    CALL mpalloc(yfd,length,'modification date')
    yfd=0
    !
    WRITE(*,*) '-------------------------'
    WRITE(*,*) ' '
 
    !     print table of files ---------------------------------------------
 
    IF (mprint > 1) THEN
        WRITE(*,*) 'Table of files:'
        WRITE(*,*) '---------------'
    END IF
    WRITE(8,*) ' '
    WRITE(8,*) 'Text and data files:'
    ioff=0
    DO i=1,nfiles
        DO k=1,lfd(i)
            fname(k:k)=tfd(ioff+k)
        END DO
        !        fname=tfd(i)(1:lfd(i))
        IF (mprint > 1) WRITE(*,103) i,bite(mfd(i)),fname(1:lfd(i))
        WRITE(8,103) i,bite(mfd(i)),fname(1:lfd(i))
        ioff=ioff+lfd(i)
    END DO
    IF (mprint > 1) THEN
        WRITE(*,*) '---------------'
        WRITE(*,*) ' '
    END IF
 
    !     open the binary Fortran (data) files on unit 11, 12, ...
 
    iosum=0
    nfilf=0
    nfilb=0
    nfilw=0
    ioff=0
    ifilb=0
    IF (keepopen < 1) ifilb=1
    DO i=1,nfiles
        IF(mfd(i) == 3) THEN
            nfilf=nfilf+1
            nfilb=nfilb+1
            ! next file name
            sfd(1,nfilb)=ioff
            sfd(2,nfilb)=lfd(i)
            CALL binopn(nfilb,ifilb,ios)
            IF(ios == 0) THEN
                wfd(nfilb)=ofd(i)
                IF (keepopen < 1) CALL bincls(nfilb,ifilb)
            ELSE ! failure
                iosum=iosum+1
                nfilf=nfilf-1
                nfilb=nfilb-1
            END IF
        END IF
        ioff=ioff+lfd(i)
    END DO
 
    !     open the binary C files
 
    nfilc=-1
    ioff=0
    DO i=1,nfiles                                 ! Cfiles
        IF(mfd(i) == 1) THEN
#ifdef READ_C_FILES
            IF(nfilc < 0) THEN ! initialize
                CALL initc(max(nfiles,mthrdr)) ! uncommented by GF
                nfilc=0
            END IF
            nfilc=nfilc+1
            nfilb=nfilb+1
            ! next file name
            sfd(1,nfilb)=ioff
            sfd(2,nfilb)=lfd(i)
            CALL binopn(nfilb,ifilb,ios)
            IF(ios == 0) THEN
                wfd(nfilb)=ofd(i)
                IF (keepopen < 1) CALL bincls(nfilb,ifilb)
            ELSE ! failure
                iosum=iosum+1
                nfilc=nfilc-1
                nfilb=nfilb-1
            END IF
#else
            WRITE(*,*) 'Opening of C-files not supported.'
            ! GF add
            iosum=iosum+1
            ! GF add end
#endif
        END IF
        ioff=ioff+lfd(i)
    END DO
 
    DO k=1,nfilb
        kfd(1,k)=1   ! reset (negated) record counters
        kfd(2,k)=k   ! set file number
        ifd(k)=0     ! reset integrated record numbers
        xfd(k)=0     ! reset max record size
    END DO
 
    IF(iosum /= 0) THEN
        CALL peend(15,'Aborted, open error(s) for binary files')
        stop 'FILETC: open error                                      '
    END IF
    IF(nfilb == 0) THEN
        CALL peend(14,'Aborted, no binary files')
        stop 'FILETC: no binary files                                 '
    END IF
    IF (keepopen > 0) THEN
        WRITE(*,*) nfilb,' binary files opened' ! corrected by GF
    ELSE
        WRITE(*,*) nfilb,' binary files opened and closed' ! corrected by GF
    END IF
101 FORMAT(i3,2x,a)
102 FORMAT(a)
103 FORMAT(i3,2x,a14,3x,a)
    !    CALL mend
    RETURN
END SUBROUTINE filetc
 
 
SUBROUTINE filetx ! ---------------------------------------------------
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ierrf
    INTEGER(mpi) :: ioff
    INTEGER(mpi) :: ios
    INTEGER(mpi) :: iosum
    INTEGER(mpi) :: k
    INTEGER(mpi) :: mat
    INTEGER(mpi) :: nab
    INTEGER(mpi) :: nfiln
    INTEGER(mpi) :: nline
    INTEGER(mpi) :: nlinmx
    INTEGER(mpi) :: npat
    INTEGER(mpi) :: ntext
    INTEGER(mpi) :: matint
 
    !      CALL MSTART('FILETX')
 
    CHARACTER (LEN=1024) :: text
    CHARACTER (LEN=1024) :: fname
 
    WRITE(*,*) ' '
    WRITE(*,*) 'Processing text files ...'
    WRITE(*,*) ' '
 
    iosum=0
    ioff=0
    DO i=0,nfiles
        IF(i == 0) THEN
            WRITE(*,*) 'File ',filnam(1:nfnam)
            nlinmx=100
        ELSE
            nlinmx=10
            ia=ioff
            ioff=ioff+lfd(i)
            IF(mfd(i) /= 2) cycle ! exclude binary files
            DO k=1,lfd(i)
                fname(k:k)=tfd(ia+k)
            END DO
            WRITE(*,*) 'File ',fname(1:lfd(i))
            IF (mprint > 1) WRITE(*,*) ' '
            OPEN(10,file=fname(1:lfd(i)),iostat=ios,form='FORMATTED')
            IF(ios /= 0) THEN
                WRITE(*,*) 'Open error for file ',fname(1:lfd(i))
                iosum=iosum+1
                cycle
            END IF
        END IF
  
        nline=0
        nfiln=1
        !      read text file
        DO
            READ(10,102,iostat=ierrf) text
            IF (ierrf < 0) THEN
                text=' '
                CALL intext(text,nline)
                WRITE(*,*) '    end-of-file after',nline,' text lines'
                EXIT ! eof
            ENDIF
            nline=nline+1
            IF(nline <= nlinmx.AND.mprint > 1) THEN ! print first 10 lines of every text fiLE
                CALL rltext(text,ia,ib,nab)
                nab=max(1,nab)
                WRITE(*,101) nline,text(1:nab)
                IF(nline == nlinmx) WRITE(*,*) '    ...'
            END IF
  
            CALL rltext(text,ia,ib,nab)        ! test content   'end'
            IF(ib == ia+2) THEN
                mat=matint(text(ia:ib),'end',npat,ntext)
                IF(mat == max(npat,ntext)) THEN ! exact matching
                    text=' '
                    CALL intext(text,nline)
                    WRITE(*,*) '    end-statement after',nline,' text lines'
                    EXIT
                END IF
            END IF
  
            IF(i == 0) THEN ! first text file - exclude lines with file names
                IF(nfiln <= nfiles) THEN
                    IF(nline == nfd(nfiln)) THEN
                        nfiln=nfiln+1
                        text=' '
                    !             WRITE(*,*) 'line is excluded ',TEXT(1:10)
                    END IF
                END IF
            END IF
            !       WRITE(*,*) TEXT(1:40),'  < interprete text'
            CALL intext(text,nline)   ! interprete text
        END DO
        WRITE(*,*) ' '
        rewind 10
        CLOSE(unit=10)
    END DO
 
    IF(iosum /= 0) THEN
        CALL peend(16,'Aborted, open error(s) for text files')
        stop 'FILETX: open error(s) in text files                     '
    END IF
 
    WRITE(*,*) '... end of text file processing.'
    WRITE(*,*) ' '
 
    IF(lunkno /= 0) THEN
        WRITE(*,*) ' '
        WRITE(*,*) lunkno,' unknown keywords in steering files, ',  &
            'or file non-existing,'
        WRITE(*,*) '   see above!'
        WRITE(*,*) '------------>    stop'
        WRITE(*,*) ' '
        CALL peend(13,'Aborted, unknown keywords in steering file')
        stop
    END IF
 
    !     check methods
 
    IF(metsol == 0) THEN        ! if undefined
        IF(matsto == 0) THEN     ! if unpacked symmetric
            metsol=8 ! LAPACK
        ELSE IF(matsto == 1) THEN ! if full symmetric
            metsol=4 ! MINRES
        ELSE IF(matsto == 2) THEN ! if sparse
            metsol=4 ! MINRES
        END IF
    ELSE IF(metsol == 1) THEN   ! if inversion
        matsto=1
    ELSE IF(metsol == 2) THEN   ! if diagonalization
        matsto=1
    ELSE IF(metsol == 3) THEN   ! if decomposition
        matsto=1
    ELSE IF(metsol == 4) THEN   ! if MINRES
    !        MATSTO=2 or 1
    ELSE IF(metsol == 5) THEN   ! if MINRES-QLP
    !        MATSTO=2 or 1
    ELSE IF(metsol == 6) THEN   ! if GMRES
    !        MATSTO=2 or 1
#ifdef LAPACK64
    ELSE IF(metsol == 7) THEN   ! if LAPACK
        matsto=1
    ELSE IF(metsol == 8) THEN   ! if LAPACK
        matsto=0
#ifdef PARDISO
    ELSE IF(metsol == 9) THEN   ! if Intel oneMKL PARDISO
        matsto=3
#endif
#endif
    ELSE
        WRITE(*,*) 'MINRES forced with sparse matrix!'
        WRITE(*,*) ' '
        WRITE(*,*) 'MINRES forced with sparse matrix!'
        WRITE(*,*) ' '
        WRITE(*,*) 'MINRES forced with sparse matrix!'
        metsol=4 ! forced
        matsto=2 ! forced
    END IF
    IF(matsto > 4) THEN
        WRITE(*,*) 'MINRES forced with sparse matrix!'
        WRITE(*,*) ' '
        WRITE(*,*) 'MINRES forced with sparse matrix!'
        WRITE(*,*) ' '
        WRITE(*,*) 'MINRES forced with sparse matrix!'
        metsol=4 ! forced
        matsto=2 ! forced
    END IF
 
    !     print information about methods and matrix storage modes
 
    WRITE(*,*) ' '
    WRITE(*,*) 'Solution method and matrix-storage mode:'
    IF(metsol == 1) THEN
        WRITE(*,*) '     METSOL = 1:  matrix inversion'
    ELSE IF(metsol == 2) THEN
        WRITE(*,*) '     METSOL = 2:  diagonalization'
    ELSE IF(metsol == 3) THEN
        WRITE(*,*) '     METSOL = 3:  decomposition'
    ELSE IF(metsol == 4) THEN
        WRITE(*,*) '     METSOL = 4:  MINRES'
    ELSE IF(metsol == 5) THEN
        WRITE(*,*) '     METSOL = 5:  MINRES-QLP'
    ELSE IF(metsol == 6) THEN
        WRITE(*,*) '     METSOL = 6:  GMRES (-> MINRES)'
#ifdef LAPACK64
    ELSE IF(metsol == 7) THEN
        WRITE(*,*) '     METSOL = 7:  LAPACK factorization'
    ELSE IF(metsol == 8) THEN
        WRITE(*,*) '     METSOL = 8:  LAPACK factorization'
#ifdef PARDISO
    ELSE IF(metsol == 9) THEN
        WRITE(*,*) '     METSOL = 9:  Intel oneMKL PARDISO'
#endif
#endif
    END IF
 
    WRITE(*,*) '                  with',mitera,' iterations'
 
    IF(matsto == 0) THEN
        WRITE(*,*) '     MATSTO = 0:  unpacked symmetric matrix, ', 'n*n elements'
    ELSEIF(matsto == 1) THEN
        WRITE(*,*) '     MATSTO = 1:  full symmetric matrix, ', '(n*n+n)/2 elements'
    ELSE IF(matsto == 2) THEN
        WRITE(*,*) '     MATSTO = 2:  sparse matrix (custom)'
    ELSE IF(matsto == 3) THEN
        IF (mpdbsz == 0) THEN
            WRITE(*,*) '     MATSTO = 3:  sparse matrix (upper triangle, CSR3)'
        ELSE
            WRITE(*,*) '     MATSTO = 3:  sparse matrix (upper triangle, BSR3)'
        END IF
    END IF
    IF(mbandw /= 0.AND.(metsol >= 4.AND. metsol <7)) THEN ! band matrix as MINRES preconditioner
        WRITE(*,*) '                  and band matrix, width',mbandw
    END IF
 
    IF(chicut /= 0.0) THEN
        WRITE(*,*) 'Chi square cut equiv 3 st.dev applied ...'
        WRITE(*,*) ' in  first iteration with factor',chicut
        WRITE(*,*) ' in second iteration with factor',chirem
        WRITE(*,*) ' (reduced by sqrt in next iterations)'
    END IF
 
    IF(lhuber /= 0) THEN
        WRITE(*,*) '   Down-weighting of outliers in', lhuber,' iterations'
        WRITE(*,*) '   Cut on downweight fraction',dwcut
    END IF
 
    WRITE(*,*) 'Iterations (solutions) with line search:'
    IF(lsearch > 2) THEN
        WRITE(*,*) ' All'
    ELSEIF (lsearch == 1) THEN
        WRITE(*,*) ' Last'
    ELSEIF (lsearch < 1) THEN
        WRITE(*,*) ' None'
    ELSE
        IF (chicut /= 0.0) THEN
            WRITE(*,*) ' All with Chi square cut scaling factor <= 1.'
        ELSE
            WRITE(*,*) ' All'
        ENDIF
    ENDIF
 
    IF(nummeasurements>0) THEN
        WRITE(*,*)
        WRITE(*,*) ' Number of external measurements ', nummeasurements
    ENDIF
    
    CALL mend
 
101 FORMAT(i3,2x,a)
102 FORMAT(a)
END SUBROUTINE filetx
 
 
INTEGER(mpi) FUNCTION nufile(fname)
    USE mpdef
 
    IMPLICIT NONE
    INTEGER(mpi) :: ios
    INTEGER(mpi) :: l1
    INTEGER(mpi) :: ll
    INTEGER(mpi) :: nm
    INTEGER(mpi) :: npat
    INTEGER(mpi) :: ntext
    INTEGER(mpi) :: nuprae
    INTEGER(mpi) :: matint
 
    CHARACTER (LEN=*), INTENT(INOUT) :: fname
    LOGICAL :: ex
    SAVE
    !     ...
    nufile=0
    nuprae=0
    IF(len(fname) > 5) THEN
        IF(fname(1:5) == 'rfio:') nuprae=1
        IF(fname(1:5) == 'dcap:') nuprae=2
        IF(fname(1:5) == 'root:') nuprae=3
    END IF
    IF(nuprae == 0) THEN
        INQUIRE(file=fname,iostat=ios,exist=ex)
        IF(ios /= 0) nufile=-abs(ios)
        IF(ios /= 0) RETURN
    ELSE IF(nuprae == 1) THEN  ! rfio:
        ll=len(fname)
        fname=fname(6:ll)
        ex=.true.
        nufile=1
        RETURN
    ELSE
        ex=.true.   ! assume file existence
    END IF
    IF(ex) THEN
        nufile=1                                   ! binary
        ll=len(fname)
        l1=max(1,ll-3)
        nm=matint('xt',fname(l1:ll),npat,ntext)
        IF(nm == 2) nufile=2                       ! text
        IF(nm < 2) THEN
            nm=matint('tx',fname(l1:ll),npat,ntext)
            IF(nm == 2) nufile=2                   ! text
        END IF
    END IF
END FUNCTION nufile
 
SUBROUTINE intext(text,nline)
    USE mpmod
    USE mptext
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ia
    INTEGER(mpi) :: ib
    INTEGER(mpi) :: ier
    INTEGER(mpi) :: iomp
    INTEGER(mpi) :: j
    INTEGER(mpi) :: k
    INTEGER(mpi) :: kkey
    INTEGER(mpi) :: label
    INTEGER(mpi) :: lkey
    INTEGER(mpi) :: mat
    INTEGER(mpi) :: miter
    INTEGER(mpi) :: nab
    INTEGER(mpi) :: nkey
    INTEGER(mpi) :: nkeys
    INTEGER(mpi) :: nl
    INTEGER(mpi) :: nmeth
    INTEGER(mpi) :: npat
    INTEGER(mpi) :: ntext
    INTEGER(mpi) :: nums
    INTEGER(mpi) :: matint
 
    CHARACTER (LEN=*), INTENT(IN) :: text
    INTEGER(mpi), INTENT(IN) :: nline
 
#ifdef LAPACK64
#ifdef PARDISO
    parameter(nkeys=7,nmeth=10)
#else
    parameter(nkeys=6,nmeth=9)
#endif
#else
    parameter(nkeys=6,nmeth=7)
#endif
    CHARACTER (LEN=16) :: methxt(nmeth)
    CHARACTER (LEN=16) :: keylst(nkeys)
    CHARACTER (LEN=32) :: keywrd
    CHARACTER (LEN=32) :: keystx
    CHARACTER (LEN=itemCLen) :: ctext
    INTEGER(mpi), PARAMETER :: mnum=100
    REAL(mpd) :: dnum(mnum)
#ifdef LAPACK64
#ifdef PARDISO
    INTEGER(mpi) :: ipvs    ! ... integer value
#endif
#endif
    INTEGER(mpi) :: lpvs    ! ... integer label
    REAL(mpd)    :: plvs    ! ... float value
 
    INTERFACE
        SUBROUTINE additem(length,list,label,value)
            USE mpmod
            INTEGER(mpi), INTENT(IN OUT) :: length
            TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
            INTEGER(mpi), INTENT(IN) :: label
            REAL(mpd), INTENT(IN) :: value
        END SUBROUTINE additem
        SUBROUTINE additemc(length,list,label,text)
            USE mpmod
            INTEGER(mpi), INTENT(IN OUT) :: length
            TYPE(listitemc), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
            INTEGER(mpi), INTENT(IN) :: label
            CHARACTER(LEN = itemCLen), INTENT(IN) :: text
        END SUBROUTINE additemc
        SUBROUTINE additemi(length,list,label,ivalue)
            USE mpmod
            INTEGER(mpi), INTENT(IN OUT) :: length
            TYPE(listitemi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
            INTEGER(mpi), INTENT(IN) :: label
            INTEGER(mpi), INTENT(IN) :: ivalue
        END SUBROUTINE additemi
    END INTERFACE
 
    SAVE
#ifdef LAPACK64
#ifdef PARDISO
    DATA keylst/'unknown','parameter','constraint','measurement','method','comment','pardiso'/
    DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
        'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition', 'fullLAPACK', 'unpackedLAPACK', &
        'sparsePARDISO'/
#else
    DATA keylst/'unknown','parameter','constraint','measurement','method','comment'/
    DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
        'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition', 'fullLAPACK', 'unpackedLAPACK'/
#endif
#else
    DATA keylst/'unknown','parameter','constraint','measurement','method','comment'/
    DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
        'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition'/
#endif
    DATA lkey/-1/                 ! last keyword
 
    !     ...
    nkey=-1                       ! new keyword
    CALL rltext(text,ia,ib,nab)   ! return indices for non-blank area
    IF(nab == 0) GOTO 10
    CALL ratext(text(1:nab),nums,dnum,mnum) ! translate text to DP numbers
 
    IF(nums /= 0) nkey=0
    IF(keyb /= 0) THEN
        keywrd=text(keya:keyb) !          text is TEXT(KEYA)...TEXT(KEYB)
        !         WRITE(*,*) 'Keyword is ',KEYWRD
  
        !        compare keywords
  
        DO nkey=2,nkeys           ! loop over all pede keywords
            keystx=keylst(nkey)   ! copy NKEY.th pede keyword
            mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
            IF(100*mat >= 80*max(npat,ntext)) GO TO 10 ! 80% (symmetric) matching
        END DO
  
        !        more comparisons
  
        keystx='print'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            mprint=1
            IF(nums > 0) mprint=nint(dnum(1),mpi)
            RETURN
        END IF
  
        keystx='debug'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            mdebug=3
            ! GF            IF(NUMS.GT.0) MPRINT=DNUM(1)
            IF(nums > 0) mdebug=nint(dnum(1),mpi)
            IF(nums > 1) mdebg2=nint(dnum(2),mpi)
            RETURN
        END IF
 
        keystx='entries'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0 .AND. dnum(1) > 0.5) mreqenf=nint(dnum(1),mpi)
            IF(nums > 1 .AND. dnum(2) > 0.5) mreqena=nint(dnum(2),mpi)
            IF(nums > 2 .AND. dnum(3) > 0.5) iteren=nint(dnum(1)*dnum(3),mpi)
            RETURN
        END IF
 
        keystx='printrecord'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0) nrecpr=nint(dnum(1),mpi)
            IF(nums > 1) nrecp2=nint(dnum(2),mpi)
            RETURN
        END IF
 
        keystx='maxrecord'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF (nums > 0.AND.dnum(1) > 0.) mxrec=nint(dnum(1),mpi)
            RETURN
        END IF
  
        keystx='cache'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF (nums > 0.AND.dnum(1) >= 0.) ncache=nint(dnum(1),mpi) ! cache size, <0 keeps default
            IF (nums == 2.AND.dnum(2) > 0..AND.dnum(2) <= 1.0)  &  ! read cache fill level
                fcache(1)=real(dnum(2),mps)
            IF (nums >= 4) THEN                                    ! explicit cache splitting
                DO k=1,3
                    fcache(k)=real(dnum(k+1),mps)
                END DO
            END IF
            RETURN
        END IF
  
        keystx='chisqcut'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums == 0) THEN ! always 3-sigma cut
                chicut=1.0
                chirem=1.0
            ELSE
                chicut=real(dnum(1),mps)
                IF(chicut < 1.0) chicut=-1.0
                IF(nums == 1) THEN
                    chirem=1.0  ! 3-sigma cut, if not specified
                ELSE
                    chirem=real(dnum(2),mps)
                    IF(chirem < 1.0) chirem=1.0
                    IF(chicut >= 1.0) chirem=min(chirem,chicut)
                END IF
            END IF
            RETURN
        END IF
  
        ! GF added:
        keystx='hugecut'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0) chhuge=real(dnum(1),mps)
            IF(chhuge < 1.0) chhuge=1.0 ! at least (!!) 3-sigma
            RETURN
        END IF
        ! GF added end
  
        keystx='linesearch'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0) lsearch=nint(dnum(1),mpi)
            RETURN
        END IF
 
        keystx='localfit'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0) lfitnp=nint(dnum(1),mpi)
            IF(nums > 1) lfitbb=nint(dnum(2),mpi)
            RETURN
        END IF
 
        keystx='regularization'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            nregul=1
            regula=real(dnum(1),mps)
            IF(nums >= 2) regpre=real(dnum(2),mps)
            RETURN
        END IF
  
        keystx='regularisation'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            nregul=1
            regula=real(dnum(1),mps)
            IF(nums >= 2) regpre=real(dnum(2),mps)
            RETURN
        END IF
  
        keystx='presigma'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            regpre=real(dnum(1),mps)
            RETURN
        END IF
  
        keystx='matiter'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            matrit=nint(dnum(1),mpi)
            RETURN
        END IF
  
        keystx='matmoni'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            matmon=-1
            IF (nums > 0.AND.dnum(1) > 0.) matmon=nint(dnum(1),mpi)
            RETURN
        END IF
  
        keystx='bandwidth'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0)   mbandw=nint(dnum(1),mpi)
            IF(mbandw < 0) mbandw=-1
            IF(nums > 1)   lprecm=nint(dnum(2),mpi)
            RETURN
        END IF
  
        !         KEYSTX='outlierrejection'
        !         MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison
        !         WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3
        !         IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN
        !         IF(MAT.GE.(NPAT-NPAT/5)) THEN
        !            CHDFRJ=DNUM(1)
        !            IF(CHDFRJ.LT.3.0) CHDFRJ=100.0
        !            RETURN
        !         END IF
  
        !         KEYSTX='outliersuppression'
        !         MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison
        !         WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3
        !         IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN
        !         IF(MAT.GE.(NPAT-NPAT/5)) THEN
        !            LHUBER=DNUM(1)
        !            IF(LHUBER.LE.2) LHUBER=2 ! at least 2 Huber iterations
        !            RETURN
        !         END IF
  
        keystx='outlierdownweighting'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            lhuber=nint(dnum(1),mpi)
            IF(lhuber > 0.AND.lhuber <= 2) lhuber=2 ! at least 2 Huber iterations (if any)
            RETURN
        END IF
  
        keystx='dwfractioncut'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            dwcut=real(dnum(1),mps)
            IF(dwcut > 0.5) dwcut=0.5
            RETURN
        END IF
  
        keystx='maxlocalcond'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF (nums > 0.AND.dnum(1) > 0.0) cndlmx=real(dnum(1),mps)
            RETURN
        END IF
 
        keystx='pullrange'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            prange=abs(real(dnum(1),mps))
            RETURN
        END IF
 
        keystx='subito'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            isubit=1
            RETURN
        END IF
  
        keystx='force'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            iforce=1
            RETURN
        END IF
 
        keystx='memorydebug'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            memdbg=1
            IF (nums > 0.AND.dnum(1) > 0.0) memdbg=nint(dnum(1),mpi)
            RETURN
        END IF
  
        keystx='globalcorr'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            igcorr=1
            RETURN
        END IF
 
        keystx='printcounts'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            ipcntr=1
            IF (nums > 0) ipcntr=nint(dnum(1),mpi)
            RETURN
        END IF
 
        keystx='weightedcons'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            iwcons=1
            IF (nums > 0) iwcons=nint(dnum(1),mpi)
            RETURN
        END IF
 
        keystx='skipemptycons'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            iskpec=1
            RETURN
        END IF
        
        keystx='resolveredundancycons'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            irslvrc=1
            RETURN
        END IF
 
        keystx='withelimination'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            icelim=1
            RETURN
        END IF
 
#ifdef LAPACK64
        keystx='withLAPACKelimination'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            icelim=2
            RETURN
        END IF
#endif
        
        keystx='withmultipliers'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            icelim=0
            RETURN
        END IF
 
        keystx='checkinput'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            icheck=1
            IF (nums > 0) icheck=nint(dnum(1),mpi)
            RETURN
        END IF
 
        keystx='checkparametergroups'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            ichkpg=1
            RETURN
        END IF
 
        keystx='monitorresiduals'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            imonit=3
            IF (nums > 0) imonit=nint(dnum(1),mpi)
            IF (nums > 1) measbins=max(measbins,nint(dnum(2),mpi))
            RETURN
        END IF
 
        keystx='monitorpulls'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            imonit=3
            imonmd=1
            IF (nums > 0) imonit=nint(dnum(1),mpi)
            IF (nums > 1) measbins=max(measbins,nint(dnum(2),mpi))
            RETURN
        END IF
        
        keystx='monitorprogress'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            monpg1=1
            monpg2=1024
            IF (nums > 0) monpg1=max(1,nint(dnum(1),mpi))
            IF (nums > 1) monpg2=max(1,nint(dnum(2),mpi))
            RETURN
        END IF
 
        keystx='scaleerrors'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            iscerr=1
            IF (nums > 0) dscerr(1:2)=dnum(1)
            IF (nums > 1) dscerr(2)=dnum(2)
            RETURN
        END IF
        
        keystx='iterateentries'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            iteren=huge(iteren)
            IF (nums > 0) iteren=nint(dnum(1),mpi)
            RETURN
        END IF
 
        keystx='threads'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            iomp=0
            !$          IOMP=1
            !$          IF (IOMP.GT.0) THEN
            !$             IF (NUMS.GE.1.AND.DNUM(1).GT.0.) MTHRD =NINT(dnum(1),mpi)
            !$             MTHRDR=MTHRD
            !$             IF (NUMS.GE.2.AND.DNUM(2).GT.0.) MTHRDR=NINT(dnum(2),mpi)
            !$          ELSE
            WRITE(*,*) 'WARNING: multithreading not available'
            !$          ENDIF
            RETURN
        END IF
  
        keystx='compress'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            WRITE(*,*) 'WARNING: keyword COMPRESS is obsolete (compression is default)'
            RETURN
        END IF
        
        ! still experimental
        !keystx='extendedStorage'
        !mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        !IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
        !    mextnd=1
        !    RETURN
        !END IF
 
        keystx='countrecords'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            mcount=1
            RETURN
        END IF
          
        keystx='errlabels'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext).AND.mnrsel < 100) THEN ! 80% (symmetric) matching
            nl=min(nums,100-mnrsel)
            DO k=1,nl
                lbmnrs(mnrsel+k)=nint(dnum(k),mpi)
            END DO
            mnrsel=mnrsel+nl
            RETURN
        END IF
  
        keystx='pairentries'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            !     This option could be implemented to get rid of parameter pairs
            !     that have very few entries - to save matrix memory size.
            IF (nums > 0.AND.dnum(1) > 0.0) THEN
                mreqpe=nint(dnum(1),mpi)
                IF (nums >= 2.AND.dnum(2) >= dnum(1)) mhispe=nint(dnum(2),mpi)
                IF (nums >= 3.AND.dnum(3) >= dnum(1)) msngpe=nint(dnum(3),mpi)
            END IF
            RETURN
        END IF
  
        keystx='wolfe'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            wolfc1=real(dnum(1),mps)
            wolfc2=real(dnum(2),mps)
            RETURN
        END IF
  
        ! GF added:
        ! convergence tolerance for minres:
        keystx='mrestol'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0) THEN
                IF (dnum(1) < 1.0e-10_mpd.OR.dnum(1) > 1.0e-04_mpd) THEN
                    WRITE(*,*) 'ERROR: need 1.0D-10 <= MRESTL ',  &
                        '<= 1.0D-04, but get ', dnum(1)
                ELSE
                    mrestl=dnum(1)
                END IF
            END IF
            RETURN
        END IF
        ! GF added end
 
        keystx='mrestranscond'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0) THEN
                mrtcnd = dnum(1)
            END IF
            RETURN
        END IF
 
        keystx='mresmode'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            IF(nums > 0) THEN
                mrmode = int(dnum(1),mpi)
            END IF
            RETURN
        END IF
 
        keystx='nofeasiblestart'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            nofeas=1 ! do not make parameters feasible at start
            RETURN
        END IF
  
        keystx='histprint'
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            nhistp=1 ! print histograms
            RETURN
        END IF
        
        keystx='readerroraseof' ! treat (C) read errors as eof
        mat=matint(text(ia:ib),keystx,npat,ntext)
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            ireeof=1
            RETURN
        END IF
 
#ifdef LAPACK64
        keystx='LAPACKwitherrors' ! calculate parameter errors with LAPACK
        mat=matint(text(ia:ib),keystx,npat,ntext)
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            ilperr=1
            RETURN
        END IF
#ifdef PARDISO
        keystx='debugPARDISO' ! enable debug for Intel oneMKL PARDISO
        mat=matint(text(ia:ib),keystx,npat,ntext)
        IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
            ipddbg=1
            RETURN
        END IF
 
        keystx='blocksizePARDISO' ! use BSR3 for Intel oneMKL PARDISO, list of (increasing) block sizes to be tried
        mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
        IF(100*mat >= 80*max(npat,ntext).AND.mnrsel < 100) THEN ! 80% (symmetric) matching
            nl=min(nums,10-mpdbsz)
            DO k=1,nl
                IF (nint(dnum(k),mpi) > 0) THEN
                    IF (mpdbsz == 0) THEN
                        mpdbsz=mpdbsz+1
                        ipdbsz(mpdbsz)=nint(dnum(k),mpi)
                    ELSE IF (nint(dnum(k),mpi) > ipdbsz(mpdbsz)) THEN
                        mpdbsz=mpdbsz+1
                        ipdbsz(mpdbsz)=nint(dnum(k),mpi)
                    END IF
                END IF
            END DO
            RETURN
        END IF
#endif
#endif
        keystx='fortranfiles'
        mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
        IF(mat == max(npat,ntext)) RETURN
  
        keystx='Cfiles'
        mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
        IF(mat == max(npat,ntext)) RETURN
 
        keystx='closeandreopen'
        mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
        IF(mat == max(npat,ntext)) RETURN
          
        keystx=keylst(1)
        nkey=1                 ! unknown keyword
        IF(nums /= 0) nkey=0
  
        WRITE(*,*) ' '
        WRITE(*,*) '**************************************************'
        WRITE(*,*) ' '
        WRITE(*,*) 'Unknown keyword(s): ',text(1:min(nab,50))
        WRITE(*,*) ' '
        WRITE(*,*) '**************************************************'
        WRITE(*,*) ' '
        lunkno=lunkno+1
  
    END IF
    !     result: NKEY = -1    blank
    !             NKEY =  0    numerical data, no text keyword or unknown
    !             NKEY >  0    keyword NKEY from list, keyword = KEYSTX
 
 
    !     content/lastcontent
    !     -------------------
    !     blank            -1
    !     data              0
    !     keyword
    !      unknown          1
    !      parameter        2
    !      constraint       3
    !      measurement      4
    !      method           5
 
 
10  IF(nkey > 0) THEN     ! new keyword
        lkey=nkey
        IF(lkey == 2) THEN              ! parameter
            IF(nums == 3) THEN
                lpvs=nint(dnum(1),mpi)  ! label
                IF(lpvs /= 0) THEN
                    CALL additem(lenparameters,listparameters,lpvs,dnum(2)) ! start value
                    CALL additem(lenpresigmas,listpresigmas,lpvs,dnum(3))   ! pre-sigma
                ELSE
                    WRITE(*,*) 'Line',nline,' error, label=',lpvs
                END IF
            ELSE IF(nums /= 0) THEN
                kkey=1   ! switch to "unknown"  ?
                WRITE(*,*) 'Wrong text in line',nline
                WRITE(*,*) 'Status: new parameter'
                WRITE(*,*) '> ',text(1:nab)
            END IF
        ELSE IF(lkey == 3) THEN         ! constraint
            !            WRITE(*,*) 'Keyword is constraint!',NUMS,' numerical data'
            IF(nums >= 1.AND.nums <= 2) THEN ! start constraint
                lpvs=-nline   ! r = r.h.s. value
                CALL additem(lenconstraints,listconstraints,lpvs,dnum(1))
                lpvs=-1                    ! constraint
                IF(iwcons > 0) lpvs=-2     ! weighted constraint
                plvs=0.0
                IF(nums == 2) plvs=dnum(2) ! sigma
                CALL additem(lenconstraints,listconstraints,lpvs,plvs)
            ELSE
                kkey=1   ! switch to "unknown"
                WRITE(*,*) 'Wrong text in line',nline
                WRITE(*,*) 'Status: new keyword constraint'
                WRITE(*,*) '> ',text(1:nab)
            END IF
        ELSE IF(lkey == 4) THEN         ! measurement
            IF(nums == 2) THEN ! start measurement
                nummeasurements=nummeasurements+1
                lpvs=-nline   ! r = r.h.s. value
                CALL additem(lenmeasurements,listmeasurements,lpvs,dnum(1))
                lpvs=-1  ! sigma
                CALL additem(lenmeasurements,listmeasurements,lpvs,dnum(2))
            ELSE
                kkey=1   ! switch to "unknown"
                WRITE(*,*) 'Wrong text in line',nline
                WRITE(*,*) 'Status: new keyword measurement'
                WRITE(*,*) '> ',text(1:nab)
            END IF
        ELSE IF(lkey == 5.AND.keyb < keyc) THEN         ! method with text argument
            miter=mitera
            IF(nums >= 1) miter=nint(dnum(1),mpi)
            IF(miter >= 1) mitera=miter
            dflim=real(dnum(2),mps)
            lkey=0
            DO i=1,nmeth
                keystx=methxt(i)
                mat=matint(text(keyb+1:keyc),keystx,npat,ntext) ! comparison
                IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
                    IF(i == 1) THEN            ! diagonalization
                        metsol=2
                        matsto=1
                    ELSE IF(i == 2) THEN       ! inversion
                        metsol=1
                        matsto=1
                    ELSE IF(i == 3) THEN       ! fullMINRES
                        metsol=4
                        matsto=1
                    ELSE IF(i == 4) THEN       ! sparseMINRES
                        metsol=4
                        matsto=2
                    ELSE IF(i == 5) THEN       ! fullMINRES-QLP
                        metsol=5
                        matsto=1
                    ELSE IF(i == 6) THEN       ! sparseMINRES-QLP
                        metsol=5
                        matsto=2
                    ELSE IF(i == 7) THEN       ! decomposition
                        metsol=3
                        matsto=1
#ifdef LAPACK64
                    ELSE IF(i == 8) THEN       ! fullLAPACK factorization
                        metsol=7
                        matsto=1
                    ELSE IF(i == 9) THEN       ! unpackedLAPACK factorization
                        metsol=8
                        matsto=0
#ifdef PARDISO
                    ELSE IF(i == 10) THEN       ! Intel oneMKL PARDISO (sparse matrix (CSR3 or BSR3, upper triangle))
                        metsol=9
                        matsto=3
#endif
#endif
                    END IF
                END IF
            END DO
        END IF
    ELSE IF(nkey == 0) THEN  ! data for continuation
        IF(lkey == 2) THEN              ! parameter
            IF(nums >= 3) THEN   ! store data from this line
                lpvs=nint(dnum(1),mpi) ! label
                IF(lpvs /= 0) THEN
                    CALL additem(lenparameters,listparameters,lpvs,dnum(2))  ! start value
                    CALL additem(lenpresigmas,listpresigmas,lpvs,dnum(3))    ! pre-sigma
                ELSE
                    WRITE(*,*) 'Line',nline,' error, label=',lpvs
                END IF
            ELSE IF(nums > 1.AND.nums < 3) THEN
                kkey=1   ! switch to "unknown"  ?
                WRITE(*,*) 'Wrong text in line',nline
                WRITE(*,*) 'Status continuation parameter'
                WRITE(*,*) '> ',text(1:nab)
            END IF
    
        ELSE IF(lkey == 3) THEN         ! constraint
            ier=0
            DO i=1,nums,2
                label=nint(dnum(i),mpi)
                IF(label <= 0) ier=1
            END DO
            IF(mod(nums,2) /= 0) ier=1 ! reject odd number
            IF(ier == 0) THEN
                DO i=1,nums,2
                    lpvs=nint(dnum(i),mpi) ! label
                    plvs=dnum(i+1)         ! factor
                    CALL additem(lenconstraints,listconstraints,lpvs,plvs)
                END DO
            ELSE
                kkey=0
                WRITE(*,*) 'Wrong text in line',nline
                WRITE(*,*) 'Status continuation constraint'
                WRITE(*,*) '> ',text(1:nab)
            END IF
    
        ELSE IF(lkey == 4) THEN         ! measurement
            !            WRITE(*,*) 'continuation                          < ',NUMS
            ier=0
            DO i=1,nums,2
                label=nint(dnum(i),mpi)
                IF(label <= 0) ier=1
            END DO
            IF(mod(nums,2) /= 0) ier=1 ! reject odd number
            !            WRITE(*,*) 'IER NUMS ',IER,NUMS
            IF(ier == 0) THEN
                DO i=1,nums,2
                    lpvs=nint(dnum(i),mpi) ! label
                    plvs=dnum(i+1)         ! factor
                    CALL additem(lenmeasurements,listmeasurements,lpvs,plvs)
                END DO
            ELSE
                kkey=0
                WRITE(*,*) 'Wrong text in line',nline
                WRITE(*,*) 'Status continuation measurement'
                WRITE(*,*) '> ',text(1:nab)
            END IF
        ELSE IF(lkey == 6) THEN         ! comment
            IF(nums == 1) THEN
                lpvs=nint(dnum(1),mpi)  ! label
                IF(lpvs /= 0) THEN
                    ! skip label
                    DO j=ia,ib
                        IF (text(j:j) == ' ') EXIT
                    END DO
                    ctext=text(j:ib)
                    CALL additemc(lencomments,listcomments,lpvs,ctext)
                ELSE
                    WRITE(*,*) 'Line',nline,' error, label=',lpvs
                END IF
            ELSE IF(nums /= 0) THEN
                kkey=1   ! switch to "unknown"
                WRITE(*,*) 'Wrong text in line',nline
                WRITE(*,*) 'Status: continuation comment'
                WRITE(*,*) '> ',text(1:nab)
            END IF
#ifdef LAPACK64
#ifdef PARDISO
        ELSE IF(lkey == 7) THEN         ! Intel oneMKL PARDISO parameters
            ier=0
            DO i=1,nums,2
                label=nint(dnum(i),mpi)
                IF(label <= 0.OR.label > 64) ier=1
            END DO
            IF(mod(nums,2) /= 0) ier=1 ! reject odd number
            !            WRITE(*,*) 'IER NUMS ',IER,NUMS
            IF(ier == 0) THEN
                DO i=1,nums,2
                    lpvs=nint(dnum(i),mpi)   ! label
                    ipvs=nint(dnum(i+1),mpi) ! parameter
                    CALL additemi(lenpardiso,listpardiso,lpvs,ipvs)
                END DO
            ELSE
                kkey=0
                WRITE(*,*) 'Wrong text in line',nline
                WRITE(*,*) 'Status continuation measurement'
                WRITE(*,*) '> ',text(1:nab)
            END IF
#endif
#endif
        END IF
    END IF
END SUBROUTINE intext
 
SUBROUTINE additem(length,list,label,value)
    USE mpdef
    USE mpdalc
 
    INTEGER(mpi), INTENT(IN OUT) :: length
    TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
    INTEGER(mpi), INTENT(IN) :: label
    REAL(mpd), INTENT(IN) :: value
 
    INTEGER(mpl) :: newSize
    INTEGER(mpl) :: oldSize
    TYPE(listitem), DIMENSION(:), ALLOCATABLE :: tempList
 
    IF (label > 0.AND.value == 0.) RETURN ! skip zero for valid labels
    IF (length == 0 ) THEN  ! initial list with size = 100
        newsize = 100
        CALL mpalloc(list,newsize,' list ')
    ENDIF
    oldsize=size(list,kind=mpl)
    IF (length >= oldsize) THEN ! increase sizeby 20% + 100
        newsize = oldsize + oldsize/5 + 100
        CALL mpalloc(templist,oldsize,' temp. list ')
        templist=list
        CALL mpdealloc(list)
        CALL mpalloc(list,newsize,' list ')
        list(1:oldsize)=templist(1:oldsize)
        CALL mpdealloc(templist)
    ENDIF
    ! add to end of list
    length=length+1
    list(length)%label=label
    list(length)%value=value
 
END SUBROUTINE additem
 
SUBROUTINE additemc(length,list,label,text)
    USE mpdef
    USE mpdalc
 
    INTEGER(mpi), INTENT(IN OUT) :: length
    TYPE(listitemc), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
    INTEGER(mpi), INTENT(IN) :: label
    CHARACTER(len = itemCLen), INTENT(IN) :: text
 
    INTEGER(mpl) :: newSize
    INTEGER(mpl) :: oldSize
    TYPE(listitemc), DIMENSION(:), ALLOCATABLE :: tempList
 
    IF (label > 0.AND.text == '') RETURN ! skip empty text for valid labels
    IF (length == 0 ) THEN  ! initial list with size = 100
        newsize = 100
        CALL mpalloc(list,newsize,' list ')
    ENDIF
    oldsize=size(list,kind=mpl)
    IF (length >= oldsize) THEN ! increase sizeby 20% + 100
        newsize = oldsize + oldsize/5 + 100
        CALL mpalloc(templist,oldsize,' temp. list ')
        templist=list
        CALL mpdealloc(list)
        CALL mpalloc(list,newsize,' list ')
        list(1:oldsize)=templist(1:oldsize)
        CALL mpdealloc(templist)
    ENDIF
    ! add to end of list
    length=length+1
    list(length)%label=label
    list(length)%text=text
 
END SUBROUTINE additemc
 
SUBROUTINE additemi(length,list,label,ivalue)
    USE mpdef
    USE mpdalc
 
    INTEGER(mpi), INTENT(IN OUT) :: length
    TYPE(listitemi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
    INTEGER(mpi), INTENT(IN) :: label
    INTEGER(mpi), INTENT(IN) :: ivalue
 
    INTEGER(mpl) :: newSize
    INTEGER(mpl) :: oldSize
    TYPE(listitemi), DIMENSION(:), ALLOCATABLE :: tempList
 
    IF (length == 0 ) THEN  ! initial list with size = 100
        newsize = 100
        CALL mpalloc(list,newsize,' list ')
    ENDIF
    oldsize=size(list,kind=mpl)
    IF (length >= oldsize) THEN ! increase sizeby 20% + 100
        newsize = oldsize + oldsize/5 + 100
        CALL mpalloc(templist,oldsize,' temp. list ')
        templist=list
        CALL mpdealloc(list)
        CALL mpalloc(list,newsize,' list ')
        list(1:oldsize)=templist(1:oldsize)
        CALL mpdealloc(templist)
    ENDIF
    ! add to end of list
    length=length+1
    list(length)%label=label
    list(length)%ivalue=ivalue
 
END SUBROUTINE additemi
 
SUBROUTINE mstart(text)
    USE mpdef
    USE mpmod, ONLY: textl
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ka
    INTEGER(mpi) :: kb
    INTEGER(mpi) :: l
    CHARACTER (LEN=*), INTENT(IN)  :: text
    CHARACTER (LEN=16) :: textc
    SAVE
    !     ...
    DO i=1,74
        textl(i:i)='_'
    END DO
    l=len(text)
    ka=(74-l)/2
    kb=ka+l-1
    textl(ka:kb)=text(1:l)
    WRITE(*,*) ' '
    WRITE(*,*) textl
    WRITE(*,*) ' '
    textc=text(1:l)//'-end'
 
    DO i=1,74
        textl(i:i)='_'
    END DO
    l=l+4
    ka=(74-l)/2
    kb=ka+l-1
    textl(ka:kb)=textc(1:l)
    RETURN
END SUBROUTINE mstart
 
SUBROUTINE mend
    USE mpmod, ONLY: textl
 
    IMPLICIT NONE
    WRITE(*,*) ' '
    WRITE(*,*) textl
    CALL petime
    WRITE(*,*) ' '
END SUBROUTINE mend
 
 
SUBROUTINE mvopen(lun,fname)
    USE mpdef
 
    IMPLICIT NONE
    INTEGER(mpi) :: l
    INTEGER(mpi), INTENT(IN) :: lun
    CHARACTER (LEN=*), INTENT(IN) :: fname
    CHARACTER (LEN=33) :: nafile
    CHARACTER (LEN=33) :: nbfile
    LOGICAL :: ex
    SAVE
    !     ...
    l=len(fname)
    IF(l > 32) THEN
        CALL peend(17,'Aborted, file name too long')
        stop 'File name too long                    '
    END IF
    nafile=fname
    nafile(l+1:l+1)='~'
 
    INQUIRE(file=nafile(1:l),exist=ex)
    IF(ex) THEN
        INQUIRE(file=nafile(1:l+1),exist=ex)
        IF(ex) THEN
            CALL system('rm '//nafile)
        END IF
        nbfile=nafile
        nafile(l+1:l+1)=' '
        CALL system('mv '//nafile//nbfile)
    END IF
    OPEN(unit=lun,file=fname)
END SUBROUTINE mvopen
 
 
SUBROUTINE petime
    USE mpdef
 
    IMPLICIT NONE
    REAL, DIMENSION(2) :: ta
    REAL etime
    REAL :: rst
    REAL :: delta
    REAL :: rstp
    REAL :: secnd1
    REAL :: secnd2
    INTEGER :: ncount
    INTEGER :: nhour1
    INTEGER :: minut1
    INTEGER :: nsecd1
    INTEGER :: nhour2
    INTEGER :: minut2
    INTEGER :: nsecd2
 
    SAVE
    DATA ncount/0/
    !     ...
    ncount=ncount+1
    rst=etime(ta)
    IF(ncount > 1) THEN
        delta=rst
        nsecd1=int(delta,mpi) ! -> integer
        nhour1=nsecd1/3600
        minut1=nsecd1/60-60*nhour1
        secnd1=delta-60*(minut1+60*nhour1)
        delta=rst-rstp
        nsecd2=int(delta,mpi) ! -> integer
        nhour2=nsecd2/3600
        minut2=nsecd2/60-60*nhour2
        secnd2=delta-60*(minut2+60*nhour2)
        WRITE(*,101) nhour1,minut1,secnd1, nhour2,minut2,secnd2
    END IF
 
    rstp=rst
    RETURN
101 FORMAT(i4,' h',i3,' min',f5.1,' sec total',18x,'elapsed',  &
        i4,' h',i3,' min',f5.1,' sec')
END SUBROUTINE petime                          ! print
 
 
SUBROUTINE peend(icode, cmessage)
    USE mpdef
 
    IMPLICIT NONE
    INTEGER(mpi), INTENT(IN) :: icode
    CHARACTER (LEN=*), INTENT(IN) :: cmessage
 
    CALL mvopen(9,'millepede.end')
    WRITE(9,101) icode, cmessage
101 FORMAT(1x,i4,3x,a)
    CLOSE(9)
    RETURN
 
END SUBROUTINE peend
 
SUBROUTINE binopn(kfile, ithr, ierr)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi), INTENT(IN) :: kfile
    INTEGER(mpi), INTENT(IN) :: ithr
    INTEGER(mpi), INTENT(OUT) :: ierr
 
    INTEGER(mpi), DIMENSION(13) :: ibuff
    INTEGER(mpi) :: ioff
    INTEGER(mpi) :: ios
    INTEGER(mpi) :: k
    INTEGER(mpi) :: lfn
    INTEGER(mpi) :: lun
    INTEGER(mpi) :: moddate
    CHARACTER (LEN=1024) :: fname
    CHARACTER (LEN=7) :: cfile
    INTEGER stat
 
#ifdef READ_C_FILES
    INTERFACE
        SUBROUTINE openc(filename, lfn, lun, ios) BIND(c)
            USE iso_c_binding
            CHARACTER(kind=c_char), DIMENSION(*), INTENT(IN) :: filename
            INTEGER(c_int), INTENT(IN), VALUE :: lfn
            INTEGER(c_int), INTENT(IN), VALUE :: lun
            INTEGER(c_int), INTENT(INOUT) :: ios
        END SUBROUTINE openc
    END INTERFACE
#endif
 
    ierr=0
    lun=ithr
    ! modification date (=0: open for first time, >0: reopen, <0: unknown )
    moddate=yfd(kfile)
    ! file name
    ioff=sfd(1,kfile)
    lfn=sfd(2,kfile)
    DO k=1,lfn
        fname(k:k)=tfd(ioff+k)
    END DO
    !print *, " opening binary ", kfile, ithr, moddate, " : ", fname(1:lfn)
    ! open
    ios=0
    IF(kfile <= nfilf) THEN
        ! Fortran file
        lun=kfile+10
        OPEN(lun,file=fname(1:lfn),iostat=ios, form='UNFORMATTED')
        print *, ' lun ', lun, ios
#ifdef READ_C_FILES
    ELSE
        ! C file
        CALL openc(fname(1:lfn),lfn,lun,ios)
#else
        WRITE(*,*) 'Opening of C-files not supported.'
        ierr=1
        RETURN
#endif
    END IF
    IF(ios /= 0) THEN
        ierr=1
        WRITE(*,*) 'Open error for file ',fname(1:lfn), ios
        IF (moddate /= 0) THEN
            WRITE(cfile,'(I7)') kfile
            CALL peend(15,'Aborted, open error(s) for binary file ' // cfile)
            stop 'PEREAD: open error'
        ENDIF
        RETURN
    END IF
    ! get status
    ios=stat(fname(1:lfn),ibuff)
    !print *, ' STAT ', ios, ibuff(10), moddate
    IF(ios /= 0) THEN
        ierr=1
        WRITE(*,*) 'STAT error for file ',fname(1:lfn), ios
        ibuff(10)=-1
    END IF
    ! check/store modification date
    IF (moddate /= 0) THEN
        IF (ibuff(10) /= moddate) THEN
            WRITE(cfile,'(I7)') kfile
            CALL peend(19,'Aborted, binary file modified (date) ' // cfile)
            stop 'PEREAD: file modified'
        END IF
    ELSE
        yfd(kfile)=ibuff(10)
    END IF
    RETURN
 
END SUBROUTINE binopn
 
SUBROUTINE bincls(kfile, ithr)
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpi), INTENT(IN) :: kfile
    INTEGER(mpi), INTENT(IN) :: ithr
 
    INTEGER(mpi) :: lun
 
#ifdef READ_C_FILES
    INTERFACE
        SUBROUTINE closec(lun) BIND(c)
            USE iso_c_binding
            INTEGER(c_int), INTENT(IN), VALUE :: lun
        END SUBROUTINE closec
    END INTERFACE
#endif
 
    lun=ithr
    !print *, " closing binary ", kfile, ithr
    IF(kfile <= nfilf) THEN ! Fortran file
        lun=kfile+10
        CLOSE(lun)
#ifdef READ_C_FILES
    ELSE ! C file
        CALL closec(lun)
#endif
    END IF
    
END SUBROUTINE bincls
    
SUBROUTINE binrwd(kfile)
    USE mpmod
    
    IMPLICIT NONE
    INTEGER(mpi), INTENT(IN) :: kfile
 
    INTEGER(mpi) :: lun
 
#ifdef READ_C_FILES
    INTERFACE
        SUBROUTINE resetc(lun) BIND(c)
            USE iso_c_binding
            INTEGER(c_int), INTENT(IN), VALUE :: lun
        END SUBROUTINE resetc
    END INTERFACE
#endif
 
    !print *, " rewinding binary ", kfile
    IF (kfile <= nfilf) THEN
        lun=kfile+10
        rewind lun
#ifdef READ_C_FILES
    ELSE
        lun=kfile-nfilf
        CALL resetc(lun)
#endif
    END IF
 
END SUBROUTINE binrwd
 
SUBROUTINE ckpgrp
    USE mpmod
    USE mpdalc
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: ipgrp
    INTEGER(mpi) :: irank
    INTEGER(mpi) :: isize
    INTEGER(mpi) :: ivoff
    INTEGER(mpi) :: itgbi
    INTEGER(mpi) :: j
    INTEGER(mpi) :: msize
    INTEGER(mpi), PARAMETER :: mxsize = 1000
    INTEGER(mpl):: ij
    INTEGER(mpl):: length
 
    REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD
    INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI
    REAL(mpd), DIMENSION(:), ALLOCATABLE :: resParGroup
    REAL(mpd), DIMENSION(:), ALLOCATABLE :: blockParGroup
    REAL(mpd) :: matij
    SAVE
 
    ! maximal group size
    msize=0
    DO ipgrp=1,nvpgrp
        isize=globalallindexgroups(ipgrp+1)-globalallindexgroups(ipgrp)
        IF (isize <= mxsize) THEN
            msize=max(msize,isize)
        ELSE
            print *, ' CKPGRP: par. group', ipgrp, ' not checked -- too large: ', isize
        END IF
    END DO
    IF (msize == 0) RETURN
 
    ! (matrix) block for parameter groups
    length=int(msize,mpl)*(int(msize,mpl)+1)/2
    CALL mpalloc(blockpargroup,length,'(matrix) block for parameter groups (D)')
    length=msize
    CALL mpalloc(respargroup,length,'residuals for parameter groups (D)')  ! double aux 1
    CALL mpalloc(auxvectori,length,'auxiliary array (I)')  ! int aux 1
    CALL mpalloc(auxvectord,length,'auxiliary array (D)')  ! double aux 1
 
    respargroup=0
    print *
    print *,' CKPGRP   par. group first label        size        rank'
    DO ipgrp=1,nvpgrp
        isize=globalallindexgroups(ipgrp+1)-globalallindexgroups(ipgrp)
        IF (isize > mxsize) cycle
        ! copy matrix block
        ivoff=globalallindexgroups(ipgrp)-1
        ij=0
        DO i=1,isize
            DO j=1,i
                ij=ij+1
                blockpargroup(ij)=matij(ivoff+i,ivoff+j)
            END DO
        END DO
        ! inversion of matrix block
        CALL sqminv(blockpargroup,respargroup,isize,irank, auxvectord, auxvectori)
        !
        itgbi=globalparvartototal(globalallindexgroups(ipgrp))
        IF (isize == irank) THEN
            print *,' CKPGRP ', ipgrp, globalparlabelindex(1,itgbi), isize, irank
        ELSE
            ndefpg=ndefpg+1
            print *,' CKPGRP ', ipgrp, globalparlabelindex(1,itgbi), isize, irank, '  rank deficit !!!'
        END IF
    END DO
 
    ! clean up
    CALL mpdealloc(auxvectord)
    CALL mpdealloc(auxvectori)
    CALL mpdealloc(respargroup)
    CALL mpdealloc(blockpargroup)
 
END SUBROUTINE ckpgrp
                    
SUBROUTINE chkmat
    USE mpmod
 
    IMPLICIT NONE
    INTEGER(mpl) :: i
    INTEGER(mpl) :: nan
    INTEGER(mpl) :: neg
    
    print *, ' Checking global matrix(D) for NANs ', size(globalmatd,kind=mpl)
    nan=0
    DO i=1,size(globalmatd,kind=mpl)
        IF(.NOT.(globalmatd(i) <= 0.0_mpd).AND..NOT.(globalmatd(i) > 0.0_mpd)) THEN
            nan=nan+1
            print *, ' i, nan ', i, nan
        END IF    
    END DO
 
    IF (matsto > 1) RETURN
    print *
    print *, ' Checking diagonal elements ', nagb
    neg=0
    DO i=1,nagb
        IF(.NOT.(globalmatd(globalrowoffsets(i)+i) > 0.0_mpd)) THEN
            neg=neg+1
            print *, ' i, neg ', i, neg
        END IF 
    END DO
    print *
    print *, ' CHKMAT summary ', nan, neg
    print *
    
END SUBROUTINE chkmat 
 
                       
! ----- accurate summation ----(from mpnum) ---------------------------------
 
 
SUBROUTINE addsums(ithrd, chi2, ndf, dw)
    USE mpmod
 
    IMPLICIT NONE
    REAL(mpd), INTENT(IN) :: chi2
    INTEGER(mpi), INTENT(IN) :: ithrd
    INTEGER(mpi), INTENT(IN) :: ndf
    REAL(mpd), INTENT(IN) :: dw
 
    INTEGER(mpl) ::nadd
    REAL(mpd) ::add
    !     ...
    add=chi2*dw              ! apply (file) weight
    nadd=int(add,mpl)        ! convert to integer
    globalchi2sumi(ithrd)=globalchi2sumi(ithrd)+nadd                 ! sum integer
    globalchi2sumd(ithrd)=globalchi2sumd(ithrd)+(add-real(nadd,mpd)) ! sum remainder
    IF(globalchi2sumd(ithrd) > 16.0_mpd) THEN       ! + - 16
        globalchi2sumd(ithrd)=globalchi2sumd(ithrd)-16.0_mpd
        globalchi2sumi(ithrd)=globalchi2sumi(ithrd)+16_mpl
    END IF
    globalndfsum(ithrd)=globalndfsum(ithrd)+int(ndf,mpl)
    globalndfsumw(ithrd)=globalndfsumw(ithrd)+real(ndf,mpd)*dw
    RETURN
END SUBROUTINE addsums
 
 
SUBROUTINE getsums(chi2, ndf, wndf)
    USE mpmod
 
    IMPLICIT NONE
    REAL(mpd), INTENT(OUT) ::chi2
    INTEGER(mpl), INTENT(OUT) ::ndf
    REAL(mpd), INTENT(OUT) ::wndf
    !     ...
    chi2=sum(globalchi2sumd)+real(sum(globalchi2sumi),mpd)
    ndf=sum(globalndfsum)
    wndf=sum(globalndfsumw)
    globalchi2sumd=0.0_mpd
    globalchi2sumi=0_mpl
    globalndfsum=0_mpl
    globalndfsumw=0.0_mpd
    RETURN
END SUBROUTINE getsums