C=============================================================================C C Comprehensive Ocean-Atmosphere Data Set (COADS): Fortran 77 Library C C Filename:level: rptin.f:01C 10 February 2000 C C Function: Read/write: COS blocked rptin/rptout files Author: S.Lubker C C=============================================================================C C Software documentation for the (modifiable) routine {COSopn} and for the C (invariant) user-interface routines {rptin,rptout}: C C Functionality: The same as NCAR's corresponding routines (NCAR, 1983). C {rptout} first packs shorter variable-length logical records into larger C physical records, according to the "RPTIN" format defined by NCAR C (1983). Then the resulting physical records are restructured into "Cray C Operating System" (COS) blocks and output. This block structure includes C 64-bit control words to delimit the boundaries of physical records as C produced by {rptout}, and of the superimposed COS blocks. COS blocks C always contain 512 64-bit, or 1024 32-bit, words (with binary zero fill C at the end of a file, as needed). Thus a COS blocked file always C consists of an integral number of 4096-byte blocks. {rptin} is used to C read records made in RPTIN format with COS blocking, including those made C by {rptout}. COS blocked files may have multiple internal files; the C functionality and return codes available in {rptin} are designed to C provide access to this COS multi-file structure. C C Input arguments to {rptin}: kunit (input unit number), jj (unused; C obsolete argument), and klmax (maximum number of 2*32-bit words to C move to kloc). Output arguments: kbuf (a working array), kloc (array C to put report in), kwds (total number of 2*32-bit words in this C report), and jeof (0=report returned; 1=EOF; 2=checksum error; C 3=unused, but defined as "end of tape"). Input arguments to {rptout}: C nunit (output unit number), locrpt (location of the report for output, C with the first 16 bits reserved), nwds (number of 2*32-bit words in C the report), jl (1=output report; 2=no report to output, but output C the last buffer). Output arguments: nbuf (an array in which the C records are built). The buffer arrays kbuf and nbuf, each dimensioned C 1006 Cray (or 2*1006 32-bit) words, have the first six array locations C reserved for control/counters, including, e.g., counts of logical C (physical) records read or written in location 2 (3). C C Known machine dependencies are isolated into the first part of {COSopn}, C which is not a user-interface routine, but is called from within the C library. The open statements in {COSopn} are machine-dependent, e.g., C some computers/compilers expect record-length in words instead of bytes. C C Reference: NCAR, 1983: Conversion Handbook (2nd Ed.), Scientific Computing C Division, National Center for Atmospheric Research, Boulder, CO (Feb. 1983). C C Machine dependencies: Usable only on 32-bit computers (a 64-bit version is C available from NCAR for Cray computers). {COSopn} open statements may be C machine dependent, as discussed above. C For more information: See and (electronic documents). c-----------------------------------------------------------------------3456789 subroutine COSopn(u) c open a COS blocked file implicit integer(a-z) common /COS/m(99),ubc(99),bn(99),pfi(99),pri(99),fwi(99) +,b(2,512,99),bw(99) logical named character name*80 c inquire(unit=u,named=named,name=name) close(u) if (named) then c open to read binary data (machine-dependent modifications may be needed) c recl in bytes open(u,form='unformatted',access='direct',recl=4*2*512 + ,file=name) c recl in 32-bit words c open(u,form='unformatted',access='direct',recl=2*512 c + ,file=name) else c open to read binary data (machine-dependent modifications may be needed) c recl in bytes open(u,form='unformatted',access='direct',recl=4*2*512) c recl in 32-bit words c open(u,form='unformatted',access='direct',recl=2*512) endif C=============================================================================C C WARNING: Code beyond this point should not require any modification. C C=============================================================================C m(u)=0 ubc(u)=0 bn(u)=0 pfi(u)=0 pri(u)=0 fwi(u)=0 return c entry COSbd(u) c reinitialize a unit bw(u)=0 end c-----------------------------------------------------------------------3456789 subroutine rptin(kunit,kbuf,kloc,kwds,jj,klmax,jeof) c get a rptin logical record implicit integer(a-z) dimension kbuf(2,1006),kloc(2,klmax) parameter(eor=0,eof=1,eod=2) if (kbuf(1,1).eq.0.and.kbuf(2,1).eq.0.and.kbuf(1,2).eq.0 +.and.kbuf(2,2).eq.0.and.kbuf(1,3).eq.0.and.kbuf(2,3).eq.0) +call COSbd(kunit) if (kbuf(1,1)+2.eq.kbuf(2,4).or.kbuf(1,1).eq.0) then call COSin(kunit,kbuf(1,4),kbuf(1,1),jeof) if (jeof.eq.eod) jeof=eof kbuf(2,3)=jeof if (jeof.eq.eof) return call rptck(kbuf(1,4),kbuf(2,4),jeof) if (jeof.eq.2) stop 'rptin: bad checksum' if (kbuf(2,4).ne.kbuf(1,1)) stop 'rptin: bad physical length' kbuf(1,1)=0 kbuf(1,2)=kbuf(1,2)+1 kbuf(2,2)=kbuf(2,2)+kbuf(2,4) endif call gbyte(kbuf(1,4+kbuf(1,1)+1),kwds,0,12) if (kwds.lt.1.or.kwds.gt.998) stop 'rptin: bad logical length' if (kwds.gt.klmax) stop 'rptin: short logical record' do 190 j=1,kwds kloc(1,j)=kbuf(1,4+kbuf(1,1)+j) kloc(2,j)=kbuf(2,4+kbuf(1,1)+j) 190 continue kbuf(1,1)=kbuf(1,1)+kwds kbuf(2,1)=kbuf(2,1)+1 end c-----------------------------------------------------------------------3456789 subroutine rptout(nunit,nbuf,locrpt,nwds,jl) c put a rptout logical record implicit integer(a-z) dimension nbuf(2,1006),locrpt(2,nwds) parameter(eor=0,eof=1,eod=2) if (nbuf(1,1).eq.0.and.nbuf(2,1).eq.0.and.nbuf(1,2).eq.0 +.and.nbuf(2,2).eq.0.and.nbuf(1,3).eq.0.and.nbuf(2,3).eq.0) +call COSbd(nunit) if (nwds.lt.1.or.nwds.gt.998) stop 'rptout: bad logical length' if (nbuf(1,1)+nwds.gt.998.or.jl.eq.2) then if (nbuf(1,1).eq.0) stop 'rptout: bad physical write' nbuf(1,4)=268435456 nbuf(2,4)=nbuf(1,1)+2 call rptck(nbuf(1,4),nbuf(2,4),jl) call COSout(nunit,nbuf(1,4),nbuf(2,4),eor) nbuf(1,1)=0 nbuf(1,2)=nbuf(1,2)+1 nbuf(2,2)=nbuf(2,2)+nbuf(2,4) if (jl.eq.2) then call COSout(nunit,nbuf(1,4),nbuf(1,1),eof) call COSout(nunit,nbuf(1,4),nbuf(1,1),eod) return endif endif do 190 j=1,nwds nbuf(1,4+nbuf(1,1)+j)=locrpt(1,j) nbuf(2,4+nbuf(1,1)+j)=locrpt(2,j) 190 continue call sbyte(nbuf(1,4+nbuf(1,1)+1),nwds,0,12) nbuf(1,1)=nbuf(1,1)+nwds nbuf(2,1)=nbuf(2,1)+1 end c-----------------------------------------------------------------------3456789 subroutine rptck(buf,wds,jeof) c get/put a rptin/rptout checksum implicit integer(a-z) dimension buf(2,wds) +,cksum(2),sum(64),bit(64) do 190 i=1,64 sum(i)=0 190 continue do 290 j=1,wds-1 call gbytes(buf(1,j),bit,0,1,0,64) do 280 i=64,1,-1 sum(i)=sum(i)+bit(i) if (i.gt.1) sum(i-1)=sum(i-1)+sum(i)/2 sum(i)=mod(sum(i),2) 280 continue 290 continue call sbytes(cksum,sum,0,1,0,64) if (jeof.eq.0) then if (buf(1,wds).ne.cksum(1) + .or.buf(2,wds).ne.cksum(2)) jeof=2 else buf(1,wds)=cksum(1) buf(2,wds)=cksum(2) endif end c-----------------------------------------------------------------------3456789 subroutine COSin(u,r,w,ios) c get a COS blocked logical record implicit integer(a-z) common /COS/m(99),ubc(99),bn(99),pfi(99),pri(99),fwi(99) +,b(2,512,99),bw(99) dimension r(2,*) parameter(EOR=8,EOF=14,EOD=15) save c if (u.lt.1.or.u.gt.99) stop 'COSin: bad unit' rw=0 if (bw(u).lt.2) then call COSopn(u) bw(u)=1 goto 200 endif c 100 continue c call gbyte(b(1,1,u),fwi(u),0+4+7+1+19+24,9) call gbyte(b(1,bw(u),u),fwi(u),0+4+6+1+1+1+7+20+15,9) do 190 j=1,fwi(u) r(1,rw+j)=b(1,bw(u)+j,u) r(2,rw+j)=b(2,bw(u)+j,u) 190 continue rw=rw+fwi(u) bw(u)=mod(bw(u)+fwi(u),512)+1 c c block control word 200 if (bw(u).eq.1) then mod1=mod(bn(u),2**24) inquire(unit=u,nextrec=n) read(u,rec=n)(b(1,j,u),b(2,j,u),j=1,512) c call gbyte(b(1,1,u),m(u) ,0,4) c call gbyte(b(1,1,u),unused,0+4,7) c call gbyte(b(1,1,u),bdf ,0+4+7,1) c call gbyte(b(1,1,u),unused,0+4+7+1,19) call gbyte(b(1,1,u),bn(u) ,0+4+7+1+19,24) c call gbyte(b(1,1,u),fwi(u),0+4+7+1+19+24,9) if (bn(u).ne.mod1) + stop 'COSin: bad block number' bn(u)=bn(u)+1 if (fwi(u).ne.0.or.m(u).eq.EOR) pfi(u)=pfi(u)+1 if (fwi(u).ne.0) pri(u)=pri(u)+1 goto 100 c c record control word else mod2=mod(pfi(u),2**20) mod3=mod(pri(u),2**15) call gbyte(b(1,bw(u),u),m(u) ,0,4) call gbyte(b(1,bw(u),u),ubc(u),0+4,6) c call gbyte(b(1,bw(u),u),tran ,0+4+6,1) c call gbyte(b(1,bw(u),u),bdf ,0+4+6+1,1) c call gbyte(b(1,bw(u),u),srs ,0+4+6+1+1,1) c call gbyte(b(1,bw(u),u),unused,0+4+6+1+1+1,7) call gbyte(b(1,bw(u),u),pfi(u),0+4+6+1+1+1+7,20) call gbyte(b(1,bw(u),u),pri(u),0+4+6+1+1+1+7+20,15) c call gbyte(b(1,bw(u),u),fwi(u),0+4+6+1+1+1+7+20+15,9) if (pfi(u).ne.mod2) + stop 'COSin: bad previous file index' if (pri(u).ne.mod3) + stop 'COSin: bad previous record index' if (m(u).eq.EOR) then pri(u)=0 else if (m(u).eq.EOF) then pfi(u)=0 else if (m(u).eq.EOD) then bw(u)=1 else stop 'COSin: bad type of control word' endif w=rw ios=m(u)/EOF+m(u)/EOD endif end c-----------------------------------------------------------------------3456789 subroutine COSout(u,r,w,ios) c put a COS blocked logical record implicit integer(a-z) common /COS/m(99),ubc(99),bn(99),pfi(99),pri(99),fwi(99) +,b(2,512,99),bw(99) dimension r(2,*) parameter(EOR=8,EOF=14,EOD=15) save c if (u.lt.1.or.u.gt.99) stop 'COSout: bad unit' rw=0 if (bw(u).lt.2) then call COSopn(u) bw(u)=1 do 90 j=1,512 b(1,j,u)=0 b(2,j,u)=0 90 continue endif c 100 fwi(u)=min(w-rw,512-bw(u)) c call sbyte(b(1,1,u),fwi(u),0+4+7+1+19+24,9) call sbyte(b(1,bw(u),u),fwi(u),0+4+6+1+1+1+7+20+15,9) do 190 j=1,fwi(u) b(1,bw(u)+j,u)=r(1,rw+j) b(2,bw(u)+j,u)=r(2,rw+j) 190 continue rw=rw+fwi(u) bw(u)=mod(bw(u)+fwi(u),512)+1 c c block control word 200 if (bw(u).eq.1) then c call sbyte(b(1,1,u),m(u) ,0,4) c call sbyte(b(1,1,u),unused,0+4,7) c call sbyte(b(1,1,u),bdf ,0+4+7,1) c call sbyte(b(1,1,u),unused,0+4+7+1,19) call sbyte(b(1,1,u),bn(u) ,0+4+7+1+19,24) c call sbyte(b(1,1,u),fwi(u),0+4+7+1+19+24,9) inquire(unit=u,nextrec=n) write(u,rec=n)(b(1,j,u),b(2,j,u),j=1,512) if (m(u).eq.EOD) return do 290 j=1,512 b(1,j,u)=0 b(2,j,u)=0 290 continue bn(u)=bn(u)+1 if (fwi(u).ne.0.or.m(u).eq.EOR) pfi(u)=pfi(u)+1 if (fwi(u).ne.0) pri(u)=pri(u)+1 goto 100 c c record control word else m(u)=EOR+(ios+1)/2*5+ios call sbyte(b(1,bw(u),u),m(u) ,0,4) call sbyte(b(1,bw(u),u),ubc(u),0+4,6) c call sbyte(b(1,bw(u),u),tran ,0+4+6,1) c call sbyte(b(1,bw(u),u),bdf ,0+4+6+1,1) c call sbyte(b(1,bw(u),u),srs ,0+4+6+1+1,1) c call sbyte(b(1,bw(u),u),unused,0+4+6+1+1+1,7) call sbyte(b(1,bw(u),u),pfi(u),0+4+6+1+1+1+7,20) call sbyte(b(1,bw(u),u),pri(u),0+4+6+1+1+1+7+20,15) c call sbyte(b(1,bw(u),u),fwi(u),0+4+6+1+1+1+7+20+15,9) if (m(u).eq.EOR) then pri(u)=0 else if (m(u).eq.EOF) then pfi(u)=0 else if (m(u).eq.EOD) then bw(u)=1 goto 200 else stop 'COSout: bad type of control word' endif endif end c-----------------------------------------------------------------------3456789 block data bdCOS implicit integer(a-z) common /COS/m(99),ubc(99),bn(99),pfi(99),pri(99),fwi(99) +,b(2,512,99),bw(99) c data bw/99*0/ end