!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
!                     version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software 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 above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!

      SUBROUTINE OBSCORHU(PJO),1
#if defined (DOC)
*
***s/r OBSCORHU  - Vertical error correlations.
*                    for HUMSAT.
*
*
*Author  : P. Koclas *CMC/AES  April  1996
*Revision:
*          S. Pellerin *ARMA/AES Sept 97.
*                   - Control of the different model state of the 3Dvar
*                     through COMSTATE, COMSTATEC and COMSTNUM common
*                     blocks variables (comstate.cdk).
*          S. Pellerin *ARMA/AES Aug. 98.
*                   - Built-up of O matrix based on assimilated elements
*                     instead of NPOS variable.
*          C. Charette *ARMA/AES Mar. 99.
*                   - Increase the maximum nuumber of iterations
*                     from 30 to 50 for 3dvar-eta version
*          S. Pellerin *ARMA/AES May 2000
*                   - Logical unit cleanup
*          C. Charette *ARMA/AES Oct 2000.
*                   - Consider all accepted elements including
*                     those flagged outside the domain. See
*                     changes in LHUMSAT3D and AHUMSAT3D.
*           C. Charette ARMA/SMC jan. 2005
*            - Replaced write(nuldbg,..) statements by write(nulout,...)
*                              -1
**    Purpose:  - CALCULATE  [O] * [ H(X) - obs ]/sigmaobs    FOR HUMSAT DATA
*
*               - save result into ROBDATA(NCMOMI,IDATA)
*               - calculate the contibution to  J0
*
*
*Arguments
*     PJO:  CONTRIBUTION to Jo(X)
*
#endif

      IMPLICIT NONE
*implicits
#include "comcst.cdk"
#include "comlun.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "cvcord.cdk"
#include "comstato.cdk"
#include "comvcor.cdk"
#include "comfilt.cdk"
*
C
      REAL*8 PJO
C
      INTEGER IBEGIN,ILAST,IDATA,IK
      INTEGER J,JDATA,JL
      INTEGER IERR,jvar
C
      REAL*8 DLSUM
C
      LOGICAL LLOK,LLPR
C
      REAL*8  X(JPGRADLEN),B(JPGRADLEN)
      REAL*8  WK(1)
      POINTER(PXWRK,WK)
C
      INTEGER INFO,ITER
      REAL*8 ZPRE

      EXTERNAL MATVEC
*----------------------------------------------------------------------
C
C     ALLOW MEMORY FOR WORKSPACE
C
      CALL HPALLOC(PXWRK,5*JPGRADLEN,IERR,8)
C
C==============
      DLSUM=0.D0
C
C===============
C
C     LOOP OVER ALL FILES AND LOOK FOR THE ONES CONTAINING HUMSAT DATA
C
      ITER=50
      ZPRE=RPRECIS
c      WRITE(NULOUT,*) '  '
c      WRITE(NULOUT,*)'*************-OBSCORHU-************************'
c      WRITE(NULOUT,*) ' DATA FAMILY                 ---> ','HUMSAT'
c      WRITE(NULOUT,*) ' MAXIMUM NUMBER OF ITERATIONS---> ',ITER
c      WRITE(NULOUT,*) ' REQUESTED ACCURACY          ---> ',ZPRE
      DO J = 1,NFILES
      IF ( CFAMTYP(J) .EQ. 'HU') THEN
         IBEGIN=NBEGINTYP(J)
         ILAST =NENDTYP(J)
         NBEG  =IBEGIN
         NEND  =ILAST
c         WRITE(NULOUT,*)'----------------------------------------------'
c         WRITE(NULOUT,*) ' DATA FILE                   ---> ',CFILNAM(J)
c         WRITE(NULOUT,*)'----------------------------------------------'
c         WRITE(NULOUT,*) '  '
C
C       LOOP OVER VARIABLE TYPES ( 0=U 1=V 2=GZ 3=T-Td ...)
C
C     ----------------------------
         DO JVAR=1,nelems
           IK=0
           DO JDATA = IBEGIN, ILAST
             LLOK=
     &            (MOBDATA(NCMASS,JDATA) .EQ. 1)
     &            .AND. (MOBDATA(NCMVNM,JDATA) .EQ. nlist(jvar))
             IF ( LLOK ) THEN
               IK=IK+1
               X(IK)    = ROBDATA8(NCMOMA,JDATA)*.99
               B(IK)    = ROBDATA8(NCMOMA,JDATA)
               NINDX(IK) = JDATA
             ENDIF
           END DO
C
C
C        =====
           ND=IK
C        =====
           IF ( ND .NE. 0 ) THEN
c             WRITE(NULOUT,*
c     &            )'--------------------------------------------'
c             WRITE(NULOUT,*) ' ',ND,' HUMSAT DATA  '
C
C     SOLVE BY CONJUGATE GRADIENT METHOD
C     ------------------------------------------------------------------
             ITER=50
             ZPRE=RPRECIS
             LLPR=.FALSE.
C=======================================================================
             CALL CONJGRAD(ND,B,X,WK,ND,ITER,ZPRE,MATVEC,INFO,LLPR
     &            ,nlist(jvar),CFAMTYP(j))
C=======================================================================
c             WRITE(NULOUT,*)'-----CONJGRAD: ',ITER,' ITERATIONS-----'
c             WRITE(NULOUT,*
c     &            )'-------------------------------------------'
C
             DO JDATA = 1, ND
               IDATA=NINDX(JDATA)
               ROBDATA8(NCMOMI,IDATA) =X(JDATA)
               DLSUM=DLSUM+ROBDATA8(NCMOMI,IDATA)*ROBDATA8(NCMOMA,IDATA)
             END DO
C
           ENDIF
 300       CONTINUE
         enddo
       ENDIF
      END DO
C
C    ===================
      PJO = DLSUM/2.0
C    ===================
C
      CALL HPDEALLC(PXWRK,IERR,1)
c      WRITE(NULOUT,*)'-END----------OBSCORHU------------------END-----'
      RETURN
      END