SUBROUTINE SAVHESS(KTBMIN,YD_PDIAG,YDYBAR,YDSBAR,KMUPD,&
 & KILM,KKLM,PSIZE)  

!***  *SAVHESS* save minimisation algorithm information.

!**   Purpose.
!     --------
!     this routine saves files for a possible new reuse of the hessian
!     for a subsequent minimisation.

!**   Interface.
!     *CALL* *SAVHESS (...)* from CVA1

!        Explicit arguments :
!        --------------------
!        KTBMIN : integer reference table for working array
!        PDIAG  : diagonal preconditioner
!        YDYBAR  : 'y' vectors of BFGS matrix
!        YDSBAR  : 's' vectors of BFGS matrix
!        KMUPD  : number of BFGS vector pairs
!        KILM(KKLM) : integer array for N1CG1
!        Implicit arguments :
!        --------------------
!        none.

!     Method.
!     -------
!        See documentation : The modules M1QN2,N1QN2,M1QN3,N1QN3
!                            version 1.1.b (February 1989)
!                            J.C Gilbert and C. Lemarechal

!     Externals.
!     ----------
!      none

!     Reference.
!     ----------
!        ECMWF research department documentation of the IFS

!     Author.
!     -------
!        Jean-Noel Thepaut *ECMWF*

!     Modifications.
!     --------------
!        Original : 93-03-04
!        Modified : 95-06-06 L.Isaksen   Reordering of spectral arrays
!        Modified : 96-02-20 L.Isaksen   Adapted for Message Passing
!        Modified : 96-10-11 F.Rabier    Do not use MIO if not on Cray
!        Modified : 98-01-10 M.Hamrud    Minimisation parallelized
!        Modified 97-05    by R. Randriamampianina 3DVAR ALADIN
!        Modified : 99-08-02 M.Fisher    Separate SAVMINI and SAVHESS
!        Modified : 99-04-16 M. Torki    Save informations from N1CG1
!        Modified : 99-11-09 C. Fischer  Clean out calls to (E)CAIN
!        Modified : 00-08-09 Y.Tremolet  Cleaning
!        Modified : 02-08-06 Y.Tremolet  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 YOMVAR   , ONLY : LN1CG1
USE YOMLUN   , ONLY : NULOUT   , NULERR
USE YOMIOMI  , ONLY : CFVATRA
USE YOMMP    , ONLY : MYPROC
USE YOMMSC   , ONLY : NREALEN, NINTLEN
USE CONTROL_VECTORS_COMM_MOD
USE CONTROL_VECTORS

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KMUPD 
INTEGER(KIND=JPIM),INTENT(IN)    :: KKLM 
INTEGER(KIND=JPIM),INTENT(IN)    :: KTBMIN(5) 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_PDIAG 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YDYBAR(KMUPD) 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YDSBAR(KMUPD) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KILM(KKLM) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSIZE 
REAL(KIND=JPRB),ALLOCATABLE ::  ZBUF2(:)
REAL(KIND=JPRB),ALLOCATABLE ::  ZTBMIN(:)
INTEGER(KIND=JPIM) :: IDIMR, IERR, ILEN, IOMASTER, IVATR, J, ISIZE
INTEGER(KIND=JPIM) :: IDIMI, IBUF(3)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

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

!*    1.  WRITE THE DIAGONAL OF THE HESSIAN (Dk) AND TBMIN.
!     -----------------------------------------------------

IF (LHOOK) CALL DR_HOOK('SAVHESS',0,ZHOOK_HANDLE)
IOMASTER=MIN(1,NPROC)

IF(MYPROC == IOMASTER) THEN
  IERR=0
  ISIZE=YDYBAR(1)%nsizeg
  CALL PBOPEN(IVATR,CFVATRA,'W',IERR)
  IF(IERR /= 0) THEN
    WRITE(NULOUT,'('' >> Sub SAVHESS:PBOPEN FAILED on '',A)') CFVATRA
    WRITE(NULOUT,'(''              IERR='',I10)') IERR
    CALL ABOR1('SAVHESS: PBOPEN FAILED')
  ENDIF

  IBUF(1)=YDYBAR(1)%nsizeg
  IBUF(2)=YDYBAR(1)%nsmax
  IBUF(3)=YDYBAR(1)%nserr
  IDIMI=3*NINTLEN
  CALL PBWRITE(IVATR,IBUF,IDIMI,IERR)
  IF(IERR < 0) THEN
    WRITE(NULERR,'('' >> Sub SAVHESS:PBWRITE FAILED on '',A20)') CFVATRA
    WRITE(NULERR,'(''              IERR='',I10)') IERR
    CALL ABOR1('SAVHESS: PBWRITE 1 FAILED')
  ENDIF

  IF (LN1CG1) THEN
    ALLOCATE(ZTBMIN(KKLM+3))
    ZTBMIN(1)=KKLM
    ZTBMIN(2:KKLM+1)=KILM(:)
    ZTBMIN(KKLM+2)=ISIZE
    ZTBMIN(KKLM+3)=PSIZE
    ILEN=(KKLM+3)*NREALEN
  ELSE
    ALLOCATE(ZTBMIN(5))
    ZTBMIN(:)=KTBMIN(:)
    ILEN=5*NREALEN
  ENDIF
  CALL PBWRITE(IVATR,ZTBMIN,ILEN,IERR)
  DEALLOCATE(ZTBMIN)
  IF(IERR < 0) THEN
    WRITE(NULOUT,'('' >> Sub SAVHESS:PBWRITE FAILED on '',A20)') CFVATRA
    WRITE(NULOUT,'(''              IERR='',I10)') IERR
    CALL ABOR1('SAVHESS: PBWRITE FAILED')
  ENDIF
  ALLOCATE(ZBUF2(ISIZE))
  IDIMR=ISIZE*NREALEN
  IF (.NOT.LN1CG1) THEN
    CALL GATHER_CTLVEC(YD_PDIAG,IOMASTER,ZBUF2)
    CALL PBWRITE(IVATR,ZBUF2,IDIMR,IERR)
    IF(IERR < 0) THEN
      WRITE(NULOUT,'('' >> Sub SAVHESS:PBWRITE FAILED on '',A20)') CFVATRA
      WRITE(NULOUT,'(''              IERR='',I10)') IERR
      CALL ABOR1('SAVHESS: PBWRITE FAILED')
    ENDIF
  ENDIF
  DO J=1,KMUPD
    CALL GATHER_CTLVEC(YDYBAR(J),IOMASTER,ZBUF2)
    CALL PBWRITE(IVATR,ZBUF2,IDIMR,IERR)
    IF(IERR < 0) THEN
      WRITE(NULOUT,'('' >> Sub SAVHESS:PBWRITE FAILED on '',A20)') CFVATRA
      WRITE(NULOUT,'(''              IERR='',I10)') IERR
      CALL ABOR1('SAVHESS: PBWRITE FAILED')
    ENDIF
    CALL GATHER_CTLVEC(YDSBAR(J),IOMASTER,ZBUF2)
    CALL PBWRITE(IVATR,ZBUF2,IDIMR,IERR)
    IF(IERR < 0) THEN
      WRITE(NULOUT,'('' >> Sub SAVHESS:PBWRITE FAILED on '',A20)') CFVATRA
      WRITE(NULOUT,'(''              IERR='',I10)') IERR
      CALL ABOR1('SAVHESS: PBWRITE FAILED')
    ENDIF
  ENDDO
  IERR=0
  CALL PBCLOSE(IVATR,IERR)
  IF(IERR /= 0) THEN
    WRITE(NULOUT,'('' >> Sub SAVHESS:PBCLOSE FAILED on '',A20)') CFVATRA
    WRITE(NULOUT,'(''              IERR='',I10)') IERR
    CALL ABOR1('SAVHESS: PBCLOSE FAILED')
  ENDIF
ELSE
  ALLOCATE(ZBUF2(1))
  IF (.NOT.LN1CG1) THEN
    CALL GATHER_CTLVEC(YD_PDIAG,IOMASTER,ZBUF2)
  ENDIF
  DO J=1,KMUPD
    CALL GATHER_CTLVEC(YDYBAR(J),IOMASTER,ZBUF2)
    CALL GATHER_CTLVEC(YDSBAR(J),IOMASTER,ZBUF2)
  ENDDO
ENDIF

DEALLOCATE(ZBUF2)

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

IF (LHOOK) CALL DR_HOOK('SAVHESS',1,ZHOOK_HANDLE)
END SUBROUTINE SAVHESS
