CMAX: [Version 1.0 (6/22/93)]
CMAX: ----------------------------------------------------
CMAX: Transformation of OBSCOV from obscov.f
CMAX: ----------------------------------------------------
CFPP$ NOCONCUR R
      SUBROUTINE obscov(ocv,zkx,gi,gj,obserr,kq,pi,pj,d,xki,hco,vco,nz)
C-------------------------------------------------------------------
C     NASA / DAO OPTIMUM INTERPOLATION ANALYSIS GROUP
C     ANALYSIS VERSION 1.3
C-------------------------------------------------------------------
C     Programmer: S. Bloom
C     Date:       July, 1990
C     ROUTINE TO GENERATE THE OBSERVATIONAL ERROR COVARIANCES (BOTH
C     HORIZONTAL AND VERTICAL)
C
C     INPUTS:
C
C             D         OBS-OBS DISTANCES (FROM MMCOV)
C             GI        GETI
C             GJ        GETJ
C             NZ        NUMBER OF HEIGHT OBSEVATIONS
C             PI        PRSI (OBS PRESSURES AT 'I' POINTS)
C             PJ        PRSJ (OBS PRESSURES AT 'J' POINTS)
C
C     OUTPUT:
C
C             OCV       OBS-OBS HEIGHT ERROR COVARIANCES
C
C
C     THIS CODE REPLACES A SECTION OF ORIGINAL ZUVCOV ROUTINE
C
C     S. BLOOM   7/90
c     M. SEABLOM 9/91 Removed this subroutine; replaced with version
c                     using modified matrix setup to accomodate large
c                     volumes.
c     M. SEABLOM 5/92 Resurrected original subroutine for use in low
c                     and middle latitude minivolumes.
C----------------------------------------------------------------
      DIMENSION obserr(200,4,19),vco(:),hco(:),xki(:),pj(:),pi(:),d(:),
     &    kq(*),gj(:),gi(:),zkx(:),ocv(:)
      DIMENSION IHOLD (4000), IARR (4000)
      COMMON / OBSCORR / VCORLIST (200), HCORLIST (200), VCOROE (13, 13,
     & 4), HCOROE (400, 5)
!hpf$ distribute d(block)
!hpf$ distribute gi(block)
!hpf$ distribute gj(block)
!hpf$ distribute hco(block)
!hpf$ distribute hcorlist(block)
!hpf$ distribute hcoroe(block,block)
!hpf$ distribute iarr(block)
!hpf$ distribute ihold(block)
!hpf$ distribute kq(block)
!hpf$ distribute obserr(block,block,block)
!hpf$ distribute ocv(block)
!hpf$ distribute pi(block)
!hpf$ distribute pj(block)
!hpf$ distribute vco(block)
!hpf$ distribute vcorlist(block)
!hpf$ distribute vcoroe(block,block,block)
!hpf$ distribute xki(block)
!hpf$ distribute zkx(block)
      LOGICAL lif
      DATA ZERO / 0.0 /
      DATA ONE / 1.0 /
      DATA TENTH / 0.10 /
      DATA TENM3 / .001 /
C------------------------------------------------------------
C------------------------------------------------------------
      INTEGER Ti1
      INTEGER TTT4_temp_auto, TTT3_temp_auto, TTT2_temp_auto, TTT1_temp_
     &auto, TTT0_temp_auto, TTT5_temp_auto
      i2(i) = i * (i + 1) / 2
      nzs = (nz * (nz + 1)) / 2
      CALL ahgather_v2(zkx,gi,xki,nzs)
      CALL ahgather_v2(zkx,gj,hco,nzs)
      CALL ahgather_v2(vcorlist,hco,vco,nzs)
      CALL ahgather_v2(hcorlist,xki,ocv,nzs)
      ncount = 0
C
C     FIRST SECTION COUNTS THE NUMBER OF OBSERVATION PAIRS TO
C     CORRELATE (NCOUNT). ALSO COMPRESSES THE ARRAYS, REMEMBERING
C     THE CORRECT LOCATION IN IARR.
C
C     THE COMPRESSION STEP USES IHOLD AS A "PLACEHOLDER", WITH ALL
C     ELEMENTS INITIALLY ONE.  THEN DIAGONAL ELEMENTS ARE SET TO ZERO.
C     FINALLY, ALL APPROPRIATE LOCATIONS ARE MARKED WITH INTEGERS.
C     INDEX ARRAY "IARR" IS OBTAINED BY USING WHENIGT FUNCTION, WHICH
C     POINTS TO ALL NON-ZERO ELEMENTS OF IHOLD.
C
      DO ti1 = 1 , nzs
        ihold(ti1) = 1
      ENDDO
      DO 7000 n = 1 , nz
        ihold(i2(n)) = 0
 7000 CONTINUE
      DO k = 1 , nzs
        lif = (xki(k) .EQ. hco(k) .AND. vco(k) .NE. 0.0) .AND. ihold(k)
     &      .NE. 0
        IF ((xki(k) .EQ. hco(k) .AND. vco(k) .NE. 0.0) .AND. ihold(k) 
     &        .NE. 0) THEN
          ncount = ncount + 1
          ihold(k) = ncount
        ENDIF
      ENDDO
      DO k = 1 , nzs
        IF (.NOT.lif) THEN
          ihold(k) = 0
        ENDIF
      ENDDO
      IF (ncount .EQ. 0) THEN
        ocv(:nzs) = 0.
        RETURN
      ENDIF
      CALL whenigt(nzs,ihold,1,0,iarr,ncnt)
      IF (ncnt .NE. ncount) THEN
        WRITE( 6,401 ) ncnt,ncount
      ENDIF
401   FORMAT ('  WHENIGT PROBLEM, NCNT  NCOUNT ',2I8)
cmm$*********************************************************
cmm$  Trying to achieve this:
cmm$          D(1:NCOUNT)  =   D(IARR(1:NCOUNT))
cmm$         PI(1:NCOUNT)  =  PI(IARR(1:NCOUNT))
cmm$         PJ(1:NCOUNT)  =  PJ(IARR(1:NCOUNT))
cmm$        XKI(1:NCOUNT)  = XKI(IARR(1:NCOUNT))
cmm$        VCO(1:NCOUNT)  = VCO(IARR(1:NCOUNT))
cmm$        OCV(1:NCOUNT)  = OCV(IARR(1:NCOUNT))
cmm$*********************************************************
      FORALL (ti1 = 1:ncount) d(ti1) = d(iarr(ti1)) 
      FORALL (ti1 = 1:ncount) pi(ti1) = pi(iarr(ti1))
      FORALL (ti1 = 1:ncount) pj(ti1) = pj(iarr(ti1))
      FORALL (ti1 = 1:ncount) xki(ti1) = xki(iarr(ti1))
      FORALL (ti1 = 1:ncount) vco(ti1) =  vco(iarr(ti1))
      FORALL (ti1 = 1:ncount) ocv(ti1) = ocv(iarr(ti1))
C
C     NEXT SECTION GENERATES HORIZONTAL CORRELATIONS,
C     CHECKING FOR RAWINSONDES (ITY=-1) WHICH ARE NOT
C     HORIZONTALLY CORRELATED (HENCE THE CHECK FOR D >0,
C     SINCE RAWINSONDES HAVE VERTICAL CORRELATION...)
C
      DO l = 1 , ncount
        id = int(.1 * d(l) + .001)
        r = .1 * d(l) - id
        id = id + 1
        id1 = id + 1
        ity = int(ocv(l) + .001)
        IF (ity .GT. 0) THEN
          t1 = hcoroe(id,ity)
          t2 = hcoroe(id1,ity)
          ocv(l) = t1 + r * (t2 - t1)
        ELSE
          ocv(l) = 1.0
          IF (d(l) .GT. 0.0) THEN
            ocv(l) = 0.0
          ENDIF
        ENDIF
      ENDDO
C
C     THIS SECTION OBTAINS THE OBSERVATION HEIGHT ERROR VARIANCES,
C     AND ACCUMULATES THEM INTO OCV.
C
C     NOTE: REDEFINING VARIABLES TO SAVE SPACE,
C             D   = 'OBERI' (IN OLD ZUVCOV CODE)
C             HCO = 'OBERJ' ( " )
C
      CALL obertrp0(xki,pi,d,obserr,kq(1),ncount)
      CALL obertrp0(xki,pj,hco,obserr,kq(1),ncount)
      ocv(:ncount) = d(:ncount) * hco(:ncount) * ocv(:ncount)
C
C     THIS SECTION OBTAINS THE VERTICAL CORRELATION TERMS, TAKING
C     CARE TO USE THE CORRECT VERTICAL CORRELATION FUNCTION FOR EACH
C     INSTRUMENT
C
      hco(:ncount) = 0.0
      CALL vcorroe(pi,pj,hco,vco,ncount)
C     FINALLY, COMBINE THE RESULTS.
C             1. COMBINE VERTICAL CORRELATIONS WITH REST OF TERMS
C                (SAVING COMPRESSED COVARIANCES IN VCO)
C
C             2. ZERO THE OCV ARRAY
C
C             3. LOAD COVARIANCES INTO PROPER LOCATIONS IN OCV USING
C                IARR
C
      vco(:ncount) = ocv(:ncount) * hco(:ncount)
      ocv(:nzs) = 0.0
      DO l = 1 , ncount
        ocv(iarr(l)) = vco(l)
      ENDDO
      RETURN
      END
