SUBROUTINE OBSCORST(PJO)
#if defined (DOC)
*
***s/r OBSCORST  - Vertical error correlations.
*                    for SATEMS.
*
*
*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.
*          S. Pellerin *ARMA/SMC May 2000
*                   - Logical unit cleanup
*          Y. Yang    Oct. 2004
*                   - Added include "comnumbr.cdk"
*                     due to the dependence of the "cvcord.cdk" on JPNBRELEM
*          C. Charette ARMA/SMC jan. 2005
*            - Replaced write(nuldbg,..) statements by write(nulout,...)
*            - Replaced print statements by write(nulout,...)
*          Y.J. Rochon, ARQX/EC May 2010
*            - Added test on input/initial PJO to determine if calc are to proceed.
*
*
*                              -1
**    Purpose:  - CALCULATE  [O] * [ H(X) - obs ]/sigmaobs    FOR SATEMS
*
*               - save result into ROBDATA(NCMOMI,IDATA)
*               - calculate the contibution to J0
*
*
*Arguments
*     PJO:  CONTIBUTION 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 "comnumbr.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,IELMDZ,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
      IF (PJO.LT.1.D-4) RETURN
C
C     ALLOW MEMORY FOR WORKSPACE
C
      CALL HPALLOC(PXWRK,5*JPGRADLEN,IERR,8)
C
C======================
      IELMDZ = 10192
      DLSUM  = 0.
C======================
C
      ITER=30
      ZPRE=RPRECIS
c      WRITE(NULOUT,*) '  '
c      WRITE(NULOUT,*)'*************-OBSCORST-*************************'
c      WRITE(NULOUT,*) ' DATA FAMILY                  ---> ','SATEMS'
c      WRITE(NULOUT,*) ' MAXIMUM NUMBER OF ITERATIONS ---> ',ITER
c      WRITE(NULOUT,*) ' REQUESTED ACCURACY           ---> ',ZPRE
      DO J = 1,NFILES
        IF ( CFAMTYP(J) .EQ. 'ST') THEN
          IBEGIN=NBEGINTYP(J)
          ILAST =NENDTYP(J)
C
          NBEG=IBEGIN
          NEND=ILAST
C
c          WRITE(NULOUT,*
c     &         )'----------------------------------------------'
c          WRITE(NULOUT,*) ' DATA FILE                   ---> ',CFILNAM(J
c     &         )
c          WRITE(NULOUT,*
c     &         )'----------------------------------------------'
c          WRITE(NULOUT,*) '  '
C
C       LOOP OVER VARIABLE TYPES ( 0=U 1=V 2=GZ 3=T-Td ...)
C
C     ----------------------------
          DO JVAR=1,nelems
C--------==============----
            DO JL=1,JPNTYP
C--------==============---
C
C       MBAND=1:CLEAR 2 : CLOUDY
C
              MBAND=JL
              IK=0
              DO JDATA = IBEGIN, ILAST
                LLOK= ((MOBDATA(NCMOEC,JDATA) .EQ. JL )
     &               .AND. (MOBDATA(NCMASS,JDATA) .EQ. 1)
     &               .AND. (MOBDATA(NCMXTR,JDATA) .EQ. 0)
     &               .AND.   (MOBDATA(NCMVNM,JDATA) .EQ. nlist(jvar)))
     &            .OR.  ((MOBDATA(NCMOEC,JDATA) .EQ. JL)
     &                    .AND.(MOBDATA(NCMASS,JDATA) .EQ. 1)
     &                    .AND.(MOBDATA(NCMXTR,JDATA) .EQ. 2)
     &                    .AND.(MOBDATA(NCMVNM,JDATA) .EQ. nlist(jvar))
     &                    .AND.(MOBDATA(NCMVNM,JDATA) .EQ. IELMDZ))
***************************************
c               write(6,*)' obscorst:LLOK,ass,xtr,vnm',llok,
c     %         MOBDATA(NCMASS,JDATA),MOBDATA(NCMXTR,JDATA),
c     %         MOBDATA(NCMVNM,JDATA)
c               write(6,*)' obscorst:jvar,nlist,',jvar,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,' SATEMS WITH TYPE: ',JL
C
C    SOLVE BY CONJUGATE GRADIENT METHOD
C
                ITER=30
                ZPRE=RPRECIS
               LLPR=.FALSE.
***********************************************************************
c               LLPR=.TRUE.
c               WRITE(NULOUT,*) 'obscorst: x= ',(x(jdata),jdata=1,nd)
c               WRITE(NULOUT,*) 'obscorst: B= ',(b(jdata),jdata=1,nd)
***********************************************************************
C
C=======================================================================
                CALL CONJGRAD(ND,B,X,WK,ND,ITER,ZPRE,MATVEC,INFO,LLPR
     &               ,nlist(jvar),CFAMTYP(j))
C=======================================================================
c                WRITE(NULOUT,*)'------CONJGRAD: ',ITER
c     &               ,' 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
c              ELSE
c                WRITE(NULOUT,*) ' NO SATEMS WITH TYPE: ',JL
              ENDIF
C
C-------=======----
            END DO
C-------=======---
C
          enddo
        endif
      END DO
C======================
      PJO = DLSUM/2.0
C======================
C
      CALL HPDEALLC(PXWRK,IERR,1)
c      WRITE(NULOUT,*)'-END----------OBSCORST------------------END-----'
      RETURN
      END