cat > p.f <<\EOR C=============================================================================C C Comprehensive Ocean-Atmosphere Data Set (COADS): Fortran 77 Program+Shell C C Filename:level: rdcmr5:01A 9 February 2000 C C Function: Read/print: Compressed Marine Reports (CMR5) Author: S.Lubker C C=============================================================================C C Software documentation for the (modifiable) example program {rdcmr} and C the (invariant) user-interface routines {prnfld,getrpt,prnrpt}: C C As provided {rdcmr}: (a) Prints the program name and level, and FILE (up to C 80 characters supplied by the user from standard input). Also, {prnfld} C prints a 5-line header for all the regular and location fields in the CMR5 C format. (b) Reads a report (from UNIT=1) via an unformatted direct-access C read, and unpacks all the regular and location fields via {getrpt}. This C makes coded (integer) values available in array CODED (zero for missing C data), and true (floating point) values available in array FTRUE (FMISS for C missing data). (c) For location and regular fields, a PARAMETER statement C relates each field abbreviation to an FTRUE (or CODED) array location; this C facilitates usage such as FTRUE(DAY), to obtain the floating point value C for day. (d) Prints a report via {prnrpt}, under the aforementioned field C headings. For readability, blank is printed for missing data. (e) The C program iterates (to step b) reading reports until an end-of-file (EOF) is C encountered. Caution: IMPLICIT INTEGER(A-E,G-Z) is used; users may need to C explicitly type additional variables when modifying this program. C C Notes on the printed format: In the header, field abbreviations are listed C vertically. The checksum (CK) is also printed. All decimal points are C removed by the following uniform procedure. Each FTRUE value is divided by C the corresponding units, e.g., S=10.4/0.1 = 104 printed. C C The following optional features are initially deactivated in the Fortran C code; they may be activated by changing the appropriate Fortran comment C lines to executable statements, i.e., remove the letter "C" from column 1: C (a) The call to {b2lola} can be activated to return the E longitude (BLO) C and latitude (BLA; degrees +N, -S) of the lower-left (SW) corner of 2-degree C box B2. (b) The test for NREC greater than 50 can be activated to stop C before reading/printing the entire file. C C External libraries: None. C Machine dependencies: None known. C For more information: See (electronic document). C-----------------------------------------------------------------------3456789 PROGRAM RDCMR IMPLICIT INTEGER(A-E,G-Z) C DATA UNIT/1/,FMISS/-999.9/ C CHARACTER RPT*24 C PARAMETER(BOX10=1,MONTH=2,BOX2=3,YEAR=4,DAY=5,HOUR=6,X=7,Y=8,S=9 +,BI=10,A=11,DP=12,TI=13,U=14,V=15,DI=16,WI=17,P=18,C=19,NH=20 +,CL=21,H=22,HI=23,CM=24,CH=25,ST=26,PW=27,CD=28,LF=29,SF=30,AF=31 +,RF=32,WF=33,PF=34,CK=35) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=35) COMMON /CMR5/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER) +,FORMAT(NUMBER),RPTID,INDXCK C DIMENSION CODED(NUMBER),FTRUE(NUMBER) REAL B2,BLO,BLA EQUIVALENCE(FTRUE(BOX2),B2) C CHARACTER FILE*80 C READ(*,'(A)')FILE PRINT '(A)',' RDCMR5.01A < '//FILE C C PRINT REPORT HEADER CALL PRNFLD(FIELD,FORMAT,NUMBER) C C OPEN TO READ BINARY DATA (MACHINE-DEPENDENT MODIFICATIONS MAY BE NEEDED) OPEN(UNIT,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=LEN(RPT) +,STATUS='OLD',FILE=FILE) C INITIALIZE NUMBER OF RECORDS READ NREC=0 C C READ REPORT (MACHINE-DEPENDENT MODIFICATIONS MAY BE NEEDED) 100 READ(UNIT,REC=NREC+1,IOSTAT=EOF)RPT C EOF OF ZERO INDICATES A SUCCESSFUL READ IF(EOF.NE.0)GOTO 900 C INCREMENT NUMBER OF RECORDS READ NREC=NREC+1 C C UNPACK REPORT AND CONVERT CODED TO TRUE VALUES CALL GETRPT(RPT,CODED,FTRUE,FMISS +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK) C CALL B2LOLA(B2,BLO,BLA) C C PRINT REPORT CALL PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER) C C STOP AFTER SEVERAL REPORTS HAVE BEEN READ C IF(NREC.GE.50)STOP 'REMOVE STOP TO READ ALL REPORTS' GOTO 100 C C END OF FILE IF EOF IS NEGATIVE ELSE AN ERROR 900 PRINT *,'REPORTS ',NREC,', EOF ',EOF END C=============================================================================C C WARNING: Code beyond this point should not require any modification. C C=============================================================================C C-----------------------------------------------------------------------3456789 BLOCK DATA BDCMR5 IMPLICIT INTEGER(A-E,G-Z) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=35) COMMON /CMR5/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER) +,FORMAT(NUMBER),RPTID,INDXCK C DATA FIELD/'BOX10 ','MONTH ','BOX2 ','YEAR ','DAY ', +'HOUR ','X ','Y ','S ','BI ','A ', +'DP ','TI ','U ','V ','DI ','WI ', +'P ','C ','NH ','CL ','H ','HI ', +'CM ','CH ','ST ','PW ','CD ','LF ', +'SF ','AF ','RF ','WF ','PF ','CK '/ C DATA FTRUEL/3*1.,1800.,1.,3*0.,-5.,0.,-88.,2*0.,2*-102.2,2*0.,870. +,17*0./ C DATA FTRUEU/648.,12.,16202.,2054.,31.,23.,2*2.,40.,2.,58.,70.,5. +,2*102.2,5.,1.,1074.6,2*9.,2*10.,1.,2*10.,7.,99.,999.,0.,5*2.,30./ C DATA FUNITS/6*1.,3*.1,1.,2*.1,1.,2*.1,2*1.,.1,17*1./ C DATA FBASE/3*0,1799,0,3*-1,-51,-1,-881,2*-1,2*-1023,2*-1,8699 +,16*-1,0/ C DATA BITS/10,4,14,8,4*5,9,2,11,10,3,2*11,3,2,11,4*4,2,3*4,7,10 +,1,5*2,5/ C DATA OFFSET/ + 0, 10, 14, 28, 36, 41, 46, 51, 56, 65, 67, 78, 88, 91,102,113 +,116,118,129,133,137,141,145,147,151,155,159,166,176,177,179,181 +,183,185,187/ C DATA FORMAT/ +'(A4 ',',A2 ',',A5 ',',A4 ',',A2 ',',A2 ',',A2 ',',A2 ',',A3 ', +',A1 ',',A4 ',',A3 ',',A1 ',',A5 ',',A5 ',',A1 ',',A1 ',',A5 ', +',A1 ',',A1 ',',A2 ',',A2 ',',A1 ',',A2 ',',A2 ',',A1 ',',A2 ', +',A3 ',',A1 ',',A1 ',',A1 ',',A1 ',',A1 ',',A1 ',',A2)'/ C DATA RPTID/5/,INDXCK/NUMBER/ END C-----------------------------------------------------------------------3456789 SUBROUTINE GETRPT(RPT,CODED,FTRUE,FMISS +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK) C UNPACK REPORT AND CONVERT CODED TO TRUE VALUES C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) RPT DIMENSION CODED(*),FTRUE(*),FUNITS(*),FBASE(*),BITS(*),OFFSET(*) C C IF(MOD(ICHAR(RPT(2:2)),16).NE.RPTID)STOP 'RPTID ERROR' CALL UNPACK(RPT,CODED) FTRUE(INDXCK)=CODED(INDXCK) CODED(INDXCK)=0 DO 190 I=1,NUMBER IF(I.EQ.INDXCK)GOTO 190 IF(CODED(I).EQ.0)THEN FTRUE(I)=FMISS ELSE FTRUE(I)=(CODED(I)+FBASE(I))*FUNITS(I) CODED(INDXCK)=CODED(INDXCK)+CODED(I) ENDIF 190 CONTINUE CODED(INDXCK)=MOD(CODED(INDXCK),2**BITS(INDXCK)-1) IF(FTRUE(INDXCK).NE.CODED(INDXCK))STOP 'CHECKSUM ERROR' END C-----------------------------------------------------------------------3456789 SUBROUTINE UNPACK(RPT,CODED) C UNPACK REPORT C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) RPT DIMENSION CODED(*) C CODED(1)=ICHAR(RPT(1:1))*4+ICHAR(RPT(2:2))/64 CODED(2)=MOD(ICHAR(RPT(2:2)),64)/4 CODED(3)=(MOD(ICHAR(RPT(2:2)),4)*256+ICHAR(RPT(3:3)))*16 ++ICHAR(RPT(4:4))/16 CODED(4)=MOD(ICHAR(RPT(4:4)),16)*16+ICHAR(RPT(5:5))/16 CODED(5)=MOD(ICHAR(RPT(5:5)),16)*2+ICHAR(RPT(6:6))/128 CODED(6)=MOD(ICHAR(RPT(6:6)),128)/4 CODED(7)=MOD(ICHAR(RPT(6:6)),4)*8+ICHAR(RPT(7:7))/32 CODED(8)=MOD(ICHAR(RPT(7:7)),32) CODED(9)=ICHAR(RPT(8:8))*2+ICHAR(RPT(9:9))/128 CODED(10)=MOD(ICHAR(RPT(9:9)),128)/32 CODED(11)=MOD(ICHAR(RPT(9:9)),32)*64+ICHAR(RPT(10:10))/4 CODED(12)=MOD(ICHAR(RPT(10:10)),4)*256+ICHAR(RPT(11:11)) CODED(13)=ICHAR(RPT(12:12))/32 CODED(14)=MOD(ICHAR(RPT(12:12)),32)*64+ICHAR(RPT(13:13))/4 CODED(15)=(MOD(ICHAR(RPT(13:13)),4)*256+ICHAR(RPT(14:14)))*2 ++ICHAR(RPT(15:15))/128 CODED(16)=MOD(ICHAR(RPT(15:15)),128)/16 CODED(17)=MOD(ICHAR(RPT(15:15)),16)/4 CODED(18)=(MOD(ICHAR(RPT(15:15)),4)*256+ICHAR(RPT(16:16)))*2 ++ICHAR(RPT(17:17))/128 CODED(19)=MOD(ICHAR(RPT(17:17)),128)/8 CODED(20)=MOD(ICHAR(RPT(17:17)),8)*2+ICHAR(RPT(18:18))/128 CODED(21)=MOD(ICHAR(RPT(18:18)),128)/8 CODED(22)=MOD(ICHAR(RPT(18:18)),8)*2+ICHAR(RPT(19:19))/128 CODED(23)=MOD(ICHAR(RPT(19:19)),128)/32 CODED(24)=MOD(ICHAR(RPT(19:19)),32)/2 CODED(25)=MOD(ICHAR(RPT(19:19)),2)*8+ICHAR(RPT(20:20))/32 CODED(26)=MOD(ICHAR(RPT(20:20)),32)/2 CODED(27)=MOD(ICHAR(RPT(20:20)),2)*64+ICHAR(RPT(21:21))/4 CODED(28)=MOD(ICHAR(RPT(21:21)),4)*256+ICHAR(RPT(22:22)) CODED(29)=ICHAR(RPT(23:23))/128 CODED(30)=MOD(ICHAR(RPT(23:23)),128)/32 CODED(31)=MOD(ICHAR(RPT(23:23)),32)/8 CODED(32)=MOD(ICHAR(RPT(23:23)),8)/2 CODED(33)=MOD(ICHAR(RPT(23:23)),2)*2+ICHAR(RPT(24:24))/128 CODED(34)=MOD(ICHAR(RPT(24:24)),128)/32 CODED(35)=MOD(ICHAR(RPT(24:24)),32) END C-----------------------------------------------------------------------3456789 SUBROUTINE PRNFLD(FIELD,FORMAT,NUMBER) C PRINT FIELD C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*8 FIELD,FORMAT DIMENSION FIELD(NUMBER),FORMAT(NUMBER) C WRITE(*,FORMAT)((FIELD(I) +(MOD(J+INDEX(FIELD(I)(1:5)//' ',' ')-1,5)+1 +:MOD(J+INDEX(FIELD(I)(1:5)//' ',' ')-1,5)+1) +,I=1,NUMBER),J=0,4) WRITE(*,FORMAT)('-',I=1,NUMBER) END C-----------------------------------------------------------------------3456789 SUBROUTINE PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER) C PRINT REPORT C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*8 FORMAT DIMENSION FTRUE(NUMBER),FUNITS(NUMBER),FORMAT(NUMBER) CHARACTER*8 ATRUE(200) C CHARACTER CSET*3 C COMMON /ENV/CSET C IF(NUMBER.GT.200)STOP 'NUMBER ERROR' DO 190 I=1,NUMBER IF(FTRUE(I).EQ.FMISS)THEN ATRUE(I)=' ' C ELSE IF(FORMAT(I)(2:2).EQ.' ')THEN C IF(CSET.EQ.'EBC')THEN C ATRUE(I)=CHAR(IEBC(NINT(FTRUE(I)))) C ELSE C ATRUE(I)=CHAR(NINT(FTRUE(I))) C ENDIF ELSE WRITE(ATRUE(I),'(I'//FORMAT(I)(3:3)//')') + NINT(FTRUE(I)/FUNITS(I)) ENDIF 190 CONTINUE WRITE(*,FORMAT)(ATRUE(I),I=1,NUMBER) END C-----------------------------------------------------------------------3456789 SUBROUTINE B2LOLA(B2,BLO,BLA) C 2 DEG BOX WEST LON +E AND SOUTH LAT +N -S IMPLICIT REAL(A-Z) C IF (NINT(B2).GE.2.AND.NINT(B2).LE.16201) THEN BLO = MOD(NINT(B2)-2,180)*2 BLA = 88-(NINT(B2)-2)/180*2 ELSE IF (NINT(B2).EQ.1) THEN BLO = 0 BLA = 90 ELSE IF (NINT(B2).EQ.16202) THEN BLO = 0 BLA = -90 ELSE PRINT *,'ERROR: B2 = ',B2 STOP 'B2LOLA' ENDIF END EOR rm a.out f77 p.f date echo $1 | a.out