EOF () { rm fort.1 fort.2 fort.3 fort.7 #dd if=/data/coads/ftp/$1 of=fort.1 cbs=131 conv=unblock ln -s data/$1 fort.1 grep "^ $1 " tapelist > fort.8 ln -s LMR6/$1 fort.3 ln -s LMR6E/$1 fort.2 ln -s LMR6S/$1 fort.7 echo /DSS/LMR6/SL/$1 > fort.4 cat fort.4 a=/data/coads/software f77 p.f $a/date.o $a/gsbytes.o $a/rptin.o ./a.out } cat > p.f <<\EOR PROGRAM QS6 C CONVERT IMMT TO LMR6 C AUTHOR: S.LUBKER, 91/01/10 15:45:39 C -----------REVISION HISTORY---------------------------------------34567898 C LEVEL AUTHOR DATE DESCRIPTION C ===== ====== ========== ==================== C .01A. SJL 91/01/10 ORIGINAL VERSION. C .01B. SJL 93/02/25 LIB/SAVSUM AND LIB/PUTRPT OPTIMIZED; C REVISED BLOCK DATA LMR6. C .02A. SJL 95/11/20 IMMT CODE EFFECTIVE NOV 2, 1994: C REPLACE 124 WITH 131 CHARACTER LENGTH; C REPLACE B10QXY WITH B10XY; C REPLACE 2 WITH 4 DIGIT YEAR; C REPLACE 3 WITH 4 DIGIT LONGITUDE; C REPLACE AMBIGUOUS WITH POSITIONAL C WET BULB AND DEW POINT TEMPERATURES; C REPLACE RIGHT WITH LEFT JUSTIFIED SHIP C IDENTIFIER; C ALLOW LEADING BLANKS IN NUMERIC FIELDS. C .02B. SJL 96/07/16 REPLACE OCTANT WITH QUADRANT. C .02C. SJL 97/11/19 JAPANESE KOBE DCK 762 SID 97. C .02D. SJL 02/05/23 UNIX JAPANESE KOBE DCK 762. C .02E. SJL 03/10/15 KOBE 2003 EDITION. C ------------------------------------------------------------------34567898 IMPLICIT INTEGER(A-E,G-Z) C CHARACTER IMMT*131 COMMON //IMMT C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER) +,FORMAT(NUMBER),RPTID,INDXCK COMMON /DAT/CODED(NUMBER),FTRUE(NUMBER),FMISS COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR C DIMENSION NREC(3) C LOGICAL B10XY C DATA LEVEL/4H.02E/,NREC/3*0/ C LOGICAL MEASUR,COMPUT CHARACTER CHR MEASUR(CHR)= +CHR.EQ.'0'.OR. +CHR.EQ.'1'.OR. +CHR.EQ.'2' COMPUT(CHR)= +CHR.EQ.'5'.OR. +CHR.EQ.'6'.OR. +CHR.EQ.'7' C IMMT=' ' DO 1 I=1,NUMBER 1 FTRUE(I)=FMISS CALL PUTIMM(FTRUE(11),FTRUE(48),FTRUE(71),RECL) C WRITE(7,'(''1QS6'',A4)')LEVEL C 100 NREC(1)=NREC(1)+1 101 READ(1,'(A)',IOSTAT=IEOF)IMMT IF(IEOF.NE.0)GOTO 810 IF(RECL.EQ.80.AND. +(IMMT(1:3).EQ.'VOL'.OR. + IMMT(1:3).EQ.'HDR'.OR. + IMMT(1:3).EQ.'EOF'))GOTO 101 C EBCDIC IF(NINT(FTRUE(11)).EQ.46.OR. + NINT(FTRUE(11)).EQ.59)CALL EBCASC(IMMT,IMMT,RECL) C NERR=0 C LAT CALL MAP( 8,12,15,1) IF(FTRUE( 8).EQ.FMISS)GOTO 800 C LON CALL MAP( 7,16,19,1) IF(FTRUE( 7).EQ.FMISS)GOTO 800 C MO CALL MAP( 3, 6, 7,0) IF(FTRUE( 3).EQ.FMISS)GOTO 800 C YR CALL MAP( 2, 2, 5,0) IF(FTRUE( 2).EQ.FMISS)GOTO 800 C B10 IF(.NOT.B10XY(NINT(FTRUE( 7)*100.),NINT(FTRUE( 8)*100.) +,CODED( 1)))STOP 'B10XY' FTRUE( 1)=CODED( 1) C DY CALL MAP( 4, 8, 9,0) C HR CALL MAP( 5,10,11,0) C TI IF(IMMT(10:11).EQ.' ')THEN FTRUE( 6)=FMISS ELSE FTRUE( 6)=0. ENDIF C LI FTRUE( 9)=0. C DCK FTRUE(10)=762. C SID C PT FTRUE(12)=5. C QI C CALL MAP(13,0) C DS C CALL MAP(14,0) C DC C CALL MAP(15,0) C TC C CALL MAP(16,0) C PB C CALL MAP(17,0) C DI IF(IMMT(25:26).EQ.' ')THEN FTRUE(18)=FMISS ELSE FTRUE(18)=0. ENDIF C D CALL MAP(19,25,26,-1) C WI IF(IMMT(28:29).EQ.' ')THEN FTRUE(20)=FMISS ELSE CALL MAP(20,27,27,0) ENDIF C W CALL MAP(21,28,29,0) C VI IF(IMMT(22:23).EQ.' ')THEN FTRUE(22)=FMISS ELSE CALL MAP(22,20,20,0) ENDIF C VV CALL MAP(23,22,23,0) C WW CALL MAP(24,42,43,0) C W1 CALL MAP(25,44,44,0) C W2 CALL MAP(26,45,45,0) C SLP CALL MAP(27,38,41,1) C T1 IF(IMMT(30:37).EQ.' '.AND. + IMMT(50:53).EQ.' '.AND. + IMMT(89:92).EQ.' ')THEN FTRUE(28)=FMISS ELSE CALL MAP(28, 1, 1,0) ENDIF C AT CALL MAP(29,30,33,1) C WBT CALL MAP(30,89,92,1) C DPT CALL MAP(31,34,37,1) C SST CALL MAP(32,50,53,1) C SI IF(IMMT(50:53).EQ.' ')THEN FTRUE(33)=FMISS ELSE CALL MAP(33,54,54,0) ENDIF C N CALL MAP(34,24,24,0) C NH CALL MAP(35,46,46,0) C CL CALL MAP(36,47,47,0) C HI IF(IMMT(21:21).EQ.' ')THEN FTRUE(37)=FMISS ELSE CALL MAP(37,20,20,0) ENDIF C H CALL MAP(38,21,21,0) C CM CALL MAP(39,48,48,0) C CH CALL MAP(40,49,49,0) C WD C CALL MAP(41,0) C WP CALL MAP(42,56,57,0) C WH CALL MAP(43,58,59,0) C SD CALL MAP(44,60,61,0) C SP CALL MAP(45,62,63,0) C SH CALL MAP(46,64,65,0) C C1 FTRUE(47)=17. C C2 C CALL MAP(48,0) C SC CALL MAP(49,97,97,0) C SS CALL MAP(50,98,98,0) C A CALL MAP(51,93,93,0) C PPP CALL MAP(52,94,96,1) C IS CALL MAP(53,66,66,0) C ES CALL MAP(54,67,68,0) C RS CALL MAP(55,69,69,0) C II IF(IMMT(72:78).EQ.' ')THEN FTRUE(56)=FMISS ELSE FTRUE(56)=9. ENDIF C ID1 CALL MAP(57,72,72,-9) C ID2 CALL MAP(58,73,73,-9) C ID3 CALL MAP(59,74,74,-9) C ID4 CALL MAP(60,75,75,-9) C ID5 CALL MAP(61,76,76,-9) C ID6 CALL MAP(62,77,77,-9) C ID7 CALL MAP(63,78,78,-9) C ID8 C CALL MAP(64,0) C OS CALL MAP(65,70,70,0) C OP CALL MAP(66,71,71,0) C T2 IF(MEASUR(IMMT(89:89)).AND..NOT.MEASUR(IMMT(34:34)).OR. + COMPUT(IMMT(34:34)).AND..NOT.COMPUT(IMMT(89:89)))THEN FTRUE(67)=0. IF(IMMT(89:89).EQ.'2')FTRUE(67)=2. ELSE +IF(MEASUR(IMMT(34:34)).AND..NOT.MEASUR(IMMT(89:89)).OR. + COMPUT(IMMT(89:89)).AND..NOT.COMPUT(IMMT(34:34)))THEN FTRUE(67)=1. ELSE FTRUE(67)=FMISS ENDIF C IX CALL MAP(68,83,83,0) C WX C CALL MAP(69,0) C SX C CALL MAP(70,0) C IRD C A6 C CALL MAP(72,0) C N=0 SUPLEN=0 DO 790 J=12,RECL IF(J.NE.12 +.AND.J.NE.34 +.AND.J.NE.55 +.AND.(J.LT.81.OR.J.GT.82) +.AND.(J.LT.84.OR.J.GT.89) +.AND.J.LT.99)GOTO 790 N=N+1 SUP(N)=ICHAR(IMMT(J:J)) IF(IMMT(J:J).NE.' ')SUPLEN=N 790 CONTINUE CALL PUTLMR(1) NREC(2)=NREC(2)+1 GOTO 100 C 800 NREC(3)=NREC(3)+1 C EBCDIC IF(NINT(FTRUE(11)).EQ.46.OR. + NINT(FTRUE(11)).EQ.59)CALL ASCEBC(IMMT,IMMT,RECL) WRITE(2,'(A)')IMMT GOTO 100 810 IF(IEOF.NE.1)PRINT *,' IOSTAT=',IEOF 900 NREC(1)=NREC(1)-1 WRITE(7,'(I8,A,T27,I8,A,T53,I8,A,A,I3,A)') + NREC(1),' IMMT READ' +,NREC(1)-NREC(2),' IMMT REJECTED' +,NREC(2),' LMR6 WRITTEN' +,' (',NINT(FLOAT(NREC(2)*100)/NREC(1)),'%)' CALL PUTLMR(2) END C-----------------------------------------------------------------------3456789 SUBROUTINE MAP(I,J,K,P) IMPLICIT INTEGER(A-E,G-Z) C CHARACTER IMMT*131 COMMON //IMMT C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER) +,FORMAT(NUMBER),RPTID,INDXCK COMMON /DAT/CODED(NUMBER),FTRUE(NUMBER),FMISS COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR C LOGICAL INSIDE C INSIDE(A2,A1,A3)=.NOT.(A2.LT.A1.OR.A2.GT.A3) C IF(IMMT(J:K).EQ.' ')THEN IF(I.EQ.2.OR.I.EQ.3.OR.I.EQ.7.OR.I.EQ.8)GOTO 800 GOTO 820 ENDIF C IF(P.NE.-9)THEN IF(IMMT(J:K).EQ.'/')THEN IF(I.EQ.36.OR.I.EQ.38.OR.I.EQ.39.OR.I.EQ.40)THEN FTRUE(I)=10. ELSE GOTO 800 ENDIF ELSE CODED(I)=-1 DO 190 L=J,K IF(L.EQ.J.AND.I.GE.29.AND.I.LE.32)GOTO 190 IF(CODED(I).LT.0)THEN IF(IMMT(L:L).EQ.' ')GOTO 190 CODED(I)=0 ENDIF IF(LLT(IMMT(L:L),'0').OR.LGT(IMMT(L:L),'9'))GOTO 800 CODED(I)=CODED(I)*10+ICHAR(IMMT(L:L))-ICHAR('0') 190 CONTINUE IF(CODED(I).LT.0)GOTO 800 FTRUE(I)=CODED(I)*10**FLOAT(-P) ENDIF ENDIF C GOTO +(700,700,700,700,700,700, 7, 8,700,700 +,700,700,700,700,700,700,700,700, 19, 20 +, 21, 22, 23,700,700,700, 27, 28, 29, 30 +, 31, 32, 33,700,700,700, 37,700,700,700 +,700,700, 43, 44,700, 46,700,700,700,700 +,700,700,700,700,700,700, 64, 64, 64, 64 +, 64, 64, 64, 64,700,700,700,700,700,700)I C 7 IF(.NOT.INSIDE(NINT(FTRUE( 7)*10.),0,1800))GOTO 800 IF(IMMT(12:12).EQ.'5' +.OR.IMMT(12:12).EQ.'7') +FTRUE( 7)=AMOD(360.-FTRUE( 7),360.) GOTO 700 C 8 IF(IMMT(12:12).EQ.'1' +.OR.IMMT(12:12).EQ.'7')THEN ELSE + IF(IMMT(12:12).EQ.'3' +.OR.IMMT(12:12).EQ.'5')THEN FTRUE( 8)=-FTRUE( 8) ELSE GOTO 800 ENDIF FTRUE( 8)=AMOD(FTRUE( 8),100.) GOTO 700 C 19 IF(NINT(FTRUE(19)).EQ.0)THEN FTRUE(19)=361. ELSE IF(NINT(FTRUE(19)).EQ.990)THEN FTRUE(19)=362. ENDIF GOTO 700 C 20 IF(.NOT.INSIDE(NINT(FTRUE(20)),0,4) +.OR.NINT(FTRUE(20)).EQ.2)GOTO 800 GOTO 700 C 21 IF(IMMT(27:27).EQ.'0' +.OR.IMMT(27:27).EQ.'1')THEN ELSE + IF(IMMT(27:27).EQ.'3' +.OR.IMMT(27:27).EQ.'4')THEN FTRUE(21)=FTRUE(21)*.51 444 444 444 4 ELSE GOTO 800 ENDIF GOTO 700 C 22 IF(.NOT.INSIDE(NINT(FTRUE(22)),0,3))GOTO 800 FTRUE(22)=NINT(FTRUE(22))/2 GOTO 700 C 23 IF(NINT(FTRUE(23)).EQ.53)FTRUE(22)=2. GOTO 700 C 27 IF(NINT(FTRUE(27)*10.).LE.746)FTRUE(27)=FTRUE(27)+1000. GOTO 700 C 28 IF(.NOT.INSIDE(NINT(FTRUE(28)),3,5))GOTO 800 FTRUE(28)=AMOD(FTRUE(28),3.) GOTO 700 C 29 GOTO 32 C 30 GOTO 31 C 31 IF(IMMT(J:J).EQ.'5')THEN ELSE +IF(IMMT(J:J).EQ.'2'.OR. + IMMT(J:J).EQ.'6'.OR. + IMMT(J:J).EQ.'7')THEN FTRUE(I)=-FTRUE(I) ELSE GOTO 32 ENDIF GOTO 700 C 32 IF(IMMT(J:J).EQ.'0')THEN ELSE +IF(IMMT(J:J).EQ.'1')THEN FTRUE(I)=-FTRUE(I) ELSE GOTO 800 ENDIF GOTO 700 C 33 IF(.NOT.INSIDE(NINT(FTRUE(33)),0,7))GOTO 800 GOTO 700 C 37 IF(.NOT.INSIDE(NINT(FTRUE(37)),0,3))GOTO 800 IF(NINT(FTRUE(37)).GE.2)FTRUE(37)=3.-FTRUE(37) GOTO 700 C 43 GOTO 46 C 44 IF(NINT(FTRUE(44)).EQ.99)THEN FTRUE(44)=38. ELSE IF(.NOT.INSIDE(NINT(FTRUE(44)),0,36))GOTO 800 ENDIF GOTO 700 C 46 FTRUE(I)=FTRUE(I)/2. GOTO 700 C 64 FTRUE(I)=ICHAR(IMMT(J:K)) GOTO 700 C 700 IF(INSIDE(NINT(FTRUE(I)/FUNITS(I)) +,NINT(FTRUEL(I)/FUNITS(I)),NINT(FTRUEU(I)/FUNITS(I))))RETURN C 800 NERR=NERR+1 IF(NERR.GT.51)THEN PRINT *,' STOP SUBROUTINE MAP NERR.GT.51' STOP ENDIF ERRNUM(NERR)=I ERRLEN(NERR)=K-J+1 DO 810 M=1,ERRLEN(NERR) 810 ERR(M,NERR)=ICHAR(IMMT(J+M-1:)) IF(I.EQ.2.OR.I.EQ.3.OR.I.EQ.7.OR.I.EQ.8)THEN CALL SAVSUM3 NERR=NERR-1 ENDIF 820 FTRUE(I)=FMISS END C-----------------------------------------------------------------------3456789 BLOCK DATA BDLMR6 IMPLICIT INTEGER(A-E,G-Z) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER) +,FORMAT(NUMBER),RPTID,INDXCK C DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I= 1,10) 1/'B10 ', 1., 648., 1., 0., 10, 16,'(A4 ' 2,'YR ', 1770., 2024., 1., 1769., 8, 26,',A4 ' 3,'MO ', 1., 12., 1., 0., 4, 34,',A2 ' 4,'DY ', 1., 31., 1., 0., 5, 38,',A2 ' 5,'HR ', 0.00, 23.99, 0.01, -1.00, 12, 43,',A4 ' 6,'TI ', 0., 3., 1., -1., 4, 55,',A1 ' 7,'LON ', 0.00, 359.99, 0.01, -1.00, 16, 59,',A5 ' 8,'LAT ', -90.00, 90.00, 0.01,-9001.00, 15, 75,',A5 ' 9,'LI ', 0., 6., 1., -1., 4, 90,',A1 ' 1,'DCK ', 0., 999., 1., -1., 10, 94,',A3 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=11,20) 1/'SID ', 0., 99., 1., -1., 8, 104,',A2 ' 2,'PT ', 0., 15., 1., -1., 5, 112,',A2 ' 3,'QI ', 0., 2., 1., -1., 2, 117,',A1 ' 4,'DS ', 0., 13., 1., -1., 5, 119,',A2 ' 5,'DC ', 0., 2., 1., -1., 4, 124,',A1 ' 6,'TC ', 0., 1., 1., -1., 3, 128,',A1 ' 7,'PB ', 0., 2., 1., -1., 2, 131,',A1 ' 8,'DI ', 0., 6., 1., -1., 4, 133,',A1 ' 9,'D ', 1., 362., 1., 0., 9, 137,',A3 ' 2,'WI ', 0., 8., 1., -1., 4, 146,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=21,30) 1/'W ', 0.0, 102.2, 0.1, -1.0, 10, 150,',A4 ' 2,'VI ', 0., 2., 1., -1., 2, 160,',A1 ' 3,'VV ', 90., 99., 1., 89., 4, 162,',A2 ' 4,'WW ', 0., 99., 1., -1., 7, 166,',A2 ' 5,'W1 ', 0., 9., 1., -1., 4, 173,',A1 ' 6,'W2 ', 0., 9., 1., -1., 4, 177,',A1 ' 7,'SLP ', 870.0, 1074.6, 0.1, 8699.0, 11, 181,',A5 ' 8,'T1 ', 0., 9., 1., -1., 4, 192,',A1 ' 9,'AT ', -99.9, 99.9, 0.1, -1000.0, 11, 196,',A4 ' 3,'WBT ', -99.9, 99.9, 0.1, -1000.0, 11, 207,',A4 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=31,40) 1/'DPT ', -99.9, 99.9, 0.1, -1000.0, 11, 218,',A4 ' 2,'SST ', -99.9, 99.9, 0.1, -1000.0, 11, 229,',A4 ' 3,'SI ', 0., 12., 1., -1., 4, 240,',A2 ' 4,'N ', 0., 9., 1., -1., 4, 244,',A1 ' 5,'NH ', 0., 9., 1., -1., 4, 248,',A1 ' 6,'CL ', 0., 10., 1., -1., 4, 252,',A2 ' 7,'HI ', 0., 1., 1., -1., 2, 256,',A1 ' 8,'H ', 0., 10., 1., -1., 4, 258,',A2 ' 9,'CM ', 0., 10., 1., -1., 4, 262,',A2 ' 4,'CH ', 0., 10., 1., -1., 4, 266,',A2 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=41,50) 1/'WD ', 0., 38., 1., -1., 6, 270,',A2 ' 2,'WP ', 0., 30., 1., -1., 5, 276,',A2 ' 3,'WH ', 0., 49.5, 0.5, -1., 7, 281,',A2 ' 4,'SD ', 0., 38., 1., -1., 6, 288,',A2 ' 5,'SP ', 0., 30., 1., -1., 5, 294,',A2 ' 6,'SH ', 0., 49.5, 0.5, -1., 7, 299,',A2 ' 7,'C1 ', 0., 40., 1., -1., 7, 306,',A2 ' 8,'C2 ', 0., 40., 1., -1., 7, 313,',A2 ' 9,'SC ', 0., 9., 1., -1., 4, 320,',A1 ' 5,'SS ', 0., 9., 1., -1., 4, 324,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=51,60) 1/'A ', 0., 8., 1., -1., 4, 328,',A1 ' 2,'PPP ', 0.0, 51.0, 0.1, -1.0, 9, 332,',A3 ' 3,'IS ', 1., 5., 1., 0., 3, 341,',A1 ' 4,'ES ', 0., 99., 1., -1., 7, 344,',A2 ' 5,'RS ', 0., 4., 1., -1., 3, 351,',A1 ' 6,'II ', 0., 10., 1., -1., 4, 354,',A2 ' 7,'ID1 ', 33., 95., 1., 32., 6, 358,', A1' 8,'ID2 ', 33., 95., 1., 32., 6, 364,', A1' 9,'ID3 ', 33., 95., 1., 32., 6, 370,', A1' 6,'ID4 ', 33., 95., 1., 32., 6, 376,', A1'/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=61,70) 1/'ID5 ', 33., 95., 1., 32., 6, 382,', A1' 2,'ID6 ', 33., 95., 1., 32., 6, 388,', A1' 3,'ID7 ', 33., 95., 1., 32., 6, 394,', A1' 4,'ID8 ', 33., 95., 1., 32., 6, 400,', A1' 5,'OS ', 0., 6., 1., -1., 4, 406,',A1 ' 6,'OP ', 0., 9., 1., -1., 4, 410,',A1 ' 7,'T2 ', 0., 6., 1., -1., 3, 414,',A1 ' 8,'IX ', 1., 6., 1., 0., 4, 417,',A1 ' 9,'WX ', 1., 1., 1., 0., 1, 421,',A1 ' 7,'SX ', 1., 1., 1., 0., 1, 422,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=71,73) 1/'IRD ', 1., 255., 1., 0., 8, 423,',A3 ' 2,'A6 ', 0., 1., 1., -1., 2, 431,',A1 ' 3,'CK ', 0., 30., 1., 0., 5, 443,',A2)'/ C DATA INDXCK/NUMBER/,RPTID/6/ END C-----------------------------------------------------------------------3456789 LOGICAL FUNCTION B10XY(X,Y,B10) IMPLICIT INTEGER(A-E,G-Z) C B10XY=.FALSE. IF(X.LT.0.OR.X.GT.35999.OR.ABS(Y).GT.9000)RETURN C IF(X.EQ.0.OR.X.GT.18000)THEN C=35-MOD(36000-X,36000)/1000 ELSE C=X/1000 ENDIF C R=8-SIGN(MIN(ABS(Y),8999)/1000,Y) IF(Y.LT.0)R=R+1 C B10=R*36+MOD(C+36-3,36)+1 B10XY=.TRUE. END c-----------------------------------------------------------------------3456789 subroutine ebcasc(ebc,asc,num) c c convert num characters from ebcdic to ascii, ebc is ebcdic input string c and asc is ascii output string, ebc and asc may be the same string. c character ebc*(*),asc*(*) do 20 i=1,num asc(i:i)=char(iasc(ichar(ebc(i:i)))) 20 continue return end c-----------------------------------------------------------------------3456789 subroutine ascebc(asc,ebc,num) c c convert num characters from ascii to ebcdic, asc is ascii input string c and ebc is ebcdic output string, asc and ebc may be the same string. c character asc*(*),ebc*(*) do 20 i=1,num ebc(i:i)=char(iebc(ichar(asc(i:i)))) 20 continue return end c-----------------------------------------------------------------------3456789 function iasc(iebc) c c convert the ichar of a character from ebcdic to ascii c c the conversion table corresponds to the NCAR import/export conversion c and should give the same results. c dimension ntab(256) data ntab/ a 000,001,002,003,156,009,134,127,151,141,142,011,012,013,014,015, b 016,017,018,019,157,133,008,135,024,025,146,143,028,029,030,031, c 128,129,130,131,132,010,023,027,136,137,138,139,140,005,006,007, d 144,145,022,147,148,149,150,004,152,153,154,155,020,021,158,026, e 032,160,161,162,163,164,165,166,167,168,213,046,060,040,043,124, f 038,169,170,171,172,173,174,175,176,177,033,036,042,041,059,094, g 045,047,178,179,180,181,182,183,184,185,229,044,037,095,062,063, h 186,187,188,189,190,191,192,193,194,096,058,035,064,039,061,034, i 195,097,098,099,100,101,102,103,104,105,196,197,198,199,200,201, j 202,106,107,108,109,110,111,112,113,114,203,204,205,206,207,208, k 209,126,115,116,117,118,119,120,121,122,210,211,212,091,214,215, l 216,217,218,219,220,221,222,223,224,225,226,227,228,093,230,231, m 123,065,066,067,068,069,070,071,072,073,232,233,234,235,236,237, n 125,074,075,076,077,078,079,080,081,082,238,239,240,241,242,243, o 092,159,083,084,085,086,087,088,089,090,244,245,246,247,248,249, p 048,049,050,051,052,053,054,055,056,057,250,251,252,253,254,255/ iasc=ntab(iebc+1) return end c-----------------------------------------------------------------------3456789 function iebc(iasc) c c convert the ichar of a character from ascii to ebcdic c c the conversion table corresponds to the NCAR import/export conversion c and should give the same results. c dimension ntab(256) data ntab/ a 000,001,002,003,055,045,046,047,022,005,037,011,012,013,014,015, b 016,017,018,019,060,061,050,038,024,025,063,039,028,029,030,031, c 064,090,127,123,091,108,080,125,077,093,092,078,107,096,075,097, d 240,241,242,243,244,245,246,247,248,249,122,094,076,126,110,111, e 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, f 215,216,217,226,227,228,229,230,231,232,233,173,224,189,095,109, g 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, h 151,152,153,162,163,164,165,166,167,168,169,192,079,208,161,007, i 032,033,034,035,036,021,006,023,040,041,042,043,044,009,010,027, j 048,049,026,051,052,053,054,008,056,057,058,059,004,020,062,225, k 065,066,067,068,069,070,071,072,073,081,082,083,084,085,086,087, l 088,089,098,099,100,101,102,103,104,105,112,113,114,115,116,117, m 118,119,120,128,138,139,140,141,142,143,144,154,155,156,157,158, n 159,160,170,171,172,074,174,175,176,177,178,179,180,181,182,183, o 184,185,186,187,188,106,190,191,202,203,204,205,206,207,218,219, p 220,221,222,223,234,235,236,237,238,239,250,251,252,253,254,255/ iebc=ntab(iasc+1) return end C-----------------------------------------------------------------------3456789 SUBROUTINE LOPEN(UNIT,RECL,BUFL) IMPLICIT INTEGER(A-E,G-Z) CHARACTER REC*(*) CHARACTER BUF*18600 PARAMETER(UNITS=2) DIMENSION IBUF(6,UNITS),BUF(UNITS) SAVE C IF(UNIT.GT.UNITS)STOP 'UNIT' IF(BUFL.GT.LEN(BUF(UNIT)))STOP 'BUFL' IBUF(1,UNIT)=0 IBUF(2,UNIT)=RECL IBUF(3,UNIT)=0 IBUF(4,UNIT)=BUFL+LEN(BUF(UNIT))*DIM(1,BUFL) IBUF(5,UNIT)=0 IBUF(6,UNIT)=0 DO 90 I=1,LEN(BUF(UNIT)) 90 BUF(UNIT)(I:I)=CHAR(0) RETURN C ENTRY LREAD(UNIT,END,REC) 100 IF(IBUF(1,UNIT)+IBUF(2,UNIT).GT.IBUF(3,UNIT))THEN 101 CALL RDBUF(UNIT,BUF(UNIT),IBUF(3,UNIT),(IBUF(4,UNIT)-1)/8+1,END) IBUF(1,UNIT)=0 IBUF(3,UNIT)=IBUF(3,UNIT)*8 IBUF(5,UNIT)=IBUF(5,UNIT)*END+END GOTO(100,101,102)IBUF(5,UNIT)+1 102 RETURN ENDIF REC(1:IBUF(2,UNIT)) +=BUF(UNIT)(IBUF(1,UNIT)+1:IBUF(1,UNIT)+IBUF(2,UNIT)) IBUF(1,UNIT)=IBUF(1,UNIT)+IBUF(2,UNIT) RETURN C ENTRY LWRITE(UNIT,REC) IF(IBUF(1,UNIT)+IBUF(2,UNIT).GT.IBUF(4,UNIT))THEN CALL WRBUF(UNIT,BUF(UNIT),(IBUF(1,UNIT)-1)/8+1) IBUF(1,UNIT)=0 ENDIF BUF(UNIT)(IBUF(1,UNIT)+1:IBUF(1,UNIT)+IBUF(2,UNIT)) +=REC(1:IBUF(2,UNIT)) IBUF(1,UNIT)=IBUF(1,UNIT)+IBUF(2,UNIT) RETURN C ENTRY LCLOSE(UNIT) IF(IBUF(1,UNIT).GT.0)THEN CALL WRBUF(UNIT,BUF(UNIT),(IBUF(1,UNIT)-1)/8+1) IBUF(1,UNIT)=0 ENDIF END C-----------------------------------------------------------------------3456789 SUBROUTINE RDBUF(UN,BUF,MBUF,NBUF,END) IMPLICIT INTEGER(A-E,G-Z) REAL UNIT DIMENSION BUF(NBUF) C BUFFER IN(UN,0)(BUF(1),BUF(NBUF)) C MBUF=LENGTH(UN) C END=NINT(UNIT(UN))+1 GOTO(1000,1000)END+1 STOP 'UNIT' 1000 END C-----------------------------------------------------------------------3456789 SUBROUTINE WRBUF(UN,BUF,NBUF) IMPLICIT INTEGER(A-E,G-Z) REAL UNIT DIMENSION BUF(NBUF) C BUFFER OUT(UN,0)(BUF(1),BUF(NBUF)) C GOTO(1000)NINT(UNIT(UN))+2 STOP 'UNIT' 1000 END C-----------------------------------------------------------------------3456789 SUBROUTINE PBYTE(P,U,Q,B) IMPLICIT INTEGER(A-Z) IF(U.LT.0 .OR. U.GT.2**B-1)STOP 'SBYTE' CALL SBYTE(P,U,Q,B) END C-----------------------------------------------------------------------3456789 SUBROUTINE PBYTES(P,U,Q,B,S,N) IMPLICIT INTEGER(A-Z) DIMENSION U(*) DO 1 I=1,N 1 IF(U(I).LT.0 .OR. U(I).GT.2**B-1)STOP 'SBYTES' CALL SBYTES(P,U,Q,B,S,N) END C-----------------------------------------------------------------------3456789 FUNCTION PUTATT(RPT,AL,AD) C PACK ATTACHMENTS RETURNING LENGTH OF RPT IN BITS C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) RPT DIMENSION AL(15),AD(255,15) C PUTATT=452 AC=0 DO 190 AID=1,15 IF(AL(AID).EQ.0)GOTO 190 CALL PBYTE(RPT,AID,PUTATT+8,4) CALL PBYTE(RPT,AL(AID),PUTATT,8) CALL PBYTES(RPT,AD(1,AID),PUTATT+12,4,0,AL(AID)) PUTATT=PUTATT+12+4*AL(AID) AC=AC+1 190 CONTINUE CALL PBYTE(RPT,AC,452-4,4) END C-----------------------------------------------------------------------3456789 SUBROUTINE PUTERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR) C PUT ERROR ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51) C AL(5)=0 DO 190 J=1,NERR AD(AL(5)+1,5)=ERRNUM(J)/16 AD(AL(5)+2,5)=MOD(ERRNUM(J),16) AD(AL(5)+3,5)=ERRLEN(J) AL(5)=AL(5)+3 DO 190 I=1,ERRLEN(J) AD(AL(5)+1,5)=ERR(I,J)/16 AD(AL(5)+2,5)=MOD(ERR(I,J),16) AL(5)=AL(5)+2 190 CONTINUE IF(AL(5).GT.255)STOP 'AL(5)' END C-----------------------------------------------------------------------3456789 SUBROUTINE PUTLMR(JEOF) IMPLICIT INTEGER(A-E,G-Z) C BITS PER WORD PARAMETER(BPW=32) C PARAMETER(DIM BUF=(1006*64-1)/BPW+1) DIMENSION BUF(DIM BUF) DATA (BUF(I),I=1,6)/6*0/ DATA UNIT/3/ C PARAMETER(BPR=452+(3+255)*4*15,DIM RPT=(BPR-1)/BPW+1) DIMENSION RPT(DIM RPT) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) COMMON /LMR6/FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER) COMMON /LMR6/OFFSET(NUMBER),FORMAT(NUMBER),RPTID,INDXCK C COMMON /DAT/CODED(NUMBER),FTRUE(NUMBER),FMISS DATA FMISS/-999./ C DIMENSION AL(15),AD(255,15) DATA AL/15*0/ C COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR DATA SUPLEN/0/ DATA NERR/0/ C CHARACTER PATH*27 CHARACTER MMDDYY*8,HHMMSS*8 DIMENSION B10YR(4) DATA B10YR/999,0,9999,0/ SAVE C GOTO(100,200)JEOF STOP 'JEOF' C 100 CALL PUTSUP(AL,AD,SUP,SUPLEN) CALL PUTERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR) DO 110 I=1,DIM RPT 110 RPT(I)=0 CALL PUTRPT(RPT,CODED,FTRUE,FMISS +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK) CALL RPTOUT(UNIT,BUF,RPT,(PUTATT(RPT,AL,AD)-1)/64+1,JEOF) B10YR(1)=MIN(B10YR(1),NINT(FTRUE(1))) B10YR(2)=MAX(B10YR(2),NINT(FTRUE(1))) B10YR(3)=MIN(B10YR(3),NINT(FTRUE(2))) B10YR(4)=MAX(B10YR(4),NINT(FTRUE(2))) CALL SAVSUM1 CALL SAVSUM2 RETURN C 200 CALL RPTOUT(UNIT,BUF,RPT,998,JEOF) READ(4,'(A)')PATH CALL DATE(MMDDYY) CALL CLOCK(HHMMSS) WRITE(7,'(A,2I4,2I5,2I8,I10,2A9,I4)')PATH,B10YR +,BUF(2),BUF(3),BUF(4),MMDDYY,HHMMSS,1 CALL PRNSUM1 CALL PRNSUM2 CALL PRNSUM3 END C-----------------------------------------------------------------------3456789 SUBROUTINE PUTRPT(RPT,CODED,FTRUE,FMISS +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK) C CONVERT TRUE TO CODED VALUES AND PACK REPORT C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) RPT DIMENSION CODED(*),FTRUE(*),FUNITS(*),FBASE(*),BITS(*),OFFSET(*) C RPT(2:2)=CHAR(MOD(RPTID,16)) CODED(INDXCK)=0 DO 190 I=1,NUMBER IF(I.EQ.INDXCK)GOTO 190 IF(FTRUE(I).EQ.FMISS)THEN CODED(I)=0 ELSE CODED(I)=NINT(FTRUE(I)/FUNITS(I)-FBASE(I)) IF(CODED(I).LT.1.OR.CODED(I).GT.2**BITS(I)-1)THEN PRINT *,' FTRUE(',I,') = ',FTRUE(I) PRINT *,' FTRUE = ',(FTRUE(J),J=1,NUMBER) STOP 'SBYTE' ENDIF CODED(INDXCK)=CODED(INDXCK)+CODED(I) C IF RPT.NE.NULL SBYTE AFTER ENDIF!!! CALL SBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) ENDIF C CALL SBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) 190 CONTINUE I=INDXCK CODED(I)=MOD(CODED(I),2**BITS(I)-1) CALL SBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) FTRUE(I)=CODED(I) END C-----------------------------------------------------------------------3456789 SUBROUTINE PUTSID(SID) REAL SID CHARACTER LIST*160 COMMON /TAPE/LIST I=1 100 READ(8,'(A)',IOSTAT=IOS)LIST IF(I.EQ.1)THEN IF(IOS.NE.0)STOP 'TAPELIST' ELSE IF(IOS.GE.0)STOP 'TAPELIST' RETURN ENDIF SID=ISTR(LIST(12:)) I=2 GOTO 100 END C-----------------------------------------------------------------------3456789 SUBROUTINE PUTIMM(SID,C2,IRD,RECL) REAL SID,C2,IRD INTEGER RECL CHARACTER LIST*160 COMMON /TAPE/LIST INTEGER YYMM MMJUL(YYMM)=(YYMM/100-82)*12+MOD(YYMM,100) C CALL PUTSID(SID) C IF(INDEX(LIST,'C2=').EQ.0)STOP 'TAPELIST' IF(INDEX(LIST,'IRD=').EQ.0)STOP 'TAPELIST' IF(INDEX(LIST,'RECL=').EQ.0)STOP 'TAPELIST' C2=ISTR(LIST(INDEX(LIST,'C2=')+3:)) C IRD=ISTR(LIST(INDEX(LIST,'IRD=')+4:)) RECL=ISTR(LIST(INDEX(LIST,'RECL=')+5:)) C C IRD=MMJUL(NINT(IRD)) END C-----------------------------------------------------------------------3456789 INTEGER FUNCTION ISTR(STR) CHARACTER STR(*) ISTR=0 I=1 100 IF(STR(I).GE.'0'.AND.STR(I).LE.'9')THEN ISTR=ISTR*10+ICHAR(STR(I))-ICHAR('0') I=I+1 GOTO 100 ENDIF IF(STR(I).NE.' '.OR.I.EQ.1)STOP 'TAPELIST' END C-----------------------------------------------------------------------3456789 SUBROUTINE PUTSUP(AL,AD,SUP,SUPLEN) C PUT SUPPLEMENTAL ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION SUP(255) DIMENSION SHIP(256) DATA SHIP +/32*15,10,5*15,202,3*15,234,203,15,218,15,225 +,0,1,2,3,4,5,6,7,8,9,7*15 +,193,194,195,196,197,198,199,200,201 +,209,210,211,212,213,214,215,216,217 +,226,227,228,229,230,231,232,233,32*15,192,15,208,130*15/ C AL(4)=0 DO 9 I=1,SUPLEN AL(4)=AL(4)+1 C AD(AL(4),4)=SHIP(SUP(I)+1) GOTO(9,9,9,9,9,9,9,9,9,9,11,11,14,14,14,15)AD(AL(4),4)+1 C 14 AD(AL(4)+1,4)=MOD(AD(AL(4),4),16) AD(AL(4),4)=AD(AL(4),4)/16 AL(4)=AL(4)+1 GOTO 9 C 11 IF(I.LT.3.OR.SUP(I-2).NE.SUP(I).OR.SUP(I-1).NE.SUP(I))GOTO 9 IF(AD(AL(4)-2,4).EQ.11.AND.AD(AL(4)-1,4).LT.15)THEN AD(AL(4)-1,4)=AD(AL(4)-1,4)+1 AL(4)=AL(4)-1 ELSE IF(AD(AL(4)-2,4).EQ.10.AND.AD(AL(4)-1,4).EQ.10)THEN AD(AL(4)-2,4)=11 AD(AL(4)-1,4)=0 AL(4)=AL(4)-1 ENDIF GOTO 9 C 15 AD(AL(4)+2,4)=MOD(SUP(I),16) AD(AL(4)+1,4)=SUP(I)/16 AL(4)=AL(4)+2 9 CONTINUE IF(AL(4).GT.255)STOP 'AL(4)' END C-----------------------------------------------------------------------3456789 SUBROUTINE SAVSUM1 C SUMMARY OF FIELDS C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) COMMON /LMR6/FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER) COMMON /LMR6/OFFSET(NUMBER),FORMAT(NUMBER),RPTID,INDXCK COMMON /DAT/CODED(NUMBER),FTRUE(NUMBER),FMISS COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR C DIMENSION SUM1(NUMBER),SUM2(NUMBER),SUM3(NUMBER) SAVE SUM1,SUM2,SUM3 DATA SUM1/NUMBER*0/,SUM2/NUMBER*0/,SUM3/NUMBER*0/ PC(A1,A2)=NINT(FLOAT(A1*100)/MAX(A2,1)) C DO 190 I=1,NUMBER-1 IF(FTRUE(I).NE.FMISS)THEN SUM1(I)=SUM1(I)+1 ELSE SUM2(I)=SUM2(I)+1 ENDIF 190 CONTINUE DO 290 I=1,NERR SUM3(ERRNUM(I))=SUM3(ERRNUM(I))+1 290 CONTINUE RETURN C ENTRY PRNSUM1 WRITE(7,'(1X,A)')'SUMMARY OF FIELDS' WRITE(7,'(A6,2X,A10,A11,A13,2X,A10,A11,A13)')'FIELD' +,'# EXTANT','# MISSING','# ERRONEOUS' +,'% EXTANT','% MISSING','% ERRONEOUS' TOTAL=SUM1(1)+SUM2(1) WRITE(7,'(I3,1X,A3,1X,I10,I11,I13,2X,I10,I11,I13)')(I,FIELD(I) +,SUM1(I),SUM2(I),SUM3(I) +,PC(SUM1(I),TOTAL),PC(SUM2(I),TOTAL),PC(SUM3(I),TOTAL) +,I=1,NUMBER-1) END C-----------------------------------------------------------------------3456789 SUBROUTINE SAVSUM2 C SUMMARY OF ERROR ATTACHMENTS C IMPLICIT INTEGER(A-E,G-Z) COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR C PARAMETER(NMAX=5000) CHARACTER*56 STR,ARR1(NMAX) DIMENSION ARR2(NMAX) SAVE ARR1,ARR2,N DATA N/0/ C DO 290 J=1,NERR CALL GETSTR(STR,ERRNUM(J),ERRLEN(J),ERR(1,J)) CALL SAVSTR(STR,ARR1,ARR2,N,NMAX) 290 CONTINUE RETURN C ENTRY PRNSUM2 WRITE(7,'(1X,A)')'SUMMARY OF ERROR ATTACHMENTS' WRITE(7,'(4A)')' FIELD-',' INPUT----------' +,' HEXADECIMAL-------------------',' --------------FREQUENCY' CALL PRNSTR(STR,ARR1,ARR2,N,NMAX) END C-----------------------------------------------------------------------3456789 SUBROUTINE SAVSUM3 C SUMMARY OF ADDITIONAL INFORMATION C IMPLICIT INTEGER(A-E,G-Z) COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR C PARAMETER(NMAX=5000) CHARACTER*56 STR,ARR1(NMAX) DIMENSION ARR2(NMAX) SAVE ARR1,ARR2,N DATA N/0/ C CALL GETSTR(STR,ERRNUM(NERR),ERRLEN(NERR),ERR(1,NERR)) CALL SAVSTR(STR,ARR1,ARR2,N,NMAX) RETURN C ENTRY PRNSUM3 WRITE(7,'(1X,A)')'SUMMARY OF ADDITIONAL INFORMATION' WRITE(7,'(4A)')' FIELD-',' INPUT----------' +,' HEXADECIMAL-------------------',' --------------FREQUENCY' CALL PRNSTR(STR,ARR1,ARR2,N,NMAX) END C-----------------------------------------------------------------------3456789 SUBROUTINE SAVSTR(STR,ARR1,ARR2,N,NMAX) C FREQUENCY OF A STRING C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) STR,ARR1(NMAX) DIMENSION ARR2(NMAX) C DO 190 M=1,N IF(STR.NE.ARR1(M))GOTO 190 ARR2(M)=ARR2(M)+1 RETURN 190 CONTINUE N=N+1 IF(N.GT.NMAX-1)THEN PRINT *,' STOP SUBROUTINE SAVSTR N.GT.NMAX-1' STOP ENDIF ARR1(N)=STR ARR2(N)=1 RETURN C ENTRY PRNSTR(STR,ARR1,ARR2,N,NMAX) DO 290 I=1,N-1 M=I DO 280 J=I+1,N IF(LLT(ARR1(J),ARR1(M)))M=J 280 CONTINUE IF(M.NE.I)THEN ARR1(NMAX)=ARR1(I) ARR2(NMAX)=ARR2(I) ARR1(I)=ARR1(M) ARR2(I)=ARR2(M) ARR1(M)=ARR1(NMAX) ARR2(M)=ARR2(NMAX) ENDIF 290 CONTINUE WRITE(7,'(A,I22)')(ARR1(I),ARR2(I),I=1,N) END C-----------------------------------------------------------------------3456789 SUBROUTINE GETSTR(STR,ERRNUM,ERRLEN,ERR) C WRITE ERROR FROM ERROR ATTACHMENT TO STR C IMPLICIT INTEGER(A-E,G-Z) DIMENSION ERR(*) CHARACTER*(*) STR CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) COMMON /LMR6/FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER) COMMON /LMR6/OFFSET(NUMBER),FORMAT(NUMBER),RPTID,INDXCK C WRITE(STR,'(I3,1X,A3,1X,15A1,1X,15Z2)')ERRNUM,FIELD(ERRNUM) +,(CHAR(MAX(MOD(MIN(ERR(I),127),127),32)),I=1,ERRLEN) +,(' ',I=ERRLEN+1,15) +,(ERR(I),I=1,ERRLEN) END EOR EOF kobe1889 EOF kobe1890 EOF kobe1891 EOF kobe1892 EOF kobe1893 EOF kobe1894 EOF kobe1895 EOF kobe1898 EOF kobe1899 EOF kobe1900 EOF kobe1901 EOF kobe1902 EOF kobe1903 EOF kobe1904 EOF kobe1905 EOF kobe1906 EOF kobe1907 EOF kobe1908 EOF kobe1909 EOF kobe1910 EOF kobe1911 EOF kobe1912 EOF kobe1913 EOF kobe1914 EOF kobe1915 EOF kobe1916 EOF kobe1917 EOF kobe1918 EOF kobe1919 EOF kobe1920 EOF kobe1921 EOF kobe1922 EOF kobe1923 EOF kobe1924 EOF kobe1925 EOF kobe1926 EOF kobe1927 EOF kobe1928 EOF kobe1929 EOF kobe1930 EOF kobe1931 EOF kobe1932 EOF kobe1933 EOF kobe1935 EOF kobe1936 EOF kobe1937 EOF kobe1938 EOF kobe1939 EOF kobe1940