C 
C Subroutine file 'forms.for' to facilitate writing and reading data.
C
C Version: 5.10
C Date: 1997, October 17
C
C Coded by: Ludek Klimes
C     Department of Geophysics, Charles University Prague,
C     Ke Karlovu 3, 121 16 Praha 2, Czech Republic,
C     E-mail: klimes@seis.karlov.mff.cuni.cz
C
C.......................................................................
C
C This file consists of the following external procedures:
C     WARRAY..Subroutine designed to write a given real array into the
C             given formatted or unformatted file.
C             WARRAY
C     WARRAI..Subroutine designed to write a given integer array into
C             the given formatted or unformatted file.
C             WARRAI
C     RARRAY..Subroutine designed to read the real array from the given
C             formatted or unformatted file.
C             RARRAY
C     RARRAI..Subroutine designed to read the integer array from the
C             given formatted or unformatted file.
C             RARRAI
C     FORM1...Subroutine designed to determine the best output format
C             for reals.
C             FORM1
C     FORM2...Subroutine designed to determine the best output format
C             for multiples of real numbers.
C             FORM2
C
C=======================================================================
C
C     
C
      SUBROUTINE WARRAY(LU,FILE,FORM,LMIN,VMIN,LMAX,VMAX,NOUT,OUT)
      CHARACTER*(*) FILE,FORM
      LOGICAL LMIN,LMAX
      INTEGER LU,NOUT
      REAL VMIN,VMAX,OUT(NOUT)
C
C Subroutine designed to write a given real array into the file.
C
C Input:
C     LU...   Logical unit number to be used for the output.
C     FILE... Destination filename.  If not blank, the file will be
C             opened and closed.  If blank, the file is assumed to be
C             already open, and will not be closed in this subroutine.
C     FORM... Form of the output file: either 'FORMATTED' or
C             'UNFORMATTED'.
C     LMIN... TRUE if the null values are to be written in place of
C             array elements less than or equal to VMIN, otherwise
C             FALSE.
C             Formatted output:
C               The null values are treated as default values when read
C               by list-directed input (free format).
C               Example: 124 null values are written as '    124*'.
C             Unformatted output:
C               The values of 999999 are written in place of the null
C               values.
C     VMIN... Trade-off limit.
C     LMAX... TRUE if the null values are to be written in place of
C             array elements greater than or equal to VMAX, otherwise
C             FALSE.
C     VMAX... Trade-off limit.
C     NOUT... Dimension of the array OUT.
C     OUT...  Array to be written.
C
C No output.
C
C Date: 1995, August 17
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Local storage locations:
C
      CHARACTER*14 FORMAT
      INTEGER IMIN,IADR
      REAL OUTMIN,OUTMAX,VMINA,VMAXA
C
C     FORMAT..String containing the output format, e.g. like (10F8.3).
C     IMIN... Loop lower bound, locally also loop variable.
C     IADR... Loop variable.
C     OUTMIN,OUTMAX... Minimum and maximum defined element to determine
C             the best format for printing.
C     VMINA,VMAXA... Local storage locations for VMIN, VMAX.
C
C.......................................................................
C
      IF(FILE.NE.' ') THEN
        WRITE(*,'(''+'',79('' ''))')
        WRITE(*,'(2A)') '+Writing: ',FILE(1:MIN0(LEN(FILE),70))
        OPEN(LU,FILE=FILE,FORM=FORM)
      END IF
C
C     Formatted or unformatted output:
      IF(FORM.EQ.'FORMATTED') THEN
C
C       Minimum and maximum elements:
        OUTMIN=0.
        IF(LMIN) THEN
          VMINA=VMIN
          DO 11 IADR=1,NOUT
            IF(OUTMIN.GT.OUT(IADR)) THEN
              IF(OUT(IADR).GT.VMINA) THEN
                OUTMIN=OUT(IADR)
              END IF
            END IF
   11     CONTINUE
        ELSE
          DO 12 IADR=1,NOUT
            IF(OUTMIN.GT.OUT(IADR)) THEN
              OUTMIN=OUT(IADR)
            END IF
   12     CONTINUE
        END IF
        OUTMAX=0.
        IF(LMAX) THEN
          VMAXA=VMAX
          DO 13 IADR=1,NOUT
            IF(OUTMAX.LT.OUT(IADR)) THEN
              IF(OUT(IADR).LT.VMAXA) THEN
                OUTMAX=OUT(IADR)
              END IF
            END IF
   13     CONTINUE
        ELSE
          DO 14 IADR=1,NOUT
            IF(OUTMAX.LT.OUT(IADR)) THEN
              OUTMAX=OUT(IADR)
            END IF
   14     CONTINUE
        END IF
C
C       Setting output format for the array:
        FORMAT='(10(F00.0,1X))'
        CALL FORM1(OUTMIN,OUTMAX,FORMAT(5:12))
        FORMAT(11:14)=   '1X))'
C       Output format is set.
C
C       Printing loop:
C       Initial value of the first element to print
        IADR=1
C       Beginning of the loop
   20   CONTINUE
C
C         Trade off (searching for undefined elements):
          IMIN=IADR
          IF(LMIN) THEN
            IF(LMAX) THEN
              DO 21 IADR=IMIN,NOUT
                IF(OUT(IADR).LE.VMINA.OR.OUT(IADR).GE.VMAXA) THEN
                  GO TO 29
                END IF
   21         CONTINUE
            ELSE
              DO 22 IADR=IMIN,NOUT
                IF(OUT(IADR).LE.VMINA) THEN
                  GO TO 29
                END IF
   22         CONTINUE
            END IF
          ELSE
            IF(LMAX) THEN
              DO 23 IADR=IMIN,NOUT
                IF(OUT(IADR).GE.VMAXA) THEN
                  GO TO 29
                END IF
   23         CONTINUE
            ELSE
              IADR=NOUT+1
            END IF
          END IF
   29     CONTINUE
C         IADR is the first undefined element.
C
C         Writing the array (defined elements):
          IF(IMIN.EQ.1.AND.IADR.GT.NOUT) THEN
            WRITE(LU,FORMAT) OUT
            GO TO 90
          ELSE
            WRITE(LU,FORMAT) (OUT(IMIN),IMIN=IMIN,IADR-1)
            IF(IADR.GT.NOUT) THEN
              GO TO 90
            END IF
          END IF
C
C         Searching for the next defined elements:
          IMIN=IADR
          IF(LMIN) THEN
            IF(LMAX) THEN
              DO 31 IADR=IADR,NOUT
                IF(OUT(IADR).GT.VMINA.AND.OUT(IADR).LT.VMAXA) THEN
                  GO TO 39
                END IF
   31         CONTINUE
            ELSE
              DO 32 IADR=IADR,NOUT
                IF(OUT(IADR).GT.VMINA) THEN
                  GO TO 39
                END IF
   32         CONTINUE
            END IF
          ELSE
            IF(LMAX) THEN
              DO 33 IADR=IADR,NOUT
                IF(OUT(IADR).LT.VMAXA) THEN
                  GO TO 39
                END IF
   33         CONTINUE
            ELSE
              IADR=NOUT+1
            END IF
          END IF
   39     CONTINUE
C         IADR is the first defined element.
C
C         Writing the array (undefined elements):
          WRITE(LU,'(I7,A)') IADR-IMIN,'*'
          IF(NOUT.LT.IADR) THEN
            GO TO 90
          END IF
C
        GO TO 20
      ELSE
C
C       Null values:
        IF(LMIN) THEN
          VMINA=VMIN
          IF(LMAX) THEN
            VMAXA=VMAX
            DO 51 IADR=1,NOUT
              IF(OUT(IADR).LE.VMINA.OR.VMAXA.LE.OUT(IADR)) THEN
                OUT(IADR)=999999.
              END IF
   51       CONTINUE
          ELSE
            DO 52 IADR=1,NOUT
              IF(OUT(IADR).LE.VMINA) THEN
                OUT(IADR)=999999.
              END IF
   52       CONTINUE
          END IF
        ELSE
          IF(LMAX) THEN
            VMAXA=VMAX
            DO 53 IADR=1,NOUT
              IF(VMAXA.LE.OUT(IADR)) THEN
                OUT(IADR)=999999.
              END IF
   53       CONTINUE
          END IF
        END IF
C
C       Writing the array:
        WRITE(LU) OUT
C
      END IF
   90 CONTINUE
      IF(FILE.NE.' ') THEN
        CLOSE(LU)
      END IF
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE WARRAI(LU,FILE,FORM,LMIN,IVMIN,LMAX,IVMAX,NOUT,IOUT)
      CHARACTER*(*) FILE,FORM
      LOGICAL LMIN,LMAX
      INTEGER LU,NOUT,IVMIN,IVMAX,IOUT(NOUT)
C
C Subroutine designed to write a given real array into the file.
C
C Input:
C     LU...   Logical unit number to be used for the output.
C     FILE... Destination filename.  If not blank, the file will be
C             opened and closed.  If blank, the file is assumed to be
C             already open, and will not be closed in this subroutine.
C     FORM... Form of the output file: either 'FORMATTED' or
C             'UNFORMATTED'.
C     LMIN... TRUE if the null values are to be written in place of
C             array elements less than or equal to IVMIN, otherwise
C             FALSE.
C             Formatted output:
C               The null values are treated as default values when read
C               by list-directed input (free format).
C               Example: 124 null values are written as '    124*'.
C             Unformatted output:
C               The values of -999999 are written in place of the null
C               values.
C     IVMIN . Trade-off limit.
C     LMAX... TRUE if the null values are to be written in place of
C             array elements greater than or equal to IVMAX, otherwise
C             FALSE.
C     IVMAX...Trade-off limit.
C     NOUT... Dimension of the array IOUT.
C     IOUT... Array to be written.
C
C No output.
C
C Date: 1995, August 17
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Local storage locations:
C
      CHARACTER*12 FORMAT
      INTEGER IMIN,IADR,MINOUT,MAXOUT,IVMINA,IVMAXA
C
C     FORMAT..String containing the output format, e.g. like (10I08).
C     IMIN... Loop lower bound, locally also loop variable.
C     IADR... Loop variable.
C     MINOUT,MAXOUT... Minimum and maximum defined element to determine
C             the best format for printing.
C     IVMINA,IVMAXA... Local storage locations for IVMIN, IVMAX.
C
C.......................................................................
C
      IF(FILE.NE.' ') THEN
        WRITE(*,'(''+'',79('' ''))')
        WRITE(*,'(2A)') '+Writing: ',FILE(1:MIN0(LEN(FILE),70))
        OPEN(LU,FILE=FILE,FORM=FORM)
      END IF
C
C     Formatted or unformatted output:
      IF(FORM.EQ.'FORMATTED') THEN
C
C       Minimum and maximum elements:
        MINOUT=0
        IF(LMIN) THEN
          IVMINA=IVMIN
          DO 11 IADR=1,NOUT
            IF(MINOUT.GT.IOUT(IADR)) THEN
              IF(IOUT(IADR).GT.IVMINA) THEN
                MINOUT=IOUT(IADR)
              END IF
            END IF
   11     CONTINUE
        ELSE
          DO 12 IADR=1,NOUT
            IF(MINOUT.GT.IOUT(IADR)) THEN
              MINOUT=IOUT(IADR)
            END IF
   12     CONTINUE
        END IF
        MAXOUT=0
        IF(LMAX) THEN
          IVMAXA=IVMAX
          DO 13 IADR=1,NOUT
            IF(MAXOUT.LT.IOUT(IADR)) THEN
              IF(IOUT(IADR).LT.IVMAXA) THEN
                MAXOUT=IOUT(IADR)
              END IF
            END IF
   13     CONTINUE
        ELSE
          DO 14 IADR=1,NOUT
            IF(MAXOUT.LT.IOUT(IADR)) THEN
              MAXOUT=IOUT(IADR)
            END IF
   14     CONTINUE
        END IF
C
C       Setting output format for the array:
        FORMAT='(10(I00,1X))'
        IMIN=MAXOUT
        IF(MINOUT.LT.0.) THEN
          IMIN=MAX0(IMIN,-10*MINOUT)
        END IF
        DO 15 IADR=1,99
          IMIN=IMIN/10
          IF(IMIN.LT.1) THEN
            FORMAT(6:6)=CHAR(ICHAR('0')+IADR/10)
            FORMAT(7:7)=CHAR(ICHAR('0')+MOD(IADR,10))
            GO TO 16
          END IF
   15   CONTINUE
   16   CONTINUE
C       Output format is set.
C
C       Printing loop:
C       Initial value of the first element to print
        IADR=1
C       Beginning of the loop
   20   CONTINUE
C
C         Trade off (searching for undefined elements):
          IMIN=IADR
          IF(LMIN) THEN
            IF(LMAX) THEN
              DO 21 IADR=IMIN,NOUT
                IF(IOUT(IADR).LE.IVMINA.OR.IOUT(IADR).GE.IVMAXA) THEN
                  GO TO 29
                END IF
   21         CONTINUE
            ELSE
              DO 22 IADR=IMIN,NOUT
                IF(IOUT(IADR).LE.IVMINA) THEN
                  GO TO 29
                END IF
   22         CONTINUE
            END IF
          ELSE
            IF(LMAX) THEN
              DO 23 IADR=IMIN,NOUT
                IF(IOUT(IADR).GE.IVMAXA) THEN
                  GO TO 29
                END IF
   23         CONTINUE
            ELSE
              IADR=NOUT+1
            END IF
          END IF
   29     CONTINUE
C         IADR is the first undefined element.
C
C         Writing the array (defined elements):
          IF(IMIN.EQ.1.AND.IADR.GT.NOUT) THEN
            WRITE(LU,FORMAT) IOUT
            GO TO 90
          ELSE
            WRITE(LU,FORMAT) (IOUT(IMIN),IMIN=IMIN,IADR-1)
            IF(IADR.GT.NOUT) THEN
              GO TO 90
            END IF
          END IF
C
C         Searching for the next defined elements:
          IMIN=IADR
          IF(LMIN) THEN
            IF(LMAX) THEN
              DO 31 IADR=IADR,NOUT
                IF(IOUT(IADR).GT.IVMINA.AND.IOUT(IADR).LT.IVMAXA) THEN
                  GO TO 39
                END IF
   31         CONTINUE
            ELSE
              DO 32 IADR=IADR,NOUT
                IF(IOUT(IADR).GT.IVMINA) THEN
                  GO TO 39
                END IF
   32         CONTINUE
            END IF
          ELSE
            IF(LMAX) THEN
              DO 33 IADR=IADR,NOUT
                IF(IOUT(IADR).LT.IVMAXA) THEN
                  GO TO 39
                END IF
   33         CONTINUE
            ELSE
              IADR=NOUT+1
            END IF
          END IF
   39     CONTINUE
C         IADR is the first defined element.
C
C         Writing the array (undefined elements):
          WRITE(LU,'(I7,A)') IADR-IMIN,'*'
          IF(NOUT.LT.IADR) THEN
            GO TO 90
          END IF
C
        GO TO 20
      ELSE
C
C       Null values:
        IF(LMIN) THEN
          IVMINA=IVMIN
          IF(LMAX) THEN
            IVMAXA=IVMAX
            DO 51 IADR=1,NOUT
              IF(IOUT(IADR).LE.IVMINA.OR.IVMAXA.LE.IOUT(IADR)) THEN
                IOUT(IADR)=-999999
              END IF
   51       CONTINUE
          ELSE
            DO 52 IADR=1,NOUT
              IF(IOUT(IADR).LE.IVMINA) THEN
                IOUT(IADR)=-999999
              END IF
   52       CONTINUE
          END IF
        ELSE
          IF(LMAX) THEN
            IVMAXA=IVMAX
            DO 53 IADR=1,NOUT
              IF(IVMAXA.LE.IOUT(IADR)) THEN
                IOUT(IADR)=-999999
              END IF
   53       CONTINUE
          END IF
        END IF
C
C       Writing the array:
        WRITE(LU) IOUT
C
      END IF
   90 CONTINUE
      IF(FILE.NE.' ') THEN
        CLOSE(LU)
      END IF
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE RARRAY(LU,FILE,FORM,LDEF,DEF,N,ARRAY)
      CHARACTER*(*) FILE,FORM
      LOGICAL LDEF
      INTEGER LU,N
      REAL DEF,ARRAY(N)
C
C Subroutine designed to read the real array from the disk.
C
C Input:
C     LU...   Logical unit number to be used.
C     FILE... Source filename.  If not blank, the file will be
C             opened and closed.  If blank, the file is assumed to be
C             already open, and will not be closed in this subroutine.
C     FORM... Form of the output file: either 'FORMATTED' or
C             'UNFORMATTED'.
C     LDEF... True if the null values are to be replaced by the given
C             default value DEF.
C             If FORM='FORMATTED' and LDEF=.FALSE., the array elements
C             corresponding to null values remain unchanged.
C     DEF...  Default value.
C     N...    Array dimension (number of elements to read).
C
C Output:
C     ARRAY.. Array having been read.
C
C Date: 1997, January 23
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
      INTEGER I
      REAL AUX
C
      IF(FILE.NE.' ') THEN
        WRITE(*,'(''+'',79('' ''))')
        WRITE(*,'(2A)') '+Reading: ',FILE(1:MIN0(LEN(FILE),70))
        OPEN(LU,FILE=FILE,FORM=FORM,STATUS='OLD')
      END IF
C
      IF(FORM.EQ.'FORMATTED') THEN
        IF(LDEF) THEN
          AUX=DEF
          DO 10 I=1,N
            ARRAY(I)=AUX
   10     CONTINUE
        END IF
        READ(LU,*) ARRAY
      ELSE
        READ(LU) ARRAY
        IF(LDEF) THEN
          IF(DEF.LT.899999..OR.1111110..LT.DEF) THEN
            AUX=DEF
            DO 20 I=1,N
              IF(999998..LT.ARRAY(I)) THEN
                ARRAY(I)=AUX
              END IF
   20       CONTINUE
          END IF
        END IF
      END IF
C
      IF(FILE.NE.' ') THEN
        CLOSE(LU)
      END IF
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE RARRAI(LU,FILE,FORM,LDEF,IDEF,N,IARRAY)
      CHARACTER*(*) FILE,FORM
      LOGICAL LDEF
      INTEGER LU,IDEF,N,IARRAY(N)
C
C Subroutine designed to read the integer array from the disk.
C
C Input:
C     LU...   Logical unit number to be used.
C     FILE... Source filename.  If not blank, the file will be
C             opened and closed.  If blank, the file is assumed to be
C             already open, and will not be closed in this subroutine.
C     FORM... Form of the output file: either 'FORMATTED' or
C             'UNFORMATTED'.
C     LDEF... True if the null values are to be replaced by the given
C             default value IDEF.
C             If FORM='FORMATTED' and LDEF=.FALSE., the array elements
C             corresponding to null values remain unchanged.
C     IDEF... Default value.
C     N...    Array dimension (number of elements to read).
C
C Output:
C     IARRAY..Array having been read.
C
C Date: 1997, June 18
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
      INTEGER I,IAUX
C
      IF(FILE.NE.' ') THEN
        WRITE(*,'(''+'',79('' ''))')
        WRITE(*,'(2A)') '+Reading: ',FILE(1:MIN0(LEN(FILE),70))
        OPEN(LU,FILE=FILE,FORM=FORM,STATUS='OLD')
      END IF
C
      IF(FORM.EQ.'FORMATTED') THEN
        IF(LDEF) THEN
          IAUX=IDEF
          DO 10 I=1,N
            IARRAY(I)=IAUX
   10     CONTINUE
        END IF
        READ(LU,*) IARRAY
      ELSE
        READ(LU) IARRAY
        IF(LDEF) THEN
C         IF(IDEF.LT.899999.OR.1111110.LT.IDEF) THEN
            IAUX=IDEF
            DO 20 I=1,N
              IF(IARRAY(I).LT.-999998) THEN
                IARRAY(I)=IAUX
              END IF
   20       CONTINUE
C         END IF
        END IF
      END IF
C
      IF(FILE.NE.' ') THEN
        CLOSE(LU)
      END IF
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE FORM1(OUTMIN,OUTMAX,FORMAT)
      REAL OUTMIN,OUTMAX
      CHARACTER*8 FORMAT
C
C Subroutine designed to determine the best output format for reals.
C
C Input:
C     OUTMIN,OUTMAX... Minimum and maximum real number to be written.
C
C Output:
C     FORMAT..String containing the output format e.g. like 'F07.3,A,'.
C             The width of the defined string is 8 characters.
C             It has the form of 'F00.0,A,', where zeros are replaced
C             by reasonable values.  The subroutine attempts to output
C             at least NDIG digits (including all zeros after the
C             decimal point) of the largest positive number OUTMAX and
C             NDIG-1 digits of the most negative number if OUTMIN is
C             negative, and to adjust the width of the output field to
C             NDIG+1 columns, if possible.  The (NDIG+2)th column is
C             space or reserved for another separator.  If OUTMIN=0 and
C             OUTMAX=0, the width of the output field is adjusted to
C             2 columns.
C             ------------------
              INTEGER NDIG
              PARAMETER (NDIG=6)
C             ------------------
C
C Date: 1997, May 11
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Local storage locations:
      INTEGER IFORM1,IFORM2
C     IFORM1,IFORM2... Define format to write the travel times.
C             Limits: 0.LE.IFORM2.LE.9, IFORM2+1.LE.IFORM1.LE.99.
C
C.......................................................................
C
C     Setting output format:
      IFORM1=MAX0(INT(ALOG10(AMAX1(OUTMAX,0.001))+1.001),0)
      IF(OUTMIN.LT.0.) THEN
        IFORM1=MAX0(INT(ALOG10(AMAX1(-OUTMIN,0.001))+2.001),1,IFORM1)
      END IF
C     Here, IFORM1 is the number of digits left to the decimal point.
      IFORM2=MAX0(6-IFORM1,0)
C     IFORM2 is the number of decimal places.
      IFORM1=IFORM1+IFORM2+1
C     IFORM1 is the width of the output field for one element.
      FORMAT='F02.0,A,'
      IF(OUTMIN.NE.0..OR.OUTMAX.NE.0.) THEN
        FORMAT(2:2)=CHAR(ICHAR('0')+IFORM1/10)
        FORMAT(3:3)=CHAR(ICHAR('0')+MOD(IFORM1,10))
        FORMAT(5:5)=CHAR(ICHAR('0')+IFORM2)
      END IF
C     Output format is set.
C
      RETURN
      END
C
C=======================================================================
C
C     
C
      SUBROUTINE FORM2(NQ,OUTMIN,OUTMAX,FORMAT)
      INTEGER NQ
      REAL OUTMIN(NQ),OUTMAX(NQ)
      CHARACTER*(*) FORMAT
C
C Subroutine designed to determine the best output format for multiples
C of real numbers.
C
C Input:
C     NQ...   Number of reals in each output line.
C     OUTMIN,OUTMAX... Minimum and maximum real numbers to be written.
C     FORMAT..String of at least 8*NQ characters.
C
C Output:
C     FORMAT..String containing the output format, e.g. like
C             'F07.3,A,F07.3,A,F07.3,A,F07.6,A,,F07.4,A)'.  The width of
C             the defined string if 8*NQ characters.  It has the above
C             form, where digits are replaced by reasonable values.
C             Note ')' at the end instead of ','.   The subroutine
C             attempts to output at least 6 digits (including all zeros
C             after the decimal point) of the largest positive number
C             OUTMAX and 5 digits of the most negative number if OUTMIN
C             is negative, and to adjust the width of the output field
C             to 8 columns including the space after the number, if
C             possible.
C
C Date: 1995, August 17
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Local storage locations:
      INTEGER I
C
C.......................................................................
C
      DO 10 I=1,NQ
        CALL FORM1(OUTMIN(I),OUTMAX(I),FORMAT(8*I-7:8*I))
   10 CONTINUE
      FORMAT(8*NQ:8*NQ)=')'
C
      RETURN
      END
C
C=======================================================================
C