MODULE B3_MODULE USE B3_KIND C---------------------------------------------------------------------- C---------------------------------------------------------------------- INTEGER (KIND=INT2):: PRIMAP(180,90) INTEGER (KIND=INT2):: LEV100(9750) INTEGER (KIND=INT2):: LEV050(21200) INTEGER (KIND=INT2):: LEV025(42200) INTEGER (KIND=INT2):: BUFFER(4000,23) INTEGER (KIND=INT2):: L_W(92000) EQUIVALENCE (PRIMAP(1,1),BUFFER(1,1)) EQUIVALENCE (L_W(1),BUFFER(1,1)) EQUIVALENCE (LEV100(1),L_W(16201)) EQUIVALENCE (LEV050(1),L_W(25951)) EQUIVALENCE (LEV025(1),L_W(47151)) C---------------------------------------------------------------------- C B3 INPUT BUFFER C---------------------------------------------------------------------- INTEGER (KIND=INT4) :: WBUF(2000) INTEGER (KIND=INT2) :: HBUF(4000) CHARACTER (LEN=4) :: CHBUF4(2000) CHARACTER (LEN=1) :: CBUF(8000) C C---------------------------------------------------------------------- C MISCELLANEOUS STORAGE C---------------------------------------------------------------------- C INTEGER (KIND=INT4) :: ISCNAV(5) , INAVER(5) INTEGER (KIND=INT4), ALLOCATABLE :: NOISE(:) INTEGER (KIND=INT2) :: HLFWRD=0 CHARACTER (LEN=4), ALLOCATABLE :: CHNRNG(:,:) CHARACTER (LEN=1) :: CHARWD(2) C C----------------------------------------------------------------------- C ARRAYS AND VARIABLES FOR CALIBRATION C----------------------------------------------------------------------- C INTEGER (KIND=INT4) :: NAVRNG(5),INTFLG(0:1)/1,0/ REAL (KIND=REAL4), ALLOCATABLE :: NRCOEF(:,:) INTEGER (KIND=INT4) :: CINDEX,CSIDEX INTEGER (KIND=INT4), SAVE ::CALDEX(6)/44,346,648,950, & 1252,1554/, CSODEX(6)/4,306,608,910,1212,1514/ INTEGER (KIND=INT4),ALLOCATABLE ::ISOURC(:,:),IUNITS(:,:), & ICKCAL(:),ISCALE(:) INTEGER (KIND=INT4) :: PRJDAT,YYMM,HINDEX,WINDEX, & FWORD=0,TOTCHS,DATCOD,BYPIX INTEGER (KIND=INT4) :: MCHAN INTEGER (KIND=INT2) :: 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)) EQUIVALENCE (HLFWRD,CHARWD(1)) EQUIVALENCE (HWORD(1),FWORD) C C----------------------------------------------------------------------- C SET CONSTANTS C----------------------------------------------------------------------- C -- IHBEG IS CALCULATED DYNAMIC IN THE B3READ EX: FOR 6 CHANS C -- IHBEG=19+2(NCHANS -5). THIS IS DONE THIS WAY TO ACCOMODATE C -- PREVIOUS B3 DATA IMAGE ID FORMAT C----------------------------------------------------------------------- INTEGER (KIND=INT4):: NANGS/5/,IHBEG,NBYHW/2/,IPTSCN INTEGER (KIND=INT4)::SCALNV/.05/,SCLNVM/.01/ INTEGER (KIND=INT4):: INITLW /0/ C----------------------------------------------------------------------- C B3COM - CONTAINS B3 DATA ARRAYS C----------------------------------------------------------------------- INTEGER (KIND=INT4),PARAMETER:: MAXPIX=500 INTEGER (KIND=INT4),PARAMETER:: NCNT=256, NNA=3, ANG=5 INTEGER (KIND=INT4)::NOFPL,MTIME,DATERR,SCQUAL,IMGLIN, . LOCGRD(18,36) INTEGER (KIND=INT2):: PLANFL(MAXPIX),LNDWTR(MAXPIX) INTEGER (KIND=INT2), ALLOCATABLE ::DATBUF(:,:) INTEGER (KIND=INT4), ALLOCATABLE ::CHNFLG(:) REAL (KIND=REAL4),ALLOCATABLE ::CALVAL(:,:) REAL (KIND=REAL4) ::DATNAV(ANG,MAXPIX) C----------------------------------------------------------------------- C B3INIT C----------------------------------------------------------------------- C NCHANS:: IS = THE NO OF DATA CHANNELS READ FROM B3 IMAGE ID C MCH:: IS = THE MAXIMUM NUMBER OF CHANNELS FOR WHICH THE IMAGE ID C IS FILLED UP. IT IS EQUAL WITH NCHANS(REAL NR OF CHANNELS FOR SATELLITE) C IF NCHANS>=5 IT IS SET TO NCHANS ELSE IT IS SET TO 5 (OLD B3 IMAGE ID C FORMAT) C----------------------------------------------------------------------- INTEGER (KIND=INT4)::IPRTFL,NSATID,NSPCID,IPBDSC,JULIAN,IYEAR, & MONTH,IMAGNO,IRECTY,IBGTIM,IENTIM,IBGDAT,IENDAT,NIMGRC, & IDAY,IHOUR,MINS,IDORN,INPUT=10,INIT,NSCANS,NTOTPX, & NCHANS,MCH,NAVFLG(5),NOMGMT,ICLFLG(6) INTEGER (KIND=INT4), ALLOCATABLE :: CHNLID(:),ICHAAV(:),CALFLG(:) INTEGER (KIND=INT4) ::IASLON,IASGMT,IDSLON,IDSGMT REAL (KIND=REAL4) :: ALATLO/-90./,ALATHI/+90.0/ CHARACTER (LEN=4) :: SATID(2),SPCID(2) CHARACTER (LEN=4), ALLOCATABLE :: CHNID(:) C----------------------------------------------------------------------- C B3MORE B3OUT: TO REDIRECT B3READ'S PRINTS C------------------------------------------------------------------------- INTEGER (KIND=INT4) :: B3OUT=6,IASCFLAG C------------------------------------------------------------------------- C -- SUBROUTINE TO FILL UP IMAGE ID C------------------------------------------------------------------------- CONTAINS SUBROUTINE IMAGE_ID INTEGER (KIND=INT2) ::P,I C--------------------------------------------------------------------- C RECORD NUMBER, IMAGE NUMBER, RECORD TYPE C--------------------------------------------------------------------- IRECNO = WBUF(1) IMAGNO = HBUF(3) IRECTY = HBUF(4) C--------------------------------------------------------------------- C - THIS IS THE EBC OR ASCII FLAG ( FOR OLD DATA DONE ON MAINFRAME) C - OVER A PERIOD OF TIME THIS FLAG WAS SAVED IN IMAGEID WORD 111 C - THIS CHANGED WHEN MORE THAN 5 CHANNELS STARTED TO BE PROCESSED WHEN C - IT WAS MOVED IN WORD 750. TO AVOID ANY CONFUSION THE FOLLOWING CHECK C - WILL BE USED. IF ANY ERRORS AT PRINTING THE B3 IMAGE HEADER ID MODIFY IT. C - THIS WILL BE ELIMINATED WHEN ALL DATA C - WILL BE REPROCESSED. C--------------------------------------------------------------------- C--------------------------------------------------------------------- C SPC ID (EBCDIC) C--------------------------------------------------------------------- SPCID(1) = CHBUF4(3) SPCID(2) = CHBUF4(4) IASCFLAG = ICHAR(SPCID(1)(1:1)) IF(IASCFLAG>64.AND.IASCFLAG<91)IASCFLAG=1 IF (IASCFLAG /= 1)CALL ETOA(SPCID,SPCID,8) C--------------------------------------------------------------------- C SATELLITE ID (EBCDIC) C--------------------------------------------------------------------- SATID(1) = CHBUF4(5) SATID(2) = CHBUF4(6) IF(IASCFLAG /= 1)CALL ETOA(SATID,SATID,8) C--------------------------------------------------------------------- C YEAR, JULIAN DAY, AND NOMINAL GMT C--------------------------------------------------------------------- IYEAR = WBUF(7) JULIAN = WBUF(8) NOMGMT = WBUF(9) P=11 DO I=1,MCH CHNID(I) = CHBUF4(P) P=P+1 END DO C--------------------------------------------------------------------- C NUMBER OF SCAN LINES IN IMAGE, NUMBER OF PIXELS / SCAN LINE C--------------------------------------------------------------------- NSCANS = WBUF(P) P=P+1 NTOTPX = WBUF(P) C--------------------------------------------------------------------- C BEGINNING AND ENDING SCAN LINE GMT'S C--------------------------------------------------------------------- P=P+1 IBGTIM = WBUF(P) P=P+1 IENTIM = WBUF(P) C--------------------------------------------------------------------- C BEGINNING AND ENDING SCAN LINE DATES C--------------------------------------------------------------------- P=P+1 IBGDAT = WBUF(P) P=P+1 IENDAT = WBUF(P) C--------------------------------------------------------------------- C NUMBER DATA RECORDS IN IMAGE C--------------------------------------------------------------------- P=P+1 NIMGRC = WBUF(P) C--------------------------------------------------------------------- C NAVIGATION FIT ERRORS C--------------------------------------------------------------------- INDW=P DO I = 1,NANGS ISCNAV(I) = WBUF(INDW+1) INAVER(I) = WBUF(INDW+2) INDW = INDW + 2 END DO C--------------------------------------------------------------------- C NOISE FACTORS C--------------------------------------------------------------------- P=INDW+1 DO I = 1,MCH NOISE(I) = WBUF(P) P=P+1 END DO C--------------------------------------------------------------------- C CHANNEL SPECTRAL RANGES C--------------------------------------------------------------------- IPT = 0 C -- FIX CURRENT VALUE OF P FOR THE NEXT LOOP IPP=P-1 DO ICH = 1,MCH DO 150 J = 1,10 IPT = IPT + 1 CHNRNG(J,ICH) = CHBUF4(IPP+IPT) P=P+1 150 CONTINUE END DO IF(IASCFLAG /= 1 )CALL ETOA(CHNRNG,CHNRNG,200) C--------------------------------------------------------------------- C CALIBRATION FLAGS C ****ATTENTION***** C FOR THIS CODE TO READ ANY B3 IMAGE WE NEED TO ADD A CONDITON FOR C THE YEAR 1996 WHEN THE CALIBRATION FLAGS STARTED TO BE SAVED FOR ALL C PRESENT CHANNELS ( BEFORE 1996 ONLY FOR VIS AND IR1 ) C--------------------------------------------------------------------- IF(IYEAR <1996)IFL=2 IF(IYEAR >=1996)IFL=MCH DO I=1,IFL CALFLG(I) = WBUF(P) P=P+1 END DO C--------------------------------------------------------------------- C PERCENTAGE OF IMAGE CONTAINING BAD SCAN LINES C--------------------------------------------------------------------- IPBDSC = WBUF(P) C--------------------------------------------------------------------- C -- LOCATION INFORMATION (EQUATOR CROSSINGS OR SUBSATELLITE LONGITUDE C--------------------------------------------------------------------- C P=P+1 IASLON = WBUF(P) P=P+1 IASGMT = WBUF(P) P=P+1 IDSLON = WBUF(P) P=P+1 IDSGMT = WBUF(P) C--------------------------------------------------------------------- C -- SPC CODE NUMBER C--------------------------------------------------------------------- C P=P+1 NSPCID = WBUF(P) C--------------------------------------------------------------------- C -- SATELLITE CODE NUMBER C--------------------------------------------------------------------- C P=P+1 NSATID = WBUF(P) C C--------------------------------------------------------------------- C -- CHANNEL IDENTIFICATION (INTEGER) C--------------------------------------------------------------------- C P=P+1 C -- MCHAN IS THE LARGEST POSSIBLE NUMBER OF CHANNELS SO FAR cmyfix MCHAN = 36 MCHAN=6 MCHAN=0 DO I = 1,MCH CHNLID(I) = WBUF(P) P=P+1 IF(CHNLID(I) > MCHAN) MCHAN = CHNLID(I) END DO C C--------------------------------------------------------------------- C -- CHANNEL AVAILABILITY FLAGS C--------------------------------------------------------------------- C DO I = 1,MCH ICHAAV(I) = WBUF(P) P=P+1 END DO C C--------------------------------------------------------------------- C -- DAY OR NIGHT FLAG C--------------------------------------------------------------------- C IDORN = WBUF(P) RETURN END SUBROUTINE IMAGE_ID C SUBROUTINE ALOC_ARRAY IF (ALLOCATED(DATBUF))DEALLOCATE(DATBUF) ALLOCATE(DATBUF(MCH,MAXPIX),STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING DATBUF" IF (ALLOCATED(CHNFLG))DEALLOCATE(CHNFLG) ALLOCATE(CHNFLG(MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING CHNFLG" IF (ALLOCATED(CALFLG))DEALLOCATE(CALFLG) ALLOCATE(CALFLG(MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING CALFLG" IF (ALLOCATED(CALVAL))DEALLOCATE(CALVAL) ALLOCATE(CALVAL(NCNT,MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING CALVAL" IF (ALLOCATED(CHNLID))DEALLOCATE(CHNLID) ALLOCATE(CHNLID(MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING CHNLID" IF (ALLOCATED(ICKCAL))DEALLOCATE(ICKCAL) ALLOCATE(ICKCAL(MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING ICKCAL" IF (ALLOCATED(ICHAAV))DEALLOCATE(ICHAAV) ALLOCATE(ICHAAV(MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING ICHAAV" IF (ALLOCATED(CHNID))DEALLOCATE(CHNID) ALLOCATE(CHNID(MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING CHNID" IF (ALLOCATED(ISCALE))DEALLOCATE(ISCALE) ALLOCATE(ISCALE(MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING ISCALE" IF (ALLOCATED(ISOURC))DEALLOCATE(ISOURC) ALLOCATE(ISOURC(20,MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING ISOURC" IF (ALLOCATED(IUNITS))DEALLOCATE(IUNITS) ALLOCATE(IUNITS(20,MCH), STAT=IOS) IF(IOS /= 0) STOP "ERROR ALLOCATING IUNITS" IF (ALLOCATED(CHNRNG))DEALLOCATE(CHNRNG) ALLOCATE(CHNRNG(10,MCH)) IF(IOS /= 0) STOP "ERROR ALLOCATING CHNRNG" IF (ALLOCATED(NRCOEF))DEALLOCATE(NRCOEF) ALLOCATE(NRCOEF(MCH,MCH)) IF(IOS /= 0) STOP "ERROR ALLOCATING NRCOEF" IF (ALLOCATED(NOISE))DEALLOCATE(NOISE) ALLOCATE(NOISE(MCH)) IF(IOS /= 0) STOP "ERROR ALLOCATING NOISE" PRINT*,'FINISHED ALLOCATING ARRAYS...' PRINT*,' ' END SUBROUTINE ALOC_ARRAY END MODULE B3_MODULE