SUBROUTINE W3FI61 (LOC,ICAT,AREG,IBCKUP,IDATYP,IERR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3FI61 BUILD 40 CHAR COMMUNICATIONS PREFIX C PRGMMR: CAVANAUGH ORG: NMC421 DATE:91-07-24 C C ABSTRACT: USING INFORMATION FROM THE USER, BUILD A 40 CHARACTER C COMMUNICATIONS PREFIX AND PLACE IN INDICATED LOCATION. C C PROGRAM HISTORY LOG: C 91-06-21 CAVANAUGH C 91-09-20 R.E.JONES CHANGES FOR SiliconGraphics 3.3 FORTRAN 77 C 93-03-29 R.E.JONES ADD SAVE STATEMENT C 94-04-28 R.E.JONES CHANGE FOR CRAY 64 BIT WORD SIZE AND C FOR ASCII CHARACTER SET COMPUTERS C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I C C USAGE: CALL W3FI61 (LOC,ICAT,AREG,IBCKUP,IDATYP,IERR) C INPUT ARGUMENT LIST: C ICAT - CATALOG NUMBER C 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 IERR - ERROR RETURN C 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 FD AND DF BULLETINS C IDATYP - DATA TYPE INDICATOR C 0 = EBCIDIC DATA C 11 = BINARY DATA C 12 = PSUEDO-ASCII DATA C 3 = ASCII DATA C C OUTPUT ARGUMENT LIST: C LOC - NAME OF THE ARRAY TO RECEIVE THE COMMUNICATIONS PREFIX C C REMARKS: ERROR RETURNS C IERR = 0 NORMAL RETURN C = 1 INCORRECT BACKUP FLAG C = 2 A REGIONAL ADDRESSING FLAG IS C NON-BLANK AND NON-STANDARD ENTRY C = 3 DATA TYPE IS NON-STANDARD ENTRY C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 C C$$$ 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