C
C Subroutine file 'forms.for' to facilitate writing and reading data. C C Version: 5.20 C Date: 1998, November 9 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 WARAY...Subroutine calling WARRAY for N4 individual time levels. C WARAY C WARAI...Subroutine calling WARRAI for N4 individual time levels. C WARAI C RARAY...Subroutine calling RARRAY for N4 individual time levels. C RARAY C RARAI...Subroutine calling RARRAI for N4 individual time levels. C RARAI 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: 1998, June 26 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: C CHARACTER*11 FORML 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: FORML=FORM CALL LOWER(FORML) IF(FORML.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: 1998, June 26 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: C CHARACTER*11 FORML 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: FORML=FORM CALL LOWER(FORML) IF(FORML.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: 1998, June 26 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C CHARACTER*11 FORML 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 FORML=FORM CALL LOWER(FORML) IF(FORML.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: 1998, June 26 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C CHARACTER*11 FORML 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 FORML=FORM CALL LOWER(FORML) IF(FORML.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 WARAY(LU,FILE,FORM,LMIN,VMIN,LMAX,VMAX,NOUT,N4,OUT) CHARACTER*(*) FILE,FORM LOGICAL LMIN,LMAX INTEGER LU,NOUT,N4 REAL VMIN,VMAX,OUT(NOUT,N4) C C Subroutine designed to N4 times call subroutine WARRAY, for individual C time levels. C C Input: C LU,FILE,FORM,LMIN,VMIN,LMAX,VMAX,NOUT... Refer to subroutine C WARRAY C N4... Number of time levels. NOUT values corresponding to each C level are written through an individual invocation of C subroutine WARRAY. C OUT... Array of dimension NOUT*N4 to be written. C C No output. C C Date: 1998, March 21 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I4 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 DO 10 I4=1,N4 CALL WARRAY(LU,' ',FORM,LMIN,VMIN,LMAX,VMAX,NOUT,OUT(1,I4)) 10 CONTINUE C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE WARAI(LU,FILE,FORM,LMIN,IVMIN,LMAX,IVMAX,NOUT,N4,IOUT) CHARACTER*(*) FILE,FORM LOGICAL LMIN,LMAX INTEGER LU,IVMIN,IVMAX,NOUT,N4,IOUT(NOUT,N4) C C Subroutine designed to N4 times call subroutine WARRAI, for individual C time levels. C C Input: C LU,FILE,FORM,LMIN,IVMIN,LMAX,IVMAX,NOUT... Refer to subroutine C WARRAI C N4... Number of time levels. NOUT values corresponding to each C level are written through an individual invocation of C subroutine WARRAI. C IOUT... Array of dimension NOUT*N4 to be written. C C No output. C C Date: 1998, May 28 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I4 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 DO 10 I4=1,N4 CALL WARRAI(LU,' ',FORM,LMIN,IVMIN,LMAX,IVMAX,NOUT,IOUT(1,I4)) 10 CONTINUE C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE RARAY(LU,FILE,FORM,LDEF,DEF,N,N4,ARRAY) CHARACTER*(*) FILE,FORM LOGICAL LDEF INTEGER LU,N,N4 REAL DEF,ARRAY(N,N4) C C Subroutine designed to N4 times call subroutine RARRAY, for individual C time levels. C C Input: C LU,FILE,FORM,LDEF,DEF,N... Refer to subroutine C RARRAY C N4... Number of time levels. NOUT values corresponding to each C level are read by an individual invocation of subroutine C RARRAY. C C Output: C ARRAY...Array of dimension NOUT*N4 having been read. C C Date: 1998, March 21 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I4 C C....................................................................... 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 DO 10 I4=1,N4 CALL RARRAY(LU,' ',FORM,LDEF,DEF,N,ARRAY(1,I4)) 10 CONTINUE C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE RARAI(LU,FILE,FORM,LDEF,IDEF,N,N4,IARRAY) CHARACTER*(*) FILE,FORM LOGICAL LDEF INTEGER LU,N,IDEF,N4,IARRAY(N,N4) C C Subroutine designed to N4 times call subroutine RARRAI, for individual C time levels. C C Input: C LU,FILE,FORM,LDEF,IDEF,N... Refer to subroutine C RARRAI C N4... Number of time levels. NOUT values corresponding to each C level are read by an individual invocation of subroutine C RARRAI. C C Output: C IARRAY..Array of dimension NOUT*N4 having been read. C C Date: 1998, May 28 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I4 C C....................................................................... 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 DO 10 I4=1,N4 CALL RARRAI(LU,' ',FORM,LDEF,IDEF,N,IARRAY(1,I4)) 10 CONTINUE 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 is 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: 1998, June 29 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