subroutine preppcm

!-----------------------------------------------------------------------
!   PREPPCM - Calculates the preconditioner for 'congrad'

!   Purpose.
!   -------- 

!   Interface.
!   ----------
!      CALL PREPPCM

!      Implicit input:  Vectors in CINCGL

!      Implicit output: Eigenvalues and eigenvectors of the
!                       preconditioner in CPCCGL
!   Externals.
!   ----------

!   Reference.
!   ----------
!       IFS Documentation Chapter 7 Section 5

!   Author.
!   -------
!       Mike Fisher  *ECMWF*

!   Modifications.
!   --------------
!       Original   94-05-03
!     L.Isaksen    95-06-06 : Reordering of spectral arrays
!     M.Fisher     95-11-24 : Read vectors in GRIB format
!     E.Andersson  96-08-01 : Precalculated SQRT(SCALP)
!     M. Fisher    96-08-01 : Optionally store vectors in memory
!     M. Fisher    97-11-26 : USE DISTRIBUTED_VECTORS_MIX
!     Y.Tremolet   02-08-06 : Use control_vectors.
!     K. Yessad    03-10-01 : bugfix for congrad (after M. Fisher)
!     M.Hamrud     01-10-03 : Remove Fortran 66 constructs
!     M.Hamrud      01-Oct-2003 CY28 Cleaning
!     M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!     D.Salmond     18-Apr-2007 Use multiple processors for I/O
!     T.Wilhelmsson 28-Aug-2009 Move multiprocessor I/O to GETMINI2
!-----------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMSP    , ONLY : SPA3     ,SPA2
USE YOMCT0   , ONLY : NPRINTLEV,LALLOPR,NPROC
USE YOMDIM   , ONLY : NFD2D
USE YOMCVA   , ONLY : YSCALPSQRT
USE YOMVAR   , ONLY : CFNPCV   ,NPCVECS  ,LMPCGL, LEVECCNTL, LEVECGRIB,&
 & R_MAX_CNUM_PC  
USE YOMJG    , ONLY : LSUBBG, LCTLFG
USE YOMLUN   , ONLY : NULOUT
USE YOMVCGL  , ONLY : YVCGLPC   ,RCGLPC   ,NVCGLPC
USE YOMMSC   , ONLY : N_DEFAULT_REAL_KIND, N_DOUBLE_KIND
USE CONTROL_VECTORS, ONLY : CONTROL_VECTOR, ALLOCATE_CTLVEC, DEALLOCATE_CTLVEC, &
                          & DOT_PRODUCT, ASSIGNMENT(=)
USE CONTROL_VECTORS_COMM_MOD, ONLY : ALLGATHER_CVSECTION, SET_CVSECTION
USE YOMGETMINI, ONLY : MIOPROC, RZVAZX, NUM_IO_PROCS, NUM_PROCS_PER_IO_PROC

IMPLICIT NONE

type(control_vector) :: ylcglwk(NPCVECS)

INTEGER(KIND=JPIM) :: indarr(NPCVECS)
REAL(KIND=JPRB) :: zq(NPCVECS),zlam(NPCVECS),zU(NPCVECS,NPCVECS),&
 & zUUT(NPCVECS,NPCVECS),zwork(3*NPCVECS),zzz(NPCVECS)  
CHARACTER (LEN = 16) ::  clfile

INTEGER(KIND=JPIM) :: i, info, ik, inpcv, J, ji, jj, jk, jvec, ii
INTEGER(KIND=JPIM) :: jvec_start, jvec_end, ICOUNT

LOGICAL ::  llp

REAL(KIND=JPRB) :: za, zps
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "cain.intfb.h"
#include "cainin.intfb.h"
#include "chavar.intfb.h"
#include "getmini.intfb.h"
#include "getmini2.intfb.h"
#include "readvec.intfb.h"

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

IF (LHOOK) CALL DR_HOOK('PREPPCM',0,ZHOOK_HANDLE)
llp = NPRINTLEV >= 1.OR. LALLOPR

!--- assign work file

DO J=1,NPCVECS
  CALL ALLOCATE_CTLVEC(ylcglwk(J))
ENDDO

SPA3(:,:,:) = 0.0_JPRB
SPA2(  :,1:NFD2D) = 0.0_JPRB

!--- read vectors, apply change of variable and copy to work file

LSUBBG = .false.

NUM_PROCS_PER_IO_PROC=MAX(1,NPROC/NPCVECS)
NUM_IO_PROCS=NPROC/NUM_PROCS_PER_IO_PROC

IF(NUM_IO_PROCS > 1 .AND. .NOT.LEVECGRIB)THEN
  ALLOCATE(MIOPROC(NPCVECS))
  jvec_end=0

  DO ICOUNT=1,(NPCVECS-1)/NUM_IO_PROCS+1

    ALLOCATE(RZVAZX(1))
    jvec_start=jvec_end+1
    jvec_end=MIN(NPCVECS,jvec_start+NUM_IO_PROCS-1)

    clfile = CFNPCV
    call getmini2 (ylcglwk,clfile,jvec_start,jvec_end)

    do jvec=jvec_start,jvec_end
      if (.not.LEVECCNTL) then
        call CAIN (ylcglwk(jvec))
        call CHAVAR (ylcglwk(jvec))
      endif

      call GSTATS(1235,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jk)
      do jk=1,ylcglwk(jvec)%nsizel
        ylcglwk(jvec)%data(jk) = ylcglwk(jvec)%data(jk) * YSCALPSQRT%data(jk)
      enddo
!$OMP END PARALLEL DO
      call GSTATS(1235,1)
    ENDDO

    DEALLOCATE(RZVAZX)

  ENDDO

  DEALLOCATE(MIOPROC)

ELSE

do jvec=1,NPCVECS
  clfile = CFNPCV
  write(clfile(7:9),'(I3.3)') jvec
  if (LEVECGRIB) then
!-- NB: CAININ and CHAVAR have not been converted to use SPA3JB/SPA2JB
    call readvec (clfile,LDJB=.FALSE.)
    if (LEVECCNTL) then
      call CAININ (ylcglwk(jvec))
    else
      call CHAVAR (ylcglwk(jvec))
    endif
  else
    call getmini (ylcglwk(jvec),clfile)
    if (.not.LEVECCNTL) then
      call CAIN (ylcglwk(jvec))
      call CHAVAR (ylcglwk(jvec))
    endif
  endif

  call GSTATS(1235,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jk)
  do jk=1,ylcglwk(jvec)%nsizel
    ylcglwk(jvec)%data(jk) = ylcglwk(jvec)%data(jk) * YSCALPSQRT%data(jk)
  enddo
!$OMP END PARALLEL DO
  call GSTATS(1235,1)
ENDDO

ENDIF

LSUBBG = .NOT.LCTLFG

!--- Perform Householder transformations to reduce the matrix of vectors
!--- to upper triangular

do jj=1,NPCVECS
  CALL ALLGATHER_CVSECTION(ylcglwk(jj),zq(1:jj),1,jj)

  zps = DOT_PRODUCT(ylcglwk(jj),ylcglwk(jj)) - DOT_PRODUCT(zq(1:jj),zq(1:jj))

  if (zq(jj) < 0.0_JPRB) then
    zU(jj,jj) = -sqrt(zps+zq(jj)*zq(jj))
  else
    zU(jj,jj) =  sqrt(zps+zq(jj)*zq(jj))
  endif

  zq(jj) = zq(jj) - zU(jj,jj)

  do jk=1,jj-1
    zU(jk,jj) = zq(jk)
  ENDDO

  zps = zps + zq(jj)*zq(jj)

  zzz(1:jj-1)=0.0_JPRB
  zzz(jj)=zq(jj)
  CALL SET_CVSECTION(zzz(1:jj),ylcglwk(jj),1,jj)

  call GSTATS(1235,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jk)
  do jk=1,ylcglwk(jj)%nsizel
    ylcglwk(jj)%data(jk) = ylcglwk(jj)%data(jk) * sqrt(2.0_JPRB/zps)
  enddo
!$OMP END PARALLEL DO
  call GSTATS(1235,1)

!--- we now have the Householder vector in ylcglwk(jj), and the non-zero
!--- elements of the transformed vector in ZU. Now apply the Householder
!--- transformations to the remaining vectors.

  do ji=jj+1,NPCVECS
    zps = DOT_PRODUCT (ylcglwk(jj),ylcglwk(ji))
    call GSTATS(1235,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jk)
    do jk=1,ylcglwk(ji)%nsizel
      ylcglwk(ji)%data(jk) = ylcglwk(ji)%data(jk) - zps*ylcglwk(jj)%data(jk)
    enddo
!$OMP END PARALLEL DO
    call GSTATS(1235,1)
  ENDDO
ENDDO

!--- Multiply the upper triangle by its transpose and find eigenvectors
!--- and eigenvalues

do jj=1,NPCVECS
  do ji=jj+1,NPCVECS
    zU(ji,jj) = 0.0_JPRB
  enddo
enddo

do jj=1,NPCVECS
  do ji=jj,NPCVECS
    zUUT(ji,jj) = 0.0_JPRB
    do jk=ji,NPCVECS
      zUUT(ji,jj) = zUUT(ji,jj) + zU(ji,jk)*zU(jj,jk)
    ENDDO
  ENDDO
ENDDO

call GSTATS(1959,0)
if (JPRB == N_DEFAULT_REAL_KIND) then
  call SSYEV ('V','L',NPCVECS,zUUT,NPCVECS,zlam,zwork,SIZE(zwork),info)
ELSEIF (JPRB == N_DOUBLE_KIND) then
  call DSYEV ('V','L',NPCVECS,zUUT,NPCVECS,zlam,zwork,SIZE(zwork),info)
else
  call ABOR1 ('REAL(KIND=JPRB) is neither default real nor double precision')
endif
call GSTATS(1959,1)

if (info /= 0) then
  write (NULOUT,*) 'preppcm: SSYEV/DSYEV returned with info=',info
  call ABOR1 ('preppcm: SSYEV/DSYEV returned non-zero return code')
endif

!--- convert to eigenvalues of the preconditioner

do jk=1,NPCVECS
  zlam(jk) = 1.0_JPRB / (1.0_JPRB - zlam(jk))
ENDDO

write (NULOUT,*) 'preppcm: eigenvalues found are: ',(zlam(ji),ji=1,NPCVECS)

!--- sort eigenvalues with eigenvalues larger than 1 after eigenvalues 
!--- smaller than 1 and with eigenvalues larger than 1 sorted in decreasing
!--- order

do ji=1,NPCVECS
  indarr(ji) = ji
ENDDO

!--- straight insertion sort courtesy of Numerical Recipies

do jj=2,NPCVECS
  za = zlam(jj)
  ik = indarr(jj)
  do ji=jj-1,1,-1
    if (zlam(ji)>1.0_JPRB .and. (zlam(ji)>=za .or. za<=1.0_JPRB)) then
      ii=ji
      exit
    else
      ii=0
    endif
    zlam(ji+1) = zlam(ji)
    indarr(ji+1) = indarr(ji)
  ENDDO
  zlam(ii+1) = za
  indarr(ii+1) = ik
ENDDO

inpcv = NPCVECS

do while (zlam(inpcv) <= 0.0_JPRB) 
  write (NULOUT,*) 'Warning - eigenvalue less than 1: ',zlam(inpcv)
  inpcv = inpcv-1
  if (inpcv == 0) then
    write (NULOUT,*) 'preppcm: cannot form preconditioner - '//&
     & 'no positive eigenvalues.'  
    write (NULOUT,*)'preppcm: minimisation will not be preconditioned.'
    EXIT
  endif
enddo

IF (inpcv>0) THEN
  write (NULOUT,*)'Number of preconditioning vectors selected is ',inpcv
  write (NULOUT,*) 'preppcm: selected eigenvalues are: ',(zlam(ji),ji=1,inpcv)

!--- Save eigenvalues

  ALLOCATE (YVCGLPC(inpcv))
  DO i=1,inpcv
    CALL ALLOCATE_CTLVEC(YVCGLPC(i))
  ENDDO

  ALLOCATE (RCGLPC(inpcv))
  IF (LLP) WRITE(NULOUT,9) 'RCGLPC   ',SIZE(RCGLPC   ),SHAPE(RCGLPC   )

  NVCGLPC = inpcv
  RCGLPC(:) = MIN(R_MAX_CNUM_PC,zlam(1:inpcv))

!--- apply Householder transformations to the eigenvectors to get the
!--- eigenvectors of the preconditioner

  DO jj=1,inpcv
    YVCGLPC(jj) = 0.0_JPRB
    CALL SET_CVSECTION(zuut(1:NPCVECS,indarr(jj)),YVCGLPC(jj),1,NPCVECS)

    do ji=NPCVECS,1,-1
      zps = DOT_PRODUCT (ylcglwk(ji),YVCGLPC(jj))
      call GSTATS(1235,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jk)
      do jk=1,YVCGLPC(jj)%nsizel
        YVCGLPC(jj)%data(jk) = YVCGLPC(jj)%data(jk) - zps*ylcglwk(ji)%data(jk)
      enddo
!$OMP END PARALLEL DO 
      call GSTATS(1235,1)
    ENDDO
  ENDDO

  DO J=1,NPCVECS
    CALL DEALLOCATE_CTLVEC(ylcglwk(J))
  ENDDO
ELSE
  LMPCGL = .false.
ENDIF

NPCVECS = inpcv

9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)

IF (LHOOK) CALL DR_HOOK('PREPPCM',1,ZHOOK_HANDLE)
end subroutine preppcm
