C Copyright(c) 1999, 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: kbxindi.dlm,v 1.1 2011/04/05 15:05:42 tommyj Rel $ *** INTEGER FUNCTION KBXINI(CIN, COUT, IOPT) IMPLICIT NONE INCLUDE 'areaparm.inc' C --- PARAMETERS CHARACTER*4 CIN ! input units CHARACTER*4 COUT ! output units INTEGER IOPT(*) ! options C --- CONSTANTS INTEGER ITYPE INTEGER JTYPE INTEGER JOPT(NUMAREAOPTIONS) COMMON /INDICALXX/ ITYPE, JTYPE, JOPT C --- move the options from the input to the common CALL MOVW( NUMAREAOPTIONS, IOPT, JOPT) C --- check for invalid input units ITYPE = 0 IF( CIN(1:3).EQ.'RAW' ) ITYPE = 1 IF( CIN(1:3).EQ.'ALB' ) ITYPE = 2 IF( CIN(1:3).EQ.'RAD' ) ITYPE = 3 IF( CIN(1:4).EQ.'TEMP' ) ITYPE = 4 IF( CIN(1:4).EQ.'BRIT' ) ITYPE = 5 IF( ITYPE.EQ.0 ) THEN KBXINI = -1 RETURN ENDIF CALL M0SXTRCE('INDI CAL: CIN='//CIN(1:4)) C --- check for invalid output units JTYPE = 0 IF( COUT(1:3).EQ.'RAW' ) JTYPE = 1 IF( COUT(1:3).EQ.'ALB' ) JTYPE = 2 IF( COUT(1:3).EQ.'RAD' ) JTYPE = 3 IF( COUT(1:4).EQ.'TEMP' ) JTYPE = 4 IF( COUT(1:4).EQ.'BRIT' .OR. COUT(1:4).EQ.'MODB' ) JTYPE = 5 IF( JTYPE.EQ.0 ) THEN KBXINI = -1 RETURN ENDIF CALL M0SXTRCE('INDI CAL: COUT='//COUT(1:4)) KBXINI = 0 RETURN END INTEGER FUNCTION KBXCAL(PREFIX, DIRECTORY, NVAL, BAND, IBUF) IMPLICIT NONE INCLUDE 'areaparm.inc' INTEGER MAXVAL PARAMETER (MAXVAL = 1023) INTEGER MAXBAND PARAMETER (MAXBAND = 6) C --- PARAMETERS INTEGER PREFIX(*) ! line prefix INTEGER DIRECTORY(*) ! directory block INTEGER NVAL ! number of DATA values to calibrate INTEGER BAND ! BAND number INTEGER*2 IBUF(*) ! DATA to be calibrated C --- CONSTANTS INTEGER ITYPE INTEGER JTYPE INTEGER JOPT(NUMAREAOPTIONS) COMMON /INDICALXX/ ITYPE, JTYPE, JOPT C------ CALIBRATION TABLES FOR SERVER DATA REQUESTS INTEGER IARR(2048) INTEGER BACKDOOR COMMON /CALBXX/ IARR, BACKDOOR C --- EXTERNAL FUNCTIONS CHARACTER*12 CFJ CHARACTER*12 CFI INTEGER M0BANDMAP C --- INTERNAL VARIABLES CHARACTER*12 CVAL CHARACTER*12 CVAL1 CHARACTER*12 CVAL2 CHARACTER*12 CVAL3 CHARACTER*12 CVALUE CHARACTER*12 CVALUE1 CHARACTER*12 CINDXVAL INTEGER I, J, II ! loop counter INTEGER LAST_SATELLITE ! tracks satellite number of cal table INTEGER LAST_BAND ! tracks band number of cal table INTEGER LAST_ITYPE ! tracks input type of table INTEGER LAST_JTYPE ! tracks output type of table INTEGER LAST_AREA ! tracks area number INTEGER AREA ! AREA number INTEGER ICAL(0:MAXVAL) ! CALIBRATION BLOCK INTEGER SATELLITE ! Satellite number INTEGER STATUS ! function status INTEGER PTR ! calibration block offset pointer INTEGER IBAND INTEGER NBANDS INTEGER BANDS(MAXBAND) INTEGER FILL INTEGER IVALUE INTEGER BAND1_ALB_ARRAY(0:MAXVAL) INTEGER BAND1_BRIT_ARRAY(0:MAXVAL) INTEGER BAND2_ALB_ARRAY(0:MAXVAL) INTEGER BAND2_BRIT_ARRAY(0:MAXVAL) INTEGER BAND3_RAD_ARRAY(0:MAXVAL) INTEGER BAND3_TEMP_ARRAY(0:MAXVAL) INTEGER BAND3_BRIT_ARRAY(0:MAXVAL) INTEGER BAND4_RAD_ARRAY(0:MAXVAL) INTEGER BAND4_TEMP_ARRAY(0:MAXVAL) INTEGER BAND4_BRIT_ARRAY(0:MAXVAL) INTEGER BAND5_RAD_ARRAY(0:MAXVAL) INTEGER BAND5_TEMP_ARRAY(0:MAXVAL) INTEGER BAND5_BRIT_ARRAY(0:MAXVAL) INTEGER BAND6_RAD_ARRAY(0:MAXVAL) INTEGER BAND6_TEMP_ARRAY(0:MAXVAL) INTEGER BAND6_BRIT_ARRAY(0:MAXVAL) INTEGER OUTVAL REAL RVALUE C --- initialize tracking variables DATA LAST_AREA/-1/ C --- GET THE LOOKUP TABLES AREA = DIRECTORY(33) call mctrace(1,'KBXINDI','in cal module') IF(AREA.NE.LAST_AREA) THEN C ------ MAKE A LIST OF THE BANDS IN THIS AREA STATUS=M0BANDMAP(DIRECTORY,MAXBAND,NBANDS,BANDS) IF(STATUS.LT.0) THEN KBXCAL = -1 RETURN ENDIF C ------ SERVER REQUEST (Only single band request is possible) IF(BACKDOOR.EQ.666) THEN PTR = 1 IF(BAND.EQ.1) THEN DO J = 0, MAXVAL BAND1_ALB_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO CALL ALBTOBRIT(BAND1_ALB_ARRAY, & BAND1_BRIT_ARRAY) ELSEIF(BAND.EQ.2) THEN DO J = 0, MAXVAL BAND2_ALB_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO CALL ALBTOBRIT(BAND2_ALB_ARRAY, & BAND2_BRIT_ARRAY) ELSEIF(BAND.EQ.3) THEN DO J = 0, MAXVAL BAND3_RAD_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO DO J = 0, MAXVAL BAND3_TEMP_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO CALL TEMPTOBRIT(BAND3_TEMP_ARRAY, & BAND3_BRIT_ARRAY) ELSEIF(BAND.EQ.4) THEN DO J = 0, MAXVAL BAND4_RAD_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO DO J = 0, MAXVAL BAND4_TEMP_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO CALL TEMPTOBRIT(BAND4_TEMP_ARRAY, & BAND4_BRIT_ARRAY) ELSEIF(BAND.EQ.5) THEN DO J = 0, MAXVAL BAND5_RAD_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO DO J = 0, MAXVAL BAND5_TEMP_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO CALL TEMPTOBRIT(BAND5_TEMP_ARRAY, & BAND5_BRIT_ARRAY) do 1111 j = 1,maxval cval1 = cfi(band5_rad_array(j)) cval2 = cfi(band5_temp_array(j)) cval3 = cfi(band5_brit_array) call mctrace(1,'KBXINDI',cfi(j) // & ' '//cval1// & ' '//cval2// & ' '//cval3) 1111 continue ELSEIF(BAND.EQ.6) THEN DO J = 0, MAXVAL BAND6_RAD_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO DO J = 0, MAXVAL BAND6_TEMP_ARRAY(J) = IARR(PTR) PTR=PTR+1 ENDDO CALL TEMPTOBRIT(BAND6_TEMP_ARRAY, & BAND6_BRIT_ARRAY) ENDIF ELSE C ------ INIT THE BAND LOOKUP TABLES PTR = 0 DO I = 1, NBANDS IBAND = BANDS(I) IF( IBAND.EQ.1 ) THEN CALL M0SXTRCE(' ARAGET BAND = 1') CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND1_ALB_ARRAY(J) = ICAL(J) ENDDO CALL ALBTOBRIT(BAND1_ALB_ARRAY, & BAND1_BRIT_ARRAY ) ELSEIF( IBAND.EQ.2 ) THEN CALL M0SXTRCE(' ARAGET BAND = 2') CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND2_ALB_ARRAY(J) = ICAL(J) ENDDO CALL ALBTOBRIT(BAND2_ALB_ARRAY, & BAND2_BRIT_ARRAY ) ELSEIF( IBAND.EQ.3 ) THEN CALL M0SXTRCE(' ARAGET BAND = 3') CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND3_RAD_ARRAY(J) = ICAL(J) ENDDO CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND3_TEMP_ARRAY(J) = ICAL(J) ENDDO CALL TEMPTOBRIT( BAND3_TEMP_ARRAY, & BAND3_BRIT_ARRAY ) ELSEIF( IBAND.EQ.4 ) THEN CALL M0SXTRCE(' ARAGET BAND = 4') CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND4_RAD_ARRAY(J) = ICAL(J) ENDDO CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND4_TEMP_ARRAY(J) = ICAL(J) ENDDO CALL TEMPTOBRIT( BAND4_TEMP_ARRAY, & BAND4_BRIT_ARRAY ) ELSEIF( IBAND.EQ.5 ) THEN CALL M0SXTRCE(' ARAGET BAND = 5') CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND5_RAD_ARRAY(J) = ICAL(J) ENDDO CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND5_TEMP_ARRAY(J) = ICAL(J) ENDDO CALL TEMPTOBRIT(BAND5_TEMP_ARRAY, & BAND5_BRIT_ARRAY ) ELSEIF( IBAND.EQ.6 ) THEN CALL M0SXTRCE(' ARAGET BAND = 6') CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND6_RAD_ARRAY(J) = ICAL(J) ENDDO CALL ARAGET( & AREA, & DIRECTORY(63)+PTR, & (MAXVAL+1)*4, & ICAL & ) PTR = PTR+((MAXVAL+1)*4) DO J = 0, MAXVAL BAND6_TEMP_ARRAY(J) = ICAL(J) ENDDO CALL TEMPTOBRIT(BAND6_TEMP_ARRAY, & BAND6_BRIT_ARRAY ) ENDIF ENDDO ENDIF LAST_AREA = AREA ENDIF C --- BRANCH USING SOURCE CAL TYPE GOTO (100, 200, 300, 400, 500 ) ITYPE C --- INPUT IS RAW (FILE) DATA VALUES 100 GOTO( 101, 102, 103, 104, 105 ) JTYPE C --- RAW -> RAW 101 CONTINUE KBXCAL = 0 RETURN C --- RAW -> ALB 102 CONTINUE IF( BAND.EQ.1 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND1_ALB_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.2 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND2_ALB_ARRAY) KBXCAL = 0 ELSE KBXCAL = -102 ENDIF RETURN C --- RAW -> RAD 103 CONTINUE IF( BAND.EQ.3 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND3_RAD_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.4 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND4_RAD_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.5 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND5_RAD_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.6 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND6_RAD_ARRAY) KBXCAL = 0 ELSE KBXCAL = -103 ENDIF RETURN C --- RAW -> TEMP 104 CONTINUE IF( BAND.EQ.3 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND3_TEMP_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.4 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND4_TEMP_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.5 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND5_TEMP_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.6 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND6_TEMP_ARRAY) KBXCAL = 0 ELSE KBXCAL = -104 ENDIF RETURN C --- RAW -> BRIT 105 CONTINUE IF( BAND.EQ.1 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND1_BRIT_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.2 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND2_BRIT_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.3 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND3_BRIT_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.4 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND4_BRIT_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.5 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND5_BRIT_ARRAY) KBXCAL = 0 ELSEIF( BAND.EQ.6 ) THEN CALL MPIXTB(NVAL,JOPT(1),JOPT(2),IBUF, BAND6_BRIT_ARRAY) KBXCAL = 0 ELSE KBXCAL = -105 ENDIF RETURN C --- INPUT IS ALBEDO 200 GOTO( 201, 202, 203, 204, 205 ) JTYPE C --- ALB -> RAW 201 CONTINUE KBXCAL = -201 RETURN C --- ALB -> ALB 202 CONTINUE KBXCAL = 0 RETURN C --- ALB -> RAD 203 CONTINUE KBXCAL = -203 RETURN C --- ALB -> TEMP 204 CONTINUE KBXCAL = -204 RETURN C --- ALB -> BRIT 205 CONTINUE KBXCAL = -205 RETURN C --- INPUT IS RADIANCE 300 GOTO( 301, 302, 303, 304, 305 ) JTYPE C --- RAD -> RAW 301 CONTINUE KBXCAL = -301 RETURN C --- RAD -> ALB 302 CONTINUE KBXCAL = -302 RETURN C --- RAD -> RAD 303 CONTINUE KBXCAL = 0 RETURN C --- RAD -> TEMP 304 CONTINUE KBXCAL = -304 RETURN C --- RAD -> BRIT 305 CONTINUE KBXCAL = -305 RETURN C --- INPUT IS TEMPERATURE 400 GOTO( 401, 402, 403, 404, 405 ) JTYPE C --- TEMP -> RAW 401 CONTINUE KBXCAL = -401 RETURN C --- TEMP -> ALB 402 CONTINUE KBXCAL = -402 RETURN C --- TEMP -> RAD 403 CONTINUE KBXCAL = -403 RETURN C --- TEMP -> TEMP 404 CONTINUE KBXCAL = 0 RETURN C --- TEMP -> BRIT 405 CONTINUE KBXCAL = -405 RETURN C --- INPUT IS VISIBLE BRIGHTNESS 500 GOTO( 501, 502, 503, 504, 505 ) JTYPE C --- BRIT -> RAW 501 CONTINUE KBXCAL = -501 RETURN C --- BRIT -> ALB 502 CONTINUE KBXCAL = -502 RETURN C --- BRIT -> RAD 503 CONTINUE KBXCAL = -503 RETURN C --- BRIT -> TEMP 504 CONTINUE KBXCAL = -504 RETURN C --- BRIT -> BRIT 505 CONTINUE KBXCAL = 0 RETURN END INTEGER FUNCTION KBXOPT( CFUNC, IIN, IOUT) IMPLICIT NONE INCLUDE 'areaparm.inc' C --- parameters CHARACTER*4 CFUNC ! option INTEGER IIN(*) ! input array INTEGER IOUT(*) ! output array C --- symbolic constants & shared DATA INTEGER ITYPE INTEGER JTYPE INTEGER JOPT(NUMAREAOPTIONS) INTEGER I COMMON /INDICALXX/ ITYPE, JTYPE, JOPT INTEGER IARR(2048) INTEGER BACKDOOR COMMON/CALBXX/ IARR, BACKDOOR CHARACTER*4 CALTYP COMMON /BRKPNT/ CALTYP C --- external functions INTEGER BRKSET INTEGER ISCHAR INTEGER LIT C --- internal variables CHARACTER*12 BRKP_FILE C --- KEYS option IF( CFUNC(1:4).EQ.'KEYS' ) THEN C ------ VISIBLE and SWIR DATA, Bands 1 and 2 IF (IIN(4) .LT. 3) THEN IOUT(1) = 3 IOUT(2) = LIT( 'RAW ' ) IOUT(3) = LIT( 'ALB' ) IOUT(4) = LIT( 'BRIT' ) C ------ IR AND WV DATA ELSE IOUT(1) = 4 IOUT(2) = LIT( 'RAW ' ) IOUT(3) = LIT( 'RAD' ) IOUT(4) = LIT( 'TEMP' ) IOUT(5) = LIT( 'BRIT' ) ENDIF C ------ check for stretch table in frame directory IF( ISCHAR(IIN(38)).EQ.1 ) THEN CALL MOVWC( IIN(38), BRKP_FILE) IF( BRKSET( BRKP_FILE, CALTYP ).NE.0 ) THEN KBXOPT = -4 RETURN ENDIF ENDIF C --- BRKP option ELSEIF( CFUNC(1:4).EQ.'BRKP' ) THEN CALL MOVWC( IIN(1), BRKP_FILE ) IF( BRKSET( BRKP_FILE, CALTYP ).NE.0 ) THEN KBXOPT = -4 RETURN ENDIF C --- INFO option ELSEIF( CFUNC(1:4).EQ.'INFO' ) THEN C ------ VISIBLE and SWIR DATA, Bands 1 and 2 IF (IIN(4) .LT. 3) THEN IOUT(1) = 3 IOUT(2) = LIT( 'RAW ' ) IOUT(3) = LIT( 'ALB' ) IOUT(4) = LIT( 'BRIT' ) IOUT(5) = LIT( ' ' ) IOUT(6) = LIT( '% ' ) IOUT(7) = LIT( ' ' ) IOUT(8) = 1 IOUT(9) = 10 IOUT(10) = 1 C ------ IR AND WV DATA 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) = 1000 IOUT(12) = 100 IOUT(13) = 1 ENDIF C --- SERVER REQUEST ELSE IF ( CFUNC(1:4).EQ.'CALB') THEN C----- VIS and SWIR BANDS IF (IIN(1) .LT. 3) THEN DO I= 1, 1024 IARR(I) = IIN(I+1) ENDDO C----- IR BANDS ELSE IF (IIN(1).EQ.3) THEN DO I= 1, 2048 IARR(I) = IIN(I+1) ENDDO ELSE IF (IIN(1).EQ.4) THEN DO I= 1, 2048 IARR(I) = IIN(I+1) ENDDO ELSE IF (IIN(1).EQ.5) THEN DO I= 1, 2048 IARR(I) = IIN(I+1) ENDDO C----- WV BAND ELSE IF (IIN(1).EQ.6) THEN DO I= 1, 2048 IARR(I) = IIN(I+1) ENDDO ENDIF BACKDOOR = 666 C --- invalid option ELSE KBXOPT = -4 RETURN ENDIF KBXOPT = 0 RETURN END SUBROUTINE ALBTOBRIT( ALB, BRIT ) IMPLICIT NONE C --- PARAMETERS INTEGER ALB(0:1023) INTEGER BRIT(0:1023) C --- INTERNAL VARIABLES INTEGER I REAL RALB DO I = 0, 1023 RALB = REAL(ALB(I)) * .1 IF( RALB.LE.0 ) THEN BRIT(I) = 0 ELSE BRIT(I) = NINT( SQRT(RALB)*25.5 ) IF( BRIT(I).GT.255 ) BRIT(I) = 255 IF( BRIT(I).LT. 0 ) BRIT(I) = 0 ENDIF ENDDO RETURN END SUBROUTINE TEMPTOBRIT( TEMP, BRIT ) IMPLICIT NONE C --- PARAMETERS INTEGER TEMP(0:1023) INTEGER BRIT(0:1023) C --- INTERNAL VARIABLES INTEGER I REAL XTEMP CHARACTER*12 CFI DO I = 0, 1023 XTEMP = REAL(TEMP(I))*.01 IF( XTEMP.LT.242 ) THEN BRIT(I) = NINT(418. - XTEMP) ELSE BRIT(I) = NINT(660. - (2.*XTEMP)) ENDIF IF( BRIT(I).GT.255 ) BRIT(I) = 255 IF( BRIT(I).LT. 0 ) BRIT(I) = 0 ENDDO RETURN END