A	SUBROUTINE GPAR (MODE,LUN,NAME,IDEF,IDA,IROW1,IROW2,IWORK,IA,IR)+C_TITLE  GPAR  Array file Input and output.C_ARGUMENTS=	INTEGER MODE 	    ! [I] Mode determines state of the program8	INTEGER LUN         ! [I] System dependent logical unit;	INTEGER*2 NAME(3)   ! [I] 6 char ASCII string of file name1	INTEGER*2 IDEF(120) ! [I] Array definition array	INTEGER IDA	    ! [I] Array IDE	INTEGER IROW1	    ! [I] Defines range of rows for GET/PUT with IROW2E	INTEGER IROW2	    ! [I] Defines range of rows for GET/PUT with IROW1&	INTEGER IWORK	    ! [I] Work location;	INTEGER*2 IA(1)     ! [O] Array for data of rows requested!	INTEGER IR	    ! [O] Return codeOC_DESCRIPTION  The subroutine GPAR performs array file input or output; it willMC get or put row(s) of a two dimensional array from a standard XG array file..C It is for use with only one array at a time.C#NC  Create file with 'makeit' file hdr word 21 is the number of arrays written.CC  File formats:  3C  Length arrays - each array header points to next1C                  file header word 23 must be 0.C9C  Fixed length arrays - all arrays in file are same sizeGC                        file header word 23 must be number of sectors #C                        for array.-C  ITEMS:  1  NX  number columns (row length)-C          2  NY  number rows (column length)QC          3  NSECT  number whole sectors for array (computed by gpar in put modeLC          4  ITYPE  word type (0 or 1 for integer*2 (default), -1 for byte)"C          5  IEXCL  exclude valueLC          6-120  optional items (see array file doc. for recommended usage)KC   IDEF will contain the array header after the 1st get call for the arrayEC   NX, NY and IEXCL should be set into IDEF before the PUT operation*C   IDA is array id (array order in file).CNC   If mode is put, IDA of 0 causes array to be written in the next available LC   space, (put extend mode).  Otherwise, (put replace mode) array must haveHC   exact dimensions of array being replaced.  The actual id written is +C   returned as IDA after the closing call.OC   IROW1 and IROW2 define range of rows for get/put, set both to 0 to get/put C   the entire array.4C   Set irow2 = irow1 or irow2 = 0 to get/put 1 row.NC   IWORK is work location - points to array header after the 1st call for the
C   array.BC   After I/O or EOF error, IWORK will contain row being processedOC   IA is an integer*2 array for data of rows requested - must be large enough!C#
C_MESSAGESC    IR IS RETURN CODEC              0 OK$C           gt 0 Fortran error code.C             -1 EOF  C             -2 Illegal row  -C             -3 Illegal array identificaiton5C             -4 Wrong dimension (PUT REPLACE MODE)   C             -5 Parameter error.C_CALLS  A2AN,MIN0,DSOPEN,DSCLOS,DSREAD,DSWRITZC_HISTORY  R.Mehlman  UCLA  79Sept25   AFTER GPCOL OF 3/23/79 and EARLIER GPA2C,GPA2X,GPA2FC  7/2/84 Corrected handling of DSOPEN LPARM error - IR now set to -5.OC  7/19/83 Put MODE correction: increment ISECT after DSWRIT call; and CLEANUP.CGC  1/19/83 GPOPEN/CLOSE/READ/WRITE replaced by DSOPEN/CLOSE/READ/WRITE.FC  5/4/82 Arguably machine independent version for VAX/VMS FORTRAN 77.,C  GPOPEN/GPCLOS/GPREAD/GPWRIT I/O routines.'C  LUN and NAME arguments replace LFCB.C  BYTE data type implemented.:C  10/2/80  Read before write fix to mode 2, mode 4 added.(C  10/17/79 Apparently debugged version.C_ENDC DESCRIPTION (CONT.)KC   GPAR: GET/PUT row(s) of 2-dimensional array from standard XG array file.C   for use with only one (1) array at a time.CC   call GPAR(mode,lun,name,idef,ida,irow1,irow2,iwork,ia,ir) whereGC   mode is 1 for get, 2 for put, 3 to empty buffer and close after all@C   rows output (not necessary if whole array written by 1 call)@C   mode 4 is 'fast' put without read-before-write feature - use>C   at your own risk - only if writing entire array from row 1FC   automatic put buffering assumes rows output consecutively, if not,(C   use MODE 3 between calls with mode 2=C   lun is system dependent logical unit (see dsopen routine)6C   on vax/vms:  LUN 0 refers to the default directoryGC                LUN N refers to dev/dir defined by logical daN (N=1-9)            INTEGER*4 NX4,LOC0,JSECT      LOGICAL LCLOSE,SAME"      INTEGER*2 IBUF(256),CNAME(3)      DATA IOUT/6/0      DATA  LS,LARHD,IFD,KLUN,KMODE,IBLANK,CNAME:     1    /256,  120, 56,   0,    0,  2H  ,2H  ,2H  ,2H  /C----Error checks.*      IF (MODE.LE.0.OR.MODE.GT.4) GO TO 75      IF (IDA.LT.0) GO TO 73*      IF (MODE.EQ.1.AND.IDA.EQ.0) GO TO 75      LCLOSE=.FALSE.      IF (MODE.NE.3) GO TO 3?C-----Close mode: empty buffer, update file header, close file. 1    IF (IWORD2.NE.LS) THEN)        CALL DSWRIT(IFD,ISECT,IBUF,LS,IR)        IF (IR.NE.0) GO TO 70        GO TO 102      ENDIF	 101  ISECT=ISECT-1 102  IEOF=0 105  IF (IDA.GT.MDA)THEN        IEOF=ISECT%        CALL DSREAD(IFD,1,IBUF,LS,IR)        IF (IR) 71,106,70 106    MDA=MDA+1        IBUF(21)=MDA        IBUF(1)=IEOF-1+NHDRS%        CALL DSWRIT(IFD,1,IBUF,LS,IR)        IF (IR.NE.0) GO TO 70      ENDIF  2    LCLOSE=.TRUE.
      KLUN=-1C-----New file?G 3    IF (LUN.EQ.KLUN.AND.SAME(NAME,CNAME,6).AND.MODE.EQ.KMODE) GO TO 51C-----Yes. Open new file (close old file if any).      CALL DSCLOS(IFD,IEOF,IR)      IF (IR.NE.0) GO TO 70      KMODE=MODE      KDA=-1      IF (LCLOSE) GO TO 60*      CALL DSOPEN(IFD,LUN,NAME,LS,-1,0,IR)      IF (IR.NE.0) GO TO 75      KLUN=LUN
      ISECT=1      CALL A2AN(NAME,CNAME,3)C-----Read file header.'      CALL DSREAD(IFD,ISECT,IBUF,LS,IR)      IF (IR) 71,4,70 4    NHDRS=IBUF(6)      KFREE=IBUF(1)+NHDRS      KMAX=IBUF(2)+NHDRS      MDA=IBUF(21)      LENA=IBUF(23)C-----New array? 5    IF (IDA.EQ.KDA) GO TO 30
      KDA=IDA
      KSECT=0C-----YES.  PUT/EXTEND MODE?      IF (IDA.EQ.0) GO TO 18,C-----NO.  check to see if array is in file.      IF (IDA.GT.MDA) GO TO 73      IF (LENA.LE.0) GO TO 8=C-----Fixed length array format: set to read header directly.       ISECT=LENA*(IDA-1)+NHDRS+1      K1=IDA
      GO TO 9DC-----Variable length array format: set to chain down array headers. 8    ISECT=NHDRS+1
      K1=1C-----Get array header. 9    DO 10 K=K1,IDA)        CALL DSREAD(IFD,ISECT,IBUF,LS,IR)        IF (IR) 71,905,70+ 905    IF (K.LT.IDA) ISECT=ISECT+IBUF(3)+1 10   CONTINUE      NX=IBUF(1)      NY=IBUF(2)      IF (MODE.NE.1) GO TO 156C-----GET MODE: Transfer array header to output array.       CALL A2AN(IBUF,IDEF,LARHD)      NX4=NX      GO TO 286C-----PUT/REPLACE MODE: Set to replace existing array.2 15   IF (NX.NE.IDEF(1).OR.NY.NE.IDEF(2)) GO TO 74      GO TO 20<C-----PUT/EXTEND MODE: Set to write to next available space. 18   KDA=MDA+1
      IDA=KDA      ISECT=KFREE      NX=IDEF(1)      NY=IDEF(2)DC-----Set to automatically empty buffer if whole array being output.# 20   IF (IROW1.LE.0) LCLOSE=.TRUE.C-----Write array header.      NX4=NX      NSECT=(NX4*NY-1)/LS+11      IF (LENA.GT.0.AND.LENA.NE.NSECT+1) GO TO 74      IDEF(3)=NSECT*      CALL DSWRIT(IFD,ISECT,IDEF,LARHD,IR)      IF (IR.NE.0) GO TO 70 28   IWORK=ISECTC-----Set to loop on rows. 30   JROW1=IROW1      JROW2=IROW2      IF (JROW1.NE.0) GO TO 31
      JROW1=1      JROW2=NY!      IF (IDA.EQ.0) LCLOSE=.TRUE.! 31   IF (JROW2.EQ.0) JROW2=JROW1-      IF (JROW1.LE.0.OR.JROW2.GT.NY) GO TO 72	      J=1C       Loop on rows.5C-----  Compute sectors and words to be read/written.      DO 50 JROW=JROW1,JROW2        LOC0=(JROW-1)*NX4        JSECT=LOC0/LS        ISECT=JSECT+IWORK+1$        IWORD1=LOC0 - JSECT * LS + 1         LEN=MIN0(NX,LS-IWORD1+1)
        MX=NX 35     IF (MODE.NE.1) GO TO 40<C------ Get mode: read sector, move words into output array.         IF (ISECT.NE.KSECT) THEN,           CALL DSREAD(IFD,ISECT,IBUF,LS,IR)           IF (IR) 71,36,70 36        KSECT=ISECT	ENDIF 37     ISECT=KSECT+1) 38     CALL A2AN(IBUF(IWORD1),IA(J),LEN)        GO TO 45MC------ Put mode: read sector if nec., move words into buffer, write if full.$ 40     IF (ISECT.EQ.KSECT) GO TO 42#        IF (ISECT.GT.KMAX) GO TO 71:        IF (IDA.GT.MDA.OR.LEN.EQ.LS.OR.MODE.EQ.4) GO TO 41+          CALL DSREAD(IFD,ISECT,IBUF,LS,IR)          IF (IR) 71,41,70 41     KSECT=ISECT) 42     CALL A2AN(IA(J),IBUF(IWORD1),LEN)        IWORD2=IWORD1+LEN-1         IF (IWORD2 .GT. LS) THEN+          CALL DSWRIT(IFD,ISECT,IBUF,LS,IR)          IF (IR.NE.0) GO TO 70          ISECT=ISECT+1 45       IWORD1=1	ENDIF 46     J=J+LEN        MX=MX-LEN        LEN=MIN0(LS,MX)        IF (MX.GT.0) GO TO 35 50   CONTINUE-C-----End row loop.  Set return code, return.      IF (LCLOSE) GO TO 1
 60   IR=0      RETURN
C-----Errors. 70   RETURN 71   IR=-1      IWORK=IROW      WRITE(IOUT,9010)#9010  FORMAT('0 GPAR> End of file')      RETURN 72   IR=-2      WRITE(IOUT,9020)#9020  FORMAT('GPAR> 0 Illegal row')      RETURN 73   IR=-3      WRITE(IOUT,9030)49030  FORMAT('0 GPAR> Illegal array identification')      RETURN 74   IR=-4      WRITE(IOUT,9040)B9040  FORMAT('0 GPAR> Wrong dimension in the Put or Replace mode')      RETURN 75   IR=-5      WRITE(IOUT,9060),9060  FORMAT(' GPAR> Input parameter error')      RETURN	      END