C Copyright(c) 1997, Space Science and Engineering Center, UW-Madison
C Refer to "McIDAS Software Acquisition and Distribution Policies"
C in the file  mcidas/data/license.txt

C
C *** $Id: agetserv.f,v 1.52 1999/04/29 22:34:22 krauss Rel $ ***

c AGETSERV - ADDE image file line read server

c Remarks:
c      AGETSERV is intended to be executed via client applications
c      which read image file data. All communication is via a
c      control block embedded within the client/server transaction
c      protocol. The client interface to this module is through the
c      subroutine MCAGET.


      IMPLICIT NONE

      ! symbolic constants and shared data

      character*8   servername
      parameter (servername = 'AGETSERV')

      ! external functions

      INTEGER INDEX
      INTEGER M0CMDPARSE
      integer m0splice
      INTEGER m0sxdatasetinfo
      integer m0sxresolv
      integer m0istraceset
      integer m0sxgetclientrequest

      ! local variables

      CHARACTER*500 TMPREQ
      CHARACTER*500 REQST
      CHARACTER*500 group			! dataset group name
      CHARACTER*500 dataset			! dataset name
      CHARACTER*500 type			! dataset type
      CHARACTER*500 info			! dataset info
      CHARACTER*500 comment			! comment attached to dataset
      CHARACTER*120 A
      CHARACTER*72  B
      CHARACTER*32  NAME
      CHARACTER*24  PROGRAM
      CHARACTER*12  KIND
      INTEGER*2 I

      INTEGER ISTAT
      INTEGER J(64)
      INTEGER KREQ(125)
      INTEGER LENREQ
      integer LEN_TRIM
      integer LENCMD
      integer min_range				! min area number in dataset
      integer max_range				! max area number in dataset
      integer rc				! return code from function
      integer realflag				! flag used by m0sxdatasetinfo

      EQUIVALENCE(KREQ,REQST)

C
C - - ZERO UNUSED FIELDS IN CONTROL BLOCK
      CALL ZEROW(64,J)
C
C - - GET McIDAS ENVIRONMENT
      CALL INITBLOK(I)

      IF(I.NE.0) then

	 b =
     &  'Image data server unable to initialize McIDAS environment'

         call movcw(b,j(44))
	 j(43) = -117

	 goto 999

      endif
C
C - - READ REQUEST HEADER
      istat = m0sxgetclientrequest(j,reqst)

      istat = m0istraceset (reqst)
      call mctrace (1, servername, reqst)
C
C - - - ALWAYS PUT BEGINNING OF REQST BACK IN J
      A=REQST
      CALL MOVCW(A,J(11))
      CALL M0SXTRCE(A)
C
C-----check authorization
      CALL M0VSERV( J )

      istat = m0sxdatasetinfo(REQST,group,dataset,type,kind,info,
     &		comment,min_range,max_range,realflag)

c
c - tack info field back on the end of the request
c
      LENREQ = LEN_TRIM(REQST)
      TMPREQ = REQST(1:LENREQ)//' "'//info
      REQST = TMPREQ
c
c--- fail if m0sxdatasetinfo doesn't succeed....
c
      IF (ISTAT .LT. 0) THEN

	 write(b,FMT='(a27,1x,i4)')
     &     'm0sxdatasetinfo returns:',istat
	 call m0sxtrce(b)

         rc = m0splice(reqst,name)

	 if (rc .lt. 0) then
	    b = 'Invalid dataset name'//reqst
	    call movcw(b,j(44))
	    j(43) = -118
            goto 999
	 endif

	 b =
     &  'Image data server unable to resolve this dataset: '//name

         call movcw(b,j(44))
	 j(43) = -118

	 goto 999

      ENDIF

      call m0sxtrce(reqst)
C
C==========   CALL ACTUAL SERVER   ==========
      IF(KIND.EQ.'AREA') THEN
C     - - Initialize accounting
          CALL M0SXLOGI(J)
C     - - PARSE COMMAND
          CALL M0CMDPUT(M0CMDPARSE(REQST,LENCMD))
C---------call server
          CALL AGET( J, min_range, max_range)
c----
c   if this program is calling a Global Imaging (GI) server
c   then you have to do some funny things:  For one, the GI server
c     expects that the REQST string has been mangled by m0sxresolv,
c     so a call to that function is necessary.  Secondly, the subserver
c     program is all upcase, so don't do the mclocase that is done
c     otherwise...

      elseif (kind.eq.'GI') then

	  i = index(KIND,' ')-1
	  program = kind(1:i)//'AGET'
          KIND='AREA'
          istat = m0sxresolv(REQST,kind)

	  if (istat .lt. 0) then
	     b = 'Invalid dataset name'//reqst
	     call movcw(b,j(44))
	     j(43) = -118
	     goto 999
	  endif

          CALL   M0SUBSERV( J, PROGRAM, REQST)
C----------this return indicates an error
          J(43) = -114
          B='AGETSERV failed on exec of '//PROGRAM
          CALL MOVCW(B,J(44))

      ELSE
C---------call a server by exec() of a sub_server
          I=INDEX(KIND,' ')-1
          PROGRAM=KIND(1:I)//'AGET'
	  call mclocase(program)
          CALL   M0SUBSERV( J, PROGRAM, REQST)
C----------this return indicates an error
          J(43) = -114
          B='AGETSERV failed on exec of '//PROGRAM
          CALL MOVCW(B,J(44))
      ENDIF
C============================================

 999  CALL M0SXDONE(J)

      END

*$ Name:
*$	aget - Gets data from areas matching search criteria
*$
*$ Interface:
*$	subroutine
*$	aget(integer j, integer min_areanumber, integer max_areanumber)
*$
*$ Input:
*$	j		- communications block
*$	min_areanumber	- minimum area number in dataset
*$	max_areanumber	- maximum area number in dataset
*$
*$ Input and Output:
*$	none
*$
*$ Output:
*$	none
*$
*$ Remarks:
*$	This server does not do blowups, the work for blowups should
*$	be completed on the client side of the transaction.

      subroutine aget( j, min_areanumber, max_areanumber )

      IMPLICIT NONE

      include 'areaparm.inc'

      INTEGER   J(64)			! communications block

      ! symbolic constants and shared data

      CHARACTER*(*) VAS_CAL_FILE
      PARAMETER (VAS_CAL_FILE = 'VASTBLS')

      INTEGER MAXCALSIZ			! max word size of cal block
      PARAMETER (MAXCALSIZ = 10000)

      INTEGER MAXCARDS			! max # of comment cards
      PARAMETER (MAXCARDS = 500)

      INTEGER MAXTYP
      PARAMETER (MAXTYP = 20)

      INTEGER search_list(MAX_AREA_NUMBER)
      INTEGER work_array(MAX_AREA_NUMBER)
      INTEGER pad(10000)
      COMMON/STORE/work_array,search_list,pad  ! make room for big lines

      ! external functions

      CHARACTER*12 CFI
      CHARACTER*4  CLIT

      DOUBLE PRECISION DTOKHR
      DOUBLE PRECISION DTOKLL

      INTEGER   aranam
      INTEGER   IAND
      INTEGER   ICGET
      INTEGER   ISCHAR
      INTEGER   ISAN
      INTEGER   ISNGL
      INTEGER   KB1OPT
      INTEGER   KBPREP
      INTEGER   LIT
      INTEGER   LWFILE
      integer	mcargnum
      INTEGER   m0specs
      integer   mcargiyd
      integer   mcargihr
      INTEGER   MCARGINT
      INTEGER   MCARGSTR
      integer   mcdaytimetosec
      integer   mciydtocyd
      INTEGER   MFD
      INTEGER   NINT
      INTEGER   volnam

      ! local variables

      character*72   area_path
      character*12   area_file
      CHARACTER*256 ARGDUM
      CHARACTER*72  B
      CHARACTER*12  CALTYP
      CHARACTER*12  CBAND
      CHARACTER*12  CKEY
      CHARACTER*12  CLAT
      CHARACTER*12  CLON
      CHARACTER*12  COPT(5)
      CHARACTER*12  CSTYP
      CHARACTER*12  CTIM1
      CHARACTER*12  CTIM2
      CHARACTER*12  CTYP(MAXTYP)
      CHARACTER*12  GETAUX
      CHARACTER*12  GETDOC
      CHARACTER*12  UNITS
      CHARACTER*4   CINSRC
      CHARACTER*4   CSRC
      CHARACTER*4   NATIVE_UNITS

      integer   all
      integer   all_check
      INTEGER   AREA_DATE       !date of area in ccyyddd format
      integer   area_dir(65)
      integer   area_index
      integer   bband
      integer   bday
      integer   btim
      INTEGER	CARD(20)
      INTEGER	CALSIZ
      INTEGER   DEFBAND
      integer   eband
      integer   eday
      integer   etim
      integer   file_ok
      integer   filter_index
      integer   good_searchs
      INTEGER   I
      INTEGER   IAIN(64)
      INTEGER   IAOUT(64)
      INTEGER   IBAND
      INTEGER   IBUF(64)
      INTEGER   ICAL(MAXCALSIZ)
      INTEGER   ICARD
      INTEGER   ICOL
      INTEGER   IDAY
      INTEGER   IDUMMY
      INTEGER   IERR
      INTEGER   IHM2
      INTEGER   IHMM
      INTEGER   IELE
      INTEGER   IEMAX
      INTEGER   IER
      INTEGER   II
      INTEGER   ILIN
      INTEGER   ILMAX
      INTEGER   ILR
      INTEGER   IMGELE
      INTEGER   IMGLIN
      INTEGER   INAV(1024)
      INTEGER   IR
      INTEGER   IRET
      INTEGER   IRET1
      INTEGER   IRO
      INTEGER   IROW
      INTEGER   IS
      INTEGER   ISCAN
      INTEGER   ISTAT
      INTEGER   IV
      INTEGER   IVAL(5)
      INTEGER   IX
      INTEGER   IXTRA
      INTEGER   IY
      INTEGER   JA
      INTEGER   JCAL
      INTEGER   JCOL
      INTEGER   JJ
      INTEGER   JPAD
      INTEGER   JSEND
      INTEGER   KBAND
      INTEGER   KCAL
      INTEGER   KEYS(MAXTYP)
      INTEGER   KSEND
      INTEGER   LOC
      INTEGER   LWORD
      integer   max_areanumber
      integer   min_areanumber
      integer   max_relativenum
      integer   min_relativenum
      INTEGER   MWORD
      INTEGER   NABS
      INTEGER   NB
      INTEGER   NBPL
      INTEGER   NBYT
      INTEGER   NBYT4
      INTEGER   NJ
      INTEGER   NK
      INTEGER   NLNGTH
      INTEGER   NOPT
      INTEGER   NTYP
      INTEGER   PFXLEN
      integer   relatv
      INTEGER   search_ok
      INTEGER   SCALE(MAXTYP)
      INTEGER   SPAC
      integer   ss1
      integer   ss2
      INTEGER   STYPE
      integer   temp_areanum
      integer   temp_time
      INTEGER   time_check
      integer   total_areas
      INTEGER   TYPE(MAXTYP)
      INTEGER   VALID
      INTEGER   VERSION

      CHARACTER*12  CSU
      INTEGER       ISU(3)
      EQUIVALENCE  (CSU,ISU)

      ALL = lit('ALL ')
      call swbyt4(ALL, 1)

      CALL M0SXTRCE('AGET')
c
c--- poke uc to suppress all messages to stdout
c
      call puc(0, -31)		! sdest
      call puc(0, -32)		! edest
      call puc(0, -33)		! ddest

C------ parse command line

C------ beginning and ending satellite ids

      istat = mcargint(0, 'SS', 1, -1,  0, -1, ss1, argdum)
      istat = mcargint(0, 'SS', 2, ss1, 0, -1, ss2, argdum)

C------ day

      istat = mcargiyd(0, 'DAY', 1, -1,   0, -1, bday, argdum)
      istat = mcargiyd(0, 'DAY', 2, bday, 0, -1, eday, argdum)

C------ time

      istat = mcargihr(0, 'TIM.E', 1,   -1, 0, -1, btim, argdum)
      istat = mcargihr(0, 'TIM.E', 2, btim, 0, -1, etim, argdum)

C------ band

      istat = mcargint(0, 'BAN.D', 1,   -1, 0, -1, bband, argdum)
      istat = mcargint(0, 'BAN.D', 2,bband, 0, -1, eband, argdum)

C------ max and min relative numbers

      istat = mcargint(0, ' ', 2, 0, 0, -1, min_relativenum, argdum)
      istat = mcargint(0, ' ', 3, 0, 0, -1, max_relativenum, argdum)

      NABS=min_areanumber

C------ block

      loc = min_relativenum

      if (max_areanumber .lt. min_areanumber) then 
            max_areanumber = min_areanumber
      endif

      if (max_relativenum .lt. min_relativenum) then 
            max_relativenum = min_relativenum
      endif

C------ Legal Bounds

      if ((min_areanumber .lt. 1) .or.
     &    (max_areanumber .gt. MAX_AREA_NUMBER)) goto 1001

      IHMM=MFD(DTOKHR(CTIM1))
      IHM2=MFD(DTOKHR(CTIM2))

      istat = mcargiyd(0, 'DAY', 1, -1,  0, -1, iday, argdum)

      WRITE(B,902) btim,etim
 902  FORMAT('TIME BOUNDS ARE',2I10)
      CALL M0SXTRCE(B)

C------ Case of specifying a subgroup

      if (min_relativenum .eq. ALL) then
         all_check=1
         relatv = 0
         min_relativenum = 0

C------ Case of positive numbers

      elseif (min_relativenum .gt. 0) then
         relatv = 0
         total_areas = max_areanumber-min_areanumber+1

         if (max_relativenum .gt. total_areas) then
              max_relativenum = total_areas
         endif

         max_areanumber = max_relativenum + min_areanumber - 1
         min_areanumber = min_relativenum + min_areanumber - 1

         if (min_relativenum .gt. max_areanumber) goto 1001

C------- Case of time ordered (0 or negative)

      elseif (min_relativenum .le. 0) then
         relatv = 1
      endif

C-------Test bounds against legal area numbers

           if (relatv .eq. 0) then
              if (((min_areanumber .le. 0) .or.
     &             (min_areanumber .gt. MAX_AREA_NUMBER)) .or.
     &            ((max_areanumber .le. 0) .or.
     &             (max_areanumber .gt. MAX_AREA_NUMBER))) goto 1001
           endif

C-------- Filter out unwanted areas and sort newest to oldest

      good_searchs = 0
      file_ok = 0

      do 52 area_index=min_areanumber,max_areanumber

           istat = aranam(area_index,area_file)
           istat = volnam(area_file,area_path)

           if (lwfile(area_path) .eq. 1) then
                file_ok = file_ok + 1

                if (file_ok .gt. MAX_AREA_NUMBER) then
                     goto 1001
                else
                     call readd(area_index,area_dir)
                endif


C-------- Convert area date + time to total seconds

                if (relatv .eq. 1) then
                     istat = mciydtocyd(area_dir(4),area_date)
                     if (istat .lt. 0) goto 52

                     istat = mcdaytimetosec(area_date, area_dir(5),
     &                                      time_check)
                     if (istat .lt. 0) goto 52
                endif
C-------Test against search conditions

                search_ok=m0specs(ss1,ss2,bday,eday,btim,etim,
     &                          bband,eband,area_dir)
                if (search_ok .eq. 0) then
                     good_searchs = good_searchs + 1
                     search_list(good_searchs)=area_index

C------- Add time to list of times

                     if (relatv .eq. 1) then
                          work_array(good_searchs) = time_check
                     end if

                endif
            endif

52       continue

         if (good_searchs .eq. 0) goto 1001

C-------Time sort

           if (relatv .eq. 1) then
                if(good_searchs.lt.-min_relativenum+1) goto 1001
                do 61 area_index=1,good_searchs
                     do 51 filter_index=area_index,good_searchs
                         if (work_array(area_index) .ge.
     &                       work_array(filter_index))  goto 51

                         temp_time=work_array(area_index)
                         work_array(area_index)=work_array(filter_index)
                         work_array(filter_index)=temp_time

                         temp_areanum=search_list(area_index)
                         search_list(area_index)=
     &                           search_list(filter_index)
                         search_list(filter_index)=temp_areanum
 51                   continue
 61             continue
           end if

C------Determine the loop bounds for listing for time and non-based
C------requests

           if (relatv .eq. 1) then
               loc = search_list(-min_relativenum + 1)
           else
               loc = search_list(1)
           endif

C
C -   AT THIS POINT "LOC" IS THE AREA LOCATION IN ABSOLUTE TERMS
      WRITE(B,901) LOC
 901  FORMAT('RESOLVED AREA=',I5)
      CALL M0SXTRCE(B)
C
C -   GET  2 COPIES OF AREA DIRECTORY OF WINNING AREA
C     ONE AS SOURCE, OTHER AS TEMPLATE OF DESTINATION
      CALL READD(LOC,IAIN)
      IF(IAIN(1).LT.0) GOTO 1001
      CALL READD(LOC,IAOUT)
C
C -   INSERT RELATIVE LOCATION, AS INFO TO CLIENT
      IAOUT(1)=LOC-NABS+1
C
C--- get calibration units
C
      NATIVE_UNITS = clit(iain(53))
      istat = mcargstr(0, 'UNI.TS', 1, NATIVE_UNITS, units)

C
C--- get spacing value
C
      istat = mcargint(0, 'SPA.C', 1, 0,  0, -1, spac, argdum)
c
c--- if the requested spacing was 0 we
c--- want to return the native bytes per pixel
c

      if (spac .eq. 0) spac = iaout(11)

c
c--- If the bytes/pixel (spac) requested is larger than it
c--- it needs to be, send back in a more compact format
c--- and let the client (mcaget) deal with it

      if (version .ge. 1) then
         if (units .eq. 'BRIT') spac = 1
         if (units .eq. 'TEMP') spac = 2
         if (units .eq. 'ALB ') spac = 2
         if (units .eq. NATIVE_UNITS) spac = iaout(11)
      endif
c
c--- set the area directory to reflect the number
c--- of bytes per pixel that the server is returning
c
      iaout(11) = spac
c
c--- set the area directory to reflect the requested cal units
c
      iaout(53) = lit(units)
C
C--- set options for calls to araopt
C
      NOPT = 2

      COPT(1) = 'UNIT'
      COPT(2) = 'SPAC'

      IVAL(1) = LIT(UNITS)
      IVAL(2) = SPAC
C
C -   Use QTIR calibration if needed

      istat = mcargstr(0, 'CAL', 1, ' ', caltyp)

      if (caltyp (1:4) .eq. 'QTIR') then

	 NOPT = 3
	 COPT(3) = 'CALB'
	 IVAL(3) = LIT('QTIR')

      endif

C
C -   GET 'SU='

      istat = mcargstr(0, 'SU', 1, ' ', CSU)
C
C -   WILL THIS BE AN ALL-BAND OR A 1-BAND TRANSFER

      istat = mcargstr(0, 'STY.PE', 1, ' ', CSTYP)

      defband = isngl(iaout(19))

      istat = mcargint(0, 'BAN.D', 1, defband, 0, -1, iband, argdum)

      istat = mcargstr(0, 'BAN.D', 1, ' ', CBAND)
      IF(CBAND .EQ. 'ALL') IBAND=LIT('ALL ')
C
C -   CHECK FOR 1-BAND TRANSFER
      IF(IBAND.NE.LIT('ALL ')) THEN

c ------ check for list of BANDS
         if( mcargnum(0, 'BAN.D').gt.1 ) goto 1017

         IAOUT(14)=1
         IAOUT(15)=IAOUT(15)-IAOUT(51)
         IAOUT(51)=0
         IF(IBAND.GT.31) GOTO 1005
         IF(IAOUT(19).NE.0.AND.IBAND.EQ.0) THEN
C	 No band specified, on a multibanded image.
C	 Do not set a default band, instead error out.
	    goto 1016
         ENDIF
C
C -      BE SURE REQUESTED BAND IS IN AREA

         if (iband .le. 0) then
              kband = 0
         else
              kband = 2**(iband-1)
         endif

         IF(IAND(KBAND,IAOUT(19)).EQ.0.AND.IBAND.NE.0) GOTO 1005
         IAOUT(19)=KBAND
      ENDIF
C
C -   CHECK FOR 1-BYTE DATA
      IF(CSTYP.EQ.'VISR') THEN
         IAOUT(11)=1
         IAOUT(15) = IAOUT(15) - IAOUT(50) - IAOUT(51)
         IAOUT(50)=0
         IAOUT(51)=0
         IAOUT(52)=LIT('VISR')
         IAOUT(53)=LIT('BRIT')
         IF(IAOUT(57).EQ.0) IAOUT(57)=IAIN(52)

         UNITS = 'BRIT'
         SPAC = 1

         IVAL(1) = LIT(UNITS)
         IVAL(2) = SPAC

      ENDIF
      WRITE(B,101) LOC
 101  FORMAT('USING AREA ',I5)
      CALL M0SXTRCE(B)
C
C-    GET COORDINATES
      istat = mcargstr(0, ' ', 3, ' ', ckey)
C
C -   EARTH
      IF(CKEY(1:1).EQ.'E') THEN
         istat = mcargstr(0, ' ', 4, ' ', clat)
         istat = mcargstr(0, ' ', 5, ' ', clon)
         IY=MFD(DTOKLL(CLAT))
         IX=MFD(DTOKLL(CLON))
         CALL EARTH(LOC,IY,IX,IERR)
         IF(IERR.NE.0) GOTO 1003
C -   AREA
      ELSEIF(CKEY(1:1).EQ.'A') THEN

         istat = mcargint(0, ' ', 4, 0, 0, -1, imglin, argdum)
         istat = mcargint(0, ' ', 5, 0, 0, -1, imgele, argdum)

         IY=IAIN(6)+IAIN(12)*imglin
         IX=IAIN(7)+IAIN(13)*imgele
C -   SAT
      ELSE

         istat = mcargint(0, ' ', 4, iain(6), 0, -1, imglin, argdum)
         istat = mcargint(0, ' ', 5, iain(7), 0, -1, imgele, argdum)

         IY = imglin
         IX = imgele

      ENDIF
C
C -   RESOLUTION

      istat = mcargint(0, ' ', 6, 1, 0, -1, ir, argdum)

      istat = mcargint(0, 'LMA.G', 1, ir, 0, -1, ilr, argdum)
      istat = mcargint(0, 'EMA.G', 1, ir, 0, -1, ier, argdum)

      ILR = IABS(ilr)
      IER = IABS(ier)
C
C -   SIZE

      istat = mcargint(0, ' ', 7, 480, 0, -1, ilin, argdum)
      istat = mcargint(0, ' ', 8, 640, 0, -1, iele, argdum)

c
c--- determine if we're going to send a prefix
c
      istat = mcargstr(0, 'DOC', 1, 'N', getdoc)

      PFXLEN = IAOUT(15)
      IAOUT(15) = IAOUT(15) - IAOUT(49)
      IF(IAOUT(36) .NE. 0) THEN
         IAOUT(15) = IAOUT(15) - 4
         IAOUT(36) = 0
      ENDIF
      IAOUT(49) = 0
c
c--- Should we send the DOC?
c--- If DOC=YES, send the DOC 
c--- If SIZE=ALL, send the DOC 
c--- Note, iele=99999 denotes that the entire image is requested 
c--  by requesting SIZE=ALL or SIZE=SAME. If SIZE=SAME
c--- and STYP=VISR is requested, the doc should not be sent.
c
      if ((getdoc(1:1) .eq. 'Y') .or. ((iele .eq. 99999)
     &      .and. (cstyp(1:4) .ne. 'VISR'))) then

          IAOUT(49) = IAIN(49)
          IAOUT(15) = PFXLEN
          IAOUT(36) = IAIN(36)

      ENDIF

      NJ=0
      NK=0
C
C -   CALCULATE STARTING UPPER-LEFT CORNER
      IF(CKEY(2:2).EQ.'C') THEN
         NJ=(ILIN-1)/2
         NK=(IELE-1)/2
      ELSEIF(CKEY(2:2).EQ.'D') THEN
         NJ=IY-1
         NK=IX-1
      ENDIF
C
      IY=IY-ILR*NJ*IAIN(12)
      IX=IX-IER*NK*IAIN(13)
C
      IROW=NINT(REAL(IY-IAIN(6))/IAIN(12))
      ICOL=NINT(REAL(IX-IAIN(7))/IAIN(13))
C
C -----------   ADJUST OUTPUT AREA DIRECTORY ENTRIES
C
C-----STARTING LINE AND ELEMENT
      IAOUT(6)=IAIN(6)+IROW*IAIN(12)
      IAOUT(7)=IAIN(7)+ICOL*IAIN(13)
C
C-----LINE AND ELEMENT SIZE; DONT GO OFF RIGHT SIDE OR BOTTOM
      ILMAX=(IAIN(9)-IROW)/ILR
      IEMAX=(IAIN(10)-ICOL)/IER
c
c--- check to see if starting position requested is
c--- past the end of the image
c
      IF (ILMAX .LE. 0 .OR. IEMAX .LE. 0) GOTO 1015
c
c--- check to see if portion of image requested
c--- lies before the actual image domain
c
      IF ((IROW + ILIN*ILR) .LE. 0) GOTO 1015
      IF ((ICOL + IELE*IER) .LE. 0) GOTO 1015

      IF(ILIN.GT.ILMAX) ILIN=ILMAX
      IF(IELE.GT.IEMAX) IELE=IEMAX
C
      IF(IELE.LT.4) IELE=4
C
C-----DECLARE LINE AND ELEMENT SIZE
      IAOUT(9)=ILIN
      IAOUT(10)=IELE
C-----AREA RULES: NUMBER OF ELEMENTS MUST BE DIVISIBLE BY 4
      IAOUT(10)=4*((IAOUT(10)+3)/4)
      IXTRA=IAOUT(10)-IELE
C
C-----LINE AND ELEMENT RESOLUTION
      IAOUT(12)=IAIN(12)*ILR
      IAOUT(13)=IAIN(13)*IER
C
      WRITE(B,102) IAOUT(6),IAOUT(7)
 102  FORMAT('IMAGE COORDINATES',2I10)
      CALL M0SXTRCE(B)
C
C -   CALIBRATION CODICIL
      JCAL=1
      IF(IAIN(63).NE.0) JCAL=0
c
c--- calculate size of calibration codicil
c
      CALSIZ = IAIN(34) - IAIN(63)
      IF(IAIN(63) .EQ. 0) CALSIZ = 0
c
c--- check to make sure we can handle this cal block
c

      IF (CALSIZ .GT. MAXCALSIZ*4) GOTO 1014

C
C-----JCAL=0 MEANS A CODICIL IS PRESENT
C-----KCAL=1 MEANS A CAL CODICIL WILL BE SENT
C
      IF(CSTYP .EQ. 'VISR') THEN
         KCAL=0
      ELSE IF(CLIT(IAIN(52)).EQ.'VISR') THEN
         KCAL=0
      ELSE IF(JCAL.EQ.0) THEN
         KCAL=1
      ELSE
         KCAL=0
      ENDIF
C
C-    NAVIGATION CODICIL
      NLNGTH=128
      DO 6 JA=1,128
 6    INAV(JA)=0
C
C------READ CODICIL, UP TO 640 WORDS
 20   IF(IAIN(35).NE.0) CALL ARAGET( LOC  ,IAIN(35),NLNGTH*4,INAV)
      IF(INAV(NLNGTH).NE.LIT('MORE').OR.NLNGTH.EQ.640) GOTO 21
      NLNGTH=NLNGTH+128
      GOTO 20
C
C -   LENGTH OFFSET TERMS
 21   IAOUT(34)=256+4*NLNGTH+CALSIZ*KCAL
      IAOUT(35)=256
      IAOUT(63)=256+4*NLNGTH
      IF(KCAL.EQ.0) IAOUT(63)=0
      ICARD=0
C
C -   COMMENT-CARDS
 22   IF(ICGET(LOC,CARD).NE.0) GOTO 23
      ICARD=ICARD+1
      GOTO 22
C
C     REWIND COMMENT CARD READ POINTER
 23   IV=ICGET(0,CARD)
C
C -   REDUCE PATHALOGICAL CASE
      IF(ICARD .GT. MAXCARDS) ICARD=0
      IAOUT(64)=ICARD
C
C -   DID WE NEED A CAL CODOCIL, BUT THE SOURCE AREA DIDNT HAVE ONE?
      IF(JCAL.NE.0) THEN
         IF(IAIN(52).EQ.LIT('AAA '))GOTO 1006
         IF(IAIN(52).EQ.LIT('PRD '))GOTO 1006
         IF(IAIN(52).EQ.LIT('QTIR'))GOTO 1006
      ENDIF

c
c--- send auxillary information if requested
c
      istat = mcargstr(0, 'AUX', 1, 'N', getaux)

      if (getaux(1:1) .eq. 'Y') then

	 STYPE = IAIN(52)
	 IF (IAIN(57) .NE. 0) STYPE = IAIN(57)

         IS=KBPREP(1, STYPE)

         IF (IS .NE. 0) THEN
c
c--- we still want to send data that doesn't have a cal codicil
c--- as long as the units requested are the same as what is contained
c--- in the image.
c
	    IF(UNITS(1:4) .NE. NATIVE_UNITS(1:4)) GOTO 1012

            iaout(58) = lit('    ')
            iaout(59) = 1
	    GOTO 500

         ENDIF

C--- INITIALIZE VALID FLAG TO "IN" VALIDATE CALIBRATION UNITS
         VALID    = 0

C--- PICK UP CALIBRATION TYPES FOR THIS CALB
         IBUF(1)  = IAOUT(3)
         IBUF(2)  = IAOUT(4)
         IBUF(3)  = IAOUT(5)
         IBUF(4)  = IBAND
         IBUF(17) = LOC
         IS=KB1OPT('KEYS',IBUF,KEYS)


C--- IF ALL BANDS ARE REQUESTED, ALL SCALE FACTORS ARE SET TO 1 AND ALL
C--- UNITS ARE VALIDATED, REGARDLESS OF HOW KB1OPT HANDLES BAND="ALL"
         IF(IBAND.EQ.LIT('ALL')) THEN
            VALID=1
            DO II=1,MAXTYP
               SCALE(II)=1
            END DO
         END IF


C--- MAKE CALL TO KB1OPT WITH OPTION INFO TO PICK UP THE SCALING FACTORS
C--- AND LABELS FOR THE CALIBRATION TYPES
         IBUF(1) = IBAND
         IBUF(2) = IAOUT(3)
         IBUF(3) = IAOUT(52)
         IS=KB1OPT('INFO',IBUF,TYPE)


C--- IF THERE IS NO INFO OPTION FOR THIS CALB, SET THE SCALING TO 1
C--- OTHERWISE USE THE SCALING PROVIDED BY THE CAL MODULE
         NTYP=KEYS(1)
         IF(TYPE(1).LE.0) CALL MOVW(NTYP+1,KEYS,TYPE)

         DO 10 II=1,NTYP

            JJ=II+1
            CTYP(II)=CLIT(TYPE(JJ))

C  CHECK KEYS BUFFER IF 'PROD' FOUND

            IF(CTYP(II)(1:4).EQ.'PROD') THEN
               TYPE(JJ)=KEYS(JJ)
               CTYP(II)=CLIT(TYPE(JJ))
            ENDIF

            IF (IS.LT.0) THEN
c
c--- there is no info option in the cal module
c
               CTYP(II+NTYP) = ' '
               SCALE(II)  = 1

            ELSE
c
c--- there is an info option in the cal module
c
               CTYP(II+NTYP)=CLIT(TYPE(JJ+NTYP))

               SCALE(II)=TYPE(JJ+2*NTYP)

            ENDIF

10       CONTINUE

         do 15 II=1,ntyp
c
c--- set values in area directory
c---
c--- word 58: units of values returned (e.g. K, ALB, etc.)
c--- word 59: scaling of values returned (e.g. 1, 10, 100, etc.)
c
	    jj = ii + 1
	    if (clit(type(jj)) .eq. units(1:4)) then
	       valid = 1
               iaout(58) = lit(ctyp(II+ntyp))
               iaout(59) = scale(II)
            endif

 15      continue
c
c--- check to make sure we have valid units and scaling
c
         if (valid .eq. 0) goto 1012

      endif

 500  CSRC=CLIT(IAOUT(52))
      CINSRC=CLIT(IAIN(52))
c
c--- check for the existence of the 'VASTBLS' file
c
      IF (CINSRC(1:3) .EQ. 'VAS') THEN
	 ISTAT = LWFILE(VAS_CAL_FILE)
c
c--- if the file doesn't exist, error out
c
	 IF (ISTAT .EQ. 0) GOTO 1013

      ENDIF
C
C-----OPEN AREA, AND DECLARE TYPE OF TRANSFER
      CALL OPNARA(LOC)
      IF(CSU.NE.' ') IVAL(1)=LIT('MODB')
      CALL ARAOPT(LOC, NOPT, COPT, IVAL)
      IF(CSU.NE.' ') THEN
         IRET1=KB1OPT('BRKP',ISU,IDUMMY)
         IF(IRET1.NE.0) GOTO 1007
      ENDIF
C
C==============================================
C
C     AT THIS POINT, WE ARE COMMITTED TO SEND
C
C -   TOTAL BYTES

      NBPL=IAOUT(10)*SPAC*IAOUT(14)+IAOUT(15)
      NBYT=80*IAOUT(64)+IAOUT(34)+IAOUT(9)*NBPL
      WRITE(B,104) NBYT
 104  FORMAT('SENDING ',I8,' BYTES')
      CALL M0SXTRCE(B)
C
C -   SEND OUT DATA
      NB=NBYT
      CALL SWBYT4(NB,1)
      CALL M0SXSEND(4,NB)
      J(41)=NBYT
C
C -   CHANGE DEST TO TRANSMISSION FORMAT
      CALL SWBYT4(IAOUT(1),20)
      IF(ISCHAR(IAOUT(21)).EQ.0) CALL SWBYT4(IAOUT(21),1)
      CALL SWBYT4(IAOUT(22),3)
      CALL SWBYT4(IAOUT(33),19)
      CALL SWBYT4(IAOUT(54),1)
      CALL SWBYT4(IAOUT(59),6)
C
C -   ARADIR


      CALL M0SXSEND(256,IAOUT)
C
C -   RESTORE FORMAT SO WE CAN USE CONTENTS
      CALL SWBYT4(IAOUT(1),20)
      IF(ISCHAR(IAOUT(21)).EQ.0) CALL SWBYT4(IAOUT(21),1)
      CALL SWBYT4(IAOUT(22),3)
      CALL SWBYT4(IAOUT(33),19)
      CALL SWBYT4(IAOUT(54),1)
      CALL SWBYT4(IAOUT(59),6)
      CALL M0SXTRCE('SENT ARADIR')
C
C -   NAV
      DO 24 JA=1,NLNGTH
      IF(INAV(1).ne.lit('GMSX').and.ISCHAR(INAV(JA)).EQ.0)
     x   CALL SWBYT4(INAV(JA),1)
 24   CALL M0SXSEND(4,INAV(JA))
      CALL M0SXTRCE('SENT NAV')
      IF(KCAL.EQ.0) GOTO 26
C
C -   CAL
      CALL ARAGET( LOC, IAIN(63), CALSIZ, ICAL)
      DO 25 JA=1,CALSIZ/4
      IF (ISAN(CLIT(ICAL(JA))) .EQ. 0) CALL SWBYT4(ICAL(JA),1)
 25   CALL M0SXSEND(4,ICAL(JA))
      CALL M0SXTRCE('SENT CAL'//cfi(calsiz))
C
C -   BODY
 26   ISCAN=-1
      IRO=IROW
C
C-----LOOP OVER NUMBER OF LINES
      DO 30 JA=1,IAOUT(9)
c
c--- send prefix if requested
c

      IF(IAOUT(15).NE.0) THEN
         CALL REDPFX(LOC,IRO,work_array)
         II=1

         IF(IAIN(36).NE.0) THEN
              CALL SWBYT4(work_array(1),1)
              II=2
          ENDIF
          IF(IAIN(49).NE.0) THEN
              IF(CSRC.EQ.'AAA ') 
     &            CALL SWBYT4(work_array(II),IAIN(49)/4)
              IF(CSRC.EQ.'VAS ')
     &             CALL SWBYT4(work_array(II),IAIN(49)/4)
              IF(CSRC.EQ.'MSAT')
     &             CALL SWBYT2(work_array(II),IAIN(49)/2)
              IF(CSRC.EQ.'QTIR')
     &             CALL SWBYT2(work_array(II),IAIN(49)/2)
              IF(CSRC.EQ.'TIRO')
     &             CALL SWBYT2(work_array(II),IAIN(49)/2)
              IF(CSRC.EQ.'AVHR')
     &             CALL SWBYT2(work_array(II),IAIN(49)/2)
              IF(CSRC.EQ.'MI  ')
     &             CALL SWBYT2(work_array(II),IAIN(49)/2)
              II=II+IAOUT(49)/4
          ENDIF
          IF(IAIN(50).NE.0) THEN
              IF(CSRC.EQ.'AAA ') 
     &             CALL SWBYT2(work_array(II),IAIN(50)/2)
              IF(CSRC.EQ.'VAS ')
     &              CALL SWBYT2(work_array(II),IAIN(50)/2)
              IF(CSRC.EQ.'MI  ')
     &              CALL SWBYT2(work_array(II),IAIN(50)/2)
              IF(CSRC.EQ.'QTIR')
     &              CALL SWBYT4(work_array(II),IAIN(50)/4)
              IF(CSRC.EQ.'TIRO')
     &              CALL SWBYT4(work_array(II),IAIN(50)/4)
              IF(CSRC.EQ.'AVHR')
     &              CALL SWBYT4(work_array(II),IAIN(50)/4)
          ENDIF

          IF(IAIN(15) .NE. IAOUT(15)) THEN
             CALL MOVB(IAIN(15), work_array(1), search_list(1),0)

             MWORD = 1
             LWORD = 1

             IF( IAOUT(36) .NE. 0) LWORD = LWORD + 1
             IF( IAIN(36)  .NE. 0) MWORD = MWORD + 1

             DO 50 I=49, 51

             IF( IAOUT(I) .NE. 0)
     &            CALL MOVB(IAOUT(I),
     &                      search_list(MWORD), work_array(LWORD),0)

             MWORD = MWORD + IAIN(I)/4
             LWORD = LWORD + IAOUT(I)/4
50           CONTINUE

          ENDIF
          CALL M0SXSEND(IAOUT(15),work_array(1))
      ENDIF

C----------------------------------------------------------------
C                   END-OF-PREFIX
C
      JCOL=ICOL
c
c--- determine the number of bytes to send according to
c--- the number of elements, the number of bytes per element
c--- requested by araopt, and the number of bands per line
c

      JSEND=IELE*SPAC*IAOUT(14)
      JPAD=IXTRA*SPAC*IAOUT(14)

C -   CASE OF STARTING TOO FAT LEFT... ADD ZEROS
      IF(ICOL.LT.0) THEN
          JCOL=0

          KSEND=(-ICOL/IER)*SPAC*IAOUT(14)

          IF(KSEND.GT.JSEND) KSEND=JSEND
          JSEND=JSEND-KSEND
          CALL ZEROW(KSEND/4+1,work_array)
          CALL M0SXSEND(KSEND,work_array)
      ENDIF
C
C-----READ DATA FROM AREA
      CALL REDARA(LOC,IRO,JCOL,IAOUT(10)*IER,IBAND,work_array)
C
C-----REDUCE RESOLUTION
      CALL M0RESRED(work_array,IER,IAOUT(10),SPAC*IAOUT(14))
C
C---------Do in two batches, in case it is large
      NBYT4=IAOUT(14)*IAOUT(10)/2
c
c--- switch bytes according to the number of bytes per element
c--- requested by araopt
c
      if (SPAC .eq. 2) then
         CALL SWBYT2(work_array(1),NBYT4)
         CALL SWBYT2(work_array(1+NBYT4/2),NBYT4)
      elseif (SPAC .eq. 4) then
         CALL SWBYT4(work_array(1),NBYT4)
         CALL SWBYT4(work_array(1+NBYT4),NBYT4)
      endif

      IF(JSEND.GT.0) CALL M0SXSEND(JSEND,work_array)
      CALL ZEROW(64,work_array)
      IF(JPAD.NE.0)  CALL M0SXSEND(JPAD,work_array)
C
C -   POINT TO THE NEXT SOURCE LINE
 30   IRO=IRO+ILR
C-------------------------------------------------------------------
C      END-OF-TRANSMITTING LINES
C
C -   COMMENTS
      IF(ICARD.EQ.0) GOTO 99
      DO 91 JA=1,ICARD
      IV=ICGET(LOC,CARD)
 91   CALL M0SXSEND(80,CARD)
      IV=ICGET(0,CARD)
 99   CALL CLSARA(LOC)

      GOTO 2000
C
C -   ERROR RETURNS
 1001 B='No images satisfy the selection criteria'
      IRET=-11000
      goto 1999

 1003 B = 'Unable to initialize navigation for this image'
      IRET=-11001
      IF(IERR.EQ.2) THEN
          IRET=-11002
          B='The requested Earth location is not contained in the image'
      ENDIF
      GOTO 1999

 1005 B='Band not present'
      IRET=-11003
      GOTO 1999

 1006 B='Cal not present'
      IRET=-11004
      GOTO 1999

 1007 B='Stretch table specified in SU= does not exist on server'
      IRET=-11005
      GOTO 1999

 1010 B='Maximum number of images for a group exceeded'
      IRET=-11006
      GOTO 1999

 1012 B='Units requested are not available for this image'
      IRET=-11007
      GOTO 1999

 1013 B='The VASTBLS file is missing. Contact your Server Administrator'
      IRET=-11008
      GOTO 1999

 1014 B='The calibration block for this image is too large.'
      IRET=-11009
      GOTO 1999

 1015 B='The requested portion of the image does not exist'
      IRET=-11010
      GOTO 1999

 1016 B='Band keyword required for multi-banded image'
      iret=-11011
      goto 1999

 1017 B='Server does not support BAND lists'
      iret=-11012
      goto 1999

c --- move error message into comm buffer
1999  J(43)=IRET
      CALL MOVCW(B,J(44))

2000  continue

c --- close open files (kills 0 length files)
      call lwmop

      RETURN
      END



      SUBROUTINE EARTH(AREA,IY,IX,ERRFLG)
      IMPLICIT INTEGER(A-Z)
      REAL FLALO,XLIN,XELE,XLAT,XLON,ZDUM
      IF(NVSET('AREA',AREA).NE.0) THEN
         ERRFLG=1
         RETURN
      ENDIF
      XLAT=FLALO(IY)
      XLON=FLALO(IX)
      IF(NV1EAS(XLAT,XLON,0.,XLIN,XELE,ZDUM).NE.0) THEN
         ERRFLG=2
         RETURN
      ENDIF
      IY=IROUND(XLIN)
      IX=IROUND(XELE)
      ERRFLG=0
      RETURN
      END

      FUNCTION ISNGL(I)
C     IS THIS A 1-BAND AREA EXPRESSION ?
      ISNGL=0
      IF(I.EQ.1) ISNGL=1
      DO 1 JA=2,31
      IF(I.EQ.2**(JA-1)) ISNGL=JA
 1    CONTINUE
      RETURN
      END
