       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
