c This version of the ISCCP B3 read software is for use c with the Portland Group Compiler on a Linux machine c only. This code will swap the bytes as needed. c Rev. April 2002 c C VERSION 09/19/00 C IASCFLAG ADDED TO IMAGID FOR ALL DATA CREATED IN A UNIX SYSTEM. C THIS FLAG WILL DETERMINE WHETHER OR NOT THE ETOA SUBROUTINE SHOULD C BE USED C* SAMPLE MAIN PROGRAM FOR B3READ SUBROUTINE C* DATERR CODES ARE DESCRIBED IN COMMENTS OF B3READ SUBROUTINE C* USER SHOULD CHECK DATERR BEFORE USING DATA-cbp 1/19/00 C----------------------------------------------------------------------- C B3COM - CONTAINS B3 DATA ARRAYS C----------------------------------------------------------------------- PARAMETER (MAXPIX=500) COMMON /B3COM/ NOFPL,MTIME,DATERR,SCQUAL,CHNFLG(5),IMGLIN, 1 LOCGRD(18,36),CALVAL(256,5),DATNAV(5,MAXPIX), 2 PLANFL(MAXPIX),LNDWTR(MAXPIX),DATBUF(5,MAXPIX) INTEGER DATERR,SCQUAL,CHNFLG INTEGER*2 PLANFL,LNDWTR,DATBUF INTEGER*4 LOCGRD C----------------------------------------------------------------------- INTEGER NANGS/5/,TOTCHS/5/ C----------------------------------------------------------------------- COMMON /B3INIT/ LUN,INIT,ALATLO,ALATHI,NSCANS,NTOTPX,NCHANS, 1 IMAGNO,IBGTIM,IENTIM,IBGDAT,IENDAT,NIMGRC,IVSCAL,IIRCAL, 2 IPBDSC,JULIAN,IYEAR,MONTH,IDAY,IHOUR,MINS,IDORN,ICLFLG(5), 3 NAVFLG(5),CHNLID(5),ICHAAV(5),NSATID,NSPCID,SATID(2), 4 SPCID(2),CHNID(5),CAL3,CAL4,CAL5 INTEGER CHNLID CHARACTER*4 SATID,SPCID,CHNID INTEGER*4 CAL3,CAL4,CAL5 C----------------------------------------------------------------------- C first call to b3read is to initialize C----------------------------------------------------------------------- c unit 9 is the land/water data set (file 4 on b3 tape) open(unit=9,access='direct',recl=8000,form='unformatted') c unit 14 is the b3 image file open(unit=14,access='direct',recl=8000,form='unformatted') C DEC C OPEN(UNIT=LUNIN,ACCESS='DIRECT',RECL=LRECL/4,FORM='UNFORMATTED', C $ CONVERT=LITTLE_ENDIAN') C also must change each occurance of chars(4) to chars(1) INIT = 0 CALL B3READ C PRINT 501,DATERR 501 FORMAT('1','INITIAL READ SECTION COMPLETED DATERR FLAG = ',I5) C -- DETERMINE ENDING CHANNEL NUMBER IF(DATERR.NE.0) GO TO 1000 INIT = 1 C----------------------------------------------------------------------- C loop over scan lines C----------------------------------------------------------------------- DO 200 J =1,NSCANS CALL B3READ C SAMPLE MAIN PROGRAM UPDATED TO MORE EXPLICITLY HANDLE DATERR VALUE C CBP 1/19/00 IF(DATERR.NE.0) THEN IF(DATERR.LT.0) GO TO 1100 IF(SCQUAL.GT.0) PRINT 601,SCQUAL,IMGLIN 601 FORMAT(1X,'SCAN LINE QUALITY FLAG',I8,' FOR SCAN NUMBER ',I5) DO 620 I = 1,5 IF(CHNFLG(I).NE.0) PRINT 602,I,CHNFLG(I),IMGLIN 602 FORMAT(1X,'CHANNEL ',I3,' HAS CHANNEL QUALITY FLAG OF ',I4, 1 ' FOR SCAN NUMBER ',I5) 620 CONTINUE PRINT 700,J,SCQUAL,(CHNFLG(I),I=1,5),NTOTPX,NOFPL 700 FORMAT(1X,'DIAGNOSTICS FOR SCAN LINE NUMBER ',I5/ 1 ' SCAN LINE QUALITY FLAG = ',I5/ 2 ' CHANNEL QUALITY FLAGS = ',4(I4,', '),I4/ 3 ' TOTAL NUMBER OF PIXELS IN SCAN LINE : ',I5/ 4 ' TOTAL NUMBER OF OFF PLANET PIXELS IN SCAN LINE : ',I5) C ENDIF !on bad scan line c at this point you have one scan line in common block b3com 200 CONTINUE PRINT*,'SCANS: ',j-1,'OUT OF ',nscans GO TO 1100 1000 PRINT 1010 1010 FORMAT(1X,'ERROR IN INITIALIZATION ROUTINE') GO TO 300 1100 PRINT 1110 1110 FORMAT(1X,'END OF DATA') 300 CONTINUE STOP END C*********************************************************************** C*********************************************************************** C*********************************************************************** C B3READ FORTRN09 VERSION 000919 C----------------------------------------------------------------------- C C SUBROUTINE B3READ C C C----------------------------------------------------------------------- C C B3READ --- 9/27/83 A. WOLF C 2/08/84 L. GARDER C 3/19/84 A. WOLF C 1/15/85 L. GARDER C 7/24/97 C. PEARL C 7/30/98 C. PEARL C 12/10/98 C. PEARL C 01/19/00 C. PEARL C 09/19/00 C. PEARL C 06/25/01 P. CARTER CC C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C THIS SUBROUTINE CONTAINS TWO SECTIONS : C C INIT SECTION --- READS THE IMAGE IDENTIFICATION RECORD, THE LOCATION C GRID RECORD AND CALIBRATION RECORDS FOR THE IMAGE C AND PASSES THIS INFORMATION TO THE USER THROUGH C COMMON BLOCKS C C READ SECTION --- TAKES ONE SCAN LINE'S WORTH OF INFORMATION FROM C A DATA RECORD, UNPACKS IT INTO VARIOUS ARRAYS AND C PASSES THE INFORMATION THROUGH COMMON BLOCK B3COM C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C THERE ARE TWO COMMON BLOCKS WHICH MUST BE INCLUDED IN THE MAIN C PROGRAM: C B3COM AND B3INIT C THESE COMMON BLOCKS ARE OUTLINED BELOW. C----------------------------------------------------------------------- C C THE SUBROUTINE REQUIRES THAT SOME ARRAYS BE INITIALIZED C BY THE USER : C C ICLFLG(5) - DETERMINES WHICH CALIBRATION TABLE IS READ PER CHANNEL C 0 - CHANNEL NOT AVAILABLE C 1 - NOMINAL RADIANCE VALUES (WATTS/M2 - STERADIAN) C 2 - NORMALIZED RADIANCE VALUES C 3 - ABSOLUTE RADIANCE VALUES C 4 - NOMINAL ALBEDO OR TEMPERATURE (VISIBLE OR THERMAL) C 5 - NORMALIZED ALBEDO OR TEMPERATURE C 6 - ABSOLUTE ALBEDO OR TEMPERATURE C NAVFLG(5) - NAVIGATION ANGLE FLAG ARRAY DETERMINES WHICH ANGLES C TO DECODE C 0 - ANGLE NOT DECODED C 1 - ANGLE DECODED C C NOTE C A PATTERN OF (1 1 0 0 0) WOULD CORRESPOND TO A REQUEST TO DECODE C THE FIRST TWO ANGLES AND NONE OF THE OTHERS. THESE ARRAYS AND C A FEW OTHER VARIABLES ARE INITIALIZED IN THE BLOCK DATA SECTION C INCLUDED WITH THE SUBROUTINE. C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C COMMON BLOCK B3INIT C C C I*4 LUN --------- LOGICAL UNIT NUMBER C I*4 INIT -------- INITIALIZATION FLAG C 0 - FIRST READ OF DATA SET C 1 - SCAN LINE READ C R*4 ALATLO ------ LOW VALUE FOR LATITUDE WINDOW SELECTION C R*4 ALATHI ------ HIGH VALUE FOR LATITUDE WINDOW SELECTION C I*4 NSCANS ------ NUMBER OF SCAN LINES IN THE IMAGE C I*4 NTOTPX ------ NUMBER OF PIXELS IN EACH SCAN LINE C I*4 NCHANS ------ NUMBER OF ACTIVE CHANNELS C I*4 IMAGNO ------ IMAGE SEQUENCE NUMBER C I*4 IBGTIM ------ BEGINNING SCAN LINE GMT (HHMMSS) C I*4 IENTIM ------ ENDING SCAN LINE GMT (HHMMSS) C I*4 IBGDAT ------ BEGINNING SCAN LINE DATE (YYDDD) C I*4 IENDAT ------ ENDING SCAN LINE DATE (YYDDD) C I*4 NIMGRC ------ NUMBER OF DATA RECORDS IN THE IMAGE C I*4 IVSCAL ------ CALIBRATION FLAG FOR THE VISIBLE CHANNEL C I*4 IIRCAL ------ CALIBRATION FLAG FOR THE IR CHANNEL C I*4 CAL3 ------ CALIBRATION FLAG FOR 3RD CHANNEL (IF AVAILABLE) C I*4 CAL4 ------ CALIBRATION FLAG FOR 4TH CHANNEL (IF AVAILABLE) C I*4 CAL5 ------ CALIBRATION FLAG FOR 5TH CHANNEL (IF AVAILABLE) C 0 - CALIBRATION NOT PRESENT C 1 - CALIBRATION PRESENT C I*4 IPBDSC ------ PERCENTAGE OF THE IMAGE CONTAINING BAD SCANS C I*4 JULIAN ------ JULIAN DAY (1-366) C I*4 IYEAR ------- YEAR C I*4 MONTH ------- MONTH (1-12) C I*4 IDAY -------- DAY (1-31) C I*4 IHOUR ------- GMT OF IMAGE C I*4 MINS -------- GMT OF IMAGE C I*4 IDORN ------- DAY/NIGHT FLAG C 0 - DAY TIME IMAGE C 1 - FULL NIGHT TIME IMAGE (NO VISIBLE DATA) C I*4 ICLFLG(5) --- CALIBRATION TABLE FLAGS C I*4 NAVFLG(5) --- NAVIGATION ANGLE FLAGS C I*4 CHNLID(5) --- CHANNEL ID (INTEGER VALUE) C I*4 ICHAAV(5) --- CHANNEL AVAILABILITY FLAGS C 1 - PRESENT C 0 - NOT PRESENT C I*4 NSATID ------ SATELLITE CODE NUMBER C I*4 NSPCID ------ SPC CODE NUMBER C C*4 SATID(2) ---- SATELLITE ID (EBCDIC) C C*4 SPCID(2) ---- SPC ID (EBCDIC) C C*4 CHNID(5) --- CHANNEL IDENTIFICATION (EBCDIC) C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- COMMON /B3INIT/ LUN,INIT,ALATLO,ALATHI,NSCANS,NTOTPX,NCHANS, 1 IMAGNO,IBGTIM,IENTIM,IBGDAT,IENDAT,NIMGRC,IVSCAL,IIRCAL, 2 IPBDSC,JULIAN,IYEAR,MONTH,IDAY,IHOUR,MINS,IDORN,ICLFLG(5), 3 NAVFLG(5),CHNLID(5),ICHAAV(5),NSATID,NSPCID,SATID(2), 4 SPCID(2),CHNID(5),CAL3,CAL4,CAL5 INTEGER CHNLID CHARACTER*4 SATID,SPCID,CHNID character*1 C INTEGER*4 CAL3,CAL4,CAL5 C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C C COMMON BLOCK B3COM C C C I*4 NOFPL ------ THE NUMBER OF OFF PLANET PIXELS IN THE SCAN LINE C I*4 MTIME ------ GMT OF THE SCAN LINE (HHMMSS) C I*4 DATERR ----- ERROR FLAG RETURNED FROM B3READ C -4 - B3 INIT ERROR CALIBRATION NOT AVAILABLE C -3 - B3 INIT ERROR C -2 - I/O ERROR C -1 - END OF DATA C 0 - NO ERROR C 1 - ERROR IN DATA NON ZERO SCAN LINE QUALITY C 2 - CHANNEL QUALITY FLAG NON ZERO C I*4 SCQUAL ----- SCAN LINE QUALITY INDICATOR C 0 - GOOD C 1 - BAD SCAN LINE C 2 - NAVIGATION ERROR C 3 - NAVIGATION FIT ERROR C 4 - BAD SCAN LINE HEADER INFORMATION C 5 - BAD RECORD HEADER INFORMATION C I*4 CHNFLG(5) -- CHANNEL QUALITY INDICATOR C -2 - DATA ALL 0 OR 255 C -1 - NOT PRESENT C 0 - GOOD C >0 - BAD BUT PRESENT C I*4 IMGLIN ----- SCAN LINE NUMBER C I*4 LOCGRD(18,36) - LOCATION GRID C R*4 CALVAL(256,5) - CALIBRATION TABLE C R*4 DATNAV(5,MAXPIX) - ARRAY CONTAINING NAVIGATED ANGLES C I*2 PLANFL(MAXPIX) - ARRAY CONTAINING PLANETARY FLAGS C -1 - OFF PLANET C 0 - ON PLANET / DAYTIME C 1 - ON PLANET / NIGHT TIME C I*2 LNDWTR(MAXPIX) - ARRAY CONTAINING LAND/WATER FLAGS FOR C EACH PIXEL IN SCAN LINE C 1 - WATER C 2 - LAND C 3 - COAST C I*2 DATBUF(5,MAXPIX) - ARRAY CONTAINING DATA VALUES FOR EACH C CHANNEL C CHANNEL 1 : VISIBLE C CHANNEL 2 : IR C CHANNEL 3-5 : IF APPLICABLE C C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- PARAMETER (MAXPIX=500) COMMON /B3COM/ NOFPL,MTIME,DATERR,SCQUAL,CHNFLG(5),IMGLIN, 1 LOCGRD(18,36),CALVAL(256,5),DATNAV(5,MAXPIX), 2 PLANFL(MAXPIX),LNDWTR(MAXPIX),DATBUF(5,MAXPIX) INTEGER DATERR,SCQUAL,CHNFLG INTEGER*2 PLANFL,LNDWTR,DATBUF INTEGER*4 LOCGRD C----------------------------------------------------------------------- C*********************************************************************** C*********************************************************************** C----------------------------------------------------------------------- C C LWX025 - THE RIGHT STUFF FOR ALL LAND/WATER LOVERS C C + INPUT > ALAT (-90./+90.) C ALON (0./360. EAST) C + OUTPUT > LNDFLG = 1 WATER C = 2 LAND C = 3 COAST C C----------------------------------------------------------------------- C C CAUTION: C C IF YOU ARE NOT INTERESTED IN LAND/WATER FEATURE, PLEASE C COMMENT OUT ENTIRE COMMON /B3LAND/ (7 CARDS) C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- COMMON /B3LAND/ PRIMAP,LEV100,LEV050,LEV025 INTEGER*2 PRIMAP(180,90) INTEGER*2 LEV100(9750) INTEGER*2 LEV050(21200) INTEGER*2 LEV025(42200) INTEGER*2 BUFFER(4000,23) EQUIVALENCE (PRIMAP(1,1),BUFFER(1,1)) C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C VARIABLE DICTIONARY B3READ SUBROUTINE C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C I*4 ALON --------- LONGITUDE OF PIXEL C I*4 BYPIX -------- NUMBER OF BYTES PER PIXEL FOR DATA RANGE C I*4 CALDEX(4) ---- INDEX TO BEGINNING WORD OF DIFFERENT CALIBRATION C TABLES IN A CALIBRATION RECORD C C*1 CBUF(8000) --- BYTE BUFFER FOR INPUT RECORD C C*1 CHARWD(2) ---- CHARACTER STORAGE ARRAY FOR BYTE MANIPULATION C C*4 CHBUF4(2000) - WORD BUFFER FOR INPUT RECORD C C*4 CHNRNG(10,5) - CHANNEL RANGES (BANDWIDTHS FOR EACH CHANNEL) C I*4 CINDEX ------- CALIBRATION RECORD INDEX C R*4 COEF1 -------- CALIBRATION NORMALIZATION COEFFICIENT C R*4 COEF2 -------- CALIBRATION NORMALIZATION COEFFICIENT C R*4 COEF3 -------- CALIBRATION NORMALIZATION COEFFICIENT C R*4 COEF4 -------- CALIBRATION NORMALIZATION COEFFICIENT C R*4 COEF5 -------- CALIBRATION NORMALIZATION COEFFICIENT C R*4 CSCALE ------- CALIBRATION COEFFICIENT SCALE FACTOR C I*4 CSIDEX ------- CALIBRATION RECORD INDEX C I*4 CSODEX(6) ---- CALIBRATION RECORD INDEX C I*4 DATCOD ------- CODE ASSIGNED TO DATA RANGE C -1 - OFF PLANET C 0 - ON PLANET / DAY C 1 - ON PLANET / NIGHT C R*4 DEL1 --------- NAVIGATION PARAMETER C R*4 DEL2 --------- NAVIGATION PARAMETER C I*4 FWORD -------- WORD OF STORAGE FOR BYTE MANIPULATION C R*4 F0 ----------- NAVIGATION PARAMETER C I*2 HBUF(4000) --- HALF-WORD BUFFER FOR INPUT RECORD C I*4 HINDEX ------- POINTER TO HBUF (HALF-WORD INPUT BUFFER) C I*2 HLFWRD ------- HALF-WORD STORAGE FOR BYTE MANIPULATION C I*2 HWORD(2) ----- HALF-WORD STORAGE FOR BYTE MANIPULATION C I*4 IASLON ------- LOCATION INFO (EQUATOR CROSSING OR SSP LONG.) C I*4 IASGMT ------- GMT OF EQUATOR CROSSING OR SSP C I*4 ICKCAL(5) ---- COUNTER FOR CHECKING CALIBRATION TABLE VALUES C I*4 IDSLON ------- LOCATION INFO (EQUATOR CROSSING OF SSP LON) C I*4 IDSGMT ------- GMT OF EQUATOR CROSSING OR SSP C I*4 ID1 ---------- SCALED INTEGER DEL1 NAVIGATION PARAMETER C I*4 ID2 ---------- SCALED INTEGER DEL2 NAVIGATION PARAMETER C I*4 IF0 ---------- SCALED INTEGER F0 NAVIGATION PARAMETER C I*4 IHBEG -------- INITIAL VALUE OF POINTER TO HALF-WORD INPUT C RECORD C I*4 ILATHI ------- SCALED MAXIMUM LATITUDE VALUE IN INPUT RECORD C I*4 ILATLO ------- SCALED MINIMUM LATITUDE VALUE IN INPUT RECORD C I*4 ILONHI ------- SCALED RIGHTMOST LONGITUDE VALUE IN INPUT RECORD C I*4 ILONLO ------- SCALED LEFTMOST LONGITUDE VALUE IN INPUT RECORD C I*4 INAVER ------- NAVIGATION FIT ERROR FOR EACH CHANNEL C I*4 INITLW ------- INITIALIZATION FLAG FOR LAND/WATER C I*4 INTFLG(0:1) -- INITIALIZATION FLAG FOR INIT SECTION C I*4 IPLPNT ------- PLANETARY FLAG ARRAY POINTER C I*4 IPTSCN ------- POINTER TO NEXT SCAN (HALF-WORD BUFFER) C I*4 IPXBEG ------- BEGINNING PIXEL NUMBER OF NAVIGATION RANGE C I*4 IPXEND ------- ENDING PIXEL NUMBER OF NAVIGATION RANGE C I*4 IRANGE ------- POINTER TO BEGINNING PIXEL OF DATA RANGE C I*4 IRECNO ------- INPUT RECORD NUMBER C I*4 IRECTY ------- INPUT RECORD TYPE C I*4 ISCALE(5) ---- SCALE FACTORS FOR CALIBRATION TABLES C I*4 ISCNAV(5) ---- SCALE FACTORS FOR NAVIGATION FIT ERRORS C I*4 ISOURC(20,5) - SOURCE FOR CALIBRATION INFORMATION C I*4 IUNITS(20,5) - PHYSICAL UNITS FOR CALIBRATION TABLES C I*4 LNDWON ------- C I*4 LPOINT ------- POINTER TO FIRST BYTE OF RAW DATA C I*4 MANGS -------- COUNT OF NAVIGATION ANGLES DECODED C I*4 MAXPIX ------- MAXIMUM SIZE OF SCAN LINE (500 PIXELS) C I*4 MCHAN -------- LARGEST POSSIBLE CHANNEL CODE NUMBER C I*4 NANGS -------- NUMBER OF POSSIBLE NAVIGATION ANGLES C I*4 NAVRNG(5) ---- NUMBER OF NAVIGATION RANGES C I*4 NBYHW -------- NUMBER OF BYTES PER HALF-WORD (2) C I*4 NDATRG ------- NUMBER OF DATA RANGES C I*4 NINRCS ------- INPUT RECORD COUNTER C I*4 NOISE(5) ----- NOISE ESTIMATE FOR EACH CHANNEL C -1 - NOT AVAILABLE C I*4 NOMGMT ------- NOMINAL GMT OF IMAGE (HHMMSS) C I*4 NOPIX -------- NUMBER OF PIXELS IN DATA RANGE C I*4 NTOHER ------- CHANNEL IDENTIFICATION C R*4 NRCOEF(5,5) -- CALIBRATION NORMALIZATION COEFFICIENTS C I*4 NTOCHN ------- NUMBER OF ACTIVE CHANNELS C I*4 PRJDAT ------- PROJECT DATE C R*4 RLATHI ------- MAXIMUM LATITUDE VALUE IN INPUT RECORD C R*4 RLATLO ------- MINIMUM LATITUDE VALUE IN INPUT RECORD C R*4 RLONHI ------- RIGHTMOST LONGITUDE VALUE IN INPUT RECORD C R*4 RLONLO ------- LEFTMOST LONGITUDE VALUE IN INPUT RECORD C R*4 RMUHI -------- MAXIMUM MU ANGLE VALUE IN INPUT RECORD C R*4 RMULO -------- MINIMUM MU ANGLE VALUE IN INPUT RECORD C R*4 RMU0HI ------- MAXIMUM MU0 ANGLE VALUE IN INPUT RECORD C R*4 RMU0LO ------- MINIMUM MU0 ANGLE VALUE IN INPUT RECORD C R*4 SCALE -------- SCALE FACTOR FOR NAVIGATION PARAMETERS C R*4 SCALNV ------- SCALE FACTOR FOR RECORD ID LATITUDE AND C LONGITUDE MAX/MIN INFORMATION C R*4 SCLNVM ------- SCALE FACTOR FOR RECORD ID MU AND MU0 C MAX/MIN INFORMATION C I*4 TOTCHS ------- TOTAL POSSIBLE CHANNELS C I*4 WBUF(2000) --- WORD BUFFER FOR INPUT RECORD C I*4 WINDEX ------- POINTER TO INPUT RECORD (WORD BUFFER) C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C B3 INPUT BUFFER C C----------------------------------------------------------------------- INTEGER WBUF(2000) INTEGER*2 HBUF(4000) CHARACTER*4 CHBUF4(2000) CHARACTER*1 CBUF(8000) C----------------------------------------------------------------------- PARAMETER (MAXBYT = 8000) BYTE BYTEBUFFR(MAXBYT) BYTE SHORTBYBUF(MAXBYT,23) C C MISCELLANEOUS STORAGE C C----------------------------------------------------------------------- INTEGER IVALUE(20,5) INTEGER ISCNAV(5),INAVER(5),NOISE(5) INTEGER*2 HLFWRD CHARACTER*4 CHNRNG(10,5) CHARACTER*1 CHARWD(2) CHARACTER*4 CVAL(4) CHARACTER*30 NUSORC CHARACTER*40 UNIVAL(5) CHARACTER*40 SOUVAL(5) C----------------------------------------------------------------------- C C ARRAYS AND VARIABLES FOR CALIBRATION C C----------------------------------------------------------------------- DIMENSION ISCALE(5),NAVRNG(5),INTFLG(0:1) REAL*4 NRCOEF(5,5) INTEGER CINDEX,CSIDEX,CALDEX(6),CSODEX(6) INTEGER ISOURC(20,5),IUNITS(20,5),ICKCAL(5) INTEGER PRJDAT INTEGER HINDEX,WINDEX,FWORD INTEGER TOTCHS,DATCOD,BYPIX, VALUE, IWHICH INTEGER*2 HWORD(2) C----------------------------------------------------------------------- C C SET EQUIVALENCES FOR FILLING IN RECORD ID C C----------------------------------------------------------------------- EQUIVALENCE (WBUF(1),HBUF(1)),(WBUF(1),CBUF(1)) EQUIVALENCE (WBUF(1),CHBUF4(1)) c EQUIVALENCE (HLFWRD,CHARWD(1)) EQUIVALENCE (HLFWRD,CHARWD(2)) c EQUIVALENCE (HWORD(1),FWORD) EQUIVALENCE (HWORD(2),FWORD) C----------------------------------------------------------------------- C C SET CONSTANTS C C----------------------------------------------------------------------- DATA CALDEX/44,346,648,950,1252,1554/ DATA CSODEX/4,306,608,910,1212,1514/ DATA NANGS/5/,SCALNV/.05/,SCLNVM/.01/ DATA IHBEG/19/,NBYHW/2/,TOTCHS/5/ DATA FWORD /0/ DATA HLFWRD /0/ DATA INTFLG /1,0/ DATA INITLW /0/ C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C INIT SECTION C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C BEGIN C C----------------------------------------------------------------------- DATERR = 0 DO 12 I = 1, 5 UNIVAL(I)(1:40) = "" SOUVAL(I)(1:40) = "" 12 CONTINUE IF((INIT.LT.0).OR.(INIT.GT.1)) GO TO 10000 IF(INTFLG(INIT).EQ.0) GO TO 10000 IF(INIT.EQ.1) GO TO 1000 INTFLG(1) = 1 SCALE = 2. ** 22 NINRCS = 0 IREC = 0 C----------------------------------------------------------------------- C FIRST READ IMAGE ID C----------------------------------------------------------------------- IREC = IREC + 1 C READ(LUN,REC=IREC,IOSTAT=IRC) WBUF READ(LUN,rec=IREC,IOSTAT=IRC) BYTEBUFFR if ( IRC .lt. 0 ) goto 4100 if ( IRC .gt. 0 ) goto 5000 C----------------------------------------------------------------------- C RECORD NUMBER, IMAGE NUMBER, RECORD TYPE C----------------------------------------------------------------------- IFLAG = 1 IWHICH = 0 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IRECNO = VALUE IFLAG = 3 IWHICH = 1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IMAGNO = VALUE IFLAG = 4 IWHICH = 1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IRECTY = VALUE IFLAG = 111 IWHICH = 0 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IASCFLAG=VALUE C----------------------------------------------------------------------- C SPC ID (EBCDIC) C----------------------------------------------------------------------- IFLAG = 3 IWHICH = 2 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) SPCID(1) = CVAL(1)(1:4) IFLAG = 4 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) SPCID(2) = CVAL(1)(1:4) IF(IASCFLAG .NE.1)call etoa(spcid,spcid,8) C----------------------------------------------------------------------- C SATELLITE ID (EBCDIC) C----------------------------------------------------------------------- IFLAG = 5 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) SATID(1) = CVAL(1)(1:4) IFLAG = 6 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) SATID(2) = CVAL(1)(1:4) IF(IASCFLAG .NE.1)call etoa(satid,satid,8) C----------------------------------------------------------------------- C YEAR, JULIAN DAY, AND NOMINAL GMT C----------------------------------------------------------------------- IFLAG = 7 IWHICH = 0 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IYEAR = VALUE IFLAG = 8 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) JULIAN = VALUE IFLAG = 9 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NOMGMT = VALUE C----------------------------------------------------------------------- C NUMBER OF ACTIVE CHANNELS, AND CHANNEL ID'S C----------------------------------------------------------------------- IFLAG = 10 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NCHANS = VALUE IF(NCHANS.LE.0) GO TO 10100 NTOCHN = NCHANS IWHICH = 2 IFLAG = 11 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNID(1) = CVAL(1)(1:4) IFLAG = 12 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNID(2) = CVAL(1)(1:4) IFLAG = 13 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNID(3) = CVAL(1)(1:4) IFLAG = 14 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNID(4) = CVAL(1)(1:4) IFLAG = 15 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNID(5) = CVAL(1)(1:4) IF(IASCFLAG .NE.1)call etoa(chnid,chnid,20) C----------------------------------------------------------------------- C NUMBER OF SCAN LINES IN IMAGE, NUMBER OF PIXELS / SCAN LINE C----------------------------------------------------------------------- IWHICH = 0 IFLAG = 16 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NSCANS = VALUE IFLAG = 17 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NTOTPX = VALUE C----------------------------------------------------------------------- C BEGINNING AND ENDING SCAN LINE GMT'S C----------------------------------------------------------------------- IFLAG = 18 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IBGTIM = VALUE IFLAG = 19 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IENTIM = VALUE C----------------------------------------------------------------------- C BEGINNING AND ENDING SCAN LINE DATES C----------------------------------------------------------------------- IFLAG = 20 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IBGDAT = VALUE IFLAG = 21 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IENDAT = VALUE C----------------------------------------------------------------------- C NUMBER DATA RECORDS IN IMAGE C----------------------------------------------------------------------- IFLAG = 22 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NIMGRC = VALUE IF(NSCANS.LE.0.OR.NIMGRC.LE.0) GO TO 10100 C----------------------------------------------------------------------- C NAVIGATION FIT ERRORS C----------------------------------------------------------------------- INDW = 22 DO 50 I = 1,NANGS IFLAG = INDW + 1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ISCNAV(I) = VALUE IFLAG = INDW + 2 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) INAVER(I) = VALUE INDW = INDW + 2 50 CONTINUE C----------------------------------------------------------------------- C NOISE FACTORS C----------------------------------------------------------------------- DO 100 I = 1,TOTCHS IFLAG = 32 + I CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NOISE(I) = VALUE 100 CONTINUE C----------------------------------------------------------------------- C CHANNEL SPECTRAL RANGES C----------------------------------------------------------------------- IWHICH = 2 IPT = 0 DO 150 ICH = 1,TOTCHS DO 150 J = 1,10 IPT = IPT + 1 IFLAG = 37 + IPT CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNRNG(J,ICH) = CVAL(1)(1:4) 150 CONTINUE IF(IASCFLAG .NE.1)call etoa(chnrng,chnrng,200) C GET CORRECT IMAGID ELEMENT BASED ON YEAR OF DATA IF (IYEAR .LT. 1996) THEN C----------------------------------------------------------------------- C CALIBRATION FLAGS C----------------------------------------------------------------------- IWHICH = 0 IFLAG = 88 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IVSCAL = VALUE CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IFLAG = 89 IIRCAL = VALUE C----------------------------------------------------------------------- C PERCENTAGE OF IMAGE CONTAINING BAD SCAN LINES C----------------------------------------------------------------------- IFLAG = 90 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IPBDSC = VALUE C----------------------------------------------------------------------- C LOCATION INFORMATION (EQUATOR CROSSINGS OR SUBSATELLITE LONGITUDE) C----------------------------------------------------------------------- IFLAG = 91 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IASLON = VALUE IFLAG = 92 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IASGMT = VALUE IFLAG = 93 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IDSLON = VALUE IFLAG = 94 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IDSGMT = VALUE C----------------------------------------------------------------------- C SPC CODE NUMBER C----------------------------------------------------------------------- IFLAG = 95 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NSPCID = VALUE C----------------------------------------------------------------------- C SATELLITE CODE NUMBER C----------------------------------------------------------------------- IFLAG = 96 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NSATID = VALUE C----------------------------------------------------------------------- C CHANNEL IDENTIFICATION (INTEGER) C----------------------------------------------------------------------- MCHAN = 0 DO 160 I = 1,TOTCHS IFLAG = 96+I CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNLID(I) = VALUE IF(CHNLID(I).GT.MCHAN) MCHAN = CHNLID(I) 160 CONTINUE C----------------------------------------------------------------------- C CHANNEL AVAILABILITY FLAGS C----------------------------------------------------------------------- DO 170 I = 1,TOTCHS IFLAG = 101+I CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ICHAAV(I) = VALUE 170 CONTINUE C----------------------------------------------------------------------- C DAY OR NIGHT FLAG C----------------------------------------------------------------------- IFLAG = 107 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IDORN = VALUE C POST 9601 DATA ELSE C----------------------------------------------------------------------- C CALIBRATION FLAGS C----------------------------------------------------------------------- IWHICH = 0 IFLAG = 88 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IVSCAL = VALUE IFLAG = 89 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IIRCAL = VALUE IFLAG = 90 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CAL3 = VALUE IFLAG = 91 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CAL4 = VALUE IFLAG = 92 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CAL5 = VALUE C----------------------------------------------------------------------- C PERCENTAGE OF IMAGE CONTAINING BAD SCAN LINES C----------------------------------------------------------------------- IFLAG = 93 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IPBDSC = WBUF(93) C----------------------------------------------------------------------- C LOCATION INFORMATION (EQUATOR CROSSINGS OR SUBSATELLITE LONGITUDE) C----------------------------------------------------------------------- IFLAG = 94 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IASLON = VALUE IFLAG = 95 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IASGMT = VALUE IFLAG = 96 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IDSLON = VALUE IFLAG = 97 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IDSGMT = VALUE C----------------------------------------------------------------------- C SPC CODE NUMBER C----------------------------------------------------------------------- IFLAG = 98 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NSPCID = VALUE C----------------------------------------------------------------------- C SATELLITE CODE NUMBER C----------------------------------------------------------------------- IFLAG = 99 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NSATID = VALUE C----------------------------------------------------------------------- C CHANNEL IDENTIFICATION (INTEGER) C----------------------------------------------------------------------- MCHAN = 0 DO 161 I = 1,TOTCHS IFLAG = 99 + I CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNLID(I) = VALUE IF(CHNLID(I).GT.MCHAN) MCHAN = CHNLID(I) 161 CONTINUE C----------------------------------------------------------------------- C CHANNEL AVAILABILITY FLAGS C----------------------------------------------------------------------- DO 171 I = 1,TOTCHS C IFLAG = 103 + I C CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) C ICHAAV(I) = VALUE IFLAG = 104 + I CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ICHAAV(I) = VALUE 171 CONTINUE C----------------------------------------------------------------------- C DAY OR NIGHT FLAG C----------------------------------------------------------------------- IFLAG = 110 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IDORN = VALUE C END OF DATE CHECK ENDIF C----------------------------------------------------------------------- C DETERMINE MONTH AND DAY FROM JULIAN DATE C----------------------------------------------------------------------- CALL JULCNV (JULIAN,IYEAR,MONTH,IDAY,PRJDAT) C----------------------------------------------------------------------- C FIND HOUR AND MINUTES FROM GMT IN MILITARY TIME C----------------------------------------------------------------------- IHOUR = NOMGMT/10000 MINS = (NOMGMT - IHOUR*10000)/100 C----------------------------------------------------------------------- C PRINT IMAGE IDENTIFICATION INFORMATION C----------------------------------------------------------------------- PRINT 175,IMAGNO,SPCID,NSPCID,SATID,NSATID,JULIAN,IYEAR, 1 MONTH,IDAY,NOMGMT,IHOUR,MINS 175 FORMAT('1',T10,'IMAGE DESCRIPTION'/ 1 T10,'================='// 2 T10,'IMAGE SEQUENCE NUMBER : ',I5/ 3 T10,'SPC ID ',2A4,' CODE ',I5,T40,'SATELLITE ID ',2A4,' CODE',I5/ 3 T10,'JULIAN DAY (DDD):',I4,3X,'YEAR (YYYY):',I5,' MONTH :',I3, 3 ' DAY :',I3/ 4 T10,'NOMINAL GMT (HHMMSS) :',I7,' HOUR :',I3,' MINS :',I4) PRINT 176,NIMGRC,NSCANS,IPBDSC,IBGTIM,IENTIM,IBGDAT,IENDAT, 1 NTOTPX 176 FORMAT(1X,T10,'NUMBER OF DATA RECORDS :',I6/ 1 1X,T10,'NUMBER OF SCAN LINES :',I6,/ 1 1X,T10,'PERCENTAGE BAD SCAN LINES :',I6/ 2 1X,T10,'GMT (HHMMSS) OF BEGINNING SCAN LINE : ',I8, 3 ' ENDING :',I8/ 4 1X,T10,'DATE (YYDDD) OF BEGINNING SCAN LINE :',I8, 5 ' ENDING :',I8/ 6 1X,T10,'NUMBER OF PIXELS / SCAN LINE :',I8) C----------------------------------------------------------------------- C PRINT CHANNEL ID'S C----------------------------------------------------------------------- PRINT 177,NCHANS 177 FORMAT(1X,T10,'NUMBER OF ACTIVE CHANNELS :',I8) DO 179 I = 1,NCHANS PRINT 178,I,CHNID(I),(CHNRNG(J,I),J=1,10),CHNLID(I) 178 FORMAT(1X,T10,'CHANNEL ',I2,5X,A4,5X,10A4,' CODE : ',I5) 179 CONTINUE PRINT 180,IVSCAL,IIRCAL,CAL3,CAL4,CAL5 180 FORMAT(1X,T10,'CALIBRATION FLAGS (VIS IR 3 4 5): ',I5,I5,I5,I5,I5) PRINT 181,IDORN 181 FORMAT(1X,T10,'DAY OR NIGHT FLAG ',I5) PRINT 182,IASLON,IASGMT,IDSLON,IDSGMT 182 FORMAT(1X,T10,'ASCENDING EQUATOR CROSSING LONGITUDE ',I8, 1 ' GMT ',I8/1X,T10, 2 'DESCENDING EQUATOR CROSSING LONGITUDE ',I8,' GMT ',I8) C----------------------------------------------------------------------- C RESET CALVAL C----------------------------------------------------------------------- DO 200 ICH = 1,MCHAN DO 200 I = 1,256 CALVAL(I,ICH) = 0.0 200 CONTINUE C----------------------------------------------------------------------- C INITIALIZE DATNAV AND DATBUF C----------------------------------------------------------------------- DO 350 IPIX = 1,MAXPIX DO 300 IANG = 1,NANGS DATNAV(IANG,IPIX) = -1000.0 300 CONTINUE DO 350 ICHAN = 1,TOTCHS DATBUF(ICHAN,IPIX) = 255 350 CONTINUE C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C READ LOCATION GRID RECORD C----------------------------------------------------------------------- IWHICH = 0 IREC = IREC + 1 C READ(LUN,rec=IREC,IOSTAT=IRC) WBUF READ(LUN,rec=IREC,IOSTAT=IRC) BYTEBUFFR IGRDPT = 2 DO 360 ILON = 1,36 DO 360 ILAT = 1,18 IGRDPT = IGRDPT + 1 IFLAG = IGRDPT CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) LOCGRD(ILAT,ILON) = VALUE 360 CONTINUE PRINT 361 361 FORMAT('1',T50,'LOCATION GRID'//) DO 370 ILON = 1,36 PRINT 369,(LOCGRD(ILAT,ILON),ILAT=1,18) 369 FORMAT(1X,18(I7)) 370 CONTINUE C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C READ CHANNEL CALIBRATION RECORDS C C CHECK CALIBRATION FLAG TO DETERMINE WHICH CALIBRATION TABLE IS C DESIRED FOR EACH CHANNEL, PICK UP SCALE FACTOR AND SCALED INTEGERS C FROM RECORD. DIVIDE SCALED INTEGERS BY SCALE FACTOR TO RETRIEVE C PHYSICAL VALUES CORRESPONDING TO EACH COUNT VALUE AND STORE IN THE C CALVAL ARRAY. C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C READ CALIBRATION RECORDS C----------------------------------------------------------------------- DO 550 ICAL = 1,NTOCHN ICHAN = CHNLID(ICAL) C----------------------------------------------------------------------- C INITIALIZE CALIBRATION CHECK ARRAY C----------------------------------------------------------------------- ICKCAL(ICHAN) = 0 IREC = IREC + 1 C READ (LUN,rec=IREC,IOSTAT=IRC) WBUF READ(LUN,rec=IREC,IOSTAT=IRC) BYTEBUFFR if ( IRC .lt. 0 ) goto 4100 if ( IRC .gt. 0 ) goto 5000 IWHICH = 0 IFLAG = 1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IRECNO = VALUE IWHICH = 1 IFLAG = 3 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IMAGNO = VALUE IFLAG = 4 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IRECTY = VALUE IWHICH = 0 IFLAG = 3 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IF(VALUE.EQ.0) THEN PRINT 399,ICHAN 399 FORMAT(//1X,'CALIBRATION TABLES FOR CHANNEL ',I6, 1 ' ARE NOT AVAILABLE'/) ICKCAL(ICHAN) = 256 GO TO 550 ENDIF IND = ICLFLG(ICHAN) IF(IND.LT.1.OR.IND.GT.6) IND = 1 C----------------------------------------------------------------------- C PICK UP TEXTUAL INFORMATION -- PHYSICAL UNITS OF TABLE AND SOURCE C----------------------------------------------------------------------- CSIDEX = CSODEX(IND) J=1 K=1 DO 400 I = 1,20 IWHICH = 2 IFLAG = CSIDEX-1+I CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IF(I .LT. 7) THEN UNIVAL(ICHAN)(K:K+4) = CVAL(1)(1:4) K = K + 4 ENDIF IFLAG = CSIDEX+19+I CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IF(I .LT. 7) THEN SOUVAL(ICHAN)(J:J+4) = CVAL(1)(1:4) J = J + 4 ENDIF IF(IASCFLAG .NE.1)call etoa(iunits(i,ichan),iunits(i,ichan),4) IF(IASCFLAG .NE.1)call etoa(isourc(i,ichan),isourc(i,ichan),4) 400 CONTINUE C----------------------------------------------------------------------- C PICK UP CALIBRATION TABLES C----------------------------------------------------------------------- IWHICH = 0 CINDEX = CALDEX(IND) IFLAG = CINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ISCALE(ICHAN) = VALUE IF(ISCALE(ICHAN).LE.0) THEN PRINT 401,IND,ICHAN 401 FORMAT(//1X,'CALIBRATION TABLE # ',I5,' FOR CHANNEL ', 1 I5,' IS NOT AVAILABLE'//) DATERR = -4 ENDIF C PRINT *,'CHAN',ICHAN,'ISCALE',ISCALE WRITE(*,123)ICHAN,ISCALE 123 FORMAT("CHAN ",I2,1x,"ISCALE ",5(I4)) CSCALE = ISCALE(ICHAN) IFLAG = CINDEX+1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) COEF1 = VALUE NRCOEF(1,ICHAN) = COEF1 / 10000. IFLAG = CINDEX+2 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) COEF2 = VALUE NRCOEF(2,ICHAN) = COEF2 / CSCALE IFLAG = CINDEX+3 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) COEF3 = VALUE NRCOEF(3,ICHAN) = COEF3 / CSCALE IFLAG = CINDEX+4 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) COEF4 = VALUE NRCOEF(4,ICHAN) = COEF4 / CSCALE IFLAG = CINDEX+5 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) COEF5 = VALUE NRCOEF(5,ICHAN) = COEF5 / CSCALE DO 500 I = 1,256 IFLAG = CINDEX+5+I CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IVAL = VALUE VAL = IVAL IF(IVAL.EQ.0) ICKCAL(ICHAN) = ICKCAL(ICHAN) + 1 CALVAL(I,ICHAN) = VAL / CSCALE 500 CONTINUE 550 CONTINUE C DO 600 ICAL = 1,NTOCHN ICHAN = CHNLID(ICAL) IF(ICKCAL(ICHAN).EQ.256) THEN PRINT 551,ICHAN 551 FORMAT(//1X,' * * * CALIBRATION TABLE FOR CHANNEL ',I5, 1 ' IS NOT AVAILABLE * * *'//) DATERR = -4 ENDIF 600 CONTINUE PRINT 601 601 FORMAT(//1X,T10,'CALIBRATION INFORMATION '/) DO 620 ICAL = 1,NTOCHN ICHAN = CHNLID(ICAL) PRINT 606,ICHAN,ICLFLG(ICHAN) 606 FORMAT(1X,T10,'CHANNEL ',I5,5X,'TABLE ',I5) PRINT 607,UNIVAL(ICHAN)(1:40) 607 FORMAT(1X,T10,' UNITS : ',(A)) PRINT 608,SOUVAL(ICHAN)(1:40) 608 FORMAT(/1X,T10,' SOURCE : ',(A)) PRINT 609,(NRCOEF(I,ICHAN),I=1,5) 609 FORMAT(/1X,T10,' COEFS : ',5(F8.4,2X)) 620 CONTINUE C----------------------------------------------------------------------- C PRINT CALIBRATION TABLES C----------------------------------------------------------------------- PRINT 651 651 FORMAT('1',T55,'CALIBRATION TABLE'/ 1 T55,'================='// 1 1X,' COUNT',T60,'CHANNEL'// 2 1X,'___________',T29,' 1 ',' 2 ', 3 ' 3 ',' 4 ', 3 ' 5 ',/T29,5(' ------- ')/) DO 655 ICT = 1,256 NCT = ICT - 1 PRINT 652,NCT,(CALVAL(ICT,ICH),ICH=1,MCHAN) 652 FORMAT(1X,I5,T29,5(F9.2,5X)) 655 CONTINUE C----------------------------------------------------------------------- C CHECK ANGLE FLAGS C----------------------------------------------------------------------- MANGS = 0 DO 700 I = 1,NANGS IF((NAVFLG(I).LT.0).OR.(NAVFLG(I).GT.1)) THEN DATERR = -3 PRINT 670,I,NAVFLG(I) 670 FORMAT(//,1X,'*** WARNING NAVFLG NOT PROPERLY SET',2I8,/) RETURN ENDIF MANGS = MANGS + NAVFLG(I) 700 CONTINUE IPTSCN = 0 C----------------------------------------------------------------------- C TEST LATITUDE WINDOW SELECTION C----------------------------------------------------------------------- IF((ALATLO.EQ.-90.).AND.(ALATHI.EQ.+90.)) GO TO 800 PRINT 701,ALATLO,ALATHI 701 FORMAT(/,20X,'LAT WINDOW SELECTION LOGIC FOR LAT RANGE',2F8.2,/) C----------------------------------------------------------------------- C READ SUCCESSIVE B3 RECORDS UNTIL EITHER ALATLO OR ALATHI IS REACHED C----------------------------------------------------------------------- 750 CONTINUE IREC = IREC + 1 C READ (LUN,rec=IREC,IOSTAT=IRC) WBUF READ(LUN,rec=IREC,IOSTAT=IRC) BYTEBUFFR if ( IRC .lt. 0 ) goto 4000 if ( IRC .gt. 0 ) goto 5000 IWHICH = 1 IFLAG = 7 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NINRCS = NINRCS + 1 ILATLO = VALUE IFLAG = 8 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ILATHI = VALUE IFLAG = 9 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ILONLO = VALUE IFLAG = 10 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ILONHI = VALUE RLATLO = ILATLO * SCALNV RLATHI = ILATHI * SCALNV RLONLO = ILONLO * SCALNV RLONHI = ILONHI * SCALNV IF(RLATHI.LT.ALATLO) GO TO 750 IF(RLATLO.GT.ALATHI) GO TO 750 PRINT 751,ALATLO,ALATHI,NINRCS,NIMGRC,RLATLO,RLATHI 751 FORMAT(/,2X,'FOR GIVEN LAT WINDOW RANGE',2F8.2,2X,'AFTER',I5, 1 2X,'OF A TOTAL ',I5,2X,'INPUT RECORDS WE HAVE REACHED',2F8.2, 2 2X,'LAT RANGE',/) IPTSCN = IHBEG C----------------------------------------------------------------------- C SET LAND/WATER TEST FLAG C----------------------------------------------------------------------- 800 CONTINUE IF((NAVFLG(1).EQ.1).AND.(NAVFLG(2).EQ.1)) THEN LNDWON = 1 IF(INITLW.EQ.1) RETURN C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C INIT LAND/WATER C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C * * * * NB - INPUT FILE IS LUN 9 * * * * C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C INITLW = 1 C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C CAUTION: IF YOU ARE NOT INTERESTED IN LAND/WATER FEATURE, C PLEASE COMMENT OUT UNTIL RETURN STATEMENT C LUNMAP = 9 IWHICH = 1 IFLAG = 1 C Fixed so the array PRIMAP can be filled for LAND/WATER retrieval. DO 850 IBUF = 1,23 READ (LUNMAP,REC=IBUF,IOSTAT=IRC) & (BYTEBUFFR(IWD),IWD=1,8000) DO 692 II = 1 ,4000 IFLAG = II CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) BUFFER(II,IBUF) = VALUE 692 CONTINUE if ( IRC .lt. 0 ) goto 20100 if ( IRC .gt. 0 ) goto 20200 850 CONTINUE PRINT 851 851 FORMAT(/'---< LNDWTR MAPS INITIALIZED >---'/) ELSE LNDWON = 0 PRINT 852 852 FORMAT(//,10X,'SINCE LAT/LON INFORMATION IS NOT TO BE DECODED', 1 ' NO LAND WATER FLAGS ARE AVAILABLE',/) ENDIF RETURN C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C READ SECTION C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C FETCH NEXT SCAN LINE C----------------------------------------------------------------------- 1000 IF(IPTSCN.EQ.0) GO TO 1100 HINDEX = IPTSCN GO TO 1200 C----------------------------------------------------------------------- C READ B3 FORMAT INPUT RECORD C----------------------------------------------------------------------- 1100 continue IREC = IREC + 1 C READ (LUN,REC=IREC,IOSTAT=IRC) WBUF READ(LUN,REC=IREC,IOSTAT=IRC) BYTEBUFFR if ( IRC .lt. 0 ) goto 4000 if ( IRC .gt. 0 ) goto 5000 NINRCS = NINRCS + 1 C----------------------------------------------------------------------- C INITIALIZE HALF-WORD POINTER C----------------------------------------------------------------------- HINDEX = IHBEG IWHICH = 1 IFLAG = 7 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ILATLO = VALUE IFLAG = 8 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ILATHI = VALUE IFLAG = 9 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ILONLO = VALUE IFLAG = 10 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ILONHI = VALUE c RLATLO = ILATLO * SCALNV RLATHI = ILATHI * SCALNV RLONLO = ILONLO * SCALNV RLONHI = ILONHI * SCALNV IFLAG = 11 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) RMULO = VALUE RMULO = RMULO * SCLNVM IFLAG = 12 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) RMUHI = VALUE RMUHI = RMUHI * SCLNVM IFLAG = 13 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) RMU0LO = VALUE RMU0LO = RMU0LO * SCLNVM IFLAG = 14 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) RMU0HI = VALUE RMU0HI = RMU0HI * SCLNVM C----------------------------------------------------------------------- C FETCH SCAN LINE DIRECTORY C----------------------------------------------------------------------- 1200 NOFPL=0 C----------------------------------------------------------------------- C POINTER TO NEXT SCAN LINE C----------------------------------------------------------------------- IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IPTSCN = VALUE C----------------------------------------------------------------------- C SCAN LINE NUMBER C----------------------------------------------------------------------- IFLAG = HINDEX + 1 if(IPTSCN .EQ. 2299) then endif CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IMGLIN = VALUE HINDEX = HINDEX + 2 HINDEX = HINDEX + 1 IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) C----------------------------------------------------------------------- C PICK UP LOGICAL POINTER TO FIRST DATA BYTE (SKIP UNUSED HALF-WORD) C----------------------------------------------------------------------- IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) LPOINT = VALUE IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) C----------------------------------------------------------------------- C NUMBER OF NAVIGATION RANGES FOR EACH ANGLE C----------------------------------------------------------------------- HINDEX = HINDEX + 1 DO 1300 NAV = 1,NANGS IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NAVRNG(NAV) = VALUE HINDEX = HINDEX + 1 1300 CONTINUE C----------------------------------------------------------------------- C NUMBER OF DATA RANGES C----------------------------------------------------------------------- IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NDATRG = VALUE C----------------------------------------------------------------------- C UNPACK SCAN LINE QUALITY FLAG AND CHANNEL QUALITY FLAGS C IF BAD SCAN LINE PRINT FLAG SET DATERR FLAG AND RETURN C----------------------------------------------------------------------- HINDEX = HINDEX+1 IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) SCQUAL = VALUE HINDEX = HINDEX + 1 IF(SCQUAL.GT.0) GO TO 6000 DO 1400 ICH = 1,TOTCHS IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNFLG(ICH) = VALUE HINDEX = HINDEX + 1 1400 CONTINUE DO 1500 ICH = 1,NTOCHN IF(CHNFLG(ICH).NE.0) THEN C PROGRAM MODIFIED TO NOT RETURN A BAD SCANLINE FLAG WHEN VIS NIGHT DATA C IS THERE. IFLAG = 1 IWHICH = 2 CALL BYTESWAP(CHNID,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) CHNID(ICH) = CVAL(1)(1:4) IF(CHNID(ICH).EQ.'VIS ' .AND. IDORN. EQ. 1)GO TO 1500 DATERR = 2 GO TO 1510 ENDIF 1500 CONTINUE C----------------------------------------------------------------------- C GMT OF SCAN LINE C----------------------------------------------------------------------- 1510 WINDEX = HINDEX / 2 + 1 IFLAG = WINDEX IWHICH = 1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) MTIME = VALUE HINDEX = HINDEX + 2 C----------------------------------------------------------------------- C FETCH SCAN LINE PARAMETERS AND RENAVIGATE ANGLES C----------------------------------------------------------------------- IF(MANGS.EQ.0) GO TO 2100 DO 2000 NAV = 1,NANGS IF(NAVFLG(NAV).EQ.0) GO TO 1900 NNAV = NAVRNG(NAV) IF(NNAV.EQ.0) GO TO 2000 DO 1700 INAVRN = 1,NNAV IWHICH = 1 IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IPXBEG = VALUE IFLAG = HINDEX + 1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IPXEND = VALUE HINDEX = HINDEX + 2 WINDEX = (HINDEX-1) / NBYHW + 1 IFLAG = WINDEX IWHICH = 0 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IF0 = VALUE IFLAG = WINDEX + 1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ID1 = VALUE IFLAG = WINDEX + 2 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) ID2 = VALUE HINDEX = NBYHW * (WINDEX+3) - 1 C PRINT *,'ANG RANGE SCALE IF0 ID1 ID2',NAV,INAVRN,SCALE,IF0,ID1,ID2 F0 = IF0 F0 = F0 / SCALE DATNAV(NAV,IPXBEG) = F0 DEL1 = ID1 / SCALE DEL2 = ID2 / SCALE IF(IPXBEG.EQ.IPXEND) GO TO 1700 IPXBEG = IPXBEG + 1 DO 1600 IPIX = IPXBEG,IPXEND IF0 = IF0 + ID1 ID1 = ID1 + ID2 F0 = IF0 F0 = F0 / SCALE DATNAV(NAV,IPIX) = F0 1600 CONTINUE 1700 CONTINUE IF(NAV.NE.2) GO TO 2000 C----------------------------------------------------------------------- C CORRECT LONGITUDE TO A 0-360 DEGREE RANGE C----------------------------------------------------------------------- DO 1800 IPIX = 1,NTOTPX ALON = DATNAV(2,IPIX) IF(ALON.LT.0..AND.ALON.GT.-500.0) ALON = ALON + 360. DATNAV(2,IPIX) = ALON 1800 CONTINUE GO TO 2000 1900 WINDEX = WINDEX + 4 * NAVRNG(NAV) HINDEX = HINDEX + 8 * NAVRNG(NAV) 2000 CONTINUE GO TO 2300 C----------------------------------------------------------------------- C IF NO ANGLES ARE DECODED ---- INCREMENT POINTERS C----------------------------------------------------------------------- 2100 DO 2200 NAV = 1,NANGS WINDEX = WINDEX + 4 * NAVRNG(NAV) HINDEX = HINDEX + 8 * NAVRNG(NAV) 2200 CONTINUE C----------------------------------------------------------------------- C INITIALIZE DATA POINTERS C----------------------------------------------------------------------- 2300 IPLPNT = 0 C----------------------------------------------------------------------- C FETCH DATA DIRECTORY C----------------------------------------------------------------------- DO 3000 IDAT = 1,NDATRG C----------------------------------------------------------------------- C NUMBER OF BYTES / PIXEL C----------------------------------------------------------------------- IWHICH = 1 IFLAG = HINDEX CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) BYPIX = VALUE IFLAG = HINDEX+1 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) IRANGE = VALUE C----------------------------------------------------------------------- C DATA CODE FOR RANGE (0,1,-1) C----------------------------------------------------------------------- IFLAG = HINDEX + 2 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) DATCOD = VALUE C----------------------------------------------------------------------- C NUMBER OF PIXELS IN RANGE C----------------------------------------------------------------------- IFLAG = HINDEX+3 CALL BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) NOPIX = VALUE HINDEX = HINDEX + 4 C----------------------------------------------------------------------- C PRE-LOAD PLANETARY FLAGS C----------------------------------------------------------------------- IF(DATCOD.GE.0) GO TO 2450 C----------------------------------------------------------------------- C OFF-PLANET PIXELS C----------------------------------------------------------------------- NOFPL = NOFPL + NOPIX DO 2400 IPIX = 1,NOPIX PLANFL(IPLPNT+IPIX) = DATCOD LNDWTR(IPLPNT+IPIX) = 0 C----------------------------------------------------------------------- C TO SET ALL OFF-PLANET PIXEL VALUES TO 255 LOOP LABELED 2350 TO FILL C INSTEAD OF UNPACK ORIGINAL VALUES C----------------------------------------------------------------------- C DO 2350 ICHAN = 1,NTOCHN C DATBUF(ICHAN,IPLPNT+IPIX) = 255 C2350 CONTINUE C----------------------------------------------------------------------- DO 2350 ICHAN = 1,NTOCHN IFLAG = IRANGE+ICHAN-1 WRITE(CHARWD(2),'(A)') BYTEBUFFR(IFLAG) 777 format("CHARWD(2) ",Z,1x,O) 7777 format("HLFWRD ",O) JCHAN = CHNLID(ICHAN) DATBUF(JCHAN,IPLPNT+IPIX) = HLFWRD 2350 CONTINUE C----------------------------------------------------------------------- IRANGE = IRANGE + NTOCHN DO 2370 NAV = 1,NANGS DATNAV(NAV,IPLPNT+IPIX) = -1000. 2370 CONTINUE 2400 CONTINUE GO TO 2950 C----------------------------------------------------------------------- C ON-PLANET PIXELS C----------------------------------------------------------------------- 2450 DO 2900 IPIX = 1,NOPIX PLANFL(IPLPNT+IPIX) = DATCOD LNDWTR(IPLPNT+IPIX) = 0 C----------------------------------------------------------------------- C DECODE DATA C----------------------------------------------------------------------- IF(BYPIX.LE.0) GO TO 2900 DO 2500 ICHAN = 1,NTOCHN IFLAG = IRANGE+ICHAN-1 WRITE(CHARWD(2),'(A)') BYTEBUFFR(IFLAG) JCHAN = CHNLID(ICHAN) DATBUF(JCHAN,IPLPNT+IPIX) = HLFWRD 2500 CONTINUE IRANGE = IRANGE + NTOCHN C----------------------------------------------------------------------- C TEST IF LAND/WATER COMPUTATION IS POSSIBLE C----------------------------------------------------------------------- IF(LNDWON.EQ.0) GO TO 2900 C----------------------------------------------------------------------- C OFF-PLANET TEST C----------------------------------------------------------------------- IF(DATCOD.LT.0) GO TO 2900 C----------------------------------------------------------------------- C LAND/WATER FLAG RETRIEVAL C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C CAUTION: C C----------------------------------------------------------------------- C IF YOU WISH TO SKIP LAND/WATER FLAG RETRIEVAL, COMMENT OUT UP C TO AND INCLUDING 2850 CONTINUE C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C BEGIN PROCESSING - INITIAL CHECK OF PRIMAP (85% PASSES) C----------------------------------------------------------------------- ALAT = DATNAV(1,IPLPNT+IPIX) ALON = DATNAV(2,IPLPNT+IPIX) LATBIN = ALAT * 0.5 + 46.0 LONBIN = ALON * 0.5 + 1.0 IF(LATBIN.LT.1) LATBIN=1 IF(LATBIN.GT.90) LATBIN=90 IF(LONBIN.LT.1) LONBIN=1 IF(LONBIN.GT.180) LONBIN=180 IF(PRIMAP(LONBIN,LATBIN).GT.10) GO TO 2600 LNDFLG = PRIMAP(LONBIN,LATBIN) GO TO 2850 C----------------------------------------------------------------------- C ENTER LEVEL 2; 1.0X1.0 DEGREE RESOLUTION C----------------------------------------------------------------------- 2600 RKLAT = (LATBIN-1) * 2 LATPL = ALAT - RKLAT + 90.0 if ( latpl.gt.1 ) latpl = 1 LATPL = LATPL * 2 RKLON = (LONBIN-1) * 2 LONPL = ALON - RKLON if ( lonpl.gt.1 ) lonpl = 1 IPNTR = PRIMAP(LONBIN,LATBIN) + LONPL + LATPL IF(LEV100(IPNTR).GT.10) GO TO 2700 LNDFLG = LEV100(IPNTR) GO TO 2850 C----------------------------------------------------------------------- C ENTER LEVEL 3; 0.5X0.5 DEGREE RESOLUTION C----------------------------------------------------------------------- 2700 RKLAT = RKLAT + LATPL / 2 LATPL = (ALAT-RKLAT+90.0) * 2.0 if ( latpl.gt.1 ) latpl = 1 LATPL = LATPL * 2 RKLON = RKLON + LONPL LONPL = (ALON-RKLON) * 2.0 if ( lonpl.gt.1 ) lonpl = 1 IPNTR = LEV100(IPNTR) + LONPL + LATPL HWORD(2) = LEV050(IPNTR) IF(FWORD.GT.10) GO TO 2800 LNDFLG = FWORD GO TO 2850 C----------------------------------------------------------------------- C ENTER LEVEL 4; .25X.25 DEGREE RESOLUTION C----------------------------------------------------------------------- 2800 RKLAT = RKLAT + (LATPL/2) * 0.5 LATPL = (ALAT-RKLAT+90.0) * 4.0 if ( latpl.gt.1 ) latpl = 1 LATPL = LATPL * 2 RKLON = RKLON + LONPL * 0.5 LONPL = (ALON-RKLON) * 4.0 if ( lonpl.gt.1 ) lonpl = 1 IPNTR = FWORD + LONPL + LATPL LNDFLG = LEV025(IPNTR) C----------------------------------------------------------------------- C SAVE LAND/WATER FLAG C----------------------------------------------------------------------- 2850 LNDWTR(IPLPNT+IPIX) = LNDFLG C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- 2900 CONTINUE C----------------------------------------------------------------------- C AUGMENT IPLPNT C----------------------------------------------------------------------- 2950 IPLPNT = IPLPNT + NOPIX 3000 CONTINUE RETURN C----------------------------------------------------------------------- C NORMAL END OF DATA C----------------------------------------------------------------------- 4000 PRINT 4001,NINRCS 4001 FORMAT(//,10X,'END OF INPUT DATA',I8,//) INIT = 0 DATERR = -1 RETURN C----------------------------------------------------------------------- C PREMATURE END OF DATA C----------------------------------------------------------------------- 4100 PRINT 4101 4101 FORMAT(//,10X,'PREMATURE END OF IMAGE '//) INIT = 0 DATERR = -3 RETURN C----------------------------------------------------------------------- C I/O ERROR C----------------------------------------------------------------------- 5000 CONTINUE C IF(NINRCS .EQ. 135) THEN C DATERR = 0 C ELSE PRINT 5001,NINRCS 5001 FORMAT(/,20X,'I/O ERROR',I8,//) DATERR = -2 C ENDIF RETURN 6000 PRINT 6001,SCQUAL 6001 FORMAT(1X,'* * BAD SCAN LINE * * QUALITY INDICATOR =',I4,' *') DATERR = 1 C----------------------------------------------------------------------- C FILL SCAN LINE WITH NON-DATA C----------------------------------------------------------------------- DO 7500 IPIX = 1,NTOTPX DO 7100 IANG = 1,NANGS DATNAV(IANG,IPIX) = -1000.0 7100 CONTINUE DO 7200 ICHAN = 1,TOTCHS DATBUF(ICHAN,IPIX) = 255 7200 CONTINUE 7500 CONTINUE RETURN C----------------------------------------------------------------------- C INIT ERROR C----------------------------------------------------------------------- 10000 PRINT 10001,INIT 10001 FORMAT(/,10X,'WARNING: USER HAS NOT SET INIT FLAG ',I8,/) DATERR = -3 RETURN 10100 PRINT 10101,NCHANS,NSCANS,NIMGRC 10101 FORMAT(/1X,'IMAGE IDENTIFICATION RECORD CONTAINS BAD INFORMATION', 1 //1X,' NCHANS = ',I4,' NSCANS = ',I5,' NIMGRC = ',I5/) DATERR = -3 RETURN C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C IF USING THE LAND WATER FLAG ROUTINE THE FOLLOWING 8 STATEMENTS C MUST BE UNCOMMENTED C----------------------------------------------------------------------- C LAND/WATER INIT ERRORS C----------------------------------------------------------------------- 20100 PRINT 20101 20101 FORMAT(/,10X,'----ERROR: LNDWTR MAP INIT ----',/) DATERR = -3 RETURN 20200 PRINT 20201 20201 FORMAT(/,10X,'----END OF FILE: LAND/WATER MAP ---',/) DATERR = -3 RETURN C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- END SUBROUTINE BYTESWAP(BYTEBUFFR,MAXBYT,IFLAG,IWHICH,VALUE,CVAL) C------------------------------------------------------------- C This routine was necessary when running on a Linux machine c with the Portland Group Compiler. C----------------------------------------------------------------------- BYTE BYTEBUFFR(MAXBYT) INTEGER MAXBYT, IFLAG, IWHICH, VALUE INTEGER*4 IHOLD INTEGER*2 HBUF(2) CHARACTER*1 BBUFF(4) CHARACTER*4 CHBUF4(2000), CVAL(4) EQUIVALENCE(IHOLD,BUFF) EQUIVALENCE(IVAR2,HBUF(1)) EQUIVALENCE(IVAR2,SBUFF) EQUIVALENCE(BBUFF, BUFF) BYTE BUFF(4) BYTE SBUFF(2) C------------------------------------------------------------ C INTEGER*4 DATA RECORD IF(IWHICH .EQ. 0) THEN IFLAG = IFLAG * 4 BUFF(4) = BYTEBUFFR(IFLAG-3) BUFF(3) = BYTEBUFFR(IFLAG-2) BUFF(2) = BYTEBUFFR(IFLAG-1) BUFF(1) = BYTEBUFFR(IFLAG) VALUE = IHOLD ELSEIF(IWHICH .EQ. 1) THEN C INTEGER*2 DATA RECORD IFLAG = IFLAG * 2 HBUF(2) = BYTEBUFFR(IFLAG) SBUFF(2) = BYTEBUFFR(IFLAG-1) SBUFF(1) = BYTEBUFFR(IFLAG) IVAR2 = HBUF(1) VALUE = IVAR2 ELSEIF(IWHICH .EQ. 2) THEN C CHARACTER*4 DATA RECORD IFLAG = ((IFLAG -1) * 4) + 1 BUFF(1) = BYTEBUFFR(IFLAG) BUFF(2) = BYTEBUFFR(IFLAG+1) BUFF(3) = BYTEBUFFR(IFLAG+2) BUFF(4) = BYTEBUFFR(IFLAG+3) CVAL(1)(1:1) = BBUFF(1) CVAL(1)(2:2) = BBUFF(2) CVAL(1)(3:3) = BBUFF(3) CVAL(1)(4:4) = BBUFF(4) ENDIF RETURN END SUBROUTINE JULCNV (JULIAN,IYEAR,MONTH,IDAY,PRJDAT) C----------------------------------------------------------------------- C C JULIAN DAY TO MONTH-DAY CONVERSION ROUTINE C C----------------------------------------------------------------------- DIMENSION MNTAB(12) INTEGER PRJDAT DATA MNTAB /31,28,31,30,31,30,31,31,30,31,30,31/ C----------------------------------------------------------------------- C BEGIN C----------------------------------------------------------------------- MNTAB(2) = 28 IF(MOD(IYEAR,4).EQ.0) MNTAB(2) = 29 MONTH = 0 IDAY = 0 IF(JULIAN.EQ.0) GO TO 800 ISUM = 0 DO 500 MNTH = 1,12 ISUM = ISUM + MNTAB(MNTH) IF(JULIAN.GT.ISUM) GO TO 500 MONTH = MNTH ISUM = ISUM - MNTAB(MNTH) IDAY = JULIAN - ISUM C----------------------------------------------------------------------- C COMPUTE PROJECT DATE C----------------------------------------------------------------------- PRJDAT = -365 - 181 DO 100 IYR = 1982,IYEAR-1 JUL = 365 IF(MOD(IYR,4).EQ.0) JUL = 366 PRJDAT = PRJDAT + JUL 100 CONTINUE PRJDAT = PRJDAT + JULIAN RETURN 500 CONTINUE C----------------------------------------------------------------------- C JULIAN DATE ERROR C----------------------------------------------------------------------- 800 PRINT 801,JULIAN,IYEAR 801 FORMAT(/,10X,'JULCNV ERROR JULIAN',I5,2X,'YEAR',I8,/) PRJDAT = -1 RETURN END BLOCK DATA C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C BLOCK DATA SECTION C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C COMMON BLOCK B3INIT C C----------------------------------------------------------------------- C C I*4 LUN --------- LOGICAL UNIT NUMBER C I*4 INIT -------- INITIALIZATION FLAG C 0 - FIRST READ OF DATA SET C 1 - SCAN LINE READ C R*4 ALATLO ------ LOW VALUE FOR LATITUDE WINDOW SELECTION C R*4 ALATHI ------ HIGH VALUE FOR LATITUDE WINDOW SELECTION C I*4 NSCANS ------ NUMBER OF SCAN LINES IN THE IMAGE C I*4 NTOTPX ------ NUMBER OF PIXELS IN EACH SCAN LINE C I*4 NCHANS ------ NUMBER OF ACTIVE CHANNELS C I*4 IMAGNO ------ IMAGE SEQUENCE NUMBER C I*4 IBGTIM ------ BEGINNING SCAN LINE GMT (HHMMSS) C I*4 IENTIM ------ ENDING SCAN LINE GMT (HHMMSS) C I*4 IBGDAT ------ BEGINNING SCAN LINE DATE (YYDDD) C I*4 IENDAT ------ ENDING SCAN LINE DATE (YYDDD) C I*4 NIMGRC ------ NUMBER OF DATA RECORDS IN THE IMAGE C I*4 IVSCAL ------ CALIBRATION FLAG FOR THE VISIBLE CHANNEL C I*4 IIRCAL ------ CALIBRATION FLAG FOR THE IR CHANNEL C 0 - CALIBRATION NOT PRESENT C 1 - CALIBRATION PRESENT C I*4 IPBDSC ------ PERCENTAGE OF IMAGE CONTAINING BAD SCAN LINES C I*4 JULIAN ------ JULIAN DAY (1-366) C I*4 IYEAR ------- YEAR C I*4 MONTH ------- MONTH (1-12) C I*4 IDAY -------- DAY (1-31) C I*4 IHOUR ------- GMT OF IMAGE C I*4 MINS -------- GMT OF IMAGE C I*4 IDORN ------- DAY/NIGHT FLAG C 0 - DAY TIME IMAGE C 1 - FULL NIGHT TIME IMAGE (NO VISIBLE DATA) C I*4 ICLFLG(5) --- CALIBRATION TABLE FLAGS C I*4 NAVFLG(5) --- NAVIGATION ANGLE FLAGS C I*4 CHNLID(5) --- CHANNEL ID (INTEGER VALUE) C I*4 ICHAAV(5) --- CHANNEL AVAILABILITY FLAGS C 1 - PRESENT C 0 - NOT PRESENT C I*4 NSATID ------ SATELLITE CODE NUMBER C I*4 NSPCID ------ SPC CODE NUMBER C C*4 SATID(2) ---- SATELLITE ID (EBCDIC) C C*4 SPCID(2) ---- SPC ID (EBCDIC) C C*4 CHNID(5) --- CHANNEL IDENTIFICATION (EBCDIC) C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- COMMON /B3INIT/ LUN,INIT,ALATLO,ALATHI,NSCANS,NTOTPX,NCHANS, 1 IMAGNO,IBGTIM,IENTIM,IBGDAT,IENDAT,NIMGRC,IVSCAL,IIRCAL, 2 IPBDSC,JULIAN,IYEAR,MONTH,IDAY,IHOUR,MINS,IDORN,ICLFLG(5), 3 NAVFLG(5),CHNLID(5),ICHAAV(5),NSATID,NSPCID,SATID(2), 4 SPCID(2),CHNID(5),CAL3,CAL4,CAL5 INTEGER CHNLID CHARACTER*4 SATID,SPCID,CHNID INTEGER*4 CAL3,CAL4,CAL5 C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- C C B3COM COMMON BLOCK C C----------------------------------------------------------------------- C C I*4 NOFPL ------ NUMBER OF OFF PLANET PIXELS IN THE SCAN LINE C I*4 MTIME ------ GMT OF SCAN LINE (HHMMSS) C I*4 DATERR ----- ERROR FLAG RETURNED FROM B3READ C -4 - B3 INIT CALIBRATION NOT AVAILABLE C -3 - B3 INIT ERROR C -2 - I/O ERROR C -1 - END OF DATA C 0 - NO ERROR C 1 - ERROR IN DATA NON ZERO SCAN LINE QUALITY C 2 - CHANNEL QUALITY FLAG NON ZERO C I*4 IMGLIN ----- SCAN LINE NUMBER C I*4 LOCGRD(18,36) - LOCATION GRID C R*4 CALVAL(256,5) - CALIBRATION TABLE C R*4 DATNAV(5,MAXPIX) - ARRAY CONTAINING NAVIGATED ANGLES C I*2 PLANFL(MAXPIX) - ARRAY CONTAINING PLANETARY FLAGS C -1 - OFF PLANET C 0 - ON PLANET / DAYTIME C 1 - ON PLANET / NIGHT TIME C I*2 LNDWTR(MAXPIX) - ARRAY CONTAINING LAND/WATER FLAGS FOR EACH C PIXEL IN THE SCAN LINE C 1 - WATER C 2 - LAND C 3 - COAST C I*2 DATBUF(5,MAXPIX) - ARRAY CONTAINING DATA VALUES FOR EACH C CHANNEL C CHANNEL 1 : VISIBLE C CHANNEL 2 : IR C C----------------------------------------------------------------------- C*********************************************************************** C----------------------------------------------------------------------- PARAMETER (MAXPIX=500) COMMON /B3COM/ NOFPL,MTIME,DATERR,SCQUAL,CHNFLG(5),IMGLIN, 1 LOCGRD(18,36),CALVAL(256,5),DATNAV(5,MAXPIX), 2 PLANFL(MAXPIX),LNDWTR(MAXPIX),DATBUF(5,MAXPIX) INTEGER DATERR,SCQUAL,CHNFLG INTEGER*2 PLANFL,LNDWTR,DATBUF INTEGER*4 LOCGRD DATA LUN /14/ DATA INIT /0/ DATA ALATLO /-90./ DATA ALATHI /+90./ DATA ICLFLG /6,6,6,6,6/ DATA NAVFLG /1,1,1,1,1/ END C*********************************************************************** C*********************************************************************** C*********************************************************************** c convert ebcdic to ascii subroutine etoa( ebcstring, ascstring, length ) character*1 ebcstring(length) character*1 ascstring(length) character*1 asctab(0:255)/ $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ','.','<','(','+','|','&',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ','!','$','*',')',';','^','-','/', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',',','%','_','>','?', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ','`',':','#','@','\'', $ '=','"',' ','a','b','c','d','e','f','g','h','i',' ',' ', $ ' ',' ',' ',' ',' ','j','k','l','m','n','o','p','q','r', $ ' ',' ',' ',' ',' ',' ',' ','~','s','t','u','v','w','x', $ 'y','z',' ',' ',' ','[',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',']',' ',' ','{','A','B','C', $ 'D','E','F','G','H','I',' ',' ',' ',' ',' ',' ','}','J', $ 'K','L','M','N','O','P','Q','R',' ',' ',' ',' ',' ',' ', $ '\\',' ','S','T','U','V','W','X','Y','Z',' ',' ',' ',' ', $ ' ',' ','0','1','2','3','4','5','6','7','8','9',' ',' ', $ ' ',' ',' ',' '/ do 10 i=1,length ascstring(i) = asctab(ichar(ebcstring(i))) 10 continue return end