C
C Subroutine file 'forms.for' to facilitate writing and reading data. C C Version: 6.20 C Date: 2008, January 18 C C Coded by: Ludek Klimes C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C http://sw3d.cz/staff/klimes.htm C C....................................................................... C C This file consists of the following external procedures: C UARRAY..Function returning the undefined value used in the C unformatted files with real arrays. C UARRAY 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 REAL FUNCTION UARRAY() C C Function returning the undefined value used in the unformatted files C with real-valued arrays. C C No input. C C Output: C UARRAY..The value used as "undefined value" in the unformatted C files with real-valued arrays by subroutines WARRAY and C RARRAY. C C Date: 2005, June 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: REAL UNDEF PARAMETER (UNDEF=-3.4E+38) C UARRAY=UNDEF RETURN END 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 -999999999 are written in place of the C null 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 C Input SEP parameter: C NUMLIN=positive integer... Number of the numbers to be written C to each line of the output file. C NUMLIN must be less than 100 (99 at most). C Default: NUMLIN=10 C C Date: 2007, January 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: EXTERNAL UARRAY REAL UARRAY REAL UNDEF C C Local storage locations: CHARACTER*11 FORML CHARACTER*14 FORMAT INTEGER IMIN,IADR REAL OUTMIN,OUTMAX,VMINA,VMAXA 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 INTEGER NUMLIN SAVE NUMLIN DATA NUMLIN/-1/ C C....................................................................... C UNDEF=UARRAY() 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: IF (NUMLIN.EQ.-1) THEN CALL RSEP3I('NUMLIN',NUMLIN,10) ENDIF FORMAT='(00(F00.0,1X))' FORMAT(3:3)=CHAR(ICHAR('0')+MOD(NUMLIN,10)) FORMAT(2:2)=CHAR(ICHAR('0')+ NUMLIN/10 ) 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)=UNDEF END IF 51 CONTINUE ELSE DO 52 IADR=1,NOUT IF(OUT(IADR).LE.VMINA) THEN OUT(IADR)=UNDEF 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)=UNDEF 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 integer 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 -999999999 are written in place of the C null 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 Input SEP parameter: C NUMLIN=positive integer... Number of the numbers to be written C to each line of the output file. C NUMLIN must be less than 100 (99 at most). C Default: NUMLIN=10 C C Date: 2007, January 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: INTEGER IUNDEF PARAMETER (IUNDEF=-999999999) C C Local storage locations: CHARACTER*11 FORML CHARACTER*12 FORMAT INTEGER IMIN,IADR,MINOUT,MAXOUT,IVMINA,IVMAXA 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 INTEGER NUMLIN SAVE NUMLIN DATA NUMLIN/-1/ 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: IF (NUMLIN.EQ.-1) THEN CALL RSEP3I('NUMLIN',NUMLIN,10) ENDIF FORMAT='(00(I00,1X))' FORMAT(3:3)=CHAR(ICHAR('0')+MOD(NUMLIN,10)) FORMAT(2:2)=CHAR(ICHAR('0')+ NUMLIN/10 ) 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)=IUNDEF END IF 51 CONTINUE ELSE DO 52 IADR=1,NOUT IF(IOUT(IADR).LE.IVMINA) THEN IOUT(IADR)=IUNDEF 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)=IUNDEF 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: 2000, November 25 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: EXTERNAL UARRAY REAL UARRAY REAL UNDEF C CHARACTER*11 FORML INTEGER I REAL AUX C UNDEF=UARRAY() 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.NE.UNDEF) THEN AUX=DEF DO 20 I=1,N IF(ARRAY(I).EQ.UNDEF) 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: 2000, November 25 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: INTEGER IUNDEF PARAMETER (IUNDEF=-999999999) 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.NE.IUNDEF) THEN IAUX=IDEF DO 20 I=1,N IF(IARRAY(I).EQ.IUNDEF) 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. N values corresponding to each C level are read by an individual invocation of subroutine C RARRAY. C C Output: C ARRAY...Array of dimension N*N4 having been read. C C Date: 2000, July 31 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,N4... Refer to subroutine C RARRAI C C Output: C IARRAY..Array of dimension N*N4 having been read. C C Date: 2000, July 31 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 outputs C at least MAXDIG digits (including all zeros after the C decimal point) of the largest positive number OUTMAX or C MAXDIG-1 digits of the most negative number if OUTMIN is C negative, and adjusts the width of the output field to C MAXDIG+1 columns, if possible. The (MAXDIG+2)th column is C reserved for a space or another separator. C If OUTMIN=0 and OUTMAX=0, the width of the output field is C adjusted to 2 columns. C If the number of digits (without leading zeros) is smaller C than MINDIG, format Fnn.d with nn=MAXDIG+1 is changed to C Gmm.d with mm=MAXDIG+5. The (MAXDIG+6)th column is C reserved for a space or another separator. C C Input SEP parameters: C MAXDIG=positive integer... Minimum number of digits of the largest C positive number OUTMAX in the output format, C see the description of FORMAT above. C MAXDIG must be less than 10. C Default: MAXDIG=6 C MINDIG=positive integer... Number of digits to change edition F C to edition G, see the description of FORMAT above. C MINDIG should be less than MAXDIG. C Default: MINDIG=4 C C Date: 2008, January 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER MAXDIG,MINDIG INTEGER IFORM1,IFORM2 REAL SMALL SAVE MAXDIG,MINDIG DATA MAXDIG/-1/ 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 IF (MAXDIG.EQ.-1) THEN CALL RSEP3I('MAXDIG',MAXDIG,6) CALL RSEP3I('MINDIG',MINDIG,4) ENDIF C Setting output format: IFORM1=MAX0(INT(ALOG10(AMAX1(OUTMAX,0.001))+0.3*0.1**MAXDIG+1.),0) IF(OUTMIN.LT.0.) THEN IFORM1=MAX0(INT(ALOG10(AMAX1(-OUTMIN,0.001))+3.0*0.1**MAXDIG+2.) * ,1,IFORM1) END IF C Here, IFORM1 is the number of digits left to the decimal point. IFORM2=MAX0(MAXDIG-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 SMALL=10.**(MINDIG-IFORM2)-0.5*10.**(-IFORM2) IF(-SMALL.LE.OUTMIN.AND.OUTMAX.LE.SMALL) THEN FORMAT='E00.0,A,' IFORM1=MAXDIG+5 IFORM2=MAXDIG IF(OUTMIN.LT.0.) THEN IFORM2=MAXDIG-1 ELSE IFORM2=MAXDIG END IF ELSE IF(IFORM1.GT.MAXDIG+5) THEN FORMAT='E00.0,A,' IFORM1=MAXDIG+5 IF(OUTMIN.LT.0.) THEN IFORM2=MAXDIG-1 ELSE IFORM2=MAXDIG END IF END IF 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 ','. C The format is set using repeated invocation of subroutine C FORM1, see the description of its C parameters MAXDIG and MINDIG. C C Date: 2005, April 7 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