!!  Copyright (C) Stichting Deltares, 2005-2023.
!!
!!  This file is part of iMOD.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License as published by
!!  the Free Software Foundation, either version 3 of the License, or
!!  (at your option) any later version.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!!
!!  Contact: imod.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands.
!!
!
!!!https://go.gale.com/ps/i.do?p=AONE&u=googlescholar&id=GALE|A98592842&v=2.1&it=r&sid=AONE&asid=d690f25b 
 
 
MODULE MOD_IPEST_GLM

#if(defined(DEFPARALLEL))
USE OMP_LIB
#endif
USE WINTERACTER
USE MOD_IDF_PAR
USE MOD_IDF, ONLY : IDFNULLIFY,IDFALLOCATEX,IDFWRITE,IDFREAD,IDFDEALLOCATEX,IDFWRITEFREE_ROW,IDFIROWICOL
USE IMODVAR, ONLY : DP_KIND
USE MOD_OSD, ONLY : OSD_OPEN
USE MOD_PMANAGER_PAR, ONLY : PEST,SIM,PARAM,PRJNLAY,PBMAN,PRJNPER,HNOFLOW,PCG,PRJIDF,PSTMEASURE,TOPICS,TKDW,TKHV,TKVV,TKVA,TSTO,TSPY,TSHD
USE MOD_PMANAGER_UTL, ONLY : PMANAGER_SAVEMF2005_MOD_U2DREL
USE MOD_UTL, ONLY  : UTL_GETUNIT,UTL_CAP,VTOS,UTL_GETMED,UTL_CREATEDIR,UTL_GOODNESS_OF_FIT,UTL_NASH_SUTCLIFFE,&
       VTOS,UTL_MF2005_MAXNO,UTL_DEL1TREE,YMDHMSTOITIME,UTL_COMPUTE_GXG,UTL_CONTINUE
USE MOD_IPEST_GLM_PAR
USE MOD_KRIGING_PAR
USE MOD_KRIGING
USE MOD_LUDCMP
USE MOD_LHC, ONLY : LHC
USE MOD_AI, ONLY : MOD_NN_MAIN,MOD_NN_OPTIMIZE,MOD_NN_DEALLOCATE
!INCLUDE 'for_iosdef.for'

CONTAINS

 !#####=================================================================
 SUBROUTINE IPEST_GLM_MAIN(DIR,MNAME,IBATCH,ITER)
 !#####=================================================================
 IMPLICIT NONE
 REAL(KIND=DP_KIND) :: LAMBDA_GAMMA,MU_GAMMA,MU_MAX,LAMBDA_MAX,LAMBDA_GAMMA_INI
 INTEGER,INTENT(IN) :: IBATCH
 INTEGER,INTENT(OUT) :: ITER
 CHARACTER(LEN=*),INTENT(IN) :: DIR,MNAME
 CHARACTER(LEN=256) :: LINE,STRING,DIRNAME,DIRO,DIRP
 REAL(KIND=DP_KIND) :: LAMBDA,DUMMY,DS
 INTEGER :: I,J,N,IX,ILOG,NITER,IOS,IP,IACT,NP,IS,NS,NMU
 INTEGER,ALLOCATABLE,DIMENSION(:) :: IPOS
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: PFCT
 TYPE(IDFOBJ) :: JIDF,RIDF
 LOGICAL :: LEX
 
 !## natural log transformation
 ILOG=1
  
 !## initialize random number generator
 CALL SRAND(1234) ! SEED FOR REPRODUCIBILITY

 !## initiate mu - set to number of observations eventually
 MU_INI=PBMAN%MU_INI; IF(MU_INI.EQ.0.0D0.AND.PBMAN%IPESTMETHOD.EQ.2)MU_INI=1.0D0
 
 !## initialize LAMBDA_GAMMA
 LAMBDA_GAMMA_INI=4.0D0
 LAMBDA_GAMMA=LAMBDA_GAMMA_INI
 !## half ratio between measurement objective/parameter objective
 MU_GAMMA    =4.0D0
 
 !## maximum ratio
 MU_MAX      =10.0D10 !## ratio between measurement and parameter objective function - need to unlimited as limj is set to determine mu eventually
 LAMBDA_MAX  =10.0D0  !## is reset to lambda_gamma_ini after reduction of objective function value
 NMU         =0
 
 !## organise groups
 IF(.NOT.IPEST_GLM_SETGROUPS(IBATCH,0))RETURN
 
! !## set up initial set of parameters for neural network optimization
! CALL IPEST_GLM_GENERATE_ENSEMBLES()

 !## allocate memory for simulations
 CALL IPEST_GLM_ALLOCATE(DIR)

 !## set initial values for alpha()
 DO I=1,SIZE(PEST%PARAM); IF(.NOT.IPEST_GLM_CHK(I,IBATCH))RETURN; ENDDO

 !## remove all nam-files unneeded
 DO I=1,SIZE(PEST%PARAM)
  IF(ABS(PEST%PARAM(I)%PACT).EQ.1)CYCLE 
  INQUIRE(FILE=TRIM(DIR)//'\'//TRIM(MNAME)//'_P#'//TRIM(VTOS(I))//'.NAM',EXIST=LEX)
  IF(LEX)CALL IOSDELETEFILE(TRIM(DIR)//'\'//TRIM(MNAME)//'_P#'//TRIM(VTOS(I))//'.NAM')
 ENDDO

 !## output map

 DIRP=TRIM(DIR)//'\IPEST'; IF(TRIM(PBMAN%IPESTPOUTPUT).NE.'')DIRP=PBMAN%IPESTPOUTPUT
 DIRO=DIR; IF(PBMAN%OUTPUT.NE.'')DIRO=PBMAN%OUTPUT

 CALL IOSDIRNAME(DIRNAME)
 !## make sure diro and pbman%output are all absolute pathnames
 STRING=DIRO;         CALL UTL_RELPATHNAME(DIRNAME,STRING,DIRO,'D')
 STRING=DIRP;         CALL UTL_RELPATHNAME(DIRNAME,STRING,DIRP,'D')
 STRING=PBMAN%OUTPUT; CALL UTL_RELPATHNAME(DIRNAME,STRING,PBMAN%OUTPUT,'D')
 
 !## restart, if so read previous files
 IF(PBMAN%RESTART.GT.0)THEN
  INQUIRE(FILE=TRIM(DIRP)//'\LOG_PEST_EFFICIENCY.TXT',EXIST=LEX)
  !## read initial objective function value
  IF(LEX)THEN
   IUPESTEFFICIENCY=UTL_GETUNIT(); OPEN(IUPESTEFFICIENCY, FILE=TRIM(DIRP)//'\LOG_PEST_EFFICIENCY.TXT',STATUS='OLD',ACTION='READ')
   DO I=1,2; READ(IUPESTEFFICIENCY,*); ENDDO; READ(IUPESTEFFICIENCY,*) MSR%TJRESTART,DUMMY,MSR%RJRESTART
   NITER=0; DO
    READ(IUPESTEFFICIENCY,*,IOSTAT=IOS)
    IF(IOS.NE.0)EXIT; NITER=NITER+1
   ENDDO
   LINE='COPY '//TRIM(DIRP)//'\LOG_PEST_EFFICIENCY.TXT '//TRIM(DIRP)//'\LOG_PEST_EFFICIENCY_COPY.TXT'
   CLOSE(IUPESTEFFICIENCY); CALL SYSTEM(LINE)
  ENDIF
  INQUIRE(FILE=TRIM(DIRP)//'\LOG_PEST_RUNFILE.TXT',EXIST=LEX)
  !## read initial objective function value
  IF(LEX)THEN
   IUPESTRUNFILE=UTL_GETUNIT(); OPEN(IUPESTRUNFILE,    FILE=TRIM(DIRP)//'\LOG_PEST_RUNFILE.TXT'    ,STATUS='OLD',ACTION='READ')
   DO 
    READ(IUPESTRUNFILE,'(A256)',IOSTAT=IOS) LINE
    IF(IOS.NE.0)THEN
     WRITE(*,*) 'Reading previous parameters did not read in correctly'
     STOP
    ENDIF
    LINE=UTL_CAP(LINE,'U')
    WRITE(STRING,'(A,1X,I10)') 'Copy in the runfile, iteration',NITER; STRING=UTL_CAP(STRING,'U')
    IF(INDEX(LINE,STRING).GT.0)THEN
     WRITE(*,*) 'New values:'
     !## reset parameters
     DO IP=1,SIZE(PEST%PARAM)
      READ(IUPESTRUNFILE,*) IACT,PEST%PARAM(IP)%PPARAM,PEST%PARAM(IP)%PILS,PEST%PARAM(IP)%PIZONE,PEST%PARAM(IP)%PINI
      !##  make upper case
      PEST%PARAM(IP)%PPARAM=UTL_CAP(PEST%PARAM(IP)%PPARAM,'U')
      WRITE(*,'(A,1X,2(I5,1X),F15.3)') TRIM(PEST%PARAM(IP)%PPARAM),PEST%PARAM(IP)%PILS,PEST%PARAM(IP)%PIZONE,PEST%PARAM(IP)%PINI
      IF(PEST%PARAM(IP)%PLOG.EQ.1)THEN
       PEST%PARAM(IP)%PINI=LOG(PEST%PARAM(IP)%PINI)
      ELSEIF(PEST%PARAM(IP)%PLOG.EQ.2)THEN
       PEST%PARAM(IP)%PINI=LOG10(PEST%PARAM(IP)%PINI)
      ENDIF
      PEST%PARAM(IP)%ALPHA(1)=PEST%PARAM(IP)%PINI !## current  alpha
      PEST%PARAM(IP)%ALPHA(2)=PEST%PARAM(IP)%PINI !## previous alpha
      PEST%PARAM(IP)%LALPHA=PEST%PARAM(IP)%ALPHA(1) 
     ENDDO
     EXIT
    ENDIF
   ENDDO
   LINE='COPY '//TRIM(DIRP)//'\LOG_PEST_RUNFILE.TXT '//TRIM(DIRP)//'\LOG_PEST_RUNFILE_COPY.TXT'
   CLOSE(IUPESTRUNFILE); CALL SYSTEM(LINE)
  ENDIF
 ENDIF
 
 !## open output files
 CALL UTL_CREATEDIR(TRIM(DIRP))
 IF(PBMAN%NCYCLE.GT.0)THEN
  IUPESTOUT=UTL_GETUNIT();         OPEN(IUPESTOUT,        FILE=TRIM(DIRP)//'\LOG_PEST_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT'            ,STATUS='REPLACE',ACTION='WRITE')
  IUPESTPROGRESS=UTL_GETUNIT();    OPEN(IUPESTPROGRESS,   FILE=TRIM(DIRP)//'\LOG_PEST_PROGRESS_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT'   ,STATUS='REPLACE',ACTION='WRITE')
  IUPESTEFFICIENCY=UTL_GETUNIT();  OPEN(IUPESTEFFICIENCY, FILE=TRIM(DIRP)//'\LOG_PEST_EFFICIENCY_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT' ,STATUS='REPLACE',ACTION='WRITE')
  IUPESTSENSITIVITY=UTL_GETUNIT(); OPEN(IUPESTSENSITIVITY,FILE=TRIM(DIRP)//'\LOG_PEST_SENSITIVITY_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT',STATUS='REPLACE',ACTION='WRITE')
  IUPESTRUNFILE=UTL_GETUNIT();     OPEN(IUPESTRUNFILE,    FILE=TRIM(DIRP)//'\LOG_PEST_RUNFILE_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT'    ,STATUS='REPLACE',ACTION='WRITE')
  IUPESTJACOBIAN=UTL_GETUNIT();    OPEN(IUPESTJACOBIAN,   FILE=TRIM(DIRP)//'\LOG_PEST_JACOBIAN_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT'   ,STATUS='REPLACE',ACTION='WRITE')
 ELSE
  IUPESTOUT=UTL_GETUNIT();         OPEN(IUPESTOUT,        FILE=TRIM(DIRP)//'\LOG_PEST.TXT'            ,STATUS='REPLACE',ACTION='WRITE')
  IUPESTPROGRESS=UTL_GETUNIT();    OPEN(IUPESTPROGRESS,   FILE=TRIM(DIRP)//'\LOG_PEST_PROGRESS.TXT'   ,STATUS='REPLACE',ACTION='WRITE')
  IUPESTEFFICIENCY=UTL_GETUNIT();  OPEN(IUPESTEFFICIENCY, FILE=TRIM(DIRP)//'\LOG_PEST_EFFICIENCY.TXT' ,STATUS='REPLACE',ACTION='WRITE')
  IUPESTSENSITIVITY=UTL_GETUNIT(); OPEN(IUPESTSENSITIVITY,FILE=TRIM(DIRP)//'\LOG_PEST_SENSITIVITY.TXT',STATUS='REPLACE',ACTION='WRITE')
  IUPESTRUNFILE=UTL_GETUNIT();     OPEN(IUPESTRUNFILE,    FILE=TRIM(DIRP)//'\LOG_PEST_RUNFILE.TXT'    ,STATUS='REPLACE',ACTION='WRITE')
  IUPESTJACOBIAN=UTL_GETUNIT();    OPEN(IUPESTJACOBIAN,   FILE=TRIM(DIRP)//'\LOG_PEST_JACOBIAN.TXT'   ,STATUS='REPLACE',ACTION='WRITE')
 ENDIF
 
 WRITE(IUPESTOUT,'(A)') '==============='
 WRITE(IUPESTOUT,'(A)') 'iPESTP-Settings'
 WRITE(IUPESTOUT,'(A)') '==============='
 WRITE(IUPESTOUT,'(A)') 'Number of CPU used: '//TRIM(VTOS(PBMAN%NCPU))
 WRITE(IUPESTOUT,'(A)') 'Number of Lambda-searches: '//TRIM(VTOS(PBMAN%NLAMBDASEARCH))
 WRITE(IUPESTOUT,'(A,99F10.3)') '- Lambdas: ',(PBMAN%LAMBDA_TEST(I),I=1,PBMAN%NLAMBDASEARCH)
 WRITE(IUPESTOUT,'(A)') 'Number of Line-searches: '//TRIM(VTOS(PBMAN%NLINESEARCH))
 WRITE(IUPESTOUT,'(A,99F10.3)') '- Line-searches: ',(PBMAN%LINE_SEARCH(I),I=1,PBMAN%NLINESEARCH)
 WRITE(IUPESTOUT,'(A)') 'Number of Pest Iterations: '//TRIM(VTOS(PEST%PE_MXITER))
 IF(PEST%PE_MXITER.EQ.0)WRITE(IUPESTOUT,'(A)') ' Sensitivity Analyses Started'
 WRITE(IUPESTOUT,'(A)') 'Stop Criterium Objective Function Value: '//TRIM(VTOS(PEST%PE_STOP,'F',3))
 WRITE(IUPESTOUT,'(A)') 'Sensitivity to Exclude Parameter (temporarily): '//TRIM(VTOS(ABS(PEST%PE_SENS),'F',3))
 IF(PEST%PE_SENS.GE.0.0D0) WRITE(IUPESTOUT,'(A)') '- Parameters are turned off TEMPORARILY whenever they have less sensitivity'
 IF(PEST%PE_SENS.LT.0.0D0) WRITE(IUPESTOUT,'(A)') '- Parameters are turned off PERMENANTLY whenever they have less sensitivity'
 WRITE(IUPESTOUT,'(A)') 'Acceptable residual value: '//TRIM(VTOS(PEST%PE_DRES,'F',3))
 WRITE(IUPESTOUT,'(A)') 'Absolute Residual Target: '//TRIM(VTOS(PEST%PE_TARGET(1),'F',3))
 WRITE(IUPESTOUT,'(A)') 'Relative Residual Target: '//TRIM(VTOS(PEST%PE_TARGET(2),'F',3))
 SELECT CASE (PEST%PE_SCALING)
  CASE (0); WRITE(IUPESTOUT,'(A)') 'No  Scaling, No  SVD'
  CASE (1); WRITE(IUPESTOUT,'(A)') 'Yes Scaling, No  SVD'
  CASE (2); WRITE(IUPESTOUT,'(A)') 'Yes Scaling, Yes SVD'
  CASE (3); WRITE(IUPESTOUT,'(A)') 'No  Scaling, Yes SVD'
 END SELECT
 SELECT CASE (ABS(PEST%PE_KTYPE))
  CASE (1); WRITE(IUPESTOUT,'(A)') 'Linear Semivariogram is used (if neccessary)'
  CASE (2); WRITE(IUPESTOUT,'(A)') 'Spherical Semivariogram is used (if neccessary)'
  CASE (3); WRITE(IUPESTOUT,'(A)') 'Exponential Semivariogram is used (if neccessary)'
  CASE (4); WRITE(IUPESTOUT,'(A)') 'Gaussian Semivariogram is used (if neccessary)'
  CASE (5); WRITE(IUPESTOUT,'(A)') 'Power Semivariogram is used (if neccessary)'
  CASE (6); WRITE(IUPESTOUT,'(A)') 'Thiessen Interpolation is used (if neccessary)'
 END SELECT
 WRITE(IUPESTOUT,'(A)') 'Kriging Range: '//TRIM(VTOS(PEST%PE_KRANGE,'F',3))
 WRITE(IUPESTOUT,'(A)') 'Termination Criterion for Parameter Adjustments (vectorlength): '//TRIM(VTOS(PEST%PE_PADJ,'F',3))
 SELECT CASE (PEST%PE_REGULARISATION)
  CASE (0)
   WRITE(IUPESTOUT,'(A)') 'Not using Regularisation: '//TRIM(VTOS(PEST%PE_REGULARISATION))
  CASE (1)
   WRITE(IUPESTOUT,'(A)') 'Using Regularisation (Homogenization): '//TRIM(VTOS(PEST%PE_REGULARISATION))
  CASE (2)
   WRITE(IUPESTOUT,'(A)') 'Using Regularisation (Preferred Parameter): '//TRIM(VTOS(PEST%PE_REGULARISATION))
  CASE DEFAULT 
   WRITE(*,'(A)') '>>> Use a value of 0,1 or 2 for regularisation: '//TRIM(VTOS(PEST%PE_REGULARISATION))//' <<<'
 END SELECT
 WRITE(IUPESTOUT,'(A)') 'TIKHONOV REGULARISATION INITIAL FACTOR (MU): '//TRIM(VTOS(PBMAN%MU_INI,'E',7))
 
 WRITE(IUPESTOUT,'(/A)') 'Parameters'
 WRITE(IUPESTOUT,'(A2,1X,A5,1X,A5,1X,A7,5(1X,A15),3A10,6A15)') 'AC','PTYPE','ILS','IZN','INITIAL','DELTA','MINIMUM','MAXIMUM','FADJ','IGROUP','LTRANS', &
     'NODES','ACRONYM','PPRIOR','STDEV','SDATE','EDATE','PORG'
  
 DO I=1,SIZE(PEST%PARAM); CALL IPEST_GLM_ECHO_PARAMETERS(I); ENDDO;  WRITE(IUPESTOUT,*)
 
 WRITE(IUPESTOUT,'(/1X,2(A,I10),A/)') 'Optimizing ',SIZE(RNG),' Parameters/Groups out of ',SIZE(PEST%PARAM),' parameters'
 
 WRITE(IUPESTEFFICIENCY,'(8(A15,1X))') 'TOTAL_J','MEAS._J','PARAM._J','RMSE_TJ','ADJUSTMENTS','CUR_IMPROVEMENT','TOT_IMPROVEMENT'
 WRITE(IUPESTEFFICIENCY,'(8(A15,1X))') '(L2)',   '(L2)',   '(L2)',    '(L)',    '(-)',        '(%)',            '(%)'
 IF(PBMAN%RESTART.EQ.1)THEN
  WRITE(IUPESTEFFICIENCY,'(3(F15.3,1X),A)') MSR%TJRESTART,MSR%TJRESTART-MSR%RJRESTART,MSR%RJRESTART,' >>> restart org value <<< '
 ENDIF
 WRITE(IUPESTSENSITIVITY,'(A)')   'Sensitivity (%):'

 N=0; DO J=1,SIZE(PEST%PARAM); IF(ABS(PEST%PARAM(J)%PIGROUP).GT.0)N=N+1; ENDDO

 CALL IPEST_GLM_WRITEHEADER('Iteration      ',N,IUPESTSENSITIVITY)
 
 !## get and remember actual iMOD run location + switch to temporal simulation directory
 CALL IOSDIRNAME(DIRNAME); CALL IOSDIRCHANGE(TRIM(DIR)//'\')
 
 CALL WMESSAGEENABLE(TIMEREXPIRED,1); MSR%PJ=HUGE(1.0D0)
 
 !## compute parameter weight matrix
 CALL IPEST_GLM_QR(IBATCH,DIRP)

 IF(PEST%PE_MXITER.LT.-1)THEN
  NS=ABS(PEST%PE_MXITER)
  PEST%PARAM%PMIN=LOG(0.001D0)
  PEST%PARAM%PMAX=LOG(1000.0D0)
  NP=0; DO I=1,SIZE(PEST%PARAM); IF(PEST%PARAM(I)%PIGROUP.GT.0)NP=NP+1; ENDDO
  DS=6.0D0/REAL(NS-1,8)
  ALLOCATE(PFCT(NS)); PFCT(1)=-3.0D0; DO I=2,NS ; PFCT(I)=PFCT(I-1)+DS; ENDDO
  !## all start at 1
  ALLOCATE(IPOS(NP)); IPOS=1
  IF(NP.EQ.2)THEN
   CALL IDFNULLIFY(JIDF)
   JIDF%NCOL=NS;     JIDF%NROW=NS; JIDF%DX=DS; JIDF%DY=JIDF%DX
   JIDF%XMIN=-3.0D0-0.5D0*DS; JIDF%XMAX= 3.0D0+0.5D0*DS
   JIDF%YMIN=-3.0D0-0.5D0*DS; JIDF%YMAX= 3.0D0+0.5D0*DS
   IF(.NOT.IDFALLOCATEX(JIDF))THEN; ENDIF
   CALL IDFCOPY(JIDF,RIDF)
  ENDIF
  WRITE(IUPESTOUT,'(/99A15)') ('PARAM'//TRIM(VTOS(J)),J=1,NP),'MES.OBJ.F.','PAR.OBJ.F.'
  DO IS=1,NS**NP
   
   !## set alpha
   IP=0; DO I=1,SIZE(PEST%PARAM)
    IF(PEST%PARAM(I)%PIGROUP.GT.0)THEN
     IP=IP+1
     PEST%PARAM(I)%PINI=PFCT(IPOS(IP))
     PEST%PARAM(I)%LALPHA(1)=PEST%PARAM(I)%PINI
     !## set all group members
     DO J=1,SIZE(PEST%PARAM)
      IF(PEST%PARAM(J)%PIGROUP.EQ.PEST%PARAM(I)%PIGROUP)THEN
       PEST%PARAM(J)%PINI=PFCT(IPOS(IP))
       PEST%PARAM(J)%LALPHA(1)=PEST%PARAM(J)%PINI
      ENDIF
     ENDDO
    ENDIF
   ENDDO
   WRITE(*,'(99A)') (' I',TRIM(VTOS(J)),'=',TRIM(VTOS(PFCT(IPOS(J)),'F',2)),J=1,NP)
   
   !## run lambda-testing
   ITER=0; IF(.NOT.IPEST_GLM_RUNMODELS(DIRNAME,IBATCH,RNL,LPARAM,'L',DIR,MNAME,ITER,LAMBDA,0))THEN; ENDIF
!   !## copy current objective function value to previous objective function value
!   IF(MSR%NOBS.GT.0)MSR%PJ=MSR%TJ
   ITER=1
  
   WRITE(IUPESTOUT,'(99F15.7)') (PFCT(IPOS(J)),J=1,NP),MSR%TJ-MSR%RJ,MSR%RJ
   IF(NP.EQ.2)THEN
    JIDF%X(IPOS(1),(NS-IPOS(2)+1))=MSR%TJ-MSR%RJ
    RIDF%X(IPOS(1),(NS-IPOS(2)+1))=MSR%RJ
   ENDIF
   
 !  !## run and process all parameters-sensitivities
 !  IUPESTRESIDUAL=0; IUPESTPRESIDUAL=0; IF(.NOT.IPEST_GLM_RUNMODELS(DIRNAME,IBATCH,RNG,GPARAM,'P',DIR,MNAME,ITER,LAMBDA,0))EXIT
  
 !  !## determine new gradient
 !  J=IPEST_GLM_GRADIENT(IBATCH,ITER,LAMBDA,LAMBDA_GAMMA,DIRO)
  
 !  !## run lambda-testing
 !  IF(.NOT.IPEST_GLM_RUNMODELS(DIRNAME,IBATCH,RNL,LPARAM,'L',DIR,MNAME,ITER,LAMBDA,0))THEN; ENDIF
 !  !## determine best lambda and continue, otherwise determine another set of lambda's
 !  IF(.NOT.IPEST_GLM_NEXT(IBATCH,ITER,DIR,DIRO,DIRP,LAMBDA,LAMBDA_GAMMA,MNAME,MU_MAX,MU_LAMBDA_GAMMA))THEN; ENDIF

   !## goto next set of parameters
   IPOS(1)=IPOS(1)+1
   DO I=1,NP
    IF(I.LT.NP.AND.IPOS(I).GT.NS)THEN
     IPOS(I)=1; IPOS(I+1)=IPOS(I+1)+1
    ENDIF
   ENDDO

  ENDDO
  IF(NP.EQ.2)THEN
   IF(.NOT.IDFWRITE(JIDF,TRIM(DIRP)//'\JIDF.IDF',1))THEN; ENDIF
   IF(.NOT.IDFWRITE(RIDF,TRIM(DIRP)//'\RIDF.IDF',1))THEN; ENDIF
  ENDIF
  RETURN
 ENDIF
 
 NP=0; DO I=1,SIZE(PEST%PARAM); IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE; NP=NP+1; ENDDO
 WRITE(*,'(/A/)') '>>> Number of in- and active parameters in current model optimization '//TRIM(VTOS(NP))//' <<<' 
 
 !## start optimization cycle
 ITER=0
MAINLOOP: DO 

  !## run and process all lambda-testing
  !## save initial residuals
  IF(ITER.EQ.0)THEN
   IF(IUPESTRESIDUAL.GT.0)CLOSE(IUPESTRESIDUAL); IUPESTRESIDUAL=UTL_GETUNIT()
   IF(PBMAN%NCYCLE.GT.0)THEN
    OPEN(IUPESTRESIDUAL,FILE=TRIM(DIRP)//'\LOG_PEST_RESIDUAL_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT',STATUS='REPLACE',ACTION='WRITE')
   ELSE
    OPEN(IUPESTRESIDUAL,FILE=TRIM(DIRP)//'\LOG_PEST_RESIDUAL_0.TXT',STATUS='REPLACE',ACTION='WRITE')
   ENDIF
   IF(IUPESTPRESIDUAL.GT.0)CLOSE(IUPESTPRESIDUAL); IUPESTPRESIDUAL=UTL_GETUNIT()
   IF(PBMAN%NCYCLE.GT.0)THEN
    OPEN(IUPESTPRESIDUAL,FILE=TRIM(DIRP)//'\LOG_PESTP_RESIDUAL_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT',STATUS='REPLACE',ACTION='WRITE')
   ELSE
    OPEN(IUPESTPRESIDUAL,FILE=TRIM(DIRP)//'\LOG_PESTP_RESIDUAL_0.TXT',STATUS='REPLACE',ACTION='WRITE')
   ENDIF
  ELSE
   IUPESTRESIDUAL=0; IUPESTPRESIDUAL=0
  ENDIF 
  
  !## set up initial set of parameters for neural network optimization
  IF(PBMAN%IPESTMETHOD.EQ.3)CALL IPEST_GLM_GENERATE_ENSEMBLES()
  
  !## run lambda-testing
  IF(.NOT.IPEST_GLM_RUNMODELS(DIRNAME,IBATCH,RNL,LPARAM,'L',DIR,MNAME,ITER,LAMBDA,0))EXIT
  
  !## initial lambda
  IF(ITER.GT.0)THEN
   IF(PBMAN%IPESTMETHOD.EQ.1)THEN
    !## determine best lambda and continue, otherwise determine another set of lambda's
    IF(.NOT.IPEST_GLM_NEXT(IBATCH,ITER,DIR,DIRO,DIRP,LAMBDA,LAMBDA_MAX,LAMBDA_GAMMA,MNAME,MU_MAX,MU_GAMMA,LAMBDA_GAMMA_INI,NMU))THEN
     IF(LAMBDA_GAMMA.GT.0.0D0)THEN    
      !## determine new gradient
      I=IPEST_GLM_GRADIENT(IBATCH,ITER,LAMBDA,ABS(LAMBDA_GAMMA),DIRO)
     ELSE
      !## overrule stopping
      IF(LAMBDA_GAMMA.LT.0.0D0)I=-1
     ENDIF
     SELECT CASE (I)
      !## quit
      CASE (-1); ITER=ITER-1; EXIT MAINLOOP
      !## start next cycle
      CASE (0 ); EXIT
      !## repeat current cycle
      CASE (1 ); CYCLE
     END SELECT
    ENDIF
   ELSE
!    CALL IPEST_GLM_FILL_JACOBIAN()
    MSR%GOF_H(ITER)=MSR%GOF(1); MSR%NSC_H(ITER)=MSR%NSC(1)
    MSR%TJ_H(ITER)=MSR%TJ;      MSR%RJ_H(ITER)=MSR%RJ
    MSR%MU(ITER)=MU_INI
    DO I=1,MSR%NOBS
     MSR%HL(0,I) =MSR%HL(1,I)
     MSR%DHL(0,I)=MSR%DHL(1,I)
    ENDDO
   ENDIF
  ELSE
   IF(MSR%NOBS.GT.0)THEN
    !## set current h on correct position
    DO I=1,MSR%NOBS
     MSR%HL(0,I) =MSR%HL(1,I)
     MSR%DHL(0,I)=MSR%DHL(1,I)
    ENDDO
    LAMBDA=MSR%TJ/DBLE(2.0D0*MSR%NOBS)
    IF(ILOG.EQ.1)THEN
     LAMBDA=LOG(LAMBDA); IX=FLOOR(LAMBDA); LAMBDA=EXP(REAL(IX,8))
    ELSEIF(ILOG.EQ.2)THEN
     LAMBDA=LOG10(LAMBDA); IX=FLOOR(LAMBDA); LAMBDA=10.0D0**IX
    ENDIF
    !## write initial lambda
    WRITE(IUPESTOUT,'(/A/)') 'Initial Lambda_0 computed as '//TRIM(VTOS(LAMBDA,'G',3))
    MSR%TJ_H(ITER)=MSR%TJ; MSR%RJ_H(ITER)=MSR%RJ; MSR%GOF_H(ITER)=MSR%GOF(1); MSR%NSC_H(ITER)=MSR%NSC(1)
     !## save initial heads with these (only for modflow2005/modflow6) and if isteady=1 icm transient
    IF(PBMAN%IFORMAT.EQ.2.OR.PBMAN%IFORMAT.EQ.3)CALL IPEST_GLM_UPDATEHEADS(DIR,DIRO,1)
   ENDIF
  ENDIF
  IF(.NOT.IPEST_GLM_ECHOPARAMETERS(IBATCH,ITER,DIRP))EXIT

  !## if mxiter <0 stop
  IF(PEST%PE_MXITER.LT.0)EXIT

  !## next cycle
  ITER=ITER+1
  
  !## copy current objective function value to previous objective function value
  IF(MSR%NOBS.GT.0)MSR%PJ=MSR%TJ
  
  !## "melt" all parameters for next cycle
  DO I=1,SIZE(PEST%PARAM); IF(PEST%PARAM(I)%PACT.EQ.-1)PEST%PARAM(I)%PACT=1; ENDDO
  
  !## run and process all parameters-sensitivities
  IUPESTRESIDUAL=0; IUPESTPRESIDUAL=0; IF(.NOT.IPEST_GLM_RUNMODELS(DIRNAME,IBATCH,RNG,GPARAM,'P',DIR,MNAME,ITER,LAMBDA,0))EXIT
  
  !## determine new gradient
  SELECT CASE (PBMAN%IPESTMETHOD)
   CASE (1); I=IPEST_GLM_GRADIENT(IBATCH,ITER,LAMBDA,LAMBDA_GAMMA,DIRO)
   CASE (2); I=IPEST_PATTERN_SEARCH(); LAMBDA=1.0D0
   !## carry out neural-network
   CASE (3); I=IPEST_AI_OPTIMIZATION(DIRP,ITER); LAMBDA=1.0D0
  END SELECT
  
  !## sensitivities finished
  IF(PEST%PE_MXITER.EQ.0)EXIT

  SELECT CASE (I)
   !## quit
   CASE (-1); ITER=ITER-1; EXIT MAINLOOP
  END SELECT
  
 ENDDO MAINLOOP
 CALL WMESSAGETIMER(0); CALL WMESSAGEENABLE(TIMEREXPIRED,0)

 !## bring the iMOD run location back to he origional directory
 CALL IOSDIRCHANGE(DIRNAME)
 
 END SUBROUTINE IPEST_GLM_MAIN
 
 !###======================================================================
 INTEGER FUNCTION IPEST_AI_OPTIMIZATION(DIR,ITER)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER,INTENT(IN) :: ITER
 INTEGER :: IU,JU,NOBS,NPARAM,NSIM,I,II,J,K,IDATE,NITER,IOS,NEURONS
 CHARACTER(LEN=20) :: CIPF
 REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: X,OBS,WGT 
 REAL(KIND=DP_KIND),DIMENSION(:,:,:),ALLOCATABLE :: HED,FCT
 REAL(KIND=DP_KIND) :: ACC

 CALL IPEST_GLM_FILL_JACOBIAN(); CLOSE(IUPESTJACOBIAN)
 
 !## read jacobian and fill ini for neural-network
 IU=UTL_GETUNIT(); OPEN(IU,FILE=TRIM(DIR)//'\NN_INPUT.TXT'         ,ACTION='WRITE',STATUS='REPLACE',FORM='FORMATTED')
 JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(DIR)//'\LOG_PEST_JACOBIAN.TXT',ACTION='READ' ,STATUS='OLD'    ,FORM='FORMATTED')
 
 DO II=1,2
  K=0; DO
   READ(JU,*,IOSTAT=IOS); IF(IOS.NE.0)EXIT
   K=K+1
   READ(JU,*) NOBS,NPARAM,NSIM
   IF(.NOT.ALLOCATED(OBS))THEN; ALLOCATE(OBS(NOBS)); OBS=0.0D0; ENDIF
   IF(.NOT.ALLOCATED(WGT))THEN; ALLOCATE(WGT(NOBS)); WGT=0.0D0; ENDIF
   READ(JU,*); READ(JU,*)
   !## read factors
   ALLOCATE(X(NPARAM))
   DO J=1,NSIM
    READ(JU,*) I,(X(I),I=1,NPARAM)
    IF(II.EQ.2)THEN
     !## log-transform factors
     DO I=1,NPARAM; FCT(I,J,K)=LOG(X(I)); ENDDO
    ENDIF
   ENDDO
   DEALLOCATE(X)
   READ(JU,*); READ(JU,*)
   !## read observations
   ALLOCATE(X(NSIM))
   DO I=1,NOBS
    READ(JU,*) J,CIPF,IDATE,ACC,OBS(I),WGT(I),(X(J),J=1,NSIM)
    IF(II.EQ.2)THEN
     DO J=1,NSIM; HED(I,J,K)=X(J); ENDDO
    ENDIF
   ENDDO
   DEALLOCATE(X)
  ENDDO
  IF(II.EQ.1)THEN
   NITER=K
   ALLOCATE(FCT(NPARAM,NSIM,NITER)); FCT=0.0D0
   ALLOCATE(HED(NOBS  ,NSIM,NITER)); HED=0.0D0
   REWIND(JU)   
  ENDIF
 ENDDO
 CLOSE(JU)
 
 !## do iets met hed/obs
 DO K=1,NITER
  DO J=1,NSIM
   DO I=1,NOBS
    HED(I,J,K)=WGT(I)*ABS(HED(I,J,K)-OBS(I))
!    HED(I,J,K)=WGT(I)*(HED(I,J,K)-OBS(I))**2.0D0
   ENDDO
  ENDDO
 ENDDO
 
 WRITE(IU,'(2I10,A)') NPARAM,NOBS, ' !## INPUT,OUTPUT'
 WRITE(IU,'(2I10,A)') NSIM*NITER,0,' !## SAMPLE,VALIDATION'
 WRITE(IU,'(99(A,1X))') ('FCT'//TRIM(VTOS(I))//',',I=1,NPARAM),('OBS'//TRIM(VTOS(I))//',',I=1,NOBS-1),'OBS'//TRIM(VTOS(NOBS))
 DO K=1,NITER
  DO J=1,NSIM
   WRITE(IU,'(99(F15.7,1X))') (FCT(I,J,K),I=1,NPARAM),(HED(I,J,K),I=1,NOBS)
  ENDDO
 ENDDO
 CLOSE(IU)
 
 IU=UTL_GETUNIT(); OPEN(IU,FILE=TRIM(DIR)//'\NN_INPUT.INI',STATUS='REPLACE',ACTION='WRITE')
 
 WRITE(IU,'(A)') TRIM(DIR)//'\NN_INPUT.OUT'
 WRITE(IU,'(A)') '1               !## IDEBUG'
 WRITE(IU,'(A)') '0.9             !## LEARNING RATE'
 WRITE(IU,'(A)') '0.0             !## MOMENTUM'
 WRITE(IU,'(A)') '0               !## CONVOLUTION LAYERS'
 WRITE(IU,'(A)') '1               !## HIDDENLAYERS'

 !## number of neurons
 NEURONS=CEILING(REAL(NPARAM,8)*(2.0/3.0))+NOBS
 NEURONS=MAX(2,NEURONS) 
 
 WRITE(IU,'(A)') TRIM(VTOS(NEURONS))//'       !## NEURONS'
 WRITE(IU,'(A)') 'SIGMOID SIGMOID !## ACTIVATION FUNCTION'
 WRITE(IU,'(A)') '1000            !## NUMBER OF TRAINING'
 WRITE(IU,'(A)') '1               !## NUMBER OF BATCHES'
 WRITE(IU,'(A)') TRIM(DIR)//'\NN_INPUT.TXT'
 CLOSE(IU)
 
 CALL MOD_NN_MAIN(TRIM(DIR)//'\NN_INPUT.INI')
 
 !## find optimal value starting from current centre point, thus from niter
 CALL MOD_NN_OPTIMIZE(FCT(:,1,NITER),FCT(:,1,1),ITER)
 
 !## clean all
 CALL MOD_NN_DEALLOCATE()

 J=0; DO I=1,SIZE(PEST%PARAM)
  IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE
  J=J+1
  PEST%PARAM(I)%ALPHA(1)=FCT(J,1,NITER)
!    WRITE(IUPESTPROGRESS,'(/A2,I5,7F15.7/)') FWBW(J),ABS(IC),X,MSR%DHG_J(JGRAD),MSR%DHG_J(JGRAD)-MSR%DPG_J(JGRAD),MSR%DPG_J(JGRAD),MSR%PJ,MSR%DHG_J(JGRAD)-MSR%PJ,F
 ENDDO
 
 !## copy gradients to all groups
 DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE
  DO J=1,SIZE(PEST%PARAM)
   IF(ABS(PEST%PARAM(J)%PIGROUP).EQ.PEST%PARAM(I)%PIGROUP)PEST%PARAM(J)%ALPHA(1)=PEST%PARAM(I)%ALPHA(1)
  ENDDO
 ENDDO
 
 !## copy alphas to correct vector with updates per lambda
! WRITE(IUPESTPROGRESS,*) '==============================================='
 DO I=1,SIZE(PEST%PARAM)
  PEST%PARAM(I)%LALPHA(:)=PEST%PARAM(I)%ALPHA(1)
  WRITE(*,*) I,EXP(PEST%PARAM(I)%ALPHA(1))
 ENDDO
! WRITE(IUPESTPROGRESS,*) '==============================================='
 
 DEALLOCATE(OBS,WGT,HED,FCT)

 !## reopen to add to iupestjacobian
 IUPESTJACOBIAN=UTL_GETUNIT(); OPEN(IUPESTJACOBIAN,FILE=TRIM(DIR)//'\LOG_PEST_JACOBIAN.TXT',STATUS='OLD',POSITION='APPEND',ACTION='WRITE')
   
 IPEST_AI_OPTIMIZATION=1
 
 END FUNCTION IPEST_AI_OPTIMIZATION
 
 !###======================================================================
 SUBROUTINE IPEST_GLM_GENERATE_ENSEMBLES()
 !###======================================================================
 IMPLICIT NONE
 REAL(KIND=DP_KIND),DIMENSION(:,:),ALLOCATABLE :: COV,COR,SAMPLE
 REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: STD,AVG
 REAL(KIND=DP_KIND) :: K1,K2,CB,STDV,AVEG
 INTEGER :: I,II,J,N,ILOG,NSIM,ISIM,IU,NPOP
 
 !## KAN OOK MET EIGEN COVARIANCE BINNENKOMEN
 !## PARAMETER KANS TRIMMMEN OP MIN/MAX WAARDEN
 
 ILOG=PEST%PARAM(1)%PLOG

 N=0; DO I=1,SIZE(PEST%PARAM); IF(PEST%PARAM(I)%PACT.EQ.1)N=N+1; ENDDO
 DO I=1,SIZE(PEST%PARAM)
  !## variance adjust with new minimal value
  PEST%PARAM(I)%PARMEAN=PEST%PARAM(I)%LALPHA(1)
!  IF(ILOG.EQ.1)THEN
!   PEST%PARAM(I)%PARMEAN=LOG(PEST%PARAM(I)%PINI)
!   K1=LOG(ABS(PEST%PARAM(I)%PMIN)); K2=LOG(ABS(PEST%PARAM(I)%PMAX))
!  ELSEIF(ILOG.EQ.2)THEN
!   PEST%PARAM(I)%PARMEAN=LOG10(PEST%PARAM(I)%PINI)
!   K1=LOG10(ABS(PEST%PARAM(I)%PMIN)); K2=LOG10(ABS(PEST%PARAM(I)%PMAX))
!  ELSE
!   PEST%PARAM(I)%PARMEAN=PEST%PARAM(I)%PINI
!   K1=PEST%PARAM(I)%PMIN; K2=PEST%PARAM(I)%PMAX
!  ENDIF
  K1=PEST%PARAM(I)%PMIN; K2=PEST%PARAM(I)%PMAX
  PEST%PARAM(I)%PARSTD=(K2-K1)/4.0D0
 ENDDO 
 
 ALLOCATE(STD(N),AVG(N),COV(N,N),COR(N,N)); COV=0.0D0; COR=0.0D0; STD=0.0D0; AVG=0.0D0

 !## number of simulations equato to n
 NSIM=N; ALLOCATE(SAMPLE(NSIM,N)); SAMPLE=0.0D0

 DO I=1,SIZE(PEST%PARAM)
  IF(ASSOCIATED(PEST%PARAM(I)%ALPHA_SIM))DEALLOCATE(PEST%PARAM(I)%ALPHA_SIM)
  ALLOCATE(PEST%PARAM(I)%ALPHA_SIM(NSIM))
 ENDDO
 
 N=0; DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PACT.EQ.1)THEN
   N=N+1
   STD(N)=PEST%PARAM(I)%PARSTD
   AVG(N)=PEST%PARAM(I)%PARMEAN
  ENDIF
 ENDDO
! avg=0.0d0
! std=1.0d0
 
 CALL IPEST_GLM_LATIN_HYPERCUBE_SAMPLING(NSIM,N,AVG,STD,SAMPLE)

! SEED=12345

! CALL LHC(N,N,SEED,sample)
! do isim=1,N
!  write(*,'(99f10.3)') (sample(isim,i),i=1,n)
! enddo
 
 !# set up covariance (no corrrelation initially) - will come from optimization
 DO I=1,N; COV(I,I)=STD(I)*STD(I); ENDDO
 !## compute correlation
 DO I=1,N; DO J=1,N
  CB=COV(I,I)*COV(J,J)
  IF(CB.GT.0.0D0)COR(I,J)=COV(I,J)/SQRT(CB)
 ENDDO; ENDDO
 
 !## perform cholesky-decomposition A=LTL - delivers upper triangle is LT
 CALL CHOLESKYDECOMPOSITION(COR,N,1) 
   
 !ELSE
 !
 ! ALLOCATE(EV(N,N),E(N),EW(N))
 ! !## copy covariance matrix
 ! EV=COV
 ! 
 ! ECRIT=99.0D0 !9.9D0
 ! 
 ! !## perform eigenvalue decomposition
 ! CALL LUDCMP_TRED2(EV,N,N,EW,E)
 ! !## ev are the eigenvectors
 ! IF(.NOT.LUDCMP_TQLI(EW,E,N,N,EV))THEN; PAUSE; STOP; ENDIF
 ! 
 ! !## sort
 ! CALL LUDCMP_EIGSRT(EW,EV,N,NE)
 ! ALLOCATE(EVEC(NE,N))
 ! EVEC=TRANSPOSE(EV)
 ! DEALLOCATE(EV)
 ! 
 ! DO I=1,NE
 !  IF(EW(I).LE.1.0D-10)EW(I)=0.0D0
 !  EW(I)=SQRT(EW(I))
 ! ENDDO
 !
 ! DEALLOCATE(COR); ALLOCATE(COR(N,N)); COR=0.0D0; DO I=1,N
 !  COR(I,I)=EW(I)
 ! ENDDO
 ! CALL UTL_MATMUL(EV,COR,COV)
 ! NN=N
 ! DEALLOCATE(EV,EW)
 
! DO I=1,N
!  DO ISIM=1,NSIM
!   !## generates number -3 to +3 - in log-space permeability is normal-distributed
!   CALL IPEST_NORMAL_MS_SAMPLE(AVG(I),STD(I),SEED,SAMPLE(ISIM,I))
!  ENDDO
! ENDDO

 iu=utl_getunit()
 open(iu,file='d:\tmp.txt',FORM='FORMATTED',status='REPLACE')
 do isim=1,nsim
  write(iu,'(99f10.3)') (sample(isim,i),i=1,n)
 enddo
 close(iu)

 DO II=1,2

  N=0; DO I=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(I)%PACT.NE.1)CYCLE; N=N+1
   IF(ILOG.EQ.1)THEN
    WRITE(*,'(A,4F15.7)')  'LN:    MIN,MAX,MEAN,STDEV',K1     ,K2     ,PEST%PARAM(I)%PARMEAN     ,PEST%PARAM(I)%PARSTD
    WRITE(*,'(A,4F15.7)')  '       MIN,MAX,MEAN,STDEV',EXP(K1),EXP(K2),EXP(PEST%PARAM(I)%PARMEAN),EXP(PEST%PARAM(I)%PARSTD)
   ELSEIF(ILOG.EQ.2)THEN
    WRITE(*,'(A,4F15.7)')  'LOG10: MIN,MAX,MEAN,STDEV',K1        ,K2        ,PEST%PARAM(I)%PARMEAN        ,PEST%PARAM(I)%PARSTD
    WRITE(*,'(A,4F15.7)')  '       MIN,MAX,MEAN,STDEV',10.0D0**K1,10.0D0**K2,10.0D0**PEST%PARAM(I)%PARMEAN,10.0D0**PEST%PARAM(I)%PARSTD
   ENDIF

   CALL UTL_STDEF(SAMPLE(:,N),NSIM,0.0D0,STDV,AVEG,NPOP)
   IF(ILOG.EQ.0)THEN
    WRITE(*,'(A10,2A15)') 'NPOP','MEAN','STDV'
    WRITE(*,'(I10,2F15.7)') NPOP,AVEG,STDV
   ELSEIF(ILOG.EQ.1)THEN
    WRITE(*,'(A10,4A15)') 'NPOP','LN(MEAN)','LN(STDV)','MEAN','STDV'
    WRITE(*,'(I10,4F15.7)') NPOP,AVEG,STDV,EXP(AVEG),EXP(STDV)
   ELSEIF(ILOG.EQ.2)THEN
    WRITE(*,'(A10,4A15)') 'NPOP','LOG10(MEAN)','LOG10(STDV)','MEAN','STDV'
    WRITE(*,'(I10,4F15.7)') NPOP,AVEG,STDV,10.0**AVEG,10.0D0**STDV
   ENDIF
  ENDDO
 
  !## project on L-matrix
  IF(II.EQ.1)SAMPLE=TRANSPOSE(MATMUL(COR,TRANSPOSE(SAMPLE)))

 ENDDO
 
 N=0; DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PACT.NE.1)CYCLE; N=N+1
  !## give all parameters update 
  DO J=1,SIZE(PEST%PARAM)
   !## skip inactive parameters
   IF(PEST%PARAM(I)%PACT.EQ.0)CYCLE
   IF(ABS(PEST%PARAM(I)%PIGROUP).EQ.ABS(PEST%PARAM(J)%PIGROUP))THEN
    DO ISIM=1,NSIM
     PEST%PARAM(J)%ALPHA_SIM(ISIM)=SAMPLE(ISIM,N)
    ENDDO
   ENDIF
  ENDDO  
 ENDDO
 
 DEALLOCATE(COV,STD,AVG)

 N=0; DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PACT.NE.1)CYCLE; N=N+1
  WRITE(*,'(99F10.3)') (EXP(PEST%PARAM(I)%ALPHA_SIM(ISIM)),ISIM=1,NSIM)
 ENDDO
 
 END SUBROUTINE IPEST_GLM_GENERATE_ENSEMBLES

 !!#####=================================================================
 !SUBROUTINE IPEST_GLM_LATIN_HYPERCUBE_SAMPLING(N_SAMPLES,N_VARS,MEAN_VALS,STD_DEVS)
 !!#####=================================================================
 !IMPLICIT NONE
 !INTEGER,INTENT(IN) :: N_SAMPLES,N_VARS
 !REAL(KIND=DP_KIND),DIMENSION(N_VARS) :: MEAN_VALS,STD_DEVS
 !REAL(KIND=DP_KIND),DIMENSION(:,:),ALLOCATABLE :: SAMPLES !(N_VARS, N_SAMPLES)
 !REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: FRACTIONS !(N_SAMPLES)
 !INTEGER :: I, J
 !REAL(KIND=DP_KIND) :: TEMP,X
 !   
 !ALLOCATE(FRACTIONS(N_SAMPLES),SAMPLES(N_VARS,N_SAMPLES))
 !
 !!## generate latin hypercube fractions
 !DO I=1,N_SAMPLES
 ! FRACTIONS(I)=(I-0.5D0)/REAL(N_SAMPLES,8)
 !END DO
 !
 !!## shuffle the fractions
 !DO I = 1, N_SAMPLES
 ! CALL RANDOM_NUMBER(X)
 ! J = INT(X*N_SAMPLES) + 1
 ! TEMP = FRACTIONS(I)
 ! FRACTIONS(I) = FRACTIONS(J)
 ! FRACTIONS(J) = TEMP
 !END DO
 !
 !!## generate samples
 !DO I = 1, N_VARS
 ! DO J = 1, N_SAMPLES
 !  SAMPLES(I, J) = NORM_INV_CDF(FRACTIONS(J), MEAN_VALS(I), STD_DEVS(I))
 ! END DO
 !END DO
 !
 !!## print samples
 !DO I = 1, N_SAMPLES
 ! PRINT *, SAMPLES(:, I)
 !END DO
 !
 !DEALLOCATE(SAMPLES,FRACTIONS)
 !
 !END SUBROUTINE IPEST_GLM_LATIN_HYPERCUBE_SAMPLING
 !
 !!#####=================================================================
 !REAL(KIND=DP_KIND) FUNCTION NORM_INV_CDF(P, MEAN, STD_DEV)
 !!#####=================================================================
 !REAL(KIND=DP_KIND), INTENT(IN) :: P, MEAN, STD_DEV
 !REAL(KIND=DP_KIND) :: Q, R, VAL
 !
 !Q=P-0.5
 !R=SQRT(-2.0*LOG(MAX(1.0E-20,ABS(Q))))
 !VAL=MEAN+STD_DEV*SIGN(1.0,Q)*R
 !NORM_INV_CDF=VAL
 !
 !END FUNCTION NORM_INV_CDF
 
 !#####=================================================================
 SUBROUTINE IPEST_GLM_LATIN_HYPERCUBE_SAMPLING(N_SAMPLES,N_VARIABLES,MEAN,STD_DEV,X)
 !#####=================================================================
 IMPLICIT NONE
 INTEGER :: N_SAMPLES,N_VARIABLES
 INTEGER :: I,LHSTYPE
 REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(N_SAMPLES,N_VARIABLES) :: X !, Y(N_VARIABLES, N_SAMPLES)
 REAL(KIND=DP_KIND), DIMENSION(N_VARIABLES) :: MEAN ! MEAN VECTOR OF NORMAL DISTRIBUTION
 REAL(KIND=DP_KIND), DIMENSION(N_VARIABLES) :: STD_DEV ! STANDARD DEVIATION VECTOR OF NORMAL DISTRIBUTION
 REAL(KIND=DP_KIND), PARAMETER :: TRUNC_FACTOR = 3.0 ! TRUNCATION FACTOR (NUMBER OF STANDARD DEVIATIONS)
 
! !## initialize random number generator
! CALL SRAND(1234) ! SEED FOR REPRODUCIBILITY
 
 !## uniform
 LHSTYPE=1
 !## (log)normal
 LHSTYPE=2
 
 !## generate latin hypercube samples
 CALL GENERATE_LHS(N_SAMPLES,N_VARIABLES,X,MEAN,STD_DEV,LHSTYPE)
    
 !## output the samples
 DO I = 1, N_SAMPLES
  WRITE(*,'(99F15.7)') X(:, I)
 END DO
    
END SUBROUTINE IPEST_GLM_LATIN_HYPERCUBE_SAMPLING

 !#####=================================================================
 SUBROUTINE SRAND(SEED)
 !#####=================================================================
 IMPLICIT NONE
 INTEGER, INTENT(IN) :: SEED
 INTEGER :: N
 INTEGER,ALLOCATABLE,DIMENSION(:) :: SEED_VALUES
 
 CALL RANDOM_SEED(SIZE = N)
 ALLOCATE(SEED_VALUES(N))
 SEED_VALUES = 0
 SEED_VALUES(1) = SEED
 CALL RANDOM_SEED(PUT = SEED_VALUES)
 DEALLOCATE(SEED_VALUES)
 
 END SUBROUTINE SRAND
    
 !#####=================================================================
 SUBROUTINE GENERATE_LHS(N,N_VARS,SAMPLES,MEAN,STD_DEV,LHSTYPE)
 !#####=================================================================
 INTEGER, INTENT(IN) :: N, N_VARS,LHSTYPE
 REAL(KIND=DP_KIND), INTENT(OUT) :: SAMPLES(N_VARS, N)
 REAL(KIND=DP_KIND), DIMENSION(N_VARS) :: MEAN ! MEAN VECTOR OF NORMAL DISTRIBUTION
 REAL(KIND=DP_KIND), DIMENSION(N_VARS) :: STD_DEV ! STANDARD DEVIATION VECTOR OF NORMAL DISTRIBUTION
 REAL(KIND=DP_KIND) :: DELTA,U,Z
 INTEGER :: I, J
 REAL(KIND=DP_KIND), DIMENSION(:),allocatable :: fractions
 REAL(KIND=DP_KIND), PARAMETER :: TRUNC_FACTOR = 3.0 ! TRUNCATION FACTOR (NUMBER OF STANDARD DEVIATIONS)
        
 DELTA=1.0D0/REAL(N,8)

 ALLOCATE(FRACTIONS(N))  
 !## compute fractions for latin hypercube sampling
 DO I=1,N
  FRACTIONS(I)=DELTA*(I-0.5D0)-0.5D0
 END DO
       
 !## generate lhs samples for each variable
 DO I=1,N_VARS
  DO J=1,N
   DO
    CALL RANDOM_NUMBER(U)
    IF(LHSTYPE.EQ.1)THEN
     Z=MEAN(I)+FRACTIONS(J)*STD_DEV(I)*U
    ELSEIF(LHSTYPE.EQ.2)THEN
     Z=MEAN(I)+FRACTIONS(J)*STD_DEV(I)*PPND(U)
    ENDIF
    ! TRUNCATE THE SAMPLE IF IT FALLS OUTSIDE THE DESIRED RANGE
    IF(ABS(Z-MEAN(I)).LE.TRUNC_FACTOR*STD_DEV(I))THEN
     SAMPLES(I,J)=Z 
     EXIT
    ENDIF
   ENDDO
  END DO
 END DO
        
 DO I=1,N
  PRINT *, SAMPLES(:, I)
 END DO

 !## shuffle the samples for each variable
 DO I=1,N_VARS
  CALL SHUFFLE(SAMPLES(I, :))
 ENDDO

 DO I=1,N
  PRINT *, SAMPLES(:, I)
 ENDDO
 DEALLOCATE(FRACTIONS)
 
 END SUBROUTINE GENERATE_LHS

 !#####=================================================================
 SUBROUTINE SHUFFLE(ARR)
 !#####=================================================================
 IMPLICIT NONE
 REAL(KIND=DP_KIND),INTENT(INOUT),DIMENSION(:) :: ARR
 INTEGER :: I, J
 REAL(KIND=DP_KIND) :: TEMP
     
 DO I = 1, SIZE(ARR)
  J = RANDINT(I, SIZE(ARR))
  TEMP = ARR(I)
  ARR(I) = ARR(J)
  ARR(J) = TEMP
 ENDDO

 END SUBROUTINE SHUFFLE
    
 !#####=================================================================
 REAL(KIND=DP_KIND) FUNCTION RAND()
 !#####=================================================================
 IMPLICIT NONE

 CALL RANDOM_NUMBER(RAND)

 END FUNCTION RAND
    
 !#####=================================================================
 REAL(KIND=DP_KIND) FUNCTION PPND(P)
 !#####=================================================================
 IMPLICIT NONE
!The ppnd function (also known as the Percent Point Function or the Inverse Cumulative Distribution Function) is commonly used to convert uniformly distributed random numbers
!to numbers with a standard normal distribution. It's essentially the inverse of the cumulative distribution function (CDF) of the standard normal distribution.
!The coefficients and the implementation of the ppnd function in the provided Fortran code are based on the well-known algorithm published by Michael Wichura in 1988
!("Algorithm AS 241: The Percentage Points of the Normal Distribution," Applied Statistics, Vol. 37, No. 3, 1988, pp. 477-484). This algorithm provides accurate
!approximations for the inverse of the standard normal cumulative distribution function.
!The coefficients used in the ppnd function are chosen to provide accurate results over the entire range of possible inputs. The algorithm itself is widely used
!and accepted in various programming languages and statistical software packages for generating random numbers from normal distributions.    
 REAL(KIND=DP_KIND), INTENT(IN) :: P
 REAL(KIND=DP_KIND) :: A0, A1, A2, A3, B0, B1, B2, C0, C1, C2, D1, D2, D3
 REAL(KIND=DP_KIND) :: Q, R, RESULT
        
 A0 = 2.50662823884D0
 A1 = -18.61500062529D0
 A2 = 41.39119773534D0
 A3 = -25.44106049637D0
 B0 = -8.47351093090D0
 B1 = 23.08336743743D0
 B2 = -21.06224101826D0
 C0 = 0.3374754822726147D0
 C1 = 0.9761690190917186D0
 C2 = 0.1607979714918209D0
 D1 = 0.0498673470D0
 D2 = 0.0211410061D0
 D3 = 0.0032776263D0
        
 Q = P - 0.5D0
   
 IF (ABS(Q) <= 0.425D0) THEN
  R = 0.180625D0 - Q * Q
  RESULT = Q * (A0 + R * (A1 + R * (A2 + R * A3))) / &
          (1.0 + R * (B0 + R * (B1 + R * (B2))))
 ELSE
  R = SQRT(-LOG(MIN(P, 1.0D0 - P)))
  RESULT = (SIGN(-1.0, Q) * (C0 + R * (C1 + R * C2)) / &
           (1.0D0 + R * (D1 + R * (D2 + R * D3))))
 END IF
        
 PPND = RESULT

 END FUNCTION PPND
    
 !#####=================================================================
 INTEGER FUNCTION RANDINT(LOWER, UPPER)
 !#####=================================================================
 IMPLICIT NONE
 INTEGER, INTENT(IN) :: LOWER, UPPER
 REAL(KIND=DP_KIND) :: RAND

 RANDINT = LOWER + INT(RAND() * (UPPER - LOWER + 1))
 
 END FUNCTION RANDINT

 !#####=================================================================
 LOGICAL FUNCTION IPEST_GLM_RUNMODELS(DIRNAME,IBATCH,RN,RPARAM,RT,DIR,MNAME,ITER,LAMBDA,ILAMBDA)
 !#####=================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN),DIMENSION(:) :: RN
 REAL(KIND=DP_KIND),INTENT(IN) :: LAMBDA
 INTEGER,INTENT(IN),DIMENSION(:) :: RPARAM
 INTEGER,INTENT(IN) :: ITER,IBATCH,ILAMBDA
 CHARACTER(LEN=1),INTENT(IN) :: RT
 CHARACTER(LEN=*),INTENT(IN) :: DIR,MNAME,DIRNAME
 INTEGER :: IGRAD,NDONE,NCPU,IFLAGS,I,T,ET,ST,CLOCK_RATE
 INTEGER,DIMENSION(2) :: IDPROC
 LOGICAL :: LRESTART
 
 IPEST_GLM_RUNMODELS=.FALSE.

 IF(RT.EQ.'L')THEN
  WRITE(IUPESTPROGRESS,'(/A5,4A15,15X,4A15)') 'LS','PARAMETER','LAMBDA','TOT_J','RED_J','GOODNESS FIT','NASH SUTCLIFFE','SIM_TIME(SEC)','PP_TIME(SEC)' 
 ELSEIF(RT.EQ.'P')THEN
  WRITE(IUPESTPROGRESS,'(/A5,5A15,30X,2A15)') 'GD','PARAMETER','FACTOR','TOT_J','RED_J','CUR_PARAMETER','SIM_TIME(SEC)','PP_TIME(SEC)'
  WRITE(IUPESTOUT,'(/A/)') ' *** BEGIN SENSITIVITY CYCLE ***'; WRITE(*,'(/A/)') ' *** BEGIN SENSITIVITY CYCLE ***'
 ELSEIF(RT.EQ.'R')THEN
  WRITE(IUPESTPROGRESS,'(/A5,4A15,15X,4A15)') 'RS','REALIZATION','LAMBDA','TOT_J','RED_J','GOODNESS FIT','NASH SUTCLIFFE','SIM_TIME(SEC)','PP_TIME(SEC)'
  WRITE(IUPESTOUT,'(/A)') ' *** REALIZATION CYCLE '//TRIM(VTOS(ILAMBDA))//' ***'
  WRITE(*,        '(/A)') ' *** REALIZATION CYCLE '//TRIM(VTOS(ILAMBDA))//' ***'
 ENDIF
 
 !## see whether to reuse sensitivities
 LRESTART=.FALSE.
 IF(RT.EQ.'P'.AND.ITER.EQ.1)THEN
  !## reuse sensitivities if not equal to mod(iter,usesens)
  !LRESTART=.FALSE.; IF(MOD(ITER-1,PBMAN%USESENS).NE.0)
  IF(PBMAN%USESENS.EQ.1)LRESTART=.TRUE.
  IF(LRESTART)WRITE(*,'(/A/)') '>>> BE AWARE SENSITIVIES ARE RE-USED <<<'
 ENDIF
 
 CALL WMESSAGETIMER(NCSECS,IREPEAT=1); IGRAD=0; NCPU=0; IPROC=0; ISTATUS=-1; INSENS=0; IF(LRESTART)INSENS=-1
 !## executes lamdba-testing on commandtool such that commands alike 'dir' etc. works
 IFLAGS=PROCCMDPROC; IF(PBMAN%CMDHIDE.EQ.1)IFLAGS=IFLAGS+PROCSILENT

 !## all done initially except the first
 IF(RT.EQ.'L'.AND.ITER.EQ.0)THEN; ISTATUS=1; ISTATUS(1)=-1; ENDIF

 !## exclude parameters that are turned off
 IF(RT.EQ.'P'.AND.PEST%PE_SENS.LT.0.0D0)THEN
  !## determine what model to be ran
  IGRAD=0; DO I=1,SIZE(PEST%PARAM)
   !## associated parameters to existing groups inactive for gradient computation
   IF(ABS(PEST%PARAM(I)%PACT).EQ.1)THEN
    !## flag as done
    IGRAD=IGRAD+1; IF(PEST%PARAM(I)%INSENS.EQ.1)INSENS(IGRAD)=1
   ENDIF
  ENDDO
 ENDIF
 
 !## start the lambda-analyses
 DO 

  !## start processes
  DO
  
   !## find gradient simulation to be (re)carried out
   DO IGRAD=1,SIZE(RN); IF(ISTATUS(IGRAD).EQ.-1)EXIT; ENDDO; IF(IGRAD.GT.SIZE(RN))EXIT
    
   !## number of cpu full
   NCPU=NCPU+1

   !## parameter insensitive, skip simulating this parameter again
   IF(ABS(INSENS(IGRAD)).EQ.1)THEN
    
    IPROC(:,IGRAD)=1; LRESTART=.TRUE.
   
   ELSE
   
    SELECT CASE (RT)
     CASE ('L','P')
      !## adjust alpha for current igrad
      CALL IPEST_GLM_NEXTGRAD(RPARAM(IGRAD),RT,IGRAD)
      !## update arr-files for modflow6/seawat
      IF(PBMAN%IFORMAT.EQ.3.OR.PBMAN%IFORMAT.EQ.6)THEN
       !## update files for this simulation
       CALL IPEST_GLM_SAVE_PARAMETERS(IBATCH,DIR,RPARAM(IGRAD),RT,IGRAD) 
      ELSE
       !## define update in pst file
       IF(.NOT.IPEST_GLM_PST(DIRNAME,DIR,MNAME,IGRAD,RPARAM(IGRAD),RT))THEN
        CALL IPEST_GLM_ERROR(IBATCH,'ERROR CREATED PST1 FILE FOR '//RT//'#'//TRIM(VTOS(RPARAM(IGRAD)))); RETURN
       ENDIF
      ENDIF
    END SELECT
   
    !## wait before starting a new process
    IF(PBMAN%NSWAIT.GT.0)THEN
     WRITE(*,'(/A)') '>>> Wait '//TRIM(VTOS(PBMAN%NSWAIT/100))//' seconds ...'
     CALL SYSTEM_CLOCK(ST)
     !## check residual, if you have to wait anyhow
     NDONE=IPEST_GLM_EVALUATE(IBATCH,ITER,NCPU,DIR,RN,RT,RPARAM,LAMBDA,ILAMBDA,MNAME)
     CALL SYSTEM_CLOCK(ET,CLOCK_RATE)
     T=100*((ET-ST)/CLOCK_RATE)
     WRITE(*,*) ST,ET,T,PBMAN%NSWAIT-T
     T=PBMAN%NSWAIT-T
     !## wait remaining time
     IF(T.GT.0)CALL IOSWAIT(PBMAN%NSWAIT)
     WRITE(*,'(A/)') '    Finished waiting <<<'
    ENDIF
    
    !## clear error
    I=WINFOERROR(1); IDPROC=0

    CALL IOSCOMMAND(TRIM(RN(IGRAD)),IFLAGS=IFLAGS,IDPROC=IDPROC); IPROC(:,IGRAD)=IDPROC
    IF(WINFOERROR(1).EQ.ERROSCOMMAND)THEN
     CALL IPEST_GLM_ERROR(IBATCH,'FAILED TO START MODEL '//RT//'#'//TRIM(VTOS(RPARAM(IGRAD)))); RETURN
    ENDIF
    CALL IPEST_GLM_PROGRESS_NUMBERS(RN,NDONE)
  
   ENDIF

   !## save start time
   CALL SYSTEM_CLOCK(STIME(IGRAD))
   !## started
   ISTATUS(IGRAD)=1

   !## all started
   DO IGRAD=1,SIZE(RN); IF(ISTATUS(IGRAD).EQ.-1)EXIT; ENDDO; IF(IGRAD.GT.SIZE(RN))EXIT
   !## maximum number of cpu reached
   IF(NCPU.GE.PBMAN%NCPU)EXIT

  ENDDO
   
  !## evaluate processes that are finished
  NDONE=IPEST_GLM_EVALUATE(IBATCH,ITER,NCPU,DIR,RN,RT,RPARAM,LAMBDA,ILAMBDA,MNAME)
  !## finished if all succesfully completed
  IF(NDONE.EQ.SIZE(RN))EXIT
  !## first iteration only need a single run
  IF(RT.EQ.'L'.AND.ITER.EQ.0.AND.ISTATUS(1).EQ.0)EXIT
 ENDDO
  
 IF(RT.EQ.'L')THEN
  IF(ITER.NE.0)THEN
   WRITE(IUPESTOUT,'(/A/)') ' *** END LAMBDA CYCLE ***'; WRITE(*,'(/A/)') ' *** END LAMBDA CYCLE ***'
  ENDIF
 ELSEIF(RT.EQ.'P')THEN
  WRITE(IUPESTOUT,'(/A)') ' *** END SENSITIVITY CYCLE ***'; WRITE(*,'(/A/)') ' *** END SENSITIVITY CYCLE ***'
 ELSEIF(RT.EQ.'R')THEN
  WRITE(IUPESTOUT,'(A/)') ' *** END REALIZATION CYCLE '//TRIM(VTOS(ILAMBDA))//' ***'
  WRITE(*,        '(A/)') ' *** END REALIZATION CYCLE '//TRIM(VTOS(ILAMBDA))//' ***'
 ENDIF

 IPEST_GLM_RUNMODELS=.TRUE.
 
 END FUNCTION IPEST_GLM_RUNMODELS
 
 !###====================================================================
 SUBROUTINE IPEST_GLM_PROGRESS_NUMBERS(RN,NDONE)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN),DIMENSION(:) :: RN
 INTEGER,INTENT(OUT) :: NDONE
 INTEGER :: IGRAD,NBUSY
 REAL(KIND=DP_KIND) :: F
 
 !## how much done?
 NDONE=0; NBUSY=0
 DO IGRAD=1,SIZE(RN)
  IF(ISTATUS(IGRAD).EQ.0)NDONE=NDONE+1
  IF(ISTATUS(IGRAD).EQ.1)NBUSY=NBUSY+1
 ENDDO
 F=DBLE(NDONE)*100.0D0/DBLE(SIZE(RN))
 WRITE(6,'(A)') '+Still running '//TRIM(VTOS(NBUSY))//' models; completed: '//TRIM(VTOS(F,'F',2))//'% (total '// &
      TRIM(VTOS(NDONE))//' out of '//TRIM(VTOS(SIZE(RN)))//' simulations completed)'

 END SUBROUTINE IPEST_GLM_PROGRESS_NUMBERS

 !###====================================================================
 SUBROUTINE IPEST_GLM_QR(IBATCH,DIR) 
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER,INTENT(IN) :: IBATCH
 INTEGER :: I,J,N,ILS,NILS
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: IQR
 
 IF(PEST%PE_REGULARISATION.EQ.0)RETURN
 
 !## construct weight matrix for all parameters (except the grouped ones) including constant ones
 !## process parameter values
 N=0; DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PIGROUP.GT.0)N=N+1
 ENDDO

 IF(ALLOCATED(QR))DEALLOCATE(QR); ALLOCATE(QR(N,N)); QR=0.0D0
 IF(ALLOCATED(QO))DEALLOCATE(QO); ALLOCATE(QO(N,N)); QO=0.0D0

 !## process parameter values for zones
 N=0; DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE
  N=N+1
  !## compute weights
  IF(PEST%PARAM(I)%ZTYPE.EQ.0)THEN
   !## weight is sqrt(1/2*quadratic(std)) = 1/variance
   QR(N,N)=SQRT(1.0D0/(2.0D0*PEST%PARAM(I)%PARSTD**2.0D0))
   QO(N,N)=1.0D0
  ENDIF
 ENDDO
 
 !## process parameter values for pilot points
 DO I=1,SIZE(PARAM)
  !## how many systems
  NILS=0; DO J=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(J)%PIGROUP.LE.0.OR.PEST%PARAM(J)%ZTYPE.EQ.0.OR.PEST%PARAM(J)%PPARAM.NE.PARAM(I))CYCLE
   NILS=MAX(NILS,PEST%PARAM(J)%PILS)
  ENDDO
  IF(NILS.EQ.0)CYCLE
  !## save variance of kriging in combination with scaled residuals - check all parameters
  DO ILS=1,NILS
   DO J=1,SIZE(PEST%PARAM)
    IF(PEST%PARAM(J)%ZTYPE.NE.1)CYCLE
    IF(PEST%PARAM(J)%PIGROUP.LE.0.OR.PEST%PARAM(J)%ZTYPE.EQ.0.OR. &
       PEST%PARAM(J)%PPARAM.NE.PARAM(I).OR.PEST%PARAM(J)%PILS.NE.ILS)CYCLE
    !## add if needed pilot point interpolation - also save variance, which is independent of interpolation values
    !## need to be scale by the error for the effective variance - later
    IF(.NOT.IPEST_GLM_COMPUTE_PILOTPOINTS(PEST%PARAM(J)%PPARAM,PEST%PARAM(J)%PILS,IBATCH,1,DIR))THEN
     WRITE(*,'(/A/)') '>>> STOPPED COMPUTING PARAMETER WEIGHTS <<<'; PAUSE; STOP 
    ENDIF
    EXIT
   ENDDO
  ENDDO
 ENDDO
 
 !## compute square root of the inverse
 ALLOCATE(IQR(N,N))
 CALL LUDCMP_CALC_SQRTROOTINVERSE(N,QR,ISQRTCOV=IQR)
 QR=IQR
 DEALLOCATE(IQR)
 
 !## parameter operator for homogenization is zero at parameter itself
 IF(PEST%PE_REGULARISATION.EQ.1)THEN
  DO I=1,N; QO(I,I)=0.0D0; ENDDO
 !## preferred parameter
 ELSEIF(PEST%PE_REGULARISATION.EQ.2)THEN
  QO=0.0D0 
  DO I=1,N; QO(I,I)=1.0D0; ENDDO
 ENDIF
 
 IF(N.LT.50)THEN
  WRITE(IUPESTOUT,'(/A/)') 'QR'
  DO I=1,N; WRITE(IUPESTOUT,'(99F15.7)') (QR(I,J),J=1,N); ENDDO
  WRITE(IUPESTOUT,'(/A/)') 'QO'
  DO I=1,N; WRITE(IUPESTOUT,'(99F15.7)') (QO(I,J),J=1,N); ENDDO
  FLUSH(IUPESTOUT)
 ENDIF
 
 END SUBROUTINE IPEST_GLM_QR
 
 !###====================================================================
 INTEGER FUNCTION IPEST_GLM_EVALUATE(IBATCH,ITER,NCPU,DIR,RN,RT,RPARAM,LAMBDA,ILAMBDA,MNAME)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IBATCH,ITER,ILAMBDA
 INTEGER,INTENT(IN),DIMENSION(:) :: RPARAM
 INTEGER,INTENT(INOUT) :: NCPU
 REAL(KIND=DP_KIND),INTENT(IN) :: LAMBDA
 CHARACTER(LEN=*),INTENT(IN),DIMENSION(:) :: RN
 CHARACTER(LEN=*),INTENT(IN) :: DIR,RT,MNAME
 INTEGER :: ITYPE,N,JGRAD,IEXCOD !,IW
 TYPE(WIN_MESSAGE) :: MESSAGE
 INTEGER,DIMENSION(2) :: IDPROC
 INTEGER :: ILIN,NDONE
 
 IPEST_GLM_EVALUATE=0

 CALL IPEST_GLM_PROGRESS_NUMBERS(RN,NDONE)

 ILIN=0
 
 DO
  CALL WMESSAGE(ITYPE,MESSAGE)
  !## timer expired
  IF(ITYPE.EQ.TIMEREXPIRED)THEN

   N=0; DO JGRAD=1,SIZE(RN) 
    !## all handled process
    IF(IPROC(1,JGRAD)+IPROC(2,JGRAD).EQ.0)CYCLE
    !## insensitive
    IF(ABS(INSENS(JGRAD)).EQ.1)THEN 
     ISTATUS(JGRAD)=0; IEXCOD=0
    !## sensitive
    ELSE
     !## check running status
     IDPROC=IPROC(:,JGRAD)
     CALL IOSCOMMANDCHECK(IDPROC,ISTATUS(JGRAD),IEXCOD=IEXCOD)
    ENDIF
    !## stopped running
    IF(ISTATUS(JGRAD).EQ.0)THEN
     !## save end time
     CALL SYSTEM_CLOCK(ETIME(JGRAD))
     !## error occured 
     IF(IEXCOD.NE.0)THEN
      CALL IPEST_GLM_ERROR(IBATCH,'ERROR OCCURED RUNNING MODEL '//RT//'#'//TRIM(VTOS(RPARAM(JGRAD)))//'; Error code '//TRIM(VTOS(IEXCOD)))
      !## question to continue?
      IF(.NOT.UTL_CONTINUE('Inspect model '//TRIM(RN(JGRAD))//'; something went wrong in the SIMULATION; Error code '//TRIM(VTOS(IEXCOD))))STOP
      !## try again - need to run again
      ISTATUS(JGRAD)=-1
     ENDIF
     !## set part of objective function
     IF(ISTATUS(JGRAD).EQ.0)THEN
      !## check run
      IF(.NOT.IPEST_GLM_CHECKRUN(DIR,MNAME,RT,RPARAM(JGRAD)))THEN
       CALL IPEST_GLM_ERROR(IBATCH,'WARNING, AN ERROR OCCURED EXAMINING THE LIST FILE FOR MODEL '//RT//'#'//TRIM(VTOS(RPARAM(JGRAD)))//' IMOD KEEPS TRYING AGAIN')
       IF(.NOT.UTL_CONTINUE('Inspect model '//TRIM(RN(JGRAD))//'; something went wrong in the LIST EXAMINING'))STOP
       !## try again - need to run again
       ISTATUS(JGRAD)=-1
      ENDIF
      IF(ISTATUS(JGRAD).EQ.0)THEN
       !## save start time
       CALL SYSTEM_CLOCK(STIMEJ(JGRAD))
       IF(INSENS(JGRAD).EQ.0)THEN
        IF(.NOT.IPEST_GLM_GETJ_AVG(DIR,JGRAD,RPARAM(JGRAD),RT,IBATCH,ILAMBDA,MNAME))THEN
         !## question to continue?  --- causes by MF6 that cannot write obs.txt file
         CALL IPEST_GLM_ERROR(IBATCH,'WARNING, AN ERROR OCCURED COLLECTING RESIDUALS FOR MODEL '//RT//'#'//TRIM(VTOS(RPARAM(JGRAD)))//' IMOD KEEPS TRYING AGAIN')
         IF(.NOT.UTL_CONTINUE('Inspect model '//TRIM(RN(JGRAD))//'; something went wrong in the RESIDUAL COMPUTATION'))STOP
         !## try again - need to run again
         ISTATUS(JGRAD)=-1
        ENDIF
!        IF(PBMAN%IPESTMETHOD.EQ.3)CALL IPEST_GLM_FILL_JACOBIAN()
        IF(MSR%NOBS.GT.0)THEN
         IF(RT.EQ.'L'.OR.RT.EQ.'R')THEN
          MSR%DHL_J(JGRAD)=MSR%TJ
          MSR%GOF(JGRAD)=UTL_GOODNESS_OF_FIT(GF_H,GF_O,MSR%NOBS)
          MSR%NSC(JGRAD)=UTL_NASH_SUTCLIFFE(GF_H,GF_O,MSR%NOBS)
         ELSEIF(RT.EQ.'P')THEN
          MSR%DHG_J(JGRAD)=MSR%TJ
          MSR%DPG_J(JGRAD)=MSR%RJ
         ENDIF
        ENDIF!### insensitive set equal to reference head
       ELSE
        IF(MSR%NOBS.GT.0)MSR%HG(JGRAD,:)=MSR%HL(0,:) 
       ENDIF
      ENDIF
      !## save end time
      CALL SYSTEM_CLOCK(ETIMEJ(JGRAD))
      !## write echo
      CALL IPEST_GLM_PROGRESS(ITER,JGRAD,RPARAM(JGRAD),RT,LAMBDA); IF(IUPESTPROGRESS.GT.0)FLUSH(IUPESTPROGRESS)
     ENDIF
     !## reset running handle proces
     IPROC(:,JGRAD)=0
     !## release cpu so another can be started
     NCPU=NCPU-1
     !## finished, quit this loop, and try to restart a new new
     EXIT
    ENDIF

   ENDDO   

   CALL IPEST_GLM_PROGRESS_NUMBERS(RN,NDONE)

   !## start another one as a proces has been stopped and there might be still one waiting in the que
   IF(NCPU.LT.PBMAN%NCPU)EXIT 

  ENDIF
 ENDDO
! write(*,*) 'see whether to start another one'
 
 IPEST_GLM_EVALUATE=NDONE
 
 END FUNCTION IPEST_GLM_EVALUATE
 
 !###======================================================================
 LOGICAL FUNCTION IPEST_GLM_CHECKRUN(DIR,MNAME,CTYPE,IPARAM)
 !###======================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR,CTYPE,MNAME
 INTEGER,INTENT(IN) :: IPARAM
 INTEGER :: I,J,IU,IOS,N
 CHARACTER(LEN=256) :: FNAME,DIRO,LINE
 INTEGER,ALLOCATABLE,DIMENSION(:) :: ITER
 REAL(KIND=DP_KIND) :: QS
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: QPERC
 
 IPEST_GLM_CHECKRUN=.FALSE.
 
 ALLOCATE(ITER(PRJNPER),QPERC(PRJNPER))
 
 IF(PBMAN%IFORMAT.EQ.2)THEN
  DIRO=DIR; IF(PBMAN%OUTPUT.NE.'')DIRO=PBMAN%OUTPUT

  FNAME=TRIM(DIRO)//'\'//TRIM(MNAME)//'_'//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM))//'.LIST'
  WRITE(*,'(A)') 'Checking LIST-file='//TRIM(FNAME)

  !## check whether converged 
  IU=UTL_GETUNIT(); OPEN(IU,FILE=FNAME,STATUS='OLD',FORM='FORMATTED',ACTION='READ',IOSTAT=IOS)
  IF(IOS.EQ.0)THEN
   N=0; DO
    READ(IU,'(A256)',IOSTAT=IOS) LINE
    IF(IOS.NE.0)EXIT
    IF(INDEX(LINE,'TOTAL ITERATIONS').GT.0)THEN
     N=N+1
     READ(LINE,*,IOSTAT=IOS) ITER(N)
     IF(IOS.NE.0)THEN
      WRITE(*,'(/A)') '>>> ERROR READING TOTAL ITERATIONS'
      WRITE(*,'(A/)') TRIM(LINE)//' <<<'
      RETURN
     ENDIF
    ENDIF
    IF(INDEX(LINE,'PERCENT DISCREPANCY').GT.0.AND.INDEX(LINE,'PERCENT DISCREPANCY IS').EQ.0)THEN
     READ(LINE,'(63X,F15.2)',IOSTAT=IOS) QPERC(N); QPERC(N)=ABS(QPERC(N))
     IF(IOS.NE.0)THEN
      WRITE(*,'(/A)') '>>> ERROR READING PERCENT DISCREPANCY'
      WRITE(*,'(A/)') TRIM(LINE)//' <<<'
      RETURN
     ENDIF
    ENDIF
    IF(INDEX(LINE,'FAILURE TO MEET SOLVER CONVERGENCE CRITERIA').GT.0)THEN
     ITER(N)=-1*ITER(N)
    ENDIF
   ENDDO
   CLOSE(IU)
   !## something went wrong
   IF(N.NE.PRJNPER)THEN
    WRITE(*,'(/A)') '>>> ERROR READING ALL TIME STEPS IN'
    WRITE(*,'(A/)') TRIM(FNAME)//' <<<'
    RETURN
   ENDIF

   !## check failure
   DO I=1,N; IF(ITER(I).LE.0)EXIT; ENDDO
   IF(I.LE.N)THEN
    QS=0.0D0; J=0; DO I=1,N
     WRITE(*,'(2I10,F15.2)') I,ITER(I),QPERC(I)
     IF(ITER(I).LE.0)THEN
      J=J+1
     ELSE
      QS=QS+QPERC(I)
     ENDIF
    ENDDO
    WRITE(*,'(/A)') '>>> FAILED TO CONVERGE FOR '//TRIM(VTOS(J))//' TIME STEPS IN'
    WRITE(*,'(A/)') TRIM(FNAME)//' <<<'
    QS=QS/REAL(N-J,8)
   
    !## thresshold 10 times average budget error
    QS=10.0D0*QS
   
    J=0; DO I=1,N
     IF(ITER(I).LE.0)THEN
      IF(QPERC(I).GT.QS)J=J+1
     ENDIF
    ENDDO
    IF(J.EQ.0)THEN
     WRITE(*,'(/A)') '>>> CONTINUING AS BUDGET ERROR OF FAILED MODEL IS LESS/EQUAL THE AVERAGE BUDGET ERROR OF '//TRIM(VTOS(QS,'F',2))//' % <<<'
    ELSE
     WRITE(*,'(/A)') '>>> PROCESS PAUSED AS BUDGET ERROR OF FAILED MODEL IS GREATER THAN 10 TIMES AVERAGE BUDGET ERROR OF '//TRIM(VTOS(QS,'F',2))//' %'
     WRITE(*,'(A/)') '    CLICK KEYBOARD TO CONTINUE OR CRTL-DEL TO STOP'
     PAUSE !; STOP
    ENDIF
   ENDIF
  ELSE
   WRITE(*,'(/A)') 'Cannot inspect lst-file '//TRIM(FNAME)
   WRITE(*,'(A/)') 'iMOD assumes it is okay, fingers crossed!'
  ENDIF
 ENDIF
 
 DEALLOCATE(ITER,QPERC)
 
 IPEST_GLM_CHECKRUN=.TRUE.

 END FUNCTION IPEST_GLM_CHECKRUN

 !###====================================================================
 SUBROUTINE IPEST_GLM_ERROR(IBATCH,TXT)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IBATCH
 CHARACTER(LEN=*),INTENT(IN) :: TXT
 
 IF(IBATCH.EQ.1)WRITE(*,'(/A/)') TRIM(TXT)
 IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,TRIM(TXT),'Error')
 WRITE(IUPESTOUT,'(/A/)') TRIM(TXT)
 
 END SUBROUTINE IPEST_GLM_ERROR

 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_CHK(IP,IBATCH)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IP,IBATCH
 INTEGER :: I,N
 REAL(KIND=DP_KIND) :: K1,K2
 
 IPEST_GLM_CHK=.FALSE.
 
 DO I=1,SIZE(PARAM)
  PEST%PARAM(IP)%PPARAM=UTL_CAP(PEST%PARAM(IP)%PPARAM,'U')
  IF(TRIM(PEST%PARAM(IP)%PPARAM).EQ.TRIM(PARAM(I)))EXIT
 ENDDO
 IF(I.GT.SIZE(PARAM))THEN
  IF(IBATCH.EQ.1)THEN
   WRITE(*,'(/A)') 'Error can not recognize parameter type:'//TRIM(PEST%PARAM(IP)%PPARAM)
   WRITE(*,'(/A)') ' Choose from:'
   DO I=1,SIZE(PARAM); WRITE(*,'(A)') ' - '//TRIM(PARAM(I)); ENDDO
   WRITE(*,'(A)')
  ELSEIF(IBATCH.EQ.0)THEN
   CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error can not recognize parameter type:'//TRIM(PEST%PARAM(IP)%PPARAM),'Error')
  ENDIF
  RETURN
 ENDIF

 IF(PEST%PARAM(IP)%PMIN.GE.PEST%PARAM(IP)%PMAX)THEN
  IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'No proper parameter width defined for parameter '//TRIM(VTOS(IP))
  IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No proper parameter width defined for parameter '//TRIM(VTOS(IP)),'Error')
  RETURN
 ENDIF

 !## estimate variance of parameter
 IF(PEST%PARAM(IP)%PARSTD.EQ.0.0D0)THEN
  IF(PEST%PARAM(IP)%PLOG.EQ.1)THEN
   K1=LOG(ABS(PEST%PARAM(IP)%PMIN))
   K2=LOG(ABS(PEST%PARAM(IP)%PMAX))
  ELSEIF(PEST%PARAM(IP)%PLOG.EQ.2)THEN
   K1=LOG10(ABS(PEST%PARAM(IP)%PMIN))
   K2=LOG10(ABS(PEST%PARAM(IP)%PMAX))
  ELSE
   K1=PEST%PARAM(IP)%PMIN
   K2=PEST%PARAM(IP)%PMAX
  ENDIF
  PEST%PARAM(IP)%PARSTD=(K2-K1)/4.0D0
 ENDIF
 
 IF(PEST%PARAM(IP)%PINI.LT.PEST%PARAM(IP)%PMIN.OR.PEST%PARAM(IP)%PINI.GT.PEST%PARAM(IP)%PMAX)THEN
  IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'Parameter '//TRIM(VTOS(IP))//' outside parameter width'
  IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Parameter '//TRIM(VTOS(IP))//' outside parameter width','Error')
  RETURN
 ENDIF
 SELECT CASE (TRIM(PEST%PARAM(IP)%PPARAM))
  CASE ('KD','KH','SC','AF','VA','SY')
   IF(PEST%PARAM(IP)%PILS.LE.0.OR.PEST%PARAM(IP)%PILS.GT.PRJNLAY)THEN
    IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'Parameter '//TRIM(VTOS(IP))//': ILS exceeds NLAY'
    IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Parameter '//TRIM(VTOS(IP))//': ILS exceeds NLAY','Error')
    RETURN
   ENDIF
  CASE ('VC','KV')
   IF(PEST%PARAM(IP)%PILS.LE.0.OR.PEST%PARAM(IP)%PILS.GT.PRJNLAY-1)THEN
    IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'Parameter '//TRIM(VTOS(IP))//': ILS exceeds NLAY-1'
    IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Parameter '//TRIM(VTOS(IP))//': ILS exceeds NLAY-1','Error')
    RETURN
   ENDIF
  CASE ('EP','RE')
   IF(PEST%PARAM(IP)%PILS.NE.1)THEN
    IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'Parameter '//TRIM(VTOS(IP))//': ILS need to be equal to 1'
    IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Parameter '//TRIM(VTOS(IP))//': ILS need to be equal to 1','Error')
    RETURN
   ENDIF
 END SELECT

 !## scaling
 IF(PEST%PARAM(IP)%PLOG.GT.0)THEN
  IF(PEST%PARAM(IP)%PDELTA.EQ.1.0D0)WRITE(*,'(/A/)') 'You can not specify delta alpha eq 1.0'
  IF(PEST%PARAM(IP)%PMIN  .EQ.0.0D0)WRITE(*,'(/A/)') 'You can not specify minimal value eq 0.0 for log-transformed parameters'
  IF(PEST%PARAM(IP)%PLOG.EQ.1)THEN
   PEST%PARAM(IP)%PINI  =LOG(PEST%PARAM(IP)%PINI)
   PEST%PARAM(IP)%PMIN  =LOG(PEST%PARAM(IP)%PMIN)
   PEST%PARAM(IP)%PMAX  =LOG(PEST%PARAM(IP)%PMAX)
   PEST%PARAM(IP)%PDELTA=LOG(PEST%PARAM(IP)%PDELTA)
   PEST%PARAM(IP)%PPRIOR=LOG(PEST%PARAM(IP)%PPRIOR)
  ELSEIF(PEST%PARAM(IP)%PLOG.EQ.2)THEN
   PEST%PARAM(IP)%PINI  =LOG10(PEST%PARAM(IP)%PINI)
   PEST%PARAM(IP)%PMIN  =LOG10(PEST%PARAM(IP)%PMIN)
   PEST%PARAM(IP)%PMAX  =LOG10(PEST%PARAM(IP)%PMAX)
   PEST%PARAM(IP)%PDELTA=LOG10(PEST%PARAM(IP)%PDELTA)
   PEST%PARAM(IP)%PPRIOR=LOG10(PEST%PARAM(IP)%PPRIOR)
  ENDIF
 ENDIF
 PEST%PARAM(IP)%ALPHA(1)=PEST%PARAM(IP)%PINI !## current  alpha
 PEST%PARAM(IP)%ALPHA(2)=PEST%PARAM(IP)%PINI !## previous alpha
 ALLOCATE(PEST%PARAM(IP)%ALPHA_HISTORY(0:ABS(PEST%PE_MXITER))); PEST%PARAM(IP)%ALPHA_HISTORY=0.0D0
 
 !## allocate memory for running the models
 N=0 ; DO I=1,SIZE(PEST%PARAM)
  !## associated parameters to existing groups inactive for gradient computation
  IF(PEST%PARAM(I)%PACT.EQ.1)N=N+1
 ENDDO
 SELECT CASE (PBMAN%IPESTMETHOD)
  CASE (1); ALLOCATE(PEST%PARAM(IP)%GALPHA(N))
  CASE (2); ALLOCATE(PEST%PARAM(IP)%GALPHA(N*2))
  CASE (3); ALLOCATE(PEST%PARAM(IP)%GALPHA(N))
 END SELECT
 PEST%PARAM(IP)%GALPHA=0.0D0
 
 !## set initial lalpha to initial value
 N=PBMAN%NLAMBDASEARCH; ALLOCATE(PEST%PARAM(IP)%LALPHA(N)); PEST%PARAM(IP)%LALPHA=PEST%PARAM(IP)%ALPHA(1) 
 
 !## fill in default acronym
 IF(PEST%PARAM(IP)%ACRONYM.EQ.'')THEN
  WRITE(PEST%PARAM(IP)%ACRONYM,'(A2,2I5.5,I3.3)') PEST%PARAM(IP)%PPARAM,PEST%PARAM(IP)%PILS,PEST%PARAM(IP)%PIZONE,ABS(PEST%PARAM(IP)%PIGROUP)
 ENDIF

 PEST%PARAM(IP)%ACRONYM=ADJUSTR(PEST%PARAM(IP)%ACRONYM)
  
 !## final check, check whether the optimized parameter is part of the model
 SELECT CASE (PEST%PARAM(IP)%PPARAM)
  CASE ('KD'); IF(TOPICS(TKDW)%IACT_MODEL.EQ.0)STOP 'PARAMETER KD CANNOT BE OPTIMIZED AS KDW IS NOT PRESENT'
  CASE ('KH'); IF(TOPICS(TKHV)%IACT_MODEL.EQ.0)STOP 'PARAMETER KH CANNOT BE OPTIMIZED AS KHV IS NOT PRESENT'
  CASE ('KV'); IF(TOPICS(TKVV)%IACT_MODEL.EQ.0)STOP 'PARAMETER KV CANNOT BE OPTIMIZED AS KVV IS NOT PRESENT'
  CASE ('SC'); IF(TOPICS(TSTO)%IACT_MODEL.EQ.0)STOP 'PARAMETER SC CANNOT BE OPTIMIZED AS STO IS NOT PRESENT'
  CASE ('SY'); IF(TOPICS(TKHV)%IACT_MODEL.EQ.0)STOP 'PARAMETER SY CANNOT BE OPTIMIZED AS SPY IS NOT PRESENT'
  CASE ('VA'); IF(TOPICS(TKVA)%IACT_MODEL.EQ.0)STOP 'PARAMETER VA CANNOT BE OPTIMIZED AS KVA IS NOT PRESENT'
 END SELECT
 
 IPEST_GLM_CHK=.TRUE.

 END FUNCTION IPEST_GLM_CHK
 
 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_READ_ZONES_OPENFILE(DIR,JU,NCOL,NROW)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER,INTENT(OUT) :: JU,NROW,NCOL
 INTEGER :: N,IOS
 
 IPEST_GLM_READ_ZONES_OPENFILE=.FALSE.
 
 JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(DIR)//'\PARAM_DUMP_IPEST_IMOD.DAT',STATUS='OLD',ACTION='READ',FORM='FORMATTED')
 READ(JU,*)
 READ(JU,*)
 READ(JU,'(22X,I10)',IOSTAT=IOS) NCOL
 READ(JU,'(22X,I10)',IOSTAT=IOS) NROW
 READ(JU,'(22X,I10)',IOSTAT=IOS) N
 IF(IOS.NE.0)THEN
  CLOSE(JU); WRITE(*,'(/A)') 'OOPS, AN OLD VERSION OF A PARAM_DUMP_IPEST_IMOD FOUND, NEED TO BE RECREATED'; RETURN
 ENDIF
 IF(N.NE.SIZE(PEST%PARAM))THEN
  CLOSE(JU); WRITE(*,'(/A)') 'NUMBER OF ZONES IN THE PARAM_DUMP_IPEST_IMOD DOES NOT COINCIDE WITH THE ACTUAL NUMBER OF PARAMETERS'; RETURN
 ENDIF
 
 IPEST_GLM_READ_ZONES_OPENFILE=.TRUE.
 
 END FUNCTION  IPEST_GLM_READ_ZONES_OPENFILE

 !###====================================================================
 SUBROUTINE IPEST_GLM_READ_ZONES(DIR,NCOL,NROW)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER,INTENT(OUT) :: NCOL,NROW
 INTEGER :: JU,I,J,N,IROW,ICOL
 
 IF(.NOT.IPEST_GLM_READ_ZONES_OPENFILE(DIR,JU,NCOL,NROW))STOP
 
 DO I=1,SIZE(PEST%PARAM)
  READ(JU,*)
  READ(JU,*)
  READ(JU,'(2I10)') PEST%PARAM(I)%NODES,PEST%PARAM(I)%ZTYPE
  IF(PEST%PARAM(I)%ZTYPE.EQ.0)THEN
   ALLOCATE(PEST%PARAM(I)%IROW(PEST%PARAM(I)%NODES), &
            PEST%PARAM(I)%ICOL(PEST%PARAM(I)%NODES), &
            PEST%PARAM(I)%F(   PEST%PARAM(I)%NODES))
   READ(JU,*)
   DO J=1,PEST%PARAM(I)%NODES
    READ(JU,'(2I10,F10.4)') PEST%PARAM(I)%IROW(J),PEST%PARAM(I)%ICOL(J),PEST%PARAM(I)%F(J)
   ENDDO
  ELSE
   ALLOCATE(PEST%PARAM(I)%XY(PEST%PARAM(I)%NODES,2))
   READ(JU,*)
   N=0; DO J=1,PEST%PARAM(I)%NODES
    READ(JU,*) PEST%PARAM(I)%XY(J,1),PEST%PARAM(I)%XY(J,2)
    CALL IDFIROWICOL(PRJIDF,IROW,ICOL,PEST%PARAM(I)%XY(J,1),PEST%PARAM(I)%XY(J,2))
    IF(IROW.EQ.0.OR.ICOL.EQ.0)N=N+1
   ENDDO
   !## if not in current model, turn them off but they remain active for kriging interpolation
   IF(N.NE.0)THEN
    PEST%PARAM(I)%PACT=0
    PEST%PARAM(I)%NODES=0
    PEST%PARAM(I)%PIGROUP=0
   ENDIF
  ENDIF
!  IF(PEST%PARAM(I)%PPARAM.EQ.'HF')THEN
!   PEST%PARAM(I)%NODES=0 !## one single cell used as zone for horizontal barrier module
!  ELSE
  IF(PEST%PARAM(I)%NODES.EQ.0)PEST%PARAM(I)%PACT=0
!  ENDIF
 
 ENDDO
 CLOSE(JU)  
  
 END SUBROUTINE IPEST_GLM_READ_ZONES
 
 !###====================================================================
 SUBROUTINE IPEST_GLM_RESET_PARAMETER(DIR)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER :: I
 LOGICAL :: LEX
 
 !## scaling
 WRITE(*,*) '>>> Cleaning for '//TRIM(VTOS(SIZE(PEST%PARAM)))//' parameters ...'
 DO I=1,SIZE(PEST%PARAM)
  PEST%PARAM(I)%PACT=ABS(PEST%PARAM(I)%PACT)
  IF(PEST%PARAM(I)%PLOG.EQ.1)THEN
   PEST%PARAM(I)%PINI  =EXP(PEST%PARAM(I)%PINI)
   PEST%PARAM(I)%PMIN  =EXP(PEST%PARAM(I)%PMIN)
   PEST%PARAM(I)%PMAX  =EXP(PEST%PARAM(I)%PMAX)
   PEST%PARAM(I)%PDELTA=EXP(PEST%PARAM(I)%PDELTA)
   PEST%PARAM(I)%PPRIOR=EXP(PEST%PARAM(I)%PPRIOR)
  ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
   PEST%PARAM(I)%PINI  =10.0D0**(PEST%PARAM(I)%PINI)
   PEST%PARAM(I)%PMIN  =10.0D0**(PEST%PARAM(I)%PMIN)
   PEST%PARAM(I)%PMAX  =10.0D0**(PEST%PARAM(I)%PMAX)
   PEST%PARAM(I)%PDELTA=10.0D0**(PEST%PARAM(I)%PDELTA)
   PEST%PARAM(I)%PPRIOR=10.0D0**(PEST%PARAM(I)%PPRIOR)
  ENDIF
  IF(PBMAN%ICLEAN.EQ.1)THEN
   IF(ABS(PEST%PARAM(I)%PACT).EQ.1.AND.PEST%PARAM(I)%PIGROUP.GT.0)THEN
    INQUIRE(DIRECTORY=TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(I)),EXIST=LEX)
    WRITE(*,'(A)') '    - '//TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(I))
    IF(LEX)THEN
     IF(.NOT.UTL_DEL1TREE(TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(I)),IQUESTION=0))THEN
      WRITE(*,'(/A)') '>>> Could not delete folder:'
      WRITE(*,'(A/)') '   '//TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(I))
     ENDIF
    ENDIF
   ENDIF
  ENDIF
 ENDDO
 WRITE(*,*) '     Finished <<<'
 
 WRITE(*,*) '     Finished <<<'
  
 END SUBROUTINE IPEST_GLM_RESET_PARAMETER
 
 !###====================================================================
 SUBROUTINE IPEST_GLM_CLOSE_FILES()
 !###====================================================================
 IMPLICIT NONE

 ! return
 WRITE(*,*) 'Closing files'
 !return

! WRITE(*,*) IUPESTOUT
 IF(IUPESTOUT.GT.0)        CLOSE(IUPESTOUT);         IUPESTOUT=0
! WRITE(*,*) IUPESTPROGRESS
 IF(IUPESTPROGRESS.GT.0)   CLOSE(IUPESTPROGRESS);    IUPESTPROGRESS=0
! WRITE(*,*) IUPESTEFFICIENCY
 IF(IUPESTEFFICIENCY.GT.0) CLOSE(IUPESTEFFICIENCY);  IUPESTEFFICIENCY=0
! WRITE(*,*) IUPESTSENSITIVITY
 IF(IUPESTSENSITIVITY.GT.0)CLOSE(IUPESTSENSITIVITY); IUPESTSENSITIVITY=0
! WRITE(*,*) IUPESTRUNFILE
 IF(IUPESTRUNFILE.GT.0)    CLOSE(IUPESTRUNFILE);     IUPESTRUNFILE=0
! WRITE(*,*) IUPESTJACOBIAN
 IF(IUPESTJACOBIAN.GT.0)   CLOSE(IUPESTJACOBIAN);    IUPESTJACOBIAN=0
 
 END SUBROUTINE IPEST_GLM_CLOSE_FILES
 
 !###====================================================================
 SUBROUTINE IPEST_GLM_ECHO_PARAMETERS(IP)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IP
 INTEGER :: I
 CHARACTER(LEN=12) :: STRING
 
 IF(PBMAN%IPESTP.EQ.1)THEN
  STRING=TRIM(VTOS(PEST%PARAM(IP)%NODES))
 ELSE
  STRING='REPLACE'
 ENDIF
 
 I=PEST%PARAM(IP)%ORG_PACT
 !## parameter off in resulting run-file
 IF(PEST%PE_SENS.LT.0.0D0.AND.PEST%PARAM(IP)%INSENS.EQ.1)I=0

 IF(PEST%PARAM(IP)%PLOG.EQ.0)THEN
  WRITE(IUPESTOUT,'(I2,1X,A5,1X,I5,1X,I7,5(1X,F15.3),I10,I10,A10,A15,2F15.3,2A15,F15.3)') I,PEST%PARAM(IP)%PPARAM,PEST%PARAM(IP)%PILS, &
     PEST%PARAM(IP)%PIZONE,PEST%PARAM(IP)%PINI,PEST%PARAM(IP)%PDELTA,PEST%PARAM(IP)%PMIN,PEST%PARAM(IP)%PMAX,PEST%PARAM(IP)%PINCREASE, &
     ABS(PEST%PARAM(IP)%PIGROUP),PEST%PARAM(IP)%PLOG,TRIM(STRING),PEST%PARAM(IP)%ACRONYM,PEST%PARAM(IP)%PPRIOR,PEST%PARAM(IP)%PARSTD, &
     PEST%PARAM(IP)%SDATE,PEST%PARAM(IP)%EDATE,PEST%PARAM(IP)%PORG
  PEST%PARAM(IP)%ALPHA_HISTORY(0)=PEST%PARAM(IP)%PINI
 ELSEIF(PEST%PARAM(IP)%PLOG.EQ.1)THEN
  WRITE(IUPESTOUT,'(I2,1X,A5,1X,I5,1X,I7,5(1X,F15.3),I10,I10,A10,A15,2F15.3,2A15,F15.3)') I,PEST%PARAM(IP)%PPARAM,PEST%PARAM(IP)%PILS, &
     PEST%PARAM(IP)%PIZONE,EXP(PEST%PARAM(IP)%PINI),EXP(PEST%PARAM(IP)%PDELTA),EXP(PEST%PARAM(IP)%PMIN),EXP(PEST%PARAM(IP)%PMAX),PEST%PARAM(IP)%PINCREASE, &
     ABS(PEST%PARAM(IP)%PIGROUP),PEST%PARAM(IP)%PLOG,TRIM(STRING),PEST%PARAM(IP)%ACRONYM,EXP(PEST%PARAM(IP)%PPRIOR),EXP(PEST%PARAM(IP)%PARSTD), &
     PEST%PARAM(IP)%SDATE,PEST%PARAM(IP)%EDATE,PEST%PARAM(IP)%PORG
  PEST%PARAM(IP)%ALPHA_HISTORY(0)=EXP(PEST%PARAM(IP)%PINI)
 ELSEIF(PEST%PARAM(IP)%PLOG.EQ.2)THEN
  WRITE(IUPESTOUT,'(I2,1X,A5,1X,I5,1X,I7,5(1X,F15.3),I10,I10,A10,A15,2F15.3,2A15,F15.3)') I,PEST%PARAM(IP)%PPARAM,PEST%PARAM(IP)%PILS, &
     PEST%PARAM(IP)%PIZONE,10.0D0**(PEST%PARAM(IP)%PINI),10.0D0**PEST%PARAM(IP)%PDELTA,10.0D0**(PEST%PARAM(IP)%PMIN),10.0D0**(PEST%PARAM(IP)%PMAX),PEST%PARAM(IP)%PINCREASE, &
     ABS(PEST%PARAM(IP)%PIGROUP),PEST%PARAM(IP)%PLOG,TRIM(STRING),PEST%PARAM(IP)%ACRONYM,10.0D0**(PEST%PARAM(IP)%PPRIOR),10.0D0**PEST%PARAM(IP)%PARSTD, &
     PEST%PARAM(IP)%SDATE,PEST%PARAM(IP)%EDATE,PEST%PARAM(IP)%PORG
  PEST%PARAM(IP)%ALPHA_HISTORY(0)=10.0D0**(PEST%PARAM(IP)%PINI)
 ENDIF
 
 END SUBROUTINE IPEST_GLM_ECHO_PARAMETERS
  
 !#####=================================================================
 LOGICAL FUNCTION IPEST_GLM_SETGROUPS(IBATCH,IMODE)
 !#####=================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IBATCH,IMODE
 INTEGER :: I,J,NG,NP,N,IH,IM,IS
 REAL(KIND=DP_KIND) :: X,XMIN,XMAX
 INTEGER,ALLOCATABLE,DIMENSION(:) :: SEED
 
 IPEST_GLM_SETGROUPS=.TRUE.; IF(PBMAN%IPESTP+PBMAN%IIES.EQ.0)RETURN
 
 IPEST_GLM_SETGROUPS=.FALSE.

 !## get number of active parameters (number of groups need to be zero)
 NP=0; NG=0; DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PACT.EQ.1)NP=NP+1
  IF(PEST%PARAM(I)%PACT.EQ.2)NG=NG+1
 ENDDO
 WRITE(*,'(/A)') 'Got Initially '//TRIM(VTOS(NP+NG))//' defined parameters; number of active parameters/groups '//TRIM(VTOS(NP))

 !## set igroup lt 0 for followers in group - check whether factors within group are equal --- need to be
 !## make sure group with active nodes is positive rest is negative
 IF(IUPESTOUT.NE.0)WRITE(IUPESTOUT,'(/A10,1X,A3,1X,A8,1X,A2,1X,A15)') 'NO','ACT','GRP','P','ACRONYM' 
 IF(IUPESTOUT.EQ.0)WRITE(*        ,'(/A10,1X,A3,1X,A8,1X,A2,1X,A15)') 'NO','ACT','GRP','P','ACRONYM' 
 
 NP=0; DO I=1,SIZE(PEST%PARAM)
  !## nothing for this parameter
  IF(PEST%PARAM(I)%PACT.EQ.0)CYCLE
  !## skip location outside model
  IF(PEST%PARAM(I)%PIGROUP.EQ.0)CYCLE
  !## get all parameters in same group for current parameter - discarding activeness, need to set proper group
  NP=NP+1; DO J=1,SIZE(PEST%PARAM)
   IF(I.EQ.J)CYCLE
   !## skip no area assigned to it
   IF(PEST%PARAM(J)%PACT.EQ.0)CYCLE
   !## skip location outside model
   IF(PEST%PARAM(J)%PIGROUP.EQ.0)CYCLE
   IF(PEST%PARAM(J)%PIGROUP.EQ.PEST%PARAM(I)%PIGROUP)THEN
    !## check factor
    IF(PEST%PARAM(J)%PINI.NE.PEST%PARAM(I)%PINI)THEN
     IF(IBATCH.EQ.1)THEN
      WRITE(*,'(/A)') 'Initial factor in an group need to be identicial'
!      IF(PEST%PARAM(J)%PACT.EQ.0)WRITE(*,'(A)') '>>> Parameter is inactive, but it needs to be active if a parameter in that group is active too <<<'
      WRITE(*,'(A/)') 'Check initial factors for group '//TRIM(VTOS(PEST%PARAM(J)%PIGROUP))
      WRITE(*,'(A/)') 'Check initial factors for group '//TRIM(VTOS(PEST%PARAM(J)%PIGROUP))
      PAUSE; STOP
     ELSE
      CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Parameters within the same group need to have idential initial values','Error')
      RETURN
     ENDIF
    ENDIF
    PEST%PARAM(J)%PIGROUP=-1*ABS(PEST%PARAM(J)%PIGROUP)
    !## make sure groupsnames are equally
    PEST%PARAM(J)%ACRONYM=     PEST%PARAM(I)%ACRONYM
    IF(PEST%PARAM(J)%PACT.NE.0)PEST%PARAM(J)%PACT=2
   ENDIF
  ENDDO
 ENDDO
 
 !## change initial point randomly
 IF(PBMAN%IRANDOM.EQ.1.AND.IMODE.EQ.1)THEN
  CALL RANDOM_SEED(SIZE=N); ALLOCATE(SEED(N))
  WRITE(*,*) N
  CALL IOSTIME(IH,IM,IS)
  WRITE(*,*) IH,IM,IS
  SEED=IH+IM+IS
  CALL RANDOM_SEED(PUT=SEED)
  CALL RANDOM_SEED(GET=SEED)
  WRITE(*,*) SEED
  DO I=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(I)%PIGROUP.LT.0.AND.PEST%PARAM(I)%PACT.EQ.0)CYCLE
   XMIN=LOG10(PEST%PARAM(I)%PMIN)
   XMAX=LOG10(PEST%PARAM(I)%PMAX)
   DO
    CALL RANDOM_NUMBER(X); IF(X.GT.0.10D0.AND.X.LT.0.9D0)EXIT
   ENDDO
   X=XMIN+X*(XMAX-XMIN)
   X=10.0D0**X
   DO J=1,SIZE(PEST%PARAM)
    IF(ABS(PEST%PARAM(J)%PIGROUP).EQ.ABS(PEST%PARAM(I)%PIGROUP))PEST%PARAM(J)%PINI=X
    PEST%PARAM(J)%ALPHA=PEST%PARAM(J)%PINI
!     SELECT CASE (PEST%PARAM(I)%ILOG)
!      CASE (0); PEST%PARAM(I)%PINI=X
!      CASE (1); PEST%PARAM(I)%PINI=LOG(X)
!      CASE (2); PEST%PARAM(I)%PINI=LOG10(X)
!     END SELECT
   ENDDO
  ENDDO
  DEALLOCATE(SEED)
 ENDIF
 
 DO I=1,SIZE(PEST%PARAM)
  !## if not pilotpoint, turn parameter off (group=0) OTHERWISE all inactive cell become part of math which is needed in case pilotpoints are used but not for zones
  IF(PEST%PARAM(I)%ZTYPE.EQ.0.AND.PEST%PARAM(I)%PACT.EQ.0)PEST%PARAM(I)%PIGROUP=0
  IF(IUPESTOUT.NE.0)WRITE(IUPESTOUT,'(I10,1X,I3,1X,I8,1X,A2,1X,A15)') I,PEST%PARAM(I)%PACT,PEST%PARAM(I)%PIGROUP,PEST%PARAM(I)%PPARAM,PEST%PARAM(I)%ACRONYM 
  IF(IUPESTOUT.EQ.0)WRITE(*        ,'(I10,1X,I3,1X,I8,1X,A2,1X,A15)') I,PEST%PARAM(I)%PACT,PEST%PARAM(I)%PIGROUP,PEST%PARAM(I)%PPARAM,PEST%PARAM(I)%ACRONYM 
 ENDDO

 !## check labels equal and unique
 DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PACT.EQ.0)   CYCLE
  IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE
  !## get all parameters in same group for current parameter
  DO J=1,SIZE(PEST%PARAM)
   IF(I.EQ.J)CYCLE
   !## skip inactive parameters
   IF(PEST%PARAM(J)%PACT.EQ.0)CYCLE
   !## skip group parameters
   IF(PEST%PARAM(J)%PIGROUP.LT.0)CYCLE
!   IF(PEST%PARAM(J)%PACT.EQ.2)CYCLE
   IF(PEST%PARAM(I)%ACRONYM.EQ.PEST%PARAM(J)%ACRONYM)THEN
    WRITE(*,'(3A10,1X,A15)') 'NUMBER','ACT','GROUP','ACRONYM'
    WRITE(*,'(3I10,1X,A15)') I,PEST%PARAM(I)%PACT,PEST%PARAM(I)%PIGROUP,PEST%PARAM(I)%ACRONYM
    WRITE(*,'(3I10,1X,A15)') J,PEST%PARAM(J)%PACT,PEST%PARAM(J)%PIGROUP,PEST%PARAM(J)%ACRONYM
    WRITE(*,'(/A/)') '>>> Duplicate groupslabels assigned which is not allowed <<<'; PAUSE
   ENDIF
  ENDDO
 ENDDO
 
 !## check whether pact=0 in combination with igroup
 DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PIGROUP.LT.0.AND.PEST%PARAM(I)%PACT.EQ.1)THEN
   WRITE(*,'(/2A10)') 'ACTIVE','GROUP'
   WRITE(*,'(2I10)') PEST%PARAM(I)%PACT,PEST%PARAM(I)%PIGROUP
   WRITE(*,'(/A/)') '>>> Groups are not assigned correctly <<<'; PAUSE
  ENDIF
 ENDDO
 
 !## get number of active parameters
 NP=0; NG=0; DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PACT.EQ.1)NP=NP+1
  IF(PEST%PARAM(I)%PACT.EQ.2)NG=NG+1
 ENDDO
 WRITE(*,'(/A)') 'Got Initially '//TRIM(VTOS(NP+NG))//' defined parameters; number of active parameters/groups '//TRIM(VTOS(NP))

 IPEST_GLM_SETGROUPS=.TRUE.
 
 END FUNCTION IPEST_GLM_SETGROUPS
 
 !#####=================================================================
 LOGICAL FUNCTION IPEST_GLM_PST(DIRNAME,DIR,MNAME,IGRAD,IPARAM,CTYPE)
 !#####=================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR,CTYPE,MNAME,DIRNAME
 INTEGER,INTENT(IN) :: IGRAD,IPARAM
 CHARACTER(LEN=256) :: FNAME,FN1,FN2
 CHARACTER(LEN=3) :: FWBW
 INTEGER :: I,J,N,IU,JU,IOS,NCOL,NROW,ICOL,IROW,IEQ
 REAL(KIND=DP_KIND) :: X1,Y1,X2,Y2,DX !,A
 REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: SX,SY
 
 IPEST_GLM_PST=.FALSE.
 
 FWBW=''; IF(CTYPE.EQ.'P'.AND.PBMAN%IPESTMETHOD.EQ.2)THEN
   !## allocate memory for running the models
   J=0 ; DO I=1,SIZE(PEST%PARAM)
    !## associated parameters to existing groups inactive for gradient computation
    IF(PEST%PARAM(I)%PACT.EQ.1)J=J+1
   ENDDO
   FWBW='FW_'; IF(IGRAD.GT.J)FWBW='BW_'
  ENDIF
 
 FNAME=TRIM(DIR)//'\MODELINPUT\'//TRIM(MNAME)//'_'//TRIM(FWBW)//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM))//'.PST1'
 IU=UTL_GETUNIT(); OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ',IOSTAT=IOS)
 IF(IOS.NE.0)THEN
  WRITE(*,'(/A)') 'Cannot read the appropriate PST1-file for parameter '//TRIM(VTOS(IGRAD))
  WRITE(*,'(A/)') TRIM(FNAME)
  STOP
 ENDIF
 FNAME=TRIM(DIR)//'\MODELINPUT\'//TRIM(MNAME)//'_'//TRIM(FWBW)//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM))//'.PST1_'
 JU=UTL_GETUNIT(); OPEN(JU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE',IOSTAT=IOS)
 IF(IOS.NE.0)THEN
  WRITE(*,'(/A)') 'Cannot update the appropriate PST-file for parameter '//TRIM(VTOS(IGRAD))
  WRITE(*,'(A/)') TRIM(FNAME)
  STOP
 ENDIF
 
 !## copy header
 READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN;     WRITE(JU,'(A)') TRIM(LINE)
 READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN;     WRITE(JU,'(A)') TRIM(LINE)
 READ(LINE,*,IOSTAT=IOS) NCOL,NROW; IF(IOS.NE.0)RETURN
 READ(IU,*,IOSTAT=IOS) X1,Y1,X2,Y2,IEQ; IF(IOS.NE.0)RETURN; WRITE(JU,*) X1,Y1,X2,Y2,IEQ
 IF(IEQ.EQ.0)THEN 
  READ(IU,*,IOSTAT=IOS) DX; IF(IOS.NE.0)RETURN; WRITE(JU,*) DX
 ELSE
  ALLOCATE(SX(0:NCOL)); READ(IU,*,IOSTAT=IOS) (SX(ICOL),ICOL=0,NCOL); IF(IOS.NE.0)RETURN; WRITE(JU,*) (SX(ICOL),ICOL=0,NCOL); DEALLOCATE(SX)
  ALLOCATE(SY(0:NROW)); READ(IU,*,IOSTAT=IOS) (SY(IROW),IROW=0,NROW); IF(IOS.NE.0)RETURN; WRITE(JU,*) (SY(IROW),IROW=0,NROW); DEALLOCATE(SY)
 ENDIF

 !## copy measurements
 READ(IU,*,IOSTAT=IOS) N; IF(IOS.NE.0)RETURN; WRITE(JU,*) N
 DO I=1,ABS(N)
  READ(IU,'(A256)',IOSTAT=IOS) LINE
  IF(IOS.NE.0)RETURN
  !## ensure a global path here
  IF(INDEX(LINE,'.\').GT.0)THEN
   CALL UTL_SUBST(LINE,'.\',TRIM(DIRNAME)//'\')
   CALL UTL_SUBST(LINE,'\\','\')
  ENDIF
  WRITE(JU,'(A)') TRIM(LINE)
 ENDDO
 
 !## copy parameters
 READ(IU,*,IOSTAT=IOS) N; IF(IOS.NE.0)RETURN; WRITE(JU,*) N
 READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN; WRITE(JU,'(A)') TRIM(LINE)

 !## write kriging settings
 IF(PEST%PE_KRANGE.LE.0.0D0)THEN
  DO I=1,SIZE(PEST%KSETTINGS)
   READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN; WRITE(JU,'(A)') TRIM(LINE)
  ENDDO
 ENDIF
 
 !## write blankout idf
 IF(PEST%PE_KTYPE.LT.0)THEN
  READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN; WRITE(JU,'(A)') TRIM(LINE)
 ENDIF
 
 N=0; IF(ASSOCIATED(PEST%S_PERIOD))N=SIZE(PEST%S_PERIOD)
 IF(N.GT.0)THEN
  DO I=1,SIZE(PEST%S_PERIOD)
   READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN; WRITE(JU,'(A)') TRIM(LINE)
  ENDDO
 ENDIF
 
 !## no batchfiles no matter what in pst-files, iMOD takes care of it
 N=0 !; IF(ASSOCIATED(PEST%B_FRACTION))N=SIZE(PEST%B_FRACTION)
 IF(N.GT.0)THEN
  DO I=1,SIZE(PEST%B_FRACTION)
   READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN; WRITE(JU,'(A)') TRIM(LINE) 
  ENDDO
 ENDIF

 DO I=1,SIZE(PEST%PARAM)
  !## read old settings
  READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN
  IF(PEST%PARAM(I)%PLOG.EQ.0)THEN
   LINE=TRIM(VTOS(MIN(1,ABS(PEST%PARAM(I)%PACT))))//','// &
        TRIM(PEST%PARAM(I)%PPARAM)               //','// &
        TRIM(VTOS(PEST%PARAM(I)%PILS))           //','// &
        TRIM(VTOS(PEST%PARAM(I)%PIZONE))         //','// &    
        TRIM(VTOS(PEST%PARAM(I)%ALPHA(1),'G',7)) //','// &
        TRIM(VTOS(PEST%PARAM(I)%PDELTA,'G',7))   //','// &
        TRIM(VTOS(PEST%PARAM(I)%PMIN/10.0D0,'G',7))     //','// &
        TRIM(VTOS(PEST%PARAM(I)%PMAX*10.0D0,'G',7))     //','// &
        TRIM(VTOS(PEST%PARAM(I)%PINCREASE,'G',7))//','// &
        TRIM(VTOS(ABS(PEST%PARAM(I)%PIGROUP)))   //','// &
        TRIM(VTOS(PEST%PARAM(I)%PLOG))//','// &
        TRIM(PEST%PARAM(I)%ACRONYM)//','// &
        TRIM(VTOS(PEST%PARAM(I)%PPRIOR,'G',7))//','// &
        TRIM(VTOS(PEST%PARAM(I)%PARSTD,'G',7))//','// &        
        TRIM(PEST%PARAM(I)%SDATE)//','// &        
        TRIM(PEST%PARAM(I)%EDATE)//','// &
        TRIM(VTOS(PEST%PARAM(I)%PORG,'G',7))
  ELSEIF(PEST%PARAM(I)%PLOG.EQ.1)THEN
   LINE=TRIM(VTOS(MIN(1,ABS(PEST%PARAM(I)%PACT))))//','// &
        TRIM(PEST%PARAM(I)%PPARAM)                 //','// &
        TRIM(VTOS(PEST%PARAM(I)%PILS))             //','// &
        TRIM(VTOS(PEST%PARAM(I)%PIZONE))           //','// &    
        TRIM(VTOS(EXP(PEST%PARAM(I)%ALPHA(1)),'G',7))//','// &
        TRIM(VTOS(EXP(PEST%PARAM(I)%PDELTA),'G',7))//','// &
        TRIM(VTOS(EXP(PEST%PARAM(I)%PMIN)/10.0D0,'G',7))  //','// &
        TRIM(VTOS(EXP(PEST%PARAM(I)%PMAX)*10.0D0,'G',7))  //','// &
        TRIM(VTOS(PEST%PARAM(I)%PINCREASE,'G',7))  //','// &
        TRIM(VTOS(ABS(PEST%PARAM(I)%PIGROUP)))     //','// &
        TRIM(VTOS(PEST%PARAM(I)%PLOG))//','// &
        TRIM(PEST%PARAM(I)%ACRONYM)//','// &
        TRIM(VTOS(EXP(PEST%PARAM(I)%PPRIOR),'G',7))//','// &
        TRIM(VTOS(EXP(PEST%PARAM(I)%PARSTD),'G',7))//','// &        
        TRIM(PEST%PARAM(I)%SDATE)//','// &        
        TRIM(PEST%PARAM(I)%EDATE)//','// &
        TRIM(VTOS(PEST%PARAM(I)%PORG,'G',7))
  ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
   LINE=TRIM(VTOS(MIN(1,ABS(PEST%PARAM(I)%PACT))))//','// &
        TRIM(PEST%PARAM(I)%PPARAM)                 //','// &
        TRIM(VTOS(PEST%PARAM(I)%PILS))             //','// &
        TRIM(VTOS(PEST%PARAM(I)%PIZONE))           //','// &    
        TRIM(VTOS(10.0D0**(PEST%PARAM(I)%ALPHA(1)),'G',7))//','// &
        TRIM(VTOS(10.0D0**PEST%PARAM(I)%PDELTA,'G',7))//','// &
        TRIM(VTOS(10.0D0**(PEST%PARAM(I)%PMIN)/10.0D0,'G',7))  //','// &
        TRIM(VTOS(10.0D0**(PEST%PARAM(I)%PMAX)*10.0D0,'G',7))  //','// &
        TRIM(VTOS(PEST%PARAM(I)%PINCREASE,'G',7))  //','// &
        TRIM(VTOS(ABS(PEST%PARAM(I)%PIGROUP)))     //','// &
        TRIM(VTOS(PEST%PARAM(I)%PLOG))//','// &
        TRIM(PEST%PARAM(I)%ACRONYM)//','// &
        TRIM(VTOS(10.0D0**PEST%PARAM(I)%PPRIOR,'G',7))//','// &
        TRIM(VTOS(10.0D0**PEST%PARAM(I)%PARSTD,'G',7))//','// &        
        TRIM(PEST%PARAM(I)%SDATE)//','// &        
        TRIM(PEST%PARAM(I)%EDATE)//','// &
        TRIM(VTOS(PEST%PARAM(I)%PORG,'G',7))
  ENDIF
  WRITE(JU,'(A)') TRIM(LINE)

  IF(TRIM(CTYPE).EQ.'L')THEN
   PEST%PARAM(I)%LALPHA(IGRAD)=PEST%PARAM(I)%ALPHA(1)
  ELSEIF(TRIM(CTYPE).EQ.'P')THEN
   PEST%PARAM(I)%GALPHA(IGRAD)=PEST%PARAM(I)%ALPHA(1)
  ENDIF
  
 ENDDO
 
 !## copy zones
 READ(IU,*,IOSTAT=IOS) N; IF(IOS.NE.0)RETURN; WRITE(JU,*) N
 DO I=1,N
  READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)RETURN
  IF(INDEX(LINE,'.\').GT.0)THEN
   CALL UTL_SUBST(LINE,'.\',TRIM(DIR)//'\')
   CALL UTL_SUBST(LINE,'\\','\')
  ENDIF
  WRITE(JU,'(A)') TRIM(LINE)
 ENDDO
 
 CLOSE(IU,STATUS='DELETE'); CLOSE(JU)
 FN1=TRIM(DIR)//'\MODELINPUT\'//TRIM(MNAME)//'_'//TRIM(FWBW)//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM))//'.PST1_'
 FN2=TRIM(DIR)//'\MODELINPUT\'//TRIM(MNAME)//'_'//TRIM(FWBW)//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM))//'.PST1'
 CALL IOSRENAMEFILE(FN1,FN2)
 
 IPEST_GLM_PST=.TRUE.
 
 END FUNCTION IPEST_GLM_PST

 !#####=================================================================
 SUBROUTINE IPEST_GLM_ALLOCATE(DIR)
 !#####=================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER :: I,N,M
 LOGICAL :: LEX
 CHARACTER(LEN=3) :: FWBW
 
 CALL IPEST_GLM_DEALLOCATE()
 
 !## allocate memory for running the models
 N=0 ; DO I=1,SIZE(PEST%PARAM)
  !## associated parameters to existing groups inactive for gradient computation
  IF(PEST%PARAM(I)%PACT.EQ.1)N=N+1
 ENDDO
 
 IF(PBMAN%IPESTMETHOD.EQ.2)N=N*2
 
 M=PBMAN%NLAMBDASEARCH
 
 WRITE(*,'(/1X,A,I10,A/)') 'Optimizing (nett groups included): ',N,' Parameters/Groups'
 
 ALLOCATE(RNG(N),RNL(M),GPARAM(N),LPARAM(M))

 !## allocate memory for process-status memory
 M=MAX(M,N); ALLOCATE(ISTATUS(M),INSENS(M),IPROC(2,M),STIME(M),ETIME(M),STIMEJ(M),ETIMEJ(M))
 
 !## set linesearch-runbatch-files
 N=PBMAN%NLAMBDASEARCH; IF(PEST%PE_MXITER.LT.0)N=1

 DO I=1,N
  !## modflow6
  IF(PBMAN%IFORMAT.EQ.3)THEN
   RNL(I)=TRIM(DIR)//'\IPEST_L#'//TRIM(VTOS(I))//'\RUN_L#'//TRIM(VTOS(I))//'.BAT'
  ELSE
   RNL(I)=TRIM(DIR)//'\RUN_L#'//TRIM(VTOS(I))//'.BAT'
  ENDIF
  LPARAM(I)=I
  INQUIRE(FILE=RNL(I),EXIST=LEX)
  IF(.NOT.LEX)THEN
   WRITE(*,'(/A)') 'Cannot read the appropriate BAT-file for parameter '//TRIM(VTOS(I))
   WRITE(*,'(A/)') TRIM(RNL(I))
   STOP
  ENDIF  
  RNL(I)='"'//TRIM(RNL(I))//'"'
 ENDDO

 FWBW=''; IF(PBMAN%IPESTMETHOD.EQ.2)FWBW='FW_'

 !## set gradient-runbatch-files - equal to number of parameter to be estimated
 IF(PEST%PE_MXITER.GE.0)THEN
  N=0; DO I=1,SIZE(PEST%PARAM)
   !## parameter
   IF(PEST%PARAM(I)%PACT.NE.1)CYCLE; N=N+1
   IF(PBMAN%IFORMAT.EQ.3)THEN
    RNG(N)=TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(I))//'\RUN_'//TRIM(FWBW)//'P#'//TRIM(VTOS(I))//'.BAT'
   ELSE
    RNG(N)=TRIM(DIR)//'\RUN_'//TRIM(FWBW)//'P#'//TRIM(VTOS(I))//'.BAT'
   ENDIF
   INQUIRE(FILE=RNG(N),EXIST=LEX)
   IF(.NOT.LEX)THEN
    WRITE(*,'(/A)') 'Cannot read the appropriate BAT-file for parameter '//TRIM(VTOS(I))
    WRITE(*,'(A/)') TRIM(RNG(N))
    STOP
   ENDIF
   GPARAM(N)=I; RNG(N)='"'//TRIM(RNG(N))//'"'
  ENDDO

  IF(PBMAN%IPESTMETHOD.EQ.2)THEN
   
   FWBW='BW_'
   
   DO I=1,SIZE(PEST%PARAM)
    !## parameter
    IF(PEST%PARAM(I)%PACT.NE.1)CYCLE; N=N+1
    IF(PBMAN%IFORMAT.EQ.3)THEN
     RNG(N)=TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(I))//'\RUN_'//TRIM(FWBW)//'P#'//TRIM(VTOS(I))//'.BAT'
    ELSE
     RNG(N)=TRIM(DIR)//'\RUN_'//TRIM(FWBW)//'P#'//TRIM(VTOS(I))//'.BAT'
    ENDIF
    INQUIRE(FILE=RNG(N),EXIST=LEX)
    IF(.NOT.LEX)THEN
     WRITE(*,'(/A)') 'Cannot read the appropriate BAT-file for parameter '//TRIM(VTOS(I))
     WRITE(*,'(A/)') TRIM(RNG(N))
     STOP
    ENDIF
    GPARAM(N)=I; RNG(N)='"'//TRIM(RNG(N))//'"'
   ENDDO  
  ENDIF
 
 ENDIF
 
 END SUBROUTINE IPEST_GLM_ALLOCATE

 !#####=================================================================
 SUBROUTINE IPEST_GLM_DEALLOCATE()
 !#####=================================================================
 IMPLICIT NONE

 IF(ALLOCATED(RNG))    DEALLOCATE(RNG)
 IF(ALLOCATED(RNL))    DEALLOCATE(RNL)
 IF(ALLOCATED(IPROC))  DEALLOCATE(IPROC)
 IF(ALLOCATED(GPARAM)) DEALLOCATE(GPARAM)
 IF(ALLOCATED(LPARAM)) DEALLOCATE(LPARAM)
 IF(ALLOCATED(ISTATUS))DEALLOCATE(ISTATUS)
 IF(ALLOCATED(INSENS)) DEALLOCATE(INSENS)
 IF(ALLOCATED(STIME))  DEALLOCATE(STIME)
 IF(ALLOCATED(ETIME))  DEALLOCATE(ETIME)
 IF(ALLOCATED(STIMEJ)) DEALLOCATE(STIMEJ)
 IF(ALLOCATED(ETIMEJ)) DEALLOCATE(ETIMEJ)
 
 END SUBROUTINE IPEST_GLM_DEALLOCATE
 
 !#####=================================================================
 LOGICAL FUNCTION IPEST_GLM_NEXT(IBATCH,ITER,DIR,DIRO,DIRP,LAMBDA,LAMBDA_MAX,LAMBDA_GAMMA,MNAME,MU_MAX,MU_GAMMA,LAMBDA_GAMMA_INI,NMU)
 !#####=================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ITER,IBATCH
 INTEGER,INTENT(INOUT) :: NMU
 CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRO,DIRP,MNAME
 CHARACTER(LEN=52) :: TXT
 REAL(KIND=DP_KIND),INTENT(INOUT) ::  LAMBDA_GAMMA,LAMBDA,MU_GAMMA
 REAL(KIND=DP_KIND),INTENT(IN) :: MU_MAX,LAMBDA_MAX,LAMBDA_GAMMA_INI
 REAL(KIND=DP_KIND) :: MJ,X,C2
 INTEGER :: I,IJ
 REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: XLAMBDA,YLAMBDA,CPARABOL

 IPEST_GLM_NEXT=.FALSE.
 
 IF(ALLOCATED(XLAMBDA))DEALLOCATE(XLAMBDA)
 IF(ALLOCATED(YLAMBDA))DEALLOCATE(YLAMBDA)
 IF(ALLOCATED(CPARABOL))DEALLOCATE(CPARABOL)
 
 ALLOCATE(XLAMBDA(PBMAN%NLAMBDASEARCH),YLAMBDA(PBMAN%NLAMBDASEARCH),CPARABOL(PBMAN%NLAMBDASEARCH))
 
 !## get optimal model with lowest objective function value
 IJ=0; MJ=HUGE(1.0D0); DO I=1,PBMAN%NLAMBDASEARCH
  XLAMBDA(I)=PBMAN%LAMBDA_TEST(I)*LAMBDA
  YLAMBDA(I)=MSR%DHL_J(I)
  IF(MSR%DHL_J(I).LT.MJ)THEN
   MJ=MSR%DHL_J(I)
   IJ=I
  ENDIF
 ENDDO

 C2=(1.0D0-MJ/MSR%PJ)*100.0D0

 WRITE(IUPESTPROGRESS,'(/50A1)') ('=',I=1,50)
 WRITE(IUPESTPROGRESS,'(A)') 'Computing improvement is '//TRIM(VTOS(C2,'F',2))//'%'
 
 !## no room to adjust main-parameters anymore - finished
 IF(C2.LT.0.0D0.AND.(LAMBDA_GAMMA.GE.LAMBDA_MAX))THEN !.AND.(MU_GAMMA.GE.MU_MAX.OR.NMU.GT.2))THEN
  !## save alphas for history-logging
  DO I=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(I)%PIGROUP.LT.0)CYCLE
   IF(PEST%PARAM(I)%PLOG.EQ.1)THEN
    PEST%PARAM(I)%ALPHA_HISTORY(ITER)=EXP(PEST%PARAM(I)%ALPHA(1))
   ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
    PEST%PARAM(I)%ALPHA_HISTORY(ITER)=10.0D0**(PEST%PARAM(I)%ALPHA(1))
   ELSE
    PEST%PARAM(I)%ALPHA_HISTORY(ITER)=PEST%PARAM(I)%ALPHA(1)
   ENDIF
  ENDDO
  WRITE(IUPESTPROGRESS,'(A)') '>>> No reduction of objective function found in lambda search, process finished <<<'
  WRITE(IUPESTPROGRESS,'(50A1)') ('=',I=1,50)
  WRITE(IUPESTPROGRESS,'(A)') 'Current Lambda '//TRIM(VTOS(LAMBDA,'F',7))//' multiplyer lambda_gamma '//TRIM(VTOS(LAMBDA_GAMMA,'F',3))
  IF(PEST%PE_REGULARISATION.NE.0)WRITE(IUPESTPROGRESS,'(A )') 'Current Mu     '//TRIM(VTOS(MU_INI,'F',7))//' multiplyer mu_gamma     '//TRIM(VTOS(MU_GAMMA,'F',3))
  WRITE(IUPESTPROGRESS,'(50A1)') ('=',I=1,50)
  LAMBDA_GAMMA=-1.0D0*LAMBDA_GAMMA; MU_GAMMA=-1.0D0*MU_GAMMA; RETURN
 ENDIF
 
 !## if improvement is less than 1%, decrease mu and try again without renewed sensitivities - DO THIS ONLY ONE TIME !!!
 IF(PEST%PE_REGULARISATION.NE.0)THEN
  IF(C2.LT.1.0D0.AND.MU_GAMMA.LT.MU_MAX.AND.NMU.LT.2)THEN 
   WRITE(IUPESTPROGRESS,'(/50A1)') ('=',I=1,50)
   WRITE(IUPESTPROGRESS,'(A38,F10.3,A2)') 'Slight progression in this iteration (',C2,'%) rerun without recomputing sensitivites'
   MU_GAMMA=MIN(MU_GAMMA*2.0D0,MU_MAX); MU_INI=MSR%MU(0)/MU_GAMMA
   WRITE(IUPESTPROGRESS,'(A)') 'Next Initial Lambda '//TRIM(VTOS(LAMBDA,'F',7))//' multiplied with lambda_gamma '//TRIM(VTOS(LAMBDA_GAMMA,'F',3))
   WRITE(IUPESTPROGRESS,'(A )') 'Next Initial Mu     '//TRIM(VTOS(MU_INI,'F',7))//' multiplied with mu_gamma     '//TRIM(VTOS(MU_GAMMA,'F',3))
   WRITE(IUPESTPROGRESS,'(50A1)')  ('=',I=1,50)
   NMU=NMU+1
   RETURN
  ENDIF
 ENDIF

 !## increase lambda
 IF(C2.LT.0.0D0)THEN
  WRITE(IUPESTPROGRESS,'(/50A1)') ('=',I=1,50)
  WRITE(IUPESTPROGRESS,'(A38,F10.3,A2)') 'Slight progression in this iteration (',C2,'%) rerun without recomputing sensitivites - increase lambda'
  LAMBDA_GAMMA=MIN(LAMBDA_GAMMA*2.0D0,LAMBDA_MAX); LAMBDA=LAMBDA*LAMBDA_GAMMA
  WRITE(IUPESTPROGRESS,'(A)') 'Next Initial Lambda '//TRIM(VTOS(LAMBDA,'F',7))//' multiplied with lambda_gamma '//TRIM(VTOS(LAMBDA_GAMMA,'F',3))
  IF(PEST%PE_REGULARISATION.NE.0)WRITE(IUPESTPROGRESS,'(A )') 'Next Initial Mu     '//TRIM(VTOS(MU_INI,'F',7))//' multiplied with mu_gamma     '//TRIM(VTOS(MU_GAMMA,'F',3))
  WRITE(IUPESTPROGRESS,'(50A1)')  ('=',I=1,50)
  RETURN
 ENDIF

 !## store winning lambda
 LAMBDAS(ITER)=XLAMBDA(IJ)
 
 !## determine lambda
 IF(PBMAN%NLAMBDASEARCH.EQ.3)THEN
  CALL UTL_FIT_PARABOLA(CPARABOL,XLAMBDA,YLAMBDA)
 ENDIF
 
 TXT='selected from Obj. Function Value '//TRIM(VTOS(MJ,'F',7))

 !## current objective function less than previous
 IF(MJ.LT.MSR%PJ)THEN
  !## bot-parabola and objective function reduced
  IF(PBMAN%NLAMBDASEARCH.EQ.3)THEN
   IF(CPARABOL(3).GT.0.0D0)THEN
    !## valley at this lambda value
    X=-CPARABOL(2)/(2.0D0*CPARABOL(3))
    !## update lambda
    LAMBDA=MAX(LAMBDA/LAMBDA_GAMMA,X)
    TXT='derived from a U-shaped parabola at  '//TRIM(VTOS(CPARABOL(1)+CPARABOL(2)*X+CPARABOL(3)*X**2.0D0,'F',7))
   ELSE
    LAMBDA=LAMBDA*PBMAN%LAMBDA_TEST(IJ)
   ENDIF
  ELSE
   LAMBDA=LAMBDA*PBMAN%LAMBDA_TEST(IJ)
  ENDIF
  LAMBDA_GAMMA=LAMBDA_GAMMA_INI
 !## no reduction start with largest lambda to test another set of lambda's
 ELSE
  LAMBDA=PBMAN%LAMBDA_TEST(PBMAN%NLAMBDASEARCH)*LAMBDA
 ENDIF
 
 NMU=0
 
 WRITE(IUPESTPROGRESS,'(/50A1)')  ('=',I=1,50)
 WRITE(IUPESTPROGRESS,'(A)') 'Next Initial Lambda '//TRIM(VTOS(LAMBDA,'F',7))//' '//TRIM(TXT)//' m2; lambda_gamma='//TRIM(VTOS(LAMBDA_GAMMA,'F',3))
 IF(PEST%PE_REGULARISATION.NE.0)WRITE(IUPESTPROGRESS,'(A)') 'Next Initial Mu     '//TRIM(VTOS(MU_INI,'F',7))//'; mu_gamma='//TRIM(VTOS(MU_GAMMA,'F',3))
 WRITE(IUPESTPROGRESS,'(50A1)')  ('=',I=1,50)
 
 !## update new objective function value to be minimized
 MSR%TJ=MJ
 
 !## save residuals
 IF(IUPESTRESIDUAL.GT.0)CLOSE(IUPESTRESIDUAL); IUPESTRESIDUAL=0
 IUPESTRESIDUAL=UTL_GETUNIT(); OPEN(IUPESTRESIDUAL,FILE=TRIM(DIRP)//'\LOG_PEST_RESIDUAL_'// &
   TRIM(VTOS(ITER))//'.TXT',STATUS='REPLACE',ACTION='WRITE')
 IF(IUPESTPRESIDUAL.GT.0)CLOSE(IUPESTPRESIDUAL); IUPESTPRESIDUAL=0
 IUPESTPRESIDUAL=UTL_GETUNIT(); OPEN(IUPESTPRESIDUAL,FILE=TRIM(DIRP)//'\LOG_PESTP_RESIDUAL_'// &
   TRIM(VTOS(ITER))//'.TXT',STATUS='REPLACE',ACTION='WRITE')
 IF(.NOT.IPEST_GLM_GETJ_AVG(DIRO,IJ,LPARAM(IJ),'L',IBATCH,0,MNAME))RETURN
 
 !## set current h on correct position
 DO I=1,MSR%NOBS
  MSR%HL(0,I) =MSR%HL(IJ,I)
  MSR%DHL(0,I)=MSR%DHL(IJ,I)
 ENDDO
 MSR%GOF(1)=MSR%GOF(IJ); MSR%NSC(1)=MSR%NSC(IJ)

 MSR%GOF_H(ITER)=MSR%GOF(1); MSR%NSC_H(ITER)=MSR%NSC(1)
 MSR%TJ_H(ITER)=MSR%TJ;      MSR%RJ_H(ITER)=MSR%RJ
 MSR%MU(ITER)=MU_INI
 
 !## set correct set of parameters
 DO I=1,SIZE(PEST%PARAM)
  PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%LALPHA(IJ)
 ENDDO

 IF(PBMAN%IFORMAT.EQ.2.OR.PBMAN%IFORMAT.EQ.3)CALL IPEST_GLM_UPDATEHEADS(DIR,DIRO,IJ)
 
 IPEST_GLM_NEXT=.TRUE.
 
 END FUNCTION IPEST_GLM_NEXT

 !#####=================================================================
 SUBROUTINE IPEST_GLM_UPDATEHEADS(DIR,DIRO,IJ)
 !#####=================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRO
 INTEGER,INTENT(IN) :: IJ
 INTEGER :: ILAY,IROW,ICOL
 REAL(KIND=DP_KIND),DIMENSION(:,:),ALLOCATABLE :: XBND
 TYPE(IDFOBJ) :: SHD,HED
 LOGICAL :: LEX
 
 !## only reset starting head conditions for steady-state solutions
 IF(PBMAN%ISS.EQ.1)THEN
  IF(PBMAN%ISTEADY.EQ.0)RETURN
 ENDIF
 
 !## copy results from "winner" as starting heads
 ALLOCATE(XBND(PRJIDF%NCOL,PRJIDF%NROW))
 CALL IDFNULLIFY(HED); CALL IDFNULLIFY(SHD)

 !## process from nlay to top
 DO ILAY=PRJNLAY,1,-1
  !## only if it exists
  INQUIRE(FILE=TRIM(DIRO)//'\IPEST_L#'//TRIM(VTOS(IJ))//'\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF',EXIST=LEX)
  IF(LEX)THEN
   IF(IDFREAD(SHD,TRIM(DIRO)//'\IPEST_L#'//TRIM(VTOS(IJ))//'\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF',1))THEN
    IF(.NOT.ASSOCIATED(HED%X))THEN
     CALL IDFCOPY(SHD,HED); HED%X=SHD%X
    ENDIF
    XBND=HED%X
    !## fill in nodata if needed
    DO IROW=1,SHD%NROW; DO ICOL=1,SHD%NCOL
     IF(SHD%X(ICOL,IROW).EQ.SHD%NODATA)SHD%X(ICOL,IROW)=HED%X(ICOL,IROW)
    ENDDO; ENDDO
    IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\MODELINPUT\BAS6\STRT_L'//TRIM(VTOS(ILAY))//'.ARR', &
       SHD,0,0,-1,'F10.3',XBND))THEN
    ENDIF
    HED%X=SHD%X
   ENDIF
   CALL IDFDEALLOCATEX(SHD)
  ENDIF
 ENDDO
 
 IF(ALLOCATED(XBND))DEALLOCATE(XBND)
 CALL IDFDEALLOCATEX(SHD); CALL IDFDEALLOCATEX(HED)
 
 END SUBROUTINE IPEST_GLM_UPDATEHEADS
 
 !#####=================================================================
 SUBROUTINE IPEST_GLM_NEXTGRAD(IPARAM,RTYPE,IGRAD)
 !#####=================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IPARAM,IGRAD
 CHARACTER(LEN=1),INTENT(IN) :: RTYPE
 INTEGER :: I,J
 REAL(KIND=DP_KIND) :: FCT
 CHARACTER(LEN=2) :: FWBW
 
 IF(RTYPE.EQ.'L')THEN
 
  DO I=1,SIZE(PEST%PARAM)
   PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%LALPHA(IGRAD)
  ENDDO
  
 ELSEIF(RTYPE.EQ.'P')THEN

  FWBW='FW'; IF(PBMAN%IPESTMETHOD.EQ.2)THEN
   !## allocate memory for running the models
   J=0 ; DO I=1,SIZE(PEST%PARAM)
    !## associated parameters to existing groups inactive for gradient computation
    IF(PEST%PARAM(I)%PACT.EQ.1)J=J+1
   ENDDO
   IF(IGRAD.GT.J)FWBW='BW'
  ENDIF
 
  !## adjust all parameters
  IF(PBMAN%IPESTMETHOD.EQ.3)THEN
   
   DO I=1,SIZE(PEST%PARAM)
    !## skip inactive parameters
    IF(PEST%PARAM(I)%PACT.EQ.0)CYCLE
    PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%ALPHA_SIM(IGRAD)
    IF(PEST%PARAM(IPARAM)%PIGROUP.GT.0)THEN
     IF(PEST%PARAM(I)%PLOG.EQ.1)THEN
      FCT=EXP(PEST%PARAM(I)%ALPHA(1))
     ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
      FCT=10.0D0**(PEST%PARAM(I)%ALPHA(1))
     ELSE
      FCT=PEST%PARAM(I)%ALPHA(1)
     ENDIF
     WRITE(IUPESTOUT,'(A)') 'Adjusting Parameter '//TRIM(PEST%PARAM(I)%PPARAM)// &
                  '['//TRIM(PEST%PARAM(I)%ACRONYM)//']'// &
                  ';ils='//TRIM(VTOS(PEST%PARAM(I)%PILS))// &
                  ';izone='//TRIM(VTOS(PEST%PARAM(I)%PIZONE))// &
                  ';igroup='//TRIM(VTOS(PEST%PARAM(I)%PIGROUP))// &
                  ';factor='//TRIM(VTOS(FCT,'*',1))
    ENDIF
   ENDDO

  !## adjust all parameters within the same group
  ELSE
  
   !## reset all alpha's
   PEST%PARAM%ALPHA(1)=PEST%PARAM%ALPHA(2)
  
   DO I=1,SIZE(PEST%PARAM)
    !## skip inactive parameters
    IF(PEST%PARAM(I)%PACT.EQ.0)CYCLE
    IF(ABS(PEST%PARAM(I)%PIGROUP).EQ.ABS(PEST%PARAM(IPARAM)%PIGROUP))THEN
     IF(FWBW.EQ.'FW')THEN
      IF(PBMAN%IPESTMETHOD.EQ.1)THEN
       PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%ALPHA(2)+PEST%PARAM(I)%PDELTA
      ELSEIF(PBMAN%IPESTMETHOD.EQ.2)THEN
       PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%ALPHA(2)+PEST%PARAM(I)%DELTAALPHA
      ELSEIF(PBMAN%IPESTMETHOD.EQ.3)THEN
       PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%ALPHA_SIM(IGRAD)
      ENDIF
     ELSE
      PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%ALPHA(2)-PEST%PARAM(I)%DELTAALPHA
     ENDIF
     IF(PEST%PARAM(I)%PLOG.EQ.1)THEN
      FCT=EXP(PEST%PARAM(I)%ALPHA(1))
     ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
      FCT=10.0D0**(PEST%PARAM(I)%ALPHA(1))
     ELSE
      FCT=PEST%PARAM(I)%ALPHA(1)
     ENDIF
     IF(PEST%PARAM(I)%PIGROUP.GT.0)THEN
      WRITE(IUPESTOUT,'(A)') 'Adjusting Parameter '//TRIM(PEST%PARAM(I)%PPARAM)// &
                   '['//TRIM(PEST%PARAM(I)%ACRONYM)//']'// &
                   ';ils='//TRIM(VTOS(PEST%PARAM(I)%PILS))// &
                   ';izone='//TRIM(VTOS(PEST%PARAM(I)%PIZONE))// &
                   ';igroup='//TRIM(VTOS(PEST%PARAM(I)%PIGROUP))// &
                   ';factor='//TRIM(VTOS(FCT,'*',1))
     ENDIF
    ENDIF
   ENDDO
  ENDIF
 ENDIF
 
 CALL FLUSH(IUPESTOUT)
 
 END SUBROUTINE IPEST_GLM_NEXTGRAD
 
 !#####=================================================================
 SUBROUTINE IPEST_GLM_SAVE_PARAMETERS(IBATCH,DIR,IPARAM,RT,IGRAD) 
 !#####=================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IGRAD,IPARAM,IBATCH
 CHARACTER(LEN=*),INTENT(IN) :: DIR,RT
 INTEGER :: I,J,K,ILAY,ISUB,IROW,ICOL,NCOL,NROW,IPER,ISYS
 INTEGER,DIMENSION(4) :: IOS
 INTEGER(KIND=DP_KIND) :: SDATE_PAR,EDATE_PAR,SDATE_MOD,EDATE_MOD
 REAL(KIND=DP_KIND) :: FCT,F
 REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: XORG,XADJ,FRAC,XCNT
 REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: FADJ
 INTEGER,POINTER,DIMENSION(:,:) :: IDX
 CHARACTER(LEN=2),DIMENSION(14) :: IPTYPE
 CHARACTER(LEN=5),DIMENSION(14) :: FPTYPE
 CHARACTER(LEN=4),DIMENSION(14) :: SVFILE
 INTEGER,DIMENSION(14) :: NCLIST,ACLIST,NCILST
 CHARACTER(LEN=256) :: FNAME,CFOLDER
 CHARACTER(LEN=3) :: FWBW
 LOGICAL :: LEX

 FWBW=''; IF(PBMAN%IPESTMETHOD.EQ.2)FWBW='FW_'
 
 IPTYPE= ['KH ' ,'VA'  ,'SC'  ,'SY'  ,'DC'  ,'RC'  ,'GC',  'RE'  ,  'QR', 'KD', 'VC', 'HF', 'ER', 'ED']
 !# modflow6
 IF(PBMAN%IFORMAT.EQ.3)THEN
  FPTYPE=['K'   ,'K33' ,'SS'  ,'SY'  ,'DRN' ,'RIV' ,'GHB' ,'RCH' , 'WEL','NaN','NaN', 'HFB', 'EVT', 'EVT']
  SVFILE=['NPF6','NPF6','STO6','STO6','DRN6','RIV6','GHB6','RCH6','WEL6','NaN','NaN','HFB6','EVT6','EVT6']
 !## imod-wq
 ELSE
  IF(TOPICS(TKDW)%IACT_MODEL.EQ.1)THEN
   FPTYPE=['HK'  ,'VKA' ,'SF1' ,'SF2' ,'DRN' ,'RIV' ,'GHB' ,'RCH' , 'WEL','TRAN','VCONT','NaN','EVT' ,'EVT' ]
   SVFILE=['LPF7','LPF7','BCF6','BCF6','DRN7','RIV7','GHB7','RCH7','WEL7','BCF6','BCF6' ,'NaN','EVT6','EVT6']
  ELSE
   FPTYPE=['HK'  ,'VKA' ,'SF1' ,'SF2' ,'DRN' ,'RIV' ,'GHB' ,'RCH' , 'WEL','TRAN','VCONT','NaN','EVT' ,'EVT' ]
   SVFILE=['LPF7','LPF7','LPF7','LPF7','DRN7','RIV7','GHB7','RCH7','WEL7','BCF6','BCF6' ,'NaN','EVT6','EVT6']
  ENDIF
 ENDIF
 !## number of columns to be read as reals modflow6
 IF(PBMAN%IFORMAT.EQ.3)THEN
  !## number of reals to be read per package
  NCLIST=[     0,     0,     0,     0,    2,     3,     2 ,    1 ,    1 ,     0,     0,     1,     3 ,    3]
  !## number of integer to be read per package
  NCILST=[     0,     0,     0,     0,    3,     3,     3 ,    3 ,    3 ,     0,     0,     6,     3 ,    3]
  IF(PBMAN%DDRN.NE.0.0D0)NCLIST(5)=3
 !## number of columns to be read as reals imod-wq
 ELSE
  !## number of reals to be read per package
  NCLIST=[     0,     0,     0,     0,    2,     4,     3 ,    1 ,    1 ,     0,     0,     0,     3 ,    3]
  !## number of integer to be read per package
  NCILST=[     0,     0,     0,     0,    3,     3,     3 ,    3 ,    3 ,     0,     0,     6,     3 ,    3]
 ENDIF
 !## parameter to be adjusted (from the reals in clist)
 ACLIST= [     0,     0,     0,     0,    2,     2,     2 ,    1 ,    1 ,     0,     0,     1,     2 ,    3]
  
 !## modify parameters per submodel

 DO ISUB=1,PBMAN%NSUBMODEL
  
  IF(PBMAN%IFORMAT.EQ.3)CFOLDER='\GWF_'//TRIM(VTOS(ISUB))//'\'
  IF(PBMAN%IFORMAT.EQ.6)CFOLDER='\'
  
  !## read the zones per submodel
  CALL IPEST_GLM_READ_ZONES(TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT',NCOL,NROW)
  ALLOCATE(FRAC(NCOL,NROW))
  
  DO I=1,SIZE(IPTYPE)
  
   !## read from list of number
   SELECT CASE (IPTYPE(I))
    CASE ('DC','RC','GC','QR','RE','HF','ER','ED')
   
    !## see whether this parameter is optimized
    DO J=1,SIZE(PEST%PARAM)
     !## check whether the parameter is available
     IF(PEST%PARAM(J)%PPARAM.EQ.IPTYPE(I))EXIT
    ENDDO; IF(J.GT.SIZE(PEST%PARAM))CYCLE

    ISYS=0
    DO
     ISYS=ISYS+1

     !## mf6
     IF(PBMAN%IFORMAT.EQ.3)THEN
      IF(IPTYPE(I).EQ.'HF')THEN
       FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))
      ELSE
       FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\SYS'//TRIM(VTOS(ISYS)); IF(.NOT.IOSDIREXISTS(FNAME))EXIT
       FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\SYS'//TRIM(VTOS(ISYS))//'\'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))
      ENDIF
      CALL UTL_CREATEDIR(FNAME)
     !## imod-wq
     ELSE
      FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))
      CALL UTL_CREATEDIR(FNAME)
     ENDIF
      
     DO IPER=1,PRJNPER
      !## mf6
      IF(PBMAN%IFORMAT.EQ.3)THEN      
       !## read original parameter values
       IF(IPTYPE(I).EQ.'HF')THEN
        FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FPTYPE(I))//'_T'//TRIM(VTOS(IPER))//'.ARR'
       ELSE
        FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\SYS'//TRIM(VTOS(ISYS))//'\'//TRIM(FPTYPE(I))//'_T'//TRIM(VTOS(IPER))//'.ARR'
       ENDIF
      !## imod-wq
      ELSE
       !## read original parameter values
       FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FPTYPE(I))//'_T'//TRIM(VTOS(IPER))//'.ARR'
      ENDIF
      !## skip it for this period
      INQUIRE(FILE=FNAME,EXIST=LEX); IF(.NOT.LEX)CYCLE
      !## imod-wq and recharge/evaporation
      IF(PBMAN%IFORMAT.EQ.6.AND.(IPTYPE(I).EQ.'RE'.OR.IPTYPE(I).EQ.'ER'.OR.IPTYPE(I).EQ.'ED'))THEN
       IF(.NOT.IPEST_GLM_READ_ARRFILE(FNAME,XORG))RETURN
       IF(.NOT.ASSOCIATED(XADJ))ALLOCATE(XADJ(SIZE(XORG,1),SIZE(XORG,2)))
       IF(.NOT.ASSOCIATED(XCNT))ALLOCATE(XCNT(SIZE(XORG,1),SIZE(XORG,2)))
       XADJ=XORG; XCNT=0.0D0
      ELSE
       IF(.NOT.IPEST_GLM_READ_LSTFILE(FNAME,NCLIST(I),XORG,NCILST(I),IDX))RETURN
       IF(.NOT.ASSOCIATED(XADJ))ALLOCATE(XADJ(SIZE(XORG,1),SIZE(XORG,2)))
       XADJ=XORG; ALLOCATE(FADJ(SIZE(IDX,2))); FADJ=0.0D0
      ENDIF
       
      !## process parameter values
      DO J=1,SIZE(PEST%PARAM)
       
       !## check whether the parameter is available - leave this out otherwise parameters that are kept constant are excluded
       IF(PEST%PARAM(J)%PPARAM.NE.IPTYPE(I))CYCLE

       !## check date if needed
       IF(PEST%PARAM(J)%SDATE.NE.''.AND.PEST%PARAM(J)%EDATE.NE.'')THEN
        IF(TRIM(SIM(IPER)%CDATE).EQ.'STEADY-STATE')THEN
         IF(TRIM(PEST%PARAM(J)%SDATE).EQ.'STEADY-STATE'.AND.TRIM(PEST%PARAM(J)%EDATE).EQ.'STEADY-STATE')THEN
          IF(TRIM(SIM(IPER)%CDATE).NE.'STEADY-STATE')CYCLE
         ELSE
          !## skip this parameter
          CYCLE
         ENDIF
        ELSE
         READ(PEST%PARAM(J)%SDATE,*,IOSTAT=IOS(1)) SDATE_PAR
         READ(PEST%PARAM(J)%EDATE,*,IOSTAT=IOS(2)) EDATE_PAR
         SDATE_MOD=YMDHMSTOITIME(SIM(IPER  )%IYR,SIM(IPER  )%IMH,SIM(IPER  )%IDY,SIM(IPER  )%IHR,SIM(IPER  )%IMT,SIM(IPER  )%ISC)
         EDATE_MOD=YMDHMSTOITIME(SIM(IPER+1)%IYR,SIM(IPER+1)%IMH,SIM(IPER+1)%IDY,SIM(IPER+1)%IHR,SIM(IPER+1)%IMT,SIM(IPER+1)%ISC)
         !## ready to evaluate
         IF(SUM(IOS).EQ.0)THEN
          !## make sure all are in same dimensions
          SDATE_MOD=UTL_COMPLETEDATE(SDATE_MOD); EDATE_MOD=UTL_COMPLETEDATE(EDATE_MOD)
          SDATE_PAR=UTL_COMPLETEDATE(SDATE_PAR); EDATE_PAR=UTL_COMPLETEDATE(EDATE_PAR)
          IF(EDATE_PAR.LE.SDATE_MOD)CYCLE; IF(SDATE_PAR.GT.EDATE_MOD)CYCLE
         ENDIF
        ENDIF      
       ENDIF
       
       !## found correct parameter in time : apply factor
       FCT=PEST%PARAM(J)%ALPHA(1)
       IF(PEST%PARAM(J)%PLOG.EQ.1)FCT=EXP(FCT)
       IF(PEST%PARAM(J)%PLOG.EQ.2)FCT=10.0D0**FCT
       IF(PEST%PARAM(J)%ZTYPE.EQ.0)THEN
       
        !## fill array with location of a zone
        FRAC=0.0D0
        DO K=1,PEST%PARAM(J)%NODES
         IROW=PEST%PARAM(J)%IROW(K)
         ICOL=PEST%PARAM(J)%ICOL(K)
         FRAC(ICOL,IROW)=PEST%PARAM(J)%F(K)
        ENDDO
        
        IF(PBMAN%IFORMAT.EQ.6.AND.IPTYPE(I).EQ.'RE')THEN
         DO K=1,PEST%PARAM(J)%NODES
          IROW=PEST%PARAM(J)%IROW(K); ICOL=PEST%PARAM(J)%ICOL(K)
          F   =FRAC(ICOL,IROW) 
          IF(XCNT(ICOL,IROW).EQ.0.0D0)THEN
           XADJ(ICOL,IROW)=XORG(ICOL,IROW)*F*FCT
          ELSE
           XADJ(ICOL,IROW)=XADJ(ICOL,IROW)+XORG(ICOL,IROW)*F*FCT
          ENDIF
          XCNT(ICOL,IROW)=XCNT(ICOL,IROW)+F 
         ENDDO
        ELSE
         IF(IPTYPE(I).EQ.'HF')THEN
          DO K=1,SIZE(IDX,2)
           !## skip wrong system number
           IF(IDX(4,K).NE.PEST%PARAM(J)%PILS)CYCLE
           IROW=IDX(2,K); ICOL=IDX(3,K); F=FRAC(ICOL,IROW); IF(F.LE.0.0D0)CYCLE
           IROW=IDX(5,K); ICOL=IDX(6,K); F=FRAC(ICOL,IROW); IF(F.LE.0.0D0)CYCLE
           IF(FADJ(K).EQ.0.0D0)THEN
            XADJ(ACLIST(I),K)=XORG(ACLIST(I),K)*F*FCT
           ELSE
            !## modify current package for this zone
            XADJ(ACLIST(I),K)=XADJ(ACLIST(I),K)+XORG(ACLIST(I),K)*F*FCT
           ENDIF
           FADJ(K)=FADJ(K)+F 
          ENDDO
         ELSE
          DO K=1,SIZE(IDX,2)
           !## skip wrong system number
           IF(IDX(4,K).NE.PEST%PARAM(J)%PILS)CYCLE
           IROW=IDX(2,K); ICOL=IDX(3,K); F=FRAC(ICOL,IROW); IF(F.LE.0.0D0)CYCLE
           IF(FADJ(K).EQ.0.0D0)THEN
            XADJ(ACLIST(I),K)=XORG(ACLIST(I),K)*F*FCT
           ELSE
            !## modify current package for this zone
            XADJ(ACLIST(I),K)=XADJ(ACLIST(I),K)+XORG(ACLIST(I),K)*F*FCT
           ENDIF
           FADJ(K)=FADJ(K)+F 
          ENDDO
         ENDIF
        ENDIF
       ENDIF
      ENDDO
      
      IF(PBMAN%IFORMAT.EQ.6.AND.IPTYPE(I).EQ.'RE')THEN
       !## check whether adjustments are okay
       DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
        IF(XCNT(ICOL,IROW).GT.1.01D0.AND.XORG(ICOL,IROW).NE.XADJ(ICOL,IROW))THEN
         WRITE(*,'(A)') '>>> Parameter: '//IPTYPE(I)//' <<<'
         WRITE(*,'(A,F15.7,A,2I5,A)') 'Too much altered (',XCNT(ICOL,IROW),') in a single cell [rc]: (',IROW,ICOL,')'
         WRITE(*,'(2(A,F15.7))') 'Original Value= ',XORG(ICOL,IROW),' ; Modified Value= ',XADJ(ICOL,IROW)
         PAUSE
        ENDIF
       ENDDO; ENDDO
      ELSE
       DO K=1,SIZE(IDX,2)
        IROW=IDX(2,K); ICOL=IDX(3,K)
        IF(FADJ(K).GT.1.01D0.AND.XORG(ACLIST(I),K).NE.XADJ(ACLIST(I),K))THEN
         WRITE(*,'(A)') '>>> Parameter :'//IPTYPE(I)//' for system '//TRIM(VTOS(K))//' <<<'
         WRITE(*,'(A,F15.7,A,I10,A,3I5,A)') 'Too much altered (',FADJ(K),') in a single entry (',K,') for cell [lrc]: ',IDX(4,K),IROW,ICOL,')'
         WRITE(*,'(2(A,F15.7))') 'Original Value= ',XORG(ACLIST(I),K),' ; Modified Value= ',XADJ(ACLIST(I),K)
         PAUSE
        ENDIF
       ENDDO
      ENDIF
      
      !## add if needed pilot point interpolation
      IF(IPEST_GLM_COMPUTE_PILOTPOINTS(IPTYPE(I),ISYS,IBATCH,0))THEN !ILAY,IBATCH,0))THEN
       
       IF(PBMAN%IFORMAT.EQ.6.AND.(IPTYPE(I).EQ.'RE'.OR.IPTYPE(I).EQ.'ER'.OR.IPTYPE(I).EQ.'ED'))THEN
        DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
         !## copy interpolated data into current adjusted dataset
         IF(PRJIDF%X(ICOL,IROW).NE.PRJIDF%NODATA)XADJ(ICOL,IROW)=XADJ(ICOL,IROW)*PRJIDF%X(ICOL,IROW)
        ENDDO; ENDDO   
       ELSE
        IF(IPTYPE(I).EQ.'HF')THEN
         DO K=1,SIZE(IDX,2)
          !## skip wrong system number
          IF(IDX(7,K).NE.ISYS)CYCLE !PEST%PARAM(J)%PILS)CYCLE
          !## inside from node
          IROW=IDX(2,K); ICOL=IDX(3,K); IF(PRJIDF%X(ICOL,IROW).EQ.PRJIDF%NODATA)CYCLE
          !## inside to   node
          IROW=IDX(5,K); ICOL=IDX(6,K); IF(PRJIDF%X(ICOL,IROW).EQ.PRJIDF%NODATA)CYCLE
          !## copy interpolated data into current adjusted dataset
          XADJ(ACLIST(I),K)=XADJ(ACLIST(I),K)*PRJIDF%X(ICOL,IROW)
         ENDDO   
        ELSE
         DO K=1,SIZE(IDX,2)
          !## skip wrong system number
          IF(IDX(4,K).NE.ISYS)CYCLE !PEST%PARAM(J)%PILS)CYCLE
          IROW=IDX(2,K); ICOL=IDX(3,K)
          !## copy interpolated data into current adjusted dataset
          IF(PRJIDF%X(ICOL,IROW).NE.PRJIDF%NODATA)XADJ(ACLIST(I),K)=XADJ(ACLIST(I),K)*PRJIDF%X(ICOL,IROW)
         ENDDO   
        ENDIF
       ENDIF
      ENDIF

      !## mf6
      IF(PBMAN%IFORMAT.EQ.3)THEN      
       !## save adjusted package-values
       IF(IPTYPE(I).EQ.'HF')THEN
        FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))//'\'// &
              TRIM(FPTYPE(I))//'_T'//TRIM(VTOS(IPER))//'_'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))//'.ARR'
       ELSE
        FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\SYS'//TRIM(VTOS(ISYS))//'\'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))//'\'// &
              TRIM(FPTYPE(I))//'_T'//TRIM(VTOS(IPER))//'_'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))//'.ARR'
       ENDIF
      !## imod-wq
      ELSE
       !## save adjusted package-values
       FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))//'\'// &
             TRIM(FPTYPE(I))//'_T'//TRIM(VTOS(IPER))//'_'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))//'.ARR'
      ENDIF
      IF(PBMAN%IFORMAT.EQ.6.AND.IPTYPE(I).EQ.'RE')THEN
       IF(.NOT.IPEST_GLM_WRITE_ARRFILE(FNAME,XADJ))RETURN
      ELSE
       IF(IPTYPE(I).EQ.'RE'.OR.IPTYPE(I).EQ.'ER')THEN
        IF(.NOT.IPEST_GLM_WRITELSTFILE(FNAME,XADJ,IDX,'G15.7'))RETURN
       ELSE
        IF(.NOT.IPEST_GLM_WRITELSTFILE(FNAME,XADJ,IDX,'F15.3'))RETURN
       ENDIF
      ENDIF
      !## deallocate memory
      DEALLOCATE(XORG,XADJ)
      IF(ASSOCIATED(IDX))DEALLOCATE(IDX)
      IF(ASSOCIATED(FADJ))DEALLOCATE(FADJ)
      IF(ASSOCIATED(XCNT))DEALLOCATE(XCNT)
     ENDDO
     IF(PBMAN%IFORMAT.EQ.6)EXIT
     IF(PBMAN%IFORMAT.EQ.3.AND.IPTYPE(I).EQ.'HF')EXIT
    ENDDO

   CASE ('KH','VA','SC','SY','KD','VC')

    !## see whether this parameter is optimized
    DO J=1,SIZE(PEST%PARAM)
     !## check whether the parameter is available - leave this out otherwise parameters that are kept constant are excluded
     IF(PEST%PARAM(J)%PPARAM.EQ.IPTYPE(I))EXIT 
    ENDDO; IF(J.GT.SIZE(PEST%PARAM))CYCLE

    FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))
    CALL UTL_CREATEDIR(FNAME)

    DO ILAY=1,PRJNLAY
     
     DO J=1,SIZE(PEST%PARAM)
      !## check whether the parameter is available - leave this out otherwise parameters that are kept constant are excluded
      IF(PEST%PARAM(J)%PPARAM.EQ.IPTYPE(I))THEN
       IF(PEST%PARAM(J)%PILS.EQ.ILAY)EXIT
      ENDIF
     ENDDO
     !## skip this layer as it is not in the list optimized parameters
     IF(J.GT.SIZE(PEST%PARAM))CYCLE
      
     !## read original parameter values
     FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FPTYPE(I))//'_L'//TRIM(VTOS(ILAY))//'.ARR'
     INQUIRE(FILE=FNAME,EXIST=LEX)
     IF(.NOT.LEX)THEN
      WRITE(*,'(/A)') 'Cannot find '//TRIM(FNAME)
      WRITE(*,'(A/)') 'Probably you are trying to calibrate a parameter not-existing in the current model'
      STOP
     ENDIF
     IF(.NOT.IPEST_GLM_READ_ARRFILE(FNAME,XORG))RETURN
     IF(.NOT.ASSOCIATED(XADJ))ALLOCATE(XADJ(SIZE(XORG,1),SIZE(XORG,2)))
     IF(.NOT.ASSOCIATED(XCNT))ALLOCATE(XCNT(SIZE(XORG,1),SIZE(XORG,2)))
     IF(IPTYPE(I).EQ.'VC')THEN
      DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
       IF(XORG(ICOL,IROW).NE.0.0D0)XORG(ICOL,IROW)=1.0D0/XORG(ICOL,IROW)
      ENDDO; ENDDO
     ENDIF
     XADJ=XORG; XCNT=0.0D0
      
     !## process zonation
     DO J=1,SIZE(PEST%PARAM)
      !## check whether the parameter is available - leave this out otherwise parameters that are kept constant are excluded
      IF(PEST%PARAM(J)%PPARAM.NE.IPTYPE(I))CYCLE
      IF(PEST%PARAM(J)%PILS.NE.ILAY)CYCLE
      !## found correct parameter - apply factor
      FCT=PEST%PARAM(J)%ALPHA(1)
      IF(PEST%PARAM(J)%PLOG.EQ.1)FCT=EXP(FCT)
      IF(PEST%PARAM(J)%PLOG.EQ.2)FCT=10.0D0**FCT
      IF(PEST%PARAM(J)%ZTYPE.EQ.0)THEN
       DO K=1,PEST%PARAM(J)%NODES
        IROW=PEST%PARAM(J)%IROW(K)
        ICOL=PEST%PARAM(J)%ICOL(K)
        F   =PEST%PARAM(J)%F(K)
        IF(XCNT(ICOL,IROW).EQ.0.0D0)THEN
         XADJ(ICOL,IROW)=XORG(ICOL,IROW)*F*FCT
        ELSE
         XADJ(ICOL,IROW)=XADJ(ICOL,IROW)+XORG(ICOL,IROW)*F*FCT
        ENDIF
        XCNT(ICOL,IROW)=XCNT(ICOL,IROW)+F 
       ENDDO
      ENDIF
     ENDDO
      
     !## check whether adjustments are okay
     DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
      IF(XCNT(ICOL,IROW).GT.1.01D0.AND.XORG(ICOL,IROW).NE.XADJ(ICOL,IROW))THEN
       WRITE(*,'(A)') '>>> Parameter :'//IPTYPE(I)//' model layer '//TRIM(VTOS(ILAY))//' <<<'
       WRITE(*,'(A,F15.7,A,3I5,A)') 'Too much altered (',XCNT(ICOL,IROW),') in a single cell [lrc]: (',ILAY,IROW,ICOL,')'
       WRITE(*,'(2(A,F15.7))') 'Original Value= ',XORG(ICOL,IROW),' ; Modified Value= ',XADJ(ICOL,IROW)
       PAUSE
      ENDIF
     ENDDO; ENDDO
      
     !## add if needed pilot point interpolation
     IF(IPEST_GLM_COMPUTE_PILOTPOINTS(IPTYPE(I),ILAY,IBATCH,0))THEN
       
      DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
       !## copy interpolated data into current adjusted dataset
       IF(PRJIDF%X(ICOL,IROW).NE.PRJIDF%NODATA)XADJ(ICOL,IROW)=XADJ(ICOL,IROW)*PRJIDF%X(ICOL,IROW)
      ENDDO; ENDDO   
      
     ENDIF
      
     IF(IPTYPE(I).EQ.'VC')THEN
      DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
       IF(XORG(ICOL,IROW).NE.0.0D0)XORG(ICOL,IROW)=1.0D0/XORG(ICOL,IROW)
      ENDDO; ENDDO
     ENDIF

     !## save adjusted values
     FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//SVFILE(I)//'\'//TRIM(FWBW)//RT//'#'//TRIM(VTOS(IPARAM))//'\'// &
           TRIM(FPTYPE(I))//'_L'//TRIM(VTOS(ILAY))//'_'//RT//'#'//TRIM(VTOS(IPARAM))//'.ARR'
     IF(.NOT.IPEST_GLM_WRITE_ARRFILE(FNAME,XADJ))RETURN
      
     !## deallocate memory
     DEALLOCATE(XORG,XADJ,XCNT)

    ENDDO
   END SELECT
  ENDDO
  
  !## clean memory
  DO I=1,SIZE(PEST%PARAM)
   IF(ASSOCIATED(PEST%PARAM(I)%IROW))DEALLOCATE(PEST%PARAM(I)%IROW)
   IF(ASSOCIATED(PEST%PARAM(I)%ICOL))DEALLOCATE(PEST%PARAM(I)%ICOL)
   IF(ASSOCIATED(PEST%PARAM(I)%F))   DEALLOCATE(PEST%PARAM(I)%F)
   IF(ASSOCIATED(PEST%PARAM(I)%XY))  DEALLOCATE(PEST%PARAM(I)%XY)
  ENDDO
  
 ENDDO

 DEALLOCATE(FRAC)
 DO I=1,SIZE(PEST%PARAM)
  IF(RT.EQ.'L')THEN
   PEST%PARAM(I)%LALPHA(IGRAD)=PEST%PARAM(I)%ALPHA(1)
  ELSEIF(RT.EQ.'P')THEN
   PEST%PARAM(I)%GALPHA(IGRAD)=PEST%PARAM(I)%ALPHA(1)
  ENDIF
 ENDDO

 END SUBROUTINE IPEST_GLM_SAVE_PARAMETERS
 
 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_COMPUTE_PILOTPOINTS(IPTYPE,ILAY,IBATCH,IQR,DIR) 
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: IPTYPE
 CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: DIR
 INTEGER,INTENT(IN) :: ILAY,IBATCH,IQR
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: XD,YD,ZD,WD,PD
 REAL(KIND=DP_KIND) :: FCT
 INTEGER :: I,J,K,ND,ILOG,IROW,ICOL,IPARAM
 REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: XBLNK,SEMVAR
 INTEGER,ALLOCATABLE,DIMENSION(:) :: IPOS
 TYPE(IDFOBJ) :: IDFV,ZONE
 
 IPEST_GLM_COMPUTE_PILOTPOINTS=.FALSE.
 
 !## process pilot points if needed
 ND=0; DO J=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(J)%PPARAM.NE.IPTYPE)CYCLE
  IF(PEST%PARAM(J)%PILS.NE.ILAY)CYCLE
  !## pilot point
  IF(PEST%PARAM(J)%ZTYPE.EQ.1)THEN
   ND=ND+PEST%PARAM(J)%NODES
  ENDIF
 ENDDO

 !## no parameters which is odd
 IF(ND.EQ.0)RETURN
!  WRITE(*,'(/A/)') '>>> NO PARAMETERS FOUND IN CONSTRUCTING QR MATRIX <<<'; PAUSE; STOP
! ENDIF
 
 SILL=-100.0D0
 
 ALLOCATE(XD(ND),YD(ND),ZD(ND),WD(ND),PD(ND))
 ND=0; DO J=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(J)%PPARAM.NE.IPTYPE)CYCLE
  IF(PEST%PARAM(J)%PILS.NE.ILAY)CYCLE
  IF(PEST%PARAM(J)%ZTYPE.EQ.0)CYCLE
  FCT=PEST%PARAM(J)%ALPHA(1)
  DO K=1,PEST%PARAM(J)%NODES
   ND=ND+1
   !## kriging on log-values
   XD(ND)=PEST%PARAM(J)%XY(K,1)
   YD(ND)=PEST%PARAM(J)%XY(K,2)

!   !## snap coordinates - except points that are measurements, or outside modelling domain
!   IF(PEST%PARAM(J)%PACT.EQ.1)THEN
!    CALL IDFIROWICOL(PRJIDF,IROW,ICOL,XD(ND),YD(ND))
!    !## snap them inside model domain, leave them intact outside model domain
!    IF(IROW.GT.0.AND.ICOL.GT.0)CALL IDFGETLOC(PRJIDF,IROW,ICOL,XD(ND),YD(ND))
!   ENDIF
   
   ZD(ND)=0.0D0
   !## set log-type (be aware not possible to use mix of them)
   ILOG=PEST%PARAM(J)%PLOG
   PD(ND)=FCT
   WD(ND)=1.0D0
   !## not sure what to do whith difference stdev per point - convert to variance
   SILL=PEST%PARAM(J)%PARSTD**2.0D0
  ENDDO
 ENDDO
     
 RANGE =PEST%PE_KRANGE
 KTYPE=-1*ABS(PEST%PE_KTYPE)
! KTYPE =PEST%PE_KTYPE
 NUGGET=0.0D0

 !## set kriging setting per parameter - if available
 IF(PEST%PE_KRANGE.LE.0.0)THEN
  !## set range to be automatic by default
  RANGE=0.0D0
  DO I=1,SIZE(PEST%KSETTINGS)
   !## settings for current type
   IF(TRIM(IPTYPE).NE.PEST%KSETTINGS(I)%PTYPE)CYCLE
   IF(ILAY.NE.PEST%KSETTINGS(I)%ILS)CYCLE
   !## overwrite current settings
   RANGE =PEST%KSETTINGS(I)%RANGE   
   KTYPE =PEST%KSETTINGS(I)%KTYPE
   KTYPE=-1*ABS(KTYPE)
   SILL  =PEST%KSETTINGS(I)%SILL
   NUGGET=PEST%KSETTINGS(I)%NUGGET
   EXIT
  ENDDO
 ENDIF

 IF(SILL.LE.0.0D0)STOP 'SILL NOT DEFINED'

 WRITE(*,'(A3,2A5,3A15  ,A10)') 'PRM','ILS','TYPE','NUGGET','SILL','RANGE','POINTS'
 WRITE(*,'(A3,2I5,3F15.3,I10)') IPTYPE,ILAY,KTYPE,NUGGET,SILL,RANGE,ND

 !## number of pilotpoint to be used in interpolation (take all)
 MAXPNT=0; IF(ABS(PEST%PE_KTYPE).EQ.6)MAXPNT=1
 IBLANKOUT=0 !; IF(PEST%PE_KTYPE.LE.0)IBLANKOUT=1

 PNTSEARCH=1
 IQUADRANT=0 
 !## copy what has been adjusted so far
 IF(.NOT.IDFALLOCATEX(PRJIDF))RETURN
 !## read blank-out region
 IF(PEST%PE_KTYPE.LE.0)THEN
  IF(.NOT.IPEST_GLM_READ_ARRFILE(PEST%PPBNDIDF,XBLNK))RETURN
  PRJIDF%X=0.0D0 
  !## interpolate for areas equal to nodata only
  DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
   IF(XBLNK(ICOL,IROW).NE.0.0)PRJIDF%X(ICOL,IROW)=PRJIDF%NODATA
  ENDDO; ENDDO        
 ELSE
  !## interpolate all
  PRJIDF%X=PRJIDF%NODATA; ALLOCATE(XBLNK(PRJIDF%NCOL,PRJIDF%NROW)); XBLNK=1.0D0
 ENDIF
 
 CALL IDFCOPY(PRJIDF,ZONE); ZONE%X=XBLNK; ZONE%NODATA=-999.0D0
 IF(IQR.EQ.0)THEN
  CALL KRIGING_MAIN(SIZE(XD),XD,YD,ZD,PD,WD,PRJIDF,IBATCH,0.0D0,ZONE)
 ELSE
  !## use standard deviation 
  CALL IDFCOPY(PRJIDF,IDFV)
  CALL KRIGING_MAIN(SIZE(XD),XD,YD,ZD,PD,WD,PRJIDF,IBATCH,0.0D0,ZONE,IDFV=IDFV,SEMVAR=SEMVAR)
 ENDIF
 CALL IDFDEALLOCATEX(ZONE)
 !## back-transformation
 DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
  !## copy interpolated data into current adjusted dataset
  IF(XBLNK(ICOL,IROW).NE.0.0)THEN
   SELECT CASE (ILOG)
    CASE (1)
     PRJIDF%X(ICOL,IROW)=EXP(PRJIDF%X(ICOL,IROW))
!     IF(IQR.EQ.1)IDFV%X(ICOL,IROW)=EXP(IDFV%X(ICOL,IROW))
    CASE (2)
     PRJIDF%X(ICOL,IROW)=10.0D0**PRJIDF%X(ICOL,IROW)
!     IF(IQR.EQ.1)IDFV%X(ICOL,IROW)=10.0D0**IDFV%X(ICOL,IROW)
   END SELECT
  ELSE
   PRJIDF%X(ICOL,IROW)=PRJIDF%NODATA
   IF(IQR.EQ.1)IDFV%X(ICOL,IROW)=IDFV%NODATA
  ENDIF
 ENDDO; ENDDO
 
 !## get weight matrix pilot points
 IF(IQR.EQ.1)THEN
 
  IDFV%FNAME=TRIM(DIR)//'\KRIGING_STDEV\'//TRIM(IPTYPE)//'_ILS'//TRIM(VTOS(ILAY))//'.IDF'
  IF(.NOT.IDFWRITE(IDFV,IDFV%FNAME,1))STOP 
  PRJIDF%FNAME=TRIM(DIR)//'\KRIGING\'//TRIM(IPTYPE)//'_ILS'//TRIM(VTOS(ILAY))//'.IDF'
  IF(.NOT.IDFWRITE(PRJIDF,PRJIDF%FNAME,1))STOP 

  !## figure out what position in the weight matrix
  ALLOCATE(IPOS(ND)); IPOS=0

  ND=0; IPARAM=0
  DO I=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(I)%PIGROUP.LE.0)    CYCLE
   IPARAM=IPARAM+1
   !## skip iact=0
   IF(PEST%PARAM(I)%PACT.EQ.0)       CYCLE
   IF(PEST%PARAM(I)%PPARAM.NE.IPTYPE)CYCLE
   IF(PEST%PARAM(I)%PILS.NE.ILAY)    CYCLE
   IF(PEST%PARAM(I)%ZTYPE.EQ.0)      CYCLE
   DO J=1,PEST%PARAM(I)%NODES
    ND=ND+1; IPOS(ND)=IPARAM
   ENDDO
  ENDDO

  DO I=1,ND
   DO J=1,ND
    !## weight as the square-root of the inverse of twice the semivariance (doherty 2003)

    QR(IPOS(I),IPOS(J))=2.0D0*SEMVAR(I,J)
!    IF(QR(IPOS(I),IPOS(J)).NE.0.0D0)QR(IPOS(I),IPOS(J))=SQRT(1.0D0/QR(IPOS(I),IPOS(J)))
    !## parameter operator as the semivariance value or can be constant in case of zones
    QO(IPOS(I),IPOS(J))=SEMVAR(I,J)
   ENDDO
  ENDDO

  ND=SIZE(QR,1)
  IF(ND.LE.50)THEN
   WRITE(IUPESTOUT,'(/A/)') 'QR'
   DO I=1,ND; WRITE(IUPESTOUT,'(99F15.7)') (QR(I,J),J=1,ND); ENDDO
   WRITE(IUPESTOUT,'(/A/)') 'QO'
   DO I=1,ND; WRITE(IUPESTOUT,'(99F15.7)') (QO(I,J),J=1,ND); ENDDO
   FLUSH(IUPESTOUT)
  ENDIF
  
  DEALLOCATE(IPOS)
  
 ENDIF
 
 IF(ASSOCIATED(XBLNK))DEALLOCATE(XBLNK)
 
 IPEST_GLM_COMPUTE_PILOTPOINTS=.TRUE.
 
 END FUNCTION IPEST_GLM_COMPUTE_PILOTPOINTS

 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_READ_LSTFILE(FNAME,NC,X,NCI,IDX)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: FNAME
 INTEGER,INTENT(IN) :: NC,NCI
 REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: X
 INTEGER,POINTER,DIMENSION(:,:) :: IDX
 INTEGER :: IU,IOS,I,J,N
 CHARACTER(LEN=256) :: LINE
 
 IPEST_GLM_READ_LSTFILE=.FALSE.

 IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',FORM='FORMATTED',ACTION='READ',IOSTAT=IOS)
 IF(IOS.NE.0)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot open file: '//CHAR(13)// &
   '['//TRIM(FNAME)//']'//CHAR(13)//'for reading','Error')
  RETURN
 ENDIF

 DO I=1,2
  N=0; DO
   READ(IU,'(A256)',IOSTAT=IOS) LINE
   IF(IOS.NE.0)EXIT; IF(INDEX(LINE,'DIMENSIONS').GT.0)EXIT; N=N+1
   IF(I.EQ.2)THEN
    READ(LINE,*) (IDX(J,N),J=1,NCI),(X(J,N),J=1,NC),IDX(NCI+1,N)
   ENDIF
  ENDDO
  IF(I.EQ.1)THEN
   ALLOCATE(IDX(NCI+1,N),X(NC,N)); IDX=0; X=0.0D0
  ENDIF
  REWIND(IU)
 ENDDO
 
 CLOSE(IU)
 
 IPEST_GLM_READ_LSTFILE=.TRUE.
 
 END FUNCTION IPEST_GLM_READ_LSTFILE
 
 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_WRITELSTFILE(FNAME,X,IDX,FORM)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: FNAME,FORM
 REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: X
 INTEGER,POINTER,DIMENSION(:,:) :: IDX
 INTEGER :: IU,IOS,I,J,NCI,NCR
 CHARACTER(LEN=52) :: FRM
 
 IPEST_GLM_WRITELSTFILE=.FALSE.

 NCI=SIZE(IDX,1)
 NCR=SIZE(X  ,1)
 
 IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',FORM='FORMATTED',ACTION='WRITE',IOSTAT=IOS)
 IF(IOS.NE.0)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot open file: '//CHAR(13)// &
   '['//TRIM(FNAME)//']'//CHAR(13)//'for writing','Error')
  RETURN
 ENDIF

 WRITE(FRM,'(A10,I2.2,A)') '('//TRIM(VTOS(NCI-1))//'(I5,1X),',NCR,'('//TRIM(FORM)//',1X),I5)'

 DO I=1,SIZE(IDX,2)
  WRITE(IU,FRM) (IDX(J,I),J=1,NCI-1),(X(J,I),J=1,NCR),IDX(NCI,I)
 ENDDO
 
 CLOSE(IU)
 
 IPEST_GLM_WRITELSTFILE=.TRUE.
 
 END FUNCTION IPEST_GLM_WRITELSTFILE
 
 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_READ_ARRFILE(FNAME,X,IDBL)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: FNAME
 INTEGER,INTENT(OUT),OPTIONAL :: IDBL
 REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: X
 INTEGER :: IU,NLINE,IOS,NCOL,NROW,IROW,ICOL
 CHARACTER(LEN=52) :: LINE
 
 IPEST_GLM_READ_ARRFILE=.FALSE.

 IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',FORM='FORMATTED',ACTION='READ',IOSTAT=IOS)
 IF(IOS.NE.0)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot open file: '//CHAR(13)// &
   '['//TRIM(FNAME)//']'//CHAR(13)//'for reading','Error')
  RETURN
 ENDIF

 !## look for network dimensions
 NLINE=0; DO
  READ(IU,'(A52)') LINE
  IF(INDEX(LINE,'DIMENSIONS').GT.0)EXIT
  NLINE=NLINE+1
 ENDDO
 
 READ(IU,'(A52)') LINE; READ(LINE(2:),*) NCOL
 READ(IU,'(A52)') LINE; READ(LINE(2:),*) NROW
 ALLOCATE(X(NCOL,NROW))
 REWIND(IU)
 DO IROW=1,NROW
  READ(IU,*) (X(ICOL,IROW),ICOL=1,NCOL)
 ENDDO
 !## try to read double/single precision
 IF(PRESENT(IDBL))THEN
  !## default single precision
  READ(IU,*,IOSTAT=IOS) IDBL; IF(IOS.NE.0)IDBL=4
 ENDIF

 CLOSE(IU)
 
 IPEST_GLM_READ_ARRFILE=.TRUE.
 
 END FUNCTION IPEST_GLM_READ_ARRFILE
 
 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_WRITE_ARRFILE(FNAME,X)
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: FNAME
 REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: X
 INTEGER :: IU,IOS,NCOL,NROW,IROW
 REAL(KIND=DP_KIND) :: NODATA
 
 IPEST_GLM_WRITE_ARRFILE=.FALSE.

 IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',FORM='FORMATTED',ACTION='WRITE',IOSTAT=IOS)
 IF(IOS.NE.0)THEN
  CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot open file: '//CHAR(13)// &
   '['//TRIM(FNAME)//']'//CHAR(13)//'for writing','Error')
  RETURN
 ENDIF

 NCOL=SIZE(X,1)
 NROW=SIZE(X,2)
 
 NODATA=HUGE(1.0) 
 DO IROW=1,NROW
  CALL IDFWRITEFREE_ROW(IU,X(:,IROW),NCOL,NODATA,0,'G15.7')  
 ENDDO
 CALL IDFWRITEFREE_HEADER(IU,PRJIDF)

 CLOSE(IU)
 
 IPEST_GLM_WRITE_ARRFILE=.TRUE.
 
 END FUNCTION IPEST_GLM_WRITE_ARRFILE

 !###====================================================================
 INTEGER FUNCTION IPEST_PATTERN_SEARCH()
 !###====================================================================
 IMPLICIT NONE
 INTEGER :: NGRAD,IGRAD,JGRAD,I,J,IC
 CHARACTER(LEN=2),DIMENSION(2) :: FWBW=['FW','BW']
 REAL(KIND=DP_KIND) :: X,CJ,F
 
 NGRAD=0; DO I=1,SIZE(PEST%PARAM); IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE; NGRAD=NGRAD+1; ENDDO
 
 !## fill in by default 
 DO I=1,SIZE(PEST%PARAM); PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%ALPHA(2); ENDDO

 WRITE(IUPESTPROGRESS,'(/A2,A5,7A15)') 'FB','IGRD','PARAM','OBJ.F.','OBJ.F.H.','OBJ.F.P.','PREV.OBJ.F.','DIFF.OBJ.F.','RED.OBJ.F.(%)'

 JGRAD=0
 DO J=1,2
  IGRAD=0
  DO I=1,SIZE(PEST%PARAM)
   IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE
   IGRAD=IGRAD+1; JGRAD=JGRAD+1
   SELECT CASE (PEST%PARAM(I)%PLOG)
    CASE (0); X=PEST%PARAM(I)%GALPHA(JGRAD)
    CASE (1); X=EXP(PEST%PARAM(I)%GALPHA(JGRAD))
    CASE (2); X=10.0D0**PEST%PARAM(I)%GALPHA(JGRAD)
   END SELECT
   F=(MSR%DHG_J(JGRAD)-MSR%PJ)/MSR%PJ*100.0D0
   WRITE(IUPESTPROGRESS,'(A2,I5,7F15.7)') FWBW(J),IGRAD,X,MSR%DHG_J(JGRAD),MSR%DHG_J(JGRAD)-MSR%DPG_J(JGRAD),MSR%DPG_J(JGRAD),MSR%PJ,MSR%DHG_J(JGRAD)-MSR%PJ,F
   !## cannot go there no significant improvement
   IF(F.GT.-1.0D0)MSR%DHG_J(JGRAD)=10.0D010
  ENDDO
 ENDDO
 
 !## determine whether centre point is the smallest
 IC=0; JGRAD=NGRAD; IGRAD=0
 DO I=1,SIZE(PEST%PARAM)
  IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE
  IGRAD=IGRAD+1; JGRAD=JGRAD+1
  !## centre
  IF(MSR%DHG_J(IGRAD).LT.MSR%PJ)THEN; IC=IGRAD; EXIT; ENDIF
  IF(MSR%DHG_J(JGRAD).LT.MSR%PJ)THEN; IC=IGRAD; EXIT; ENDIF
 ENDDO
 
 !## no improvement in search-pattern, reduce size of the legs
 IF(IC.EQ.0)THEN
  DO I=1,SIZE(PEST%PARAM)
   IF(I.EQ.1)THEN
    WRITE(IUPESTPROGRESS,'(/A/)') 'DECREASE DELTA FROM '//TRIM(VTOS(PEST%PARAM(I)%DELTAALPHA,'F',4))// &
      ' TO '//TRIM(VTOS(PEST%PARAM(I)%DELTAALPHA/2.0D0,'F',4))
   ENDIF
   PEST%PARAM(I)%DELTAALPHA=PEST%PARAM(I)%DELTAALPHA/2.0D0
  ENDDO
 ELSE
  !## find leg with biggest improvement
  CJ=MSR%PJ; IC=0; JGRAD=NGRAD; IGRAD=0
  DO I=1,SIZE(PEST%PARAM)
   IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE
   IGRAD=IGRAD+1; JGRAD=JGRAD+1
   !## forward
   IF(MSR%DHG_J(IGRAD).LT.CJ)THEN
    IC= IGRAD; CJ=MSR%DHG_J(IGRAD)
   !## backward
   ENDIF
   IF(MSR%DHG_J(JGRAD).LT.CJ)THEN
    IC=-IGRAD; CJ=MSR%DHG_J(JGRAD)
   ENDIF
  ENDDO
  WRITE(IUPESTPROGRESS,*) IC,CJ,MSR%PJ
  IF(IC.EQ.0)THEN
   WRITE(*,'(/A/)') '>>> CANNOT DETERMINE NEXT POSITION <<<'; PAUSE; STOP
  ENDIF
  
!   WRITE(IUPESTPROGRESS,'(A2,I5,F15.7)') 'FW',IC,CJ,MSR%PJ

  JGRAD=NGRAD; IGRAD=0
  DO I=1,SIZE(PEST%PARAM)
   IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE
   IGRAD=IGRAD+1; JGRAD=JGRAD+1
   IF(IGRAD.EQ.ABS(IC))THEN

    SELECT CASE (PEST%PARAM(I)%PLOG)
     CASE (0); X=PEST%PARAM(I)%GALPHA(JGRAD)
     CASE (1); X=EXP(PEST%PARAM(I)%GALPHA(JGRAD))
     CASE (2); X=10.0D0**PEST%PARAM(I)%GALPHA(JGRAD)
    END SELECT
    F=(MSR%DHG_J(JGRAD)-MSR%PJ)/MSR%PJ*100.0D0

    J=1; IF(IC.LT.0)J=2
    WRITE(IUPESTPROGRESS,'(/A2,I5,7F15.7/)') FWBW(J),ABS(IC),X,MSR%DHG_J(JGRAD),MSR%DHG_J(JGRAD)-MSR%DPG_J(JGRAD),MSR%DPG_J(JGRAD),MSR%PJ,MSR%DHG_J(JGRAD)-MSR%PJ,F
    
    IF(IC.GT.0)PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%GALPHA(IGRAD)
    IF(IC.LT.0)PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%GALPHA(JGRAD)
    
    EXIT
    
   ENDIF
  ENDDO
 ENDIF

 CALL FLUSH(IUPESTPROGRESS)
 
 !## copy gradients to all groups
 DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE
  DO J=1,SIZE(PEST%PARAM)
   IF(ABS(PEST%PARAM(J)%PIGROUP).EQ.PEST%PARAM(I)%PIGROUP)PEST%PARAM(J)%ALPHA(1)=PEST%PARAM(I)%ALPHA(1)
  ENDDO
 ENDDO
 
 !## copy alphas to correct vector with updates per lambda
! WRITE(IUPESTPROGRESS,*) '==============================================='
 DO I=1,SIZE(PEST%PARAM)
  PEST%PARAM(I)%LALPHA(:)=PEST%PARAM(I)%ALPHA(1)
!  WRITE(IUPESTPROGRESS,*) I,EXP(PEST%PARAM(I)%ALPHA(1))
 ENDDO
! WRITE(IUPESTPROGRESS,*) '==============================================='
 
 IPEST_PATTERN_SEARCH=1
 
 END FUNCTION IPEST_PATTERN_SEARCH
 
 !###====================================================================
 INTEGER FUNCTION IPEST_GLM_GRADIENT(IBATCH,ITER,LAMBDA,LAMBDA_GAMMA,DIR)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ITER,IBATCH
 REAL(KIND=DP_KIND),INTENT(INOUT) :: LAMBDA
 REAL(KIND=DP_KIND),INTENT(IN) :: LAMBDA_GAMMA
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 REAL(KIND=DP_KIND) :: DJ1,DJ2,TS,DF1,EIGWTHRESHOLD,W,H1,H2,MARQUARDT,P1,P2,PMIN,PMAX,SS,F,F1,F2
 INTEGER :: I,J,K,NP,IP1,NE,ISING,ILAMBDA,IBND,IPARAM
 INTEGER,ALLOCATABLE,DIMENSION(:) :: INDX 
 CHARACTER(LEN=1) :: TXT
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: JQJ,DF
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: U
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: JS,P,PT
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: N,RU 
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: S
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: EIGV,B,M 
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: EIGW,JQR
 LOGICAL :: LSVD

 IPEST_GLM_GRADIENT=0
 
 SELECT CASE (PEST%PE_SCALING)
  CASE (0,1); LSVD=.FALSE.
  CASE (2,3); LSVD=.TRUE.
 END SELECT
 
 !## sensitivity
 NP=0; DO I=1,SIZE(PEST%PARAM); IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE; NP=NP+1; ENDDO
 IF(.NOT.ALLOCATED(S)) ALLOCATE(S(NP))
 
 WRITE(*,'(A)') '     >>> Computing Sensitivities on '//TRIM(VTOS(UTL_OMP_GET_MAX_THREADS()))//' threads'

 S=0.0D0; IPARAM=0
 DO I=1,SIZE(PEST%PARAM)
  IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE

  DF1=PEST%PARAM(I)%PDELTA

  IPARAM=IPARAM+1

  TS=0.0D0
  SS=0.0D0  
  DO J=1,MSR%NOBS
   W=MSR%W(J); H1=MSR%HG(IPARAM,J); H2=MSR%HL(0,J) 
   TS=TS+(W*((H1-H2)/DF1))
  ENDDO
  SS=SS+TS
  S(IPARAM)=SS
 
  F=REAL(IPARAM,8)/REAL(NP,8); WRITE(6,'(A,F10.2,A)') '+     >>> Progress ',F*100.0D0,'%'
  
 ENDDO

 WRITE(*,'(A)') '     >>> Computing Sensitivities on '//TRIM(VTOS(UTL_OMP_GET_MAX_THREADS()))//' threads <<<'

 DO I=1,NP; S(I)=S(I)/DBLE(MSR%NOBS); ENDDO
 
 TS=SUM(ABS(S)); IPARAM=0; DO I=1,SIZE(PEST%PARAM)
  !## skip inactive parameters
  IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE; IPARAM=IPARAM+1; IF(TS.NE.0.0D0)S(IPARAM)=S(IPARAM)/TS
 ENDDO; S=ABS(S)*100.0D0
 WRITE(IUPESTSENSITIVITY,'(I9,6X,99999F15.3)') ITER,(S(I),I=1,NP)

 IPARAM=0; DO I=1,SIZE(PEST%PARAM)
  IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE; IPARAM=IPARAM+1
  !## remove sensitivities of zero
  IF(S(IPARAM).LE.0.0D0)PEST%PARAM(I)%PACT=-1
 ENDDO

 !##===================
 !## write statistics of ALL parameters prior to the update
 !##===================
 NP=0; DO I=1,SIZE(PEST%PARAM); IF(PEST%PARAM(I)%PIGROUP.GT.0)NP=NP+1; ENDDO
 IF(ALLOCATED(JQJ))DEALLOCATE(JQJ);   ALLOCATE(JQJ (NP,NP))
 IF(ALLOCATED(EIGW))DEALLOCATE(EIGW); ALLOCATE(EIGW(NP   ))
 IF(ALLOCATED(EIGV))DEALLOCATE(EIGV); ALLOCATE(EIGV(NP,NP))

 !## write statistics (covariance/correlation) - compute those in normal space
 CALL IPEST_GLM_JQJ_FULL(IBATCH,ITER,MARQUARDT,JQJ,NP,.TRUE.,DIR,LSVD,EIGW,EIGV)
 
 IF(PEST%PE_MXITER.EQ.0)RETURN

 !## reset insensitive parameters to log them in a list
 IPARAM=0; DO I=1,SIZE(PEST%PARAM)
  IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE; IPARAM=IPARAM+1
  !## remove sensitivities of zero
  IF(S(IPARAM).LE.0.0D0)PEST%PARAM(I)%PACT=1
 ENDDO
 
 !## reset parameters - alpha(2)=previous alpha
 DO I=1,SIZE(PEST%PARAM); PEST%PARAM(I)%ALPHA(1)=PEST%PARAM(I)%ALPHA(2); ENDDO

 !## "freeze"-insensitive parameters according to a specified sens.-criterion
 K=0; IPARAM=0; DO I=1,SIZE(PEST%PARAM)
  IF(ABS(PEST%PARAM(I)%PACT).NE.1)CYCLE; IPARAM=IPARAM+1
  IF(S(IPARAM).LE.ABS(PEST%PE_SENS))THEN
   PEST%PARAM(I)%PACT=-1; K=K+1
   IF(K.EQ.1)THEN
    WRITE(IUPESTOUT,'(/A)') 'List of Insensitive Parameter (Sensitivity <= '//TRIM(VTOS(ABS(PEST%PE_SENS),'F',7))//' %)'
    IF(PEST%PE_SENS.GE.0.0D0)WRITE(IUPESTOUT,'(A/)') ' turned off TEMPORARILY'
    IF(PEST%PE_SENS.LT.0.0D0)WRITE(IUPESTOUT,'(A/)') ' turned off PERMENANTLY'
   ENDIF
   IF(PEST%PE_SENS.LT.0.0D0)PEST%PARAM(I)%INSENS=1
   WRITE(IUPESTOUT,'(A15,F15.7,A2)') PEST%PARAM(I)%ACRONYM,S(IPARAM),' %'
  ENDIF
 ENDDO

 WRITE(IUPESTOUT,'(/A)') 'Compute Parameters for Lambdas'
 
 !## set boundaries for parameters
 DO I=1,SIZE(PEST%PARAM); CALL IPEST_GLM_GETBOUNDARY(I,IBND,P1,P2,PMIN,PMAX); PEST%PARAM(I)%IBND=IBND; ENDDO

 !## initiate number of parameters
 NP=0; DO I=1,SIZE(PEST%PARAM); IF(PEST%PARAM(I)%PIGROUP.GT.0)NP=NP+1; ENDDO

 IF(ALLOCATED(JQJ))DEALLOCATE(JQJ);   ALLOCATE(JQJ (NP,NP ))
 IF(ALLOCATED(JQR))DEALLOCATE(JQR);   ALLOCATE(JQR (NP    ))
 IF(ALLOCATED(U  ))DEALLOCATE(U);     ALLOCATE(U   (NP    ))
 
 !## compute update vector for lambdas
 ILAMBDA=0
 DO 
  
  ILAMBDA=ILAMBDA+1
  !## finished
  IF(ILAMBDA.GT.PBMAN%NLAMBDASEARCH)EXIT
  
  IF(LAMBDA.LT.0.0D0)THEN
   WRITE(*,*) 'LAMBDA < 0 IS NOT POSSIBLE'; PAUSE
  ENDIF
  
  WRITE(*,'(A)') '  >>> Computing JQr on '//TRIM(VTOS(UTL_OMP_GET_MAX_THREADS()))//' threads <<<'

  !## construct jTqr (<--- r is residual for current parameter set)
  JQR=0.0; I=0; IPARAM=0
  DO IP1=1,SIZE(PEST%PARAM)  !## row
   IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
   I=I+1
   IF(ABS(PEST%PARAM(IP1)%PACT).EQ.1)THEN
    IPARAM=IPARAM+1
    IF(PEST%PARAM(IP1)%PACT.EQ.1)THEN
     DF1=PEST%PARAM(IP1)%PDELTA
     TS=0.0D0
     SS=0.0D0
     DO J=1,MSR%NOBS
      H1=MSR%HG(IPARAM,J); H2=MSR%HL(0,J)
      DJ1=(H1-H2)/DF1    ; DJ2=MSR%DHL(0,J) 
      W  =MSR%W(J)
      TS=TS+(DJ1*W*DJ2)
     ENDDO
     SS=SS+TS
    ELSE
     SS=0.0D0
    ENDIF
   ELSE
    SS=0.0D0
   ENDIF
   JQR(I)=JQR(I)+SS
  ENDDO

  !## add parameter regularisation (not in gradient-simulations: why not?, should be!)
  IF(PEST%PE_REGULARISATION.NE.0)THEN 

   !## insert regularisation to objective function
   NP=0; DO I=1,SIZE(PEST%PARAM); IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE; NP=NP+1; ENDDO
  
   ALLOCATE(DF(NP,1)); DF=0.0D0
  
   !## total weight observations
   MU=MU_INI 
  
   NP=0; DO I=1,SIZE(PEST%PARAM)  !## row
    !## skip others parts of parameter only from groups
    IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE
    NP=NP+1
    F1=PEST%PARAM(I)%ALPHA(2) !IGRAD)
    !## add balance-weighting
    F2=PEST%PARAM(I)%PPRIOR
    SELECT CASE (PEST%PE_REGULARISATION)
     !## homogenization
     CASE (1)
      !## objective (homogenization)
      DF(NP,1)=0.0D0-F1
     !## preferred parameter
     CASE (2)
      !## minimal error compared to prior value
!      DF(NP,1)=0.0D0-(F1-F2)
      DF(NP,1)=F2-F1
    END SELECT
   ENDDO
  
   DF=MATMUL(MATMUL(QO,QR),DF)
   JQR=JQR+DF(:,1)
   
   DEALLOCATE(DF)
  
  ENDIF

  WRITE(*,'(A)') '      End Computing JQr <<<'
  !## try to come with some suitable lambdas
  DO

   !## set marquardt-lambda (cannot become negative)
   MARQUARDT=MAX(LAMBDA*PBMAN%LAMBDA_TEST(ILAMBDA),0.0D0)

   WRITE(*,'(A)') 'Computing lambda '//TRIM(VTOS(LAMBDA,'F',7))//'; MARQUARDT is '//TRIM(VTOS(MARQUARDT,'F',7))

   !## construct jqj - normal matrix/hessian
   CALL IPEST_GLM_JQJ_FULL(IBATCH,ITER,MARQUARDT,JQJ,NP,.FALSE.,DIR,LSVD,EIGW,EIGV)
   
   !## project on important singular values
   IF(LSVD)THEN

    !## add eigenvalue decomposition
    WRITE(*,'(A)') 'Computing eigenvalues '//TRIM(VTOS(NP))//'x'//TRIM(VTOS(NP))//' matrix'
    CALL IPEST_GLM_EIGDECOM(IBATCH,JQJ,EIGW,EIGV,NP,.TRUE.) 
    !## make percentage of eigenvalues
    EIGW=(EIGW*100.0D0)/SUM(EIGW)  

    EIGWTHRESHOLD=0.0D0 !% explained variance
    DO NE=1,NP
     IF(EIGW(NE).LE.0.0D0)EXIT
     EIGWTHRESHOLD=EIGWTHRESHOLD+EIGW(NE); IF(EIGWTHRESHOLD.GE.PBMAN%EIGV)EXIT
    ENDDO
    NE=MIN(NE,NP)
    
    WRITE(IUPESTOUT,'(A)') 'Problem projected on '//TRIM(VTOS(NE))//' eigenvalues (out of '//TRIM(VTOS(NP))//')'
    
    ALLOCATE(P(NP,NE)); P(:,1:NE)=EIGV(:,1:NE); ALLOCATE(M(NE,NE),N(NE),RU(NE),PT(NE,NP))

    !## compute pp=pt(jqj) on eigen-space
    PT=0.0; DO I=1,NE; DO J=1,NP
     DO K=1,NP
      PT(I,J)=PT(I,J)+P(K,I)*JQJ(K,J)
     ENDDO
    ENDDO; ENDDO
    !## project jqj on eigen-space
    M=0.0; DO I=1,NE; DO J=1,NE
     DO K=1,NP
      M(I,J)=M(I,J)+PT(I,K)*P(K,J)
     ENDDO
    ENDDO; ENDDO
    !## project right hand side on eigenspace
    N=0.0; DO I=1,NE
     DO K=1,NP
      N(I)=N(I)+P(K,I)*JQR(K)
     END DO
    ENDDO

    !## compute inverse of (Pt(JQJ)P)-1 -> B
    IF(ALLOCATED(INDX))DEALLOCATE(INDX); ALLOCATE(INDX(NE))
    IF(ALLOCATED(B   ))DEALLOCATE(B);    ALLOCATE(B   (NE,NE))
    CALL IPEST_LUDECOMP_DBL(M,INDX,NE,ISING)
    IF(ISING.EQ.1)THEN; CALL IPEST_GLM_ERROR(IBATCH,'Singular matrix after projection on eigenvectors which is rather odd, stopped.'); IPEST_GLM_GRADIENT=-1; RETURN; ENDIF
    B=0.0D0; DO I=1,NE; B(I,I)=1.0D0; ENDDO
    DO I=1,NE; CALL IPEST_LUBACKSUB_DBL(M,INDX,B(1,I),NE); ENDDO

    !## compute U=(M)-1*N
    RU=0.0D0; DO I=1,NE; DO J=1,NE
     RU(I)=RU(I)+(B(J,I)*N(J))
    ENDDO; ENDDO

!    do j=1,ne; write(*,*) (b(i,j),i=1,ne); enddo
    
    !## reproject reduced gradient on original space
    !## compute U=(M)-1*N
    U=0.0D0; DO I=1,NP; DO J=1,NE
     U(I)=U(I)+(P(I,J)*RU(J))
    ENDDO; ENDDO

    DEALLOCATE(P,PT,M,N,RU,INDX,B)
  
   ELSE

    !## compute inverse of (JQJ)-1 -> B
    IF(ALLOCATED(INDX))DEALLOCATE(INDX); ALLOCATE(INDX(NP))
    IF(ALLOCATED(B))DEALLOCATE(B); ALLOCATE(B(NP,NP))
    IF(NP.EQ.1)THEN
     B(1,1)=1.0D0/JQJ(1,1)
    ELSE
     CALL IPEST_LUDECOMP_DBL(JQJ,INDX,NP,ISING)
     IF(ISING.EQ.1)THEN; CALL IPEST_GLM_ERROR(IBATCH,'Singular matrix,try activating the SVD option to avoid this, stopped.'); IPEST_GLM_GRADIENT=-1; RETURN; ENDIF
     B=0.0D0; DO I=1,NP; B(I,I)=1.0D0; ENDDO
     DO I=1,NP; CALL IPEST_LUBACKSUB_DBL(JQJ,INDX,B(1,I),NP); ENDDO
    ENDIF
    
    !## compute (JQJ)-1*JQR
    U=0.0D0
    DO I=1,NP; DO J=1,NP
     U(I)=U(I)+(B(J,I)*JQR(J))
    ENDDO; ENDDO

    DEALLOCATE(INDX,B)

   ENDIF

   !## pointing downhill
   U=-1.0D0*U 

   !## store gradient update vector in list
   I=IPEST_GLM_UPGRADEVECTOR_LAMBDA(ILAMBDA,U)
   SELECT CASE (I)
    !## step inappropriate (too large) try another lambda   
    CASE (0)
     LAMBDA=LAMBDA*LAMBDA_GAMMA
    !## approved step
    CASE (1)
     EXIT
    !## try the same lambda without the excluded parameter due to a boundary hit
    CASE (2)
     ILAMBDA=ILAMBDA-1
     EXIT
   END SELECT
 
  ENDDO
 ENDDO !## lambda-test-loop

 WRITE(IUPESTOUT,'(/A/)') ' *** BEGIN LAMBDA CYCLE ***'; WRITE(*,'(/A/)') ' *** BEGIN LAMBDA CYCLE ***'

 !## print parameters for lambda testing
 WRITE(IUPESTOUT,'(15X,99(1X,A15))') ('LAMBDA'//TRIM(VTOS(J)),J=1,PBMAN%NLAMBDASEARCH)
 WRITE(IUPESTOUT,'(A15,99(1X,F15.7))') 'Parameters',(LAMBDA*PBMAN%LAMBDA_TEST(J),J=1,PBMAN%NLAMBDASEARCH)
 WRITE(IUPESTOUT,'(999A1)') ('-',I=1,15+16*(PBMAN%NLAMBDASEARCH))
 DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE 
  TXT=''; IF(PEST%PARAM(I)%PACT.EQ.0)TXT='*'
  IF(PEST%PARAM(I)%PLOG.EQ.0)THEN
   WRITE(IUPESTOUT,'(A15,A1,99(F15.7,1X))') PEST%PARAM(I)%ACRONYM,TXT,(PEST%PARAM(I)%LALPHA(J),J=1,PBMAN%NLAMBDASEARCH)
  ELSEIF(PEST%PARAM(I)%PLOG.EQ.1)THEN
   WRITE(IUPESTOUT,'(A15,A1,99(F15.7,1X))') PEST%PARAM(I)%ACRONYM,TXT,(EXP(PEST%PARAM(I)%LALPHA(J)),J=1,PBMAN%NLAMBDASEARCH)
  ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
   WRITE(IUPESTOUT,'(A15,A1,99(F15.7,1X))') PEST%PARAM(I)%ACRONYM,TXT,(10.0D0**(PEST%PARAM(I)%LALPHA(J)),J=1,PBMAN%NLAMBDASEARCH)
  ENDIF
 ENDDO
 WRITE(IUPESTOUT,'(/A/)') 'AN * MEANS THAT THE PARAMETER IS INACTIVE'

 IF(IUPESTOUT.GT.0)FLUSH(IUPESTOUT)
 
 IF(ALLOCATED(JQJ)) DEALLOCATE(JQJ )
 IF(ALLOCATED(U  )) DEALLOCATE(U   )
 IF(ALLOCATED(EIGW))DEALLOCATE(EIGW)
 IF(ALLOCATED(EIGV))DEALLOCATE(EIGV)
 IF(ALLOCATED(JQR ))DEALLOCATE(JQR )
 IF(ALLOCATED(S   ))DEALLOCATE(S   )
 IF(ALLOCATED(JS  ))DEALLOCATE(JS  )

 IPEST_GLM_GRADIENT=1

 END FUNCTION IPEST_GLM_GRADIENT
 
 !###====================================================================
 SUBROUTINE IPEST_GLM_GETBOUNDARY(IP1,IBND,P1,P2,PMIN,PMAX)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IP1
 INTEGER,INTENT(OUT) :: IBND
 REAL(KIND=DP_KIND),INTENT(OUT) :: P1,P2,PMIN,PMAX
 
 !## parameter adjustment hit the parameter boundary
 P1  =PEST%PARAM(IP1)%ALPHA(1)
 P2  =PEST%PARAM(IP1)%ALPHA(2)
 PMIN=PEST%PARAM(IP1)%PMIN
 PMAX=PEST%PARAM(IP1)%PMAX
   
 IBND=0
 !## shoot over
 IF(P1.LE.PMIN)IBND=-1
 IF(P1.GE.PMAX)IBND= 1

! !## too close
! IF(ABS(P1-PMIN).LE.XPBND)IBND=-1; IF(ABS(PMAX-P1).LE.XPBND)IBND= 1
 
 END SUBROUTINE IPEST_GLM_GETBOUNDARY
 
 !###====================================================================
 INTEGER FUNCTION IPEST_GLM_UPGRADEVECTOR_LAMBDA(ILAMBDA,U)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ILAMBDA
 REAL(KIND=DP_KIND),DIMENSION(:),INTENT(IN) :: U
 INTEGER :: I,IP1,IP2,IBND
 REAL(KIND=DP_KIND) :: F,PMAX,PMIN,P1,P2  
 
 !## exit code
 IPEST_GLM_UPGRADEVECTOR_LAMBDA=0

 !## fill in by default 
 DO IP1=1,SIZE(PEST%PARAM); PEST%PARAM(IP1)%ALPHA(1)=PEST%PARAM(IP1)%ALPHA(2); ENDDO
 
 !## update parameters
 I=0; DO IP1=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
  I=I+1; DO IP2=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(IP1)%PIGROUP.EQ.ABS(PEST%PARAM(IP2)%PIGROUP))THEN
    PEST%PARAM(IP2)%ALPHA(1)=PEST%PARAM(IP2)%ALPHA(2)+U(I)
   ENDIF
  ENDDO
 ENDDO  

 !## check for size of adjustment
 DO IP1=1,SIZE(PEST%PARAM)
  
  !## inactive parameter
  IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
  
  !## check size of adjustment
  IF(PEST%PARAM(IP1)%PLOG.EQ.1)THEN
   F=EXP(PEST%PARAM(IP1)%ALPHA(1))/EXP(PEST%PARAM(IP1)%ALPHA(2))
  ELSEIF(PEST%PARAM(IP1)%PLOG.EQ.2)THEN
   F=10.0D0**(PEST%PARAM(IP1)%ALPHA(1))/10.0D0**(PEST%PARAM(IP1)%ALPHA(2))
  ELSE
   F=PEST%PARAM(IP1)%ALPHA(1)/PEST%PARAM(IP1)%ALPHA(2)
  ENDIF 
  !## adjustment too large try another lambda
  IF(F.LT.1.0D0/PEST%PARAM(IP1)%PINCREASE.OR. &
     F.GT.      PEST%PARAM(IP1)%PINCREASE)RETURN

  CALL IPEST_GLM_GETBOUNDARY(IP1,IBND,P1,P2,PMIN,PMAX)
  
  !## parameter hits the boundary
  IF(IBND.NE.0)THEN
   !## hits the same boundary as before - skip it
   IF(IBND.EQ.PEST%PARAM(IP1)%IBND)THEN 
    !## ignore this parameter (group) for now - reuse current lambda and search another update vector ignoring this parameters again
    IF(PEST%PARAM(IP1)%PACT.EQ.1)THEN
     PEST%PARAM(IP1)%PACT=-1; IPEST_GLM_UPGRADEVECTOR_LAMBDA=2
    ENDIF
   ENDIF
  ENDIF  
 
 ENDDO

 !## if hit to boundary, return
 IF(IPEST_GLM_UPGRADEVECTOR_LAMBDA.EQ.2)RETURN
 
 !## corrects all gradients in case limits are overwritten
 !## adjust all parameters
 DO IP1=1,SIZE(PEST%PARAM) 
  IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
  
  PMIN=PEST%PARAM(IP1)%PMIN
  PMAX=PEST%PARAM(IP1)%PMAX
   
  !## adjust in case parameter exceeds limits
  IF(PEST%PARAM(IP1)%ALPHA(1).LT.PMIN)PEST%PARAM(IP1)%ALPHA(1)=PMIN
  IF(PEST%PARAM(IP1)%ALPHA(1).GT.PMAX)PEST%PARAM(IP1)%ALPHA(1)=PMAX

 ENDDO
 
 !## copy gradients to all groups
 DO IP1=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
  DO IP2=1,SIZE(PEST%PARAM)
   IF(ABS(PEST%PARAM(IP2)%PIGROUP).EQ.PEST%PARAM(IP1)%PIGROUP)PEST%PARAM(IP2)%ALPHA(1)=PEST%PARAM(IP1)%ALPHA(1)
  ENDDO
 ENDDO
 
 !## copy alphas to correct vector with updates per lambda
 DO IP1=1,SIZE(PEST%PARAM)
  PEST%PARAM(IP1)%LALPHA(ILAMBDA)=PEST%PARAM(IP1)%ALPHA(1)
 ENDDO
 
 !## correct update gradient found
 IPEST_GLM_UPGRADEVECTOR_LAMBDA=1

 END FUNCTION IPEST_GLM_UPGRADEVECTOR_LAMBDA

 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_ECHOPARAMETERS(IBATCH,ITER,DIRP)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: ITER,IBATCH
 CHARACTER(LEN=*),INTENT(IN) :: DIRP
 INTEGER :: IP1,N,I,J,IU
 REAL(KIND=DP_KIND) :: C1,C2,C3,X 
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: GRADUPDATE
 CHARACTER(LEN=1) :: TXT
 
 IPEST_GLM_ECHOPARAMETERS=.FALSE.
 
 N=0; C1=0.0D0
 DO I=1,SIZE(PEST%PARAM)
  IF(ABS(PEST%PARAM(I)%PACT).EQ.1)THEN 
   N=N+1
   C1=C1+(PEST%PARAM(I)%ALPHA(2)-PEST%PARAM(I)%ALPHA(1))**2.0D0
  ENDIF
 ENDDO
 C1=SQRT(C1)

 IF(ITER.EQ.0)THEN
  IF(PBMAN%RESTART.NE.0)THEN
   MSR%TJ=MSR%TJRESTART; MSR%RJ=MSR%RJRESTART
  ELSE
   WRITE(IUPESTEFFICIENCY,'(4(F15.3,1X))') MSR%TJ,MSR%TJ-MSR%RJ,MSR%RJ,REAL(SQRT(MSR%TJ))/MAX(1.0D0,REAL(MSR%NOBS,8))
  ENDIF
  IF(PEST%PE_REGULARISATION.NE.0)THEN
   MSR%MU(0)=MU_INI
  ENDIF
 ELSE
  C2=(1.0D0-MSR%TJ/MSR%PJ)*100.0D0
  C3=(1.0D0-MSR%TJ/MSR%TJ_H(0))*100.0D0
  WRITE(IUPESTEFFICIENCY,'(8(F15.3,1X))') MSR%TJ,MSR%TJ-MSR%RJ,MSR%RJ,REAL(SQRT(MSR%TJ))/REAL(MSR%NOBS,8),C1,C2,C3
 ENDIF
 
 !## save alphas for history-logging
 DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PIGROUP.LT.0)CYCLE

  IF(PEST%PARAM(I)%PLOG.EQ.1)THEN
   PEST%PARAM(I)%ALPHA_HISTORY(ITER)=EXP(PEST%PARAM(I)%ALPHA(1))
  ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
   PEST%PARAM(I)%ALPHA_HISTORY(ITER)=10.0D0**(PEST%PARAM(I)%ALPHA(1))
  ELSE
   PEST%PARAM(I)%ALPHA_HISTORY(ITER)=PEST%PARAM(I)%ALPHA(1)
  ENDIF
  
 ENDDO
 
 !## replace old by new parameter values
 PEST%PARAM%ALPHA(2)=PEST%PARAM%ALPHA(1)
 
 WRITE(IUPESTOUT,'(A/)') 'Optimization History:'
 WRITE(IUPESTOUT,'(A15,6X,999(1X,5X,A7,I3.3))') 'Statistics',('ITER',I,I=ITER,0,-1)
 WRITE(IUPESTOUT,'(999A1)') ('-',I=1,21+(ITER+1)*16)
  
 IF(MSR%NOBS.GT.0)THEN
  WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.3))') 'Total Obj. Val.',(MSR%TJ_H(I),I=ITER,0,-1)
  WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.3))') 'Lim. Obj. Val. ',(MSR%LIMJ,I=ITER,0,-1)
  IF(PEST%PE_REGULARISATION.NE.0)THEN
   WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.3))') 'Meas. Obj. Val.',(MSR%TJ_H(I)-MSR%RJ_H(I),I=ITER,0,-1)
   WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.3))') 'Param Obj. Val.',(MSR%RJ_H(I),I=ITER,0,-1)
   WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.7))') 'Tikhonov W.Fact',(MSR%MU(I),I=ITER,0,-1)
   WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.3))') 'ScaledPObj.Val.',(MSR%RJ_H(I)/MSR%MU(I),I=ITER,0,-1)
  ENDIF
  WRITE(IUPESTOUT,'(A15,6X,99(1X,I15))')   'Number of Obs. ',(MSR%NOBS,I=ITER,0,-1)
  WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.3))') 'Goodness of Fit',(MSR%GOF_H(I),I=ITER,0,-1)
  WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.3))') 'Nash Sutcliffe ',(MSR%NSC_H(I),I=ITER,0,-1)
 ELSE
  WRITE(IUPESTOUT,'(A15,6X,99(1X,I15))')   'Number of Obs. ',(MSR%NOBS,I=ITER,0,-1)
 ENDIF
 WRITE(IUPESTOUT,'(A15,6X,99(1X,I15))')   'Positive Score  ',(MSR%SCORE(1,I),I=ITER,0,-1)
 WRITE(IUPESTOUT,'(A15,6X,99(1X,I15))')   'Negative Score  ',(MSR%SCORE(2,I),I=ITER,0,-1)
 
 WRITE(IUPESTOUT,'(/A15,1X,A5,999(1X,5X,A7,I3.3))') 'Parameter','Score',('ITER',I,I=ITER,0,-1)
 WRITE(IUPESTOUT,'(999A1)') ('-',I=1,21+(ITER+1)*16)

 ALLOCATE(GRADUPDATE(ITER)); GRADUPDATE=0.0D0
 N=0
 DO IP1=1,SIZE(PEST%PARAM)

  WRITE(BLINE,'(99(F15.7,1X))') (PEST%PARAM(IP1)%ALPHA_HISTORY(I),I=ITER,0,-1)
  
  IF(PEST%PARAM(IP1)%PIGROUP.GT.0)THEN 
   TXT=''; IF(PEST%PARAM(IP1)%PACT.EQ.0)TXT='#'
   WRITE(IUPESTOUT,'(A15,A1,1X,A5,A)') PEST%PARAM(IP1)%ACRONYM,TXT,PEST%PARAM(IP1)%SCORE,TRIM(BLINE)
   N=N+1
   DO I=1,ITER
    GRADUPDATE(I)=GRADUPDATE(I)+(PEST%PARAM(IP1)%ALPHA_HISTORY(I)-PEST%PARAM(IP1)%ALPHA_HISTORY(I-1))**2.0D0
   ENDDO
  ENDIF

 ENDDO
 WRITE(IUPESTOUT,'(/A/)') 'AN * MEANS THAT THE PARAMETER IS INACTIVE'
 
 GRADUPDATE=SQRT(GRADUPDATE)
 WRITE(IUPESTOUT,'(999A1)') ('-',I=1,21+(ITER+1)*16)
 WRITE(IUPESTOUT,'(A15,6X,99(1X,F15.7)/)') 'Adjustment',(GRADUPDATE(I),I=ITER,1,-1)

 DEALLOCATE(GRADUPDATE)

 !## write gen
 ALLOCATE(GRADUPDATE(N)); GRADUPDATE=0.0D0
 IU=UTL_GETUNIT(); OPEN(IU,FILE=TRIM(DIRP)//'\IPEST.GEN',ACTION='WRITE',STATUS='REPLACE')
 WRITE(IU,'(A)') '1'
 DO I=0,ITER
  N=0; DO IP1=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(IP1)%PIGROUP.GT.0)THEN 
    N=N+1
    GRADUPDATE(N)=LOG(PEST%PARAM(IP1)%ALPHA_HISTORY(I))
   ENDIF
  ENDDO
  WRITE(IU,'(999(F10.2,1X))') (GRADUPDATE(IP1),IP1=1,N)
 ENDDO
 WRITE(IU,'(A)') 'END'
 WRITE(IU,'(A)') 'END'
 CLOSE(IU)
 
 WRITE(IUPESTRUNFILE,'(/A,I10/)') 'Copy in the runfile, iteration ',ITER
 DO I=1,SIZE(PEST%PARAM)
  J=MAX(0,MIN(1,ABS(PEST%PARAM(I)%PACT)))
  
  X=PEST%PARAM(I)%ALPHA(1)
!  !## reset to value 1 as this parameters is not assignable
!  IF(INDEX(PEST%PARAM(I)%SCORE,'-').GT.0)THEN
!   IF(PEST%PARAM(I)%PLOG.EQ.1)THEN
!    X=LOG(1.0D0)
!   ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
!    X=LOG10(1.0D0)
!   ELSE
!    X=1.0D0
!   ENDIF
!  ENDIF
  
  IF(PEST%PARAM(I)%PLOG.EQ.1)THEN
   WRITE(IUPESTRUNFILE,'(I2,1X,A,1X,I5,1X,I7,1X,5(F10.3,1X),I7,1X,I2,1X,A15,2F10.3,2A15)') J, &  !## iact
       PEST%PARAM(I)%PPARAM, &         !## ptype
       PEST%PARAM(I)%PILS, &           !## ilayer/system
       PEST%PARAM(I)%PIZONE, &         !## zone number
       EXP(X), &  !## initial value
       EXP(PEST%PARAM(I)%PDELTA), &    !## finite difference step
       EXP(PEST%PARAM(I)%PMIN), &      !## minimal value
       EXP(PEST%PARAM(I)%PMAX),&       !## maximal value
       PEST%PARAM(I)%PINCREASE,&       !## maximal adjust factor
       ABS(PEST%PARAM(I)%PIGROUP),&    !## group number
       PEST%PARAM(I)%PLOG,&            !## log transformed
       TRIM(PEST%PARAM(I)%ACRONYM), &
       EXP(PEST%PARAM(I)%PPRIOR), &
       EXP(PEST%PARAM(I)%PARSTD), &
       TRIM(PEST%PARAM(I)%SDATE), &
       TRIM(PEST%PARAM(I)%EDATE)//','// &
       TRIM(VTOS(PEST%PARAM(I)%PORG,'G',7))
  ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
   WRITE(IUPESTRUNFILE,'(I2,1X,A,1X,I5,1X,I7,1X,5(F10.3,1X),I7,1X,I2,1X,A15,2F10.3,2A15)') J, &  !## iact
       PEST%PARAM(I)%PPARAM, &              !## ptype
       PEST%PARAM(I)%PILS, &                !## ilayer/system
       PEST%PARAM(I)%PIZONE, &              !## zone number
       10.0D0**(X), &  !## initial value
       10.0D0**(PEST%PARAM(I)%PDELTA), &    !## finite difference step
       10.0D0**(PEST%PARAM(I)%PMIN), &      !## minimal value
       10.0D0**(PEST%PARAM(I)%PMAX),&       !## maximal value
       PEST%PARAM(I)%PINCREASE,&            !## maximal adjust factor
       ABS(PEST%PARAM(I)%PIGROUP),&         !## group number
       PEST%PARAM(I)%PLOG,&                 !## log transformed
       TRIM(PEST%PARAM(I)%ACRONYM), &
       10.0D0**(PEST%PARAM(I)%PPRIOR), &
       10.0D0**(PEST%PARAM(I)%PARSTD), &
       TRIM(PEST%PARAM(I)%SDATE), &
       TRIM(PEST%PARAM(I)%EDATE)//','// &
       TRIM(VTOS(PEST%PARAM(I)%PORG,'G',7))
  ELSE
   WRITE(IUPESTRUNFILE,'(I2,1X,A,1X,I5,1X,I7,1X,5(F10.3,1X),I7,1X,I2,1X,A15,2F10.3,2A15)') J, &  !## iact
       PEST%PARAM(I)%PPARAM, &      !## ptype
       PEST%PARAM(I)%PILS, &        !## ilayer/system
       PEST%PARAM(I)%PIZONE, &      !## zone number
       X, &    !## initial value
       PEST%PARAM(I)%PDELTA, &      !## finite difference step
       PEST%PARAM(I)%PMIN, &        !## minimal value
       PEST%PARAM(I)%PMAX,&         !## maximal value
       PEST%PARAM(I)%PINCREASE,&    !## maximal adjust factor
       ABS(PEST%PARAM(I)%PIGROUP),& !## group number
       PEST%PARAM(I)%PLOG, &        !## log transformed
       TRIM(PEST%PARAM(I)%ACRONYM), &
       PEST%PARAM(I)%PPRIOR, &
       PEST%PARAM(I)%PARSTD, &
       TRIM(PEST%PARAM(I)%SDATE), &
       TRIM(PEST%PARAM(I)%EDATE)//','// &
       TRIM(VTOS(PEST%PARAM(I)%PORG,'G',7))
  ENDIF 
 ENDDO

 IF(IUPESTOUT.GT.0)FLUSH(IUPESTOUT);                 IF(IUPESTPROGRESS.GT.0)FLUSH(IUPESTPROGRESS); IF(IUPESTEFFICIENCY.GT.0)FLUSH(IUPESTEFFICIENCY)
 IF(IUPESTSENSITIVITY.GT.0)FLUSH(IUPESTSENSITIVITY); IF(IUPESTRUNFILE.GT.0)FLUSH(IUPESTRUNFILE);   IF(IUPESTJACOBIAN.GT.0)FLUSH(IUPESTJACOBIAN)

 IF(ITER.GT.0)THEN
  WRITE(*,'(/A/)') 'Current Obj.Func. '//TRIM(VTOS(MSR%TJ,'F',7))//'; current/total improvement '//TRIM(VTOS(C2,'F',7))//';'//TRIM(VTOS(C3,'F',7))//'%'
  !## continue ?
  IF(ITER+1.GT.PEST%PE_MXITER)THEN
   CALL IPEST_GLM_ERROR(IBATCH,'Pest iteration terminated: PEST_ITER (='//TRIM(VTOS(PEST%PE_MXITER))//') = PEST_NITER (='// &
     TRIM(VTOS(PEST%PE_MXITER))//')'); RETURN
  ENDIF
  C2=(1.0D0-MSR%TJ_H(ITER-1)/MSR%TJ_H(0))*100.0D0
  C3=(1.0D0-MSR%TJ_H(ITER  )/MSR%TJ_H(0))*100.0D0
  C1=C3-C2
!  IF(PEST%PE_REGULARISATION.EQ.0)THEN
  IF(MSR%TJ_H(ITER).LT.PEST%PE_STOP)THEN
   CALL IPEST_GLM_ERROR(IBATCH,'Pest iteration terminated as objective function ('//TRIM(VTOS(MSR%TJ_H(ITER),'G',7))// &
        ' m2) <= PEST_JSTOP ('//TRIM(VTOS(PEST%PE_STOP,'G',7))//' m2)'); RETURN
  ENDIF
!  ENDIF
 ENDIF
 
 IF(MSR%NOBS.EQ.0)MSR%TJ=0.0D0
 
 IF(MSR%TJ.LE.0.0D0)THEN
  CALL IPEST_GLM_ERROR(IBATCH,'Objective Function <= 0.0 ('//TRIM(VTOS(MSR%TJ,'G',7))//')'); RETURN
 ENDIF

 !## next iteration
 WRITE(IUPESTOUT,'(/A/)') ' *** NEXT OPTIMIZATION CYCLE '//TRIM(VTOS(ITER+1))//' ***'
 WRITE(*,'(/A/)')         ' *** NEXT OPTIMIZATION CYCLE '//TRIM(VTOS(ITER+1))//' ***'

 IPEST_GLM_ECHOPARAMETERS=.TRUE.
 
 END FUNCTION IPEST_GLM_ECHOPARAMETERS
 
 !###====================================================================
 SUBROUTINE IPEST_GLM_FILL_JACOBIAN()
 !###====================================================================
 IMPLICIT NONE
 LOGICAL :: LEX
 INTEGER :: IP1,IPARAM,I,J
 CHARACTER(LEN=15),ALLOCATABLE,DIMENSION(:) :: CPARAM
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: X
 
 LEX=.FALSE.
 IF(PBMAN%BOSS.EQ.1.AND.PBMAN%NWORKERS.EQ.0)LEX=.TRUE.
 IF(PBMAN%BOSS.EQ.0)LEX=.TRUE.
 IF(LEX)THEN
  IPARAM=0; DO IP1=1,SIZE(PEST%PARAM); IF(ABS(PEST%PARAM(IP1)%PACT).NE.1)CYCLE; IPARAM=IPARAM+1; ENDDO
  ALLOCATE(CPARAM(IPARAM),X(IPARAM))
  WRITE(*,'(A)') '  >>> Exporting Jacobians to a TXT file'
  IF(PBMAN%IPESTMETHOD.EQ.3)THEN
   !## number of observations and parameters
   WRITE(IUPESTJACOBIAN,'(3A10)') 'NBR_OBS','NPARAMS','NSIM'
   !## total number of active parameters
   WRITE(IUPESTJACOBIAN,'(3I10)') MSR%NOBS,IPARAM,IPARAM+1
  ELSE
   !## number of observations and parameters
   WRITE(IUPESTJACOBIAN,'(2A10)') 'NBR_OBS','NPARAMS'
   !## total number of active parameters
   WRITE(IUPESTJACOBIAN,'(2I10)') MSR%NOBS,IPARAM
  ENDIF
  IF(PBMAN%IPESTMETHOD.EQ.3)THEN
   WRITE(IUPESTJACOBIAN,'(/99A10)') 'SIMUL.',('FCT'//TRIM(VTOS(I)),I=1,SIZE(CPARAM))
   !## set pini
   X=0.0D0; IPARAM=0; DO IP1=1,SIZE(PEST%PARAM)      
    IF(ABS(PEST%PARAM(IP1)%PACT).NE.1)CYCLE
    IPARAM=IPARAM+1; X(IPARAM)=EXP(PEST%PARAM(IP1)%LALPHA(1)) !PINI)
   ENDDO
   WRITE(IUPESTJACOBIAN,'(I10,99F10.3)') 0,(X(I),I=1,SIZE(CPARAM))
   DO I=1,SIZE(CPARAM)
    !## set factors per simulation   
    X=0.0D0; IPARAM=0; DO IP1=1,SIZE(PEST%PARAM)      
     IF(ABS(PEST%PARAM(IP1)%PACT).NE.1)CYCLE
     IPARAM=IPARAM+1; X(IPARAM)=EXP(PEST%PARAM(IP1)%ALPHA_SIM(I))
    ENDDO
    WRITE(IUPESTJACOBIAN,'(I10,99F10.3)') I,(X(J),J=1,SIZE(CPARAM))
   ENDDO
  ENDIF
  IPARAM=0; DO IP1=1,SIZE(PEST%PARAM)      
   IF(ABS(PEST%PARAM(IP1)%PACT).NE.1)CYCLE
   IPARAM=IPARAM+1; CPARAM(IPARAM)=PEST%PARAM(IP1)%ACRONYM
  ENDDO
  IF(PBMAN%IPESTMETHOD.EQ.3)THEN
   WRITE(IUPESTJACOBIAN,'(/A3,A32,A15,9999(A15,1X))') 'IPF','LABEL','DATE','ACCEPT','OBSERVATION','WEIGHT','HEAD',('ENSEMBLE'//TRIM(VTOS(I)),I=1,IPARAM)
  ELSE
   WRITE(IUPESTJACOBIAN,'( A3,A32,A15,9999(A15,1X))') 'IPF','LABEL','DATE','ACCEPT','OBSERVATION','WEIGHT','HEAD',(CPARAM(I),I=1,IPARAM)
  ENDIF
  DO J=1,MSR%NOBS
   WRITE(IUPESTJACOBIAN,'(I3,A32,I15,9999(F15.3,1X))') MSR%IPF(J),ADJUSTR(MSR%CLABEL(J)),MSR%IDATE(J),MSR%D(J),MSR%O(J),MSR%W(J),MSR%HL(0,J),(MSR%HG(I,J),I=1,IPARAM)
  ENDDO   
  WRITE(*,'(A)') '      Exporting Finished Jacobians <<< '
  DEALLOCATE(CPARAM)
 ENDIF
 
 END SUBROUTINE IPEST_GLM_FILL_JACOBIAN

 !###====================================================================
 SUBROUTINE IPEST_GLM_JQJ_FULL(IBATCH,ITER,MARQUARDT,JQJ,NP,LCOV,DIR,LSVD,EIGW,EIGV) 
 !###====================================================================
 IMPLICIT NONE
 INTEGER,PARAMETER :: PRINTLIMIT=50
 REAL(KIND=DP_KIND),INTENT(IN) :: MARQUARDT
 LOGICAL,INTENT(IN) :: LSVD
 REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(NP,NP) :: JQJ,EIGV
 REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(NP) :: EIGW
 CHARACTER(LEN=*),INTENT(IN) :: DIR
 INTEGER,INTENT(IN) :: NP,IBATCH,ITER
 CHARACTER(LEN=1) :: TXT
 CHARACTER(LEN=24) :: FRM
 LOGICAL,INTENT(IN) :: LCOV
 INTEGER :: I,J,IP1,IP2,II,JJ,N,IPARAM,ISING,IERROR,IOS,I1,I2,ILS,NILS,NE,JU,JTER,ISCORE
 REAL(KIND=DP_KIND) :: DF1,DJ1,DJ2,B1,CB,W,ZW,Z1,Z2,H1,H2,F,Z,MU,EIGWTHRESHOLD,F1,F2,DZ
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: B,P,M,RB
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: COR,COV,QOQR !,LOGCOV
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: DJ
 INTEGER,ALLOCATABLE,DIMENSION(:) :: INDX
 INTEGER :: CLOCK_RATE,IROW,ICOL,NLAY,ILAY
 TYPE(IDFOBJ) :: STD !,DF
 TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: HEDP,HEDS,PRM
 
 !## save jacobian for all
 IF(LCOV)THEN
  
  !## save jacobian
  CALL IPEST_GLM_FILL_JACOBIAN()
  
  !## compute sensitivities if mxiter=0
  IF(PEST%PE_MXITER.EQ.0)THEN
   CALL UTL_CREATEDIR(TRIM(DIR)//'\SENS\')
   !## read head
   NLAY=SIZE(PBMAN%ISAVE(TSHD)%ILAY)
   ALLOCATE(HEDP(NLAY)); DO I=1,NLAY; CALL IDFNULLIFY(HEDP(I)); ENDDO
   ALLOCATE(HEDS(NLAY)); DO I=1,NLAY; CALL IDFNULLIFY(HEDS(I)); ENDDO
   ALLOCATE(PRM(2));     DO I=1,2;    CALL IDFNULLIFY(PRM(I));  ENDDO 
   !## per layer to be exported
   DO I=1,NLAY
    ILAY=PBMAN%ISAVE(TSHD)%ILAY(I)
    IF(PBMAN%IFORMAT.EQ.2.OR.PBMAN%IFORMAT.EQ.6)THEN
     HEDP(I)%FNAME=TRIM(DIR)//'\IPEST_L#1\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'
    ELSEIF(PBMAN%IFORMAT.EQ.3)THEN
     HEDP(I)%FNAME=TRIM(DIR)//'\GWF_1\MODELOUTPUT\IPEST_L#1\HEAD\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'
    ENDIF
    IF(.NOT.IDFREAD(HEDP(I),HEDP(I)%FNAME,1))THEN
     WRITE(*,'(/A/)') '>>> Cannot find '//TRIM(HEDP(I)%FNAME)//' <<<'; PAUSE; STOP
    ENDIF
   ENDDO
   IPARAM=0; DO IP1=1,SIZE(PEST%PARAM)      
    IF(ABS(PEST%PARAM(IP1)%PACT).NE.1)CYCLE
    IPARAM=IPARAM+1 
    CALL UTL_CREATEDIR(TRIM(DIR)//'\SENS\P#'//TRIM(VTOS(IP1)))
    
    !## should not be in log-space for fosm and real parameter values
    F1=EXP(PEST%PARAM(IP1)%PINI)                       *PEST%PARAM(IP1)%PORG
    F2=EXP(PEST%PARAM(IP1)%PINI+PEST%PARAM(IP1)%PDELTA)*PEST%PARAM(IP1)%PORG
    !## normal space
    DF1=F2-F1

!    ILAY=PEST%PARAM(IP1)%PILS
!    !## in case pilot points are used, use the d-alpha oojn the parameter
!    IF(PEST%PARAM(IP1)%ZTYPE.EQ.1)THEN
!     !## read prior
!     I=1; PRM(I)%FNAME=TRIM(DIR)//'\IPEST_L#1\PEST\PARAMETERS_CYCLE0\'//TRIM(PEST%PARAM(IP1)%PPARAM)//'_L'//TRIM(VTOS(ILAY))//'.IDF'
!     IF(.NOT.IDFREAD(PRM(I),PRM(I)%FNAME,1))THEN
!      WRITE(*,'(/A/)') '<<< CANNOT READ '//TRIM(PRM(I)%FNAME)//' <<<'; PAUSE; STOP
!     ENDIF
!     I=2; PRM(I)%FNAME=TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(IP1))//'\PEST\PARAMETERS_CYCLE0\'//TRIM(PEST%PARAM(IP1)%PPARAM)//'_L'//TRIM(VTOS(ILAY))//'.IDF'
!     IF(.NOT.IDFREAD(PRM(I),PRM(I)%FNAME,1))THEN
!      WRITE(*,'(/A/)') '<<< CANNOT READ '//TRIM(PRM(I)%FNAME)//' <<<'; PAUSE; STOP
!     ENDIF
!     !## sample df value from d-alpha at location of pilotpoint(s)
!     DO I=1,SIZE(PEST%PARAM(IP1)%XY,1)
!      CALL IDFIROWICOL(PRM(I),IROW,ICOL,PEST%PARAM(IP1)%XY(I,1),PEST%PARAM(IP1)%XY(I,2))
!      DF1=PRM(2)%X(ICOL,IROW)-PRM(1)%X(ICOL,IROW)
!     ENDDO
!    ENDIF
    
!    !## NIET SCHALEN NAR DELTA-ALPHA, DUS GEWOON DH LATEN ZIEN
!    DF1=1.0D0
    
    !## per layer to be exported
    DO I=1,NLAY
     ILAY=PBMAN%ISAVE(TSHD)%ILAY(I)
     IF(PBMAN%IFORMAT.EQ.2.OR.PBMAN%IFORMAT.EQ.6)THEN
      HEDS(I)%FNAME=TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(IP1))//'\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'
     ELSEIF(PBMAN%IFORMAT.EQ.3)THEN
      HEDS(I)%FNAME=TRIM(DIR)//'\GWF_1\MODELOUTPUT\IPEST_P#'//TRIM(VTOS(IP1))//'\HEAD\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'
     ENDIF    
     IF(.NOT.IDFREAD(HEDS(I),HEDS(I)%FNAME,1))THEN
      WRITE(*,'(/A/)') '>>> Cannot find '//TRIM(HEDS(I)%FNAME)//' <<<'; PAUSE; STOP
     ENDIF
     DO IROW=1,HEDS(I)%NROW; DO ICOL=1,HEDS(I)%NCOL
      
      IF(HEDS(I)%X(ICOL,IROW).NE.HEDS(I)%NODATA.AND.DF1.NE.0.0D0)THEN
       HEDS(I)%X(ICOL,IROW)=(HEDS(I)%X(ICOL,IROW)-HEDP(I)%X(ICOL,IROW))/DF1
      ELSE
       HEDS(I)%X(ICOL,IROW)=0.0D0
      ENDIF
     ENDDO; ENDDO
     HEDS(I)%FNAME=TRIM(DIR)//'\SENS\P#'//TRIM(VTOS(IP1))//'\SENS_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'
     IF(.NOT.IDFWRITE(HEDS(I),HEDS(I)%FNAME,1))THEN
      WRITE(*,'(/A/)') '>>> Cannot find '//TRIM(HEDS(I)%FNAME)//' <<<'; PAUSE; STOP
     ENDIF
     
    ENDDO
    CALL IDFDEALLOCATE(HEDS,NLAY)
   ENDDO
   CALL IDFDEALLOCATE(HEDP,NLAY)
   DO I=1,NLAY
    ILAY=PBMAN%ISAVE(TSHD)%ILAY(I)
    JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(DIR)//'\SENS\SENS_LIST_IDF_L'//TRIM(VTOS(ILAY))//'.TXT',STATUS='REPLACE')
    DO IP1=1,SIZE(PEST%PARAM)      
     IF(ABS(PEST%PARAM(IP1)%PACT).NE.1)CYCLE
     HEDS(I)%FNAME=TRIM(DIR)//'\SENS\P#'//TRIM(VTOS(IP1))//'\SENS_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'
     WRITE(JU,'(A)') TRIM(HEDS(I)%FNAME)
    ENDDO
   ENDDO
   JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(DIR)//'\SENS\COV.TXT',STATUS='REPLACE')
   WRITE(JU,'(I10,1X,A10)') IPARAM,'NPARAM'
   WRITE(JU,'(6(A10,1X),A15,2(A15,1X))') 'IPARAM','PACT','PTYPE','ILS','IZONE','IGROUP','ACRONYM','PARAM_VAL','PARAM_DVAL'
   IPARAM=0; DO IP1=1,SIZE(PEST%PARAM)      
    IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
    IPARAM=IPARAM+1
    F1=EXP(PEST%PARAM(IP1)%PINI)*PEST%PARAM(IP1)%PORG
    F2=EXP(PEST%PARAM(IP1)%PINI+PEST%PARAM(IP1)%PDELTA)*PEST%PARAM(IP1)%PORG
    WRITE(JU,'(2(I10,1X),A10,3(1X,I10),1X,A15,2(F15.7,1X))') IP1,PEST%PARAM(IP1)%PACT,PEST%PARAM(IP1)%PPARAM,PEST%PARAM(IP1)%PILS,PEST%PARAM(IP1)%PIZONE,PEST%PARAM(IP1)%PIGROUP,PEST%PARAM(IP1)%ACRONYM,F1,F2
   ENDDO
  ENDIF      
 ENDIF
 
 !## construct jqj - NORMAL MATRIX/HESSIAN - can take a while, so only in case ljqj=.true.
 WRITE(*,'(A)') '  >>> Computing JQJ on '//TRIM(VTOS(UTL_OMP_GET_MAX_THREADS()))//' threads <<<'

 CALL SYSTEM_CLOCK (I1)

 ALLOCATE(DJ(NP,MSR%NOBS)); DJ=0.0D0

 WRITE(*,'(A)') '     >>> Computing Gradients'

 DJ=0.0D0
 !## compute gradients
 I=0; IPARAM=0; DO IP1=1,SIZE(PEST%PARAM) 
  IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
  I=I+1
  IF(ABS(PEST%PARAM(IP1)%PACT).EQ.1)THEN
   IPARAM=IPARAM+1;
   IF(PEST%PARAM(IP1)%PACT.EQ.1)THEN

    IF(LCOV)THEN
     SELECT CASE (PEST%PARAM(IP1)%PLOG)
      CASE (0)
       F1=PEST%PARAM(IP1)%ALPHA(2)
       F2=PEST%PARAM(IP1)%ALPHA(2)+PEST%PARAM(IP1)%PDELTA
      CASE (1)
       F1=EXP(PEST%PARAM(IP1)%ALPHA(2))
       F2=EXP(PEST%PARAM(IP1)%ALPHA(2)+PEST%PARAM(IP1)%PDELTA)
      CASE (2)
       F1=10.0D0**(PEST%PARAM(IP1)%ALPHA(2))
       F2=10.0D0**(PEST%PARAM(IP1)%ALPHA(2)+PEST%PARAM(IP1)%PDELTA)
     END SELECT
     !## normal space
     DF1=F2-F1
    ELSE
     DF1=PEST%PARAM(IP1)%PDELTA 
    ENDIF

    DO J=1,MSR%NOBS
     H1=MSR%HG(IPARAM,J); H2=MSR%HL(0,J); DJ(I,J)=(H1-H2)/DF1
    ENDDO
   ELSE
    DJ(I,:)=0.0D0 !## insensitive set jacobian to zero
   ENDIF
  ELSE
   DJ(I,:)=0.0D0 !## inactive, set jacobian to zero for known pilot-parameters (not to be updated)
  ENDIF
  F=REAL(I,8)/REAL(NP,8); WRITE(6,'(A,F10.2,A)') '+     >>> Progress ',F*100.0D0,'%'
 ENDDO
  
 WRITE(*,'(A)') '         End Computing Gradients <<<'

!  !### TEMP
!  WRITE(IUPESTJACOBIAN,'(2A10)') 'DJ'
!  DO J=1,MSR%NOBS
!   WRITE(IUPESTJACOBIAN,'(9999F15.7)') (DJ(I,J),I=1,SIZE(DJ,1))
!  ENDDO   
!  !### TEMP
  
 WRITE(*,'(A)') '     >>> Computing Product'

 JQJ=0.0D0; N=0
 DO I=1,NP
  DO II=1,I
   DO J=1,MSR%NOBS
    DJ1=DJ(I,J); DJ2=DJ(II,J); W=MSR%W(J)
    JQJ(II,I)=JQJ(II,I)+(DJ1*W*DJ2)  
   ENDDO
  ENDDO
  N=N+1
  F=REAL(N,8)/REAL(NP,8); WRITE(6,'(A,F10.2,A)') '+     >>> Progress ',F*100.0D0,'%'
 ENDDO
  
 !## mirror results
 DO I=1,NP; DO J=I,NP; JQJ(J,I)=JQJ(I,J); ENDDO; ENDDO
  
 WRITE(*,'(A)') '         End Computing Product <<<'

 DEALLOCATE(DJ)

!  !### TEMP
!  WRITE(IUPESTJACOBIAN,'(2A10)') 'Jqj'
!  DO J=1,size(jqj,1)
!   WRITE(IUPESTJACOBIAN,'(9999F15.7)') (jqj(I,J),I=1,SIZE(Jqj,2))
!  ENDDO   
!  !### TEMP

 CALL SYSTEM_CLOCK (I2,CLOCK_RATE)
 WRITE(*,'(A)') '      Computing Finished JQJ '//TRIM(VTOS(REAL(I2-I1,8)/REAL(CLOCK_RATE,8),'F',2))//' secs. <<<'
 
 IF(.NOT.LCOV)THEN
  SELECT CASE(PEST%PE_REGULARISATION)
!   CASE (0)
!    DO I=1,NP
!     IF(JQJ(I,I).NE.0.0D0)JQJ(I,I)=JQJ(I,I)+MARQUARDT
!    ENDDO 
   !## homogenization/preferred parameter
   CASE (1,2)
    !## initial mu
    ALLOCATE(QOQR(NP,NP))
    QOQR=MATMUL(MATMUL(QO,QR),QO)
    IF(MU_INI.EQ.0.0D0)THEN
     MU_INI=IPEST_GLM_GETMU(NP,JQJ,QOQR); MSR%MU(0)=MU_INI
    ENDIF
    MU=MU_INI
    JQJ=JQJ+MU*QOQR 
    DEALLOCATE(QOQR)
  END SELECT

!  !## add marquardt
!  I=0; DO IP1=1,SIZE(PEST%PARAM)
!   IF(PEST%PARAM(IP1)%PIGROUP.GT.0.AND.PEST%PARAM(IP1)%PACT.EQ.1)THEN
!    I=I+1
!    JQJ(I,I)=JQJ(I,I)+MARQUARDT
!   ENDIF
!  ENDDO
 
  DO I=1,NP
   IF(JQJ(I,I).NE.0.0D0)JQJ(I,I)=JQJ(I,I)+MARQUARDT
  ENDDO 

 ENDIF 
 
 !## make sure matrix is invertible for inactive/insensitive parameters
 I=0
 DO IP1=1,SIZE(PEST%PARAM) 
  IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
  I=I+1
  IF(PEST%PARAM(IP1)%PACT.EQ.1)CYCLE
  !## set matrix to unity
  JQJ(I,:)=0.0D0
  JQJ(I,I)=1.0D0
 ENDDO

 IF(.NOT.LCOV)RETURN
 
 IF(LSVD)THEN

  WRITE(*,'(A)') 'Computing eigenvalues '//TRIM(VTOS(NP))//'x'//TRIM(VTOS(NP))//' matrix'

  !## add eigenvalue decomposition
  CALL IPEST_GLM_EIGDECOM(IBATCH,JQJ,EIGW,EIGV,NP,.TRUE.) 
  !## make percentage of eigenvalues
  EIGW=(EIGW*100.0D0)/SUM(EIGW)  
  EIGWTHRESHOLD=0.0D0 !% explained variance
  DO NE=1,NP
   IF(EIGW(NE).LE.0.0D0)EXIT
   EIGWTHRESHOLD=EIGWTHRESHOLD+EIGW(NE); IF(EIGWTHRESHOLD.GE.99.999990)EXIT
  ENDDO
  NE=MIN(NE,NP)
  WRITE(IUPESTOUT,'(A)') 'Problem projected on '//TRIM(VTOS(NE))//' eigenvalues (out of '//TRIM(VTOS(NP))//')'
  ALLOCATE(P(NP,NE)); P(:,1:NE)=EIGV(:,1:NE); ALLOCATE(M(NE,NE))

  M=MATMUL(MATMUL(TRANSPOSE(P),JQJ),P)

 ELSE
  ALLOCATE(M(NP,NP)); M=JQJ; NE=NP
 ENDIF
 
 IF(ALLOCATED(INDX))DEALLOCATE(INDX); ALLOCATE(INDX(NE))
 IF(ALLOCATED(RB  ))DEALLOCATE(RB);   ALLOCATE(RB(NE,NE))

 !## compute inverse of (JQJ)-1 -> B = covariance matrix
 WRITE(*,'(A)') 'Computing inverse Jacobian ...'
 CALL IPEST_LUDECOMP_DBL(M,INDX,NE,ISING)
 !## matrix singular - compute inverse from projected jqj
 IF(ISING.EQ.0)THEN
  RB=0.0D0; DO I=1,NE; RB(I,I)=1.0D0; ENDDO
  DO I=1,NE; CALL IPEST_LUBACKSUB_DBL(M,INDX,RB(1,I),NE); ENDDO
 ELSE
  CALL IPEST_GLM_ERROR(IBATCH,'Singular matrix, cannot compute covariance matrix: skipped.')
 ENDIF
 
 IF(ALLOCATED(M))DEALLOCATE(M)
 IF(ALLOCATED(B))DEALLOCATE(B); ALLOCATE(B(NP,NP))

 !## reproject inverse matrix
 IF(LSVD)THEN
  B=MATMUL(MATMUL(P,RB),TRANSPOSE(P))
 ELSE
  B=RB
 ENDIF
 
 DEALLOCATE(RB)
 
 IF(ALLOCATED(COR   ))DEALLOCATE(COR);    ALLOCATE(COR(NP,NP   ))
 IF(ALLOCATED(COV   ))DEALLOCATE(COV);    ALLOCATE(COV(NP,NP   ))
! IF(ALLOCATED(LOGCOV))DEALLOCATE(LOGCOV); ALLOCATE(LOGCOV(NP,NP))
 
!  !### TEMP
!  WRITE(IUPESTJACOBIAN,'(2A10)') 'b'
!  DO J=1,size(b,1)
!   WRITE(IUPESTJACOBIAN,'(9999F15.7)') (b(I,J),I=1,SIZE(b,2))
!  ENDDO   
!  !### TEMP
 
!  !### TEMP
!  WRITE(IUPESTJACOBIAN,*) 'n',n,'b1',b1,'tj',msr%tj
!  !### TEMP

 !## b1 is error of the model response
 N=0; DO IP1=1,SIZE(PEST%PARAM) 
  IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
  IF(PEST%PARAM(IP1)%PACT.NE.1)CYCLE
  N=N+1
 ENDDO
 
 N=MAX(1,MSR%NOBS-N) !1)
 
 !## if sepmodelling is activated, iter is actually icycle, ignore that
 JTER=ITER-1; IF(JTER.GT.PEST%PE_MXITER)JTER=PEST%PE_MXITER
 
 B1=MSR%TJ_H(JTER)/REAL(N,8)
 
 WRITE(IUPESTOUT,'(/A,F15.7,A,I10,A,F15.7/)') 'Covariance Scaled by J/MAX(1,N-M): ',MSR%TJ_H(JTER),' / ',N,' = ',B1
 IF(PEST%PE_MXITER.EQ.0)THEN
  WRITE(JU,'(/A,F15.7,A,I10,A,F15.7/)') 'Covariance Scaled by J/MAX(1,N-M): ',MSR%TJ_H(JTER),' / ',N,' = ',B1
 ENDIF

 !## parameter covariance matrix scaled to this variance of active parameters
 DO I=1,NP; DO J=1,NP; B(I,J)=B1*B(I,J); ENDDO; ENDDO
  
!  !### TEMP
!  WRITE(IUPESTJACOBIAN,'(A,f15.7)') 'b_scaled_with_',b1
!  DO J=1,size(b,1)
!   WRITE(IUPESTJACOBIAN,'(9999F15.7)') (b(I,J),I=1,SIZE(b,2))
!  ENDDO   
!  !### TEMP

 IF(PEST%PE_MXITER.EQ.0)THEN
  WRITE(JU,'(A/)') 'Parameter Covariance Matrix (m2):'
  CALL IPEST_GLM_WRITEHEADER('               ',NP,JU)
  WRITE(FRM,'(A1,I10.10,A3)') '(',15+NP*16,'A1)'
  WRITE(JU,FRM) ('-',I=1,15+NP*16)
 ENDIF
 
 IF(NP.LT.PRINTLIMIT)THEN
  WRITE(IUPESTOUT,'(/A/)') 'Parameter Covariance Matrix (m2):'
  CALL IPEST_GLM_WRITEHEADER('               ',NP,IUPESTOUT)
  WRITE(IUPESTOUT,'(9999A1)') ('-',I=1,15+NP*16)
 ENDIF

 I=0
 DO IP1=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(IP1)%PIGROUP.GT.0)THEN 
   I=I+1
   IF(PEST%PE_MXITER.EQ.0)THEN
    TXT=''; IF(PEST%PARAM(IP1)%PACT.EQ.0)TXT='*'
    WRITE(JU,'(A15,A1,99999(F15.7,1X))',IOSTAT=IOS) PEST%PARAM(IP1)%ACRONYM,TXT,(B(I,J),J=1,NP)
    IF(IOS.NE.0)WRITE(JU,'(A)') '>>> error writing previous line <<<'
   ELSE
    IF(NP.LT.PRINTLIMIT)THEN
     TXT=''; IF(PEST%PARAM(IP1)%PACT.EQ.0)TXT='*'
     WRITE(IUPESTOUT,'(A15,A1,99999(F15.7,1X))',IOSTAT=IOS) PEST%PARAM(IP1)%ACRONYM,TXT,(B(I,J),J=1,NP)
     IF(IOS.NE.0)WRITE(IUPESTOUT,'(A)') '>>> error writing previous line <<<'
    ENDIF
   ENDIF
   DO J=1,NP; COV(I,J)=B(I,J); ENDDO
  ENDIF
 ENDDO
 WRITE(IUPESTOUT,'(/A/)') 'AN * MEANS THAT THE PARAMETER IS INACTIVE'
 
 !## save parameter covariance
 IF(PEST%PE_MXITER.EQ.0)CLOSE(JU)
 
 !## parameter correlation matrix
 IF(NP.LT.PRINTLIMIT)THEN
  WRITE(IUPESTOUT,'(/A/)') 'Parameter Correlation Matrix (-)'
  CALL IPEST_GLM_WRITEHEADER('               ',NP,IUPESTOUT)
  WRITE(IUPESTOUT,'(9999A1)') ('-',I=1,15+NP*16)
 ENDIF
  
 COR=0.0D0; I=0
 DO IP1=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(IP1)%PIGROUP.GT.0)THEN
   I=I+1
   DO J=1,NP
    CB=B(I,I)*B(J,J)
    IF(CB.GT.0.0D0)THEN
     COR(I,J)=B(I,J)/SQRT(CB)
    ELSE
     COR(I,J)=0.0D0
    ENDIF
   ENDDO
   IF(NP.LT.PRINTLIMIT)THEN
    TXT=''; IF(PEST%PARAM(IP1)%PACT.EQ.0)TXT='*'
    WRITE(IUPESTOUT,'(A15,A1,99999(F15.7,1X))',IOSTAT=IOS) PEST%PARAM(IP1)%ACRONYM,TXT,(COR(I,J),J=1,NP)
    IF(IOS.NE.0)WRITE(IUPESTOUT,'(A)') '>>> error writing previous line <<<'
   ENDIF
  ENDIF
 ENDDO
 WRITE(IUPESTOUT,'(/A/)') 'AN * MEANS THAT THE PARAMETER IS INACTIVE'

 !## write per parameter highly correlated other parameter
 DO JJ=1,2
  IF(JJ.EQ.2)WRITE(IUPESTOUT,'(/A/)') 'List of Parameter Highly Correlated (correlation > 95%)'
  IP1=0; N=0
  DO I=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(I)%PIGROUP.GT.0)THEN
    WRITE(BLINE,'(A15)') PEST%PARAM(I)%ACRONYM
    IP1=IP1+1
    IP2=0
    II=0
    DO J=1,SIZE(PEST%PARAM)
     IF(PEST%PARAM(J)%PIGROUP.GT.0)THEN
      IP2=IP2+1
      IF(I.NE.J)THEN
       WRITE(SLINE,'(A15)') PEST%PARAM(J)%ACRONYM
       IF(ABS(COR(IP1,IP2)).GE.0.95D0)THEN
        II=II+1
        BLINE=TRIM(BLINE)//' , '//TRIM(SLINE)//' ( '//TRIM(VTOS(COR(IP1,IP2)*100.0D0,'F',2))//'% )'
       ENDIF
      ENDIF
     ENDIF
    ENDDO
    IF(II.GT.0)THEN
     N=N+1; IF(JJ.EQ.2)WRITE(IUPESTOUT,'(A)') TRIM(BLINE)
    ENDIF
   ENDIF  
  ENDDO
  IF(N.EQ.0)EXIT
 ENDDO
  
 WRITE(IUPESTOUT,'(/A/)') 'Parameter Variance - Standard Parameter Error (Confidence Limits ~96%)'
 
 J=0; IERROR=0
 DO I=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(I)%PIGROUP.GT.0)THEN
   J=J+1
   IF(COV(J,J).GT.0.0D0)THEN
    !## stdev
    PEST%PARAM(I)%ALPHA_ERROR_STDEV=SQRT(COV(J,J))
   ELSE
    !## error value - should not happen
    PEST%PARAM(I)%ALPHA_ERROR_STDEV=-999.99D0 
    WRITE(IUPESTOUT,*) 'Active Parameter#,',J,' Variance ',COV(J,J)
    IERROR=IERROR+1
   ENDIF
   !## check whether current other parameters belong to this group
   DO IP1=1,SIZE(PEST%PARAM)
    !## active and follower of group
    IF(PEST%PARAM(IP1)%PACT.EQ.2)THEN
     IF(ABS(PEST%PARAM(IP1)%PIGROUP).EQ.PEST%PARAM(I)%PIGROUP)THEN
      PEST%PARAM(IP1)%ALPHA_ERROR_STDEV=PEST%PARAM(I)%ALPHA_ERROR_STDEV
     ENDIF
    ENDIF
   ENDDO
  ENDIF
 ENDDO
 
 IF(IERROR.GT.0)THEN
  
  CALL IPEST_GLM_ERROR(IBATCH,'Errors (#'//TRIM(VTOS(IERROR))//') found in the Covariance Matrix, check your matrix, might by singular')

 ELSE
  
  WRITE(IUPESTOUT,'(15X,3(1X,A15))') 'Lower_Limit','Average','Upper Limit'
  WRITE(IUPESTOUT,'(63A1)') ('-',I=1,63)

  MSR%SCORE(:,ITER)=0
  DO I=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(I)%PIGROUP.GT.0)THEN
    ZW=PEST%PARAM(I)%ALPHA_ERROR_STDEV*1.96D0
    
    IF(PEST%PARAM(I)%PLOG.EQ.1)THEN
     ZW=MIN(10.0D0,Zw)
     !## maximize uncertainty
     Z =EXP(PEST%PARAM(I)%ALPHA(2)) 
     Z1=EXP(PEST%PARAM(I)%ALPHA(2)-LOG(ZW))
     Z2=EXP(PEST%PARAM(I)%ALPHA(2)+LOG(ZW))
     IF(Z2.LT.Z1)THEN
      Z=Z2
      Z2=Z1
      Z1=Z
     ENDIF
    ELSEIF(PEST%PARAM(I)%PLOG.EQ.2)THEN
     ZW=MIN(10.0D0,Zw)
     !## maximize uncertainty
     Z =10.0D0**(PEST%PARAM(I)%ALPHA(2)) 
     Z1=10.0D0**(PEST%PARAM(I)%ALPHA(2)-LOG10(ZW))
     Z2=10.0D0**(PEST%PARAM(I)%ALPHA(2)+LOG10(ZW))
     IF(Z2.LT.Z1)THEN
      Z=Z2
      Z2=Z1
      Z1=Z
     ENDIF
    ELSE
     Z= PEST%PARAM(I)%ALPHA(2) 
     Z1=PEST%PARAM(I)%ALPHA(2)-ZW 
     Z2=PEST%PARAM(I)%ALPHA(2)+ZW 
    ENDIF 

    !## score uncertainty of parameter as character
    
!    DZ=LOG(Z2)-LOG(Z1); ISCORE=NINT(DZ)
    DZ=Z2/Z1; ISCORE=NINT(DZ)
    
    SELECT CASE (ISCORE)
     CASE (0);  PEST%PARAM(I)%SCORE='+++++'; MSR%SCORE(1,ITER)=MSR%SCORE(1,ITER)+5
     CASE (1);  PEST%PARAM(I)%SCORE='++++ '; MSR%SCORE(1,ITER)=MSR%SCORE(1,ITER)+3
     CASE (2);  PEST%PARAM(I)%SCORE='+++  '; MSR%SCORE(1,ITER)=MSR%SCORE(1,ITER)+3
     CASE (3);  PEST%PARAM(I)%SCORE='++   '; MSR%SCORE(1,ITER)=MSR%SCORE(1,ITER)+2
     CASE (4);  PEST%PARAM(I)%SCORE='+    '; MSR%SCORE(1,ITER)=MSR%SCORE(1,ITER)+1
     CASE (5);  PEST%PARAM(I)%SCORE='-    '; MSR%SCORE(2,ITER)=MSR%SCORE(2,ITER)+1
     CASE (6);  PEST%PARAM(I)%SCORE='--   '; MSR%SCORE(2,ITER)=MSR%SCORE(2,ITER)+2
     CASE (7);  PEST%PARAM(I)%SCORE='---  '; MSR%SCORE(2,ITER)=MSR%SCORE(2,ITER)+3
     CASE (8);  PEST%PARAM(I)%SCORE='---- '; MSR%SCORE(2,ITER)=MSR%SCORE(2,ITER)+4
     CASE (9:); PEST%PARAM(I)%SCORE='-----'; MSR%SCORE(2,ITER)=MSR%SCORE(2,ITER)+5
    END SELECT
    
    WRITE(BLINE,'(3(F15.7,1X))',IOSTAT=IOS) Z1,Z,Z2
    IF(IOS.NE.0)WRITE(BLINE,'(3(G15.7,1X))',IOSTAT=IOS) Z1,Z,Z2
    IF(IOS.NE.0)BLINE='>>> error writing this line <<<'
    TXT=''; IF(PEST%PARAM(I)%PACT.EQ.0)TXT='*'
    WRITE(IUPESTOUT,'(A15,A1,A)') PEST%PARAM(I)%ACRONYM,TXT,TRIM(BLINE)

   ENDIF
  ENDDO
  WRITE(IUPESTOUT,'(/A/)') 'AN * MEANS THAT THE PARAMETER IS INACTIVE'
 ENDIF

 !## copy score to all groups
 DO IP1=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(IP1)%PIGROUP.LE.0)CYCLE
  DO IP2=1,SIZE(PEST%PARAM)
   IF(ABS(PEST%PARAM(IP2)%PIGROUP).EQ.PEST%PARAM(IP1)%PIGROUP)PEST%PARAM(IP2)%SCORE=PEST%PARAM(IP1)%SCORE
  ENDDO
 ENDDO
 
 IF(PEST%PE_REGULARISATION.NE.0)THEN

  DO I=1,SIZE(PARAM)
   NILS=0; DO J=1,SIZE(PEST%PARAM)
    IF(PEST%PARAM(J)%PIGROUP.LE.0.OR.PEST%PARAM(J)%ZTYPE.EQ.0.OR.PEST%PARAM(J)%PPARAM.NE.PARAM(I))CYCLE
    NILS=MAX(NILS,PEST%PARAM(J)%PILS)
   ENDDO
   IF(NILS.EQ.0)CYCLE
   !## save variance of kriging in combination with scaled residuals - check all parameters
   DO ILS=1,NILS
    DO J=1,SIZE(PEST%PARAM)
     IF(PEST%PARAM(J)%PIGROUP.LE.0.OR.PEST%PARAM(J)%ZTYPE.EQ.0.OR. &
        PEST%PARAM(J)%PPARAM.NE.PARAM(I).OR.PEST%PARAM(J)%PILS.NE.ILS)CYCLE
      STD%FNAME=TRIM(DIR)//'\IPEST\KRIGING_STDEV\'//TRIM(PARAM(I))//'_ILS'//TRIM(VTOS(PEST%PARAM(J)%PILS))//'.IDF'
      IF(.NOT.IDFREAD(STD,STD%FNAME,1))STOP
      DO IROW=1,STD%NROW; DO ICOL=1,STD%NCOL
       IF(STD%X(ICOL,IROW).NE.STD%NODATA)STD%X(ICOL,IROW)=SQRT(STD%X(ICOL,IROW))*B1
      ENDDO; ENDDO
      STD%FNAME=TRIM(DIR)//'\IPEST\KRIGING_STDEV_ERROR\'//TRIM(PARAM(I))//'_ILS'//TRIM(VTOS(PEST%PARAM(J)%PILS))//'_CYCLE'//TRIM(VTOS(ITER))//'.IDF'
      IF(.NOT.IDFWRITE(STD,STD%FNAME,1))STOP
     EXIT
    ENDDO
   ENDDO
 
  ENDDO
 
 ENDIF
 
 !## generate sample of possible parameter combinations that suit covariance and confidence intervals
 !CALL IPEST_GLM_RANDOM_VARIABLES(COV)
 
 IF(ALLOCATED(COV ))DEALLOCATE(COV)
 IF(ALLOCATED(COR ))DEALLOCATE(COR)
 IF(ALLOCATED(INDX))DEALLOCATE(INDX)
 IF(ALLOCATED(B))   DEALLOCATE(B)

 END SUBROUTINE IPEST_GLM_JQJ_FULL

 !###====================================================================
 SUBROUTINE IPEST_GLM_RANDOM_VARIABLES(COV)
 !###====================================================================
 !This method is widely used for generating correlated random variables with a specific covariance matrix.
 !The key idea behind the Cholesky decomposition is that it transforms a covariance matrix into the product of a lower triangular matrix and its conjugate
 !transpose. By multiplying a set of uncorrelated random variables by this lower triangular matrix, we effectively introduce correlations among them that
 !match the covariance matrix. While it might seem complex, it's a powerful tool used in various fields such as statistics, finance, and engineering for
 !simulating correlated random variables.
 IMPLICIT NONE
 REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:,:) :: COV
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: CHO
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: RND,X
 INTEGER :: N,I,J,IRND,NRND,SEED
 
 IF(ALLOCATED(RND))DEALLOCATE(RND)
 IF(ALLOCATED(CHO))DEALLOCATE(CHO)
 IF(ALLOCATED(X))  DEALLOCATE(X)

 N=SIZE(COV,1); ALLOCATE(RND(N),X(N)); RND=0.0D0; NRND=10
 
 ALLOCATE(CHO(N,N)); CHO=COV
 CALL CHOLESKYDECOMPOSITION(CHO,N,1) 
 DO I=1,N; WRITE(*,*) (CHO(J,I),J=1,N); ENDDO

! Perform Cholesky decomposition of the covariance matrix
! CHO=COV; CALL DPOTRF('U', N, CHO, N, J)
! IF(J.NE.0)THEN; WRITE(*,*) '>>> ERROR: CHOLESKY DECOMPOSITION FAILED <<<'; RETURN; END IF
! DO I=1,N; WRITE(*,*) (CHO(J,I),J=1,N); ENDDO
 
 SEED=12345
 
 !## generate number of samples
 X=0.0D0
 DO IRND=1,NRND

  J=0; DO I=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(I)%PIGROUP.GT.0)THEN
    !## generates number -3 to +3 - in log-space permeability is normal-distributed
    J=J+1; CALL IPEST_NORMAL_MS_SAMPLE(PEST%PARAM(I)%ALPHA(2),COV(J,J),SEED,RND(J))
   ENDIF
  ENDDO
!  CALL RANDOM_NUMBER(RND); RND=RND-0.5D0 
 
  !## Multiply the lower triangular Cholesky matrix by the random variables
  RND=MATMUL(CHO,RND)

  !## logtransfer parameter to be added to current mean
  J=0; DO I=1,SIZE(PEST%PARAM)
   IF(PEST%PARAM(I)%PIGROUP.GT.0)THEN
    J=J+1; WRITE(*,*) I,PEST%PARAM(I)%ACRONYM,RND(J),EXP(PEST%PARAM(I)%ALPHA(2)+RND(J))
   ENDIF
  ENDDO

  X=X+RND
 
 ENDDO

 END SUBROUTINE IPEST_GLM_RANDOM_VARIABLES
 
 !###====================================================================
 REAL(KIND=DP_KIND) FUNCTION IPEST_GLM_GETMU(N,A,B)
 !###====================================================================
 IMPLICIT NONE
 REAL(KIND=DP_KIND),PARAMETER :: STOPCRIT=0.001D0
 INTEGER,INTENT(IN) :: N
 REAL(KIND=DP_KIND),DIMENSION(N,N),INTENT(IN) :: A,B
 REAL(KIND=DP_KIND) :: ME,F1,DF
 REAL(KIND=DP_KIND),DIMENSION(3) :: F,E
 INTEGER :: I,IE
 
 !## pattern search - it uses 3 points, centre point move to the best location, if centre point is the best
 !## location, it shrinks in size
 
 DF=1.0D0; F1=1.0D0; ME=HUGE(1.0)

 !## initial values
 DF=1.0D0
 F1=1.0D0

 WRITE(*,'(A5,2A15)') 'PNT','ERROR','MU'
 
 !## determine three points 
 DO
  F(1)=F1-DF
  F(2)=F1
  F(3)=F1+DF
  DO I=1,3
   E(I)=SUM(A-F(I)*B)
  ENDDO
  E=ABS(E)
  !## see how e evolves - search for lowest point - exclude f()=0.0
  ME=HUGE(1.0); DO I=1,3
   IF(F(I).GT.0.0D0.AND.E(I).LT.ME)THEN; IE=I; ME=E(I); ENDIF
  ENDDO
  WRITE(*,'(I5,2F15.7)') IE,ME,F(IE)
  SELECT CASE (IE)
   CASE (1)
    F1=F(1)
   CASE (2)
    DF=DF/2.0D0; IF(DF.LE.STOPCRIT)EXIT
   CASE (3)
    F1=F(3)
  END SELECT
 ENDDO
 
! WRITE(*,*) 'A'
! DO I=1,N
!  WRITE(*,'(99F15.7)') (A(I,J),J=1,N)
! ENDDO
! WRITE(*,*) 'B'
! DO I=1,N
!  WRITE(*,'(99F15.7)') (B(I,J),J=1,N)
! ENDDO
! WRITE(*,*) 'A-MU*B'
! DO I=1,N
!  WRITE(*,'(99F15.7)') (A(I,J)-F(IE)*B(I,J),J=1,N)
! ENDDO
  
 IPEST_GLM_GETMU=F(IE)
 
 END FUNCTION IPEST_GLM_GETMU

 !###====================================================================
 SUBROUTINE IPEST_GLM_EIGDECOM(IBATCH,JQJ,EIGW,EIGV,NP,LPRINT) 
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NP,IBATCH
 LOGICAL,INTENT(IN) :: LPRINT
 REAL(KIND=DP_KIND),DIMENSION(NP,NP),INTENT(IN) :: JQJ
 REAL(KIND=DP_KIND),DIMENSION(NP,NP),INTENT(OUT) :: EIGV
 REAL(KIND=DP_KIND),DIMENSION(NP),INTENT(OUT) :: EIGW
 INTEGER :: I,II,J,K,IU
 REAL(KIND=DP_KIND) :: TV,TEV,KAPPA
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: B
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: E
! REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: WORK 
! INTEGER,DIMENSION(:),ALLOCATABLE :: IWORK 

 IF(ALLOCATED(E))DEALLOCATE(E); ALLOCATE(E(NP))
 IF(ALLOCATED(B))DEALLOCATE(B); ALLOCATE(B(NP,NP))

! !## compute determinant of JQJ
! DET=IPEST_GLM_DET(JQJ,NP)

! IF(LPRINT)THEN
!  WRITE(IUPESTOUT,'(A,E15.7)') 'Determinant JQJ + '//TRIM(VTOS(MARQUARDT,'F',7))//' * I = ',DET
! ENDIF
 
! WRITE(IUPESTOUT,'(a)') 'jqj'
! do j=1,np; WRITE(IUPESTOUT,'(999f10.3)') (jqj(i,j),i=1,np); enddo
! flush(iupestout)
 
 DO II=1,100 !2
 
  !## copy jqj to b for eigenvalue decomposition
  B=JQJ
  
  !## add diagonal to get positive definite matrix
  IF(II.EQ.2)THEN
   WRITE(*,'(A,F10.2)') 'Adding identity diagonal to hessian',REAL(II-1,8)
   DO I=1,NP; B(I,I)=B(I,I)+REAL(II-1,8); ENDDO
  ENDIF
  
!  IF(.TRUE.)THEN 
!   ALLOCATE(WORK(1),IWORK(1))
!   CALL DSYEVD('V','U',NP,B,NP,EIGW,WORK,-1,IWORK,-1,IERR)
!   NN=INT(WORK(1));  DEALLOCATE(WORK);  ALLOCATE(WORK(NN)); WRITE(*,*) NN
!   MM=INT(IWORK(1)); DEALLOCATE(IWORK); ALLOCATE(IWORK(MM)); WRITE(*,*) MM
!   CALL DSYEVD('V','U',NP,B,NP,EIGW,WORK,NN,IWORK,MM,IERR)
!   WRITE(*,*) 'NP=',NP
!   DO I=1,NP; WRITE(*,*) EIGW(I); ENDDO
!   DEALLOCATE(WORK,IWORK)
!   EIGV=B
!  ELSE
  !## eigenvalue of covariance matrix 
  CALL LUDCMP_TRED2(B,NP,NP,EIGW,E)
  IF(.NOT.LUDCMP_TQLI(EIGW,E,NP,NP,B))THEN
   WRITE(*,'(A)') 'Errors in eigenvalue decomposition'
  ELSE
!  NERROR=0
!  DO I=1,NP
!   IF(EIGW(I).NE.EIGW(I).OR.EIGW(I).GT. HUGE(1.0D0).OR.EIGW(I).LT.-HUGE(1.0D0))THEN
!    NERROR=NERROR+1
!   ENDIF
!  ENDDO
   EXIT  
  ENDIF
  
 ENDDO
 
 CALL LUDCMP_EIGSRT(EIGW,B,NP,NP)
 !## check computation of eigenvalues
 DO I=1,NP
  IF(EIGW(I).NE.EIGW(I).OR.EIGW(I).GT. HUGE(1.0D0).OR.EIGW(I).LT.-HUGE(1.0D0))THEN
   WRITE(*,*) 'Error finding eigenvalues for matrix, see eigenvalues.txt'
   WRITE(*,*) I,EIGW(I)
   IU=UTL_GETUNIT(); OPEN(IU,FILE='eigenvalues.txt',STATUS='REPLACE',ACTION='WRITE')
   WRITE(IU,'(A)') 'JQJ=['
   DO J=1,SIZE(JQJ,1)
    WRITE(IU,'(999F15.7)') (JQJ(J,K),K=1,SIZE(JQJ,2))
   ENDDO
   WRITE(IU,'(A)') ']'
   WRITE(IU,'(A)') 'EIGW=['
   DO J=1,SIZE(JQJ,1)
    WRITE(IU,'(I10,G15.7)') J,EIGW(J)
   ENDDO
   WRITE(IU,'(A)') ']'
   WRITE(IU,'(A)') 'EIGV=['
   DO J=1,SIZE(B,1)
    WRITE(IU,'(999F15.7)') (B(J,K),K=1,SIZE(B,2))
   ENDDO
   WRITE(IU,'(A)') ']'
   CLOSE(IU); PAUSE; EXIT
  ENDIF
 ENDDO
 IF(LPRINT)WRITE(IUPESTOUT,'(/10X,4A15)') 'Eigenvalues','Sing.Values','Variance','Explained Var.'
 DO I=1,NP; IF(EIGW(I).LE.0.0)EIGW(I)=0.0; ENDDO; TEV=SUM(EIGW)
 TV=0.0D0
 DO I=1,NP
  TV=TV+(EIGW(I)*100.0D0/TEV)
  IF(EIGW(I).GT.0.0D0)THEN
   IF(LPRINT)WRITE(IUPESTOUT,'(I10,G15.7,3F15.7)') I,EIGW(I),SQRT(EIGW(I)),EIGW(I)*100.0D0/TEV,TV
  ELSE
   IF(LPRINT)WRITE(IUPESTOUT,'(I10,G15.7,3F15.7)') I,EIGW(I),     EIGW(I) ,EIGW(I)*100.0D0/TEV,TV
  ENDIF
 ENDDO
 EIGV= B  

 IF(SUM(EIGW).LT.0.0D0)THEN
  CALL IPEST_GLM_ERROR(IBATCH,'Warning, there is NO information (no eigenvalues) in parameter perturbation'); RETURN
 ENDIF

 !## condition number
 !## get lowest non-zero
 DO I=NP,1,-1; IF(EIGW(I).GT.0.0D0)EXIT; ENDDO
 KAPPA=SQRT(EIGW(1))/SQRT(EIGW(I)); KAPPA=LOG10(KAPPA)
 IF(LPRINT)THEN
  WRITE(IUPESTOUT,'(/A,F15.7/)') 'Condition Number (kappa):',KAPPA
  IF(KAPPA.GT.15.0D0)THEN
   WRITE(IUPESTOUT,'(A)') '>>> If Kappa > 15, inversion is a concern due to parameters that are highly correlated <<<'
  ELSEIF(KAPPA.GT.30.0D0)THEN
   WRITE(IUPESTOUT,'(A)') '>>> If Kappa > 30, inversion is highly questionable due to parameters that are highly correlated <<<'
  ENDIF
 ENDIF 
 
 IF(ALLOCATED(E))DEALLOCATE(E)
 IF(ALLOCATED(B))DEALLOCATE(B)
 
 END SUBROUTINE IPEST_GLM_EIGDECOM
 
 !###========================================================================
 SUBROUTINE IPEST_GLM_WRITEHEADER(TXT,NP,IU)
 !###========================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: TXT
 INTEGER,INTENT(IN) :: IU,NP
 INTEGER :: I,J,N
 CHARACTER(LEN=15),ALLOCATABLE,DIMENSION(:) :: CTMP
   
 ALLOCATE(CTMP(NP))
   
 N=0
 DO J=1,SIZE(PEST%PARAM)
  IF(PEST%PARAM(J)%PIGROUP.GT.0)THEN 
   N=N+1
   WRITE(CTMP(N),'(A15)') PEST%PARAM(J)%ACRONYM
  ENDIF
 ENDDO
 WRITE(IU,'(A15,99999(1X,A15))') TXT,(CTMP(I),I=1,NP) 
 
 DEALLOCATE(CTMP)
 
 END SUBROUTINE IPEST_GLM_WRITEHEADER
  
 !###========================================================================
 DOUBLE PRECISION FUNCTION IPEST_GLM_DET(JQJ,N)
 !###========================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: N
 DOUBLE PRECISION,DIMENSION(N,N),INTENT(IN) :: JQJ
 DOUBLE PRECISION,DIMENSION(:,:),ALLOCATABLE :: MATRIX
 DOUBLE PRECISION :: M, TEMP
 INTEGER :: I, J, K, L
 LOGICAL :: DETEXISTS = .TRUE.

 ALLOCATE(MATRIX(N,N))
 MATRIX=JQJ
 
! open(99,file='d:\tmp.m',status='REPLACE',action='write')
! write(99,*) '['
! do j=1,n
!  write(99,'(999f15.7)') (jqj(i,j),i=1,n)
! enddo
! close(99)
 
 L = 1
 !## convert to upper triangular form
 DO K = 1, N-1
  IF (MATRIX(K,K).EQ.0.0D0) THEN
   DETEXISTS = .FALSE.
   DO I = K+1, N
    IF (MATRIX(I,K).NE.0.0D0) THEN
     DO J = 1, N
      TEMP = MATRIX(I,J)
      MATRIX(I,J)= MATRIX(K,J)
      MATRIX(K,J) = TEMP
     END DO
     DETEXISTS = .TRUE.
     L=-L
     EXIT
    ENDIF
   END DO
   IF (DETEXISTS .EQV. .FALSE.) THEN
    IPEST_GLM_DET = 0.0D0
    DEALLOCATE(MATRIX)
    RETURN
   END IF
  ENDIF
  DO J = K+1, N
   M = MATRIX(J,K)/MATRIX(K,K)
   DO I = K+1, N
    MATRIX(J,I) = MATRIX(J,I) - M*MATRIX(K,I)
   END DO
  END DO
 END DO
    
 !## calculate determinant by finding product of diagonal elements
 IPEST_GLM_DET = L
 DO I = 1, N
  IPEST_GLM_DET = IPEST_GLM_DET * MATRIX(I,I)
 END DO

 DEALLOCATE(MATRIX)
    
 END FUNCTION IPEST_GLM_DET

 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_GETJ_AVG(DIR,IGRAD,IPARAM,CTYPE,IBATCH,ILAMBDA,MNAME) 
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR,CTYPE,MNAME
 INTEGER,INTENT(IN) :: IGRAD,IPARAM,IBATCH,ILAMBDA
 INTEGER :: I,J,JJ,II,NC,NP,NPERIOD,III,K,KK,ILAY,NROWIPFTXT,IUIPFTXT,NCOLIPFTXT,IOS,NAJ,IERROR,SEED,IROW,ICOL,JROW,JCOL,IORG
 REAL(KIND=DP_KIND) :: X,Y,Z,H,WW,W,MC,MM,DHH,XCOR,YCOR,ZCOR,DHW,NSC,D,MU,F1,F2,N,WWGHG,WWGLG,DRES
 CHARACTER(LEN=256) :: DIRNAME,FNAME,DIRO
 CHARACTER(LEN=52) :: CID,TXT,CDATE
 CHARACTER(LEN=52),ALLOCATABLE,DIMENSION(:) :: IPFSTRING
 CHARACTER(LEN=12) :: CEXT
 CHARACTER(LEN=3) :: FWBW
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: TSNODATA,M,C,MCOPY,CCOPY,STD
 INTEGER(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: IDATE,ID1,ID2
 REAL(KIND=DP_KIND),DIMENSION(3) :: PC,PM,DYN !## percentiles computed/measured
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: AVGOBS,NUMOBS,AVGCOM,AVGW,SUMW,VAR,COV,COR,DF
 INTEGER(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: VARIDATE
 INTEGER :: IU,NR,IEXT,IPER
 LOGICAL :: LYN,LDUAL
 TYPE(PSTMEASURE),ALLOCATABLE,DIMENSION(:) :: MEASURES
 REAL(KIND=DP_KIND),DIMENSION(1,1) :: JR
 
 !## no measurements
 IPEST_GLM_GETJ_AVG=.TRUE.
 
 !## initiate number of observations
 MSR%NOBS=0

 FWBW=''; IF(CTYPE.EQ.'P'.AND.PBMAN%IPESTMETHOD.EQ.2)THEN
  !## allocate memory for running the models
  J=0 ; DO I=1,SIZE(PEST%PARAM)
   !## associated parameters to existing groups inactive for gradient computation
   IF(PEST%PARAM(I)%PACT.EQ.1)J=J+1
  ENDDO
  FWBW='FW_'; IF(IGRAD.GT.J)FWBW='BW_'
 ENDIF
 
 !## run batch files and get number of observations
 IF(.NOT.PEST_GLM_BATCHFILES(1,CTYPE,IPARAM))THEN
  IPEST_GLM_GETJ_AVG=.FALSE.; RETURN
 ENDIF
 
 !## initialise variables
 MSR%TJ=0.0D0; MSR%RJ=0.0D0; MSR%LIMJ=0.0D0

 !## write header
 IF(ASSOCIATED(PEST%MEASURES))THEN
  IF(TRIM(CTYPE).EQ.'L'.AND.IUPESTRESIDUAL.GT.0)THEN
   DO I=1,SIZE(MEASURES)
    J=INDEX(MEASURES(I)%IPFNAME,'\',.TRUE.)+1
    FNAME=TRIM(DIRNAME)//'\'//TRIM(MEASURES(I)%IPFNAME(J:))
    WRITE(IUPESTRESIDUAL,'(I10,A)') I,','//TRIM(FNAME)
   ENDDO
  ENDIF
 ENDIF
 
 IF(TRIM(CTYPE).EQ.'L'.OR.TRIM(CTYPE).EQ.'R')THEN 
  !## write head for the first
  IF(IUPESTRESIDUAL.GT.0)THEN
   !## save observation in the residual-text file
   DO I=1,SIZE(PEST%MEASURES)
    WRITE(IUPESTRESIDUAL,'(A)') TRIM(PEST%MEASURES(I)%IPFNAME)
   ENDDO
   !## steady-state
   IF(PRJNPER.EQ.1)THEN
    WRITE(IUPESTRESIDUAL,'(2A16,A11,6A16,A11,A5)') 'X,','Y,','ILAY,','MSR,','MDL,', &
           'MDL-MSR,','MDL-MSR*,','WRESIDUAL,','WEIGHT,','IPF,','LABEL'
   !## transient
   ELSE
    WRITE(IUPESTRESIDUAL,'(2A16,A11,8A16,A11,A5,27X,1X,A15)') 'X,','Y,','ILAY,','WEIGHT,','MSR,','MDL,','MDL-MSR*,', &
           'DYNMSR,','DYNMDL,','DYNMSR-DYNMDL,','NASH-SUTCLIFF,','IPF,','LABEL','DATE'
   ENDIF
  ENDIF
  IF(IUPESTPRESIDUAL.GT.0)THEN
!   !## save observation in the residual-text file
!   DO I=1,SIZE(PEST%MEASURES)
!    WRITE(IUPESTRESIDUAL,'(A)') TRIM(PEST%MEASURES(I)%IPFNAME)
!   ENDDO
   WRITE(IUPESTPRESIDUAL,'(2A16,A11,4A16,2A11,A33,A14)') 'X,','Y,','LAYER,','MEASURE,','COMPUTED,','WEIGHT,','ACCEPTDIFF,','IPF,','IPOS,','LABEL,','DATE'
  ENDIF
 ENDIF

 IF(ASSOCIATED(PEST%MEASURES))THEN
 
  IPEST_GLM_GETJ_AVG=.FALSE.; LYN=.TRUE.; LDUAL=.TRUE. 

  SEED=12345; DIRO=DIR; IF(PBMAN%OUTPUT.NE.'')DIRO=PBMAN%OUTPUT
 
  IF(PBMAN%IIES.EQ.1)THEN
   DIRNAME=TRIM(DIRO)//'\IIES_'//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM))//'_L#'//TRIM(VTOS(ILAMBDA))//'\TIMESERIES'
  ELSE  
   DIRNAME=TRIM(DIRO)//'\IPEST_'//TRIM(FWBW)//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM))//'\TIMESERIES'
  ENDIF
 
  !## create output files in case modflow6 is used (aggregate results from different modflow6- models)
  IF((PBMAN%IFORMAT.EQ.3.OR.PBMAN%IFORMAT.EQ.6).AND.PBMAN%IPESTP.EQ.1)THEN
   IF(.NOT.IPEST_GLM_CREATE_RESIDUALSFILES(DIRO,IPARAM,CTYPE,MNAME))RETURN
   ALLOCATE(MEASURES(1))
   MEASURES(1)%IPFNAME=TRIM(DIRNAME)//'\OUTPUT_OBS.IPF'
   MEASURES(1)%IPFTYPE=1
   MEASURES(1)%IXCOL=1; MEASURES(1)%IYCOL=2
   MEASURES(1)%ILCOL=3; MEASURES(1)%IMCOL=4
   !## check whether imcol needs to be negative
   IF(PEST%MEASURES(1)%IMCOL.LT.0)MEASURES(1)%IMCOL=-4
   !## here ivcol is set to standard stdev input
   MEASURES(1)%IVCOL=5; MEASURES(1)%IDCOL=0
  ELSE
   NP=SIZE(PEST%MEASURES); ALLOCATE(MEASURES(NP))
   !## make temporary copy of measurement settings
   MEASURES=PEST%MEASURES
   DO I=1,SIZE(MEASURES)
    !## ensure a global path here
    IF(INDEX(MEASURES(I)%IPFNAME,'.\').GT.0)THEN
     CALL UTL_SUBST(MEASURES(I)%IPFNAME,'.\',TRIM(PREFDIR)//'\') !DIRNAME)//'\')
     CALL UTL_SUBST(MEASURES(I)%IPFNAME,'\\','\')
    ENDIF
   ENDDO
  ENDIF 

  !## initialise variables
  II=0

  NPERIOD=0; IF(ASSOCIATED(PEST%S_PERIOD))NPERIOD=SIZE(PEST%S_PERIOD)
  IF(NPERIOD.GT.0)THEN
   ALLOCATE(ID1(NPERIOD),ID2(NPERIOD))
   DO I=1,NPERIOD; READ(PEST%S_PERIOD(I),*) ID1; READ(PEST%E_PERIOD(I),*) ID2; ENDDO
  ENDIF
  
 ELSE
  ALLOCATE(PEST%MEASURES(0)); MEASURES=PEST%MEASURES
 ENDIF
 
 !## if not yet allocated, allocate msr
 IF(.NOT.ASSOCIATED(MSR%CLABEL))THEN
  IF(.NOT.IPEST_GLM_ALLOCATEMSR(0,0,0,MEASURES))RETURN
 ENDIF

 IF(SIZE(PEST%MEASURES).LE.0)DEALLOCATE(PEST%MEASURES)
 
 IF(SIZE(PEST%MEASURES).GT.0)THEN 
  !## process files
  DO I=1,SIZE(MEASURES)

   J=INDEX(MEASURES(I)%IPFNAME,'\',.TRUE.)+1
   FNAME=TRIM(DIRNAME)//'\'//TRIM(MEASURES(I)%IPFNAME(J:))
   IU=UTL_GETUNIT(); OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ',iostat=ios)
   IF(IOS.NE.0)THEN
    WRITE(*,'(/A/)') '>>> Cannot find: '//TRIM(FNAME)//' <<<'
   ENDIF
   READ(IU,*) NR; READ(IU,*) NC; DO J=1,NC; READ(IU,*); ENDDO; READ(IU,*) IEXT,CEXT
  
   IF(IEXT.EQ.0)THEN
   
    ALLOCATE(IPFSTRING(NC))
    DO J=1,NR
    
     F1=REAL(J,8)/REAL(NR,8)*100.0D0
     F2=REAL(I,8)/REAL(SIZE(MEASURES),8)*100.0D0
     WRITE(6,'(A)') '+Progressing residuals '//TRIM(VTOS(F1,'F',2))//' for observation file '//TRIM(VTOS(F2,'F',2))
    
     II=II+1

     IF(.NOT.UTL_READCSVENTRY(IU,IPFSTRING))EXIT
     READ(IPFSTRING(1 ),*) MSR%X(II)
     READ(IPFSTRING(2 ),*) MSR%Y(II)   
     READ(IPFSTRING(3 ),*) MSR%L(II)
     READ(IPFSTRING(4 ),*) MSR%O(II)
     READ(IPFSTRING(5 ),*) MSR%W(II)
     READ(IPFSTRING(6 ),*) MSR%C(II)
     READ(IPFSTRING(7 ),*) F1
     READ(IPFSTRING(8 ),*) F2
     READ(IPFSTRING(9 ),*) MSR%D(II)
     READ(IPFSTRING(10),*) IORG
     MSR%CLABEL(II)='MEASURE'//TRIM(VTOS(IORG))//'_IPF'//TRIM(VTOS(I))
        
     !## steady-state
     MSR%IDATE(II)=0
     MSR%IPF(II)=I
     MSR%LOC(II)=J
    
    ENDDO
    DEALLOCATE(IPFSTRING)
   
   !## transient
   ELSE
    
    IUIPFTXT=0; ALLOCATE(IPFSTRING(NC))
    DO J=1,NR
    
     !## read x,y,layer,name,weight,acceptable_error,original_ipf_number
     IF(.NOT.UTL_READCSVENTRY(IU,IPFSTRING))EXIT
     READ(IPFSTRING(1),*,IOSTAT=IOS) X;    IF(IOS.NE.0)THEN; WRITE(*,'(A)') '>>> ERROR READING X <<<'; STOP; ENDIF   
     READ(IPFSTRING(2),*,IOSTAT=IOS) Y;    IF(IOS.NE.0)THEN; WRITE(*,'(A)') '>>> ERROR READING Y <<<'; STOP; ENDIF
     READ(IPFSTRING(3),*,IOSTAT=IOS) ILAY; IF(IOS.NE.0)THEN; WRITE(*,'(A)') '>>> ERROR READING ILAY <<<'; STOP; ENDIF
     CID=IPFSTRING(4)
     READ(IPFSTRING(5),*,IOSTAT=IOS) WW;   IF(IOS.NE.0)THEN; WRITE(*,'(A)') '>>> ERROR READING WEIGHT <<<'; STOP; ENDIF
     READ(IPFSTRING(6),*,IOSTAT=IOS) D;    IF(IOS.NE.0)THEN; WRITE(*,'(A)') '>>> ERROR READING D <<<'; STOP; ENDIF
     READ(IPFSTRING(7),*,IOSTAT=IOS) IORG; IF(IOS.NE.0)THEN; WRITE(*,'(A)') '>>> ERROR READING IORG <<<'; STOP; ENDIF

     !## usage of gxg values
     IF(MEASURES(I)%IMCOL.LT.0.AND.MEASURES(I)%IVCOL.EQ.0)THEN
      READ(IPFSTRING(8),*,IOSTAT=IOS) WWGHG; IF(IOS.NE.0)THEN; WRITE(*,'(A)') '>>> ERROR READING WWGHG <<<'; STOP; ENDIF
      READ(IPFSTRING(9),*,IOSTAT=IOS) WWGLG; IF(IOS.NE.0)THEN; WRITE(*,'(A)') '>>> ERROR READING WWGLG <<<'; STOP; ENDIF
     ELSE
      WWGHG=WW; WWGLG=WW
     ENDIF
    
     LINE=TRIM(DIRNAME)//CHAR(92)//TRIM(CID)//'.'//TRIM(CEXT)
     IF(IUIPFTXT.EQ.0)IUIPFTXT=UTL_GETUNIT(); OPEN(IUIPFTXT,FILE=LINE,STATUS='OLD',ACTION='READ')
    
     READ(IUIPFTXT,*) NROWIPFTXT; READ(IUIPFTXT,*) NCOLIPFTXT

     ALLOCATE(TSNODATA(MAX(3,NCOLIPFTXT)))
     DO K=1,NCOLIPFTXT; READ(IUIPFTXT,*) TXT,TSNODATA(K); ENDDO
     ALLOCATE(M(NROWIPFTXT),C(NROWIPFTXT),IDATE(NROWIPFTXT),MCOPY(NROWIPFTXT),CCOPY(NROWIPFTXT))
     IDATE=0; C=0.0D0; M=0.0D0; MCOPY=M; CCOPY=C
     IF(NCOLIPFTXT.LT.3)TSNODATA(3)=TSNODATA(2)
    
     !## get mean measure
     KK=0
     DO K=1,NROWIPFTXT
      KK=KK+1
      READ(IUIPFTXT,*,IOSTAT=IOS) IDATE(KK),M(KK),C(KK) 

      !## error reading, skip it (can be caused by steady-state periods in between)
      IF(IOS.NE.0)THEN; KK=KK-1; CYCLE; ENDIF

      !## make double precision dates - if needed
      IDATE(KK)=UTL_COMPLETEDATE(IDATE(KK))
     
      !## check period (if available)
      IF(NPERIOD.GT.0)THEN
       DO III=1,NPERIOD; IF(IDATE(KK).GE.ID1(III).AND.IDATE(KK).LE.ID2(III))EXIT; ENDDO
       IF(III.GT.NPERIOD)C(KK)=TSNODATA(3)
      ENDIF

      IF(M(KK).EQ.TSNODATA(2).OR.C(KK).EQ.TSNODATA(3))KK=KK-1
     ENDDO 

     !## add this measurement
     IF(KK.GT.0)THEN
    
      !## compute mean measurement in period
      XCOR=-9999.99D0
      NSC =-9999.99D0
      DYN =-9999.99D0

      !## mean values
      MM=SUM(M(1:KK))/DBLE(KK) !## measurements
      MC=SUM(C(1:KK))/DBLE(KK) !## computed

      IF(PEST%PE_TARGET(2).GT.0.0D0)THEN
       DO K=1,KK; MCOPY(K)=M(K); CCOPY(K)=C(K); ENDDO
       !## percentiles
       CALL UTL_GETMED(MCOPY,KK,-999.99D0,(/10.0D0,50.0D0,90.0D0/),3,NAJ,PM)
       CALL UTL_GETMED(CCOPY,KK,-999.99D0,(/10.0D0,50.0D0,90.0D0/),3,NAJ,PC)
       !## measurements
       DYN(1)=PM(3)-PM(1) 
       !## computed
       DYN(2)=PC(3)-PC(1) 
      ENDIF
      !## compute cross-correlation
      IF(KK.GT.1)THEN
       XCOR=0.0D0; YCOR=0.0D0; ZCOR=0.0D0
       DO K=1,KK
        XCOR=XCOR+(MM-M(K))*(MC-C(K)); YCOR=YCOR+(MM-M(K))**2.0D0; ZCOR=ZCOR+(MC-C(K))**2.0D0
       ENDDO
       IF(YCOR.NE.0.0.AND.ZCOR.NE.0.0)XCOR=XCOR/(SQRT(YCOR)*SQRT(ZCOR))
       NSC =UTL_NASH_SUTCLIFFE(M,C,KK)
       NSC=MIN(MAX(-999.9D0,NSC),999.9D0)
      ENDIF
     
      !## compute ghg/glg
      IF(MEASURES(I)%IMCOL.LT.0)THEN
       !## compute ghg(1)/glg(2) if ldual=.true.
       IF(.NOT.UTL_COMPUTE_GXG(M,IDATE,KK,.TRUE.,LDUAL,-999.99D0))THEN 
        WRITE(*,'(/A)') '>>> Cannot compute GXG for measurements for:'
        WRITE(*,'(A/)') '   '//TRIM(CID)//'.'//TRIM(CEXT)//' <<<'
        KK=0
       !## compute ghg(1)/glg(2) if ldual=.true.
       ELSE
        IF(.NOT.UTL_COMPUTE_GXG(C,IDATE,KK,.TRUE.,LDUAL,-999.99D0))THEN 
         WRITE(*,'(/A)') '>>> Cannot compute GXG for computed heads for:'
         WRITE(*,'(A/)') '   '//TRIM(CID)//'.'//TRIM(CEXT)//' <<<'
         KK=0
        ENDIF
       ENDIF
       !## only two values for gxg measurements
       IF(LDUAL)KK=2
      ENDIF

      !## add observation
      DO K=1,KK
       II =II+1

       !## random error not yet set
       IF(MEASURES(I)%IMCOL.LT.0)THEN
        IF(K.EQ.1)MSR%W(II)=WWGHG
        IF(K.EQ.2)MSR%W(II)=WWGLG
       ELSE
        MSR%W(II)=WW
       ENDIF
      
       !## save information for measurement
       MSR%CLABEL(II)=TRIM(CID)
       MSR%X(II)=X
       MSR%Y(II)=Y
       MSR%L(II)=ILAY
       !## dynamics
       IF(PEST%PE_TARGET(2).GT.0.0D0)THEN
        MSR%O(II)=DYN(1)
        MSR%C(II)=DYN(2)
       !## absolute values
       ELSE
        MSR%O(II)=M(K)
        MSR%C(II)=C(K)
       ENDIF
       MSR%D(II)=D
       MSR%IDATE(II)=IDATE(K)
       MSR%IPF(II)=I
       MSR%LOC(II)=J
       MSR%NS(II)=NSC
      
       IF(PEST%PE_TARGET(1).EQ.0.0D0.AND.PEST%PE_TARGET(2).GT.0.0D0)EXIT
     
      ENDDO
     ENDIF
     DEALLOCATE(TSNODATA,C,M,MCOPY,CCOPY,IDATE); CLOSE(IUIPFTXT)
    ENDDO
    DEALLOCATE(IPFSTRING)
   ENDIF

   CLOSE(IU)

  ENDDO
 
  MSR%NOBS=II; IF(MSR%NOBS.LE.0)THEN
   CALL IPEST_GLM_ERROR(IBATCH,'No measurements available within current spatial/temporal space.')
  ENDIF
 
  IERROR=1; IF(PBMAN%IIES.EQ.1)IERROR=IGRAD

  !## aggregate to mean values per gridcel
  IF(PBMAN%AVGOBS.EQ.1)THEN

   !## aggregate per layer
   ALLOCATE(NUMOBS(PRJIDF%NCOL,PRJIDF%NROW))

   !## transient measurements
   IF(IEXT.NE.0)THEN
  
    NP=1; DO I=2,MSR%NOBS; IF(MSR%LOC(I).NE.MSR%LOC(I-1))NP=NP+1; ENDDO; ALLOCATE(AVGOBS(NP,PRJNPER))

    DO ILAY=1,PRJNLAY
 
     !## aggregate per location  
     NUMOBS=0.0D0; DO II=1,MSR%NOBS
      !## skip observations that have been processed already
      IF(MSR%W(II).LE.0.0D0)CYCLE
      !## skip observations in the wrong modellayer
      IF(MSR%L(II).NE.ILAY)CYCLE
      CALL IDFIROWICOL(PRJIDF,IROW,ICOL,MSR%X(II),MSR%Y(II))
      !## count number of observations per location
      NUMOBS(ICOL,IROW)=NUMOBS(ICOL,IROW)+1.0D0
     ENDDO
    
     !## process values per gridcell
     DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
      !## nothing here
      IF(NUMOBS(ICOL,IROW).LE.0.0D0)CYCLE; AVGOBS=HNOFLOW; NP=0
      DO II=1,MSR%NOBS
       !## already processed
       IF(MSR%LOC(II).LT.0)CYCLE
       !## skip observations in the wrong modellayer
       IF(MSR%L(II).NE.ILAY)CYCLE
       !## not in current gridcell
       CALL IDFIROWICOL(PRJIDF,JROW,JCOL,MSR%X(II),MSR%Y(II)); IF(IROW.NE.JROW.OR.JCOL.NE.ICOL)CYCLE
       !## get correct time-slots for current measurement
       NP=NP+1
       DO JJ=II,MSR%NOBS
        !## different location
        IF(MSR%LOC(JJ).NE.ABS(MSR%LOC(II)).OR.MSR%IPF(JJ).NE.MSR%IPF(II))CYCLE
        !## make sure not to use this again
        MSR%LOC(JJ)=-1*ABS(MSR%LOC(JJ))
        DO IPER=1,PRJNPER
         IF(SIM(IPER)%CDATE.NE.'STEADY-STATE')THEN
          WRITE(CDATE,'(I4.4,6I2.2)') SIM(IPER)%IYR,SIM(IPER)%IMH,SIM(IPER)%IDY,SIM(IPER)%IHR,SIM(IPER)%IMT,SIM(IPER)%ISC
          IF(TRIM(CDATE).NE.TRIM(VTOS(MSR%IDATE(JJ))))CYCLE
         ELSE
          IF(MSR%IDATE(JJ).NE.0D0)CYCLE
         ENDIF
         !## get measurement and quit looking
         AVGOBS(NP,IPER)=MSR%O(JJ); EXIT
        ENDDO
       ENDDO
      ENDDO

      !## get number of complete timesteps
      DO K=1,2
       JJ=1; DO I=1,PRJNPER
        II=0; DO J=1,NP
         IF(AVGOBS(J,I).NE.HNOFLOW)THEN
          II=II+1
          IF(K.EQ.2)THEN
           VAR(J,JJ)=AVGOBS(J,I)
           VARIDATE(JJ)=YMDHMSTOITIME(SIM(I)%IYR,SIM(I)%IMH,SIM(I)%IDY,SIM(I)%IHR,SIM(I)%IMT,SIM(I)%ISC)
          ENDIF
         ENDIF
        ENDDO
        IF(II.EQ.NP)JJ=JJ+1
        IF(K.EQ.2.AND.JJ.GT.SIZE(VAR,2))EXIT
       ENDDO
       IF(K.EQ.1)THEN
        JJ=JJ-1; ALLOCATE(VAR(NP,JJ),VARIDATE(JJ))
       ENDIF
      ENDDO
     
      !## compute variance/correlation
      DO I=1,NP
       H=0.0D0; DO J=1,SIZE(VAR,2)
        H=H+VAR(I,J)     
       ENDDO
       H=H/REAL(SIZE(VAR,2),8)
       DO J=1,SIZE(VAR,2)
        VAR(I,J)=VAR(I,J)-H
       ENDDO
      ENDDO

      ALLOCATE(STD(SIZE(VAR,1)),COV(SIZE(VAR,1),SIZE(VAR,1)),COR(SIZE(VAR,1),SIZE(VAR,1)))
      COV=MATMUL(VAR,TRANSPOSE(VAR))
      !## compute standard deviation
      DO I=1,SIZE(VAR,1)
       STD(I)=SQRT(COV(I,I)/(REAL(SIZE(VAR,2),8)-1.0D0))
      ENDDO
      !## compute correlation
      COR=0.0D0; I=0
      DO I=1,SIZE(VAR,1)
       DO J=1,SIZE(VAR,1)
        H=COV(I,I)*COV(J,J)
        IF(H.GT.0.0D0)THEN
         COR(I,J)=COV(I,J)/SQRT(H)
        ELSE
         COR(I,J)=0.0D0
        ENDIF
       ENDDO
      ENDDO
   
      !## add minimal correlation on measurements
      H=MINVAL(ABS(COR))
      DO I=1,MSR%NOBS
       IF(MSR%LOC(I).LT.0)THEN
        MSR%COR(I)=H
        MSR%LOC(I)=ABS(MSR%LOC(I))
        !## if not in current selected dataset (overlap) set weighting to zero
        DO II=1,SIZE(VARIDATE)
         IF(MSR%IDATE(I).EQ.VARIDATE(II))EXIT
        ENDDO
        IF(II.GT.SIZE(VARIDATE))MSR%W(I)=0.0D0
       ENDIF
      ENDDO
   
      DEALLOCATE(VAR,COV,STD,COR,VARIDATE)

     ENDDO
    
    ENDDO; ENDDO
    DEALLOCATE(AVGOBS)
    
   ENDIF
  
   ALLOCATE(AVGOBS(PRJIDF%NCOL,PRJIDF%NROW),AVGCOM(PRJIDF%NCOL,PRJIDF%NROW), &
            AVGW(PRJIDF%NCOL,PRJIDF%NROW),  SUMW(PRJIDF%NCOL,PRJIDF%NROW))

   !## apply average measurements/computed values
   DO IPER=1,PRJNPER
    DO ILAY=1,PRJNLAY
     AVGOBS=0.0D0; AVGCOM=0.0D0; NUMOBS=0.0D0; AVGW=0.0D0; SUMW=0.0D0
     DO II=1,MSR%NOBS
      IF(MSR%L(II).NE.ILAY)CYCLE
      IF(SIM(IPER)%CDATE.NE.'STEADY-STATE')THEN
       WRITE(CDATE,'(I4.4,6I2.2)') SIM(IPER)%IYR,SIM(IPER)%IMH,SIM(IPER)%IDY,SIM(IPER)%IHR,SIM(IPER)%IMT,SIM(IPER)%ISC
       IF(TRIM(CDATE).NE.TRIM(VTOS(MSR%IDATE(II))))CYCLE
      ELSE
       IF(MSR%IDATE(II).NE.0D0)CYCLE
      ENDIF
      CALL IDFIROWICOL(PRJIDF,IROW,ICOL,MSR%X(II),MSR%Y(II))
      IF(IROW.EQ.0.OR.ICOL.EQ.0)THEN
       WRITE(*,'(/A/)') 'Assignment of an observation yields a location outside the current modelling domain'; PAUSE; STOP
      ENDIF
      H=MSR%C(II)
      Z=MSR%O(II)
      W=MSR%W(II)
      AVGOBS(ICOL,IROW)=AVGOBS(ICOL,IROW)+Z*W
      AVGCOM(ICOL,IROW)=AVGCOM(ICOL,IROW)+H*W
      AVGW  (ICOL,IROW)=AVGW  (ICOL,IROW)+W*W
      SUMW  (ICOL,IROW)=SUMW  (ICOL,IROW)+W
      NUMOBS(ICOL,IROW)=NUMOBS(ICOL,IROW)+1.0D0
     ENDDO
    
     !## do something with stdev van de metingen binnen 1 cel
     DO II=1,MSR%NOBS
      IF(MSR%L(II).NE.ILAY)CYCLE
      IF(SIM(IPER)%CDATE.NE.'STEADY-STATE')THEN
       WRITE(CDATE,'(I4.4,6I2.2)') SIM(IPER)%IYR,SIM(IPER)%IMH,SIM(IPER)%IDY,SIM(IPER)%IHR,SIM(IPER)%IMT,SIM(IPER)%ISC
       IF(TRIM(CDATE).NE.TRIM(VTOS(MSR%IDATE(II))))CYCLE
      ELSE
       IF(MSR%IDATE(II).NE.0D0)CYCLE
      ENDIF
      CALL IDFIROWICOL(PRJIDF,IROW,ICOL,MSR%X(II),MSR%Y(II))
      Z=AVGOBS(ICOL,IROW)
      H=AVGCOM(ICOL,IROW)
      W=AVGW  (ICOL,IROW)
      N=SUMW  (ICOL,IROW)
      IF(N.NE.0.0D0)THEN
       Z=Z/N
       H=H/N
       W=W/N
       N=NUMOBS(ICOL,IROW)
       W=W/N
      ELSE
       W=0.0D0
      ENDIF
      MSR%C(II)=H
      MSR%O(II)=Z
      MSR%W(II)=W
     ENDDO
    ENDDO
   ENDDO
   DEALLOCATE(AVGOBS,AVGCOM,AVGW,SUMW,NUMOBS) 
  ENDIF
 
 ENDIF
 
 !## postprocess batch files and fill in observations
 IF(.NOT.PEST_GLM_BATCHFILES(2,CTYPE,IPARAM))THEN
   IPEST_GLM_GETJ_AVG=.FALSE.; RETURN
 ENDIF
 
 !## write summary of residuals (data)
 DO II=1,MSR%NOBS
  H=MSR%C(II)
  Z=MSR%O(II)

  H=REAL(INT(H*10000.0D0),8)/10000.0D0
  Z=REAL(INT(Z*10000.0D0),8)/10000.0D0
  
  !## random error not yet set
  CALL IPEST_GLM_ADDNOISE(II,SEED,LYN)
  
  !## add random error
  Z=Z+MSR%E(II)

  !## calculated - measured
  DHH=H-Z
  DRES=PEST%PE_DRES
  
  IF(DRES.EQ.0.0D0)DRES=MSR%D(II)

  !## exclude big residuals
  IF(DRES.LT.0.0D0)THEN
   IF(ABS(DHH).GT.ABS(DRES))DHH=0.0D0
  ELSE 
   DHH=DHH-DRES
  ENDIF 
  
  !## save information for measurement
  SELECT CASE (TRIM(CTYPE))
   CASE ('P')
    MSR%HG(IGRAD,II)=H
   CASE ('R')
    MSR%HG(IGRAD,II)=H
    MSR%IESC(IGRAD,II)=H
   CASE ('L')
    MSR%HL(IGRAD,II) =H  
    MSR%DHL(IGRAD,II)=DHH
  END SELECT
 
  GF_H(II)=H
  GF_O(II)=Z
  
  !## compute part of objective function weighted
  DHW=MSR%W(II)*DHH**2.0D0
  !## add to total objective function
  MSR%TJ=MSR%TJ+DHW
  !## set limited objective function value - weighted for a point
  MSR%LIMJ=MSR%LIMJ+MSR%W(II)*DRES**2.0D0

  IF(MSR%IDATE(II).EQ.0)THEN   
   IF(IUPESTRESIDUAL.GT.0.AND.(TRIM(CTYPE).EQ.'L'.OR.TRIM(CTYPE).EQ.'R'))THEN
    WRITE(IUPESTRESIDUAL,'(2(F15.2,A1),I10,A1,6(F15.3,A1),I10,A1,A32)') &
       MSR%X(II),',',MSR%Y(II),',',MSR%L(II),',',MSR%O(II),',',MSR%C(II),',',MSR%C(II)-MSR%O(II),',',DHH,',', &
       MSR%W(II)*DHH,',',MSR%W(II),',',MSR%IPF(II),',',MSR%CLABEL(II)
   ENDIF
  ELSE
   IF(IUPESTRESIDUAL.GT.0.AND.(TRIM(CTYPE).EQ.'L'.OR.TRIM(CTYPE).EQ.'R'))THEN
    IF(PEST%PE_TARGET(1).GT.0.0D0)THEN
     WRITE(IUPESTRESIDUAL,'(2(F15.2,A1),I10,A1,8(F15.3,A1),I10,A1,A32,A1,I15)') &
       MSR%X(II),',',MSR%Y(II),',',MSR%L(II),',',MSR%W(II),',',MSR%O(II),',',MSR%C(II),',',DHH,',',MSR%COR(II),',',-999.0,',',-999.0,',', &
       MSR%NS(II),',',MSR%IPF(II),',',MSR%CLABEL(II),',',MSR%IDATE(II)
    ELSE
     WRITE(IUPESTRESIDUAL,'(2(F15.2,A1),I10,A1,8(F15.3,A1),I10,A1,A32,A1,I15)') &
       MSR%X(II),',',MSR%Y(II),',',MSR%L(II),',',MSR%W(II),',',-999.0,',',-999.0,',',-999.0,',',MSR%O(II),',',MSR%C(II),',',DHH,',', &
       MSR%NS(II),',',MSR%IPF(II),',',MSR%CLABEL(II),',',MSR%IDATE(II)
    ENDIF
   ENDIF
  ENDIF
  IF(IUPESTPRESIDUAL.GT.0)THEN
   WRITE(IUPESTPRESIDUAL,'(2(F15.2,A1),I10,A1,4(F15.3,A1),2(I10,A1),A32,A1,I14)') MSR%X(II),',',MSR%Y(II),',',MSR%L(II),',',MSR%O(II),',',MSR%C(II),',', &
                            MSR%W(II),',',MSR%D(II),',',MSR%IPF(II),',',MSR%LOC(II),',',ADJUSTR(MSR%CLABEL(II)),',',MSR%IDATE(II)
  ENDIF
 ENDDO

 IF(ALLOCATED(ID1))DEALLOCATE(ID1); IF(ALLOCATED(ID2))DEALLOCATE(ID2)
 
 MSR%LIMJ=MAX(PEST%PE_STOP,MSR%LIMJ)
 
! write(*,*) 'msr%tj,msr%rj',msr%tj,msr%rj
 
 !## add parameter regularisation (not in gradient-simulations: why not?, should be!)
 IF(PEST%PE_REGULARISATION.NE.0)THEN 

  !## insert regularisation to objective function
  NP=0; DO I=1,SIZE(PEST%PARAM); IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE; NP=NP+1; ENDDO
 
  ALLOCATE(DF(NP,1)); DF=0.0D0
  
  !## total weight observations
  MU=MU_INI; IF(PEST%PE_MXITER.LT.-1)MU=1.0D0
  
  NP=0; DO I=1,SIZE(PEST%PARAM)  !## row
   !## skip others parts of parameter only from groups
   IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE
   NP=NP+1
   IF(CTYPE.EQ.'L')THEN
    F1=PEST%PARAM(I)%LALPHA(IGRAD)
   ELSEIF(CTYPE.EQ.'P')THEN
    F1=PEST%PARAM(I)%GALPHA(IGRAD)
   ENDIF
   !## add balance-weighting
   F2=PEST%PARAM(I)%PPRIOR
   SELECT CASE (PEST%PE_REGULARISATION)
    !## homogenization
    CASE (1)
     !## objective (homogenization)
     DF(NP,1)=F1-F2
    !## preferred parameter
    CASE (2)
     !## minimal error compared to prior value
     DF(NP,1)=0.0D0-(F1-F2)
   END SELECT
  
  ENDDO
  
  SELECT CASE (PEST%PE_REGULARISATION)
   !## get difference weighted with semivariance
   CASE (1)
    DF=MATMUL(QO,DF)
  END SELECT
  
  JR=MATMUL(MATMUL(TRANSPOSE(DF),QR),DF)
 
  !## add balance-weighting
  MSR%RJ=MU*JR(1,1)
  IF(MSR%RJ.LE.0.0D0)THEN
   WRITE(*,*) MSR%RJ !; PAUSE
  ENDIF
!  write(*,*) 'mu,jr(1,1),msr%rj',mu,jr(1,1),msr%rj
 
 ENDIF
 
 MSR%TJ=MSR%TJ+MSR%RJ
 
 !## limited measurement objective function
 IF(PEST%PE_REGULARISATION.NE.0)THEN
  IF(MSR%LIMJ.EQ.0.0D0)THEN
   WRITE(*,'(/A/)') '>>> YOU SHOULD SET THE LIMITED MEASUREMENT OBJECTIVE FUNCTION ABOVE ZERO (DRES or IDCOL OR PE_STOP > 0) <<<'; PAUSE; STOP
  ENDIF
 ENDIF
 WRITE(*,'(A)') 'LIMITED OBJECTIVE FUNCTION :'//TRIM(VTOS(MSR%LIMJ,'F',5))
 
 IF(IUPESTRESIDUAL.GT.0) CLOSE(IUPESTRESIDUAL);  IUPESTRESIDUAL=0
 IF(IUPESTPRESIDUAL.GT.0)CLOSE(IUPESTPRESIDUAL); IUPESTPRESIDUAL=0
 IF(ALLOCATED(MEASURES))DEALLOCATE(MEASURES)
 
 IPEST_GLM_GETJ_AVG=.TRUE.

 END FUNCTION IPEST_GLM_GETJ_AVG

 !###====================================================================
 SUBROUTINE PEST_GLM_ADD_BATCHFILES(IU,CTYPE,IPARAM) 
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IU,IPARAM
 CHARACTER(LEN=*),INTENT(IN) :: CTYPE
 INTEGER :: I,J
 CHARACTER(LEN=256) :: COMMANDLINE,DIRNAME
 
 !## skip if not ipestp activated
 IF(PBMAN%IPESTP.EQ.0)RETURN
 
 !## run batchfile locally
 IF(.NOT.ASSOCIATED(PEST%B_BATCHFILE))RETURN

 CALL IOSDIRNAME(DIRNAME) 

 !## goto folder
 WRITE(IU,'(/A)') 'CD /D '//TRIM(PBMAN%OUTPUT)

 !## compute what needs to be computed first
 DO I=1,SIZE(PEST%B_BATCHFILE)
  WRITE(IU,'(/50A1)') ('=',J=1,50)
  WRITE(IU,'(A    )') 'REM Executing: '//TRIM(PEST%B_BATCHFILE(I))
  WRITE(IU,'(50A1/)') ('=',J=1,50)
  !## add argument of current model; in case the batchfile needs it
  COMMANDLINE=TRIM(PEST%B_BATCHFILE(I))//' '//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM))
  WRITE(IU,'(A )') 'START /B /WAIT '//TRIM(COMMANDLINE)
  WRITE(IU,'(/A)') 'IF %ERRORLEVEL% NEQ 0 (ECHO AN ERROR WAS FOUND %EXIT /B %ERRORLEVEL%)'
 ENDDO

 !## got back
 WRITE(IU,'(/A)') 'CD /D '//TRIM(DIRNAME)

 END SUBROUTINE PEST_GLM_ADD_BATCHFILES
 
 !###====================================================================
 LOGICAL FUNCTION PEST_GLM_BATCHFILES(IOPTION,CTYPE,IPARAM) 
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: IOPTION,IPARAM
 CHARACTER(LEN=*),INTENT(IN) :: CTYPE
 INTEGER :: I,II,J,N,NR,IUBAT,IIPF,IFLAGS
 LOGICAL :: LEX
 CHARACTER(LEN=256) :: DIRNAME,FNAME

 !## run batchfile locally
 PEST_GLM_BATCHFILES=.TRUE.; IF(.NOT.ASSOCIATED(PEST%B_BATCHFILE))RETURN
 
 PEST_GLM_BATCHFILES=.FALSE.

 IFLAGS=PROCCMDPROC+PROCBLOCKED

 N=SIZE(PEST%B_BATCHFILE); IF(.NOT.ASSOCIATED(PEST%B_NOBS))ALLOCATE(PEST%B_NOBS(N)); PEST%B_NOBS=0
 
 CALL IOSDIRNAME(DIRNAME); CALL IOSDIRCHANGE(PBMAN%OUTPUT)
 WRITE(*,'(/A)') 'Currently iMOD operates BATCHFILES here: '//TRIM(PBMAN%OUTPUT)
 
 !## get maximum number of observations
 DO I=1,SIZE(PEST%B_BATCHFILE)
  !## skip this batchfile for processing
  IF(PEST%B_FRACTION(I).LE.0.0D0)CYCLE
  
  !## try to replace $run$ by current model
  FNAME=UTL_CAP(PEST%B_OUTFILE(I),'U')
  CALL UTL_SUBST(FNAME,'$RUN$','IPEST_'//TRIM(CTYPE)//'#'//TRIM(VTOS(IPARAM)))
  
  INQUIRE(FILE=FNAME,EXIST=LEX)
  IF(.NOT.LEX)THEN
   WRITE(*,'(/A)') '>>> Cannot find: '//TRIM(FNAME)
   WRITE(*,'(A )') '    ioption= '//TRIM(VTOS(IOPTION))
   WRITE(*,'(A )') '    ctype  = '//TRIM(CTYPE)
   WRITE(*,'(A )') '    iparam = '//TRIM(VTOS(IPARAM))//' <<<'
   WRITE(*,'(A/)') '    Model is restarted <<<'
   PAUSE; RETURN
  ENDIF
  
  IUBAT=UTL_GETUNIT(); OPEN(IUBAT,FILE=FNAME,STATUS='OLD')
  READ(IUBAT,*) PEST%B_NOBS(I)

  WRITE(*,'(1X,A)') ' Found '//TRIM(VTOS(PEST%B_NOBS(I)))//' measurements from '//TRIM(FNAME)

  IF(IOPTION.EQ.2)THEN
 
   READ(IUBAT,*) NR

   WRITE(*,'(1X,A)') ' Reading them ...'

   !## check whether it is an IPF file
   IIPF=0; IF(INDEX(UTL_CAP(PEST%B_OUTFILE(I),'U'),'IPF').GT.0)THEN
   
    DO J=1,NR+1; READ(IUBAT,*); ENDDO
    IIPF=1
    
   ENDIF
   
   J=MSR%NOBS
   DO II=1,PEST%B_NOBS(I)
    J=J+1
    IF(IIPF.EQ.1)THEN
     READ(IUBAT,*) MSR%X(J),MSR%Y(J),MSR%CLABEL(J),MSR%O(J),MSR%W(J),MSR%C(J)
    ELSE
     READ(IUBAT,*) MSR%CLABEL(J),MSR%O(J),MSR%W(J),MSR%C(J)
     MSR%X(J)=-999.99D0; MSR%Y(J)=-999.99D0
    ENDIF
    MSR%D(J)    =0.0D0
    MSR%L(J)    =0
    MSR%NS(J)   =0.0D0
    MSR%IDATE(J)=0
    MSR%IPF(J)  =I
    MSR%LOC(J)  =II
   ENDDO
   MSR%NOBS=J

  ENDIF
  CLOSE(IUBAT)
 ENDDO

 CALL IOSDIRCHANGE(DIRNAME); WRITE(*,'(A/)') 'Currently iMOD operates MODELS here: '//TRIM(DIRNAME)
 
 PEST_GLM_BATCHFILES=.TRUE.
 
 END FUNCTION PEST_GLM_BATCHFILES
 
 !###====================================================================
 SUBROUTINE IPEST_GLM_ADDNOISE(II,SEED,LYN)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(INOUT) :: SEED
 INTEGER,INTENT(IN) :: II
 REAL(KIND=DP_KIND) :: SIGMA,E
 LOGICAL,INTENT(INOUT) :: LYN
 CHARACTER(LEN=1) :: YN
 
 IF(PBMAN%IIES.EQ.1)THEN
  !## initiate measurement error
  IF(MSR%E(II).EQ.-999.99D0)THEN
   IF(MSR%W(II).NE.0.0D0)THEN
    !## compute stdev from weights again
    SIGMA=SQRT(1.0D0/MSR%W(II)**2.0D0)
    IF(SIGMA.GT.1.0D0.AND.LYN)THEN
     WRITE(*,'(/A$/)') 'Found STDEV for measurement of > 1.0 ('//TRIM(VTOS(SIGMA,'F',3))//'), Are you sure this correct ?'
     READ(*,'(A1)') YN; IF(YN.NE.'Y'.AND.YN.NE.'y')STOP; LYN=.FALSE.
    ENDIF
    E=MSR%E(II)
    CALL IPEST_NORMAL_MS_SAMPLE(0.0D0,SIGMA,SEED,E)
    MSR%E(II)=E
   ELSE
    MSR%E(II)=0.0D0
   ENDIF
  ENDIF
 ELSE
  MSR%E(II)=0.0D0
 ENDIF
 
 END SUBROUTINE IPEST_GLM_ADDNOISE
 
! !###====================================================================
! REAL(KIND=DP_KIND) FUNCTION IPEST_GLM_BALANCEFACTOR()
! !###====================================================================
! IMPLICIT NONE
! REAL(KIND=DP_KIND) :: WO,WP
! INTEGER :: I,NP,NO
! 
! WO=0.0D0; NO=0; DO I=1,MSR%NOBS
!  WO=WO+MSR%W(I)
!  NO=NO+1
! ENDDO
! !## total weight parameters (diagonal of weight parameters)
! WP=0.0D0; NP=0; DO I=1,SIZE(PEST%PARAM)  !## row
!  !## skip others parts of parameter
!  IF(PEST%PARAM(I)%PIGROUP.LE.0)CYCLE
!  NP=NP+1
!  !## add only if the parameter is active
!  IF(PEST%PARAM(I)%PACT.EQ.1)WP=WP+QR(NP,NP)
! ENDDO
! !## determine balance factor
! MU_INI=WO/WP
!
! IPEST_GLM_BALANCEFACTOR=MU_INI
! 
!! !## MET NUL GEEFT EXACT ZELFDE RESULTAAT ALS ZONDER REGUARISATIE - DAT IS CORRECT
!! IPEST_GLM_BALANCEFACTOR=0.0D0
! 
! END FUNCTION IPEST_GLM_BALANCEFACTOR
 
 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_CREATE_RESIDUALSFILES(DIR,IGRAD,CTYPE,MNAME) 
 !###====================================================================
 IMPLICIT NONE
 CHARACTER(LEN=*),INTENT(IN) :: DIR,CTYPE,MNAME
 INTEGER,INTENT(IN) :: IGRAD
 INTEGER :: IU,JU,KU,ISUB,NPER,NOBS,IOBS,IPER,N,MPER,IOS
 INTEGER,ALLOCATABLE,DIMENSION(:) :: NMES
 REAL(KIND=DP_KIND) :: CUMTT,DH,DHW,NODATA
 CHARACTER(LEN=52) :: TXT,CFOLDER
 CHARACTER(LEN=256) :: FNAME
 TYPE HTYPE
  INTEGER(KIND=DP_KIND) :: ITIME
  INTEGER :: ILAY
  REAL(KIND=DP_KIND) :: H,W,M,D
 END TYPE HTYPE
 TYPE(HTYPE),ALLOCATABLE,DIMENSION(:,:) :: H
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: X,Y
 CHARACTER(LEN=40),ALLOCATABLE,DIMENSION(:) :: ONAME
 
 IPEST_GLM_CREATE_RESIDUALSFILES=.FALSE.
 
 IF(TRIM(CTYPE).EQ.'')THEN 
  CALL UTL_CREATEDIR(TRIM(DIR)//'\TIMESERIES')
  FNAME=TRIM(DIR)//'\TIMESERIES\OUTPUT_OBS.IPF_' 
 ELSE
  CALL UTL_CREATEDIR(TRIM(DIR)//'\IPEST_'//CTYPE//'#'//TRIM(VTOS(IGRAD))//'\TIMESERIES')
  FNAME=TRIM(DIR)//'\IPEST_'//CTYPE//'#'//TRIM(VTOS(IGRAD))//'\TIMESERIES\OUTPUT_OBS.IPF_' 
 ENDIF
 
 IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
 WRITE(IU,'(A)') 'NaN1#'
 IF(PRJNPER.EQ.1)THEN
  WRITE(IU,'(A)') '10'
 ELSE
  WRITE(IU,'(A)') '7'
 ENDIF
 WRITE(IU,'(A)') 'X-COORDINATE'
 WRITE(IU,'(A)') 'Y-COORDINATE'
 WRITE(IU,'(A)') 'MODELLAYER'
 WRITE(IU,'(A)') 'OBSERVATION'
 WRITE(IU,'(A)') 'WEIGHT'
 IF(PRJNPER.EQ.1)THEN
  WRITE(IU,'(A)') 'COMPUTED_HEAD'
  WRITE(IU,'(A)') 'DIFFERENCE'
  WRITE(IU,'(A)') 'WEIGHTED_DIFFERENCE'
 ENDIF
 WRITE(IU,'(A)') 'ACCEPTABLE_ERROR'
 WRITE(IU,'(A)') 'ORG_MEASUREMENT_NUMBER'
 IF(PRJNPER.EQ.1)THEN
  WRITE(IU,'(A)') '0,TXT'
 ELSE
  WRITE(IU,'(A)') '4,TXT'
 ENDIF
 
 N=0; DO ISUB=1,PBMAN%NSUBMODEL

  IF(PBMAN%IFORMAT.EQ.3)CFOLDER='\GWF_'//TRIM(VTOS(ISUB))//'\MODELOUTPUT\'
  IF(PBMAN%IFORMAT.EQ.6)CFOLDER='\'
  
  !## skip zero
  IF(TRIM(CTYPE).EQ.'')THEN
   FNAME=TRIM(DIR)//TRIM(CFOLDER)//'OUTPUT_OBS.TXT'
  ELSE
   IF(PBMAN%IFORMAT.EQ.3)THEN
    FNAME=TRIM(DIR)//TRIM(CFOLDER)//'IPEST_'//TRIM(CTYPE)//'#'// &
          TRIM(VTOS(IGRAD))//'\OUTPUT_OBS_'//TRIM(CTYPE)//'#'//TRIM(VTOS(IGRAD))//'.TXT'
   ELSE
    FNAME=TRIM(DIR)//TRIM(CFOLDER)//'IPEST_'//TRIM(CTYPE)//'#'// &
          TRIM(VTOS(IGRAD))//'\OUTPUT_OBS_'//TRIM(CTYPE)//'#'//TRIM(VTOS(IGRAD))//'._OS'
   ENDIF
  ENDIF
  JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=FNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED'); IF(JU.EQ.0)THEN; CLOSE(IU); RETURN; ENDIF

  IF(PBMAN%IFORMAT.EQ.3)THEN
   IF(PBMAN%IFORMAT.EQ.3)CFOLDER='\GWF_'//TRIM(VTOS(ISUB))//'\'
   FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//TRIM(MNAME)//'.MES6'
  ELSE
   FNAME=TRIM(DIR)//TRIM(CFOLDER)//'MODELINPUT\'//TRIM(MNAME)//'.MES7'
  ENDIF
  KU=UTL_GETUNIT(); CALL OSD_OPEN(KU,FILE=FNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED')
  IF(KU.EQ.0)THEN; CLOSE(JU); CLOSE(IU); RETURN; ENDIF
  
  READ(KU,*)
  READ(KU,*)
  READ(KU,*) TXT,NPER
  READ(KU,*) TXT,NOBS
  READ(KU,*) TXT,NODATA

  IF(NOBS.GT.0)THEN
   ALLOCATE(H(NOBS,NPER),ONAME(NOBS),X(NOBS),Y(NOBS),NMES(NOBS))
   
   READ(KU,*)
   !## read measurements from mes6 file (not used directly by modflow6 and/or seawat)
   DO IOBS=1,NOBS
    READ(KU,*)
    READ(KU,*) ONAME(IOBS),NMES(IOBS),X(IOBS),Y(IOBS)
    IF(NMES(IOBS).NE.NPER)THEN
     WRITE(*,'(/A/)') 'Something goes wrong (number of stressperiods in OBS6 and MET6 ne number of stresses'; STOP
    ENDIF
    READ(KU,*)
    DO IPER=1,NMES(IOBS)
     READ(KU,*,IOSTAT=IOS) H(IOBS,IPER)%ITIME,H(IOBS,IPER)%M,H(IOBS,IPER)%D,H(IOBS,IPER)%W,H(IOBS,IPER)%ILAY
     
     !## weight is always specified in stdev
     H(IOBS,IPER)%W=1.0D0/H(IOBS,IPER)%W**2.0D0

     !## error probabily MF6 faces an issue running/closing, try to restart
     IF(IOS.NE.0)THEN
      CLOSE(IU); CLOSE(JU); CLOSE(KU); INQUIRE(UNIT=KU,NAME=FNAME)
      WRITE(*,'(1X,A)') '>>> ERROR READING FILE (IOS='//TRIM(VTOS(IOS))//'): '//TRIM(FNAME)//' <<<'
      RETURN
     ENDIF     
    ENDDO
   ENDDO
   
   !## read computed heads from mf6
   IF(PBMAN%IFORMAT.EQ.3)THEN
    READ(JU,*)
    DO IPER=1,NPER
     READ(JU,*,IOSTAT=IOS) CUMTT,(H(IOBS,IPER)%H,IOBS=1,NOBS)
     !## error probabily MF6 faces an issue running/closing, try to restart
     IF(IOS.NE.0)THEN
      CLOSE(IU); CLOSE(JU); CLOSE(KU); INQUIRE(UNIT=JU,NAME=FNAME)
      WRITE(*,'(1X,A)') '>>> ERROR READING FILE (IOS='//TRIM(VTOS(IOS))//'): '//TRIM(FNAME)//' <<<'
      RETURN
     ENDIF
    ENDDO
   !## read computed heads from seawat
   ELSE
    DO IOBS=1,NOBS
     DO IPER=1,NPER
      READ(JU,*,IOSTAT=IOS) H(IOBS,IPER)%H
      !## error probably MF6 faces an issue running/closing, try to restart
      IF(IOS.NE.0)THEN
       CLOSE(IU); CLOSE(JU); CLOSE(KU); INQUIRE(UNIT=JU,NAME=FNAME)
       WRITE(*,'(1X,A)') '>>> ERROR READING FILE (IOS='//TRIM(VTOS(IOS))//'): '//TRIM(FNAME)//' <<<'
       RETURN
      ENDIF
     ENDDO
    ENDDO
   ENDIF
   
   !## close files
   CLOSE(JU); CLOSE(KU)

   !## store them in aggregated IPF-file
   DO IOBS=1,NOBS
    N=N+1
    
    IF(PRJNPER.EQ.1)THEN
     IPER=1
     DH =H(IOBS,IPER)%H-H(IOBS,IPER)%M
     DHW=DH*H(IOBS,IPER)%W
     WRITE(IU,'(A)') TRIM(VTOS(X(IOBS),'F',3))       //','//TRIM(VTOS(Y(IOBS),'F',3))       //','//TRIM(VTOS(H(IOBS,IPER)%ILAY))//','// &
                     TRIM(VTOS(H(IOBS,IPER)%M,'F',6))//','//TRIM(VTOS(H(IOBS,IPER)%W,'F',3))//','//TRIM(VTOS(H(IOBS,IPER)%H,'F',6))//','// &
                     TRIM(VTOS(DH,'F',6))            //','//TRIM(VTOS(DHW,'F',6))           //','//TRIM(VTOS(H(IOBS,IPER)%D,'F',6))//','// &
                     TRIM(VTOS(IOBS))
    ELSE
     FNAME=ONAME(IOBS)
     !## find first correct value for w and d
     DO IPER=1,NPER; IF(H(IOBS,IPER)%M.NE.NODATA)EXIT; ENDDO
     IF(IPER.LE.NPER)THEN
      WRITE(IU,'(A)') TRIM(VTOS(X(IOBS),'F',3))//','//TRIM(VTOS(Y(IOBS),'F',3))//','//TRIM(VTOS(H(IOBS,1)%ILAY))//','// &
                       TRIM(FNAME)//','//TRIM(VTOS(H(IOBS,IPER)%W,'F',3))//','//TRIM(VTOS(H(IOBS,IPER)%D,'F',3))//','//TRIM(VTOS(IOBS))
     ELSE
      WRITE(IU,'(A)') TRIM(VTOS(X(IOBS),'F',3))//','//TRIM(VTOS(Y(IOBS),'F',3))//','//TRIM(VTOS(H(IOBS,1)%ILAY))//','// &
                       TRIM(FNAME)//','//TRIM(VTOS(0.0D0,'F',3))//','//TRIM(VTOS(0.0D0,'F',3))//','//TRIM(VTOS(IOBS))
     ENDIF
     IF(TRIM(CTYPE).EQ.'')THEN
      FNAME=TRIM(DIR)//'\TIMESERIES\'//TRIM(FNAME)//'.TXT'
     ELSE
      FNAME=TRIM(DIR)//'\IPEST_'//CTYPE//'#'//TRIM(VTOS(IGRAD))//'\TIMESERIES\'//TRIM(FNAME)//'.TXT'
     ENDIF
     JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
     MPER=0; DO IPER=1,NPER
      IF(H(IOBS,IPER)%ITIME.EQ.0)CYCLE; MPER=MPER+1
     ENDDO
     WRITE(JU,'(A)') TRIM(VTOS(MPER))
     WRITE(JU,'(A)') '3,1'
     WRITE(JU,'(A)') 'IDATE,-9999'
     WRITE(JU,'(A)') 'MEASURED,'//TRIM(VTOS(HNOFLOW,'G',6))
     WRITE(JU,'(A)') 'COMPUTED,'//TRIM(VTOS(HNOFLOW,'G',6))
     DO IPER=1,NPER
      IF(H(IOBS,IPER)%ITIME.EQ.0)CYCLE
      WRITE(JU,'(A)') TRIM(VTOS(H(IOBS,IPER)%ITIME))//','//TRIM(VTOS(H(IOBS,IPER)%M,'G',6))//','// &
                      TRIM(VTOS(H(IOBS,IPER)%H,'G',6))
     ENDDO
     CLOSE(JU)
    ENDIF
   ENDDO
   DEALLOCATE(H,ONAME,X,Y)
  
  ELSE

   !## close files
   CLOSE(JU); CLOSE(KU)
  
  ENDIF
  
 ENDDO
 CLOSE(IU)
 
 !## update number of records in ipf file
 IF(TRIM(CTYPE).EQ.'')THEN
  CALL UTL_MF2005_MAXNO(TRIM(DIR)//'\TIMESERIES\OUTPUT_OBS.IPF_',(/N/))
 ELSE
  CALL UTL_MF2005_MAXNO(TRIM(DIR)//'\IPEST_'//CTYPE//'#'//TRIM(VTOS(IGRAD))//'\TIMESERIES\OUTPUT_OBS.IPF_',(/N/))
 ENDIF
 
 IPEST_GLM_CREATE_RESIDUALSFILES=.TRUE.
 
 END FUNCTION IPEST_GLM_CREATE_RESIDUALSFILES
  
 !#####=================================================================
 SUBROUTINE IPEST_GLM_PROGRESS(ITER,JGRAD,IGRAD,CTYPE,LAMBDA)
 !#####=================================================================
 IMPLICIT NONE
 CHARACTER(LEN=1),INTENT(IN) :: CTYPE
 INTEGER,INTENT(IN) :: JGRAD,IGRAD,ITER
 REAL(KIND=DP_KIND),INTENT(IN) :: LAMBDA
 REAL(KIND=DP_KIND) :: X1,X2,ETM,ETP
 INTEGER :: CLOCK_RATE
 
 IF(CTYPE.EQ.'P')THEN
  !## present parameter value
  X1=PEST%PARAM(IGRAD)%GALPHA(JGRAD)
  IF(PEST%PARAM(IGRAD)%PLOG.EQ.1)X1=EXP(X1)
  IF(PEST%PARAM(IGRAD)%PLOG.EQ.2)X1=10.0D0**X1
  X2=PEST%PARAM(IGRAD)%ALPHA(2)
  IF(PEST%PARAM(IGRAD)%PLOG.EQ.1)X2=EXP(X2)
  IF(PEST%PARAM(IGRAD)%PLOG.EQ.2)X2=10.0D0**X2
 ELSEIF(CTYPE.EQ.'R')THEN
  !## present lambda
  X1=LAMBDA 
 ELSEIF(CTYPE.EQ.'L')THEN
  !## present lambda
  X1=LAMBDA*PBMAN%LAMBDA_TEST(JGRAD) 
 ENDIF

 CALL SYSTEM_CLOCK(ETIME(JGRAD),CLOCK_RATE)
 ETM=REAL(ETIME(JGRAD )-STIME(JGRAD ),8)/REAL(CLOCK_RATE,8)
 ETP=REAL(ETIMEJ(JGRAD)-STIMEJ(JGRAD),8)/REAL(CLOCK_RATE,8)

 !## sensitivity
 IF(MSR%NOBS.GT.0)THEN

  IF(CTYPE.EQ.'P')THEN
   IF(INSENS(JGRAD).EQ.0)THEN
    WRITE(IUPESTPROGRESS,'(I5,A15,4F15.3,30X,2F15.3)') IGRAD,PEST%PARAM(IGRAD)%ACRONYM,X1,MSR%TJ,MSR%TJ-MSR%PJ,X2,ETM,ETP
   ELSE
    WRITE(IUPESTPROGRESS,'(I5,A15,F15.3,2A15,F15.5,A15)') IGRAD,PEST%PARAM(IGRAD)%ACRONYM,X2,'NaN','NaN',X2,'> insensitive <' 
   ENDIF
  !## lambda testing
  ELSEIF(CTYPE.EQ.'L')THEN
   IF(ITER.EQ.0)THEN
    WRITE(IUPESTPROGRESS,'(I5,30X,F15.3,30X,4F15.3)') 0,MSR%TJ,MSR%GOF(JGRAD),MSR%NSC(JGRAD),ETM,ETP
   ELSE
    WRITE(IUPESTPROGRESS,'(I5,A15,F15.3,2F15.3,15X,4F15.3)') IGRAD,'LAMBDA'//TRIM(VTOS(JGRAD)),X1,MSR%TJ,MSR%TJ-MSR%PJ, &
                                         MSR%GOF(JGRAD),MSR%NSC(JGRAD),ETM,ETP
   ENDIF
  !## realization
  ELSEIF(CTYPE.EQ.'R')THEN
   IF(ITER.EQ.0)THEN
    WRITE(IUPESTPROGRESS,'(I5,A15,2F15.3,30X,4F15.3)')       IGRAD,'REALS'//TRIM(VTOS(JGRAD)),X1,MSR%TJ,MSR%GOF(JGRAD),MSR%NSC(JGRAD),ETM,ETP
   ELSE
    WRITE(IUPESTPROGRESS,'(I5,A15,2F15.3,F15.3,15X,4F15.3)') IGRAD,'REALS'//TRIM(VTOS(JGRAD)),X1,MSR%TJ,MSR%TJ-JE(IGRAD,ITER-1),&
                                         MSR%GOF(JGRAD),MSR%NSC(JGRAD),ETM,ETP
   ENDIF
   JE(IGRAD,ITER)=MSR%TJ
   WRITE(IUPESTOUT,'(I5,7X,F15.3)') ITER,MSR%TJ
  ENDIF
 ENDIF
 
 END SUBROUTINE IPEST_GLM_PROGRESS
 
 !###====================================================================
 LOGICAL FUNCTION IPEST_GLM_ALLOCATEMSR(NDIM1,NDIM2,NDIM3,MEASURES) 
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NDIM1,NDIM2,NDIM3
 TYPE(PSTMEASURE),DIMENSION(:),INTENT(IN) :: MEASURES
 INTEGER :: I,N1,N2,N,M,O,IOS,IU
 CHARACTER(LEN=256) :: FNAME
 
 IPEST_GLM_ALLOCATEMSR=.FALSE.

 CALL IPEST_GLM_DEALLOCATEMSR()

 IF(NDIM1.EQ.0)THEN
  !## open files and get total maximum number of observations
  N=0; DO I=1,SIZE(MEASURES)
   FNAME=MEASURES(I)%IPFNAME
   IF(INDEX(FNAME,'.\').GT.0)THEN
    CALL UTL_SUBST(FNAME,'.\',TRIM(PREFDIR)//'\')
    CALL UTL_SUBST(FNAME,'\\','\')
   ENDIF
   IU=UTL_GETUNIT(); OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ')
   READ(IU,*) M; CLOSE(IU)
   !## gxg takes less memory, only 2 per observation
   IF(MEASURES(I)%IMCOL.LT.0)THEN
    N=N+2*M
   ELSE
    N=N+M*PRJNPER
   ENDIF
  ENDDO
  
  !## get dimension of possible maximal number of observations
  M=N
 
  !## number of line-searches (-) and number of gradients-simulations (+)
  N1=0; IF(ALLOCATED(RNL))N1=SIZE(RNL)
  N2=0; IF(ALLOCATED(RNG))N2=SIZE(RNG)
 ELSE
  !## number of observations
  M =NDIM1 
  !## number of linesearches
  N1=NDIM2
  !## number of parameters
  N2=NDIM3
 ENDIF
 
 IF(M.GT.0)THEN
  WRITE(*,'(/I10,A)')     M  ,' Maximal number of observations (from IPF)'
 ELSE
  WRITE(*,'(/I10,A)') ABS(M) ,' Maximal number of observations (from LOG_PESTP_RESIDUAL_*.TXT)'
 ENDIF
 
 !## add measurements from batchfiles
 IF(ASSOCIATED(PEST%B_NOBS).AND.M.GE.0)THEN
  M=M+SUM(PEST%B_NOBS)
  WRITE(*,'(I10,A)') SUM(PEST%B_NOBS) ,' Maximal number of observations (from Batchfiles)'
  WRITE(*,'(60A1)') ('-',I=1,60)
  WRITE(*,'(I10,A/)') M ,' Maximal number of observations (totally)'
 ENDIF

 M=ABS(M)
 
 O=ABS(PEST%PE_MXITER)

 WRITE(*,'(I10,A)') N1,' Maximal number of lambda- and/or linesearches'
 WRITE(*,'(I10,A)') N2,' Maximal number of parameters'
 WRITE(*,'(I10,A)') O ,' Maximal number of iterations'
 WRITE(*,*) 

 O=MAX(O,1)

 ALLOCATE(LAMBDAS(O),STAT=IOS);      IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR LAMBDAS';     RETURN; ENDIF
 ALLOCATE(MSR%GOF_H(0:O),STAT=IOS);  IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%GOF_H';   RETURN; ENDIF
 
 ALLOCATE(MSR%SCORE(2,0:O),STAT=IOS); IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%SCORE';  RETURN; ENDIF; MSR%SCORE=0
 
 ALLOCATE(MSR%NSC_H(0:O),STAT=IOS);  IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%NSC_H';   RETURN; ENDIF
 ALLOCATE(MSR%TJ_H(0:O),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%TJ_H';    RETURN; ENDIF
 ALLOCATE(MSR%RJ_H(0:O),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%RJ_H';    RETURN; ENDIF
 ALLOCATE(MSR%MU(0:O),STAT=IOS);     IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%MU';      RETURN; ENDIF
 IF(N1.GT.0)THEN
  ALLOCATE(MSR%GOF(N1),STAT=IOS);     IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%GOF';    RETURN; ENDIF
  ALLOCATE(MSR%NSC(N1),STAT=IOS);     IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%NSC';    RETURN; ENDIF
  ALLOCATE(MSR%DHL_J(N1),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%DHL_J';  RETURN; ENDIF
  IF(M.GT.0)THEN
   ALLOCATE(MSR%DHL(0:N1,M),STAT=IOS); IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%DHL';   RETURN; ENDIF
   ALLOCATE(MSR%HL(0:N1,M),STAT=IOS); IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%HL';     RETURN; ENDIF
  ENDIF
 ENDIF
 IF(PBMAN%IIES.EQ.1)THEN
  ALLOCATE(MSR%GOF(N2),STAT=IOS);     IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%GOF';    RETURN; ENDIF
  ALLOCATE(MSR%NSC(N2),STAT=IOS);     IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%NSC';    RETURN; ENDIF
  ALLOCATE(MSR%DHL_J(N2),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%DHL_J';  RETURN; ENDIF
  ALLOCATE(MSR%IESC(N2,M),STAT=IOS);  IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%IESC';   RETURN; ENDIF
  ALLOCATE(MSR%DHG(N2,M),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%DHG';    RETURN; ENDIF
 ENDIF
 IF(N2.GT.0)THEN
  ALLOCATE(MSR%DHG_J(N2),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%DHG_J';  RETURN; ENDIF
  ALLOCATE(MSR%DPG_J(N2),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%DPG_J';  RETURN; ENDIF
  IF(M.GT.0)THEN
   ALLOCATE(MSR%HG(N2,M),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%HG';     RETURN; ENDIF
  ENDIF
 ENDIF
 IF(M.GT.0)THEN
  ALLOCATE(MSR%W(M),STAT=IOS);        IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%W';      RETURN; ENDIF
  ALLOCATE(MSR%X(M),STAT=IOS);        IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%X';      RETURN; ENDIF
  ALLOCATE(MSR%Y(M),STAT=IOS);        IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%Y';      RETURN; ENDIF
  ALLOCATE(MSR%O(M),STAT=IOS);        IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%O';      RETURN; ENDIF
  ALLOCATE(MSR%C(M),STAT=IOS);        IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%C';      RETURN; ENDIF
  ALLOCATE(MSR%D(M),STAT=IOS);        IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%D';      RETURN; ENDIF
  ALLOCATE(MSR%L(M),STAT=IOS);        IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%L';      RETURN; ENDIF
  ALLOCATE(MSR%NS(M),STAT=IOS);       IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%NS';     RETURN; ENDIF
  ALLOCATE(MSR%COR(M),STAT=IOS);      IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%COR';    RETURN; ENDIF; MSR%COR=-999.0D0
  ALLOCATE(MSR%IDATE(M),STAT=IOS);    IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%IDATE';  RETURN; ENDIF
  ALLOCATE(MSR%IPF(M),STAT=IOS);      IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%IPF';    RETURN; ENDIF
  ALLOCATE(MSR%LOC(M),STAT=IOS);      IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%LOC';    RETURN; ENDIF
  ALLOCATE(MSR%CLABEL(M),STAT=IOS);   IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR MSR%CLABEL'; RETURN; ENDIF
  ALLOCATE(GF_H(M),STAT=IOS);         IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR GF_H';       RETURN; ENDIF
  ALLOCATE(GF_O(M),STAT=IOS);         IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'CANNOT ALLOCATE MEMORY FOR GF_O';       RETURN; ENDIF
 ENDIF
 
 !## allocate stochastic error per measurement
 ALLOCATE(MSR%E(M)); MSR%E=-999.99D0
 
 IPEST_GLM_ALLOCATEMSR=.TRUE.

 END FUNCTION IPEST_GLM_ALLOCATEMSR
 
 !###====================================================================
 SUBROUTINE IPEST_GLM_DEALLOCATEMSR()
 !###====================================================================
 IMPLICIT NONE

 IF(ASSOCIATED(MSR%TJ_H))  DEALLOCATE(MSR%TJ_H)
 IF(ASSOCIATED(MSR%RJ_H))  DEALLOCATE(MSR%RJ_H)
 IF(ASSOCIATED(MSR%GOF_H)) DEALLOCATE(MSR%GOF_H)
 IF(ASSOCIATED(MSR%SCORE)) DEALLOCATE(MSR%SCORE)
 IF(ASSOCIATED(MSR%NSC_H)) DEALLOCATE(MSR%NSC_H)
 IF(ASSOCIATED(MSR%GOF))   DEALLOCATE(MSR%GOF)
 IF(ASSOCIATED(MSR%NSC))   DEALLOCATE(MSR%NSC)
 IF(ASSOCIATED(MSR%DHL_J)) DEALLOCATE(MSR%DHL_J)
 IF(ASSOCIATED(MSR%DHG_J)) DEALLOCATE(MSR%DHG_J)
 IF(ASSOCIATED(MSR%DPG_J)) DEALLOCATE(MSR%DPG_J)
 IF(ASSOCIATED(MSR%HL))    DEALLOCATE(MSR%HL)
 IF(ASSOCIATED(MSR%DHL))   DEALLOCATE(MSR%DHL)
 IF(ASSOCIATED(MSR%HG))    DEALLOCATE(MSR%HG)
 IF(ASSOCIATED(MSR%W ))    DEALLOCATE(MSR%W) 
 IF(ASSOCIATED(MSR%X ))    DEALLOCATE(MSR%X) 
 IF(ASSOCIATED(MSR%Y ))    DEALLOCATE(MSR%Y) 
 IF(ASSOCIATED(MSR%O ))    DEALLOCATE(MSR%O) 
 IF(ASSOCIATED(MSR%C ))    DEALLOCATE(MSR%C) 
 IF(ASSOCIATED(MSR%IESC))  DEALLOCATE(MSR%IESC) 
 IF(ASSOCIATED(MSR%D ))    DEALLOCATE(MSR%D) 
 IF(ASSOCIATED(MSR%MU))    DEALLOCATE(MSR%MU) 
 IF(ASSOCIATED(MSR%E ))    DEALLOCATE(MSR%E) 
 IF(ASSOCIATED(MSR%L ))    DEALLOCATE(MSR%L) 
 IF(ASSOCIATED(MSR%NS))    DEALLOCATE(MSR%NS) 
 IF(ASSOCIATED(MSR%COR))   DEALLOCATE(MSR%COR) 
 IF(ASSOCIATED(MSR%IDATE)) DEALLOCATE(MSR%IDATE) 
 IF(ASSOCIATED(MSR%IPF))   DEALLOCATE(MSR%IPF) 
 IF(ASSOCIATED(MSR%LOC))   DEALLOCATE(MSR%LOC) 
 IF(ASSOCIATED(MSR%CLABEL))DEALLOCATE(MSR%CLABEL) 
 IF(ALLOCATED(GF_H))       DEALLOCATE(GF_H)
 IF(ALLOCATED(GF_O))       DEALLOCATE(GF_O)
 IF(ALLOCATED(LAMBDAS))    DEALLOCATE(LAMBDAS)
! IF(ALLOCATED(QR))         DEALLOCATE(QR)
 
 END SUBROUTINE IPEST_GLM_DEALLOCATEMSR
 
 !###====================================================================
 SUBROUTINE IPEST_LUDECOMP_DBL(AA,IDX,N,ISING)
 !###====================================================================
 IMPLICIT NONE
! INTEGER,PARAMETER :: NMAX=2000
 REAL(KIND=DP_KIND),PARAMETER :: TINY=1.0D-20
 INTEGER,INTENT(IN) :: N
 INTEGER,INTENT(OUT) :: ISING
 INTEGER,DIMENSION(N),INTENT(OUT) :: IDX
 REAL(KIND=DP_KIND),DIMENSION(N,N),INTENT(INOUT) :: AA
 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: VV
 REAL(KIND=DP_KIND) :: AAMAX,DUM,SUM
 INTEGER :: I,IMAX,J,K

 ALLOCATE(VV(N)); VV=0.0D0
 
 DO I=1,N
  IDX(I)=0
 END DO
 ISING=0

 DO I=1,N
  AAMAX=0.0D0
  DO J=1,N
   IF(ABS(AA(I,J)).GT.AAMAX)AAMAX=ABS(AA(I,J))
  ENDDO
  IF(AAMAX.EQ.0.0D0)THEN
   WRITE(*,*) 'Matrix is singular'
   ISING=1
   RETURN
  ENDIF
  VV(I)=1.0D0/AAMAX
 ENDDO
 DO J=1,N
  DO I=1,J-1
   SUM=AA(I,J)
   DO K=1,I-1
    SUM=SUM-AA(I,K)*AA(K,J)
   ENDDO
   AA(I,J)=SUM
  ENDDO
  AAMAX=0.0D0
  DO I=J,N
   SUM=AA(I,J)
   DO K=1,J-1
    SUM=SUM-AA(I,K)*AA(K,J)
   ENDDO
   AA(I,J)=SUM
   DUM=VV(I)*ABS(SUM)
   IF(DUM.GE.AAMAX)THEN
    IMAX=I
    AAMAX=DUM
   ENDIF
  ENDDO
  IF(J.NE.IMAX)THEN
   DO K=1,N
    DUM=AA(IMAX,K)
    AA(IMAX,K)=AA(J,K)
    AA(J,K)=DUM
   ENDDO
   VV(IMAX)=VV(J)
  ENDIF
  IDX(J)=IMAX
  IF(AA(J,J).EQ.0.0D0)AA(J,J)=TINY
  IF(J.NE.N)THEN
   DUM=1.0D0/AA(J,J)
   DO I=J+1,N
    AA(I,J)=AA(I,J)*DUM
   ENDDO
  ENDIF
 ENDDO

 DEALLOCATE(VV)
 
 END SUBROUTINE IPEST_LUDECOMP_DBL

 !###====================================================================
 SUBROUTINE IPEST_LUBACKSUB_DBL(AA,IDX,BB,N)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: N
 REAL(KIND=DP_KIND),DIMENSION(N,N),INTENT(IN) :: AA
 REAL(KIND=DP_KIND),DIMENSION(N),INTENT(INOUT) :: BB
 INTEGER,DIMENSION(N),INTENT(IN) :: IDX
 INTEGER :: I,II,J,LL
 REAL(KIND=DP_KIND) :: SUM

 II=0
 DO I=1,N
  LL=IDX(I)
  SUM=BB(LL)
  BB(LL)=BB(I)
  IF(II.NE.0)THEN
   DO J=II,I-1
    SUM=SUM-AA(I,J)*BB(J)
   ENDDO
  ELSE IF(SUM.NE.0.0D0)THEN
   II=I
  ENDIF
  BB(I)=SUM
 ENDDO
 DO I=N,1,-1
  SUM=BB(I)
  DO J=I+1,N
   SUM=SUM-AA(I,J)*BB(J)
  ENDDO
  BB(I)=SUM/AA(I,I)
 ENDDO

 END SUBROUTINE IPEST_LUBACKSUB_DBL
 
 !###====================================================================
 SUBROUTINE IPEST_ECHELON_DBL(AO,BO,NROW,NCOL)
 !###====================================================================
 IMPLICIT NONE
 INTEGER,INTENT(IN) :: NROW,NCOL
 REAL(KIND=DP_KIND),DIMENSION(NCOL,NROW),INTENT(IN) :: AO
 INTEGER,DIMENSION(NROW),INTENT(OUT) :: BO
 REAL(KIND=DP_KIND),PARAMETER :: TINY=1.0D-10
 REAL(KIND=DP_KIND),DIMENSION(:,:),ALLOCATABLE :: A
 INTEGER,DIMENSION(:),ALLOCATABLE :: B
 INTEGER :: IROW,JROW,KROW,ICOL,PCOL
 REAL(KIND=DP_KIND) :: AMAX,ATMP,F
 
 !## copy matrix
 ALLOCATE(A(NCOL,NROW),B(NROW)); A=AO
 
 PCOL=0
MLOOP: DO IROW=1,NROW
  !## assume next column to be pivot column
  PCOL=PCOL+1; IF(PCOL.GT.NCOL)EXIT
  !## find pivot icol
PLOOP: DO
   DO JROW=IROW+1,NROW
    IF(ABS(A(PCOL,JROW)).GT.TINY)EXIT PLOOP
   ENDDO
   PCOL=PCOL+1
   !## finished
   IF(PCOL.GT.NCOL)EXIT MLOOP
  ENDDO PLOOP

  !## find row with largest pivot value
  KROW=IROW; AMAX=0.0D0; DO JROW=IROW,NROW !+1,NROW
   IF(ABS(A(PCOL,JROW)).GT.ABS(AMAX))THEN; AMAX=A(PCOL,JROW); KROW=JROW; ENDIF
  ENDDO

  !## interchange rows
  IF(KROW.NE.IROW)THEN
   DO ICOL=PCOL,NCOL
    ATMP        =A(ICOL,IROW)
    A(ICOL,IROW)=A(ICOL,KROW)
    A(ICOL,KROW)=ATMP
   ENDDO
  ENDIF
  !## reduce all rows using the pivot row
  AMAX=A(PCOL,IROW)
  DO JROW=IROW+1,NROW
   F=A(PCOL,JROW)/AMAX
   DO ICOL=PCOL,NCOL
    A(ICOL,JROW)=A(ICOL,JROW)-A(ICOL,IROW)*F
   ENDDO
  ENDDO
 ENDDO MLOOP

! DO IROW=1,NROW
!  WRITE(*,'(99F10.2)') (A(ICOL,IROW),ICOL=1,NCOL)
! ENDDO
 
 !## determine over/bad dimension of matrix
 B=0; DO IROW=1,NROW
  DO ICOL=1,NCOL; IF(ABS(A(ICOL,IROW)).GT.TINY)THEN; B(IROW)=ICOL; EXIT; ENDIF; ENDDO
 ENDDO
 BO=0; DO IROW=1,NROW; ICOL=B(IROW); IF(ICOL.GT.0)BO(ICOL)=1; ENDDO
 
 DEALLOCATE(A,B)
 
 END SUBROUTINE IPEST_ECHELON_DBL
 
END MODULE MOD_IPEST_GLM