      SUBROUTINE WHDR12                                                   00001 
C                                                                         00002 
CC    THIS SUBROUTINE WRITES HDR1 & HDR2 LABELS                           00003 
CC    OR A LOGICAL END-OF-TAPE                                            00004 
C                                                                         00005 
      LOGICAL*1 LBLANK,LYYDDD(6)                                          00006 
      DIMENSION SYSCOD(3)                                                 00007 
C                                                                         00008 
      INCLUDE 'SY:BCOM.FTN'                                               00009 
      INCLUDE 'SY:FLGCM.FTN'                                              00010 
      INCLUDE 'SY:LABCM.FTN'                                              00011 
      INCLUDE 'SY:MTCOMM.FTN'                                             00012 
      INCLUDE 'SY:MTFCB.FTN'                                              00013 
C                                                                         00014 
      DATA LBLANK/1H /                                                    00015 
      DATA HDR1,HDR2/4HHDR1,4HHDR2/                                       00016 
      DATA SYSCOD(1),SYSCOD(2),SYSCOD(3)/4H  BI,4HOMET,4HRICS/            00017 
C                                                                         00018 
CC    IDENTIFY ROUTINE                                                    00019 
C                                                                         00020 
      IF (DEBUG) TYPE 1                                                   00021 
1     FORMAT (' WHDR12')                                                  00022 
C                                                                         00023 
CC    FILL LBUFR WITH 80 CHARACTERS OF HDR1 INFORMATION                   00024 
C                                                                         00025 
CC    BUT FIRST INITIALIZE LBUFR WITH BLANKS                              00026 
C                                                                         00027 
      DO 32758 I=1,80                                                     00028 
      LBUFR(I) = LBLANK                                                   00028 
32758 CONTINUE                                                            00028 
C                                                                         00029 
CC    NOW PUT HDR1 INTO LBUFR                                             00030 
C                                                                         00031 
      CALL STRMOV (HDR1,LBUFR(1),4)                                       00032 
C                                                                         00033 
CC    AND LBDATA                                                          00034 
C                                                                         00035 
      IF(.NOT.(LABFLG .EQ. 0)) GO TO 32757                                00036 
      DO 32756 I=1,17                                                     00037 
      LBDATA(I) = DDFNAM(I)                                               00037 
32756 CONTINUE                                                            00037 
32757 IF(.NOT.(LABFLG .EQ. 1)) GO TO 32755                                00039 
      DO 32754 I=1,17                                                     00040 
      LBDATA(I) = DFNAME(I)                                               00040 
32754 CONTINUE                                                            00040 
32755 CALL STRMOV (LBDATA,LBUFR(5),17)                                    00042 
C                                                                         00043 
CC    AND VSNLST                                                          00044 
C                                                                         00045 
      CALL STRMOV (VSNLST,LBUFR(22),6)                                    00046 
C                                                                         00047 
CC    AND FILE SECTION NUMBER                                             00048 
C                                                                         00049 
      I = 1                                                               00050 
      ENCODE (4,2,LBUFR(28)) I                                            00051 
2     FORMAT (I4)                                                         00052 
      CALL LEADZE (LBUFR(28),4)                                           00053 
C                                                                         00054 
CC    AND KTFILE                                                          00055 
C                                                                         00056 
      ENCODE (4,2,LBUFR(32)) KTFILE                                       00057 
      CALL LEADZE (LBUFR(32),4)                                           00058 
C                                                                         00059 
CC    AND YYDDD                                                           00060 
C                                                                         00061 
      CALL YYDDD (LYYDDD)                                                 00062 
      CALL STRMOV (LYYDDD,LBUFR(42),6)                                    00063 
      CALL STRMOV (LYYDDD,LBUFR(48),6)                                    00064 
C                                                                         00065 
CC    AND BLOCK COUNT                                                     00066 
C                                                                         00067 
      I = 0                                                               00068 
      ENCODE (6,3,LBUFR(55)) I                                            00069 
3     FORMAT (I6)                                                         00070 
      CALL LEADZE (LBUFR(55),6)                                           00071 
C                                                                         00072 
CC    AND SYSTEM CODE                                                     00073 
C                                                                         00074 
      CALL STRMOV (SYSCOD,LBUFR(61),12)                                   00075 
C                                                                         00076 
CC    NOW WRITE HDR1 LABEL                                                00077 
C                                                                         00078 
      IBUFER = 1                                                          00079 
      NBUFER = 80                                                         00080 
      ASSIGN 32752 TO I32753                                              00081 
      GO TO 32753                                                         00081 
C                                                                         00082 
CC    FILL LBUFR WITH 80 CHARACTERS OF HDR2 INFORMATION                   00083 
C                                                                         00084 
CC    BUT FIRST INITIALIZE LBUFR WITH BLANKS                              00085 
C                                                                         00086 
32752 DO 32751 I=1,80                                                     00087 
      LBUFR(I) = LBLANK                                                   00087 
32751 CONTINUE                                                            00087 
C                                                                         00088 
CC    NOW PUT HDR2 INTO LBUFR                                             00089 
C                                                                         00090 
      CALL STRMOV (HDR2,LBUFR(1),4)                                       00091 
C                                                                         00092 
CC    AND RECORD FORMAT                                                   00093 
C                                                                         00094 
      LBUFR(5) = 'U'                                                      00095 
C                                                                         00096 
CC    AND BLOCK LENGTH                                                    00097 
C                                                                         00098 
      IBLOCL = 2046                                                       00099 
      ENCODE (5,4,LBUFR(6)) IBLOCL                                        00100 
4     FORMAT (I5)                                                         00101 
      CALL LEADZE (LBUFR(6),5)                                            00102 
C                                                                         00103 
CC    AND RECORD LENGTH                                                   00104 
C                                                                         00105 
      IRECL = 2046                                                        00106 
      ENCODE (5,4,LBUFR(11)) IRECL                                        00107 
      CALL LEADZE (LBUFR(11),5)                                           00108 
C                                                                         00109 
CC    NOW WRITE HDR2 LABEL                                                00110 
C                                                                         00111 
      IBUFER = 1                                                          00112 
      NBUFER = 80                                                         00113 
      ASSIGN 32750 TO I32753                                              00114 
      GO TO 32753                                                         00114 
C                                                                         00115 
CC    NOW WRITE AN END-OF-FILE MARK                                       00116 
C                                                                         00117 
32750 ASSIGN 32748 TO I32749                                              00118 
      GO TO 32749                                                         00118 
C                                                                         00119 
CC    THATS IT!                                                           00120 
C                                                                         00121 
32748 RETURN                                                              00122 
C                                                                         00123 
CC    M T W R I T . F L X                                                 00124 
C                                                                         00125 
CC    NOTE ** INCLUDE MTFCB.FTN COMMON DEFINITION                         00126 
CC    MAGTAPE PROCEDURES TO WRITE A TAPE                                  00127 
32749 CONTINUE                                                            00128 
      MAGERR = .FALSE.                                                    00129 
      CALL MTEOF( MTLUN,ISTAT )                                           00130 
      IF(.NOT.( MTERRL )) GO TO 32747                                     00131 
      ASSIGN 32745 TO I32746                                              00131 
      GO TO 32746                                                         00131 
32745 CONTINUE                                                            00131 
32747 GO TO I32749                                                        00132 
32753 CONTINUE                                                            00133 
      MAGERR = .FALSE.                                                    00134 
      CALL MTWLB( MTLUN,LBUFR(IBUFER),NBUFER,ISTAT )                      00135 
      IF(.NOT.( MTERRL )) GO TO 32744                                     00136 
      ASSIGN 32742 TO I32743                                              00136 
      GO TO 32743                                                         00136 
32742 CONTINUE                                                            00136 
32744 GO TO I32753                                                        00137 
32746 CONTINUE                                                            00138 
      CALL ERROR( TTLUN,'WRITE MAGTAPE END-OF-FILE FAILED',MTDSW,MTIOS )  00139 
      ASSIGN 32740 TO I32741                                              00140 
      GO TO 32741                                                         00140 
32740 GO TO I32746                                                        00141 
32743 CONTINUE                                                            00142 
      CALL ERROR( TTLUN,'WRITE MAGTAPE FAILED',MTDSW,MTIOS )              00143 
      ASSIGN 32739 TO I32741                                              00144 
      GO TO 32741                                                         00144 
32739 GO TO I32743                                                        00145 
32741 CONTINUE                                                            00146 
      MAGERR = .TRUE.                                                     00147 
      GO TO I32741                                                        00148 
      END                                                                 00149 
