GC_TITLE:   OPCUBE:  Open NIMS PDS-labelled multi-dimensional array fileC MC_ARGS:    FCB    (128) I4   [B] File control block [future ref: NIMSFCB.TXT],C				 FCB should be initialized with zeroes.)C				 Only FCB(1) may be set by the user.3C				  FCB(1)   Fortran unit (default 1) [settable]&C					    Set this to avoid conflicts.3C				  FCB(26)  last label byte filled (before END)'C				  FCB(31)  number of axes in array4C				  FCB(32-35) array dimensions - 1st to 4th axes*C					     (first axis is fastest varying)*C				  FCB(36)  core item type:  1 integer+C					    2 unsigned integer  3 real number.C					    4 complex number  5 character string(C				  FCB(37)  core item length (bytes)"C				  FCB(38)  core exclude value'C	   FLSPEC	CHAR [I] File specificationJC	   SBSPEC (2,4)	I4   [I] Subspec: min/max in each axis (not implemented)5C				  May possibly be changed to CHAR string in GARP-C				  notation to define any "virtual" cube.AC	   IOTYPE	I4   [I] Input/Output type: 0 read, 1 update, 2 write?C	   LABEL	CHAR [B] File label: output for read & update modes,C					     input for write modeGC	   IR           I4   [O] Return code:  0 OK, -1 label keyword missingC				 -2 invalid keyword value0C				 >0 VMS error code passed by NIMS I/O rtnesC DC_KEYS:    FILE_I/O, FILE_LABEL, CUBE, ARRAY, PDS, NIMS, SYSTEM, VMSC JC_DESCR:   OPCUBE and associated entry points and routines (CLCUBE, GTRUN,EC	   GTCUBE, GTIMAG, GTLINE, GTSAMP, GTBRIK, GTNMSL and correspondingGC	   PT____ entries) handle I/O for NIMS multi-dimensional array files.?C	   The data in these files is described by a PDS label at theEC	   beginning of the file.  Label interpretation is done by a set ofCC	   PDS-label parsing routines.  Data I/O is done by a set of NIMSJC	   standard direct access file I/O routines (NOPEN,NCLOSE,NREAD,NWRITE).CC	   Eventually, this set of routines will transparently accomodate=C	   arrays already in memory, as in a mapped global section.CCC	   OPCUBE is the entry point for opening a NIMS multi-dimensionalGC	   array file for reading, updating or writing.  CLCUBE, GTRUN, PTRUN*C	   are entry points in the same routine.CJC_FILES:   NIMS multi-dimensional array files are an implementation of theGC	   PDS Qube file proposal.  See "Qube File and PDS Label Extensions -CC	   Proposal" by R. Mehlman and H. H. Kieffer, 9th draft, 14apr87.AC	   The PDS labels are summarized in the same document, and will3C	   be fully described in a forthcoming one.	<tbd>HC	   NIMS standard files are described in the "NIMS System Design" (NSD)BC	   document, and summarized in the internal documentation of the)C	   NIMS file I/O routines (NOPEN, etc.)C EC_CALLS:   NOPEN,NCLOSE,NREAD,NWRITE,GLVALI,GLVECI,GTKVAL,MOVE1,FILL4C;C_LIMITS:  Array ("cube") presently limited to 4 dimensions@C	   Core of array not yet distinguished from prefix/suffix area:C	   Files restricted to fixed-length records of 512 bytes9C	   Access to mapped global sections not yet implemented0C	   SBSPEC ("virtual cube") not yet implementedCC	   Addition of history entry to file at close not yet implementedCC_BUGS:C PC_HIST:    07apr86  R Mehlman (RMX) UCLA/IGPP  ORIGINAL VERSION (old NIMS label)DC          14apr86  RMX  Replaced calls to NGET/NPUT by NREAD/NWRITENC          18apr86  RMX  Added GTRUN/PTRUN, separated out GTCUBE, GTIMAG, etc.7C	   01may87  RMX  GTRUN/PTRUN MOD function usage fixed5C	   14jul87  RMX  Modified to read PDS-labelled cube=C	   09aug87  RMX  NIMS standard internal documentation addedJC	   13aug87  RMX  Call to GLVALN replaced by call to GLVECI (name change)JC	   19aug87  RMX  Array dimensions gotten from AXIS_ITEMS, not CORE_ITEMSBC	   20aug87  RMX  Alternate keyword added for ITEM_BITS in OPCUBEHC	   21sep87  RMX  Fix to Write mode: write dummy last block after open,5C			  then change mode in FCB to Update (required for2C			  Fortran); plus improvements to documentationCC_PAUSE:C:      SUBROUTINE OPCUBE(FCB,FLSPEC,SBSPEC,IOTYPE,LABEL,IR)'      CHARACTER*(*) FLSPEC,LABEL,HISTRY"      CHARACTER*16 TYPE, TYPTAB(5)B     1 /'INTEGER','UNSIGNED_INTEGER','REAL','COMPLEX','CHARACTER'/7      BYTE IBUF(1),JBUF(512)				! Note: 512 byte blocksB      INTEGER*4 IOTYPE,IR,LBUF,SBSPEC(2,4),FCB(128)     ! FCB(1) ?/      DATA MAXTYP /5/ , MAXDIM /4/ , LBLK /512/C      DATA LKP,LNDIM,LDIM,LTYPE,LLEN,LEXCL		! temp. FCB assignments+     1    / 26,   31,  32,   36,  37,   38/CC  OPCUBE ENTRY=C  OPEN NIMS (PDS) STANDARD FILE, READ OLD OR WRITE NEW LABEL,      CALL NOPEN(FCB,FLSPEC,IOTYPE,LABEL,IR)      IF (IR.NE.0) GO TO 704C  CONSTRUCT CUBE SECTION OF NIMS LABEL TABLE IN FCB      KPOS=FCB(LKP)B      CALL GLVALI(LABEL,KPOS,'AXES',FCB(LNDIM),IR)         	! NDIM      IF (IR.LT.0) GO TO 717      IF (FCB(LNDIM).GT.MAXDIM) GO TO 71			! NDIM CHECK<      CALL FILL4(FCB(LDIM),MAXDIM,0)			   ! DEFAULT DIMS = 0M      CALL GLVECI(LABEL,KPOS,'AXIS_ITEMS',FCB(LNDIM),FCB(LDIM),IR) ! GET DIMS      IF (IR.LT.0) GO TO 71>      IF (IR.NE.FCB(LNDIM)) GO TO 71			   ! CHECK AGAINST AXESH      CALL GLVALI(LABEL,KPOS,'ITEM_BITS',IBITS,IR)	   ! 2 ALTERNATE KEYSD      IF (IR.LT.0) CALL GLVALI(LABEL,KPOS,'CORE_ITEM_BITS',IBITS,IR)      IF (IR.LT.0) GO TO 71      FCB(LLEN)=IBITS/8K      CALL GTKVAL(LABEL,KPOS,'CORE_ITEM_TYPE',TYPE,IR)          ! ITEM-TYPE      IF (IR.LT.0) GO TO 155      DO 15 I=1,MAXTYP'        IF (TYPE.EQ.TYPTAB(I)) GO TO 16 15   CONTINUE# 155  TYPE='INTEGER'						! DEFAULT	      I=1M 16   FCB(LTYPE)=I                                         ! TYPE CODE TO FCB0C  FOLLOWING MUST BE CHANGED FOR REAL DATA TYPESN      CALL GLVALI(LABEL,KPOS,'CORE_EXCLUDE_VALUE',FCB(LEXCL),IR) ! EXCLUDE VAL
      IR=0#C  IS THIS WRITE (FIRST TIME) MODE?      IF (IOTYPE.NE.2) GO TO 708C  YES, WRITE DUMMY LAST BLOCK AND CHANGE TO UPDATE MODE
      NI=1      DO 19 I=1,FCB(LNDIM)& 19   NI=NI*FCB(LNDIM+I)					! # ITEMS;      IBLK=(NI*FCB(LLEN)+LBLK-1)/LBLK+FCB(3)			! LAST BLOCK%      CALL NWRITE(FCB,IBLK,1,JBUF,IR))      FCB(2)=1						! TEMP - RESET IOTYPE      GO TO 70CHC_TITLE:   CLCUBE:  Close NIMS PDS-labelled multi-dimensional array fileC EC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)%C	   LABEL	CHAR [B] PDS label of fileBC	   HISTRY	CHAR [I] History entry to be added to file (not impl.)$C	   IR		I4   [O] Return code:  0 OKCOC_DESCR:  Close NIMS multi-dimensional array file; update label and add historyC	  entry unless read mode.CC_PAUSE:C'      ENTRY CLCUBE(FCB,LABEL,HISTRY,IR)C&      CALL NCLOSE(FCB,LABEL,HISTRY,IR)      GO TO 70CNC_TITLE:   GTRUN:  Get arbitrary "run" of consecutive elements from array fileCEC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)HC	   IELEM        I4   [I] First element of requested "run", where first/C				  element of array is 1 (i.e. 1-dim index)@C	   NELEM        I4   [I] Number of consecutive elements to get:C	   IBUF   (*)   BYTE [O] Buffer for returned run of dataCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enuf9C	   IR		I4   [O] Return code: 0 OK, -2 buffer too small, C						    >0 VMS I/O error codeCJC_DESCR:  Get run of consecutive elements from array file - designed to beDC	  called for longest set of consecutive elements possible in order9C	  to maximize I/O efficiency.  Assumes 512 byte blocks.CC_PAUSE:C/      ENTRY GTRUN(FCB,IELEM,NELEM,IBUF,LBUF,IR)CE      ILEN=FCB(LLEN)                            ! ITEM LENGTH (BYTES)?      NBYTES=NELEM*ILEN                         ! TOTAL # BYTESD      IF (NBYTES.GT.LBUF) GO TO 73              ! BUFFER BIG ENOUGH?K      NLBLKS=FCB(3)                             ! # LABEL BLOCKS ** TEMP **A      IPERB=LBLK/ILEN                           ! ITEMS PER BLOCK?      IBLK1=NLBLKS+(IELEM+IPERB-1)/IPERB        ! INITIAL BLOCKM      I1=MOD(IELEM-1,IPERB)+1                   ! FIRST ITEM IN INITIAL BLOCK>      LELEM=IELEM+NELEM-1                       ! LAST ELEMENT=      IBLK2=NLBLKS+(LELEM+IPERB-1)/IPERB        ! FINAL BLOCKJ      I2=MOD(LELEM-1,IPERB)+1                   ! LAST ITEM IN FINAL BLOCKK      K=1                                       ! INIT PTR TO USER'S BUFFERC      IBLK=IBLK1                                ! SET FOR 1ST BLOCKJ      IF (I1.EQ.1.AND.NBYTES.GE.LBLK) GO TO 20  ! BRANCH IF 1ST BLOCK FULLC  READ FIRST PARTIAL BLOCKK      CALL NREAD(FCB,IBLK,1,JBUF,IR)            ! READ 1ST BLOCK TO INT BUF=      IF (IR.NE.0) GO TO 70                     ! READ ERROR?A      NB1=(IPERB-I1+1)*ILEN                     ! # BYTES TO XFERmL      IF (NB1.GT.NBYTES) NB1=NBYTES             ! CUT IF ENTIRE RUN IN BLOCK<      J1=(I1-1)*ILEN+1                          ! FIRST BYTEP      CALL MOVE1(JBUF(J1),IBUF(K),NB1)          ! XFER PARTIAL BLK TO USER'S BUFM      IF (NB1.EQ.NBYTES) GO TO 70               ! QUIT IF ENTIRE RUN IN BLOCK2K      K=K+NB1                                   ! BUMP PTR TO USER'S BUFFERr<      IBLK=IBLK+1                               ! BUMP BLOCKC  WHOLE BLOCKS LEFT?E 20   NBLKS=(NBYTES-K+1)/LBLK                   ! # WHOLE BLOCKS LEFT@      IF (NBLKS.LE.0) GO TO 22                  ! BRANCH IF NONE#C  YES, READ WHOLE BLOCKS IN 1 GULPO      CALL NREAD(FCB,IBLK,NBLKS,IBUF(K),IR)     ! READ WHOLE BLKS TO USER'S BUF=      IF (IR.NE.0) GO TO 70                     ! READ ERROR?K      K=K+NBLKS*LBLK                            ! BUMP PTR TO USER'S BUFFERC  ANYTHING LEFT?D      IF (K.GT.NBYTES) GO TO 70                 ! BRANCH IF ALL DONE<      IBLK=IBLK+NBLKS                           ! BUMP BLOCK C  YES, READ FINAL PARTIAL BLOCKL 22   CALL NREAD(FCB,IBLK,1,JBUF,IR)            ! READ LAST BLOCK TO INT BUF=      IF (IR.NE.0) GO TO 70                     ! READ ERROR?P      CALL MOVE1(JBUF(1),IBUF(K),I2*ILEN)       ! XFER PARTIAL BLK TO USER'S BUF      GO TO 70CLC_TITLE:   PTRUN:  Put arbitrary "run" of consecutive elements to array fileCEC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)HC	   IELEM        I4   [I] First element of requested "run", where first/C				  element of array is 1 (i.e. 1-dim index)@C	   NELEM        I4   [I] Number of consecutive elements to put7C	   IBUF   (*)   BYTE [I] Buffer for data to be outputCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enuf9C	   IR		I4   [O] Return code: 0 OK, -2 buffer too small, C						    >0 VMS I/O error codeCJC_DESCR:  Write run of consecutive elements to array file - designed to beDC	  called for longest set of consecutive elements possible in orderBC	  to maximize I/O efficiency.  Reads partial blocks before write0C	  where appropriate.  Assumes 512 byte blocks.CC_PAUSE:C/      ENTRY PTRUN(FCB,IELEM,NELEM,IBUF,LBUF,IR)CE      ILEN=FCB(LLEN)                            ! ITEM LENGTH (BYTES)?      NBYTES=NELEM*ILEN                         ! TOTAL # BYTESD      IF (NBYTES.GT.LBUF) GO TO 73              ! BUFFER BIG ENOUGH?L      IOTYP=FCB(2)                              ! IOTYPE          ** TEMP **L      NLBLKS=FCB(3)                             ! # LABEL BLOCKS  ** TEMP **A      IPERB=LBLK/ILEN                           ! ITEMS PER BLOCK?      IBLK1=NLBLKS+(IELEM+IPERB-1)/IPERB        ! INITIAL BLOCKM      I1=MOD(IELEM-1,IPERB)+1                   ! FIRST ITEM IN INITIAL BLOCK>      LELEM=IELEM+NELEM-1                       ! LAST ELEMENT=      IBLK2=NLBLKS+(LELEM+IPERB-1)/IPERB        ! FINAL BLOCKJ      I2=MOD(LELEM-1,IPERB)+1                   ! LAST ITEM IN FINAL BLOCKK      K=1                                       ! INIT PTR TO USER'S BUFFERC      IBLK=IBLK1                                ! SET FOR 1ST BLOCKJ      IF (I1.EQ.1.AND.NBYTES.GE.LBLK) GO TO 30  ! BRANCH IF 1ST BLOCK FULLC  UPDATE FIRST PARTIAL BLOCKJ      IF (IOTYP.NE.2) THEN                      ! UNLESS FIRST TIME WRITE:N        CALL NREAD(FCB,IBLK,1,JBUF,IR)          !  READ FIRST BLOCK TO INT BUF>        IF (IR.NE.0) GO TO 70                   !  READ ERROR?      ENDIFA      NB1=(IPERB-I1+1)*ILEN                     ! # BYTES TO XFERL      IF (NB1.GT.NBYTES) NB1=NBYTES             ! CUT IF ENTIRE RUN IN BLOCK<      J1=(I1-1)*ILEN+1                          ! FIRST BYTEO      CALL MOVE1(IBUF(K),JBUF(J1),NB1)          ! XFER PART BLK FROM USER'S BUF?      CALL NWRITE(FCB,IBLK,1,JBUF,IR)           ! REWRITE BLOCK>      IF (IR.NE.0) GO TO 70                     ! WRITE ERROR?M      IF (NB1.EQ.NBYTES) GO TO 70               ! QUIT IF ENTIRE RUN IN BLOCKK      K=K+NB1                                   ! BUMP PTR TO USER'S BUFFER<      IBLK=IBLK+1                               ! BUMP BLOCKC  WHOLE BLOCKS LEFT?E 30   NBLKS=(NBYTES-K+1)/LBLK                   ! # WHOLE BLOCKS LEFT@      IF (NBLKS.LE.0) GO TO 32                  ! BRANCH IF NONE&C  YES, WRITE WHOLE BLOCKS IN 1 STREAMP      CALL NWRITE(FCB,IBLK,NBLKS,IBUF(K),IR)    ! WRITE WHOLE BLKS TO USER'S BUF>      IF (IR.NE.0) GO TO 70                     ! WRITE ERROR?K      K=K+NBLKS*LBLK                            ! BUMP PTR TO USER'S BUFFERC  ANYTHING LEFT?D      IF (K.GT.NBYTES) GO TO 70                 ! BRANCH IF ALL DONE<      IBLK=IBLK+NBLKS                           ! BUMP BLOCK"C  YES, UPDATE FINAL PARTIAL BLOCKJ 32   IF (IOTYP.NE.2) THEN                      ! UNLESS FIRST TIME WRITE:M        CALL NREAD(FCB,IBLK,1,JBUF,IR)          !  READ LAST BLOCK TO INT BUF>        IF (IR.NE.0) GO TO 70                   !  READ ERROR?      ENDIFO      CALL MOVE1(IBUF(K),JBUF(1),I2*ILEN)       ! XFER PART BLK FROM USER'S BUFA      CALL NWRITE(FCB,IBLK,1,JBUF,IR)           ! (RE)WRITE BLOCKCC  TERMINATION 70   RETURNC	C  ERRORS 71   IR=-1      RETURN 72   IR=-2      RETURN 73   IR=-3      RETURN	      ENDCLC...........................................................................C@C_TITLE:   GTCUBE:  Read entire cube of data from NIMS cube fileC MC_ARGS:    FCB    (128) I4   [B] File control block [future ref: NIMSFCB.TXT]'C				  FCB(31)  number of axes in array3C				  FCB(32-34) cube dimensions - 1st to 3rd axes*C				  FCB(36)  core item type:  1 integer+C					    2 unsigned integer  3 real number.C					    4 complex number  5 character string(C				  FCB(37)  core item length (bytes)"C				  FCB(38)  core exclude value;C	   IBUF   (*)   BYTE [O] Buffer for returned cube of dataCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enufBC	   IR           I4   [O] Return code:  0 OK, -3 buffer too small0C				 >0 VMS error code passed by NIMS I/O rtnesC 2C_KEYS:    FILE_I/O, CUBE, ARRAY, PDS, NIMS, IMAGEC HC_DESCR:   GTCUBE and associated entry points GTIMAG, GTLINE, GTSAMP andFC	   corresponding PT____ entries handle I/O for NIMS 3-D array files.HC	   The terminology is specific to Image Cubes, i.e. cubes of 2 spatialDC	   and 1 spectral dimension, but the entries will work for any 3-DHC	   cube.  OPCUBE must be called prior to calling any of these entries.CC	   If write or update mode, CLCUBE must be called before exiting.C	   (See also OPCUBE)C;C	   GTCUBE is the entry point for reading the entire cube.CC_FILES:   (See OPCUBE)C C_CALLS:   GTRUN, PTRUNCKC_LIMITS:  Band-sequential cube files only (to be extended to permutations)@C	   Core of cube not yet distinguished from prefix/suffix areasC	   (See also OPCUBE)CC_BUGS:C PC_HIST:    07apr86  R Mehlman (RMX) UCLA/IGPP  ORIGINAL VERSION (old NIMS label).C          18apr86  RMX  Separated from OPCUBE=C	   11aug87  RMX  NIMS standard internal documentation addedCC_PAUSE:C)      SUBROUTINE GTCUBE(FCB,IBUF,LBUF,IR);      INTEGER*4 BAND, SAMPLE, FCB(128)            ! FCB(1)?      BYTE IBUF(1)0      DATA LNDIM,LN1,LN2,LN3,LN4,LFMT,LLEN,LEXCL1     1    /   31, 32, 33, 34, 35,  36,  37,   38/C      N1=FCB(LN1)      N2=FCB(LN2)      N3=FCB(LN3)      NELEM=N1*N2*N3*      CALL GTRUN(FCB,1,NELEM,IBUF,LBUF,IR)      GO TO 70C?C_TITLE:   PTCUBE:  Write entire cube of data to NIMS cube fileC EC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)@C	   IBUF   (*)   BYTE [I] Buffer for cube of data to be writtenCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enufBC	   IR           I4   [O] Return code:  0 OK, -3 buffer too small0C				 >0 VMS error code passed by NIMS I/O rtnesC$      ENTRY PTCUBE(FCB,IBUF,LBUF,IR)C      N1=FCB(LN1)      N2=FCB(LN2)      N3=FCB(LN3)      NELEM=N1*N2*N3*      CALL PTRUN(FCB,1,NELEM,IBUF,LBUF,IR)      GO TO 70CCC_TITLE:   GTIMAG:  Read specified image (band) from NIMS cube fileC EC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)	=C	   BAND		I4   [I] Index of image in cube, where first is 1.b4C	   IBUF   (*)   BYTE [O] Buffer for returned imageCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enufFCC	   IR           I4   [O] Return code:  0 OK, -1 band out of rangecC				  -3 buffer too small1C				  >0 VMS error code passed by NIMS I/O rtnesC	)      ENTRY GTIMAG(FCB,BAND,IBUF,LBUF,IR)C	      N1=FCB(LN1)I      N2=FCB(LN2)       N3=FCB(LN3)r+      IF (BAND.LE.0.OR.BAND.GT.N3) GO TO 71f      IELEM=(BAND-1)*N1*N2+1.      CALL GTRUN(FCB,IELEM,N1*N2,IBUF,LBUF,IR)      GO TO 70CeBC_TITLE:   PTIMAG:  Write specified image (band) to NIMS cube fileC EC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)F=C	   BAND		I4   [I] Index of image in cube, where first is 1.O@C	   IBUF   (*)   BYTE [I] Buffer containing image to be writtenCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enufCC	   IR           I4   [O] Return code:  0 OK, -1 band out of rangesC				  -3 buffer too small1C				  >0 VMS error code passed by NIMS I/O rtnesnCg)      ENTRY PTIMAG(FCB,BAND,IBUF,LBUF,IR) Ca      N1=FCB(LN1)l      N2=FCB(LN2)e      N3=FCB(LN3)e+      IF (BAND.LE.0.OR.BAND.GT.N3) GO TO 71s      IELEM=(BAND-1)*N1*N2+1.      CALL PTRUN(FCB,IELEM,N1*N2,IBUF,LBUF,IR)      GO TO 70CsEC_TITLE:   GTLINE:  Read specified lines from image in NIMS cube filebC EC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)i=C	   BAND		I4   [I] Index of image in cube, where first is 1.C>C	   LINE		I4   [I] Index of first line to be read from image,&C				  where first line of image is 1./C	   NLINES	I4   [I] Number of lines to be readS4C	   IBUF   (*)   BYTE [O] Buffer for returned linesCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enuf,HC	   IR           I4   [O] Return code:  0 OK, -1 band/line out of rangeC				  -3 buffer too small1C				  >0 VMS error code passed by NIMS I/O rtnesfCs5      ENTRY GTLINE(FCB,BAND,LINE,NLINES,IBUF,LBUF,IR)dCm      N1=FCB(LN1)       N2=FCB(LN2)u      N3=FCB(LN3)	+      IF (BAND.LE.0.OR.BAND.GT.N3) GO TO 71      LINE2=LINE+NLINES-1A!      IF (NLINES.LE.0) LINE2=LINE,,      IF (LINE.LE.0.OR.LINE2.GT.N2) GO TO 71%      IELEM=((BAND-1)*N2+LINE-1)*N1+1f2      CALL GTRUN(FCB,IELEM,N1*NLINES,IBUF,LBUF,IR)      GO TO 70CcDC_TITLE:   PTLINE:  Write specified lines to image in NIMS cube fileC EC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)e=C	   BAND		I4   [I] Index of image in cube, where first is 1.m?C	   LINE		I4   [I] Index of first line to be written to image, &C				  where first line of image is 1.2C	   NLINES	I4   [I] Number of lines to be written@C	   IBUF   (*)   BYTE [I] Buffer containing lines to be writtenCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enufMHC	   IR           I4   [O] Return code:  0 OK, -1 band/line out of rangeC				  -3 buffer too small1C				  >0 VMS error code passed by NIMS I/O rtnesaC75      ENTRY PTLINE(FCB,BAND,LINE,NLINES,IBUF,LBUF,IR)cCg      N1=FCB(LN1)M      N2=FCB(LN2)       N3=FCB(LN3)E+      IF (BAND.LE.0.OR.BAND.GT.N3) GO TO 71a      LINE2=LINE+NLINES-1I!      IF (NLINES.LE.0) LINE2=LINEx,      IF (LINE.LE.0.OR.LINE2.GT.N2) GO TO 71%      IELEM=((BAND-1)*N2+LINE-1)*N1+1U2      CALL PTRUN(FCB,IELEM,N1*NLINES,IBUF,LBUF,IR)      GO TO 70CnLC_TITLE:   GTSAMP:  Read specified sample (pixel, specl) from NIMS cube fileC EC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)(=C	   BAND		I4   [I] Index of image in cube, where first is 1.A=C	   LINE		I4   [I] Index of line in image, where first is 1.?C	   SAMPLE	I4   [I] Index of sample in line, where first is 1.)4C	   IBUF   (*)   BYTE [O] Buffer for returned pixelCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enuf-C	   IR           I4   [O] Return code:  0 OK'C				  -1 band/line/sample out of rangeAC				  -3 buffer too small1C				  >0 VMS error code passed by NIMS I/O rtnesBCI5      ENTRY GTSAMP(FCB,BAND,LINE,SAMPLE,IBUF,LBUF,IR)TC       N1=FCB(LN1)       N2=FCB(LN2)F      N3=FCB(LN3)L+      IF (BAND.LE.0.OR.BAND.GT.N3) GO TO 71 +      IF (LINE.LE.0.OR.LINE.GT.N2) GO TO 71 /      IF (SAMPLE.LE.0.OR.SAMPLE.GT.N1) GO TO 71C*      IELEM=((BAND-1)*N2+LINE-1)*N1+SAMPLE*      CALL GTRUN(FCB,IELEM,1,IBUF,LBUF,IR)      GO TO 70C,KC_TITLE:   PTSAMP:  Write specified sample (pixel, specl) to NIMS cube file(C EC_ARGS:    FCB    (128) I4   [B] File control block (see OPCUBE args)E=C	   BAND		I4   [I] Index of image in cube, where first is 1.R=C	   LINE		I4   [I] Index of line in image, where first is 1. ?C	   SAMPLE	I4   [I] Index of sample in line, where first is 1.A@C	   IBUF   (*)   BYTE [I] Buffer containing pixel to be writtenCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enuf.-C	   IR           I4   [O] Return code:  0 OKE'C				  -1 band/line/sample out of range1C				  -3 buffer too small1C				  >0 VMS error code passed by NIMS I/O rtnes CL5      ENTRY PTSAMP(FCB,BAND,LINE,SAMPLE,IBUF,LBUF,IR)GCL      N1=FCB(LN1)E      N2=FCB(LN2)E      N3=FCB(LN3)V+      IF (BAND.LE.0.OR.BAND.GT.N3) GO TO 71 +      IF (LINE.LE.0.OR.LINE.GT.N2) GO TO 71Y/      IF (SAMPLE.LE.0.OR.SAMPLE.GT.N1) GO TO 71O*      IELEM=((BAND-1)*N2+LINE-1)*N1+SAMPLE*      CALL PTRUN(FCB,IELEM,1,IBUF,LBUF,IR)C  TERMINATION 70   RETURN	C  ERRORS	 71   IR=-1      RETURN	      ENDBC1LC...........................................................................CLKC_TITLE:   GTBRIK:  Read arbitrary m-dimensional brick from NIMS array fileSC MC_ARGS:    FCB    (128) I4   [B] File control block [future ref: NIMSFCB.TXT]B'C				  FCB(31)  number of axes in array]4C				  FCB(32-35) array dimensions - 1st to 4th axes*C				  FCB(36)  core item type:  1 integer+C					    2 unsigned integer  3 real numberd.C					    4 complex number  5 character string(C				  FCB(37)  core item length (bytes)"C				  FCB(38)  core exclude valueGC	   LIMITS (2,4) I4   [I] Min & max index of brick in each axis, up to $C				  mth axis - indices begin at 1<C	   IBUF   (*)   BYTE [O] Buffer for returned brick of dataCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enuftBC	   IR           I4   [O] Return code:  0 OK, -3 buffer too small0C				 >0 VMS error code passed by NIMS I/O rtnesC +C_KEYS:    FILE_I/O, CUBE, ARRAY, PDS, NIMS C JC_DESCR:   GTBRIK and PTBRIK handle I/O for arbitrary m-dimensional bricksFC	   in NIMS array files.  OPCUBE must be called before calling any ofCC	   these entries.  If write or update mode, CLCUBE must be calledEFC	   before exiting.  (See also OPCUBE)          [Could be recursive?]C 3C	   GTBRIK is the entry point for reading a brick.lCnC_FILES:   (See OPCUBE)/C C_CALLS:   GTRUN, PTRUNtCl2C_LIMITS:  Array presently limited to 4 dimensionsC	   (See also OPCUBE)CC_BUGS:NC PC_HIST:    07apr86  R Mehlman (RMX) UCLA/IGPP  ORIGINAL VERSION (old NIMS label).C          18apr86  RMX  Separated from OPCUBE=C	   11aug87  RMX  NIMS standard internal documentation addedC C_PAUSE:C30      SUBROUTINE GTBRIK(FCB,LIMITS,IBUF,LBUF,IR)J      INTEGER*4 LIMITS(2,4),FCB(128)               ! FCB(1)?  LIMITS(2,1)?      BYTE IBUF(1)      LOGICAL GETE      DATA LN1,LN2,LN3,LLEN      1    / 32, 33, 34,  37/C       GET=.TRUE.
      GO TO 5ACLJC_TITLE:   PTBRIK:  Write arbitrary m-dimensional brick to NIMS array fileC @C_ARGS:    FCB    (128) I4   [B] File control block (see GTBRIK)GC	   LIMITS (2,4) I4   [I] Min & max index of brick in each axis, up to $C				  mth axis - indices begin at 1@C	   IBUF   (*)   BYTE [I] Buffer containing brick to be writtenCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enufKBC	   IR           I4   [O] Return code:  0 OK, -3 buffer too small0C				 >0 VMS error code passed by NIMS I/O rtnesC C_PAUSE:CT+      ENTRY PTBRIK(FCB,LIMITS,IBUF,LBUF,IR) C       GET=.FALSE.RC 5    LDIM1=FCB(LN1)      LDIM2=FCB(LN2)      LDIM3=FCB(LN3)      ILEN=FCB(LLEN)A      L1=LIMITS(1,4)                               ! SET DEFAULTS1      IF (L1.EQ.0) L1=1       L2=LIMITS(2,4)      IF (L2.LT.L1) L2=L1(      K1=LIMITS(1,3)      IF (K1.EQ.0) K1=1       K2=LIMITS(2,3)      IF (K2.LT.K1) K2=K1       J1=LIMITS(1,2)      IF (J1.EQ.0) J1=1       J2=LIMITS(2,2)      IF (J2.LT.J1) J2=J1PCTA      IRUN=(((L1-1)*LDIM3+(K1-1))*LDIM2+(J1-1))*LDIM1+LIMITS(1,1) PC                                                  ! SET INDEX TO FIRST "SAMPLE"P      LRUN=LIMITS(2,1)-LIMITS(1,1)+1               ! SET # CONSECUTIVE "SAMPLES"L      N=1                                          ! INITIALIZE OUTPUT INDEXD      DO 30 L=L1,L2                                ! LOOP ON "CUBES"F        DO 20 K=K1,K2                              !  LOOP ON "IMAGES"F          DO 10 J=J1,J2                            !   LOOP ON "LINES"            IF (GET) THENON              CALL GTRUN(FCB,IRUN,LRUN,IBUF(N),LBUF,IR) ! GET RUN OF "SAMPLES"            ELSEN              CALL PTRUN(FCB,IRUN,LRUN,IBUF(N),LBUF,IR) ! PUT RUN OF "SAMPLES"            ENDIF E            IF (IR.NE.0) RETURN                    !    QUIT IF ERRORDP            IRUN=IRUN+LDIM1                        !    SET INDEX TO NEXT "LINE"N            N=N+LRUN*ILEN                          !    INCREMENT OUTPUT INDEXJ 10       CONTINUE                                 !   END LOOP ON "LINES"L          IRUN=IRUN+(LDIM2-J2+J1-1)*LDIM1          !   SKIP UNWANTED "LINES"J 20     CONTINUE                                   !  END LOOP ON "IMAGES"L        IRUN=IRUN+(LDIM3-K2+K1-1)*LDIM2            !  SKIP UNWANTED "IMAGES"H 30   CONTINUE                                     ! END LOOP ON "CUBES"      RETURN	      END CbMC............................................................................ C DC_TITLE:   GTNMSL:  Read nimsel (point spectrum) from NIMS cube fileC MC_ARGS:    FCB    (128) I4   [B] File control block [future ref: NIMSFCB.TXT]s'C				  FCB(31)  number of axes in arrayi3C				  FCB(32-34) cube dimensions - 1st to 3rd axesp*C				  FCB(36)  core item type:  1 integer+C					    2 unsigned integer  3 real number,.C					    4 complex number  5 character string(C				  FCB(37)  core item length (bytes)"C				  FCB(38)  core exclude value@C	   LINE		I4   [I] Line index of point spectrum in image, whereC				  first is 1.CC	   SAMPLE	I4   [I] Sample index of point spectrum in image, whereYC				  first is 1.=C	   IBUF   (*)   BYTE [O] Buffer for returned nimsel of dataLCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enufTBC	   IR           I4   [O] Return code:  0 OK, -3 buffer too small0C				 >0 VMS error code passed by NIMS I/O rtnesC 5C_KEYS:    FILE_I/O, CUBE, ARRAY, PDS, NIMS, SPECTRALEC NC_DESCR:   GTNMSL  and PTNMSL handle I/O of point spectra in NIMS image cubes.HC	   The terminology is specific to Image Cubes, i.e. cubes of 2 spatialFC	   and 1 spectral dimension.  OPCUBE must be called prior to callingCC	   any of these entries.  If write or update mode, CLCUBE must be .C	   called before exiting.  (See also OPCUBE)C.4C	   GTNMSL is the entry point for reading a nimsel.CLC_FILES:   (See OPCUBE) C C_CALLS:   GTBRIK, PBRIKCNKC_LIMITS:  Band-sequential cube files only (to be extended to permutations),>C	   Backplanes or other prefix/suffix areas not yet supportedC	   (See also OPCUBE)C C_BUGS: C PC_HIST:    07apr86  R Mehlman (RMX) UCLA/IGPP  ORIGINAL VERSION (old NIMS label).C          18apr86  RMX  Separated from OPCUBE=C	   11aug87  RMX  NIMS standard internal documentation added 9C			 GTNMSL and PTNMSL combined as 2 entries in 1 routine(CJC_PAUSE:C 5      SUBROUTINE GTNMSL(FCB,LINE,SAMPLE,IBUF,LBUF,IR)RI      INTEGER*4 FCB(128),LIMITS(2,4),SAMPLE        ! FCB(1)? LIMITS(2,1)?O      LOGICAL GET       BYTE IBUF(1)      DATA LN3 /34/ECG      GET=.TRUE.
      GO TO 5NCECC_TITLE:   PTNMSL:  Write nimsel (point spectrum) to NIMS cube filePC @C_ARGS:    FCB    (128) I4   [B] File control block (see GTNMSL)@C	   LINE		I4   [I] Line index of point spectrum in image, whereC				  first is 1.CC	   SAMPLE	I4   [I] Sample index of point spectrum in image, where C				  first is 1.;C	   IBUF   (*)   BYTE [I] Buffer containing nimsel of dataCCC	   LBUF		I4   [I] Length in bytes of buffer, to check if big enufFBC	   IR           I4   [O] Return code:  0 OK, -3 buffer too small0C				 >0 VMS error code passed by NIMS I/O rtnesCRC_END:C 0      ENTRY PTNMSL(FCB,LINE,SAMPLE,IBUF,LBUF,IR)      GET=.FALSE. CN 5    LIMITS(1,1)=SAMPLE      LIMITS(2,1)=SAMPLE      LIMITS(1,2)=LINE      LIMITS(2,2)=LINE      LIMITS(1,3)=1F      LIMITS(2,3)=FCB(LN3)      LIMITS(1,4)=1F      LIMITS(2,4)=1       IF (GET) THENL%	CALL GTBRIK(FCB,LIMITS,IBUF,LBUF,IR)K
      ELSE%	CALL PTBRIK(FCB,LIMITS,IBUF,LBUF,IR)       ENDIFR      RETURN	      END