C Copyright(c) 1997, 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 C *** $Id: areaadirsub.f,v 1.10 2019/05/17 15:31:13 daves Exp $ *** *$ Name: *$ areaadirsub - Gets area directories matching search criteria *$ *$ Interface: *$ subroutine *$ adir(integer request) *$ *$ Input: *$ request - communications block *$ *$ Input and Output: *$ none *$ *$ Output: *$ none *$ *$ Remarks: *$ 260 bytes are sent for each area directory entry. *$ The first 4 are the absolute number of the entry on the server *$ The next 4 are the relative number within the cylinder *$ The rest are words 2 thru 64 of the area directory entry *$ Word 1 is not sent, since it will always be 0 for a valid entry *$ and invalid entries just aren't sent. subroutine areaadirsub(request) IMPLICIT NONE c --- include areaparm.inc to get the value MAX_AUXBLOCK_SIZE include 'areaparm.inc' include 'fileparm.inc' INTEGER request(*) ! communication block INTEGER min_areanumber ! min area number in dataset INTEGER max_areanumber ! max area number in dataset ! symbolic constants and shared data character*8 servername parameter (servername = 'AREAADIR') INTEGER MAXCARDS ! max # of comment cards PARAMETER (MAXCARDS = 500) INTEGER MAXNAM ! max # of expanded key names PARAMETER (MAXNAM = 9) INTEGER MAXTYP ! max # of keys per area PARAMETER (MAXTYP = 20) INTEGER MAX_INFO PARAMETER (MAX_INFO = 2048) INTEGER MAGIC_NUMBER ! AUX block big endian MAGIC number PARAMETER (MAGIC_NUMBER = 67305985) INTEGER BIG_ENDIAN PARAMETER (BIG_ENDIAN = 1) INTEGER LITTLE_ENDIAN PARAMETER (LITTLE_ENDIAN = 0) INTEGER search_list(MAX_AREA_NUMBER) INTEGER search_pos(MAX_AREA_NUMBER) INTEGER work_array(MAX_AREA_NUMBER) COMMON/STORE/search_list INTEGER AUXBUF( MAX_AUXBLOCK_SIZE ) ! buffer to hold AUX block COMMON/adirservcommon/AUXBUF ! external functions CHARACTER*4 CLIT CHARACTER*12 CFF CHARACTER*12 CFG CHARACTER*12 CFI CHARACTER*12 CFJ CHARACTER*12 CFU integer all_check INTEGER ARANAM integer fullpathname INTEGER ICGET INTEGER ISCHAR INTEGER KB1OPT INTEGER KBPREP INTEGER LEN_TRIM INTEGER LIT INTEGER LLTORA INTEGER LUC integer lbi integer lwfile integer m0arasize integer m0bandmap integer m0getmaskfilelist integer m0readd INTEGER m0specs INTEGER MCARGIHR INTEGER MCARGINT INTEGER MCARGSTR integer mcargiyd integer mcdaytimetosec integer mciydtocyd INTEGER NV1SAE INTEGER NVSET INTEGER VOLNAM integer m0wltoband integer m0wntoband integer mcargdbl ! local variables character*1 lat_sign, lon_sign character*4 cid character*4 KEYNAM(MAXNAM) character*4 cval4 character*8 cval8 character*8 cunit character*12 cval12_1, cval12_2, cval12_3 character*12 cval12_4, cval12_5, cval12_6 character*12 cval12_7 character*12 CBLOCK character*12 EXPTXT character*12 GETAUX character*12 KEYEXP(MAXNAM) character*12 cwl, cwn character*40 cval40 character*80 CTEMP character*256 ARGDUM character*500 mask_string character*512 area_file character*512 gathered_files(MAX_IMAGE_FILES) character*(MAXPATHLENGTH) area_path DOUBLE PRECISION AZIMUTH double precision dval double precision dscale double precision doffset DOUBLE PRECISION RANGE1 DOUBLE PRECISION RANGE2 double precision bwl, ewl double precision bwn, ewn INTEGER ALL INTEGER area_dir(64) INTEGER area_index integer area_number integer area_date ! area directory(5) in ccyyddd format INTEGER AUXFLAG ! indicates AUX block transfer integer bands(MAX_BAND) INTEGER BBAND INTEGER BDAY integer begin_list INTEGER BTIM INTEGER CARDS(MAXCARDS*20) INTEGER EBAND INTEGER EDAY integer wl_bband, wl_eband integer wn_bband, wn_eband integer end_list INTEGER ETIM integer file_ok integer filter_index integer good_searchs integer i integer ival INTEGER IBAND INTEGER IBUF(64) INTEGER IELE INTEGER IKEY INTEGER ILIN INTEGER INICK INTEGER IRES integer iret INTEGER ISTAT INTEGER KEYS(MAXTYP) INTEGER LEN_CTEMP integer len_cval12_1 integer len_cval12_2 integer len_cval12_3 integer len_cval12_4 integer len_cval12_7 integer len_cval8 integer len_cunit integer len_cval40 INTEGER min_relativenum INTEGER max_relativenum INTEGER total_areas INTEGER NA INTEGER NABS INTEGER NAUX ! byte size of AUX block INTEGER NB INTEGER NBYTES INTEGER NCARD integer nfiles integer num_bands integer ifile INTEGER NINT INTEGER OLDUC31 INTEGER OLDUC32 INTEGER OLDUC33 integer pow INTEGER RELATV INTEGER search_ok INTEGER SS1 INTEGER SS2 INTEGER status INTEGER STYPE INTEGER temp_areanum INTEGER temp_time INTEGER TIME_CHECK integer pos integer nexrad_info( MAX_INFO ) character*12 cvalue character*12 cband character*12 ckey character*12 cdqfs(8) integer GOESR_SSS integer GOESS_SSS integer dqfs(16) integer n(8) integer k, kk integer len_exptxt integer len double precision dvalue REAL DG2RAD REAL PI REAL XDUM REAL XELE REAL XLAT REAL XLAT2 REAL XLIN REAL XLON REAL XLON2 REAL XLNRES REAL XLTRES LOGICAL NOMIN LOGICAL FLIP_BYTES LOGICAL BAND_SPECIFIED C------ poke uc to suppress all messages to stdout olduc31 = luc(-31) olduc32 = luc(-32) olduc33 = luc(-33) call puc(0, -31) ! sdest call puc(0, -32) ! edest call puc(0, -33) ! ddest NA=0 data keynam /'ALB ', 'BRIT', 'DBZ ', 'RAD ', & 'RAW ', 'TE64', 'TEMP', 'VIP ', & 'REFL'/ data keyexp /'ALBEDO', 'BRIGHTNESS', 'DECIBELS', 'RADIANCE', & 'RAW', 'TE64', 'TEMPERATURE', 'VIP LEVEL', & 'REFLECTIVITY'/ data GOESR_SSS/186/ data GOESS_SSS/188/ pi = 4.0 * atan(1.0) dg2rad = pi / 180.0 istat = mcargint(0, 'MNMXRANGE', 1, -1, 0, -1, * min_areanumber, argdum) istat = mcargint(0, 'MNMXRANGE', 2, -1, 0, -1, * max_areanumber, argdum) ALL = lit('ALL ') call swbyt4(ALL, 1) C------ parse command line C------ beginning and ending satellite ids istat = mcargint(0, 'SS', 1, -1, 0, -1, ss1, argdum) istat = mcargint(0, 'SS', 2, ss1, 0, -1, ss2, argdum) C------ day istat = mcargiyd(0, 'DAY', 1, -1, 0, -1, bday, argdum) istat = mcargiyd(0, 'DAY', 2, bday, 0, -1, eday, argdum) C------ time istat = mcargihr(0, 'TIM.E', 1, -1, 0, -1,btim, argdum) istat = mcargihr(0, 'TIM.E', 2,btim, 0, -1,etim, argdum) C------ band istat = mcargstr(0, 'BAN.D', 1, ' ', cwl ) if( cwl(1:3).eq.'ALL' .or. cwl(1:3).eq.' ' ) then BAND_SPECIFIED = .FALSE. else BAND_SPECIFIED = .TRUE. istat = mcargint(0, 'BAN.D', 1, -1, 0, -1, bband, argdum) istat = mcargint(0, 'BAN.D', 2,bband, 0, -1, eband, argdum) endif C------ wl istat = mcargstr(0, 'WL', 1, ' ', cwl ) if( cwl(1:3).eq.'ALL' ) then bwl = 1.0D0 ewl = 99999.0D0 else istat = mcargdbl(0,'WL',1,-1.0D0,0.0D0,-1.0D0,bwl,argdum) istat = mcargdbl(0,'WL',2, bwl,0.0D0,-1.0D0,ewl,argdum) endif C------ wn istat = mcargstr(0, 'WN', 1, ' ', cwn ) if( cwn(1:3).eq.'ALL' ) then bwn = 1.0D0 ewn = 99999.0D0 else istat = mcargdbl(0,'WN',1,-1.0D0,0.0D0,-1.0D0,bwn,argdum) istat = mcargdbl(0,'WN',2, bwn,0.0D0,-1.0D0,ewn,argdum) endif C------ id istat = mcargstr(0, 'ID', 1, ' ', cid) C------ max and min relative numbers (position numbers) istat = mcargint(0, ' ', 2, 0, 0, -1, min_relativenum, argdum) istat = mcargint(0, ' ', 3, 0, 0, -1, max_relativenum, argdum) c --- MASK string nfiles = 0 istat = mcargstr(0,'MASK',1, ' ',mask_string) if(mask_string.ne. ' ') then c ------ get the list of files matching the string iret = m0getmaskfilelist( mask_string, MAX_IMAGE_FILES, * gathered_files, nfiles) c ------ if no files returned --> exit if( nfiles.le. 0 ) goto 101 c ------ the "area numbers" are really the positions of the c files in gathered_files. min_areanumber=1 max_areanumber=nfiles endif NABS=min_areanumber if (max_relativenum .lt. min_relativenum) & max_relativenum=min_relativenum if (max_areanumber .lt. min_areanumber) & max_areanumber=min_areanumber C------ block AUXFLAG = 0 istat = mcargstr(0, 'BLOCK', 1, ' ', cblock) if( cblock(1:3).eq.'AUX' ) AUXFLAG = 1 C------ Case of specifying a subgroup if (min_relativenum .eq. ALL) then all_check=1 relatv = 0 min_relativenum = 0 C------ Case of positive numbers elseif (min_relativenum .gt. 0) then relatv = 0 total_areas = max_areanumber-min_areanumber+1 if (max_relativenum .gt. total_areas) then max_relativenum = total_areas endif max_areanumber = max_relativenum + min_areanumber - 1 min_areanumber = min_relativenum + min_areanumber - 1 if (min_relativenum .gt. max_areanumber) goto 101 C------- Case of time ordered (0 or negative) elseif (min_relativenum .le. 0) then relatv = 1 C-------Test to see if -negative number is to large, if set number C-------equal to the number of areas minus 1 if (min_relativenum .le. -1 * (max_areanumber & -min_areanumber)) then min_relativenum = -1 * (max_areanumber & -min_areanumber) endif endif C-------Test bounds against legal area numbers if (relatv .eq. 0) then if (((min_areanumber .le. 0) .or. & (min_areanumber .gt. MAX_AREA_NUMBER)) .or. & ((max_areanumber .le. 0) .or. & (max_areanumber .gt. MAX_AREA_NUMBER))) goto 102 endif C-------- Trace out the ranges and flags call mctrace (1,'ADIR', 'area range '//cfi(min_areanumber) & //cfi(max_areanumber)) call mctrace (1,'ADIR', 'position range '//cfi(min_relativenum) & //cfi(max_relativenum)) call mctrace (1,'ADIR', 'rltiv,num areas'//cfi(relatv) & //cfi(total_areas) & //cfi(nabs)) C Filter out unwanted areas and sort newest to oldest c --- if we have a list of file names ... good_searchs = 0 pos = 0 if( nfiles.gt.0 ) then ifile = 1 c ------ loop through the list of file names returned by the c m0getmaskfilelist function above 50 continue if( ifile.gt.nfiles ) goto 100 c ------ call fullpathname to signal the area I/O routines c to use the files name instead of the area number istat = fullpathname( gathered_files(ifile) ) c ------ call aranam to return the name of the file istat = aranam(ifile,area_path) c ------ read the first 64 words as an area directory istat = m0readd(ifile,area_dir) if( istat.lt.0 ) then call mctrace(1,'ADIR','m0readd error '//cfi(istat)) goto 52 endif c ------ check area type code (should be 4 or 5) if( area_dir(2).eq.4 .or. area_dir(2).eq.5 ) then continue else goto 52 endif c ------ Convert area date istat = mciydtocyd(area_dir(4),area_date) if( istat.lt.0 ) goto 52 c ------ day/time to total seconds istat=mcdaytimetosec(area_date,area_dir(5),time_check) if( istat.lt.0 ) goto 52 c ------ this is a valid area, so the position must be saved pos = pos+1 c ------ do we have a wl list? if( bwl.ne.-1.0D0) then istat = m0wltoband( & area_dir, & bwl, & ewl, & wl_bband, & wl_eband & ) if( istat.eq.0 ) then if( bband.eq.0 .and. eband.eq.0 ) then bband = wl_bband eband = wl_eband else if( wl_bband.ge.bband ) bband = wl_bband if( wl_eband.le.eband ) eband = wl_eband endif endif endif c ------ do we have a wn list? if( bwn.ne.-1.0D0) then istat = m0wntoband( & area_dir, & bwn, & ewn, & wn_bband, & wn_eband & ) if( istat.eq.0 ) then if( bband.eq.0 .and. eband.eq.0 ) then bband = wn_bband eband = wn_eband else if( wn_bband.ge.bband ) bband = wn_bband if( wn_eband.le.eband ) eband = wn_eband endif endif endif c ------ Test against search conditions istat=m0specs( & ss1,ss2, & bday,eday, & btim,etim, & bband,eband, & cid, & area_dir & ) if( istat.lt.0 ) goto 52 c ------ test for specified position if( pos.lt.min_areanumber .or. & pos.gt.max_areanumber ) goto 52 c ------ passed all tests good_searchs = good_searchs + 1 search_list(good_searchs)=good_searchs search_pos(good_searchs)= pos work_array(good_searchs)=time_check ifile = ifile+1 goto 50 c ------ go here to eliminate a file name from the list 52 continue nfiles = nfiles-1 if( ifile.le.nfiles ) then do i=ifile, nfiles gathered_files(i) = gathered_files(i+1) enddo endif goto 50 c This code will select files if area numbers are used else do 152 area_index=min_areanumber,max_areanumber call mctrace(1,'ADIR','Area index is '//cfi(area_index)) istat = aranam(area_index,area_file) call mctrace(1,'ADIR','Area file is '// & area_file(1:len_trim(area_file))) c question exists whether volnam need be called if the c file is obtained from the mask field in the RESOLV.SRC file istat = volnam(area_file,area_path) call mctrace(1,'ADIR','Area path is '// & area_file(1:len_trim(area_path))) if (lwfile(area_path) .eq. 1) then file_ok = file_ok + 1 if (file_ok .gt. MAX_AREA_NUMBER) then goto 102 else istat = m0readd(area_index,area_dir) if( istat.lt.0 ) then call mctrace(1,'ADIR','m0readd error '//cfi(istat)) goto 152 endif c ------ check area type code (should be 4 or 5) if( area_dir(2).eq.4 .or. area_dir(2).eq.5 ) then continue else goto 152 endif endif C-------- Convert area date + time to total seconds if (relatv .eq. 1) then istat = mciydtocyd(area_dir(4),area_date) if (istat .lt. 0) goto 152 istat = mcdaytimetosec(area_date, area_dir(5), & time_check) if (istat .lt. 0) goto 152 endif call m0sxtrce('BEFORE WL: bband='//cfi(bband)) call m0sxtrce('BEFORE WL: eband='//cfi(eband)) c ------------- do we have a wl list? if( bwl.ne.-1.0D0) then istat = m0wltoband( & area_dir, & bwl, & ewl, & wl_bband, & wl_eband & ) if( istat.eq.0 ) then if( bband.eq.0 .and. eband.eq.0 ) then bband = wl_bband eband = wl_eband else if( wl_bband.ge.bband ) bband=wl_bband if( wl_eband.le.eband ) eband=wl_eband endif endif endif call m0sxtrce('AFTER WL: bband='//cfi(bband)) call m0sxtrce('AFTER WL: eband='//cfi(eband)) c ------------- do we have a wn list? if( bwn.ne.-1.0D0) then istat = m0wntoband( & area_dir, & bwn, & ewn, & wn_bband, & wn_eband & ) if( istat.eq.0 ) then if( bband.eq.0 .and. eband.eq.0) then bband = wn_bband eband = wn_eband else if( wn_bband.ge.bband ) bband=wn_bband if( wn_eband.le.eband ) eband=wn_eband endif endif endif call m0sxtrce('AFTER WN: bband='//cfi(bband)) call m0sxtrce('AFTER WN: eband='//cfi(eband)) C-------Test against search conditions search_ok=m0specs( & ss1,ss2, & bday,eday, & btim,etim, & bband,eband, & cid, & area_dir & ) if (search_ok .eq. 0) then good_searchs = good_searchs + 1 search_list(good_searchs)=area_index search_pos(good_searchs)=area_index-NABS+1 C------- Add time to list of times if (relatv .eq. 1) then work_array(good_searchs) = time_check end if endif endif 152 continue endif 100 continue if (good_searchs .eq. 0) goto 101 C-------Time sort if (relatv .eq. 1) then do 61 area_index=1,good_searchs do 51 filter_index=area_index,good_searchs if (work_array(area_index) .ge. & work_array(filter_index)) goto 51 temp_time=work_array(area_index) work_array(area_index)=work_array(filter_index) work_array(filter_index)=temp_time temp_areanum=search_list(area_index) search_list(area_index)= & search_list(filter_index) search_list(filter_index)=temp_areanum temp_areanum=search_pos(area_index) search_pos(area_index)= & search_pos(filter_index) search_pos(filter_index)=temp_areanum 51 continue 61 continue end if C------Determine the loop bounds for listing for time and non-based C------requests if (relatv .eq. 1) then begin_list = 1 if (good_searchs .le. -min_relativenum) then end_list = good_searchs else end_list = -min_relativenum + 1 endif else begin_list = 1 end_list = good_searchs endif C-----Send response. For each area, directory and comments, if any do 80 area_index=begin_list,end_list area_number=search_list(area_index) pos=search_pos(area_index) if( nfiles.gt.0 ) then iret=fullpathname(gathered_files(search_list(area_index))) endif c -------- read the image directory block istat = m0readd(area_number,area_dir) if( istat.lt.0 ) then call mctrace(1,'ADIR','m0readd error '//cfi(istat)) goto 80 endif c ------ check area type code (should be 4 or 5) if( area_dir(2).eq.4 .or. area_dir(2).eq.5 ) then continue else goto 80 endif call mctrace(1,'adirserv','embedded comment cards '// & cfi(area_dir(64))) c -------- Get comment cards ncard=0 istat = ICGET(0,CARDS) 5 istat = ICGET(area_number,CARDS(1+20*NCARD)) if ((istat .eq. 0) .and. (ncard .lt. maxcards-100)) then ncard=ncard+1 goto 5 endif call mctrace(1,'adirserv','num comment cards '//cfi(ncard)) c c--- attach some cards that the client applications might need c--- we are putting these values here because there is no room c--- in the area directory and the comment card section is c--- currently the only expandable structure we have to pass c--- variable length information. c c c--- lat and lon at center of image c istat = mcargstr(0, 'AUX', 1, 'N', getaux) if (getaux(1:1) .eq. 'Y') then call mctrace(1,'adirserv','GET AUX INFO') ilin = area_dir(6) + ((area_dir(9)/2) * area_dir(12)) iele = area_dir(7) + ((area_dir(10)/2) * area_dir(13)) xlin = ilin xele = iele call mctrace(1,'adirserv','Center line ='//cfi(ilin)) call mctrace(1,'adirserv','Center elem ='//cfi(iele)) c ------------ initialize the navigation istat = nvset('AREA', area_number) call mctrace(1,'adirserv','nvset status ='//cfi(istat)) if (istat .eq. 0) then c --------------- get the navigation for the center point of the image istat = nv1sae(xlin, xele, xdum, xlat, xlon, xdum) call mctrace(1,'adirserv','nv1sae status ='// & cfi(istat)) if (istat .eq. 0) then c ------------------ center latitude card call mctrace(1,'adirserv','Center Lat ='// & cfg(xlat)) ctemp = 'Center latitude = ' // cfg(xlat) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c ------------------ center longitude card call mctrace(1,'adirserv','Center Lon ='// & cfg(xlon)) ctemp = 'Center longitude = ' // cfg(xlon) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 endif endif ! end of center lat/lon c ------------ resolution of image if (istat .eq. 0) then c --------------- check for pole as center point if(nint(abs(xlat)) .eq. 90) then ilin = area_dir(6) + area_dir(12)*area_dir(9)/4 iele = area_dir(7) + area_dir(13)*area_dir(10)/4 xlin = ilin xele = iele istat = nv1sae(xlin, xele, 0.0, xlat, xlon, xdum) endif c --------------- move the center point one line down for Latitude Res calc c ilin = ilin + area_dir(12) c xlin = ilin xlin = ilin + area_dir(12) xele = iele istat = nv1sae(xlin, xele, 0.0, xlat2, xlon2, xdum) istat = lltora(xlat,xlon,xlat2,xlon2,range1,azimuth) c xlat = xlat2 c xlon = xlon2 c --------------- move the center point one element over for Longitude Res calc xlin = ilin c iele = iele + area_dir(13) c xele = iele xele = iele + area_dir(13) istat = nv1sae(xlin, xele, 0.0, xlat2, xlon2, xdum) istat = lltora(xlat,xlon,xlat2,xlon2,range2,azimuth) xltres = real((range1 + range2) / 2.0) xlnres = xltres c --------------- computed latitude resolution card ctemp = 'Computed Latitude resolution (km) = '// & cfg( real(range1) ) call bsquez(ctemp) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c --------------- latitude resolution card ires = nint(xltres) if(ires .eq. 0) then ctemp='Latitude resolution (km) = ' // cfg(xltres) else ctemp='Latitude resolution (km) = ' // cfi(ires) endif call bsquez(ctemp) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c --------------- computed longitude resolution ctemp = 'Computed Longitude resolution (km) = '// & cfg( real(range2) ) call bsquez(ctemp) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c --------------- longitude resolution ires = nint(xlnres) if(ires .eq. 0) then ctemp='Longitude resolution (km) = ' // cfg(xlnres) else ctemp='Longitude resolution (km) = ' // cfi(ires) endif call bsquez(ctemp) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 endif ! end of resolution c ------------ valid calibration types istat = kbprep(1, area_dir(52)) call mctrace(1,'adirserv','kbprep status ='//cfi(istat)) if (istat .eq. 0) then c --------------- get the valid types from kb1opt stype = area_dir(52) if( area_dir(57).ne.0 ) stype=area_dir(57) ibuf(1) = area_dir(3) ibuf(2) = area_dir(4) ibuf(3) = area_dir(5) ibuf(17) = area_number ibuf(37) = stype c --------------- offset to the calibration block ibuf(63) = area_dir(63) c --------------- construct a band map of the image status=m0bandmap(area_dir, MAX_BAND, num_bands, bands) c -----If type 5, send back only one set of calibration units if(area_dir(2) .eq. 5) num_bands = 1 c --------------- if BAND=ALL then set the last band if( eband.eq.9999 ) then bband = 1 eband = bands(num_bands) endif call m0sxtrce('BBAND='//cfi(bband)) call m0sxtrce('EBAND='//cfi(eband)) do 300 iband=1,num_bands c --------------- filter based on requested bands if( BAND_SPECIFIED ) then if( & bands(iband).lt.bband .or. & bands(iband).gt.eband & ) goto 300 endif ibuf(4) = bands(iband) c --------------- Patch for GOESR/S DQF values if( & ibuf(1).eq.GOESR_SSS .or. & ibuf(1).eq.GOESS_SSS & ) then istat = kb1opt('TDQF', ibuf, dqfs) if( istat.eq.0 ) then cband = cfi(bands(iband)) call bsquez( cband ) len = len_trim( cband ) do k = 1,8 if( k.eq.1 ) kk=5 if( k.eq.2 ) kk=6 if( k.eq.3 ) kk=7 if( k.eq.4 ) kk=8 if( k.eq.5 ) kk=1 if( k.eq.6 ) kk=2 if( k.eq.7 ) kk=3 if( k.eq.8 ) kk=4 if( dqfs(kk).eq.65530 ) then cdqfs(k) = 'NA ' n(k) = 3 elseif( dqfs(kk).eq.65531 ) then cdqfs(k) = 'ND ' n(k)= 3 else dvalue = DBLE(dqfs(kk)) / 100.0D0 cvalue = cfi( NINT(dvalue) ) if( kk.le.5 ) then cdqfs(k) = cvalue(10:12)//'% ' else cdqfs(k) = cvalue(10:12)//'K ' endif n(k) = 5 endif enddo ctemp = 'DQF for band '// & cband(1:len)//'= '// & cdqfs(1)(1:n(1))// & cdqfs(2)(1:n(2))// & cdqfs(3)(1:n(3))// & cdqfs(4)(1:n(4))// & cdqfs(5)(1:n(5))// & cdqfs(6)(1:n(6))// & cdqfs(7)(1:n(7))// & cdqfs(8)(1:n(8)) c call bsquez( ctemp ) len_ctemp = len_trim( ctemp ) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 endif endif c --------------- Patch for GOESR/S DQF values istat = kb1opt('KEYS', ibuf, keys) if (istat .eq. 0) then do 310 ikey=2,keys(1)+1 c c--- find an expanded name for the c--- key if it exists c exptxt = ' ' do 320 inick=1,MAXNAM if (clit(keys(ikey)) .eq. keynam(inick)) then exptxt = keyexp(inick) endif 320 continue c ------- All bands have same calibration for type 5 areas if( area_dir(2) .eq. 5) then ctemp = 'Valid calibration unit for band ALL ' else cband = cfu(bands(iband)) ctemp = 'Valid calibration unit for band ' & //cband(1:2) endif len_ctemp = len_trim( ctemp ) ckey = clit(keys(ikey)) call bsquez( exptxt ) len_exptxt = len_trim( exptxt ) ctemp = & ctemp(1:len_ctemp)// & ' = '//ckey(1:4)// & ' "'//exptxt(1:len_exptxt)//'"' call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 310 continue endif 300 continue endif ! end of valid cal types c ------ NEXRAD data: construct radar info cards if( clit(stype).eq.'NEXR' ) then call mctrace(1,'adirserv','NEXRAD data') c --------- get the INFO aux entry istat = aranam(area_number,area_file) istat = lbi( & area_file, & area_dir(60), & min0( area_dir(61), MAX_INFO ), & nexrad_info & ) c --------- verify that this is an INFO aux block call movwc( nexrad_info(5), cval4 ) if( cval4(1:4).eq.'INFO' ) then c --------- check the AUX entry byte order FLIP_BYTES = .FALSE. if( nexrad_info(1).ne.MAGIC_NUMBER ) then call fbyte4( nexrad_info(1),1 ) if( nexrad_info(1).ne.MAGIC_NUMBER ) goto 400 FLIP_BYTES = .TRUE. endif c --------- Site ID card call movwc( nexrad_info(18), cval8) if( FLIP_BYTES ) call fbyte4( nexrad_info(20), 3 ) lat_sign = ' ' if( nexrad_info(20).lt.0 ) lat_sign = '-' cval12_1 = cfi( nexrad_info(20)/10000 ) cval12_2 = cfj( mod(nexrad_info(20),10000)/100 ) cval12_3 = cfj( mod(nexrad_info(20),100) ) lon_sign = ' ' if( nexrad_info(21).lt.0 ) lon_sign = '-' cval12_4 = cfi( nexrad_info(21)/10000 ) cval12_5 = cfj( mod(nexrad_info(21),10000)/100 ) cval12_6 = cfj( mod(nexrad_info(21),100) ) cval12_7 = cfi( nexrad_info(22) ) len_cval12_7 = len_trim( cval12_7 ) len_cval8 = len_trim( cval8 ) ctemp = 'ID = '//cval8(1:len_cval8)//' '// & 'Lat = '//lat_sign(1:1)//cval12_1(11:12)//':'// & cval12_2(11:12)//':'// & cval12_3(11:12)//' '// & ' Lon = '//lon_sign(1:1)//cval12_4(10:12)//':'// & cval12_5(11:12)//':'// & cval12_6(11:12)//' '// & ' Elev = '//cval12_7(8:12)//' FT' call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c --------- Product Code card if( FLIP_BYTES ) call fbyte4( nexrad_info(16), 1 ) if( & nexrad_info(16).eq.19 .or. & nexrad_info(16).eq.20 .or. & nexrad_info(16).eq.37 .or. & nexrad_info(16).eq.41 .or. & nexrad_info(16).eq.57 .or. & nexrad_info(16).eq.78 .or. & nexrad_info(16).eq.80 & ) then NOMIN = .TRUE. else NOMIN = .FALSE. endif cval12_1 = cfu( nexrad_info(16) ) len_cval12_1 = len_trim( cval12_1) call movwc( nexrad_info(6), cval40 ) len_cval40 = len_trim( cval40 ) call movwc( nexrad_info(29), cval8) if( cval8(1:3).eq.'-99' ) cval8 = 'LAYER' ctemp = 'Pcode = '//cval12_1(1:len_cval12_1)//' '// & '-> '//cval40(1:len_cval40)//' '// & ' Tilt = '//cval8(1:8) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c --------- Resolution card if( FLIP_BYTES ) call fbyte4( nexrad_info(26), 3 ) cval12_1 = cfu( nexrad_info(26) ) len_cval12_1 = len_trim( cval12_1 ) cval12_2 = cfu( nexrad_info(27) ) len_cval12_2 = len_trim( cval12_2 ) cval12_3 = cfu( nexrad_info(28) ) len_cval12_3 = len_trim( cval12_3 ) ctemp = 'Resolution = '// & cval12_2(1:len_cval12_2)//' km '// & 'Range = '// & cval12_1(1:len_cval12_1)//' km '// & 'Update = '// & cval12_3(1:len_cval12_3)//' min ' call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c --------- Day/Time card if( FLIP_BYTES ) call fbyte4( nexrad_info(34), 4 ) cval12_1 = cfu( nexrad_info(34) ) len_cval12_1 = len_trim( cval12_1 ) cval12_2 = cfu( nexrad_info(35) ) len_cval12_2 = len_trim( cval12_2 ) cval12_3 = cfu( nexrad_info(36) ) len_cval12_3 = len_trim( cval12_3 ) cval12_4 = cfu( nexrad_info(37) ) len_cval12_4 = len_trim( cval12_4 ) ctemp = 'Day/Time: Start = '// & cval12_1(1:len_cval12_1)//'/'// & cval12_2(1:len_cval12_2)//' '// & 'End = '// & cval12_3(1:len_cval12_3)//'/'// & cval12_4(1:len_cval12_4) call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c --------- Min/Max card if( FLIP_BYTES ) call fbyte4( nexrad_info(31), 3 ) dval = dble(nexrad_info(32))/dble(nexrad_info(31)) cval12_1 = cff( dval, 1 ) call bsquez( cval12_1 ) len_cval12_1 = len_trim( cval12_1 ) dval = dble(nexrad_info(33))/dble(nexrad_info(31)) cval12_2 = cff( dval, 1 ) call bsquez( cval12_2 ) len_cval12_2 = len_trim( cval12_2 ) call movwc( nexrad_info(39), cunit) len_cunit = len_trim( cunit ) if( NOMIN ) then ctemp = 'Values: Max = '// & cval12_2(1:len_cval12_2)//' '//cunit(1:len_cunit) else ctemp = 'Values: Min = '// & cval12_1(1:len_cval12_1)//' '//cunit(1:len_cunit)// & ' Max = '// & cval12_2(1:len_cval12_2)//' '//cunit(1:len_cunit) endif call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 c --------- Level cards if( FLIP_BYTES ) call fbyte4( nexrad_info(41), 3 ) dscale = dble( nexrad_info(43) ) doffset = dble( nexrad_info(42) ) / dscale do i = 0,9 ival = 10**i if( ival.eq.nexrad_info(43) ) goto 1 enddo i = 1 1 continue pow = max( i, 1 ) do i = 1, nexrad_info(41) cval12_1 = cfi(i-1) if( FLIP_BYTES ) call fbyte4( nexrad_info(43+i), 1 ) ival = nexrad_info(43+i) c ------------ attach correct units if( ival.eq.-9996 ) then dval = dble(nexrad_info(43+i)) cval8 = 'RF' elseif( ival.eq.-9997 ) then dval = dble(nexrad_info(43+i)) cval8 = 'ND' elseif( ival.eq.-9998 ) then dval = dble(nexrad_info(43+i)) cval8 = 'TH' elseif( ival.eq.-9999 ) then dval = dble(nexrad_info(43+i)) cval8 = ' ' else dval = ( dble(nexrad_info(43+i)) / dscale ) + doffset cval8 = cunit endif cval12_2 = cff( dval, pow ) ctemp = 'Values: '// & cval12_1(11:12)//' -> '// & cval12_2( 6:12)//' '//cval8 call movcw(ctemp, CARDS(1+20*ncard)) ncard = ncard + 1 enddo endif endif endif ! end of aux information 400 continue IF(NCARD.GE.MAXCARDS-2) NCARD=0 NBYTES=260+80*NCARD area_dir(64)=NCARD call mctrace(1,'adirserv','Ncard = '//cfi(ncard)) c --- AUX block transfer NAUX = m0arasize('AUX', area_dir) if ((naux .ne. 0) .and. (AUXFLAG .eq. 1)) then CALL MCTRACE(1, servername, 'sending the AUX block') IF( NAUX.GT.MAX_AUXBLOCK_SIZE*4 ) GOTO 103 CALL ARAGET( area_number, area_dir(60), NAUX, AUXBUF ) else naux = 0 endif C------Account for bytes sent request(41)=request(41)+NBYTES+NAUX NB=NBYTES+NAUX C------Record header = length CALL SWBYT4(NB,1) CALL M0SXSEND(4,NB) C-------Transform to network format area_dir(1)=pos CALL SWBYT4(area_dir(1),20) IF(ISCHAR(area_dir(21)).EQ.0) CALL SWBYT4(area_dir(21),1) CALL SWBYT4(area_dir(22),3) CALL SWBYT4(area_dir(33),19) CALL SWBYT4(area_dir(54),1) CALL SWBYT4(area_dir(59),6) c --- send the area number call swbyt4(area_number,1) call m0sxsend(4,area_number) call mctrace(1,'adirserv','sent NUM ') c --- send the directory block call m0sxsend(256,area_dir) call mctrace(1,'adirserv','sent DIR ') c --- send the comment block if( ncard.ne.0) then call m0sxsend(ncard*80,cards) call mctrace(1,'adirserv','sent COM ') endif c --- send the auxiliary block if( naux.ne.0 ) then call m0sxsend(naux,auxbuf) call mctrace(1,'adirserv','sent AUX ') endif 80 CONTINUE call puc(olduc31, -31) call puc(olduc32, -32) call puc(olduc33, -33) RETURN 101 area_path='No images satisfy the selection criteria' request(43)=-51 CALL MOVCW(area_path(1:72),request(44)) call puc(olduc31, -31) call puc(olduc32, -32) call puc(olduc33, -33) RETURN 102 area_path='Maximum number of images for a group exceeded' request(43)=-52 CALL MOVCW(area_path(1:72),request(44)) call puc(olduc31, -31) call puc(olduc32, -32) call puc(olduc33, -33) RETURN 103 area_path='Maximum size of AUX block buffer exceeded' request(43)=-54 CALL MOVCW(area_path(1:72),request(44)) call puc(olduc31, -31) call puc(olduc32, -32) call puc(olduc33, -33) RETURN END