w3fi65.f

Go to the documentation of this file.

C> @file
C> @brief NMC office note 29 report packer.
C> @author L. Marx @date 1990-01
 
C> Packs an array of upper-air reports into the format
C> described by NMC office note 29, or packs an array of surface
C> reports into the format described by NMC office note 124. Input
C> integer, real or character type as specified in the category
C> tables in the write-up for w3fi64() (the office note 29 report
C> packer) are converted to character data. Missing character data
C> are specified as strings of 9's except for that converted from
C> input character type which are generally specified as blanks.
C> This library is similar to w3ai03() except w3ai03() was written in
C> assembler.
C>
C> Program history log:
C> - L. Marx 1990-01 Converted code from assembler
C> to vs fortran.
C> - Dennis Keyser 1991-08-23 Use same arguments as w3ai03() ;
C> Streamlined code; Docblocked and commented.
C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
C> - Dennis Keyser 1992-07-09 Checks the number of characters
C> used by each variable prior to conversion from
C> integer to character format; If this number is
C> greater than the number of characters allocated for
C> the variable the variable is packed as "missing"
C> (i.e., stores as all 9's).
C> - Dennis Keyser 1993-06-28 Initializes number of words in
C> report to 42 in case "strange" report with no data
C> in any category encountered (used to be zero, but
C> such "strange" reports caused code to fail).
C> - Dennis Keyser 1993-12-22 Corrected error which resulted
C> in storage of 0's in place of actual data in a
C> category when that category was the only one with
C> data.
C> - Dennis Keyser 1998-08-07 Fortran 90-compliant - split an
C> if statement into 2-parts to prevent f90 floating
C> point exception error that can now occur in some
C> cases (did not occur in f77).
C>
C> @param[in] LOCRPT Integer array containing one unpacked report.
C> LOCRPT must begin on a fullword boundary. Format
C> is mixed, user must equivalence real and character
C> arrays to this array (see w3fi64 write-up for
C> content).
C> @param[out] COCBUF CHARACTER*10 Array containing a packed report in
C> NMC office note 29/124 format.
C>
C> @note After first creating and writing out the office note 85
C> (first) date record, the user's fortran program begins a packing
C> loop as follows.. Each iteration of the packing loop consists of
C> a call first to w3fi65() to pack the report into COCBUF, then a call
C> to w3fi66() with the current value of 'NFLAG' (set to zero for first
C> call) to block the packed report into a record (see w3fi66() write-
C> up). if 'NFLAG' is -1 upon returning from w3fi66(), the remaining
C> portion of the record is not large enough to hold the current
C> packed report. The user should write out the record, set 'NFLAG'
C> to zero, call w3fi66() to write the packed report to the beginning
C> of the next record, and repeat the packing loop. If 'NFLAG' is
C> positive, a packed report has been blocked into the record and
C> the user should continue the packing loop.
C> When all reports have been packed and blocked, the user
C> should write out this last record (which is not full but contains
C> fill information supplied by w3fi66()). One final record containing
C> the string 'endof file' (sic) followed by blank fill must be
C> written out to signal the end of the data set.
C>
C> @note 1: The packed report will have the categories ordered as
C> follows:  1, 2, 3, 4, 5, 6, 7, 51, 52, 8, 9.
C> @note 2: The input unpacked report must be in the format spec-
C> ified in the w3fi64() office note 29 report unpacker write-up.
C> @note 3: The unused porion of cocbuf is not cleared.
 
C> @note Entry w3ai03() duplicates processing in w3fi65() since no
C> assembly language code in cray w3lib.
C>
C> @author L. Marx @date 1990-01
      SUBROUTINE w3fi65(LOCRPT,COCBUF)
C
      CHARACTER*12  HOLD
      CHARACTER*10  COCBUF(*),FILL
      CHARACTER*7   CNINES
      CHARACTER*4   COCRPT(10000)
      CHARACTER*2   KAT(11)
C
      INTEGER  LOCRPT(*),KATL(11),KATO(11),KATGC(20,11),KATGL(20,11),
     $ MOCRPT(5000),KATLL(11)
C
      REAL  ROCRPT(5000)
C
      equivalence(rocrpt,mocrpt,cocrpt)
C
      SAVE
C
      DATA  katl/6,4,4,4,6,6,3,20,15,3,1/,kato/13,15,17,19,21,23,25,29,
     $ 31,27,33/,imsg/99999/,fill/'XXXXXXXXXX'/,kat/'01','02','03','04',
     $'05','06','07','51','52','08','09'/,cnines/'9999999'/,xmsg/99999./
      DATA katgc/    5*2,4,14*0, 3*2,4,16*0, 3*2,4,16*0,   3*2,4,16*0,
     $  5*2,4,14*0,  5*2,4,14*0, 2*2,4,17*0, 8*2,4,10*1,2, 15*1,5*0,
     $  2*2,4,17*0,  4,19*0/
      DATA katgl/    5,4,3*3,4,14*0, 5,4,2*3,16*0,   5,2*3,2,16*0,
     $ 5,2*3,2,16*0, 5,4,3*3,4,14*0, 5,4,3*3,4,14*0, 5,3,2,17*0,
     $ 2*5,2*3,4,3,2*4,5,2*3,7*2,1,3,
     $ 4,3,4,1,5*2,4,2*2,1,2,7,5*0,  5,3,2,17*0,     12,19*0/
      DATA  katll/6,4,4,4,6,6,3,21,15,3,3/
      DATA  lwflag/0/
C
           entry      w3ai03(locrpt,cocbuf)
C
      IF (lwflag.EQ.0) THEN
C FIRST TIME CALLED, DETERMINE MACHINE WORD LG IN BYTES (=8 FOR CRAY)
C     DEPENDING ON WORD SIZE LW2*I-LW1 INDEXES THRU COCRPT
C     EITHER AS 1,2,3...I    FOR LW = 4 OR
C            AS 1,3,5..2*I-1 FOR LW = 8 <------ HERE
C     NECESSITATED BY LEFT JUSTIFICATION OF EQUIVALENCE
         CALL w3fi01(lw)
         lw2 = lw/4
         lw1 = lw/8
         lwflag = 1
      END IF
      mi   = 43
      kk   =  0
      lvls =  0
C DETERMINE THE TRUE NUMBER OF BYTES IN THE INPUT REPORT
      DO 100  ncat = 1,11
         m = kato(ncat)
         IF(locrpt(m+1).GE.mi)  kk = ncat
         mi = max(mi,locrpt(m+1))
  100 CONTINUE
      IF(kk.GT.0)  THEN
         m = kato(kk)
         lvls = locrpt(m)
      END IF
cvvvvvy2k
cdak  MBYTES = LW * ((MI - 1) + (LVLS * KATLL(KK)))
      mwords = (mi - 1) + (lvls * katll(kk))
C TRANSFER LOCRPT TO MOCRPT IN ORDER TO EQUIVALENCE TO REAL AND CHAR.
cdak  CALL XMOVEX(MOCRPT,LOCRPT,MBYTES)
      mocrpt(1:mwords) = locrpt(1:mwords)
caaaaay2k
C INITIALIZE REPORT ID AS MISSING OR NOT APPLICABLE
      cocbuf(1)       = '9999999999'
      cocbuf(2)(7:10) = '9999'
      cocbuf(3)(8:10) = '999'
      cocbuf(4)(1:7)  = '9999999'
C READ IN LATITUDE FROM WORD 1 (REAL)
C WRITE OUT IN FIRST 5 CHARACTERS OF WORD 1 (C*5)
      m = 1
      n = 1
      IF(rocrpt(m).LT.xmsg)  THEN
         IF(int(rocrpt(m)).GE.0)  WRITE(cocbuf(n)(1:5),50)int(rocrpt(m))
         IF(int(rocrpt(m)).LT.0)  WRITE(cocbuf(n)(1:5),55)int(rocrpt(m))
      END IF
C READ IN LONGITUDE FROM WORD 2 (REAL)
C WRITE OUT IN LAST 5 CHARACTERS OF WORD 1 (C*5)
      m = 2
      IF(rocrpt(m).LT.xmsg)  THEN
         IF(int(rocrpt(m)).GE.0) WRITE(cocbuf(n)(6:10),50)int(rocrpt(m))
         IF(int(rocrpt(m)).LT.0) WRITE(cocbuf(n)(6:10),55)int(rocrpt(m))
      END IF
C READ IN STATION ID FROM WORDS 11 AND 12 (C*8)
C (CHAR. 1-4 OF ID IN WORD 11, CHAR. 5-6 OF ID IN WORD 12, LEFT-JUSTIF.)
C WRITE OUT IN FIRST 6 CHARACTERS OF WORD 2 (C*6)
      m = 11
      n = n + 1
      cocbuf(n)(1:6) = cocrpt(lw2*m-lw1)(1:4)//
     $                 cocrpt(lw2*(m+1)-lw1)(1:2)
C READ IN OBSERVATION TIME FROM WORD 4 (REAL)
C WRITE OUT IN LAST 4 CHARACTERS OF WORD 2 (C*4)
      m = 4
      IF(rocrpt(m).LT.xmsg)  WRITE(cocbuf(n)(7:10),40)  int(rocrpt(m))
C READ IN RESERVED CHARACTERS FROM WORDS 5 AND 6 (C*8)
C  (4 CHAR., LEFT-JUSTIF.)
C WRITE OUT IN FIRST 7 CHARACTERS OF WORD 3 (C*7)
      m = 5
      n = n + 1
      cocbuf(n)(1:7) =cocrpt(lw2*(m+1)-lw1)(1:2)//
     $                cocrpt(lw2*m-lw1)(1:4)//cocrpt(lw2*(m+1)-lw1)(3:3)
C READ IN OFFICE NOTE 29 REPORT TYPE FROM WORD 9 (INTEGER)
C WRITE OUT IN LAST 3 CHARACTERS OF WORD 3 (C*3)
      m = 9
      IF(mocrpt(m).LT.imsg)  WRITE(cocbuf(n)(8:10),30)  mocrpt(m)
C READ IN STATION ELEVATION FROM WORD 7 (REAL)
C WRITE OUT IN FIRST 5 CHARACTERS OF WORD 4 (C*4)
      m = 7
      n = n + 1
      IF(rocrpt(m).LT.xmsg)  THEN
         IF(int(rocrpt(m)).GE.0)  WRITE(cocbuf(n)(1:5),50)int(rocrpt(m))
         IF(int(rocrpt(m)).LT.0)  WRITE(cocbuf(n)(1:5),55)int(rocrpt(m))
      END IF
C READ IN INSTRUMENT TYPE FROM WORD 8 (INTEGER)
C WRITE OUT IN NEXT 2 CHARACTERS OF WORD 4 (C*2)
      m = 8
      IF(mocrpt(m).LT.99)  WRITE(cocbuf(n)(6:7),20)  mocrpt(m)
      no = n
      n  = n + 1
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C        LOOP THROUGH ALL THE CATEGORIES WHICH HAVE VALID DATA
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
      DO 3000  ncat = 1,11
C 'M' IS THE WORD IN MOCRPT WHERE THE NO. OF LEVELS IS READ FROM
         m = kato(ncat)
         lvls = mocrpt(m)
C 'MI' IS THE STARTING LOCATION IN MOCRPT FOR READING DATA FROM THIS CAT
         mi = mocrpt(m+1)
         IF(lvls.EQ.0.OR.mi.EQ.0)  GO TO 3000
C CATEGORY WITH VALID CATEGORY ENCOUNTERED - WRITE OUT IN FIRST 2
C  CHARACTERS OF CATEGORY/COUNTER GROUP FOR THIS CATEGORY (C*2)
         cocbuf(n)(1:2) = kat(ncat)
C NUMBER OF LEVELS WRITTEN OUT TO CHAR. 6 & 7 OF CAT/CNTR GROUP (C*2)
         WRITE(cocbuf(n)(6:7),20)  lvls
         nc = n
         n = n + 1
C NWDSC COUNTS THE NUMBER OF 10-CHAR. WORDS IN THIS CATEGORY
         nwdsc = 1
         i = 1
C***********************************************************************
C         LOOP THROUGH ALL THE LEVELS IN THE CURRENT CATEGORY
C***********************************************************************
         DO 2000  l = 1,lvls
C NDG IS NO. OF INPUT PARAMETERS PER LEVEL IN THIS CATEGORY
            ndg = katl(ncat)
C-----------------------------------------------------------------------
C        LOOP THROUGH ALL THE PARAMETERS IN THE CURRENT LEVEL
C-----------------------------------------------------------------------
            DO 1800  k = 1,ndg
C 'LL' IS THE NUMBER OF OUTPUT CHARACTERS PER PARAMETER FOR THIS CAT.
               ll = katgl(k,ncat)
C KATGC IS AN INDICATOR FOR THE INPUT FORMAT OF EACH OUTPUT PARAMETER
C  (=2 - REAL, =1 - INTEGER, =4 - CHARACTER*8)
               IF(katgc(k,ncat).EQ.4)  GO TO 1500
C OUTPUT PARAMETER IS MISSING OR NOT APPLICABLE (BASED ON MISSING INPUT)
               IF(katgc(k,ncat).EQ.1)  THEN
                  IF(mocrpt(mi).GE.imsg)  THEN
                     hold(1:ll) = cnines(1:ll)
C SPECIAL CASE FOR INPUT PARAMETER 15, CAT. 52 -- MISSING IS '0099999'
                     IF(k.EQ.15.AND.ncat.EQ.9)  hold(1:7) = '0099999'
                     GO TO 1750
                  END IF
               ELSE  IF(katgc(k,ncat).EQ.2)  THEN
                  IF(rocrpt(mi).GE.xmsg)  THEN
                     hold(1:ll) = cnines(1:ll)
C SPECIAL CASE FOR INPUT PARAMETER 15, CAT. 52 -- MISSING IS '0099999'
                     IF(k.EQ.15.AND.ncat.EQ.9)  hold(1:7) = '0099999'
                     GO TO 1750
                  END IF
               END IF
               ivalue = mocrpt(mi)
               IF(katgc(k,ncat).EQ.2)  ivalue = int(rocrpt(mi))
C INITIALIZE ALL OUTPUT PARAMETERS HERE AS MISSING
C  (WILL REMAIN MISSING IF "IVALUE" SOMEHOW WOULD FILL-UP TOO
C   MANY CHARACTERS)
               hold(1:ll) = cnines(1:ll)
               IF(ll.EQ.1)  THEN
C OUTPUT PARAMETER CONSISTS OF ONE CHARACTER
                  IF(ivalue.LE.9.AND.ivalue.GE.0)
     $               WRITE(hold(1:ll),10)  ivalue
               ELSE  IF(ll.EQ.2)  THEN
C OUTPUT PARAMETER CONSISTS OF TWO CHARACTERS
                  IF(ivalue.LE.99.AND.ivalue.GE.-9)  THEN
                     IF(ivalue.GE.0)  WRITE(hold(1:ll),20)  ivalue
                     IF(ivalue.LT.0)  WRITE(hold(1:ll),25)  ivalue
                  END IF
               ELSE  IF(ll.EQ.3)  THEN
C OUTPUT PARAMETER CONSISTS OF THREE CHARACTERS
                  IF(ivalue.LE.999.AND.ivalue.GE.-99)  THEN
                     IF(ivalue.GE.0)  WRITE(hold(1:ll),30)  ivalue
                     IF(ivalue.LT.0)  WRITE(hold(1:ll),35)  ivalue
                  END IF
               ELSE  IF(ll.EQ.4)  THEN
C OUTPUT PARAMETER CONSISTS OF FOUR CHARACTERS
                  IF(ivalue.LE.9999.AND.ivalue.GE.-999)  THEN
                     IF(ivalue.GE.0)  WRITE(hold(1:ll),40)  ivalue
                     IF(ivalue.LT.0)  WRITE(hold(1:ll),45)  ivalue
                  END IF
               ELSE  IF(ll.EQ.5)  THEN
C OUTPUT PARAMETER CONSISTS OF FIVE CHARACTERS
                  IF(ivalue.LE.99999.AND.ivalue.GE.-9999)  THEN
                     IF(ivalue.GE.0)  WRITE(hold(1:ll),50)  ivalue
                     IF(ivalue.LT.0)  WRITE(hold(1:ll),55)  ivalue
                  END IF
               ELSE  IF(ll.EQ.6)  THEN
C OUTPUT PARAMETER CONSISTS OF SIX CHARACTERS
                  IF(ivalue.LE.999999.AND.ivalue.GE.-99999)  THEN
                     IF(ivalue.GE.0)  WRITE(hold(1:ll),60)  ivalue
                     IF(ivalue.LT.0)  WRITE(hold(1:ll),65)  ivalue
                  END IF
               ELSE  IF(ll.EQ.7)  THEN
C OUTPUT PARAMETER CONSISTS OF SEVEN CHARACTERS
                  IF(ivalue.LE.9999999.AND.ivalue.GE.-999999)  THEN
                     IF(ivalue.GE.0)  WRITE(hold(1:ll),70)  ivalue
                     IF(ivalue.LT.0)  WRITE(hold(1:ll),75)  ivalue
                  END IF
               END IF
               GO TO 1750
 1500          CONTINUE
C.......................................................................
C INPUT CHARACTER (MARKER) PROCESSING COMES HERE
               IF(ll.LE.4)  THEN
C THERE ARE BETWEEN ONE AND FOUR MARKERS IN OUTPUT PARAMETER
                  hold(1:ll) = cocrpt(lw2*mi-lw1)(1:ll)
               ELSE
C THERE ARE MORE THAN FOUR MARKERS IN OUTPUT PARAMETER
                  ip = 1
 1610             CONTINUE
                  jp = ip + 3
                  IF(jp.LT.ll)  THEN
C GET FIRST FOUR MARKERS FROM INPUT WORD
                     hold(ip:jp) = cocrpt(lw2*mi-lw1)(1:4)
                     mi = mi + 1
                     ip = jp + 1
                     GO TO 1610
                  ELSE  IF(jp.EQ.ll)  THEN
C GET FOUR REMAINING MARKERS FROM NEXT INPUT WORD
                     hold(ip:jp) = cocrpt(lw2*mi-lw1)(1:4)
                  ELSE
C GET ONE, TWO, OR THREE REMAINING MARKERS FROM NEXT INPUT WORD
                     hold(ip:ll) = cocrpt(lw2*mi-lw1)(1:ll-jp+4)
                  END IF
               END IF
C.......................................................................
 1750          CONTINUE
C 'I' IS POINTER FOR BEGINNING BYTE IN C*10 WORD FOR OUTPUT PARAMETER
C 'J' IS POINTER FOR ENDING    BYTE IN C*10 WORD FOR OUTPUT PARAMETER
               j = i + ll - 1
               IF(j.GT.10)  THEN
C COME HERE IF OUTPUT PARAMETER SPANS ACROSS TWO C*10 WORDS
                  cocbuf(n)(i:10)     = hold(1:11-i)
                  cocbuf(n+1)(1:j-10) = hold(12-i:ll)
                  n = n + 1
                  nwdsc = nwdsc + 1
                  i = j - 9
               ELSE
                  cocbuf(n)(i:j) = hold(1:ll)
                  i = j + 1
                  IF(i.GE.11)  THEN
                     n = n + 1
                     nwdsc = nwdsc + 1
                     i = 1
                  END IF
               END IF
C GO ON TO NEXT INPUT WORD IN THIS LEVEL
               mi = mi + 1
 1800       CONTINUE
C-----------------------------------------------------------------------
 2000    CONTINUE
C***********************************************************************
C FILL REMAINING PART OF LAST OUTPUT WORD IN THIS CATEGORY WITH X'S
         IF(i.GT.1)  cocbuf(n)(i:10) = fill(i:10)
C TOTAL NO. CHARACTERS IN CATEGORY (EXCL. FILLS) (NCHAR) WRITTEN OUT TO
C  LAST 3 CHARACTERS OF CATEGORY/COUNTER GROUP (C*3)
         nchar = ((nwdsc - 1) * 10) + i - 1
         WRITE(cocbuf(nc)(8:10),30)  nchar
         IF(i.GT.1)  n = n + 1
C RELATIVE POSITION IN REPORT OF NEXT CAT/CNTR GROUP (N) WRITTEN OUT TO
C  CHAR. 3 - 5 OF CURRENT CATEGORY/COUNTER GROUP (C*3)
         WRITE(cocbuf(nc)(3:5),30)  n
C GO ON TO THE NEXT CATEGORY
 3000 CONTINUE
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C WRITE OUT THE TOTAL LENGTH OF THE REPORT -- NO. OF 10-CHARACTER WORDS
C  -- (N) IN LAST THREE CHARACTERS OF WORD 4 (C*3)
      WRITE(cocbuf(no)(8:10),30)  n
C WRITE OUT 'END REPORT' TO LOCATE THE END OF THIS REPORT IN THE BLOCK
      cocbuf(n) = 'END REPORT'
      RETURN
   10 FORMAT(i1.1)
   15 FORMAT(i1.0)
   20 FORMAT(i2.2)
   25 FORMAT(i2.1)
   30 FORMAT(i3.3)
   35 FORMAT(i3.2)
   40 FORMAT(i4.4)
   45 FORMAT(i4.3)
   50 FORMAT(i5.5)
   55 FORMAT(i5.4)
   60 FORMAT(i6.6)
   65 FORMAT(i6.5)
   70 FORMAT(i7.7)
   75 FORMAT(i7.6)
      END