!-------------------------------------- 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 OBSCORST(PJO),1
#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
* C. Charette ARMA/SMC jan. 2005
* - Replaced write(nuldbg,..) statements by write(nulout,...)
* - Replaced print statements by write(nulout,...)
*
*
* -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 "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
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