w3fq07.f

Go to the documentation of this file.

C> @file
C> @brief Sends fax,varian,afos,awips, maps & bulls
C> @author Peter Henrichsen @date 1997-01-09
 
C> Sets up the arguments for sub dbn_alert which posts transmission
C> availability to various statfiles. The input key words for w3fq07() may be
C> read in via the parm field or from a data card see remarks for examples.
C>
C> ### Program History Log:
C> Date | Programmer | Comments
C> -----|------------|---------
C> 1997-01-09 | Peter Henrichsen | Initial
C>
C> @param[in] LPARM Character*1 100 byte array containing ascii
C> flags and key words.
C> @param[in] NUMBYT Integer number of bytes of ascii data in lparm.
C> @param[in] OUTFIL Integer unit number of file to post to the
C> telecommunications gateway computer system.
C> @param[in] CARDFIL Integer unit number of file to read to get data
C> control card in lue of parm. this is only necessary
C> when parm(5:5) = 'a'.
C> @param[out] KRTN See return conditions.
C> Return conditions:
C> KRTN = 0 good return, file posted for transmission
C> KRTN = 1 good return, file not posted for transmission test flag was on ie
C> k=test or there was an "n" the 1st byte of the input data card.
C> KRTN = 2 bad  return, posting not attempted, the "k" key was missing.
C> KRTN = 3 bad  return, posting not attempted, parm less than than 6 bytes.
C> KRTN = 4 bad  return, card reader empty.
C> KRTN = 5 bad  return, error return from sub dbn_alert.
C>
C> FTNNF001 - File that contains the data to send. where 'nn' can be any
C> number from 01 to 99 except 5 or 6. This file must be assigned with u:nn.
C>
C> FTXXF001 - Input cards, only necessary if lparm(3-6) ='card'. a sample data
C> card is: m=ft24f001,k=afos (all on one card starting in col 1).
C> If col 1 = 'n' then the data set is not posted to the monitior,ie., w3fq07()
C> will return to calling program with out sending the product.
C> (xx has default of 05. however this number can be any unit number you wish.
C>
C> @note The key words that are passed to sub in lparm may be in any order in
C> the lparm array or data card. there is one key word that is mandatory. they are:
C> K=KKKKKKK Where KKKKKKKK is up to a 24 byte ascii keyword left-justified
C> which identifies what dbnet is to do with the input data file.
C>
C> 'KKKKKKKK' Is generally a keyword such as: 'FAXX', 'TRAN','AFOS','AWIP'
C> but may be: any one of these type-keys.
C>
C> Type-keys | Functions
C> ----------|----------
C> AFOS              | Posts AFOS utf map file to CRAY OSO'S statusfile.
C> AWIP              | Posts AWIPS map file to CRAY OSO'S statusfile.
C> FAXX              | Posts nmc6bit map file to CRAY OSO'S statusfile.
C> GRIB              | Posts wmo grib file to CRAY OSO'S statusfile.
C> TRAN              | Posts wmo bulletin file to CRAY OSO'S statusfile.
C> XTRN              | Posts xtrn file to CRAY OSO'S statusfile.
C> IG_DATA_ipsa1     | Sends data file to the intergraph ipsa1.
C> IG_DATA_ipsa2     | Sends data file to the intergraph ipsa2.
C> IG_DATA_lzr_srv1  | Sends data file to the intergraph lzr_srv1.
C> IG_PLTF_ipsa1     | Sends AFOS plot file to the intergraph ipsa1.
C> IG_PLTF_ipsa2     | Sends AFOS plot file to the intergraph ipsa2.
C> IG_PLTF_lzr_srv1  | Sends AFOS plot file to the intergraph lzr_srv1.
C> IG_6BIT_lzr_srv1  | Sends nmc6bit file to the intergraph lzr_srv1.
C> TPC_6BIT_nhc-hp13 | Sends nmc6bit file to nhc-hp13 at TPC.
C> OSO_IG_6BIT_lzr_srv1 | Posts nmc6bit file to CRAY OSO'S  statusfile and then Sends nmc6bit file to the intergraph lzr_srv1.
C> OSO_TPC_6BIT_nhc-hp13 | Posts nmc6bit file to CRAY OSO'S statusfile and then Sends nmc6bit file to nhc-hp13 at TPC.
C>
C> Where outfil is the file number containg the data.
C>
C> A sample: M=PETERS,K=FAXX where A ',' or A ' ' Terminates the key word.
C> Where a comma or blank terminates the key word.
C>
C> The M= is an optional key word. the 'M' key word is the model name
C> if missing the "missing" is used other wise it may by any
C> 24 byte ASCII string.
C>
C> A sample: M=AVN,K=AFOS, where a comma or blank terminates the key word.
C>
C> @author Peter Henrichsen @date 1997-01-09
      SUBROUTINE w3fq07(LPARM,NUMBYT,OUTFIL,CARDFIL,KRTN)
C
C
      CHARACTER*(*) LPARM
C
      CHARACTER*80  BLNK80
      CHARACTER*80  FILNAM
      CHARACTER*80  OUTXT
      CHARACTER*80  STRING
 
C
      CHARACTER*55 CHTEST
      DATA         chtest
     1/'THIS WAS A TEST, PRODUCTS NOT POSTED FOR TRANSMISSION.:'/
C      '1234567890123456789012345678901234567890123456789012345
C
      CHARACTER*52 NOTSNT
      DATA         notsnt
     1   /'** FILE NOT POSTED FOR TRANSMISSION AVAILABILITY **:'/
C         '1234567890123456789012345678901234567890123456789012'/
C
 
      CHARACTER*52 MESAG1
      DATA         mesag1
     1 /'FILE NOT POSTED FOR TRANSMISSION, FOUND BYPASS FLAG:'/
C    1 /'1234567890123456789012345678901234567890123456789012/
      CHARACTER*56 MESAG2
      DATA         mesag2
     1 /'FILE NOT POSTED FOR TRANSMISSION, "K" KEY FLAG MISSINGS:'/
C    1 /'12345678901234567890123456789012345678901234567890123456
      CHARACTER*46 MESAG3
      DATA         mesag3
     1    /'ERROR W3FQ07, LESS THAN 6 BYTES IN PARM FIELD:'/
C    1    /'12345678901234567890123456789012345678901234567890123456'/
 
      CHARACTER*55 MESAG4
      DATA         mesag4
     1    /'ERROR W3FQ07, CARD FILE EMPTY. CHECK JCL CARD FIILE   :'/
      CHARACTER*42 MESAG5
      DATA         mesag5
     1    /'ERROR RETURN FROM SUB DBN_ALERT,RETURN=  :'/
C    1    /'12345678901234567890123456789012345678901234567890123456'/
C
      CHARACTER*40 BLNK40
      DATA         blnk40
     1    /'                                        '/
      CHARACTER*24  BUFFER
      DATA          buffer/'                        '/
      CHARACTER*24  JOBNAM
      DATA          jobnam/'UNKOWN                  '/
C
      CHARACTER*12 CTEXT
      CHARACTER*4 CPLMIZ
      DATA        cplmiz  /'L999'/
C
      CHARACTER*04 LTRS
      DATA         ltrs   /'K=M='/
C
      CHARACTER*24  BLANK
      DATA        blank       /'                        '/
 
      CHARACTER*24 IFAXX
      DATA         ifaxx      /'FAXX                    '/
 
      CHARACTER*24 KEYWRD
      CHARACTER*24 MODNAM
C
      CHARACTER*4  AWIP
      DATA         awip        /'AWIP'/
      CHARACTER*4  IFAX
      DATA         ifax        /'FAX '/
 
C
      CHARACTER*1  IQUOT
C
      DATA       inunit        /5/
      INTEGER    CARDFIL
      INTEGER    OUTFIL
      INTEGER    NK,NM,NJ,NF,KRET4
C
 
      LOGICAL*1  BYPASS
      LOGICAL*1  GOTFLN
      LOGICAL*1  GOTKEY
      LOGICAL*1  GOTMOD
      LOGICAL*1  GOTJOB
      LOGICAL*1  LCARDS
      LOGICAL*1  KPRINT
C
        iquot  = char(27)
        blnk80 = blnk40//blnk40
C
C
        WRITE(6,fmt='('' USING W3FQ07 CRAY VERSION 97.008 08:40.'')')
C
C . . . PICKUP PARAMETERS.
C
C . . . CHECK TO SEE IF BYTE COUNT LESS THAN 6 IF SO PRODUCT NOT SENT.
C
      IF(numbyt.LT.6) THEN
C
C . . . BYTE COUNT LESS THAN 6.
C
             krtn = 3
             WRITE(6,fmt='('' W3FQ07: '',A)') notsnt(1:52)
             WRITE(6,fmt='('' W3FQ07: '',A)') mesag3(1:46)
             CALL consol(notsnt)
             CALL consol(mesag3)
      ELSE
 
C
C . . . BYTE COUNT GREATER THAN OR EQUAL TO 6,
C . . . START TO PROCESS FLAGS
C
C
      lcards = .false.
      gotkey = .false.
      gotmod = .false.
      gotjob = .false.
      gotfln = .false.
 
          IF(lparm(5:5).EQ.'A') lcards = .true.
C
C . . . . FILL KEYS WITH BLANKS.
C
          IF(lcards)THEN
C
              numbyt = 80
C
C . . . BLANK OUT LPARM.............................
C
             lparm(1:numbyt) = blnk80(1:numbyt)
C
C . . . READ DATA CARD TO GET DATA KEYWORDS TO SEND.
C
C        CHECK TO SEE IF CARDFIL IS GOOD
C
           IF(cardfil.GT.0)THEN
           ELSE
            cardfil  = inunit
           ENDIF
           WRITE(6,fmt='('' W3FQ07: READING CARD FROM UNIT '',
     1           I4)') cardfil
              READ(cardfil,fmt='(80A1)',END=940)
     1         (lparm(i:i),i=1,numbyt)
C
           WRITE(6,fmt='('' W3FQ07: PARM='',
     1           A)')lparm(1:numbyt)
C
C         CHECK TO SEE IF INTERFACE OFF FLAG IS SET....
C . . . . IF THERE IS AN 'N' IN THE 1ST COL OF DATA CARD CALL TO
C         DBN_ALERT WILL BE BYPASSED.
C
           IF(lparm(1:1).EQ.'N') bypass = .true.
C
C
C         CHECK TO SEE IF EXTRA PRINT FLAG IS SET....
C . . . . IF THERE IS AN 'P' IN THE 1ST COL OF DATA CARD
C         TURN ON 'KPRNT' FLAG.
C
            kprint = .false.
           IF(lparm(1:1).EQ.'P') kprint = .true.
          ENDIF
          IF(kprint)THEN
              WRITE(6,fmt='('' PARM='',A)') lparm(1:numbyt)
          ENDIF
C
           IF(bypass)THEN
          WRITE(6,fmt='(1H0,A)')mesag1(1:52)
          krtn = 7
           CALL consol(mesag1)
           ELSE
              IF(.NOT.lcards)
     1         WRITE(6,fmt='('' PARM='',A)') lparm(1:numbyt)
                 num = 0
            DO 840 lk  = 1,10,2
C
              DO 820 mm  = 1,numbyt
C
                next = mm+1
               IF(lparm(mm:next).EQ.ltrs(lk:lk+1))THEN
                   kstart = next + 1
                   loc    = next + 1
C              WRITE(6,FMT='('' FOUND'',A,'' AT LOC '',I3,
C    1         '' AND WILL START SEARCHING AT'',I4,'' IN ARRAY '',
C    2         ''OF LENGHT'',I4)')LPARM(MM:NEXT),MM,KSTART,NUMBYT
C
                    lloc = 0
                 DO 8010 ni = kstart,numbyt
                    loc = ni
                   IF(lparm(ni:ni).EQ.',')THEN
                   ELSE IF(lparm(ni:ni).EQ.iquot)THEN
                   ELSE IF(lparm(ni:ni).EQ.' ')THEN
                   ELSE
                    lloc = ni
                    GO TO 8010
                   ENDIF
                  GO TO 8015
8010             CONTINUE
               WRITE(6,fmt='('' I FELL THROUGH LOOP WITH LOC='',I4,
     1         '' WITH LLOC='',I4,'' & KSTART='',I4,
     2          '' NUMBYT='',I4,'' THEREFORE ADD "1" TO LOC'')')
     3          loc,lloc,kstart,numbyt
                   IF(lloc.EQ.kstart) loc = lloc + 1
8015           CONTINUE
                   IF(loc.GT.kstart) THEN
C
C              HAVE A FLAG LOAD IT INTO PROPER WORD
C
C       IF(KPRINT) THEN
                   WRITE(6,fmt='('' FOUND THE KEY WORD: '',A,
     1             '' AT LOCATION '',I2,'' IN LPARM ARRAY.'',/)')
     2             lparm(kstart:lloc),kstart
C       ENDIF
                     IF(lk.EQ.1) THEN
 
                       keywrd = lparm(kstart:lloc)
                       nk = lloc - kstart+1
                       gotkey = .true.
                       num = num + 1
                     ELSE IF(lk.EQ.3) THEN
                       modnam = lparm(kstart:lloc)
                       nm = lloc - kstart+1
                       gotmod = .true.
                       num = num + 1
                     ENDIF
                   ELSE
                    GO TO 820
                   ENDIF
               ELSE
C              GO SEARCH SOME MORE.
                    GO TO 820
               ENDIF
C
               GOTO 840
 820         CONTINUE
C
 840         CONTINUE
              numgod = 2
C
           IF(num.LT.numgod) THEN
C
C             DID NOT FIND A MATCH OF A KEY LETTER CHECK TO SEE WHICH
C             ONE IT WAS.
C
              IF(gotkey)THEN
                modnam(1:8) = 'MISSGING'
                nm = 8
                gotmod = .true.
              ELSE
               krtn = 2
             WRITE(6,fmt='('' W3FQ07: '',A)') notsnt(1:52)
             WRITE(6,fmt='('' W3FQ07: '',A)') mesag2(1:46)
C
              CALL consol(notsnt)
              CALL consol(mesag2)
              GO TO 900
              ENDIF
           ENDIF
C
C
              WRITE(6,fmt='('' PARM='',A)') lparm(1:numbyt)
              WRITE(6,fmt='('' MODNAM='',A,'' KEYWRD='',A,
     1        /)')modnam(1:nm),keywrd(1:nk)
C
C
C         CHECK TO SEE IF FIRST 4 BYTES OF KEYWRD = FAX .
C          IF IT DOES, CHANGE IT TO FAXX .
C
                IF(keywrd(1:nk).EQ.'FAX')THEN
                 keywrd(1:4) = 'FAXX'
                 nk = 4
                ENDIF
                IF(keywrd(1:nk).EQ.'TEST')THEN
                 bypass = .true.
              WRITE(6,fmt='('' W3FQ07: BYPASS FLAG ON, '',
     1                      ''SKIP POSTING FILE.'',/)')
                 GO TO 900
                ENDIF
C
C             MUST NOW I MUST GET THE JOB NAME AND UNIT NAME FOR
C             CALL TO DBN_ALERT.
C
C . . .       READ IN JOBNAME
              jchars = getenv('QSUB_REQNAME',buffer)
              nj = 0
                IF(buffer(1:8).EQ.'        ')THEN
                 jobnam(1:8) = 'MSG_JOBNM'
                 nj = 8
                ELSE
                 DO ii =1,8
                  IF(buffer(ii:ii).NE.' ')THEN
                   nj = nj + 1
                   jobnam(nj:nj) = buffer(ii:ii)
                  ENDIF
                 ENDDO
                ENDIF
C
             WRITE(6,fmt='('' W3FQ07: JOB NAME JOBNAM= :'',A,
     1         ''!'')') jobnam(1:24)
              WRITE(6,fmt='('' W3FQ07: JOB NAME= '',A,
     1         '' NJ='',I3)') jobnam(1:nj),nj
C
C . . .       READ IN FILE NAME
C
                 krtn = 0
 
                 CALL asnqunit(outfil,string,istat)
              WRITE(6,fmt='('' W3FQ07:OUTFIL NAME= '',
     1         A,'' ISTAT='',I4)')string(1:80),istat
C                SEARCH FOR LENGHT OF FILE NAME.
C
                kret = istat
                IF(kret.EQ.0) THEN
                  istrt = 0
                DO i = 1,80
                  IF(istrt.EQ.0)THEN
                   IF(string(i:i).EQ.'/')THEN
                    istrt = i
                   ENDIF
                  ELSE
                   IF(string(i:i).EQ.' ')THEN
                    iend = i
                    GOTO 775
                   ENDIF
                  ENDIF
                ENDDO
 775            nf = iend - istrt
                outxt(1:nf) = string(istrt:iend)
                 WRITE(6,fmt='('' W3FQ07: OUTXT= '',
     1          A,'' NF='',I3)')outxt(1:nf),nf
C
               WRITE(6,fmt='('' W3FQ07: CALLING DBN_ALERT WITH'',
     1         '' :'',A,'' NK='',I2,'' '',A,'' NM='',I2,'' '',
     2         A,'' NJ='',I2,'' '',A,'' NF='',I3)')keywrd(1:nk),
     3          nk,modnam(1:nm),nm,jobnam(1:nj),nj,outxt(1:nf),nf
 
                  CALL dbn_alert(keywrd,nk,modnam,nm,jobnam,nj,
     1                 outxt,nf,kret4)
                  kret=kret4
C
               ENDIF
                IF(kret.EQ.0) THEN
C               COMES HERE FOR NORMAL STOP.
C
                 filnam(1:8) = 'POSTING '
                 filnam(9:9+nk-1) = keywrd(1:nk)
                 jloc = 9 + nk
                 filnam(jloc:jloc+6) = ' FILE '
                  loc = jloc + 6
                 filnam(loc+1:loc+1+nf) = outxt(1:nf)
                  joc = loc + nf + 1
                 filnam(joc:joc) = ':'
                 WRITE(6,fmt='('' W3FQ07: KRET='',I4,'' THEREFORE '',
     1          A)')kret,filnam(1:joc)
                 CALL consol(filnam)
                ELSE
                  krtn = 5
                 CALL int2ch(kret,ctext,2,cplmiz)
                 mesag5(40:41) = ctext(1:2)
                   WRITE(6,fmt='('' W3FQ07: '',
     1             A)')mesag5(1:42)
                 CALL consol(notsnt)
                 CALL consol(mesag5)
                ENDIF
C
 900    CONTINUE
       ENDIF
       GO TO 1000
 940  CONTINUE
           CALL int2ch(cardfil,ctext,2,cplmiz)
              mesag4(53:54) = ctext(1:2)
             CALL consol(notsnt)
             CALL consol(mesag4)
             WRITE(6,fmt='('' W3FQ07: '',A)') notsnt
             WRITE(6,fmt='('' W3FQ07: '',A)') mesag4
        krtn = 4
       ENDIF
1000  RETURN
      END