CMAX: [Version 1.0 (6/22/93)]
CMAX: ----------------------------------------------------
CMAX: Transformation of PRTRMS from prtrms.f
CMAX: ----------------------------------------------------
      SUBROUTINE prtrms(kx,del,bgrs,bacc,bq,bbud,bchk,nobs)
C  PRINTS RMS STATISTICS FOR THE QUALITY CONTROL
      INTEGER           BACC(NOBS)
      INTEGER           BBUD(NOBS)
      INTEGER           BCHK(NOBS)
      INTEGER           BGRS(NOBS)
      INTEGER BQ (NOBS)
      DIMENSION DEL (NOBS)
      INTEGER I
      INTEGER KK
      REAL KX (NOBS)
      LOGICAL LACC
      LOGICAL LCHEK
      LOGICAL LGOOD
      LOGICAL LQUAL
      INTEGER NTNACC
      INTEGER NTNBTH
      INTEGER NTNCHK
      INTEGER NTNCUT
      INTEGER NTNOCH
      INTEGER NTNQUL
      INTEGER NTNREJ
      INTEGER NTNTOT
      CHARACTER * 4 UNDRLINE (33)
!hpf$ distribute bacc(block)
!hpf$ distribute bbud(block)
!hpf$ distribute bchk(block)
!hpf$ distribute bgrs(block)
!hpf$ distribute bq(block)
!hpf$ distribute del(block)
!hpf$ distribute hh(block,block,block)
!hpf$ distribute irmsa(block)
!hpf$ distribute irmsr(block)
!hpf$ distribute kx(block)
!hpf$ distribute nacc(block)
!hpf$ distribute nboth(block)
!hpf$ distribute nchk(block)
!hpf$ distribute ncut(block)
!hpf$ distribute ndum(block,block)
!hpf$ distribute nochk(block)
!hpf$ distribute nqual(block)
!hpf$ distribute nrej(block)
!hpf$ distribute ntot(block)
!hpf$ distribute obserr(block,block,block)
!hpf$ distribute offlev(block)
!hpf$ distribute qobs(block,block)
!hpf$ distribute rmsa(block)
!hpf$ distribute rmsr(block)
!hpf$ distribute vcoroe(block,block,block)
!hpf$ distribute ww(block,block,block)
      LOGICAL lif(nobs)
!hpf$ distribute lif(block)
      LOGICAL lif100(nobs)
!hpf$ distribute lif100(block)
      LOGICAL lif101(nobs)
!hpf$ distribute lif101(block)
      LOGICAL lif102(nobs)
!hpf$ distribute lif102(block)
      LOGICAL  LCHEK100(nobs)
!hpf$ distribute lchek100(block)
      INTEGER  KK100(nobs)
!hpf$ distribute KK100(block)
      LOGICAL  LACC100(nobs)
!hpf$ distribute lacc100(block)
      LOGICAL  LGOOD102(nobs)
!hpf$ distribute lgood102(block)
      LOGICAL  LGOOD101(nobs)
!hpf$ distribute lgood101(block)
      LOGICAL  LGOOD100(nobs)
!hpf$ distribute lgood100(block)
      LOGICAL  LQUAL100(nobs)
!hpf$ distribute LQUAL100(block)
      DATA UNDRLINE / '----', '----', 31 * '----' /
      CHARACTER * 8 DATANAME, OBSNAME
      LOGICAL QOBS, OFFLEV
      REAL RMSA, RMSR
C  OBSERVATIONS INFORMATION
      COMMON / obs / maxdex, nfgge, lun, hh (13, 13, 20),
     &vcoroe (18, 18, 4), obserr (200, 4, 19), ww (13, 13, 20),
     &qobs (200, 5), offlev (200)
      common / obschar / dataname (5), obsname(200)
C  TALLY MATRIX FOR RMS STATISTICS
      COMMON / OBSKNT / NTOT (200), NACC (200), NREJ (200), NCUT (200), 
     &NQUAL (200), NBOTH (200), NCHK (200), NOCHK (200), RMSA (200), IRM
     &SA (200), RMSR (200), IRMSR (200), NDUM (200, 4)
C  INITIALIZE VARIABLES FOR THE STATISTICS
      DO i = 1 , maxdex
        irmsa(i) = 0
      ENDDO
      DO i = 1 , maxdex
        irmsr(i) = 0
      ENDDO
      nacc(:maxdex) = 0
      DO i = 1 , maxdex
        nboth(i) = 0
      ENDDO
      nchk(:maxdex) = 0
      ncut(:maxdex) = 0
      DO i = 1 , maxdex
        nochk(i) = 0
      ENDDO
      nqual(:maxdex) = 0
      nrej(:maxdex) = 0
      ntot(:maxdex) = 0
      DO i = 1 , maxdex
        rmsa(i) = 0.0
      ENDDO
      DO i = 1 , maxdex
        rmsr(i) = 0.0
      ENDDO
      ntnacc = 0
      ntnbth = 0
      ntnchk = 0
      ntncut = 0
      ntnoch = 0
      ntnqul = 0
      ntnrej = 0
      ntntot = 0
C  LOOP OVER OBSERVATIONS TO ACCUMULATE STATISTICS.
      FORALL (i = 1:nobs) kk100(i) = kx(i)
      DO i = 1 , nobs
        ntot(kk100(i)) = ntot(kk100(i)) + 1
      ENDDO
C  FINAL RESULTS OF GROSS AND BUDDY CHECKS.
      lgood100(1:nobs) = bbud(1:nobs) .EQ. 1
      DO i = 1 , nobs
        lif(i) = lgood100(i)
        IF (lgood100(i)) THEN
          nacc(kk100(i)) = nacc(kk100(i)) + 1
        ENDIF
      ENDDO
      DO i = 1 , nobs
        IF (lif(i)) THEN
          irmsa(kk100(i)) = irmsa(kk100(i)) + 1
        ENDIF
      ENDDO
      DO i = 1 , nobs
        IF (lif(i)) THEN
          rmsa(kk100(i)) = rmsa(kk100(i)) + del(i) ** 2
        ENDIF
      ENDDO
      lgood101(1:nobs) = bgrs(1:nobs) .EQ. 1
      lgood102(1:nobs) = bbud(1:nobs) .EQ. 1
      DO i = 1 , nobs
        IF (.NOT.lif(i)) THEN
          nrej(kk100(i)) = nrej(kk100(i)) + 1
        ENDIF
      ENDDO
      DO i = 1 , nobs
        IF (.NOT.lif(i)) THEN
          irmsr(kk100(i)) = irmsr(kk100(i)) + 1
        ENDIF
      ENDDO
      DO i = 1 , nobs
        IF (.NOT.lif(i)) THEN
          rmsr(kk100(i)) = rmsr(kk100(i)) + del(i) ** 2
        ENDIF
      ENDDO
C  REASON FOR REJECTION
      FORALL (i = 1:nobs) lqual100(i) = bq(i) .EQ. 1
      DO i = 1 , nobs
        lif100(i) = .NOT.lgood101(i)
        IF (.NOT.lgood101(i) .AND. lqual100(i)) THEN
          ncut(kk100(i)) = ncut(kk100(i)) + 1
        ENDIF
      ENDDO
      DO i = 1 , nobs
        IF (lif100(i) .AND. .NOT.lqual100(i)) THEN
          nboth(kk100(i)) = nboth(kk100(i)) + 1
        ENDIF
      ENDDO
      DO i = 1 , nobs
        IF (.NOT.lif100(i) .AND. .NOT.lqual100(i)) THEN
          nqual(kk100(i)) = nqual(kk100(i)) + 1
        ENDIF
      ENDDO
C  REASON FOR REACCEPTANCE
C  FOR REPORTS THAT FAILED THE GROSS CHECK OR WERE OF SUSPICIOUS QUALITY
C  BUT ARE BEING USED, RECORD HOW THEY GOT ACCEPTED.
      lacc100(1:nobs) = bacc(1:nobs) .EQ. 1
      WHERE (.NOT.lacc100(1:nobs) .AND. lgood102(1:nobs))
        lchek100(1:nobs) = bchk(1:nobs) .EQ. 1
C  PASSED BUDDY CHECK
      ENDWHERE
      DO i = 1 , nobs
        lif101(i) = .NOT.lacc100(i) .AND. lgood102(i)
        lif102(i) = .NOT.lchek100(i)
        IF (.NOT.lacc100(i) .AND. lgood102(i) .AND. .NOT.lchek100(i)
     &        ) THEN
          nchk(kk100(i)) = nchk(kk100(i)) + 1
        ENDIF
      ENDDO
C  (SUSP. QUAL).AND.(PASSED GROSS).AND.(FAILED BUDDY)
      DO i = 1 , nobs
        IF (.NOT.lif102(i) .AND. lif101(i)) THEN
          nochk(kk100(i)) = nochk(kk100(i)) + 1
        ENDIF
      ENDDO
C  PRINT RMS STATISTICS
      WRITE( 6,1010 ) 
      WRITE( 6,1011 ) undrline
      WRITE( 6,1000 ) 
      WRITE( 6,1011 ) undrline
      ntntot = ntntot + sum(ntot(:maxdex),mask=ntot(:maxdex) .GT. 0)
      ntnacc = ntnacc + sum(nacc(:maxdex),mask=ntot(:maxdex) .GT. 0)
      ntnrej = ntnrej + sum(nrej(:maxdex),mask=ntot(:maxdex) .GT. 0)
      ntncut = ntncut + sum(ncut(:maxdex),mask=ntot(:maxdex) .GT. 0)
      ntnqul = ntnqul + sum(nqual(:maxdex),mask=ntot(:maxdex) .GT. 0)
      DO kk = 1 , maxdex
        IF (ntot(kk) .GT. 0) THEN
          ntnbth = ntnbth + nboth(kk)
        ENDIF
      ENDDO
      ntnchk = ntnchk + sum(nchk(:maxdex),mask=ntot(:maxdex) .GT. 0)
      DO kk = 1 , maxdex
        IF (ntot(kk) .GT. 0) THEN
          ntnoch = ntnoch + nochk(kk)
        ENDIF
      ENDDO
      DO kk = 1 , maxdex
        IF (ntot(kk) .GT. 0 .AND. irmsa(kk) .GT. 0) THEN
          rmsa(kk) = sqrt(rmsa(kk) / irmsa(kk))
        ENDIF
      ENDDO
      DO kk = 1 , maxdex
        IF (ntot(kk) .GT. 0 .AND. irmsr(kk) .GT. 0) THEN
          rmsr(kk) = sqrt(rmsr(kk) / irmsr(kk))
        ENDIF
      ENDDO
      DO kk = 1 , maxdex
        IF (ntot(kk) .GT. 0) THEN
          WRITE( 6,1002 ) obsname(kk),ntot(kk),nacc(kk),nrej(kk),
     &        ncut(kk),nqual(kk),nboth(kk),nchk(kk),nochk(kk),rmsa(kk),
     &        rmsr(kk)
        ENDIF
      ENDDO
C  PRINT TOTALS.
      WRITE( 6,1011 ) undrline
      WRITE( 6,1003 ) ntntot,ntnacc,ntnrej,ntncut,ntnqul,ntnbth,ntnchk,
     &    ntnoch
C  TOTAL GROSS CHECK REJECTED AND BUDDY CHECK ACCEPTED REPORTS.
      ntgrs = ntncut + ntnqul + ntnbth
      ntbud = ntnchk + ntnoch
      WRITE( 6,1005 ) 
      WRITE( 6,1004 ) ntgrs,ntbud
      RETURN
1000  FORMAT (T11,'Data',T22,'Total',T33,'Reports',T46,'Reports',T63,'Di
     &d not pass',T89,'Reaccepted',T119,'RMS',/,T11,'type',T21,'reports'
     &,T33,'accepted',T46,'rejected',T63,'gross check',T84,'with buddy '
     &,'w/o buddy',T111,'Accepted   Rejected',/,T58,'Cutoff  Quality   B
     &oth',T88,'check',T98,'check')
1002  FORMAT (1X,A8,5X,I6,5X,I6,5X,I6,5X,I5,4X,I5,4X,I5,6X,I5,6X,I5,6X,E
     &11.4,3X,E11.4)
1003  FORMAT (1X,' Total  ',5X,I6,5X,I6,5X,I6,5X,I5,4X,I5,4X,I5,6X,I5,6X
     &,I5)
1004  FORMAT (57X,I5,21X,I5,/)
1005  FORMAT (52X,20('-'),10X,12('-'))
1010  FORMAT (30X,' * Detailed Gross and',' Buddy Check Results *',/)
1011  FORMAT (1X,33A4)
      return
      END
