C Copyright(c) 2014, 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: msgsaget2.f,v 1.15 2021/02/05 04:35:14 daves Exp $ *** C This server was adapted from code supplied to SSEC from EUMETSAT. C Fortran 90 extensions have been replaced with COMMON blocks and C location of source datasets have been generalized. Comments have C been added for future maintance and expansion of functionality. C Code flow remains as close to original src as possible. C NAVIGATION block was changed from type=MSG to type=MGST. This C was done to allow NAVCALC to work with these images C Code moved from McIDAS-XRD to McIDAS-X subroutine msgsaget2( request ) implicit none c --- include files include 'areaparm.inc' include 'fileparm.inc' include 'imgdparm.inc' c --- constants character*8 servername parameter (servername = 'MSGSAGET') integer MAXGFILE parameter (MAXGFILE = 10000) integer MAXSERVE parameter (MAXSERVE = 30000) double precision POWER parameter (POWER = .0000152587891) c --- parameters integer request(*) c --- external functions character*12 cfu integer lit integer read_get_request integer readfile_information integer read_file_header integer select_files integer adjust_coordinates integer calibration integer nvprep integer nv2ini integer kbprep integer kb1opt integer serve_data_ir_vis integer serve_data_hrv c --- internal variables character*12 cvalue character*72 reqerr integer status integer number_bytes integer number_lines_file integer area_dir(64) integer calibration_int(400) integer cal_option(10) integer idummy(10) c --- common holds file names integer MAXFILE integer number_elements_file integer number_elements_hrv_file integer number_files integer number_serve_files character*512 gathered_files(MAXGFILE) common/FILCOM/ & MAXFILE, & number_elements_file, & number_elements_hrv_file, & number_files, & number_serve_files, & gathered_files c --- common holds request character*4 request_unit character*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- holds navigation entries real sublon integer bounds(4) integer planned_bounds(4) integer HRV_bounds(8) integer navigation_data(128) logical SUBSET logical RAPIDSCAN common/NAVCOM/ & sublon, & bounds, & planned_bounds, & HRV_bounds, & navigation_data, & SUBSET, & RAPIDSCAN c --- holds calibration entries real ac(8,4) real bc(8,4) real calibration_data(6) real cal_special(6,4) real center_freq(8,4) real c1 real c2 CHARACTER*1600 calibration_char common/CALCOM/ & ac, & bc, & calibration_data, & cal_special, & center_freq, & c1, & c2, & calibration_char c --- holds serve entries integer number_select_files integer serve_pos(MAXSERVE) integer serve_day(MAXSERVE) integer serve_time(MAXSERVE) integer serve_ss(MAXSERVE) character*12 serve_band(MAXSERVE) character*150 serve_filename(MAXSERVE) common/SRVCOM/ & number_select_files, & serve_pos, & serve_day, & serve_time, & serve_ss, & serve_band, & serve_filename c --- holds the band map character*12 cbandmap common/BANDCOM/ & cbandmap equivalence (calibration_char, calibration_int) C ************************************************************************************ c --- identify the server call m0sxtrce(servername(1:8)//' *******************************') call m0sxtrce(servername(1:8)//' START V0.1') MAXFILE = MAXGFILE c --- Read the client request status = read_get_request( ) if( status.lt.0 ) then if( status.eq.-1 ) then reqerr = 'Band keyword required for multi-banded images' call movcw (reqerr,request(44)) request(43) = -51 return endif if( status.eq.-2 ) then reqerr = 'Server does not support multi-banded transfers' call movcw (reqerr,request(44)) request(43) = -51 return endif if( status.eq.-3 ) then reqerr = 'No images satisfy the selection criteria' call movcw (reqerr,request(44)) request(43) = -51 return endif endif c --- Use mask to find files status = readfile_information( ) if( status.le.0 ) then if( status.eq.0 ) then reqerr = 'No images satisfy the selection criteria' call movcw(reqerr,request(44)) request(43) = -51 return endif if( status.eq.-1 ) then reqerr = 'Invalid position number specified' call movcw(reqerr,request(44)) request(43) = -51 return endif endif c --- apply the search conditions to the file list status = select_files( ) if( status.lt.0 ) then reqerr = 'No images satisfy the selection criteria' call movcw (reqerr,request(44)) request(43) = -51 return endif c --- For the "get" server we just serve the last image found c in the selection process (index number_select_files) status = read_file_header( number_select_files ) c --- Determine whether requested BAND is in the image file if( & request_band.gt.0 .and. & request_band.le.12 .and. & cbandmap(request_band:request_band).ne.'X' & ) then reqerr = 'No images satisfy the selection criteria' call movcw(reqerr,request(44)) request(43) = -51 return endif c --- Find number of lines and elements in the file c ALlow for padding of HRV data in case of a SUBSET number_lines_file = bounds(1) - bounds(2) + 1 number_elements_file = bounds(3) - bounds(4) + 1 number_elements_hrv_file = number_elements_file * 3 if( .NOT.SUBSET ) & number_elements_hrv_file = number_elements_hrv_file / 2 if( cbandmap(12:12).EQ.'X' ) then call test_10byte( number_elements_hrv_file ) HRV_bounds(4) = HRV_bounds(3) - number_elements_hrv_file + 1 if( .NOT.RAPIDSCAN ) & HRV_bounds(8) = HRV_bounds(7) - number_elements_hrv_file + 1 else number_elements_hrv_file = 0 endif c --- Change the respective element numbers so that full c 10 bit entries are fulfilled call test_10byte( number_elements_file ) bounds(4) = bounds(3) - number_elements_file + 1 c --- Make the Navigation parameters: c navigation_data(1) = LIT('MSG ') c navigation_data(2) = -sublon*10000 c --- changed to MSGT naviagtion navigation_data(1) = lit('MSGT') navigation_data(2) = 1856.*10. navigation_data(3) = 1856.*10. navigation_data(4) = 13642337.*(POWER)*1000000. navigation_data(5) = 13642337.*(POWER)*1000000. navigation_data(6) = -sublon*10000 c --- Find the starting upper left corner status = adjust_coordinates( ) if( status.lt.0 ) then if( status.eq.-1 ) & reqerr = 'FAILED -- Initialization of nav module' if( status.eq.-2 ) & reqerr = 'FAILED -- Earth to Image transform' if( status.eq.-3 ) & reqerr = 'The requested portion of the image does not exist' call movcw(reqerr,request(44)) request(43) = -51 return endif c --- Make the AREA directory call zerow(64,area_dir) area_dir(1) = serve_pos(number_select_files) area_dir(2) = 4 area_dir(3) = serve_ss(number_select_files) area_dir(4) = serve_day(number_select_files) - 1900000 area_dir(5) = serve_time(number_select_files) area_dir(6) = request_image_line area_dir(7) = request_image_element area_dir(8) = 1 area_dir(9) = requ_number_lines area_dir(10) = ((requ_number_elements+3)/4) * 4 area_dir(11) = requ_byte_resolution if( request_band.ne.12 ) then area_dir(12) = 3 * line_resolution area_dir(13) = 3 * element_resolution else area_dir(12) = line_resolution area_dir(13) = element_resolution endif area_dir(14) = 1 area_dir(17) = area_dir(4) area_dir(18) = area_dir(5) area_dir(19) = 2**(request_band-1) area_dir(34) = 2368 area_dir(35) = 256 area_dir(52) = LIT('MSG ') area_dir(53) = lit(request_unit) area_dir(59) = 1 area_dir(63) = 768 c --- initialize the calibration transform status = kbprep( 1,area_dir(52) ) if(request_csstr(1:3) .eq. 'EXP') then cal_option(1) = request_band cal_option(2) = area_dir(3) cal_option(3) = 1 status = kb1opt('STR ', cal_option, idummy) if(status .eq. 0) then area_dir(EXP_BRIT_FLAG) = 1 call movw(2, idummy, area_dir(EXP_BRIT_NAME1)) endif endif if( request_unit.eq.'TEMP' ) then area_dir(58) = LIT('K ') area_dir(59) = 100 elseif( request_unit.eq.'RAD ' ) then area_dir(58) = LIT('mWm2') area_dir(59) = 100 if(request_band.ge.4.and.request_band.le. 6) area_dir(59)=1000 elseif( request_unit.EQ.'REFL' ) then area_dir(58) = LIT('% ') area_dir(59) = 100 elseif( request_unit.EQ.'BRIT' ) then area_dir(58) = LIT(' ') area_dir(59) = 1 elseif( request_unit.EQ.'RAW ' ) then area_dir(58) = LIT(' ') area_dir(59) = 1 else reqerr = 'The requested calibration does not exist' call movcw(reqerr,request(44)) request(43) = -51 return endif c --- calibration (IR only) status = calibration( ) c **************** BEGIN DATA TRANSFER ******************** c --- compute the number of bytes that will be transfered cvalue = cfu( area_dir(9) ) call m0sxtrce(' lines='//cvalue) cvalue = cfu( area_dir(10) ) call m0sxtrce(' elems='//cvalue) cvalue = cfu( requ_byte_resolution ) call m0sxtrce(' res='//cvalue) number_bytes = & 64*4 + & 128*4 + & 400*4 + & area_dir(9)*area_dir(10)*requ_byte_resolution call swbyt4( number_bytes,1 ) call m0sxsend( 4,number_bytes ) c --- send the directory block call swbyt4( area_dir(1),64 ) call swbyt4( area_dir(52),2 ) call m0sxsend( 256,area_dir ) call swbyt4( area_dir(1),64 ) call swbyt4( area_dir(52),2 ) c --- send the navigation block c call swbyt4( navigation_data(2),1 ) c call m0sxsend( 512,navigation_data(1) ) c call swbyt4( navigation_data(2),1 ) c --- changed to MSGT navigation call swbyt4( navigation_data(2),5 ) call m0sxsend( 512,navigation_data(1) ) call swbyt4( navigation_data(2),5 ) c --- send the calibration block call m0sxsend( 1600,calibration_char ) c --- initialize the navigation transform status = nvprep( 2,navigation_data(1) ) status = nv2ini( 2,'LL ' ) c --- Read and send image data line by line if( request_band.ne.12 ) then status = serve_data_ir_vis( area_dir ) else status = serve_data_hrv( area_dir ) endif c --- check read status if( status.ne.0 ) then reqerr = 'FAILED -- reading source file' call movcw(reqerr,request(44)) request(43) = -51 return endif c --- FINISHED reqerr = 'Done' request(43) = 0 call movcw(reqerr,request(44)) call m0sxdone(request) return end integer function read_get_request( ) implicit none c --- constants c --- external variables integer len_trim integer m0sxdatasetinfo integer mcargnum integer mcargint integer mcargstr integer mcargiyd integer mcargihr integer mcargdll integer lit c --- internal varaibles character*12 cvalue character*256 char_dummy character*256 mcidas_dataset integer status integer i integer ir integer len integer len_group integer len_descriptor integer num_date integer num_time integer ALL double precision dlat double precision dlon c --- common holds request character*4 request_unit character*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- initialize the function value read_get_request = 0 c --- create the ALL variable ALL = lit('ALL ') CALL swbyt4 (ALL,1) c --- ADDE group status = mcargstr(0,' ',0,' ',dataset_group) call bsquez( dataset_group ) len_group = len_trim( dataset_group ) c --- ADDE descriptor status = mcargstr(0,' ',1,' ',dataset_descriptor) call bsquez( dataset_descriptor ) len_descriptor = len_trim( dataset_descriptor ) c --- trace the group/descriptor mcidas_dataset = dataset_group(1:len_group)//' '// & dataset_descriptor(1:len_descriptor) call bsquez( mcidas_dataset ) len = len_trim( mcidas_dataset ) call m0sxtrce(' DATASET='//mcidas_dataset(1:len)) c --- read dataset information status = m0sxdatasetinfo( & mcidas_dataset, & dataset_group, & dataset_descriptor, & data_type, & data_kind, & data_mask, & data_info, & comment, & minrange, & maxrange, & real_time & ) c --- Get requested BAND and check for validity status = mcargnum(0,'BAN.D') if( status.le.0 ) then read_get_request = -1 return endif status = mcargint(0,'BAN.D',1,0,1,12,begin_band,cvalue) if( status.lt.0 ) then read_get_request = -3 return endif status = mcargint(0,'BAN.D',2,begin_band,begin_band,12, & end_band,cvalue) if( status.lt.0 ) then read_get_request = -3 return endif c --- server only supports single band transfers if( begin_band.ne.end_band) then read_get_request = -2 return endif request_band = begin_band c --- Get requested DAY status = mcargiyd(0,'DAY ',1,-1,0,-1,begin_day,cvalue) end_day = begin_day if( begin_day.ne.-1 ) num_time = 1 c --- Get requested TIME range status = mcargihr(0,'TIM.E',1,-1,0,-1,begin_time,cvalue) status = mcargihr(0,'TIM.E',2,-1,0,-1,end_time,cvalue) if( end_time.lt.begin_time ) end_time = begin_time if( begin_time.ne.-1 ) num_time = num_time+1 c --- Get position number status = mcargint(0,' ',2,-1,0,9999,begin_position,cvalue) call m0sxtrce(' Request Position ='//cvalue) end_position = begin_position c --- if DAY and/or TIME was specified AND poistion is 0 (zero) c signal a time search (scan ALL positions) if( & (num_time.gt.0) .and. & (begin_position.eq.0 ) & ) then begin_position = ALL endif c --- Get resolution (only important if this is negative!) status = mcargint(0,' ',6,1,0,-1,ir,cvalue) status = mcargint(0,'LMA.G',1,ir,0,-1,line_resolution,cvalue) status = mcargint(0,'EMA.G',1,ir,0,-1,element_resolution,cvalue) line_resolution = IABS(line_resolution) element_resolution = IABS(element_resolution) c --- Get units status = mcargstr(0,'UNI.TS',1,'RAW',request_unit) status = mcargstr(0,'UNI.TS',2, ' ', request_csstr) C --- Get byte resolution if( request_unit(1:3).EQ.'RAW' ) requ_byte_resolution = 2 if( request_unit(1:3).EQ.'RAD' ) requ_byte_resolution = 4 if( request_unit(1:4).EQ.'TEMP' ) requ_byte_resolution = 2 if( request_unit(1:4).EQ.'REFL' ) requ_byte_resolution = 4 if( request_unit(1:4).EQ.'BRIT' ) requ_byte_resolution = 1 c --- spacing status = mcargint( & 0, & 'SPA.C',1, & requ_byte_resolution, & 0, & 4, & requ_byte_spacing, & cvalue & ) if(requ_byte_spacing.eq.0) requ_byte_spacing= requ_byte_resolution c --- Get size of image window status = mcargint(0,' ',7,480,0,-1,requ_number_lines,cvalue) status = mcargint(0,' ',8,640,0,-1,requ_number_elements,cvalue) if( request_band.ne.12 ) then requ_number_lines = MIN(requ_number_lines, 3712) requ_number_elements = MIN(requ_number_elements, 3712) else requ_number_lines = MIN(requ_number_lines, 11136) requ_number_elements = MIN(requ_number_elements, 11136) endif c --- Get requested coordinate system status = mcargstr(0,' ',3,' ',request_coordinate) c --- set all possible requests to -999, just to be sure request_image_line = -999 request_image_element = -999 request_file_line = -999 request_file_element = -999 request_latitude = -999.0 request_longitude = -999.0 c --- Handle the case of EARTH coordinates (type E) if( request_coordinate(1:1).eq.'E' ) then status = mcargdll( & 0,' ',4, & -999.0D0,-90.0D0,90.0D0, & dlat,cvalue & ) request_latitude = REAL( dlat ) status = mcargdll( & 0,' ',5, & -999.0D0,-180.0D0,180.0D0, & dlon,cvalue) request_longitude = REAL( dlon ) c --- Handle the case of FILE coordinates (type A, zero-based in McIDAS) elseif( request_coordinate(1:1).eq.'A' ) then status = mcargint(0,' ',4,0,0,-1,request_file_line,cvalue) status = mcargint(0,' ',5,0,0,-1,request_file_element,cvalue) request_file_line = request_file_line + 1 request_file_element = request_file_element + 1 c --- Handle the case of IMAGE coordinates (type I, one-based) elseif( request_coordinate(1:1).eq.'I' ) then status = mcargint(0,' ',4,1,0,-1,request_image_line,cvalue) status = mcargint(0,' ',5,1,0,-1,request_image_element,cvalue) c ----- Round the request to nearest centre of IR/VIS pixel to avoid confusion if( request_band.ne.12 ) then request_image_line = INT((request_image_line+1.9)/3.) * 3 request_image_element = INT((request_image_element+1.9)/3.)* 3 endif c --- Handle the case that nothing is specified (file start in upper left corner) else request_coordinate(1:2) = 'AU' request_file_line = 1 request_file_element = 1 endif return end integer function readfile_information( ) implicit none c --- constants integer MAXGFILE parameter (MAXGFILE = 10000) c --- external functions character*12 cfu integer lit integer lbi integer len_trim integer m0getmaskfilelist c --- internal variables character*12 cvalue integer status integer len_mask integer iALL integer absolute_begin integer absolute_end c --- common holds file names integer MAXFILE integer number_elements_file integer number_elements_hrv_file integer number_files integer number_serve_files character*512 gathered_files(MAXGFILE) common/FILCOM/ & MAXFILE, & number_elements_file, & number_elements_hrv_file, & number_files, & number_serve_files, & gathered_files c --- common holds request character*4 request_unit character*12 request_csstr character*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- create the ALL variable iALL = lit('ALL ') CALL swbyt4 (iALL,1) c --- for debug call bsquez( data_mask ) len_mask = len_trim( data_mask ) call m0sxtrce(' MASK='//data_mask(1:len_mask)) cvalue = cfu( MAXFILE ) call m0sxtrce(' MAX FILES='//cvalue) c --- get a list of files matching the mask status = m0getmaskfilelist( & data_mask, & MAXFILE, & gathered_files, & number_files & ) c --- for debug cvalue = cfu( status ) call m0sxtrce(' STATUS='//cvalue) cvalue = cfu( number_files ) call m0sxtrce(' NFILES='//cvalue) c --- file increment position_step = 1 c --- Get the begin and end position numbers right c (McIDAS allows negative position numbers!) if( begin_position.eq.iALL ) then call m0sxtrce(' SCAN ALL POSITIONS FOR TIME MATCH') begin_position = number_files end_position = 1 position_step = -1 number_serve_files = number_files else number_serve_files = end_position- begin_position + 1 c ------ adjust position and increment for time relative serving if( begin_position.le.0 ) then absolute_begin = IABS(begin_position)+1 if( & absolute_begin.lt.0 .or. & absolute_begin.gt.number_files & ) then readfile_information = -1 return else number_serve_files = 1 begin_position = number_files-(absolute_begin-1) end_position = number_files-(absolute_begin-1) position_step = 1 endif endif endif readfile_information = number_files return end integer function read_file_header( ientry ) implicit none C Subroutine reads the file header information, i.e. C the image boundaries C C Output: C INTEGER array bounds, C bounds(1): southern line C bounds(2): northern line C bounds(3): eastern element C bounds(4): western element C HRV_bounds(1): southern limit, southern section C HRV_bounds(2): northern limit, southern section C HRV_bounds(3): eastern limit, southern section C HRV_bounds(4): western limit, southern section C C HRV_bounds(5): southern limit, northern section C HRV_bounds(6): northern limit, northern section C HRV_bounds(7): eastern limit, southern section C HRV_bounds(8): western limit, southern section C C Note: The "bounds" and "HRV_bounds" coordinates are in McIDAS coordinates, C i.e. line 1 is in the north, element 1 in the west C Note: "bounds" refer to the IR/VIS grid (1-3712), C while "HRV_bounds" refer to the HRV gird (1-11136) C sublon: subsatellite longitude, as provided by the L1.5 header C calibration_data(5)/(6): calibration for the requested band (gain and offset) C cal_special: array fo stored calibrtion information for bands 4,9,11 C (necessary for the BAND 04 correction stuff) c --- constants integer MAXSERVE parameter (MAXSERVE = 30000) c --- parameters integer ientry c --- external functions character*12 cfi character*12 cfu integer lbi integer lwi integer mcstrtoint integer len_trim c --- internal variables character*12 cvalue character*80 marf_header_bandmap character*80 marf_header_sline character*80 marf_header_nline character*80 marf_header_ecol character*80 marf_header_wcol character*150 filnam character*160 cout double precision cal_data(24) double precision storecal(24) integer status integer i integer j integer len integer LF integer isublon c --- hold cal values common/CALSTORE/ storecal c --- holds the band map character*12 cbandmap common/BANDCOM/ & cbandmap c --- holds navigation entries real sublon integer bounds(4) integer planned_bounds(4) integer HRV_bounds(8) integer navigation_data(128) logical SUBSET logical RAPIDSCAN common/NAVCOM/ & sublon, & bounds, & planned_bounds, & HRV_bounds, & navigation_data, & SUBSET, & RAPIDSCAN c --- holds calibration entries real ac(8,4) real bc(8,4) real calibration_data(6) real cal_special(6,4) real center_freq(8,4) real c1 real c2 CHARACTER*1600 calibration_char common/CALCOM/ & ac, & bc, & calibration_data, & cal_special, & center_freq, & c1, & c2, & calibration_char c --- holds serve entries integer number_select_files integer serve_pos(MAXSERVE) integer serve_day(MAXSERVE) integer serve_time(MAXSERVE) integer serve_ss(MAXSERVE) character*12 serve_band(MAXSERVE) character*150 serve_filename(MAXSERVE) common/SRVCOM/ & number_select_files, & serve_pos, & serve_day, & serve_time, & serve_ss, & serve_band, & serve_filename c --- common holds request character*4 request_unit CHARACTER*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude data LF/Z'0A'/ c --- function status read_file_header = 0 c --- initialize the navigation array call zerow(128, navigation_data) c --- get the path+filename filnam = serve_filename(ientry) c --- read in the header band map status = lbi( filnam,4394,80,marf_header_bandmap ) if( status.ne.0 ) then read_file_header = -1 return else cbandmap = marf_header_bandmap(31:42) endif c --- read the image Southern most line status = lbi( filnam,4474,80,marf_header_sline ) if( status.ne.0 ) then read_file_header = -2 return else i = index( marf_header_sline, ': ' ) j = index( marf_header_sline, char(LF) ) cvalue = marf_header_sline(i+2:j-1) status = mcstrtoint(cvalue,bounds(1)) if( status.lt.0 ) then read_file_header = -21 return endif bounds(1) = 3713 - bounds(1) if( bounds(1).lt.1 .or. bounds(1).gt.3712 ) then read_file_header = -22 return endif endif c --- read the image Northern most line status = lbi( filnam,4554,80,marf_header_nline ) if( status.ne.0 ) then read_file_header = -3 return else i = index( marf_header_nline, ': ' ) j = index( marf_header_nline, char(LF) ) cvalue = marf_header_nline(i+2:j-1) status = mcstrtoint(cvalue,bounds(2)) if( status.lt.0 ) then read_file_header = -31 return endif bounds(2) = 3713 - bounds(2) if( bounds(2).lt.1 .or. bounds(2).gt.3712 ) then read_file_header = -32 return endif endif c --- read the image Eastern most line status = lbi( filnam,4634,80,marf_header_ecol ) if( status.ne.0 ) then read_file_header = -4 return else i = index( marf_header_ecol, ': ' ) j = index( marf_header_ecol, char(LF) ) cvalue = marf_header_ecol(i+2:j-1) status = mcstrtoint(cvalue,bounds(3)) if( status.lt.0 ) then read_file_header = -41 return endif bounds(3) = 3713 - bounds(3) if( bounds(3).lt.1 .or. bounds(3).gt.3712 ) then read_file_header = -42 return endif endif c --- read the image Western most line status = lbi( filnam,4714,80,marf_header_wcol ) if( status.ne.0 ) then read_file_header = -5 return else i = index( marf_header_wcol, ': ' ) j = index( marf_header_wcol, char(LF) ) cvalue = marf_header_wcol(i+2:j-1) status = mcstrtoint(cvalue,bounds(4)) if( status.lt.0 ) then read_file_header = -51 return endif bounds(4) = 3713 - bounds(4) if( bounds(4).lt.1 .or. bounds(4).gt.3712 ) then read_file_header = -52 return endif endif c --- read nominal subsatellite longitude from file status = lbi( filnam, 392046, 4, sublon ) status = lbi( filnam, 392046, 4, isublon ) if( status.ne.0 ) then read_file_header = -6 return else call swbyt4(sublon,1) call swbyt4(isublon,1) endif cvalue = cfi( isublon ) c --- Find out whether the file is an image subset SUBSET = .FALSE. if( & bounds(1).ne.3712 .or. & bounds(2).ne.1 .or. & bounds(3).ne.3712 .or. & bounds(4).ne.1 & ) then status = lbi( filnam, 392084, 16, planned_bounds ) if( status.ne.0 ) then read_file_header = -7 return else call swbyt4(planned_bounds,4) endif c ------ convert to GOES (North-to-South/West-to-East) scanning coordinates do i = 1, 4 planned_bounds(i) = 3713-planned_bounds(i) if( & planned_bounds(i).lt.1 .or. & planned_bounds(i).gt.3712 & ) then read_file_header = -71 return endif enddo c ------ compare the planned and actual bounding coordinates do i=1,4 if( planned_bounds(i).ne.bounds(i) ) SUBSET = .TRUE. enddo endif c --- check for RAPIDSCAN RAPIDSCAN = .FALSE. status = lbi( filnam, 392100, 32, HRV_bounds(1) ) if( status.ne.0 ) then read_file_header = -8 return endif c --- we have a rapidscan image if the northern part of HRV is set to zero call swbyt4( HRV_bounds,8 ) if( & HRV_bounds(5).eq.0 .and. & HRV_bounds(6).eq.0 .and. & HRV_bounds(7).eq.0 .and. & HRV_bounds(8).eq.0 & ) RAPIDSCAN = .TRUE. c --- convert to GOES (North-to-South/West-to-East) scanning coordinates do i = 1, 8 HRV_bounds(i) = 3712*3 + 1 - HRV_bounds(i) if( .NOT.RAPIDSCAN ) then if( & HRV_bounds(i).lt.1 .or. & HRV_bounds(i).gt.11136 & ) then read_file_header = -81 return endif endif enddo c --- Not sure why this done? if( SUBSET ) then HRV_bounds(1) = bounds(1) * 3 HRV_bounds(5) = HRV_bounds(1) HRV_bounds(2) = bounds(2) * 3 - 2 HRV_bounds(6) = HRV_bounds(2) HRV_bounds(3) = bounds(3)*3 HRV_bounds(7) = HRV_bounds(3) HRV_bounds(4) = bounds(4) * 3 -2 HRV_bounds(8) = HRV_bounds(4) endif c --- enforce RAPIDSCAN context (northern section set to zero) if( RAPIDSCAN ) then HRV_bounds(5) = 0 HRV_bounds(6) = 0 HRV_bounds(7) = 0 HRV_bounds(8) = 0 endif c --- Read the calibration information from file status = lbi( filnam, 5152+387066, 192, cal_data(1) ) CALL swbyt8 (cal_data,24) c --- put cal_data in a common block so it can be used in the c calibration function call m0sxtrce('Store Cal') do 1600 i = 1,24 storecal(i) = cal_data(i) 1600 continue c --- use the requested band to pick the appropriate cal coefficients calibration_data(5) = REAL( cal_data(2*request_band-1) ) calibration_data(6) = REAL( cal_data(2*request_band) ) return end integer function select_files( ) implicit none C selects files for the requested day, time, band and SS range C Output: C number_select_files: number of files that meet the selection criteria C serve_pos : array of POS numbers of the served files C serve_day : array of DAY numbers of the served files (yyyyccc) C serve_time : array of TIME numbers of the served files (hhmmss) C serve_ss : array of SS numbers of the served files (numeric) C serve_filename : CHARACTER array of the served filenames (without path) c --- constants integer MAXSERVE parameter (MAXSERVE = 30000) integer MAXGFILE parameter (MAXGFILE = 10000) c --- external functions character*12 cfi integer len_trim integer lbi integer mcstrtoint integer mcdmytocyd c --- internal variables character*12 cvalue character*12 file_band character*80 header_bandmap character*512 path character*512 file integer i integer j integer date_position integer status integer ivalue integer year integer month integer day integer hour integer minute integer file_day integer file_time integer eumetsat_ss integer file_ss integer day1 integer day2 integer time1 integer time2 integer ss1 integer ss2 integer ptr integer len integer len_path integer len_file c --- holds serve entries integer number_select_files integer serve_pos(MAXSERVE) integer serve_day(MAXSERVE) integer serve_time(MAXSERVE) integer serve_ss(MAXSERVE) character*12 serve_band(MAXSERVE) character*150 serve_filename(MAXSERVE) common/SRVCOM/ & number_select_files, & serve_pos, & serve_day, & serve_time, & serve_ss, & serve_band, & serve_filename c --- common holds file names integer MAXFILE integer number_elements_file integer number_elements_hrv_file integer number_files integer number_serve_files character*512 gathered_files(MAXGFILE) common/FILCOM/ & MAXFILE, & number_elements_file, & number_elements_hrv_file, & number_files, & number_serve_files, & gathered_files c --- common holds request character*4 request_unit CHARACTER*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- function status select_files = -1 c --- First we sort for DAY, TIME, SS number_select_files = 0 call m0sxtrce(' SELECT: begin='//cfi(begin_position)) call m0sxtrce(' SELECT: end='//cfi(end_position)) call m0sxtrce(' SELECT: step='//cfi(position_step)) do i = begin_position, end_position, position_step c ------ break the names into paths and files call bsquez( gathered_files(i) ) len = len_trim( gathered_files(i) ) ptr = 0 do j = 1, len if( gathered_files(i)(j:j).eq.'/' ) ptr = j enddo if( ptr.eq.0 ) then path = ' ' len_path = 1 file = gathered_files(i) len_file = len else path = gathered_files(i)(1:ptr) len_path = ptr file = gathered_files(i)(ptr+1:len) len_file = len_trim( file ) endif c ------ break the date from the file name cvalue = file(25:32) status = mcstrtoint( cvalue, ivalue ) year = ivalue/10000 month = mod(ivalue,10000)/100 day = mod(ivalue,100) status = mcdmytocyd( day, month, year, file_day ) call m0sxtrce(' FILE: day='//cfi(file_day)) c ------ break the time from the file name cvalue = file(33:36) status = mcstrtoint( cvalue, ivalue ) hour = ivalue/100 minute = mod(ivalue,100) C------- Adjust the time according to start of scan, C------- first for 15 min scans, then for 5 min scans if( & minute.eq.12 .or. & minute.eq.27 .or. & minute.eq.42 .or. & minute.eq.57 & ) then minute = (minute/15) * 15 else minute = (minute/5) * 5 endif file_time = (hour*100 + minute) * 100 call m0sxtrce(' FILE: time='//cfi(file_time)) C------- Read satellite number form position 4 of filename C------- McIDAS Sensor ID for MET-8 (=MSG-1) is 51, for MET-9 52, etc. cvalue = file(4:4) status = mcstrtoint( cvalue, ivalue ) eumetsat_ss = ivalue+7 if( eumetsat_ss.eq.11 ) then file_ss = 354 else file_ss = eumetsat_ss+43 endif c ------ setup request search conditions day1 = begin_day day2 = end_day time1 = begin_time time2 = end_time ss1 = begin_ss ss2 = end_ss c ------ if no request search conditions, default to file name values if( day1 .le.0 ) day1 = file_day if( day2 .le.0 ) day2 = file_day if( time1.lt.0 ) time1 = file_time if( time2.lt.0 ) time2 = file_time if( ss1 .le.0 ) ss1 = file_ss if( ss2 .le.0 ) ss2 = file_ss c ------ Now we check whether the file is within the user request if( & file_day .ge.day1 .and. file_day .le.day2 .and. & file_time.ge.time1 .and. file_time.le.time2 .and. & file_ss .ge.ss1 .and. file_ss .le.ss2 & ) then c -------- check the BAND range - this is in the header info status = lbi( gathered_files(i), 4394, 80, header_bandmap ) if( status.eq.0 ) then c ----------- set function status to success select_files = 0 c ----------- gather the band list file_band = header_bandmap(31:42) c ----------- for debug c call m0sxtrce('PASSED ='//file(1:len_file) ) c call m0sxtrce(' '//header_bandmap ) c ----------- all tests passed -> add this file to the serve list number_select_files = number_select_files+1 serve_pos(number_select_files) = i serve_day(number_select_files) = file_day serve_time(number_select_files) = file_time serve_ss(number_select_files) = file_ss serve_band(number_select_files) = file_band serve_filename(number_select_files) = gathered_files(i) if( number_select_files.eq.number_serve_files ) return endif endif enddo return end subroutine test_10byte( numele ) implicit none C Subroutine tests whether number of elements in a file C fit into the 10bit/byte boundaries, if not, numele is extended C to the next 10 bit/byte boundary C C Input: numele - initial number of elements in the file C Output: numele - changed, possibly larger to fit 10bit structure c --- parameters integer numele c --- internal variables integer kbyte integer khelp integer numbytes real xbyte real xhelp xbyte = numele * 10./8. numbytes = INT(xbyte) if( numbytes.lt.xbyte ) then do kbyte = numbytes+1,numbytes+4 khelp = kbyte*8/10 xhelp = kbyte*8./10. if( khelp.ge.xhelp ) then numbytes = kbyte numele = kbyte*8/10 return endif enddo endif return end integer function adjust_coordinates( ) implicit none C Subroutine finds the final coordinates, depending on the C user request, to determine what to serve C Input: C request_coordinates (E, A, I, and C or U for CENTER/ULEFT) C request_latitude, request_longitude: latitudes and longitudes for E C request_file_line, .._element: lines and elements (file!) for option A C request_image_line, .._element: lines and elements (image!) for option I C Output: C serve_file_first_line,erve_file_first_element: C First line and element in file coordinates to be served C ("file coordinates" at this point refer to the nominal 1-3712 IR/VIS grid, C correction for possible subsetting and rapid scan is done later) C Possible error message: C The requested portion of the image does not exist in the file c --- constants c --- parameters c --- external functions character*12 cfi integer nvprep integer nv1ini integer nv1eas c --- internal variables integer status integer offset_element integer offset_line real request_dummy real xline real xelement real xdummy c --- common holds request character*4 request_unit CHARACTER*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- holds navigation entries real sublon integer bounds(4) integer planned_bounds(4) integer HRV_bounds(8) integer navigation_data(128) logical SUBSET logical RAPIDSCAN common/NAVCOM/ & sublon, & bounds, & planned_bounds, & HRV_bounds, & navigation_data, & SUBSET, & RAPIDSCAN c --- function status adjust_coordinates = 0 c --- First we deal with the CENTER or ULEFT option and define an c offset (in terms of lines and elements) to be applied with respect c to the request if( request_coordinate(2:2).eq.'U' ) then offset_element = 0 offset_line = 0 else offset_element = INT(requ_number_elements/2.) - 1 offset_line = INT(requ_number_lines/2.) - 1 endif c --- convert Earth coordinates to Image coordinates if( request_coordinate(1:1).eq.'E' ) then call m0sxtrce('Convert EC to Line/Elem') c ------ initialize naviagtion module status = nvprep(1,navigation_data(1)) if( status.ne.0 ) then adjust_coordinates = -1 return else status = nv1ini(2,'LL ') endif c ------ Earth to image transform request_dummy = 0.0 status = nv1eas( & request_latitude, & request_longitude, & request_dummy, & xline, & xelement, & xdummy & ) if( status.ne.0 ) then adjust_coordinates = -2 return else request_image_line = NINT(xline) request_image_element = NINT(xelement) call m0sxtrce(' REQUEST LINE='//cfi(request_image_line)) call m0sxtrce(' REQUEST ELEM='//cfi(request_image_element)) endif c --- convert File coordinates to Image coordinates elseif( request_coordinate(1:1).eq.'A' ) then if( request_band.ne.12 ) then request_image_line = request_file_line *3 + & bounds(2)*3 - 3 request_image_element = request_file_element*3 + & bounds(4)*3 - 3 else request_image_line = request_file_line request_image_element = request_file_element endif endif c --- At this point we should definitely have the variables c request_image_line and .._element populated! c --- check whether this part of the image exists if( & (request_image_line .gt.(bounds(1)*3) ) .or. & (request_image_line .lt.(bounds(2)*3-2)) .or. & (request_image_element.gt.(bounds(3)*3) ) .or. & (request_image_element.lt.(bounds(4)*3-2)) & ) then adjust_coordinates = -3 return endif c --- convert to the ULEFT option (using the offsets) if( request_band.ne.12 ) then request_image_line = request_image_line - & line_resolution * offset_line * 3 request_image_element = request_image_element - & element_resolution * offset_element * 3 call m0sxtrce(' LINE RESOLUTION='//cfi(line_resolution)) call m0sxtrce(' LINE OFFSET='//cfi(offset_line)) call m0sxtrce(' ULEFT LINE='//cfi(request_image_line)) else request_image_line = request_image_line - & line_resolution * offset_line request_image_element = request_image_element - & element_resolution * offset_element endif c --- compute the first and last coordinates request_file_first_line = (request_image_line+2)/3 request_file_last_line = request_file_first_line + & (requ_number_lines-1) * line_resolution request_file_first_elem = (request_image_element+2)/3 request_file_last_elem = request_file_first_elem + & (requ_number_elements-1) * element_resolution return end integer function calibration( ) implicit none c Subroutine populates the calibration_data arrays (IR): c calibration_data(1) : c1 * frequ**3 c calibration_data(2) : c2 * frequ c calibration_data(3) : band correction coefficient ac c calibration_data(4) : band correction coefficient bc c calibration_data(5) : calibration gain c calibration_data(6) : calibration offset c --- constants integer MAXSERVE parameter (MAXSERVE = 30000) c --- parameters c --- external functions integer lit c --- internal variables character*150 filnam real allcaldata(12,6) integer i,j integer iband integer satnum c --- common holds request character*4 request_unit CHARACTER*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- hold cal values common/CALSTORE/ storecal double precision storecal(24) c --- holds calibration entries real ac(8,4) real bc(8,4) real calibration_data(6) real cal_special(6,4) real center_freq(8,4) real c1 real c2 CHARACTER*1600 calibration_char common/CALCOM/ & ac, & bc, & calibration_data, & cal_special, & center_freq, & c1, & c2, & calibration_char c --- holds serve entries integer number_select_files integer serve_pos(MAXSERVE) integer serve_day(MAXSERVE) integer serve_time(MAXSERVE) integer serve_ss(MAXSERVE) character*12 serve_band(MAXSERVE) character*150 serve_filename(MAXSERVE) common/SRVCOM/ & number_select_files, & serve_pos, & serve_day, & serve_time, & serve_ss, & serve_band, & serve_filename data ac/ & 0.9956,0.9962,0.9991,0.9996,0.9999,0.9983,0.9988,0.9981, & 0.9954,0.9963,0.9991,0.9996,0.9999,0.9983,0.9988,0.9981, & 0.9956,0.9962,0.9991,0.9996,0.9999,0.9983,0.9988,0.9981, & 0.9916,0.9959,0.9990,0.9996,0.9998,0.9983,0.9988,0.9981 & / data bc/ & 3.410,2.218,0.478,0.179,0.060,0.625,0.397,0.578, & 3.438,2.185,0.470,0.179,0.056,0.640,0.408,0.561, & 3.372,2.164,0.446,0.177,0.054,0.631,0.401,0.559, & 2.9438,2.0780,0.4929,0.1731,0.0597,0.6256,0.4002,0.5635 & / DATA center_freq/ & 256733.0,159810.3,136208.2,114906.9, & 103434.3,93064.7,83966.0,75238.7, & 256883.2,160054.8,136033.0,114862.0, & 103528.9,93170.0,83644.5,75179.2, & 256655.6,159774.0,136052.2,114817.5, & 103472.8,92997.7,83872.2,75073.7, & 255528.0,159608.0,136174.8,114743.3, & 103485.1,93112.2,83911.3,74858.5 & / c --- function status calibration = 0 c --- initialize CALCOM c1 = 1.19104E-11 c2 = 1.43877E-02 if( serve_ss(number_select_files) .eq. 354) then satnum = serve_ss(number_select_files) - 350 else satnum = serve_ss(number_select_files) - 50 endif call m0sxtrce('Start loop 1600') do 1600 iband = 1,12 if( iband.gt.3.and.iband.lt.12 ) then allcaldata(iband,1) = c1 * center_freq(iband-3,satnum)**3 allcaldata(iband,2) = c2 * center_freq(iband-3,satnum) allcaldata(iband,3) = ac(iband-3,satnum) allcaldata(iband,4) = bc(iband-3,satnum) else allcaldata(iband,1) = 0.0 allcaldata(iband,2) = 0.0 allcaldata(iband,3) = 0.0 allcaldata(iband,4) = 0.0 endif c --- use the requested band to pick the appropriate cal coefficients allcaldata(iband,5) = REAL( storecal(2*iband-1) ) allcaldata(iband,6) = REAL( storecal(2*iband) ) 1600 continue call m0sxtrce('Done with loop') c --- The calibration info is written to a CHARACTER string (McIDAS) WRITE(calibration_char,'(A4,12(6E17.10,2X))') 'MSGT', & (allcaldata(1,i),i=1,6), & (allcaldata(2,i),i=1,6), & (allcaldata(3,i),i=1,6), & (allcaldata(4,i),i=1,6), & (allcaldata(5,i),i=1,6), & (allcaldata(6,i),i=1,6), & (allcaldata(7,i),i=1,6), & (allcaldata(8,i),i=1,6), & (allcaldata(9,i),i=1,6), & (allcaldata(10,i),i=1,6), & (allcaldata(11,i),i=1,6), & (allcaldata(12,i),i=1,6) call m0sxtrce(calibration_char) return end integer function serve_data_ir_vis( area_dir ) implicit none include 'imgdparm.inc' c Subroutine reads and serves all IR and VIS data c Output: n/a c Call to m0sxsend already done in this routine c --- constants integer MAXGFILE parameter (MAXGFILE = 10000) integer MAXSERVE parameter (MAXSERVE = 30000) integer MAXSOURCE parameter (MAXSOURCE = 20000) integer MAXOPTION parameter (MAXOPTION = 10) c --- parameters integer area_dir(64) c --- external functions integer read_linedata integer kb1cal integer kb1ini integer kb1opt c --- internal variables integer element integer i integer j integer status integer line integer brit_init integer cal_prefix integer cal_init integer cal_option(MAXOPTION) integer serve_data(MAXSOURCE) integer idummy(10) c --- common holds request character*4 request_unit CHARACTER*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- holds calibration entries real ac(8,4) real bc(8,4) real calibration_data(6) real cal_special(6,4) real center_freq(8,4) real c1 real c2 CHARACTER*1600 calibration_char common/CALCOM/ & ac, & bc, & calibration_data, & cal_special, & center_freq, & c1, & c2, & calibration_char c --- holds navigation entries real sublon integer bounds(4) integer planned_bounds(4) integer HRV_bounds(8) integer navigation_data(128) logical SUBSET logical RAPIDSCAN common/NAVCOM/ & sublon, & bounds, & planned_bounds, & HRV_bounds, & navigation_data, & SUBSET, & RAPIDSCAN c --- holds the line arrays character*1 line_buffer(4640) character*1 line_buffer_hrv(13920) integer pixel(3712) integer pixel_hrv(11136) integer*2 image_data(11136) common/LINCOM/ & line_buffer, & line_buffer_hrv, & pixel, & pixel_hrv, & image_data data cal_init/ 0 / data cal_prefix / 0 / c --- initialize function status serve_data_ir_vis = 0 c --- main loop through the source data do line= & request_file_first_line, & request_file_last_line, & line_resolution c ------ initialize the source data array do j = 1, MAXSOURCE if( request_band.gt.3 ) then serve_data(j) = 1023 else serve_data(j) = 0 endif enddo c ------ initialize the element counter i = 0 c ------ make sure line number is within request bounds if( line.ge.bounds(2).and.line.le.bounds(1)) then c --------- read a line of data from the source file status = read_linedata( line ) if( status.ne.0 ) then serve_data_ir_vis = -1 return endif c --------- loop through the source line do element= & request_file_first_elem, & request_file_last_elem, & element_resolution c --------- increment the element counter i = i+1 c --------- make sure the element number is within the request bounds if( element.ge.bounds(4).and.element.le.bounds(3)) then serve_data(i) = image_data(element) c --------- element is outside the bounds else if( request_band.gt.3 ) then serve_data(i) = 1023 else serve_data(i) = 0 endif endif enddo endif c ------ At this point, serve_data contains one line of image data to c be served (either 0 (resp. 1023), i.e. off disk, or some image data value in c terms of COUNTS; now we have to deal with the units and the byte resolution c ------ calibration is visible brightness (BRIT) if( request_unit.eq.'BRIT' ) then c --------- initialize the calibration transform if( cal_init.eq.0 ) then cal_option(1) = 2 cal_option(2) = 2 status = kb1ini( 'RAW ','BRIT',cal_option ) status = kb1opt( 'CALB',calibration_char, idummy ) cal_init = 1 if(request_csstr(1:3) .eq. 'EXP') then cal_option(1) = request_band cal_option(2) = area_dir(3) cal_option(3) = 1 status = kb1opt('STR ', cal_option, idummy) if(status .eq. 0) then area_dir(EXP_BRIT_FLAG) = 1 call movw(2, idummy, area_dir(EXP_BRIT_NAME1)) endif endif endif c --------- pack 4 byte values into 2 byte words call mpixel( area_dir(10), 4, 2, serve_data ) c --------- convert counts to brightness status = kb1cal( & cal_prefix, & area_dir(1), & area_dir(10), & request_band, & serve_data & ) c --------- pack the brightness into the requested byte size words call mpixel(area_dir(10),2,requ_byte_resolution,serve_data) c ------ calibration is raw counts (RAW) elseif( request_unit.EQ.'RAW ' ) then c --------- pack the brightness into the requested byte size words call mpixel(area_dir(10),4,requ_byte_resolution,serve_data) c ------ calibration is radiance (RAD) elseif( request_unit.EQ.'RAD ' ) then c --------- initialize the calibration transform if( cal_init.eq.0 ) then cal_option(1) = 2 cal_option(2) = requ_byte_resolution status = kb1ini ('RAW ','RAD ',cal_option) status = kb1opt ('CALB',calibration_char, idummy) cal_init = 1 endif c --------- pack 4 byte values into 2 byte words call mpixel( area_dir(10), 4, 2, serve_data ) c --------- convert counts to radiance status = kb1cal( & cal_prefix, & area_dir(1), & area_dir(10)*requ_byte_resolution/2, & request_band, & serve_data & ) c ------ calibration is brightness temperature (TEMP) elseif( request_unit.eq.'TEMP' ) then c --------- initialize the calibration transform if( cal_init.eq.0 ) then cal_option(1) = 2 cal_option(2) = requ_byte_resolution status = kb1ini ('RAW ','TEMP',cal_option) status = kb1opt ('CALB',calibration_char, idummy) cal_init = 1 endif c --------- pack 4 byte values into 2 byte words call mpixel( area_dir(10), 4, 2, serve_data ) c --------- convert counts to brightness temperature status = kb1cal( & cal_prefix, & area_dir(1), & area_dir(10)*requ_byte_resolution/2, & request_band, & serve_data & ) c ------ calibration is reflectance (REFL) elseif( request_unit.EQ.'REFL' ) then c --------- initialize the calibration transform if( cal_init.eq.0 ) then cal_option(1) = 4 cal_option(2) = requ_byte_resolution status = kb1ini ('RAW ','REFL',cal_option) status = kb1opt ('CALB',calibration_char, idummy) cal_init = 1 endif c --------- convert counts to brightness temperature status = kb1cal( & cal_prefix, & area_dir(1), & area_dir(10)*requ_byte_resolution/2, & request_band, & serve_data & ) endif c ------ insure the correct byte order if( requ_byte_resolution.eq.2 ) & call swbyt2( serve_data,area_dir(10) ) if( requ_byte_resolution.eq.4 ) & call swbyt4( serve_data,area_dir(10) ) c ------ send the line to the client call m0sxsend( & area_dir(10)*requ_byte_resolution, & serve_data & ) enddo return end integer function read_linedata(line) implicit none C Subroutine reads one line of (IR or VIS) data from the image file C (COUNTS), all available elements, for the requested band C C Input: C line: Requested line number (number 1 in the north), for nominal C image coordinates (1-3712), other file limits are taken C into account through the conversion to request_line C Output: C image_data: array (1:3712) holding the image counts for this line, C indexing refers to the nominal image coordinates C C Possible error message: reading from file not possible C (not much one can do - check whether file is corrupted??) c --- constants integer MAXSERVE parameter (MAXSERVE = 30000) integer MAXGFILE parameter (MAXGFILE = 10000) c --- parameters integer line c --- external functions integer lbi c --- internal variables character*150 filnam integer i integer status integer number_bands integer numbytes_line integer num_10bit integer num_hrv_10bit integer request_line integer start_byte c --- common holds request character*4 request_unit character*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- holds serve entries integer number_select_files integer serve_pos(MAXSERVE) integer serve_day(MAXSERVE) integer serve_time(MAXSERVE) integer serve_ss(MAXSERVE) character*12 serve_band(MAXSERVE) character*150 serve_filename(MAXSERVE) common/SRVCOM/ & number_select_files, & serve_pos, & serve_day, & serve_time, & serve_ss, & serve_band, & serve_filename c --- holds navigation entries real sublon integer bounds(4) integer planned_bounds(4) integer HRV_bounds(8) integer navigation_data(128) logical SUBSET logical RAPIDSCAN common/NAVCOM/ & sublon, & bounds, & planned_bounds, & HRV_bounds, & navigation_data, & SUBSET, & RAPIDSCAN c --- holds the band map character*12 cbandmap common/BANDCOM/ & cbandmap c --- common holds file names integer MAXFILE integer number_elements_file integer number_elements_hrv_file integer number_files integer number_serve_files character*512 gathered_files(MAXGFILE) common/FILCOM/ & MAXFILE, & number_elements_file, & number_elements_hrv_file, & number_files, & number_serve_files, & gathered_files c --- holds the line arrays character*1 line_buffer(4640) character*1 line_buffer_hrv(13920) integer pixel(3712) integer pixel_hrv(11136) integer*2 image_data(11136) common/LINCOM/ & line_buffer, & line_buffer_hrv, & pixel, & pixel_hrv, & image_data c --- initialize function status read_linedata = 0 c --- Get the filename filnam = serve_filename(number_select_files) c --- Find the requested line within the file request_line = bounds(1) - line + 1 c --- Add up the elements per line, depending on available channels c and account for 10 bit data structure numbytes_line = 0 number_bands = 0 num_10bit = number_elements_file * 10/8 num_hrv_10bit = number_elements_hrv_file * 10/8 c --- compute the length of a ir-vis source line do i = 1,11 if( cbandmap(i:i).EQ.'X' ) then numbytes_line = numbytes_line + num_10bit + 65 if( i.lt.request_band) number_bands = number_bands+1 endif enddo c --- if hrv is present, add to source line length if( cbandmap(12:12).EQ.'X' ) then numbytes_line = numbytes_line + 3*(num_hrv_10bit + 65) endif c --- compute the starting byte of the requested line start_byte = 450400 + (request_line-1)*numbytes_line + & number_bands * (num_10bit + 65) + 65 c --- read the source line from the file status = lbi( & filnam, & start_byte, & num_10bit, & line_buffer(1) & ) if( status.ne.0 ) then read_linedata =-1 return endif c --- expand the source data call expand_msg( ) c --- Change the element order (East/West) to (West/East) do i = bounds(4), bounds(3) image_data(i) = pixel(bounds(3) - i + 1) enddo return end subroutine expand_msg( ) implicit none C Subroutine exbands one line of 10 bit MSG data C into 4 byte INTEGER array (for IR/VIS) C Input: C line_buffer: one line of 10 bit MSG data C Output: C pixel: one line of expanded data (4 bytes) c --- constants integer MAXGFILE parameter (MAXGFILE = 10000) c --- parameters c --- external functions c --- internal varaibles character*5 ch5 integer*2 j1 integer*2 j2 integer*2 j3 integer*2 j4 integer*2 mask integer*2 shiftamount integer grouploop integer inindex integer maxloop integer outindex c --- common holds file names integer MAXFILE integer number_elements_file integer number_elements_hrv_file integer number_files integer number_serve_files character*512 gathered_files(MAXGFILE) common/FILCOM/ & MAXFILE, & number_elements_file, & number_elements_hrv_file, & number_files, & number_serve_files, & gathered_files c --- holds the line arrays character*1 line_buffer(4640) character*1 line_buffer_hrv(13920) integer pixel(3712) integer pixel_hrv(11136) integer*2 image_data(11136) common/LINCOM/ & line_buffer, & line_buffer_hrv, & pixel, & pixel_hrv, & image_data mask = 1023 maxloop = number_elements_file / 4 do grouploop=1,maxloop inindex = (grouploop-1) * 5 + 1 outindex = (grouploop-1) * 4 + 1 ch5 = line_buffer(inindex)//line_buffer(inindex+1)// & line_buffer(inindex+2)//line_buffer(inindex+3)// & line_buffer(inindex+4) shiftamount = -6 call movc (2,ch5,0,j1,0) call swbyt2 (j1,1) j1 = ISHFT(j1,shiftamount) j1 = IAND(j1,mask) pixel(outindex) = j1 shiftamount = -4 call movc (2,ch5,1,j2,0) call swbyt2 (j2,1) j2 = ISHFT(j2,shiftamount) j2 = IAND(j2,mask) pixel(outindex+1) = j2 shiftamount = -2 call movc (2,ch5,2,j3,0) call swbyt2 (j3,1) j3 = ISHFT(j3,shiftamount) j3 = IAND(j3,mask) pixel(outindex+2) = j3 call movc (2,ch5,3,j4,0) call swbyt2 (j4,1) j4 = IAND(j4,mask) pixel(outindex+3) = j4 enddo return end integer function serve_data_hrv( area_dir ) implicit none include 'imgdparm.inc' C Subroutine reads and serves all HRV data C Output: n/a C Call to m0sxsend already done in this routine c --- constants integer MAXSOURCE parameter (MAXSOURCE = 20000) integer MAXOPTION parameter (MAXOPTION = 10) integer MAXSERVE parameter (MAXSERVE = 30000) c --- parameters integer area_dir(64) c --- external functions character*12 cfi integer read_linedata_hrv integer kb1ini integer kb1opt integer kb1cal c --- internal varaibales character*12 cvalue character*12 cval1 character*12 cval2 character*12 cval3 character*12 cval4 character*12 cval5 character*12 cval6 character*80 cout integer status integer element integer end_element integer end_line integer i,ii,ir integer j integer line integer serve_data(MAXSERVE) c integer bug_init integer cal_init integer cal_prefix integer cal_option(MAXOPTION) real xx integer idummy(10) c --- common holds request character*4 request_unit CHARACTER*12 request_csstr CHARACTER*12 request_coordinate character*12 data_type character*12 data_kind character*80 dataset_group character*80 dataset_descriptor character*80 comment character*256 data_mask character*256 data_info integer minrange integer maxrange integer begin_day integer end_day integer begin_time integer end_time integer begin_band integer end_band integer begin_position integer end_position integer line_resolution integer element_resolution integer position_step integer begin_ss integer end_ss integer real_time integer request_band integer request_image_line integer request_image_element integer request_file_line integer request_file_element integer request_file_first_elem integer request_file_first_line integer request_file_last_elem integer request_file_last_line integer requ_byte_resolution integer requ_byte_spacing integer requ_number_elements integer requ_number_lines real request_latitude real request_longitude common/REQCOM/ & request_unit, & request_csstr, & request_coordinate, & data_type, & data_kind, & dataset_group, & dataset_descriptor, & comment, & data_mask, & data_info, & minrange, & maxrange, & begin_day, & end_day, & begin_time, & end_time, & begin_band, & end_band, & begin_position, & end_position, & line_resolution, & element_resolution, & position_step, & begin_ss, & end_ss, & real_time, & request_band, & request_image_line, & request_image_element, & request_file_line, & request_file_element, & request_file_first_elem, & request_file_first_line, & request_file_last_elem, & request_file_last_line, & requ_byte_resolution, & requ_byte_spacing, & requ_number_elements, & requ_number_lines, & request_latitude, & request_longitude c --- holds navigation entries real sublon integer bounds(4) integer planned_bounds(4) integer HRV_bounds(8) integer navigation_data(128) logical SUBSET logical RAPIDSCAN common/NAVCOM/ & sublon, & bounds, & planned_bounds, & HRV_bounds, & navigation_data, & SUBSET, & RAPIDSCAN c --- holds calibration entries real ac(8,4) real bc(8,4) real calibration_data(6) real cal_special(6,4) real center_freq(8,4) real c1 real c2 CHARACTER*1600 calibration_char common/CALCOM/ & ac, & bc, & calibration_data, & cal_special, & center_freq, & c1, & c2, & calibration_char c --- holds the line arrays character*1 line_buffer(4640) character*1 line_buffer_hrv(13920) integer pixel(3712) integer pixel_hrv(11136) integer*2 image_data(11136) common/LINCOM/ & line_buffer, & line_buffer_hrv, & pixel, & pixel_hrv, & image_data data cal_init/ 0 / c data bug_init/ 0 / data cal_prefix/ 0 / c --- initialize function status serve_data_hrv = 0 c --- compute the ending line and element end_line = request_image_line + (requ_number_lines-1) * & line_resolution end_element = request_image_element + (requ_number_elements-1) * & element_resolution c --- loop through the requested line range do line= & request_image_line, & end_line, & line_resolution c ------ initialize the element counter i = 0 c ------ initialize the data array call zerow( MAXSERVE,serve_data ) c ------ insure that line is within the request bounds if( line.ge.HRV_bounds(6).and.line.le.HRV_bounds(1)) then c --------- read a line of HRV data status = read_linedata_hrv( line ) if( status.ne.0 ) then serve_data_hrv = -1 return endif if( i.eq.0 ) then cvalue = cfi( request_image_element ) call m0sxtrce('REQUEST IMAGE ELEMENT = '//cvalue) cvalue = cfi( end_element ) call m0sxtrce('END ELEMENT = '//cvalue) cvalue = cfi( element_resolution ) call m0sxtrce('ELEMENT RES = '//cvalue) cvalue = cfi( i ) call m0sxtrce('I = '//cvalue) endif c --------- loop through the element bounds ii = request_image_element DO element= & request_image_element, & end_element, & element_resolution c --------- increment the element counter i = i+1 c if( bug_init.eq.0 ) then c cval1 = cfi( line ) c cval2 = cfi( element ) c cval3 = cfi( i ) c cout = cval1//cval2//cval3 c call bsquez( cout ) c call m0sxtrce( cout ) c endif c --------- Check whether we are in the northern or the southern sector if( line.ge.HRV_bounds(6).and.line.le.HRV_bounds(5)) then if( & element.ge.HRV_bounds(8) .and. & element.le.HRV_bounds(7) & ) then c if( bug_init.eq.0 ) then c cvalue = cfi( i ) c call m0sxtrce('i='//cvalue) c cvalue = cfi( line ) c call m0sxtrce('line='//cvalue) c cvalue = cfi( element ) c call m0sxtrce('element='//cvalue) c endif serve_data(i) = image_data(element) c bug_init = 1 else serve_data(i) = 0 endif endif if( line.ge.HRV_bounds(2).and.line.le.HRV_bounds(1)) then if( & element.ge.HRV_bounds(4) .and. & element.le.HRV_bounds(3) & ) then serve_data(i) = image_data(element) else serve_data(i) = 0 endif endif enddo endif c if( bug_init.eq.0 ) call m0sxtrce('BANG!!!') c ------ At this point, serve_data contains one line of image data to be served c in terms of COUNTS; now we have to deal with the units and the byte resolution c ------ calibration is visible brightness (BRIT) if( request_unit.eq.'BRIT' ) then c --------- initialize the calibration if( cal_init.eq.0 ) then cal_option(1) = 2 cal_option(2) = 2 status = kb1ini ('RAW ','BRIT',cal_option) status = kb1opt ('CALB',calibration_char, idummy) cal_init = 1 if(request_csstr(1:3) .eq. 'EXP') then cal_option(1) = request_band cal_option(2) = area_dir(3) cal_option(3) = 1 status = kb1opt('STR ', cal_option, idummy) if(status .eq. 0) then area_dir(EXP_BRIT_FLAG) = 1 call movw(2, idummy, area_dir(EXP_BRIT_NAME1)) endif endif endif c --------- pack 4 byte counts into 2 byte words call mpixel( area_dir(10),4,2,serve_data ) c --------- convert counts to brightness status = kb1cal( & cal_prefix, & area_dir(1), & area_dir(10), & request_band, & serve_data & ) c --------- pack the brightness into the requested byte size words call mpixel( area_dir(10),2,requ_byte_resolution,serve_data) c ------ calibration is raw counts (RAW) elseif( request_unit.eq.'RAW ' ) then c --------- pack the counts into the requested byte size words call mpixel( area_dir(10),4,requ_byte_resolution,serve_data) c ------ calibration is radiance (RAD) elseif( request_unit.eq.'RAD ') then c --------- initialize the calibration if( cal_init.eq.0 ) then cal_option(1) = 4 cal_option(2) = requ_byte_resolution status = kb1ini ('RAW ','RAD ',cal_option) status = kb1opt ('CALB',calibration_char, idummy) cal_init = 1 endif c --------- convert counts to radiance status = kb1cal( & cal_prefix, & area_dir(1), & area_dir(10)*requ_byte_resolution/2, & request_band, & serve_data & ) c ------ calibration is reflectance (REFL) elseif( request_unit.eq.'REFL' ) then c --------- initialize the calibration if( cal_init.eq.0 ) then cal_option(1) = 4 cal_option(2) = requ_byte_resolution status = kb1ini ('RAW ','REFL',cal_option) status = kb1opt ('CALB',calibration_char, idummy) cal_init = 1 endif c --------- convert counts to reflectance status = kb1cal( & cal_prefix, & area_dir(1), & area_dir(10)*requ_byte_resolution/2, & request_band, & serve_data & ) endif c ------ swap the bytes if( requ_byte_resolution.eq.2 ) & call swbyt2( serve_data,area_dir(10) ) if( requ_byte_resolution.EQ.4 ) & call swbyt4 (serve_data,area_dir(10) ) c ------ send data line to client call m0sxsend(area_dir(10)*requ_byte_resolution,serve_data) enddo return end integer function read_linedata_hrv(line) implicit none C Subroutine reads one line of (HRV) data from the image file C (COUNTS), all available elements, for the requested band C C Input: C line: Requested line number (number 1 in the north), for nominal C HRV image coordinates (1-11136), other file limits are taken C into account through the conversion to irline C Output: C image_data: array (1:11136) holding the image counts for this line, C indexing refers to the nominal image coordinates C C Possible error message: reading from file not possible C (not much one can do - check whether file is corrupted??) c --- constants integer MAXSOURCE parameter (MAXSOURCE = 20000) integer MAXSERVE parameter (MAXSERVE = 30000) integer MAXGFILE parameter (MAXGFILE = 10000) c --- parameters integer line c --- external functions integer lbi c --- internal variablies character*150 filnam integer status integer hrv_offset integer i integer irline integer number_bands integer numbytes_line integer num_10bit integer num_hrv_10bit integer offset_hrv integer start_byte c --- holds serve entries integer number_select_files integer serve_pos(MAXSERVE) integer serve_day(MAXSERVE) integer serve_time(MAXSERVE) integer serve_ss(MAXSERVE) character*12 serve_band(MAXSERVE) character*150 serve_filename(MAXSERVE) common/SRVCOM/ & number_select_files, & serve_pos, & serve_day, & serve_time, & serve_ss, & serve_band, & serve_filename c --- holds navigation entries real sublon integer bounds(4) integer planned_bounds(4) integer HRV_bounds(8) integer navigation_data(128) logical SUBSET logical RAPIDSCAN common/NAVCOM/ & sublon, & bounds, & planned_bounds, & HRV_bounds, & navigation_data, & SUBSET, & RAPIDSCAN c --- holds the band map character*12 cbandmap common/BANDCOM/ & cbandmap c --- common holds file names integer MAXFILE integer number_elements_file integer number_elements_hrv_file integer number_files integer number_serve_files character*512 gathered_files(MAXGFILE) common/FILCOM/ & MAXFILE, & number_elements_file, & number_elements_hrv_file, & number_files, & number_serve_files, & gathered_files c --- holds the line arrays character*1 line_buffer(4640) character*1 line_buffer_hrv(13920) integer pixel(3712) integer pixel_hrv(11136) integer*2 image_data(11136) common/LINCOM/ & line_buffer, & line_buffer_hrv, & pixel, & pixel_hrv, & image_data c --- initialize function status read_linedata_hrv = 0 c --- Get the filename filnam = serve_filename(number_select_files) c --- Find the appropriate IR/VIS line number and the offset (0,1,2) irline = (line + 2)/3 irline = bounds(1) - irline + 1 if( MOD(line,3).EQ.1 ) hrv_offset = 2 if( MOD(line,3).EQ.2 ) hrv_offset = 1 if( MOD(line,3).EQ.0 ) hrv_offset = 0 c --- Add up elements per line, depending on available channels c and account for 10 bit data structure numbytes_line = 0 number_bands = 0 num_10bit = number_elements_file * 10/8 num_hrv_10bit = number_elements_hrv_file * 10/8 c --- compute line byte length do i = 1, 11 if( cbandmap(i:i).EQ.'X' ) then numbytes_line = numbytes_line + num_10bit + 65 number_bands = number_bands + 1 endif enddo c --- add bytes for HRV elements numbytes_line = numbytes_line + 3*(num_hrv_10bit+65) c --- compute the starting byte based on number of bands start_byte = 450400 + (irline-1)*numbytes_line + & number_bands * (num_10bit+65) + & hrv_offset*(num_hrv_10bit+65) + 65 c --- read the counts from the source file status = lbi( & filnam, & start_byte, & num_hrv_10bit, & line_buffer_hrv(1) & ) if( status.ne.0 ) then read_linedata_hrv = -1 return endif c --- expand 10 bit counts into 32 bit words call expand_msg_hrv( ) c --- Change the element order (East/West) to (West/East) c and store everything in image_data; account for the two blocks if( line.ge.HRV_bounds(6).and.line.le.HRV_bounds(5) ) then do i = HRV_bounds(8),HRV_bounds(7) image_data(i) = pixel_hrv(HRV_bounds(7) - i + 1) enddo endif if( line.ge.HRV_bounds(2).and.line.le.HRV_bounds(1) ) then do i = HRV_bounds(4),HRV_bounds(3) image_data(i) = pixel_hrv(HRV_bounds(3) - i + 1) enddo endif return end subroutine expand_msg_hrv( ) implicit none C Subroutine expands three lines of 10 bit MSG HRV data C into 4 byte INTEGER array C Input: C line_buffer_hrv: line of 10 bit MSG HRV data C Output: C pixel_hrv: one line of expanded data (4 bytes) c --- constants integer MAXGFILE parameter (MAXGFILE = 10000) c --- parameters c --- external functions c --- internal variables character*5 ch5_hrv integer*2 j1 integer*2 j2 integer*2 j3 integer*2 j4 integer*2 mask integer*2 shiftamount integer grouploop integer inindex integer maxloop integer outindex c --- common holds file names integer MAXFILE integer number_elements_file integer number_elements_hrv_file integer number_files integer number_serve_files character*512 gathered_files(MAXGFILE) common/FILCOM/ & MAXFILE, & number_elements_file, & number_elements_hrv_file, & number_files, & number_serve_files, & gathered_files c --- holds the line arrays character*1 line_buffer(4640) character*1 line_buffer_hrv(13920) integer pixel(3712) integer pixel_hrv(11136) integer*2 image_data(11136) common/LINCOM/ & line_buffer, & line_buffer_hrv, & pixel, & pixel_hrv, & image_data mask = 1023 maxloop = number_elements_hrv_file / 4 do grouploop = 1, maxloop inindex = (grouploop-1) * 5 + 1 outindex = (grouploop-1) * 4 + 1 ch5_hrv = line_buffer_hrv(inindex)// & line_buffer_hrv(inindex+1)// & line_buffer_hrv(inindex+2)// & line_buffer_hrv(inindex+3)// & line_buffer_hrv(inindex+4) shiftamount = -6 call movc (2,ch5_hrv,0,j1,0) call swbyt2 (j1,1) j1 = ISHFT(j1,shiftamount) j1 = IAND(j1,mask) pixel_hrv(outindex) = j1 shiftamount = -4 call movc (2,ch5_hrv,1,j2,0) call swbyt2 (j2,1) j2 = ISHFT(j2,shiftamount) j2 = IAND(j2,mask) pixel_hrv(outindex+1) = j2 shiftamount = -2 call movc (2,ch5_hrv,2,j3,0) call swbyt2 (j3,1) j3 = ISHFT(j3,shiftamount) j3 = IAND(j3,mask) pixel_hrv(outindex+2) = j3 call movc (2,ch5_hrv,2,j3,0) call swbyt2 (j3,1) j3 = ISHFT(j3,shiftamount) j3 = IAND(j3,mask) pixel_hrv(outindex+2) = j3 call movc (2,ch5_hrv,3,j4,0) call swbyt2 (j4,1) j4 = IAND(j4,mask) pixel_hrv(outindex+3) = j4 enddo return end