EC_TITLE:   NOPEN:  Open NIMS (PDS) standard file, read or write labelC OC_ARGS:    FCB    (128) I4    [B]  File control block [future ref: NIMSFCB.TXT]PC                        Temporary: (1) Fortran unit (caller may set, default 1)NC                                   (2) current IOTYPE for file (set by NOPEN)FC                                   (3) # label records (set by NOPEN)IC                                   (4) next sequential rec (assoc. var.)=C                                  (21) label size (in bytes)#C				   (25) record size (in bytes)LC                                  (26) KPOS: current highest label positionC					       (just before END):C                                  (30) PDS file_type code)C					 (1 TABLE, 2 IMAGE, 3 CUBE, 4 QUBE)5C          FLSPEC       CHAR* [I]  File specificationKC          IOTYPE       I     [I]  I/O type (0=read, 1=update, 2=write_new)NC          LABEL        CHAR* [B]  File label, size a multiple of RECORD_BYTESOC                                  Input for IOTYPE 2, output for IOTYPE 0 or 1.C          IR           I     [O]  Return code)C                                   0  OKFC                                  -1  missing or invalid RECORD_BYTESGC                                  -2  missing or invalid LABEL_RECORDSCC                                  -3  missing or invalid FILE_TYPEDC                                  >0  Fortran or VMS I/O error codeC 1C_KEYS:    FILE_I/O, FILE_LABEL, PDS, SYSTEM, VMSC LC_DESCR:   Open NIMS (PDS) standard file for direct access read (shareable),HC	   update or write_new.  If read or update, read label.  If write_new,DC	   write label.  Construct label table in FCB of essential keywordC	   values.C FC_FILES:   NIMS (PDS) standard labelled file.  PDS label summarized inDC	   QUBE.DOC, and will be described in full in forthcoming PDS FileDC	   Label document.  Data file types described in NSD-D-1.3,1.4 andIC	   QUBE.DOC.  Files must consist of fixed-length records.  (Maximum???)C EC_CALLS:   RDREC, WTREC, GTKVAL, GLVALI, %REF, PREPRS, ! PSTPRS (tbd)C -C_LIMITS:  Non-transportable, VAX/VMS versionLC          Calls Fortran fixed-length-record I/O routines (to be replaced byIC           calls to Eric Eliason's MACRO routines which use VAX/VMS QIO))C          Uses temporary FCB assignmentsCC	   PDS label assumed to have fixed length records of same size as$C	    the entire file (RECORD_BYTES)JC	   RECORD_BYTES and LABEL_RECORDS entries assumed to be in first record,.C	    with no complex entries before them. ???.C	   History entry at close not yet supported.EC	   Label re-written in update mode, even if unchanged (to be fixed)C @C_HIST:    17apr86  RMX  R. Mehlman, UCLA/IGPP, ORIGINAL VERSION(C			  calling Fortran block I/O routinesIC          11jul86  RMX  Added -1 return code for EOF in sequential NREADNC          28jul86  RMX  Code to check for valid IBLK & NBLKS in NREAD, NWRITEHC	   13jul87  RMX  Preliminary PDS label version, reads/writes arbitrary1C			  fixed-length RECORDS rather than VAX blocks:C	   19aug87  RMX  Documentation updated, write mode fixedC C_PAUSE:2      SUBROUTINE NOPEN(FCB,FLSPEC,IOTYPE,LABEL,IR)I!      EXTERNAL FOR$IOS_ATTACCNON   !  Error code for non-existent recordK!      INTEGER*4 FOR$IOS_ATTACCNON  !  Use to detect EOF in sequential read'      CHARACTER*(*) FLSPEC,LABEL,HISTRYD      CHARACTER*16 FILTYP, FILTAB(4) /'TABLE','IMAGE','CUBE','QUBE'/.      INTEGER*4 IOTYPE,IR,FCB(128)		! FCB(1) ?      BYTE IBUF(1)C      DATA LLS,LLREC,LKP,LFTYPE /21,25,26,30/	! TEMP ASSIGNMENT ***+      DATA LBLK /512/				! VAX BLOCK LENGTH1      DATA MAXTYP /4/				! MAX # VALID FILE_TYPES-      DATA IFUD /1/				! DEFAULT FORTRAN UNIT      CHARACTER*1 CR,LFC-      CR=CHAR(13)				! CARRIAGE RETURN STRING'      LF=CHAR(10)				! LINE FEED STRINGC>C...ADD OPTION TO CREATE FILE OF INPUT INITIAL SIZE (USE FCB?)C...FIND UNUSED FORTRAN UNITC=C  NOPEN ENTRY:  OPEN NIMS STANDARD FILE, READ OR WRITE LABELF      IF (FCB(1).EQ.0) FCB(1)=IFUD          ! TEMP: USE DEFAULT UNLESS+      IFU=FCB(1)			    !  NONZERO IN FCB(1)2      FCB(2)=IOTYPE                         ! TEMPAC  OPEN OLD FILE FOR READ OR UPDATE, GET RECORD LENGTH FROM LABEL&      IF (IOTYPE.EQ.0)						! READONLYK     1 OPEN(IFU,FILE=FLSPEC,STATUS='OLD',READONLY,IOSTAT=IR,	!  (shareable).     2 ACCESS='DIRECT',ASSOCIATEVARIABLE=KREC)$      IF (IOTYPE.EQ.1)						! UPDATE3     1 OPEN(IFU,FILE=FLSPEC,STATUS='OLD',IOSTAT=IR,.     2 ACCESS='DIRECT',ASSOCIATEVARIABLE=KREC)      IF (IOTYPE.NE.2) THEN*	INQUIRE(IFU,RECL=LREC4)					! GET REC LEN	LREC=4*LREC4						!  IN BYTES      ENDIFLC  OPEN NEW FILE FOR WRITE, EXTRACT RECORD LENGTH FROM NEW LABEL (1ST BLOCK)      IF (IOTYPE.EQ.2) THENI	CALL GLVALI(LABEL,LBLK,'RECORD_BYTES',LREC,LVAL) ! EXTRACT RECORD LENGTH.	IF (LVAL.LE.0) GO TO 71				 !  FROM NEW LABEL	LREC4=(LREC+3)/4-	OPEN(IFU,FILE=FLSPEC,STATUS='NEW',IOSTAT=IR,1     1    ACCESS='DIRECT',ASSOCIATEVARIABLE=KREC,;     2    FORM='UNFORMATTED',RECORDTYPE='FIXED',RECL=LREC4)      ENDIF0      FCB(LLREC)=LREC					! RECORD LENGTH TO FCB      IF (IR.NE.0) RETURNC  READ OR WRITE LABEL1      IF (IOTYPE.NE.2)					! READ OR UPDATE MODE:C     1 CALL RDREC(IFU,1,%REF(LABEL),LREC,IR)		!  READ 1ST LABEL REC      KPOS=LRECO      CALL GLVALI(LABEL,KPOS,'RECORD_BYTES',LRECL,LVAL)	! EXTRACT RECORD LENGTH7      IF (LVAL.LE.0) GO TO 71				! assume in 1st recordG      IF (LRECL.NE.LREC) GO TO 71	! Check label rec len against system)P      CALL GLVALI(LABEL,KPOS,'LABEL_RECORDS',NLRECS,LVAL) ! EXTRACT # LABEL RECS7      IF (LVAL.LE.0) GO TO 72				! assume in 1st record3      LBLSIZ=NLRECS*LREC				! COMPUTE # LABEL BYTES/      FCB(LLS)=LBLSIZ					! SAVE # BYTES IN FCBC      IF (IOTYPE.NE.2.AND.NLRECS.GT.1) THEN		! READ OR UPDATE MODE:&        L=1						!  READ REST OF LABEL        DO 14 K=2,NLRECS          L=L+LRECL          CALL RDREC(IFU,K,%REF(LABEL(L:L)),LREC,IR)	!   READ A LABEL RECORD          IF (IR.NE.0) RETURN 14     CONTINUE      ENDIFIC  Pre-parsing step:  eliminate CR/LFs, continuations, tabs, extra spacesA      CALL PREPRS(LABEL,LABEL,LBLSIZ,KPOS)		! RETURNS CUR POS ***6      IF (KPOS.LE.0) GO TO 71				! SHOULD NEVER HAPPENLC      DO 15 I=LBLSIZ,1,-1                              ! FIND CUR LABEL POS)C        IF (LABEL(I:I).NE.' ') GO TO 155C 15   CONTINUEOC      GO TO 71                                         ! SHOULD NEVER GET HERE5C 155  KPOS=I+1                                      J      FCB(LKP)=KPOS                                     ! SAVE KPOS IN FCBK      CALL GTKVAL(LABEL,KPOS,'FILE_TYPE',FILTYP,LVAL)   ! EXTRACT FILE TYPE      IF (LVAL.LE.0) GO TO 73D      DO 157 I=1,MAXTYP                                 ! CHECK TYPE*        IF (FILTYP.EQ.FILTAB(I)) GO TO 158 157  CONTINUE      GO TO 72- 158  FCB(LFTYPE)=I					! SAVE FILE TYPE CODEE      IF (IOTYPE.EQ.2) THEN                             ! WRITE MODE:>C...   CALL PSTPRS(LABEL,LABEL,LBLSIZ,KPOS)		! POST PROCESSING6	LABEL(KPOS+1:KPOS+5)='END'//CR//LF		! ADD END<CR><LF>M        L=1                                             !  WRITE ENTIRE LABEL        DO 16 K=1,NLRECSM          CALL WTREC(IFU,K,%REF(LABEL(L:L)),LREC,IR)	!   WRITE A LABEL RECORD          IF (IR.NE.0) RETURN          L=L+LREC 16     CONTINUE      ENDIF=      FCB(3)=NLRECS                                   	! TEMP;      FCB(4)=KREC                                   	! TEMP      RETURNCAC_TITLE:   NCLOSE:  Close NIMS standard file after updating labelC HC_ARGS:    FCB    (128) I4    [B]  File control block (ref: NIMSFCB.TXT)LC          LABEL        CHAR* [B]  File label, size a multiple of 512 bytes.MC          HISTRY       CHAR* [I]  History entry for updated file (not impl.).C          IR           I     [O]  Return code*C                                   0 = OKEC                                  >0 = Fortran or VMS I/O error codeC AC_DESCR:   Update label if write_new or update mode.  Close file.C C_PAUSE:C'      ENTRY NCLOSE(FCB,LABEL,HISTRY,IR)C      IFU=FCB(1)      IF (FCB(2).EQ.0) GO TO 20.C  WRITE OR UPDATE MODE:  REWRITE ENTIRE LABEL=C...  CALL PSTPRS(LABEL,LABEL,LBLSIZ,KPOS)		! POST-PROCESSING      LREC=FCB(LLREC)      NLRECS=FCB(3)      KPOS=FCB(LKP);      LABEL(KPOS+1:KPOS+5)='END'//CR//LF		! ADD END<CR><LF>	      L=1      DO 18 K=1,NLRECSN        CALL WTREC(IFU,K,%REF(LABEL(L:L)),LREC,IR)      ! WRITE A LABEL RECORD        IF (IR.NE.0) RETURN        L=L+LREC 18   CONTINUE
C  CLOSE FILE  20   CLOSE(IFU,IOSTAT=IR)      RETURNCGC_TITLE:   NREAD:  Read one or more VAX records from NIMS standard fileNC HC_ARGS:    FCB    (128) I4    [B]  File control block (ref: NIMSFCB.TXT):C          IREC         I     [I]  Starting record in fileIC                                   If 0, start at next sequential record3HC          NRECS        I     [I]  Number of consecutive records to read7C          IBUF   (*)   BYTE  [O]  Buffer for data read BC                                   Any spec OK if it's big enough.C          IR           I     [O]  Return codeCC                                  -2 = Invalid record or # recordsLC                                  -1 = End of file if IREC = 0 (sequential)*C                                   0 = OKEC                                  >0 = Fortran or VMS I/O error codeC C_PAUSE:C;C  NREAD ENTRY:  READ VAX RECORD(S) FROM NIMS STANDARD FILE1C   CALLS RDREC TO AVOID IMPLICIT DO LOOP FOR I/O)      ENTRY NREAD(FCB,IREC,NRECS,IBUF,IR)C<      IF (IREC.LT.0.OR.NRECS.LE.0) THEN    ! PARAMETER CHECK
        IR=-2        RETURN      ENDIF      JREC=IRECF      IF (IREC.EQ.0) JREC=FCB(4)           ! IF RECORD 0, SET FOR NEXT      IFU=FCB(1)      LREC=FCB(LLREC)	      L=1<      DO 25 K=1,NRECS                      ! LOOP ON RECORDS:      CALL RDREC(IFU,JREC,IBUF(L),LREC,IR) ! READ 1 RECORDOC      IF (IREC.EQ.0.AND.IR.EQ.%LOC(FOR$IOS_ATTACCNON)) IR=-1  ! SEQUENTIAL EOFG      IF (IREC.EQ.0.AND.IR.EQ.36) IR=-1    ! SEQUENTIAL EOF (TEMPORARY)      IF (IR.NE.0) GO TO 28      L=L+LREC@ 25   JREC=JREC+1                          ! END LOOP ON RECORDS 28   FCB(4)=KREC      RETURNCGC_TITLE:   NWRITE:  Write one or more VAX records to NIMS standard fileC HC_ARGS:    FCB    (128) I4    [B]  File control block (ref: NIMSFCB.TXT):C          IREC         I     [I]  Starting record in fileIC                                   If 0, start at next sequential recordIC          NRECS        I     [I]  Number of consecutive records to writeNC          IBUF   (*)   BYTE  [I]  Buffer for data to be written (any spec OK)BC                                   Any spec OK if it's big enough.C          IR           I     [O]  Return codeCC                                  -2 = Invalid record or # records*C                                   0 = OKEC                                  >0 = Fortran or VMS I/O error codeC C_PAUSE:C;C  NWRITE ENTRY:  WRITE VAX RECORD(S) TO NIMS STANDARD FILE9C   CALLS RDREC & WTREC TO AVOID IMPLICIT DO LOOP FOR I/OMC  ... NEED TO ADD READ-BEFORE-WRITE FOR PARTIAL 1ST AND LAST RECORDS ??? ...*      ENTRY NWRITE(FCB,IREC,NRECS,IBUF,IR)C;      IF (IREC.LT.0.OR.NRECS.LE.0) THEN   ! PARAMETER CHECK
        IR=-2        RETURN      ENDIFE      JREC=IREC                           ! IF RECORD 0, SET FOR NEXT       IF (IREC.EQ.0) JREC=FCB(4)      IFU=FCB(1)      LREC=FCB(LLREC)	      L=1;      DO 35 K=1,NRECS                     ! LOOP ON RECORDS;      CALL WTREC(IFU,JREC,IBUF(L),LREC,IR) ! WRITE 1 RECORD      IF (IR.NE.0) GO TO 38      L=L+LREC? 35   JREC=JREC+1                         ! END LOOP ON RECORDS 38   FCB(4)=KREC      RETURNC	C  ERRORS 71   IR=-1      RETURN 72   IR=-2      RETURN 73   IR=-3      RETURN	      ENDCCCC_TITLE:   RDREC:  Read VAX-record from file open for direct accessC @C_ARGS:    IFU      I     [I]  Fortran logical unit of open fileEC          IREC     I     [I]  Record number of VAX-record to be readIC          IBUF (*) BYTE  [O]  Buffer for record to be read (any spec ok)&C	   LREC     I     [I]  Record lengthLC          IR       I     [O]  Return code (0 = ok, >0 = VAX/VMS error code)C  C_KEYS:    FILE_I/O, SYSTEM, VMSC DC_DESCR:   Read single VAX record in order to avoid implicit DO loop6C          generated by Fortran I/O in calling routineC NC_FILES:   Any file of fixed length records open for unformatted direct accessC =C_HIST:    17apr86  RMX  ORIGINAL VERSION (for block records).C	   13jul87  RMX  fixed-length record versionCC_PAUSE:C-      SUBROUTINE RDREC(IFU,IREC,IBUF,LREC,IR)      BYTE IBUF(LREC)C$      READ (IFU'IREC,IOSTAT=IR) IBUF      RETURN	      ENDCCBC_TITLE:   WTREC:  Write VAX-record to file open for direct accessC @C_ARGS:    IFU      I     [I]  Fortran logical unit of open fileHC          IREC     I     [I]  Record number of VAX-record to be writtenLC          IBUF (*) BYTE  [I]  Buffer for record to be written (any spec ok)&C	   LREC     I     [I]  Record lengthLC          IR       I     [O]  Return code (0 = ok, >0 = VAX/VMS error code)C  C_KEYS:    FILE_I/O, SYSTEM, VMSC EC_DESCR:   Write single VAX record in order to avoid implicit DO loop6C          generated by Fortran I/O in calling routineC NC_FILES:   Any file of fixed length records open for unformatted direct accessC =C_HIST:    17apr86  RMX  ORIGINAL VERSION (for block records).C	   13jul87  RMX  fixed-length record versionCC_PAUSE:C-      SUBROUTINE WTREC(IFU,IREC,IBUF,LREC,IR)      BYTE IBUF(LREC)C%      WRITE (IFU'IREC,IOSTAT=IR) IBUF      RETURN	      ENDCCCC_TITLE:   UPREC:  Update VAX-record in file open for direct accessC BC_ARGS:    IFU        I     [I]  Fortran logical unit of open fileJC          IREC       I     [I]  Record number of VAX-record to be updatedMC          IBUF (*)   BYTE  [I]  Buffer with updated values in bytes I1 to I2(C	   LREC       I     [I]  Record lengthCC          I1         I     [I]  First byte in record to be updatedBC          I2         I     [I]  Last byte in record to be updatedNC          IR         I     [O]  Return code (0 = ok, >0 = VAX/VMS error code)C  C_KEYS:    FILE_I/O, SYSTEM, VMSC IC_DESCR:   Update consecutive bytes in VAX-record of file open for directJC          access.  Reads record, replaces indicated bytes in buffer, then9C          rewrites record.  Rest of record is unchanged.C NC_FILES:   Any file of fixed length records open for unformatted direct accessC C_CALLS:   RDREC, WTRECC>C_LIMITS:  Record length limited to 10 VAX blocks (5120 bytes)C=C_HIST:    17apr86  RMX  ORIGINAL VERSION (for block records)BC	   13jul87  RMX  fixed-length record version, maximum 4096 bytesCC_END:C3      SUBROUTINE UPREC(IFU,IREC,IBUF,LREC,I1,I2,IR)       BYTE IBUF(LREC),JBUF(4096)CO      IF (I1.EQ.1.AND.I2.EQ.LREC) GO TO 20         ! IF FULL RECORD, JUST WRITEA      IF (I1.LE.0.OR.I2.GT.LREC) GO TO 72          ! RANGE ERROR?@      CALL RDREC(IFU,IREC,JBUF,IR)                 ! READ RECORD      IF (IR.NE.0) RETURNM      DO 10 I=I1,I2                                ! TRANSFER BYTES TO UPDATE 10   JBUF(I)=IBUF(I)C 20   CALL WTREC(IFU,IREC,JBUF,IR)                 ! REWRITE RECORD      RETURN@ 72   IR=-2                                        ! RANGE ERROR      RETURN	      END