C Copyright(c) 2015, 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: kbxabin.dlm,v 1.30 2019/04/11 18:32:08 russd Tst $ *** C$ Name: C$ kbxini - Calibration module for GOES-ABI data C$ C$ Interface: C$ integer function C$ kbxini(character*4 input_cal,character*4 output_cal,integer io_size(*)) C$ C$ Input: C$ input_cal - Input calibration type ('RAW') C$ output_cal - Output calibration type ('TEMP','ALB','RAD','RAW','BRIT') C$ io_size - Source and destination byte depth C$ io_size(1) - Source pixel size (2) C$ io_size(2) - Destination pixel size (1,2,4) C$ C$ Output: C$ Error messages if return value is not 0. (To be backward compatible C$ with the existing API, the return value does not indicate which C$ error was encountered.) C$ C$ Return values: C$ 0 - success C$ -1 - error C$ C$ Remarks: C$ C$ Categories: C$ image C$ display C$ calibration C$ met/science integer function kbxini(input_cal,output_cal,io_size) implicit none c --- constants c 577 = (32 bands X 18 values band) + 1 value for 'ABIN' integer CALB_SIZE parameter (CALB_SIZE = 577) c --- input parametes character*4 input_cal ! input calibration type (RAW) character*4 output_cal ! output cal type (TEMP,ALB,RAD,RAW,BRIT) integer io_size(*) ! source and destination byte depth c --- external functions integer len_trim c --- local variables character*4 cNAME integer iBAND integer len_cNAME integer valid_cal c --- GOES ABI calibration block character*4 cal_input ! input calibration type (RAW) character*4 cal_output ! output cal type (TEMP, ALB, RAD, RAW, BRIT) integer enh_str_flag ! =1 for new BRIT stretch character*8 enh_str_name ! stretch table name integer src_byte_size ! number of bytes for source pixel integer dest_byte_size ! number of bytes for destination pixel integer cal_flag ! 0= from AREA, 1= from server character*4 calb_name ! name of calibration block integer calb_block(18,32) ! cal block common/abincal/ & cal_input, & cal_output, & enh_str_flag, ! =1 for new BRIT stretch & enh_str_name, ! stretch table name & src_byte_size, & dest_byte_size, & cal_flag, & calb_name, & calb_block c ***************************************************************** INCLUDE 'abincalb.inc' c ***************************************************************** c --- set local variables to fill common block cal_input = input_cal cal_output = output_cal c --- Verify that the input calibration type if( cal_input(1:3).ne.'RAW' ) then kbxini = -1 return endif c --- Verify the output calibration type valid_cal = 0 if(cal_output(1:4).eq.'TEMP') valid_cal = 1 if(cal_output(1:3).eq.'RAD') valid_cal = 1 if(cal_output(1:3).eq.'RAW') valid_cal = 1 if(cal_output(1:3).eq.'ALB') valid_cal = 1 if(cal_output(1:4).eq.'BRIT') valid_cal = 1 do iBAND = 1,L2_NBAND cNAME = L2_MCIDAS_NAMES(iBAND) call bsquez( cNAME ) len_cNAME = len_trim( cNAME ) if( & cal_output(1:len_cNAME).eq. & cNAME(1:len_cNAME) & ) valid_cal=1 enddo if( valid_cal.eq.0 ) then kbxini = -1 return endif c --- set the byte size of the source and destination src_byte_size = io_size(1) dest_byte_size = io_size(2) cal_flag = 0 c --- Switch off new stretch; call kbxopt to switch on enh_str_flag = 0 ! By default, new stretch is off enh_str_name = ' ' kbxini = 0 return end C$ Name: C$ kbxcal - Converts input DN to output of correct byte size & dimensions C$ C$ Interface: C$ integer function C$ kbxcal(integer prefix(*), integer area_dir(*), integer num_pixels, C$ integer band, integer ibuf(*) ) C$ C$ Input: C$ prefix - Line prefix calibration information C$ area_dir - Area directory associated with the IBUF data C$ num_pixels - Number of pixels in IBUF array C$ band - Band number for data in IBUF array C$ ibuf - array of data to be converted C$ C$ Output: C$ ibuf - array of converted data C$ C$ Return values: C$ 0 - success C$ -1 - failure to build a calibration lookup table C$ (output will always be returned in IBUF, even with an C$ invalid or unbuilt table) C$ C$ Remarks: C$ KBXINI determines if the conversion is permitted, by putting C$ constraints on the conversion types. Here, the type is assumed C$ already validated, and the only decision is whether to build a C$ table for a new valid type or use the table already existing. C$ Since data is always returned, it is the user's responsibility to C$ test return value KBXCAL for 0 to guarantee returned data is valid. C$ C$ Categories: C$ image C$ display C$ calibration C$ met/science integer function kbxcal(prefix,area_dir,num_pixels,band,ibuf) implicit none INCLUDE 'areaparm.inc' ! defines NUMAREAOPTIONS c --- constants integer MAXTBLSIZE parameter (MAXTBLSIZE = 65536) integer CALB_SIZE parameter (CALB_SIZE = 577) c --- input parameters integer prefix(*) ! line prefix information to determine detector integer area_dir(*) ! area directory integer num_pixels ! number of pixels in ibuf array integer band ! band number integer*2 ibuf(*) ! I/O array containing pixels to be modified c --- external functions character*12 cfi character*12 cfe character*12 cff c --- local variables character*12 cval character*12 cRAD character*4 last_cal integer area_number ! area number found in area directory integer ss_value integer cal_offset integer i ! do loop index integer j ! do loop index integer last_area ! last area used for araget integer last_band ! last area used for araget integer iRAW integer iRAD integer iTEMP integer iALB integer iBRIT integer jbuf(22000) integer*2 s2array(8) integer DQF_iarray(16) real H ! Planck Constant real C ! Speed of Light real K ! Boltzmann Constant double precision dRAW double precision dRAD double precision dTEMP double precision dALB double precision dSCL double precision dMIN double precision dMAX double precision RAW_SCALE double precision RAD_SCALE double precision TEMP_SCALE double precision ALB_SCALE logical ir_data ! flag indicating ir data requested logical vis_data ! flag indicating visible data requested logical L1B_FLAG ! flag indicating L1B data file logical L2_FLAG ! flag indicating L2 data file c --- GOES ABI calibration block character*4 cal_input ! input calibration type RAW character*4 cal_output ! output cal type (TEMP, ALB, RAD, RAW, BRIT) integer enh_str_flag ! =1 for new BRIT stretch character*8 enh_str_name ! stretch table name integer src_byte_size ! number of bytes for source pixel integer dest_byte_size ! number of bytes for destination pixel integer cal_flag ! 0= from AREA, 1=from server character*4 calb_name ! name of calibration block integer calb_block(18,32) ! cal block common/abincal/ & cal_input, & cal_output, & enh_str_flag, ! =1 for new BRIT stretch & enh_str_name, ! stretch table name & src_byte_size, & dest_byte_size, & cal_flag, & calb_name, & calb_block c --- Cal common integer calb_bandNo integer calb_bitPix integer calb_errorCount integer calb_outCount double precision calb_waveLen double precision calb_gainCnt2rad double precision calb_cnstCnt2rad double precision calb_rad2btpFK1 double precision calb_rad2btpFK2 double precision calb_rad2btpBC1 double precision calb_rad2btpBC2 double precision calb_lightSpeed double precision calb_planckConst double precision calb_bolzConst double precision calb_rad2albedo double precision calb_DQF(16) integer calb_invalidValue common/GOESABI/ & calb_bandNo, & calb_bitPix, & calb_errorCount, & calb_outCount, & calb_waveLen, & calb_gainCnt2rad, & calb_cnstCnt2rad, & calb_rad2btpFK1, & calb_rad2btpFK2, & calb_rad2btpBC1, & calb_rad2btpBC2, & calb_lightSpeed, & calb_planckConst, & calb_bolzConst, & calb_rad2albedo, & calb_DQF, & calb_invalidValue c --- GOES ABI calibration table integer table(MAXTBLSIZE) common/CALTBL/ & table c ************************************************************************ INCLUDE 'abincalb.inc' c ************************************************************************ data last_area /-1/ data last_band /-1/ data last_cal /' '/ data RAW_SCALE /1.0000D0/ data RAD_SCALE /1000.0D0/ data TEMP_SCALE/100.0D0/ data ALB_SCALE /100.0D0/ c --- module return code kbxcal = 0 c --- set internal variables area_number = area_dir(33) ss_value = area_dir(3) cal_offset = area_dir(63) c --- L1B vs L2 image data L1B_FLAG = .FALSE. L2_FLAG = .FALSE. do i = 1, Num_GOESR if( ss_value .eq. L1B_SSS(i) ) L1B_FLAG = .TRUE. if( ss_value .eq. L2_SSS(i) ) L2_FLAG = .TRUE. enddo c --- set ir_data/vis_data flag if (band .le. 6) then vis_data = .TRUE. ir_data = .FALSE. else vis_data = .FALSE. ir_data = .TRUE. endif c --- read in calibration block if (last_area .ne. area_number .and. cal_flag.eq.0) then call araget(area_number,cal_offset,CALB_SIZE*4,calb_name) last_area = area_number last_band = -1 last_cal = ' ' endif if(last_band .ne. band .or. last_cal .ne. cal_output) then c ------ set the constants H = 6.6260755e-34 C = 2.9979246e+8 K = 1.380658e-23 c ------ values from abincal common go into GOESABI common calb_bandNo = calb_block(1,band) calb_bitPix = 2 calb_errorCount = calb_block(18,band) calb_outCount = calb_block(18,band) calb_waveLen = DBLE(calb_block(2,band)) *0.0000001D0 calb_gainCnt2rad = DBLE(calb_block(3,band)) *0.0000001D0 calb_cnstCnt2rad = DBLE(calb_block(4,band)) *0.0000001D0 calb_rad2btpFK1 = DBLE(calb_block(14,band))*0.0001D0 calb_rad2btpFK2 = DBLE(calb_block(15,band))*0.0001D0 calb_rad2btpBC1 = DBLE(calb_block(16,band))*0.0000001D0 calb_rad2btpBC2 = DBLE(calb_block(17,band))*0.0000001D0 calb_rad2albedo = DBLE(calb_block(12,band))*0.0000001D0 calb_invalidValue = calb_block(18,band) c ------ new DQF values 03/13/19 c This is currently set up to read 16 values from a calibration/band block c Each block is 18 words long. DQF values are stored in 8, 32 bit words as c half words (16 values @ 16 bits each). The words are 5,6,7,8,9,10,11 and 13. c The MISSING DATA value = 65530 do i = 1,7 DQF_iarray(i) = calb_block(4+i,band) enddo DQF_iarray(8) = calb_block(13,band) call mpixel( 16,2,4,DQF_iarray) do i = 1,16 if( DQF_iarray(i) .eq. 65530 ) then calb_DQF(i) = DBLE( DQF_iarray(i) ) else calb_DQF(i) = DBLE( DQF_iarray(i) ) * .01 endif enddo calb_lightSpeed = DBLE(C) calb_planckConst = DBLE(H) calb_bolzConst = DBLE(K) cval = cfi( calb_bandNo ) call mctrace(1,'KBXABIN','Band ='//cval) cval = cfe( REAL(calb_gainCnt2rad), 6 ) call mctrace(1,'KBXABIN','Scale ='//cval) cval = cfe( REAL(calb_cnstCnt2rad), 6 ) call mctrace(1,'KBXABIN','Offset ='//cval) cval = cfe( REAL(calb_waveLen), 6 ) call mctrace(1,'KBXABIN','WaveLength ='//cval) cval = cfe( REAL(calb_rad2btpFK1), 6 ) call mctrace(1,'KBXABIN','radtobtpFK1 ='//cval) cval = cfe( REAL(calb_rad2btpFK2), 6 ) call mctrace(1,'KBXABIN','radtobtpFK2 ='//cval) cval = cfe( REAL(calb_rad2btpbC1), 6 ) call mctrace(1,'KBXABIN','radtobtpBC1 ='//cval) cval = cfe( REAL(calb_rad2btpbC2), 6 ) call mctrace(1,'KBXABIN','radtobtpBC2 ='//cval) cval = cfe( REAL(calb_rad2albedo), 6 ) call mctrace(1,'KBXABIN','radtoalbedo ='//cval) do i = 1,16 if( calb_DQF(i).eq.65530.0 ) then cval = cfi( INT( calb_DQF(i) ) ) else cval = cff( calb_DQF(i) , 6 ) endif call mctrace(1,'KBXABIN','DQF ='//cval) enddo c ------ PRODUCT RANGE if( L2_FLAG ) then cval = L2_MCIDAS_NAMES(band) call mctrace(1,'KBXABIN','Product NAME ='//cval) cval = L2_MCIDAS_UNITS(band) call mctrace(1,'KBXABIN','Product UNIT ='//cval) dSCL = dble( L2_MCIDAS_SCALES(band) ) cval = cfe( REAL(dSCL), 6 ) call mctrace(1,'KBXABIN','Product SCALE ='//cval) dMIN = dble( L2_MCIDAS_MINS(band) ) cval = cfe( REAL(dMIN), 6 ) call mctrace(1,'KBXABIN','Product MIN ='//cval) dMAX = dble( L2_MCIDAS_MAXS(band) ) cval = cfe( REAL(dMAX), 6 ) call mctrace(1,'KBXABIN','Product MAX ='//cval) endif c ------ make the lookup table call maktbl( ss_value, band ) last_band = band last_cal = cal_output endif call mpixtb(num_pixels,src_byte_size,dest_byte_size,ibuf,table) return end C$ Name: C$ kbxopt - Returns auxiliary parameters for setup or sets internal state C$ C$ Interface: C$ integer function C$ kbxopt(character*4 option, integer param_in(*), integer param_out(*)) C$ C$ Input: C$ option - Option ('KEYS', 'INFO', 'CALB' ) C$ param_in - Array of input parameters C$ C$ Output: C$ param_out - Array of output parameters C$ (The number of input and output parameters is determined C$ by the option or function executed. The calling routine C$ is responsible for having arrays large enough to send C$ and receive output for the option or function requested.) C$ C$ Return values: C$ 0 - success C$ -1 - Invalid function requested C$ -3 - Error in breakpoint table (table cannot be set up) C$ -4 - Error in specifying enhanced stretch C$ C$ Remarks: C$ Check the d.pgm code to see how the various functions are used. C$ C$ Categories: C$ image C$ display C$ calibration C$ met/science integer function kbxopt(option,param_in,param_out) implicit none c --- constants integer CALB_SIZE parameter (CALB_SIZE = 577) c --- input parameters character*4 option ! option integer param_in(*) ! input parameters c --- output parameters integer param_out(*) ! output parameters c --- external functions character*12 cfe character*12 cfi character*4 clit integer m0brkset ! checks SU table integer ischar ! checks for character string integer lit ! four byte integer representation of char*4 integer len_trim integer kbenhstr c --- local variables character*4 cNAME,cPARM character*12 cval1 character*12 cvalue character*8 su_file ! stretch table file integer band ! band number integer i,j, iret integer iSSS ! Satellite number integer len_cNAME integer TDQF_area integer last_TDQF_area integer TDQF_band integer TDQF_offset logical brt_data ! flag indicating ir data requested logical ir_data ! flag indicating ir data requested logical vis_data ! flag indicating visible data requested logical prd_data ! flag indicating product data requested logical L1B_FLAG ! flag indicating L1B data file logical L2_FLAG ! flag indicating L2 data file c --- GOES ABI calibration block character*4 cal_input ! input calibration type (RAW) character*4 cal_output ! output cal type (TEMP, ALB, RAD, RAW, BRIT) integer enh_str_flag ! =1 for new BRIT stretch character*8 enh_str_name ! stretch table name integer src_byte_size ! number of bytes for source pixel integer dest_byte_size ! number of bytes for destination pixel integer cal_flag ! 0=from AREA, 1=from server character*4 calb_name ! name of calibration block integer calb_block(18,32) ! cal block common/abincal/ & cal_input, & cal_output, & enh_str_flag, ! =1 for new BRIT stretch & enh_str_name, ! stretch table name & src_byte_size, & dest_byte_size, & cal_flag, & calb_name, & calb_block c --- Cal common integer calb_bandNo integer calb_bitPix integer calb_errorCount integer calb_outCount double precision calb_waveLen double precision calb_gainCnt2rad double precision calb_cnstCnt2rad double precision calb_rad2btpFK1 double precision calb_rad2btpFK2 double precision calb_rad2btpBC1 double precision calb_rad2btpBC2 double precision calb_lightSpeed double precision calb_planckConst double precision calb_bolzConst double precision calb_rad2albedo double precision calb_DQF(16) integer calb_invalidValue common/GOESABI/ & calb_bandNo, & calb_bitPix, & calb_errorCount, & calb_outCount, & calb_waveLen, & calb_gainCnt2rad, & calb_cnstCnt2rad, & calb_rad2btpFK1, & calb_rad2btpFK2, & calb_rad2btpBC1, & calb_rad2btpBC2, & calb_lightSpeed, & calb_planckConst, & calb_bolzConst, & calb_rad2albedo, & calb_DQF, & calb_invalidValue c ************************************************************ INCLUDE 'abincalb.inc' c ************************************************************ data last_TDQF_area/-9999/ kbxopt = 0 vis_data = .FALSE. ir_data = .FALSE. prd_data = .FALSE. brt_data = .TRUE. if (option .eq. 'KEYS') then c c --- param_in contains frame directory - set ir_data/vis_data flag c iSSS = param_in(1) band = param_in(4) do i = 1, Num_GOESR if( iSSS.eq.L1B_SSS(i) ) then prd_data = .FALSE. brt_data = .FALSE. if (band .le. 6) then vis_data = .TRUE. ir_data = .FALSE. else vis_data = .FALSE. ir_data = .TRUE. endif elseif( iSSS.eq.L2_SSS(i) ) then prd_data = .TRUE. brt_data = .FALSE. vis_data = .FALSE. ir_data = .FALSE. endif enddo if (vis_data) then param_out(1) = 4 param_out(2) = lit('RAW ') param_out(3) = lit('RAD ') param_out(4) = lit('ALB ') param_out(5) = lit('BRIT') elseif (ir_data) then param_out(1) = 4 param_out(2) = lit('RAW ') param_out(3) = lit('RAD ') param_out(4) = lit('TEMP') param_out(5) = lit('BRIT') elseif (prd_data) then cNAME = L2_MCIDAS_NAMES(band) call bsquez( cNAME ) len_cNAME = len_trim( cNAME ) cPARM = ' ' cPARM(1:len_cNAME) = cNAME(1:len_cNAME) param_out(1) = 3 param_out(2) = lit('RAW ') param_out(3) = lit(cPARM(1:4)) param_out(4) = lit('BRIT') elseif (brt_data) then param_out(1) = 2 param_out(2) = lit('RAW ') param_out(3) = lit('BRIT') endif c c --- Check for a stretch table (SU) c if (ischar(param_in(38)) .eq. 1) then call movwc(param_in(38),su_file) if (m0brkset(su_file,cal_input) .ne. 0) then kbxopt = -3 endif endif elseif (option .eq. 'BRKP') then c c --- param_in(1) is the su table name c call movwc(param_in(1),su_file) if (m0brkset(su_file,cal_input) .ne. 0) then kbxopt = -3 endif elseif (option .eq. 'STR ') then c c --- ORIGinal or EXPanded stretch c enh_str_flag = kbenhstr(param_in, enh_str_name) call movcw(' ', param_out) if(enh_str_flag .lt. 0) kbxopt = -4 call movcw(enh_str_name, param_out) elseif (option .eq. 'INFO') then c c --- param_in contains frame directory - set ir_data/vis_data flag c band = param_in(1) iSSS = param_in(2) do i = 1, Num_GOESR if( iSSS .eq. L1B_SSS(i) ) then brt_data = .FALSE. prd_data = .FALSE. if (band .le. 6) then vis_data = .TRUE. ir_data = .FALSE. else vis_data = .FALSE. ir_data = .TRUE. endif elseif( iSSS .eq. L2_SSS(i) ) then prd_data = .TRUE. vis_data = .FALSE. ir_data = .FALSE. brt_data = .FALSE. endif enddo if (vis_data) then param_out(1) = 4 param_out(2) = lit('RAW ') param_out(3) = lit('RAD ') param_out(4) = lit('ALB ') param_out(5) = lit('BRIT') param_out(6) = lit(' ') param_out(7) = lit('WM**') param_out(8) = lit(' % ') param_out(9) = lit(' ') param_out(10) = 1 param_out(11) = 1000 param_out(12) = 100 param_out(13) = 1 elseif (ir_data) then param_out(1) = 4 param_out(2) = lit('RAW ') param_out(3) = lit('RAD ') param_out(4) = lit('TEMP') param_out(5) = lit('BRIT') param_out(6) = lit(' ') param_out(7) = lit('MW**') param_out(8) = lit(' K ') param_out(9) = lit(' ') param_out(10)= 1 param_out(11)= 1000 param_out(12)= 100 param_out(13)= 1 elseif (prd_data) then cNAME = L2_MCIDAS_NAMES(band) call bsquez( cNAME ) len_cNAME = len_trim( cNAME ) cPARM = ' ' cPARM(1:len_cNAME) = cNAME(1:len_cNAME) param_out(1) = 3 param_out(2) = lit('RAW ') param_out(3) = lit(cPARM(1:4)) param_out(4) = lit('BRIT') cNAME = L2_MCIDAS_UNITS(band) call bsquez( cNAME ) len_cNAME = len_trim( cNAME ) cPARM = ' ' cPARM(1:len_cNAME) = cNAME(1:len_cNAME) param_out(5) = lit(' ') param_out(6) = lit(cPARM(1:4)) param_out(7) = lit(' ') param_out(8) = 1 param_out(9) = L2_MCIDAS_SCALES(band) param_out(10)= 1 elseif (brt_data) then param_out(1) = 2 param_out(2) = lit('RAW ') param_out(3) = lit('BRIT') param_out(4) = lit(' ') param_out(5) = lit(' ') param_out(6)= 1 param_out(7)= 1 endif c --- param_in contains calibration block from server elseif (option .eq. 'CALB') then cal_flag = 1 call movw( CALB_SIZE, param_in, calb_name ) do j = 1,6 do i = 1,18 cvalue = cfi( calb_block(i,j) ) call mctrace(1,'KBXABIN','value='//cvalue) enddo enddo c --- param_in contains calibration block from server elseif (option .eq. 'TDQF') then TDQF_band = param_in(4) TDQF_area = param_in(17) TDQF_offset = param_in(63) cvalue = cfi( TDQF_band ) call mctrace(1,'KBXABIN','TDQF_band ='//cvalue) cvalue = cfi( TDQF_area ) call mctrace(1,'KBXABIN','TDQF_area ='//cvalue) cvalue = cfi( TDQF_offset ) call mctrace(1,'KBXABIN','TDQF_offset ='//cvalue) c ------ read in calibration block if( last_TDQF_area .ne. TDQF_area ) then call araget(TDQF_area,TDQF_offset,CALB_SIZE*4,calb_name) last_TDQF_area = TDQF_area endif c ------ new DQF values 03/13/19 c This is currently set up to read 16 values from a calibration/band block c Each block is 18 words long. DQF values are stored in 8, 32 bit words as c half words (16 values @ 16 bits each). The words are 5,6,7,8,9,10,11 and 13. c The MISSING DATA value = 65530 do i = 1,7 param_out(i) = calb_block(4+i,TDQF_band) enddo param_out(8) = calb_block(13,TDQF_band) call mpixel( 16,2,4,param_out ) do i = 1,8 cvalue = cfi( param_out(i) ) call mctrace(1,'KBXABIN','TDQF value ='//cvalue) enddo else kbxopt = -1 endif return end subroutine RADtoTEMP( & RAD, & TEMP & ) implicit none c --- parameters double precision RAD double precision TEMP c --- external functions character*12 cfe c --- internal variables character*12 cval double precision radiance double precision effective_temperature double precision lambda double precision planck_c1 double precision planck_c2 c --- Cal common integer calb_bandNo integer calb_bitPix integer calb_errorCount integer calb_outCount double precision calb_waveLen double precision calb_gainCnt2rad double precision calb_cnstCnt2rad double precision calb_rad2btpFK1 double precision calb_rad2btpFK2 double precision calb_rad2btpBC1 double precision calb_rad2btpBC2 double precision calb_lightSpeed double precision calb_planckConst double precision calb_bolzConst double precision calb_rad2albedo double precision calb_DQF(16) integer calb_invalidValue common/GOESABI/ & calb_bandNo, & calb_bitPix, & calb_errorCount, & calb_outCount, & calb_waveLen, & calb_gainCnt2rad, & calb_cnstCnt2rad, & calb_rad2btpFK1, & calb_rad2btpFK2, & calb_rad2btpBC1, & calb_rad2btpBC2, & calb_lightSpeed, & calb_planckConst, & calb_bolzConst, & calb_rad2albedo, & calb_DQF, & calb_invalidValue c ****************************************************************** INCLUDE 'abincalb.inc' c ****************************************************************** c --- radiance radiance = RAD c --- compute the brightness temperature TEMP = -9999.0D0; if( radiance.gt.0.0D0 ) then TEMP=calb_rad2btpFK2/ & DLOG(calb_rad2btpFK1/radiance+1.0D0) TEMP=(TEMP-calb_rad2btpBC1)/calb_rad2btpBC2 endif return end subroutine maktbl( ss_value, band ) implicit none c --- constants integer MAXTBLSIZE parameter (MAXTBLSIZE = 65536) integer CALB_SIZE parameter (CALB_SIZE = 577) c --- parameters integer ss_value integer band c --- external functions character*12 cfd character*12 cfi integer len_trim integer m0brkset integer m0graybrkset integer m0grayscale integer isenhstr c --- internal variables character*4 cNAME character*8 PROCESS character*12 cRAD character*12 cCNT character*12 cval character*4 ret_unit integer last_area ! last area used for araget integer last_band ! last area used for araget integer i integer iCNT integer iRAW integer iRAD integer iPRD integer iTEMP integer iALB integer iBRIT integer len integer iret integer L2_MAXERR double precision PRD_SCALE double precision PRD_MIN double precision PRD_MAX double precision RAW_SCALE double precision RAD_SCALE double precision TEMP_SCALE double precision ALB_SCALE double precision dRAW double precision dRAD double precision dPRD double precision dTEMP double precision dALB logical ir_data ! flag indicating ir data requested logical vis_data ! flag indicating visible data requested logical L1B_FLAG ! flag indicating L1B data file logical L2_FLAG ! flag indicating L2 data file real H ! Planck Constant real C ! Speed of Light real K ! Boltzmann Constant real rALB real rBRIT c --- Cal common integer calb_bandNo integer calb_bitPix integer calb_errorCount integer calb_outCount double precision calb_waveLen double precision calb_gainCnt2rad double precision calb_cnstCnt2rad double precision calb_rad2btpFK1 double precision calb_rad2btpFK2 double precision calb_rad2btpBC1 double precision calb_rad2btpBC2 double precision calb_lightSpeed double precision calb_planckConst double precision calb_bolzConst double precision calb_rad2albedo double precision calb_DQF(16) integer calb_invalidValue common/GOESABI/ & calb_bandNo, & calb_bitPix, & calb_errorCount, & calb_outCount, & calb_waveLen, & calb_gainCnt2rad, & calb_cnstCnt2rad, & calb_rad2btpFK1, & calb_rad2btpFK2, & calb_rad2btpBC1, & calb_rad2btpBC2, & calb_lightSpeed, & calb_planckConst, & calb_bolzConst, & calb_rad2albedo, & calb_DQF, & calb_invalidValue c --- GOES ABI calibration block character*4 cal_input ! input calibration type (RAW) character*4 cal_output ! output cal type (TEMP, ALB, RAD, RAW, BRIT) integer enh_str_flag ! =1 for new BRIT stretch character*8 enh_str_name ! stretch table name integer src_byte_size ! number of bytes for source pixel integer dest_byte_size ! number of bytes for destination pixel integer cal_flag ! 0= from AREA, 1= from server character*4 calb_name ! name of calibration block integer calb_block(18,32) ! cal block common/abincal/ & cal_input, & cal_output, & enh_str_flag, ! =1 for new BRIT stretch & enh_str_name, ! stretch table name & src_byte_size, & dest_byte_size, & cal_flag, & calb_name, & calb_block c --- GOES ABI calibration table integer table(MAXTBLSIZE) common/CALTBL/ & table c *************************************************************** INCLUDE 'abincalb.inc' c *************************************************************** data RAW_SCALE /1.0000D0/ data RAD_SCALE /1000.0D0/ data TEMP_SCALE/100.0D0/ data ALB_SCALE /100.0D0/ data L2_MAXERR/65535/ c --- L1B vs L2 image data L1B_FLAG = .FALSE. L2_FLAG = .FALSE. do i = 1, Num_GOESR if( ss_value .eq. L1B_SSS(i) ) L1B_FLAG = .TRUE. if( ss_value .eq. L2_SSS(i) ) L2_FLAG = .TRUE. enddo c --- set ir_data/vis_data flag if (band .le. 6) then vis_data = .TRUE. ir_data = .FALSE. else vis_data = .FALSE. ir_data = .TRUE. endif c --- Setup for EXPanded BRIT values if(enh_str_flag .eq. 1 .and. L1B_FLAG) then iret = isenhstr(ss_value, band, enh_str_name) if( iret .eq. 0) then iret = m0graybrkset(enh_str_name) endif endif c --- get the PRD specific fields if( L2_FLAG ) then cNAME = L2_MCIDAS_NAMES(band) call bsquez( cNAME ) len = len_trim( cNAME ) PRD_SCALE = dble( L2_MCIDAS_SCALES(band) ) PRD_MAX = dble( L2_MCIDAS_MAXS(band) ) PRD_MIN = dble( L2_MCIDAS_MINS(band) ) PROCESS = L2_McIDAS_PROCESS(band) c ------ determine error codes c L2_MINERR = MIN(calb_errorCount,calb_outCount) endif c --- loop through incoming RAW counts do i = 1, MAXTBLSIZE c --- calibrate the RAW units if (cal_output(1:3) .eq. 'RAW') then dRAW = dble(i-1) iRAW = INT( dRAW*RAW_SCALE ) c --- need to convert to another physical value else c --- for L1B files if( L1B_FLAG ) then c ------ count value is table index iCNT = i-1 c ------ convert RAW to RAD if( & iCNT.eq.calb_errorCount .or. & iCNT.eq.calb_outCount & ) then dRAD = calb_invalidValue iRAD = 0 else dRAD = dble(iCNT)*calb_gainCnt2rad+calb_cnstCnt2rad if( dRAD.le.0.0D0 ) then iRAD = NINT( dRAD*RAD_SCALE ) dRAD = calb_invalidValue else iRAD = NINT( dRAD*RAD_SCALE ) endif endif c ------ for reflectance bands if( vis_data ) then c --------- convert RAD to ALB/BRIT if( & cal_output(1:3).eq.'ALB' .or. & cal_output(1:4).eq.'BRIT' & ) then if( dRAD.eq.calb_invalidValue ) then dALB = calb_invalidValue c -- WCS3 - Added to make Albedo 0 for space and invalid pixels */ iALB = 0 rALB = 0 iBRIT = 0 c -- WCS3 */ else dALB = calb_rad2albedo*dRAD rALB = REAL(dALB) iret = m0grayscale('ALB', rALB*100., rBRIT) iBRIT = NINT(rBRIT) iALB = INT( dALB*100.0D0*ALB_SCALE ) iBRIT = MIN(MAX(iBRIT,0),255) endif endif c ------ for radiance bands else c --------- convert RAD to TEMP/BRIT if( & cal_output(1:4).eq.'TEMP' .or. & cal_output(1:4).eq.'BRIT' & ) then if( dRAD.eq.calb_invalidValue ) Then dTEMP = calb_invalidValue iTEMP = 0 iBRIT = 255 else call RADtoTEMP(dRAD, dTEMP) iret = m0grayscale('TEMP', sngl(dTEMP), rBRIT) iBRIT = nint(rBRIT) iTEMP = NINT( dTEMP*TEMP_SCALE ) iBRIT = MIN(MAX(iBRIT,0),255) endif endif endif c ------ move the computed value into the array if( cal_output(1:3).eq.'RAW' ) table(i) = iRAW if( cal_output(1:3).eq.'RAD' ) table(i) = iRAD if( cal_output(1:3).eq.'TEM' ) table(i) = iTEMP if( cal_output(1:3).eq.'ALB' ) table(i) = iALB if( cal_output(1:3).eq.'BRI' ) table(i) = iBRIT c --- ABI L2 products elseif( L2_FLAG ) then c ------ count value is table index iCNT = i-1 c ------ convert RAW to PRD if( & iCNT.eq.calb_errorCount .or. & iCNT.eq.calb_outCount .or. & iCNT.eq.L2_MAXERR & ) then dPRD = calb_invalidValue iPRD = 0 else dPRD = dble(iCNT)*calb_gainCnt2rad+calb_cnstCnt2rad if( dPRD.lt.PRD_MIN ) then c dPRD = calb_invalidValue c iPRD = 0 iPRD = NINT( dPRD*PRD_SCALE ) dPRD = PRD_MIN elseif( dPRD.gt.PRD_MAX) then c dPRD = calb_invalidValue c iPRD = 0 iPRD = NINT( dPRD*PRD_SCALE ) dPRD = PRD_MAX else iPRD = NINT( dPRD*PRD_SCALE ) endif endif c ------ convert PRD to BRIT if( cal_output(1:4).eq.'BRIT' ) then if( dPRD.eq.calb_invalidValue ) then iBRIT = 0 else c ************ PROCESSing from scientific units to BRIT c ------------ BINARY if( PROCESS(1:6).eq.'BINARY' ) then iBRIT = NINT(dPRD*255.0) endif c ------------ SQRT if( PROCESS(1:4).eq.'SQRT' ) then rALB = REAL((dPRD-PRD_MIN)/(PRD_MAX-PRD_MIN)) iBRIT = NINT(SQRT(rALB)*255.0) endif c ------------ LINEAR if( PROCESS(1:6).eq.'LINEAR' ) then rALB = REAL((dPRD-PRD_MIN)/(PRD_MAX-PRD_MIN)) iBRIT = NINT(rALB*255.0) endif c ------------ INVLINE if( PROCESS(1:7).eq.'INVLINE' ) then rALB = REAL((dPRD-PRD_MIN)/(PRD_MAX-PRD_MIN)) iBRIT = 255 - NINT(rALB*255.0) endif c ------------ INVSQRT if( PROCESS(1:7).eq.'INVSQRT' ) then rALB = REAL((dPRD-PRD_MIN)/(PRD_MAX-PRD_MIN)) iBRIT = 255 - NINT(SQRT(rALB)*255.0) endif c ------------ GRYSCL if( PROCESS(1:6).eq.'GRYSCL' ) then call gryscl(REAL(dPRD),iBRIT) endif c ------------ NONE if( PROCESS(1:4).eq.'NONE' ) then iBRIT = NINT(dPRD) endif endif c --------- enforce the 8-bit brightness values iBRIT = MIN(MAX(iBRIT,0),255) endif c ------ move the computed value into the array table(i)=0 if(cal_output(1:3).eq.'RAW') then table(i)=iRAW elseif(cal_output(1:len).eq.cNAME(1:len)) then table(i)=iPRD elseif(cal_output(1:3).eq.'BRI') then table(i)=iBRIT endif endif endif enddo call mctrace(1,'KBXABIN','lookup table created') return end