C PROGRAM WRTEST(INPUT,OUTPUT,TAPE1=INPUT) C C PROGRAM TO READ DATA AND PASS IT TO SUBROUTINES WHICH C CREATE A STANDARD INTERCHANGE TAPE. C INCLUDE 'SY:FLGCM.FTN' INCLUDE 'SY:DDFCOM.FTN' REAL*8 TAG,MFID,NN DIMENSION INFO(13), IVSNS(2) LOGICAL*1 DT(40),DTA(40),N1(5) REAL*8 DBLANK EQUIVALENCE (DT,DTA), (MFID,INFO(3)) DATA NS/0/, NDAT/0/, NST/0/, NT/5/ DATA DBLANK/' '/ DATA BLANK /1H / DATA NN/'00001'/ DATA LUNPRM/2/ OPEN (UNIT=LUNPRM,NAME='SY:WRTEST.DAT',TYPE='OLD',ACCESS= $'SEQUENTIAL',FORM='FORMATTED') PRINT 21 21 FORMAT(1H1) C C GET DATA BASE NAME C READ(LUNPRM,24) TAG, DT, LNTH C C INITIALIZE FILE C 12 CALL INITCN MAGEND=.FALSE. C C GET LEADER CHARACTERISTICS C C TYPE 210 210 FORMAT(' ENTER SUBSYSTEM CONTROL CHARACTER LEVEL 1 = BLANK') ACCEPT 211,SSC TYPE 220 220 FORMAT(' ENTER CHARACTER SET CONTROL - TWO CHARACTERS LEVEL 1 = 2 $BLANKS') ACCEPT 221,CSC 211 FORMAT(A1) 221 FORMAT(A2) TYPE 230 230 FORMAT(' ENTER FIELD CONTROL COUNT - 2 CHARACTERS LEVEL 1 = 00') ACCEPT 221,FCC TYPE 240 240 FORMAT(' ENTER TAG LENGTH - I2 1-7') ACCEPT 241,ITL 241 FORMAT(I2) TYPE 250 250 FORMAT(' ENTER CONVERSION MODE - I2 LEVEL 1 = 1') ACCEPT 241,ICM TYPE 260 260 FORMAT(' ENTER MULTIFILE SET IDENTIFIER - 6 CHARACTERS') ACCEPT 261,MFID 261 FORMAT(A6) CALL SETDDF(ISTAT,ITL,ICM) C C GO TO STATEMENT 26 TO OUTPUT TAG 00000 C IF (ISTAT .EQ. 0) GO TO 26 IF (DEBUG) TYPE 15, ISTAT 15 FORMAT (7H ERROR ,I2,24H FROM SETDDF, WILL ABORT) STOP 'ABORT' C LOOP TO READ DDF DIRECTORY 23 READ(LUNPRM,24) TAG, DT, LNTH 24 FORMAT(A5,5X,40A1,10X,I2) IF(TAG.EQ.DBLANK) GO TO 27 26 IF (DEBUG) TYPE 6, TAG, DT, LNTH 6 FORMAT(/1X,A8,40A1,5X,I10) DO 5 I=1,5 CALL ADDFLD(ISTAT,TAG,DT,LNTH) IF (ISTAT .NE. 0) GO TO 30 5 CONTINUE GO TO 23 30 IF (DEBUG) TYPE 31, ISTAT 31 FORMAT(7H ERROR ,I2,24H FROM ADDFLD, WILL ABORT) STOP 'ABORT' 27 CALL WRTREC(ISTAT) IF (ISTAT .NE. 0) GO TO 36 NR=0 C READ IN DATA 1 CONTINUE IF(DEBUG) TYPE 2000 2000 FORMAT(' READ DATA') READ (LUNPRM,2,END=99)(DTA(I),I=1,6),(DTA(I2),I2=11,12),(DTA(I3), 1I3=21,40) IF(DEBUG) TYPE 2000 2 FORMAT(6A1,4X,12A1,18X,10A1) 3 CONTINUE C CHECK FOR CONTINUATION OF STATION AND DATE C WRITE PREVIOUS RECORD IF ANY IF (NR .EQ. 0) GO TO 28 CALL WRTREC(ISTAT) DO 200 I=1,6 IF(DTA(I).EQ.BBLANK)GO TO 200 GO TO 201 200 CONTINUE GO TO 99 201 IF (ISTAT .EQ. 0) GO TO 28 36 IF(DEBUG) TYPE 37, ISTAT 37 FORMAT(7H ERROR ,I2,24H FROM WRTREC, WILL ABORT) STOP 'ABORT' C TAG 001 DATA TO RECORD 28 NR=NR+1 ENCODE(NT,100,N1)NR 100 FORMAT(I5) CALL LEADZE (N1,5) 25 FORMAT(10O3,5X,I5) CALL ADDFLD(ISTAT,NN,N1,NT) IF (ISTAT .NE. 0) GO TO 30 CALL STRMOV(DTA(11),NST,2) C STATION TO RECORD IF(DEBUG) TYPE 25,(DTA(I),I=11,12) NN='00010' CALL ADDFLD(ISTAT,NN,DTA(11),2) IF (ISTAT .NE. 0) GO TO 30 NDAT=DTA(1) C DATE TO RECORD IF(DEBUG) TYPE 25,(DTA(I),I=1,10) NN='00011' CALL ADDFLD(ISTAT,NN,DTA(1),6) IF (ISTAT .NE. 0) GO TO 30 4 CONTINUE C PARAMETER/VALUE TO RECORD C NUMBER OF CHARACTERS IN VALUE CALL COUNT(DTA(21),NC,10) IF(DEBUG) TYPE 120,(DTA(I),I=21,30),NC 120 FORMAT(1X,10O3,5X,I5) NN='00012' CALL ADDFLD(ISTAT,NN,DTA(21),NC) IF (ISTAT .NE. 0) GO TO 30 CALL COUNT(DTA(31),NC,10) NN='00013' CALL ADDFLD(ISTAT,NN,DTA(31),NC) NN='00001' IF (ISTAT .NE. 0) GO TO 30 GO TO 1 99 CONTINUE C TERMINATE TAPE CALL TERMDF(ISTAT) IF (ISTAT .EQ. 0) GO TO 98 IF(DEBUG) TYPE 97, ISTAT 97 FORMAT(7H ERROR ,I2,24H FROM TERMDF, WILL ABORT) CALL ABORT 98 STOP END