C * THIS CODE IS A FORTRAN 90 VERSION OF THE OLD B3READ C * THE VARIABLE NAMES ARE THE SAME AS IN THE OLD VERSION AND MOST C * OF THE STATEMENTS IN THE MAIN AND B3READ ARE THE SAME. C * C * IT IS SET NOW TO READ ONE IMAGE USING THE FOLLOWING GLOBAL INPUT C * C * 'B3 file name' C * 1 1 ! 1 image out of 1 available C * 6 1 1 1 1 1 ! calibration table number (6) and five angles C * ! latitude, longitude, cos(solar zenith), C * ! cos(satellite zenith) and phi C * C * THE COMPILER USED TO TEST THIS CODE IS XL FORTRAN FOR AIX C * IF YOU USE DIFFERENT COMPILERS YOU MIGHT NEED TO CHANGE IN C * THE B3_KIND MODULE THE STORAGE REQUIREMENTS C * C----------------------------------------------------------------------- C * NOTE: C * STARTING WITH NOAA KLM SATELLITES THE AVHRR INSTRUMENT HAS AN EXTRA C * CHANNEL 3A (1.6 MICROMETERS) DAYTIME STORED IN THE SAME DATA STREAM C * AS THE 3B CHANNEL (3.7 MICROMETERS) NIGHTIME. C * C * WE INTRODUCED IN B3 SCAN LINE DIR THE CHANNEL SWITCH FLAG FOR NOAA KLM C * TO SIGNAL THE AVHRR CHANNELS 3A/3B SWITCHING AT SCAN LINE LEVEL. C * THEREFORE IN THIS CODE ICH_SWITCH IS 1 FOR CH 3A AND 0 FOR 3B. C * C * CHANNEL 3B IS STORED IN CHANNEL 4 B3 AND THE SCANS THAT BELONGED TO 3A C * ARE FILLED WITH 255. C * CHANNEL 3A IS STORED IN CHANNEL 6 B3 AND THE SCANS THAT BELONGED TO 3B C * ARE FILLED WITH 255. C * THIS FLAG SHOULD BE 0 FOR ALL OTHER NOAA AND GEOSTATIONARY SATELLITES C * VG, 22 JAN 2003 C----------------------------------------------------------------------- C * C----------------------------------------------------------------------C C *********************************************************************C C TRANSFORMED TO FORTRAN 90 FEB, 2003 VG. C UPDATED FOR UNIX 1/20/99 -CBP C----------------------------------------------------------------------- C-----------------BEGIN MAIN-------------------------------------------- PROGRAM MAIN USE B3_MODULE USE B3_KIND C----------------------------------------------------------------------C C UNIX FILE SPECIFICATIONS C----------------------------------------------------------------------C CHARACTER (LEN=55) :: INFILE,OUTFILE,LUFILE INTEGER (KIND=INT4) :: OUTPUT,LUNMAP C C----------------------------------------------------------------------C C INITIALIZATION C----------------------------------------------------------------------C C INPUT=10 OUTPUT=20 LUNMAP=9 B3OUT=6 ! OUTPUT PORT cmyfix LUFILE='/clips/tables/lndwtr.data' LUFILE='fort.9' C----------------------------------------------------------------------C C -- OPEN LAND WATER MAP FILE C----------------------------------------------------------------------C OPEN(UNIT=LUNMAP,FILE=LUFILE, ACCESS='DIRECT',RECL=8000,FORM $ ='UNFORMATTED',STATUS='OLD') C----------------------------------------------------------------------C C -- READ THE NAME OF THE B3 IMAGE C----------------------------------------------------------------------C print*," " c-------9----------2---------3---------4---------5---------6---------7---------80 print*,"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX $XXXXXXXX" print*," THIS CODE IS A FORTRAN 90 VERSION OF THE OLD B3READ PROG $RAM." print*," THE VARIABLE NAMES ARE THE SAME AS IN THE OLD VERSION AN $D MOST" print*," OF THE STATEMENTS IN THE MAIN AND B3READ ARE THE SAME." print*," " c-------9----------2---------3---------4---------5---------6---------7---------80 print*," IT IS SET NOW TO READ ONE IMAGE USING THE FOLLOWING GLOB $AL INPUT." print*," " print*," 'B3 file name'" print*," 1 1 ! total no of images, image number" c-------9----------2---------3---------4---------5---------6---------7---------80 print*," 6 1 1 1 1 1 ! calibration table number (1 to 6) $and" print*," ! five angles: 1 to decode" print*," Please enter the Input as in the above example." print*," " print*,"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX $XXXXXXXX" print*,"Enter the name of the B3 image file" READ(5,*)INFILE print*,"INFILE ",INFILE print*,"Enter total number of images" READ(5,*) NUMIMG,NUM ! NUM IS IMAGE NUMBER EX: 2, 4,7 C----------------------------------------------------------------------C C -- READ THE OUTPUT FILE NAME IF NEEDED C----------------------------------------------------------------------C C----------------------------------------------------------------------C C -- READ CALIBRATION TABLE NUMBER AND NAVIGATION FLAGS C----------------------------------------------------------------------C print*,"Enter calibration table" READ(5,*) ICF,(NAVFLG(I),I=1,5) PRINT*,'CALIBRATION TABLE TO USE=',ICF PRINT*,'NAVIGATION ANGLE TO DECODE=',NAVFLG C----------------------------------------------------------------------C C BEGIN PROCESSING IMAGES C----------------------------------------------------------------------C cmyfix LUN= 10 DO L=1,6 ICLFLG(L)= ICF END DO C----------------------------------------------------------------------C C -- INITIALIZE THE 5 NAV FLAGS C----------------------------------------------------------------------C DO 300 IMG=1,NUMIMG C----------------------------------------------------------------------C C Here insert statement to read the b3 file name when reading more C files cmyfix WRITE(UNIT=INFILE(21:23),FMT='(I3.3)')IMG C----------------------------------------------------------------------C OPEN(UNIT=B3OUT,FILE='B3_OUT.txt',FORM='FORMATTED') OPEN(UNIT=INPUT,FILE=INFILE,ACCESS='DIRECT', FORM='UNFORMATTED' $ ,IOSTAT=IOS,RECL=8000,STATUS='OLD') IF(IOS .NE.0) PRINT*,'ERR OPENING FILE',IOS,INFILE C----------------------------------------------------------------------C C -- FLAG FOR READING THE IMAGE HEADER C----------------------------------------------------------------------C INIT = 0 C----------------------------------------------------------------------C C INITIAL CALL B3READ C----------------------------------------------------------------------C SCQUAL=0 CALL B3READ c PRINT 501,DATERR WRITE(B3OUT,501)DATERR 501 FORMAT('1','INITIAL READ SECTION COMPLETED DATERR FLAG = ',I5) IF(DATERR.NE.0) GO TO 1000 C----------------------------------------------------------------------C C -- FLAG FOR LOOPING OVER SCAN LINES C----------------------------------------------------------------------C INIT = 1 C----------------------------------------------------------------------C C -- VAR IHBEG USED TO BE FIXED (=19) FOR 5 OR LESS CHANNELS. NOW, IT C -- IS ADJUSTABLE, IF MORE THAN 5 CHANNELS(MCH) AS FOLLOWS: C----------------------------------------------------------------------C IHBEG=19 +2*(MCH-5) DO 200 J=1,NSCANS CALL B3READ C----------------------------------------------------------------------C C SAMPLE MAIN PROGRAM UPDATED TO MORE EXPLICITLY HANDLE DATERR VALUE C CBP 1/19/00 C----------------------------------------------------------------------C IF(DATERR.NE.0) THEN IF(DATERR.LT.0) GO TO 1100 PRINT 700,J,SCQUAL,NTOTPX,NOFPL IF(SCQUAL.GT.0) PRINT 601,SCQUAL,IMGLIN DO I = 1,NCHANS IF(CHNFLG(I).NE.0) PRINT 602,I,CHNFLG(I),IMGLIN END DO END IF !ON BAD SCAN LINE C----------------------------------------------------------------------C C----------------------------------------------------------------------C 700 FORMAT(1X,'***************DIAGNOSTICS FOR SCAN LINE NUMBER ',I5/ & ' SCAN LINE QUALITY FLAG = ',I5/ & ' TOTAL NUMBER OF PIXELS IN SCAN LINE : ',I5/ & ' TOTAL NUMBER OF OFF PLANET PIXELS IN SCAN LINE : ',I5) 601 FORMAT(1X,'SCAN LINE QUALITY FLAG',I8,' FOR SCAN NUMBER ',I5) 602 FORMAT(1X,'CHANNEL ',I3,' HAS CHANNEL QUALITY FLAG OF ',I4, & ' FOR SCAN NUMBER ',I5) C C----------------------------------------------------------------------C C AT THIS POINT YOU HAVE ONE SCAN LINE C----------------------------------------------------------------------C 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 c1100 PRINT 1110 1100 WRITE(B3OUT,1110) 1110 FORMAT(1X,'END OF DATA') 300 CONTINUE PRINT*," " PRINT*,"The Program Completed Successfully!!" PRINT*," " STOP END PROGRAM MAIN C - TRANSFORMED INTO FORTRAN90. READS ANY NUMBER OF CHANNELS C - UNIX COMPATIBLE 7/20/99 C--------------------------------------------------------------------- C********************************************************************* C--------------------------------------------------------------------- C B3READ FORTRN09 VERSION 2003 C--------------------------------------------------------------------- SUBROUTINE B3READ C--------------------------------------------------------------------- C C B3READ --- 10/27/2003 V. GOLEA C 8/28/97 C. PEARL C 9/27/83 A. WOLF C 2/08/84 L. GARDER C 3/19/84 A. WOLF C 1/15/85 L. GARDER C C C--------------------------------------------------------------------- C********************************************************************* C--------------------------------------------------------------------- C C THIS SUBROUTINE CONTAINS TWO SECTIONS : C C INIT SECTION --- READS THE IMAGE IDENTIFICATION RECORD, THE LOCATI 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 C THE SUBROUTINE REQUIRES THAT SOME ARRAYS BE INITIALIZED C BY THE USER --> SEE SAMPLE INPUT IN MAIN C NUMBER OF CHANNELS (NCHANS) IT IS READ FROM THE IMAGE ID AND USED TO C ALLOCATE THE ARRAYS C ICLFLG(NCHANS) : C 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(NCHANS) : C NAVIGATION ANGLE FLAG ARRAY DETERMINES WHICH ANGLES 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 I*4 MCH --------- HOLDS THE NUMBER THAT USED FOR ALLOCATING ARRAYS C IT IS = 5 WHEN THE NUMBER OF CHANNELS IS <= 5 C IT IS = NCHANS WHEN THE NUMBER OF CHANNELS IS > 5 C (due to format changes since the start of ISCCP) 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 CALFLG(NCHANS) ------ CALIBRATION FLAG FOR THE VISIBLE CHANNEL 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(NCHANS) --- CALIBRATION TABLE FLAGS C I*4 NAVFLG(5) --- NAVIGATION ANGLE FLAGS C I*4 CHNLID(NCHANS) --- CHANNEL ID (INTEGER VALUE) C I*4 ICHAAV(NCHANS) --- 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(NCHANS) --- CHANNEL IDENTIFICATION (EBCDIC) C C--------------------------------------------------------------------- C********************************************************************* 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 FOR POLAR SATELLITES C 6 - BAD TIME FOR B2 SCAN C 7 - B2 CALIBRATION ERRORS C 8 - B2 EARTH LOCATION ERRORS C I*4 CHNFLG(NCHANS) -- CHANNEL QUALITY INDICATOR C -2 - DATA ALL 0 OR 255 C -1 - NOT PRESENT C 0 - GOOD C >0 - BAD BUT PRESENT C FOR POLAR SATELLITES C 2 - NOMINAL SLOPE OR INTERCEPT IS 0 C 3 - REFLECTED SUNLIGHT C 4 - NOMINAL CALIBRATION PROBLEMS C C I*4 IMGLIN ----- SCAN LINE NUMBER C I*4 LOCGRD(18,36) - LOCATION GRID C R*4 CALVAL(256,NCHANS) - 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(NCHANS,MAXPIX) : C ARRAY CONTAINING DATA VALUES FOR EACH C CHANNEL C 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********************************************************************* 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 CALIBRATIO 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,NCHANS) - 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(MCH) C ------- 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 RECOR 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(MCH) ---- SCALE FACTORS FOR CALIBRATION TABLES C I*4 ISCNAV(5) ---- SCALE FACTORS FOR NAVIGATION FIT ERRORS C I*4 ISOURC(20,MCH) - SOURCE FOR CALIBRATION INFORMATION C I*4 IUNITS(20,MCH) - 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(MCH) ----- 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,MCH) -- CALIBRATION NORMALIZATION COEFFICIENTS 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 MCH ------- 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-------------------------------------------------------------------- USE B3_MODULE USE B3_KIND C********************************************************************* C--------------------------------------------------------------------- C C INIT SECTION C C--------------------------------------------------------------------- C********************************************************************* C--------------------------------------------------------------------- C C BEGIN C C--------------------------------------------------------------------- C--- CHECK WHETHER STDOUT IS UNDEFINED, AND MAKE IT LUNIT 6 IF IT IS: C---------------------- IF (B3OUT .NE. 8) B3OUT = 6 DATERR = 0 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 READ(INPUT,REC=IREC,IOSTAT=IRC)WBUF IF(IRC < 0)GO TO 4100 IF(IRC > 0) GO TO 5000 NCHANS = WBUF(10) c PRINT*,'THE NUMBER OF CHANNELS IN B3 IMAGE NCHANS=',NCHANS WRITE(B3OUT,*)'THE NUMBER OF CHANNELS IN B3 IMAGE NCHANS=',NCHANS C--------------------------------------------------------------------- C THE DATA FROM 1996 FORWARD WAS SAVED WITH A IMAGE ID C DESIGNED TO HOLD 5 CHANNELS THEREFORE WHEN THE SATELLITE HAs LESS THEN 5 C THE EXTRA FIELDS ARE EMPTY. FOR THIS REASON WE DO THE FOLLOWING: C--------------------------------------------------------------------- IF(NCHANS<5) MCH=5 IF(NCHANS>=5) MCH=NCHANS C------------------------ARRAY ALLOCATION SECTION-------------------- C---------------ARRAY ALLOCATION SECTION------------------------------ CALL ALOC_ARRAY C----------------------END ARRAY ALLOCATION --------------------------- IREC=1 READ(INPUT,REC=IREC,IOSTAT=IRC)WBUF IF(IRC < 0)GO TO 4100 IF(IRC > 0) GO TO 5000 C--------------------------------------------------------------------- C RECORD NUMBER, IMAGE NUMBER, RECORD TYPE C--------------------------------------------------------------------- IRECNO = WBUF(1) IMAGNO = HBUF(3) IRECTY = HBUF(4) C--------------------------------------------------------------------- IF(NCHANS < 0) GO TO 10100 C----------------------------------------------------------------------- C - FILL THE VARS FOR IMAGEID TO PRINT C----------------------------------------------------------------------- CALL IMAGE_ID C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(NSCANS <= 0.OR.NIMGRC <= 0) GO TO 10100 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--------------------------------------------------------------------- WRITE(B3OUT,175) IMAGNO,SPCID,NSPCID,SATID,NSATID,JULIAN,IYEAR, & MONTH,IDAY,NOMGMT,IHOUR,MINS 175 FORMAT('1',T10,'IMAGE DESCRIPTION'/ & T10,'================='// & T10,'IMAGE SEQUENCE NUMBER : ',I5/ & T10,'SPC ID ',2A4,' CODE ',I5,T40,'SATELLITE ID ',2A4,' CODE',I5/ & T10,'JULIAN DAY (DDD):',I4,3X,'YEAR (YYYY):',I5,' MONTH :',I3, & ' DAY :',I3/ & T10,'NOMINAL GMT (HHMMSS) :',I7,' HOUR :',I3,' MINS :',I4) WRITE(B3OUT,176) NIMGRC,NSCANS,IPBDSC,IBGTIM,IENTIM,IBGDAT,IENDAT, & NTOTPX 176 FORMAT(1X,T10,'NUMBER OF DATA RECORDS :',I6/ & 1X,T10,'NUMBER OF SCAN LINES :',I6,/ & 1X,T10,'PERCENTAGE BAD SCAN LINES :',I6/ & 1X,T10,'GMT (HHMMSS) OF BEGINNING SCAN LINE : ',I8, & ' ENDING :',I8/ & 1X,T10,'DATE (YYDDD) OF BEGINNING SCAN LINE :',I8, & ' ENDING :',I8/ & 1X,T10,'NUMBER OF PIXELS / SCAN LINE :',I8) C--------------------------------------------------------------------- C PRINT CHANNEL ID'S C--------------------------------------------------------------------- WRITE(B3OUT,177) NCHANS 177 FORMAT(1X,T10,'NUMBER OF ACTIVE CHANNELS :',I8) DO 179 I = 1,NCHANS cmyfix CALL ETOA( CHNID(I), CHNID(I), 4 ) WRITE(B3OUT,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 DO I=1,NCHANS WRITE(B3OUT,180) I, CALFLG(I) 180 FORMAT(1X,T10,'CHANNEL = ',I2,4X,'CALIBRATION FLAGS : ',I5) END DO WRITE(B3OUT,181) IDORN 181 FORMAT(1X,T10,'DAY OR NIGHT FLAG ',I5) WRITE(B3OUT,182) IASLON,IASGMT,IDSLON,IDSGMT 182 FORMAT(1X,T10,'ASCENDING EQUATOR CROSSING LONGITUDE ',I8, & ' GMT ',I8/1X,T10, & 'DESCENDING EQUATOR CROSSING LONGITUDE ',I8,' GMT ',I8) C--------------------------------------------------------------------- C RESET CALVAL C--------------------------------------------------------------------- DO 200 ICH = 1,MCH 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,MCH DATBUF(ICHAN,IPIX) = 255 350 CONTINUE C--------------------------------------------------------------------- C********************************************************************* C--------------------------------------------------------------------- C READ LOCATION GRID RECORD C--------------------------------------------------------------------- IREC=IREC+1 READ(INPUT,REC=IREC,IOSTAT=IRC)WBUF IF(IRC < 0)GO TO 4100 IF(IRC > 0) GO TO 5000 IGRDPT = 2 DO 360 ILON = 1,36 DO 360 ILAT = 1,18 IGRDPT = IGRDPT + 1 LOCGRD(ILAT,ILON) = WBUF(IGRDPT) 360 CONTINUE cmyfix PRINT 361 WRITE(B3OUT,361) 361 FORMAT('1',T50,'LOCATION GRID'//) DO 370 ILON = 1,36 WRITE(B3OUT,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,NCHANS ICHAN = CHNLID(ICAL) C--------------------------------------------------------------------- C INITIALIZE CALIBRATION CHECK ARRAY C--------------------------------------------------------------------- ICKCAL(ICHAN) = 0 IREC=IREC+1 READ(INPUT,REC=IREC,IOSTAT=IRC)WBUF cmyfix IF(IRC .NE.0)PRINT*,'RC AT CAL TABLE READ',IRC print*,'RC AT CAL TABLE READ',IRC IF(IRC < 0)GO TO 4100 IF(IRC > 0) GO TO 5000 IRECNO = WBUF(1) IMAGNO = HBUF(3) IRECTY = HBUF(4) IF(WBUF(3) == 0) THEN cmyfix WRITE(B3OUT,399)ICHAN cmyfix PRINT 399,ICHAN 399 FORMAT(//1X,'CALIBRATION TABLES FOR CHANNEL ',I6, 1 ' ARE NOT AVAILABLE'/) ICKCAL(ICHAN) = 256 GO TO 550 ENDIF C--------------------------------------------------------------------- C -- THE VALUES FOR ICLFLG ARE READ FROM INPUT FILE AND ARE SET BY THE USER C--------------------------------------------------------------------- IND = ICLFLG(ICHAN) IF(IND.LT.1.OR.IND.GT.6) IND = 1 C------------------- C--------------------------------------------------------------------- C PICK UP TEXTUAL INFORMATION -- PHYSICAL UNITS OF TABLE AND SOURCE C--------------------------------------------------------------------- CSIDEX = CSODEX(IND) DO I = 1,20 IUNITS(I,ICHAN) = WBUF(CSIDEX-1+I) ISOURC(I,ICHAN) = WBUF(CSIDEX+19+I) IF(IASCFLAG /= 1)CALL ETOA(IUNITS(I,ICHAN),IUNITS(I,ICHAN),4) IF(IASCFLAG /= 1)CALL ETOA(ISOURC(I,ICHAN),ISOURC(I,ICHAN),4) END DO C--------------------------------------------------------------------- C PICK UP CALIBRATION TABLES C--------------------------------------------------------------------- CINDEX = CALDEX(IND) ISCALE(ICHAN) = WBUF(CINDEX) IF(ISCALE(ICHAN) <= 0) THEN cmyfix PRINT 401,IND,ICHAN WRITE(B3OUT,401)IND,ICHAN 401 FORMAT(//1X,'CALIBRATION TABLE # ',I5,' FOR CHANNEL ', & I5,' IS NOT AVAILABLE'//) DATERR = -4 ENDIF CSCALE = ISCALE(ICHAN) COEF1 = WBUF(CINDEX+1) NRCOEF(1,ICHAN) = COEF1 / 10000. COEF2 = WBUF(CINDEX+2) NRCOEF(2,ICHAN) = COEF2 / CSCALE COEF3 = WBUF(CINDEX+3) NRCOEF(3,ICHAN) = COEF3 / CSCALE COEF4 = WBUF(CINDEX+4) NRCOEF(4,ICHAN) = COEF4 / CSCALE COEF5 = WBUF(CINDEX+5) NRCOEF(5,ICHAN) = COEF5 / CSCALE DO 500 I = 1,256 IVAL = WBUF(CINDEX+5+I) VAL = IVAL C-------------------------------------------------------------------- C IF A VALUE IN A CAL TABLE IS 0 INCREASE THE COUNTER ICKCAL C-------------------------------------------------------------------- IF(IVAL == 0) ICKCAL(ICHAN) = ICKCAL(ICHAN) + 1 CALVAL(I,ICHAN) = VAL / CSCALE 500 CONTINUE 450 CONTINUE 550 CONTINUE DO 600 ICAL = 1,NCHANS ICHAN = CHNLID(ICAL) IF(ICKCAL(ICHAN) == 256) THEN cmyfix c PRINT 551,ICHAN WRITE(B3OUT,551)ICHAN 551 FORMAT(//1X,' * * * CALIBRATION TABLE FOR CHANNEL ',I5, & ' IS NOT AVAILABLE * * *'//) DATERR = -4 ENDIF 600 CONTINUE WRITE(B3OUT,601) 601 FORMAT(//1X,T10,'CALIBRATION INFORMATION '/) DO 620 ICAL = 1,NCHANS ICHAN = CHNLID(ICAL) print*,"ICHAN ",ICHAN WRITE(B3OUT,606) ICHAN,ICLFLG(ICHAN) 606 FORMAT(1X,T10,'CHANNEL ',I5,5X,'TABLE ',I5) WRITE(B3OUT,607) (IUNITS(I,ICHAN),I=1,20) 607 FORMAT(1X,T10,' UNITS : ',20(A4)) WRITE(B3OUT,608) (ISOURC(I,ICHAN),I=1,20) 608 FORMAT(1X,T10,' SOURCE : ',20(A4)) WRITE(B3OUT,609) (NRCOEF(I,ICHAN),I=1,5) 609 FORMAT(1X,T10,' COEFS : ',5(F8.4,2X)) print*,"NCHANS ",NCHANS 620 CONTINUE C--------------------------------------------------------------------- C PRINT CALIBRATION TABLES C--------------------------------------------------------------------- cmyfix c PRINT 651 WRITE(B3OUT,651) 651 FORMAT('1',T55,'CALIBRATION TABLE'/ & T55,'====================='// & 1X,' COUNT',T60,'CHANNEL'// & 1X,'___________',T29,' 1 ',' 2 ', & ' 3 ',' 4 ', & ' 5 ',' 6 ', & /T29,6(' ------- ')/) DO 655 ICT = 1,256 NCT = ICT - 1 PRINT 652, NCT,(CALVAL(ICT,ICH),ICH=1,NCHANS) cmyfix WRITE(B3OUT,652)NCT,(CALVAL(ICT,ICH),ICH=1,MCHAN) print*,"NCT ",NCT print*,"ICHAN ",ICHAN print*,"NCHANS ",NCHANS print*,"MCHAN ",MCHAN c STOP25 WRITE(B3OUT,652)NCT,(CALVAL(ICT,ICH),ICH=1,MCHAN) 652 FORMAT(1X,I5,T29,6(F9.2,5X)) 655 CONTINUE 650 CONTINUE C--------------------------------------------------------------------- C CHECK ANGLE FLAGS C--------------------------------------------------------------------- 660 MANGS = 0 DO I = 1,NANGS IF((NAVFLG(I).LT.0).OR.(NAVFLG(I).GT.1)) THEN DATERR = -3 cmyfix c PRINT 670,I,NAVFLG(I) WRITE(B3OUT,670)I,NAVFLG(I) RETURN ENDIF MANGS = MANGS + NAVFLG(I) END DO 670 FORMAT(//,1X,'*** WARNING NAVFLG NOT PROPERLY SET',2I8,/) IPTSCN = 0 C--------------------------------------------------------------------- C TEST LATITUDE WINDOW SELECTION C--------------------------------------------------------------------- IF((ALATLO.EQ.-90.).AND.(ALATHI.EQ.+90.)) GO TO 800 cmyfix PRINT 701, ALATLO,ALATHI WRITE(B3OUT,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 READ(INPUT,REC=IREC,IOSTAT=IRC)WBUF IF(IRC .NE.0)PRINT*,'RC AT LAT/LON HI LO READ',IRC IF(IRC .LT. 0)GO TO 4000 IF(IRC .GT.0) GO TO 5000 NINRCS = NINRCS + 1 ILATLO = HBUF(7) ILATHI = HBUF(8) ILONLO = HBUF(9) ILONHI = HBUF(10) 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 cmyfix PRINT 751,ALATLO,ALATHI,NINRCS,NIMGRC,RLATLO,RLATHI WRITE(B3OUT,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',/) C--------------------------------------------------------------------- C TO ACCOMODATE THE FLEXIBLE STRUCTURE OF THE SCAN DIRECTORY C IHBEG IS VARIABLE AS FOLLOWS: IHBEG=19+2*(MCH-5) C IT IS THE LENGTH OF THE SCAN LINE DIRECTORY C--------------------------------------------------------------------- IPTSCN = IHBEG C--------------------------------------------------------------------- C SET LAND/WATER TEST FLAG C--------------------------------------------------------------------- 800 IF((NAVFLG(1).EQ.1).AND.(NAVFLG(2).EQ.1)) THEN LNDWON = 1 print *,'initlw=',initlw 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 THE LINE BEFORE THE ELSE STATEMENT C LUNMAP = 9 DO 850 IBUF = 1,23 READ(LUNMAP,REC=IBUF,IOSTAT=IRC)(BUFFER(IWD,IBUF),IWD=1,4000) IF(IRC < 0)GO TO 20100 IF(IRC > 0) GO TO 20200 850 CONTINUE CLOSE(LUNMAP) cmyfix PRINT 851 WRITE(B3OUT,851) 851 FORMAT(/'---< LNDWTR MAPS INITIALIZED >---'/) ELSE LNDWON = 0 cmyfix PRINT 852 WRITE(B3OUT,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 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 cmyfix READ(INPUT,REC=IREC,IOSTAT=IRC)WBUF READ(INPUT,REC=IREC,IOSTAT=IRC)WBUF IF(IRC .NE.0)PRINT*,'RC AT RECORD ',IREC,'IS ',IRC IF(IRC < 0)GO TO 4000 IF(IRC > 0)GO TO 5000 NINRCS = NINRCS + 1 C--------------------------------------------------------------------- C INITIALIZE HALF-WORD POINTER C RECORD IDENTIFICATION 2.8.4.1. C--------------------------------------------------------------------- HINDEX = IHBEG ILATLO = HBUF(7) ILATHI = HBUF(8) ILONLO = HBUF(9) ILONHI = HBUF(10) RLATLO = ILATLO * SCALNV RLATHI = ILATHI * SCALNV RLONLO = ILONLO * SCALNV RLONHI = ILONHI * SCALNV RMULO = HBUF(11) RMULO = RMULO * SCLNVM RMUHI = HBUF(12) RMUHI = RMUHI * SCLNVM RMU0LO = HBUF(13) RMU0LO = RMU0LO * SCLNVM RMU0HI = HBUF(14) RMU0HI = RMU0HI * SCLNVM C--------------------------------------------------------------------- C FETCH SCAN LINE DIRECTORY C--------------------------------------------------------------------- 1200 NOFPL=0 C--------------------------------------------------------------------- C POINTER TO NEXT SCAN LINE C--------------------------------------------------------------------- IPTSCN = HBUF(HINDEX) C--------------------------------------------------------------------- C SCAN LINE NUMBER C--------------------------------------------------------------------- IMGLIN = HBUF(HINDEX+1) C--------------------------------------------------------------------- C -- READ THE FLAG FOR SWITCH CHAN 3A AND 3B. 1 FOR 3A AND 0 FOR 3B C -- IT IS FILLED FOR NOAA-16 AND FORWARD, FOR THE REST IS 0 C--------------------------------------------------------------------- HINDEX = HINDEX + 2 ICH_SWITCH=HBUF(HINDEX) C PRINT*,'ICH_SWITCH=',ICH_SWITCH C--------------------------------------------------------------------- C PICK UP LOGICAL POINTER TO FIRST DATA BYTE (SKIP UNUSED HALF-WORD) C--------------------------------------------------------------------- HINDEX = HINDEX + 1 LPOINT = HBUF(HINDEX) HINDEX = HINDEX + 1 C--------------------------------------------------------------------- C NUMBER OF NAVIGATION RANGES FOR EACH ANGLE C--------------------------------------------------------------------- DO 1300 NAV = 1,NANGS NAVRNG(NAV) = HBUF(HINDEX) HINDEX = HINDEX + 1 1300 CONTINUE C--------------------------------------------------------------------- C NUMBER OF DATA RANGES C--------------------------------------------------------------------- NDATRG = HBUF(HINDEX) 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 SCQUAL = HBUF(HINDEX) HINDEX = HINDEX + 1 IF(SCQUAL.GT.0) GO TO 6000 DO ICH =1,MCH CHNFLG(ICH) = HBUF(HINDEX) HINDEX = HINDEX + 1 END DO DO 1500 ICH = 1,NCHANS IF(CHNFLG(ICH).NE.0) THEN DATERR = 2 GO TO 1510 ENDIF 1500 CONTINUE C--------------------------------------------------------------------- C GMT OF SCAN LINE C--------------------------------------------------------------------- 1510 CONTINUE C MTIME = WBUF(WINDEX) C -- NOW, SINCE WE HAVE MORE THAN 5 CHANNELS FOR NOAA-16 FORWARD C -- WE NEED TO DO THIS: IF(MCH>=6) HINDEX=HINDEX+(MCH-5) WINDEX=HINDEX/2+1 MTIME = WBUF(WINDEX) HINDEX = HINDEX + 2 IF(MTIME<0)PRINT*,'ERROR IN SCAN LINE GMT, & CHECK LINE 1415 TO 1428' C--------------------------------------------------------------------- C FETCH SCAN LINE PARAMETERS AND RENAVIGATE ANGLES C--------------------------------------------------------------------- IF(NANGS.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 IPXBEG = HBUF(HINDEX) IPXEND = HBUF(HINDEX+1) HINDEX = HINDEX + 2 WINDEX = (HINDEX-1) / NBYHW + 1 IF0 = WBUF(WINDEX) ID1 = WBUF(WINDEX+1) ID2 = WBUF(WINDEX+2) HINDEX = NBYHW * (WINDEX+3) - 1 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--------------------------------------------------------------------- BYPIX = HBUF(HINDEX) C--------------------------------------------------------------------- C POINTER TO FIRST DATA BYTE C--------------------------------------------------------------------- IRANGE = HBUF(HINDEX+1) C--------------------------------------------------------------------- C DATA CODE FOR RANGE (0 PLANET DAY,1 ON PLANET NIGHT ,-1 OFF PLANET) C--------------------------------------------------------------------- DATCOD = HBUF(HINDEX+2) C--------------------------------------------------------------------- C NUMBER OF PIXELS IN RANGE C--------------------------------------------------------------------- NOPIX = HBUF(HINDEX+3) HINDEX = HINDEX + 4 C--------------------------------------------------------------------- C PRE-LOAD PLANETARY FLAGS C IF NIGHT OR DAY ON PLANET GO TO 2450 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,MCH C DATBUF(ICHAN,IPLPNT+IPIX) = 255 C2350 CONTINUE C--------------------------------------------------------------------- C DECODE OFF PLANET ORIGINAL VALUES C--------------------------------------------------------------------- DO 2350 ICHAN = 1,NCHANS CHARWD(2) = CBUF(IRANGE+ICHAN-1) JCHAN = CHNLID(ICHAN) DATBUF(JCHAN,IPLPNT+IPIX) = HLFWRD 2350 CONTINUE C--------------------------------------------------------------------- IRANGE = IRANGE + NCHANS DO 2370 NAV = 1,NANGS DATNAV(NAV,IPLPNT+IPIX) = -1000. 2370 CONTINUE 2400 CONTINUE GO TO 2950 ! IF OFF PLANET SKIP 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 ! IF 0 BYTES/PIXEL C--------------------------------------------------------------------- C FOR NOAA-16 SPLIT CHANNELS FOUR IN 3B ( B3 CHA 4) AHD 3A (B3 CH 6) C--------------------------------------------------------------------- DO 2500 ICHAN = 1,NCHANS CHARWD(2) = CBUF(IRANGE+ICHAN-1) JCHAN = CHNLID(ICHAN) DATBUF(JCHAN,IPLPNT+IPIX) = HLFWRD 2500 CONTINUE IRANGE = IRANGE + NCHANS 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--------------------------------------------------------------------- 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 WRITE(B3OUT,4001) NINRCS 4001 FORMAT(//,10X,'END OF INPUT DATA',I8,//) INIT = 0 DATERR = -1 RETURN C--------------------------------------------------------------------- C PREMATURE END OF DATA C--------------------------------------------------------------------- cmyfix 4100 PRINT 4101 4100 WRITE(B3OUT,4101) 4101 FORMAT(//,10X,'PREMATURE END OF IMAGE '//) INIT = 0 DATERR = -3 RETURN C--------------------------------------------------------------------- C I/O ERROR C--------------------------------------------------------------------- cmyfix 5000 PRINT 5001,NINRCS 5000 WRITE(B3OUT,5001)NINRCS 5001 FORMAT(/,20X,'I/O ERROR',I8,//) DATERR = -2 RETURN 6000 WRITE(B3OUT,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,MCH DATBUF(ICHAN,IPIX) = 255 7200 CONTINUE 7500 CONTINUE RETURN C--------------------------------------------------------------------- C INIT ERROR C--------------------------------------------------------------------- cmyfix10000 PRINT 10001,INIT 10000 WRITE(B3OUT,10001)INIT 10001 FORMAT(/,10X,'WARNING: USER HAS NOT SET INIT FLAG ',I8,/) DATERR = -3 RETURN cmyfix10100 PRINT 10101,NCHANS,NSCANS,NIMGRC 10100 WRITE(B3OUT,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--------------------------------------------------------------------- cmyfix20100 PRINT 20101 20100 WRITE(B3OUT,20101) 20101 FORMAT(/,10X,'----ERROR: LNDWTR MAP INIT ----'/) DATERR = -3 RETURN cmyfix20200 PRINT 20201 20200 WRITE(B3OUT,20201) 20201 FORMAT(/,10X,'----END OF FILE: LAND/WATER MAP ---'/) DATERR = -3 RETURN END SUBROUTINE B3READ C--------------------------------------------------------------------- C**********************************************************************C C* NAME: ICHAR_ *C C* DESCRIPTION: FUNCTION TO HANDLE CHANGE IN ICHAR BEHAVIOR WITH *C C* v8 OF THE IBM xlf90 COMPILER *C C**********************************************************************C C**********************************************************************C C**********************************************************************C INTEGER FUNCTION ICHAR_(C) CHARACTER C INTEGER TMP TMP = ICHAR(C) IF(TMP.GE.0) THEN ICHAR_=TMP ELSE ICHAR_=256+TMP ENDIF RETURN END 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)/ $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', $ ' ',' ',' ',' ',' ','.','<','(','+','|','&',' ',' ',' ', $ ' ',' ',' ',' ',' ',' ','!','$','*',')',';','^','-','/', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ',',','%','_','>','?', $ ' ',' ',' ',' ',' ',' ',' ',' ',' ','`',':','#','@','\', cmyfix $ '=','"',' ','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 I=1,LENGTH ASCSTRING(I) = ASCTAB(ICHAR_(EBCSTRING(I))) END DO RETURN END SUBROUTINE ETOA C--------------------------------------------------------------------- C********************************************************************* C--------------------------------------------------------------------- SUBROUTINE HSTPRN (NBINS,HIST) C C HISTOGRAM PRINTOUT C INTEGER HIST(1) CHARACTER*1 PRNT(100) CHARACTER*1 BLNK,XXXX DATA BLNK /' '/ DATA XXXX /'X'/ C C BEGIN C MAX=0 ISUM=0 IFRSBN=0 DO 100 IBIN=1,NBINS IVAL=HIST(IBIN) ISUM=ISUM+IVAL IF(IVAL.GT.MAX) MAX=IVAL IF(IVAL.EQ.0) GO TO 100 LASTBN=IBIN IF(IFRSBN.EQ.0) IFRSBN=IBIN 100 CONTINUE IF(MAX.EQ.0) RETURN AMAX=MAX SUM=ISUM ISUM=0 DO 700 IBIN=IFRSBN,LASTBN HEIT=HIST(IBIN) IHEIT=100.0*(HEIT/AMAX) DO 600 IPRN=1,100 PRNT(IPRN)=BLNK IF(IPRN.LE.IHEIT) PRNT(IPRN)=XXXX 600 CONTINUE ISUM=ISUM+HIST(IBIN) TOT=100.0*(ISUM/SUM) IF(TOT.LT.0.1) GO TO 700 PRINT 601,IBIN,HIST(IBIN),TOT,PRNT 601 FORMAT(1X,I4,1X,I8,1X,F11.2,1X,'.',100A1) IF(TOT.GT.99.5) RETURN 700 CONTINUE RETURN END SUBROUTINE HSTPRN C--------------------------------------------------------------------- C********************************************************************* C--------------------------------------------------------------------- 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 SUBROUTINE JULCNV