c Copyright(c) 2007, Space Science and Engineering Center, UW-Madison C Refer to "McIDAS Software Acquisition and Distribution Policies" C in the file mcidas/data/license.txt C *** $Id: m0tmpshpdec.f,v 1.3 2018/07/13 20:37:08 kevinb Tst $ *** C *** McIDAS Revision History *** C *** McIDAS Revision History *** *| Name: *| m0tmpshpdec - TEMP SHIP decoding routine that puts data into *| TEMP SHIP md files *| - TEMP SHIP is a combination of SHIPBUOY data *| and RAOB data *| *| Interface: *| integer function *| m0tmpshpdec(character*(*) wheadr, character*(*) cblk(*), *| integer nlines, character*(*) circit, integer julday, *| integer timdec, integer flags(*), *| character*(*) cflags(*)) *| *| Input: *| wheadr - wmo header of the data block *| cblk - data block to be decoded *| nlines - number of lines in data block *| circit - circuit source *| julday - the julian day that the data represents (ccyyddd) *| timdec - time that data represents (hhmmss) *| flags - array containing *| 1 - error output flag (1 = active) *| 2 - id monitoring key *| 3 - the decoder number to display status information *| 4 - base of the real-time md files used *| (i.e. if mdbase=20 the md file range used will be *| 21-30 for irab and 31-40 for irsg *| 5 - the number of rows to make the md file. valid *| values are 2 , 4 , and 8 *| 6 - the number of columns to make the md file *| (max=1500) *| 7 - set to 0 if no significant level data is to be *| decoded otherwise set it to the number of *| columns to make the irsg md file *| 8 - set to 1 if the rapid access filing system is used *| cflags - array containing *| 1 - error file name *| 2 - old station ids file name *| 3 - new station ids file name *| 4 - id table name to use. *| 5 - master station id list. if set to ' ', the file *| name in FMASID is used from m0xcd.inc *| 6 - pointer file name used for the rapid access file *| file system *| *| Input and Output: *| none *| *| Output: *| none *| *| Return values: *| 1 - success *| -1 - unable to process data *| *| Remarks: *| If the file name for the station id begins the characters *| 'stn', then it is assumed that the station list is static *| and that the file should NOT be recreated by the routine *| m0bildid. *| *| Categories: *| ingestor/decoder INTEGER FUNCTION m0tmpshpdec(wheadr,cblk,nlines,circit,julday, & timdec,flags,cflags) IMPLICIT INTEGER (a-b,d-z) IMPLICIT CHARACTER*12 (c) INCLUDE 'm0xcd.inc' PARAMETER (rbdkey = 148 , rbrkey = 3 ) PARAMETER (sgrkey = 4 , sgdkey = 4 , sgtkey = sgrkey + sgdkey) PARAMETER (rbtkey = rbdkey + rbrkey) PARAMETER (maxgrp = 200 , sigdif = 4) PARAMETER ( kmod = 1 , ktype = 2 , kida = 3 , kidb = 4) PARAMETER ( khms = 5 , klat = 6 , klon = 7 , kmars = 8) PARAMETER (nlevs = 15) PARAMETER (sigini = sigdif) CHARACTER*(*) wheadr CHARACTER*80 cblk(*) , cline CHARACTER*4 origin , circit , clit CHARACTER*8 creprt(maxgrp) CHARACTER*12 cflags(*) CHARACTER*12 ptrfil , ctemp CHARACTER*32 manttl , sigttl INTEGER mdlist(2) , locout(5) INTEGER flgsig(sigdif) , wndlvs(nlevs) , flags(*) INTEGER report(maxgrp) , icrept(2,maxgrp) , sigobs(sgtkey) INTEGER ibuf(20) , obs(rbtkey), obsval(rbtkey) INTEGER hight(3) , wdir(3) , wspd(3) INTEGER ttlman(8) , ttlsig(8) EQUIVALENCE (creprt,icrept) EQUIVALENCE (ttlman , manttl) EQUIVALENCE (ttlsig , sigttl) INTEGER rbscal(rbtkey) , rbunit(rbtkey) , rblocs(rbtkey) , & rbname(rbtkey) , sgscal(sgtkey) , sgunit(sgtkey) , & sglocs(sgtkey) , sgname(sgtkey) INTEGER blkdom(4) , timdom(8) , ptrhed(THSIZE) INTEGER bullbd(BBSIZE) INTEGER cyddd integer typfnd DATA flgsig/sigini*-1/,initxt/0/ DATA tmpshprabmd/-1/,tmpshprabrow/-1/,tmpshpcol/0/,nraob/0/ DATA tmpshpsigmd/-1/,tmpshpsigrow/-1/,nsig/0/ DATA manttl/'Mand. Level TEMPSHIP for '/ DATA sigttl/'Sig. Level TEMPSHIP for '/ DATA initcl/0/ m0tmpshpdec = -1 c--- if something has gone wrong if (initcl .eq. -1)goto 1000 iswit=0 lastln=0 cerror = cflags(1) cmstid = cflags(5) ptrfil = cflags(6) origin = circit cyddd = julday now = timdec ierror = flags(1) itshpdecnum = flags(3) mdbase = flags(4) / 10 * 10 maxrow = flags(5) maxcol = flags(6) sigflg = max0(flags(7),0) c rapid access filing rapflg = flags(8) c--- if this is the first call to the decoder, make c--- certain that all of the input values make c--- sense. if any of them don't, print out an error c--- message and set initcl to 0 indicating that c--- there has been an error if (initcl .eq. 0)then initcl = -1 c--- check the base md file number if (mdbase .lt. 0 .or. mdbase .gt. ksys(9)/10*10)then cline = 'm0tmpshpdec - invalid value for flags(4) = ' & //cfu(mdbase) call edest(cline,0) call mcermess(ierror,cerror,cline) goto 999 endif c--- check the number of rows if (maxrow .ne. 2 .and. maxrow .ne. 4 .and. maxrow .ne. 8)then cline = 'm0tmpshpdec - invalid value for flags(5) = ' & //cfu(maxrow) call edest(cline,0) call mcermess(ierror,cerror,cline) goto 999 endif c--- check the number of columns if (maxcol .le. 0)then cline = 'm0tmpshpdec - invalid value for flags(6) = ' & //cfu(maxcol) call edest(cline,0) call mcermess(ierror,cerror,cline) goto 999 endif uuaa = lit('UUAA') uubb = lit('UUBB') uucc = lit('UUCC') uudd = lit('UUDD') nil = lit('NIL ') irab = lit('TSHP') c--- if you have made it to here, all of the input c--- parameters are fine initcl = 1 endif timint = 240000 / maxrow hhint = 24 / maxrow lastln = 0 c--- check for end of file 5 continue if (lastln .gt. nlines) go to 999 pt = 1 num = 0 frstln = lastln 10 if (lastln .le. nlines) then call movcw(cblk(lastln),ibuf) c--- check for start of new record if (pt .eq. 1 .or. (ic(ibuf,0) .ne. RECSEP .and. & ic(ibuf,1) .ne. RECSEP)) then if (pt + 80 .gt. DCMXCH) goto 5 call crack(80,ibuf,msg(pt)) pt = pt + 80 lastln = lastln + 1 eptr = -1 i = pt 13 i = i - 1 if (i .le. pt-80)goto 14 if (msg(i) .eq. SPACE .or. msg(i) .eq. CRT .or. & msg(i) .eq. EOT)goto 13 if (msg(i) .eq. EQUAL .or. msg(i) .eq. XCLAM)eptr=i 14 continue if (pt .lt. 1640 .and. eptr .lt. 0 .and. iswit .ne. 0)goto 10 endif endif 12 continue c--- get time and day from wmo header if (iswit .ne. 0)goto 40 iswit = 1 timcur = now iwmo = m0wmodec(wheadr , cyddd , hday , htime , origin , cwmo , & dystmp , tmstmp, 1) call mcincday (cyddd, -1, yesday) call mcincday (cyddd, 1, tommro) call mccydtodmy (cyddd,date,month,year) call mccydtodmy (tommro,tdate,tmonth,tyear) call mccydtodmy (yesday,ydate,ymonth,yyear) c--- create md file whose number corresponds to day c--- of wmo header and initialize the md file keys c--- if necessary if (mdbase .lt. 0)then mdbase=mdsvc('ITSHPDEC',91001)/10*10 endif mdno=mdbase+mod(cyddd,10) if (mdno .eq. mdbase)mdno = mdno + 10 ok = mcydd2ch(cyddd,4,ctemp) manttl(22:) = ctemp sigttl(22:) = ctemp if (tmpshprabmd .gt. 0 .and. tmpshprabmd .ne. mdno)then if (nraob.gt.0 .and. tmpshprabrow .gt. 0)then imdo = mdo(tmpshprabmd,tmpshprabrow,0,1,rblocs(4),nraob) call mdflsh if (imdo .lt. 0)goto 930 call mdclos(tmpshprabmd) endif endif flag=mdmake(mdno,irab,0,0,maxcol,cyddd,ttlman) if (flag .lt. 0)goto 910 if (sigflg .gt. 0)then if (tmpshpsigmd .gt. 0 .and. tmpshpsigmd .ne. mdno + 10)then if (nsig.gt.0 .and. sigrow .gt. 0)then imdo = mdo(tmpshpsigmd,tmpshpsigrow,0,1,sglocs(4),nsig) call mdflsh if (imdo .lt. 0)goto 930 call mdclos(sigmd) endif endif sgflag=mdmake(mdno+50,irsg,0,maxrow*2,sigflg,cyddd,ttlsig) if (sgflag.lt.0) goto 910 endif mdinit=kytmpshp(mdno,sigflg,rbscal,rbunit,rblocs,rbname, & sgscal,sgunit,sglocs,sgname) c--- if the md file was just made, set it up c--- including row and column headers if (flag.eq.0)then if (maktmpshp(mdno,cyddd,maxrow,maxcol,1).ne.0) & goto 999 endif if (sgflag.eq.0 .and. sigflg .gt. 0)then if (maktmpshp(mdno+50,cyddd,maxrow,maxcol,2).ne.0) & goto 999 endif go to 5 c--- from here down it is assumed that the wmo header c--- was successfully decoded and that the md file was c--- made properly. 40 flag = num endlin = frstln + (pt / 80) - 1 grpnum = 0 nchrs = pt - 1 c--- parse out the ob into an easily decodable format call m0parobs(msg,nchrs,maxgrp,report,icrept,ngrp) if (ngrp .le. 0)goto 5 itype = 0 typfnd = 0 c--- scan to determine what type of ob it is, whether c--- it is a mandatory or significant ob or a nil. do 42 i = 1, 5 if (i .gt. ngrp) goto 43 itest = icrept (1, i) if (itest .eq. nil) then goto 5 endif if (itest .eq. uuaa)itype = 1 if (itest .eq. uubb)itype = 2 if (itest .eq. uucc)itype = 6 if (itest .eq. uudd)itype = 3 if (itype .ne. 0 .and. typfnd .eq. 0) then grpnum = i typfnd = 1 endif 42 continue 43 continue if (itype .eq. 0) goto 5 c45 continue c grpnum = grpnum + 1 c if (grpnum .gt. 5)goto 5 c itest = icrept(1,grpnum) c c call sdest ('nil =', nil) c call sdest ('itest =', itest) c if (itest .eq. nil )goto 5 c if (itest .eq. uuaa)itype = 1 c if (itest .eq. uubb)itype = 2 c if (itest .eq. uucc)itype = 6 c if (itest .eq. uudd)itype = 3 c if (itype .eq. 0)goto 45 c--- if a significant level ob has been found and you c--- are not filing sig info go grab next ob. if (itype .ne. 1 .and. itype .ne. 6 .and. sigflg .eq. 0)goto 5 c--- rinc is the row increment used for sig level c--- filing. it is set to one for sig temps and 2 c--- for sig winds. rinc = 1 c if (itype .eq. 4 .or. itype .eq. 7)rinc = 2 c decode the first line of the TEMP SHIP code call dcdtmpshp(report,creprt,grpnum,ngrp,julday,flag,oday, & otime,obs) c--- compute row number for this time period itime=otime/10000 irow=-1 c the following line is a check for bad hour data c otherwise, bad hour data is assumed to be the next day and a new MD file created if (itime .gt. 23) goto 5 if (itime .ge. 0) irow = 1 if (itime .gt. 1 .and. itime .le. 4) irow = 2 if (itime .gt. 4 .and. itime .le. 7) irow = 3 if (itime .gt. 7 .and. itime .le. 10) irow = 4 if (itime .gt. 10 .and. itime .le. 13) irow = 5 if (itime .gt. 13 .and. itime .le. 16) irow = 6 if (itime .gt. 16 .and. itime .le. 19) irow = 7 if (itime .gt. 19 .and. itime .le. 22) irow = 8 if (itime .gt. 22)then irow = 1 if (oday .eq. cyddd)then oday = tommro elseif (oday .eq. yesday)then oday = cyddd endif endif if (maxrow .eq. 4)irow = (irow - 1)/ 2 + 1 if (maxrow .eq. 2)irow = (irow - 1)/ 4 + 1 if (irow .lt. 0)goto 5 mdinc = 0 timfil = (irow - 1) * (24 / maxrow) if (itype .ne. 1 .and. itype .ne. 6)then mdinc = 50 irow = (irow-1) * 2 + rinc endif c--- determine the row and md file the data will c--- go in if (oday .eq. cyddd)then md = mdno + mdinc else c--- if the data is from a different day, create the c--- md file if necessary. call mdclos(mdno) call mdclos(mdno+10) md=mdbase+mod(oday,10) if (md.eq.mdbase)md=md+10 mnmd = md sgmd = md + 50 md = md + mdinc ok = mcydd2ch(oday , 4 , ctemp) manttl(22:) = ctemp sigttl(22:) = ctemp mnflag = mdmake(mnmd,irab,0,maxrow,maxcol,oday,ttlman) sgflag = 1 if (sigflg .ne. 0) & sgflag = mdmake(sgmd,irsg,0,maxrow*2,sigflg,oday,ttlsig) if (mnflag .lt. 0 .or. sgflag .lt. 0) go to 910 if (mnflag.ne.1) then if (maktmpshp(mnmd,oday,maxrow,maxcol,1).ne.0) & goto 999 endif if (sgflag.ne.1 .and. sigflg .ne. 0)then if (maktmpshp(sgmd,oday,maxrow,maxcol,2).ne.0) & goto 999 endif endif imdo = mdopen(md,2) if (imdo .lt. 0)goto 920 c--- grpnum going in to rabdcd will contain the c--- point in creprt where the station id group is c--- found c--- if the report is a uuaa or uucc if (itype.eq.1 .or. itype.eq.6)then winflg=999 if (itype .eq. 1) then call rabdcd(report,creprt,grpnum,ngrp,winflg,laslev, & obs,icnf,1) nparms = rbdkey - (5 * 7) ptr = 4 endif if (itype .eq. 6) then call ttcdcd(report,creprt,grpnum,ngrp,winflg,laslev, & obs,icnf,1) nparms = 5 * 7 ptr = rbrkey + 8 + nlevs * 7 + 1 endif if (irow.ne.tmpshprow.or.md.ne.tmpshpmd) then if (nraob.gt.0)then imdo = mdo(tmpshpmd,tmpshprow,0,1,rblocs(4),nraob) call mdflsh if (imdo .lt. 0)goto 930 endif if (tmpshpmd.gt.0 .and. md.ne.tmpshpmd)call mdclos(tmpshpmd) tmpshpmd = md tmpshprow =irow if (mdi(tmpshpmd,tmpshprow,0,1,rblocs(4),nraob).lt.0)goto 940 endif c check to see if part of a reading has already been filed c UUAA and UUCC are combined into one reading in UPPERMAND c As there is no IDN from STNDB.CORE for TEMP SHIP data, c we have to do this matchtest=0 if (itype .eq. 1.or.itype.eq.6) then if (tmpshpcol.gt.0) then call mdflsh imdi=mdi(tmpshpmd,tmpshprow,tmpshpcol,11,rblocs,obsval) c imdsch=mdsch(tmpshprow,tmpshpcol,11,rblocs,obsval) if (obsval(1).eq.oday) matchtest=matchtest+1 if (obsval(2).eq.otime) matchtest=matchtest+1 do kk=3,11 if (obsval(kk).eq.obs(kk)) matchtest=matchtest+1 enddo c create a new reading if first 11 slots don't match if (matchtest.ne.11) tmpshpcol=tmpshpcol+1 else tmpshpcol=tmpshpcol + 1 endif endif mdbull = md icbull = tmpshpcol if (itype .eq. 1) then if (matchtest.eq.11) then ptr=12 nparms = nparms-8 else nraob=nraob+1 endif if (mdo(md,irow,tmpshpcol,nparms,rblocs(ptr),obs(ptr)).lt.0) & goto 950 endif if (itype .eq. 6) then c write(cline,889)'md=',md,'r=',irow,'c=',tmpshpcol,'nparms=', c & nparms,'ptr=',ptr c889 format(a3,i5,1x,a2,i8,1x,a2,i8,1x,a7,i8,1x,a4,i8) c call sdest(cline,0) if (matchtest.ne.11) then if (mdo(md,irow,tmpshpcol,11,rblocs,obs).lt.0) & goto 950 nraob=nraob+1 endif if (mdo(md,irow,tmpshpcol,nparms,rblocs(ptr),obs(ptr)).lt.0) & goto 950 endif endif c--- if report is a uubb, uudd if (itype.gt.1.and.itype.lt.4 .and. sigflg .ne. 0)then c--- sigco is a function that is used if the ob is a c--- sig level ob. because globally there are so c--- many sig level obs, it is only practical to save c--- data for certain countries. the countries can c--- be specified with the sigco command. itcon = lit(contry(1:4)) icon = sigco(itcon) if (icon.lt.0)goto 5 sigobs(5) = idn c--- loop 200 will continue until grpnum = ngrp, c--- decoding all groups containing sig temps. c write(cline,891)'ityp=',itype,'ngp=',ngrp,'nsg=',nsig,'sr=',sigrow c891 format(a5,i1,1x,a4,i3,1x,a4,i4,1x,a3,i3) c call sdest(cline,0) 200 call sigtem(idn,itype,report,creprt,grpnum,ngrp,sigobs) if (irow.ne.sigrow.or.md.ne.sigmd)then c write(cline,892)'irw=',irow,'sr=',sigrow,'md=',md, c 1 'sigmd=',sigmd,'nsig=',nsig c892 format(a5,i3,1x,a3,i3,1x,a3,i3,1x,a6,i3,1x,a5,i4) c call sdest(cline,0) if (nsig.gt.0)then imdo = mdo(sigmd,sigrow,0,1,sglocs(4),nsig) call mdflsh if (imdo .lt. 0)goto 930 endif if (sigmd .ne. md)call mdclos(sigmd) sigmd = md sigrow = irow imdi = mdi(sigmd,sigrow,0,1,sglocs(4),nsig) if (imdi .lt. 0)goto 940 endif if (grpnum.lt.ngrp) then nsig = nsig + 1 c write(cline,893)'md1=',md,'r=',irow,'c=',nsig,'idn=',sigobs(5) c893 format(a4,i5,1x,a2,i3,1x,a2,i5,1x,a4,i6) c call sdest(cline,0) mdbull = md icbull = nsig imdo = mdo(md,irow,nsig,sgdkey,sglocs(5),sigobs(5)) if (imdo .lt. 0)goto 950 goto 200 endif endif c--- file the ob in the rapid access file system c--- if specified if (rapflg .gt. 0)then c--- if this is the first call to the pointer file c--- system, open the file, retrieving the necessary c--- information if (initxt .eq. 0)then ok = mctxtopn(ptrfil,ptrhed,maxids,idtab,numsta) c--- if there was an error opening the file, flag it c--- so that no data will attempt to be filed in the c--- system if (ok .lt. 0)then initxt = -1 c--- otherwise, flag it as ok else initxt = 1 endif endif c--- if the file has been flagged as successfully c--- opened if (initxt .eq. 1)then c--- set the domain in the data block where the c--- ob exists blkdom(1) = frstln blkdom(2) = endlin blkdom(3) = 1 blkdom(4) = 80 c--- set the time domain parameters timdom(1) = itype - 1 timdom(2) = 1 timdom(3) = oday timdom(4) = obs(2) timdom(5) = timfil * 10000 timdom(6) = timdom(3) timdom(7) = timdom(4) timdom(8) = timdom(5) c--- file the actual observation ok = mctxtwrt(ptrfil,ptrhed,cblk,blkdom,idn,timdom, & maxids,numsta,idtab) endif endif goto 5 910 call mcermess(ierron,cerror,'m0tmpshpdec - unable to make md #' & //cfu(mdno)) goto 1000 920 call mcermess(ierron,cerror,'m0tmpshpdec - unable to open md #' & //cfu(mdno)) goto 1000 930 call mcermess(ierron,cerror, & 'm0tmpshpdec - unable to write to row=' & //cfu(irow)) goto 1000 940 call mcermess & (ierron,cerror,'m0tmpshpdec - unable to read from row=' & //cfu(irow)) goto 1000 950 call mcermess(ierron,cerror, & 'm0tmpshpdec - unable to write to col=' & //cfu(tmpshpcol)) goto 1000 999 continue if (nraob.gt.0) then if (mdo(tmpshpmd,tmpshprow,0,1,rblocs(4),nraob).lt.0) goto 930 endif if (nsig.gt.0)then if (mdo(sigmd,sigrow,0,1,sglocs(4),nsig).lt.0)goto 930 endif m0tmpshpdec = 0 1000 continue c--- file stuff on bulletin board call m0rsdcd(' ',itshpdecnum,'DECO',bullbd,BBSIZE,jstat) bullbd(BBON ) = 1 bullbd(BBTIME) = now call mccydtoiyd (julday, bullbd(BBDAY)) bullbd(BBMD ) = mdbull bullbd(BBROW ) = irow bullbd(BBCOL ) = icbull call movcw(' ',bullbd(BBTEXT)) call movcw('TSHPDEC ',bullbd(BBTASK)) call m0wsdcd(' ',itshpdecnum,'DECO',bullbd,BBSIZE,jstat) return end c--- end - m0tmpshpdec c maktmpshp - set up tmpshp md files. c c mdno = md file number c cyddd = year and julian date corresponding to data (ccyyddd) c c maktmpshp = 0 if md file was successfully made c -1 for failure c INTEGER FUNCTION maktmpshp(mdno,cyddd,maxrow,maxcol,type) IMPLICIT INTEGER (a-z) INTEGER manrecord(3) , sigrecord(4), manrow(3) , sigrow(4) makrab = -1 sigt = lit('SIGT') sigw = lit('SIGW') irsg = lit('IRSG') manrecord(1) = cyddd sigrecord(1) = cyddd timint = 240000 / maxrow if (type .eq. 2)goto 50 c--- make mandatory md file header iok = mdopen(mdno,2) if (iok .lt. 0)goto 900 c--- write row headers manrecord(3)=0 do 5 i=1,3 5 manrow(i)=i do 10 i=1,maxrow c--- time manrecord(2) = (i-1) * timint if (mdo(mdno,i,0,3,manrow,manrecord) .lt. 0)goto 900 10 continue ok = m0mdtimeput(mdno, cyddd,0,cyddd,235959) maktmpshp = 0 goto 999 c--- make significant level headers 50 continue iok = mdopen(mdno,2) if (iok .lt. 0)goto 900 c--- cmax is the last column location containing data do 55 i = 1 , 4 55 sigrow(i) = i sigrecord(4) = 0 c--- row headers do 60 i=1 , (maxrow * 2 - 1) , 2 row=i c--- time sigrecord(2)=((i+1)/2-1)*timint c--- type sigrecord(3) = sigt if (mdo(mdno,row,0,4,sigrow,sigrecord) .lt. 0)goto 900 row = row + 1 sigrecord(3) = sigw if (mdo(mdno,row,0,4,sigrow,sigrecord) .lt. 0)goto 900 60 continue ok = m0mdtimeput(mdno, cyddd,0,cyddd,235959) maktmpshp = 0 goto 999 900 continue call edest('maktmpshp: unable to initialize tmpshp md file ',mdno) 999 continue call mdclos(mdno) return end c--- end - maktmpshp c kytmpshp - initializes the keys for the tmpshp data c =1 if successful INTEGER FUNCTION kytmpshp(mdf , sigflg , rbscal , rbunit , & rblocs , rbname , sgscal , sgunit , & sglocs , sgname) IMPLICIT INTEGER (a-z) PARAMETER (rbdkey = 148 , rbrkey = 3 ) PARAMETER (rbtkey = rbdkey + rbrkey ) PARAMETER (sgdkey = 4 , sgrkey = 4) PARAMETER (sgtkey = sgdkey + sgrkey) INTEGER rbscal(*) , rbunit(*) , rblocs(*) , rbname(*), & sgscal(*) , sgunit(*) , sglocs(*) , sgname(*) DATA rbkeyi/0/ kytmpshp = 1 if (rbkeyi .gt. 0)return kytmpshp = -1 rbkeyi = 1 if (mdopen(mdf,1) .lt. 0)then call edest('kytmpshp - unable to open md file ',mdf) goto 999 endif call movcw('DAY TIMECMAXMOD TYPEIDA IDB HMS LAT LON MAR ',rbname) do 10 i=12,147,7 10 call movcw('LEV P T TD DIR SPD Z ',rbname(i)) imdkey=mdkeys(mdf,rbtkey,rbname,rbscal,rbunit,rblocs) if (imdkey.lt.rbtkey)then call edest('kytmpshp - invalid key name mdf=',mdf) goto 999 endif kytmpshp = 1 if (sigflg .eq. 0)goto 999 100 continue kytmpshp = -1 mdsig = mdf + 50 if (mdopen(mdsig,1) .lt. 0)then call edest('kytmpshp - unable to open md file ',mdsig) goto 999 endif call movcw('DAY TIMETYPECMAXIDN P3 P1 P2 ',sgname) imdkey=mdkeys(mdsig,sgtkey,sgname,sgscal,sgunit,sglocs) if (imdkey .lt. sgtkey)then call edest('kytmpshp - invalid key name in sig mdf=',mdsig) goto 999 endif kytmpshp = 1 999 continue call mdclos(mdf) call mdclos(mdsig) return end c decode the first part of the TEMP SHIP report c input: c report (i) - array of integer values for the observation c groups c creprt (c*8) - array of character strings for the observation c groups c ngrp (i) - number of groups in observation c output: c day (i) - julian day of the observation (ccyyddd) c time (i) - time of the observation (hhmmss) c obs (i) - decoded observation c flag (i) - returns a 0 if successful SUBROUTINE dcdtmpshp(report,creprt,grpnum,ngrp,julday,flag, & day,time,obs) IMPLICIT INTEGER (a-z) INCLUDE 'm0xcd.inc' PARAMETER (sndkey=148,snrkey=3,sntkey=sndkey+snrkey) PARAMETER ( kmod = 4 , ktype = 5 , kida = 6 , kidb = 7) PARAMETER ( khms = 8 , klat = 9 , klon = 10 , kmars = 11) character*80 cline INTEGER report(*) CHARACTER*8 ctemp,creprt(*) CHARACTER*12 cval,cfu INTEGER obs(*) INTEGER ok EQUIVALENCE (ibuf,ctemp) c--- initialize obs buffer do 15 i = 1 , sndkey 15 obs(i+3) = MISS obs(kmod) = 0 c--- scan for id c grpnum will be at 1 10 continue grpnum = grpnum + 1 if (grpnum .gt. ngrp)goto 999 ctemp = creprt(grpnum) call crack(8,ibuf,msg) numgrp=0 ok = m0dcsplt(8,numgrp,0,dum) c US/UK/UE/UL NO does not have a ship name if (type(1).eq.ACHAR) then call m0grbval(cval,value,1) call movcw(cval,obs(kida)) grpnum = grpnum + 1 if (grpnum .gt. ngrp)goto 999 else call m0grbval(cval,value,1) obs(kida)=lit('UNKN') endif obs(ktype)=lit('TSHP') val0 = report(grpnum) time = mod(val0,1000) / 10 * 10000 obs(khms) = time C TEMP SHIP FM 36-IX - adds 50 if wind speed is knots day = mod(val0 / 1000,50) cyddd = julday daycur = cyddd call mccydtodmy(cyddd,dd,mm,yy) dday = dd - day if (dday .lt. 0)dday = 1 call mcincday (cyddd, -dday, cyddd) day = cyddd if (daycur .lt. day)day = daycur grpnum = grpnum + 1 if (grpnum .gt. ngrp)goto 999 val0 = report(grpnum) c--- if 99 group is found get lat/lon if (val0 .ge. 99000)then lat = mod(val0,1000) grpnum = grpnum + 1 if (grpnum .gt. ngrp)goto 999 val0 = report(grpnum) quad = val0 / 10000 lon = mod(val0,10000) if (quad .eq. 3 .or. quad .eq. 5)lat = -lat if (quad .eq. 1 .or. quad .eq. 3)lon = -lon obs(klat) = lat * 1000 obs(klon) = lon * 1000 endif c--- get MMMUlaUlo group (Marsden square) grpnum = grpnum + 1 if (grpnum .gt. ngrp)goto 999 val0 = report(grpnum) ctemp = creprt(grpnum) if (ctemp(1:1) .ne. '/')obs(kmars) = val0 / 100 999 return end c--- end - dcdtmpshp