C Copyright(c) 2001, 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: kbxmsg.dlm,v 1.25 2021/01/31 17:54:53 daves Exp $ *** C Calibration for Meteosat second generation (MSG) INTEGER FUNCTION KBXINI(CIN,COUT,IOPT) IMPLICIT NONE CHARACTER*4 CIN CHARACTER*4 COUT INTEGER IOPT(*) ! symbolic constants & shared data INCLUDE 'areaparm.inc' INTEGER ITYPE INTEGER JTYPE INTEGER JOPT(NUMAREAOPTIONS) INTEGER CALFLG INTEGER CALARR(400) integer enh_str_flag ! =1 for new BRIT stretch character*8 enh_str_name ! stretch table name COMMON/MSGCOM/ITYPE,JTYPE,JOPT,CALFLG,CALARR, & enh_str_flag, enh_str_name ! external functions ! local variables C CALL MOVW(NUMAREAOPTIONS,IOPT,JOPT) ITYPE=0 CALFLG = 0 if(CIN.eq.'RAW'.and. COUT.eq.'BRIT') ITYPE=1 if(CIN.eq.'RAW'.and. COUT.eq.'RAD ') ITYPE=2 if(CIN.eq.'RAW'.and. COUT.eq.'REFL') ITYPE=3 if(CIN.eq.'RAW'.and. COUT.eq.'TEMP') ITYPE=4 if(ITYPE.eq.0) GOTO 900 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 900 CONTINUE KBXINI=-1 RETURN END C C-------------------------------------------------------------------- INTEGER FUNCTION KBXCAL(PFX,IDIR,NVAL,BAND,IBUF) IMPLICIT NONE INTEGER PFX(*) INTEGER IDIR(*) INTEGER NVAL INTEGER BAND INTEGER*2 IBUF(*) ! symbolic constants & shared data INCLUDE 'areaparm.inc' INTEGER ITYPE INTEGER JTYPE INTEGER JOPT(NUMAREAOPTIONS) INTEGER CALFLG INTEGER CALSIZ INTEGER CALARR(400) integer enh_str_flag ! =1 for new BRIT stretch character*8 enh_str_name ! stretch table name COMMON/MSGCOM/ITYPE,JTYPE,JOPT,CALFLG,CALARR, & enh_str_flag, enh_str_name ! external functions CHARACTER*12 CFI CHARACTER*12 CFE CHARACTER*12 CFF CHARACTER*4 CLIT INTEGER M0ARASIZE INTEGER m0graybrkset INTEGER m0grayscale INTEGER isenhstr ! local variables CHARACTER*4 CPCP CHARACTER*104 COUT CHARACTER*1600 CBUF INTEGER I INTEGER IDES INTEGER iret INTEGER ISOU INTEGER ITEMP INTEGER THISAREA INTEGER THISBAND INTEGER BANDOFFSET INTEGER BUF(400) INTEGER IBRIT INTEGER SS INTEGER SAT_OFFSET INTEGER IPCP(12) REAL XTEMP REAL REFL real rBRIT real RADSCALE DOUBLE PRECISION C1W3 DOUBLE PRECISION C2W DOUBLE PRECISION ALPHA DOUBLE PRECISION BETA DOUBLE PRECISION GAIN DOUBLE PRECISION OFFSET REAL FACTOR(12,4) DATA THISAREA/-9999/ DATA THISBAND/-9999/ C --- ADDED FOR EUMETSAT COMPATIBILITY DATA C1W3/0.0D0/ DATA C2W/0.0D0/ DATA ALPHA/0.0D0/ DATA BETA/0.0D0/ DATA GAIN/0.0D0/ DATA OFFSET/0.0D0/ c --- Visible factors for MSG-8 data (factor(i,1),i=1,12)/ & 20.76, & 23.24, & 19.85, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 25.07 & / c --- Visible factors for MSG-9 data (factor(i,2),i=1,12)/ & 20.76, & 23.30, & 19.73, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 25.17 & / c --- Visible factors for MSG-10 data (factor(i,3),i=1,12)/ & 20.85, & 23.29, & 19.74, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 25.13 & / c --- Visible factors for MSG-11 data (factor(i,4),i=1,12)/ & 20.78, & 23.29, & 19.71, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 0.00, & 25.15 & / C C --- get SS number form AREA Directory C ss = idir(3) if (ss .eq. 51) then sat_offset = 1 ! Meteosat 8 elseif (ss .eq. 52) then sat_offset = 2 ! Meteosat 9 elseif (ss .eq. 53) then sat_offset = 3 ! Meteosat 10 elseif (ss .eq. 354) then sat_offset = 4 ! Meteosat 11 endif C --- get radiometric constants from CAL header IF( THISBAND .NE. BAND .OR. THISAREA .NE. IDIR(33) ) THEN c --- Setup for EXPanded BRIT values if(enh_str_flag .eq. 1) then iret = isenhstr(ss, band, enh_str_name) if( iret .eq. 0) then iret = m0graybrkset(enh_str_name) endif endif CALL ZEROW( 12, IPCP ) THISAREA = IDIR(33) THISBAND = BAND RADSCALE=100. IF( BAND .GE. 4 .AND. BAND .LE. 6) RADSCALE=1000. COUT = ' ' CALSIZ = M0ARASIZE('CAL', IDIR) C ------ Check to see if calibration block passed in through kbxopt IF(CALFLG .NE. 0) THEN CALL MOVB(CALSIZ, CALARR, BUF, 0) ELSE CALL ARAGET(IDIR(33),IDIR(63),CALSIZ,BUF) ENDIF CALL MOVWC(BUF, CBUF) C ------ NEW FORMAT: ALL BANDS IN BLOCK IF( CBUF(1:4).EQ.'MSGT' ) THEN BANDOFFSET = (BAND-1)*104+5 COUT(1:104) = CBUF(BANDOFFSET:BANDOFFSET+103) C --------- PLANNED CHANEL PROCESSING IF( CALSIZ.GT.313 ) THEN CALL M0SXTRCE('KBXMSG: PCP IS INCLUDED') DO I = 1,12 IPCP(I) = 0 CPCP = CLIT(BUF(313+I)) IF( CPCP(1:1).EQ.'1' ) IPCP(I) = 1 IF( CPCP(1:1).EQ.'2' ) IPCP(I) = 2 ENDDO ENDIF ELSE COUT = CBUF(1:104) ENDIF CALL M0SXTRCE('KBXMSG: CAL='//COUT) 1 FORMAT(6E17.10) READ(COUT,1,ERR=999) C1W3,C2W,ALPHA,BETA,GAIN,OFFSET CALL M0SXTRCE('KBXMSG: GAIN='//CFF( GAIN, 4 )) CALL M0SXTRCE('KBXMSG: OFFSET='//CFF( OFFSET, 4 )) ENDIF ISOU=JOPT(1) IDES=JOPT(2) DO I = 1, NVAL ITEMP = IBUF(I) C --- Visible and near-visible (VIS006, VIS008, IR016, HRV) IF( BAND.LT.4 .OR. BAND.EQ.12) THEN C ------ RAW->TEMP, can't do temperature for this channel IF( ITYPE.EQ.4 ) THEN IBUF(I)=0 ELSE XTEMP = ( REAL(ITEMP) * GAIN ) + OFFSET IF( XTEMP.LE.0.0 ) XTEMP = 0.0 C ----------radiance IF( ITYPE.EQ.2 ) THEN IBUF(I) = NINT( XTEMP*100.0 ) C --------- reflectance ELSEIF( ITYPE.EQ.3 ) then REFL = (XTEMP/FACTOR(BAND,sat_offset))*100 IF( REFL.LT. 0.00 ) REFL = 0.00 IF( REFL.GT.100.00 ) REFL = 100.00 IBUF(I) = NINT(REFL*100) C --------- brightness ELSE REFL = (XTEMP/FACTOR(BAND,sat_offset))*100 IF( REFL.LT. 0.00 ) REFL = 0.00 IF( REFL.GT.100.00 ) REFL = 100.00 iret = m0grayscale('ALB', REFL, rBRIT) IBUF(I) = NINT(rBRIT) ENDIF ENDIF C --- IR channel ELSE XTEMP = (GAIN * ITEMP) + OFFSET IF( XTEMP.LT.0.0 ) XTEMP = 0.0 C ------ radiance IF( ITYPE.EQ.2) THEN IBUF(I) = NINT( XTEMP*RADSCALE ) C ------ reflectance, can't do reflectance for these channels ELSEIF( ITYPE.EQ.3 ) THEN IBUF(I)=0 C ------ temperature ELSEIF( ITYPE.EQ.4) THEN IF( XTEMP.gt.0.0 ) THEN XTEMP = (C2W/LOG(1.0+C1W3/XTEMP)-BETA)/ALPHA IBUF(I)=NINT( XTEMP*100.0 ) ELSE IBUF(I) = 0 ENDIF C ------ brightness ELSE IF( XTEMP.gt.0.0 ) THEN XTEMP = (C2W/LOG(1.0+C1W3/XTEMP)-BETA)/ALPHA iret = m0grayscale('TEMP', XTEMP, rBRIT) IBUF(I) = nint(rBRIT) ELSE IBUF(I) = 255 ENDIF ENDIF ENDIF ENDDO c --- pack the array CALL MPIXEL(NVAL,ISOU,IDES,IBUF) KBXCAL=0 RETURN C --- READ ERROR 999 CALL M0SXTRCE('KBXMSG: CAN NOT READ CAL HEADER') KBXCAL=-1 RETURN END C C-------------------------------------------------------------------- INTEGER FUNCTION KBXOPT(CFUNC,IIN,IOUT) IMPLICIT NONE CHARACTER*4 CFUNC INTEGER IIN(*) INTEGER IOUT(*) ! external functions INTEGER LIT integer kbenhstr INCLUDE 'areaparm.inc' INTEGER ITYPE INTEGER JTYPE INTEGER JOPT(NUMAREAOPTIONS) INTEGER CALFLG INTEGER CALARR(400) integer enh_str_flag ! =1 for new BRIT stretch character*8 enh_str_name ! stretch table name COMMON/MSGCOM/ITYPE,JTYPE,JOPT,CALFLG,CALARR, & enh_str_flag, enh_str_name C KBXOPT=0 IF(CFUNC(1:4).EQ.'KEYS') THEN IF( IIN(4).LE.3 .OR. IIN(4).EQ.12 ) THEN IOUT(1)=4 IOUT(2)=LIT('RAW ') IOUT(3)=LIT('RAD ') IOUT(4)=LIT('REFL') IOUT(5)=LIT('BRIT') ELSE IOUT(1)=4 IOUT(2)=LIT('RAW ') IOUT(3)=LIT('RAD ') IOUT(4)=LIT('TEMP') IOUT(5)=LIT('BRIT') ENDIF ELSEIF(CFUNC(1:4).EQ.'INFO') THEN IF( IIN(1).LE.3 .OR. IIN(1).EQ.12 ) THEN IOUT(1)=4 IOUT(2)=LIT('RAW ') IOUT(3)=LIT('RAD ') IOUT(4)=LIT('REFL') IOUT(5)=LIT('BRIT') IOUT(6)=LIT(' ') IOUT(7)=LIT('MW**') IOUT(8)=LIT('% ') IOUT(9)=LIT(' ') IOUT(10)=1 IOUT(11)=100 IOUT(12)=100 IOUT(13)=1 ELSE IOUT(1)=4 IOUT(2)=LIT('RAW ') IOUT(3)=LIT('RAD ') IOUT(4)=LIT('TEMP') IOUT(5)=LIT('BRIT') IOUT(6)=LIT(' ') IOUT(7)=LIT('MW**') IOUT(8)=LIT('K ') IOUT(9)=LIT(' ') IOUT(10)=1 IOUT(11)=100 IF( IIN(1) .GE. 4 .AND. IIN(1) .LE. 6) IOUT(11)=1000 IOUT(12)=100 IOUT(13)=1 ENDIF elseif (cfunc .eq. 'STR ') then c c --- ORIGinal or EXPanded stretch c enh_str_flag = kbenhstr(iin, enh_str_name) call movcw(' ', iout) if(enh_str_flag .lt. 0) kbxopt = -4 call movcw(enh_str_name, iout) ELSEIF(CFUNC(1:4).EQ.'CALB') THEN CALFLG = 1 CALL MOVW(400,IIN,CALARR) ELSE KBXOPT=-1 ENDIF RETURN END