w3fi61.f

Go to the documentation of this file.

C> @file
C> @brief Build 40 char communications prefix.
C> @author Bill Cavanaugh @date 1991-06-21
 
C> Using information from the user, build a 40 character
C> communications prefix and place in indicated location.
C>
C> Program history log:
C> - Bill Cavanaugh 1991-06-21
C> - Ralph Jones 1991-09-20 Changes for silicongraphics 3.3 fortran 77.
C> - Ralph Jones 1993-03-29 Add save statement.
C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and
C> for ASCII character set computers.
C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
C>
C> @param[in] ICAT Catalog number.
C> @param[in] AREG AFOS regional addressing flags (6 positions)
C> select any or all of the following. Selections
C> will automatically be left justified and blank
C> filled to 6 positions.
C> If bulletins and/or messages are not to be routed
C> to AFOS, then leave the field filled with blanks.
C> - E - Eastern region
C> - C - Central region
C> - W - Western region
C> - S - Southern region
C> - A - Atlantic region
C> - P - Pacific region
C> @param[in] IERR Error return.
C> @param[in] IBCKUP Backup indicator w/header key
C> - 0 = Not a backup.
C> - 1 = FD backup.
C> - 2 = DF backup.
C>  - Back up is only permitted for KU and KU bulletins.
C> @param[in] IDATYP Data type indicator.
C> - 0  = EBCIDIC data.
C> - 11 = Binary data.
C> - 12 = Psuedo-ASCII data.
C> - 3  = ASCII data.
C> @param[out] LOC Name of the array to receive the communications prefix.
C>
C> @note Error returns
C> IERR:
C> - = 0 Normal return.
C> - = 1 Incorrect backup flag.
C> - = 2 A regional addressing flag is non-blank and non-standard entry.
C> - = 3 Data type is non-standard entry.
C>
C> @author Bill Cavanaugh @date 1991-06-21
      SUBROUTINE w3fi61 (LOC,ICAT,AREG,IBCKUP,IDATYP,IERR)
      INTEGER        LOC(*)
      INTEGER        ICAT,IBCKUP,IDATYP
      INTEGER        IERR,IHOLD
C
      CHARACTER*6    AREG
      CHARACTER*8    AHOLD
      CHARACTER*6    ARGNL
      CHARACTER*1    BLANK
C
      LOGICAL        IBM370
C
      equivalence(ihold,ahold)
C
      SAVE
C
      DATA  argnl /'ECWSAP'/
C
C     BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
C     COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
C     BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
C     ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
C     SETS TO FIND IBM370 TYPE COMPUTER.
C
      DATA  blank /' '/
      DATA  ibm370/.false./
C
C  ----------------------------------------------------------------
C
C     TEST FOR CRAY 64 BIT COMPUTER, LW = 8
C
      CALL w3fi01(lw)
C
C     TEST FOR EBCDIC CHARACTER SET
C
      IF (mova2i(blank).EQ.64) THEN
        ibm370 = .true.
      END IF
C
      ierr      = 0
      inofst    = 0
C BYTE  1                    SOH -  START OF HEADER
      CALL sbyte (loc,125,inofst,8)
      inofst    = inofst + 8
C BYTE  2                    TRANSMISSION PRIORITY
      CALL sbyte (loc,1,inofst,8)
      inofst    = inofst + 8
C BYTE  3-7                  CATALOG NUMBER
      IF (icat.GT.0) THEN
        IF (lw.EQ.4) THEN
          kk        = icat / 10
          CALL w3ai15 (kk,ihold,1,4,'-')
          IF (.NOT.ibm370) CALL w3ai39(ihold,4)
          CALL sbyte (loc,ihold,inofst,32)
          inofst    = inofst + 32
          kk        = mod(icat,10)
          CALL w3ai15 (kk,ihold,1,4,'-')
          IF (.NOT.ibm370) CALL w3ai39(ihold,4)
          CALL sbyte (loc,ihold,inofst,8)
          inofst    = inofst + 8
        ELSE
          CALL w3ai15 (icat,ihold,1,8,'-')
          IF (.NOT.ibm370) CALL w3ai39(ihold,8)
          CALL sbyte (loc,ihold,inofst,40)
          inofst    = inofst + 40
        END IF
      ELSE
          CALL sbyte (loc,-252645136,inofst,32)
          inofst    = inofst + 32
          CALL sbyte (loc,240,inofst,8)
          inofst    = inofst + 8
      END IF
C BYTE  8-9-10              BACK-UP FLAG FOR FD OR DF BULLETINS
C                                    0 = NOT A BACKUP
C                                    1 = FD
C                                    2 = DF
      IF (ibckup.EQ.0) THEN
C                              NOT A BACKUP
          CALL sbyte (loc,4210752,inofst,24)
          inofst    = inofst + 24
      ELSE IF (ibckup.EQ.1) THEN
C                              BACKUP FOR FD
          CALL sbyte (loc,12764868,inofst,24)
          inofst    = inofst + 24
      ELSE IF (ibckup.EQ.2) THEN
C                              BACKUP FOR DF
          CALL sbyte (loc,12764358,inofst,24)
          inofst    = inofst + 24
      END IF
C BYTE  11                   BLANK
      CALL sbyte (loc,64,inofst,8)
      inofst    = inofst + 8
C BYTE  12                   DATA TYPE
      IF (idatyp.EQ.0) THEN
      ELSE IF (idatyp.EQ.11) THEN
      ELSE IF (idatyp.EQ.12) THEN
      ELSE IF (idatyp.EQ.3) THEN
      ELSE
          ierr  = 3
          RETURN
      END IF
      CALL sbyte (loc,idatyp,inofst,8)
      inofst    = inofst + 8
C BYTES 13-18                AFOS REGIONAL ADDRESSING FLAGS
      CALL sbyte (loc,1077952576,inofst,32)
      inofst    = inofst + 32
      CALL sbyte (loc,1077952576,inofst,16)
      kreset    = inofst + 16
      inofst    = inofst - 32
      DO 1000 j = 1, 6
          DO 900 k = 1, 6
              IF (areg(j:j).EQ.argnl(k:k)) THEN
C                 PRINT *,AREG(J:J),ARGNL(K:K),' MATCH'
                  ihold    = 0
                  IF (lw.EQ.4) THEN
                    ahold(4:4) = areg(j:j)
                    IF (.NOT.ibm370) CALL w3ai39(ihold,4)
                  ELSE
                    ahold(8:8) = areg(j:j)
                    CALL w3ai39(ihold,8)
                  END IF
                  CALL sbyte (loc,ihold,inofst,8)
                  inofst   = inofst + 8
                  GO TO 1000
              ELSE IF (areg(j:j).EQ.' ') THEN
C                 PRINT *,'BLANK SOURCE '
                  GO TO 1000
              END IF
  900     CONTINUE
          ierr  = 2
          RETURN
 1000 CONTINUE
      inofst   = kreset
C BYTES 19-39                UNUSED (SET TO BLANK)
      DO 1938 i = 1, 20, 4
          CALL sbyte (loc,1077952576,inofst,32)
          inofst    = inofst + 32
 1938 CONTINUE
C BYTE  39                   MUST BE A BLANK
      CALL sbyte (loc,64,inofst,8)
          inofst    = inofst + 8
C BYTE  40                   MUST BE A BLANK
      CALL sbyte (loc,64,inofst,8)
C  ----------------------------------------------------------------
      RETURN
      END