w3fp06.f

Go to the documentation of this file.

C> @file
C> @brief NMC title subroutine.
C> @author Ralph Jones @date 1988-11-28
 
C> Provides a title for data fields formulated according to
C> nmc o.n. 84. the extracted information is converted into up to
C> 81 words and stored at a user provided location.
C>
C> Program history log:
C> - Ralph Jones 1988-11-28
C> - Ralph Jones 1990-02-12 Convert to cray cft77 fortran
C> - Ralph Jones 1991-04-26 Add q type 23, 136, 137, 71, 159, 75, 118,
C> 119, 24 to tables, changes for big records.
C> - Ralph Jones 1993-02-23 Add q type 157 & 158 (core & tke) to tables
C>
C> @param[in] N Integer number of lines of output desired
C> - = 1  First 88 char. the abbreviated title (line 1 starts at arg2(1))
C> - = 2  First 216 char. decimal values of the parameters
C> - = 3  All 324 char., hexidecimal dump of the 12 word field label (line 3 char. 221)
C> @param ID, KTITLE
C>
C> @note See NMC O.N. 84 for data field abbreviations.
C>
C> @author Ralph Jones @date 1988-11-28
      SUBROUTINE w3fp06(ID,KTITLE,N)
C
      INTEGER(8)         ID(6)
      INTEGER(4)      MASK(8)
C
      CHARACTER * 324  KTITLE
C
      DATA  mask(1)/z'0000000F'/
      DATA  mask(2)/z'000000FF'/
      DATA  mask(3)/z'00000FFF'/
      DATA  mask(4)/z'0000FFFF'/
      DATA  mask(5)/z'000FFFFF'/
      DATA  mask(6)/z'00FFFFFF'/
      DATA  mask(7)/z'0FFFFFFF'/
      DATA  mask(8)/z'FFFFFFFF'/
C
      CALL line01(id,mask,ktitle)
        IF (n.GT.1) GO TO 10
      RETURN
C
   10 CONTINUE
        CALL line02(id,mask,ktitle)
        IF (n.GT.2) GO TO 20
        RETURN
C
   20 CONTINUE
        CALL line03(id,ktitle)
        RETURN
      END
C> @brief Creates the first line of title.
C> @author Ralph Jones @date 1988-09-02
 
C> Creates the fist line of the title from the id words.
C> call by w3fp06() to make 1st line of title. Words 1 to 22.
C>
C> Program history log:
C> - Ralph Jones 1988-09-02
C> - Ralph Jones 1993-02-23 Add q type 157 & 158 (core & tke) to tables.
C>
C> @param[in] ID Id words (6 integer words) office note 84.
C> @param[in] MASK Mask for unpacking id words (8 integer words).
C> @param[out] KTITLE Character *324 array
C>
C> @author Ralph Jones @date 1988-09-02
       SUBROUTINE line01(ID,MASK,KTITLE)
 
C
C     CREATES THE FIRST 22 WORDS OF TITLER
C
      INTEGER(8)          ID(6)
      INTEGER(4)       MASK(8)
      INTEGER(4)       SHFMSK(17)
C
      CHARACTER * 4    UNIT
      CHARACTER * 4    UNIT1
      CHARACTER * 4    DAYS
      CHARACTER * 5    FOR
      CHARACTER * 5    FOR1
      CHARACTER * 1    DASH
      CHARACTER * 8    KNAME(9)
      CHARACTER * 8    KNAME1(3)
      CHARACTER * 324  KTITLE
      CHARACTER * 8    KWRITE(3)
      CHARACTER * 8    INUM1
      CHARACTER * 8    INUM2
      CHARACTER * 6    QNAME1
      CHARACTER * 6    QNAME2
      CHARACTER * 6    QNAME3
      CHARACTER * 2    DN
      CHARACTER * 6    QNAME(166)
      CHARACTER * 6    QWRITE
      CHARACTER * 4    SNAME(18)
      CHARACTER * 20   VUNIT(2)
      CHARACTER * 7    AFTER
      CHARACTER * 7    AFTBEF
C
      INTEGER          KK(3)
      INTEGER          LL(166)
      INTEGER          JKEEP(17)
      INTEGER          JLIST(17)
      INTEGER          C1,C2,E1,E2,S1,S2,Q,M,G
      INTEGER          YY,MM,DD,HH,F1,F2,JT,JN
C
C     IDWORDS:  MASK CONTROL (INTEGER)
C
      DATA shfmsk( 1)/z'20020100'/
      DATA shfmsk( 2)/z'28020400'/
      DATA shfmsk( 3)/z'30020400'/
      DATA shfmsk( 4)/z'38020400'/
      DATA shfmsk( 5)/z'08050100'/
      DATA shfmsk( 6)/z'00020100'/
      DATA shfmsk( 7)/z'08050200'/
      DATA shfmsk( 8)/z'00020200'/
      DATA shfmsk( 9)/z'3C010200'/
      DATA shfmsk(10)/z'28030100'/
      DATA shfmsk(11)/z'28030200'/
      DATA shfmsk(12)/z'34030100'/
      DATA shfmsk(13)/z'20020400'/
      DATA shfmsk(14)/z'30020400'/
      DATA shfmsk(15)/z'1C010100'/
      DATA shfmsk(16)/z'1C010200'/
      DATA shfmsk(17)/z'20020200'/
C
C     REFERENCE TABLE FOR SNAME.
C
      DATA jlist(1)/1/
      DATA jlist(2)/2/
      DATA jlist(3)/6/
      DATA jlist(4)/7/
      DATA jlist(5)/8/
      DATA jlist(6)/16/
      DATA jlist(7)/19/
      DATA jlist(8)/128/
      DATA jlist(9)/129/
      DATA jlist(10)/130/
      DATA jlist(11)/144/
      DATA jlist(12)/145/
      DATA jlist(13)/146/
      DATA jlist(14)/147/
      DATA jlist(15)/148/
      DATA jlist(16)/131/
      DATA jlist(17)/132/
C
C     SNAME TABLE.
C
      DATA sname( 1)/' GPM'/
      DATA sname( 2)/' PA '/
      DATA sname( 3)/' M  '/
      DATA sname( 4)/' M  '/
      DATA sname( 5)/' MB '/
      DATA sname( 6)/' DEG'/
      DATA sname( 7)/' POT'/
      DATA sname( 8)/' MSL'/
      DATA sname( 9)/' SFC'/
      DATA sname(10)/' TRO'/
      DATA sname(11)/' BDY'/
      DATA sname(12)/' TRS'/
      DATA sname(13)/' STS'/
      DATA sname(14)/' QCP'/
      DATA sname(15)/' SIG'/
      DATA sname(16)/'MWSL'/
      DATA sname(17)/'PLYR'/
      DATA sname(18)/'    '/
C
C     REFERENCE TABLE FOR QNAME.
C
      DATA ll( 1)/  1/
      DATA ll( 2)/  2/
      DATA ll( 3)/  6/
      DATA ll( 4)/  8/
      DATA ll( 5)/ 16/
      DATA ll( 6)/ 17/
      DATA ll( 7)/ 18/
      DATA ll( 8)/ 19/
      DATA ll( 9)/ 20/
      DATA ll(10)/ 21/
      DATA ll(11)/ 40/
      DATA ll(12)/ 41/
      DATA ll(13)/ 42/
      DATA ll(14)/ 43/
      DATA ll(15)/ 44/
      DATA ll(16)/ 48/
      DATA ll(17)/ 49/
      DATA ll(18)/ 50/
      DATA ll(19)/ 51/
      DATA ll(20)/ 52/
      DATA ll(21)/ 53/
      DATA ll(22)/ 54/
      DATA ll(23)/ 55/
      DATA ll(24)/ 56/
      DATA ll(25)/ 57/
      DATA ll(26)/ 58/
      DATA ll(27)/ 59/
      DATA ll(28)/ 60/
      DATA ll(29)/ 72/
      DATA ll(30)/ 73/
      DATA ll(31)/ 74/
      DATA ll(32)/ 80/
      DATA ll(33)/ 81/
      DATA ll(34)/ 88/
      DATA ll(35)/ 89/
      DATA ll(36)/ 90/
      DATA ll(37)/ 91/
      DATA ll(38)/ 92/
      DATA ll(39)/ 93/
      DATA ll(40)/ 94/
      DATA ll(41)/ 95/
      DATA ll(42)/ 96/
      DATA ll(43)/112/
      DATA ll(44)/113/
      DATA ll(45)/114/
      DATA ll(46)/115/
      DATA ll(47)/120/
      DATA ll(48)/121/
      DATA ll(49)/160/
      DATA ll(50)/161/
      DATA ll(51)/162/
      DATA ll(52)/163/
      DATA ll(53)/164/
      DATA ll(54)/165/
      DATA ll(55)/166/
      DATA ll(56)/167/
      DATA ll(57)/168/
      DATA ll(58)/169/
      DATA ll(59)/170/
      DATA ll(60)/171/
      DATA ll(61)/176/
      DATA ll(62)/177/
      DATA ll(63)/178/
      DATA ll(64)/184/
      DATA ll(65)/185/
      DATA ll(66)/186/
      DATA ll(67)/187/
      DATA ll(68)/188/
      DATA ll(69)/384/
      DATA ll(70)/385/
      DATA ll(71)/386/
      DATA ll(72)/387/
      DATA ll(73)/388/
      DATA ll(74)/389/
      DATA ll(75)/390/
      DATA ll(76)/391/
      DATA ll(77)/ 97/
      DATA ll(78)/ 98/
      DATA ll(79)/ 99/
      DATA ll(80)/100/
      DATA ll(81)/101/
      DATA ll(82)/102/
      DATA ll(83)/103/
      DATA ll(84)/172/
      DATA ll(85)/200/
      DATA ll(86)/201/
      DATA ll(87)/202/
      DATA ll(88)/203/
      DATA ll(89)/392/
      DATA ll(90)/  7/
      DATA ll(91)/ 61/
      DATA ll(92)/104/
      DATA ll(93)/173/
      DATA ll(94)/174/
      DATA ll(95)/175/
      DATA ll(96)/304/
      DATA ll(97)/305/
      DATA ll(98)/400/
      DATA ll(99)/401/
      DATA ll(100)/402/
      DATA ll(101)/403/
      DATA ll(102)/404/
      DATA ll(103)/405/
      DATA ll(104)/  9/
      DATA ll(105)/105/
      DATA ll(106)/116/
      DATA ll(107)/106/
      DATA ll(108)/107/
      DATA ll(109)/108/
      DATA ll(110)/179/
      DATA ll(111)/180/
      DATA ll(112)/181/
      DATA ll(113)/182/
      DATA ll(114)/183/
      DATA ll(115)/189/
      DATA ll(116)/190/
      DATA ll(117)/191/
      DATA ll(118)/192/
      DATA ll(119)/193/
      DATA ll(120)/194/
      DATA ll(121)/195/
      DATA ll(122)/196/
      DATA ll(123)/197/
      DATA ll(124)/198/
      DATA ll(125)/199/
      DATA ll(126)/204/
      DATA ll(127)/210/
      DATA ll(128)/211/
      DATA ll(129)/212/
      DATA ll(130)/213/
      DATA ll(131)/214/
      DATA ll(132)/215/
      DATA ll(133)/216/
      DATA ll(134)/117/
      DATA ll(135)/209/
      DATA ll(136)/ 22/
      DATA ll(137)/ 62/
      DATA ll(138)/ 63/
      DATA ll(139)/ 82/
      DATA ll(140)/ 83/
      DATA ll(141)/ 84/
      DATA ll(142)/ 85/
      DATA ll(143)/205/
      DATA ll(144)/206/
      DATA ll(145)/207/
      DATA ll(146)/208/
      DATA ll(147)/217/
      DATA ll(148)/109/
      DATA ll(149)/110/
      DATA ll(150)/111/
      DATA ll(151)/86/
      DATA ll(152)/87/
      DATA ll(153)/218/
      DATA ll(154)/133/
      DATA ll(155)/134/
      DATA ll(156)/135/
      DATA ll(157)/23/
      DATA ll(158)/136/
      DATA ll(159)/137/
      DATA ll(160)/71/
      DATA ll(161)/159/
      DATA ll(162)/75/
      DATA ll(163)/157/
      DATA ll(164)/119/
      DATA ll(165)/24/
      DATA ll(166)/158/
C
C     QNAME TABLE:  CHARACTER*6
C
      DATA qname( 1)/' HGT  '/
      DATA qname( 2)/' P ALT'/
      DATA qname( 3)/' DIST '/
      DATA qname( 4)/' PRES '/
      DATA qname( 5)/' TMP  '/
      DATA qname( 6)/' DPT  '/
      DATA qname( 7)/' DEPR '/
      DATA qname( 8)/' POT  '/
      DATA qname( 9)/' T MAX'/
      DATA qname(10)/' T MIN'/
      DATA qname(11)/' V VEL'/
      DATA qname(12)/' NETVD'/
      DATA qname(13)/' DZDT '/
      DATA qname(14)/' OROW '/
      DATA qname(15)/' FRCVV'/
      DATA qname(16)/' U GRD'/
      DATA qname(17)/' V GRD'/
      DATA qname(18)/' WIND '/
      DATA qname(19)/' T WND'/
      DATA qname(20)/' VW SH'/
      DATA qname(21)/' U DIV'/
      DATA qname(22)/' V DIV'/
      DATA qname(23)/' WDIR '/
      DATA qname(24)/' WWND '/
      DATA qname(25)/' SWND '/
      DATA qname(26)/' RATS '/
      DATA qname(27)/' VECW '/
      DATA qname(28)/' SFAC '/
      DATA qname(29)/' ABS V'/
      DATA qname(30)/' REL V'/
      DATA qname(31)/' DIV  '/
      DATA qname(32)/' STRM '/
      DATA qname(33)/' V POT'/
      DATA qname(34)/' R H  '/
      DATA qname(35)/' P WAT'/
      DATA qname(36)/' A PCP'/
      DATA qname(37)/' P O P'/
      DATA qname(38)/' P O Z'/
      DATA qname(39)/' SNO D'/
      DATA qname(40)/' ACPCP'/
      DATA qname(41)/' SPF H'/
      DATA qname(42)/' L H2O'/
      DATA qname(43)/' LFT X'/
      DATA qname(44)/' TOTOS'/
      DATA qname(45)/' K X  '/
      DATA qname(46)/' C INS'/
      DATA qname(47)/' L WAV'/
      DATA qname(48)/' S WAV'/
      DATA qname(49)/' DRAG '/
      DATA qname(50)/' LAND '/
      DATA qname(51)/' KFACT'/
      DATA qname(52)/' 10TSL'/
      DATA qname(53)/' 7TSL '/
      DATA qname(54)/' RCPOP'/
      DATA qname(55)/' RCMT '/
      DATA qname(56)/' RCMP '/
      DATA qname(57)/' ORTHP'/
      DATA qname(58)/' ALBDO'/
      DATA qname(59)/' ENFLX'/
      DATA qname(60)/' TTHTG'/
      DATA qname(61)/' LAT  '/
      DATA qname(62)/' LON  '/
      DATA qname(63)/' RADIC'/
      DATA qname(64)/' PROB '/
      DATA qname(65)/' CPROB'/
      DATA qname(66)/' USTAR'/
      DATA qname(67)/' TSTAR'/
      DATA qname(68)/' MIXHT'/
      DATA qname(69)/' WTMP '/
      DATA qname(70)/' WVHGT'/
      DATA qname(71)/' SWELL'/
      DATA qname(72)/' WVSWL'/
      DATA qname(73)/' WVPER'/
      DATA qname(74)/' WVDIR'/
      DATA qname(75)/' SWPER'/
      DATA qname(76)/' SWDIR'/
      DATA qname(77)/' RRATE'/
      DATA qname(78)/' TSTM '/
      DATA qname(79)/' CSVR '/
      DATA qname(80)/' CTDR '/
      DATA qname(81)/' MIXR '/
      DATA qname(82)/' PSVR '/
      DATA qname(83)/' MCONV'/
      DATA qname(84)/' ENRGY'/
      DATA qname(85)/' RDNCE'/
      DATA qname(86)/' BRTMP'/
      DATA qname(87)/' TCOZ '/
      DATA qname(88)/' OZMR '/
      DATA qname(89)/' ICWAT'/
      DATA qname(90)/' DEPTH'/
      DATA qname(91)/' GUST '/
      DATA qname(92)/' VAPP '/
      DATA qname(93)/' TOTHF'/
      DATA qname(94)/' SPEHF'/
      DATA qname(95)/' SORAD'/
      DATA qname(96)/' UOGRD'/
      DATA qname(97)/' VOGRD'/
      DATA qname(98)/' HTSGW'/
      DATA qname(99)/' PERPW'/
      DATA qname(100)/' DIRPW'/
      DATA qname(101)/' PERSW'/
      DATA qname(102)/' DIRSW'/
      DATA qname(103)/' WCAPS'/
      DATA qname(104)/' PTEND'/
      DATA qname(105)/' NCPCP'/
      DATA qname(106)/' 4LFTX'/
      DATA qname(107)/' ICEAC'/
      DATA qname(108)/' NPRAT'/
      DATA qname(109)/' CPRAT'/
      DATA qname(110)/'CEILHT'/
      DATA qname(111)/' VISIB'/
      DATA qname(112)/'LIQPCP'/
      DATA qname(113)/'FREPCP'/
      DATA qname(114)/'FROPCP'/
      DATA qname(115)/' MIXLY'/
      DATA qname(116)/' DLRFL'/
      DATA qname(117)/' ULRFL'/
      DATA qname(118)/' DSRFL'/
      DATA qname(119)/' USRFL'/
      DATA qname(120)/' UTHFL'/
      DATA qname(121)/' UTWFL'/
      DATA qname(122)/' TTLWR'/
      DATA qname(123)/' TTSWR'/
      DATA qname(124)/' TTRAD'/
      DATA qname(125)/' MSTAV'/
      DATA qname(126)/' SWABS'/
      DATA qname(127)/' CDLYR'/
      DATA qname(128)/' CDCON'/
      DATA qname(129)/' PBCLY'/
      DATA qname(130)/' PTCLY'/
      DATA qname(131)/' PBCON'/
      DATA qname(132)/' PTCON'/
      DATA qname(133)/' SFEXC'/
      DATA qname(134)/' A EVP'/
      DATA qname(135)/' STCOF'/
      DATA qname(136)/' TSOIL'/
      DATA qname(137)/'D DUDT'/
      DATA qname(138)/'D DVDT'/
      DATA qname(139)/' U STR'/
      DATA qname(140)/' V STR'/
      DATA qname(141)/' TUVRD'/
      DATA qname(142)/' TVVRD'/
      DATA qname(143)/' TTLRG'/
      DATA qname(144)/' TTSHL'/
      DATA qname(145)/' TTDEP'/
      DATA qname(146)/' TTVDF'/
      DATA qname(147)/' ZSTAR'/
      DATA qname(148)/' TQDEP'/
      DATA qname(149)/' TQSHL'/
      DATA qname(150)/' TQVDF'/
      DATA qname(151)/'XGWSTR'/
      DATA qname(152)/'YGWSTR'/
      DATA qname(153)/' STDZG'/
      DATA qname(154)/' A LEV'/
      DATA qname(155)/' T AIL'/
      DATA qname(156)/' B AIL'/
      DATA qname(157)/' EPOT '/
      DATA qname(158)/' MSLSA'/
      DATA qname(159)/' MSLMA'/
      DATA qname(160)/'MGSTRM'/
      DATA qname(161)/' CONDP'/
      DATA qname(162)/' POT V'/
      DATA qname(163)/' CAPE '/
      DATA qname(164)/' CIN  '/
      DATA qname(165)/' VTMP '/
      DATA qname(166)/' TKE  '/
C
C  REFERENCE TABLE FOR G (GENERATING PROGRAM NAME)
C
      DATA kk(1)/57/
      DATA kk(2)/58/
      DATA kk(3)/59/
C
C  G TABLE (GENERATING PROGRM NAME):
C
      DATA kname/'   ECMWF', ' READING', ',UK.    ',
     &           '    FNOC', ' MONTERE', 'Y, CA.  ',
     &           '  AFGWC ', 'OFFUTT A', 'FB, NB. '/
      DATA kname1/'   WMC N','MC WASHI', 'NGTON   '/
C
      DATA after /' AFTER '/
      DATA dn    /'DN'/
      DATA qname1/' THCK '/
      DATA qname2/' THKDN'/
      DATA qname3/' PRSDN'/
C
      DATA vunit(1)/' 0-HR FCST VALID AT '/
      DATA vunit(2)/' ANALYSIS  VALID AT '/
      DATA unit1   /' HRS'/
      DATA days    /' DYS'/
      DATA for1    /' FOR '/
      DATA dash    /'-'/
C
 200   FORMAT ( ' ',a7,a4,' ',a7)
 210   FORMAT ( a4,1x,a6,a5,f4.1,a4,a7,
     &          i2.2,a1,i2.2,a1,i2.2,1x,i2.2,'Z',3a8)
 220   FORMAT ( 13x,a7)
 230   FORMAT ( '  Q IS AN ILLEGAL OFFICE NOTE 84 DATA TYPE, Q = ',
     &       i5,35x)
 240   FORMAT ( a4,1x,a6,a20,
     &          i2.2,a1,i2.2,a1,i2.2,1x,i2.2,'Z',3a8)
C
C         1.   UNPACK ID WORDS.
C
      DO 10 n = 1,17
        itemp    = 0
        ktemp    = 0
        itemp    = shfmsk(n)
        nshift   = iand(ishft(itemp,-24),255)
        nmask    = iand(ishft(itemp,-16),255)
        nid      = iand(ishft(itemp,-8),255)
        itemp    = mask(nmask)
        ktemp    = id(nid)
        jkeep(n) = iand(itemp,ishft(ktemp,-nshift))
   10 CONTINUE
C
      f1 = jkeep(1)
      dd = jkeep(2)
      mm = jkeep(3)
      yy = jkeep(4)
      c1 = jkeep(5)
      e1 = jkeep(6)
      c2 = jkeep(7)
      e2 = jkeep(8)
      m  = jkeep(9)
      s1 = jkeep(10)
      s2 = jkeep(11)
      q  = jkeep(12)
      hh = jkeep(13)
      g  = jkeep(14)
      jt = jkeep(15)
      jn = jkeep(16)
      f2 = jkeep(17)
C
      ks = iand(ishft(id(3),-40_8),255_8)
C
C         2.  FIND WHICH PARAMETER (Q) IS INDICATED BE THE ID WORDS.
C
      DO 20 n = 1,166
        nn = n
        IF (q.EQ.ll(n)) GO TO 30
 20   CONTINUE
C
C     CAN NOT FIND A LEGAL Q
      GO TO 170
C
 30   CONTINUE
      unit(1:4)    = unit1(1:4)
      for(1:5)     = for1(1:5)
      aftbef(1:7)  = after(1:7)
C
      IF (e1.GT.128) e1 = -(jkeep(6)-128)
      IF (e2.GT.128) e2 = -(jkeep(8)-128)
C
C        3.    FIND WHICH SURFACE IS INDICATED BY THE ID WORDS
C                   AS BEING THE FIRST SURFACE.
C
      DO 40 i = 1,17
        IF (s1.EQ.jlist(i)) THEN
          k1 = i
          GO TO 50
        ENDIF
 40   CONTINUE
        k1 = 18
C
 50   CONTINUE
C
C         4.   BEGIN PROCESSING OF A ONE-SURFACE TITLE
C
      IF (m.EQ.0.OR.m.EQ.8) THEN
        k2 = k1
        CALL value1(s1,c1,e1,inum1)
        WRITE (ktitle(1:20),220) inum1
        GO TO 80
      ENDIF
C
C        5.    FIND WHICH SURFACE IS INDICATED BY THE ID WORDS
C                   AS BEING THE SECOND SURFACE.
C
      DO 60 i = 1,17
        IF (s2.EQ.jlist(i)) THEN
          k2 = i
          GO TO 70
        ENDIF
 60   CONTINUE
        k2 = 18
C
 70   CONTINUE
C
C         6.    BEGIN PROCESSING OF A TWO-SURFACE TITLE
C
      CALL value1(s1,c1,e1,inum1)
      CALL value1(s2,c2,e2,inum2)
      WRITE (ktitle(1:20),200) inum1 , sname(k1) , inum2
C
 80   CONTINUE
      qwrite = qname(nn)
C
      IF (q.EQ.1 .AND. m.EQ.1.AND. s1.EQ.8)             qwrite = qname1
      IF (q.EQ.1 .AND. m.EQ.1.AND. s1.EQ.8.AND.ks.EQ.2) qwrite = qname2
      IF (q.EQ.8 .AND. s1.EQ.128.AND.ks.EQ.2)           qwrite = qname3
      IF (jt.EQ.6) qwrite(5:6) = dn(1:2)
C
C         7.    SET DATE/TIME FIELDS
C
C           A.    CHECK IF F1 AND F2 ARE IN HRS, HALF DAYS OR DAYS.
C
          rf1 = f1
          rf2 = f2
C
C           B:    IF F1 IN HALF DAYS: CONVERT TO HOURS
C
        IF (jn.EQ.15.OR.jt.EQ.7) THEN
           rf1 = rf1 * 12.0
           rf2 = rf2 * 12.0
        ENDIF
C
C           C:    IF F1 IN DAYS: CONVERT TO HOURS
C
        IF (jt.EQ.10) THEN
           rf1 = rf1 * 24.0
           rf2 = rf2 * 24.0
        ENDIF
C
C           D:    CONVERT HOURS TO DAYS IF HOURS GREATER THAN 72
C
        IF (jt.NE.6) THEN
          IF (rf1.GT.72.0.OR.rf2.GT.72.0) THEN
             rf1 = rf1 / 24.0
             rf2 = rf2 / 24.0
             unit(1:4) = days(1:4)
          ENDIF
        ENDIF
C
        IF (jt.EQ.6) THEN
          IF (f1.GT.127) THEN
            f1 = and(f1,127)
            f1 = -f1
          ENDIF
          cf1 = f1
          cf2 = f2
          CALL climo(cf1,cf2,unit,for,aftbef)
          rf1 = cf1
          CALL setcl(cf2,unit,ktitle)
        ENDIF
C
C         8.   SET GENERATING PROGRAM NAME
C
      DO 110 k = 1,3
        IF (g.EQ.kk(k)) GO TO 130
  110 CONTINUE
C
      DO 120 l = 1,3
        kwrite(l) = kname1(l)
  120 CONTINUE
      GO TO 150
C
  130 CONTINUE
      DO 140 l = 1,3
        kwrite(l) = kname( 3*(k-1) + l)
  140 CONTINUE
C
C         9.    ENCODE THE TITLE LINE
C
C         9.1   DISTINGUISH BETWEEN ANALYSIS AND ZERO FORECASTS
C                           AND 'REAL' FORECASTS
C
  150 CONTINUE
         IF (f1.NE.0) GO TO 160
           IF (g.EQ.19.OR.g.EQ.22.OR.g.EQ.43.OR.g.EQ.44.OR.g.EQ.49.OR.
     &         g.EQ.55.OR.g.EQ.56.OR.g.EQ.64) THEN
                 iii = 2
                 IF (m.EQ.8.OR.m.EQ.9.OR.m.EQ.10) iii = 1
           ELSE
              iii = 1
           ENDIF
C
      WRITE (ktitle(21:88),240) sname(k2), qwrite, vunit(iii),
     & yy, dash, mm, dash, dd, hh, (kwrite(l),l=1,3)
      RETURN
C
 160  CONTINUE
      WRITE (ktitle(21:88),210) sname(k2), qwrite, for, rf1, unit,
     & aftbef, yy, dash, mm, dash, dd, hh, (kwrite(l),l=1,3)
      RETURN
C
 170  CONTINUE
        WRITE (ktitle(1:88),230) q
      RETURN
      END
C> @brief Creates value1 of surface from ids.
C> @author Ralph Jones @date 1988-11-28
 
C> Creates the numerical value for the surface
C> to be built into the first line of the title.
C>
C> Program history log:
C> - Ralph Jones 1988-11-28
C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
C>
C> @param[in] S Integer number of surface.
C> @param[in] C,E  Numerical value of the surface (SURFACE = S * 10 ** E).
C> @param[out] NUM 7 character value of the surface for the title.
C>
C> @author Ralph Jones @date 1988-11-28
       SUBROUTINE value1(S,C,E,NUM)
 
C
      INTEGER        C
      INTEGER        E
      INTEGER        S
C
      CHARACTER*8    JNUM
      CHARACTER*8    KNUM
      CHARACTER*7    LTEMP
      CHARACTER*8    NUM
      CHARACTER*1    POINT
      CHARACTER*1    ZERO
C
      DATA  jnum  /' 0.0000 '/
      DATA  knum  /'        '/
      DATA  point /'.'/
      DATA  zero  /'0'/
C
 101  FORMAT ( i6,' ')
C
      IF (s.GE.128.AND.s.LE.132) GO TO 110
      IF (c.EQ.0) GO TO 100
      WRITE (ltemp(1:7),101) c
        j = e + 6
        k = j + 1
        IF (j.EQ.0) GO TO 90
          num(1:j)   = ltemp(1:j)
C
 90   CONTINUE
        num(k:k)   = point
        num(k+1:8) = ltemp(k:7)
        IF (j.EQ.0) num(2:2) = zero
        GO TO 150
C
 100  CONTINUE
        num = jnum
        GO TO 150
C
 110  CONTINUE
        num = knum
C
 150  CONTINUE
C
        RETURN
      END
C> @brief Creates the second line of title.
C> @author Ralph Jones @date 1988-11-28
 
C> Creates the second line of the title from the id words.
C> called by w3fp06. words 23 to 54.
C>
C> Program history log:
C> - Ralph Jones 1988-11-28
C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
C> - Ralph Jones 1991-03-01 Changes for big records.
C>
C> @param[in] ID Id words (6 integer words) office note 84
C> @param[in] MASK Mask for unpacking id words (8 words)
C> @param[out] KTITLE Title character*324
C>
C> @author Ralph Jones @date 1988-11-28
       SUBROUTINE line02(ID,MASK,KTITLE)
 
C
      INTEGER(8)          ID(6)
      INTEGER(8)          IKEEP(17)
      INTEGER(4)          MASK(8)
      INTEGER(8)          MASK32,MASKN
      INTEGER(4)          SHFMSK(17)
      integer(8)  irtemp
      real(4)     rtemp(2)
      equivalence(irtemp,rtemp(1))
C
      CHARACTER * 324  KTITLE
C
C     IDWORDS:  MASK CONTROL (INTEGER)
C
      DATA maskn /z'FFFFFFFFFFFF0000'/
      DATA mask32/z'00000000FFFFFFFF'/
      DATA shfmsk( 1)/z'3C010200'/
      DATA shfmsk( 2)/z'1C010100'/
      DATA shfmsk( 3)/z'1C010200'/
      DATA shfmsk( 4)/z'20020100'/
      DATA shfmsk( 5)/z'20020200'/
      DATA shfmsk( 6)/z'38020300'/
      DATA shfmsk( 7)/z'30020300'/
      DATA shfmsk( 8)/z'28020300'/
      DATA shfmsk( 9)/z'20020300'/
      DATA shfmsk(10)/z'3C010300'/
      DATA shfmsk(11)/z'18020400'/
      DATA shfmsk(12)/z'10020400'/
      DATA shfmsk(13)/z'00040400'/
      DATA shfmsk(14)/z'30040500'/
      DATA shfmsk(15)/z'00040500'/
      DATA shfmsk(16)/z'00080500'/
      DATA shfmsk(17)/z'20040600'/
C
 100  FORMAT(' M=',i2,' T=',i2,' N=',i2,' F1=',i3,' F2=',i3,' CD=',i3,
     1' CM=',i3,' KS=',i3,' K=',i3,' GES=',i2,' R=',i3,' G=',i3,
     2' J=',i5,' B=',i5,' Z=',i5,' A=',e15.8,' N=',i5,'   ')
C
C     UNPACK ID WORDS.
C
      DO 10 n = 1,17
        itemp    = shfmsk(n)
        nshift   = iand(ishft(itemp,-24),255)
        nmask    = iand(ishft(itemp,-16),255)
        nid      = iand(ishft(itemp,-8),255)
        jtemp    = mask(nmask)
        ktemp    = id(nid)
        ikeep(n) = iand(jtemp,ishft(ktemp,-nshift))
 10   CONTINUE
C
C     CONVERT IBM 32 BIT F.P. NUMBER TO IEEE F.P. NUMBER
C
C      CALL USSCTC(ID(5),5,A,1)
      irtemp=id(5)
      call q9ie32(rtemp(2),rtemp(1),1,istat)
      a=rtemp(1)
C
C     CONVERT 16 BIT SIGNED INTEGER INTO A 64 BIT INTEGER.
C
      IF (btest(ikeep(17),15_8)) THEN
         ikeep(17) = ior(ikeep(17),maskn)
      ENDIF
C
C     TEST FOR BIG RECORD
C
      IF (ikeep(13).EQ.0) THEN
        ikeep(13) = iand(id(6),mask32)
      END IF
C
      WRITE (ktitle(89:216),100) (ikeep(i),i=1,15) , a , ikeep(17)
      RETURN
      END
C> @brief Creates the third line of title.
C> @author Ralph Jones @date 1988-11-28
 
C> Creates the third line of the title from the id words.
C> called by w3fp06 to create words 55 to 81 of the title.
C>
C> Program history log:
C> - Ralph Jones 1988-11-28
C> - Ralph Jones 1990-02-03 Convert to cray cft77 fortran.
C>
C> @param[in] ID ID words (6 integer) office note 84.
C> @param[out] KTITLE Character*324 array.
C>
C> @author Ralph Jones @date 1988-11-28
       SUBROUTINE line03(ID,KTITLE)
 
C
      INTEGER(8)         ID(6)
      INTEGER(8)      MASK32
      INTEGER         ID84(12)
C
      CHARACTER * 324  KTITLE
C
      DATA  mask32/z'00000000FFFFFFFF'/
C
C     FORTRAN INTERNAL WRITE STATEMENT REPLACES ENCODE
C
 100  FORMAT ( 12(1x,z8))
C
      DO 10 j = 1,11,2
        id84(j)   = ishft(id(j/2+1),-32_8)
        id84(j+1) = iand(id(j/2+1),mask32)
 10   CONTINUE
C
      WRITE (ktitle(217:324),100) (id84(i),i=1,12)
      RETURN
      END
C> @brief Sets time-averaged titles.
C> @author Ralph Jones @date 1988-11-28
 
C> Fills in the first thirteen characters in the title
C> to make the title a time-averaged title.
C>
C> Program history log:
C> - Ralph Jones 1988-11-28
C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
C>
C> @param[in] CF1 Forecast period length.
C> @param[in] CF2 Length of the average.
C> @param[inout] UNIT
C> - [in] Originally set to ' hrs'.
C> - [out] Set to ' dys' if necessary.
C> @param[inout] FOR
C> - [in] Originally set to ' for '.
C> - [out] Set to ' ctr '.
C> @param[inout] AFTBEF
C> - [in] Originally set to ' after '.
C> - [out] Set to ' befor ' if necessary.
C>
C> @author Ralph Jones @date 1988-11-28
       SUBROUTINE climo(CF1,CF2,UNIT,FOR,AFTBEF)
 
C
        REAL         CF1
        REAL         CF2
C
        CHARACTER*7  AFTBEF
        CHARACTER*7  BEFOR
        CHARACTER*5  FOR
        CHARACTER*5  FOR1
        CHARACTER*4  UNIT
        CHARACTER*4  UNIT1
        CHARACTER*4  UNIT2
C
        DATA  befor /' BEFOR '/
        DATA  for1  /' CTR '/
        DATA  unit1 /' DYS'/
        DATA  unit2 /' HRS'/
C
C       SET FOR TO ' CTR '
C
        for(1:5) = for1(1:5)
C
C       DIFFERENCE = CENTERDAY - RUNDATE = F1 + 2 DAYS
C       CHANGE CF1 TO HOURS, ADD 48 HOURS
C
        diff = cf1 * 12.0 + 48.0
C
C       IF DIFF NEGATIVE, SET AFTBEF TO ' BEFOR '
C
        IF (diff.LT.0.0) aftbef(1:7) = befor(1:7)
C
        cf2 = cf2 * 12.0
C
        IF (abs(diff).LE.72.0) THEN
          cf1 = abs(diff)
          cf2 = cf2 / 24.0
C
C        SET UNIT TO ' HRS '
C
          unit(1:4) = unit2(1:4)
          GO TO 100
        ENDIF
C
        cf1 = abs(diff / 24.0 )
        cf2 = cf2 / 24.0
C
C       SET UNIT TO ' DYS '
C
        unit(1:4) = unit1(1:4)
C
 100   CONTINUE
       RETURN
       END
C> @brief Encodes time-averaged title
C> @author Ralph Jones @date 1988-11-28
 
C> Encodes the first thirteen characters in the title
C> to make the title a time-averaged title.
C>
C> Program history log:
C> - Ralph Jones 1988-11-28
C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
C>
C> @param[in] CF2 Length of the forecast period
C> @param[in] UNIT Units for cf2
C> @param[inout] KTITLE
C> - [in] Title to be modified
C> - [out] Title with the time-averaged included
C>
C> @author Ralph Jones @date 1988-11-28
       SUBROUTINE setcl(CF2,UNIT,KTITLE)
 
C
        CHARACTER*324 KTITLE
        CHARACTER*13  BLANK
        CHARACTER*4   UNIT
        CHARACTER*4   DUNIT
        CHARACTER*4   HUNIT
C
        DATA  blank /'             '/
        DATA  dunit /'-DAY'/
        DATA  hunit /'-HR '/
C
  100   FORMAT (1x, f4.1, a4, ' AVG' )
C
        ktitle(1:13) = blank(1:13)
C
        WRITE (ktitle(1:13),100) cf2 , dunit(1:4)
C
       RETURN
       END