SUBROUTINE SUHESS (KMUPD,YD_PDIAG,YDYBAR,YDSBAR,KTBMIN,&
 & KLM,KILM,PSIZE,LDWARM)  

!***  *SUHESS* initialize the Hessian estimate for warm M1QN3 restart/
!      N1CG1 preconditioning (for Multi-incremental).

!**   Purpose.
!     --------
!        Reread the M1QN3/N1CG1 work arrays saved in a previous minimization
!        by SAVMINI. M1QN3/N1CG1 will use the estimate of the Hessian
!        as a preconditioner. See also SAVMINI, MUPDTS and YSTBL.

!**   Interface.    CALL SUHESS(...)
!     ----------

!     Explicit arguments :
!     --------------------
!        In : KMUPD = number of updates
!        Out : PDIAG, YDYBAR, YDSBAR : work arrays to build an approximation
!                                    of the  hessian
!        Out : KTBMIN(5), KLM(KILM) : integer arrays for the preconditioner

!     Method. See M1QN3 documentation (J.C Gilbert and C. Lemarechal, INRIA)
!     -------

!     Author.
!     -------
!        M. Torki (based on SUHESS)

!     Modifications.
!     --------------
!        Original : 99-04-16
!        M Fisher : 2001-03-14 - Combined SUHESS and SUHMINC
!        Y.Tremolet:  02-08-06 - Use control_vectors.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMCT0   , ONLY : NPROC
USE YOMLUN   , ONLY : NULERR   ,NULOUT
USE YOMIOMI  , ONLY : CFVATRA  
USE YOMMP    , ONLY : MYPROC
USE YOMMSC   , ONLY : NREALEN, NINTLEN
USE YOMVAR   , ONLY : LN1CG1
USE YOMTAG, ONLY: MTAGGETV
USE CONTROL_VECTORS_COMM_MOD
USE CONTROL_VECTORS
USE MPL_MODULE

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KMUPD 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PDIAG 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YDYBAR(KMUPD) 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YDSBAR(KMUPD) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KTBMIN(5) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KLM(KMUPD+3) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KILM 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSIZE 
LOGICAL           ,INTENT(IN)    :: LDWARM 
INTEGER(KIND=JPIM) ::  JUPD, IVADIM2, ivadim
TYPE(control_vector) :: YL_ZYBAR2(KMUPD)
TYPE(control_vector) :: YL_ZSBAR2(KMUPD)
TYPE(control_vector) :: YL_ZDIAG2
REAL(KIND=JPRB),ALLOCATABLE ::  ZBUF2(:), ZTBMIN(:)
REAL(KIND=JPRB) :: ZSIZEFCTR

INTEGER(KIND=JPIM) :: IDIMR, IOMASTER, IRET, IVATR, J
INTEGER(KIND=JPIM) :: IBUF(3), itlmax, itlerr, idimi
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

IF (LHOOK) CALL DR_HOOK('SUHESS',0,ZHOOK_HANDLE)
IF(LDWARM) THEN

!     ------------------------------------------------------------------

!*       3.  GET THE REFERENCE TABLE AND DIAG HESSIAN (no MIO).
!        ------------------------------------------------------

!*       3.1   OPEN FILE
!              ---------
  IOMASTER = MIN(1,NPROC)

  IF(MYPROC == IOMASTER) THEN
    IRET = 0
    CALL PBOPEN(IVATR,CFVATRA,'R',IRET)
    IF(IRET /= 0) THEN
      WRITE(NULERR,'('' >> Sub SUHESS:PBOPEN FAILED on '',A)') CFVATRA
      WRITE(NULERR,'(''              IRET='',I10)') IRET
      CALL ABOR1('SUHESS: PBOPEN FAILED')
    ENDIF

    IDIMI=3*NINTLEN
    CALL PBREAD2(IVATR,IBUF,IDIMI,IRET)
    CALL PBREAD2_CHECK_RETURNCODE
  ENDIF

  CALL MPL_BROADCAST(IBUF,mtaggetv+1,KROOT=IOMASTER,CDSTRING='SUHESS:')
  ivadim=IBUF(1)
  itlmax=IBUF(2)
  itlerr=IBUF(3)

!*       3.2   READ Hessian information
!              ------------------------
  IF (LN1CG1) THEN
    IDIMR=(KMUPD+6)*NREALEN
    ALLOCATE(ZTBMIN(KMUPD+6))
  ELSE
    IDIMR=5*NREALEN
    ALLOCATE(ZTBMIN(5))
  ENDIF

  IF(MYPROC == IOMASTER) THEN
    CALL PBREAD2(IVATR,ZTBMIN,IDIMR,IRET)
    CALL PBREAD2_CHECK_RETURNCODE
  ENDIF
  CALL MPL_BROADCAST(ZTBMIN,mtaggetv,KROOT=IOMASTER,CDSTRING='SUHESS:')

  IF (LN1CG1) THEN
    KILM = NINT(ZTBMIN(1))
    KLM(:)=NINT(ZTBMIN(2:KILM+1))
    IVADIM2=NINT(ZTBMIN(KILM+2))
    PSIZE=ZTBMIN(KILM+3)
  ELSE
    KTBMIN(:)=NINT(ZTBMIN)
    IVADIM2=KTBMIN(1)
    KTBMIN(1)=YD_PDIAG%NSIZEG
  ENDIF
  DEALLOCATE(ZTBMIN)

  DO JUPD=1,KMUPD
    CALL ALLOCATE_CTLVEC(YL_ZYBAR2(JUPD),KSMAX=itlmax,KSERR=itlerr)
    CALL ALLOCATE_CTLVEC(YL_ZSBAR2(JUPD),KSMAX=itlmax,KSERR=itlerr)
  ENDDO
  IF (.NOT.LN1CG1) THEN
    CALL ALLOCATE_CTLVEC(YL_ZDIAG2,KSMAX=itlmax,KSERR=itlerr)
  ENDIF

  IF(MYPROC == IOMASTER) THEN
    ALLOCATE(ZBUF2(IVADIM2))
    IDIMR=IVADIM2*NREALEN
    IF (.NOT.LN1CG1) THEN
      CALL PBREAD2(IVATR,ZBUF2,IDIMR,IRET)
      CALL PBREAD2_CHECK_RETURNCODE
      CALL SCATTER_CTLVEC(YL_ZDIAG2,IOMASTER,ZBUF2)
    ENDIF
    DO J=1,KMUPD
      CALL PBREAD2(IVATR,ZBUF2,IDIMR,IRET)
      CALL PBREAD2_CHECK_RETURNCODE
      CALL SCATTER_CTLVEC(YL_ZYBAR2(J),IOMASTER,ZBUF2)
      CALL PBREAD2(IVATR,ZBUF2,IDIMR,IRET)
      CALL PBREAD2_CHECK_RETURNCODE
      CALL SCATTER_CTLVEC(YL_ZSBAR2(J),IOMASTER,ZBUF2)
    ENDDO
  ELSE
    ALLOCATE(ZBUF2(1))
    IF (.NOT.LN1CG1) THEN
      CALL SCATTER_CTLVEC(YL_ZDIAG2,IOMASTER,ZBUF2)
    ENDIF
    DO J=1,KMUPD
      CALL SCATTER_CTLVEC(YL_ZYBAR2(J),IOMASTER,ZBUF2)
      CALL SCATTER_CTLVEC(YL_ZSBAR2(J),IOMASTER,ZBUF2)
    ENDDO
  ENDIF
  DEALLOCATE(ZBUF2)

!*       3.3  COMPUTE THE PRECONDITIONING FACTOR
!             ----------------------------------
  IF (.NOT.LN1CG1) THEN
    ZSIZEFCTR=DOT_PRODUCT(YL_ZYBAR2(KMUPD),YL_ZSBAR2(KMUPD))
    ZSIZEFCTR=ZSIZEFCTR/DOT_PRODUCT(YL_ZYBAR2(KMUPD),YL_ZYBAR2(KMUPD))
    WRITE(NULOUT,*)'PRECONDITIONING FACTOR :ZSIZEFCTR =', ZSIZEFCTR
  ENDIF

!*       3.4   CLOSE FILE
!              ----------
  IF(MYPROC == IOMASTER) THEN
    IRET = 0
    CALL PBCLOSE(IVATR,IRET)
    IF(IRET /= 0) THEN
      WRITE(NULERR,'('' >> Sub SUHESS: PBCLOSE FAILED on '',A20)') CFVATRA
      WRITE(NULERR,'(''              IRET='',I10)') IRET
      CALL ABOR1('SUHESS: PBCLOSE FAILED')
    ENDIF
  ENDIF

!      -----------------------------------------------------------------
!        4. APPLY PSEUDO-INVERSE OF TRUNCATION
!        -------------------------------------

!       4.1  TO (Y,S) PAIRS
!            --------------
  DO JUPD=1,KMUPD
    YDSBAR(JUPD) = YL_ZSBAR2(JUPD)
    YDYBAR(JUPD) = YL_ZYBAR2(JUPD)
  ENDDO

  DO JUPD=1,KMUPD
    CALL DEALLOCATE_CTLVEC(YL_ZSBAR2(JUPD))
    CALL DEALLOCATE_CTLVEC(YL_ZYBAR2(JUPD))
  ENDDO

!        4.2  TO DIAG
!             -------
  IF (.NOT.LN1CG1) THEN
    YD_PDIAG = YL_ZDIAG2
    WHERE (YD_PDIAG%data==0.0_JPRB)
      YD_PDIAG%data = ZSIZEFCTR
    ENDWHERE
    CALL DEALLOCATE_CTLVEC(YL_ZDIAG2)
  ENDIF
ENDIF

IF (LHOOK) CALL DR_HOOK('SUHESS',1,ZHOOK_HANDLE)
CONTAINS
SUBROUTINE PBREAD2_CHECK_RETURNCODE
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (LHOOK) CALL DR_HOOK('SUHESS:PBREAD2_CHECK_RETURNCODE',0,ZHOOK_HANDLE)
IF(IRET < 0) THEN
  WRITE(NULERR,'('' >> Sub SUHESS: PBREAD2 FAILED on '',A20)') CFVATRA
  WRITE(NULERR,'(''              IRET='',I10)') IRET
  CALL ABOR1('SUHESS: PBREAD2 FAILED')
ELSEIF(IRET /= IDIMR) THEN
  WRITE(NULERR,'('' >> Sub SUHESS: PBREAD2 inconsistent on '',A20)') CFVATRA
  WRITE(NULERR,'('' nb of bytes read in='',I10)') IRET
  WRITE(NULERR,'('' nb of bytes asked ='',I10)') IDIMR
  WRITE(NULERR,'('' dimension of vectors ='',I10)') IVADIM2
  CALL ABOR1('SUHESS: PBREAD2 FAILED')
ENDIF
IF (LHOOK) CALL DR_HOOK('SUHESS:PBREAD2_CHECK_RETURNCODE',1,ZHOOK_HANDLE)
END SUBROUTINE  PBREAD2_CHECK_RETURNCODE
END SUBROUTINE SUHESS
