abs.cal 0100666 0000765 0000765 00000000013 06311435250 011650 0 ustar bulant bulant $2=ABS($1) absdif.cal 0100666 0000765 0000765 00000000026 06311435310 012334 0 ustar bulant bulant DIF=$1-$2 $3=ABS(DIF) add.cal 0100666 0000765 0000765 00000000011 06311435262 011634 0 ustar bulant bulant $3=$1+$2 addsob.cal 0100666 0000765 0000765 00000000072 10033450474 012345 0 ustar bulant bulant ABSSOB=ABS(SOBMUL) SOB=ABSSOB*$2 SOB=SOBMUL*SOB $3=$1+SOB append.pl 0100666 0000765 0000765 00000001216 07167013210 012232 0 ustar bulant bulant #!perl #
# # Perl script 'append.pl' to append a file specified by $ARGV[1] (second # command-line argument) to a file specified by $ARGV[0] (first # argument). It does not work correctly with binary data under MS DOS. # ====================================================================== # Main program 'append.pl': # ~~~~~~~~~~~~~~~~~~~~~~~~~ $FILE1=$ARGV[0]; $FILE2=$ARGV[1]; @ARGV=(); require 'go.pl'; &APPEND($FILE1,$FILE2); # ====================================================================== 1; #ascbin.for 0100666 0000765 0000765 00000015076 07230237010 012403 0 ustar bulant bulant C
C Program ASCBIN to convert gridded data (data cubes) from formatted C ascii files to direct-access binary files C C Version: 5.50 C Date: 2001, January 14 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 Attention: Functionality of program ASCBIN is strongly affected by C the Fortran compiler and by the options of the compiler. C Program ASCBIN can work only if the compiler supports unformatted C direct-access files "without headers". C Binary data on little-endian hardware (PC's) and big-endian hardware C (VAX, Alpha, RISC workstations) should strictly be distinguished. C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the input grid: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C Names of the grid files: C GRD='string'... String with the name of the input formatted file C containing the gridded values. The file contains N1*N2*N3 C reals designed to be read by a single list directed (free C format) read statement. C No default, GRD must be specified and cannot be blank. C IN='string'... String with the name of the output unformatted file C to contain the gridded values. The file will contain just C the 4 byte IEEE reals. The length of the file will thus C be exactly 4*N1*N2*N3 bytes. C No default, IN must be specified and cannot be blank. C Data specifying output format: C ESIZE=integer... Number of bytes per a real in the output binary C file. Must be ESIZE=4. C Default: ESIZE=4 C UNDEF=real... If the input ascii file contains undefined values, C the value of UNDEF will be written in place of the C undefined values into the output binary file. C Default: UNDEF=undefined value used in C forms.for C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C C External functions and subroutines: EXTERNAL UARRAY REAL UARRAY C CHARACTER*80 FILE1,FILE2 INTEGER LU1,LU2 PARAMETER (LU1=1,LU2=2) C INTEGER N1,N2,N3,I REAL UNDEF C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+ASCBIN: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 IF (FILE1.NE.' ') THEN CALL RSEP1(LU1,FILE1) ELSE C ASCBIN-01 CALL ERROR('ASCBIN-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Input and output files with gridded data: CALL RSEP3T('GRD',FILE1,' ') IF (FILE1.EQ.' ') THEN C ASCBIN-02 CALL ERROR('ASCBIN-02: Input file not specified') END IF CALL RSEP3T('IN',FILE2,' ') IF (FILE2.EQ.' ') THEN C ASCBIN-03 CALL ERROR('ASCBIN-03: Output file not specified') END IF CALL RSEP3I('ESIZE',I,4) IF (I.NE.4) THEN C ASCBIN-04 CALL ERROR('ASCBIN-04: Binary reals not 4-byte long') END IF CALL RSEP3R('UNDEF',UNDEF,UARRAY()) C C Reading grid dimensions: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) IF (N1*N2*N3.GT.MRAM) THEN C ASCBIN-05 CALL ERROR('ASCBIN-05: Small dimension MRAM of array RAM') END IF C C Reading input grid values: WRITE(*,'(A)') '+ASCBIN: Reading... ' CALL RARRAY(LU1,FILE1,'FORMATTED',.TRUE.,UNDEF,N1*N2*N3,RAM) C C Writing output grid values: WRITE(*,'(A)') '+ASCBIN: Writing... ' CALL WBIN(LU2,FILE2,RAM,N1*N2*N3) C WRITE(*,'(A)') '+ASCBIN: Done. ' STOP END C C======================================================================= C SUBROUTINE WBIN(LU,FILE,GRID,N) INTEGER LU,N CHARACTER*(*) FILE REAL GRID(N) C C----------------------------------------------------------------------- C INTEGER I C C Any Fortran 77 compiler (option "direct files without headers"): OPEN(LU,FILE=FILE,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4) DO 10 I=1,N WRITE(LU,REC=I) GRID(I) 10 CONTINUE C C Lahey F77L3 (compiler-dependent Fortran extension): * OPEN(LU,FILE=FILE,FORM='UNFORMATTED',ACCESS='TRANSPARENT') * WRITE(LU) GRID C CLOSE(LU) RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Catan2.cal 0100666 0000765 0000765 00000000020 06311435332 012107 0 ustar bulant bulant $3=ATAN2($1,$2) binasc.for 0100666 0000765 0000765 00000030126 10062244274 012403 0 ustar bulant bulant C
C Program BINASC to convert gridded data (data cubes) from binary files C to formatted ascii files C C Version: 5.80 C Date: 2004, June 11 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 Attention: Functionality of program BINASC is strongly affected by C the Fortran compiler and by the options of the compiler. C Program BINASC can work only if the compiler supports unformatted C direct-access files "without headers". C Binary data on little-endian hardware (PC's) and big-endian hardware C (VAX, Alpha, RISC workstations) should strictly be distinguished. C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the input grid: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C Optional data enabling to output a sparser grid: C N1NEW=positive integer... Number of output gridpoints along the X1 C axis. C Default: N1NEW=N1 C N2NEW=positive integer... Number of output gridpoints along the X2 C axis. C Default: N2NEW=N2 C N3NEW=positive integer... Number of output gridpoints along the X3 C axis. C Default: N3NEW=N3 C NO1=positive integer... Index of the first output gridpoint along C the X1 axis. C Default: NO1=1 C NO2=positive integer... Index of the first output gridpoint along C the X2 axis. C Default: NO2=1 C NO3=positive integer... Index of the first output gridpoint along C the X3 axis. C Default: NO3=1 C ND1=positive integer... Multiplication factor of the grid interval C along the X1 axis. C Default: ND1=1 C ND2=positive integer... Multiplication factor of the grid interval C along the X2 axis. C Default: ND2=1 C ND3=positive integer... Multiplication factor of the grid interval C along the X3 axis. C Default: ND3=1 C Names of the grid files: C IN='string'... String with the name of the input unformatted file C containing the gridded values. The file should contain C just the 4 byte IEEE reals. The length of the file is C thus exactly 4*N1*N2*N3 bytes. C No default, IN must be specified and cannot be blank. C GRD='string'... String with the name of the output formatted file C to contain the gridded values. The file contains N1*N2*N3 C reals designed to be read by a single list directed (free C format) read statement. C No default, GRD must be specified and cannot be blank. C Data specifying input/output format: C ESIZE=integer... Number of bytes per a real in the input binary C file. Must be ESIZE=4. C Default: ESIZE=4 C NDIG=integer... C NDIG=0: Optimization of the output format is entrusted to C the subroutines of file 'forms.for'. This option is C recommended for calculations with the data. The output C file will usually be only sligtly longer than twice the C input file. C NDIG.NE.0: The output format is '(5(Emm.nn,1X))'), with C mm=IABS(NDIG)+6, nn=IABS(NDIG). Value of NDIG=9 is C probably the smallest one which enables to read exactly C the same values from unformatted and formatted files. C For NDIG=9, the output file will be 4 times (Unix) or C 4.05 times (DOS) longer than the input file. C In general, (NDIG+7)/4 times (Unix) or (NDIG+7.2)/4 C times (DOS). C Minus sign disables to read the formatted file and to C compare the values read from both the files. The minus C option thus saves the time and requires twice less C memory. C Reading the formatted file and comparing the values read C from both the files is also disabled in this version if C the output grid is sparser than the input grid. C Default: NDIG=9 C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C CHARACTER*80 FILE1,FILE2 INTEGER LU1,LU2 PARAMETER (LU1=1,LU2=2) C INTEGER NDIG,N1IN,N2IN,N3IN,N1,N2,N3,I1,I2 REAL DIF C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+BINASC: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 IF (FILE1.NE.' ') THEN CALL RSEP1(LU1,FILE1) ELSE C BINASC-01 CALL ERROR('BINASC-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Input and output files with gridded data: CALL RSEP3T('IN',FILE1,' ') IF (FILE1.EQ.' ') THEN C BINASC-02 CALL ERROR('BINASC-02: Input file not specified') END IF CALL RSEP3T('GRD',FILE2,' ') IF (FILE2.EQ.' ') THEN C BINASC-03 CALL ERROR('BINASC-03: Output file not specified') END IF CALL RSEP3I('ESIZE',I1,4) IF (I1.NE.4) THEN C BINASC-04 CALL ERROR('BINASC-04: Binary reals not 4-byte long') END IF CALL RSEP3I('NDIG',NDIG,9) C C Reading grid dimensions: CALL RSEP3I('N1',N1IN,1) CALL RSEP3I('N2',N2IN,1) CALL RSEP3I('N3',N3IN,1) CALL RSEP3I('N1NEW',N1,N1IN) CALL RSEP3I('N2NEW',N2,N2IN) CALL RSEP3I('N3NEW',N3,N3IN) IF (N1*N2*N3.GT.MRAM) THEN C BINASC-05 CALL ERROR('BINASC-05: Small dimension MRAM of array RAM') END IF C C Reading input grid values: WRITE(*,'(A)') '+BINASC: Reading... ' CALL RBIN(LU1,FILE1,RAM,N1*N2*N3) C C Writing output grid values: IF (NDIG.EQ.0) THEN CALL WARRAY(LU2,FILE2,'FORMATTED',.FALSE.,0.,.FALSE.,0., * N1*N2*N3,RAM) ELSE WRITE(*,'(A)') '+BINASC: Writing... ' CALL WASC(LU2,FILE2,RAM,N1*N2*N3,NDIG) END IF C C Comparison of values read from unformatted and formatted files: IF (NDIG.GT.0.AND.N1.EQ.N1IN * .AND.N2.EQ.N2IN * .AND.N3.EQ.N3IN) THEN C Twice the memory is required for the comparison IF (2*N1*N2*N3.GT.MRAM) THEN C BINASC-06 CALL ERROR('BINASC-06: Small dimension MRAM of array RAM') END IF C Reading output grid values CALL RARRAY(LU2,FILE2,'FORMATTED',.TRUE.,0., * N1*N2*N3,RAM(N1*N2*N3+1)) C Comparing grid values WRITE(*,'(A)') '+BINASC: Checking... ' DIF=0. I2=N1*N2*N3 DO 10 I1=1,N1*N2*N3 I2=I2+1 IF(RAM(I1).NE.RAM(I2)) THEN DIF=AMAX1(ABS((RAM(I1)-RAM(I2))/RAM(I1)),DIF) END IF 10 CONTINUE WRITE(*,'(A,E15.7)') '+BINASC: Done. Max.rel.difference: ',DIF ELSE WRITE(*,'(A)') '+BINASC: Done. ' END IF C STOP END C C======================================================================= C SUBROUTINE RBIN(LU,FILE,GRID,N) INTEGER LU,N CHARACTER*(*) FILE REAL GRID(N) C C----------------------------------------------------------------------- C INTEGER N1IN,N2IN,N3IN,N1,N2,N3,NO1,NO2,NO3,ND1,ND2,ND3 INTEGER I1,I2,I3,I1MIN,I2MIN,I3MIN,I1MAX,I2MAX,I3MAX,IREC,I C C Any Fortran 77 compiler (option "direct files without headers"): OPEN(LU,FILE=FILE,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4, * STATUS='OLD') C C Reading grid dimensions: CALL RSEP3I('N1',N1IN,1) CALL RSEP3I('N2',N2IN,1) CALL RSEP3I('N3',N3IN,1) CALL RSEP3I('N1NEW',N1,N1IN) CALL RSEP3I('N2NEW',N2,N2IN) CALL RSEP3I('N3NEW',N3,N3IN) IF (N1.EQ.N1IN.AND.N2.EQ.N2IN.AND.N3.EQ.N3IN) THEN DO 10 I=1,N READ(LU,REC=I) GRID(I) 10 CONTINUE C C Lahey F77L3 (compiler-dependent Fortran extension): * OPEN(LU,FILE=FILE,FORM='UNFORMATTED',ACCESS='TRANSPARENT') * READ(LU) GRID ELSE CALL RSEP3I('NO1',NO1,1) CALL RSEP3I('NO2',NO2,1) CALL RSEP3I('NO3',NO3,1) CALL RSEP3I('ND1',ND1,1) CALL RSEP3I('ND2',ND2,1) CALL RSEP3I('ND3',ND3,1) I1MIN=NO1 I2MIN=NO2-1 I3MIN=NO3-1 I1MAX=I1MIN+(N1-1)*ND1 I2MAX=I2MIN+(N2-1)*ND2 I3MAX=I3MIN+(N3-1)*ND3 I=0 DO 23 I3=I3MIN,I3MAX,ND3 DO 22 I2=I2MIN,I2MAX,ND2 IREC=I1MIN+N1IN*(I2+N2IN*I3) DO 21 I1=I1MIN,I1MAX,ND1 I=I+1 READ(LU,REC=IREC) GRID(I) IREC=IREC+ND1 21 CONTINUE 22 CONTINUE 23 CONTINUE END IF C CLOSE(LU) RETURN END C C======================================================================= C SUBROUTINE WASC(LU,FILE,GRID,N,NDIG) INTEGER LU,N,NDIG CHARACTER*(*) FILE REAL GRID(N) C C----------------------------------------------------------------------- C INTRINSIC IABS,MOD INTEGER IABS,MOD CHARACTER*14 FORMAT C OPEN(LU,FILE=FILE,FORM='FORMATTED') FORMAT='(5(E06.00,1X))' FORMAT(9:9)=CHAR(ICHAR('0')+MOD(IABS(NDIG),10)) FORMAT(8:8)=CHAR(ICHAR('0')+ IABS(NDIG)/10 ) FORMAT(6:6)=CHAR(ICHAR('0')+MOD(IABS(NDIG)+6,10)) FORMAT(5:5)=CHAR(ICHAR('0')+ (IABS(NDIG)+6)/10) WRITE(LU,FORMAT) GRID CLOSE(LU) RETURN END C C======================================================================= C SUBROUTINE RASC(LU,FILE,GRID,N) INTEGER LU,N CHARACTER*(*) FILE REAL GRID(N) C C----------------------------------------------------------------------- C OPEN(LU,FILE=FILE,FORM='FORMATTED',STATUS='OLD') READ(LU,*) GRID CLOSE(LU) RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Ccalcomp.for 0100666 0000765 0000765 00000070724 06606324206 012575 0 ustar bulant bulant C
C CalComp-GKS interface C C Date: 1998, October 6 C Coded by Ludek Klimes C C This file contains the CalComp plotting routines C PLOTS, PLOT, NEWPEN, SYMBOL and NUMBER C PLOTS C PLOT C NEWPEN C SYMBOL C NUMBER C coded in the ANSI X3.9-1978 FORTRAN77 standard full language employing C the ANSI X3.124-1985 GKS (Graphical Kernel System) Level 0b C subroutines. Whereas the original CalComp routines are conformable to C the ANSI X3.10-1966 FORTRAN standard, the dummy argument text of the C subroutine SYMBOL is declared here as C CHARACTER*(*) TEXT C in order to conform to the ANSI X3.9-1978 FORTRAN77 standard. In this C way, the subroutine SYMBOL is not conformal to the original CalComp C specification. C C CalComp configuration: C INTERACTIVE WORKSTATION... Identifier of the interactive C workstation, i.e. the workstation at which the user is C asked to confirm or reset the configuration. The plot C on the interactive workstation is not erased before the C user's confirmation. The identifier of the interactive C workstation may be changed only by means of editing the C configuration file. Zero or none identifier leads to the C batch mode in which all plots are made without asking the C user for confirmation. C Note, that in this interface, the workstation identifier, C connection identifier, and workstation type are the same C integer referred in the GKS configuration file kernel.sys. C OPEN WORKSTATIONS... Identifiers of the workstations which are to C be opened for plotting. The list open workstations may be C changed through the interactive workstation before C starting each plot, or by means of editing the C configuration file. C CALCOMP PLOT WINDOW... The dimensions of picture in the CalComp C units. The CalComp plot window is mapped onto the largest C rectangle within the workstation viewport, having the same C aspect ratio as the CalComp plot window. The CalComp plot C window may be reset through the interactive workstation C before starting each plot, or by means of editing the C configuration file. C Note that the workstation viewport is the maximum plot C area of the workstation. C COLOUR REPETITION... If this integer is set to N, colours 2 to N C are periodically repeated representing also colour indices C N+1 to 2*N-1, 2*N to 3*N-2, 3*N-1 to 4*N-3, and so on. C This unimportant option may be set only by means of C editing the configuration file. C 'COLOUR TABLE'... String representing the name of the disk file C containing the colour table. If blank (default), C no colour table is read and 16 default colours 0 to 15, C defined in subroutine PLOTS, are used. Otherwise, the C colours specified in the disk file are redefined or C defined in addition to the default colours. See the C description of the CalComp colour table file below. C C CalComp configuration file 'calcomp.cfg': C When the CalComp configuration is changed, this interface creates C file calcomp.cfg containing the new configuration in the current C directory. As long as the file calcomp.cfg lives in the current C directory, the CalComp configuration is taken from calcomp.cfg. C Thus, to return to the default CalComp configuration, simply C delete calcomp.cfg. C C Error listing file 'calcomp.lst': C File calcomp.lst is created in the current directory in order to C contain the GKS error messages. C C CalComp colour table file: C The file is read by list-directed (free format) input, and C consists of lines defining individual colours. Each line contains C four numbers: C K,R,G,B C K... Index of the colour to be defined. Non-negative integer. C R... Content of the red colour. Real between 0 and 1. C G... Content of the green colour. Real between 0 and 1. C B... Content of the blue colour. Real between 0 and 1. C C======================================================================= C C C SUBROUTINE PLOTS(I1,I2,I3) INTEGER I1,I2,I3 C C Input: C I1,I2,I3... Dummy parameters - ignored. C No output. C C Common block /PLOTC/: INCLUDE 'calcomp.inc' C calcomp.inc C C Subroutines and external functions required: REAL RNUM EXTERNAL RNUM,NEWPEN,NUMBER EXTERNAL GOPKS,GOPWK,GACWK,GCLRWK,GDAWK,GCLWK,GSWKWN,GQOPWK,GQEWK EXTERNAL GQWKCA,GQWKCL,GQDSP,GSCHH,GSCR,GSTXCI,GTX,GINST,GRQST C RNUM... Auxiliary real function converting a string into the C corresponding number. This file. C NEWPEN,NUMBER... This file. C G*****... GKS standard subroutines. C C Date: 1998, September 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: C CHARACTER*80 STR(1),CTABLE INTEGER LUCFG,LUERR,IERR,LENGTH,IC1,IC2,I,J,K,N,NDEC,IDC,IX,IY PARAMETER (LUCFG=97) PARAMETER (LUERR=98) REAL RX,RY,XMAX,YMAX,XNDC,YNDC REAL X1,X2,X3,X4,X5,X6,X7,Y,YH,HEIGHT,R,G,B REAL RX1,RX2,RY1,RY2 C REAL AUX C C STR... Temporary string storage location. C CTABLE..Name of the file containing colour table. C LUCFG...Logical unit number of the CalComp configuration file C calcomp.lst. C LUERR...Logical unit number of the error file calcomp.lst. C IERR... Error code. C LENGTH... Length of a string. C IC1,IC2... Text colour indices when writing to the display. C I,J,K,N... Temporary storage locations. C NDEC... Number of decimal places. C IDC... Workstation units (0... metres, 1... relative). C IX,IY...Dimensions of a workstation viewport in pixels. C RX,RY...Dimensions of a workstation viewport in the workstation C units. C XMAX,YMAX... Dimensions of the CalComp plot window in centimeters. C XNDC,YNDC... Dimensions of the CalComp plot window in NDC units. C X1,X2,X3,X4,X5,X6,X7,Y... World coordinates. C YH... Line spacing. C HEIGHT..Character height. C R,G,B,RX1,RX2,RY1,RY2,AUX... Temporary storage locations. C C....................................................................... C C Opening GKS: OPEN(LUERR,FILE='calcomp.lst') WRITE(LUERR,'(A)') 'GKS ERROR MESSAGES:' CALL GOPKS(LUERR,-1) C C Reading CalComp parameters: 1 CONTINUE C Default CalComp parameters IUSER=0 DO 2 I=1,MOPEN IOPEN(I)=0 2 CONTINUE XMAX=29.7 YMAX=21.0 KOLREP=0 CTABLE=' ' OPEN(LUCFG,FILE='calcomp.cfg',STATUS='OLD',IOSTAT=IERR) IF(IERR.EQ.0) THEN C Reading the parameters from the CalComp configuration file READ(LUCFG,*,END=4) IUSER READ(LUCFG,*,END=4) IOPEN READ(LUCFG,*,END=4) XMAX,YMAX READ(LUCFG,*,END=4) KOLREP READ(LUCFG,*,END=4) CTABLE 4 CONTINUE CLOSE(LUCFG) ELSE IUSER=1 IOPEN(1)=1 END IF DO 5 I=1,MOPEN IF(IOPEN(I).LE.0) THEN NOPEN=I-1 GO TO 6 END IF 5 CONTINUE NOPEN=MOPEN 6 CONTINUE IF(IUSER.LE.0) THEN GO TO 20 END IF C C *** beginning of the interactive part *** C C Displaying CalComp parameters: CALL GQOPWK(1,IERR,N,I) IF(IERR.EQ.0.AND.N.EQ.1.AND.IUSER.EQ.I) THEN C Interactive workstation already open CALL GCLRWK(IUSER,1) ELSE IF(IERR.NE.0.OR.N.EQ.0) THEN C Interactive workstation closed CALL GOPWK(IUSER,IUSER,IUSER) CALL GACWK(IUSER) ELSE C CALCOMP-01 CALL ERROR * ('CALCOMP-01: Error when opening interactive workstation') END IF X1=0.00 X2=0.22 X3=0.50 X4=0.64 X5=0.67 X6=0.82 X7=0.94 YH=0.04 HEIGHT=0.65*YH CALL GSCHH(HEIGHT) Y=1.-YH IC1=1 IC2=5 CALL GSCR(IUSER, 0,0.0,0.6,0.0) CALL GSCR(IUSER,IC1,1.0,1.0,1.0) CALL GSCR(IUSER,IC2,1.0,1.0,0.0) CALL GSTXCI(IC1) CALL GTX(X1,Y,'FORTRAN77 CalComp to GKS conversion software.') Y=Y-2.*YH CALL GTX(X1,Y,'Workstation:') CALL GTX(X2,Y,'Classification:') CALL GTX(X3,Y,'Viewport size:') CALL GTX(X6,Y,'Units:') CALL GTX(X7,Y,'Status:') CALL GQEWK(1,IERR,N,K) IF(IERR.EQ.0) THEN DO 15 J=1,N CALL GQEWK(J,IERR,N,K) IF(IERR.EQ.0) THEN CALL GQWKCA(K,IERR,I) IF(IERR.EQ.0.AND.(I.EQ.0.OR.I.EQ.2.OR.I.EQ.4)) THEN C Workstation is of the category: OUTPUT, OUTIN or MO. Y=Y-YH C (1) Workstation CALL NUMBER(X1,Y,HEIGHT,FLOAT(K),0.,-1) C (2) Classification CALL GQWKCL(K,IERR,I) IF(IERR.EQ.0) THEN IF(I.EQ.0) THEN STR(1)='VECTOR' ELSE IF(I.EQ.1) THEN STR(1)='RASTER' ELSE STR(1)='OTHER' END IF CALL GTX(X2,Y,STR(1)) END IF C (3-6) Viewport size and its units CALL GQDSP(K,IERR,IDC,RX,RY,IX,IY) IF(IERR.EQ.0) THEN IF(IDC.EQ.0) THEN STR(1)='cm' RX=RX*100. RY=RY*100. NDEC=2 ELSE STR(1)=' ' C AUX=AMAX1(XMAX/RX,YMAX/RY) C RX=RX*AUX C RY=RY*AUX IF(RX.LT.0.99995) THEN RX=RX*100. RY=RY*100. NDEC=2 ELSE IF(IX.LT.9999) THEN RX=FLOAT(IX) RY=FLOAT(IY) NDEC=-1 ELSE IF(RX.LT.99.95) THEN NDEC=1 ELSE NDEC=-1 END IF END IF END IF END IF CALL NUMBER(X3,Y,HEIGHT,RX,0.,NDEC) CALL GTX(X4,Y,'*') CALL NUMBER(X5,Y,HEIGHT,RY,0.,NDEC) CALL GTX(X6,Y,STR(1)) END IF C (7) Status STR(1)='CLOSED' DO 14 I=1,NOPEN IF(IOPEN(I).EQ.K) THEN STR(1)='OPEN' END IF 14 CONTINUE CALL GSTXCI(IC2) CALL GTX(X7,Y,STR(1)) CALL GSTXCI(IC1) END IF END IF 15 CONTINUE END IF Y=Y-2.*YH CALL GTX(X1,Y,'CalComp plotting window:') CALL GSTXCI(IC2) CALL NUMBER(X3,Y,HEIGHT,XMAX,0.,2) CALL GSTXCI(IC1) CALL GTX(X4,Y,'*') CALL GSTXCI(IC2) CALL NUMBER(X5,Y,HEIGHT,YMAX,0.,2) CALL GSTXCI(IC1) CALL GTX(X6,Y,'cm') Y=Y-YH CALL GTX(X1,Y,'Colour-table filename:') IF(CTABLE.EQ.' ') THEN CALL GTX(X3,Y,'NONE') ELSE CALL GSTXCI(IC2) CALL GTX(X3,Y,CTABLE) CALL GSTXCI(IC1) END IF Y=Y-2.*YH CALL GTX(X1,Y, * 'Enter a digit to open/close the corresponding workstation,') Y=Y-YH CALL GTX(X1,Y, * 'Enter ''W'' to change the CalComp plotting window,') Y=Y-YH CALL GTX(X1,Y, * 'Enter ''C'' to change the colour-table filename,') Y=Y-YH CALL GTX(X1,Y, * 'Press ''ENTER'' to continue.') Y=Y-2.*YH CALL GTX(X1,Y, * 'After plotting, press ''ENTER'' again to continue.') C C Changing CalComp parameters: CALL GQDSP(IUSER,IERR,IDC,RX,RY,IX,IY) RX1=0.00*RX RX2=1.00*RX RY1=0.01*RY RY2=0.99*RY CALL GINST(IUSER,IUSER,14,'YOUR ANSWER: ', * 1,RX1,RX2,RY1,RY2,80,14,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) IF(LLE('1',STR(1)(14:14)).AND.LLE(STR(1)(14:14),'9')) THEN DO 17 J=1,NOPEN IF(IOPEN(J).EQ.ICHAR(STR(1)(14:14))-ICHAR('0')) THEN NOPEN=NOPEN-1 DO 16 I=J,NOPEN IOPEN(I)=IOPEN(I+1) 16 CONTINUE GO TO 18 END IF 17 CONTINUE NOPEN=NOPEN+1 IOPEN(NOPEN)=ICHAR(STR(1)(14:14))-ICHAR('0') 18 CONTINUE ELSE IF(STR(1)(14:14).EQ.'W'.OR.STR(1)(14:14).EQ.'w') THEN CALL GINST(IUSER,IUSER,33,'ENTER HORIZONTAL DIMENSION: ', * 1,RX1,RX2,RY1,RY2,80,29,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) XMAX=RNUM(STR(1),LENGTH) CALL GINST(IUSER,IUSER,33,'ENTER VERTICAL DIMENSION: ', * 1,RX1,RX2,RY1,RY2,80,27,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) YMAX=RNUM(STR(1),LENGTH) ELSE IF(STR(1)(14:14).EQ.'C'.OR.STR(1)(14:14).EQ.'c') THEN CALL GINST(IUSER,IUSER,33,'ENTER COLOUR TABLE FILENAME: ', * 1,RX1,RX2,RY1,RY2,80,30,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) CTABLE=STR(1)(INDEX(STR(1),':')+2:LEN(STR(1))) ELSE GO TO 20 END IF C C Writing CalComp parameters into the CalComp configuration file: OPEN(LUCFG,FILE='calcomp.cfg') WRITE(LUCFG,*) IUSER, ' / INTERACTIVE WORKSTATION' WRITE(LUCFG,*) (IOPEN(I),I=1,NOPEN),' / OPEN WORKSTATIONS' WRITE(LUCFG,*) XMAX,YMAX, ' / CALCOMP PLOT WINDOW' WRITE(LUCFG,*) KOLREP, ' / COLOUR REPETITION' I=LEN(CTABLE)+1 19 CONTINUE I=I-1 IF(I.GT.1.AND.CTABLE(I:I).EQ.' ') GO TO 19 WRITE(LUCFG,*) '''',CTABLE(1:I), ''' / COLOUR-TABLE FILE' CLOSE(LUCFG) GO TO 1 C C *** end of the interactive part *** C C Opening and activating workstations 20 CONTINUE XNDC=XMAX/AMAX1(XMAX,YMAX) YNDC=YMAX/AMAX1(XMAX,YMAX) DO 27 I=1,NOPEN IF(IOPEN(I).EQ.IUSER) THEN CALL GCLRWK(IOPEN(I),1) ELSE CALL GOPWK(IOPEN(I),IOPEN(I),IOPEN(I)) CALL GACWK(IOPEN(I)) END IF CALL GSWKWN(IOPEN(I),0.,XNDC,0.,YNDC) C C Default colour representation C R20(dB): 1.00 0.90 0.80 0.71 0.63 0.56 0.50 C R40(dB/2): 0.95 0.85 0.75 0.67 0.60 0.53 C IF(IOPEN(I).EQ.IUSER) THEN CALL GSCR(IOPEN(I), 0,1.00,1.00,1.00) CALL GSCR(IOPEN(I), 1,0.00,0.00,0.00) CALL GSCR(IOPEN(I), 2,1.00,0.00,0.00) CALL GSCR(IOPEN(I), 3,0.00,0.90,0.00) CALL GSCR(IOPEN(I), 4,0.00,0.00,1.00) CALL GSCR(IOPEN(I), 5,1.00,0.90,0.00) CALL GSCR(IOPEN(I), 6,0.00,0.80,0.90) CALL GSCR(IOPEN(I), 7,0.90,0.00,0.90) CALL GSCR(IOPEN(I), 8,0.90,0.63,0.50) CALL GSCR(IOPEN(I), 9,0.63,0.63,0.63) CALL GSCR(IOPEN(I),10,0.95,0.00,0.71) CALL GSCR(IOPEN(I),11,0.71,0.85,0.00) CALL GSCR(IOPEN(I),12,0.00,0.63,0.95) CALL GSCR(IOPEN(I),13,0.95,0.63,0.00) CALL GSCR(IOPEN(I),14,0.00,0.85,0.71) CALL GSCR(IOPEN(I),15,0.71,0.00,0.95) 27 CONTINUE IF(IUSER.NE.0) THEN DO 28 I=1,NOPEN IF(IOPEN(I).EQ.IUSER) THEN GO TO 29 END IF 28 CONTINUE C Closing the display CALL GDAWK(IUSER) CALL GCLWK(IUSER) 29 CONTINUE END IF C C Setting coordinate transformation: CALL GSVP(1,0.,XNDC,0.,YNDC) CALL GSWN(1,0.,XMAX,0.,YMAX) CALL GSELNT(1) C C Reading colour table from a disk file: IF(CTABLE.NE.' ') THEN OPEN(LUCFG,FILE=CTABLE,STATUS='OLD',IOSTAT=IERR) IF(IERR.EQ.0) THEN 31 CONTINUE K=-999 READ(LUCFG,*,END=39) K,R,G,B IF(K.LT.0) THEN GO TO 39 END IF DO 32 I=1,NOPEN CALL GSCR(IOPEN(I),K,R,G,B) 32 CONTINUE GO TO 31 39 CONTINUE CLOSE(LUCFG) ELSE C CALCOMP-51 CALL WARN('CALCOMP-51: Colour table file not found') END IF END IF C C CalComp plotting initialization: ICOUNT=0 STARTX=0. STARTY=0. OLDX=0. OLDY=0. KOLOR=0 CALL NEWPEN(1) RETURN END C C----------------------------------------------------------------------- C C C REAL FUNCTION RNUM(STR,LENGTH) CHARACTER*(*) STR INTEGER LENGTH C C Auxiliary function to PLOTS, converting an input string to the real C number, used in the interactive part of the PLOTS subroutine. C C....................................................................... C C Auxiliary storage locations: INTEGER I REAL AUX1,AUX2,AUX3 C AUX1=0. AUX2=1. AUX3=1. DO 10 I=1,LENGTH IF(LLE('0',STR(I:I)).AND.LLE(STR(I:I),'9')) THEN AUX1=AUX1*10.+FLOAT(ICHAR(STR(I:I))-ICHAR('0')) AUX2=AUX2*AUX3 ELSE IF(STR(I:I).EQ.'.') THEN AUX3=0.1 END IF 10 CONTINUE RNUM=AUX1*AUX2 RETURN END C C======================================================================= C C C SUBROUTINE PLOT(XPAGE,YPAGE,IPEN) REAL XPAGE,YPAGE INTEGER IPEN C C Input: C XPAGE,YPAGE... Coordinates of a point, in centimetres from the C current reference point (origin), of the position to which C the pen is to be moved. C IPEN... A signed integer which controls pen status (up or down) C and the origin definition: C IPEN=2... The pen is down during movement, thus drawing a C visible line. C IPEN=3... The pen is up during movement. C IPEN=-2 OR -3... A new origin is defined at the terminal C position after the movement is completed as if IPEN were C positive. C IPEN=999... Output device is closed. C No output. C C Common block /PLOTC/: INCLUDE 'calcomp.inc' C calcomp.inc C C Subroutines and external functions required: EXTERNAL GDAWK,GCLWK,GCLKS,GQDSP,GPL,GINST,GRQST,GESC C G*****... GKS standard subroutines. C C Date: 1993, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: CHARACTER*80 STR(1) INTEGER IERR,LENGTH,I,IDC,IX,IY REAL RX,RY C C IERR... Error code. C LENGTH... Length of a string. C I... Loop variable. C IDC... Workstation units (0... metres, 1... relative). C IX,IY...Dimensions of a workstation viewport in pixels. C RX,RY...Dimensions of a workstation viewport in the workstation C units. C C....................................................................... C C Recording or plotting the polyline: IF(IABS(IPEN).EQ.2) THEN 1 CONTINUE IF(ICOUNT.EQ.0) THEN ICOUNT=1 PX(1)=STARTX+OLDX PY(1)=STARTY+OLDY END IF IF(ICOUNT.LT.MCOUNT) THEN IF(XPAGE.NE.OLDX.OR.YPAGE.NE.OLDY) THEN ICOUNT=ICOUNT+1 PX(ICOUNT)=STARTX+XPAGE PY(ICOUNT)=STARTY+YPAGE END IF ELSE CALL GPL(ICOUNT,PX,PY) ICOUNT=0 GO TO 1 END IF END IF IF(IPEN.NE.2) THEN IF(ICOUNT.GT.0) THEN IF(ICOUNT.EQ.1) THEN ICOUNT=2 PX(2)=PX(1) PY(2)=PY(1) END IF CALL GPL(ICOUNT,PX,PY) ICOUNT=0 END IF END IF C C Moving the origin: IF(IPEN.GE.0) THEN OLDX=XPAGE OLDY=YPAGE ELSE STARTX=STARTX+XPAGE STARTY=STARTY+YPAGE OLDX=0. OLDY=0. END IF C C Closing CalComp: IF(IPEN.GE.999) THEN C Closing workstations DO 91 I=1,NOPEN IF(IOPEN(I).NE.IUSER) THEN C Closing batch workstations (other than the display) CALL GDAWK(IOPEN(I)) CALL GCLWK(IOPEN(I)) END IF 91 CONTINUE DO 92 I=1,NOPEN IF(IOPEN(I).EQ.IUSER) THEN C Prompting to close the display CALL GESC(-1,1,CHAR(7),1,LENGTH,STR) CALL GESC(-1,1,CHAR(7),1,LENGTH,STR) CALL GESC(-1,1,CHAR(7),1,LENGTH,STR) CALL GQDSP(IUSER,IERR,IDC,RX,RY,IX,IY) CALL GINST(IUSER,IUSER,1,' ',1,0.,RX,0.,RY,80,1,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) CALL GDAWK(IUSER) CALL GCLWK(IUSER) END IF 92 CONTINUE CALL GCLKS END IF RETURN END C C======================================================================= C C C SUBROUTINE NEWPEN(INP) INTEGER INP C C Input: C INP... Number of the pen or colour index to be selected. C No output. C C Common block /PLOTC/: INCLUDE 'calcomp.inc' C calcomp.inc C C Subroutines and external functions required: EXTERNAL GSPLCI,GSPMCI,GSTXCI,GPL C G*****... GKS standard subroutines. C C Date: 1993, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage location: INTEGER I C C I... Colour assigned to the input colour index. C C....................................................................... C IF(INP.NE.KOLOR) THEN C C Plotting the recorded polyline: IF(ICOUNT.GT.0) THEN IF(ICOUNT.EQ.1) THEN ICOUNT=2 PX(2)=PX(1) PY(2)=PY(1) END IF CALL GPL(ICOUNT,PX,PY) ICOUNT=0 END IF C C Changing the colour indices C (for KOLREP.GT.1, colours 2 to KOLREP are periodically repeated) IF(KOLREP.GT.1) THEN I=MOD(INP-2,KOLREP-1)+2 ELSE I=INP END IF CALL GSPLCI(I) CALL GSPMCI(I) CALL GSTXCI(I) C KOLOR=INP END IF RETURN END C C======================================================================= C C C SUBROUTINE SYMBOL(XPAGE,YPAGE,HEIGHT,TEXT,ANGLE,NCHAR) REAL XPAGE,YPAGE,HEIGHT,ANGLE CHARACTER TEXT*(*) INTEGER NCHAR C C Input: C XPAGE,YPAGE... Coordinates, in centimetres, of the lower left-hand C corner of the first character to be produced. C Continuation occurs when XPAGE and YPAGE equals 999. C HEIGHT..Height, in centimetres, of the characters to be plotted. C The character width, including spacing, is normally the C same as the height. C TEXT... String containing the text to be plotted. C ANGLE...Angle, in degrees anticlockwise from the X-axis, at which C the text is to be plotted. C NCHAR...NCHAR.GT.0: number of characters to be drawn. C NCHAR.EQ.0: one character is to be drawn C NCHAR.LT.0: to plot a centred symbol no. ICHAR(TEXT(1:1)). C NCHAR.EQ.-1: the pen is up during the move. C NCHAR.EQ.-2: the pen is down during the move. C No output. C C Common block /PLOTC/: INCLUDE 'calcomp.inc' C calcomp.inc C C Subroutines and external functions required: EXTERNAL PLOT EXTERNAL GSCHH,GSCHUP,GTX,GSMKSC,GSMK,GPM,GPL C PLOT... This file. C G*****... GKS standard subroutines. C C Date: 1995, May 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL X,Y,UX,UY C C X,Y... Coordinates. C UX,UY...Text path vector. C C....................................................................... C X=XPAGE Y=YPAGE IF(ABS(X).GT.998.) X=OLDX IF(ABS(Y).GT.998.) Y=OLDY IF(NCHAR.EQ.-2) THEN CALL PLOT(X,Y,2) END IF C C Plotting the recorded polyline: IF(ICOUNT.GT.0) THEN IF(ICOUNT.EQ.1) THEN ICOUNT=2 PX(2)=PX(1) PY(2)=PY(1) END IF CALL GPL(ICOUNT,PX,PY) ICOUNT=0 END IF C UX= COS(.0174533*ANGLE) UY= SIN(.0174533*ANGLE) IF(NCHAR.GE.0) THEN C standard call - text: CALL GSCHH(HEIGHT) CALL GSCHUP(-UY,UX) DO 1 I=1,MAX0(NCHAR,1) CALL GTX(STARTX+X,STARTY+Y,TEXT(I:I)) X=X+UX*HEIGHT Y=Y+UY*HEIGHT 1 CONTINUE ELSE C Special call - centred symbol: * CALL GSMKSC(HEIGHT/'NOMINAL MARKER SIZE') CALL GSMK(ICHAR(TEXT(1:1))) PX(1)=STARTX+X PY(1)=STARTY+Y CALL GPM(1,PX,PY) END IF OLDX=X OLDY=Y RETURN END C C======================================================================= C C C SUBROUTINE NUMBER (XPAGE,YPAGE,HEIGHT,FPN,ANGLE,NDEC) REAL XPAGE,YPAGE,HEIGHT,FPN,ANGLE INTEGER NDEC C C Input: C XPAGE,YPAGE... Coordinates, in centimetres, of the lower left-hand C corner of the first character to be produced. C Continuation occurs when XPAGE and YPAGE equals 999. C HEIGHT..Height, in centimetres, of the characters to be plotted. C The character width, including spacing, is normally the C same as the height. C FPN... Floating point number to be plotted. C ANGLE...Angle, in degrees anticlockwise from the X-axis, at which C the number is to be plotted. C NDEC... Controls the precision of the conversion of the number C FPN. C NDEC.GE.0: number of decimal places to be drawn, after C rounding. C NDEC.EQ.-1: only the integer portion is to be plotted, C after rounding. C NDEC.LE.-2: -NDEC-1 digits are truncated from the integer C portion, after rounding. C The magnitude of NDEC should not exceed 9. C No output. C C Subroutines and external functions required: EXTERNAL SYMBOL C SYMBOL..This file. C C Date: 1993, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER N,ILP,I,J,K REAL X,Y,FPV,SAMEV PARAMETER (SAMEV=999.) C C N... Storage for (possibly modified) NDEC. C ILP... Length of the integer part of the given number. C I... Temporary storage. C J... Loop variable. C K... Digit to plot. C X,Y... Coordinates. C FPV... Storage for FPN and its decimal modules. C C....................................................................... C X=XPAGE Y=YPAGE FPV=FPN N=MIN0(MAX0(-9,NDEC),9) C C Minus sign: IF (FPV.LT.0) THEN CALL SYMBOL (X,Y,HEIGHT,'-',ANGLE,1) X=SAMEV Y=SAMEV END IF C C To guarantee a correct rounding: IF (N.GE.0) THEN FPV=ABS(FPV)+(0.5*0.1**N) ELSE FPV=ABS(FPV)+(0.05*0.1**N) END IF C C Integer part of the given number: I=INT(ALOG10(FPV)+1.0) IF(N.GE.-1) THEN ILP=I ELSE ILP=I+N+1 END IF IF (ILP.LE.0) THEN CALL SYMBOL (X,Y,HEIGHT,'0',ANGLE,1) X=SAMEV Y=SAMEV ELSE DO 60 J=1,ILP K=FPV*10.**(J-I) CALL SYMBOL (X,Y,HEIGHT,CHAR(ICHAR('0')+K),ANGLE,1) FPV=FPV-(FLOAT(K)*10.**(I-J)) X=SAMEV Y=SAMEV 60 CONTINUE END IF C C Decimal places: IF(N.GE.0) THEN CALL SYMBOL (X,Y,HEIGHT,'.',ANGLE,1) DO 70 J=1,N K=FPV*10. CALL SYMBOL(X,Y,HEIGHT,CHAR(ICHAR('0')+K),ANGLE,1) FPV=FPV*10.-FLOAT(K) 70 CONTINUE END IF RETURN END C C======================================================================= Ccalcomp.inc 0100666 0000765 0000765 00000002672 07050447520 012554 0 ustar bulant bulant C
C INCLUDE 'calcomp.inc' C ------------------------------------------------------------------ INTEGER MOPEN,MCOUNT PARAMETER (MOPEN=9) PARAMETER (MCOUNT=1024) INTEGER IUSER,IOPEN(MOPEN),NOPEN,KOLREP,KOLOR,ICOUNT REAL PX(MCOUNT),PY(MCOUNT),STARTX,STARTY,OLDX,OLDY COMMON/PLOTC/ IUSER,IOPEN,NOPEN,KOLREP,KOLOR,ICOUNT, * PX,PY,STARTX,STARTY,OLDX,OLDY SAVE /PLOTC/ C ------------------------------------------------------------------ C IUSER...Identifier of the interactive workstation. C IOPEN...Array containing the identifiers of the open workstations. C NOPEN...Number of the open workstations. C KOLREP..for KOLREP.GT.1, colours 2 to KOLREP are periodically C repeated. C ICOUNT..Number of stored polyline vertices. C PX,PY...Arrays to store the coordinates of polyline vertices. C STARTX,STARTY... Origin of CalComp coordinates in world C coordinates. C OLDX,OLDY... Point referred during the previous invocation of a C CalComp subroutine, in CalComp coordinates. C C Common block /PLOTC/ is included in FORTRAN 77 source code file C 'calcomp.for'. C C Date: 1996, July 8 C Coded by Ludek Klimes C C======================================================================= Ccalcops.for 0100666 0000765 0000765 00000060010 07214344010 012555 0 ustar bulant bulant C
C CalComp-PostScript interface C C Version: 5.50 C Date: 2000, December 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 contains the CalComp plotting routines C PLOTS C PLOT C NEWPEN C SYMBOL C NUMBER C supplemented with additional filename-specification entry C PLOTN C and with additional area filling routine C FILL C coded in the ANSI X3.9-1978 FORTRAN77 standard full language. C The graphical output is generated in the form of ASCII files coded in C the PostScript Level 2 Language - Encapsulated PostScript File Format C Version 3.0. C C Whereas the original CalComp routines are conformable to the ANSI C X3.10-1966 FORTRAN standard, the dummy argument text of the subroutine C SYMBOL is declared here as C CHARACTER*(*) TEXT C in order to conform to the ANSI X3.9-1978 FORTRAN77 standard. In this C way, the subroutine SYMBOL is not conformal to the original CalComp C specification. C C Possible input file - CalComp colour table file 'calcops.rgb': C The file is taken into account if exists in the current directory. C If there is no 'calcops.rgb' file, default colours are used. C The file is read by list-directed (free format) input, and C consists of lines defining individual colours. Each line contains C four numbers: C K,R,G,B C K... Index of the colour to be defined. Non-negative integer. C Colours greater than MCOLOR (see include file C 'calcops.inc') are not taken into account. C calcops.inc C R... Content of the red colour. Real between 0 and 1. C G... Content of the green colour. Real between 0 and 1. C B... Content of the blue colour. Real between 0 and 1. C Example of colour table file 'calcops.rgb' C C OUTPUT PostScript files 'plot00.ps', 'plot01.ps', ..., 'plot99.ps': C Each invocation of subroutine PLOTS creates new output PostScript C file named 'plot**.ps', where ** is the smallest one of values C 00, 01, 02, ..., 99, such that the corresponding file has not been C present in the current directory. C C======================================================================= C C C SUBROUTINE PLOTS(I1,I2,I3) INTEGER I1,I2,I3 C C Input: C I1,I2,I3... Dummy parameters - ignored. C No output. C C Common block /PLOTC/: INCLUDE 'calcops.inc' C calcops.inc C C No subroutines and external functions required. C C Date: 2000, October 27 C Coded by Ludek Klimes C C....................................................................... C C C C ENTRY PLOTN(FILE,INCR) CHARACTER*(*) FILE INTEGER INCR C C Entry designed to store the name of the output PostScript file to be C opened during the next invocation of subroutine PLOTS. If PLOPN is C not called before PLOTS, the first non-existing file of name C 'plot00.ps', 'plot01.ps', 'plot02.ps', ..., 'plot99.ps' is opened for C output. C C Input: C FILE... Name of the output PostScript file to be opened during the C next invocation of subroutine PLOTS. C INCR... If INCR is positive, the given filename is modified as C follows: All digits found in the filename are considered C to form an integer number and INCR is added to the number, C creating the new filename to be used by subroutine PLOTS. C C The input parameters are not altered. C C No output. C C----------------------------------------------------------------------- C C Auxiliary storage locations: CHARACTER*80 FILEPS INTEGER IERR,I,K,N REAL RK,GK,BK SAVE FILEPS DATA FILEPS/' '/ C C....................................................................... C C Colours: C Default white: R(0)=1. G(0)=1. B(0)=1. C Default blacks: DO 10 K=1,MCOLOR R(K)=0. G(K)=0. B(K)=0. 10 CONTINUE C Other colours: OPEN(LUCFG,FILE='calcops.rgb',STATUS='OLD',IOSTAT=IERR) IF(IERR.EQ.0) THEN C User-defined colours: 11 CONTINUE K=-999 READ(LUCFG,*,END=19) K,RK,GK,BK IF(K.LT.0) THEN GO TO 19 ELSE IF(K.LE.MCOLOR) THEN R(K)=RK G(K)=GK B(K)=BK END IF GO TO 11 19 CONTINUE CLOSE(LUCFG) ELSE C Default colours: R( 2)=1.00 G( 2)=0.00 B( 2)=0.00 R( 3)=0.00 G( 3)=1.00 B( 3)=0.00 R( 4)=0.00 G( 4)=0.00 B( 4)=1.00 R( 5)=1.00 G( 5)=1.00 B( 5)=0.00 R( 6)=0.00 G( 6)=1.00 B( 6)=1.00 R( 7)=1.00 G( 7)=0.00 B( 7)=1.00 R( 8)=0.90 G( 8)=0.71 B( 8)=0.50 R( 9)=0.63 G( 9)=0.63 B( 9)=0.63 R(10)=1.00 G(10)=0.00 B(10)=0.76 R(11)=0.76 G(11)=1.00 B(11)=0.00 R(12)=0.00 G(12)=0.76 B(12)=1.00 R(13)=1.00 G(13)=0.76 B(13)=0.00 R(14)=0.00 G(14)=1.00 B(14)=0.76 R(15)=0.76 G(15)=0.00 B(15)=1.00 END IF C C Opening output PostScript file: IF(FILEPS.NE.' ') THEN OPEN(LUCFG,FILE=FILEPS,ERR=21) GO TO 29 21 CONTINUE C CALCOPS-01 CALL ERROR('CALCOPS-01: Unable to open given output PS file') ELSE C The name of the plot file is not given, using plot*.ps: FILEPS='plot00.ps' DO 28 I=0,99 WRITE(FILEPS(5:6),'(2I1)') I/10,I-I/10*10 OPEN(LUCFG,FILE=FILEPS,STATUS='NEW',ERR=25) GO TO 29 25 CONTINUE 28 CONTINUE C CALCOPS-02 CALL ERROR('CALCOPS-02: Unable to open output PS file plot*.ps') END IF 29 CONTINUE FILEPS=' ' C C Writing prolog containing definitions of procedures to be used: WRITE(LUCFG,'(A)') * '%!PS-Adobe-3.0 EPSF-3.0' *,'%%BoundingBox: (atend)' *,'%%Creator: CALCOPS' *,'%%EndComments' *,'%%BeginProlog' *,'%' *,'% General definitions:' *,'/C {setrgbcolor} bind def' *,'/M {stroke moveto} bind def' *,'/L {lineto} bind def' *,'/S {stroke} bind def' *,'/F {/H exch def' *,' /Helvetica findfont exch scalefont setfont} bind def' C Character spacing is increased by: A=H-stringwidth/N C The whole string is shifted by: A/2-0.15*H *,'/T {dup rotate exch dup stringwidth pop 4 -1 roll div H sub neg' *,' dup 2 div 0.15 H mul sub dup 0 rmoveto 3 1 roll' *,' exch 0 exch ashow neg 0 rmoveto neg rotate} bind def' *,'%' *,'% Centred symbols:' *,'/Tb {/H0 exch def /H1 H0 2 div def /H2 H1 2 div def' *,' /h0 H0 neg def /h1 H1 neg def /h2 H2 neg def dup rotate} def' *,'/Te {neg rotate} def /BD {bind def} def /R {rlineto} def' *,'/T00 {Tb 0 H1 R h1 0 R 0 h0 R H0 0 R 0 H0 R h1 0 R ' *,' 0 h1 R Te} BD' *,'/T01 {Tb 0 H1 R h2 0 R h2 h2 R 0 h1 R H2 h2 R H1 0 R ' *,' H2 H2 R 0 H1 R h2 H2 R h2 0 R 0 h1 R Te} BD' *,'/T02 {Tb 0 H1 R h1 h1 h2 add R H0 0 R h1 H1 H2 add R ' *,' 0 h1 R Te} BD' *,'/T03 {Tb 0 H1 R 0 h0 R 0 H1 R h1 0 R H0 0 R h1 0 R Te} BD' *,'/T04 {Tb h1 H1 R H0 h0 R h1 H1 R H1 H1 R h0 h0 R H1 H1 R Te} BD' *,'/T05 {Tb 0 H1 R h1 h1 R H1 h1 R H1 H1 R h1 H1 R 0 h1 R Te} BD' *,'/T06 {Tb 0 H1 R h1 h1 R H0 0 R h1 H1 R 0 h0 R 0 H1 R Te} BD' *,'/T07 {Tb H1 h1 R h0 H0 R H0 0 R h0 h0 R H1 H1 R Te} BD' *,'/T08 {Tb h2 0 R H1 0 R h2 0 R h1 h1 R H0 0 R h0 0 R ' *,' H0 H0 R h0 0 R H0 0 R h1 h1 R Te} BD' *,'/T09 {Tb h1 H1 R H1 h1 R H1 H1 R h1 h1 R 0 h1 R 0 H1 R Te} BD' *,'/T10 {Tb H1 H1 R h2 h2 R h1 0 R h2 H2 R H2 h2 R 0 h1 R ' *,' h2 h2 R H2 H2 R H1 0 R H2 h2 R h2 H2 R 0 H1 R h2 h2 R Te} BD' *,'/T11 {Tb h1 H1 R H0 h0 R h1 H1 R H1 H1 R h0 h0 R H1 H1 R ' *,' 0 H1 R 0 h0 R 0 H1 R H1 0 R h0 0 R H1 0 R Te} BD' *,'/T12 {Tb H1 h1 R h0 0 R H0 H0 R h0 0 R H1 h1 R Te} BD' *,'/T13 {Tb 0 H1 R 0 h0 R 0 H1 R Te} BD' *,'/T14 {Tb H1 0 R h0 0 R H1 0 R Te} BD' *,'%%EndProlog' *,'%' *,'%%BeginSetup' *,'%595 0 translate 90 rotate % line for landscape' *,' 0.0 0.0 translate 1.00 dup scale' *,' 1.0 setlinewidth 1 setlinecap 1 setlinejoin' *,'%%EndSetup' *,'%' C C CalComp plotting initialization: STARTX=0. STARTY=0. XOLD=0. YOLD=0. HOLD=0. KOLOR=0 B1=999.9 B2=999.9 B3=-99.9 B4=-99.9 CALL NEWPEN(1) RETURN C C----------------------------------------------------------------------- C ENTRY PLOTN(FILE,INCR) C C....................................................................... C FILEPS=FILE C C Modifying the filename if INCRPS is positive DO 53 K=1,INCR N=LEN(FILEPS) 50 CONTINUE DO 51 I=N,1,-1 IF(LLE('0',FILEPS(I:I)).AND.LLE(FILEPS(I:I),'8')) THEN FILEPS(I:I)=CHAR(ICHAR(FILEPS(I:I))+1) GO TO 52 ELSE IF(FILEPS(I:I).EQ.'9') THEN FILEPS(I:I)='0' N=I-1 GO TO 50 END IF 51 CONTINUE C CALCOPS-03 CALL ERROR('CALCOPS-03: Bad template name of PostScript file') C The digits in the template name of the output PostScript C files do not allow for the generation of a new filename. C The number of digits should be increased. 52 CONTINUE 53 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE PLOT(XPAGE,YPAGE,IPEN) REAL XPAGE,YPAGE INTEGER IPEN C C Input: C XPAGE,YPAGE... Coordinates of a point, in centimetres from the C current reference point (origin), of the position to which C the pen is to be moved. C IPEN... A signed integer which controls pen status (up or down) C and the origin definition: C IPEN=2... The pen is down during movement, thus drawing a C visible line. C IPEN=3... The pen is up during movement. C IPEN=-2 OR -3... A new origin is defined at the terminal C position after the movement is completed as if IPEN were C positive. C IPEN=999... Output device is closed. C No output. C C Common block /PLOTC/: INCLUDE 'calcops.inc' C calcops.inc C C No subroutines and external functions required. C C Date: 1996, September 30 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: REAL X,Y,XO,YO C C....................................................................... C C Plotting the line: IF(IABS(IPEN).EQ.2) THEN X=SCALE*(STARTX+XPAGE) Y=SCALE*(STARTY+YPAGE) XO=SCALE*(STARTX+XOLD) YO=SCALE*(STARTY+YOLD) IF(-99.95.LT.X.AND.X.LT.999.95.AND. * -99.95.LT.Y.AND.Y.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'L' ELSE WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),'L' END IF B1=AMIN1(B1,XO,X) B2=AMIN1(B2,YO,Y) B3=AMAX1(B3,XO,X) B4=AMAX1(B4,YO,Y) END IF IF(IPEN.NE.2) THEN X=SCALE*(STARTX+XPAGE) Y=SCALE*(STARTY+YPAGE) IF(-99.95.LT.X.AND.X.LT.999.95.AND. * -99.95.LT.Y.AND.Y.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'M' ELSE WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),'M' END IF END IF C C Moving the origin: IF(IPEN.GE.0) THEN XOLD=XPAGE YOLD=YPAGE ELSE STARTX=STARTX+XPAGE STARTY=STARTY+YPAGE XOLD=0. YOLD=0. END IF C C Closing CalComp: IF(IPEN.GE.999) THEN WRITE(LUCFG,'(A)') 'S' WRITE(LUCFG,'(A)') '%%Trailer' IF(-99.95.LT.B1.AND.B1.LT.999.95.AND. * -99.95.LT.B2.AND.B2.LT.999.95.AND. * -99.95.LT.B3.AND.B3.LT.999.95.AND. * -99.95.LT.B4.AND.B4.LT.999.95) THEN WRITE(LUCFG,'(A,4I4)') * '%%BoundingBox:',NINT(B1),NINT(B2),NINT(B3),NINT(B4) ELSE WRITE(LUCFG,'(A,4I6)') * '%%BoundingBox:',NINT(B1),NINT(B2),NINT(B3),NINT(B4) END IF WRITE(LUCFG,'(A)') 'showpage' WRITE(LUCFG,'(A)') '%%EOF' C WRITE(LUCFG,'(A)') CHAR(4) CLOSE(LUCFG) END IF RETURN END C C======================================================================= C C C SUBROUTINE NEWPEN(INP) INTEGER INP C C Input: C INP... Number of the pen or colour index to be selected. C No output. C C Common block /PLOTC/: INCLUDE 'calcops.inc' C calcops.inc C C No subroutines and external functions required. C C Date: 1995, May 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C IF(INP.NE.KOLOR) THEN IF(0.LE.INP.AND.INP.LE.MCOLOR) THEN KOLOR=INP ELSE KOLOR=MCOLOR END IF WRITE(LUCFG,'(A,3(F4.2,1X),A)') * 'S ',R(KOLOR),G(KOLOR),B(KOLOR),'C' END IF RETURN END C C======================================================================= C C C SUBROUTINE SYMBOL(XPAGE,YPAGE,HEIGHT,TEXT,ANGLE,NCHAR) REAL XPAGE,YPAGE,HEIGHT,ANGLE CHARACTER TEXT*(*) INTEGER NCHAR C C Input: C XPAGE,YPAGE... Coordinates, in centimetres, of the lower left-hand C corner of the first character to be produced. C Continuation occurs when XPAGE and YPAGE equals 999. C HEIGHT..Height, in centimetres, of the characters to be plotted. C The character width, including spacing, is normally the C same as the height. C TEXT... String containing the text to be plotted. C ANGLE...Angle, in degrees anticlockwise from the X-axis, at which C the text is to be plotted. C NCHAR...NCHAR.GT.0: number of characters to be drawn. C NCHAR.EQ.0: one character is to be drawn C NCHAR.LT.0: to plot a centred symbol no. ICHAR(TEXT(1:1)). C NCHAR.EQ.-1: the pen is up during the move. C NCHAR.EQ.-2: the pen is down during the move. C No output. C C Common block /PLOTC/: INCLUDE 'calcops.inc' C calcops.inc C C No subroutines and external functions required. C C Date: 2000, October 27 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL X,Y,SX,SY,UX,UY,VX,VY,WX,WY C C X,Y... Coordinates. C SX,SY.. Scaled coordinates. C UX,UY...Text path vector. C VX,VY...Scaled text path vector. C C....................................................................... C IF(HEIGHT.NE.HOLD) THEN IF(-99.95.LT.1.37*SCALE*HEIGHT.AND. * 1.37*SCALE*HEIGHT.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A)') * 1.37*SCALE*HEIGHT,SCALE*HEIGHT,'F' ELSE WRITE(LUCFG,'(2(I5,1X),A)') * NINT(1.37*SCALE*HEIGHT),NINT(SCALE*HEIGHT),'F' END IF HOLD=HEIGHT END IF C X=XPAGE Y=YPAGE IF(ABS(X).GT.998.) THEN X=XOLD Y=YOLD END IF C UX= HEIGHT*COS(.0174533*ANGLE) UY= HEIGHT*SIN(.0174533*ANGLE) SX=SCALE*(STARTX+X) SY=SCALE*(STARTY+Y) IF(NCHAR.GE.0) THEN C Standard call - text: IF(TEXT(1:NCHAR).NE.' ') THEN DO 1 I=MAX0(NCHAR,1),1,-1 IF(TEXT(I:I).NE.' ') THEN GO TO 2 END IF 1 CONTINUE I=1 2 CONTINUE IF(-99.95.LT.SX.AND.SX.LT.999.95.AND. * -99.95.LT.SY.AND.SY.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A,I3,3A,I4,A)') * SX,SY,'M ',I,' (',TEXT(1:I),') ',NINT(ANGLE),' T' ELSE WRITE(LUCFG,'(2(I5,1X),A,I3,3A,I4,A)') * NINT(SX),NINT(SY),'M ',I,' (',TEXT(1:I),') ',NINT(ANGLE),' T' END IF VX= SCALE*UX VY= SCALE*UY WX= VX*FLOAT(I) WY= VY*FLOAT(I) SX=SX-0.15*VX SY=SY-0.15*VY B1=AMIN1(B1,SX,SX+WX,SX-VY,SX+WX-VY) B2=AMIN1(B2,SY,SY+WY,SY+VX,SY+WY+VX) B3=AMAX1(B3,SX,SX+WX,SX-VY,SX+WX-VY) B4=AMAX1(B4,SY,SY+WY,SY+VX,SY+WY+VX) END IF X=X+UX*FLOAT(NCHAR) Y=Y+UY*FLOAT(NCHAR) ELSE C Special call - centred symbol: VX= SCALE*UX/2. VY= SCALE*UY/2. B1=AMIN1(B1,SX+VX+VY,SX-VX+VY,SX+VX-VY,SX-VX-VY) B2=AMIN1(B2,SY+VY+VX,SY-VY+VX,SY+VY-VX,SY-VY-VX) B3=AMAX1(B3,SX+VX+VY,SX-VX+VY,SX+VX-VY,SX-VX-VY) B4=AMAX1(B4,SY+VY+VX,SY-VY+VX,SY+VY-VX,SY-VY-VX) I=MIN0(ICHAR(TEXT(1:1)),14) IF(NCHAR.EQ.-2) THEN IF(-99.95.LT.SX.AND.SX.LT.999.95.AND. * -99.95.LT.SY.AND.SY.LT.999.95.AND. * -99.95.LT.SCALE*HEIGHT.AND.SCALE*HEIGHT.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A,I4,1X,F5.1,A,I2.2)') * SX,SY,'L ',NINT(ANGLE),SCALE*HEIGHT,' T',I ELSE WRITE(LUCFG,'(2(I5,1X),A,I4,1X,I5,A,I2.2)') * NINT(SX),NINT(SY),'L ',NINT(ANGLE),NINT(SCALE*HEIGHT),' T',I END IF SX=SCALE*(STARTX+XOLD) SY=SCALE*(STARTY+YOLD) B1=AMIN1(B1,SX) B2=AMIN1(B2,SY) B3=AMAX1(B3,SX) B4=AMAX1(B4,SY) ELSE IF(-99.95.LT.SX.AND.SX.LT.999.95.AND. * -99.95.LT.SY.AND.SY.LT.999.95.AND. * -99.95.LT.SCALE*HEIGHT.AND.SCALE*HEIGHT.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A,I4,F5.1,A,I2.2)') * SX,SY,'M ',NINT(ANGLE),SCALE*HEIGHT,' T',I ELSE WRITE(LUCFG,'(2(I5,1X),A,I4,1X,I5,A,I2.2)') * NINT(SX),NINT(SY),'M ',NINT(ANGLE),NINT(SCALE*HEIGHT),' T',I END IF END IF END IF XOLD=X YOLD=Y RETURN END C C======================================================================= C C C SUBROUTINE NUMBER (XPAGE,YPAGE,HEIGHT,FPN,ANGLE,NDEC) REAL XPAGE,YPAGE,HEIGHT,FPN,ANGLE INTEGER NDEC C C Input: C XPAGE,YPAGE... Coordinates, in centimetres, of the lower left-hand C corner of the first character to be produced. C Continuation occurs when XPAGE and YPAGE equals 999. C HEIGHT..Height, in centimetres, of the characters to be plotted. C The character width, including spacing, is normally the C same as the height. C FPN... Floating point number to be plotted. C ANGLE...Angle, in degrees anticlockwise from the X-axis, at which C the number is to be plotted. C NDEC... Controls the precision of the conversion of the number C FPN. C NDEC.GE.0: number of decimal places to be drawn, after C rounding. C NDEC.EQ.-1: only the integer portion is to be plotted, C after rounding. C NDEC.LE.-2: -NDEC-1 digits are truncated from the integer C portion, after rounding. C The magnitude of NDEC should not exceed 9. C No output. C C No subroutines and external functions required. C C Date: 1993, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER N,ILP,I,J,K REAL X,Y,FPV,SAMEV PARAMETER (SAMEV=999.) C C N... Storage for (possibly modified) NDEC. C ILP... Length of the integer part of the given number. C I... Temporary storage. C J... Loop variable. C K... Digit to plot. C X,Y... Coordinates. C FPV... Storage for FPN and its decimal modules. C C....................................................................... C X=XPAGE Y=YPAGE FPV=FPN N=MIN0(MAX0(-9,NDEC),9) C C Minus sign: IF (FPV.LT.0) THEN CALL SYMBOL (X,Y,HEIGHT,'-',ANGLE,1) X=SAMEV Y=SAMEV END IF C C To guarantee a correct rounding: IF (N.GE.0) THEN FPV=ABS(FPV)+(0.5*0.1**N) ELSE FPV=ABS(FPV)+(0.05*0.1**N) END IF C C Integer part of the given number: I=INT(ALOG10(FPV)+1.0) IF(N.GE.-1) THEN ILP=I ELSE ILP=I+N+1 END IF IF (ILP.LE.0) THEN CALL SYMBOL (X,Y,HEIGHT,'0',ANGLE,1) X=SAMEV Y=SAMEV ELSE DO 60 J=1,ILP K=FPV*10.**(J-I) CALL SYMBOL (X,Y,HEIGHT,CHAR(ICHAR('0')+K),ANGLE,1) FPV=FPV-(FLOAT(K)*10.**(I-J)) X=SAMEV Y=SAMEV 60 CONTINUE END IF C C Decimal places: IF(N.GE.0) THEN CALL SYMBOL (X,Y,HEIGHT,'.',ANGLE,1) DO 70 J=1,N K=FPV*10. CALL SYMBOL(X,Y,HEIGHT,CHAR(ICHAR('0')+K),ANGLE,1) FPV=FPV*10.-FLOAT(K) 70 CONTINUE END IF RETURN END C C======================================================================= C C C SUBROUTINE FILL(XPTS,YPTS,NPTS) INTEGER NPTS REAL XPTS(NPTS),YPTS(NPTS) C C Subroutine to fill the area inside a given polygon with the colour C specified by the last invocation of subroutine NEWPEN. C C Input: C XPTS,YPTS... Coordinates of vertices of the polygon to be filled C with the current colour specified by subroutine NEWPEN. C NPTS... Number of vertices of the polygon. C No output. C C Common block /PLOTC/: INCLUDE 'calcops.inc' C calcops.inc C C No subroutines and external functions required. C C Date: 1996, September 30 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL X,Y C C....................................................................... C DO 10 I=1,NPTS X=SCALE*(STARTX+XPTS(I)) Y=SCALE*(STARTY+YPTS(I)) IF(I.EQ.1) THEN IF(-99.95.LT.X.AND.X.LT.999.95.AND. * -99.95.LT.Y.AND.Y.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'M' ELSE WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),'M' END IF ELSE IF(I.LT.NPTS) THEN IF(-99.95.LT.X.AND.X.LT.999.95.AND. * -99.95.LT.Y.AND.Y.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'L' ELSE WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y),'L' END IF ELSE IF(-99.95.LT.X.AND.X.LT.999.95.AND. * -99.95.LT.Y.AND.Y.LT.999.95) THEN WRITE(LUCFG,'(2(F5.1,1X),A)') X,Y,'L closepath fill' ELSE WRITE(LUCFG,'(2(I5,1X),A)') NINT(X),NINT(Y), * 'L closepath fill' END IF END IF B1=AMIN1(B1,X) B2=AMIN1(B2,Y) B3=AMAX1(B3,X) B4=AMAX1(B4,Y) 10 CONTINUE RETURN END C C======================================================================= Ccalcops.inc 0100666 0000765 0000765 00000003210 07050447546 012557 0 ustar bulant bulant C
C INCLUDE 'calcops.inc' C ------------------------------------------------------------------ INTEGER LUCFG,MCOLOR,KOLOR PARAMETER (LUCFG=97,MCOLOR=255) REAL R(0:MCOLOR),G(0:MCOLOR),B(0:MCOLOR) REAL SCALE,STARTX,STARTY,XOLD,YOLD,HOLD,B1,B2,B3,B4 PARAMETER (SCALE=72/2.54) COMMON/PLOTC/ KOLOR,R,G,B,STARTX,STARTY,XOLD,YOLD,HOLD,B1,B2,B3,B4 SAVE /PLOTC/ C ------------------------------------------------------------------ C LUCFG...Logical unit number of the CalComp configuration file C calcomp.cfg. C MCOLOR..Maximum colour index. Colours greater than MCOLOR are C replaced by KOLOR=MCOLOR. C KOLOR...Colour index set by the last invocation of subroutine C NEWPEN. Initially set to KOLOR=0. C R,G,B...Arays containing the intensities of the red, blue and C green colour components (reals between 0 and 1). C STARTX,STARTY... Origin of CalComp coordinates in world C coordinates. C XOLD,YOLD... Point referred during the previous invocation of a C CalComp subroutine, in CalComp coordinates. C HOLD... Character height set by the last invocation of subroutine C SYMBOL or NUMBER. Initially set to HOLD=0. C B1,B2,B3,B4... Bounding box. C C Common block /PLOTC/ is included in FORTRAN 77 source code file C 'calcops.for'. C C Date: 1998, August 12 C Coded by Ludek Klimes C C======================================================================= Ccalcops.rgb 0100666 0000765 0000765 00000006356 06606324272 012572 0 ustar bulant bulant 0 1.00 1.00 1.00 White 1 0.00 0.00 0.00 Black 2 1.00 0.00 0.00 Red 3 0.00 1.00 0.00 Green 4 0.00 0.00 1.00 Blue 5 1.00 1.00 0.00 Yellow 6 0.60 0.00 0.80 Purple 7 0.00 1.00 1.00 Cyan 8 1.00 0.00 1.00 Magenta 9 1.00 0.40 0.00 Orange 10 0.60 0.00 0.00 Ruby Red 11 0.00 0.20 0.60 Navy Blue 12 0.00 0.20 0.20 Dark Green 13 0.00 0.00 0.40 Deep Navy Blue 14 0.20 0.20 0.00 Murky Green 15 0.00 0.80 1.00 Sky Blue 16 0.00 0.40 0.20 Forest Green 17 0.60 1.00 0.00 Chartreuse 18 0.80 0.20 0.00 Brick Red 19 1.00 0.80 0.00 Deep Yellow 20 0.40 0.20 0.00 Walnut 21 1.00 0.00 0.40 Neon Red 22 0.40 0.00 0.40 Plum 23 0.00 0.60 0.20 Grass Green 24 0.60 0.00 0.60 Deep Violet 25 0.20 0.00 0.40 Deep Purple 26 0.20 0.00 0.60 Storm Blue 27 0.60 0.00 1.00 Blue Purple 28 0.40 0.00 0.80 Deep River 29 0.20 0.00 0.80 Deep Blue 30 1.00 0.60 0.80 Pink 31 0.40 0.20 0.20 Dark Brown 32 0.80 0.80 1.00 Powder Blue 33 0.60 0.60 1.00 Pastel Blue 34 0.40 0.60 1.00 Baby Blue 35 0.40 0.40 1.00 Electric Blue 36 0.40 0.40 0.80 Twilight Blue 37 0.20 0.40 0.60 Desert Blue 38 0.60 1.00 1.00 Ice Blue 39 0.60 0.80 0.80 Light BlueGreen 40 0.40 0.60 0.60 Ocean Green 41 0.20 0.40 0.40 Moss Green 42 0.20 0.60 0.40 Kentucky Green 43 0.20 0.80 0.40 Light Green 44 0.20 0.80 0.20 Spring Green 45 0.40 1.00 0.80 Turquoise 46 0.20 0.80 0.60 Sea Green 47 0.60 0.80 0.60 Faded Green 48 0.80 1.00 0.80 Ghost Green 49 0.60 1.00 0.60 Mint Green 50 0.40 0.60 0.40 Army Green 51 0.40 0.60 0.20 Avocado Green 52 0.60 0.80 0.20 Martian Green 53 0.60 0.80 0.40 Dull Green 54 0.80 1.00 0.40 Moon Green 55 0.40 0.40 0.20 Olive Drab 56 0.60 0.60 0.40 Khaki 57 0.60 0.60 0.20 Olive 58 0.80 0.80 0.20 Banana Yellow 59 1.00 1.00 0.40 Light Yellow 60 1.00 1.00 0.60 Chalk 61 1.00 1.00 0.80 Pale Yellow 62 0.60 0.40 0.20 Brown 63 0.80 0.40 0.20 Red Brown 64 0.80 0.60 0.20 Gold 65 1.00 0.40 0.20 Autumn Orange 66 1.00 0.60 0.20 Light Orange 67 1.00 0.60 0.40 Peach 68 1.00 0.80 0.60 Sand 69 1.00 0.40 0.40 Tropical Pink 70 1.00 0.60 0.60 Soft Pink 71 1.00 0.80 0.80 Faded Pink 72 0.60 0.20 0.40 Crimson 73 0.80 0.20 0.40 Regal Red 74 0.80 0.20 0.60 Deep Rose 75 1.00 0.40 0.60 Deep Pink 76 1.00 0.20 0.60 Hot Pink 77 0.80 0.40 0.60 Dusty Rose 78 1.00 0.60 1.00 Light Violet 79 0.80 0.40 0.80 Violet 80 0.60 0.40 0.60 Dusty Plum 81 0.80 0.60 0.80 Pale Purple 82 0.60 0.20 0.80 Majestic Purple 83 0.80 0.20 1.00 Neon Purple 84 0.80 0.40 1.00 Light Purple 85 0.60 0.40 0.80 Twilight Violet 86 0.80 0.60 1.00 Easter Purple 87 0.40 0.20 0.60 Grape 88 0.60 0.40 1.00 Blue Violet 89 0.40 0.20 1.00 Deep Azure 101 0.95 0.95 0.95 Light grey 102 0.90 0.90 0.90 . 103 0.85 0.85 0.85 . 104 0.80 0.80 0.80 . 105 0.75 0.75 0.75 . 106 0.70 0.70 0.70 . 107 0.65 0.65 0.65 . 108 0.60 0.60 0.60 . 109 0.55 0.55 0.55 . 110 0.50 0.50 0.50 . 111 0.45 0.45 0.45 . 112 0.40 0.40 0.40 . 113 0.35 0.35 0.35 . 114 0.30 0.30 0.30 . 115 0.25 0.25 0.25 . 116 0.20 0.20 0.20 . 117 0.15 0.15 0.15 . 118 0.10 0.10 0.10 . 119 0.05 0.05 0.05 Dark grey chk.pl 0100666 0000765 0000765 00000001105 06617240434 011536 0 ustar bulant bulant #!perl #
# # Perl script 'chk.pl' to check input data files required by history files # # Version: 5.20 # Date: 1998, November 2 # ====================================================================== # Main program 'chk.pl': # ~~~~~~~~~~~~~~~~~~~~~~ $PATH=$ARGV[0]; $FILE=$ARGV[1]; if ($FILE ne '') { @ARGV=(); require 'go.pl'; &CHK($PATH,$FILE); } # ====================================================================== 1; #cknfft.h 0100666 0000765 0000765 00000002540 10061773474 012067 0 ustar bulant bulant # History file 'cknfft.h' to generate and plot Von Karman correlation # function according to the equations given in # Klimes, L. (1997): Correlation functions of random media. # In: Seismic Waves in Complex 3-D Structures, Report 6. # Department of Geophysics, Charles University, Prague. # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Input files required chk.pl: "forms/" "mul.cal" chk.pl: "forms/" "div.cal" chk.pl: "forms/" "echo.pl" # Values describing the random medium NDIM=1 POWERN=-0.1 ACORG=0. ACOR=10. # Analytical calculation of the correlation function by 'grdckn.for' # according to the equation K.4 CKNOUT='ckn.out' grdckn: # Calculation of the correlation function by FFT # according to equations 1.14, 2.1 and 3.1 O1=-31.415926 D1=0.0306796 N1=2048 grdcor: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdcor.out' GRD3='grdcal.out' grdcal: FFTINR='grdcal.out' FFTOUTR='fft.out' O1OUT=-10. D1OUT=0.1 N1OUT=201 FFT=1. grdfft: # Plots of the 1-D functions stored in files 'ckn.out' and 'fft.out' KSIG=0 DT=0.1 NFFT=512 MPTS=201 echo.pl: "/" ">>ckn.out" echo.pl: "/" ">>fft.out" SIGDIG='ckn.out' SS=' ' SIGPLOT='ckn.ps' ss: SIGDIG='fft.out' SS=' ' SIGPLOT='fft.ps' ss: # Comparisson of the results CAL='div.cal' GRD1='fft.out' GRD2='ckn.out' GRD3='div.out' grdcal: coef52.for 0100666 0000765 0000765 00000133102 10062244274 012225 0 ustar bulant bulant C
C Routine COEF52 C ************** C C Routine COEF52 is designed for the computation of the C displacement reflection/transmission coefficients (R/T C coefficients) of inhomogeneous P, SV and SH plane waves at a C stack of homogeneous isotropic dissipative layers between two C homogeneous isotropic dissipative halfspaces. The stack of C layers may be reduced to a single interface. C As special cases, it is also possible to compute the R/T C coefficients of pressure waves at a stack of liquid layers C between two liquid halfspaces, the R/T coefficients at a C surficial stack of layers, and the conversion coefficients C (receiver functions) at a free surface of the surficial C stack of layers. In all these cases, analogous R/T coefficients C for non-dissipative media may be also computed. C The routine is written in Fortran 77 programming language. C C Calling: C ******** C CALL COEF52(NC,NH,NQ,NUM,LIN,LOU,ANGLE,GAMMA,FREQ,RMOD,RPHASE, C RMOD0,RPH0) C Input parameters: C NC ..... Type of the R/T coefficient C NH ..... NH=0 ... the second halfspace is solid or liquid C NH=1 ... the second halfspace is a vacuum C NQ ..... NQ=0 ... model is non-dissipative C NQ=1 ... model is dissipative C NUM .... NUM=0 ... reading the model, no computations C NUM=1 ... computations of R/T coefficients C LIN .... Number of input file logical unit C LOU .... Number of output file logical unit C ANGLE .. Angle of incidence (in degrees) C GAMMA .. Attenuation angle of the incident inhomogeneous C plane wave (in degrees) C FREQ ... Frequency (in Hz) C Output parameters: C RMOD ... Modul of computed R/T coefficient C RPHASE.. Phase of computed R/T coefficient C RMOD0 .. Modul of analogous R/T coefficient for a single interface C between two non-dissipative halfspaces C RPH0 ... Phase of analogous R/T coefficient. C For NUM=0, all other parameters, with the exception of LIN and C LOU, may be arbitrary. C C Specification of the model: C *************************** C The number of layers in the model (including both C halfspaces) is specified by NZ. For NZ=2, the two halfspaces C are in contact and the transition layer reduces to a single C interface. The layer number 1 corresponds to the incidence C (first) halfspace, the layer number NZ to the second halfspace. C For each layer (including halfspaces), the following C real-valued parameters should be specified: C VP ... P velocity (in km/s), C VS ... S velocity (in km/s), C RHO .. density (in g/cm**3), C QP ... quality factor of P waves, C QS ... quality factor of S waves, C D ... thickness of the layer (in km). C The quality factors QP and QS of P and S waves are assumed C to be independent of frequency FREQ (constant-Q model). C The real-valued velocities VP and VS of P and S waves are C material properties of the model for the reference frequency C FREF. They correspond to the real parts of the Lame's elastic C moduli for the reference frequency FREF. For known VP(FREF), C VS(FREF), QP and QS, the frequency-dependent complex valued C velocities CVP(FREQ) and CVS(FREQ) of P and S waves for the C constant Q model are given by relations C CVP(FREQ) = VP(FREF)*(1.+ln(FREQ/FREF)/(pi*QP) - i/(2.*QP)), C CVS(FREQ) = VS(FREF)*(1.+ln(FREQ/FREF)/(pi*QS) - i/(2.*QS)). C The frequency-dependent real-valued velocities VP(FREQ) and C VS(FREQ) equal the real parts of CVP(FREQ) and CVS(FREQ). C They specify the velocity dispersion. C In both halfspaces, the thicknesses (D(1) and D(NZ)) may C be taken arbitrarily; they are automatically adjusted to zero. C For pressure waves in liquid media, VS and QS are not used C in the computations. The values of VS and QS may be specified C arbitrarily in this case. C For SH waves, VP and QP are not used in the computations. C The values of VP and QP may be specified arbitrarily in this case. C For non-dissipative media (NQ=0), QP and QS are not used C in computations. The values of QP and QS may be specified C arbitrarily in this case. C If the second halfspace represents a vacuum (NH=1), C the density in the second halfspace is automatically adjusted C to zero. Similarly, the velocities VP and VS are adjusted to 0.001. C For NUM=0, routine COEF52 reads the input data for the C model (including the reference frequency FREF), and does not C perform any computations. For NUM=1, the computation of the R/T C coefficients is performed, for the known model. C C Type of R/T coefficients. C ************************* C The type of the R/T coefficient we wish to compute is C specified by NC (input parameter of COEF52). The following C table shows the values of NC for individual R/T coefficients: C a) P/SV waves, solids: C P1P1...1 P1S1...2 P1P2...3 P1S2...4 C S1P1...5 S1S1...6 S1P2...7 S1S2...8 C b) SH waves, solids: C S1S1...9 S1S2...10 C c) Pressure waves, liquids: C P1P1...13 P1P2...14 C For example, P1S1 (NC=2) corresponds to the reflection C coefficient, for incident P wave and reflected S wave. C Similarly, S1P2 (NC=7) corresponds to the transmission C coefficient, for incident S wave and transmitted P wave. C The second halfspace may be solid or liquid (NH=0) or C a vacuum (NH=1). For NH=1, the interface between the (NZ-1)-th C layer and the NZ-th layer (second halfspace) represents a free C surface, e.g. the surface of the Earth. For NH=1, the reflection C coefficients P1P1, P1S1, S1P1 and S1S1 have a standard meaning. C The physical meaning of the transmission coefficients P1P2, C P1S2, S1P2 and S1S2 for NH=1 is, however, different. They C give the so-called conversion coefficients, also called receiver C functions: C For NH=1: P1P2=PZ, P1S2=PX, S1P2=SZ, S1S2=SX. C The conversion coefficients (receiver functions) represent C horizontal or vertical displacement components of the free surface C (top of the stack of layers) due to a plane wave incident on the C bottom of the stack of layers from below. In the notation PZ, PX, C SZ and SX for the conversion coefficients, the first letter C specifies the incident wave (P or S), and the second letter the C Cartesian component of the displacement vector (X or Z). The C Cartesian axis X is horizontal, tangential to the free surface, C situated in the plane of incidence, oriented "against" the C direction of propagation. (For the X-axis oriented "along" the C direction of propagation, we must take opposite signs of PX and C SX.) The Cartesian axis Z is vertical, perpendicular to the C interface, and oriented away from the transition layer. For SH C waves and NH=1, the R/T coefficient S1S2 represents the conversion C coefficient SY. The Cartesian axis Y is horizontal, perpendicular C to the plane of incidence. C C Incident wave: C ************** C In dissipative media, the slowness vector of the incident C wave is complex-valued. The real part of the slowness vector C is called the propagation vector, and its imaginary part the C attenuation vector. The plane of incidence is specified by the C normal vector to the interface(s) and by the propagation vector. C The attenuation vector of the incident wave is assumed to be C situated in the plane of incidence. The direction of the C propagation vector is specified by the real-valued angle of C incidence ANGLE, and the direction of the attenuation vector is C specified by the real-valued attenuation angle GAMMA. The angles C ANGLE and GAMMA are input parameters of COEF52. ANGLE represents C the acute angle between the propagation vector of the incident C wave and normal to the interface. It is specified in degrees, and C should be in the range <0.,90.>. The attenuation angle is the C angle between the propagation and attenuation vectors of the C incident wave, is specified in degrees, and should be in the C range (-90.,90.). It is positive if the attenuation vector is C pointing to the left from the propagation vector. C The complex-valued polarisation vector of the incident P C wave is proportional to the slowness vector. The complex-valued C polarisation vector of the incident SV wave is perpendicular to C the slowness vector (in the complex sense), and its real part is C oriented to the left from the propagation vector. The polarisation C vector of the incident SH wave is perpendicular to the plane of C incidence. Analogous orientation of polarisation vectors is used C even for R/T waves. Consequently, the R/T coefficients are C independent of the used coordinate system. C For given NC, NH, NQ, ANGLE, GAMMA, and FREQ, and for a C given model, the routine COEF52 returns the complex-valued C R/T coefficient RCOEF. RCOEF is expressed in terms of its modulus C RMOD and phase RPHASE. Both RMOD and RPHASE are real-valued. C RPHASE is specified in the range <-180.,180.>. C The time factor of the incident wave is exp(-i*omega*t), C where t is running time and omega=2.*pi*FREQ. For the time factor C exp(i*omega*t), it would be necessary to change the sign of C RPHASE. C For RMOD=0., RPHASE cannot be computed. Consequently, C COEF52 returns 'the warning' RPHASE=999 for RMOD<0.00001. In C plotting RPHASE, the points with RPHASE=999 should be ignored. C In each computation, also quantities RMOD0 and RPH0 are C computed, in addition to RMOD and RPHASE. They correspond to the C same R/T coefficient as RMOD and RPHASE, but to the plane C interface between the two non-dissipative halfspaces (NZ=2, NQ=0). C C Routines used C ************* C For matrix computations of R/T coefficients for P and SV C waves, routine RTMATQ is used in dissipative media, and routine C RTMAT in non-dissipative media. They further use routines RTQ, C RT, etc. C For matrix computation of R/T coefficients of SH waves and C for pressure waves in liquids, routine RTMQ2 is used in C dissipative media, and routine RTM2 in non-dissipative media. C For comparisons, R/T coefficients at a single interface C between two non-dissipative media (NZ=2, NQ=0), are computed C in routine COEF8, using explicit (non-matrix) expressions for C R/T coefficients. C Routine CRITAN tests a possible existence of nonelastic C discrete critical angles, and computes them if they exist. C Nonelastic discrete critical angles correspond to angles of C incidence for which both the real and imaginary parts of the C vertical component of the slowness vector of any R/T wave in the C dissipative model under consideration vanish. The R/T coefficients C may display anomalous jumps at the discrete critical angles. The C application of CRITAN removes such jumps, see Brokesova and C Cerveny (1998). In COEF52, routine CRITAN is applied only if NZ=2, C not for NZ.GT.2. Note that the anomalous behaviour of R/T C coefficients was also observed in the so-called Rayleigh window. C These cases will be subjects of further investigation. C Routines RTMAT and RTMATQ are modifications of analogous C routines, written by G. Muller, used in his reflectivity packages, C and described in the paper Muller (1985). The recursive algorithm C is used to compute the R/T coefficients. The potential R/T C coefficients, computed by Muller, are adjusted to displacement C R/T coefficients, considered here. Although G.Muller C considers the time convention exp(i*omega*t), the resulting phase C is adjusted to our time convention exp(-i*omega*t). Moreover, C inhomogeneous plane incident waves with arbitrary attenuation C angles are introduced. The routines are used in COEF52 with the C author's permission. C Routine COEF8 is a modification of an analogous routine, C used in the program package SEIS88 by V. Cerveny and I. Psencik. C See explicit analytical expressions for the coefficients in C Cerveny (2001). The book also displays pictures of many R/T C coefficients at a single interface between two non-dissipative C halfspaces. C Routine COEF52 itself is a modification of the routine FDEP, C used in the program package BEAM87 by V.Cerveny to study the C propagation of Gaussian beams in complex, 2-D, laterally varying C layered structures, containing thin stacks of layers. See C Cerveny (1989). C The theoretical treatment of reflection and transmission of C inhomogeneous plane waves at a single interface between two C dissipative elastic halfspaces can be found in Brokesova and C Cerveny (1998). The reference also offers a more detailed C description of routine COEF52 and presents numerous examples C of R/T coefficients. See also Brokesova (2001). C C Demonstration program for testing C ********************************* C For testing purposes, a brief main program C RTCOEF is included. C C References C ********** C Brokesova,J. (2000). Reflection/transmission coefficients at a C plane interface in dissipative and non-dissipative media: C A comparison. J.Comput.Acoustics, 9,623 -641. C Brokesova,J., and Cerveny,V. (1998). Inhomogeneous plane waves C in dissipative, isotropic and anisotropic media. Reflection/ C transmission coefficients. In Seismic waves in complex 3-D C structures, Report No. 7, pp. 57 - 146. Department of C Geophysics, Charles University, Prague. C Cerveny,V. (1989). Synthetic body wave seismograms for laterally C varying media containing thin transition layers. Geophys. J. C Int., 99, 331-349, C Cerveny,V. (2001). Seismic ray theory. Cambridge Univ. Press, C Cambridge. C Muller,G. (1985). The reflectivity method. A tutorial. J.Geophys., C 58, 153-174. C C C Consortium Project "Seismic Waves C in Complex 3-D Structures" C Praha, April 2003 C J.Brokesova, V.Cerveny C ********************************************************************* c subroutine coef52(nc,nh,nq,num,lin,lou,angle,gamma,freq,rmod, 1rphase,rmod0,rph0) complex rpp,rps,rss,rsp,tpp,tps,tss,tsp,rcoef,rp,tp,rs,ts,cunit, 1u common/model/nz,vp(50),vs(50),rho(50),d(50),qp(50),qs(50),fref, 1rho2,vp2,vs2,qp2,qs2 c cunit=(0.,1.) pi=3.141593 ang=angle*pi/180. gam=gamma*pi/180. inc=0 if(nc.gt.4.and.nc.lt.11)inc=1 ntype=2 if(nc.ge.13)ntype=0 if(nc.gt.8.and.nc.lt.13)ntype=1 if(num.eq.1)go to 20 c c reading the model read(lin,100)nz write(lou,100)nz do 1 i=1,nz read(lin,101)vp(i),vs(i),rho(i),qp(i),qs(i),d(i) write(lou,101)vp(i),vs(i),rho(i),qp(i),qs(i),d(i) 1 continue read(lin,101)fref write(lou,101)fref rho2=rho(nz) vp2=vp(nz) vs2=vs(nz) d(1)=0. d(2)=0. return c 20 cvr=0. if(nq.eq.1)cvr=alog(freq/fref)/pi if(nh.eq.1)go to 21 vp(nz)=vp2 vs(nz)=vs2 rho(nz)=rho2 go to 24 21 vp(nz)=0.001 vs(nz)=0.001 rho(nz)=0. 24 continue c c computation of the tangential component of the slowness vector c of the incident wave if(inc.eq.1)go to 22 v1=vp(1) q1=qp(1) urr=1./v1 if(nq.eq.0)go to 23 v1=vp(1)*(1.+cvr/qp(1)) go to 23 22 v1=vs(1) q1=qs(1) urr=1./v1 if(nq.eq.0)go to 23 v1=vs(1)*(1.+cvr/qs(1)) 23 vv1=v1*v1 par=1/v1 ur=par*sin(ang) urr=urr*sin(ang) if(nq.eq.0)go to 26 gaux=1./(q1*q1*cos(gam)*cos(gam)) gg=sqrt(gaux+1.) g1=sqrt(gg+1.) g2=sqrt(gg-1.) u=(g1*sin(ang)-cunit*g2*sin(ang-gam))/sqrt(2.*vv1*(1.+ *1./(q1*q1))) c c computation of R/T coefficients 26 continue call coef8(urr,vp(1),vs(1),rho(1),vp(nz),vs(nz),rho(nz),nc, 1rmod0,rph0) rph0=rph0*180./pi 31 if(ntype.eq.2)go to 33 if(nq.eq.1)go to 32 call rtmat2(nz,vp,vs,rho,d,ur,freq,rp,tp,rs,ts,ntype,nc,rcoef) go to 40 32 call rtmq2(fref,nz,vp,vs,rho,qp,qs,d,u,freq,rp,tp,rs,ts,ntype, 1nc,rcoef,v1,q1,ang,gam) go to 40 33 if(nq.eq.1)go to 34 call rtmat(nz,vp,vs,rho,d,ur,freq,rpp,rps,rss,rsp,tpp,tps,tss, 1tsp,nc,rcoef) go to 40 34 call rtmatq(fref,nz,vp,vs,rho,qp,qs,d,u,freq,rpp,rps,rss,rsp,tpp, 1tps,tss,tsp,nc,rcoef,v1,q1,ang,gam) c 40 b=real(rcoef) c=-aimag(rcoef) rmod=sqrt(b*b+c*c) if(rmod.lt.0.00001)go to 41 rphase=atan2(c,b)*180./pi go to 42 41 rphase=999. c 100 format(8i5) 101 format(8f10.3) 42 return end C C********************************************************************* c SUBROUTINE RTMAT2(N,A,B,RHO,D,U,FREQ,RP,TP,RS,TS,NTYPE,NC, 1 RCOEF) C C R/T COEFFICIENTS AT A STACK OF LAYERS FOR PRESSURE WAVES IN C LIQUIDS AND FOR SH WAVES IN NON-DISSIPATIVE MEDIA C C NTYPE=0....PRESSURE WAVES, LIQUID C NTYPE=1....SH WAVES C C DIMENSION A(N),B(N),RHO(N),D(N) COMPLEX RPD,RPU,TPD,TPU,RP,TP,RSD,RSU,TSD,TSU,RS,TS, 1 A1,A2,B1,B2,AA,EP,ES,DD,FF,RCOEF C C UQ=U*U W=6.283185*FREQ M=N-1 X=-W*D(M) IF(NTYPE.EQ.1)GO TO 5 C C PRESSURE WAVES, LIQUID C AQ1=1./(A(M)*A(M)) RHO1=RHO(M) AQ2=1./(A(N)*A(N)) RHO2=RHO(N) V=SQRT(ABS(AQ1-UQ)) ARG=X*V A1=CMPLX(V,0.) if(uq.gt.aq1)a1=cmplx(0.,-v) IF(UQ.LE.AQ1)EP=CMPLX(COS(ARG),SIN(ARG)) IF(UQ.GT.AQ1)EP=CMPLX(EXP(ARG),0.) V=SQRT(ABS(AQ2-UQ)) A2=CMPLX(V,0.) IF(UQ.GT.AQ2)A2=CMPLX(0.,-V) AA=RHO2*A1+RHO1*A2 RPD=(RHO2*A1-RHO1*A2)/AA RPU=-RPD TPD=2.*RHO2*A1/AA TPU=2.*RHO1*A2/AA RP=RPD*EP*EP TP=TPD*EP GO TO 10 C C SH WAVES C 5 BQ1=1./(B(M)*B(M)) Z1=RHO(M)*B(M)*B(M) BQ2=1./(B(N)*B(N)) Z2=RHO(N)*B(N)*B(N) V=SQRT(ABS(BQ1-UQ)) ARG=X*V B1=CMPLX(V,0.) IF(UQ.LE.BQ1)ES=CMPLX(COS(ARG),SIN(ARG)) IF(UQ.GT.BQ1)B1=CMPLX(0.,-V) IF(UQ.GT.BQ1)ES=CMPLX(EXP(ARG),0.) V=SQRT(ABS(BQ2-UQ)) B2=CMPLX(V,0.) IF(UQ.GT.BQ2)B2=CMPLX(0.,-V) AA=Z1*B1+Z2*B2 RSD=(Z1*B1-Z2*B2)/AA RSU=-RSD TSD=2.*Z1*B1/AA TSU=2.*Z2*B2/AA RS=RSD*ES*ES TS=TSD*ES C C MATRIX MULTIPLICATION FOR LAYERED MEDIUM C 10 IF(N.EQ.2)GO TO 1001 II=N-2 DO 1000 I=II,1,-1 M=I+1 X=-W*D(I) IF(NTYPE.EQ.1)GO TO 15 AQ1=1./(A(I)*A(I)) RHO1=RHO(I) AQ2=1./(A(M)*A(M)) RHO2=RHO(M) V=SQRT(ABS(AQ1-UQ)) ARG=X*V IF(UQ.LE.AQ1)EP=CMPLX(COS(ARG),SIN(ARG)) IF(UQ.GT.AQ1)EP=CMPLX(EXP(ARG),0.) A1=CMPLX(V,0.) IF(UQ.GT.AQ1)A1=CMPLX(0.,-V) V=SQRT(ABS(AQ2-UQ)) A2=CMPLX(V,0.) IF(UQ.GT.AQ2)A2=CMPLX(0.,-V) AA=RHO2*A1+RHO1*A2 RPD=(RHO2*A1-RHO1*A2)/AA RPU=-RPD TPD=2.*RHO2*A1/AA TPU=2.*RHO1*A2/AA DD=1.-RPU*RP RP=(RPD+TPU*TPD*RP/DD)*EP*EP IF(I.EQ.1)FF=TPD/DD IF(I.GT.1)FF=TPD*EP/DD TP=FF*TP GO TO 1000 15 BQ1=1./(B(I)*B(I)) Z1=RHO(I)*B(I)*B(I) BQ2=1./(B(M)*B(M)) Z2=RHO(M)*B(M)*B(M) V=SQRT(ABS(BQ1-UQ)) ARG=X*V IF(UQ.LE.BQ1)ES=CMPLX(COS(ARG),SIN(ARG)) IF(UQ.GT.BQ1)ES=CMPLX(EXP(ARG),0.) B1=CMPLX(V,0.) IF(UQ.GT.BQ1)B1=CMPLX(0.,-V) V=SQRT(ABS(BQ2-UQ)) B2=CMPLX(V,0.) IF(UQ.GT.BQ2)B2=CMPLX(0.,-V) AA=Z1*B1+Z2*B2 RSD=(Z1*B1-Z2*B2)/AA RSU=-RSD TSD=2.*Z1*B1/AA TSU=2.*Z2*B2/AA DD=1.-RSU*RS RS=(RSD+TSU*TSD*RS/DD)*ES*ES IF(I.EQ.1)FF=TSD/DD IF(I.GT.1)FF=TSD*ES/DD TS=FF*TS C 1000 CONTINUE 1001 CONTINUE if(nc.eq.9)rcoef=rs if(nc.eq.10)rcoef=ts if(nc.eq.13)rcoef=rp if(nc.eq.14)rcoef=tp C RETURN END c c******************************************************************** c SUBROUTINE rtmq2(FR,N,A,B,RHO,QA,QB,D,U,FREQ,RP,TP,RS,TS,NTYPE, 1 nc,rcoef,v1,q1,aincr,gamma) C C R/T COEFFICIENTS AT A TRANSITION LAYER FOR PRESSURE WAVES C IN LIQUIDS AND FOR SH WAVES IN DISSIPATIVE MEDIA C C NTYPE=0....PRESSURE WAVES, LIQUID C NTYPE=1....SH WAVES C DIMENSION A(N),B(N),RHO(N),D(N),QA(N),QB(N) COMPLEX RPD,RPU,TPD,TPU,RP,TP,RSD,RSU,TSD,TSU,RS,TS,EIN, 1 A1,A2,B1,B2,AA,EP,ES,Z1,Z2,CW,CV,aq1,aq2,bq1,bq2,rcoef, 2 DD,FF,U,UQ C UQ=U*U WR=6.283185*FR EIN=CMPLX(0.,1.) W=6.283185*FREQ CW=W CV=ALOG(W/WR)/3.141593+0.5*EIN M=N-1 IF(NTYPE.EQ.1)GO TO 5 C C PRESSURE WAVES, DISSIPATIVE LIQUIDS C RHO1=RHO(M) AQ1=A(M)*(1.+CV/QA(M)) AQ1=1./(AQ1*AQ1) A1=CSQRT(AQ1-UQ) RHO2=RHO(N) AQ2=A(N)*(1.+CV/QA(N)) AQ2=1./(AQ2*AQ2) A2=CSQRT(AQ2-UQ) c if(n.gt.2)go to 1 cvr=alog(w/wr)/3.14159 va1=a(m)*(1.+cvr/qa(m)) qa1=qa(m) va2=a(n)*(1.+cvr/qa(n)) qa2=qa(n) call critan(v1,va1,q1,qa1,gamma,ncrit,acrit1,acrit2) if(ncrit.ne.0)then if(aincr.gt.acrit1.and.aincr.lt.acrit2)a1=-a1 endif call critan(v1,va2,q1,qa2,gamma,ncrit,acrit1,acrit2) if(ncrit.ne.0)then if(aincr.gt.acrit1.and.aincr.lt.acrit2)a2=-a2 endif 1 continue c AA=RHO2*A1+RHO1*A2 RPD=(RHO2*A1-RHO1*A2)/AA RPU=-RPD TPD=2.*RHO2*A1/AA TPU=2.*RHO1*A2/AA EP=CEXP(-D(M)*CW*EIN*A1) RP=RPD*EP*EP TP=TPD*EP GO TO 10 C C SH WAVES, DISSIPATIVE MEDIA C 5 continue BQ1=B(M)*(1.+CV/QB(M)) BQ1=1./(BQ1*BQ1) B1=CSQRT(BQ1-UQ) Z1=RHO(M)/BQ1 BQ2=B(N)*(1.+CV/QB(N)) BQ2=1./(BQ2*BQ2) B2=CSQRT(BQ2-UQ) Z2=RHO(N)/BQ2 c if (n.gt.2)go to 2 cvr=alog(w/wr)/3.141593 vb1=b(m)*(1.+cvr/qb(m)) qb1=qb(m) vb2=b(n)*(1.+cvr/qb(n)) qb2=qb(n) call critan(v1,vb1,q1,qb1,gamma,ncrit,acrit1,acrit2) if(ncrit.ne.0)then if(aincr.gt.acrit1.and.aincr.lt.acrit2)b1=-b1 endif call critan(v1,vb2,q1,qb2,gamma,ncrit,acrit1,acrit2) if(ncrit.ne.0)then if(aincr.gt.acrit1.and.aincr.lt.acrit2)b2=-b2 endif 2 continue c AA=Z1*B1+Z2*B2 RSD=(Z1*B1-Z2*B2)/AA RSU=-RSD TSD=2.*Z1*B1/AA TSU=2.*Z2*B2/AA ES=CEXP(-D(M)*CW*EIN*B1) RS=RSD*ES*ES TS=TSD*ES C C MATRIX MULTIPLICATION FOR LAYERED MEDIUM C 10 IF(N.EQ.2)GO TO 1001 II=N-2 DO 1000 I=II,1,-1 M=I+1 IF(NTYPE.EQ.1)GO TO 15 AQ1=A(I)*(1.+CV/QA(I)) AQ1=1./(AQ1*AQ1) RHO1=RHO(I) AQ2=A(M)*(1.+CV/QA(M)) AQ2=1./(AQ2*AQ2) RHO2=RHO(M) A1=CSQRT(AQ1-UQ) A2=CSQRT(AQ2-UQ) AA=RHO2*A1+RHO1*A2 RPD=(RHO2*A1-RHO1*A2)/AA RPU=-RPD TPD=2.*RHO2*A1/AA TPU=2.*RHO1*A2/AA EP=CEXP(-D(I)*CW*EIN*A1) DD=1.-RPU*RP RP=(RPD+TPU*TPD*RP/DD)*EP*EP IF(I.EQ.1)FF=TPD/DD IF(I.GT.1)FF=TPD*EP/DD TP=FF*TP GO TO 1000 15 BQ1=B(I)*(1.+CV/QB(I)) BQ1=1./(BQ1*BQ1) Z1=RHO(I)/BQ1 BQ2=B(M)*(1.+CV/QB(M)) BQ2=1./(BQ2*BQ2) Z2=RHO(M)/BQ2 B1=CSQRT(BQ1-UQ) B2=CSQRT(BQ2-UQ) AA=Z1*B1+Z2*B2 RSD=(Z1*B1-Z2*B2)/AA RSU=-RSD TSD=2.*Z1*B1/AA TSU=2.*Z2*B2/AA ES=CEXP(-D(I)*CW*EIN*B1) DD=1.-RSU*RS RS=(RSD+TSU*TSD*RS/DD) IF(I.EQ.1)FF=TSD/DD IF(I.GT.1)FF=TSD*ES/DD TS=FF*TS C 1000 CONTINUE 1001 CONTINUE if(nc.eq.9)rcoef=rs if(nc.eq.10)rcoef=ts if(nc.eq.13)rcoef=rp if(nc.eq.14)rcoef=tp C RETURN END c c********************************************************************* c SUBROUTINE RTMAT(N,A,B,RHO,D,U,FRQ,RPP,RPS,RSS,RSP, * TPP,TPS,TSS,TSP,NC,RCOEF) C C P/SV REFLECTION AND TRANSMISSION COEFFICIENTS FOR A C NON-DISSIPATIVE TRANSITION LAYER, USING RECURSIVE FORMALISM C C N = NUMBER OF LAYERS (HALFSPACES INCLUDED) C A,B,RHO,D = MODEL C U = TANGENTIAL SLOWNESS C FRQ = FREQUENCY C RCOEF = COMPLEX-VALUED R/T COEFFICIENT OF THE TYPE NC C DIMENSION A(1),B(1),RHO(1),D(1) COMPLEX RPP,RPS,RSS,RSP,TPP,TPS,TSS,TSP,MU11,MU12,MU21,MU22, * RPPD,RSPD,RPSD,RSSD,TPPD,TSPD,TPSD,TSSD,RPPU,RSPU,RPSU,RSSU, * TPPU,TSPU,TPSU,TSSU,F11,F12,F21,F22,G11,G12,G21,G22,H11,H12, * H21,H22,I11,I12,I21,I22,EP,ES,EX,rcoef M=N-1 AQ1=1./(A(M)*A(M)) BQ1=1./(B(M)*B(M)) RHO1=RHO(M) AQ2=1./(A(N)*A(N)) BQ2=1./(B(N)*B(N)) RHO2=RHO(N) C=2.*(RHO1/BQ1-RHO2/BQ2) CALL RT(AQ1,BQ1,RHO1,AQ2,BQ2,RHO2,C,U,MU11,MU12,MU21,MU22, * TPPD,TSPD,TPSD,TSSD,RPPU,RSPU,RPSU,RSSU,TPPU,TSPU,TPSU,TSSU) W=6.283185*FRQ UQ=U*U CALL PHASE(UQ,W,AQ1,BQ1,D(M),EP,ES) EX=EP*ES RPP=MU11*EP*EP RSP=MU12*EX RPS=MU21*EX RSS=MU22*ES*ES TPP=TPPD*EP TSP=TSPD*ES TPS=TPSD*EP TSS=TSSD*ES IF(N.EQ.2) go to 1001 II=N-2 DO 1000 I=II,1,-1 M=I+1 AQ1=1./(A(I)*A(I)) BQ1=1./(B(I)*B(I)) RHO1=RHO(I) AQ2=1./(A(M)*A(M)) BQ2=1./(B(M)*B(M)) RHO2=RHO(M) C=2.*(RHO1/BQ1-RHO2/BQ2) CALL RT(AQ1,BQ1,RHO1,AQ2,BQ2,RHO2,C,U,RPPD,RSPD,RPSD,RSSD, * TPPD,TSPD,TPSD,TSSD,RPPU,RSPU,RPSU,RSSU,TPPU,TSPU,TPSU,TSSU) CALL MULMAT(RPP,RSP,RPS,RSS,TPPD,TSPD,TPSD,TSSD,G11,G12,G21, * G22) CALL MULMAT(RPP,RSP,RPS,RSS,RPPU,RSPU,RPSU,RSSU,H11,H12,H21, * H22) H11=1.-H11 H12=-H12 H21=-H21 H22=1.-H22 CALL MATINV(H11,H12,H21,H22,I11,I12,I21,I22) CALL MULMAT(I11,I12,I21,I22,G11,G12,G21,G22,H11,H12,H21,H22) CALL MULMAT(TPPU,TSPU,TPSU,TSSU,H11,H12,H21,H22,G11,G12,G21, * G22) MU11=RPPD+G11 MU12=RSPD+G12 MU21=RPSD+G21 MU22=RSSD+G22 CALL MULMAT(RPPU,RSPU,RPSU,RSSU,RPP,RSP,RPS,RSS,G11,G12,G21, * G22) G11=1.-G11 G12=-G12 G21=-G21 G22=1.-G22 CALL MATINV(G11,G12,G21,G22,H11,H12,H21,H22) CALL MULMAT(H11,H12,H21,H22,TPPD,TSPD,TPSD,TSSD,G11,G12,G21, * G22) CALL PHASE(UQ,W,AQ1,BQ1,D(I),EP,ES) F11=G11*EP F12=G12*ES F21=G21*EP F22=G22*ES CALL MULMAT(TPP,TSP,TPS,TSS,F11,F12,F21,F22,G11,G12,G21,G22) TPP=G11 TSP=G12 TPS=G21 TSS=G22 EX=EP*ES RPP=MU11*EP*EP RSP=MU12*EX RPS=MU21*EX 1000 RSS=MU22*ES*ES 1001 CONTINUE if(nc.eq.1)rcoef=rpp if(nc.eq.2)rcoef=-a(1)*rps/b(1) if(nc.eq.3)rcoef=a(1)*tpp/a(n) if(nc.eq.4)rcoef=-a(1)*tps/b(n) if(nc.eq.5)rcoef=-b(1)*rsp/a(1) if(nc.eq.6)rcoef=rss if(nc.eq.7)rcoef=-b(1)*tsp/a(n) if(nc.eq.8)rcoef=b(1)*tss/b(n) return END C C****************************************************************** C SUBROUTINE RT(AQ1,BQ1,RHO1,AQ2,BQ2,RHO2,C,U,RPPD,RSPD,RPSD, * RSSD,TPPD,TSPD,TPSD,TSSD,RPPU,RSPU,RPSU,RSSU,TPPU,TSPU, * TPSU,TSSU) C C A ROUTINE TO RTMAT. C MATRICES OF R/T COEFFICIENTS AT A SINGLE INTERFACE BETWEEN C TWO HALFSPACES C COMPLEX RPPD,RSPD,RPSD,RSSD,TPPD,TSPD,TPSD,TSSD,RPPU,RSPU, * RPSU,RSSU,TPPU,TSPU,TPSU,TSSU,A1,B1,A2,B2,D1D,D2D,D1U,D2U, * D,A1B1,A2B2,A1B2,A2B1,T1,T2,T3,T4,T5,T6,T7,T8,T9,T10 UQ=U*U V=SQRT(ABS(AQ1-UQ)) A1=CMPLX(V,0.) IF(UQ.GT.AQ1) A1=CMPLX(0.,-V) V=SQRT(ABS(BQ1-UQ)) B1=CMPLX(V,0.) IF(UQ.GT.BQ1) B1=CMPLX(0.,-V) V=SQRT(ABS(AQ2-UQ)) A2=CMPLX(V,0.) IF(UQ.GT.AQ2) A2=CMPLX(0.,-V) V=SQRT(ABS(BQ2-UQ)) B2=CMPLX(V,0.) IF(UQ.GT.BQ2) B2=CMPLX(0.,-V) C0=C*UQ C1=C0-RHO1 C2=C0+RHO2 C3=C1+RHO2 A1B1=A1*B1 A2B2=A2*B2 A1B2=A1*B2 A2B1=A2*B1 RHO12=RHO1*RHO2 T1=C1*C1*A2B2+RHO12*A2B1 T2=C2*C2*A1B1+RHO12*A1B2 T3=C3*C3*UQ T4=C*C0*A1B1*A2B2 D1D=T3+T1 D2D=T4+T2 D=D1D+D2D D1U=T3+T2 D2U=T4+T1 T5=2./D T6=A1*T5 T7=B1*T5 T8=A2*T5 T9=B2*T5 RPPD=(D2D-D1D)/D RPPU=(D2U-D1U)/D T10=U*(C3*C2+C*C1*A2B2) RPSD=-T6*T10 RSPD=T7*T10 T10=RHO12*(A1B2-A2B1)*T5 RSSD=RPPD-T10 RSSU=RPPU+T10 T10=U*(C3*C1+C*C2*A1B1) RPSU=T8*T10 RSPU=-T9*T10 T10=C2*B1-C1*B2 TPPD=RHO1*T6*T10 TPPU=RHO2*T8*T10 T10=U*(C3+C*A2B1) TPSD=-RHO1*T6*T10 TSPU=RHO2*T9*T10 T10=C2*A1-C1*A2 TSSD=RHO1*T7*T10 TSSU=RHO2*T9*T10 T10=U*(C3+C*A1B2) TSPD=RHO1*T7*T10 TPSU=-RHO2*T8*T10 RETURN END C C****************************************************************** C SUBROUTINE MULMAT(A11,A12,A21,A22,B11,B12,B21,B22,C11,C12, * C21,C22) C C A ROUTINE TO RTMAT AND RTMATQ. C MATRIX MULTIPLICATION C COMPLEX A11,A12,A21,A22,B11,B12,B21,B22,C11,C12,C21,C22 C11=A11*B11+A12*B21 C12=A11*B12+A12*B22 C21=A21*B11+A22*B21 C22=A21*B12+A22*B22 RETURN END C C****************************************************************** C SUBROUTINE MATINV(A11,A12,A21,A22,B11,B12,B21,B22) C C A ROUTINE TO RTMAT AND RTMATQ. C MATRIX INVERSION C COMPLEX A11,A12,A21,A22,B11,B12,B21,B22,D D=1./(A11*A22-A12*A21) B11=A22*D B12=-A12*D B21=-A21*D B22=A11*D RETURN END C C****************************************************************** C SUBROUTINE PHASE(UQ,W,AQ,BQ,D,EP,ES) C C A ROUTINE TO RTMAT AND RTMATQ C COMPLEX EP,ES X=-W*D V=SQRT(ABS(AQ-UQ)) A=X*V IF(UQ.GT.AQ) GO TO 100 EP=CMPLX(COS(A),SIN(A)) GO TO 200 100 EP=CMPLX(EXP(A),0.) 200 V=SQRT(ABS(BQ-UQ)) A=X*V IF(UQ.GT.BQ) GO TO 300 ES=CMPLX(COS(A),SIN(A)) GO TO 400 300 ES=CMPLX(EXP(A),0.) 400 RETURN END C C *********************************************************** C SUBROUTINE COEF8(P,VP1,VS1,RO1,VP2,VS2,RO2,NCODE,RMOD,RPH) C C ROUTINE COEF8 IS DESIGNED FOR THE COMPUTATION OF REFLECTION C AND TRANSMISSION COEFFICIENTS OF P, SV AND SH PLANE WAVES C AT A SINGLE PLANE INTERFACE BETWEEN TWO HOMOGENEOUS C NON-DISSIPATIVE SOLID HALFSPACES OR AT A FREE SURFACE OF A C NON-DISSIPATIVE HOMOGENEOUS SOLID HALFSPACE. EXPLICIT EQUATIONS C ARE USED. ALSO PRESSURE WAVES IN LIQUIDS ARE CONSIDERED. C COMPLEX B(4),RR,C1,C2,C3,C4,H1,H2,H3,H4,H5,H6,H,HB,HC DIMENSION PRMT(4),D(4),DD(4) C AUX=999.*3.14159/180. IF(NCODE.GE.9)GO TO 300 IF(RO2.LT.0.0001)GO TO 150 PRMT(1)=VP1 PRMT(2)=VS1 PRMT(3)=VP2 PRMT(4)=VS2 A1=VP1*VS1 A2=VP2*VS2 A3=VP1*RO1 A4=VP2*RO2 A5=VS1*RO1 A6=VS2*RO2 Q=2.*(A6*VS2-A5*VS1) PP=P*P QP=Q*PP X=RO2-QP Y=RO1+QP Z=RO2-RO1-QP G1=A1*A2*PP*Z*Z G2=A2*X*X G3=A1*Y*Y G4=A4*A5 G5=A3*A6 G6=Q*Q*PP DO 21 I=1,4 DD(I)=P*PRMT(I) 21 D(I)=SQRT(ABS(1.-DD(I)*DD(I))) IF(DD(1).LE.1..AND.DD(2).LE.1..AND.DD(3).LE.1..AND.DD(4).LE. 11.)GO TO 100 C C COMPLEX COEFFICIENTS DO 22 I=1,4 IF(DD(I).GT.1.)GO TO 23 B(I)=CMPLX(D(I),0.) GO TO 22 23 B(I)= CMPLX(0.,D(I)) 22 CONTINUE C1=B(1)*B(2) C2=B(3)*B(4) C3=B(1)*B(4) C4=B(2)*B(3) H1=G1 H2=G2*C1 H3=G3*C2 H4=G4*C3 H5=G5*C4 H6=G6*C1*C2 H=1./(H1+H2+H3+H4+H5+H6) HB=2.*H HC=HB*P GO TO (1,2,3,4,5,6,7,8),NCODE 1 RR=H*(H2+H4+H6-H1-H3-H5) GO TO 26 2 RR=VP1*B(1)*HC*(Q*Y*C2+A2*X*Z) GO TO 26 3 RR=A3*B(1)*HB*(VS2*B(2)*X+VS1*B(4)*Y) GO TO 26 4 RR=-A3*B(1)*HC*(Q*C4-VS1*VP2*Z) GO TO 26 5 RR=-VS1*B(2)*HC*(Q*Y*C2+A2*X*Z) GO TO 26 6 RR=H*(H2+H5+H6-H1-H3-H4) GO TO 26 7 RR=A5*B(2)*HC*(Q*C3-VP1*VS2*Z) GO TO 26 8 RR=A5*B(2)*HB*(VP1*B(3)*Y+VP2*B(1)*X) GO TO 26 C REAL COEFFICIENTS 100 E1=D(1)*D(2) E2=D(3)*D(4) E3=D(1)*D(4) E4=D(2)*D(3) S1=G1 S2=G2*E1 S3=G3*E2 S4=G4*E3 S5=G5*E4 S6=G6*E1*E2 S=1./(S1+S2+S3+S4+S5+S6) SB=2.*S SC=SB*P GO TO (101,102,103,104,105,106,107,108),NCODE 101 R=S*(S2+S4+S6-S1-S3-S5) GO TO 250 102 R=VP1*D(1)*SC*(Q*Y*E2+A2*X*Z) GO TO 250 103 R=A3*D(1)*SB*(VS2*D(2)*X+VS1*D(4)*Y) GO TO 250 104 R=-A3*D(1)*SC*(Q*E4-VS1*VP2*Z) GO TO 250 105 R=-VS1*D(2)*SC*(Q*Y*E2+A2*X*Z) GO TO 250 106 R=S*(S2+S5+S6-S1-S3-S4) GO TO 250 107 R=A5*D(2)*SC*(Q*E3-VP1*VS2*Z) GO TO 250 108 R=A5*D(2)*SB*(VP1*D(3)*Y+VP2*D(1)*X) GO TO 250 C C EARTHS SURFACE,COMPLEX COEFFICIENTS AND CONVERSION COEFFICIENTS 150 A1=VS1*P A2=A1*A1 A3=2.*A2 A4=2.*A1 A5=A4+A4 A6=1.-A3 A7=2.*A6 A8=2.*A3*VS1/VP1 A9=A6*A6 DD(1)=P*VP1 DD(2)=P*VS1 DO 151 I=1,2 151 D(I)=SQRT(ABS(1.-DD(I)*DD(I))) IF(DD(1).LE.1..AND.DD(2).LE.1.)GO TO 200 DO 154 I=1,2 IF(DD(I).GT.1.)GO TO 155 B(I)=CMPLX(D(I),0.) GO TO 154 155 B(I)= CMPLX(0.,D(I)) 154 CONTINUE H1=B(1)*B(2) H2=H1*A8 H=1./(A9+H2) GO TO (161,162,166,165,163,164,168,167),NCODE 161 RR=(-A9+H2)*H GO TO 26 162 RR=-A5*B(1)*H*A6 GO TO 26 163 RR=A5*B(2)*H*A6*VS1/VP1 GO TO 26 164 RR=-(A9-H2)*H GO TO 26 165 RR=A5*H1*H GO TO 26 166 RR=-A7*B(1)*H GO TO 26 167 RR=A7*B(2)*H GO TO 26 168 RR=A5*VS1*H1*H/VP1 C 26 Z2=REAL(RR) Z3=AIMAG(RR) IF(Z2.EQ.0..AND.Z3.EQ.0.)GO TO 157 RMOD=SQRT(Z2*Z2+Z3*Z3) RPH=ATAN2(Z3,Z2) IF(RMOD.LT.0.00001)RPH=AUX RETURN 157 RMOD=0. RPH=AUX RETURN C C EARTHS SURFACE,REAL COEFFICIENTS AND CONVERSION COEFFICIENTS 200 S1=D(1)*D(2) S2=A8*S1 S=1./(A9+S2) GO TO (201,202,206,205,203,204,208,207),NCODE 201 R=(-A9+S2)*S GO TO 250 202 R=-A5*D(1)*S*A6 GO TO 250 203 R=A5*D(2)*S*A6*VS1/VP1 GO TO 250 204 R=(S2-A9)*S GO TO 250 205 R=A5*S1*S GO TO 250 206 R=A7*D(1)*S GO TO 250 207 R=A7*D(2)*S GO TO 250 208 R=-A5*VS1*S1*S/VP1 250 IF(R.LT.0.)GO TO 251 RMOD=R RPH=0. IF(RMOD.LT.0.00001)RPH=AUX RR=CMPLX(R,0.) RETURN 251 RMOD=-R RPH=-3.14159 IF(RMOD.LT.0.00001)RPH=AUX RR=CMPLX(R,0.) RETURN C C SH COEFFICIENTS OF REFLECTION, TRANSMISSION AND CONVERSION C 300 IF(NCODE.GE.13)GO TO 400 IF(RO2.LT.0.0001) GO TO 302 A1=P*VS1 A2=P*VS2 A3=RO1*VS1 A4=RO2*VS2 A5=SQRT(ABS(1.-A1*A1)) A6=SQRT(ABS(1.-A2*A2)) C1=A5 IF(A2.LE.1.)C2=A6 IF(A2.GT.1.)C2=CMPLX(0.,A6) C1=C1*A3 C2=C2*A4 H=1./(C1+C2) IF(NCODE.EQ.10)GO TO 301 RR=H*(C1-C2) GO TO 26 301 RR=2.*C1*H GO TO 26 302 RMOD=1. RPH=0. IF(NCODE.EQ.10)GO TO 303 RETURN 303 RMOD=2. RPH=0. RETURN C C PRESSURE R/T COEFFICIENTS, LIQUIDS C 400 IF(RO2.LT.0.0001) GO TO 402 A1=P*VP1 A2=P*VP2 A3=RO1*VP1 A4=RO2*VP2 A5=SQRT(ABS(1.-A1*A1)) A6=SQRT(ABS(1.-A2*A2)) C1=A5 IF(A2.LT.1.)C2=A6 IF(A2.GE.1.)C2=CMPLX(0.,A6) C1=A4*C1 C2=A3*C2 H=1./(C1+C2) IF(NCODE.EQ.14)GO TO 401 RR=H*(C1-C2) GO TO 26 401 RR=2.*C1*H GO TO 26 402 RMOD=1. RPH=3.141593 IF(NCODE.EQ.14)GO TO 403 RETURN 403 RMOD=0. RPH=AUX RETURN END C C ************************************************************* C SUBROUTINE RTMATQ(FR,N,A,B,RHO,QA,QB,D,U,FRQ, * RPP,RPS,RSS,RSP,TPP,TPS,TSS,TSP,NC,RCOEF,v1,q1,aincr,gamma) C C P/SV REFLECTION AND TRANSMISSION COEFFICIENTS FOR A DISSIPATIVE C TRANSITION LAYER, USING RECURSIVE ALGORITHM. C C FR = REFERENCE FREQUENCY C N = NUMBER OF LAYERS (HALFSPACES INCLUDED) C A,B,RHO,QA,QB,D = MODEL (QA AND QB INDEPENDENT OF FREQUENCY) C U = TANGENTIAL SLOWNESS (COMPLEX-VALUED) C FRQ = FREQUENCY C RCOEF = COMPLEX-VALUED R/T COEFFICIENT OF THE TYPE NC C C LAYERS 1 AND N ARE HALFSPACES C C DIMENSION A(1),B(1),RHO(1),D(1),QA(1),QB(1),nc(1) COMPLEX RPP,RPS,RSS,RSP,TPP,TPS,TSS,TSP,MU11,MU12,MU21,MU22, * RPPD,RSPD,RPSD,RSSD,TPPD,TSPD,TPSD,TSSD,RPPU,RSPU,RPSU,RSSU, * TPPU,TSPU,TPSU,TSSU,F11,F12,F21,F22,G11,G12,G21,G22,H11,H12, * H21,H22,I11,I12,I21,I22,EP,ES,EX,AQ1,BQ1,AQ2,BQ2,C,CW,CV, * EIN,rcoef,apom,bpom,apom2,bpom2,u,uq C WR=6.28319*FR EIN=CMPLX(0.,1.) W=6.28319*FRQ CW=W CV=ALOG(W/WR)/3.141593+0.5*EIN C M=N-1 RHO1=RHO(M) AQ1=A(M)*(1.+CV/QA(M)) APOM=AQ1 AQ1=1./(AQ1*AQ1) BQ1=B(M)*(1.+CV/QB(M)) BPOM=BQ1 BQ1=1./(BQ1*BQ1) RHO2=RHO(N) AQ2=A(N)*(1.+CV/QA(N)) APOM2=AQ2 AQ2=1./(AQ2*AQ2) BQ2=B(N)*(1.+CV/QB(N)) BPOM2=BQ2 BQ2=1./(BQ2*BQ2) c c determination of possible critical angles in critan (for n=2) if(n.gt.2) go to 1 cvr=alog(w/wr)/3.141593 va1=a(m)*(1.+cvr/qa(m)) vb1=b(m)*(1.+cvr/qb(m)) qa1=qa(m) qb1=qb(m) va2=a(n)*(1.+cvr/qa(n)) vb2=b(n)*(1.+cvr/qb(n)) qa2=qa(n) qb2=qb(n) 1 continue c C=2.*(RHO1/BQ1-RHO2/BQ2) CALL RTQ(AQ1,BQ1,RHO1,AQ2,BQ2,RHO2,C,U,MU11,MU12,MU21,MU22, * TPPD,TSPD,TPSD,TSSD,RPPU,RSPU,RPSU,RSSU,TPPU,TSPU,TPSU,TSSU, * aincr,gamma,v1,q1,va1,vb1,va2,vb2,qa1,qb1,qa2,qb2,n) UQ=U*U EP=CEXP(-D(M)*CW*EIN*CSQRT(AQ1-UQ)) ES=CEXP(-D(M)*CW*EIN*CSQRT(BQ1-UQ)) EX=EP*ES RPP=MU11*EP*EP RSP=MU12*EX RPS=MU21*EX RSS=MU22*ES*ES TPP=TPPD*EP TSP=TSPD*ES TPS=TPSD*EP TSS=TSSD*ES IF(N.EQ.2) go to 1001 C C LOOP FOR LAYERS C II=N-2 DO 1000 I=II,1,-1 M=I+1 AQ1=A(I)*(1.+CV/QA(I)) apom=aq1 AQ1=1./(AQ1*AQ1) BQ1=B(I)*(1.+CV/QB(I)) bpom=bq1 BQ1=1./(BQ1*BQ1) RHO1=RHO(I) AQ2=A(M)*(1.+CV/QA(M)) AQ2=1./(AQ2*AQ2) BQ2=B(M)*(1.+CV/QB(M)) BQ2=1./(BQ2*BQ2) RHO2=RHO(M) C=2.*(RHO1/BQ1-RHO2/BQ2) CALL RTQ(AQ1,BQ1,RHO1,AQ2,BQ2,RHO2,C,U,RPPD,RSPD,RPSD,RSSD, * TPPD,TSPD,TPSD,TSSD,RPPU,RSPU,RPSU,RSSU,TPPU,TSPU,TPSU,TSSU, * aincr,gamma,v1,q1,va1,vb1,va2,vb2,qa1,qb1,qa2,qb2,n) CALL MULMAT(RPP,RSP,RPS,RSS,TPPD,TSPD,TPSD,TSSD,G11,G12,G21, * G22) CALL MULMAT(RPP,RSP,RPS,RSS,RPPU,RSPU,RPSU,RSSU,H11,H12,H21, * H22) H11=1.-H11 H12=-H12 H21=-H21 H22=1.-H22 CALL MATINV(H11,H12,H21,H22,I11,I12,I21,I22) CALL MULMAT(I11,I12,I21,I22,G11,G12,G21,G22,H11,H12,H21,H22) CALL MULMAT(TPPU,TSPU,TPSU,TSSU,H11,H12,H21,H22,G11,G12,G21, * G22) MU11=RPPD+G11 MU12=RSPD+G12 MU21=RPSD+G21 MU22=RSSD+G22 CALL MULMAT(RPPU,RSPU,RPSU,RSSU,RPP,RSP,RPS,RSS,G11,G12,G21, * G22) G11=1.-G11 G12=-G12 G21=-G21 G22=1.-G22 CALL MATINV(G11,G12,G21,G22,H11,H12,H21,H22) CALL MULMAT(H11,H12,H21,H22,TPPD,TSPD,TPSD,TSSD,G11,G12,G21, * G22) EP=CEXP(-D(I)*CW*EIN*CSQRT(AQ1-UQ)) ES=CEXP(-D(I)*CW*EIN*CSQRT(BQ1-UQ)) F11=G11*EP F12=G12*ES F21=G21*EP F22=G22*ES CALL MULMAT(TPP,TSP,TPS,TSS,F11,F12,F21,F22,G11,G12,G21,G22) TPP=G11 TSP=G12 TPS=G21 TSS=G22 EX=EP*ES RPP=MU11*EP*EP RSP=MU12*EX RPS=MU21*EX 1000 RSS=MU22*ES*ES 1001 continue if (nc(1).eq.1)rcoef=rpp if(nc(1).eq.2)rcoef=-apom*rps/bpom if(nc(1).eq.3)rcoef=apom*tpp/apom2 if(nc(1).eq.4)rcoef=-apom*tps/bpom2 if(nc(1).eq.5)rcoef=-bpom*rsp/apom if(nc(1).eq.6)rcoef=rss if(nc(1).eq.7)rcoef=-bpom*tsp/apom2 if(nc(1).eq.8)rcoef=bpom*tss/bpom2 RETURN END C C ************************************************************ C SUBROUTINE RTQ(AQ1,BQ1,RHO1,AQ2,BQ2,RHO2,C,U,RPPD,RSPD,RPSD, * RSSD,TPPD,TSPD,TPSD,TSSD,RPPU,RSPU,RPSU,RSSU,TPPU,TSPU, * TPSU,TSSU,aincr,gamma, * v1,q1,va1,vb1,va2,vb2,qa1,qb1,qa2,qb2,n) C C A ROUTINE TO RTMATQ C R/T COEFFICIENTS AT A SINGLE INTERFACE BETWEEN C TWO HOMOGENEOUS DISSIPATIVE HALFSPACES C COMPLEX RPPD,RSPD,RPSD,RSSD,TPPD,TSPD,TPSD,TSSD,RPPU,RSPU, * RPSU,RSSU,TPPU,TSPU,TPSU,TSSU,A1,B1,A2,B2,D1D,D2D,D1U,D2U, * D,A1B1,A2B2,A1B2,A2B1,T1,T2,T3,T4,T5,T6,T7,T8,T9,T10, * AQ1,BQ1,AQ2,BQ2,C,C1,C2,C3,C0,U,UQ C uq=u*u A1=CSQRT(AQ1-UQ) B1=CSQRT(BQ1-UQ) A2=CSQRT(AQ2-UQ) B2=CSQRT(BQ2-UQ) c c determination of possible critical angles in critan, for n=2 if(n.gt.2)go to 1 call critan(v1,va1,q1,qa1,gamma,ncrit,acrit1,acrit2) if(ncrit.ne.0)then if(aincr.gt.acrit1.and.aincr.lt.acrit2)a1=-a1 endif call critan(v1,vb1,q1,qb1,gamma,ncrit,acrit1,acrit2) if(ncrit.ne.0)then if(aincr.gt.acrit1.and.aincr.lt.acrit2)b1=-b1 endif call critan(v1,va2,q1,qa2,gamma,ncrit,acrit1,acrit2) if(ncrit.ne.0)then if(aincr.gt.acrit1.and.aincr.lt.acrit2)a2=-a2 endif call critan(v1,vb2,q1,qb2,gamma,ncrit,acrit1,acrit2) if(ncrit.ne.0)then if(aincr.gt.acrit1.and.aincr.lt.acrit2)b2=-b2 endif c 1 C0=C*UQ C1=C0-RHO1 C2=C0+RHO2 C3=C1+RHO2 A1B1=A1*B1 A2B2=A2*B2 A1B2=A1*B2 A2B1=A2*B1 RHO12=RHO1*RHO2 T1=C1*C1*A2B2+RHO12*A2B1 T2=C2*C2*A1B1+RHO12*A1B2 T3=C3*C3*UQ T4=C*C0*A1B1*A2B2 D1D=T3+T1 D2D=T4+T2 D=D1D+D2D D1U=T3+T2 D2U=T4+T1 T5=2./D T6=A1*T5 T7=B1*T5 T8=A2*T5 T9=B2*T5 RPPD=(D2D-D1D)/D RPPU=(D2U-D1U)/D T10=U*(C3*C2+C*C1*A2B2) RPSD=-T6*T10 RSPD=T7*T10 T10=RHO12*(A1B2-A2B1)*T5 RSSD=RPPD-T10 RSSU=RPPU+T10 T10=U*(C3*C1+C*C2*A1B1) RPSU=T8*T10 RSPU=-T9*T10 T10=C2*B1-C1*B2 TPPD=RHO1*T6*T10 TPPU=RHO2*T8*T10 T10=U*(C3+C*A2B1) TPSD=-RHO1*T6*T10 TSPU=RHO2*T9*T10 T10=C2*A1-C1*A2 TSSD=RHO1*T7*T10 TSSU=RHO2*T9*T10 T10=U*(C3+C*A1B2) TSPD=RHO1*T7*T10 TPSU=-RHO2*T8*T10 RETURN END C C ************************************************************* C COMPLEX FUNCTION CSQ(X) C C A ROUTINE TO RTMATQ. C COMPLEX X A=CABS(X) B=REAL(X) RE=0.7071*SQRT(A+B) AI=-0.7071*SQRT(A-B) CSQ=CMPLX(RE,AI) RETURN END c c********************************************************************** c subroutine critan(v1,v2,q1,q2,gamma,n,acrit1,acrit2) c c A routine to compute the discrete critical angles c c auxw1=sqrt(1.+1./(q1*q1)) c w1=2./(v1*v1*(1.+auxw1)) c auxw2=sqrt(1.+1./(q2*q2)) c w2=2./(v2*v2*(1.+auxw2)) auxw1=1.+1./(q1*q1) auxw2=1.+1./(q2*q2) w1=1./(v1*v1*auxw1) w2=1./(v2*v2*auxw2) c=(2.*w2*q1)/(w1*q2)-1. a=(w2*q1*cos(gamma))/(w1*q2) c n = 0 acrit1=1000. acrit2=1000. c caux=1./(c*c) cos2g=cos(gamma)*cos(gamma) if(cos2g.le.caux)then aux=sqrt(1.-c*c*cos2g) omega1=(1.+c*cos2g+sin(gamma)*aux)/2. omega2=(1.+c*cos2g-sin(gamma)*aux)/2. if(0.lt.omega1.and.omega1.lt.1)then acrit1=asin(sqrt(omega1)) if(acrit1.lt.gamma)then acrit1=1000. go to 2 endif if(abs(acrit1-gamma).lt.0.000001)then acrit1=1000. go to 2 endif aim1 = a - sin(acrit1)*sin(acrit1-gamma) if(abs(aim1).gt.0.0001)then acrit1 = 1000. go to 2 endif c n=1 g=sqrt(1.+1./(q1*q1*cos2g)) rea1=w2-(w1*((1.+g)*sin(acrit1)*sin(acrit1)- * (g-1.)*sin(acrit1-gamma)*sin(acrit1-gamma)))/2. if(rea1.gt.0)then acrit1=1000. c n=0 else n=1 endif endif c 2 if(0.lt.omega2.and.omega2.lt.1)then acrit2=asin(sqrt(omega2)) if(acrit2.lt.gamma)then acrit2=1000. go to 3 endif if(abs(acrit2-gamma).lt.0.000001)then acrit2=1000. go to 3 endif aim2=a - sin(acrit2)*sin(acrit2-gamma) if(abs(aim2).gt.0.0001)then acrit2=1000. go to 3 endif c n=n+1 g=sqrt(1.+1./(q1*q1*cos2g)) rea2=w2-(w1*((1.+g)*sin(acrit2)*sin(acrit2)- * (g-1.)*sin(acrit2-gamma)*sin(acrit2-gamma)))/2. if(rea2.gt.0)then acrit2=1000. c n=n-1 else n=n+1 endif endif endif c 3 if(acrit2.lt.acrit1)then acr11=acrit2 acrit2=acrit1 acrit1=acr11 endif c if(abs(acrit1-acrit2).lt.0.00005)then n=1 acrit2=1000. endif return end c c*********************************************************************** ccolors.for 0100666 0000765 0000765 00000030570 07214073210 012443 0 ustar bulant bulant C
C Subroutines to linearly interpolate discrete colour maps in RGB space C C Version: 5.50 C Date: 2000, November 8 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 C Description of the data file specifying the colour map: C (1) N0,N1,N2,...,NK,/ C Colour map is specified on the (K+1)-dimensional rectangular grid C of N0*N1*N2*...*Nk points situated within (K+1)-dimensional unit C cube. C (2) (K+1) times (2.1), for J=0,1,...,K C (2.1) CI(1),CI(2),...,CI(NJ) C Grid coordinates. Must be 0.LE.CI(1).LE.CI(2).LE. ... .LE.CI(NI). C (3) R(I0,I1,...,IK),G(I0,I1,...,IK),B(I0,I1,...,IK) for I0=1,2,...,N0; C for I1=1,2,...,N1; ...; for IK=1,2,...,NK C RGB components of grid values of the colour map. The colours are C linearly (bilinearly, trilinearly, ...) interpolated between the C gridpoints and are constant between the sides of the unit cube C and the nearest gridpoint. C (4) (K+1) times (2.1), for J=0,1,...,K C (4.1) REPL,REPR,CREF,VREFNORM C REPL,REPR... Colours of interval (0,1) are cyclically repeated C along the interval (-REPL,1+REPR). Colours left to -REPL C are constant, colours right to 1+REPR are constant. C CREF... Default reference colour. It may be changed by the input C SEP file using parameters CREF, CREF1, CREF2, ... C VREFNORM... Determines the default reference value. The reference C value may be changed by the input SEP file using C parameters VREF, VREF1, VREF2, ... C For an example refer to colour map hsv.dat C C C Data file 'SEP' has the form of the SEP (Stanford Exploration Project) C parameter file: C All the data are specified in the form of PARAMETER=VALUE, e.g. C N1=50, with PARAMETER directly preceding = without intervening C spaces and with VALUE directly following = without intervening C spaces. The PARAMETER=VALUE couple must be delimited by a space C or comma from both sides. C The PARAMETER string is not case-sensitive. C PARAMETER= followed by a space resets the default parameter value. C All other text in the input files is ignored. The file thus may C contain unused data or comments without leading comment character. C Everything between comment character # and the end of the C respective line is ignored, too. C The PARAMETER=VALUE couples may be specified in any order. C The last appearance takes precedence. C Data specifying the colour scale: C VADD=real... Controls the default value of VPER. C Default: VADD=0. C VMUL=real... Controls the default value of VPER. C Default: VMUL=1. C VPER=real... Period of values corresponding to one period in the C colour map. C Default: VPER=VMUL*(GMAX-GMIN+VADD), C where GMIN and GMAX are the minimum and maximum values to C be displayed in colours. C VREF=real... Reference value. It will be displayed in the C reference colour. C Default: VREF=GMIN+(GMAX-GMIN)*VREFNORM, C where VREFNORM is taken from the colour map file. C For COLORS='hsv.dat', default VREF=GMIN. C CREF=real... Reference colour. C Default value is taken from the colour map file. C For COLORS='hsv.dat', default CREF=0.666667 (blue). C VADD1=real, VADD2=real, ..., VMUL1=real, VMUL2=real, ..., C VPER1=real, VPER2=real, ..., VREF1=real, VREF2=real, ..., C CREF1=real, CREF2=real, etc... Analogous to VADD, VMUL, VPER, VREF C and CREF for multidimensional colour maps. C Default values are also analogous. C For COLORS='hsv.dat' (three-dimensional colour map), C defaults are determined by VREFNORM1=1., VREFNORM2=1., C CREF1=1. (maximum saturation), CREF2=1. (maximum C brightness). C C======================================================================= C SUBROUTINE COLOR1(LU,MRAM,IRAM,RAM,NVALUE,VALMIN,VALMAX) C INTEGER LU,MRAM,IRAM(0:MRAM-1),NVALUE REAL RAM(0:MRAM-1),VALMIN(NVALUE),VALMAX(NVALUE) C C----------------------------------------------------------------------- C C External functions and subroutines: EXTERNAL RSEP3T,RSEP3R,ERROR C C Storage in array (I)RAM: C IRAM(0)=K... Dimensionality of the colour map. C IRAM(1:K)=(L1,L2,...,LK)... Last indices of the grid coordinates C of the colour map. L0=K, L(i)=L(i-1)+N(i) where C N1,N2,...,NK are the numbers of gridpoints of the colour C map. C RAM(K+1:LK)... Grid coordinates. C RAM(LK+1:LK+3*N1*N2*...*NK)... Gridpoint RGB colours. C RAM(LK+3*N1*N2*...*NK+1:LK+3*N1*N2*...*NK+NREF*K)... For each grid C coordinate: the left and right colour repetitions, the C reference colour, the reference normalized value switched C into the reference value, the period of values, auxiliary C storage locations. C C....................................................................... C CHARACTER*80 FILE CHARACTER*5 TEXT REAL VADD,VMUL,VPER,VREF,CREF INTEGER NGRID,NREF,I1,I2,I PARAMETER (NREF=8) C C NGRID=LK+3*N1*N2*...*NK... Location of the last grid colour in C array RAM. C NREF... Number of reference values for each grid coordinate. C C....................................................................... C IF(10.GT.MRAM-1) THEN C COLORS-01 CALL ERROR('COLORS-01: Too small array RAM') END IF CALL RSEP3T('COLORS',FILE,'hsv.dat' ) OPEN(LU,FILE=FILE) DO 11 I=1,10 IRAM(I)=0 11 CONTINUE READ(LU,*) (IRAM(I),I=1,10) NGRID=1 DO 12 I=1,10 IF(IRAM(I).LE.0) THEN IRAM(0)=I-1 GO TO 13 END IF NGRID=NGRID*IRAM(I) 12 CONTINUE C COLORS-02 CALL ERROR('COLORS-02: More than 9 colour coordinates') 13 CONTINUE DO 14 I=1,IRAM(0) IRAM(I)=IRAM(I-1)+IRAM(I) 14 CONTINUE NGRID=IRAM(IRAM(0))+3*NGRID IF(NGRID+NREF*IRAM(0).GT.MRAM-1) THEN C COLORS-03 CALL ERROR('COLORS-03: Too small array RAM') END IF C Reading grid coordinates DO 15 I2=1,IRAM(0) READ(LU,*) (RAM(I1),I1=IRAM(I2-1)+1,IRAM(I2)) 15 CONTINUE C Reading grid RGB values READ(LU,*) (RAM(I1),I1=IRAM(IRAM(0))+1,NGRID) C Reading repetitions, reference colours and reference values DO 17 I2=NGRID,NGRID+NREF*(IRAM(0)-1),NREF READ(LU,*) (RAM(I1),I1=I2+1,I2+4) 17 CONTINUE C TEXT=' ' DO 21 I2=1,MIN0(IRAM(0),NVALUE) I=NGRID+NREF*(I2-1) IF(I2.GT.1) THEN TEXT(5:5)=CHAR(ICHAR('0')+I2-1) END IF TEXT(1:4)='CREF' CREF=RAM(I+3) CALL RSEP3R(TEXT,RAM(I+3),CREF) TEXT(1:4)='VREF' VREF=VALMIN(I2)+(VALMAX(I2)-VALMIN(I2))*RAM(I+4) CALL RSEP3R(TEXT,RAM(I+4),VREF) TEXT(1:4)='VADD' CALL RSEP3R(TEXT,VADD,0.) TEXT(1:4)='VMUL' CALL RSEP3R(TEXT,VMUL,1.) TEXT(1:4)='VPER' VPER=(VALMAX(I2)-VALMIN(I2)+VADD)*VMUL CALL RSEP3R(TEXT,RAM(I+5),VPER) 21 CONTINUE DO 22 I2=MIN0(IRAM(0),NVALUE)+1,IRAM(0) I=NGRID+NREF*(I2-1) IF(I2.GT.1) THEN TEXT(5:5)=CHAR(ICHAR('0')+I2-1) END IF TEXT(1:4)='CREF' CREF=RAM(I+3) CALL RSEP3R(TEXT,RAM(I+3),CREF) 22 CONTINUE CLOSE(LU) RETURN END C C======================================================================= C SUBROUTINE COLOR2(MRAM,IRAM,RAM,NVALUE,VALUE,R,G,B) C INTEGER MRAM,IRAM(0:MRAM-1),NVALUE REAL RAM(0:MRAM-1),VALUE(NVALUE),R,G,B C C----------------------------------------------------------------------- C REAL VPER,VREF,CREF,COLOR,W INTEGER NREF,NGRID,IGRID,I1,I2,I,J,N PARAMETER (NREF=8) C C NREF... Number of reference values for each grid coordinate. C NGRID...Location of the last grid colour in array RAM. C C....................................................................... C C Index of the grid origin = initial index of the cube origin IGRID=IRAM(IRAM(0)) C Index of the last grid value NGRID=1 DO 11 I=1,IRAM(0) NGRID=NGRID*(IRAM(I)-IRAM(I-1)) 11 CONTINUE NGRID=IGRID+3*NGRID C N=3 C N is the shift between indices of neighbouring gridpoints DO 39 I2=1,IRAM(0) I=NGRID+NREF*(I2-1) CREF=RAM(I+3) VREF=RAM(I+4) VPER=RAM(I+5) IF(I2.LE.NVALUE) THEN COLOR=(VALUE(I2)-VREF)/VPER+CREF ELSE COLOR=CREF END IF COLOR=AMAX1(COLOR, -RAM(I+1)) COLOR=AMIN1(COLOR,1.+RAM(I+2)) IF(COLOR.LT.0.) THEN COLOR=COLOR-AINT(COLOR)+1. ELSE IF(COLOR.GT.1.) THEN COLOR=COLOR-AINT(COLOR) IF(COLOR.LE.0.) THEN COLOR=1. END IF END IF DO 31 I1=IRAM(I2-1)+1,IRAM(I2) IF(COLOR.LE.RAM(I1)) THEN C Colour is located left to the grid coordinate RAM(I1) IF(I1.LE.IRAM(I2-1)+1) THEN RAM(I+7)=1. RAM(I+8)=0. J=0 ELSE J=I1-IRAM(I2-1)-2 RAM(I+8)=(COLOR-RAM(I1-1))/(RAM(I1)-RAM(I1-1)) RAM(I+7)=1.-RAM(I+8) END IF GO TO 32 END IF 31 CONTINUE J=IRAM(I2)-IRAM(I2-1)-2 RAM(I+7)=0. RAM(I+8)=1. 32 CONTINUE IGRID=IGRID+N*J IRAM(I+6)=N N=N*(IRAM(I2)-IRAM(I2-1)) 39 CONTINUE C R=0. G=0. B=0. C Loop over the vertices of the IRAM(0)-dimensional cube: DO 49 I2=0,2**IRAM(0)-1 N=IGRID W=1. J=I2 DO 45 I1=0,IRAM(0)-1 I=MOD(J,2) J=J/2 N=N+I*IRAM(NGRID+NREF*I1+6) W=W*RAM(NGRID+NREF*I1+7+I) 45 CONTINUE R=R+W*RAM(N+1) G=G+W*RAM(N+2) B=B+W*RAM(N+3) 49 CONTINUE RETURN END C C======================================================================= C SUBROUTINE COLOR3(MRAM,IRAM,RAM,NVALUE,IREF,IRGB) C INTEGER MRAM,IRAM(0:MRAM-1),NVALUE,IREF,IRGB REAL RAM(0:MRAM-1) C C IREF... Index of CREF in array RAM: C RAM(IREF )=CREF, RAM(IREF+1)=VREF, RAM(IREF+2)=VPER, C RAM(IREF+8)=CREF1, RAM(IREF+9)=VREF1, RAM(IREF+10)=VPER1, C etc. C IRGB... Index of the first output grid value in array RAM: C RAM(IREF )=CREF, RAM(IREF+1)=VREF, RAM(IREF+2)=VPER, C RAM(IREF+8)=CREF1, RAM(IREF+9)=VREF1, RAM(IREF+10)=VPER1, C etc. C C----------------------------------------------------------------------- C INTEGER NREF,I1,I2,I,N PARAMETER (NREF=8) C C NREF... Number of reference values for each grid coordinate. C C....................................................................... C C Index of the first reference value: IREF=1 DO 11 I1=1,IRAM(0) IREF=IREF*(IRAM(I1)-IRAM(I1-1)) 11 CONTINUE IREF=IRAM(IRAM(0))+3*IREF+3 C C Index of the first output grid value: IRGB=IREF-2+NREF*IRAM(0) C N=1 DO 21 I1=1,NVALUE N=N*(IRAM(I1)-IRAM(I1-1)) 21 CONTINUE IF(IRGB+3*N+NVALUE.GT.MRAM) THEN C COLORS-04 CALL ERROR('COLORS-04: Too small array RAM') END IF DO 29 I2=0,N-1 I=I2 DO 28 I1=0,NVALUE-1 RAM(IRGB+3*N+I1)=(RAM(IRAM(I1)+MOD(I,IRAM(I1+1)-IRAM(I1))+1) * -RAM(IREF+8*I1))*RAM(IREF+8*I1+2)+RAM(IREF+8*I1+1) I=I/(IRAM(I1+1)-IRAM(I1)) 28 CONTINUE CALL COLOR2(MRAM,IRAM(0),RAM(0),NVALUE,RAM(IRGB+3*N), * RAM(IRGB+3*I2),RAM(IRGB+3*I2+1),RAM(IRGB+3*I2+2)) 29 CONTINUE RETURN END C C======================================================================= Ccompdel.pl 0100666 0000765 0000765 00000005213 07034033074 012412 0 ustar bulant bulant #!perl #
# # Perl script 'compdel.pl' to compare files in the source directory with # the files in the working directory and to delete the identical files # from the working directory # # Version: 5.40 # Date: 2000, January 3 # # Coded by: Ludek Klimes # Department of Geophysics, Charles University Prague, # Ke Karlovu 3, 121 16 Praha 2, Czech Republic, # E-mail: klimes@seis.karlov.mff.cuni.cz # # ...................................................................... # # Usage: # perl compdel.pl path1/ path2/ # where # path1/ is the path to the source directory terminated by a slash, # path2/ is the path to the working directory terminated by a slash. # The paths should be typed in the Unix form. # The files in the working directory identical to the corresponding # files of the source directory will be deleted. # # ====================================================================== if (scalar(@ARGV)<1) { die "Arguments (paths) missing. Error"; } opendir(LU,$ARGV[0]) || die "Directory '$ARGV[0]' not found. Error"; @DIR1=readdir(LU); closedir(LU); opendir(LU,$ARGV[1]) || die "Directory '$ARGV[1]' not found. Error"; @DIR2=readdir(LU); closedir(LU); # foreach $NAME1 (@DIR1) { $PATH1=$ARGV[0].$NAME1; unless ($NAME1 eq '.') { unless ($NAME1 eq '..') { unless (-d $PATH1) { foreach $NAME2 (@DIR2) { $PATH2=$ARGV[1].$NAME2; if ($NAME1 eq $NAME2) { open(LU,$PATH1) || die "Cannot open '$PATH1'. Error"; @FILE1=copy.cal 0100666 0000765 0000765 00000000006 06311435276 012067 0 ustar bulant bulant $2=$1 copy.pl 0100666 0000765 0000765 00000001204 07167013210 011732 0 ustar bulant bulant #!perl #; close(LU) || die "Error"; open(LU,$PATH2) || die "Cannot open '$PATH2'. Error"; @FILE2= ; close(LU) || die "Error"; # Check for the number of lines: if (scalar(@FILE1)==scalar(@FILE2)) { # Check for the contents: foreach $LINE1 (@FILE1) { $LINE2=shift(@FILE2); if ($LINE1 ne $LINE2) { print "$NAME1: different lines\n"; goto EndCheck; } } print "$NAME1: identical - deleted\n"; # *** Very dangerous command *** unlink($PATH2); # ****************************** EndCheck: } else { print "$NAME1: different number of lines\n"; } } } } } } } # ====================================================================== 1; #
# # Perl script 'copy.pl' to copy a file specified by $ARGV[0] (first # command-line argument) to a file specified by $ARGV[1] (second # argument). It does not work correctly with binary data under MS DOS. # ====================================================================== # Main program 'copy.pl': # ~~~~~~~~~~~~~~~~~~~~~~~ $FILE1=$ARGV[0]; $FILE2=$ARGV[1]; @ARGV=(); require 'go.pl'; ©($FILE1,$FILE2); # ====================================================================== 1; #corfft.h 0100666 0000765 0000765 00000010503 10061773474 012075 0 ustar bulant bulant # History file 'corfft.h' to generate and plot the representations # of the random media for paper # Klimes, L. (1997): Correlation functions of random media. # In: Seismic Waves in Complex 3-D Structures, Report 6. # Department of Geophysics, Charles University, Prague. # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Input files required chk.pl: "forms/" "mul.cal" # Pseudorandom numbers and their FFT # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Grid dimensions for FFT N1=512 N1OUT=512 N2=512 N2OUT=512 D1=0.002 D1OUT=6.135923 D2=0.002 D2OUT=6.135923 O1=0. O1OUT=-1570.796 O2=0. O2OUT=-1570.796 # Selecting a particular pseudo-random representation ISEED=-13 # Generating pseudorandom numbers grdran: # FFT of the pseudorandom numbers FFT=1. FFTINR='grdran.out' FFTOUTR='grdfftr.out' FFTOUTI='grdffti.out' grdfft: # Representations of individual random media # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Grid dimensions for inverse FFT N1=512 N1OUT=501 N2=512 N2OUT=501 D1=6.135923 D1OUT=0.002 D2=6.135923 D2OUT=0.002 O1=-1570.796 O1OUT=0. O2=-1570.796 O2OUT=0. # Data for inverse FFT common to all representations FFT=-1. FFTINR='grdcalr.out' FFTINI='grdcali.out' FFTOUTI= # Figure 2 POWERN=-0.2 ACORG=0.005 ACOR=0.020 FFTOUTR='fft02.out' grdcor: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdfftr.out' GRD3='grdcalr.out' grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdffti.out' GRD3='grdcali.out' grdcal: grdfft: # Figure 3 POWERN=-1.0 ACORG=0.005 ACOR= FFTOUTR='fft03.out' grdcor: grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdfftr.out' GRD3='grdcalr.out' grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdffti.out' GRD3='grdcali.out' grdfft: # Figure 4 POWERN=-0.2 ACORG=0. ACOR=0.020 FFTOUTR='fft04.out' grdcor: grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdfftr.out' GRD3='grdcalr.out' grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdffti.out' GRD3='grdcali.out' grdfft: # Figure 5 POWERN=0.5 ACORG=0. ACOR=0.020 FFTOUTR='fft05.out' grdcor: grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdfftr.out' GRD3='grdcalr.out' grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdffti.out' GRD3='grdcali.out' grdfft: # Figure 6 POWERN=0.0 ACORG=0. ACOR=0.020 FFTOUTR='fft06.out' grdcor: grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdfftr.out' GRD3='grdcalr.out' grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdffti.out' GRD3='grdcali.out' grdfft: # Figure 7 POWERN=-0.2 ACORG=0. ACOR= FFTOUTR='fft07.out' grdcor: grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdfftr.out' GRD3='grdcalr.out' grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdffti.out' GRD3='grdcali.out' grdfft: # Figure 8 POWERN=-0.2 ACORG=0.005 ACOR= FFTOUTR='fft08.out' grdcor: grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdfftr.out' GRD3='grdcalr.out' grdcal: CAL='mul.cal' GRD1='grdcor.out' GRD2='grdffti.out' GRD3='grdcali.out' grdfft: # Grid dimensions of the representations of the random media N1=501 N2=501 D1=0.002 D2=0.002 # Rescaling the representations of the random media # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Velocities between 0.0 and 2.0, with mean value of 1.000 DSD=0.500 VMEAN=1.000 DEVMAX=1.000 DEVEXP=2. STATIN='fft02.out' STATOUT='corff02.out' grdstat: STATIN='fft03.out' STATOUT='corff03.out' grdstat: STATIN='fft04.out' STATOUT='corff04.out' grdstat: STATIN='fft05.out' STATOUT='corff05.out' grdstat: STATIN='fft06.out' STATOUT='corff06.out' grdstat: STATIN='fft07.out' STATOUT='corff07.out' grdstat: STATIN='fft08.out' STATOUT='corff08.out' grdstat: # Plotting the representations of the random medium # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HSIZE=16.032 HOFFSET=2.484 VCIRC=2. VREF=1.000 CREF=.166667 GRD='corff02.out' PS='corff02.ps' grdps: GRD='corff03.out' PS='corff03.ps' grdps: GRD='corff04.out' PS='corff04.ps' grdps: GRD='corff05.out' PS='corff05.ps' grdps: GRD='corff06.out' PS='corff06.ps' grdps: GRD='corff07.out' PS='corff07.ps' grdps: GRD='corff08.out' PS='corff08.ps' grdps: # ====================================================================== # List of output PostScript figures # 'corff02.ps', 'corff03.ps', ..., 'corff08.ps' corfun.h 0100666 0000765 0000765 00000005112 07114401304 012067 0 ustar bulant bulant # History file 'corfun.h' to generate and plot the representations # of the random media for paper # Klimes, L. (1997): Correlation functions of random media. # In: Seismic Waves in Complex 3-D Structures, Report 6. # Department of Geophysics, Charles University, Prague. # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Data common to all representations # Grid dimensions N1=501 N2=501 D1=0.002 D2=0.002 # Velocities between 0.0 and 2.0, with mean value of 1.000 DSD=0.500 VMEAN=1.000 DEVMAX=1.000 DEVEXP=2. # Selecting a particular pseudo-random representation ISEED=-13 # Representations of individual random media # Figure 2 CTYPE='D' POWERN=-0.2 ACORG=0.005 ACOR=0.020 GRD='corf02.out' grdran2d: # Figure 3 CTYPE='D' POWERN=-1.0 ACORG=0.005 ACOR= # CTYPE='L' POWERN=-1.0 ACORG=0.005 # alternative data # CTYPE='G' ACORG=0.005 # alternative data GRD='corf03.out' grdran2d: # Figure 4 CTYPE='D' POWERN=-0.2 ACORG=0. ACOR=0.020 # CTYPE='K' POWERN=-0.2 ACOR=0.020 # alternative data GRD='corf04.out' grdran2d: # Figure 5 CTYPE='D' POWERN=0.5 ACORG=0. ACOR=0.020 # CTYPE='K' POWERN=0.5 ACOR=0.020 # alternative data # CTYPE='E' ACOR=0.020 # alternative data GRD='corf05.out' grdran2d: # Figure 6 CTYPE='D' POWERN=0.0 ACORG=0. ACOR=0.020 # CTYPE='K' POWERN=0.0 ACOR=0.020 # alternative data GRD='corf06.out' grdran2d: # Figure 7 CTYPE='D' POWERN=-0.2 ACORG=0. ACOR= # CTYPE='K' POWERN=-0.2 ACOR= # alternative data # CTYPE='L' POWERN=-0.2 ACORG=0. # alternative data # CTYPE='S' POWERN=-0.2 # alternative data GRD='corf07.out' grdran2d: # Figure 8 CTYPE='D' POWERN=-0.2 ACORG=0.005 ACOR= # CTYPE='L' POWERN=-0.2 ACORG=0.005 # alternative data GRD='corf08.out' grdran2d: # Plotting the representations of the random medium HSIZE=16.032 HOFFSET=2.484 VCIRC=2. VREF=1.000 CREF=.166667 GRD='corf02.out' PS='corf02.ps' grdps: GRD='corf03.out' PS='corf03.ps' grdps: GRD='corf04.out' PS='corf04.ps' grdps: GRD='corf05.out' PS='corf05.ps' grdps: GRD='corf06.out' PS='corf06.ps' grdps: GRD='corf07.out' PS='corf07.ps' grdps: GRD='corf08.out' PS='corf08.ps' grdps: # ====================================================================== # Temporary files (may be deleted) # '*.tmp' # List of output PostScript figures # 'corf02.ps', 'corf03.ps', ..., 'corf08.ps' cremove.for 0100666 0000765 0000765 00000006460 06600637412 012613 0 ustar bulant bulant C
C Program 'CREMOVE' to remove comment lines from a Fortran code. C C Version: 5.20 C Date: 1997, October 11 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 C Main input data file read from the * external unit: C One line containing character strings, read by means of the list C directed input (free format): C (1) 'FOLD','FNEW','FC',/ C 'FOLD'..Name of the input Fortran file. C 'FNEW'..Name of the output Fortran file without comment lines. C 'FC'... Name of the output Fortran file with comment lines only. C /... An obligatory slash for the sake of compatibility with C future extensions. C Default: 'FOLD'=' ', 'FNEW'=' ', 'FC'=' '. C C----------------------------------------------------------------------- C CHARACTER*80 FOLD,FNEW,FC CHARACTER*72 LINE INTEGER ILINE,IERR,I,J,K C WRITE(*,'(2A)') '+Enter 1 input and 1 or 2 output filenames: ' FOLD=' ' FNEW=' ' FC =' ' READ(*,*) FOLD,FNEW,FC C C Opening the input and output FORTRAN77 source code files: WRITE(*,'(2A)') '+Opening old (input) and new (output) files.', * ' ' OPEN(1,FILE=FOLD,STATUS='OLD',IOSTAT=IERR) IF(IERR.NE.0) THEN C CREMOVE-01 CALL ERROR('CREMOVE-01: Input file does not exist') C Input FORTRAN77 source file does not exist. END IF OPEN(2,FILE=FNEW) IF(FC.NE.' ') THEN OPEN(3,FILE=FC) END IF C C Loop for the lines in the input source file WRITE(*,'(2A)') '+Editting ',FNEW(1:70) ILINE=0 20 CONTINUE C C Reading a line: ILINE=ILINE+1 READ(1,'(A)',END=90) LINE C C Copying a line: DO 33 K=72,12,-12 IF(LINE(K-11:K).NE.' ') THEN DO 32 J=K,K-9,-3 IF(LINE(J-2:J).NE.' ') THEN DO 31 I=J,J-2,-1 IF(LINE(I:I).NE.' ') THEN IF(LINE(1:1).EQ.'C'.OR.LINE(1:1).EQ.'c') THEN IF(FC.NE.' ') THEN WRITE(3,'(A)') LINE(1:I) END IF ELSE WRITE(2,'(A)') LINE(1:I) END IF GO TO 20 END IF 31 CONTINUE END IF 32 CONTINUE END IF 33 CONTINUE C Empty line: WRITE(*,'(A,I5,2A)') * '+Warning: Empty line',ILINE,' in ',FOLD(1:56) WRITE(*,'(A)') ' ' C GO TO 20 C End of loop for the lines in the input source file C 90 CONTINUE WRITE(*,'(2A)') '+Done: ',FNEW(1:70) STOP END C C======================================================================= C INCLUDE 'error.for' C error.for C C======================================================================= Cdel.pl 0100666 0000765 0000765 00000000767 07665047200 011552 0 ustar bulant bulant #!perl #
# # Perl script 'del.pl' to delete a file specified by $ARGV[0] (first # command-line argument). # ====================================================================== # Main program 'del.pl': # ~~~~~~~~~~~~~~~~~~~~~~ $FILE=$ARGV[0]; @ARGV=(); require 'go.pl'; &DEL($FILE); # ====================================================================== 1; #div.cal 0100666 0000765 0000765 00000000011 06311435260 011664 0 ustar bulant bulant $3=$1/$2 dmgm.for 0100666 0000765 0000765 00000014150 07303642010 012061 0 ustar bulant bulant C
C Program DMGM to compute product GM2=DM1*GM1 of diagonal matrix DM1 C and general matrix GM1. C C Version: 5.50 C Date: 2000, October 20 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows and columns of matrix DM1 C and rows of matrices GM1 and GM2. C Default: M1=' ' means that the number is 1. C M2='string'... Name of the file containing a single integer number C specifying the number of columns of matrices GM1 and GM2. C Default: M2=' ' means that the number is 1. C Filenames of the files with the matrices: C DM1='string' ... Name of the file containing matrix DM1 (input). C No default, 'DM1' must be specified and cannot be blank. C GM1='string' ... Name of the file containing matrix GM1 (input). C No default, 'GM1' must be specified and cannot be blank. C GM2='string' ... Name of the file containing matrix GM2 (output). C No default, 'GM2' must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3 INTEGER M1,M2,M1M2,LU1 PARAMETER (LU1=1) C----------------------------------------------------------------------- C C Reading in a name of the file with the input data: WRITE(*,'(A)') '+DMGM: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C DMGM-01 CALL ERROR('DMGM-01: SEP file not given') ENDIF C C Reading the dimensions of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF CALL RSEP3T('M2',FILE1,' ') IF (FILE1.EQ.' ') THEN M2=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M2 CLOSE(LU1) ENDIF M1M2=M1*M2 C IF (M1+M1M2.GT.MRAM) THEN C DMGM-02 CALL ERROR('DMGM-02: Small dimension MRAM of array RAM') END IF C C Reading in the names of the files with the matrices: CALL RSEP3T('DM1',FILE1,' ') IF (FILE1.EQ.' ') THEN C DMGM-03 CALL ERROR('DMGM-03: Input file with matrix DM1 not given.') ENDIF CALL RSEP3T('GM1',FILE2,' ') IF (FILE2.EQ.' ') THEN C DMGM-04 CALL ERROR('DMGM-04: Input file with matrix GM1 not given.') ENDIF CALL RSEP3T('GM2',FILE3,' ') IF (FILE3.EQ.' ') THEN C DMGM-05 CALL ERROR('DMGM-05: Output file with matrix GM2 not given.') ENDIF C C Reading input matrices: CALL RMAT(LU1,FILE1,M1,1,RAM) CALL RMAT(LU1,FILE2,M1,M2,RAM(M1+1)) C WRITE(*,'(A)') '+DMGM: Working... ' C C Multiplication: DO 12 I1=1,M1 AUX=RAM(I1) DO 11 I2=M1+I1,M1+M1*M2,M1 RAM(I2)=AUX*RAM(I2) 11 CONTINUE 12 CONTINUE C C Writing output matrix: IF (FILE3.NE.' ') THEN CALL WMAT(LU1,FILE3,M1,M2,RAM(M1+1)) ENDIF WRITE(*,'(A)') '+DMGM: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cdo-test.for 0100666 0000765 0000765 00000001154 06727646556 012550 0 ustar bulant bulant C
C Program to test compilation of DO loops C C Please, run this test program and compare its results with the ANSI C Fortran 77 standard. If you do not get C 1 C 2 C 3 C 4 4 C update your compiler. C C======================================================================= C I=3 DO 1 I=1,I WRITE(*,*) I 1 CONTINUE WRITE(*,*) I,I STOP END C C======================================================================= Cecho.pl 0100666 0000765 0000765 00000001241 07114401324 011676 0 ustar bulant bulant #!perl #
# # Perl script 'echo.pl' to copy the first command-line argument to the # file specified by the second command-line argument. # # Syntax: # echo.pl "text" ">file" # echo.pl "text" ">>file" # Note that there no space may precede ">". # # ====================================================================== # Main program 'echo.pl': # ~~~~~~~~~~~~~~~~~~~~~~~ $DATA=$ARGV[0]; $FILE=$ARGV[1]; @ARGV=(); require 'go.pl'; &ECHO($FILE,$DATA); # ====================================================================== 1; #eigen.for 0100666 0000765 0000765 00000012173 05306022060 012225 0 ustar bulant bulant C SUBROUTINE 'EIGEN' FROM THE IBM SCIENTIFIC SUBROUTINE PACKAGE. C C NOTE: TO CONFORM WITH THE FORTRAN77 STANDARD, DUMMY ARRAY DIMENSIONS C (1) HAVE BEEN CHANGED TO (*). C C .................................................................. C C SUBROUTINE EIGEN C C PURPOSE C COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC C MATRIX C C USAGE C CALL EIGEN(A,R,N,MV) C C DESCRIPTION OF PARAMETERS C A - ORIGINAL MATRIX (SYMMETRIC), DESTROYED IN COMPUTATION. C RESULTANT EIGENVALUES ARE DEVELOPED IN DIAGONAL OF C MATRIX A IN DESCENDING ORDER. C R - RESULTANT MATRIX OF EIGENVECTORS (STORED COLUMNWISE, C IN SAME SEQUENCE AS EIGENVALUES) C N - ORDER OF MATRICES A AND R C MV- INPUT CODE C 0 COMPUTE EIGENVALUES AND EIGENVECTORS C 1 COMPUTE EIGENVALUES ONLY (R NEED NOT BE C DIMENSIONED BUT MUST STILL APPEAR IN CALLING C SEQUENCE) C C REMARKS C ORIGINAL MATRIX A MUST BE REAL SYMMETRIC (STORAGE MODE=1) C MATRIX A CANNOT BE IN THE SAME LOCATION AS MATRIX R C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIAGONALIZATION METHOD ORIGINATED BY JACOBI AND ADAPTED C BY VON NEUMANN FOR LARGE COMPUTERS AS FOUND IN 'MATHEMATICAL C METHODS FOR DIGITAL COMPUTERS', EDITED BY A. RALSTON AND C H.S. WILF, JOHN WILEY AND SONS, NEW YORK, 1962, CHAPTER 7 C C .................................................................. C SUBROUTINE EIGEN(A,R,N,MV) DIMENSION A(*),R(*) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION A,R,ANORM,ANRMX,THR,X,Y,SINX,SINX2,COSX, C 1 COSX2,SINCS,RANGE C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENTS C 40, 68, 75, AND 78 MUST BE CHANGED TO DSQRT. ABS IN STATEMENT C 62 MUST BE CHANGED TO DABS. THE CONSTANT IN STATEMENT 5 SHOULD C BE CHANGED TO 1.0D-12. C C ............................................................... C C GENERATE IDENTITY MATRIX C 5 RANGE=1.0E-6 IF(MV-1) 10,25,10 10 IQ=-N DO 20 J=1,N IQ=IQ+N DO 20 I=1,N IJ=IQ+I R(IJ)=0.0 IF(I-J) 20,15,20 15 R(IJ)=1.0 20 CONTINUE C C COMPUTE INITIAL AND FINAL NORMS (ANORM AND ANORMX) C 25 ANORM=0.0 DO 35 I=1,N DO 35 J=I,N IF(I-J) 30,35,30 30 IA=I+(J*J-J)/2 ANORM=ANORM+A(IA)*A(IA) 35 CONTINUE IF(ANORM) 165,165,40 40 ANORM=1.414*SQRT(ANORM) ANRMX=ANORM*RANGE/FLOAT(N) C C INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR C IND=0 THR=ANORM 45 THR=THR/FLOAT(N) 50 L=1 55 M=L+1 C C COMPUTE SIN AND COS C 60 MQ=(M*M-M)/2 LQ=(L*L-L)/2 LM=L+MQ 62 IF( ABS(A(LM))-THR) 130,65,65 65 IND=1 LL=L+LQ MM=M+MQ X=0.5*(A(LL)-A(MM)) 68 Y=-A(LM)/ SQRT(A(LM)*A(LM)+X*X) IF(X) 70,75,75 70 Y=-Y 75 SINX=Y/ SQRT(2.0*(1.0+( SQRT(1.0-Y*Y)))) SINX2=SINX*SINX 78 COSX= SQRT(1.0-SINX2) COSX2=COSX*COSX SINCS =SINX*COSX C C ROTATE L AND M COLUMNS C ILQ=N*(L-1) IMQ=N*(M-1) DO 125 I=1,N IQ=(I*I-I)/2 IF(I-L) 80,115,80 80 IF(I-M) 85,115,90 85 IM=I+MQ GO TO 95 90 IM=M+IQ 95 IF(I-L) 100,105,105 100 IL=I+LQ GO TO 110 105 IL=L+IQ 110 X=A(IL)*COSX-A(IM)*SINX A(IM)=A(IL)*SINX+A(IM)*COSX A(IL)=X 115 IF(MV-1) 120,125,120 120 ILR=ILQ+I IMR=IMQ+I X=R(ILR)*COSX-R(IMR)*SINX R(IMR)=R(ILR)*SINX+R(IMR)*COSX R(ILR)=X 125 CONTINUE X=2.0*A(LM)*SINCS Y=A(LL)*COSX2+A(MM)*SINX2-X X=A(LL)*SINX2+A(MM)*COSX2+X A(LM)=(A(LL)-A(MM))*SINCS+A(LM)*(COSX2-SINX2) A(LL)=Y A(MM)=X C C TESTS FOR COMPLETION C C TEST FOR M = LAST COLUMN C 130 IF(M-N) 135,140,135 135 M=M+1 GO TO 60 C C TEST FOR L = SECOND FROM LAST COLUMN C 140 IF(L-(N-1)) 145,150,145 145 L=L+1 GO TO 55 150 IF(IND-1) 160,155,160 155 IND=0 GO TO 50 C C COMPARE THRESHOLD WITH FINAL NORM C 160 IF(THR-ANRMX) 165,165,45 C C SORT EIGENVALUES AND EIGENVECTORS C 165 IQ=-N DO 185 I=1,N IQ=IQ+N LL=I+(I*I-I)/2 JQ=N*(I-2) DO 185 J=I,N JQ=JQ+N MM=J+(J*J-J)/2 IF(A(LL)-A(MM)) 170,185,185 170 X=A(LL) A(LL)=A(MM) A(MM)=X IF(MV-1) 175,185,175 175 DO 180 K=1,N ILR=IQ+K IMR=JQ+K X=R(ILR) R(ILR)=R(IMR) 180 R(IMR)=X 185 CONTINUE RETURN END C C======================================================================= C eigennr.for 0100666 0000765 0000765 00000007750 07306620610 012601 0 ustar bulant bulant C
C Subroutine to compute eigenvalues and eigenvectors of a real C symmetric matrix, using subroutines from Numerical Recipes. Form C of the subroutine is the same as the form of subroutine 'EIGEN' C from the IBM Scientific Subroutine Package. C C Version: 5.50 C Date: 2001, June 4 C C Coded by Petr Bulant C bulant@seis.karlov.mff.cuni.cz C C----------------------------------------------------------------------- C Usage: C CALL EIGEN(A,R,N,MV) C C Input: C A ... Original matrix (symmetric), destroyed in computation. C N ... Order of matrices A and R. C MV .. Input code: C 0 ... Compute eigenvalues and eigenvectors. C 1 ... Compute eigenvalues only (currently not possible). C Output: C A ... Eigenvalues of the input matrix are developed in diagonal of C matrix A in descending order. C R ... Resultant matrix of eigenvectors (stored columnwise, C in same sequence as eigenvalues). C C Remarks: C Original matrix A must be real symmetric (storage mode=1). C Matrix A cannot be in the same location as matrix R. C Value of MAXRAM must be set by calling program, MRAM-MAXRAM.GE.2*N. C C----------------------------------------------------------------------- SUBROUTINE EIGEN(A,R,N,MV) INTEGER N,MV REAL A(N*(N+1)/2+1),R(N,N) C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C REAL WORK(MRAM) INTEGER I1,I2,I3,INDX(MRAM) EQUIVALENCE (WORK,RAM) EQUIVALENCE (INDX,IRAM) C Subroutines and external functions required: EXTERNAL ERROR,TRED2,TQLI,INDEXX C ERROR ... File error.for. C TRED2 ... File tred2.for. C TQLI ... File tqli.for. C INDEXX ... File indexx.for. C----------------------------------------------------------------------- IF (N.GT.(MRAM-MAXRAM)/2) THEN C EIGENNR-03 CALL ERROR('EIGENNR-03: Small dimension of auxiliary arrays.') C Value of MAXRAM must be set by the calling program, C MRAM-MAXRAM must be greater or equal 2*N. ENDIF C IF (MV.EQ.0) THEN C Computation of eigenvalues and eigenvectors. C C Preparing matrix R: I3=0 DO 12, I1=1,N DO 10, I2=1,I1 I3=I3+1 R(I1,I2)=A(I3) R(I2,I1)=A(I3) 10 CONTINUE 12 CONTINUE C C Preparing a tridiagonal matrix from R: CALL TRED2(R,N,N,A,A(N+1)) C C Computing eigenvalues and eigenvectors of matrix R: CALL TQLI(A,A(N+1),N,N,R) C C Sorting the eigenvalues into descending order: CALL INDEXX(N,A,INDX(MAXRAM+N+1)) C Reorganizing eigenvalues: DO 14, I2=1,N C Store the element to WORK: WORK(MAXRAM+I2)=A(I2) 14 CONTINUE DO 16, I2=1,N C Copy it back in the rearranged order: A(I2)=WORK(MAXRAM+INDX(MAXRAM+N+N+1-I2)) 16 CONTINUE C Reorganizing eigenvectors: C Loop over lines: DO 25, I1=1,N C For each element of the line: DO 18, I2=1,N C Store the element to WORK: WORK(MAXRAM+I2)=R(I1,I2) 18 CONTINUE DO 20, I2=1,N C Copy it back in the rearranged order: R(I1,I2)=WORK(MAXRAM+INDX(MAXRAM+N+N+1-I2)) 20 CONTINUE 25 CONTINUE C C Writing eigenvalues to the diagonal of A: DO 27, I1=N,2,-1 A((I1*(I1+1))/2)=A(I1) 27 CONTINUE ELSEIF (MV.EQ.1) THEN C Computation of eigenvalues only. C EIGENNR-01 CALL ERROR('EIGENNR-01: MV=1 currently not supported.') ELSE C EIGENNR-02 CALL ERROR('EIGENNR-02: Wrong value of MV.') ENDIF RETURN END eq.cal 0100666 0000765 0000765 00000000114 07034033072 011511 0 ustar bulant bulant DIF=$1-$2 DIF=ABS(DIF) DIF=999999*DIF DIF=MIN(DIF,1) DIF=1-DIF $3=NINT(DIF) error.for 0100666 0000765 0000765 00000017040 07047455330 012303 0 ustar bulant bulant CC Subroutines to handle error and warning messages C C Version: 5.40 C Date: 2000, February 7 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 Output error file: C C The output error file has fixed name 'error.out'. It is assumed to be C deleted before running the job, e.g., using Perl script 'go.pl'. C When an error or warning message is issued, the message is appended to C the error file, starting with string '##Error' or '##Warning', C respectively. Error file 'error.out' should be checked for string C '##Error' before running the next program of the job. C C....................................................................... C C This file consists of: C ERROR...Subroutine to handle the error conditions indicated within C the Fortran code. It writes a brief error message and C STOPs the program. A user is encouraged to modify this C routine to redirect the error message or to STOP the C program in a different way. C ERROR C WARN... Subroutine to handle the warning messages indicated within C the Fortran code. It writes a brief error message and C PAUSEs the program. A user is encouraged to modify this C routine to redirect the warning message or to change the C PAUSE statement. C WARN C LUWARN..Integer external function to remember the logical unit C number of the output file to write the warning messages. C LUWARN C C======================================================================= C C C SUBROUTINE ERROR(TEXT) CHARACTER*(*) TEXT C C Subroutine to handle the error conditions indicated within the Fortran C code. It writes a brief error message and STOPs the program. C A user is encouraged to modify this routine to redirect the error C message or to STOP the program in a different way. C C Input: C TEXT... A brief text identifying the error. C Example: 'PRG-04: Too small array AAA', where PRG-04 C identifies the corresponding error in program PRG. C Subroutine ERROR prepends string '##Error ' to TEXT C when writing to a file, and string ' Error ' when C writing to the standard output device *. C No output. C C Date: 1999, May 24 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C EXTERNAL LUWARN INTEGER LUWARN,LUERR PARAMETER (LUERR=88) C C....................................................................... C C The error message is appended to error file 'error.out': OPEN(LUERR,FILE='error.out') 10 CONTINUE READ(LUERR,'(A)',END=11) GO TO 10 11 CONTINUE WRITE(LUERR,'(2A)') '##Error ',TEXT CLOSE(LUERR) C C If a formatted output log file is open, a copy of the error C message is written there: IF (LUWARN(0).GT.0) THEN WRITE(LUWARN(0),'(2A)') '##Error ',TEXT END IF C C The error message is written to the standard output: WRITE(*,'(2A)') ' Error ',TEXT C C PAUSE command may enable to terminate batch files or scripts on C some systems: * PAUSE C C Finally, the program must be STOPped: STOP END C C======================================================================= C C C SUBROUTINE WARN(TEXT) CHARACTER*(*) TEXT C C Subroutine to handle the error conditions indicated within the Fortran C code. It writes a brief error message and STOPs the program. C A user is encouraged to modify this routine to redirect the error C message or to STOP the program in a different way. C Subroutine to handle the warning messages indicated within the Fortran C code. It writes a brief error message and PAUSEs the program. C A user is encouraged to modify this routine to redirect the warning C message or to change the PAUSE statement. C C Input: C TEXT... A brief text identifying the warning. C Example: 'PRG-05: No header section found', where PRG-05 C identifies the corresponding warning in program PRG. C Subroutine WARN prepends string '##Warning ' to TEXT C when writing to a file, and string ' Warning ' when C writing to the standard output device *. C No output. C C Date: 1999, May 27 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C EXTERNAL LUWARN INTEGER LUWARN,LUERR PARAMETER (LUERR=88) C C The warning message is appended to error file 'error.out': OPEN(LUERR,FILE='error.out') 10 CONTINUE READ(LUERR,'(A)',END=11) GO TO 10 11 CONTINUE WRITE(LUERR,'(2A)') '##Warning ',TEXT CLOSE(LUERR) C C If a formatted output log file is open, a copy of the warning C message is written there: IF (LUWARN(0).GT.0) THEN WRITE(LUWARN(0),'(2A)') '##Warning ',TEXT END IF C C The warning message is written to the standard output: WRITE(*,'(2A)') '+Warning ',TEXT WRITE(*,'(2A)') C C PAUSE command to suspend the execution: * PAUSE C RETURN END C C======================================================================= C C C INTEGER FUNCTION LUWARN(LU) INTEGER LU C C Function to remember the logical unit number of the output file to C write the warning, error and other messages to output log file, C if it is defined. C C Input: C LU... LU positive: C LUWARN is redefined to LU. LU should represent the C logical unit number of the formatted output log file to C write the messages. Function LUWARN with such a value C of LU should be called after opening the output log file C which is usually performed from the main program. C Otherwise: C LUWARN is the last redefined value. LUWARN=0 when C starting the program. C Output: C LUWARN..Logical unit number of the output log file to write the C warning messages. C LUWARN positive: formatted output log file is ready, C LUWARN=0: output log file is not available. C C Example: C First invocation: C OPEN(LULOG,FILE=FLOG) C LULOG=LUWARN(LULOG) C Next invocations: C IF (LUWARN(0).GT.0) THEN C WRITE(LUWARN(0),'(2A)') ' Error ',TEXT C END IF C C Note: C For consistency, it is recommended that an error message starts C with string '##Error ' at the begining of the first written line C immediately followed by the string identifying the error, and C a warning message starts with string '##Warning'. The strings C enable to detect the error and to terminate execution of the C corresponding script or history file. C Numbered warnings should be listed in the list of errors. C C Date: 1997, November 22 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C INTEGER LUSTOR SAVE LUSTOR DATA LUSTOR/0/ C IF(LU.GT.0) THEN LUSTOR=LU END IF LUWARN=LUSTOR RETURN END C C======================================================================= C fforms.pl 0100666 0000765 0000765 00000004253 07662341200 012266 0 ustar bulant bulant #!perl ## # Perl script to compile package FORMS by means of Perl script 'f.pl' # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @OPTIONS=@ARGV; @ARGV=(); require 'f.pl'; # &COMPILE('iniwrl' ,@OPTIONS); &COMPILE('ptswrl' ,@OPTIONS); &COMPILE('linwrl' ,@OPTIONS); &COMPILE('srfwrl' ,@OPTIONS); &COMPILE('grdwrl' ,@OPTIONS); &COMPILE('plgn' ,@OPTIONS); &COMPILE('trgl' ,@OPTIONS); &COMPILE('trglsort',@OPTIONS); &COMPILE('trglnorm',@OPTIONS); &COMPILE('trglps' ,@OPTIONS); &COMPILE('tsurf' ,@OPTIONS); &COMPILE('pictures',@OPTIONS); &COMPILE('pallet' ,@OPTIONS); &COMPILE('ss' ,@OPTIONS); &COMPILE('sp' ,@OPTIONS); &COMPILE('srp' ,@OPTIONS); &COMPILE('linden' ,@OPTIONS); &COMPILE('grdpts' ,@OPTIONS); &COMPILE('mgrd' ,@OPTIONS); &COMPILE('grdtrans',@OPTIONS); &COMPILE('grdnew' ,@OPTIONS); &COMPILE('grdmerge',@OPTIONS); &COMPILE('grdcal' ,@OPTIONS); &COMPILE('grdnorm' ,@OPTIONS); &COMPILE('grdfft' ,@OPTIONS); &COMPILE('grdfd' ,@OPTIONS); &COMPILE('grd2d3d' ,@OPTIONS); &COMPILE('grdiso' ,@OPTIONS); &COMPILE('grdran2d',@OPTIONS); &COMPILE('grdran' ,@OPTIONS); &COMPILE('grdcor' ,@OPTIONS); &COMPILE('grdstat' ,@OPTIONS); &COMPILE('grdckn' ,@OPTIONS); &COMPILE('grdte' ,@OPTIONS); &COMPILE('binasc' ,@OPTIONS); &COMPILE('ascbin' ,@OPTIONS); &COMPILE('swap' ,@OPTIONS); &COMPILE('ptsgrd' ,@OPTIONS); &COMPILE('grdps' ,@OPTIONS); &COMPILE('gmt' ,@OPTIONS); &COMPILE('gmgm' ,@OPTIONS); &COMPILE('smgm' ,@OPTIONS); &COMPILE('dmgm' ,@OPTIONS); &COMPILE('smsm' ,@OPTIONS); # &COMPILE('dmsm' ,@OPTIONS); # &COMPILE('gmsmgmt' ,@OPTIONS); &COMPILE('smsmsm' ,@OPTIONS); &COMPILE('gmdmgmt' ,@OPTIONS); # &COMPILE('smdmsm' ,@OPTIONS); # &COMPILE('dmsmdm' ,@OPTIONS); &COMPILE('sminv' ,@OPTIONS); &COMPILE('smpower' ,@OPTIONS); &COMPILE('smeigen' ,@OPTIONS); &COMPILE('trsmsm' ,@OPTIONS); &COMPILE('rtcoef' ,@OPTIONS); &COMPILE('cremove' ,@OPTIONS); &COMPILE('do-test' ,@OPTIONS); 1; #formsdat.htm 0100666 0000765 0000765 00000051726 07215065410 012775 0 ustar bulant bulantformserr.htm 0100666 0000765 0000765 00000044247 07435105304 013016 0 ustar bulant bulantGeneral forms of data files with Lines and Points, related to 3-D seismic modelling.
By Ludek Klimes, Ivan Psencik The data files are designed to simplify the data exchange between various programs, especially for the purposes of plotting. The data files are assumed to be formatted, sequential files, readable by list-directed input (free format). Thus the items like numbers or strings should be separated by the separators like spaces or commas, and all strings should be enclosed in apostrophes. Null values may be used in place of default values where the default values are defined. In the descriptions of input data below, each low-level numbered paragraph indicates the beginning of a new input operation (new read statement). 'ITEMS' in the list of input variables enclosed in apostrophes represent CHARACTER strings enclosed in apostrophes. Otherwise, if the first letter of the symbolic name in the list of input variables is I-N, the corresponding value in input data is INTEGER, otherwise, the input parameter is of the type REAL. / in the list of input variables indicates an obligatory slash. The slash may also be used instead of default values. The slash at the end the last line of each input is obligatory because is intended for the compatibility with various extensions of the file forms. ...................................................................... File form LINES (or briefly LIN): The file structure is designed to store the lines situated in 3-D (and also 2-D) space. These lines may represent the intersections of interfaces with given 2-D sections, velocity isolines, rays, rivers, contours of lands, lakes, or cities, coordinate lines and grids, diagrams of functions of one variable (e.g. travel-time curves), isolines of functions of two variables, axes, scales and other parts of figures, etc. Each line starts with a string that may contain the name or description of the line. The string may be supplemented with the coordinates of the reference point which may, e.g., control the eventual plotting of some part of the string. Then the points of the line follow. Since the lines of zero length are allowed, this data structure may also be used to store the discrete points, but each point should be followed by the row containing slash. That is why also the special file form 'Points' has also been proposed, see the next file form below. File structure: The file consists of its header (1), lines (2), and the end-of-data identification (3). (1) Texts - one to several lines read by a single read statement: None to several strings terminated by / (a slash). It is not recommended to write too many strings (e.g. more than 20) into this file section. On the other hand, the program reading the file should read at least 20 strings, by the single read statement. A blank string followed by a non-blank one is allowed but not recommended. The strings may be used as the notes about the data or file origin, nature, version, etc., and need not be taken into account by the reading program. On the other hand, if the reading program is able to identify within the strings some kind of information written according rules specific to the program, the strings may be used to transfer various kinds of information between the specific pairs of applications. Default for all strings: ' ' (a blank string). First example: 'String1' . . . 'StringM' / Second example: / Third example: 'String1' 'String2' 'String4' 'String5' / Fourth example: 'String1' 'String2' / (2) For each line the triplet of subsections (2.1), (2.2) and (2.3): General example (one line): (2.1) 'Text' X1 X2 X3 / (2.2) X1(1) X2(1) X3(1) / X1(2) X2(2) X3(2) / . . X1(N) X2(N) X3(N) / (2.3) / (2.1) Reference text and optional reference point (single READ statement) - one of the following possibilities (a) and (b): (a) 'TEXT',X1,X2,X3,/ (b) 'TEXT',/ 'TEXT'... Arbitrary text related to the line. The string may contain the name or description of the line. It may be used as the notes about the line, but often contains some information transferred between the specific pairs of programs, encodded according to the rules specific to the programs. Especially, the string is assumed to be used at selecting only some lines for plotting according to the given selection keywords or textual masks, or to enable plotting the lines with different attributes (colour, line width, line type, etc.) according to fitting the text by the given selection masks. A selected part of the string (according to another keyword or mask) may also be drawn as the text describing the line. Also the numerical information concerning the line (e.g. the isovalue of the isoline) may be contained within the string and identified by a keyword. The string may be blank but the default must not be used, because the default identifies the end of data. The default value in the reading program should be selected in such a way that it should not match any string describing a line. For instance, the string composed of several '$' characters may be a reasonable default (e.g. '$$$$'). Thus it is not recommended to use the '$' character within the strings identifying lines. Examples of strings generated by some programs: (since:) 'SECT 12, SURF 2' (sec, v.4.10) 'SECT 12, BLOC 3, ISOL 8, VP = 5.000' (sec, v.4.10) 'SECT 12, BLOC 3, ISOL 4, VS = 3.000' (sec, v.4.10) 'REC 13' (crtray, v.4.17) 'RecNam' (crtray, v.4.17) 'SrcNam TO RecNam' (crtray, v.4.17) 'RAY 112' (crtray, v.4.17) 'RAY 112, REC 13' (crtray, v.4.17) 'RAY 112 TO RecNam' (crtray, v.4.17) 'RAY 112 FROM SrcNam' (crtray, v.4.17) 'RAY 112 FROM SrcNam TO RecNam' (crtray, v.4.17) 'WAVE 1, RAY 112' (crtray, v.4.10) 'WAVE 1, RAY 112, REC 13' (crtray, v.4.17) 'WAVE 1, RAY 112 TO RecNam' (crtray, v.4.17) 'WAVE 1, RAY 112 FROM SrcNam' (crtray, v.4.17) 'WAVE 1, RAY 112 FROM SrcNam TO RecNam'(crtray, v.4.17) 'RAY 112' (net, v.2.00) 'RAY 112 TO RecNam' (net, v.2.00) 'RAY 112 FROM SrcNam' (net, v.2.00) 'RAY 112 FROM SrcNam TO RecNam' (net, v.2.00) Here 'SrcNam' is the name of the source point at which the ray starts and 'RecNam' is the name of the receiver at which the ray terminates (names up to 6 characters long are preferable). X1,X2,X3... Coordinates of the reference point where the text can be drawn. In 2-D, the third coordinate X3 need not be specified, and its default value should always be 0. It is also recommended to use zero default for X2 in all programs reading the data. The reference point need not be specified. A missing reference point may be identified by the reading program according to the default of X1 equal to a value unlike to appear within the the input data, e.g. -999999. Missing coordinates of the reference point may also be used to switch between drawing and dropping the texts describing the lines. A program may draw all texts, draw only texts with the reference point given, or draw no texts. If the reference point is missing, the first point of the line should be used as the reference point if the text is still to be drawn. If the reference point is missing and the line has no point, 0,0,0 should be used as the reference point if the text is still to be drawn. (2.2) Points of the line - for each point of the line (2.2.1): Any number of points may be specified, including none. (2.2.1) Coordinates of the I-th point of the line: X1(I),X2(I),X3(I),/ X1(I),X2(I),X3(I)... Coordinates of the I-th point of the line. In 2-D, the third coordinate X3(I) need not be specified, and its default value should always be 0. It is also recommended to use zero default for X2 in all programs reading the data. The end of the line is identified by the reading program according to the default of X1(I) equal to a value unlike to appear within the input data, e.g., -999999. Thus, such a value should be avoided in the data. Possible extensions: In place of the terminating slash, several additional numbers terminated by a slash may be written. The meaning of this numbers is specific to the applications. Example: Possible extensions (a) or (b) for rays: (a) X1(I),X2(I),X3(I),TT(I)/ (b) X1(I),X2(I),X3(I),TT(I),P1(I),P2(I),P3(I),/ TT(I)... Travel time at the point. P1(I),P2(I),P3(I)... Slowness vector components at the point. (2.3) / (a slash). (3) / (a slash) or end of file. Example file diagram: (1) 'TEXT1' 'TEXT2' 'TEXT3' / (2) 'LINE 1' 0.000 0.000 0.000 / 0.000 0.000 0.000 / 1.000 1.000 1.000 / 2.000 2.000 2.000 / / 'LINE 1' / 2.000 2.000 2.000 / 3.000 3.000 3.000 / / 'LINE 2' 0.000 1.500 0.000 / 0.000 1.500 0.000 / 3.000 1.500 0.000 / / (3) / or: (1) 'TEXT1' 'TEXT2' 'TEXT3' / (2) 'LINE 1' 0.000 0.000 0.000 / 0.000 0.000 0.000 / 1.000 1.000 1.000 / 2.000 2.000 2.000 / / 'LINE 1' / 2.000 2.000 2.000 / 3.000 3.000 3.000 / / 'LINE 2' 0.000 1.500 0.000 / 0.000 1.500 0.000 / 3.000 1.500 0.000 / / (3) / ...................................................................... File form POINTS (or briefly PTS): The file structure is designed to store the points situated in 3-D (and also 2-D) space. These points may represent seismic sources, receivers, endpoints of calculated rays, gridded earth surface or structural interfaces, map points like mountains, the dependence of measured data on one or two variables, take-off parameters of rays, descriptions of figures and objects displayed, descriptions of coordinate axes, etc. Each point has its name (generally the string that may contain the name or description of the point), and three coordinates. The file form is derived from file form 'Lines', described above, identifying points with lines of zero lengths (having no points except the reference one) and dropping the rows with the line-terminal slashes. File structure: The file consists of its header (1), points (2), and the end-of-data identification (3). (1) Texts - one to several lines read by a single read statement: None to several strings terminated by / (a slash). It is not recommended to write too many strings (e.g. more than 20) into this file section. On the other hand, the program reading the file should read at least 20 strings, by the single read statement. A blank string followed by a non-blank one is allowed but not recommended. The strings may be used as the notes about the data or file origin, nature, version, etc., and need not be taken into account by the reading program. On the other hand, if the reading program is able to identify within the strings some kind of information written according rules specific to the program, the strings may be used to transfer various kinds of information between the specific pairs of applications. Default for all strings: ' ' (a blank string). First example: 'String1' . . . 'StringM' / Second example: / Third example: 'String1' 'String2' 'String4' 'String5' / Fourth example: 'String1' 'String2' / (2) For each point (2.1): (2.1) 'TEXT',X1,X2,X3,/ 'TEXT'... Arbitrary text related to the point. The string is usually considered to be the name of the point. It may be used as the notes about the point, but often contains some information transferred between the specific pairs of programs, encodded according to rules specific to the programs. Especially, the string is assumed to be used at selecting only some points for plotting according to the given selection keywords or textual masks, or to enable plotting the points with different attributes (colour, marker type, etc.) according to fitting the text by the given selection masks. A selected part of the string (according to another keyword or mask) may also be drawn as the text describing the point. The string may be blank but the default must not be used, because the default identifies the end of data. The default value in the reading program should be selected in such a way that it should not match any string describing a point. For instance, the string composed of several '$' characters may be a reasonable default (e.g. '$$$$'). Thus it is not recommended to use the '$' character within the strings identifying the points. Examples of strings generated by some programs: (since:) 'RecNam' (net, v.2.00) 'REC 13' (crtpts, v.4.17) 'RecNam' (crtpts, v.4.17) 'RAY 112' (crtpts, v.4.17) 'RAY 112, REC 13' (crtpts, v.4.17) 'RAY 112 TO RecNam' (crtpts, v.4.17) 'RAY 112 FROM SrcNam' (crtpts, v.4.17) 'RAY 112 FROM SrcNam TO RecNam' (crtpts, v.4.17) 'WAVE 1, RAY 112' (crtpts, v.4.17) 'WAVE 1, RAY 112, REC 13' (crtpts, v.4.17) 'WAVE 1, RAY 112 TO RecNam' (crtpts, v.4.17) 'WAVE 1, RAY 112 FROM SrcNam' (crtpts, v.4.17) 'WAVE 1, RAY 112 FROM SrcNam TO RecNam'(crtpts, v.4.17) Here 'SrcNam' is the name of the source point at which the ray starts and 'RecNam' is the name of the receiver at which the ray terminates (names up to 6 characters long are preferable). X1,X2,X3... Coordinates of the point. In 2-D, the third coordinate X3 need not be specified, and its default value should always be 0. It is also recommended to use zero defaults for X1 and X2 in all programs reading the data. Possible extensions: In place of the point-terminating slash, several additional numbers terminated by a slash may be written. The meaning of these numbers is specific to the applications. These numbers should default to zeros. Example: possible extensions (a) or (b) for source or receiver points: (a) 'TEXT',X1,X2,X3,TT,/ (b) 'TEXT',X1,X2,X3,TT,TTERR,/ TT... Travel time at the point. TTERR...Travel time error at the point. (3) / (a slash) or end of file. Example file diagram: (1) 'VERTICES OF A UNIT CUBE' / (2) 'POINT0' 0.000 0.000 0.000 / 'POINT1' 1.000 0.000 0.000 / 'POINT2' 0.000 1.000 0.000 / 'POINT3' 0.000 0.000 1.000 / 'POINT12' 1.000 1.000 0.000 / 'POINT13' 1.000 0.000 1.000 / 'POINT23' 0.000 1.000 1.000 / 'POINT123' 1.000 1.000 1.000 / (3) / ...................................................................... File form 'Travel Times': The file structure is designed to store field travel times (FTT) or synthetic travel times (STT). Each travel time is denoted by the couple of strings identifying the source and the receiver points. File structure: The file consists of its header (1), travel times (2), and the end-of-data identification (3). (1) Texts - one to several lines read by a single READ statement: None to several strings terminated by / (a slash). It is not recommended to write too many strings (e.g. more than 20) into this file section. On the other hand, the program reading the file should read at least 20 strings, by the single read statement. A blank string followed by a non-blank one is allowed but not recommended. The strings may be used as the notes about the data or file origin, nature, version, etc., and need not be taken into account by the reading program. On the other hand, if the reading program is able to identify within the strings some kind of information written according rules specific to the program, the strings may be used to transfer various kinds of information between the specific pairs of applications. Default for all strings: ' ' (a blank string). First example: 'String1' . . . 'StringM' / Second example: / Third example: 'String1' 'String2' 'String4' 'String5' / Fourth example: 'String1' 'String2' / (2) For each travel time (2.1): (2.1) 'SRC','REC',TT,TTERR,/ 'SRC'...String identifying the source point by its name. The coordinates of the point should be listed in a file of the 'Points' format. 'REC'...String identifying the receiver point by its name. Since travel times are reciprocal, the source and receiver names may eventually be interchanged. TT... Travel time. TTERR...Error (e.g. standard deviation) of the travel time. It may be left out if it is considered negligible (e.g. for very accurate synthetic travel times compared with field travel times). (3) / (a slash) or end of file. Example file diagram: (1) 'FIELD TRAVEL TIMES' / (2) 'SRC-01' 'REC-01' 2.132 0.008 / 'SRC-01' 'REC-02' 2.483 0.004 / 'SRC-02' 'REC-01' 4.246 0.016 / 'SRC-02' 'REC-03' 3.879 0.008 / 'SRC-02' 'REC-04' 4.412 0.024 / 'SRC-03' 'REC-02' 5.060 0.016 / 'SRC-03' 'REC-03' 5.132 0.160 / (3) / ...................................................................... Multi-data file form: The file consists of any number of data sections, identified by an identifier: General data section structure: (1) '$ identifier' - string describing the data structure, beginning with the '$' sign. (2) Data section - data formatted in a form indicated by the section identifier. Specific data section structures: The following couples of string (1) and data (2) may form a section: (1) '$ FILE FORM LINES' (2) Data formatted exactly according to file form 'Lines'. (1) '$ FILE FORM POINTS' (2) Data formatted exactly according to file form 'Points'. (1) '$ DATA FORM TEXTS' (2) Data formatted exactly according to section (1) of file form 'Lines' or 'Points'. (1) '$ DATA FORM LINES' (2) Data formatted exactly according to sections (2) and (3) of file form 'Lines'. (1) '$ DATA FORM POINTS' (2) Data formatted exactly according to sections (2) and (3) of file form 'Points'. End-of-all-data identifier: The data are terminated by the following string (3) or by the end of file: (3) '$ END'FORMS: error messages Package FORMS: List of error messages
C Subroutine file 'forms.for' to facilitate writing and reading data. C C Version: 5.80 C Date: 2004, June 11 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 OMAT... Subroutine designed to set the form of the file for C reading or writing a matrix, and to open the file. C OMAT C WMAT... Subroutine designed to write a given matrix into the given C file. C WMAT C RMAT... Subroutine designed to read a matrix from the given file. C RMAT 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 SUBROUTINE OMAT(LU,FILE,IRW,FORMM) CHARACTER*(*) FILE,FORMM INTEGER LU,IRW C C Subroutine designed to set the form FORMM of the file with matrix C to be read or written, and to open the file, if FILE is specified. 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. C IRW ... Identifies, whether the file will be read or written: C IRW=1 ... reading C IRW=2 ... writing C Output: C FORMM...Form of the file to be read or written. C C Date: 2000, October 20 C Coded by Petr Bulant C E-mail: bulant@seis.karlov.mff.cuni.cz C C----------------------------------------------------------------------- C C Local storage locations: C CHARACTER*13 FORMMR,FORMMW SAVE FORMMR,FORMMW DATA FORMMR/'undefined'/ C C FORMMR ..Form of the files with matrices to be read. C FORMMW ..Form of the files with matrices to be written. C C....................................................................... C IF (FORMMR.EQ.'undefined') THEN C Reading the forms of the files with matrices: CALL RSEP3T('FORMM',FORMM,'formatted') CALL RSEP3T('FORMMR',FORMMR,FORMM) CALL RSEP3T('FORMMW',FORMMW,FORMM) CALL LOWER(FORMM) CALL LOWER(FORMMR) CALL LOWER(FORMMW) IF ((FORMM.NE.'formatted').AND.(FORMM.NE.'unformatted').OR. * (FORMMR.NE.'formatted').AND.(FORMMR.NE.'unformatted').OR. * (FORMMW.NE.'formatted').AND.(FORMMW.NE.'unformatted')) THEN C FORMS-01 CALL ERROR('FORMS-01: Wrong value of FORMM, FORMMR or FORMMW') C Input parameters FORMM, FORMMR and FORMMW, if specified, C must equal either 'formatted' or 'unformatted'. ENDIF ENDIF C C Setting the form FORMM of the file to be opened: IF (IRW.EQ.1) THEN FORMM=FORMMR ELSEIF (IRW.EQ.2) THEN FORMM=FORMMW ELSE C FORMS-02 CALL ERROR('FORMS-02: Wrong value of IRW') C Dumy argument IRW must equal either 1 or 2. ENDIF C IF (FILE.NE.' ') THEN C Opening the file for reading or writing: IF (IRW.EQ.1) THEN WRITE(*,'(2A)') '+Reading: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORMM,STATUS='OLD') ELSEIF (IRW.EQ.2) THEN WRITE(*,'(2A)') '+Writing: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORMM) ENDIF ENDIF C RETURN END C======================================================================= C C C SUBROUTINE WMAT(LU,FILE,M1,M2,OUT) CHARACTER*(*) FILE INTEGER LU,M1,M2 REAL OUT(*) C C Subroutine designed to write a given matrix 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 M1... Number of rows of the given matrix. C M2... M2=0 for a symmetric matrix, C M2=1 for a diagonal matrix, C M2=number of columns for a general matrix. C OUT... Components of the given matrix stored columnwise. C For a symmetric matrix, just components from the first row C to the diagonal are stored for each column, i.e., array C OUT has M1*(M1+1)/2 matrix components. C For a diagonal matrix, just M1 diagonal components are C stored. C C No output. C C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: C CHARACTER*13 FORMAT,FORMM INTEGER I1,I2 C C FORMAT..String containing the output format. C FORMM ..Form of the files with matrices. C I1,I2.. Loop variables. C C....................................................................... C C Setting output format: FORMAT='(5(G13.7,1X))' C C Form of the file with the matrix, opening the file: CALL OMAT(LU,FILE,2,FORMM) C C Writing the matrix: IF(M2.LE.0) THEN C Symmetric matrix IF (FORMM.EQ.'formatted') THEN DO 11 I2=1,M1 WRITE(LU,FORMAT) (OUT(I1),I1=I2*(I2-1)/2+1,I2*(I2+1)/2) 11 CONTINUE ELSE WRITE(LU) (OUT(I1),I1=1,M1*(M1+1)/2) ENDIF ELSE C Diagonal or general matrix IF (FORMM.EQ.'formatted') THEN DO 12 I2=M1,M1*M2,M1 WRITE(LU,FORMAT) (OUT(I1),I1=I2-M1+1,I2) 12 CONTINUE ELSE WRITE(LU) (OUT(I1),I1=1,M1*M2) ENDIF END IF C C Closing output file: IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE RMAT(LU,FILE,M1,M2,ARRAY) CHARACTER*(*) FILE INTEGER LU,M1,M2 REAL ARRAY(*) C C Subroutine designed to read a matrix from the file. C C Input: C LU... Logical unit number to be used for the input. 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 M1... Number of rows of the matrix. C M2... M2=0 for a symmetric matrix, C M2=1 for a diagonal matrix, C M2=number of columns for a general matrix. C C Output: C ARRAY...Components of the given matrix stored columnwise. C For a symmetric matrix, just components from the first row C to the diagonal are stored for each column, i.e., array C out has M1*(M1+1)/2 matrix components. C For a diagonal matrix, just M1 diagonal components are C stored. C C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage location: CHARACTER*13 FORMM INTEGER I C I... Loop variable. C C....................................................................... C C Form of the file with the matrix, opening the file: CALL OMAT(LU,FILE,1,FORMM) C C Reading the matrix: IF(M2.LE.0) THEN C Symmetric matrix IF (FORMM.EQ.'formatted') THEN READ(LU,*) (ARRAY(I),I=1,M1*(M1+1)/2) ELSE READ(LU) (ARRAY(I),I=1,M1*(M1+1)/2) ENDIF ELSE C Diagonal or general matrix IF (FORMM.EQ.'formatted') THEN READ(LU,*) (ARRAY(I),I=1,M1*M2) ELSE READ(LU) (ARRAY(I),I=1,M1*M2) ENDIF END IF C C Closing input file: IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END 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: 2000, November 25 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: REAL UNDEF PARAMETER (UNDEF=-999999999.) 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 Date: 2000, November 25 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 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: 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)=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 Date: 2000, November 25 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 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)=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 attempts to output C at least MAXDIG digits (including all zeros after the C decimal point) of the largest positive number OUTMAX and C MAXDIG-1 digits of the most negative number if OUTMIN is C negative, and to adjust 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 --------------------- INTEGER MAXDIG,MINDIG PARAMETER (MINDIG=4) PARAMETER (MAXDIG=6) C --------------------- C MAXDIG must be less than 10, C MINDIG should be less than MAXDIG. C C Date: 2000, January 8 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER IFORM1,IFORM2 REAL SMALL 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))+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='G00.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='G00.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 ','. The subroutine C attempts to output at least MAXDIG digits (including all C zeros after the decimal point) of the largest positive C number and MAXDIG-1 digits of the most negative number, C and to adjust the width of the output field to MAXDIG+2 C columns including the space after the number, if possible. 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 Date: 1999, August 16 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======================================================================= Cforms.htm 0100666 0000765 0000765 00000110734 10061001274 012266 0 ustar bulant bulant
Package FORMS is designed to facilitate the data exchange between individual programs and to simplify the writing, reading, comparing and plotting the various kinds of data. Package FORMS contains specifications of data forms, subroutines to write and read them, programs to perform simple operations with the data, programs to generate the data of given properties, simple graphics subroutines and programs, etc.
Programming language, error messages, screen output, etc.
Alphabetical list of input parameters of all programs.
Unified error management. The error and warning messages are written to the output error file of fixed name 'error.out'. File 'error.out' is deleted by Perl script 'go.pl' before executing the history file. When an error or warning message is issued, the message is appended to the error file, starting with string '##Error' or '##Warning', respectively. Error file 'error.out' is checked for string '##Error' before running the next program of the history file.
All Fortran 77 source code and include files are assumed
to be located in a single directory when being compiled and linked.
The files with main programs contain, at their ends, Fortran 90
INCLUDE command for all subroutine files required. In this way,
each program may simply be compiled and linked as a single file.
All filenames are assumed to be expressed in lowercase.
Fortran 77 source code files have extension '.for'. The corresponding
files with specifications of the COMMON blocks have extension '.inc'
and are included in the Fortran 77 source code by means of Fortran 90
INCLUDE command.
Compilation and linking:
It is recommended to run the programs from the history files. The history files may contain the information how to execute the programs, the data read from standard input (Fortran) or from the command line (Perl) and the data read from the SEP parameter files.
Data from standard input *:
Main input data of each program are read from the standard input,
and mostly consist of a single line containing filenames and
at most few numerical parameters.
For the description of input data of individual programs refer to
the list of files below.
# # Function @OUT=RARRAY($FILE) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub RARRAY { $FILE=$_[0]; local(@OUT); open(LU,$FILE); # Reading @OUT=formsver.htm 0100666 0000765 0000765 00000045760 10062244274 013023 0 ustar bulant bulant; close(LU) || die "Error"; # Subroutine automatically returns the value of the last expression # evaluated: @OUT=split(' ',join(' ',@OUT)); } #======================================================================= # Subroutine WARRAY($FILE,@OUT) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub WARRAY { $FILE=shift(@_); local(@OUT)=@_; @OUT=join("\n",@OUT); open(LU,$FILE); print LU "@OUT"; close(LU) || die "Error"; } #======================================================================= 1; #
fortran.htm 0100666 0000765 0000765 00000007047 06614011006 012620 0 ustar bulant bulantReleased versions of package FORMS
5.10 (1997, October): 'formsdoc.htm','gse.for','forms.for','length.for', 'srp.for', 'calcomp.for','calcomp.inc','calcops.for', 'calcops.inc', 'pallet.for': Moved from package MODEL. 'calcomp.for','calcops.for': BLOCK DATA subprograms canceled. All error descriptions moved towards the corresponding reporting statements. 'gse.for': *** Considerably revised version. *** *** new *** All Fortran files supplemented with HTML references. 'grdpts.for' 'mgrd.for' 'grdnew.for' 'grdcal.for' 'grdran2d.for' 'grdmerge.for' 'grdps.for' 'cremove.for' 5.20 (1998, October): All error messages in the Fortran files, previously generated by statements like PAUSE 'Error ...', are now generated by CALL ERROR('...') in order to enable to fit the error handling for a particular computer by editting file 'error.for' (the date of subroutines not updated). Most warning messages in the Fortran files, previously generated by statements like PAUSE 'Warning ...', are now generated by CALL WARN('...'). 'ss.for','sp.for': *** Moved from package CRT. *** 'eigen.for': *** Moved from package NET. *** 'formsdoc.htm' split into 'formsdoc.htm', 'formsver.htm' and 'formsdat.htm', list of files moved to 'forms.htm'. 'forms.for': New subroutines to write and read 3-D data cubes for several time levels (4-D data cubes). Incorrect handling of FORMATTED/UNFORMATTED files for lowercase arguments of subroutines fixed. 'length.for': Subroutine LOWER moved from 'sep.for'. 'sep.for': New subroutines WSEP1, RSEP3Q, WSEP3R and WSEP3I. Subroutine WSEPR updated (some reals written in integer format). 'gse.for','grdcal.for','grdpts.for': Some bugs fixed. 'calcops.inc','srp.for','grdran2d.for': Minor updates. 'mgrd.for': *** All output grids (data cubes) now written into a single file by default, N4 appended to input SEP file. *** 'grdnew.for': *** Input data changed *** (second input SEP file discarded). 'grdran2d.for': *** Input data changed *** (second input SEP file discarded, ISEED moved to the SEP file). *** new *** All MS-DOS batch files '*.bat' and Unix scripts '*' replaced by corresponding Perl scripts '*.pl' or by history files '*.h' containing the lines specifying how to run the programs. 'error.for': Subroutines to handle errors and warnings. 'ss.for': *** Input data changed to SEP format *** Calculating all 3 components within a single run. Taking PS filenames from input history file. EXTERNAL statements fixed problems with some compilers. Some other corrections and updates. 'sp.for': *** Input data changed to SEP format *** Overlaying seismograms of several GSE files. Plotting all 3 components within a single run. Selecting receivers according to the receiver file. Taking PS filenames from input history file. Some other corrections and updates. 'calcops.for': New entry PLOTN enables to specify the name of the output PostScript file. Now, spaces plotted by subroutine SYMBOL are not included into the bounding box. 'grdcal.for': Updated from 3-D to 4-D data cubes. 3-D data cubes may be also be used for 4-D calculations. Values of constants may now be taken from the input SEP parameter file. Conversion to integer data cubes introduced. 'grdfd.for', 'grdnorm.for': New programs. 'grdps.for': Considerable revisions: Updated from 3-D to 4-D data cubes (snaphot generation). Multiple input data cubes may now be displayed in the same figure (e.g., colours from the first data file and shades from the other data file). Various length units (cm,in,pt) enabled to facilitate bitmap generation. *** Input data changed. *** 'sep.pl', 'forms.pl', 'go.pl', 'echo.pl', 'append.pl', 'chk.pl', 'compdel.pl': New programs and subroutines coded in Perl. 5.30 (1999, June): 'error.for': *** Errors and warning messages are written to file 'error.out'. *** 'go.pl': *** Execution is terminated if an error warning is encountered in file 'error.out'. Subroutine CHK writes error messages to file 'error.out'. *** Few bugs fixed. Documentation improved. 'forms.for': A minor bug fixed. 'pallet.for': Hue domain changed from 2*pi to 1. 'ss.for': Two bugs fixed. 'gse.for','grdfd.for': Comment lines with data description updated. 'grdcal.for', 'grdnorm.for': *** Several bad bugs fixed. *** 'grdps.for': Specification of the colour of undefined values enabled. Some bugs fixed. *** new *** 'colors.for': Subroutines to linearly interpolate discrete colour maps in RGB space 'hsv.dat': Data for 'colors.for' specifying the HSV (HSB) colour scale for interpolation in the RGB colour space. 'wrl.for': Subroutines to facilitate writing VRML and POV files. 'iniwrl.for': Program to initialize a VRML file. 'ptswrl.for': Program to convert points into VRML. 'linwrl.for': Program to convert lines into VRML. 'srfwrl.for': Program to convert triangulated surfaces into VRML. 'trgl.for': Program to divide polygons on a curved surface into triangles, right-handed with respect to the surface normals. 'plgn.for': Program to convert polygons described by names of the vertices into the same polygons described by indices of the vertices. 'ptsgrd.for': Program to generate grid file containing undefined values at gridpoints closest to the given points and zeros elswhere. 'do-test.for': Program to test compilation of DO loops 'copy.pl': Perl script to copy files. 5.40 (2000, May): 'pallet.for', 'srp.for': *** Input data changed to SEP format. *** 'grdpts.for', 'mgrd.for', 'grdnew.for', 'grdmerge.for', 'grdcal.for', 'grdnorm.for', 'grdfd.for', 'grdran2d.for', 'grdps.for': *** Input data changed. *** Multiple files from * device moved to the history file. 'forms.htm': Considerably revised. 'formsdoc.htm' discarded (information moved to 'forms.htm'). 'formsdat.htm': Slightly revised (defaults for coordinates of points and lines). 'forms.for': New subroutines WMAT and RMAT for matrix elements. Subroutine FORM1 considerably updated. Comments corrected. 'wrl.for', 'iniwrl.for', 'ptswrl.for', 'linwrl.for', 'srfwrl.for': Extended to write GOCAD format (not debugged). Description corrected. 'trgl.for': Several bugs fixed. Cosmetic changes. 'ss.for': Updated and corrected (parameter SMALL, error SS-05, SIGPLOT=' ', cosmetic changes, comments, etc.). 'srp.for': Maximum number of generated files increased. 'grdpts.for': Description corrected. 'mgrd.for': Numbers in generated filenames decreased by 1. 'grdnew.for': Corrected. 'grdcal.for': Program for grid calculations extended to include also operations with vector and matrix elements. Two bugs fixed. 'grdnorm.for': *** Considerably corrected. *** 'gels.for': Moved from package MODEL to FORMS. 'go.pl': *** Default input data for programs enabled. *** The default data is the name of the history file. 'compdel.pl': Missing description supplemented. 'corfun.h': Corrected. 'grdran2d.dat' and 'grdps.dat' deleted (not used even in version 5.30). 'plgn.for', 'sp.for', 'ptsgrd.for': Cosmetic changes. 'grdps.for': New parameter SHOWPAGE useful to disable the PostScript 'showpage' command. 'error.for', 'color.for': Comments corrected. *** new *** 'gksps.for': GKS to PostScript interface. 'pictures.for': Program to draw lines and points. 'trglps.for': Program to display triangulated 2-D velocity and other sections in PostScript. 'linden.for': Program to make LINes more DENsely sampled. 'inv.cal','sqrt.cal','invsub.cal', 'reldev.cal', 'addsob.cal' and 'eq.cal': New command files for 'grdcal.for'. 'loc0.cal','loc1.cal','loc2.cal': New command files for 'grdcal.for' to perform nonlinear kinematic location of seismic hypocentre. 'grdfft.for': Program to compute the 1-D, 2-D or 3-D Fourier transform of a real or complex function defined on 1-D, 2-D or 3-D grid of points. 'grdran.for': Program to compute the pseudorandom numbers on a given grid, distributed uniformly between -0.5 and 0.5. 'grdcor.for': Program to compute the values of the spectral filters corresponding the typical correlation functions of random media on a given grid. 'grdstat.for': Program to rescale gridded data to given statistical properties. 'grdckn.for': Program to compute the values of the Von Karman correlation functions. 'grdte.for': Program to compute the values of a real or complex function, described in terms of the Taylor expansions of its amplitude and phase, on a given grid. 'binasc.for': Program to convert gridded data (data cubes) from binary files to formatted ascii files. 'ascbin.for': Program to convert gridded data (data cubes) from formatted ascii files to direct-access binary files. 'gmt.for','gmgm.for','smgm.for','dmgm.for','smsm.for', 'smsmsm.for','gmdmgmt.for','sminv.for','smpower.for', 'smeigen.for': Programs to perform operations with general matrices (gm), symmetric matrices (sm) and diagonal matrices (dm). 'sinv.for' and 'mfsd.for': Subroutines of the IBM Scientific Subroutine Package employed by program 'sminv.for'. 'eigennr.for': Subroutine to compute eigenvalues and eigenvectors of a real symmetric matrix, using subroutines of Numerical Recipes. 'corfft.h': Analogue to 'corfun.h', but using 3-D programs 'grdran.for', 'grdfft.for', 'grdcor.for', 'grdcal.for' and 'grdstat.for'. 'cknfft.h': History file to compare medium correlation functions calculate the by FFT and analytically. 5.50 (2001, June): 'ram.inc': New variables MINRAM, MAXRAM included for cases when the program calls a subroutine which needs to use a part of array RAM. 'sep.inc': Dimension MPAR enlarged. 'forms.for', 'grdcal.for': *** New parameters FORMM, FORMMR, FORMMW included to switch the form of the files with matrices between formatted and unformatted. The parameters are used by all programs working with matrices. *** 'wrl.for','iniwrl.for','ptswrl.for','linwrl.for', 'srfwrl.for': *** Output to GOCAD debugged and upgraded. *** 'srfwrl.for': *** New parameter KOLSRF to specify the colour of the surfaces. *** 'trgl.for': A bug fixed. 'trglps.for': *** Parameter LRIGHT changed to LEFT, default value of VDIV changed. *** 'pictures.for': The program now uses array RAM. 'ss.for','sp.for': Parameter names in the comment lines of waveform identification section of the GSE file changed. 'sp.for': *** Upgraded to supplement seismograms with field travel times, to combine several sets of seismograms in a single plot, to combine several components in a single plot, to specify different positions for different sets of seismograms in individual plots, to select amplidude scaling according to the maximum amplitude calculated over the plotted part of a seismogram, to label seismograms by receiver names, to describe individual plots by given text strings, etc. Many new SEP parameters corresponding to the upgrades. *** 'srp.for': *** Input parameters C1, C2 renamed to CPAR1, CPAR2. *** 'grdpts.for': *** Upgraded to supplement output points with input gridded values, and to triangulate the grid. New SEP parameters GRD, KOLUMN, PLGN, TRGL. *** 'grdnew.for': *** Considerably wrong interpolation fixed.*** 'grdfd.for': Upgraded to calculate second derivatives. 'grdran2d.for': Comments updated. 'binasc.for': Upgraded to optionally output a sparser grid. 'binasc.for','ascbin.for': *** Input parameter ASC renamed to GRD. *** 'smgm.for': Program speeded up. 'smsm.for': *** Fatal read error fixed. *** 'smsmsm.for': *** Program significantly speeded up. *** 'gmdmgmt.for': Memory requirements information included. 'eigennr.for', 'smpower.for', 'smeigen.for': Subroutine EIGENNR uses array RAM for auxiliary quantities. 'go.pl': Upgraded. 'calcops.for','gksps.for': Minor updates. 'append.pl','copy.pl': Comments corrected. *** new *** 'grdwrl.for': Converts gridded data into the GOCAD representation. 'trglsort.for': Sorts triangles according to the values at their vertices. 'trglnorm.for': Program to compute normal vectors to given triangles. 'tsurf.for': Program to convert GOCAD triangulated surfaces into a file with points and a file with triangles. 'grdtrans.for': Transposes the coordinate axes of the gridded data. 'neg.cal': New command file for 'grdcal.for'. 'grdiso.for': Calculates points at isosurfaces of 3-D gridded values. 'swap.for': Program to swap bytes, i.e., to convert binary gridded data between little-endian and big-endian hardware. 'trsmsm.for': Calculating the trace of the product of two symmetric matrices. 'grd2d3d.for': Extends 2-D grid into 3-D grid. 5.60 (2002, May): 'forms.for': Subroutine WMAT speeded up. 'sep.for','sep.inc': *** Several independent sets of SEP parameters may be handled. *** New subroutines for writing text-valued parameters into the SEP files. 'gksps.for','pictures.for': Text alignment setting enabled. 'pictures.for': Initialization of variable LU1 fixed, declaration of many variables fixed. 'sp.for': Several bad bugs fixed. 'ptswrl.for','srfwrl.for': Colour coding of coordinate values fixed. 'linwrl.for': Colour coding of coordinate values fixed and memory management fixed. 'ptswrl.for','linwrl.for','srfwrl.for','grdwrl.for': Output to GOCAD modified. 'grdfft.for': Multiplication factor of FFT updated. 'grdcor.for': Nulling infinite value corresponding to zero wavenumber fixed. 'grdps.for': Default value and usage of input parameter VSIGN fixed. 5.70 (2003, May): 'pictures.for': *** Initialization of the GKS to CALCOMP interface fixed. *** 'ss.for': A bug fixed. 'gse.for': Format of coordinates updated. 'go.pl': New perl subroutine to delete a file. *** new *** 'rtcoef.for','coef52.for': Calculation of the displacement R/T coefficients of inhomogeneous P, SV and SH plane waves at a stack of homogeneous isotropic dissipative layers between two homogeneous isotropic dissipative halfspaces. 'del.pl': New perl script to delete a file. 5.80 (2004, May): 'forms.for': Wrong formatted writing in subroutine WMAT fixed by returning back to 'forms.for' version 5.50. Comments updated. 'ss.for': Comments updated. 'sp.for': Bugs at the first and at the last seismogram sample fixed. Comments updated. 'ptswrl.for': Control of the kind and size of points in GOCAD coded. Comments updated. 'linwrl.for','plgn.for','trglsort.for','tsurf.for', 'mgrd.for': Comments updated. 'addsob.cal': Modified to consider the sign of SOBMUL. 'grdfft.for','grdiso.for','grdran2d.for': Comments updated. 'binasc.for','grdps.for': Comments updated. 'rtcoef.for','coef52.for': Comments updated. 'go.pl': Error messages updated. *** new *** 'subsob.cal': New command file for 'grdcal.for'.
f.pl 0100666 0000765 0000765 00000010355 06771615122 011226 0 ustar bulant bulant #!perl #Programming language: Programming language: FORTRAN77 full language as specified in the ANSI standard: X3.9-1978: American National Standard Programming Language FORTRAN. American National Standards Institute, New York 1978. Extension: INCLUDE statement of FORTRAN90. Character set: Code: Character set of FORTRAN77 with capital letters (49 characters including the space): ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 =+-*/(),.$': Comments and character strings: ASCII characters of the 7-bit table. Line length: 72 characters Preferred code layout: Indentation: Documentation and extensive comments at the beginnings of subroutines: columns 3, 7, 15, 17, 19, etc. with step 2. FORTRAN statements and comments within statements: columns 7, 9, 11, etc. with step 2. Insides of DO loops and IF statements are indented. Indentation of the continuation lines is haphazard in this version. Example forms of the FORTRAN statements and of the spacing: A=B+5.*(E+F) no spaces in assignment statements and expressions, except when matching similar expressions in succeeding lines. GO TO 12 GO TO (10,20,30)K IF(I.EQ.J) GO TO 30 IF(A.GT.B) THEN ELSE IF(C.GT.D) THEN END IF DO 20 I=1,15 BLOCK DATA BACKSPACE CALL VEL(N,COOR,F) SUBROUTINE VEL(N,COOR,F) PARAMETER (PI=3.14159) COMMON/ABC/IR,FF,HH COMMON IR,FF,HH DATA R/4.,2.,1./,K/0/ READ(LUN,*) L,M,(BER(I),I=LS,MS),ALFA,BETA but: READ (LUN,*) L,M,(BER(I),I=LS,MS),ALFA,BETA WRITE(LUN,*) L,M,(BER(I),I=LS,MS),ALFA,BETA Miscellaneous: All sentences in documentation should be ended by a dot. Individual sections of the code may be separated by blank lines with C in the first column. Only CONTINUE and FORMAT statements should be labeled. Specific names of the intrinsic functions are preferred to generic ones. Error messages: The error messages are most frequently written by statements like CALL ERROR('314 in SUBR: Brief description') or CALL ERROR('PROG-04: Brief description') They are spread over all files and are described inside individual routines. SUBROUTINE ERROR etc.
Control of screen output: Output to the * external unit is intended for the screen. It is assumed that the first character of each output line is a control character: ' ' to advance to the next line, and '+' to rewrite the last line. If the compiler and operating system does not support this convention, it is adviced to pipe the screen output with user-defined filter in order to achieve the best look of the output screen. The width of the screen is usually assumed to be at least 79 characters.
# # Perl script 'f.pl' to compile a single Fortran 77 source code file # # Editing this file enables to very simply compile and link all Fortran # programs of package FORMS and related packages (like MODEL, CRT, NET, # ANRAY and FD) using system-independent Perl scripts. # # Version: 5.40 # Date: 1999, September 21 # # Coded by: Vaclav Bucha and Ludek Klimes # Department of Geophysics, Charles University Prague, # Ke Karlovu 3, 121 16 Praha 2, Czech Republic, # E-mails: bucha@seis.karlov.mff.cuni.cz # klimes@seis.karlov.mff.cuni.cz # # ...................................................................... # # This file consists of the following PERL subroutines: # COMPILE... Subroutine designed to compile a single Fortran 77 # source code file. # COMPILE # Main script designed to compile single Fortran 77 source code # file by means of invocation of subroutine COMPILE # if its name is specified at the command line. # F # # ====================================================================== # # # # Subroutine COMPILE($FILE[,$OPTIONS]) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Subroutine designed to compile a single Fortran 77 source code file. # # Input: # $FILE...String containing the name of the Fortran 77 source code # file without extension '.for'. # $OPTIONS... Optional command-line arguments for the compiler. # # No output. # # Note: Uncomment and modify commands for your compiler. After that, # comment the following line: die "Uncomment and modify commands for your compiler. Error"; # # ---------------------------------------------------------------------- # sub COMPILE { $FILE=$_[0]; @FILEandOPTIONS=@_; print "---------- Compiling ${FILE}.for ----------\n"; # # Linux compiler g77: # ~~~~~~~~~~~~~~~~~~~ # Compiling $FILE.for to get executable $FILE # open(LU,"|g77 -o @FILEandOPTIONS $FILE.for>$FILE.lst"); # (option -O is not recommended) # (option -O cannot be used to compile mtt.for and anray.for) # (rounding errors on a PC sometimes resemble RISC computers) # close(LU) || die "Error"; # # Linux compiler fort77: # ~~~~~~~~~~~~~~~~~~~~~~ # Copying $FILE.for to $FILE.f # symlink("$FILE.for","$FILE.f"); # Compiling $FILE.f to get executable $FILE # open(LU,"|fort77 -Nc40 -O -o @FILEandOPTIONS $FILE.f"); # (option -Nc40 is necessary to compile grdcal.for) # (do not use option -O to compile mtt.for) # (program green.for does not work properly) # (cannot compile package RMATRIX) # close(LU) || die "Error"; # Deleting $FILE.f # unlink("$FILE.f"); # # HP-Unix compiler fort77: # ~~~~~~~~~~~~~~~~~~~~~~~~ # Copying $FILE.for to $FILE.f # symlink("$FILE.for","$FILE.f"); # Compiling $FILE.f to get executable $FILE # open(LU,"|fort77 -o @FILEandOPTIONS $FILE.f"); # (use option -K to compile grdran2d.for) # (subroutine SIGNAL in ss.for must be renamed) # close(LU) || die "Error"; # Deleting $FILE.f # unlink("$FILE.f"); # # MS-DOS Lahey compliler F77L3 and linker 386LINK: # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Compiling $FILE.for to get $FILE.obj # open(LU,"|F77L3 @FILEandOPTIONS >$FILE.lst"); # close(LU) || die "Error"; # Linking $FILE.obj to get executable $FILE.exe # open(LU,"|386LINK @FILEandOPTIONS -lib GRAPH3 -symbol"); # (use option -stack ... to link grdran2d.for) # close(LU) || die "Error"; # Deleting $FILE.obj # unlink("$FILE.obj"); } # ====================================================================== # # # # Main script # ~~~~~~~~~~~ # Usage: # perl f.pl [$FILE [options]] # Parameters: # $FILE...String containing the name of the Fortran 77 source code # file without extension '.for'. # If $FILE is not specified, no action is done. # # ---------------------------------------------------------------------- # if (scalar(@ARGV)>0) {&COMPILE(@ARGV)}; # # ====================================================================== 1; #gels.for 0100666 0000765 0000765 00000012622 06364046142 012103 0 ustar bulant bulant C SUBROUTINE 'GELS' FROM THE IBM SCIENTIFIC SUBROUTINE PACKAGE. C C NOTE: TO CONFORM WITH THE FORTRAN77 STANDARD, DUMMY ARRAY DIMENSIONS C (1) HAVE BEEN CHANGED TO (*). C C .................................................................. C C SUBROUTINE GELS C C PURPOSE C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH C SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH C IS ASSUMED TO BE STORED COLUMNWISE. C C USAGE C CALL GELS(R,A,M,N,EPS,IER,AUX) C C DESCRIPTION OF PARAMETERS C R - M BY N RIGHT HAND SIDE MATRIX. (DESTROYED) C ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS. C A - UPPER TRIANGULAR PART OF THE SYMMETRIC C M BY M COEFFICIENT MATRIX. (DESTROYED) C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR C PIVOT ELEMENT AT ANY ELIMINATION STEP C EQUAL TO 0, C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT ELIMINATION STEP K+1, C WHERE PIVOT ELEMENT WAS LESS THAN OR C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES C ABSOLUTELY GREATEST MAIN DIAGONAL C ELEMENT OF MATRIX A. C AUX - AN AUXILIARY STORAGE ARRAY WITH DIMENSION M-1. C C REMARKS C UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED C COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT C HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE C LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE C TOO. C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS C GIVEN IN CASE M=1. C ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT C MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS C ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE GELG (WHICH C WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH C PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE C SYMMETRY IN REMAINING COEFFICIENT MATRICES. C C .................................................................. C SUBROUTINE GELS(R,A,M,N,EPS,IER,AUX) C C DIMENSION A(*),R(*),AUX(*) IF(M)24,24,1 C C SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT 1 IER=0 PIV=0. L=0 DO 3 K=1,M L=L+K TB=ABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L J=K 3 CONTINUE TOL=EPS*PIV C MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT. C PIV CONTAINS THE ABSOLUTE VALUE OF A(I). C C C START ELIMINATION LOOP LST=0 NM=N*M LEND=M-1 DO 18 K=1,M C C TEST ON USEFULNESS OF SYMMETRIC ALGORITHM IF(PIV)24,24,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 LT=J-K LST=LST+K C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R PIVI=1./A(I) DO 8 L=K,NM,M LL=L+LT TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB C C IS ELIMINATION TERMINATED IF(K-M)9,19,19 C C ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A. C ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX. 9 LR=LST+(LT*(K+J-1))/2 LL=LR L=LST DO 14 II=K,LEND L=L+II LL=LL+1 IF(L-LR)12,10,11 10 A(LL)=A(LST) TB=A(L) GO TO 13 11 LL=L+LT 12 TB=A(LL) A(LL)=A(L) 13 AUX(II)=TB 14 A(L)=PIVI*TB C C SAVE COLUMN INTERCHANGE INFORMATION A(LST)=LT C C ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT PIV=0. LLST=LST LT=0 DO 18 II=K,LEND PIVI=-AUX(II) LL=LLST LT=LT+1 DO 15 LLD=II,LEND LL=LL+LLD L=LL+LT 15 A(L)=A(L)+PIVI*A(LL) LLST=LLST+II LR=LLST+LT TB=ABS(A(LR)) IF(TB-PIV)17,17,16 16 PIV=TB I=LR J=II+1 17 DO 18 LR=K,NM,M LL=LR+LT 18 R(LL)=R(LL)+PIVI*R(LR) C END OF ELIMINATION LOOP C C C BACK SUBSTITUTION AND BACK INTERCHANGE 19 IF(LEND)24,23,20 20 II=M DO 22 I=2,M LST=LST-II II=II-1 L=A(LST)+.5 DO 22 J=II,NM,M TB=R(J) LL=J K=LST DO 21 LT=II,LEND LL=LL+1 K=K+LT 21 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 22 R(K)=TB 23 RETURN C C C ERROR RETURN 24 IER=-1 RETURN END C C======================================================================= C gksps.for 0100666 0000765 0000765 00000013166 07471365704 012314 0 ustar bulant bulant C SUBROUTINE GOPKS(LUERR,ISIZE) INTEGER LUERR,ISIZE C Dummy subroutine. C C C ENTRY GPL(N,PX,PY) C INTEGER N C REAL PX(N),PY(N) C C ENTRY GPM(N,PX,PY) C INTEGER N C REAL PX(N),PY(N) C C ENTRY GTX(PX1,PY1,CHARS) C REAL PX1,PY1 C CHARACTER*(*) CHARS C C ENTRY GSCHH(CHH) C REAL CHH C C ENTRY GSCHXP(CHXP) C REAL CHXP C C ENTRY GSCHSP(CHSP) C REAL CHSP C C ENTRY GSCHUP(CHUX,CHUY) C REAL CHUX,CHUY C C ENTRY GSLN(LTYPE) C INTEGER LTYPE C C ENTRY GSLWSC(WIDTH) C REAL WIDTH C C ENTRY GSMKSC(PMSZSF) C REAL PMSZSF C C ENTRY GSMK(MTYPE) C INTEGER MTYPE C C ENTRY GSPLCI(KOLI) C INTEGER KOLI C C ENTRY GSPMCI(KOLI) C INTEGER KOLI C C ENTRY GSTXCI(KOLI) C INTEGER KOLI C C ENTRY GSTXAL(ITXALH,ITXALV) C INTEGER ITXALH,ITXALV C C ENTRY GSTXFP(IFONT,IPREC) C INTEGER IFONT,IPREC C C ENTRY GSTXP(ITXP) C INTEGER ITXP C C INTEGER N REAL PX(N),PY(N),PX1,PY1 CHARACTER*(*) CHARS REAL CHH,CHXP,CHSP,CHUX,CHUY INTEGER LTYPE REAL WIDTH,PMSZSF INTEGER MTYPE,KOLI,ITXALH,ITXALV,IFONT,IPREC,ITXP C C C Version: 5.60 C Date: 2002, May 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Common block /PLOTC/: INCLUDE 'calcops.inc' C calcops.inc C C----------------------------------------------------------------------- C C Intrinsic functions: INTRINSIC LEN INTEGER LEN C C Temporary storage location: INTEGER I REAL X,Y C C GKS setting: INTEGER LSYMB,MSYMB PARAMETER (LSYMB=-1,MSYMB=20) INTEGER KOLPL,KOLPM,KOLTX,LNTYPE,KPM,KSYMB(LSYMB:MSYMB) SAVE KOLPL,KOLPM,KOLTX,LNTYPE,KPM,KSYMB REAL SIZEPL,SIZEPM,SIZE0,SIZETX,ANGLE SAVE SIZEPL,SIZEPM,SIZE0,SIZETX,ANGLE INTEGER JTXALH,JTXALV SAVE JTXALH,JTXALV C Default GKS types DATA KOLPL/1/,KOLPM/1/,KOLTX/1/,LNTYPE/1/,KPM/1/ C Translation table of GKS marker types to CALCOMP centered symbols DATA KSYMB/5,1,1,3,11,0,4,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14/ C Default GKS dimensions DATA SIZEPL/1.0/,SIZEPM/1.0/,SIZETX/1.0/,ANGLE/0.0/ C Default text alignment DATA JTXALH/0/,JTXALV/0/ SIZE0=2.54/7.2 C Unit polymarker size in CALCOMP is SIZE0. C C....................................................................... C RETURN C ENTRY GPL(N,PX,PY) CALL NEWPEN(KOLPL) CALL PLOT(PX(1),PY(1),3) DO 10 I=2,N CALL PLOT(PX(I),PY(I),2) 10 CONTINUE RETURN C ENTRY GPM(N,PX,PY) CALL NEWPEN(KOLPM) DO 20 I=1,N CALL SYMBOL(PX(I),PY(I),SIZE0*SIZEPM,CHAR(KSYMB(KPM)),0.,-1) 20 CONTINUE RETURN C ENTRY GTX(PX1,PY1,CHARS) CALL NEWPEN(KOLTX) I=LEN(CHARS) IF (JTXALH.EQ.0) THEN X=PX1 ELSE X=PX1-FLOAT((JTXALH-1)*I)*SIZETX*0.5 ENDIF IF (JTXALV.EQ.0) THEN Y=PY1 ELSE Y=PY1-1.2*SIZETX+FLOAT(JTXALV-1)*1.4*SIZETX*0.25 ENDIF CALL SYMBOL(X,Y,SIZETX,CHARS,ANGLE,I) RETURN C ENTRY GSCHH(CHH) SIZETX=CHH*2.54/7.2 RETURN C ENTRY GSCHXP(CHXP) C Not applied. Might be coded using 'stringwidth' and 'ashow'. RETURN C ENTRY GSCHSP(CHSP) C Not applied. Might be coded using 'ashow'. RETURN C ENTRY GSCHUP(CHUX,CHUY) ANGLE=ATAN2(-CHUX,CHUY)*180./3.141593 RETURN C ENTRY GSLN(LTYPE) IF(LTYPE.NE.LNTYPE) THEN LNTYPE=LTYPE IF(LNTYPE.EQ.-1) THEN WRITE(LUCFG,'(A)') 'S [3 3 1 3 1 3] 0 setdash' ELSE IF(LNTYPE.EQ.0) THEN WRITE(LUCFG,'(A)') 'S [] 0 setdash' ELSE IF(LNTYPE.EQ.1) THEN WRITE(LUCFG,'(A)') 'S [] 0 setdash' ELSE IF(LNTYPE.EQ.2) THEN WRITE(LUCFG,'(A)') 'S [3 3] 0 setdash' ELSE IF(LNTYPE.EQ.3) THEN WRITE(LUCFG,'(A)') 'S [1 3] 0 setdash' ELSE IF(LNTYPE.EQ.4) THEN WRITE(LUCFG,'(A)') 'S [3 3 1 3] 0 setdash' ELSE C GKSPS-01 CALL ERROR('GKSPS-01: Subroutine GSLN: Wrong line type LTYPE') END IF END IF RETURN C ENTRY GSLWSC(WIDTH) IF(WIDTH.NE.SIZEPL) THEN SIZEPL=WIDTH WRITE(LUCFG,'(A,F6.2,A)') 'S ',SIZEPL,' setlinewidth' END IF RETURN C ENTRY GSMKSC(PMSZSF) SIZEPM=PMSZSF RETURN C ENTRY GSMK(MTYPE) C Centred symbols: IF(MTYPE.LT.LSYMB.OR.MTYPE.GT.MSYMB) THEN C GKSPS-02 CALL ERROR('GKSPS-02: Subroutine GSMK: Wrong marker type MTYPE') END IF KPM=MTYPE RETURN C ENTRY GSPLCI(KOLI) KOLPL=KOLI RETURN C ENTRY GSPMCI(KOLI) KOLPM=KOLI RETURN C ENTRY GSTXCI(KOLI) KOLTX=KOLI RETURN C ENTRY GSTXAL(ITXALH,ITXALV) IF((ITXALH.LT.0.OR.ITXALH.GT.3).OR. * ((ITXALV.NE.0).AND.(ITXALV.NE.1).AND.(ITXALV.NE.3).AND. * (ITXALV.NE.5))) THEN C GKSPS-04 CALL ERROR('GKSPS-04: Subroutine GSTXAL: Wrong text alignment') END IF JTXALH=ITXALH JTXALV=ITXALV RETURN C ENTRY GSTXFP(IFONT,IPREC) C Not applied. RETURN C ENTRY GSTXP(ITXP) C Not applied. * IF(ITXP.NE.0) THEN C GKSPS-03 * CALL ERROR('GKSPS-03: Subroutine GSTXP: Wrong text type ITXP') * END IF RETURN C END C C======================================================================= C gmdmgmt.for 0100666 0000765 0000765 00000014762 07303642010 012602 0 ustar bulant bulant C
C Program GMDMGMT to compute product SM1=GM1*DM1*GM1T of general matrix C GM1, diagonal matrix DM1 and transposed matrix GM1. Resulting matrix C SM1 is symmetric. C C Version: 5.50 C Date: 2000, October 20 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows of general matrix GM1 and C rows and columns of symmetric matrix SM1. C Default: M1=' ' means that the number is 1. C M2='string'... Name of the file containing a single integer number C specifying the number of columns of matrix GM1 and rows C and columns of diagonal matrix DM1. C Default: M2=' ' means that the number is 1. C Filenames of the files with the matrices: C GM1='string' ... Name of the input file containing matrix GM1. C No default, 'GM1' must be specified and cannot be blank. C DM1='string' ... Name of the input file containing matrix DM1. C If DM1 is blank (default), a unit matrix is used in C place of DM1. C Default: 'DM1'=' ' (means that DM1 is unit matrix). C SM1='string' ... Name of the output file to contain matrix SM1. C No default, 'SM1' must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILE1 CHARACTER*72 TXTERR INTEGER M1,M2,M1M2,M1M1,LU1,I1,I2,I3,I PARAMETER (LU1=1) C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GMDMGMT: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 C C Reading all data from the SEP file into the memory: IF (FILE1.NE.' ') THEN CALL RSEP1(LU1,FILE1) ELSE C GMDMGMT-01 CALL ERROR('GMDMGMT-01: SEP file not given') ENDIF C C Reading the dimensions of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF CALL RSEP3T('M2',FILE1,' ') IF (FILE1.EQ.' ') THEN M2=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M2 CLOSE(LU1) ENDIF M1M2=M1*M2 M1M1=M1*(M1+1)/2 C IF (M1M2+M2+M1M1.GT.MRAM) THEN C GMDMGMT-02 I1=M1M2+M2+M1M1-MRAM WRITE(TXTERR,'(A,I9,A)') * 'GMDMGMT-02: Array RAM too small,',I1,' units missing.' CALL ERROR(TXTERR) END IF C C Reading input matrices: CALL RSEP3T('GM1',FILE1,' ') IF (FILE1.EQ.' ') THEN C GMDMGMT-03 CALL ERROR('GMDMGMT-03: Input file with matrix GM1 not given.') ENDIF CALL RMAT(LU1,FILE1,M1,M2,RAM) CALL RSEP3T('DM1',FILE1,' ') IF (FILE1.EQ.' ') THEN DO 5 I=M1M2+1,M1M2+M2 RAM(I)=1. 5 CONTINUE ELSE CALL RMAT(LU1,FILE1,M2,1,RAM(M1M2+1)) ENDIF CALL RSEP3T('SM1',FILE1,' ') IF (FILE1.EQ.' ') THEN C GMDMGMT-05 CALL ERROR('GMDMGMT-05: Output file with matrix SM1 not given.') ENDIF C C Multiplication: WRITE(*,'(A)') '+GMDMGMT: Calculating... ' DO 10 I=M1M2+M2+1,M1M2+M2+M1M1 RAM(I)=0. 10 CONTINUE DO 13 I3=1,M2 I=M1M2+M2 DO 12 I2=M1*(I3-1)+1,M1*I3 AUX=RAM(M1M2+I3)*RAM(I2) DO 11 I1=M1*(I3-1)+1,I2 I=I+1 RAM(I)=RAM(I)+RAM(I1)*AUX 11 CONTINUE 12 CONTINUE 13 CONTINUE C C Writing output matrix SM1: CALL WMAT(LU1,FILE1,M1,0,RAM(M1M2+M2+1)) C WRITE(*,'(A)') '+GMDMGMT: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgmgm.for 0100666 0000765 0000765 00000015525 07303642010 012073 0 ustar bulant bulant C
C Program GMGM to compute product GM3=GM1*GM2 of two general matrices C GM1 and GM2. C C Version: 5.50 C Date: 2000, October 20 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows of matrices GM1 and GM3. C Default: M1=' ' means that the number is 1. C M2='string'... Name of the file containing a single integer number C specifying the number of columns of matrix GM1 and the C number of rows of matrix GM2. C Default: M2=' ' means that the number is 1. C M3='string'... Name of the file containing a single integer number C specifying the number of columns of matrices GM2 and GM3. C Default: M3=' ' means that the number is 1. C Filenames of the files with the matrices: C GM1='string' ... Name of the file containing matrix GM1 (input). C No default, 'GM1' must be specified and cannot be blank. C GM2='string' ... Name of the file containing matrix GM2 (input). C No default, 'GM2' must be specified and cannot be blank. C GM3='string' ... Name of the output file containing general matrix C GM3=GM1*GM2. C No default, 'GM3' must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3 INTEGER M1,M2,M3,NA,NB,NR,LU1,I1,I2,I3,J1,J2,J3 REAL CIJ PARAMETER (LU1=1) C C----------------------------------------------------------------------- C C Reading a name of the file with the input data: WRITE(*,'(A)') '+GMGM: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C GMGM-01 CALL ERROR('GMGM-01: SEP file not given') ENDIF C C Reading the dimensions of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF CALL RSEP3T('M2',FILE1,' ') IF (FILE1.EQ.' ') THEN M2=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M2 CLOSE(LU1) ENDIF CALL RSEP3T('M3',FILE1,' ') IF (FILE1.EQ.' ') THEN M3=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M3 CLOSE(LU1) ENDIF NA=M1*M2 NB=M2*M3 NR=M1*M3 C IF (NA+NB+NR.GT.MRAM) THEN C GMGM-02 CALL ERROR('GMGM-02: Small dimension MRAM of array RAM') END IF C C Reading the names of the files with the matrices: CALL RSEP3T('GM1',FILE1,' ') CALL RSEP3T('GM2',FILE2,' ') CALL RSEP3T('GM3',FILE3,' ') C C Reading input matrices: IF (FILE1.EQ.' ') THEN C GMGM-03 CALL ERROR('GMGM-03: Input file with matrix GM1 not given') ENDIF IF (FILE2.EQ.' ') THEN C GMGM-04 CALL ERROR('GMGM-04: Input file with matrix GM2 not given') ENDIF IF (FILE3.EQ.' ') THEN C GMGM-05 CALL ERROR('GMGM-05: Output file with matrix GM3 not given') ENDIF CALL RMAT(LU1,FILE1,M1,M2,RAM) CALL RMAT(LU1,FILE2,M2,M3,RAM(NA+1)) C WRITE(*,'(A)') '+GMGM: Working... ' C C Multiplication: J3=NA+NB C Loop over columns: DO 10, I1=1,M3 C Loop over lines: DO 20, I2=1,M1 J3=J3+1 CIJ=0. DO 30, I3=1,M2 C Element of the first matrix: J1=(I3-1)*M1+I2 C Element of the second matrix: J2=NA+(I1-1)*M2+I3 CIJ=CIJ+RAM(J1)*RAM(J2) 30 CONTINUE RAM(J3)=CIJ 20 CONTINUE 10 CONTINUE C C Writing output matrix GM3: IF (FILE3.NE.' ') THEN CALL WMAT(LU1,FILE3,M1,M3,RAM(NA+NB+1)) ENDIF WRITE(*,'(A)') '+GMGM: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgmt.for 0100666 0000765 0000765 00000013317 07303642010 011730 0 ustar bulant bulant C
C Program GMT to compute general transposed matrix GM2=GM1T. C C Version: 5.50 C Date: 2000, October 20 C C Coded by Petr Bulant C bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows of input general matrix GM1 C and the number of columns of output general matrix GM2. C Default: M1=' ' means that the number is 1. C M2='string'... Name of the file containing a single integer number C specifying the number of columns of matrix GM1 and the C number of rows of matrix GM2. C Default: M2=' ' means that the number is 1. C Filenames of the files with the matrices: C GM1='string'... Name of the input file containing general matrix C GM1. C No default, 'GM1' must be specified and cannot be blank. C GM2='string'... Name of the output file to contain general matrix C GM2=GM1T (GM1 transposed). C No default, 'GM2' must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILE1 INTEGER M1,M2,M1M2,LU1,I1,I2 PARAMETER (LU1=1) C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GMT: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 C C Reading all data from the SEP file into the memory: IF (FILE1.NE.' ') THEN CALL RSEP1(LU1,FILE1) ELSE C GMT-01 CALL ERROR('GMT-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading the dimensions of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF CALL RSEP3T('M2',FILE1,' ') IF (FILE1.EQ.' ') THEN M2=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M2 CLOSE(LU1) ENDIF M1M2=M1*M2 C IF (2*M1M2.GT.MRAM) THEN C GMT-02 CALL ERROR('GMT-02: Small dimension MRAM of array RAM') ENDIF C C Reading input matrices: CALL RSEP3T('GM1',FILE1,' ') IF (FILE1.EQ.' ') THEN C GMT-03 CALL ERROR('GMT-03: Input file with matrix GM1 not given.') ENDIF CALL RMAT(LU1,FILE1,M1,M2,RAM) CALL RSEP3T('GM2',FILE1,' ') IF (FILE1.EQ.' ') THEN C GMT-05 CALL ERROR('GMT-05: Output file with matrix GM2 not given.') ENDIF C C Multiplication: WRITE(*,'(A)') '+GMT: Calculating... ' DO 13 I2=1,M2 DO 12 I1=1,M1 RAM(M1M2+(I1-1)*M2+I2)=RAM((I2-1)*M1+I1) 12 CONTINUE 13 CONTINUE C C Writing output matrix GM2: CALL WMAT(LU1,FILE1,M2,M1,RAM(M1M2+1)) C WRITE(*,'(A)') '+GMT: Finished. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgo.pl 0100666 0000765 0000765 00000033441 10061773474 011411 0 ustar bulant bulant #!perl #
# # Perl script file 'go.pl' to run programs according to a history file # and to assist other Perl scripts in running programs and handling the # data # # Version: 5.80 # Date: 2004, June 10 # # Coded by: Vaclav Bucha and Ludek Klimes # Department of Geophysics, Charles University Prague, # Ke Karlovu 3, 121 16 Praha 2, Czech Republic, # E-mails: bucha@seis.karlov.mff.cuni.cz # klimes@seis.karlov.mff.cuni.cz # ...................................................................... # Usage: # History file 'file.h' may be executed by command # perl go.pl file.h # generating the output history file named 'file.out'. # If you wish to name the output history file, e.g., 'new.out', # the history file may be executed by command # perl go.pl file.h new.out # For the description of history files and their interpretation # refer to sep.htm. # Note: # You may wish to edit some definitions of global variables used # by subroutines of this file. The definitions are located below, # between the list of subroutines and the code of the subroutines. # The global variables are designed to adapt this script to your # computer. # ...................................................................... # This file consists of subroutines: # RUN($NAME,$DATA)... Subroutine to run a program with given input # data. # RUN # ECHO($FILE,$DATA)... Subroutine to append new data to a data file. # ECHO # COPY($FILE1,$FILE2)... Subroutine to copy files. # COPY # APPEND($FILE1,$FILE2)... Subroutine to append $FILE2 to $FILE1. # APPEND # DEL($FILE)... Subroutine to delete files. # DEL # CHK($PATH,$FILE)... Subroutine to check input data files required # by various perl scripts. # CHK # GO($INPUT,$OUTPUT)... Subroutine to run a history file. # GO # 'go.pl'... Main program to run a history file. # MAIN # ====================================================================== # Definition of global variables for subroutine CHK: # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # These definitions may be edited for a particular computer. { package Go; # # Path to the root directory of the SW3D software (for subroutine CHK): $SW3D=''; # no path specified (default) # $SW3D='/cdrom/web/software/sw3dcd6/'; # example (Unix) # $SW3D='k:/web/software/sw3dcd6/'; # example (MS-DOS) } # ====================================================================== # Definition of global variables for subroutine RUN: # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # These definitions may be edited for a particular computer. # The lines which use these definitions are commented in this version. { package Go; # # Path to the directory with the executable SW3D programs: # $EXEPATH='./'; # Unix # $EXEPATH=''; # MS-DOS # Note: open(LU,">./file") unlike open(LU,"|./prg.exe") works in MS-DOS # # Extension of the executable programs: # $EXTENSION=''; # Unix # $EXTENSION='.exe'; # MS-DOS } # ====================================================================== # Subroutine RUN($NAME,$DATA) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Input: # $NAME... String with the name of the program without an extension. # $DATA... String with the data for the program read from a console. # No output. # ---------------------------------------------------------------------- sub RUN { package Go; $NAME =shift(@_); # # Checking for a Perl script: $k=index($NAME,'.pl',0); if ($k==-1) { # # Running executable program: # $PROGRAM=$EXEPATH.$NAME.$EXTENSION; # if (!-e $PROGRAM) { # open (LU1,">>error.out"); # print LU1 "##Error go.pl-RUN-1: Executable file '$PROGRAM' not found"; # close(LU1); # die "Executable file '$PROGRAM' not found. Error"; # } open(LU,"|$NAME"); print LU "@_\n"; close(LU) || die "Error in program '$NAME' executed"; # The error is not indicated under MS-DOS # } else { # # Running Perl script: open(LU,"|perl $NAME @_"); close(LU) || die "Error in Perl script '$NAME' executed"; } # # Checking the output error file for string '##Error': if ($ERROR ne ' ') { if (-e $ERROR) { # Reading the error file into string array @ERRORLINES: open(LU,"<$ERROR"); @ERRORLINES=grd2d3d.for 0100666 0000765 0000765 00000012556 07217052010 012375 0 ustar bulant bulant C; close(LU) || die "Error when closing file '$ERROR'"; # # Loop for the lines of the input SEP history file: foreach $ERRORLINE (@ERRORLINES) { $k=index($ERRORLINE,'##Error',0); if ($k>-1) { die "Error reported in file '$ERROR', execution terminated"; } } } } } # ====================================================================== # Subroutine ECHO($FILE,$DATA) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Input: # $FILE... String containing output filename including redirection. # $DATA... String containing new data to be appended. # No output. # Example: # &ECHO(">file.tmp","First line") # &ECHO(">>file.tmp","Additional line") # ---------------------------------------------------------------------- sub ECHO { package Go; $FILE=shift(@_); open(LU,"$FILE"); print LU "@_\n"; close(LU) || die "Error when writing file '$FILE'"; } # ====================================================================== # Subroutine COPY($FILE1,$FILE2) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Input: # $FILE1... String containing input filename. # $FILE2... String containing output filename. # No output. # ---------------------------------------------------------------------- sub COPY { package Go; open(LU1,"<$_[0]"); open(LU2,">$_[1]"); while ( ){ print LU2; } close(LU1) || die "Error when copying file '$_[0]'"; close(LU2) || die "Error when copying file '$_[1]'"; } # ====================================================================== # Subroutine APPEND($FILE1,$FILE2) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Input: # $FILE1... String containing input-output filename. # $FILE2... Name of the file which content will be appended to # file $FILE1. File $FILE2 remains unchanged. # No output. # ---------------------------------------------------------------------- sub APPEND { package Go; open(LU1,">>$_[0]"); open(LU2,"<$_[1]"); while ( ){ print LU1; } close(LU1) || die "Error when appending '$_[1]' to '$_[0]'"; close(LU2) || die "Error when copying file '$_[1]'"; } # ====================================================================== # Subroutine DEL($FILE) # ~~~~~~~~~~~~~~~~~~~~~ # Subroutine to delete file # # Input: # $FILE...String containing input filename. # No output. # ---------------------------------------------------------------------- sub DEL { package Go; unlink<$_[0]>; } # ====================================================================== # Subroutine CHK($PATH,$FILE) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Subroutine to check input data files required by various perl scripts # # Input: # $PATH...String containing the second part of the PATH to desired # file. # $FILE...String containing desired filename. # No output. # # Note: $SW3D variable may be changed according to users source # containing SW3D files. # ---------------------------------------------------------------------- sub CHK { package Go; $PATH=$_[0]; $FILE=$_[1]; if (!-e $FILE) { if ($PATH eq '') { # No path to the source file specified: open (LU1,">>error.out"); print LU1 "##Error go.pl-CHK-1: File '$FILE' does not exist"; close(LU1); die "File '$FILE' does not exist. Error"; } else { if ($SW3D eq '') { # No path to the root directory of the SW3D software specified: open (LU1,">>error.out"); print LU1 "##Error go.pl-CHK-2: File '$FILE' not found. ". "Check path \$SW3D in file go.pl."; close(LU1); die "File '$FILE' not found. Check path \$SW3D in file go.pl. ". "\nInterrupted"; } else { # Path to the SW3D software: $PATHFILE=$SW3D.$PATH.$FILE; if (-e $PATHFILE) { print "Copying $PATHFILE\n"; open (LU1,"<$PATHFILE"); open (LU2,">$FILE"); while ( ){ print LU2; } close(LU1) || die "Error when copying file '$PATHFILE'"; close(LU2) || die "Error when copying file '$FILE'"; } else { open (LU1,">>error.out"); print LU1 "##Error go.pl-CHK-3: File '$FILE' not available"; close(LU1); print "\nFile $FILE is not available.\n"; die "Check '$SW3D' and input data files according to Perl script\n"; } } } } } # ====================================================================== # Subroutine GO($INPUT,$OUTPUT) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Input: # $INPUT..String containing the input history filename. # $OUTPUT... String containing the output history filename. # No output. # ---------------------------------------------------------------------- sub GO { package Go; $INPUT=$_[0]; $OUTPUT=$_[1]; # # Reading input SEP history file into string array @LINES: open(LU,"<$INPUT"); @LINES= ; close(LU) || die "Error when closing '$INPUT'"; # # Opening the output SEP history file: open(LU,">$OUTPUT"); # # Default name of the output error file: $ERROR='error.out'; # # Deleting output error file: if ($ERROR ne ' ') { if (-e $ERROR) { unlink($ERROR) } } # # Loop over the lines of the input SEP history file: foreach $LINE (@LINES) { # # Replacing string $INPUT by string $OUTPUT: $j=length($INPUT); $k=length($OUTPUT); $i=index($LINE,$INPUT,0); while ($i>-1) { substr($LINE,$i,$j)=$OUTPUT; } continue { $i=index($LINE,$INPUT,$i+$k); } # # Copying the line into the output SEP history file: print LU "$LINE"; # # Looking for the name of the error file (for future extension): ## &'RSEP2($LINE); ## $ERROROLD=$ERROR; ## &'RSEP3('ERROR',$ERROR,$ERROROLD); ## if ($ERROR ne $ERROROLD) { # ## Deleting output error file ## unlink($ERROR) ## } # # Looking for a program to execute: $k=index($LINE,'#',0); if ($k==-1) { $k=length($LINE); } # Line ends at position $k-1 $j=index(substr($LINE,0,$k),':',0); if ($j>-1) { # Line contains a colon at position $j $i=rindex($LINE,' ',$j-1)+1; if ($i<$j) { $PROG=substr($LINE,$i,$j-$i); $DATA=substr($LINE,$j+1,$k-$j-1); # # Default input data (the name of the history file) $i=length($DATA)-1; # Check whether the last character is Line Feed if ($i>-1 && substr($DATA,$i,1) eq "\n" ) { $i=$i-1; } # Check whether the last character is Carriage Return if ($i>-1 && substr($DATA,$i,1) eq "\r" ) { $i=$i-1; } while ($i>-1 && substr($DATA,$i,1) eq ' ') { $i--; } if ($i<0) { $DATA="'$OUTPUT' /"; } # # Executing program $PROG with data $DATA close(LU) || die "Error"; &'RUN($PROG,$DATA); open(LU,">>$OUTPUT"); } } } # # Closing the output history file: close(LU) || die "Error"; # # Checking the output error file for string '##Warning': if ($ERROR ne ' ') { if (-e $ERROR) { # Reading the error file into string array @ERRORLINES: open(LU,"<$ERROR"); @ERRORLINES= ; close(LU) || die "Error when closing file '$ERROR'"; # # Loop for the lines of the input SEP history file: foreach $ERRORLINE (@ERRORLINES) { $k=index($ERRORLINE,'##Warning',0); if ($k>-1) { print "Please, read the warning message(s) in file '$ERROR'!\n"; last } } } } } # ====================================================================== # Main program 'go.pl': # ~~~~~~~~~~~~~~~~~~~~~ if (scalar(@ARGV)>0) { $INPUT=$ARGV[0]; } else { $INPUT='' } if (scalar(@ARGV)>1) { $OUTPUT=$ARGV[1]; } else { $OUTPUT='' } # # Executing the SEP history file: if ($INPUT ne '') { if ($OUTPUT eq '') { # Output history file not specified, setting default based on $INPUT $j=length($INPUT); if (substr($INPUT,$j-2,2) eq '.h') { $OUTPUT=substr($INPUT,0,$j-2).'.out'; } elsif (substr($INPUT,$j-2,2) eq '.H') { $OUTPUT=substr($INPUT,0,$j-2).'.OUT'; } else { open (LU1,">>error.out"); print LU1 "##Error go.pl-MAIN-1: No output history file"; close(LU1); die "No output history file. Error"; } print "Output history file: $OUTPUT\n"; } &GO($INPUT,$OUTPUT); } # ====================================================================== 1; #
C Program GRD2D3D to extend 2-D grid into 3-D grid C C Version: 5.50 C Date: 2000, December 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input and output files: C GRD='string'... Names of the input ASCII file with the 2-D grid C values. C Default: GRD='grd.out' C GRDNEW='string'... Name of the output ASCII file containing the C 3-D grid values. The 3-D grid value G(X1,X2,X3) is the C 2-D grid value G(X1,X2) minus X3 coordinate, C G(X1,X2,X3)=G(X1,X2)-X3 . C Default: GRDNEW='grdnew.out' C For general description of the files with gridded data refer C to file forms.htm. C Data specifying dimensions of the input and output grids: C N1=positive integer... Number of gridpoints along the X1 axis C (inner loop). C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis C (intermediate loop). C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis C (outer loop). Applies just to the output grid. C Default: N3=1 C O3=real... Third coordinate of the grid origin (first point of the C grid). Applies just to the output grid. C Default: O3=0. C D3=real... Grid interval in the direction of the X3 axis. C Applies just to the output grid. C Default: D3=1. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C C Filenames and parameters: CHARACTER*80 FSEP,FGRD1,FGRD2 INTEGER LU REAL UNDEF PARAMETER (LU=1,UNDEF=-999999999.) C C Input data: INTEGER N1,N2,N3 REAL O3,D3 C C Other variables: INTEGER I1,I2,I3,I,J REAL X3 C C----------------------------------------------------------------------- C C Reading input SEP parameter file: WRITE(*,'(A)') '+GRD2D3D: Enter input filename: ' FSEP=' ' READ(*,*) FSEP IF (FSEP.EQ.' ') THEN C GRD2D3D-01 CALL ERROR('GRD2D3D-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF CALL RSEP1(LU,FSEP) WRITE(*,'(A)') '+GRD2D3D: Working ... ' C C Reading input parameters from the SEP file: CALL RSEP3T('GRD' ,FGRD1,'grd.out' ) CALL RSEP3T('GRDNEW',FGRD2,'grdnew.out') CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('O3',O3,0.) CALL RSEP3R('D3',D3,1.) IF(N1*N2*(N3+1).GT.MRAM) THEN C GRD2D3D-02 CALL ERROR('GRD2D3D-02: Too small array RAM(MRAM)') C Array RAM(MRAM) allocated in include file 'ram.inc' is too small C to contain both input (N1*N2 values) and output (N1*N2*N3 C values) grids. You may wish to increase the dimension MRAM in C file ram.inc. END IF C C Reading input grid: CALL RARRAY(LU,FGRD1,'FORMATTED',.TRUE.,UNDEF,N1*N2,RAM) C C Calculating 3-D grid values: J=N1*N2 DO 13 I3=0,N3-1 X3=O3+D3*FLOAT(I3) I=0 DO 12 I2=0,N2-1 DO 11 I1=0,N1-1 I=I+1 J=J+1 RAM(J)=RAM(I)-X3 11 CONTINUE 12 CONTINUE 13 CONTINUE C C Writing output grid: CALL WARRAY(LU,FGRD2,'FORMATTED',.TRUE.,UNDEF,.FALSE.,0.,N1*N2*N3, * RAM(N1*N2+1)) WRITE(*,'(A)') '+GRD2D3D: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdcal.for 0100666 0000765 0000765 00000122614 07303642010 012376 0 ustar bulant bulant C
C Program GRDCAL (GRiD CALculator) to perform vectorial calculations C with real-valued arrays stored in disk files. C C Version: 5.50 C Date: 2000, October 20 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input and output files: C CAL='string'...Name of the input file containing the commands C to be carried out at each gridpoint. C Should always be specified. C Description of file CAL C Default: CAL='.cal' C GRD1='string', GRD2='string', ... ,GRD9='string'... Names C of the input/output ASCII files with the grid values. C Whether a file is input, output, input/output or not C used is dependent on the pseudo-code in file CAL. C For general description of files with gridded data refer C to file forms.htm. C Default: GRD1=' ', ... , GRD9=' ' C Data specifying grid dimensions: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C N4=positive integer... Number of time slices (snapshots). C Default: N4=1 C Modification to enable operations with matrix elements: C If N1=0 or N2=0, parameters M1 or M2 are used, respectively. C M1='string'... Name of the file containing a single integer number C specifying N1. C Default: M1=' ' means that N1=1. C M2='string'... Name of the file containing a single integer number C specifying N2. C Option for symmetric matrices: C If the string value of M2 equals the string value of M1, C then N1=m1*(m1+1)/2 and N2=1, where m1 is read from M1. C Default: M2=' ' means that N2=1. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C C File CAL containing commands to be performed at each gridpoint: C Each line may contain at most a single command. C The lines are read character-by-character. The commands thus C should not be enclosed in parentheses. The commands have the C structure like: C $3=$1+$2 C C=A-B C C=$1-$2 C $3=ABS(C) C or C A=SQRT($2) C A=$1*A C @4=@3*A C etc. C Here $i or @i corresponds to the i-th input/output file GRDi, C FUN(.) represents function FUN of a single argument, C FUN(.,.) represents function FUN of two arguments, C other names represent temporary variables. C Letter case is not distinguished. C A single line may contain a single operation. C C Input and output files with data cubes: C $1,$2,$3,...,$9 are space data cubes of N1*N2*N3 grid values. C If N4 time levels are processed, the input space data C cubes apply to all time levels and output space data cubes C correspond to the first time level. C Examples: gridded P or S wave velocities or density. C @1,@2,@3,...,@9 are space-time data cubes of N1*N2*N3*N4 grid C values, read, processed and written by time levels. C Examples: components of wavefield snapshots. C The same input file cannot be denoted both by $i and @i. C The same output file cannot be denoted both by $i and @i. C If N4=1, there is no difference between $i and @i. C If an input or output $ file is considered, the @ files are read C and written by time levels. C If all input or all output @ files do not fit into array RAM, C the @ files are read and written by time levels. C If N4.GT.1, the @ files are read and written by time levels and C file @i is used for input, neither file $i nor @i can be used C for output. C Temporary variables: C If the value of a variable is not defined within the command C file, it is taken from the input SEP file with the zero default. C If the value of a variable is defined within the command file, C it must be defined before it is used on the right-hand side of C any command. C Allowed operators: C A=B+C C A=B-C C A=B*C C A=B/C C A=B**C C Allowed functions (= sign means equivalent function names): C ABS(.) C AINT(.)=INT(.) C ANINT(.)=NINT(.) C AMOD(.)=MOD(.) C SIGN(.) C DIM(.) C AMAX1(.,.)=AMAX(.,.)=MAX(.,.) C AMIN1(.,.)=AMIN(.,.)=MIN(.,.) C SQRT(.) C EXP(.) C ALOG(.)=LOG(.)=LN(.) C ALOG10(.)=LOG10(.) C SIN(.) C COS(.) C TAN(.) C ASIN(.) C ACOS(.) C ATAN(.) C ATAN2(.,.) C SINH(.) C COSH(.) C TANH(.) C Note that commands of forms like C $2=INT(A) C $3=NINT(A) C imply integer output values, which are thus written as integers C to the output ASCII files. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C Allocation of working array: INTEGER IRAM(MRAM) REAL GRID(MRAM) EQUIVALENCE (IRAM,RAM),(GRID,RAM) C C....................................................................... C EXTERNAL LENGTH INTEGER LENGTH INTEGER MFILE,MNAME,MKOM,LU1 INTEGER JFILE,IFILE,KEQ,KEND,L,IGRID,NGRID,IKOM,ITIME,NTIME C PARAMETER (MFILE=9,MNAME=2*MFILE+20,MKOM=100,LU1=1) INTEGER IUNDEF REAL UNDEF PARAMETER (IUNDEF=-999999999,UNDEF=-999999999.) CHARACTER*80 FGRD,FKOM,FILE(MFILE),FM1,FM2 CHARACTER*4 GRDN INTEGER KGRID0(MFILE),KGRID1(MFILE),LU(MFILE) CHARACTER*80 NAME(MNAME) REAL RNAME(MNAME) INTEGER KOM0(MKOM),KOM1(MKOM),KOM2(MKOM),KOM3(MKOM) CHARACTER*13 FORMM C KGRID0..Offsets in RAM for storing the output grids. C KGRID1..Offsets in RAM for storing the input grids. C NNAME...Number of all operands and results in the command file. C The first MFILE positions are reserved to files. C NAME... Strings identifying the operands and results. C RNAME...Values of the operands and results. C CHARACTER*255 LINE CHARACTER*7 FORMAT LOGICAL LUNDEF,LARRAY INTEGER NNAME,NKOM,MATRIX,I,K INTEGER N1,N2,N3,N4,M1,I0,I1,I2 C LARRAY..Logical variable identifying whether grid values must be C split into individual time levels to fit in the RAM. C NKOM... Number of commands C DATA LU/1,2,3,4,5,6,7,8,9/ C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDCAL: Enter input filename: ' FGRD=' ' READ(*,*) FGRD WRITE(*,'(A)') '+GRDCAL: Working ... ' C C Reading all data from the SEP file into the memory: IF (FGRD.NE.' ') THEN CALL RSEP1(LU1,FGRD) ELSE C GRDCAL-45 CALL ERROR('GRDCAL-45: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading name of the file CAL: CALL RSEP3T('CAL',FKOM,'.cal') C Default extension of FKOM is '.cal': IF(INDEX(FKOM,'.').EQ.0) THEN FKOM(LENGTH(FKOM)+1:LENGTH(FKOM)+4)='.cal' END IF C C Reading names of the files GRDn: GRDN='GRD0' DO 10 IFILE=1,MFILE FILE(IFILE)=' ' NAME(IFILE)='$' NAME(IFILE)(2:2)=CHAR(ICHAR('0')+IFILE) NAME(MFILE+IFILE)='@' NAME(MFILE+IFILE)(2:2)=CHAR(ICHAR('0')+IFILE) GRDN(4:4)=CHAR(ICHAR('0')+IFILE) CALL RSEP3T(GRDN,FILE(IFILE),' ') 10 CONTINUE C C Recalling the data specifying grid dimensions C (arguments: Name of value in input data, Variable, Default): CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3I('N4',N4,1) C Modification to enable operations with matrix elements MATRIX=-1 FM1=' ' IF(N1.LE.0) THEN MATRIX=1 CALL RSEP3T('M1',FM1,' ') IF(FM1.EQ.' ') THEN N1=1 ELSE OPEN(LU1,FILE=FM1,STATUS='OLD') READ(LU1,*) N1 CLOSE(LU1) ENDIF END IF M1=N1 IF(N2.LE.0) THEN MATRIX=1 CALL RSEP3T('M2',FM2,' ') IF(FM2.EQ.' ') THEN N2=1 ELSE IF(FM2.EQ.FM1) THEN MATRIX=0 M1=N1 N1=N1*(N1+1)/2 N2=1 ELSE OPEN(LU1,FILE=FM2,STATUS='OLD') READ(LU1,*) N2 CLOSE(LU1) IF(N1.EQ.1) THEN M1=N2 N1=N2 N2=1 ENDIF ENDIF END IF C C....................................................................... C C Reading the command file FKOM: C NKOM=0 NNAME=2*MFILE OPEN(LU1,FILE=FKOM,STATUS='OLD') C C Loop over input lines 11 CONTINUE READ(LU1,'(A)',END=19) LINE KEQ=INDEX(LINE,'=') IF(KEQ.NE.0) THEN C C The line contains a new command NKOM=NKOM+1 IF(NKOM.GT.MKOM) THEN C GRDCAL-01 CALL ERROR('GRDCAL-01: Insufficient memory for commands') C Maximum number MKOM of the commands read from the command C file should probably be increased. MKOM is declared by the C PARAMETER statement. END IF CALL LOWER(LINE) C C Name of the result must precede '=': DO 12 K=KEQ-1,1,-1 IF(LINE(K:K).EQ.' ') THEN GO TO 13 END IF 12 CONTINUE 13 CONTINUE IF(K.GE.KEQ-1) THEN C GRDCAL-02 CALL ERROR('GRDCAL-02: Missing identifier of the result') END IF C Registration of the name CALL REGNAM(LINE(K+1:KEQ-1),NAME,MNAME,NNAME,KOM0(NKOM)) C C End of the command: KEND=INDEX(LINE(KEQ+1:),' ') IF(KEND.EQ.0) THEN C GRDCAL-03 CALL ERROR('GRDCAL-03: Too long command line') END IF IF(KEND.EQ.1) THEN C GRDCAL-39 CALL ERROR('GRDCAL-39: Command line has no right-hand side') END IF KEND=KEQ+KEND-1 C C Search for left parenthesis: K=INDEX(LINE(KEQ+1:KEND),'(') IF(K.EQ.0) THEN C C No left parenthesis - search for binary operators: K=INDEX(LINE(KEQ+1:KEND),'**') IF(K.NE.0) THEN C Two-letter binary operator **: KOM3(NKOM)=5 C Registration of the name of the second operand K=KEQ+K CALL REGNAM(LINE(K+2:KEND),NAME,MNAME,NNAME,KOM2(NKOM)) ELSE C Search for a one-letter binary operator: K=INDEX(LINE(KEQ+2:KEND+1),'+') IF(K.NE.0) THEN K=K+1 KOM3(NKOM)=1 ELSE K=INDEX(LINE(KEQ+2:KEND+1),'-') IF(K.NE.0) THEN K=K+1 KOM3(NKOM)=2 ELSE K=INDEX(LINE(KEQ+1:KEND),'*') IF(K.NE.0) THEN KOM3(NKOM)=3 ELSE K=INDEX(LINE(KEQ+1:KEND),'/') IF(K.NE.0) THEN KOM3(NKOM)=4 ELSE C No binary operator: KOM3(NKOM)=0 END IF END IF END IF END IF K=KEQ+K IF(KOM3(NKOM).NE.0) THEN C Registration of the name of the second operand IF(K+1.GT.KEND) THEN C C GRDCAL-04 WRITE(*,'(2A)') ' ',LINE(KEQ:KEND) CALL ERROR('GRDCAL-04: Missing second operand') END IF CALL REGNAM(LINE(K+1:KEND),NAME,MNAME,NNAME,KOM2(NKOM)) END IF END IF IF(KOM3(NKOM).NE.0) THEN C Registration of the name of the first operand IF(KEQ+1.GT.K-1) THEN C GRDCAL-05 WRITE(*,'(2A)') ' ',LINE(KEQ:KEND) CALL ERROR('GRDCAL-05: Missing first operand') END IF CALL REGNAM(LINE(KEQ+1:K-1),NAME,MNAME,NNAME,KOM1(NKOM)) ELSE C Registration of the name of the single operand IF(KEQ+1.GT.KEND) THEN C GRDCAL-06 WRITE(*,'(2A)') ' ',LINE(KEQ:KEND) CALL ERROR('GRDCAL-06: Missing operand') END IF CALL REGNAM * (LINE(KEQ+1:KEND),NAME,MNAME,NNAME,KOM1(NKOM)) KOM2(NKOM)=0 END IF C ELSE C C Operator has the form of Fortran 77 intrinsic function K=KEQ+K IF(LINE(KEND:KEND).NE.')') THEN C GRDCAL-07 WRITE(*,'(2A)') ' ',LINE(KEQ:KEND) CALL ERROR('GRDCAL-07: Missing closing parenthesis') END IF C Search for comma delimiting the arguments I=INDEX(LINE(K+1:KEND-1),',') C Registration of the arguments IF(I.EQ.0) THEN C Single argument: IF(K+1.GT.KEND-1) THEN C GRDCAL-08 WRITE(*,'(2A)') ' ',LINE(KEQ:KEND) CALL ERROR('GRDCAL-08: Missing argument') END IF CALL REGNAM(LINE(K+1:KEND-1),NAME,MNAME,NNAME,KOM1(NKOM)) KOM2(NKOM)=0 ELSE C Two arguments: I=K+I IF(K+1.GT.I-1) THEN C GRDCAL-09 WRITE(*,'(2A)') ' ',LINE(KEQ:KEND) CALL ERROR('GRDCAL-09: Missing first argument') END IF CALL REGNAM(LINE(K+1:I-1),NAME,MNAME,NNAME,KOM1(NKOM)) IF(I+1.GT.KEND-1) THEN C GRDCAL-10 WRITE(*,'(2A)') ' ',LINE(KEQ:KEND) CALL ERROR('GRDCAL-10: Missing second argument') END IF CALL REGNAM(LINE(I+1:KEND-1),NAME,MNAME,NNAME,KOM2(NKOM)) END IF C Registration of the function IF(LINE(KEQ+1:K-1).EQ.'abs') THEN KOM3(NKOM)= 6 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-11 CALL ERROR('GRDCAL-11: Redundant argument in ABS') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'aint' * .OR.LINE(KEQ+1:K-1).EQ.'int') THEN KOM3(NKOM)= 7 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-12 CALL ERROR('GRDCAL-12: Redundant argument in AINT') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'anint' * .OR.LINE(KEQ+1:K-1).EQ.'nint') THEN KOM3(NKOM)= 8 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-13 CALL ERROR('GRDCAL-13: Redundant argument in ANINT') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'amod' * .OR.LINE(KEQ+1:K-1).EQ.'mod') THEN KOM3(NKOM)= 9 IF(KOM2(NKOM).EQ.0) THEN C GRDCAL-14 CALL ERROR('GRDCAL-14: Missing second argument of AMOD') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'sign') THEN KOM3(NKOM)=10 IF(KOM2(NKOM).EQ.0) THEN C GRDCAL-15 CALL ERROR('GRDCAL-15: Missing second argument of SIGN') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'dim') THEN KOM3(NKOM)=11 IF(KOM2(NKOM).EQ.0) THEN C GRDCAL-16 CALL ERROR('GRDCAL-16: Missing second argument of DIM') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'amax1' * .OR.LINE(KEQ+1:K-1).EQ.'amax' * .OR.LINE(KEQ+1:K-1).EQ.'max') THEN KOM3(NKOM)=12 IF(KOM2(NKOM).EQ.0) THEN C GRDCAL-17 CALL ERROR * ('GRDCAL-17: Missing second argument of AMAX1') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'amin1' * .OR.LINE(KEQ+1:K-1).EQ.'amin' * .OR.LINE(KEQ+1:K-1).EQ.'min') THEN KOM3(NKOM)=13 IF(KOM2(NKOM).EQ.0) THEN C GRDCAL-18 CALL ERROR * ('GRDCAL-18: Missing second argument of AMIN1') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'sqrt') THEN KOM3(NKOM)=14 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-19 CALL ERROR('GRDCAL-19: Redundant argument in SQRT') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'exp') THEN KOM3(NKOM)=15 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-20 CALL ERROR('GRDCAL-20: Redundant argument in EXP') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'alog' * .OR.LINE(KEQ+1:K-1).EQ.'log' * .OR.LINE(KEQ+1:K-1).EQ.'ln') THEN KOM3(NKOM)=16 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-21 CALL ERROR('GRDCAL-21: Redundant argument in ALOG') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'alog10' * .OR.LINE(KEQ+1:K-1).EQ.'log10') THEN KOM3(NKOM)=17 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-22 CALL ERROR('GRDCAL-22: Redundant argument in ALOG10') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'sin') THEN KOM3(NKOM)=18 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-23 CALL ERROR('GRDCAL-23: Redundant argument in SIN') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'cos') THEN KOM3(NKOM)=19 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-24 CALL ERROR('GRDCAL-24: Redundant argument in COS') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'tan') THEN KOM3(NKOM)=20 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-25 CALL ERROR('GRDCAL-25: Redundant argument in TAN') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'asin') THEN KOM3(NKOM)=21 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-26 CALL ERROR('GRDCAL-26: Redundant argument in ASIN') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'acos') THEN KOM3(NKOM)=22 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-27 CALL ERROR('GRDCAL-27: Redundant argument in ACOS') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'atan') THEN KOM3(NKOM)=23 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-28 CALL ERROR('GRDCAL-28: Redundant argument in ATAN') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'atan2') THEN KOM3(NKOM)=24 IF(KOM2(NKOM).EQ.0) THEN C GRDCAL-29 CALL ERROR * ('GRDCAL-29: Missing second argument of ATAN2') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'sinh') THEN KOM3(NKOM)=25 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-30 CALL ERROR('GRDCAL-30: Redundant argument in SINH') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'cosh') THEN KOM3(NKOM)=26 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-31 CALL ERROR('GRDCAL-31: Redundant argument in COSH') END IF ELSE IF(LINE(KEQ+1:K-1).EQ.'tanh') THEN KOM3(NKOM)=27 IF(KOM2(NKOM).NE.0) THEN C GRDCAL-32 CALL ERROR('GRDCAL-32: Redundant argument in TANH') END IF ELSE C GRDCAL-33 WRITE(*,'(2A)') ' ',LINE(KEQ:KEND) CALL ERROR ('GRDCAL-33: Unknown function') END IF C END IF END IF GO TO 11 19 CONTINUE CLOSE(LU1) C C Interpreting the constants: FORMAT='(F00.0)' * DO 20 I=2*NFILE+1,NNAME DO 20 I=1,NNAME IF(('0'.LE.NAME(I)(1:1).AND.NAME(I)(1:1).LE.'9').OR. * NAME(I)(1:1).EQ.'+'.OR.NAME(I)(1:1).EQ.'-'.OR. * NAME(I)(1:1).EQ.'.') THEN L=LENGTH(NAME(I)) FORMAT(3:3)=CHAR(ICHAR('0')+L/10) FORMAT(4:4)=CHAR(ICHAR('0')+MOD(L,10)) READ(NAME(I),FORMAT) RNAME(I) ELSE CALL RSEP3R(NAME(I),RNAME(I),0.) END IF 20 CONTINUE C C....................................................................... C C Logical variable identifying whether grid values must be split C into individual time levels to fit in the RAM: LARRAY=.FALSE. C DO 21 IFILE=1,MFILE KGRID0(IFILE)=-1 KGRID1(IFILE)=-1 21 CONTINUE C C Determining storage for input grid values: IGRID=0 DO 33 JFILE=1,2*MFILE IFILE=MOD(JFILE-1,MFILE)+1 DO 31 IKOM=1,NKOM IF(KOM1(IKOM).EQ.JFILE.OR.KOM2(IKOM).EQ.JFILE) THEN C File appears at the R.H.S. of the command: IF(FILE(IFILE).EQ.' ') THEN C GRDCAL-34 CALL ERROR('GRDCAL-34: Blank filename of input grid') END IF IF(JFILE.LE.MFILE) THEN C Space grid ($) on input, C calculation must be split into individual time levels IF(N4.GT.1) THEN LARRAY=.TRUE. END IF ELSE IF(KGRID1(IFILE).GE.0) THEN C GRDCAL-41 CALL ERROR('GRDCAL-41: $ and @ for the same input file') C Coinciding input space ($) and space-time (@) data cubes END IF END IF KGRID1(IFILE)=IGRID IGRID=IGRID+N1*N2*N3 GO TO 32 END IF 31 CONTINUE 32 CONTINUE C-530 IF(JFILE.EQ.MFILE) THEN C The part of RAM reserved for input spatial grids ($-files): C-530 JGRID=IGRID C-530 END IF 33 CONTINUE IF(IGRID.GT.MRAM) THEN C GRDCAL-35 CALL ERROR('GRDCAL-35: Insufficient memory for input grids') C Dimension MRAM of array RAM in include file C ram.inc should probably be increased C to accommodate all input grids. END IF IF(IGRID*N4.GT.MRAM) THEN C Grid values must be split into individual time levels LARRAY=.TRUE. END IF C C Determining storage for output grid values: *530 IF(N4.LE.1) THEN *530 IGRID=0 *530 ELSE C Protecting the part of RAM with input spatial grids ($-files): *530 IGRID=JGRID *530 END IF DO 43 JFILE=1,2*MFILE IFILE=MOD(JFILE-1,MFILE)+1 DO 41 IKOM=1,NKOM IF(KOM0(IKOM).EQ.JFILE) THEN C File appears at the L.H.S. of the command: IF(FILE(IFILE).EQ.' ') THEN C GRDCAL-36 CALL ERROR('GRDCAL-36: Blank filename of output grid') END IF IF(JFILE.LE.MFILE) THEN C Space grid ($) on output, C calculation must be split into individual time levels IF(N4.GT.1) THEN LARRAY=.TRUE. END IF ELSE IF(KGRID0(IFILE).GE.0) THEN C GRDCAL-42 CALL ERROR * ('GRDCAL-42: $ and @ for the same output file') C Coinciding output space ($) and space-time (@) data C cubes. END IF END IF IF(KGRID1(IFILE).GE.0) THEN KGRID0(IFILE)=KGRID1(IFILE) ELSE KGRID0(IFILE)=IGRID IGRID=IGRID+N1*N2*N3 END IF GO TO 42 END IF 41 CONTINUE 42 CONTINUE 43 CONTINUE IF(IGRID.GT.MRAM) THEN C GRDCAL-37 CALL ERROR('GRDCAL-37: Insufficient memory for output grids') C Dimension MRAM of array RAM in include file C ram.inc should probably be increased C to accommodate all output grids. END IF IF(IGRID*N4.GT.MRAM) THEN C Grid values must be split into individual time levels LARRAY=.TRUE. END IF IF(LARRAY) THEN NGRID=N1*N2*N3 NTIME=N4 ELSE NGRID=N1*N2*N3*N4 NTIME=1 DO 44 IFILE=1,MFILE KGRID0(IFILE)=KGRID0(IFILE)*N4 KGRID1(IFILE)=KGRID1(IFILE)*N4 44 CONTINUE END IF C C Loop over time slices: DO 900 ITIME=1,NTIME C C Reading input grid values: C 3-D space grids ($) IF(ITIME.EQ.1) THEN DO 53 IFILE=1,MFILE DO 51 IKOM=1,NKOM IF(KOM1(IKOM).EQ.IFILE.OR.KOM2(IKOM).EQ.IFILE) THEN C File appears at the R.H.S. of the command: IF (MATRIX.LT.0) THEN CALL RARRAY(LU(IFILE),FILE(IFILE),'FORMATTED',.TRUE., * UNDEF,N1*N2*N3, GRID(KGRID1(IFILE)+1)) ELSE CALL RMAT(LU(IFILE),FILE(IFILE), * M1,MATRIX*N2*N3,GRID(KGRID1(IFILE)+1)) ENDIF GO TO 52 END IF 51 CONTINUE 52 CONTINUE 53 CONTINUE END IF C 4-D space-time grids (@) DO 58 JFILE=MFILE+1,2*MFILE IFILE=MOD(JFILE-1,MFILE)+1 DO 56 IKOM=1,NKOM IF(KOM1(IKOM).EQ.JFILE.OR.KOM2(IKOM).EQ.JFILE) THEN C File appears at the R.H.S. of the command: IF(LARRAY) THEN DO 54 I=1,NKOM IF(KOM0(I).EQ.IFILE.OR.KOM0(I).EQ.JFILE) THEN C C GRDCAL-40 CALL ERROR('GRDCAL-40: Same input and output files') C If the grid is as huge as it must be stored in RAM C by individual time slices, the output filenames cannot C coincide with input filenames. END IF 54 CONTINUE IF(ITIME.EQ.1) THEN IF (MATRIX.LT.0) THEN OPEN(LU(IFILE),FILE=FILE(IFILE),FORM='FORMATTED') ELSE CALL OMAT(LU(IFILE),FILE(IFILE),1,FORMM) END IF END IF IF (MATRIX.LT.0) THEN CALL RARRAY(LU(IFILE),' ' ,'FORMATTED',.TRUE.,UNDEF, * N1*N2*N3, GRID(KGRID1(IFILE)+1)) ELSE CALL RMAT(LU(IFILE),' ', * M1,MATRIX*N2*N3,GRID(KGRID1(IFILE)+1)) ENDIF IF(ITIME.EQ.NTIME) THEN CLOSE(LU(IFILE)) END IF ELSE IF (MATRIX.LT.0) THEN CALL RARAY(LU1,FILE(IFILE),'FORMATTED',.TRUE.,UNDEF, * N1*N2*N3,N4,GRID(KGRID1(IFILE)+1)) ELSE CALL OMAT(LU1,FILE(IFILE),1,FORMM) DO 55 I=0,N4-1 CALL RMAT(LU1,' ', * M1,MATRIX*N2*N3,GRID(KGRID1(IFILE)+N1*N2*N3*I+1)) 55 CONTINUE CLOSE(LU1) ENDIF END IF GO TO 57 END IF 56 CONTINUE 57 CONTINUE 58 CONTINUE C C....................................................................... C C Performing grid calculations: IF(ITIME.EQ.1) THEN IF(LARRAY) THEN WRITE(*,'(A)') * '+GRDCAL: Reading, calculating, writing... ' ELSE WRITE(*,'(A)') * '+GRDCAL: Calculating... ' END IF END IF C C Loop for gridpoints: DO 202 IGRID=1,NGRID C C Loop for individual commands: DO 201 IKOM=1,NKOM I0=KOM0(IKOM) I1=KOM1(IKOM) I2=KOM2(IKOM) LUNDEF=.FALSE. IF(I1.LE.2*MFILE) THEN IF(I1.LE.MFILE) THEN RNAME(I1)=GRID(KGRID1(I1)+IGRID) ELSE RNAME(I1)=GRID(KGRID1(I1-MFILE)+IGRID) END IF END IF IF(RNAME(I1).EQ.UNDEF) THEN LUNDEF=.TRUE. END IF IF(I2.GT.0) THEN IF(I2.LE.2*MFILE) THEN IF(I2.LE.MFILE) THEN RNAME(I2)=GRID(KGRID1(I2)+IGRID) ELSE RNAME(I2)=GRID(KGRID1(I2-MFILE)+IGRID) END IF END IF IF(RNAME(I2).EQ.UNDEF) THEN LUNDEF=.TRUE. END IF END IF IF(LUNDEF) THEN RNAME(I0)=UNDEF ELSE C GO TO (101,102,103,104,105,106,107,108,109,110, * 111,112,113,114,115,116,117,118,119,120, * 121,122,123,124,125,126,127) KOM3(IKOM) RNAME(I0)=RNAME(I1) GO TO 199 101 CONTINUE RNAME(I0)=RNAME(I1)+RNAME(I2) GO TO 199 102 CONTINUE RNAME(I0)=RNAME(I1)-RNAME(I2) GO TO 199 103 CONTINUE RNAME(I0)=RNAME(I1)*RNAME(I2) GO TO 199 104 CONTINUE IF(RNAME(I2).EQ.0.) THEN IF(RNAME(I1).EQ.0.) THEN RNAME(I0)=0. ELSE RNAME(I0)=UNDEF END IF ELSE RNAME(I0)=RNAME(I1)/RNAME(I2) END IF GO TO 199 105 CONTINUE IF(RNAME(I1).LT.0.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=RNAME(I1)**RNAME(I2) END IF GO TO 199 106 CONTINUE RNAME(I0)=ABS(RNAME(I1)) GO TO 199 107 CONTINUE RNAME(I0)=AINT(RNAME(I1)) GO TO 199 108 CONTINUE RNAME(I0)=ANINT(RNAME(I1)) GO TO 199 109 CONTINUE IF(RNAME(I2).EQ.0.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=AMOD(RNAME(I1),RNAME(I2)) END IF GO TO 199 110 CONTINUE RNAME(I0)=SIGN(RNAME(I1),RNAME(I2)) GO TO 199 111 CONTINUE RNAME(I0)=DIM(RNAME(I1),RNAME(I2)) GO TO 199 112 CONTINUE RNAME(I0)=AMAX1(RNAME(I1),RNAME(I2)) GO TO 199 113 CONTINUE RNAME(I0)=AMIN1(RNAME(I1),RNAME(I2)) GO TO 199 114 CONTINUE IF(RNAME(I1).LT.0.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=SQRT(RNAME(I1)) END IF GO TO 199 115 CONTINUE RNAME(I0)=EXP(RNAME(I1)) GO TO 199 116 CONTINUE IF(RNAME(I1).LE.0.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=ALOG(RNAME(I1)) END IF GO TO 199 117 CONTINUE IF(RNAME(I1).LE.0.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=ALOG10(RNAME(I1)) END IF GO TO 199 118 CONTINUE RNAME(I0)=SIN(RNAME(I1)) GO TO 199 119 CONTINUE RNAME(I0)=COS(RNAME(I1)) GO TO 199 120 CONTINUE RNAME(I0)=TAN(RNAME(I1)) GO TO 199 121 CONTINUE IF(ABS(RNAME(I1)).GT.1.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=ASIN(RNAME(I1)) END IF GO TO 199 122 CONTINUE IF(ABS(RNAME(I1)).GT.1.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=ACOS(RNAME(I1)) END IF GO TO 199 123 CONTINUE IF(ABS(RNAME(I1)).GT.1.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=ATAN(RNAME(I1)) END IF GO TO 199 124 CONTINUE IF(RNAME(I1).EQ.0..AND.RNAME(I2).EQ.0.) THEN RNAME(I0)=UNDEF ELSE RNAME(I0)=ATAN2(RNAME(I1),RNAME(I2)) END IF GO TO 199 125 CONTINUE RNAME(I0)=SINH(RNAME(I1)) GO TO 199 126 CONTINUE RNAME(I0)=COSH(RNAME(I1)) GO TO 199 127 CONTINUE RNAME(I0)=TANH(RNAME(I1)) GO TO 199 199 CONTINUE END IF C IF(I0.LE.2*MFILE) THEN IF(I0.LE.MFILE) THEN GRID(KGRID0(I0)+IGRID)=RNAME(I0) ELSE GRID(KGRID0(I0-MFILE)+IGRID)=RNAME(I0) END IF END IF 201 CONTINUE C 202 CONTINUE C C....................................................................... C C Writing output grid values: DO 339 JFILE=1,2*MFILE IFILE=MOD(JFILE-1,MFILE)+1 DO 337 IKOM=1,NKOM IF(KOM0(IKOM).EQ.JFILE) THEN C File appears at the L.H.S. of the command: IF(KOM3(IKOM).EQ.7.OR.KOM3(IKOM).EQ.8) THEN C Integer values (Results of function INT or NINT): DO 331 I=KGRID0(IFILE)+1,KGRID0(IFILE)+NGRID IF(GRID(I).EQ.UNDEF) THEN IRAM(I)=IUNDEF ELSE IRAM(I)=NINT(GRID(I)) END IF 331 CONTINUE IF(LARRAY) THEN IF(ITIME.EQ.1.OR.JFILE.GT.MFILE) THEN IF(ITIME.EQ.1) THEN OPEN(LU(IFILE),FILE=FILE(IFILE),FORM='FORMATTED') END IF CALL WARRAI(LU(IFILE),' ','FORMATTED',.TRUE.,IUNDEF, * .FALSE.,0 ,N1*N2*N3, IRAM(KGRID0(IFILE)+1)) IF(ITIME.EQ.NTIME.OR.JFILE.LE.MFILE) THEN CLOSE(LU(IFILE)) END IF END IF ELSE CALL WARAI(LU1,FILE(IFILE),'FORMATTED',.TRUE.,IUNDEF, * .FALSE.,0 ,N1*N2*N3,N4,IRAM(KGRID0(IFILE)+1)) END IF ELSE C Output values may be real-valued: IF(LARRAY) THEN IF(ITIME.EQ.1.OR.JFILE.GT.MFILE) THEN IF(ITIME.EQ.1) THEN IF(MATRIX.LT.0) THEN OPEN(LU(IFILE),FILE=FILE(IFILE),FORM='FORMATTED') ELSE CALL OMAT(LU(IFILE),FILE(IFILE),2,FORMM) END IF END IF IF(MATRIX.LT.0) THEN CALL WARRAY(LU(IFILE),' ','FORMATTED',.TRUE.,UNDEF, * .FALSE.,0.,N1*N2*N3, GRID(KGRID0(IFILE)+1)) ELSE DO 333 I=KGRID0(IFILE)+1,KGRID0(IFILE)+N1*N2*N3 IF(GRID(I).EQ.UNDEF) THEN C C GRDCAL-43 CALL ERROR('GRDCAL-43: Undefined matrix element') C Undefined values are not allowed during matrix C operations, unlike for the grid operations. END IF 333 CONTINUE CALL WMAT(LU(IFILE),' ', * M1,MATRIX*N2*N3,GRID(KGRID0(IFILE)+1)) END IF IF(ITIME.EQ.NTIME.OR.JFILE.LE.MFILE) THEN CLOSE(LU(IFILE)) END IF END IF ELSE IF(MATRIX.LT.0) THEN CALL WARAY(LU1,FILE(IFILE),'FORMATTED',.TRUE.,UNDEF, * .FALSE.,0.,N1*N2*N3,N4,GRID(KGRID0(IFILE)+1)) ELSE DO 334 I=KGRID0(IFILE)+1,KGRID0(IFILE)+N1*N2*N3*N4 IF(GRID(I).EQ.UNDEF) THEN C C GRDCAL-44 CALL ERROR('GRDCAL-44: Undefined matrix element') C Undefined values are not allowed during matrix C operations, unlike for the grid operations. END IF 334 CONTINUE CALL OMAT(LU1,FILE(IFILE),2,FORMM) DO 335 I=0,N4-1 CALL WMAT(LU1,' ', * M1,MATRIX*N2*N3,GRID(KGRID0(IFILE)+N1*N2*N3*I+1)) 335 CONTINUE CLOSE(LU1) END IF END IF END IF GO TO 338 END IF 337 CONTINUE 338 CONTINUE 339 CONTINUE C 900 CONTINUE WRITE(*,'(A)') * '+GRDCAL: Done. ' STOP END C C======================================================================= C C C SUBROUTINE REGNAM(NAME0,NAME,MNAME,NNAME,KOM) C INTEGER MNAME,NNAME,KOM CHARACTER*(*) NAME0,NAME(MNAME) C C----------------------------------------------------------------------- C INTEGER INAME C DO 10 INAME=1,NNAME IF(NAME(INAME).EQ.NAME0) THEN KOM=INAME GO TO 20 END IF 10 CONTINUE NNAME=NNAME+1 IF(NNAME.GT.MNAME) THEN C GRDCAL-38 CALL ERROR('GRDCAL-38: Insufficient memory for variable names') C Maximum number MNAME of variables used in the command file C should probably be increased. MNAME is declared by the C PARAMETER statement. END IF NAME(NNAME)=NAME0 KOM=NNAME C 20 CONTINUE RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdckn.for 0100666 0000765 0000765 00000020313 07054147734 012423 0 ustar bulant bulant C
C Program GRDCKN to compute the values of the Von Karman correlation C function according to the formula (K.4) of the paper Klimes, L.: C Correlation functions of random media. In: Seismic waves in 3-D C structures, Report 6, Department of Geophysics, Charles C University, Prague (1997). C C Version: 5.40 C Date: 2000, February 21 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data for the correlation function: C NDIM=positive integer ... Spatial dimension. C Default: NDIM equal to the dimension of the input grid. C KAPPA=real ... Multiplicative factor. C Default: KAPPA=1. C POWERN=real... Exponent or index related to fractal dimension: C Medium is self-affine at distances L: C ACORG .LT. L .LT. ACOR C Reasonable values for geology: -0.5 .LT. POWERN .LT. 0.0 C Default: POWERN=0.0 C ACOR=positive real... Von Karman (large-scale) correlation length: C Suppresses large heterogeneities (larger than ACOR) C Default: ACOR=999999. (infinity) C CKNMAX=real ... Maximum value of the correlation function. C Default: CKNMAX=999999. (infinity) C Names of input and output formatted files: C PTS='string' ... Name of the file with coordinates of point X0 C in the form PTS. C Default: PTS=' ' means that the coordinates are [0.,0.,0]. C CKNOUT='string'... Name of the output file with the values C of the Von Karman correlation function in gridpoints. C Default: CKNOUT='ckn.out' C For general description of the files with gridded data refer to C file forms.htm. C Data specifying the parameters of the grid: C O1=real, O2=real, O3=real ... Coordinates of the origin of the C grid. C Default: O1=0. O2=0. O3=0. C D1=real... Grid interval along the X1 axis. C Default: D1=0. C D2=real... Grid interval along the X2 axis. C Default: D2=0. C D3=real... Grid interval along the X3 axis. C Default: D3=0. C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I,RMAT,WMAT,GAMMLN,BESSIK REAL GAMMLN C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... C File sep.for. C RMAT,WMAT ... File forms.for. C GAMMLN ... File gammln.for. C BESSIK ... File bessik.for. C INTEGER NDIM REAL DIM,KAPPA,VN,ACOR,CKNMAX CHARACTER*80 FILSEP,FILEX0,FILOUT INTEGER LU1,LU2 PARAMETER (LU1=1,LU2=2) CHARACTER*3 TEXT INTEGER IGROUP,K1,K2,K3,N1,N2,N3,I1,I2,I3 INTEGER MX PARAMETER (MX=300) REAL X(MX,3),COOR(3) REAL PI PARAMETER (PI=3.1415926) REAL XX,GAMMA,CKN0,CKN,RI,RK,RIP,RKP REAL O1,O2,O3,D1,D2,D3 REAL X01,X02,X03 C----------------------------------------------------------------------- C C Reading a name of the file with the input data: FILSEP=' ' WRITE(*,'(A)') '+GRDCKN: Enter input filename: ' READ(*,*) FILSEP C C Reading all data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C GRDCKN-01 CALL ERROR('GRDCKN-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C WRITE(*,'(A)') '+GRDCKN: Working ... ' C C Reading the file with coordinates of point X0: CALL RSEP3T('PTS',FILEX0,' ') IF (FILEX0.NE.' ') THEN OPEN(LU1,FILE=FILEX0,STATUS='OLD') READ(LU1,*) (TEXT,I1=1,20) READ(LU1,*) TEXT,X01,X02,X03 CLOSE(LU1) ELSE X01=0. X02=0. X03=0. ENDIF C Reading the values describing the grid: CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) C Reading filename of the output file: CALL RSEP3T('CKNOUT',FILOUT,'ckn.out') C Reading numerical constants: NDIM=3 IF (N1.EQ.1) NDIM=NDIM-1 IF (N2.EQ.1) NDIM=NDIM-1 IF (N3.EQ.1) NDIM=NDIM-1 IF (NDIM.EQ.0) NDIM=NDIM+1 I1=NDIM CALL RSEP3I('NDIM',NDIM,I1) DIM=FLOAT(NDIM) CALL RSEP3R('KAPPA',KAPPA,1.) CALL RSEP3R('POWERN',VN,0.) CALL RSEP3R('ACOR',ACOR,999999.) CALL RSEP3R('CKNMAX',CKNMAX,999999.) IF (ACOR.LE.0.) THEN C GRDCKN-02 CALL ERROR('GRDCKN-02: ACOR less or equal zero.') ENDIF C C Computing the value of the Gamma function: GAMMA=EXP(GAMMLN(DIM/2.+VN)) C Computing the x-independent part of the correlation function: CKN0=KAPPA*KAPPA*2.**(1.-DIM-VN)*PI**(-DIM/2.)/GAMMA*ACOR**VN CKN=0. C OPEN(LU2,FILE=FILOUT) C Loop over points x: DO 23 I3=1,N3 COOR(3)=O3+FLOAT(I3-1)*D3 DO 22 I2=1,N2 COOR(2)=O2+FLOAT(I2-1)*D2 DO 21 I1=1,N1 COOR(1)=O1+FLOAT(I1-1)*D1 XX=SQRT((COOR(1)-X01)**2+(COOR(2)-X02)**2+(COOR(3)-X03)**2) IF (XX.NE.0.) THEN C Computing the value of the MacDonald function: CALL BESSIK(XX/ACOR,ABS(VN),RI,RK,RIP,RKP) C Computing the correlation function: CKN=CKN0*XX**VN*RK ELSE CKN=CKNMAX ENDIF IF (CKN.GT.CKNMAX) CKN=CKNMAX WRITE(LU2,*) CKN 21 CONTINUE 22 CONTINUE 23 CONTINUE WRITE(LU2,*) '/' CLOSE(LU2) WRITE(*,'(A)') '+GRDCKN: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for INCLUDE 'sep.for' C sep.for INCLUDE 'gammln.for' C gammln.for INCLUDE 'bessik.for' C bessik.for INCLUDE 'beschb.for' C beschb.for INCLUDE 'chebev.for' C chebev.for C C======================================================================= Cgrdcor.for 0100666 0000765 0000765 00000023254 07345336504 012440 0 ustar bulant bulant C
C Program GRDCOR to compute the values of the spectral filter C according to the formula (3.1) of the paper Klimes, L.: C Correlation functions of random media. In: Seismic waves in 3-D C structures, Report 6, Department of Geophysics, Charles University, C Prague (1997). C C Version: 5.60 C Date: 2001, September 5 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying the parameters of the grid: C O1=real, O2=real, O3=real ... Coordinates of the origin of the C grid. C Default: O1=0. O2=0. O3=0. C D1=real... Grid interval along the X1 axis. C Default: D1=0. C D2=real... Grid interval along the X2 axis. C Default: D2=0. C D3=real... Grid interval along the X3 axis. C Default: D3=0. C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C Data for the spectral filter: C NDIM=positive integer ... Spatial dimension. C Default: NDIM equal to the dimension of the above grid. C KAPPA=real ... Multiplicative factor. C Default: KAPPA=1. C POWERN=real ... Exponent or index related to fractal dimension: C Medium is self-affine at distances L: C ACORG .LT. L .LT. ACOR C Reasonable values for geology: -0.5 .LT. POWERN .LT. 0.0 C Default: POWERN=0.0 C ACORG=nonnegative real ... Gaussian (small-scale) correlation C length: C Removes small details (smaller than ACORG). C Default: ACORG=0.0 C ACOR=positive real .. Von Karman (large-scale) correlation length: C Suppresses large heterogeneities (larger than ACOR). C Default: ACOR=999999. (infinity) C Data for the cosine filter: C AMIN=nonnegative real... Minimum wavelength. All wavelengths C shorter than AMIN are removed. C Default: AMIN=0. C AMAX=nonnegative real... Maximum wavelength. C Default: AMAX=999999. (infinity) C ASMALL=nonnegative real... Refer to ABIG. C Default: ASMALL=0. C ABIG=nonnegative real C Default: ABIG=999999. (infinity) C The cosine filter has value 0. at wavenumbers smaller than C 2*PI/AMAX (i.e. at wavelengths longer than AMAX), C rises between 2*PI/AMAX and 2*PI/ABIG, C equals 1 between 2*PI/ABIG and 2*PI/ASMALL, C tapers off between 2*PI/ASMALL and 2*PI/AMIN, C and is zero at wavenumbers greater than 2*PI/AMIN C (i.e. at wavelengths shorter than AMIN). C Name of output formatted file with the computed values: C COROUT='string' C Default: COROUT='grdcor.out' C For general description of the files with gridded data refer to C file forms.htm. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I,WARRAY C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... C File sep.for. C WARRAY ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER NDIM REAL DIM,RKAPPA,POWERN,ACORG,ACOR,ACOR2,AMIN,ASMALL,ABIG,AMAX CHARACTER*80 FILSEP,FILOUT REAL PI PARAMETER (PI=3.141592653589793) INTEGER LU1 PARAMETER (LU1=1) INTEGER N1,N2,N3,I1,I2,I3,I4 REAL O1,O2,O3,D1,D2,D3 REAL XK1,XK2,XK3,XK,EX,CF C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDCOR: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C GRDCOR-05 CALL ERROR('GRDCOR-05: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C WRITE(*,'(A)') '+GRDCOR: Working ... ' C C Reading filename of the output file: CALL RSEP3T('COROUT',FILOUT,'grdcor.out') C Reading the values describing the grid: CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('D1',D1,0.) CALL RSEP3R('D2',D2,0.) CALL RSEP3R('D3',D3,0.) IF (((D1.EQ.0.).AND.(N1.NE.1)).OR. * ((D2.EQ.0.).AND.(N2.NE.1)).OR. * ((D3.EQ.0.).AND.(N3.NE.1))) THEN C GRDCOR-01 CALL ERROR('GRDCOR-01: Wrong input grid.') ENDIF IF ((D1.EQ.0.).AND.(N1.EQ.1)) D1=1. IF ((D2.EQ.0.).AND.(N2.EQ.1)) D2=1. IF ((D3.EQ.0.).AND.(N3.EQ.1)) D3=1. IF (N1*N2*N3.GT.MRAM) THEN C GRDCOR-02 CALL ERROR('GRDCOR-02: Small array RAM.') ENDIF C Reading numerical constants: NDIM=3 IF (N1.EQ.1) NDIM=NDIM-1 IF (N2.EQ.1) NDIM=NDIM-1 IF (N3.EQ.1) NDIM=NDIM-1 IF (NDIM.EQ.0) NDIM=NDIM+1 I1=NDIM CALL RSEP3I('NDIM',NDIM,I1) DIM=FLOAT(NDIM) CALL RSEP3R('KAPPA',RKAPPA,1.) CALL RSEP3R('POWERN',POWERN,0.) CALL RSEP3R('ACORG',ACORG,0.) IF (ACORG.LT.0.) THEN C GRDCOR-03 CALL ERROR('GRDCOR-03: ACORG less than zero.') ENDIF CALL RSEP3R('ACOR',ACOR,999999.) IF (ACOR.LE.0.) THEN C GRDCOR-04 CALL ERROR('GRDCOR-04: ACOR less than, or equal to zero.') ENDIF IF (ACOR.GT.999998.) THEN ACOR2=0. ELSE ACOR2=1./ACOR**2 ENDIF CALL RSEP3R('AMIN',AMIN,0.) CALL RSEP3R('ASMALL',ASMALL,0.) CALL RSEP3R('ABIG',ABIG,999999.) CALL RSEP3R('AMAX',AMAX,999999.) IF (AMIN.EQ.0.) THEN AMIN=999999. ELSE AMIN=2.*PI/AMIN ENDIF IF (ASMALL.EQ.0.) THEN ASMALL=999999. ELSE ASMALL=2.*PI/ASMALL ENDIF IF (ABIG.EQ.999999.) THEN ABIG=0. ELSE ABIG=2.*PI/ABIG ENDIF IF (AMAX.EQ.999999.) THEN AMAX=0. ELSE AMAX=2.*PI/AMAX ENDIF C EX=(-(DIM/2.+POWERN)/2.) I4=0 DO 30, I3=1,N3 DO 20, I2=1,N2 DO 10, I1=1,N1 I4=I4+1 XK1=O1+(I1-1)*D1 XK2=O2+(I2-1)*D2 XK3=O3+(I3-1)*D3 XK=SQRT(XK1**2+XK2**2+XK3**2) IF (ACOR.GT.999998..AND.EX.LT.0. * .AND.ABS(XK1).LT.0.1*D1 * .AND.ABS(XK2).LT.0.1*D2 * .AND.ABS(XK3).LT.0.1*D3) THEN C Nulling infinite value corresponding to zero wavenumber RAM(I4)=0. ELSE IF (EX.EQ.0.) THEN RAM(I4)=RKAPPA*EXP(-(ACORG*XK)**2/8.) ELSE RAM(I4)=RKAPPA*EXP(-(ACORG*XK)**2/8.)*(ACOR2+XK**2)**EX ENDIF C Cosine filter: IF ((XK.LE.AMAX).OR.(XK.GE.AMIN)) THEN CF=0. ELSEIF ((XK.GE.ABIG).AND.(XK.LE.ASMALL)) THEN CF=1. ELSEIF ((XK.GT.AMAX).AND.(XK.LT.ABIG)) THEN CF=.5 - .5*COS((XK-AMAX)/(ABIG-AMAX)*PI) ELSEIF ((XK.GT.ASMALL).AND.(XK.LT.AMIN)) THEN CF=.5 + .5*COS((XK-ASMALL)/(AMIN-ASMALL)*PI) ENDIF RAM(I4)=RAM(I4)*CF 10 CONTINUE 20 CONTINUE 30 CONTINUE IF (FILOUT.NE.' ') THEN CALL WARRAY(LU1,FILOUT,'FORMATTED',.FALSE.,0.,.FALSE.,0.,I4,RAM) ENDIF WRITE(*,'(A)') '+GRDCOR: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdfd.for 0100666 0000765 0000765 00000042274 07303642010 012233 0 ustar bulant bulant C
C Program GRDFD to calculate gradient of the grid values by means of the C second-order finite differences C C Version: 5.50 C Date: 2000, July 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 E-mail: klimes@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input and output files: C GRD='string'...Name of the input ASCII file with the grid values. C Default: GRD='grd.out' C GRD1='string', GRD2='string', GRD3='string'... The names C of the output ASCII files containing the first C partial derivatives in the respective directions. C Derivatives corresponding to a blank filename are not C evaluated. C Default: GRD1=' ', GRD2=' ', GRD3=' ' C GRD11='string', GRD22='string', GRD33='string'... The names C of the output ASCII files containing the homogeneous C second partial derivatives in the respective directions. C Derivatives corresponding to a blank filename are not C evaluated. C Default: GRD11=' ', GRD22=' ', GRD33=' ' C Data specifying grid dimensions: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C N4=positive integer... Number of time slices. C Default: N4=1 C D1=real... Grid interval in the direction of the first coordinate C axis. C Default: D1=1. C D2=real... Grid interval in the direction of the second coordinate C axis. C Default: D2=1. C D3=real... Grid interval in the direction of the third coordinate C axis. C Default: D3=1. C Data specific to this program: C NORDER=even positive integer... Order of finite difference scheme. C Only NORDER=2 is now coded. C Default: NORDER=2 C NHALF=integer... Kind of finite difference scheme: C NHALF=0: Ordinary centred 1-D scheme. Output grids have C the same dimensions as the input grid. C Differences at boundaries and in the vicinity of C undefined values are approximated by single-sided C differences. C Error of derivative F1 for NORDER=2: C Err(F1)=4*F111*D1**2/24 C NHALF=1: Half-interval 1-D scheme. Output grids have C dimensions: 'GRD1': (N1-1)*N2*N3 C 'GRD2': N1*(N2-1)*N3 C 'GRD3': N1*N2*(N3-1) C Error of derivative F1 for NORDER=2: C Err(F1)= F111*D1**2/24 C NHALF=2: Averaged half-interval 1-D schemes. Output grids C have dimensions (N1-1)*(N2-1)*(N3-1) gridpoints C if N1, N2 and N3 are greater than 1. C Naturally, any dimension Ni=1 is not changed. C Error of derivative F1 for NORDER=2: C Err(F1)=(F111*D1**2+F122*D2**2+F122*D2**2)/24 C Only NHALF=0 is now coded. C Default: NHALF=0 C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C C Filenames and parameters: CHARACTER*80 FILE1,FILE2,FILE3,FILE4,FILE5,FILE6,FILE7 INTEGER LU1,LU2,LU3,LU4,LU5,LU6,LU7 REAL UNDEF PARAMETER (LU1=1,LU2=2,LU3=3,LU4=4,LU5=11,LU6=12,LU7=13) PARAMETER (UNDEF=-999999.) C Input data: INTEGER N1,N2,N3,N4,NORDER,NHALF REAL D1,D2,D3 C Other variables: INTEGER N12,N123,N1234,I1,I2,I3,I4,I,J,J1 REAL D,DD,F1,F2,F3 C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDFD: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 WRITE(*,'(A)') '+GRDFD: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILE1.NE.' ') THEN CALL RSEP1(LU1,FILE1) ELSE C GRDFD-01 CALL ERROR('GRDFD-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('GRD' ,FILE1,' ') CALL RSEP3T('GRD1' ,FILE2,' ') CALL RSEP3T('GRD2' ,FILE3,' ') CALL RSEP3T('GRD3' ,FILE4,' ') CALL RSEP3T('GRD11',FILE5,' ') CALL RSEP3T('GRD22',FILE6,' ') CALL RSEP3T('GRD33',FILE7,' ') IF (FILE1.EQ.' ') THEN C GRDFD-11 CALL ERROR('GRDFD-11: File GRD not specified') C Name of the input grid file, specified by SEP parameter GRD C is blank or not specified. It must be specified. C There is no default filename. C See the description of input data SEP. ENDIF C C Reading grid dimensions: C Original grid: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3I('N4',N4,1) CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) N12 =N1*N2 N123 =N1*N2*N3 C4 N1234=N1*N2*N3*N4 N1234=N1*N2*N3 IF(2*N1234.GT.MRAM) THEN C GRDFD-02 CALL ERROR('GRDFD-02: Too small array RAM(MRAM)') C Too small array RAM(MRAM) to allocate both input and output C grid values. If possible, increase dimension MRAM in include C file ram.inc. END IF C C Reading parameters of FD scheme: CALL RSEP3I('NORDER',NORDER,2) IF(NORDER.EQ.2) THEN CONTINUE ELSE C GRDFD-03 CALL ERROR('GRDFD-03: Incorrect value of NORDER') C Allowed values of input parameter NORDER: 2. C See the description of input data SEP. END IF CALL RSEP3I('NHALF',NHALF,0) IF(NHALF.EQ.0) THEN CONTINUE ccc ELSE IF(NHALF.EQ.1) THEN ccc CONTINUE ccc ELSE IF(NHALF.EQ.2) THEN ccc CONTINUE ELSE C GRDFD-04 CALL ERROR('GRDFD-04: Incorrect value of NHALF') C Allowed values of input parameter NHALF: 0. C See the description of input data SEP. END IF C C Opening input and output files: OPEN(LU1,FILE=FILE1,FORM='FORMATTED',STATUS='OLD') IF(FILE2.NE.' ') THEN OPEN(LU2,FILE=FILE2,FORM='FORMATTED') END IF IF(FILE3.NE.' ') THEN OPEN(LU3,FILE=FILE3,FORM='FORMATTED') END IF IF(FILE4.NE.' ') THEN OPEN(LU4,FILE=FILE4,FORM='FORMATTED') END IF IF(FILE5.NE.' ') THEN OPEN(LU5,FILE=FILE5,FORM='FORMATTED') END IF IF(FILE6.NE.' ') THEN OPEN(LU6,FILE=FILE6,FORM='FORMATTED') END IF IF(FILE7.NE.' ') THEN OPEN(LU7,FILE=FILE7,FORM='FORMATTED') END IF C C Loop over time levels: DO 90 I4=0,N4-1 CALL RARRAY(LU1,' ','FORMATTED',.TRUE.,UNDEF,N1234,RAM) C C Calculating X1 derivatives: IF(FILE2.NE.' ') THEN IF(N1.LT.2) THEN C GRDFD-05 CALL ERROR('GRDFD-05: N1 is less than 2') END IF D=D1 DD=2.*D I=0 J=N1234 DO 13 I3=1,N3 DO 12 I2=1,N2 I=I+1 J=J+1 F2=RAM(I) F3=RAM(I+1) IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF DO 11 I1=2,N1-1 I=I+1 J=J+1 F1=F2 F2=F3 F3=RAM(I+1) IF(F1.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F1)/DD ELSE IF(F1.NE.UNDEF.AND.F2.NE.UNDEF) THEN RAM(J)=(F2-F1)/D ELSE IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF 11 CONTINUE I=I+1 J=J+1 IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF 12 CONTINUE 13 CONTINUE C Writing output grid values: CALL WARRAY(LU2,' ','FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1234,RAM(N1234+1)) END IF C C Calculating X11 derivatives: IF(FILE5.NE.' ') THEN IF(N1.LT.3) THEN C GRDFD-06 CALL ERROR('GRDFD-06: N1 is less than 3') END IF DD=D1*D1 I=0 J=N1234 DO 18 I3=1,N3 DO 17 I2=1,N2 I=I+1 J=J+1 F2=RAM(I) F3=RAM(I+1) J1=J DO 16 I1=2,N1-1 I=I+1 J=J+1 F1=F2 F2=F3 F3=RAM(I+1) IF(F1.NE.UNDEF.AND.F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F1-F2-F2+F3)/DD ELSE RAM(J)=UNDEF END IF 16 CONTINUE I=I+1 J=J+1 RAM(J1)=RAM(J1+1) RAM(J)=RAM(J-1) 17 CONTINUE 18 CONTINUE C Writing output grid values: CALL WARRAY(LU5,' ','FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1234,RAM(N1234+1)) END IF C C Calculating X2 derivatives: IF(FILE3.NE.' ') THEN IF(N2.LT.2) THEN C GRDFD-07 CALL ERROR('GRDFD-07: N2 is less than 2') END IF D=D2 DD=2.*D DO 23 I3=0,N3-1 DO 22 I1=1,N1 I=I3*N12+I1 J=N1234+I F2=RAM(I) F3=RAM(I+N1) IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF DO 21 I2=1,N2-2 I=I+N1 J=J+N1 F1=F2 F2=F3 F3=RAM(I+N1) IF(F1.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F1)/DD ELSE IF(F1.NE.UNDEF.AND.F2.NE.UNDEF) THEN RAM(J)=(F2-F1)/D ELSE IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF 21 CONTINUE I=I+N1 J=J+N1 IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF 22 CONTINUE 23 CONTINUE C Writing output grid values: CALL WARRAY(LU3,' ','FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1234,RAM(N1234+1)) END IF C C Calculating X22 derivatives: IF(FILE6.NE.' ') THEN IF(N2.LT.3) THEN C GRDFD-08 CALL ERROR('GRDFD-08: N2 is less than 3') END IF DD=D2*D2 DO 28 I3=0,N3-1 DO 27 I1=1,N1 I=I3*N12+I1 J=N1234+I F2=RAM(I) F3=RAM(I+N1) J1=J DO 26 I2=1,N2-2 I=I+N1 J=J+N1 F1=F2 F2=F3 F3=RAM(I+N1) IF(F1.NE.UNDEF.AND.F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F1-F2-F2+F3)/DD ELSE RAM(J)=UNDEF END IF 26 CONTINUE I=I+N1 J=J+N1 RAM(J1)=RAM(J1+N1) RAM(J)=RAM(J-N1) 27 CONTINUE 28 CONTINUE C Writing output grid values: CALL WARRAY(LU6,' ','FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1234,RAM(N1234+1)) END IF C C Calculating X3 derivatives: IF(FILE4.NE.' ') THEN IF(N3.LT.2) THEN C GRDFD-09 CALL ERROR('GRDFD-09: N3 is less than 2') END IF D=D3 DD=2.*D DO 33 I2=0,N2-1 DO 32 I1=1,N1 I=I2*N1+I1 J=N1234+I F2=RAM(I) F3=RAM(I+N12) IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF DO 31 I3=1,N3-2 I=I+N12 J=J+N12 F1=F2 F2=F3 F3=RAM(I+N12) IF(F1.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F1)/DD ELSE IF(F1.NE.UNDEF.AND.F2.NE.UNDEF) THEN RAM(J)=(F2-F1)/D ELSE IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF 31 CONTINUE I=I+N12 J=J+N12 IF(F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F3-F2)/D ELSE RAM(J)=UNDEF END IF 32 CONTINUE 33 CONTINUE C Writing output grid values: CALL WARRAY(LU4,' ','FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1234,RAM(N1234+1)) END IF C C Calculating X33 derivatives: IF(FILE7.NE.' ') THEN IF(N3.LT.3) THEN C GRDFD-10 CALL ERROR('GRDFD-10: N3 is less than 3') END IF DD=D3*D3 DO 38 I2=0,N2-1 DO 37 I1=1,N1 I=I2*N1+I1 J=N1234+I F2=RAM(I) F3=RAM(I+N12) J1=J DO 36 I3=1,N3-2 I=I+N12 J=J+N12 F1=F2 F2=F3 F3=RAM(I+N12) IF(F1.NE.UNDEF.AND.F2.NE.UNDEF.AND.F3.NE.UNDEF) THEN RAM(J)=(F1-F2-F2+F3)/DD ELSE RAM(J)=UNDEF END IF 36 CONTINUE I=I+N12 J=J+N12 RAM(J1)=RAM(J1+N12) RAM(J)=RAM(J-N12) 37 CONTINUE 38 CONTINUE C Writing output grid values: CALL WARRAY(LU7,' ','FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1234,RAM(N1234+1)) END IF C 90 CONTINUE CLOSE(LU1) IF(FILE2.NE.' ') THEN CLOSE(LU2) END IF IF(FILE3.NE.' ') THEN CLOSE(LU3) END IF IF(FILE4.NE.' ') THEN CLOSE(LU4) END IF IF(FILE2.NE.' ') THEN CLOSE(LU5) END IF IF(FILE3.NE.' ') THEN CLOSE(LU6) END IF IF(FILE4.NE.' ') THEN CLOSE(LU7) END IF WRITE(*,'(A)') * '+GRDFD: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C length.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdfft.for 0100666 0000765 0000765 00000070066 10062244274 012427 0 ustar bulant bulant C
C Program GRDFFT to compute the 1-D, 2-D or 3-D Fourier transformation C of a complex function defined on 1-D, 2-D or 3-D grid of points. C (The dimension of the FFT is less or equal to the grid dimension.) C If the number of gridpoints in any direction of the input grid is not C a power of 2, the input grid is enlarged to the nearest power of 2 C and the functional values in new gridpoints are completed according C to input parameter FFTFIL. C Subroutines from the Numerical Recipes are then used C for the entire FFT. C C Version: 5.80 C Date: 2004, June 11 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C----------------------------------------------------------------------- C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Parameter describing the form of the FFT: C FFT=real ... The Fourier transform F(y) has the form of integral C of f(x)exp(i*FFT*x*y)dx, where f(x) is the input function C to be transformed. The integral is then multiplied by the C factor of (ABS(FFT)/(2.*PI))**(NDIM/2), where NDIM is the C dimension of the part of the input grid to be transformed C (and of the transformed grid). C The mostly used values of FFT are 6.28, -6.28, 1, -1. C If FFT is input as a multiple of PI plus minus 1%, the C value of FFT is rounded to the multiple of PI. C Default: FFT=6.28 (which means 2.*PI) C Data specifying the parameters of the input grid: C O1=real, O2=real, O3=real ... Coordinates of the origin of the C grid. C Default: O1=0. O2=0. O3=0. C D1=real... Grid interval along the X1 axis. C Default: D1=0. C D2=real... Grid interval along the X2 axis. C Default: D2=0. C D3=real... Grid interval along the X3 axis. C Default: D3=0. C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C N4=positive integer... Number of space grids. The Fourier C transform with respect to X1, X2 and X3 will be repeated C N4 times, for each space grid. C If N4=0, parameter M4 is used to specify the number of C space grids. C Note that each space grid must begin at a new line of C the input file, because each space grid is read by a C a single read statement in free format. C Default: N4=1 C M4='string'... Name of the file containing a single integer number C specifying N4. C Default: M4=' ' means that N4=1. C Data specifying the parameters of the grid for the FFT: C N1FFT=positive integer... Number of gridpoints along the X1 axis. C N2FFT=positive integer... Number of gridpoints along the X2 axis. C N3FFT=positive integer... Number of gridpoints along the X3 axis. C NiFFT must be an integer power of 2, and must be greater C than or equal to the corresponding Ni of the input data. C NiFFT=0 means, that the Fourier transform is not to be C done in the direction of the corresponding axis. In this C case the corresponding Ni number of gridpoints is C considered, this influences the default value of NiOUT. C Default: NiFFT equal to the lowest power of 2, which is C greater or equal to the corresponding Ni. C FFTFIL=real ... Value, which is used at the gridpoints of the grid C for FFT, at which the value is not given by input data. C In present version FFTFIL is used for real part, imaginary C part is zero, with exception of FFTFIL=-999999999. In such C case, input data are linearly interpolated from the values C in the first and in the last gridpoints of the input grid, C to the gridpoints of the grid for the FFT. C Default: FFTFIL=-999999999. (interpolation of the values) C Data specifying the parameters of the output grid: C O1OUT=real, O2OUT=real, O3OUT=real ... Coordinates of the origin C of the output grid. C Default: OiOUT=-1./(2.*Di)*2.*PI/ABS(FFT) C D1OUT=real, D2OUT=real, D3OUT=real ... Grid intervals along the C first, second and third axes of the output grid. DiOUT C must not differ from the default value. C Default: DiOUT=1./(NiFFT*Di)*2.*PI/ABS(FFT) C N1OUT=positive integer, N2OUT=positive integer, C N3OUT=positive integer ... Numbers of gridpoints along the first, C second and third axes of the output grid. C Default: NiOUT=NiFFT C Names of input and output formatted files with the functional values: C FFTINR='string', FFTINI='string' ... real and imaginary parts of C the input function. C Default: FFTINR=' ' FFTINI=' ' C FFTOUTR='string', FFTOUTI='string' ... real and imaginary parts of C the output function. C Default: FFTOUTR=' ' FFTOUTI=' ' C For general description of the files with gridded data refer to C file forms.htm. C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL NFFT,INDRAM,MODF,NCHECK,ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I, *RARRAY,WARRAY,FOURN INTEGER NFFT,INDRAM,MODF C NFFT,INDRAM,MODF,NCHECK ... This file. C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... C File sep.for. C RARRAY,WARRAY ... File forms.for. C FOURN ... File fourn.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C Common block /GRDFF/: INTEGER N1FFT,N1N2FF COMMON /GRDFF/ N1N2FF,N1FFT SAVE /GRDFF/ C CHARACTER*80 FILSEP,FM4,FILINR,FILINI,FILOUR,FILOUI INTEGER LU1,LU2,LU3,LU4 PARAMETER (LU1=1,LU2=2,LU3=3,LU4=4) REAL PI PARAMETER (PI=3.141592653589793) INTEGER MODFFT INTEGER N1,N2,N3,N4,N1N2,NN INTEGER N2FFT,N3FFT,NDIFFT(3),NNFFT,NN2FFT,NT1FFT,NT2FFT,NT3FFT INTEGER N1TMP,N2TMP,N3TMP INTEGER N1OUT,N2OUT,N3OUT,N1N2OU,NNOUT REAL UNDEF PARAMETER (UNDEF=-999999999.) REAL O1,O2,O3,D1,D2,D3,FFT,FFTFIL REAL O1OUT,O2OUT,O3OUT,D1OUT,D2OUT,D3OUT,D1TMP,D2TMP,D3TMP INTEGER IR,II,I1MI,I1MA,I2MI,I2MA,I3MI,I3MA,IO1,IO2,IO3 INTEGER K1MA,K2MA,K3MA,K1,K2,K3 INTEGER IRAM,I1,I2,I3,I4,I,J,K,L,NDIMFF,NFORFF,OFORFF REAL RRA,RRB,RR0,RRD,RIA,RIB,RI0,RID,RRK,RMULT C----------------------------------------------------------------------- C C Reading a name of the file with the input data: FILSEP=' ' WRITE(*,'(A)') '+GRDFFT: Enter input filename: ' READ(*,*) FILSEP IF (FILSEP.EQ.' ') THEN C GRDFFT-19 CALL ERROR('GRDFFT-19: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF WRITE(*,'(A)') '+GRDFFT: Working... ' C C Reading all the data from the SEP file into the memory: CALL RSEP1(LU1,FILSEP) C C Reading the filenames of the files with the real and imaginary C parts of the input function: CALL RSEP3T('FFTINR',FILINR,' ') CALL RSEP3T('FFTINI',FILINI,' ') IF (FILINR.EQ.' ' .AND. FILINI.EQ.' ') THEN C GRDFFT-01 CALL ERROR('GRDFFT-01: No input files specified.') ENDIF C Reading the filenames of the output files: CALL RSEP3T('FFTOUTR',FILOUR,' ') CALL RSEP3T('FFTOUTI',FILOUI,' ') IF (FILOUR.EQ.' ' .AND. FILOUI.EQ.' ') THEN C GRDFFT-02 CALL ERROR('GRDFFT-02: No output files specified.') ENDIF C Reading the multiplicative constant FFT: CALL RSEP3R('FFT',FFT,2.*PI) I=NINT(FFT/PI) IF (I.NE.0) THEN IF (ABS((FFT/PI-FLOAT(I))/FLOAT(I)).LE.0.01) THEN FFT=FLOAT(I)*PI ENDIF ENDIF C Mode of the FFT: IF (FFT.GT.0.) THEN MODFFT=1 ELSEIF (FFT.LT.0.) THEN MODFFT=-1 ELSE C GRDFFT-03 CALL ERROR('GRDFFT-03: Wrong value of FFT.') ENDIF C Reading the values describing the input grid: CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3I('N4',N4,1) N1N2=N1*N2 NN=N1N2*N3 IF (N4.LE.0) THEN CALL RSEP3T('M4',FM4,' ') IF (FM4.EQ.' ') THEN N4=1 ELSE OPEN(LU1,FILE=FM4,STATUS='OLD') READ(LU1,*) N4 CLOSE(LU1) ENDIF ENDIF CALL RSEP3R('D1',D1,0.) CALL RSEP3R('D2',D2,0.) CALL RSEP3R('D3',D3,0.) IF (((D1.EQ.0.).AND.(N1.NE.1)).OR. * ((D2.EQ.0.).AND.(N2.NE.1)).OR. * ((D3.EQ.0.).AND.(N3.NE.1))) THEN C GRDFFT-04 CALL ERROR('GRDFFT-04: Wrong input grid.') ENDIF IF ((D1.EQ.0.).AND.(N1.EQ.1)) D1=1. IF ((D2.EQ.0.).AND.(N2.EQ.1)) D2=1. IF ((D3.EQ.0.).AND.(N3.EQ.1)) D3=1. N1TMP=NFFT(N1) N2TMP=NFFT(N2) N3TMP=NFFT(N3) CALL RSEP3I('N1FFT',NT1FFT,N1TMP) CALL RSEP3I('N2FFT',NT2FFT,N2TMP) CALL RSEP3I('N3FFT',NT3FFT,N3TMP) IF (NT1FFT.EQ.0) THEN N1FFT=N1 ELSE N1FFT=NT1FFT CALL NCHECK(N1FFT,N1TMP) ENDIF IF (NT2FFT.EQ.0) THEN N2FFT=N2 ELSE N2FFT=NT2FFT CALL NCHECK(N2FFT,N2TMP) ENDIF IF (NT3FFT.EQ.0) THEN N3FFT=N3 ELSE N3FFT=NT3FFT CALL NCHECK(N3FFT,N3TMP) ENDIF N1N2FF=N1FFT*N2FFT NNFFT=N1N2FF*N3FFT NN2FFT=2*NNFFT C Reading the constant FFTFIL for values missing in input grid: CALL RSEP3R('FFTFIL',FFTFIL,UNDEF) C Dimension of the temporary grid: NFORFF=NNFFT IF (NT1FFT.EQ.0) NFORFF=NFORFF/N1FFT IF (NT2FFT.EQ.0) NFORFF=NFORFF/N2FFT IF (NT3FFT.EQ.0) NFORFF=NFORFF/N3FFT OFORFF=MRAM-2*NFORFF C Reading the values describing the output grid: CALL RSEP3I('N1OUT',N1OUT,N1FFT) CALL RSEP3I('N2OUT',N2OUT,N2FFT) CALL RSEP3I('N3OUT',N3OUT,N3FFT) N1N2OU=N1OUT*N2OUT NNOUT=N1N2OU*N3OUT CALL RSEP3R('O1OUT',O1OUT,-1./(2.*D1)*2.*PI/ABS(FFT)) CALL RSEP3R('O2OUT',O2OUT,-1./(2.*D2)*2.*PI/ABS(FFT)) CALL RSEP3R('O3OUT',O3OUT,-1./(2.*D3)*2.*PI/ABS(FFT)) D1TMP=1./(N1FFT*D1)*2.*PI/ABS(FFT) D2TMP=1./(N2FFT*D2)*2.*PI/ABS(FFT) D3TMP=1./(N3FFT*D3)*2.*PI/ABS(FFT) CALL RSEP3R('D1OUT',D1OUT,D1TMP) CALL RSEP3R('D2OUT',D2OUT,D2TMP) CALL RSEP3R('D3OUT',D3OUT,D3TMP) D1TMP=D1OUT/D1TMP D2TMP=D2OUT/D2TMP D3TMP=D3OUT/D3TMP IF ((ABS(D1TMP-1.).GT.0.001).AND.(N1OUT.NE.1)) THEN IF ((NT1FFT.NE.0).OR.(D1OUT.NE.D1)) THEN C GRDFFT-05 CALL ERROR('GRDFFT-05: Wrong D1OUT.') ENDIF ENDIF IF ((ABS(D2TMP-1.).GT.0.001).AND.(N2OUT.NE.1)) THEN IF ((NT2FFT.NE.0).OR.(D2OUT.NE.D2)) THEN C GRDFFT-16 CALL ERROR('GRDFFT-16: Wrong D2OUT.') ENDIF ENDIF IF ((ABS(D3TMP-1.).GT.0.001).AND.(N3OUT.NE.1)) THEN IF ((NT3FFT.NE.0).OR.(D3OUT.NE.D3)) THEN C GRDFFT-17 CALL ERROR('GRDFFT-17: Wrong D3OUT.') ENDIF ENDIF C IF ((NN2FFT+2*MAX0(NN,NNOUT,NFORFF)).GT.MRAM) THEN C GRDFFT-06 CALL ERROR('GRDFFT-06: Small array RAM.') ENDIF C C Preparing number NDIMFF describing the dimension C of the part of the input grid to be transformed. NDIMFF=3 IF ((N1.EQ.1).OR.(NT1FFT.EQ.0)) NDIMFF=NDIMFF-1 IF ((N2.EQ.1).OR.(NT2FFT.EQ.0)) NDIMFF=NDIMFF-1 IF ((N3.EQ.1).OR.(NT3FFT.EQ.0)) NDIMFF=NDIMFF-1 IF (NDIMFF.EQ.0) THEN C GRDFFT-07 CALL ERROR('GRDFFT-07: Input grid is 1*1*1.') ENDIF C Computing the multiplicative factor: RMULT=1. IF ((N1.NE.1).AND.(NT1FFT.NE.0)) RMULT=RMULT*D1 IF ((N2.NE.1).AND.(NT2FFT.NE.0)) RMULT=RMULT*D2 IF ((N3.NE.1).AND.(NT3FFT.NE.0)) RMULT=RMULT*D3 RMULT=RMULT*SQRT(ABS(FFT)/(2.*PI))**NDIMFF C C Opening files with input and output grids: IF (N4.GT.1) THEN IF (FILINR.NE.' ') THEN OPEN(LU1,FILE=FILINR,FORM='FORMATTED',STATUS='OLD') ENDIF IF (FILINI.NE.' ') THEN OPEN(LU2,FILE=FILINI,FORM='FORMATTED',STATUS='OLD') ENDIF IF (FILOUR.NE.' ') THEN OPEN(LU3,FILE=FILOUR,FORM='FORMATTED') ENDIF IF (FILOUI.NE.' ') THEN OPEN(LU4,FILE=FILOUI,FORM='FORMATTED') ENDIF ENDIF C C Loop over N4 space grids: DO 90, I4=1,N4 C Reading the input function: IR=MRAM-2*NN II=MRAM-NN IF (FILINR.NE.' ') THEN IF (N4.GT.1) THEN CALL RARRAY(LU1,' ' ,'FORMATTED',.TRUE.,0.,NN,RAM(IR)) ELSE CALL RARRAY(LU1,FILINR,'FORMATTED',.TRUE.,0.,NN,RAM(IR)) ENDIF ELSE DO 10, I1=IR,II-1 RAM(I1)=0. 10 CONTINUE ENDIF IF (FILINI.NE.' ') THEN IF (N4.GT.1) THEN CALL RARRAY(LU2,' ' ,'FORMATTED',.TRUE.,0.,NN,RAM(II)) ELSE CALL RARRAY(LU2,FILINI,'FORMATTED',.TRUE.,0.,NN,RAM(II)) ENDIF ELSE DO 11, I1=II,MRAM RAM(I1)=0. 11 CONTINUE ENDIF C I=N1FFT-N1 I1MI=1+I/2 I1MA=N1FFT-I/2-MOD(I,2) I=N2FFT-N2 I2MI=1+I/2 I2MA=N2FFT-I/2-MOD(I,2) I=N3FFT-N3 I3MI=1+I/2 I3MA=N3FFT-I/2-MOD(I,2) IF ((I1MI.LT.1).OR.(I2MI.LT.1).OR.(I3MI.LT.1).OR. * (I1MI.GT.N1FFT).OR.(I2MI.GT.N2FFT).OR.(I3MI.GT.N3FFT).OR. * (I1MA.LT.1).OR.(I2MA.LT.1).OR.(I3MA.LT.1).OR. * (I1MA.GT.N1FFT).OR.(I2MA.GT.N2FFT).OR.(I3MA.GT.N3FFT)) THEN C GRDFFT-08 CALL ERROR('GRDFFT-08: Wrong value of IiMA or IiMI.') C This error should not appear. ENDIF IO1=MODF(-NINT(O1/D1),N1) IF (IO1.LT.0) IO1=IO1+N1 IO2=MODF(-NINT(O2/D2),N2) IF (IO2.LT.0) IO2=IO2+N2 IO3=MODF(-NINT(O3/D3),N3) IF (IO3.LT.0) IO3=IO3+N3 IF ((IO1.LT.0).OR.(IO2.LT.0).OR.(IO3.LT.0).OR. * (IO1.GT.N1).OR.(IO2.GT.N2).OR.(IO3.GT.N3).OR. * (IO1.LT.0).OR.(IO2.LT.0).OR.(IO3.LT.0).OR. * (IO1.GT.N1).OR.(IO2.GT.N2).OR.(IO3.GT.N3)) THEN C GRDFFT-09 CALL ERROR('GRDFFT-09: Wrong value of IOi.') C This error should not appear. ENDIF C Recording the known values: IRAM=1 DO 24, I3=1,N3FFT DO 23, I2=1,N2FFT DO 22, I1=1,N1FFT IF (IRAM.GT.IR) THEN C GRDFFT-10 CALL ERROR('GRDFFT-10: Wrong index of array RAM.') C This error should not appear. ENDIF IF ((I1.GE.I1MI).AND.(I1.LE.I1MA).AND. * (I2.GE.I2MI).AND.(I2.LE.I2MA).AND. * (I3.GE.I3MI).AND.(I3.LE.I3MA)) THEN I=MODF(IO1+I1,N1) + (MODF(IO2+I2,N2)-1)*N1 + * (MODF(IO3+I3,N3)-1)*N1N2 + IR-1 IF ((I.LT.IR).OR.(I.GE.II)) THEN C C GRDFFT-11 CALL ERROR('GRDFFT-11: Wrong index in the data array') C This error should not appear. ENDIF RAM(IRAM)=RAM(I) RAM(IRAM+1)=RAM(I+NN) ENDIF IRAM=IRAM+2 22 CONTINUE 23 CONTINUE 24 CONTINUE C Interpolating the unknown values in the first axis direction: DO 34, I3=I3MI,I3MA DO 33, I2=I2MI,I2MA RRA=RAM(INDRAM(I1MI,I2,I3)) RRB=RAM(INDRAM(I1MA,I2,I3)) RR0=(RRA+RRB)/2. RRD=(RRA-RRB)/2. RIA=RAM(INDRAM(I1MI,I2,I3)+1) RIB=RAM(INDRAM(I1MA,I2,I3)+1) RI0=(RIA+RIB)/2. RID=(RIA-RIB)/2. DO 31, I1=1,I1MI-1 IF (FFTFIL.EQ.UNDEF) THEN RRK=FLOAT(I1-1)/FLOAT(I1MI-1) RAM(INDRAM(I1,I2,I3))=RR0+RRK*RRD RAM(INDRAM(I1,I2,I3)+1)=RI0+RRK*RID ELSE RAM(INDRAM(I1,I2,I3))=FFTFIL RAM(INDRAM(I1,I2,I3)+1)=0. ENDIF 31 CONTINUE DO 32, I1=I1MA+1,N1FFT IF (FFTFIL.EQ.UNDEF) THEN RRK=FLOAT(I1-N1FFT)/FLOAT(N1FFT-I1MA) RAM(INDRAM(I1,I2,I3))=RR0+RRK*RRD RAM(INDRAM(I1,I2,I3)+1)=RI0+RRK*RID ELSE RAM(INDRAM(I1,I2,I3))=FFTFIL RAM(INDRAM(I1,I2,I3)+1)=0. ENDIF 32 CONTINUE 33 CONTINUE 34 CONTINUE C Interpolating the unknown values in the second axis direction: DO 44, I3=I3MI,I3MA DO 43, I1=1,N1FFT RRA=RAM(INDRAM(I1,I2MI,I3)) RRB=RAM(INDRAM(I1,I2MA,I3)) RR0=(RRA+RRB)/2. RRD=(RRA-RRB)/2. RIA=RAM(INDRAM(I1,I2MI,I3)+1) RIB=RAM(INDRAM(I1,I2MA,I3)+1) RI0=(RIA+RIB)/2. RID=(RIA-RIB)/2. DO 41, I2=1,I2MI-1 IF (FFTFIL.EQ.UNDEF) THEN RRK=FLOAT(I2-1)/FLOAT(I2MI-1) RAM(INDRAM(I1,I2,I3))=RR0+RRK*RRD RAM(INDRAM(I1,I2,I3)+1)=RI0+RRK*RID ELSE RAM(INDRAM(I1,I2,I3))=FFTFIL RAM(INDRAM(I1,I2,I3)+1)=0. ENDIF 41 CONTINUE DO 42, I2=I2MA+1,N2FFT IF (FFTFIL.EQ.UNDEF) THEN RRK=FLOAT(I2-N2FFT)/FLOAT(N2FFT-I2MA) RAM(INDRAM(I1,I2,I3))=RR0+RRK*RRD RAM(INDRAM(I1,I2,I3)+1)=RI0+RRK*RID ELSE RAM(INDRAM(I1,I2,I3))=FFTFIL RAM(INDRAM(I1,I2,I3)+1)=0. ENDIF 42 CONTINUE 43 CONTINUE 44 CONTINUE C Interpolating the unknown values in the third axis direction: DO 54, I1=1,N1FFT DO 53, I2=1,N2FFT RRA=RAM(INDRAM(I1,I2,I3MI)) RRB=RAM(INDRAM(I1,I2,I3MA)) RR0=(RRA+RRB)/2. RRD=(RRA-RRB)/2. RIA=RAM(INDRAM(I1,I2,I3MI)+1) RIB=RAM(INDRAM(I1,I2,I3MA)+1) RI0=(RIA+RIB)/2. RID=(RIA-RIB)/2. DO 51, I3=1,I3MI-1 IF (FFTFIL.EQ.UNDEF) THEN RRK=FLOAT(I3-1)/FLOAT(I3MI-1) RAM(INDRAM(I1,I2,I3))=RR0+RRK*RRD RAM(INDRAM(I1,I2,I3)+1)=RI0+RRK*RID ELSE RAM(INDRAM(I1,I2,I3))=FFTFIL RAM(INDRAM(I1,I2,I3)+1)=0. ENDIF 51 CONTINUE DO 52, I3=I3MA+1,N3FFT IF (FFTFIL.EQ.UNDEF) THEN RRK=FLOAT(I3-N3FFT)/FLOAT(N3FFT-I3MA) RAM(INDRAM(I1,I2,I3))=RR0+RRK*RRD RAM(INDRAM(I1,I2,I3)+1)=RI0+RRK*RID ELSE RAM(INDRAM(I1,I2,I3))=FFTFIL RAM(INDRAM(I1,I2,I3)+1)=0. ENDIF 52 CONTINUE 53 CONTINUE 54 CONTINUE C C C Computing the FFT: C Quantities describing the parts of the grid where FFT will C be done: NDIFFT(1)=N1FFT NDIFFT(2)=N2FFT NDIFFT(3)=N3FFT IF (NT1FFT.EQ.0) NDIFFT(1)=1 IF (NT2FFT.EQ.0) NDIFFT(2)=1 IF (NT3FFT.EQ.0) NDIFFT(3)=1 IF (NDIFFT(2).EQ.1) THEN NDIFFT(2)=NDIFFT(3) ENDIF IF (NDIFFT(1).EQ.1) THEN NDIFFT(1)=NDIFFT(2) NDIFFT(2)=NDIFFT(3) ENDIF NFORFF=NNFFT IF (NT1FFT.EQ.0) NFORFF=NFORFF/N1FFT IF (NT2FFT.EQ.0) NFORFF=NFORFF/N2FFT IF (NT3FFT.EQ.0) NFORFF=NFORFF/N3FFT OFORFF=MRAM-2*NFORFF K1MA=1 K2MA=1 K3MA=1 IF (NT1FFT.EQ.0) K1MA=N1FFT IF (NT2FFT.EQ.0) K2MA=N2FFT IF (NT3FFT.EQ.0) K3MA=N3FFT I1MI=1 I1MA=N1FFT I2MI=1 I2MA=N2FFT I3MI=1 I3MA=N3FFT C C Loop over subgrids: DO 69, K3=1,K3MA DO 68, K2=1,K2MA DO 67, K1=1,K1MA IF (NT1FFT.EQ.0) THEN I1MI=K1 I1MA=K1 ENDIF IF (NT2FFT.EQ.0) THEN I2MI=K2 I2MA=K2 ENDIF IF (NT3FFT.EQ.0) THEN I3MI=K3 I3MA=K3 ENDIF C Moving the subgrid to the temporary location: K=OFORFF-2 DO 63, I3=I3MI,I3MA DO 62, I2=I2MI,I2MA DO 61, I1=I1MI,I1MA I=INDRAM(I1,I2,I3) J=I+1 K=K+2 L=K+1 IF ((I.LE.0).OR.(I.GT.NN2FFT).OR. * (J.LE.0).OR.(J.GT.NN2FFT).OR. * (K.GT.MRAM).OR.(L.GT.MRAM)) THEN C GRDFFT-15 CALL ERROR('GRDFFT-15: Wrong index of array RAM.') C This error should not appear. ENDIF RAM(K)=RAM(I) RAM(L)=RAM(J) 61 CONTINUE 62 CONTINUE 63 CONTINUE C FFT: CALL FOURN(RAM(OFORFF),NDIFFT,NDIMFF,MODFFT) C Moving the subgrid back from the temporary location: K=OFORFF-2 DO 66, I3=I3MI,I3MA DO 65, I2=I2MI,I2MA DO 64, I1=I1MI,I1MA I=INDRAM(I1,I2,I3) J=I+1 K=K+2 L=K+1 IF ((I.LE.0).OR.(I.GT.NN2FFT).OR. * (J.LE.0).OR.(J.GT.NN2FFT).OR. * (K.GT.MRAM).OR.(L.GT.MRAM)) THEN C GRDFFT-18 CALL ERROR('GRDFFT-18: Wrong index of array RAM.') C This error should not appear. ENDIF RAM(I)=RAM(K) RAM(J)=RAM(L) 64 CONTINUE 65 CONTINUE 66 CONTINUE 67 CONTINUE 68 CONTINUE 69 CONTINUE C End of the loop over subgrids. C C C Adding the multiplicative factor: DO 70, I1=1,NN2FFT RAM(I1)=RAM(I1)*RMULT 70 CONTINUE C C C Writing the results of the FFT: IO1=MODF(NINT(O1OUT/D1OUT),N1FFT) IF (IO1.LT.0) IO1=IO1+N1FFT IO2=MODF(NINT(O2OUT/D2OUT),N2FFT) IF (IO2.LT.0) IO2=IO2+N2FFT IO3=MODF(NINT(O3OUT/D3OUT),N3FFT) IF (IO3.LT.0) IO3=IO3+N3FFT IF ((IO1.LT.0).OR.(IO2.LT.0).OR.(IO3.LT.0).OR. * (IO1.GT.N1FFT).OR.(IO2.GT.N2FFT).OR.(IO3.GT.N3FFT).OR. * (IO1.LT.0).OR.(IO2.LT.0).OR.(IO3.LT.0).OR. * (IO1.GT.N1FFT).OR.(IO2.GT.N2FFT).OR.(IO3.GT.N3FFT)) THEN C GRDFFT-12 CALL ERROR('GRDFFT-12: Wrong value of IOi.') C This error should not appear. ENDIF C Reordering the computed values: IR=MRAM-2*NNOUT II=MRAM-NNOUT DO 74, I3=1,N3OUT DO 73, I2=1,N2OUT DO 72, I1=1,N1OUT I=INDRAM(MODF(IO1+I1,N1FFT),MODF(IO2+I2,N2FFT), * MODF(IO3+I3,N3FFT)) RAM(IR)=RAM(I) RAM(II)=RAM(I+1) IR=IR+1 II=II+1 72 CONTINUE 73 CONTINUE 74 CONTINUE IR=MRAM-2*NNOUT II=MRAM-NNOUT IF (N4.GT.1) THEN IF (FILOUR.NE.' ') THEN CALL WARRAY(LU3,' ' ,'FORMATTED',.FALSE.,0.,.FALSE.,0., * NNOUT,RAM(IR)) ENDIF IF (FILOUI.NE.' ') THEN CALL WARRAY(LU4,' ' ,'FORMATTED',.FALSE.,0.,.FALSE.,0., * NNOUT,RAM(II)) ENDIF ELSE IF (FILOUR.NE.' ') THEN CALL WARRAY(LU3,FILOUR,'FORMATTED',.FALSE.,0.,.FALSE.,0., * NNOUT,RAM(IR)) ENDIF IF (FILOUI.NE.' ') THEN CALL WARRAY(LU4,FILOUI,'FORMATTED',.FALSE.,0.,.FALSE.,0., * NNOUT,RAM(II)) ENDIF ENDIF 90 CONTINUE C C Closing files with input and output grids: IF (N4.GT.1) THEN IF (FILINR.NE.' ') THEN CLOSE(LU1) ENDIF IF (FILINI.NE.' ') THEN CLOSE(LU2) ENDIF IF (FILOUR.NE.' ') THEN CLOSE(LU3) ENDIF IF (FILOUI.NE.' ') THEN CLOSE(LU4) ENDIF ENDIF WRITE(*,'(A)') '+GRDFFT: Finished. ' STOP END C C======================================================================= C INTEGER FUNCTION INDRAM(I,J,K) C Common block /GRDFF/: INTEGER N1FFT,N1N2FF COMMON /GRDFF/ N1N2FF,N1FFT SAVE /GRDFF/ INTEGER I,J,K INDRAM=2*((K-1)*N1N2FF + (J-1)*N1FFT + (I-1)) + 1 RETURN END C C======================================================================= C INTEGER FUNCTION MODF(I,J) INTEGER I,J IF (J.EQ.1) THEN MODF=1 ELSE MODF=MOD(I,J) IF ((MODF.EQ.0).AND.(I.NE.0)) MODF=J ENDIF RETURN END C C======================================================================= C INTEGER FUNCTION NFFT(N) INTEGER N REAL AUX AUX=LOG10(FLOAT(N))/LOG10(2.) IF (AUX.GT.AINT(AUX)) AUX=AUX+1. NFFT=2**AINT(AUX) RETURN END C C======================================================================= C SUBROUTINE NCHECK(N1,N2) INTEGER N1,N2 EXTERNAL NFFT INTEGER NFFT IF (N1.LT.N2) THEN C GRDFFT-13 CALL ERROR * ('GRDFFT-13: Wrong specification of the output grid.') C Number of gridpoints for FFT must be greater than or equal to C the number of gridpoints in data. ENDIF IF (N1.NE.NFFT(N1)) THEN C GRDFFT-14 CALL ERROR * ('GRDFFT-14: Wrong specification of the output grid.') C Number of gridpoints for FFT must be an integer power of 2. ENDIF RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for INCLUDE 'sep.for' C sep.for INCLUDE 'fourn.for' C fourn.for of Numerical Recipes C C======================================================================= Cgrd.h 0100666 0000765 0000765 00000000154 06415077134 011365 0 ustar bulant bulant # Sample SEP header file defining the grid dimensions: N1=501 N2=501 D1=0.002 D2=0.002 O1=0. O2=0. grdiso.for 0100666 0000765 0000765 00000040261 10062244274 012434 0 ustar bulant bulant C
C Program GRDISO for identification of points at isosurfaces C of 3-D gridded values. If one of two neigbouring gridpoints displays C the value greater than VALUE, and if the second one of the two C gridpoints displays the value less or eaqual to VALUE, the coordinates C of the point which lies between the two gridpoints and corresponds C to the value VALUE are computed and stored in the output file. C C Version: 5.80 C Date: 2004, June 11 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Name of input file: C GRD='string'... Name of the input ASCII file with the grid values. C Default: GRD='grd.out' C For general description of the files with gridded data refer C to file forms.htm. C Parameters defining the basic regular rectangular grid: C N1=positive integer... Number of gridpoints of the basic grid C along the X1 axis. Default: N1=1 C N2=positive integer... Number of gridpoints of the basic grid C along the X2 axis. Default: N2=1 C N3=positive integer... Number of gridpoints of the basic grid C along the X3 axis. Default: N3=1 C O1=real... X1 coordinate of the origin of the grid. Default: O1=0. C O2=real... X2 coordinate of the origin of the grid. Default: O2=0. C O3=real... X3 coordinate of the origin of the grid. Default: O3=0. C D1=real... Grid spacing along the X1 axis. Default: D1=1. C D2=real... Grid spacing along the X2 axis. Default: D2=1. C D3=real... Grid spacing along the X3 axis. Default: D3=1. C Data specifying dimensions of the grid, on which the calculation C of points at isosurfaces will be performed: C N1NEW=positive integer... Number of gridpoints along the X1 axis. C Default: N1NEW=N1 C N2NEW=positive integer... Number of gridpoints along the X2 axis. C Default: N2NEW=N2 C N3NEW=positive integer... Number of gridpoints along the X3 axis. C Default: N3NEW=N3 C NO1=positive integer... Index of the first gridpoint along C the X1 axis. C Default: NO1=1 C NO2=positive integer... Index of the first gridpoint along C the X2 axis. C Default: NO2=1 C NO3=positive integer... Index of the first gridpoint along C the X3 axis. C Default: NO3=1 C ND1=positive integer... Multiplication factor of the grid interval C along the X1 axis. C Default: ND1=1 C ND2=positive integer... Multiplication factor of the grid interval C along the X2 axis. C Default: ND2=1 C ND3=positive integer... Multiplication factor of the grid interval C along the X3 axis. C Default: ND3=1 C The grid for calculation should be always a subgrid of the C original grid. Two gridpoints located at the different sides of C the isosurface are searched for on the grid for calculation. C The coordinates of the point at isosurface are then calculated on C the original grid. C Value corresponding to the points to be calculated: C VALUE=real ... Value corresponding to the isosurface being C searched for. C Default: VALUE=0. C Mode of the calculation: C MODE=integer C MODE=0 ... The points corresponding to VALUE are C searched for at all gridlegs. C MODE=1,2,3 ... The points are searched for only C at the gridlegs parallel with X1, X2 or X3 axis. C All the points are written to the file PTS. C MODE=-1,-2,-3 ... The points are searched for only C at the gridlegs parallel with X1, X2 or X3 axis. C The points with values increasing with C the corresponding gridlegs are written to the file PTS, C other points to the file PTS1. C Default: MODE=0 C Names of the output files: C PTS='string'...Name of the output file with the coordinates C of the points. The points are the intersections of C the gridlegs with the isosurface of the value VALUE. C The file is not generated if PTS=' '. C Description of file PTS. C Default: PTS='pts.out' C PTS1='string'...Name of the second output file with the points C in case of negative MODE. C The file is not generated if PTS1=' '. C Description of file PTS1. C Default: PTS1='pts1.out' C C C Output file PTS or PTS1 with the points at isosurface: C (1) / C (2) For each point data (2.1): C (2.1) 'NNNNNN',X1,X2,X3,/ C 'NNNNNN'... Name of the point - six-digit integer index of the C point. C X1,X2,X3... Coordinates of the point. C (3) / C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL GIGLEG,GICP, *ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I,FORM1 C GIGLEG,GICP ... This file. C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... C File sep.for. C FORM1 ... forms.for. C C Common block /GIC/: INCLUDE 'grdiso.inc' C grdiso.inc C C....................................................................... C Auxiliary storage locations: CHARACTER*80 FSEP,FGRD,FPTS,FPTS1 INTEGER LU,LU1,LENG,MODE PARAMETER (LU=1,LU1=2,LENG=6) REAL UNDEF,VALUE PARAMETER (UNDEF=-999999.) INTEGER I1,I2,I3,I4,J2,JCOOR,IP1,IP2,IP3,NPTS, * NLEG2,NLEG3 REAL XX(3),YY(3),ZZ(3),OUTMIN,OUTMAX,VAL1,VAL2,VAL3 CHARACTER*20 FORMAT,TEXTP C C....................................................................... C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDISO: Enter input filename: ' FSEP=' ' READ(*,*) FSEP C C Reading all data from the SEP file into the memory: IF (FSEP.EQ.' ') THEN C GRDISO-01 CALL ERROR('GRDISO-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading all the data from file FSEP to the memory C (SEP parameter file form): CALL RSEP1(LU,FSEP) C C Recalling the data specifying grid dimensions C (arguments: Name of value in input data, Variable, Default): CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3R('D1',DD(1),1.) CALL RSEP3R('D2',DD(2),1.) CALL RSEP3R('D3',DD(3),1.) CALL RSEP3I('N1NEW',N1N,N1) CALL RSEP3I('N2NEW',N2N,N2) CALL RSEP3I('N3NEW',N3N,N3) IF (N1.EQ.N1N.AND.N2.EQ.N2N.AND.N3.EQ.N3N) THEN NO1=1 NO2=1 NO3=1 ND1=1 ND2=1 ND3=1 ELSE CALL RSEP3I('NO1',NO1,1) CALL RSEP3I('NO2',NO2,1) CALL RSEP3I('NO3',NO3,1) CALL RSEP3I('ND1',ND1,1) CALL RSEP3I('ND2',ND2,1) CALL RSEP3I('ND3',ND3,1) IF ((NO1+ND1*(N1N-1).GT.N1).OR. * (NO2+ND2*(N2N-1).GT.N2).OR. * (NO3+ND3*(N3N-1).GT.N3)) THEN C GRDISO-02 CALL ERROR('GRDISO-02: Wrong grid for calculation') C The grid for calculation must be a subgrid C of the original grid. ENDIF ENDIF C C Mode of the calculation and the isovalue: CALL RSEP3I('MODE',MODE,0) CALL RSEP3R('VALUE',VALUE,0.) C C Recalling the input and output filenames: CALL RSEP3T('GRD',FGRD,'grd.out') CALL RSEP3T('PTS',FPTS,'pts.out') IF (MODE.LT.0) CALL RSEP3T('PTS1',FPTS1,'pts1.out') C C C Reading input grid values: IF (N1*N2*N3.GT.MRAM) THEN C GRDISO-03 CALL ERROR('GRDISO-03: Small array RAM.') C Try to enlarge the dimension MRAM in the file C ram.inc. ENDIF CALL RARRAY(LU,FGRD,'FORMATTED',.TRUE.,UNDEF,N1*N2*N3,RAM) NPTS=0 C C Opening output files, initializing: WRITE(*,'(A)') '+GRDISO: Working ... ' IF (FPTS.NE.' ') THEN OPEN(LU,FILE=FPTS,FORM='FORMATTED') WRITE(LU,'(A)') '/' ENDIF IF ((MODE.LT.0).AND.(FPTS1.NE.' ')) THEN OPEN(LU1,FILE=FPTS1,FORM='FORMATTED') WRITE(LU1,'(A)') '/' ENDIF C N1N2= N1 * N2 C NLEG1=(N1N-1)*N2N*N3N NLEG2=N1N*(N2N-1)*N3N NLEG3=N1N*N2N*(N3N-1) NLEG12=NLEG1+NLEG2 NLEG=NLEG12+NLEG3 C NN11= N1N-1 NN1N2= N1N * N2N NN11N2= (N1N-1)* N2N NN1N21= N1N *(N2N-1) C DIP - number of points in RAM between neighboring points C in calculation grid DIP(1)=1 DIP(2)=N1 DIP(3)=N1*N2 C I1 - index of the gridleg being processed I2=1 I3=NLEG I4=IABS(MODE) IF (I4.EQ.1) THEN I3=NLEG1 ELSEIF (I4.EQ.2) THEN I2=NLEG1 I3=NLEG12 ELSEIF (I4.EQ.3) THEN I2=NLEG12 ENDIF C Loop along all gridlegs, recording points at isosurfaces: DO 29, I1=I2,I3 CALL GIGLEG(I1,IP1,IP2) VAL1=RAM(IP1) VAL2=RAM(IP2) IF (((VAL1.LE.VALUE).AND.(VAL2.GT.VALUE)).OR. * ((VAL1.GT.VALUE).AND.(VAL2.LE.VALUE))) THEN C The points of the gridleg are at different sides C of the isosurface - searching for two neighbouring C gridpoints of the original grid, which are also C at the different sides of the isosurface: C JCOOR - index of the coordinate axis JCOOR=3 IF (I1.LE.NLEG12) JCOOR=2 IF (I1.LE.NLEG1) JCOOR=1 C J2 - number of gridsteps of the original grid C between IP1 and IP2 10 CONTINUE CALL GICP(IP1,XX) CALL GICP(IP2,YY) J2=IABS(NINT((XX(JCOOR)-YY(JCOOR))/DD(JCOOR))) J2=J2/2 IF (J2.NE.0) THEN IP3=IP1+J2*DIP(JCOOR) VAL3=RAM(IP3) IF (((VAL1.LE.VALUE).AND.(VAL3.LE.VALUE)).OR. * ((VAL1.GT.VALUE).AND.(VAL3.GT.VALUE))) THEN IP1=IP3 VAL1=VAL3 ELSE IP2=IP3 VAL2=VAL3 ENDIF GOTO 10 ENDIF C End of the search for neighbouring gridpoints. C Computing the coordinates ZZ of the point at the isosurface: ZZ(1)=XX(1) ZZ(2)=XX(2) ZZ(3)=XX(3) IF ((VAL2-VAL1).NE.0.) ZZ(JCOOR)= * XX(JCOOR)+(VALUE-VAL1)*(YY(JCOOR)-XX(JCOOR))/(VAL2-VAL1) C Writing the point: C Name of the point: NPTS=NPTS+1 DO 204, I2=0,LENG-1 TEXTP(LENG-I2:LENG-I2)= * CHAR(ICHAR('0')+MOD(NPTS,10**(I2+1))/10**I2) 204 CONTINUE C Setting the output format: FORMAT='(3A,03(F00.0,1X),A)' OUTMIN=0. OUTMAX=0. DO 214, I2=1,3 IF (OUTMIN.GT.ZZ(I2)) OUTMIN=ZZ(I2) IF (OUTMAX.LT.ZZ(I2)) OUTMAX=ZZ(I2) 214 CONTINUE CALL FORM1(OUTMIN,OUTMAX,FORMAT(8:15)) FORMAT(14:17)= '1X),' C Writing: IF ((MODE.LT.0).AND.(VAL1.GT.VAL2).AND.(FPTS1.NE.' ')) THEN WRITE(LU1,FORMAT) '''',TEXTP(1:LENG),''' ',ZZ,'/' ELSEIF (FPTS.NE.' ') THEN WRITE(LU,FORMAT) '''',TEXTP(1:LENG),''' ',ZZ,'/' ENDIF ENDIF 29 CONTINUE IF (FPTS.NE.' ') THEN WRITE(LU,'(A)') '/' CLOSE(LU) ENDIF IF ((MODE.LT.0).AND.(FPTS1.NE.' ')) THEN WRITE(LU1,'(A)') '/' CLOSE(LU1) ENDIF C WRITE(*,'(A)') *'+GRDISO: Done. ' STOP END C C======================================================================= C SUBROUTINE GIGLEG(ILEG,IPOIN1,IPOIN2) C C----------------------------------------------------------------------- C INTEGER ILEG,IPOIN1,IPOIN2 C Input: C ILEG ... Index of gridleg. C Output: C IPOIN1,IPOIN2 ... Indices of gridpoints forming the gridleg. C....................................................................... C Common block /RAMC/ to store the information about points on C structural interfaces and common block /MSC/ to store auxiliary C quantities: INCLUDE 'grdiso.inc' C grdiso.inc. C ........................... C Auxiliary storage locations: INTEGER I31,I21,I1,I2,I3,J1,J2,J3,J21,J31,JCOOR,ILEG1 C....................................................................... C ILEG1=ILEG-1 IF (ILEG.LE.NLEG1) THEN I31=ILEG1 / NN11N2 I21=(ILEG1 - I31*NN11N2) / NN11 I1=ILEG - I31*NN11N2 - I21*NN11 JCOOR=1 ELSEIF (ILEG.LE.NLEG12) THEN I31=(ILEG1-NLEG1) / NN1N21 I21=((ILEG1-NLEG1) - I31*NN1N21) / N1N I1=(ILEG-NLEG1) - I31*NN1N21 - I21*N1N JCOOR=2 ELSEIF (ILEG.LE.NLEG) THEN I31=(ILEG1-NLEG12) / NN1N2 I21=((ILEG1-NLEG12) - I31*NN1N2) / N1N I1=(ILEG-NLEG12) - I31*NN1N2 - I21*N1N JCOOR=3 ELSE C GRDISO-04 CALL ERROR ('GRDISO-04: Wrong ILEG.') C This error should not appear. Contact the author. ENDIF I2=I21+1 I3=I31+1 J1=NO1+(I1-1)*ND1 J2=NO2+(I2-1)*ND2 J3=NO3+(I3-1)*ND3 J21=J2-1 J31=J3-1 IPOIN1=J31*N1N2+J21*N1+J1 IPOIN2=IPOIN1+DIP(JCOOR) RETURN END C C C======================================================================= C SUBROUTINE GICP(IPOIN,XX) C C----------------------------------------------------------------------- C INTEGER IPOIN REAL XX(3) C IPOIN ... Index of a point. C XX ... Coordinates of the point. C....................................................................... C Common block /RAMC/ to store the information about points on C structural interfaces and common block /MSC/ to store auxiliary C quantities: INCLUDE 'grdiso.inc' C grdiso.inc. C ........................... C Auxiliary storage locations: INTEGER I31,I21,I11,IPOIN1 C....................................................................... C IPOIN1=IPOIN-1 I31= IPOIN1 / N1N2 I21=(IPOIN1 - I31*N1N2) / N1 I11= IPOIN - I31*N1N2 - I21*N1 - 1 XX(1)=O1+FLOAT(I11)*DD(1) XX(2)=O2+FLOAT(I21)*DD(2) XX(3)=O3+FLOAT(I31)*DD(3) RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdiso.inc 0100666 0000765 0000765 00000001762 07307342210 012417 0 ustar bulant bulant C
C INCLUDE 'grdiso.inc' C Declaration of the common blocks used through GRDISO program: C C Date: 2001, April 5 C C ------------------------------------------------------------------ INCLUDE 'ram.inc' C ram.inc C C Parameters defining the grid: INTEGER N1,N2,N3 REAL O1,O2,O3,DD(3) INTEGER N1N,N2N,N3N,NO1,NO2,NO3,ND1,ND2,ND3 C Auxiliary parameters of the grid: INTEGER N1N2,DIP(3),NN11,NN1N2,NN11N2,NN1N21 INTEGER NLEG,NLEG1,NLEG12 C COMMON/GIC/N1,N2,N3,O1,O2,O3,DD,N1N2,DIP, * N1N,N2N,N3N,NO1,NO2,NO3,ND1,ND2,ND3, * NN11,NN1N2,NN11N2,NN1N21, * NLEG,NLEG1,NLEG12 SAVE /GIC/ C ------------------------------------------------------------------ C C Coded by Petr Bulant C======================================================================= Cgrdmerge.for 0100666 0000765 0000765 00000014172 07042241342 012740 0 ustar bulant bulant C
C Program GRDMERGE to merge two nonoverlapping sets of values given on C the same grid into a single set. C C Version: 5.40 C Date: 2000, January 22 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input and output files: C GRD1='string', GRD2='string'... Names of the input ASCII files C with the grid values. No gridpoint may have the value C defined in both the files if 'GRD4' is blank (default). C Default: GRD1='grd1.out', GRD2='grd2.out' C GRD3='string'... Name of the output ASCII file containing the C grid values collected from both the input files. C Default: GRD3='grd.out' C GRD4='string'... Name of the auxiliary output file. C If specified and nonblank, the input grid values may C overlap. Of each pair of overlaping values, the value C of file GRD2 will be collected in this file. This file C is not created if there is no overlap. C Default: GRD4=' ' (auxiliary file not generated) C For general description of the files with gridded data refer C to file forms.htm. C Data specifying grid dimensions: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C INTEGER LU,N1,N2,N3,N1N2N3,I REAL UNDEF PARAMETER (LU=1,UNDEF=-999999.) CHARACTER*80 FSEP,FGRD1,FGRD2,FGRD,FGRDA LOGICAL LGRDA C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDMERGE: Enter input filename: ' FSEP=' ' READ(*,*) FSEP WRITE(*,'(A)') '+GRDMERGE: Working ... ' C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C GRDMERGE-03 CALL ERROR('GRDMERGE-03: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('GRD1',FGRD1,'grd1.out') CALL RSEP3T('GRD2',FGRD2,'grd2.out') CALL RSEP3T('GRD3',FGRD,'grd.out') CALL RSEP3T('GRD4',FGRDA,' ') C C Recalling the data specifying grid dimensions C (arguments: Name of value in input data, Variable, Default): CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) N1N2N3=N1*N2*N3 IF(2*N1N2N3.GT.MRAM) THEN C GRDMERGE-01 CALL ERROR('GRDMERGE-01: Too small array RAM(MRAM)') C Array RAM(MRAM) allocated in include file 'ram.inc' is too small C to contain two input grids (2*N1*N2*N3 values). You may wish to C increse the dimension MRAM in file 'ram.inc'. C ram.inc END IF C C Reading input grids: CALL RARRAY(LU,FGRD1,'FORMATTED',.TRUE.,UNDEF,N1N2N3,RAM) CALL RARRAY(LU,FGRD2,'FORMATTED',.TRUE.,UNDEF,N1N2N3, * RAM(N1N2N3+1)) C C Merging the grids: LGRDA=.FALSE. DO 10 I=1,N1N2N3 IF(RAM(I).EQ.UNDEF) THEN RAM(I)=RAM(N1N2N3+I) RAM(N1N2N3+I)=UNDEF ELSE IF(RAM(N1N2N3+I).NE.UNDEF) THEN IF(FGRDA.EQ.' ') THEN C GRDMERGE-02 CALL ERROR('GRDMERGE-02: Overlapping grid values') C Value at the same gridpoint is defined in both input files C and the auxiliary file is not specified. ELSE LGRDA=.TRUE. END IF END IF END IF 10 CONTINUE C C Writing output grid: CALL WARRAY(LU,FGRD,'FORMATTED',.TRUE.,UNDEF,.FALSE.,0.,N1N2N3, * RAM) IF(LGRDA) THEN CALL WARRAY(LU,FGRDA,'FORMATTED',.TRUE.,UNDEF,.FALSE.,0.,N1N2N3, * RAM(N1N2N3+1)) END IF WRITE(*,'(A)') '+GRDMERGE: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdnew.for 0100666 0000765 0000765 00000023266 07226523210 012437 0 ustar bulant bulant C
C Program GRDNEW to trilinearly interpolate grid values into a new grid C of different dimensions or density C C Version: 5.50 C Date: 2001, January 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of input and output files: C GRD='string'... Name of the input ASCII file with the grid values. C Default: GRD='grd.out' C GRDNEW='string'... Name of the output ASCII file containing the C grid values interpolated into a new grid. C Default: GRDNEW='grdnew.out' C For general description of the files with gridded data refer C to file forms.htm. C Data specifying dimensions of the input grid: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C O1=real... First coordinate of the grid origin (first point of the C grid). C Default: O1=0. C O2=real... Second coordinate of the grid origin. C Default: O2=0. C O3=real... Third coordinate of the grid origin. C Default: O3=0. C D1=real... Grid interval in the direction of the first coordinate C axis. C Default: D1=1. C D2=real... Grid interval in the direction of the second coordinate C axis. C Default: D2=1. C D3=real... Grid interval in the direction of the third coordinate C axis. C Default: D3=1. C Data specifying dimensions of the output grid: C N1NEW=positive integer C N2NEW=positive integer C N3NEW=positive integer C O1NEW=real C O2NEW=real C O3NEW=real C D1NEW=real C D2NEW=real C D3NEW=real... Analogous to N1, N2, N3, O1, O2, O3, D1, D2 and D3, C respectively, but for the output grid. C Defaults: N1NEW=N1, N2NEW=N2, N3NEW=N3, C O1NEW=O1, O2NEW=O2, O3NEW=O3, C D1NEW=D1, D2NEW=D2, D3NEW=D3. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C C Filenames and parameters: CHARACTER*80 FILE1,FILE2,FILE3 INTEGER LU REAL UNDEF PARAMETER (LU=1,UNDEF=-999999.) C Input data: INTEGER N1,N2,N3,N1NEW,N2NEW,N3NEW REAL O1,O2,O3,D1,D2,D3,O1NEW,O2NEW,O3NEW,D1NEW,D2NEW,D3NEW C Other variables: INTEGER N1N2,N1N2N3,I1,I2,I3 INTEGER INEW,I1NEW,I2NEW,I3NEW,I1MIN,I2MIN,I3MIN,I1MAX,I2MAX,I3MAX INTEGER I000,I100,I010,I110,I001,I101,I011,I111 REAL A000,A100,A010,A110,A001,A101,A011,A111,A00,A10,A01,A11,A0,A1 REAL B0,B1,X1,X2,X3 C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDNEW: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 WRITE(*,'(A)') '+GRDNEW: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILE1.EQ.' ') THEN C GRDNEW-01 CALL ERROR('GRDNEW-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF CALL RSEP1(LU,FILE1) C C Reading input parameters from the SEP file: CALL RSEP3T('GRD',FILE2,'grd.out') CALL RSEP3T('GRDNEW',FILE3,'grdnew.out') C C Reading grid dimensions: C Original grid: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) C New grid: CALL RSEP3I('N1NEW',N1NEW,N1) CALL RSEP3I('N2NEW',N2NEW,N2) CALL RSEP3I('N3NEW',N3NEW,N3) CALL RSEP3R('O1NEW',O1NEW,O1) CALL RSEP3R('O2NEW',O2NEW,O2) CALL RSEP3R('O3NEW',O3NEW,O3) CALL RSEP3R('D1NEW',D1NEW,D1) CALL RSEP3R('D2NEW',D2NEW,D2) CALL RSEP3R('D3NEW',D3NEW,D3) C C Dimensions of the old grid related to the new one: O1=(O1-O1NEW)/D1NEW O2=(O2-O2NEW)/D2NEW O3=(O3-O3NEW)/D3NEW D1=D1/D1NEW D2=D2/D2NEW D3=D3/D3NEW N1N2 =N1*N2 N1N2N3=N1*N2*N3 C IF(N1N2N3+N1NEW*N2NEW*N3NEW.GT.MRAM) THEN C GRDNEW-02 CALL ERROR('GRDNEW-02: Too small array RAM(MRAM)') C Too small array RAM(MRAM) to allocate both input and output C grid values. If possible, increase dimension MRAM in include C file ram.inc. END IF IF(D1.LE.0..OR.D2.LE.0..OR.D3.LE.0.) THEN C GRDNEW-03 CALL ERROR('GRDNEW-03: Negative grid interval') C In this version of program 'grdnew.for', grid intervals D1 and C D1NEW must have equal signs, D2 and D2NEW must have equal signs, C D3 and D3NEW must have equal signs. END IF C C Reading input grid values: CALL RARRAY(LU,FILE2,'FORMATTED',.TRUE.,UNDEF,N1N2N3,RAM) C C Trilinearly interpolating inside the grid: I3MIN=0 DO 23 I3=0,N3 IF(I3.LT.N3) THEN X3=O3+FLOAT(I3)*D3 I3MAX=MIN0(NINT(X3-0.5),N3NEW-1) ELSE I3MAX=N3NEW-1 END IF I2MIN=0 DO 22 I2=0,N2 IF(I2.LT.N2) THEN X2=O2+FLOAT(I2)*D2 I2MAX=MIN0(NINT(X2-0.5),N2NEW-1) ELSE I2MAX=N2NEW-1 END IF I1MIN=0 DO 21 I1=0,N1 IF(I1.LT.N1) THEN X1=O1+FLOAT(I1)*D1 I1MAX=MIN0(NINT(X1-0.5),N1NEW-1) ELSE I1MAX=N1NEW-1 END IF I111=1+I1+N1*(I2+N2*I3) IF(I3.GT.0) THEN I110=I111-N1N2 IF(I3.GE.N3) THEN I111=I110 END IF ELSE I110=I111 END IF IF(I2.GT.0) THEN I100=I110-N1 I101=I111-N1 IF(I2.GE.N2) THEN I110=I100 I111=I101 END IF ELSE I100=I110 I101=I111 END IF IF(I1.GT.0) THEN I000=I100-1 I010=I110-1 I001=I101-1 I011=I111-1 IF(I1.GE.N1) THEN I100=I000 I110=I010 I101=I001 I111=I011 END IF ELSE I000=I100 I010=I110 I001=I101 I011=I111 END IF A000=RAM(I000) A100=RAM(I100) A010=RAM(I010) A110=RAM(I110) A001=RAM(I001) A101=RAM(I101) A011=RAM(I011) A111=RAM(I111) DO 13 I3NEW=I3MIN,I3MAX B0=(X3-FLOAT(I3NEW))/D3 B1=1.-B0 A00=A000*B0+A001*B1 A10=A100*B0+A101*B1 A01=A010*B0+A011*B1 A11=A110*B0+A111*B1 DO 12 I2NEW=I2MIN,I2MAX B0=(X2-FLOAT(I2NEW))/D2 B1=1.-B0 A0=A00*B0+A01*B1 A1=A10*B0+A11*B1 INEW=N1N2N3+I1MIN+N1NEW*(I2NEW+N2NEW*I3NEW) DO 11 I1NEW=I1MIN,I1MAX B0=(X1-FLOAT(I1NEW))/D1 B1=1.-B0 INEW=INEW+1 RAM(INEW)=A0*B0+A1*B1 11 CONTINUE 12 CONTINUE 13 CONTINUE I1MIN=MAX0(0,I1MAX+1) 21 CONTINUE I2MIN=MAX0(0,I2MAX+1) 22 CONTINUE I3MIN=MAX0(0,I3MAX+1) 23 CONTINUE C C Writing output grid values: CALL WARRAY(LU,FILE3,'FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1NEW*N2NEW*N3NEW,RAM(N1N2N3+1)) WRITE(*,'(A)') '+GRDNEW: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdnorm.for 0100666 0000765 0000765 00000034225 07111151674 012622 0 ustar bulant bulant C
C Program GRDNORM to calculate the spatial density of the Lebesgue norm C Ln of gridded values C C Version: 5.40 C Date: 2000, May 19 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input and output files: C GRD='string'... Name of the input ASCII file with the grid values. C Default: GRD='grd.out' C GRDNEW='string'... Name of the output ASCII file containing the C grid values of the calculated norm. C Default: GRDNEW='grdnew.out' C For general description of the files with gridded data refer C to file forms.htm. C Data specifying dimensions of the input grid: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C N4=positive integer... Number of spatial grids (number of time C levels). C Default: N4=1 C O1=real... First coordinate of the grid origin (first point of the C grid). C Default: O1=0. C O2=real... Second coordinate of the grid origin. C Default: O2=0. C O3=real... Third coordinate of the grid origin. C Default: O3=0. C O4=real... Time corresponding to the first spatial grid. C Default: O4=0. C D1=real... Grid interval in the direction of the first coordinate C axis. C Default: D1=1. C D2=real... Grid interval in the direction of the second coordinate C axis. C Default: D2=1. C D3=real... Grid interval in the direction of the second coordinate C axis. C Default: D3=1. C D4=real... Time interval. C Default: D4=1. C Data specifying dimensions of the output grid: C N1NEW=positive integer C N2NEW=positive integer C N3NEW=positive integer C N4NEW=positive integer C O1NEW=real C O2NEW=real C O3NEW=real C O4NEW=real C D1NEW=real C D2NEW=real C D3NEW=real C D4NEW=real... Analogous to N1, N2, N3, N4, O1, O2, O3, O4, D1, C D2, D3 and D4, respectively, but for the output grid. C The output grid should be a coarser grid than the input C grid. The input grid is then divided into the subgrids C corresponding to individual gridpoints of the coarser C output grid. Each subgrid is composed of gridpoints of C the input grid, which are closer to the corresponding C gridpoint than to other gridpoints of the output grid. C Empty subgrids are not allowed. The Lebesgue norm Ln, C where n is given by parameter GNORM, is calculated over C each subgrid. Output file GRDNEW thus contains the grid C of N1NEW*N2NEW*N3NEW*N4NEW norms of individual subgrids. C Examples: C (a) If N1NEW=1, N2NEW=1, N3NEW=1 and N4NEW=1, the norm of C the whole grid is calculated. C (b) If N1NEW=1 N2NEW=1 N3NEW=1, whereas N4NEW is not C specified and defaults to N4, the norm of the spatial C grid is calculated separately at each time level. C Output than consists of N4 norms of spatial grids. C (c) If N2NEW=1, whereas N1NEW, N3NEW and N4NEW are not C specified and default to the dimensions of the input C grid, input grid contains a probability density C function, and GNORM=1, the output grid contains the C gridded marginal probability density in the X1X3 plane C at each time level. Output than consists of N1*N3*N4 C values. C Defaults: N1NEW=N1, N2NEW=N2, N3NEW=N3, N4NEW=N4, C O1NEW=O1, O2NEW=O2, O3NEW=O3, O4NEW=O4, C D1NEW=D1, D2NEW=D2, D3NEW=D3, D4NEW=D4. C Type of the norm: C GNORM=real... The norm is [sum( ABS(G)**GNORM )/NSUB]**(1/GNORM). C The summation is performed over each subgrid. NSUB is the C number of points with defined values within the subgrid. C If GNORM.EQ.0., the harmonic average is calculated. C If GNORM.EQ.1., the arithmetic average is calculated. C If GNORM.GT.998., the maximum is calculated. C If GNORM.LT.-998., the minimum is calculated. C Default: GNORM=1. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C C Filenames and parameters: CHARACTER*80 FILE1,FILE2,FILE3 INTEGER LU REAL UNDEF PARAMETER (LU=1,UNDEF=-999999999.) C Input data: INTEGER N1,N2,N3,N4,N1NEW,N2NEW,N3NEW,N4NEW REAL O1,O2,O3,O4,D1,D2,D3,D4 REAL O1NEW,O2NEW,O3NEW,O4NEW,D1NEW,D2NEW,D3NEW,D4NEW,GNORM C Other variables: INTEGER N123,N1234N,NSUB,NSUBA,NALL,I,I1,I2,I3,I4 INTEGER INEW,I1NEW,I2NEW,I3NEW,I4NEW INTEGER I1MIN,I2MIN,I3MIN,I4MIN,I1MAX,I2MAX,I3MAX,I4MAX REAL X1,X2,X3,X4,RAMNEW C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDNORM: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 WRITE(*,'(A)') '+GRDNORM: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILE1.NE.' ') THEN CALL RSEP1(LU,FILE1) ELSE C GRDNORM-06 CALL ERROR('GRDNORM-06: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('GRD',FILE2,'grd.out') CALL RSEP3T('GRDNEW',FILE3,'grdnew.out') C C Reading grid dimensions: C Original grid: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3I('N4',N4,1) CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3R('O4',O4,0.) CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) CALL RSEP3R('D4',D4,1.) C New grid: CALL RSEP3I('N1NEW',N1NEW,N1) CALL RSEP3I('N2NEW',N2NEW,N2) CALL RSEP3I('N3NEW',N3NEW,N3) CALL RSEP3I('N4NEW',N4NEW,N4) CALL RSEP3R('O1NEW',O1NEW,O1) CALL RSEP3R('O2NEW',O2NEW,O2) CALL RSEP3R('O3NEW',O3NEW,O3) CALL RSEP3R('O4NEW',O4NEW,O4) CALL RSEP3R('D1NEW',D1NEW,D1) CALL RSEP3R('D2NEW',D2NEW,D2) CALL RSEP3R('D3NEW',D3NEW,D3) CALL RSEP3R('D4NEW',D4NEW,D4) C Type of the norm: CALL RSEP3R('GNORM',GNORM,1.) C C Dimensions of the new grid related to the old one: O1=(O1NEW+0.5*D1NEW-O1)/D1 O2=(O2NEW+0.5*D2NEW-O2)/D2 O3=(O3NEW+0.5*D3NEW-O3)/D3 O4=(O4NEW+0.5*D4NEW-O4)/D4 D1=D1NEW/D1 D2=D2NEW/D2 D3=D3NEW/D3 D4=D4NEW/D4 N123 =N1*N2*N3 N1234N=N1NEW*N2NEW*N3NEW*N4NEW C IF((N1NEW.GT.0.AND.D1.LE.0.).OR. * (N2NEW.GT.0.AND.D2.LE.0.).OR. * (N3NEW.GT.0.AND.D3.LE.0.).OR. * (N4NEW.GT.0.AND.D4.LE.0.)) THEN C GRDNORM-04 CALL ERROR('GRDNORM-04: Oposite signs of grid steps)') C D1NEW must have the same sign as D1, C D2NEW must have the same sign as D2, C D3NEW must have the same sign as D3 and C D4NEW must have the same sign as D4 in this version. END IF IF(N1234N+N123.GT.MRAM) THEN C GRDNORM-01 CALL ERROR('GRDNORM-01: Too small array RAM(MRAM)') C Too small array RAM(MRAM) to allocate both input and output C grid values. If possible, increase dimension MRAM in include C file ram.inc. END IF C C Reading input grid values: OPEN(LU,FILE=FILE2,FORM='FORMATTED',STATUS='OLD') C C Calculating the spatial densities of the Lebesgue norm: NALL=0 I4MIN=0 DO 24 I4NEW=0,N4NEW-1 IF(I4NEW.LT.N4NEW-1) THEN X4=O4+FLOAT(I4NEW)*D4 I4MAX=MIN0(INT(X4),N4-1) ELSE I4MAX=N4-1 END IF IF(N1234N+N123*(I4MAX-I4MIN).GT.MRAM) THEN C GRDNORM-05 CALL ERROR('GRDNORM-05: Too small array RAM(MRAM)') C Too small array RAM(MRAM) to allocate both input and output C grid values. If possible, increase dimension MRAM in include C file ram.inc. END IF DO 10 I4=0,I4MAX-I4MIN CALL RARRAY(LU,' ','FORMATTED',.TRUE.,UNDEF, * N123,RAM(N1234N+N123*I4+1)) 10 CONTINUE I3MIN=0 DO 23 I3NEW=0,N3NEW-1 IF(I3NEW.LT.N3NEW-1) THEN X3=O3+FLOAT(I3NEW)*D3 I3MAX=MIN0(INT(X3),N3-1) ELSE I3MAX=N3-1 END IF I2MIN=0 DO 22 I2NEW=0,N2NEW-1 IF(I2NEW.LT.N2NEW-1) THEN X2=O2+FLOAT(I2NEW)*D2 I2MAX=MIN0(INT(X2),N2-1) ELSE I2MAX=N2-1 END IF INEW=N1NEW*(I2NEW+N2NEW*(I3NEW+N3NEW*I4NEW)) I1MIN=0 DO 21 I1NEW=0,N1NEW-1 IF(I1NEW.LT.N1NEW-1) THEN X1=O1+FLOAT(I1NEW)*D1 I1MAX=MIN0(INT(X1),N1-1) ELSE I1MAX=N1-1 END IF RAMNEW=0. NSUB=0 NSUBA=0 DO 14 I4=0,I4MAX-I4MIN DO 13 I3=I3MIN,I3MAX DO 12 I2=I2MIN,I2MAX I=N1234N+I1MIN+N1*(I2+N2*(I3+N3*I4)) DO 11 I1=I1MIN,I1MAX I=I+1 NSUBA=NSUBA+1 IF(RAM(I).NE.UNDEF) THEN NSUB=NSUB+1 IF(GNORM.EQ.0.) THEN RAMNEW=RAMNEW+ALOG(ABS(RAM(I))) ELSE IF(GNORM.EQ.1.) THEN RAMNEW=RAMNEW+RAM(I) ELSE IF(GNORM.GT.998.) THEN IF(NSUB.LE.1) THEN RAMNEW= RAM(I) ELSE RAMNEW=AMAX1(RAM(I),RAMNEW) END IF ELSE IF(GNORM.LT.-998.) THEN IF(NSUB.LE.1) THEN RAMNEW= RAM(I) ELSE RAMNEW=AMIN1(RAM(I),RAMNEW) END IF ELSE RAMNEW=RAMNEW+ABS(RAM(I))**GNORM END IF END IF 11 CONTINUE 12 CONTINUE 13 CONTINUE 14 CONTINUE NALL=NALL+NSUBA IF(NSUBA.EQ.0) THEN C C GRDNORM-02 CALL ERROR('GRDNORM-02: Empty subgrid') C The Lebesgue norm cannot be calculated and averaged C over an empty subgrid consisting of no gridpoint of C the given grid. Check the data for the 'new' grid. END IF IF(NSUB.EQ.0) THEN RAMNEW=UNDEF ELSE IF(GNORM.GE.-998..AND.GNORM.LE.998.) THEN RAMNEW=RAMNEW/FLOAT(NSUB) IF(GNORM.EQ.0.) THEN RAMNEW=EXP(RAMNEW) ELSE IF(GNORM.NE.1.) THEN RAMNEW=RAMNEW**(1./GNORM) END IF END IF INEW=INEW+1 RAM(INEW)=RAMNEW I1MIN=I1MAX+1 21 CONTINUE I2MIN=I2MAX+1 22 CONTINUE I3MIN=I3MAX+1 23 CONTINUE I4MIN=I4MAX+1 24 CONTINUE IF(NALL.NE.N1*N2*N3*N4) THEN WRITE(*,*) ' Subgrids cover',NALL,' gridpoints of',N1*N2*N3*N4 C GRDNORM-03 CALL ERROR('GRDNORM-03: Gaps between subgrids') C This error should not apperar. Contact the author. END IF C C Writing output grid values: CALL WARAY(LU,FILE3,'FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1NEW*N2NEW*N3NEW,N4NEW,RAM(1)) WRITE(*,'(A)') * '+GRDNORM: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdps.for 0100666 0000765 0000765 00000075376 10062244274 012303 0 ustar bulant bulant C
C Program GRDPS to Display GRiD values in Post Script C C Version: 5.80 C Date: 2004, June 11 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input and output files: C GRD='string' ... Name of the input ASCII file with the grid values C to be plotted. C For general description of files with gridded data refer C to file forms.htm. C Default: GRD='grd.out' C PS='string' ... Name of the output PostScript file. C If non-blank PSHEX is given, output file PS contains just C the prolog part of the output PostScript file, see PSHEX. C If the value of parameter N4 is greater than 1, PS is C the output filename for the first spatial grid. C The filenames for the subsequent spatial grids are C generated in such a way that all digits contained within C the filename are considered a number which is increased C by 1 for each new time slice. C Default: PS='grd.ps' C PSHEX='string' ... Optional name of the output file containing C hexadecimal grid data and the PostScript trailer. C If PSHEX is blank (default), file PS contains the whole C PostScript file. C Otherwise, file PS contains just the prolog, setup, and C object definition parts, whereas the grid data are written C to file PSHEX. C The separation into two files is designed to facilitate C batch or manual editing of the PostScript definitions. C Resulting PostScript file is then obtained by merging C PS, possible new definitions and PSHEX. C If the value of parameter N4 is greater than 1, PSHEX is C the output filename for the first spatial grid. C The filenames for the subsequent spatial grids are C generated in such a way that all digits contained within C the filename are considered a number which is increased C by 1 for each new time slice. C Default: PSHEX=' ' C GRDPS2='string', GRDPS3='string', ... , GRDPS9='string' ... Names C of the optional input ASCII files with the grid values to C be plotted together with data of GRD. C For example, data GRD may control hue (colour) and data C GRDPS2 may control brightness or saturation. C For general description of files with gridded data refer C to file forms.htm. C Defaults: GRDSP2=' ', ... , GRDPS9=' ' C Data specifying grid dimensions: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C N4=positive integer... Number of time slices (snapshots). C Individual time slices from the input file 'FILEIN' are C separated into different files. The name(s) of the first C file(s) is(are) given by input parameters 'PS' and C 'PSHEX' described above. Next filenames are generated in C such a way that all digits contained within the filenames C are considered as numbers which are increased by 1 for C each new time slice. C Default: N4=1 C D4=real... Time interval between two consecutive time slices. C Useful only if explicitly specifying time-dependent colour C scaling of snapshots (see input parameters VCIRC4, VSAT4 C and VBRI4 below). C Default: D4=1. C Additional data specific to this program: C (a) Dimensions and layout: C NH=positive integer... Layout of 2-D sections of a 3-D grid. C Individual 2-D sections of dimensions N1*N2 are merged C into rows NH sections long. Resulting (N3-1)/NH+1 rows C are merged together to form the final image. C Default: NH=INT(SQRT(N3)) C UNIT='string'... All lengths controlling the size and position of C the plot are assumed to be expressed in the units given C by the string. The units also influence the default C paper size, plot size and margins. Allowed values: C UNIT='cm': centimetres (default), C UNIT='in': inches (1in=2.54cm), C UNIT='pt': big points (1in=72pt). C Points (pt) are useful to generate plots for conversion to C bitmap forms, e.g., using GhostScript. C Default: UNIT='cm' C XSIGN=real... Determines the sign of the default value of HSIZE. C Default: XSIGN=1. C HSIZE=real... Size (in UNITs) of the image, corresponding to the C X1 axis (horizontal before a possible rotation). C If negative, the values will be displayed from the right C to the left. C Default: HSIZE=SIGN( 16.0,XSIGN) for UNIT='cm', C HSIZE=SIGN( 6.5,XSIGN) for UNIT='in', C HSIZE=SIGN(NH*N1,XSIGN) for UNIT='pt'. C YSIGN=real... Determines the sign of the default value of VSIZE. C Default: YSIGN=1. C VSIZE=real... Size (in UNITs) of the image, corresponding to the C X2 axis (vertical before a possible rotation). C If negative, the values will be displayed from the top to C the bottom. C Default (proportional display): C VSIZE=SIGN(HSIZE*((N3-1)/NH+1)*N2/(NH*N1),YSIGN), i.e., C VSIZE=SIGN(HSIZE*N2/N1,YSIGN) for N3=1. C HOFFSET=real... Distance (in UNITs) of the image from the leftmost C paper edge (before a possible rotation). Controls the C horizontal position of the figure. C Default: HOFFSET=2.5 for UNIT='cm', C HOFFSET=1.0 for UNIT='in', C HOFFSET=0.0 for UNIT='pt'. C VOFFSET=real... Distance (in UNITs) of the image from the bottom C paper edge (before a possible rotation). Controls the C vertical position of the figure. C Default: C if VSIZE.LE.HEIGHT-2*2.5: VOFFSET=HEIGHT-2.5-VSIZE C otherwise if VSIZE.LE.HEIGHT: VOFFSET=(HEIGHT-VSIZE)/2. C otherwise: VOFFSET=2.5 C HEIGHT=real... Height of the paper in a portrait position. C Default: HEIGHT=29.7 for UNIT='cm', C HEIGHT=11.0 for UNIT='in', C HEIGHT=((N3-1)/NH+1)*N2 for UNIT='pt'. C ROTATE=real... Enables to rotate the image by angle specified in C degrees (positive counterclockwise). The image is rotated C around the centre of the square paper of size HEIGHT. C If applied, the user will probably wish to specify the C value of ROTATE=90. C Parameters HSIZE,VSIZE,HOFFSET,VOFFSET apply to the image C before rotation. C Attention: BoundingBox is incorrect if ROTATE is not C multiple of 90 degrees. C Default: ROTATE=0. C (b) Range of displayed values: C VMIN=real, VMAX=real... Values less than or equal to VMIN, C or greater than or equal to VMAX will be deemed C undefined. For example, if VMIN=0 is set when plotting C velocities, zero velocities are rendered as undefined C values, that is usually desirable. C Defaults: VMIN=-999999, VMAX=999999000000. C R=real, G=real, B=real... Colour of the undefined C values. C Defaults: R=0.80, G=0.80, B=0.80 (light grey) C (c) Colour interpretation of values contained within file GRD: C VPLUS=real, VSIGN=real, VCIRC=real... VCIRC is the extent of C values corresponding to the whole colour circle RGB. C Negative VCIRC corresponds to the opposite direction C around the colour circle (BGR). C Undefined values are displayed in gray. C Defaults: VPLUS=0, VSIGN=1, C VCIRC=(GMAX1-GMIN1+VPLUS)*VSIGN, C where GMINi and GMAXi are the minimum and maximum grid C values defined in file 'GRDi'. C If the above value of VCIRC is zero (e.g., if C GMAX1=GMIN1), the default value of VCIRC is changed to C VCIRC=1. C Hint: Specify VPLUS=1 when plotting integer values. C Hint: To plot velocities with blue minimum velocity, C increasing through green, yellow and red again to blue, C specify VMIN=0 and VSIGN=-1 with default VREF and CREF. C VREF=real, CREF=real... Value VREF corresponds to colour CREF, C where Red=0, Yellow=1/6, Green=2/6, Cyan=3/6, Blue=4/6, C Magenta=5/6, Red=1, Yellow=7/6, Green=8/6, etc. C Default: VREF=GMIN1, CREF=4/6 (blue). C where GMIN1 is the minimum defined grid value. C Default VMIN, VMAX, VPLUS, VSIGN, VCIRC, VREF and CREF C render the central value (GMIN1+GMAX1)/2 in yellow. C Hint: To plot the values oscillating around 0, you may C wish to set VREF=0 and CREF=0.166667 to render 0 in C yellow. C VCIRC4=real... If VCIRC is specified, VCIRC4 enables to modify it C in dependence on progressing time levels I4=1,2,...,N4: C VCIRC(I4)=VCIRC*EXP(-VCIRC4*(I4-1)*D4) C Default: VCIRC4=0. C (d) Saturation interpretation of values contained within file GRDPS2: C VSAT=real... The extent of values corresponding to the whole C saturation range from 0 (white) to 1 (fully saturated C colours). C Default: VSAT=GMAX2-GMIN2 (or VSAT=1 for GMIN2=GMAX2). C VWHITE=real... Value corresponding to white (saturation=0). C Default: VWHITE=GMIN2 (strictly speaking, =GMAX2-VSAT). C VSAT4=real... If VSAT is specified, VSAT4 enables to modify it in C dependence on progressing time levels I4=1,2,...,N4: C VSAT(I4)=VSAT*EXP(-VSAT4*(I4-1)*D4) C Default: VSAT4=0. C (e) Brightness interpretation of values contained within file GRDPS3: C VBRI=real... The extent of values corresponding to the whole C brightness range from 0 (black) to 1 (bright colours). C Default: VBRI=GMAX3-GMIN3 (or VBRI=1 for GMIN3=GMAX3). C VBLACK=real... Value corresponding to black (brightness=0). C Default: VBLACK=GMIN3 (strictly speaking, =GMAX3-VBRI). C VBRI4=real... If VBRI is specified, VBRI4 enables to modify it in C dependence on progressing time levels I4=1,2,...,N4: C VBRI(I4)=VBRI*EXP(-VBRI4*(I4-1)*D4) C Default: VBRI4=0. C (f) Form of the output PostScript file: C SHOWPAGE=integer... PostScript command 'showpage' at the end of C file directs printer to print and delete the picture. C This is usually what we want. However, sometimes we may C wish to overlay the picture with another one. In this C case, we wish to remove the 'showpage'. C SHOWPAGE=0: Two last lines of the file containing strings C 'showpage' and '%%EOF' are not written. C SHOWPAGE=1: The lines are written. C Default: SHOWPAGE=1 C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER MGRID PARAMETER (MGRID=MRAM) REAL GRID(MGRID) EQUIVALENCE (GRID,RAM) INTEGER IGRID(MGRID) EQUIVALENCE (GRID,IGRID) C C....................................................................... C CHARACTER*2 UNIT REAL UNITPT,HEIGHT,OFFSET,WIDTH C C UNIT... One of: 'cm', 'in', 'pt'. C UNITPT...Size of the length unit, in which input data controlling C the size and position of the plot are expressed, in big C points (pt). E.g., UNITPT=72./2.54 corresponds to C plotting in cm. C HEIGHT..Anticipated height of the paper sheet. C OFFSET..Left margin, and top or bottom margin for low or high C plots, respectively. C WIDTH...Default width of the plot. C INTEGER MFILE,LU PARAMETER (MFILE=9,LU=10) CHARACTER*80 FSEP,FPS,FPSHEX,FILE(MFILE) CHARACTER*1 HEX1(0:15) CHARACTER*2 HEX2(0:255) CHARACTER*6 FGRDPS INTEGER LUIN(MFILE) REAL UNDEF PARAMETER (UNDEF=-999999.) INTEGER NFILE,IFILE,N1,N2,N3,N31,N32,N4,J,J0,I,I0,I1,I2,I31,I32,I4 INTEGER ISHOW REAL XSIGN,YSIGN REAL VMIN,VMAX,VPLUS,VSIGN,VCIRC,VREF,CREF,ROTATE,RED,GREEN,BLUE REAL GMIN(MFILE),GMAX(MFILE),G,G0,GSTEP REAL BBOX1,BBOX2,BBOX3,BBOX4,BB1,BB2,BB3,BB4 REAL BB1P,BB2P,BB3P,BB4P,BB2DEF,BB4DEF,AUX,VAUX,C,S DATA LUIN /1,2,3,4,5,6,7,8,9/ DATA HEX1 * /'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'/ C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDPS: Enter input filename: ' FSEP=' ' READ(*,*) FSEP WRITE(*,'(A)') '+GRDPS: Working ... ' C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C GRDPS-04 CALL ERROR('GRDPS-04: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('GRD',FILE(1),'grd.out') CALL RSEP3T('PS',FPS,'grd.ps') CALL RSEP3T('PSHEX',FPSHEX,' ') FGRDPS='GRDPS0' DO 12 IFILE=1,MFILE FGRDPS(6:6)=CHAR(ICHAR('0')+IFILE) IF (IFILE.NE.1) CALL RSEP3T(FGRDPS,FILE(IFILE),' ') IF(FILE(IFILE).EQ.' ') THEN NFILE=IFILE-1 GO TO 13 END IF 12 CONTINUE 13 CONTINUE CALL RSEP3I('SHOWPAGE',ISHOW,1) C C Recalling the data specifying grid dimensions C (arguments: Name of value in input data, Variable, Default): CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3I('N4',N4,1) C Transforming 2-D arrays to N1*N2*1 and 1-D arrays to N1*1*1 IF(N1.EQ.1) THEN N1=N2 N2=N3 N3=1 END IF IF(N1.EQ.1) THEN N1=N2 N2=1 END IF IF(N2.EQ.1) THEN N2=N3 N3=1 END IF C Determining the layout of 2-D slices of 3-D arrays CALL RSEP3I('NH',N31,INT(SQRT(FLOAT(N3))+.001)) N32=(N3-1)/N31+1 IF(N1*N2*N31*N32*NFILE.GT.MGRID) THEN C GRDPS-01 CALL ERROR('GRDPS-01: Too small array RAM(MRAM)') C Array RAM(MRAM) allocated in include file 'ram.inc' is too small C to contain the grid values to be plotted. You may wish to C increse the dimension MRAM in file 'ram.inc'. C ram.inc END IF C N3 slices will be arranged into N31*N32 slices. C C Recalling the plotting unit and setting default dimensions: CALL RSEP3T('UNIT',UNIT,'cm') CALL LOWER(UNIT) IF(UNIT.EQ.'cm') THEN UNITPT=72./2.54 HEIGHT=29.7 OFFSET=2.5 WIDTH=16.0 ELSE IF(UNIT.EQ.'in') THEN UNITPT=72. HEIGHT=11.0 OFFSET=1.0 WIDTH=6.5 ELSE IF(UNIT.EQ.'pt') THEN UNITPT=1. HEIGHT=FLOAT(N32*N2) OFFSET=0.0 WIDTH=FLOAT(N31*N1) ELSE C GRDPS-02 CALL ERROR('GRDPS-02: Unrecognized plotting units') C Allocated plotting units are UNIT='cm', UNIT='in' or UNIT='pt'. END IF C....................................................................... C C Loop over time slices: DO 90 I4=1,N4 IF(I4.EQ.1) THEN IF(N4.GT.1) THEN DO 15 IFILE=1,NFILE OPEN(LUIN(IFILE),FILE=FILE(IFILE), * FORM='FORMATTED',STATUS='OLD') FILE(IFILE)=' ' 15 CONTINUE END IF ELSE C Generating new output filenames: CALL NEWNAM(FPS) CALL NEWNAM(FPSHEX) END IF C C Reading input grid values: DO 16 IFILE=1,NFILE CALL RARRAY(LUIN(IFILE),FILE(IFILE),'FORMATTED',.TRUE.,UNDEF, * N1*N2*N3,GRID(N1*N2*N31*N32*(IFILE-1)+1)) 16 CONTINUE C C Rearranging 3-D input N1*N2*N3 grid into (N1*N31)*(N2*N32) grid: DO 29 IFILE=0,N1*N2*N31*N32*(NFILE-1),N1*N2*N31*N32 C Extending the grid to N1*N2*N31*N32 points DO 21 I=IFILE+N1*N2*N3+1,IFILE+N1*N2*N31*N32 GRID(I)=UNDEF 21 CONTINUE C Transposing the N1*N2*N31*N32 grid to N1*N31*N2*N32 grid DO 25 I32=0,N2*N31*(N32-1),N2*N31 DO 24 I0=0,N2*N31-1 J0=I0 22 CONTINUE I2=J0/N31 I31=J0-I2*N31 J0=I31*N2+I2 IF(J0.LT.I0) GO TO 22 I=IFILE+(I32+I0)*N1 J=IFILE+(I32+J0)*N1 DO 23 I1=1,N1 I=I+1 J=J+1 AUX=GRID(I) GRID(I)=GRID(J) GRID(J)=AUX 23 CONTINUE 24 CONTINUE 25 CONTINUE 29 CONTINUE C N1=N1*N31 N2=N2*N32 C C....................................................................... C C Recalling the data for the plotting area: CALL RSEP3R('XSIGN' ,XSIGN,1.) CALL RSEP3R('YSIGN' ,YSIGN,1.) AUX=HEIGHT CALL RSEP3R('HEIGHT' ,HEIGHT,AUX) CALL RSEP3R('HSIZE' ,BB3,SIGN(WIDTH,XSIGN)) CALL RSEP3R('HOFFSET',BB1,OFFSET) C Default height of the figure BB4DEF=ABS(BB3)*FLOAT(N2)/FLOAT(N1) CALL RSEP3R('VSIZE' ,BB4,SIGN(BB4DEF,YSIGN)) C Default vertical position of the figure IF(ABS(BB4).LE.HEIGHT-2.*OFFSET) THEN BB2DEF=HEIGHT-OFFSET-ABS(BB4) ELSE IF(ABS(BB4).LE.HEIGHT) THEN BB2DEF=(HEIGHT-ABS(BB4))/2. ELSE BB2DEF=OFFSET END IF CALL RSEP3R('VOFFSET',BB2,BB2DEF) IF(BB3.LT.0.) THEN BB1=BB1-BB3 END IF IF(BB4.LT.0.) THEN BB2=BB2-BB4 END IF CALL RSEP3R('ROTATE',ROTATE,0.) C C Transformation from plotting units (e.g. centimetres) to points: BB1P=BB1*UNITPT BB2P=BB2*UNITPT BB3P=BB3*UNITPT BB4P=BB4*UNITPT C Bounding box: BBOX1=AMIN1(BB1P,BB1P+BB3P) BBOX2=AMIN1(BB2P,BB2P+BB4P) BBOX3=AMAX1(BB1P,BB1P+BB3P) BBOX4=AMAX1(BB2P,BB2P+BB4P) IF(ROTATE.NE.0.) THEN C=COS(ROTATE*3.14159/180.) S=SIN(ROTATE*3.14159/180.) BBOX1=BBOX1-HEIGHT*UNITPT/2. BBOX2=BBOX2-HEIGHT*UNITPT/2. BBOX3=BBOX3-HEIGHT*UNITPT/2. BBOX4=BBOX4-HEIGHT*UNITPT/2. AUX =C*BBOX1-S*BBOX2 BBOX2=S*BBOX1+C*BBOX2 BBOX1=AUX AUX =C*BBOX3-S*BBOX4 BBOX4=S*BBOX3+C*BBOX4 BBOX3=AUX BBOX1=BBOX1+HEIGHT*UNITPT/2. BBOX2=BBOX2+HEIGHT*UNITPT/2. BBOX3=BBOX3+HEIGHT*UNITPT/2. BBOX4=BBOX4+HEIGHT*UNITPT/2. AUX =AMIN1(BBOX1,BBOX3) BBOX3=AMAX1(BBOX1,BBOX3) BBOX1=AUX AUX =AMIN1(BBOX2,BBOX4) BBOX4=AMAX1(BBOX2,BBOX4) BBOX2=AUX END IF C C....................................................................... C C Calculating minimum and maximum values GMIN(*) and GMAX(*): CALL RSEP3R('VMIN',VMIN,-999999.) CALL RSEP3R('VMAX',VMAX, 999999000000.) DO 33 IFILE=1,NFILE NNN=N1*N2*(IFILE-1) GMINI=VMAX GMAXI=VMIN DO 31 I=NNN+1,NNN+N1*N2 G=GRID(I) IF(G.NE.UNDEF) THEN IF(G.LE.VMIN.OR.VMAX.LE.G) THEN GRID(I)=UNDEF ELSE GMINI=AMIN1(GMINI,G) GMAXI=AMAX1(GMAXI,G) END IF END IF 31 CONTINUE C C Rescaling range GMIN--GMAX to 0--254 c (undefined values are 255): IF(GMINI.NE.GMAXI) THEN GSTEP=(GMAXI-GMINI)/254. ELSE GSTEP=1. END IF G0=GMINI-GSTEP/2. DO 32 I=NNN+1,NNN+N1*N2 IF(GRID(I).NE.UNDEF) THEN G=(GRID(I)-G0)/GSTEP IGRID(I)=INT(G) ELSE IGRID(I)=255 END IF 32 CONTINUE C GMIN(IFILE)=GMINI GMAX(IFILE)=GMAXI 33 CONTINUE C C Preparing hexadecimal coding table: I=0 DO 42 I2=0,15 DO 41 I1=0,15 HEX2(I)(1:1)=HEX1(I2) HEX2(I)(2:2)=HEX1(I1) I=I+1 41 CONTINUE 42 CONTINUE C C Parameters controlling colours: CALL RSEP3R('D4' ,D4 ,1.) TIME=FLOAT(I4-1)*D4 CALL RSEP3R('VPLUS' ,VPLUS ,0.) CALL RSEP3R('VSIGN' ,VSIGN ,1.) CALL RSEP3R('VCIRC4',VAUX ,0.) VAUX=EXP(VAUX*TIME) AUX=(GMAX(1)-GMIN(1)+VPLUS)*VSIGN*VAUX IF(AUX.EQ.0.) AUX=1. CALL RSEP3R('VCIRC' ,VCIRC ,AUX) VCIRC=VCIRC/VAUX CALL RSEP3R('VREF' ,VREF ,GMIN(1)) CALL RSEP3R('CREF' ,CREF ,2./3.) IF(NFILE.GE.2) THEN CALL RSEP3R('VSAT4' ,VAUX ,0.) VAUX=EXP(VAUX*TIME) AUX=(GMAX(2)-GMIN(2))*VAUX IF(AUX.EQ.0.) AUX=1. CALL RSEP3R('VSAT' ,VSAT ,AUX) VSAT=VSAT/VAUX CALL RSEP3R('VWHITE',VWHITE,GMAX(2)-AUX) END IF IF(NFILE.GE.3) THEN CALL RSEP3R('VBRI4' ,VAUX ,0.) VAUX=EXP(VAUX*TIME) AUX=(GMAX(3)-GMIN(3))*VAUX IF(AUX.EQ.0.) AUX=1. CALL RSEP3R('VBRI' ,VBRI ,AUX) VBRI=VBRI/VAUX CALL RSEP3R('VBLACK',VBLACK,GMAX(3)-AUX) END IF C C Writing PostScript prolog: WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Writing: ',FPS(1:MIN0(LEN(FPS),70)) OPEN(LU,FILE=FPS) WRITE(LU,'(A/A,4I6,/(A))') * '%!PS-Adobe-3.0', * '%%BoundingBox:',INT(BBOX1+.5),INT(BBOX2+.5), * INT(BBOX3+.5),INT(BBOX4+.5), * '%%EndComments', * '%%BeginProlog', * '%%BeginProcSet: (grdps)', * '%%Creator: grdps', * '%-----------------------------------------------------------', * '% Default UNDEFINED procedure:' C520 WRITE(LU,'(A)') C520 * '/UNDEFINED {0 0 0.80 sethsbcolor} bind def' CALL RSEP3R('R',RED ,0.80) CALL RSEP3R('G',GREEN,0.80) CALL RSEP3R('B',BLUE ,0.80) WRITE(LU,'(A,3(F4.2,1X),A)') * '/UNDEFINED {',RED,GREEN,BLUE,'setrgbcolor} bind def' WRITE(LU,'(A)') * '% Default VALUEtoCOLOR procedure:' WRITE(LU,'(3(A,G13.6)/A,G13.6,A/A,G13.6,A/A)') * '/VCIRC ',VCIRC ,' def % Range of grid values:', * GMIN(1),' to',GMAX(1), * '/VREF ',VREF ,' def', * '/CREF ',CREF ,' def', * '/VRED VREF CREF VCIRC mul sub def' IF(NFILE.GE.2) THEN WRITE(LU,'(3(A,G13.6)/A,G13.6,A)') * '/VSAT ',VSAT ,' def % Range of grid values:', * GMIN(2),' to',GMAX(2), * '/VWHITE ',VWHITE,' def' END IF IF(NFILE.GE.3) THEN WRITE(LU,'(3(A,G13.6)/A,G13.6,A)') * '/VBRI ',VBRI ,' def % Range of grid values:', * GMIN(3),' to',GMAX(3), * '/VBLACK ',VBLACK,' def' END IF WRITE(LU,'(A)') * '/VALUEtoCOLOR{' IF(NFILE.LE.1) THEN WRITE(LU,'(A)') * ' VRED sub VCIRC div dup truncate sub dup 0 lt {1 add} if' ELSE WRITE(LU,'(A,I1,9A))') * ' ',NFILE,' -1 roll', * ' VRED sub VCIRC div dup truncate sub dup 0 lt {1 add} if' END IF IF(NFILE.LE.1) THEN WRITE(LU,'(A)') * ' 1' ELSE WRITE(LU,'(A,I1,9A))') * ' ',NFILE,' -1 roll', * ' VWHITE sub VSAT div' END IF IF(NFILE.LE.2) THEN WRITE(LU,'(A)') * ' 1' ELSE WRITE(LU,'(A,I1,9A))') * ' ',NFILE,' -1 roll', * ' VBLACK sub VBRI div' END IF DO 51 IFILE=4,NFILE WRITE(LU,'(A)') * ' pop' 51 CONTINUE WRITE(LU,'(A)') * ' sethsbcolor} bind def', * '%-----------------------------------------------------------', * '% User-defined VALUEtoCOLOR procedure may be inserted here:' IF(FPSHEX.NE.' ') THEN CLOSE(LU) WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Writing: ',FPSHEX(1:MIN0(LEN(FPSHEX),70)) OPEN(LU,FILE=FPSHEX) END IF C C Writing the plotting procedure: WRITE(LU,'(A)') * '%-----------------------------------------------------------', * '%%EndProcSet', * '%%EndProlog', * '%-----------------------------------------------------------', * '%%BeginSetup', * '% Numerical values describing the image size and position:' WRITE(LU,'(A,I6,A)') '/N1',N1,' def' WRITE(LU,'(A,I6,A)') '/N2',N2,' def' WRITE(LU,'(A,F8.1,A,F8.3,A)') '/BB1',BB1P,' def %',BB1,'cm' WRITE(LU,'(A,F8.1,A,F8.3,A)') '/BB2',BB2P,' def %',BB2,'cm' WRITE(LU,'(A,F8.1,A,F8.3,A)') '/BB3',BB3P,' def %',BB3,'cm' WRITE(LU,'(A,F8.1,A,F8.3,A)') '/BB4',BB4P,' def %',BB4,'cm' WRITE(LU,'(A,F8.1,A)') '/PAPERSIZE',HEIGHT*UNITPT,' def' WRITE(LU,'(A,F8.1,A)') '/ROTATE',ROTATE,' def' WRITE(LU,'(A)') * '% Scaling of grid values:' DO 52 IFILE=1,NFILE WRITE(LU,'(A,I1,A,G13.6,A)') * '/GMIN',IFILE,' ',GMIN(IFILE),' def' WRITE(LU,'(A,I1,A,G13.6,A)') * '/GMAX',IFILE,' ',GMAX(IFILE),' def' 52 CONTINUE WRITE(LU,'(A)') * '%%EndSetup', * '%-----------------------------------------------------------', * '%%BeginObject: (grdps)', * 'PAPERSIZE 2 div dup translate ROTATE rotate', * 'PAPERSIZE -2 div dup translate', * '/SCALE1 N1 BB3 div def', * '/SCALE2 N2 BB4 div def' DO 53 IFILE=1,NFILE WRITE(LU,'(9(A,I1))') * '/VSTEP',IFILE,' GMAX',IFILE,' GMIN',IFILE,' sub 254 div def' 53 CONTINUE WRITE(LU,'(A)') * '/RGB 3 string def', * 'N1 N2 8 [ SCALE1 0 0 SCALE2 BB1 SCALE1 mul neg', * ' BB2 SCALE2 mul neg ]' WRITE(LU,'(A,I1,A)') * '{currentfile ',NFILE,' string readhexstring pop' DO 54 IFILE=1,NFILE WRITE(LU,'(9(A,I1))') * ' dup ',IFILE-1, * ' get VSTEP',IFILE,' mul GMIN',IFILE,' add exch' 54 CONTINUE WRITE(LU,'(11A)') * ' 0 get 255 eq {',('pop ',IFILE=1,NFILE), * 'UNDEFINED} {VALUEtoCOLOR} ifelse' WRITE(LU,'(A)') * ' currentrgbcolor', * ' 255 mul .5 add cvi RGB exch 2 exch put', * ' 255 mul .5 add cvi RGB exch 1 exch put', * ' 255 mul .5 add cvi RGB exch 0 exch put RGB}', * ' bind false 3 colorimage' C C Writing output hexadecimal values: N12=N1*N2 NNN=N1*N2*NFILE IF(NFILE.EQ.1) THEN WRITE(LU,'(40A2)') (HEX2(IGRID(I)),I=1,N12) ELSE DO 61 I=N12+1,NNN IF(IGRID(I).GE.255) THEN IGRID(MOD(I,N12))=255 END IF 61 CONTINUE WRITE(LU,'(40A2)') * ((HEX2(IGRID(IFILE)),IFILE=I,NNN,N12),I=1,N12) END IF C C Writing PostScript trailer: WRITE(LU,'(A)') * 'PAPERSIZE 2 div dup translate ROTATE neg rotate', * 'PAPERSIZE -2 div dup translate', * '%%EndObject' IF(ISHOW.NE.0) THEN WRITE(LU,'(A)') * 'showpage', * '%%EOF' END IF CLOSE(LU) C 90 CONTINUE C End of the loop over time slices. C IF(N4.GT.1) THEN DO 91 IFILE=1,NFILE CLOSE(LUIN(IFILE)) 91 CONTINUE END IF WRITE(*,'(A)') '+GRDPS: Done. ' STOP END C C======================================================================= C C C SUBROUTINE NEWNAM(NAME) CHARACTER*(*) NAME C C----------------------------------------------------------------------- C INTEGER N,I C IF(NAME.NE.' ') THEN N=LEN(NAME) 10 CONTINUE DO 11 I=N,1,-1 IF(LLE('0',NAME(I:I)).AND.LLE(NAME(I:I),'8')) THEN NAME(I:I)=CHAR(ICHAR(NAME(I:I))+1) GO TO 12 ELSE IF(NAME(I:I).EQ.'9') THEN NAME(I:I)='0' N=I-1 GO TO 10 END IF 11 CONTINUE C GRDPS-03 CALL ERROR('GRDPS-03: Too many output files') C The digits in the template name of the output files do not C allow for the generation of all output filenames. C The number of digits should be increased. 12 CONTINUE END IF RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdpts.for 0100666 0000765 0000765 00000033452 07224266010 012452 0 ustar bulant bulant C
C Program GRDPTS to generate the file containing the coordinates of all C gridpoints of the given grid. C C Version: 5.50 C Date: 2001, January 2 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Name of the optional input file: C GRD='string'... String with the name of the input data file C containing the grid values. C This file is used only if KOLUMN.NE.0, see below. C The grid may also contain undefined values. In this case, C if KOLUMN.NE.0, the gridpoints with undefined values are C not written to output file PTS. C If the filename is blank, all gridded values are assumed C undefined. C No default, GRD must be specified and cannot be blank if C KOLUMN.NE.0. C Names of the output files: C PTS='string'...Name of the output file with the coordinates C of the gridpoints. C The file is not generated if PTS=' '. C Default: PTS='pts.out' C PLGN='string'... Name of the optional output file specifying the C polygons coinciding with grid faces. C The polygons are described in terms of the indices of C their vertices. C The file is not generated if PLGN=' ' (default). C For 3-D virtual reality, the polygons should be divided C into triangles by program trgl.for. C Since the vertices have no normals, the current version of C program trgl.for does not work with them and parameter C TRGL should be used instead of PLGN. C Description of file PLGN C Default: PLGN=' ' C TRGL='string'... Name of the optional output file specifying the C triangles covering grid faces. C The triangles are described in terms of the indices of C their vertices. C The file is not generated if TRGL=' ' (default). C Description of file TRGL C Default: TRGL=' ' C Data specifying the form of the output file with points: C KOLUMN=integer ... If non-zero, specifies the position in output C file PTS where to write the values at gridpoints. C KOLUMN=0: Grid values are not written to file PTS. C KOLUMN=1, 2 or 3: The corresponding coordinate is C replaced with grid values. C KOLUMN=4: The corresponding coordinate is written after C the three coordinates, into the fourth numeric column. C Default: KOLUMN=0 C Data specifying grid dimensions: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C O1=real... First coordinate of the grid origin (first point of the C grid). C Default: O1=0. C O2=real... Second coordinate of the grid origin. C Default: O2=0. C O3=real... Third coordinate of the grid origin. C Default: O3=0. C D1=real... Grid interval in the direction of the first coordinate C axis. C Default: D1=1. C D2=real... Grid interval in the direction of the second coordinate C axis. C Default: D2=1. C D3=real... Grid interval in the direction of the third coordinate C axis. C Default: D3=1. C C C Output file PTS with the gridpoints: C (1) / C (2) For each gridpoint data (2.1): C (2.1) 'NNNNNN',X1,X2,X3,/ or C 'NNNNNN',X1,X2,X3,X4,/ C 'NNNNNN'... Name of the point - six-digit integer index of the C gridpoint (larger grids than 999999 gridpoints are not C expected to be converted into this form suitable for C a reasonably small number of points). C X1,X2,X3... Coordinates of the gridpoint. C X4... Optional grid value. C (3) / C C C Optional output file PLGN with the polygons: C (1) For each grid face data (1.1): C (1.1) I1,I2,I3,I4,/ C I1,I2,I3,I4... Integer indices of 4 vertices of the rectangle C forming the grid face. C The vertices are stored in file PTS and are indexed by C positive integers according to their order. C /... List of vertices is terminated by a slash. C C C Optional output file TRGL with the triangles: C (1) For each triangle data (1.1): C (1.1) I1,I2,I3,/ C I1,I2,I3... Integer indices of 3 vertices of one of two triangles C forming the grid face. C The vertices are stored in file PTS and are indexed by C positive integers according to their order. C /... List of vertices is terminated by a slash. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C C Filenames and parameters: CHARACTER*80 FILSEP,FGRD,FPTS,FPLGN,FTRGL INTEGER LU,LU2 REAL UNDEF PARAMETER (LU=1,LU2=2,UNDEF=-999999999.) C C Input data: INTEGER KOLUMN,N1,N2,N3 REAL O1,O2,O3,D1,D2,D3 C C Other variables: CHARACTER*42 FORMAT LOGICAL LWRITE INTEGER NCOL,N,I,I1,I2,I3,J1,J2,J3,J4 REAL X(4),X1,X2,X3,X4 EQUIVALENCE (X(1),X1),(X(2),X2),(X(3),X3),(X(4),X4) C C----------------------------------------------------------------------- C C Reading input SEP parameter file: WRITE(*,'(A)') '+GRDPTS: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP IF (FILSEP.EQ.' ') THEN C GRDPTS-01 CALL ERROR('GRDPTS-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF CALL RSEP1(LU,FILSEP) WRITE(*,'(A)') '+GRDPTS: Working ... ' C C Reading input parameters from the SEP file: CALL RSEP3T('GRD' ,FGRD ,' ') CALL RSEP3T('PTS' ,FPTS ,'pts.out') CALL RSEP3T('PLGN',FPLGN,' ') CALL RSEP3T('TRGL',FTRGL,' ') CALL RSEP3I('KOLUMN',KOLUMN,0) IF (KOLUMN.LT.0.OR.4.LT.KOLUMN) THEN C GRDPTS-02 CALL ERROR('GRDPTS-02: Wrong value of KOLUMN') C KOLUMN must be 0, 1, 2, 3 or 4. ENDIF IF (KOLUMN.NE.0.AND.FGRD.EQ.' ') THEN C GRDPTS-03 CALL ERROR('GRDPTS-03: File GRD not specified') C Input file GRD with gridded values must be specified if C KOLUMN.NE.0. C There is no default filename. ENDIF NCOL=MAX0(3,KOLUMN) C Data specifying grid dimensions CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) C C Writing output points: IF(FPTS.NE.' ') THEN IF(KOLUMN.NE.0) THEN IF(N1*N2*N3.GT.MRAM) THEN C GRDPTS-04 CALL ERROR('GRDPTS-04: Too small array RAM(MRAM)') C Array RAM(MRAM) allocated in include file 'ram.inc' is too C small to contain N1*N2*N3 grid values. C You may wish to increase the dimension MRAM in file C ram.inc. END IF C Reading grid values: CALL RARRAY(LU,FGRD,'FORMATTED',.TRUE.,UNDEF,N1*N2*N3,RAM) END IF OPEN(LU,FILE=FPTS) WRITE(LU,'(A)') '/' FORMAT(1:10)='(A,I6.6,A,' I=0 N=1 DO 23 I3=0,N3-1 X3=O3+D3*FLOAT(I3) DO 22 I2=0,N2-1 X2=O2+D2*FLOAT(I2) DO 21 I1=0,N1-1 X1=O1+D1*FLOAT(I1) I=I+1 IF(KOLUMN.EQ.0) THEN LWRITE=.TRUE. ELSE IF(RAM(I).NE.UNDEF) THEN X(KOLUMN)=RAM(I) IRAM(I)=N LWRITE=.TRUE. ELSE IRAM(I)=0 LWRITE=.FALSE. END IF END IF IF(LWRITE) THEN C Writing: CALL FORM2(NCOL,X,X,FORMAT(11:10+8*NCOL)) WRITE(LU,FORMAT) * '''',I,''' ',X1,(' ',X(J4),J4=2,NCOL),' /' N=N+1 END IF 21 CONTINUE 22 CONTINUE 23 CONTINUE WRITE(LU,'(A)') '/' CLOSE(LU) END IF C C Writing output polygons: IF(FPLGN.NE.' ') THEN OPEN(LU,FILE=FPLGN) END IF IF(FTRGL.NE.' ') THEN OPEN(LU2,FILE=FTRGL) END IF IF(FPLGN.NE.' '.OR.FTRGL.NE.' ') THEN DO 33 I3=0,N3-1 DO 32 I2=0,N2-2 DO 31 I1=0,N1-2 I=1+I1+N1*(I2+N2*I3) J1=I J2=I+1 J3=I+N1+1 J4=I+N1 IF(KOLUMN.NE.0) THEN J1=IRAM(J1) J2=IRAM(J2) J3=IRAM(J3) J4=IRAM(J4) END IF IF(FPLGN.NE.' ') THEN IF(J1.NE.0.AND.J2.NE.0.AND.J3.NE.0.AND.J4.NE.0) THEN WRITE(LU,'(4(I6,A))') J1,' ',J2,' ',J3,' ',J4,' /' END IF END IF IF(FTRGL.NE.' ') THEN IF(J1.NE.0.AND.J2.NE.0.AND.J3.NE.0) THEN WRITE(LU2,'(3(I6,A))') J1,' ',J2,' ',J3,' /' END IF IF(J1.NE.0.AND.J3.NE.0.AND.J4.NE.0) THEN WRITE(LU2,'(3(I6,A))') J1,' ',J3,' ',J4,' /' END IF END IF 31 CONTINUE 32 CONTINUE 33 CONTINUE DO 43 I3=0,N3-2 DO 42 I2=0,N2-1 DO 41 I1=0,N1-2 I=1+I1+N1*(I2+N2*I3) J1=I J2=I+1 J3=I+N1*N2+1 J4=I+N1*N2 IF(KOLUMN.NE.0) THEN J1=IRAM(J1) J2=IRAM(J2) J3=IRAM(J3) J4=IRAM(J4) END IF IF(FPLGN.NE.' ') THEN IF(J1.NE.0.AND.J2.NE.0.AND.J3.NE.0.AND.J4.NE.0) THEN WRITE(LU,'(4(I6,A))') J1,' ',J2,' ',J3,' ',J4,' /' END IF END IF IF(FTRGL.NE.' ') THEN IF(J1.NE.0.AND.J2.NE.0.AND.J3.NE.0) THEN WRITE(LU2,'(3(I6,A))') J1,' ',J2,' ',J3,' /' END IF IF(J1.NE.0.AND.J3.NE.0.AND.J4.NE.0) THEN WRITE(LU2,'(3(I6,A))') J1,' ',J3,' ',J4,' /' END IF END IF 41 CONTINUE 42 CONTINUE 43 CONTINUE DO 53 I3=0,N3-2 DO 52 I2=0,N2-2 DO 51 I1=0,N1-1 I=1+I1+N1*(I2+N2*I3) J1=I J2=I+N1 J3=I+N1*N2+N1 J4=I+N1*N2 IF(KOLUMN.NE.0) THEN J1=IRAM(J1) J2=IRAM(J2) J3=IRAM(J3) J4=IRAM(J4) END IF IF(FPLGN.NE.' ') THEN IF(J1.NE.0.AND.J2.NE.0.AND.J3.NE.0.AND.J4.NE.0) THEN WRITE(LU,'(4(I6,A))') J1,' ',J2,' ',J3,' ',J4,' /' END IF END IF IF(FTRGL.NE.' ') THEN IF(J1.NE.0.AND.J2.NE.0.AND.J3.NE.0) THEN WRITE(LU2,'(3(I6,A))') J1,' ',J2,' ',J3,' /' END IF IF(J1.NE.0.AND.J3.NE.0.AND.J4.NE.0) THEN WRITE(LU2,'(3(I6,A))') J1,' ',J3,' ',J4,' /' END IF END IF 51 CONTINUE 52 CONTINUE 53 CONTINUE END IF IF(FPLGN.NE.' ') THEN CLOSE(LU) END IF IF(FTRGL.NE.' ') THEN CLOSE(LU2) END IF C WRITE(*,'(A)') '+GRDPTS: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdran2d.for 0100666 0000765 0000765 00000063762 10062244274 012663 0 ustar bulant bulant C
C Program GRDRAN2D to generate a 2-D rectangular grid of real numbers C having a desired spatial correlation function, specified variance and C mean and, if required, falling into the given interval of the C functional values. C C Version: 5.80 C Date: 2004, June 11 C C Coded by Paul Spudich C U.S. Geological Survey C 345 Middlefield Road, Menlo Park, CA 94025, U.S.A. C E-mail: spudich@samoa.wr.usgs.gov C Input/output modified 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 This code has no known defects, but it is the sole responsibility of C the user to test the code to ensure that it gives accurate answers in C the user's application. The authors of the code take no C responsibility for damage resulting from errors in this code. C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the output files: C GRD='string' ... Name of the output ASCII file with the generated C grid values. C For general description of files with gridded data refer C to file forms.htm. C Defaults: GRD='grd.out' C LOG='string' ... Name of the output log file which may contain C error messages. C Defaults: LOG='grdran2d.out' C Data specifying grid dimensions: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C D1=positive real... Grid spacing along the X1 axis. C Default: D1=1. C D2=positive real... Grid spacing along the X2 axis. C Default: D2=1. C Data specifying the statistics: C These data are specific to this program. C Selection of a particular pseudorandom representation: C ISEED=integer ... Nonzero integer seed for the generation of C pseudorandom numbers. Its sign is ignored. C Default: ISEED=-1. C Data for the correlation function: C CTYPE='string' ... String specifying the correlation function: C ='D'... Default. The most general option (generalization of C all the subsequently listed options). C Spectrum of white noise is filtered by function C EXP(-(ACORG*k)**2/8.) C *(ACOR**(-2)+k**2)**(-(dim/2+POWERN)/2.) C Here dim=2 is the spatial dimension. C Parameters of the correlation function C ACORG,ACOR,POWERN C ='L'... Laguerr. C Spectrum of white noise is filtered by function C EXP(-(ACORG*k)**2/8.)*k**(-(dim/2+POWERN)) C Parameters of the correlation function C ACORG,POWERN C Equivalent to: 'D' ACOR=999999. C Here 999999. represents infinity. C ='K'... Von Karman. C Spectrum of white noise is filtered by function C (ACOR**(-2)+k**2)**(-(dim/2+POWERN)/2.) C Parameters of the correlation function C ACOR,POWERN C Equivalent to: 'D' ACORG=0. C ='S'... Self-affine. C Spectrum of white noise is filtered by function C k**(-(dim/2+POWERN)) C Parameter of the correlation function C POWERN C Equivalent to: 'D' ACORG=0. ACOR=999999. C 'L' ACORG=0. C 'K' ACOR=999999. C ='G'... Gaussian. C Spectrum of white noise is filtered by function C EXP(-(ACORG*k)**2/8.) C Parameter of the correlation function C ACORG C Equivalent to: 'D' POWERN=-dim/2 ACOR=999999. C 'L' POWERN=-dim/2 C Here dim=2 is the spatial dimension. C ='E'... Exponential. C Spectrum of white noise is filtered by function C (ACOR**(-2)+k**2)**(-(dim/2+0.5)/2.) C Parameter of the correlation function C ACOR C Equivalent to 'D' POWERN=0.5 ACORG=0. C 'K' POWERN=0.5 C ='W'... White noise. C No parameters of the correlation function. C Equivalent to 'D' POWERN=-dim/2 ACORG=0. C 'L' POWERN=-dim/2 ACORG=0. C 'K' POWERN=-dim/2 C 'S' POWERN=-dim/2 C 'G' ACORG=0. C POWERN=real... Exponent or index related to fractal dimension: C Medium is self-affine at distances L: C ACORG .LT. L .LT. ACOR C Reasonable values for geology: -0.5 .LT. POWERN .LT. 0.0 C Default: POWERN=0.0 C ACORG=nonnegative real... Gaussian (small-scale) correlation C length: C Removes small details (smaller than ACORG) C Default: ACORG=0.0 C ACOR=positive real... Von Karman (large-scale) correlation length: C Suppresses large heterogeneities (larger than ACOR) C Default: ACOR=999999. (infinity) C Data for the cosine low-pass filter: C Cosine filter may be applied to wavenumber power spectrum. C RLMIN=nonnegative real... Minimum wavelength. All wavelengths C shorter than RLMIN are removed. C Default: RLMIN=0. C RLMAX=nonnegative real... C Low-pass filter has value 1 at wavenumbers smaller than C 1/RLMAX (i.e. at wavelengths longer than RLMAX), tapers C down between 1/RLMAX and 1/RLMIN, and is zero at C wavenumbers greater than 1/RLMIN (i.e. at wavelengths C shorter than RLMIN). C Default: RLMAX=0. (no cosine filter) C Data to rescale the random values: C DSD=positive real... Desired Standard Deviation: C The output grid values are scaled to have standard C deviation DSD. C Default: DSD=1. C VMEAN=real... Desired mean value. C The output grid values are shifted to have the average C value of VMEAN. C Default: VMEAN=0. C DEVMAX=positive real... Maximum deviation from the mean value. C For finite DEVMAX, the grid values V with mean value VMEAN C and standard deviation DSD are rescaled using C Vnew=VMEAN+(V-VMEAN) C /(1+ABS((V-VMEAN)/DEVMAX)**DEVEXP)**(1/DEVEXP) C This rescaling does not influence values close to mean C VMEAN, especially for larger exponents DEVEXP. C For DEVEXP=999999. (infinity), rescaling does not change C values up to the deviation of DEVMAX from VMEAN. C Default: DEVMAX=999999. (infinity. i.e. no rescaling) C DEVEXP=positive real... Exponent for the renormalization to the C maximum deviation from the mean value. C Has no effect if DEVMAX=999999. (infinity). C Default: DEVEXP=2.0 C C======================================================================= C PARAMETER (IXGDIM=1024, IYGDIM=1024, IWDIM=IXGDIM*IYGDIM) PARAMETER (LU=8, LP=7, LTW=0) C C LU... Logical unit number used to read all input files and write C the output file with grid values. C REAL GRID(IXGDIM,IYGDIM) COMPLEX WORK(IWDIM) INTEGER ISEED CHARACTER FGRD*80,FOUT*80,FLOG*80,CTYPE*1 C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDRAN2D: Enter input filename: ' FGRD=' ' READ(*,*) FGRD WRITE(*,'(A)') '+GRDRAN2D: Working ... ' C C Reading all data from the SEP file into the memory: IF (FGRD.NE.' ') THEN CALL RSEP1(LU,FGRD) ELSE C GRDRAN2D-08 CALL ERROR('GRDRAN2D-08: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('GRD',FOUT,'grd.out') CALL RSEP3T('LOG',FLOG,'grdran2d.out') C C Recalling the data specifying grid dimensions C (arguments: Name of value in input data, Variable, Default): CALL RSEP3I('N1',NXG,1) CALL RSEP3I('N2',NYG,1) CALL RSEP3R('D1',DX ,1.) CALL RSEP3R('D2',DY ,1.) C C Recalling the data specifying the statistics: CALL RSEP3I('ISEED',ISEED,-1) C Data for the correlation function CALL RSEP3T('CTYPE' ,CTYPE ,'D') CALL RSEP3R('POWERN',POWERN,0.) CALL RSEP3R('ACORG' ,ACORG ,0.) CALL RSEP3R('ACOR' ,ACOR ,999999.) C Data for the cosine low-pass filter CALL RSEP3R('RLMIN' ,RLMIN ,0.) CALL RSEP3R('RLMAX' ,RLMAX ,0.) C Data to rescale the random values CALL RSEP3R('DSD' ,DSD ,1.) CALL RSEP3R('VMEAN' ,VMEAN ,0.) CALL RSEP3R('DEVMAX',DEVMAX,999999.) CALL RSEP3R('DEVEXP',DEVEXP,2.) C C Opening output log file: OPEN (UNIT=LUWARN(LP), FILE=FLOG, FORM='FORMATTED') C C Generating the random grid values with zero mean: C The seed must be negative JSEED = -IABS(ISEED) CALL GEN2D1 (CTYPE, DX, DY, POWERN, ACORG, ACOR, DSD, . RLMIN, RLMAX, GRID, IXGDIM, IYGDIM, NXG, NYG, . WORK, IWDIM, JSEED , LP, LTW) C C Rearranging and rescaling the grid values: DEVINV=1./DEVEXP IF(DEVEXP.GT.999998.) THEN VMAX=DEVMAX ELSE VMAX=DEVMAX*16000000.**DEVINV END IF I=0 DO 52 IYG=1,NYG DO 51 IXG=1,NXG C Rearranging 2-D array into 1-D array (new indices IX,IY): IY=I/IXGDIM I=I+1 IX=I-IY*IXGDIM IY=IY+1 C Rescaling the grid values: V=GRID(IXG,IYG) IF(DEVMAX.GT.999998.) THEN GRID(IX,IY)=VMEAN+V ELSE IF(ABS(V).GT.VMAX) THEN GRID(IX,IY)=VMEAN+SIGN(DEVMAX,V) ELSE IF(DEVEXP.GT.999998.) THEN GRID(IX,IY)=VMEAN+V ELSE GRID(IX,IY)=VMEAN+V/(1+ABS(V/DEVMAX)**DEVEXP)**DEVINV END IF END IF 51 CONTINUE 52 CONTINUE C C Writing output grid values: CALL WARRAY(LU,FOUT,'FORMATTED',.FALSE.,0., * .FALSE.,0.,NXG*NYG,GRID) C C Closing output log file: CLOSE(LP) C WRITE(*,'(A)') '+GRDRAN2D: Done. ' STOP END C C======================================================================= C SUBROUTINE GEN2D1 (CTYPE, DX, DY, POWERN, ACORG, ACOR, DSD, . RLMIN, RLMAX, GRID, IXGDIM, IYGDIM, NXG, NYG, . WORK, IWDIM, ISEED, LP, LTW) C----------------------------------------------------------------------- C C Subroutine to generate a rectangular grid of real numbers having a C desired spatial correlation function and [# an approximately Gaussian C distribution function having] a specified variance and zero mean. The C application this routine is specifically written for is to generate C a 2D array of seismic velocity perturbations having either Gaussian, C exponential, or self-similar autocorrelation functions, following C Frankel and Clayton, J. Geophys. Res, 1986, pp. 6465-6489. Note that C in this implementation of their functions, I have anti-aliased the C wavenumber power spectrum using a cosine taper. C C # Note: Present version seems to generate rectangular distribution C subsequently modified by the filtration (L.K.). C C Inputs: C CTYPE - CHARACTER*1 variable specifying which correlation function C to use: C = 'D' The most general option (generalization of all the C subsequently listed options): C Spectrum of white noise is filtered by function C EXP( -(ACORG * k)**2 / 8. ) C * ( ACOR**(-2) + k**2 )**( -(1.+POWERN)/2. ) C = 'L' Laguerr (common generalization of self-affine and C Gaussian), equivalent to 'D' with ACOR=infinity. C = 'K' Von Karman (Frankel and Clayton eqn B12 with C a=ACOR and exponent -1 generalized to -1-2*POWERN, C see eqn 4 with m=POWERN), equivalent to 'D' with C ACORG=0. C = 'S' self-affine (Von Karman with ACOR=infinity), C equivalent to 'D' with ACORG=0 and ACOR=infinity. C = 'G' Gaussian (Frankel and Clayton eqn B3 with C a=ACORG), equivalent to 'D' with POWERN=-1 and C ACOR=infinity. C = 'E' exponential (Frankel and Clayton eqn B6 with C a=ACOR), equivalent to 'D' with POWERN=0.5 and C ACORG=0. C = 'W' white noise, equivalent to 'D' with POWERN=-1, C ACORG=0 and ACOR=infinity. C DX - spatial grid spacing corresponding to left index of grid array C (typically km) C DY - spatial grid spacing corresponding to right index of grid array C (typically km) C ACORG - correlation distance of Gaussian media, in same units as DX C and DY. ACORG corresponds to the variable 'a' in C Frankel and Clayton's equation B3. C ACOR - correlation distance of Von Karman media, in same units as DX C and DY. ACOR corresponds to the variable 'a' in Frankel C and Clayton's equations B6 and B12. C DSD - desired standard deviation of the perturbations calculated. C = 0 means do not alter standard deviation as calculated C The output grid is scaled to have standard C deviation = DSD if DSD is input nonzero. Note that C DSD does not correspond to sigma-c in F&C eqn B3. C RLMIN, RLMAX -cosine filter is applied to wavenumber power spectrum. C Filter has value 1 at wavenumbers corresponding to C a wavelength of RLMAX, filter has value 0 at k C corresponding to wavelength of RLMIN. I.e. if you C input RLMIN = 2, all wavelengths shorter than 2 C will be filtered out of the result. C Units = units of DX, DY, ACORG, ACOR. C IXGDIM, IYGDIM - grid is dimensioned (IXGDIM, IYGDIM) outside this C routine C NXG, NYG - grid (1 to NXG, 1 to NYG) used C WORK - 1D complex array for working storage; contents on input C ignored. C IWDIM - WORK is dimensioned iwdim outside this routine. Note - C IWDIM must equal or exceed (next power of 2 larger than C NXG) times (next power of 2 larger than NYG), i.e. if C NXG = 10 and NYG = 20, IWDIM must be .GE. 16*32 C ISEED - integer seed for generating random numbers. C ISEED must be negative. C LP, LTW - logical unit numbers to which to write error messages C ( LP = LTW is okay) C C Outputs: C GRID - real array of velocities having desired statistical C properties. C GRID(1 to NXG, 1 to NYG) are set by this program. C----------------------------------------------------------------------- C DIMENSION GRID(IXGDIM, IYGDIM), NN(2) COMPLEX WORK (IWDIM) CHARACTER*1 CTYPE, CFUNC C PI = 3.1415926 C C TOL is a numeric tolerance for checking that IFFT result is pure real TOL = .5E-5 C C GRDRAN2D-01 IF (ISEED .GE. 0) CALL BOMOU2 (LP, LTW, FLOAT(ISEED), . 'GRDRAN2D-01: ENTER ISEED NEGATIVE. ILLEGAL ISEED=') C CFUNC = ' ' IF (CTYPE .EQ. 'D' .OR. CTYPE .EQ. 'd') CFUNC = 'D' IF (CTYPE .EQ. 'L' .OR. CTYPE .EQ. 'l') CFUNC = 'L' IF (CTYPE .EQ. 'K' .OR. CTYPE .EQ. 'k') CFUNC = 'K' IF (CTYPE .EQ. 'S' .OR. CTYPE .EQ. 's') CFUNC = 'S' IF (CTYPE .EQ. 'G' .OR. CTYPE .EQ. 'g') CFUNC = 'G' IF (CTYPE .EQ. 'E' .OR. CTYPE .EQ. 'e') CFUNC = 'E' IF (CTYPE .EQ. 'W' .OR. CTYPE .EQ. 'w') CFUNC = 'W' C GRDRAN2D-02 IF (CFUNC .EQ. ' ') CALL BOMOUT (LP, LTW, . 'GRDRAN2D-02: ILLEGAL COR FUNCTION REQUESTED, CTYPE='//CTYPE) C C GRDRAN2D-03 IF (RLMAX .LT. RLMIN) CALL BOMOU2(LP, LTW, 0., . 'GRDRAN2D-03: RLMIN .GE. RLMAX =') IF(RLMIN.GT.0.) THEN RKMIN = 2*PI/RLMAX ELSE RKMIN = 999999. END IF IF(RLMAX.GT.0.) THEN RKMAX = 2*PI/RLMIN ELSE RKMAX = 999999. END IF C C first determine the powers of 2 to use in the 2D FFT C EXP2 = LOG10(FLOAT(NXG))/LOG10(2.) DIF = EXP2 - IFIX(EXP2) IF (DIF .EQ. 0) THEN NX2 = 2**IFIX(EXP2) ELSE NX2 = 2** (IFIX(EXP2)+1) END IF C EXP2 = LOG10(FLOAT(NYG))/LOG10(2.) DIF = EXP2 - IFIX(EXP2) IF (DIF .EQ. 0) THEN NY2 = 2**IFIX(EXP2) ELSE NY2 = 2** (IFIX(EXP2)+1) END IF NN(1) = NX2 NN(2) = NY2 C C GRDRAN2D-04 IF (NX2 .LE. 2) CALL BOMOU2 (LP, LTW, FLOAT(NX2), . 'GRDRAN2D-04: X FFT HAS BIZARRELY FEW POINTS, NX2=') C GRDRAN2D-05 IF (NY2 .LE. 2) CALL BOMOU2 (LP, LTW, FLOAT(NY2), . 'GRDRAN2D-05: Y FFT HAS BIZARRELY FEW POINTS, NY2=') C C determine physical extent of grid, wavenumber interval XLEN = NX2 * DX YLEN = NY2 * DY DKX = 2 * PI / XLEN DKY = 2 * PI / YLEN C C fill work array with random numbers distributed uniformly between C -0.5 and 0.5 DO 100 I = 1, NX2*NY2 * WORK(I) = CMPLX(RAN2(ISEED)-.5, 0.) WORK(I) = CMPLX(RAN3(ISEED)-.5, 0.) 100 CONTINUE C NDIM = 2 ISIGN = 1 C two-dimensional FFT CALL FOURN (WORK, NN, NDIM, ISIGN) C C set kx=ky=0 component of WORK to zero so that its inverse C transform has zero mean WORK(1) = CMPLX(0.,0.) C C now multiply all elements of the WORK array by the desired wavenumber C filter. We must be careful to multiply each quadrant properly to C preserve the Hermitian property of the WORK array. Recall that the C discrete 2D fft puts the RKX=0, RKY=0 spectral component at (1,1), and C the results for negative RKX and negative RKY appear at high values C of the array indices. C IXNYQ = NX2/2 + 1 IYNYQ = NY2/2 + 1 IWORK = 0 POWER = -(1.+POWERN) / 2. AGSQ8 = ACORG**2 / 8. IF(ACOR.LE.999998.) THEN ASQINV = 1./ACOR**2 ELSE ASQINV = 0. END IF C DO 200 IY = 1, NY2 RKY = (IY-1) * DKY IF (IY .GT. IYNYQ) RKY = (IY - NY2 - 1) * DKY C DO 200 IX = 1, NX2 RKX = (IX-1) * DKX IF (IX .GT. IXNYQ) RKX = (IX - NX2 -1) * DKX RKSQ = RKX**2 + RKY**2 RK = SQRT (RKSQ) C IF(IX.EQ.1.AND.IY.EQ.1) THEN C Zero average value of each realization: P=0. ELSE C wavenumber amplitude spectra of the different correlation functions. C Note that I will C rescale the result to the desired variance at the end. IF (CFUNC .EQ. 'D') THEN C General: P = EXP(-AGSQ8*RKSQ) * (ASQINV+RKSQ)**POWER ELSE IF (CFUNC .EQ. 'L') THEN C Laguerr: P = EXP(-AGSQ8*RKSQ) * RKSQ**POWER ELSE IF (CFUNC .EQ. 'K') THEN C Von Karman: P = (ASQINV+RKSQ)**POWER ELSE IF (CFUNC .EQ. 'S') THEN C Self-affine: P = RKSQ**POWER ELSE IF (CFUNC .EQ. 'G') THEN C Gaussian: P = EXP(-AGSQ8*RKSQ) ELSE IF (CFUNC .EQ. 'E') THEN C Exponential: P = (ASQINV+RKSQ)**(-0.75) ELSE IF (CFUNC .EQ. 'W') THEN C White noise: P = 1. ELSE C GRDRAN2D-06 CALL BOMOUT(LP,LTW,'GRDRAN2D-06: ILLEGAL CFUNC='//CFUNC) END IF END IF C IWORK = IWORK + 1 WORK(IWORK) = P * WORK(IWORK) C C apply cosine taper IF (RK .GE. RKMAX) THEN COSTAP = 0. ELSE IF (RK .GT. RKMIN .AND. RK .LT. RKMAX) THEN COSTAP = .5 + .5 * COS ( (RK-RKMIN)/(RKMAX-RKMIN)*PI ) ELSE COSTAP = 1. END IF C now apply filter to work array WORK(IWORK) = WORK(IWORK) * COSTAP C 200 CONTINUE C C inverse FFT ISIGN = -1 CALL FOURN (WORK, NN, NDIM, ISIGN) C C Check that the result is pure real (to numerical accuracy). C ABMXR = 0. ABMXI = 0. NSQ = NX2*NY2 DO 300 I = 1, NSQ C normalize for the 2D FFT WORK(I) = WORK(I) / NSQ ABMXR = MAX(ABMXR, ABS(REAL(WORK(I)))) ABMXI = MAX(ABMXI, ABS(AIMAG(WORK(I)))) 300 CONTINUE C RATIM = ABMXI/ABMXR C GRDRAN2D-07 IF (RATIM .GT. TOL) CALL BOMOU2 (LP, LTW, RATIM, . 'GRDRAN2D-07: IFFT RESULT NOT PURE REAL, MAX(IM)/MAX(REAL)=') C C normalize to desired variance and load in output grid array GMEAN = 0. DO 401 IY = 1, NYG DO 401 IX = 1, NXG IWORK = NX2 * (IY-1) + IX GRID(IX,IY) = REAL(WORK(IWORK)) GMEAN = GMEAN + GRID(IX,IY) 401 CONTINUE C NG = NXG*NYG GMEAN = GMEAN / NG C C demean grid and calculate rms value RMS = 0. DO 402 IY = 1, NYG DO 402 IX = 1, NXG GRID(IX,IY) = GRID(IX,IY) - GMEAN RMS = RMS + GRID(IX,IY)**2 402 CONTINUE C RMS = SQRT (RMS / NG) C C scale grid to desired rms, DDSD IF (DSD .NE. 0) THEN DDSD = DSD ELSE DDSD = 1. RMS = 1. END IF C DO 400 IY = 1, NYG DO 400 IX = 1, NXG GRID(IX,IY) = DDSD * GRID(IX,IY) / RMS 400 CONTINUE C C ------ RETURN C ------ C END C C======================================================================= C SUBROUTINE BOMOUT (LU1, LU2, STRING) C---------------------------------------------------------------------- C C THIS ROUTINE WRITES TO UNITS LU1 AND LU2 AN ERROR MESSAGE CONSISTING C OF " *** FATAL ERROR ***" CONCATENATED WITH THE INPUT STRING, AND C THEN STOPS EXECUTION OF THE CALLING PROGRAM. IF LU1=LU2, ONLY ONE C MESSAGE IS WRITTEN TO LU1. C CHARACTER*(*) STRING c IF (LU1 .NE. 0) WRITE (LU1, 1000) STRING(1:NBLEN(STRING)) c1000 FORMAT (' *******************' / c * ' * FATAL ERROR ***** - ', A, / c * ' *******************' ) c IF (LU2 .NE. LU1 .AND. LU2 .NE. 0) WRITE (LU2 ,1000) c * STRING(1:NBLEN(STRING)) c STOP CALL ERROR(STRING) RETURN END C C======================================================================= C SUBROUTINE BOMOU2 (LU1, LU2, R, STRING) C---------------------------------------------------------------------- C C THIS ROUTINE WRITES TO UNITS LU1 AND LU2 AN ERROR MESSAGE CONSISTING C OF " *** FATAL ERROR ***" CONCATENATED WITH THE INPUT STRING, C CONCATENATED WITH THE REAL NUMBER R. BOMOU2 THEN C STOPS EXECUTION OF THE CALLING PROGRAM. IF LU1=LU2, ONLY ONE MESSAGE C IS WRITTEN TO LU1. C CHARACTER*(*) STRING c IF (LU1 .NE. 0) WRITE (LU1, 1000) STRING(1:NBLEN(STRING)), R c1000 FORMAT (' ******************' / c * ' * FATAL ERROR **** - ', c * A, G10.3 / c * ' ******************' ) c IF (LU2 .NE. 0 .AND. LU2 .NE. LU1) WRITE (LU2, 1000) c * STRING(1:NBLEN(STRING)), R c STOP CHARACTER*200 TEXT WRITE(TEXT,'(A,G10.3)') STRING(1:NBLEN(STRING)),R CALL ERROR(TEXT(1:NBLEN(TEXT))) RETURN END C C======================================================================= C FUNCTION NBLEN (STRING) C-------------------------------------------------------------------- C C GIVEN A CHARACTER STRING, NBLEN RETURNS THE LENGTH OF THE STRING C TO THE LAST NON-BLANK CHARACTER, PRESUMING THE STRING IS LEFT- C JUSTIFIED, I.E. IF STRING = ' XS J ', NBLEN = 8. C C CALLED NON-LIBRARY ROUTINES: NONE C LANGUAGE: STANDARD FORTRAN 77 C CHARACTER*(*) STRING, BLANK*1, NULL*1 DATA BLANK /' '/ C NULL = CHAR(0) NBLEN = 0 LS = LEN(STRING) IF (LS .EQ. 0) RETURN DO 1 I = LS, 1, -1 IF (STRING(I:I) .NE. BLANK .AND. STRING(I:I) .NE. NULL) GO TO 2 1 CONTINUE RETURN 2 NBLEN = I RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for INCLUDE 'fourn.for' C fourn.for of Numerical Recipes * INCLUDE 'ran2.for' C ran2.for of Numerical Recipes INCLUDE 'ran3.for' C ran3.for of Numerical Recipes C C======================================================================= Cgrdran.for 0100666 0000765 0000765 00000011060 07472107304 012420 0 ustar bulant bulant C
C Program GRDRAN to compute the pseudorandom numbers distributed C uniformly between -0.5 and 0.5 on the input grid. C C Version: 5.40 C Date: 2002, May 20 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying the parameters of the grid: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C Selection of a particular pseudorandom representation: C ISEED=integer ... Nonzero integer seed for the generation of C pseudorandom numbers. Its sign is ignored. C Default: ISEED=-1. C Name of output formatted file with the computed values: C RANOUT='string' C Default: RANOUT='grdran.out' C For general description of the files with gridded data refer to C file forms.htm. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RSEP3I,WARRAY,RAN3 REAL RAN3 C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3I ... C File sep.for. C WARRAY ... File forms.for. C RAN3 ... File ran3.for. C C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILOUT INTEGER LU1 PARAMETER (LU1=1) INTEGER N1,N2,N3,ISEED,I1,N1N2N3 C----------------------------------------------------------------------- C C Reading a name of the file with the input data: WRITE(*,'(A)') '+GRDRAN: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C GRDRAN-01 CALL ERROR('GRDRAN-01: SEP file not given') ENDIF C WRITE(*,'(A)') '+GRDRAN: Working ... ' C C Filename of the output file: CALL RSEP3T('RANOUT',FILOUT,'grdran.out') C The values describing the grid: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) N1N2N3=N1*N2*N3 IF (N1N2N3.GT.MRAM) THEN C GRDRAN-02 CALL ERROR('GRDRAN-02: Small array RAM.') ENDIF C Reading numerical constant ISEED: CALL RSEP3I('ISEED',ISEED,-1) C C C Random numbers: DO 10, I1=1,N1N2N3 RAM(I1)=RAN3(ISEED)-0.5 10 CONTINUE C IF (FILOUT.NE.' ') THEN CALL WARRAY(LU1,FILOUT,'FORMATTED',.FALSE.,0.,.FALSE.,0., * N1N2N3,RAM) ENDIF WRITE(*,'(A)') '+GRDRAN: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for INCLUDE 'ran3.for' C ran3.for of Numerical Recipes C C======================================================================= Cgrdstat.for 0100666 0000765 0000765 00000016522 07054147706 012631 0 ustar bulant bulant C
C Program GRDSTAT to rescale gridded data to given statistic properties. C C Version: 5.40 C Date: 2000, February 21 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying the parameters of the grid: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C Data to rescale the random values: C DSD=positive real... Desired Standard Deviation: C The output grid values are scaled to have standard C deviation DSD. C Default: DSD=1. C VMEAN=real... Desired mean value. C The output grid values are shifted to have the average C value of VMEAN. C Default: VMEAN=0. C DEVMAX=positive real... Maximum deviation from the mean value. C For finite DEVMAX, the grid values V with mean value VMEAN C and standard deviation DSD are rescaled using C Vnew=VMEAN+(V-VMEAN) C /(1+ABS((V-VMEAN)/DEVMAX)**DEVEXP)**(1/DEVEXP) C This rescaling does not influence values close to mean C VMEAN, especially for larger exponents DEVEXP. C For DEVEXP=999999. (infinity), rescaling does not change C values up to the deviation of DEVMAX from VMEAN. C Default: DEVMAX=999999. (infinity. i.e. no rescaling) C DEVEXP=positive real... Exponent for the renormalization to the C maximum deviation from the mean value. C Has no effect if DEVMAX=999999. (infinity). C Default: DEVEXP=2.0 C Names of input and output formatted files with the values: C STATIN='string' ... Name of the input file containing the C gridded data. C No default, 'STATIN' must be specified and cannot be blank C STATOUT='string' ... Name of the output file containing the C gridded data rescaled to the given statistic properties. C Default: STATOUT='grdstat.out' C For general description of the files with gridded data refer to C file forms.htm. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I,RARRAY,WARRAY C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... C File sep.for. C RARRAY,WARRAY ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILIN,FILOUT INTEGER LU1 PARAMETER (LU1=1) INTEGER N1,N2,N3,I1,N1N2N3 REAL DSD,VMEAN,DEVMAX,DEVEXP REAL DEVINV,V,VMAX,RMEAN,RMS C C----------------------------------------------------------------------- C C Reading in a name of the file with the input data: WRITE(*,'(A)') '+GRDSTAT: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C GRDSTAT-01 CALL ERROR('GRDSTAT-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading filenames of the input and output files: CALL RSEP3T('STATIN',FILIN,' ') IF (FILIN.EQ.' ') THEN C GRDSTAT-02 CALL ERROR('GRDSTAT-02: No input file given.') ENDIF CALL RSEP3T('STATOUT',FILOUT,'grdstat.out') C C Reading the values describing the grid: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) N1N2N3=N1*N2*N3 IF (N1N2N3.GT.MRAM) THEN C GRDSTAT-03 CALL ERROR('GRDSTAT-03: Small array RAM.') ENDIF C Data to rescale the random values CALL RSEP3R('DSD' ,DSD ,1.) CALL RSEP3R('VMEAN' ,VMEAN ,0.) CALL RSEP3R('DEVMAX',DEVMAX,999999.) CALL RSEP3R('DEVEXP',DEVEXP,2.) C C Input gridded data: CALL RARRAY(LU1,FILIN,'FORMATTED',.TRUE.,0.,N1N2N3,RAM) C WRITE(*,'(A)') '+GRDSTAT: Working ... ' C C Demean grid: RMEAN=0. DO 12, I1=1,N1N2N3 RMEAN=RMEAN+RAM(I1) 12 CONTINUE RMEAN=RMEAN/FLOAT(N1N2N3) DO 14, I1=1,N1N2N3 RAM(I1)=RAM(I1)-RMEAN 14 CONTINUE C IF (DSD.NE.0.) THEN C Computing RMS: RMS=0. DO 20, I1=1,N1N2N3 RMS=RMS+RAM(I1)**2 20 CONTINUE RMS=SQRT(RMS/FLOAT(N1N2N3)) C C Scaling to desired RMS, DSD: DO 30, I1=1,N1N2N3 RAM(I1)=DSD*RAM(I1)/RMS 30 CONTINUE ENDIF C C Rearranging and rescaling the grid values: DEVINV=1./DEVEXP IF (DEVEXP.GT.999998.) THEN VMAX=DEVMAX ELSE VMAX=DEVMAX*16000000.**DEVINV END IF DO 50 I1=1,N1N2N3 C Rescaling the grid values: V=RAM(I1) IF (DEVMAX.GT.999998.) THEN RAM(I1)=VMEAN+V ELSE IF (ABS(V).GT.VMAX) THEN RAM(I1)=VMEAN+SIGN(DEVMAX,V) ELSEIF (DEVEXP.GT.999998.) THEN RAM(I1)=VMEAN+V ELSE RAM(I1)=VMEAN+V/(1.+ABS(V/DEVMAX)**DEVEXP)**DEVINV ENDIF ENDIF 50 CONTINUE C IF (FILOUT.NE.' ') THEN CALL WARRAY(LU1,FILOUT,'FORMATTED',.FALSE.,0.,.FALSE.,0., * N1N2N3,RAM) ENDIF WRITE(*,'(A)') '+GRDSTAT: Finished. ' STOP END C C======================================================================= C INCLUDE 'forms.for' C forms.for INCLUDE 'error.for' C error.for INCLUDE 'length.for' C length.for INCLUDE 'sep.for' C sep.for C C======================================================================= Cgrdte.for 0100666 0000765 0000765 00000033345 07105722350 012257 0 ustar bulant bulant C
C Program GRDTE to compute the values of a real or complex function, C described in terms of the Taylor expansions of its amplitude and C phase, on a given grid C C Version: 5.40 C Date: 2000, May 9 C C Coded by Karel Zacek C Department of Geophysics, Charles University Prague C E-mail: zacek@karel.troja.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the output files: C GRDTER='string' C GRDTEI='string'... Names of the output files with the calculated C grid values of the given complex-valued function. C File GRDTER will contain the real part and file GRDTEI C will contain the imaginary part of the function. C If the string is blank, the corresponding file is not C generated. C For general description of files with gridded data refer C to file forms.htm. C Default: GRDTER=' ', GRDTEI=' ' C Data specifying the dimensions of the grid for discretization: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C O1=real, O2=real, O3=real ... Coordinates of the origin of the C grid. C Default: O1=0. O2=0. O3=0. C D1=real... Grid interval along the X1 axis. C Default: D1=0. C D2=real... Grid interval along the X2 axis. C Default: D2=0. C D3=real... Grid interval along the X3 axis. C Default: D3=0. C Data specifying the origins of individual discretized functions: C N10, N20, N30, O10, O20, O30, D10, D20 and D30... Specify the set C of origins X0j for individual shifted functions. Their C meaning is analogous to parameters N1, N2, N3, O1, O2, O3, C D1, D2 and D3. C Additional data specific to this program: C COEFFICIENT=real C where COEFFICIENT stands for any of the following 80 names C AR0, AI0, TR0, TI0, C AR1, AR2, AR3, AI1, AI2, AI3, C TR1, TR2, TR3, TI1, TI2, TI3, C AR11, AR12, AR22, AR13, AR23, AR33, C AI11, AI12, AI22, AI13, AI23, AI33, C TR11, TR12, TR22, TR13, TR23, TR33, C TI11, TI12, TI22, TI13, TI23, TI33, C AR111, AR112, AR122, AR222, AR113, C AR123, AR223, AR133, AR233, AR333, C AI111, AI112, AI122, AI222, AI113, C AI123, AI223, AI133, AI233, AI333, C TR111, TR112, TR122, TR222, TR113, C TR123, TR223, TR133, TR233, TR333, C TI111, TI112, TI122, TI222, TI113, C TI123, TI223, TI133, TI233, TI333. C The calculated complex-valued function has the form of C F(Xm) = A(Xm) exp(T(n)) , C where the complex-valued amplidtude is C A(Xm) = A0 + Aj*Yj + Ajk*Yj*Yk/2 + Ajkl*Yj*Yk*Yl/6 C and the complex-valued phase is C T(Xm) = T0 + Tj*Yj + Tjk*Yj*Yk/2 + Tjkl*Yj*Yk*Yl/6 , C with C Yj = Xj - X0j . C Here C A0 = AR0 + i*AI0 , C Aj = ARj + i*AIj , C Ajk = ARjk + i*AIjk , C Ajkl = ARjkl + i*AIjkl , C T0 = TR0 + i*TI0 , C Tj = TRj + i*TIj , C Tjk = TRjk + i*TIjk , C Tjkl = TRjkl + i*TIjkl . C The origins X0j of individual discretized functions are C specified by input parameters N10, N20, N30, O10, O20, C O30, D10, D20 and D30. The individual functions are C written as individual snapshots. It means that they may C be processed or displayed like N4=N10*N20*N30 spatial C grids. C Defaults: COEFFICIENT=0 C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C INTEGER N1,N2,N3,N10,N20,N30,LU1,LU2,PT,PTM REAL D1,D2,D3,O1,O2,O3,D10,D20,D30,O10,O20,O30 INTEGER IN1,IN2,IN3,IN10,IN20,IN30,I,J,K,L REAL X(3),X0(3) REAL FR,FI,AR,AI,TR,TI,AR0,AI0,TR0,TI0,DX,DXI,DXJ,DXK REAL AR1(3),AR2(3,3),AR3(3,3,3),TR1(3),TR2(3,3),TR3(3,3,3) REAL AI1(3),AI2(3,3),AI3(3,3,3),TI1(3),TI2(3,3),TI3(3,3,3) CHARACTER*80 FILE,OUTR,OUTI PARAMETER (LU1=1,LU2=2) C C----------------------------------------------------------------------- C C Reading main input data: WRITE(*,'(A)')'+GRDTE: Enter input filename: ' FILE=' ' READ(*,*) FILE IF(FILE.EQ.' ') THEN C GRDTE-01 CALL ERROR('GRDTE-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF WRITE(*,'(A)')'+GRDTE: Reading, calculating... ' C C Reading grid dimensions: CALL RSEP1(LU,FILE) CALL RSEP3T('GRDTER',OUTR,' ') CALL RSEP3T('GRDTEI',OUTI,' ') IF (OUTR.EQ.' ' .AND. OUTI.EQ.' ') THEN C GRDFFT-03 CALL ERROR('GRDFFT-03: No output files specified.') ENDIF CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3I('N10',N10,1) CALL RSEP3I('N20',N20,1) CALL RSEP3I('N30',N30,1) CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) CALL RSEP3R('D10',D10,1.) CALL RSEP3R('D20',D20,1.) CALL RSEP3R('D30',D30,1.) CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3R('O10',O10,0.) CALL RSEP3R('O20',O20,0.) CALL RSEP3R('O30',O30,0.) C N1N2N3=N1*N2*N3 IF(2*N1N2N3.GT.MRAM) THEN C GRDTE-02 CALL ERROR('GRDTE-02: Too small array RAM(MRAM)') C Too small array RAM(MRAM) to allocate both N1*N2*N3 real and C N1*N2*N3 imaginary output grid values. If possible, increase C dimension MRAM in include file ram.inc. END IF IF(OUTR.NE.' ') THEN OPEN (LU1,FILE=OUTR,FORM='FORMATTED') END IF IF(OUTI.NE.' ') THEN OPEN (LU2,FILE=OUTI,FORM='FORMATTED') END IF PTM=N10*N20*N30 PT=0 C C Reading function parameters CALL RSEP3R('AR0',AR0,0.) CALL RSEP3R('AI0',AI0,0.) CALL RSEP3R('TR0',TR0,0.) CALL RSEP3R('TI0',TI0,0.) CALL RSEP3R('AR1',AR1(1),0.) CALL RSEP3R('AI1',AI1(1),0.) CALL RSEP3R('TR1',TR1(1),0.) CALL RSEP3R('TI1',TI1(1),0.) CALL RSEP3R('AR2',AR1(2),0.) CALL RSEP3R('AI2',AI1(2),0.) CALL RSEP3R('TR2',TR1(2),0.) CALL RSEP3R('TI2',TI1(2),0.) CALL RSEP3R('AR3',AR1(3),0.) CALL RSEP3R('AI3',AI1(3),0.) CALL RSEP3R('TR3',TR1(3),0.) CALL RSEP3R('TI3',TI1(3),0.) CALL RSEP3R('AR11',AR2(1,1),0.) CALL RSEP3R('AR12',AR2(1,2),0.) CALL RSEP3R('AR22',AR2(2,2),0.) CALL RSEP3R('AR13',AR2(1,3),0.) CALL RSEP3R('AR23',AR2(2,3),0.) CALL RSEP3R('AR33',AR2(3,3),0.) CALL RSEP3R('AI11',AI2(1,1),0.) CALL RSEP3R('AI12',AI2(1,2),0.) CALL RSEP3R('AI22',AI2(2,2),0.) CALL RSEP3R('AI13',AI2(1,3),0.) CALL RSEP3R('AI23',AI2(2,3),0.) CALL RSEP3R('AI33',AI2(3,3),0.) CALL RSEP3R('TR11',TR2(1,1),0.) CALL RSEP3R('TR12',TR2(1,2),0.) CALL RSEP3R('TR22',TR2(2,2),0.) CALL RSEP3R('TR13',TR2(1,3),0.) CALL RSEP3R('TR23',TR2(2,3),0.) CALL RSEP3R('TR33',TR2(3,3),0.) CALL RSEP3R('TI11',TI2(1,1),0.) CALL RSEP3R('TI12',TI2(1,2),0.) CALL RSEP3R('TI22',TI2(2,2),0.) CALL RSEP3R('TI13',TI2(1,3),0.) CALL RSEP3R('TI23',TI2(2,3),0.) CALL RSEP3R('TI33',TI2(3,3),0.) CALL RSEP3R('AR111',AR3(1,1,1),0.) CALL RSEP3R('AR112',AR3(1,1,2),0.) CALL RSEP3R('AR122',AR3(1,2,2),0.) CALL RSEP3R('AR222',AR3(2,2,2),0.) CALL RSEP3R('AR113',AR3(1,1,3),0.) CALL RSEP3R('AR123',AR3(1,2,3),0.) CALL RSEP3R('AR223',AR3(2,2,3),0.) CALL RSEP3R('AR133',AR3(1,3,3),0.) CALL RSEP3R('AR233',AR3(2,3,3),0.) CALL RSEP3R('AR333',AR3(3,3,3),0.) CALL RSEP3R('AI111',AI3(1,1,1),0.) CALL RSEP3R('AI112',AI3(1,1,2),0.) CALL RSEP3R('AI122',AI3(1,2,2),0.) CALL RSEP3R('AI222',AI3(2,2,2),0.) CALL RSEP3R('AI113',AI3(1,1,3),0.) CALL RSEP3R('AI123',AI3(1,2,3),0.) CALL RSEP3R('AI223',AI3(2,2,3),0.) CALL RSEP3R('AI133',AI3(1,3,3),0.) CALL RSEP3R('AI233',AI3(2,3,3),0.) CALL RSEP3R('AI333',AI3(3,3,3),0.) CALL RSEP3R('TR111',TR3(1,1,1),0.) CALL RSEP3R('TR112',TR3(1,1,2),0.) CALL RSEP3R('TR122',TR3(1,2,2),0.) CALL RSEP3R('TR222',TR3(2,2,2),0.) CALL RSEP3R('TR113',TR3(1,1,3),0.) CALL RSEP3R('TR123',TR3(1,2,3),0.) CALL RSEP3R('TR223',TR3(2,2,3),0.) CALL RSEP3R('TR133',TR3(1,3,3),0.) CALL RSEP3R('TR233',TR3(2,3,3),0.) CALL RSEP3R('TR333',TR3(3,3,3),0.) CALL RSEP3R('TI111',TI3(1,1,1),0.) CALL RSEP3R('TI112',TI3(1,1,2),0.) CALL RSEP3R('TI122',TI3(1,2,2),0.) CALL RSEP3R('TI222',TI3(2,2,2),0.) CALL RSEP3R('TI113',TI3(1,1,3),0.) CALL RSEP3R('TI123',TI3(1,2,3),0.) CALL RSEP3R('TI223',TI3(2,2,3),0.) CALL RSEP3R('TI133',TI3(1,3,3),0.) CALL RSEP3R('TI233',TI3(2,3,3),0.) CALL RSEP3R('TI333',TI3(3,3,3),0.) C C C Loop over Xi0: DO 120 IN30=1,N30 X0(3)=O30+D30*(IN30-1) DO 110 IN20=1,N20 X0(2)=O20+D20*(IN20-1) DO 100 IN10=1,N10 X0(1)=O10+D10*(IN10-1) L=0 C C Loop over Xi: DO 90 IN3=1,N3 X(3)=O3+D3*(IN3-1) DO 80 IN2=1,N2 X(2)=O2+D2*(IN2-1) DO 70 IN1=1,N1 X(1)=O1+D1*(IN1-1) AR=AR0 AI=AI0 TR=TR0 TI=TI0 C Calculating the functional value: DO 10 I=1,3 DX=X(I)-X0(I) AR=AR+AR1(I)*DX AI=AI+AI1(I)*DX TR=TR+TR1(I)*DX TI=TI+TI1(I)*DX 10 CONTINUE DO 30 J=1,3 DXJ=(X(J)-X0(J))/2. DO 20 I=1,J DXI=X(I)-X0(I) DX=DXI*DXJ AR=AR+AR2(I,J)*DX AI=AI+AI2(I,J)*DX TR=TR+TR2(I,J)*DX TI=TI+TI2(I,J)*DX 20 CONTINUE 30 CONTINUE DO 60 K=1,3 DXK=(X(K)-X0(K))/6. DO 50 J=1,K DXJ=X(J)-X0(J) DO 40 I=1,J DXI=X(I)-X0(I) DX=DXI*DXJ*DXK AR=AR+AR3(I,J,K)*DX AI=AI+AI3(I,J,K)*DX TR=TR+TR3(I,J,K)*DX TI=TI+TI3(I,J,K)*DX 40 CONTINUE 50 CONTINUE 60 CONTINUE FR=AR*COS(TI)*EXP(TR)-AI*SIN(TI)*EXP(TR) FI=AR*SIN(TI)*EXP(TR)+AI*COS(TI)*EXP(TR) L=L+1 RAM(L)=FR RAM(N1N2N3+L)=FI C C End of calculation C 70 CONTINUE 80 CONTINUE 90 CONTINUE C C Writing output grid values IF(OUTR.NE.' ') THEN CALL WARRAY(LU1,' ','FORMATTED',.FALSE.,0.,.FALSE.,0., * N1N2N3,RAM) END IF IF(OUTI.NE.' ') THEN CALL WARRAY(LU2,' ','FORMATTED',.FALSE.,0.,.FALSE.,0., * N1N2N3,RAM(N1N2N3+1)) END IF C C End of loop over Xi C PT=PT+1 WRITE(*,'(''+GRDTE: '',I16,'' loops over Xi0 of'',I9)') PT,PTM 100 CONTINUE 110 CONTINUE 120 CONTINUE C C End of loop over Xi0 C IF(OUTR.NE.' ') THEN CLOSE(LU1) END IF IF(OUTI.NE.' ') THEN CLOSE(LU2) END IF C WRITE(*,'(A)')'+GRDTE: Done.' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdtrans.for 0100666 0000765 0000765 00000017450 07304363410 012774 0 ustar bulant bulant C
C Program GRDTRANS to transpose the coordinate axes of the gridded data C C Version: 5.50 C Date: 2001, May 28 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input and output files: C GRD='string'... Names of the input ASCII file with the grid C values. C Default: GRD='grd.out' C GRDNEW='string'... Name of the output ASCII file containing the C input grid values ordered according to the transposed C coordinates. C Default: GRDNEW='grdnew.out' C For general description of the files with gridded data refer C to file forms.htm. C Data specifying dimensions of the input grid: C N1=positive integer... Number of gridpoints along the fastest X1 C axis (inner loop). C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis C (intermediate loop). C Default: N2=1 C N3=positive integer... Number of gridpoints along the slowest C spatial X3 axis (outer spatial loop). C N4=positive integer... Number of gridpoints along optional time X4 C axis (outermost, temporal loop). C Default: N4=1 C Data specifying the output grid coordinates: C NEWX1=positive integer... Index of the input axis, corresponding C to the fastest output axis NEWX1 (inner output loop). C NEWX1=1: Fastest input axis (inner input loop), C NEWX1=2: Medium input axis (intermediate input loop), C NEWX1=3: Slowest input spatial axis (outer spatial input C loop). C NEWX1=4: Input time axis (outermost, temporal input loop). C Default: NEWX1=1 C NEWX2=positive integer... Index of the input axis, corresponding C to the output axis NEWX2. Analogous to NEWX1. C Default: NEWX2=2 C NEWX3=positive integer... Index of the input axis, corresponding C to the slowest output axis NEWX3. Analogous to NEWX1. C Default: NEWX3=3 C NEWX4=positive integer... Index of the input axis, corresponding C to the slowest output axis NEWX4. Analogous to NEWX1. C Default: NEWX4=4 C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C C Filenames and parameters: CHARACTER*80 FSEP,FGRD1,FGRD2 INTEGER LU REAL UNDEF PARAMETER (LU=1,UNDEF=-999999.) C Input data: INTEGER N1,N2,N3,N4,NEWX1,NEWX2,NEWX3,NEWX4 C Other variables: INTEGER NEWN1,NEWN2,NEWN3,NEWN4,ITRANS(4),I1,I2,I3,I4,I,J3,J4,J C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDTRANS: Enter input filename: ' FSEP=' ' READ(*,*) FSEP WRITE(*,'(A)') '+GRDTRANS: Working ... ' C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C GRDTRANS-01 CALL ERROR('GRDTRANS-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('GRD' ,FGRD1,'grd.out' ) CALL RSEP3T('GRDNEW',FGRD2,'grdnew.out') CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3I('N4',N4,1) IF(2*N1*N2*N3*N4.GT.MRAM) THEN C GRDTRANS-02 CALL ERROR('GRDTRANS-02: Too small array RAM(MRAM)') C Array RAM(MRAM) allocated in include file 'ram.inc' is too small C to contain two input grids (2*N1*N2*N3*N4 values). You may wish C to increase the dimension MRAM in file 'ram.inc'. C ram.inc END IF CALL RSEP3I('NEWX1',NEWX1,1) CALL RSEP3I('NEWX2',NEWX2,2) CALL RSEP3I('NEWX3',NEWX3,3) CALL RSEP3I('NEWX4',NEWX4,4) IF(NEWX1.LT.1.OR.4.LT.NEWX1) THEN C GRDTRANS-03 CALL ERROR('GRDTRANS-03: Incorrect value of parameter NEWX1') END IF IF(NEWX2.LT.1.OR.4.LT.NEWX2) THEN C GRDTRANS-04 CALL ERROR('GRDTRANS-04: Incorrect value of parameter NEWX2') END IF IF(NEWX3.LT.1.OR.4.LT.NEWX3) THEN C GRDTRANS-05 CALL ERROR('GRDTRANS-05: Incorrect value of parameter NEWX3') END IF IF(NEWX4.LT.1.OR.4.LT.NEWX4) THEN C GRDTRANS-06 CALL ERROR('GRDTRANS-06: Incorrect value of parameter NEWX4') END IF IF(NEWX1.EQ.NEWX2.OR.NEWX1.EQ.NEWX3.OR.NEWX2.EQ.NEWX3.OR. * NEWX1.EQ.NEWX4.OR.NEWX2.EQ.NEWX4.OR.NEWX3.EQ.NEWX4) THEN C GRDTRANS-07 CALL ERROR('GRDTRANS-07: Coinciding output axes') END IF C ITRANS(1)=N1 ITRANS(2)=N2 ITRANS(3)=N3 ITRANS(4)=N4 NEWN1=ITRANS(NEWX1) NEWN2=ITRANS(NEWX2) NEWN3=ITRANS(NEWX3) NEWN4=ITRANS(NEWX4) ITRANS(1)=1 ITRANS(2)=N1 ITRANS(3)=N1*N2 ITRANS(4)=N1*N2*N3 NEWX1=ITRANS(NEWX1) NEWX2=ITRANS(NEWX2) NEWX3=ITRANS(NEWX3) NEWX4=ITRANS(NEWX4) C C Reading input grid: CALL RARAY(LU,FGRD1,'FORMATTED',.TRUE.,UNDEF,N1*N2*N3,N4,RAM) C C Tranposing the grid: I=N1*N2*N3*N4 DO 14 I4=0,NEWN4-1 J4=1+I4*NEWX4 DO 13 I3=0,NEWN3-1 J3=J4+I3*NEWX3 DO 12 I2=0,NEWN2-1 J=J3+I2*NEWX2 DO 11 I1=0,NEWN1-1 I=I+1 RAM(I)=RAM(J) J=J+NEWX1 11 CONTINUE 12 CONTINUE 13 CONTINUE 14 CONTINUE C C Writing output grid: CALL WARAY(LU,FGRD2,'FORMATTED',.TRUE.,UNDEF,.FALSE.,0.,N1*N2*N3, * N4,RAM(N1*N2*N3*N4+1)) WRITE(*,'(A)') '+GRDTRANS: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cgrdwrl.for 0100666 0000765 0000765 00000036511 07471115104 012450 0 ustar bulant bulant C
C Program GRDWRL to convert gridded data into the GOCAD representation C C Version: 5.60 C Date: 2002, May 17 C C Coded by: Ludek Klimes & Vaclav Bucha C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mails: klimes@seis.karlov.mff.cuni.cz C bucha@seis.karlov.mff.cuni.cz C C Reference: C C GOCAD C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Input colour-map file: C COLORS='string'... Name of the file containing the data describing C the colour map. C Description of file COLORS C Default: COLORS='hsv.dat' C Input/output file: C WRL='string'... Name of the file to be supplemented with surfaces C or to be copied to the beginning of the output file. C If the filename is blank, output file starts from a C scratch (mostly not reasonable). C The default name of the output file is equal to WRL. C It is recommended to specify WRL rather than to use C the default name. C Default: WRL='out.wrl' C WRLOUT='string'... Name of the output file if different from WRL. C Default: WRLOUT=WRL C Data specifying the form of the output file: C VRML='string'... Virtual reality scene description language. C VRML='VRML1': VRML (Virtual Reality Modeling Language) C version 1.0. This value is accepted but C no output is generated. C VRML='VRML2': VRML97 according to ISO/IEC 14772 standard. C This value is accepted but no output is C generated. C VRML='GOCAD': GOCAD description of Voxet (data grid) is C generated. C Default: VRML='VRML2'. C NAME='string'... String containing the GOCAD name of the gridded C values. Be sure to select different names for all objects C within the GOCAD file. C The same name is used for the corresponding colour scale. C Used only if VRML='GOCAD'. Obligatory parameter, must be C specified and cannot be blank if VRML='GOCAD'. C PROPERTY='string'... String containing the GOCAD property name of C the gridded quantity. C Used only if VRML='GOCAD'. C Default: PROPERTY=NAME C Data specifying the name of the file with gridded values: C GRD='string'... String with the name of the input ascii file C containing the gridded values. The file is used to C determine the minimum and maximum grid values for colour C mapping. C Undefined grid values are allowed but dangerous. C No default, GRD must be specified and cannot be blank. C IN='string'... String with the name of the input binary file C containing the gridded values. The file should contain C just the 4 byte big-endian (workstation-like) IEEE reals, C even on a little-endian computer. The length of the file C is thus exactly 4*N1*N2*N3 bytes. The gridded data should C be converted into this form by programs C ascbin.for and C swap.for. C Note that the file given by parameter IN is not read nor C checked by this program, only its name is written to the C output file. The user is thus responsible for generating C the file with gridded values in the correct form. C No default, IN must be specified and cannot be blank. C Data specifying the parameters of the input grid: C O1=real, O2=real, O3=real ... Coordinates of the origin of the C grid. C Default: O1=0. O2=0. O3=0. C D1=real... Grid interval along the X1 axis. C Default: D1=0. C D2=real... Grid interval along the X2 axis. C Default: D2=0. C D3=real... Grid interval along the X3 axis. C Default: D3=0. C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C Data specifying the colour scale: C VADD=real, VMUL=real, VPER=real, VREF=real, CREF=real, CREF1=real, C CREF2=real, CREF3=real, etc... Refer to file C colors.for. C TRANSP=real... Transparency of the displayed sections through the C gridded data. Values from 0 to 1. C Initial position of the sections corresponds to the six C sides of the voxet. C Default: TRANSP=0. C NODATA=real... Value used as the 'property no data value' in C GOCAD. This parameter should not be specified if there C are undefined grid values. Initial transparency of the C 'no data' values is set to 0.80. C Default: NODATA=undefined value used in C forms.for C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C C External functions and subroutines: EXTERNAL LENGTH,UARRAY,RSEP1,RSEP3T,RSEP3I,RSEP3R,ERROR,FORM2 INTEGER LENGTH REAL UARRAY C C Filenames and parameters: CHARACTER*80 FSEP,FGRD,FBIN,FIN,FOUT INTEGER LU1,LU2 PARAMETER (LU1=1,LU2=2) C C Other variables: CHARACTER*27 FORMAT CHARACTER*5 VRML CHARACTER*255 NAME,TEXT INTEGER N1,N2,N3,I0,I REAL O1,O2,O3,D1,D2,D3,TRANSP REAL OUT(3),OUTMIN(1),OUTMAX(1),R,G,B,AUX,AUXA(1) C C Undefined grid value: REAL UNDEF UNDEF=UARRAY() C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+GRDWRL: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C GRDWRL-01 CALL ERROR('GRDWRL-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF CALL RSEP1(LU1,FSEP) WRITE(*,'(A)') '+GRDWRL: Working... ' C C Reading input and output filenames: CALL RSEP3T('GRD',FGRD ,' ') IF(FGRD.EQ.' ') THEN C GRDWRL-02 CALL ERROR('GRDWRL-02: No ascii grid file specified') C Ascii file with gridded data must be specified. C There is no default filename. END IF CALL RSEP3T('IN',FBIN ,' ') IF(FBIN.EQ.' ') THEN C GRDWRL-03 CALL ERROR('GRDWRL-03: No binary grid file specified') C Binary file with gridded data must be specified. C There is no default filename. END IF CALL RSEP3T('WRL' ,FIN ,'out.wrl') CALL RSEP3T('WRLOUT',FOUT ,FIN ) CALL RSEP3T('VRML' ,VRML ,'VRML2' ) CALL LOWER(VRML) C C Reading grid dimensions: CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) C C Reading input parameters for surface appearance: CALL RSEP3R('TRANSP',TRANSP,0.00) C C Opening the output file and writing its beginning: CALL WRL1(LU1,LU2,FIN,FOUT,VRML,1) C C Writing the prolog for the voxet (part 1): IF (VRML.EQ.'vrml1') THEN C GRDWRL-51 CALL WARN('GRDWRL-51: Nothing to do') C If VRML='VRML1', no output file with gridded values is created. C This program generates output only if VRML='GOCAD'. ELSE IF (VRML.EQ.'vrml2') THEN C GRDWRL-52 CALL WARN('GRDWRL-52: Nothing to do') C If VRML='VRML2', no output file with gridded values is created. C This program generates output only if VRML='GOCAD'. ELSE IF (VRML.EQ.'gocad') THEN CALL RSEP3T('NAME',NAME,' ') C Subroutine WRL has already checked that NAME is not blank. WRITE(LU2,'(A)') * 'GOCAD Voxet 1.0' WRITE(LU2,'(2A)') * 'HDR name:',NAME(1:LENGTH(NAME)) CALL RSEP3T('PROPERTY',TEXT,NAME) I=LENGTH(TEXT) WRITE(LU2,'(2A)') * 'HDR *property:',TEXT(1:I) * ,'HDR *grid3d1:',TEXT(1:I) WRITE(LU2,'(2A)') * 'HDR ','*cage:false' * ,'HDR ','*shaded:true' * ,'HDR ','*precise:true' * ,'HDR ','*smoothed:true' FORMAT='(3A,I0,A,I0,A,I0)' FORMAT( 6: 6)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(N1)-0.5))) FORMAT(11:11)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(N2)-0.5))) FORMAT(16:16)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(N3)-0.5))) WRITE(LU2,FORMAT) * 'HDR *',TEXT(1:I),'*sections: 6 1 1 0 1 1 ',N1-1 * ,' 2 1 0 2 1 ',N2-1 * ,' 3 1 0 3 1 ',N3-1 FORMAT='(A,' OUT(1)=O1 OUT(2)=O2 OUT(3)=O3 CALL FORM2(3,OUT,OUT,FORMAT(4:27)) WRITE(LU2,FORMAT) * 'AXIS_O ',O1,' ',O2,' ',O3 OUT(1)=D1 OUT(2)=D2 OUT(3)=D3 CALL FORM2(3,OUT,OUT,FORMAT(4:27)) FORMAT(25:27)=') ' WRITE(LU2,FORMAT) * 'AXIS_U ',D1,' ',0.,' ',0. * ,'AXIS_V ',0.,' ',D2,' ',0. * ,'AXIS_W ',0.,' ',0.,' ',D3 FORMAT='(A,I0,A,I0,A,I0)' FORMAT( 5: 5)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(N1)+0.5))) FORMAT(10:10)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(N2)+0.5))) FORMAT(15:15)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(N3)+0.5))) WRITE(LU2,FORMAT) * 'AXIS_MIN ',0 ,' ',0 ,' ',0 * ,'AXIS_MAX ',N1-1,' ',N2-1,' ',N3-1 * ,'AXIS_N ',N1 ,' ',N2, ' ',N3 WRITE(LU2,'(3A)') * 'PROPERTY 1 "',TEXT(1:I),'"' * ,'PROPERTY_CLASS 1 "',TEXT(1:I),'"' * ,'PROPERTY_CLASS_HEADER ',TEXT(1:I),' {' C The output file now waits for the colour scale. ELSE C GRDWRL-04 CALL ERROR('GRDWRL-04: Invalid string in VRML') C Valid string specifying the form of the output file is: C VRML='GOCAD', 'VRML1' or 'VRML2'. The output is created only C if VRML='GOCAD'. Default value is 'VRML2'. END IF C C Determining the minimum and maximum grid values: IF(N1*N2*N3.GT.MRAM) THEN C GRDWRL-05 CALL ERROR('GRDWRL-05: Too small array RAM(MRAM)') C Too small array RAM(MRAM) to allocate the grid values. C If possible, increase dimension MRAM in include file C ram.inc. END IF CALL RARRAY(LU1,FGRD,'FORMATTED',.TRUE.,UNDEF,N1*N2*N3,RAM) I0=0 DO 10 I=1,N1*N2*N3 IF(RAM(I).NE.UNDEF) THEN IF(I0.EQ.0) THEN OUTMIN(1)=RAM(I) OUTMAX(1)=RAM(I) I0=1 ELSE OUTMIN(1)=AMIN1(OUTMIN(1),RAM(I)) OUTMAX(1)=AMAX1(OUTMAX(1),RAM(I)) END IF END IF 10 CONTINUE IF(I0.EQ.0) THEN C GRDWRL-06 CALL ERROR('GRDWRL-06: All grid values undefined') C At least one grid value should be defined. END IF C C Determining the colour map: IF(VRML.EQ.'gocad') THEN CALL COLOR1(LU1,MRAM,IRAM,RAM,1,OUTMIN,OUTMAX) WRITE(LU2,'(2A)') * ' *colormap:',TEXT(1:LENGTH(TEXT)) WRITE(LU2,'(A)') * ' *colormap*nodata:true' * ,' *colormap*ndtransparency: 0.80' FORMAT='(A,' CALL FORM2(1,OUTMIN,OUTMAX,FORMAT(4:11)) FORMAT(9:11)=') ' IF(OUTMAX(1).GT.OUTMIN(1)) THEN WRITE(LU2,FORMAT) * ' *low_clip: ',OUTMIN(1) * ,' *high_clip:',OUTMAX(1) ELSE WRITE(LU2,FORMAT) * ' *low_clip: ',OUTMIN(1) * ,' *high_clip:',OUTMIN(1)+1. END IF WRITE(LU2,'(4A)') * ' *colormap*',TEXT(1:LENGTH(TEXT)),'*colors: ',CHAR(92) AUX=(OUTMAX(1)-OUTMIN(1))/255. DO 31 I=0,255 AUXA(1)=OUTMIN(1)+FLOAT(I)*AUX CALL COLOR2(MRAM,IRAM,RAM,1,AUXA,R,G,B) IF (I.LT.255) THEN WRITE(LU2,'(I5,3(1X,F4.2),2A)') * I,R,G,B,' ',CHAR(92) ELSE WRITE(LU2,'(I5,3(1X,F4.2),2A)') * I,R,G,B END IF 31 CONTINUE IF(TRANSP.GT.0.) THEN WRITE(LU2,'(2A)') * ' *colormap*alphas: ',CHAR(92) DO 32 I=0,255 IF (I.LT.255) THEN WRITE(LU2,'(I5,1X,F4.2,2A)') * I,TRANSP,' ',CHAR(92) ELSE WRITE(LU2,'(I5,1X,F4.2,2A)') * I,TRANSP END IF 32 CONTINUE END IF END IF C C Writing the prolog for the voxet (part 2): IF (VRML.EQ.'gocad') THEN WRITE(LU2,'(A)') * '}' * ,'PROP_FORMAT 1 RAW' * ,'PROP_ETYPE 1 IEEE' * ,'PROP_ESIZE 1 4' CALL RSEP3R('NODATA',AUX,UNDEF) WRITE(LU2,'(A,G15.9)') * 'PROP_NO_DATA_VALUE 1 ',AUX WRITE(LU2,'(2A)') * 'PROP_FILE 1 ',FBIN END IF C C Writing the trailor for the GOCAD object: IF (VRML.EQ.'gocad') THEN WRITE(LU2,'(A)') 'END' END IF CLOSE(LU2) WRITE(*,'(A)') '+GRDWRL: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'forms.for' C forms.for INCLUDE 'colors.for' C colors.for INCLUDE 'wrl.for' C wrl.for C C======================================================================= Cgse.for 0100666 0000765 0000765 00000104764 07662341200 011733 0 ustar bulant bulant C
C Subroutine file 'gse.for' to write and read seismograms in the GSE 1.0 C data exchange format. C C Version: 5.70 C Date: 2003, May 20 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 Reference to GSE 1.0: C GSETT-2 (1990): Instructions for the conduct of the preparatory C test of phase 3 of GSETT-2. C Ad hoc Group of Scientific Experts (GSE) to consider C international cooperative measures to detect and identify C seismic events - Conference Room Paper 190/Rev.4, C Geneva, Switzerland, September 1990. C Reference to GSE 2.0: C GSETT-3 (1995): Formats. C Group of Scientific Experts - Conference Room Paper 243, C Conference on Disarment, United Nations, Geneva, C Switzerland, July 1995. C Reference to GSE 2.1: C GSETT-3 (1997): Provisional GSE 2.1 Message Formats and Protocols. C Operation Annex 3. May 1997. C C....................................................................... C C This FORTRAN77 file consists of the following external procedures: C WGSE1...Subroutine designed to write the header section. It C should be called once after opening the output GSE file. C WGSE1 C WGSE2...Subroutine designed to write one seismogram. C WGSE2 C WGSE2C..Entry of subroutine WGSE2 designed to accumulate C individual lines to be written to the Comment sections of C the next seismograms written by WGSE2. Entry WGSE2C need C not be considered unless using the Comment sections of the C Waveform identification sections for special purposes. C WGSE2C C WGSE2D..Entry of subroutine WGSE2 designed to delete the lines C accumulated by previous invocations of WGSE2C. Usually C not needed. C WGSE2D C WGSE3...Subroutine designed to write the end of data file C indicator. It should be called once before closing the C output GSE file. C WGSE3 C RGSE1...Subroutine designed to read the text from the header C section. It may be called once after opening the input C GSE file. C RGSE1 C RGSE2...Subroutine designed to read one seismogram. The next C seismogram will be read during the next invocation of this C subroutine. C RGSE2 C RGSE2C..Entry of subroutine RGSE2 designed to pass individual C lines of the Comment section of the last seismogram read C by RGSE2. Entry RGSE2C need not be considered unless C using the Comment sections of the Waveform identification C sections for special purposes. C RGSE2C C C....................................................................... C C C Structure of the GSE 1.0 waveform data exchange file: C (1) Header section: C Position: Format: Item: C 01-04 A4 'XW01'... Obligatory string, an abbreviation for C the waveform data exchange file. C 05-45 41X Reserved for the information on the data C transmission, see the GSE 1.0 standard (blank C for synthetic data). Left blank during writing, C skipped during reading. C 46-80 1X,A34 Text describing the file or the data. Left C justified. The GSE 1.0 standard requires the C first 6 characters of the text (positions 47-52) C to identify the data day in the form: YYMMDD, C see parameter text of subroutine WGSE1. C (2) For each seismogram (2.1), (2.2), (2.3), (2.4), (2.5), and (2.6): C (2.1) Waveform identification section, Line 1: C Position: Format: Item: C 01-04 A4 'WID1'... Obligatory string, an abbreviation for C the waveform identification section. C 05-10 1X,I5 Year (often zero for synthetic data). Left C blank during writing, skipped during reading. C 11-13 I3 Day of the year (often zero for synthetic data). C If start time (argument TSTART of subroutine C WGSE2) is positive, WGSE2 writes day 001. If C start time TSTART is negative, WGSE2 writes day C 000 and time TSTART increased by 86400 seconds C before conversion to hours, minutes and seconds. C Subroutine RGSE2 deems a positive day or a blank C day to be 001, and a non-positive day to be 000. C 14-16 1X,I2 Start hours (often zero for synthetic data). C 17-19 1X,I2 Start minutes (often zero for synthetic data). C 20-22 1X,I2 Start seconds. C 23-26 1X,I3 Start miliseconds. C 27 I1 Start tenths of miliseconds (in the GSE 1.0 C standard, start time is rounded to miliseconds C and this position should be left free). C Written by subroutine WGSE2 if non-zero. C This position makes likely the greatest C difference between the GSE 1.0 standard and this C implementation, but need not necessarily C influence the portability of the data files. C 28-35 I8 Number of samples. C 36-42 1X,A6 Station name (sometimes used for synthetic C data, sometimes blank or '-'). Left justified. C 43-51 1X,A8 Channel name (occasionally used for synthetic C data, often blank or '-' even for real data). C Left justified. C 52-54 1X,A2 Component, recommendation for synthetic data: C '- ' OR ' 0'... Undefined, C '-E' OR ' 1'... X1 component, C '-N' OR ' 2'... X2 component, C '-Z' OR ' 3'... X3 component, etc. C The component (channel identifier) is written to C the GSE file by subroutine WGSE2 in the form of C integer (format I2), which is probably unusual C for the field data. However, GSE 1.0 standard C admits an arbitrary string composed of two C uppercase characters. C 55-66 1X,F11.7 Samples per second. C 67-73 1X,A6 Instrument type ('-' for synthetic data). C '- ' written by subroutine WGSE2, skipped C during reading. C 74-78 1X,A4 Data format, recommendation for synthetic data: C 'INT5'... Format(16(1X,I4), C 'INTV'... Integers, list directed input (free C format), linewidth 80 characters. C 79-80 1X,I1 Differencing flag, recommendation for synthetic C data: C '0' or ' '... Actual seismogram stored, no C differences. Differences are not C assumed by the subroutines of this C file. C (2.2) Waveform identification section, Line 2: C Position: Format: Item: C 01-09 F9.6 Amplitude corresponding to 1 in the seismogram. C 10 A1 Units of the amplitude: C '0' or ' '... Displacement in nanometers, C '1'... Particle velocity in nanometers/second, C '2'... Acceleration in nanometers/second**2. C Left blank by subroutine WGSE2, not read by C subroutine RGSE2. C 11-17 F7.4 Calibration period (-1 for synthetic data). C -1. written by subroutine WGSE2, not read by C subroutine RGSE2. C 18-27 1X,F9.4 X2 coordinate (only geographical coordinates C allowed by the GSE 1.0 standard for field data). C 28-37 1X,F9.4 X1 coordinate (only geographical coordinates C allowed by the GSE 1.0 standard for field data). C 38-47 1X,F9.4 X3 coordinate (only elevation above sea level in C metres allowed by the GSE standard for field C data). C 48-57 1X,F9.4 Depth of sensor (often -999 (N/A) for synthetic C data). C -999. written by subroutine WGSE2, not read by C subroutine RGSE2. C 58-65 1X,F7.2 Beam azimuth (-1 (N/A) for synthetic data). C -1. written by subroutine WGSE2, not read by C subroutine RGSE2. C 66-73 1X,F7.2 Beam slowness (-1 (N/A) for synthetic data). C -1. written by subroutine WGSE2, not read by C subroutine RGSE2. C 74-80 1X,F6.1 Orientation of horizontal sensors, measured C clockwise from the X2-axis (mostly -1 (N/A) for C synthetic data). C -1. written by subroutine WGSE2, not read by C subroutine RGSE2. C (2.3) Waveform identification section - Comments: C None to several lines with character strings, FORMAT(A80), C containing application specific information. Usually not used. C First four characters of a line must not match any of the C following strings: 'X***', 'WID*', 'DAT*', 'STOP', where * stands C for a wild character. To use columns 3 to 80 only seems to be the C best way of contingently introducing this specific information. C The comment lines are accumulated by means of invocation of entry C WGSE2C of subroutine WGSE2. C Example: C If we like to write real-valued data into the comment lines in C the SEP format, subroutine C WSEPR may be called to generate C string containing 2 spaces followed by the NAME=RVAL couple. C Here NAME is the name of the parameter and RVAL is the value. C For instance, string ' X1SRC=2.5' indicates that parameter C X1SRC, used by some programs for the X1 source coordinate, has C the value of 2.5. C The string may then be stored in the memory by the invocation of C entry WGSE2C. All strings stored by invocations of WGSE2C are C written to individual comment lines of the corresponding C seismogram by each invocation of subroutine WGSE2. C After reading a seismogram by the invocation of subroutine C RGSE2, corresponding individual comment lines may be retrieved C by the respective invocations of entry RGSE2C. The comment C lines may be collected in the memory by subroutine C RSEP2 and the values of the C real-valued parameters may be obtained by the invocations of C subroutine RSEP3R. C (2.4) Waveform data section - Beginning: C Position: Format: Item: C 01-04 A4 'DAT1'... Obligatory string, an abbreviation for C the waveform data section. C (2.5) Waveform data section: C Seismogram formatted according to the specified data format, C assumed to be readable by list directed input into an integer or C real array. C (2.6) Waveform data section - End: C Position: Format: Item: C 01-04 A4 'CHK1'... Obligatory string, an abbreviation for C the checksum. C 05-09 5X C 10-24 I or F Sum of all data values (before compression or C differencing). C (3) End of data file indicator: C Position: Format: Item: C 01-04 A4 'STOP'... Obligatory string at the end. C Note: GSE file may contain many other sections or lines than described C above, but they are not written and read by the subroutines of this C file. C C======================================================================= C C C SUBROUTINE WGSE1(LU,TEXT) CHARACTER*(*) TEXT INTEGER LU C C Subroutine designed to write the header section. It should be called C once after opening the output GSE file. C C Input: C LU... Logical unit number of the external output device already C open for formatted sequential output. C TEXT... String containing the text to be stored in the header C section. Maximum of 34 characters will be stored. C Note that the GSE standard requires the first 6 characters C of the text to identify the data day in the form: YYMMDD. C Such a restriction is not required by the subroutines of C this file. C The input parameters are not altered. C C No output. C C----------------------------------------------------------------------- C C No temporary storage locations. C C....................................................................... C C Writing header section: WRITE(LU,'(A4,42X,A)') 'XW01',TEXT(1:MIN0(LEN(TEXT),34)) RETURN END C C======================================================================= C C C SUBROUTINE WGSE2(LU,STAT,CHAN,KOMP, * X1,X2,X3,TSTART,TSTEP,NSEIS,SEIS) INTEGER LU,KOMP,NSEIS CHARACTER*(*) STAT,CHAN REAL X1,X2,X3,TSTART,TSTEP,SEIS(NSEIS) C C Subroutine designed to write one seismogram. C C Input: C LU... Logical unit number of the external output device already C open for formatted sequential output. C STAT... String with the station name (not required, may be ' ' or C '-'). C CHAN... String with the channel name (often ' ' or '-'). C KOMP... Component (nonnegative integer not exceeding 99): C 0... Undefined component (e.g., scalar time function), C 1... X1 component, C 2... X2 component, C 3... X3 component, etc. C The component (channel identifier) is written to the GSE C file in the form of integer (format I2), which is probably C unusual for the field data. However, GSE standard admits C an arbitrary string composed of 2 uppercase characters. C For example, the components of the 3*3 Green function may C be numbered 1,2,3,4,5,6,7,8,9. In the case of complex C functions, the imaginary parts may be distinguished from C the corresponding real parts by KOMP increased by 10. C X1,X2,X3... Coordinates of the receiver. C -999.0000 stands for the undefined value, that may be C applicable especially for, e.g., X2 in 2-D synthetic C calculations. C TSTART..Start time, i.e. the time corresponding to the first C sample in seconds. In the GSE file, the time is converted C to hours, minutes, seconds, and days from the beginning of C an unspecified year. Times greater than 86400 seconds in C absolute value are not assumed. Formal day corresponding C to negative times in GSE 1.0 format is January 0. C TSTEP...Time step between samples. C NSEIS...Number of samples. C (SEIS(I),I=1,NSEIS)... Seismogram. The leading and trailing zeros C will be removed before writing. C The input parameters are not altered. C C No output. C C....................................................................... C C C C ENTRY WGSE2C(COMLIN) CHARACTER*(*) COMLIN C C Entry designed to accumulate individual lines to be written to the C Comment sections of the next seismograms written by WGSE2. Entry C WGSE2C need not be considered unless using the Comment sections of the C Waveform identification sections for special purposes. C C Input: C COMLIN..Line to be written to the comment lines of the waveform C identification section. The lines passed by the first C MLINES invocations of WGSE2C are accumulated and written C by each next invocation of WGSE2, until the lines are C deleted by invocation of WGSE2D. Parameter MLINES may be C adjusted below. C The input parameter is not altered. C C No output. C C....................................................................... C C C C ENTRY WGSE2D C C Entry designed to delete the lines accumulated by previous invocations C of WGSE2C. The accumulation by invocations of WGSE2C then begins from C the scratch. WGSE2D is not required too often. C C No Input, no output. C C----------------------------------------------------------------------- C C Parameters: LOGICAL FIXED INTEGER NWIDTH,NFORM PARAMETER (FIXED=.FALSE.) PARAMETER (NWIDTH=5,NFORM=80/NWIDTH) C C NWIDTH is the width of the output field reserved for one integer C value of the seismogram. The number of output digits is C then NWIDTH-2. NWIDTH must be taken from interval 3 to 9, C but NWIDTH=3 or 4 is strongly discouraged. C FIXED...FIXED=.TRUE.: Fixed-length format, C FIXED=.FALSE.: Variable-length format. C C Temporary storage locations: CHARACTER*6 FORMAT CHARACTER*4 FORM CHARACTER*80 LINE CHARACTER*6 STAT6 CHARACTER*8 CHAN8 INTEGER IDAY,IH,IM,IS,IMS,IMS4,I,L,NSEIS1,NSEIS2,ISEIS(0:25) REAL TMS4,FSTEP,AMPL,AUX C C Storage location for Comments of Waveform identification section: INTEGER MLINES,NLINES PARAMETER (MLINES=20) CHARACTER*80 LINES(MLINES) SAVE NLINES,LINES DATA NLINES/0/ C MLINES..Only the first MLINES comment lines are stored. C C....................................................................... C C Output format: FORMAT='(16I5)' IF(NWIDTH.NE.5) THEN WRITE(FORMAT(5:5),'(I1)') NWIDTH END IF FORM='INTV' IF(FIXED) THEN FORM(4:4)=FORMAT(5:5) END IF C C Nonzero part of the seismogram and the maximum amplitude: DO 11 NSEIS1=1,NSEIS IF(SEIS(NSEIS1).NE.0.) THEN GO TO 12 END IF 11 CONTINUE 12 CONTINUE DO 13 NSEIS2=NSEIS,NSEIS1,-1 IF(SEIS(NSEIS2).NE.0.) THEN GO TO 14 END IF 13 CONTINUE 14 CONTINUE AMPL=0. DO 15 I=NSEIS1,NSEIS2 AMPL=AMAX1(ABS(SEIS(I)),AMPL) 15 CONTINUE AMPL=AMPL/FLOAT(10**(NWIDTH-2)-1) AUX=AMPL/2. DO 16 NSEIS1=NSEIS1,NSEIS2 IF(ABS(SEIS(NSEIS1)).GT.AUX) THEN GO TO 17 END IF 16 CONTINUE 17 CONTINUE DO 18 NSEIS2=NSEIS2,NSEIS1,-1 IF(ABS(SEIS(NSEIS2)).GT.AUX) THEN GO TO 19 END IF 18 CONTINUE 19 CONTINUE C C Writing waveform identification section: IF(ABS(TSTART).GT.86400.) THEN C GSE-01 CALL ERROR('GSE-01: Starting time greater than 86400') END IF TMS4=(TSTART+FLOAT(NSEIS1-1)*TSTEP)*10000. IF(TMS4.LT.-.5) THEN IDAY=000 IMS4=INT(TMS4-.5)+864000000 ELSE IDAY=001 IMS4=INT(TMS4+.5) END IF IMS=IMS4/10 IMS4=IMS4-IMS*10 IS=IMS/1000 IMS=IMS-IS*1000 IM=IS/60 IS=IS-IM*60 IH=IM/60 IM=IM-IH*60 I=MAX0(NSEIS2-NSEIS1+1,0) STAT6=STAT CHAN8=CHAN FSTEP=1./TSTEP IF(IMS4.EQ.0) THEN IF(FSTEP.LT.999.99999995) THEN WRITE(LU,'(A4,6X,I3.3,3(1X,I2.2),I4.3,1X, * I8,1X,A6,1X,A8,1X,I2,1X,F11.7,1X,A1,6X,A4)') * 'WID1',IDAY, IH,IM,IS,IMS, * I,STAT6,CHAN8, KOMP, FSTEP, '-', FORM ELSE IF(FSTEP.LT.9999.9999995) THEN WRITE(LU,'(A4,6X,I3.3,3(1X,I2.2),I4.3,1X, * I8,1X,A6,1X,A8,1X,I2,1X,F11.6,1X,A1,6X,A4)') * 'WID1',IDAY, IH,IM,IS,IMS, * I,STAT6,CHAN8, KOMP, FSTEP, '-', FORM ELSE IF(FSTEP.LT.9999999.9995) THEN WRITE(LU,'(A4,6X,I3.3,3(1X,I2.2),I4.3,1X, * I8,1X,A6,1X,A8,1X,I2,1X,F11.3,1X,A1,6X,A4)') * 'WID1',IDAY, IH,IM,IS,IMS, * I,STAT6,CHAN8, KOMP, FSTEP, '-', FORM ELSE WRITE(LU,'(A4,6X,I3.3,3(1X,I2.2),I4.3,1X, * I8,1X,A6,1X,A8,1X,I2,1X,F11.0,1X,A1,6X,A4)') * 'WID1',IDAY, IH,IM,IS,IMS, * I,STAT6,CHAN8, KOMP, FSTEP, '-', FORM END IF ELSE IF(FSTEP.LT.999.99999995) THEN WRITE(LU,'(A4,6X,I3.3,3(1X,I2.2),I4.3,I1, * I8,1X,A6,1X,A8,1X,I2,1X,F11.7,1X,A1,6X,A4)') * 'WID1',IDAY, IH,IM,IS,IMS,IMS4, * I,STAT6,CHAN8, KOMP, FSTEP, '-', FORM ELSE IF(FSTEP.LT.9999.9999995) THEN WRITE(LU,'(A4,6X,I3.3,3(1X,I2.2),I4.3,I1, * I8,1X,A6,1X,A8,1X,I2,1X,F11.6,1X,A1,6X,A4)') * 'WID1',IDAY, IH,IM,IS,IMS,IMS4, * I,STAT6,CHAN8, KOMP, FSTEP, '-', FORM ELSE IF(FSTEP.LT.9999999.9995) THEN WRITE(LU,'(A4,6X,I3.3,3(1X,I2.2),I4.3,I1, * I8,1X,A6,1X,A8,1X,I2,1X,F11.3,1X,A1,6X,A4)') * 'WID1',IDAY, IH,IM,IS,IMS,IMS4, * I,STAT6,CHAN8, KOMP, FSTEP, '-', FORM ELSE WRITE(LU,'(A4,6X,I3.3,3(1X,I2.2),I4.3,I1, * I8,1X,A6,1X,A8,1X,I2,1X,F11.0,1X,A1,6X,A4)') * 'WID1',IDAY, IH,IM,IS,IMS,IMS4, * I,STAT6,CHAN8, KOMP, FSTEP, '-', FORM END IF END IF IF(-999.9999.LE.X1.AND.X1.LE.9999.9999.AND. * -999.9999.LE.X2.AND.X2.LE.9999.9999.AND. * -999.9999.LE.X3.AND.X3.LE.9999.9999) THEN IF(0.0099999.LT.AMPL.AND.AMPL.LE.99.999999) THEN WRITE(LU, * '( F9.6, 1X, F7.0,3(1X, F9.4 ), F10.0,F8.0,F8.0,F7.0)') * AMPL, -1.0, X2,X1,X3, -999.,-1.0,-1.0,-1.0 ELSE WRITE(LU, * '(1PE9.3E2,1X,0PF7.0,3(1X, F9.4 ), F10.0,F8.0,F8.0,F7.0)') * AMPL, -1.0, X2,X1,X3, -999.,-1.0,-1.0,-1.0 END IF ELSE IF(0.0099999.LT.AMPL.AND.AMPL.LE.99.999999) THEN WRITE(LU, * '( F9.6, 1X, F7.0,3(1X,1PE9.3E1),0PF10.0,F8.0,F8.0,F7.0)') * AMPL, -1.0, X2,X1,X3, -999.,-1.0,-1.0,-1.0 ELSE WRITE(LU, * '(1PE9.3E2,1X,0PF7.0,3(1X,1PE9.3E1),0PF10.0,F8.0,F8.0,F7.0)') * AMPL, -1.0, X2,X1,X3, -999.,-1.0,-1.0,-1.0 END IF END IF C C Writing waveform identification section - Comments: DO 23 I=1,NLINES DO 21 L=LEN(LINES(I)),2,-1 IF(LINES(I)(L:L).NE.' ') THEN GO TO 22 END IF 21 CONTINUE L=1 22 CONTINUE WRITE(LU,'(A)') LINES(I)(1:L) 23 CONTINUE C C Writing waveform data section: WRITE(LU,'(A4)') 'DAT1' IH=0 DO 59 IS=NSEIS1,NSEIS2,NFORM IM=MIN0(NSEIS2-IS,NFORM-1) DO 51 I=0,IM AUX=SEIS(IS+I)/AMPL AUX=SIGN(ABS(AUX)+.5,AUX) ISEIS(I)=INT(AUX) IH=IH+ISEIS(I) 51 CONTINUE IF(FIXED) THEN WRITE(LU,FORMAT) (ISEIS(I),I=0,IM) ELSE WRITE(LINE,FORMAT) (ISEIS(I),I=0,IM) IM=0 DO 52 I=2,80 IF(LINE(I-1:I).NE.' ') THEN IM=IM+1 LINE(IM:IM)=LINE(I:I) END IF 52 CONTINUE WRITE(LU,'(A)') LINE(1:IM) END IF 59 CONTINUE WRITE(LU,'(A4,5X,I15)') 'CHK1',IH C RETURN C C----------------------------------------------------------------------- C ENTRY WGSE2C(COMLIN) C C....................................................................... C IF(NLINES.LT.MLINES) THEN NLINES=NLINES+1 LINES(NLINES)=COMLIN END IF RETURN C C----------------------------------------------------------------------- C ENTRY WGSE2D C C....................................................................... C NLINES=0 RETURN END C C======================================================================= C C C SUBROUTINE WGSE3(LU) INTEGER LU C C Subroutine designed to write the end of data file indicator. It C should be called once before closing the output GSE file. C C Input: C LU... Logical unit number of the external output device already C open for formatted sequential output. The logical unit C is not closed in this subroutine. C The input parameter is not altered. C C No output. C C----------------------------------------------------------------------- C C No temporary storage locations. C C....................................................................... C C Writing end of data file indicator: WRITE(LU,'(A4)') 'STOP' RETURN END C C======================================================================= C C C SUBROUTINE RGSE1(LU,TEXT) CHARACTER*(*) TEXT INTEGER LU C C Subroutine designed to read the text from the header section. It may C be called once after opening the input GSE file. C C Input: C LU... Logical unit number of the external input device C containing the input data, already open for formatted C sequential input. C The input parameter is not altered. C C Output: C TEXT... String containing the text to read from the header C section. Maximum of 34 characters are stored in the file. C C----------------------------------------------------------------------- C C Temporary storage locations: CHARACTER*4 XW01 C C....................................................................... C C Searching for header section: 10 CONTINUE READ(LU,'(A4,42X,A)',END=80) XW01,TEXT IF(XW01.EQ.'XW01') THEN RETURN END IF GO TO 10 C C End of file: 80 CONTINUE C GSE-51 CALL WARN('GSE-51: No header section in input GSE file') RETURN END C C======================================================================= C C C SUBROUTINE RGSE2(LU,STAT,CHAN,KOMP, * X1,X2,X3,TSTART,TSTEP,NSEIS,MSEIS,SEIS) INTEGER LU,KOMP,NSEIS,MSEIS CHARACTER*(*) STAT,CHAN REAL X1,X2,X3,TSTART,TSTEP,SEIS(MSEIS) C C Subroutine designed to read one seismogram. The next seismogram will C be read during the next invocation of this subroutine. C C Input: C LU... Logical unit number of the external input device C containing the input data, already open for formatted C sequential input. C MSEIS...Dimension of array SEIS, i.e. the maximum number of C samples. C The input parameters are not altered. C C Output: C STAT... String with the station name. 6 characters at the most, C but may be declared even as CHARACTER*1 if not required. C See also subroutine WGSE2. C CHAN... String with the channel name. 8 characters at the most, C but may be declared even as CHARACTER*1 if not required. C See also subroutine WGSE2. C KOMP... Component (nonnegative integer): C 0... Undefined or unrecognized component, C 1... X1 component, C 2... X2 component, C 3... X3 component, C or another positive integer written by subroutine WGSE2. C In addition to the nonnegative integers written by WGSE2, C channel identifiers in the form of strings containing C characters 'E','N','Z' are recognized as components 1,2,3, C respectively. C X1,X2,X3... Coordinates of the receiver. C -999.0000 means an undefined value, that may apply C especially to one of the coordinates in 2-D synthetic C calculations. C TSTART..Start time, i.e. the time corresponding to the first C sample. Days are almost ignored: the time is measured C since the last midnight if the day of the year in the GSE C file is positive or blank, and from the next midnight C (i.e. TSTART is negative) if the day of the year is not C positive (e.g. January 0). C TSTEP...Time step between samples. C NSEIS...Number of output samples, or -1 if there is no more C seismogram to be read. C (SEIS(I),I=1,NSEIS)... Seismogram without the leading and trailing C zeros. C C....................................................................... C C C C ENTRY RGSE2C(COMLIN,*) CHARACTER*(*) COMLIN C C Entry designed to pass individual lines of the Comment section of the C last seismogram read by RGSE2. Entry RGSE2C need not be considered C unless using the Comment sections of the Waveform identification C sections for special purposes. C C Input: C *... Label of the statement in the calling subroutine for the C alternate return when no comment line remains for the C output. The label should be preceded by *. For example, C if the comment lines are to be processed by subroutine C RSEP2, the calling code may read C 10 CONTINUE C CALL RGSE2C(COMLIN,*20) C CALL RSEP2(COMLIN) C GO TO 10 C 20 CONTINUE C C Output: C COMLIN..One line of the Comment section of the last seismogram C read by RGSE2. The first invocation of RGSE2 returns the C first comment line, the second invocation of RGSE2 returns C the second comment line and so on. At most the first C MLINES comment lines are recorded and may be output. C Parameter MLINES may be adjusted below. C C----------------------------------------------------------------------- C C Storage location for Comments of Waveform identification section: INTEGER MLINES,NLINES PARAMETER (MLINES=20) CHARACTER*80 LINES(MLINES) SAVE NLINES,LINES C MLINES..Only the first MLINES comment lines are stored. C C Temporary storage locations: CHARACTER*80 LINE CHARACTER*1 COMP1,COMP2 CHARACTER*4 FORM INTEGER IDAY,IH,IM,IS,IMS,IMS4,I REAL FSTEP,AMPL C C....................................................................... C C Searching for waveform identification section: 10 CONTINUE READ(LU,'(A)',END=80) LINE IF(LINE(1:4).EQ.'WID1') THEN GO TO 20 ELSE IF(LINE(1:4).EQ.'STOP') THEN GO TO 90 END IF GO TO 10 C C Reading waveform identification section: 20 CONTINUE READ(LINE,'(13X, * 3(1X,I2),1X,I3,I1,I8,1X,A6,1X,A8,1X,2A1,1X,F11.7,8X,A4,1X,I1)') * IH,IM,IS,IMS,IMS4,NSEIS,STAT, CHAN,COMP1,COMP2,FSTEP,FORM,I IF(LINE(11:13).NE.' ') THEN READ(LINE(11:13),'(I3)') IDAY IF(IDAY.LE.0) THEN IH=IH-24 END IF END IF TSTART=FLOAT((IH*60+IM)*60+IS)+FLOAT(10*IMS+IMS4)/10000. IF(NSEIS.GT.MSEIS) THEN C GSE-02 CALL ERROR('GSE-02: Seismogram longer than array') END IF IF(LLE('0',COMP1).AND.LLE(COMP1,'9')) THEN KOMP=ICHAR(COMP1)-ICHAR('0') ELSE KOMP=0 END IF IF(LLE('0',COMP2).AND.LLE(COMP2,'9')) THEN KOMP=ICHAR(COMP2)-ICHAR('0')+10*KOMP END IF IF(KOMP.EQ.0) THEN IF(COMP1.EQ.'Z'.OR.COMP2.EQ.'Z') THEN KOMP=3 ELSE IF(COMP1.EQ.'N'.OR.COMP2.EQ.'N') THEN KOMP=2 ELSE IF(COMP1.EQ.'E'.OR.COMP2.EQ.'E') THEN KOMP=1 END IF END IF TSTEP=1./FSTEP IF(FORM(1:3).NE.'INT') THEN C GSE-03 CALL ERROR('GSE-03: Data format not supported') END IF IF(I.NE.0) THEN C GSE-04 CALL ERROR('GSE-04: Data differences not supported') END IF READ(LU,'(F9.6,8X,3(1X,F9.4))') AMPL,X2,X1,X3 C C Searching for waveform data section: NLINES=0 30 CONTINUE READ(LU,'(A)') LINE IF(LINE(1:4).EQ.'DAT1') THEN GO TO 50 ELSE C Reading waveform identification section - Comments IF(NLINES.LT.MLINES) THEN NLINES=NLINES+1 LINES(NLINES)=LINE END IF END IF GO TO 30 C C Reading waveform data section: 50 CONTINUE IF(NSEIS.GT.0) THEN READ(LU,*) (SEIS(I),I=1,NSEIS) END IF C Checksum is not read here. C C Removing leading and trailing zeros, and renormalizing: DO 51 NSEIS=NSEIS,1,-1 IF(SEIS(NSEIS).NE.0.) THEN GO TO 52 END IF 51 CONTINUE 52 CONTINUE DO 53 IS=1,NSEIS IF(SEIS(IS).NE.0.) THEN GO TO 54 END IF 53 CONTINUE 54 CONTINUE IF(IS.GT.1) THEN IS=IS-1 TSTART=TSTART+FLOAT(IS)*TSTEP NSEIS=NSEIS-IS DO 55 I=1,NSEIS-IS SEIS(I)=SEIS(I+IS) 55 CONTINUE END IF DO 59 I=1,NSEIS SEIS(I)=SEIS(I)*AMPL 59 CONTINUE C RETURN C C End of file: 80 CONTINUE C GSE-52 CALL WARN('GSE-52: End of input GSE file encountered') C GSE file is not terminated by string STOP in the first 4 columns, C or NSEIS=-1 has not been checked during previous invocation and C subroutine RGSE2 was called again. 90 CONTINUE NSEIS=-1 RETURN C C----------------------------------------------------------------------- C ENTRY RGSE2C(COMLIN,*) C C....................................................................... C IF(NLINES.LE.0) THEN C No comment line left - return to the label given by argument *: RETURN 1 END IF C COMLIN=LINES(1) NLINES=NLINES-1 DO 99 I=1,NLINES LINES(I)=LINES(I+1) 99 CONTINUE RETURN END C C======================================================================= Chsv.dat 0100666 0000765 0000765 00000000647 06666673544 011760 0 ustar bulant bulant 7 2 2 / 0.000000 0.166667 0.333333 0.500000 0.666667 0.833333 1.000000 / 0.000000 1.000000 / 0.000000 1.000000 / 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 0 0 1 0 0 1 1 0 0 1 1 0 1 1 0 0 / 999 999 0.666667 0 / 0 0 1.000000 1 / 0 0 1.000000 1 / iniwrl.for 0100666 0000765 0000765 00000061055 07226001610 012446 0 ustar bulant bulant C
C Program INIWRL to initialize a virtual reality description file C C Version: 5.50 C Date: 2001, January 7 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 References: C C VRML (Virtual Reality Modeling Language) version 1.0C C C VRML97 (Virtual Reality Modeling Language ISO/IEC 14772) C C GOCAD C C Persistence of Vision scene description language, version 3.1 C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C WRLINI='string'... Name of the file to be copied to the beginning C of the output file. If the filename is blank (default), C the output file is initialized from its beginning. C File WRLINI may contain the user-coded description in the C corresponding VRML language. The default value is mostly C appropriate. C Default: WRLINI=' ' C CAMERA='string'... Name of the file with cameras (viewpoints). C May or may not be specified. The default initial view C of a VRML viewer is in the direction of the -X3 half-axis. C Description of file CAMERA C Not used if VRML='GOCAD'. C Default: CAMERA=' ' C DLIGHT='string'... Name of the file with directional lights. C Description of file DLIGHT C If not specified, the viewer will use its default C illumination. C Not used if VRML='GOCAD'. C Default: DLIGHT=' ' C PLIGHT='string'... Name of the file with point lights. C Description of file PLIGHT C Often need not be specified. C Not used if VRML='GOCAD'. C Default: PLIGHT=' ' C Data specifying the output file: C WRL='string'... Name of the output file. It is recommended to C specify it rather than to use the default name. C Default: WRL='out.wrl' C Data specifying the form of the output file: C VRML='string'... Virtual reality scene description language. C The case of the characters does not matter. C VRML='VRML1': VRML (Virtual Reality Modeling Language) C version 1.0. C VRML='VRML2': VRML97 according to ISO/IEC 14772 standard. C VRML='GOCAD': GOCAD description of points (VSet), curves C (PLine) and surfaces (TSurf). C VRML='POV': POV (Persistence Of Vision) scene C description language, version 3.1. C Default: VRML='VRML2' (recommended) C Data specifying the illumination and background (not used if C VRML='GOCAD'): C UP1=real, UP2=real, UP3=real... Components of a vector pointing C upwards. It is used to properly rotate the camera. C Note that VRML uses right-handed Cartesian coordinates. C If the model coordinates are left-handed, all objects C will be seen mirrored. C Defaults: UP1=0, UP2=0, UP3=1 (X3 axis pointing up) C AMBIENT=real... Float number between 0 and 1 specifying the C intensity of the ambient light. The colour of the ambient C light is assumed white. C If VRML='vrml1', the implicit ambient light has intensity C 1.00 and parameter AMBIENT is applied directly to the C material of the surface objects by subsequent programs. C If VRML='vrml2', the ambient light is the first light, C followed by directional lights and point lights. C Default: AMBIENT=0.20 (default for VRML materials) C R=real, G=real, B=real... Float numbers between 0 and 1 specifying C the colour of the background. C Not applied if VRML='vrml1' or VRML='gocad' . C Defaults: R=0, G=0, B=0 (black background) C C C Input file CAMERA with the cameras (viewpoints): C (1) None to several strings terminated by / (a slash) C (2) For each camera data (2.1): C (2.1) 'NAME',X1,X2,X3,T1,T2,T3,WIDTH,HEIGHT,/ C 'NAME'... Name of the viewpoint. Will be used by VRML viewers to C refer the viewpoint. C X1,X2,X3... Coordinates of the viewpoint (camera). C T1,T2,T3... Coordinates of the target point. C Defaults: T1=0, T2=0, T3=0 C WIDTH,HEIGHT... Width and height of the rectangle around the C target point to fit in the display window. C If specified, the width and height should be positive. C Otherwise, the results may be browser-dependent. C For VRML='vrml1': HEIGHT fits into the vertical window C dimension. The aspect ratio is proportional. C For VRML='vrml2': Square of side max(HEIGHT,WIDTH*3/4) C is maximized in the display window. The aspect ratio is C proportional. C Note that VRML uses right-handed Cartesian coordinates. C If the model coordinates are left-handed, all objects C will be seen mirrored. C For VRML='pov': Rectangle of sides HEIGHT and WIDTH fills C the display window. The aspect ratio depends on the C dimensions of the display window. C Defaults if one of the values is given: WIDTH=HEIGHT*4/3, C HEIGHT=WIDTH*3/4. C Defaults if none of them is given: HEIGHT=distance between C the camera and the target point, WIDTH=HEIGHT*4/3 C (3) / or end of file. C C C Input file DLIGHT with the directional lights: C (1) None to several strings terminated by / (a slash) C (2) For each light data (2.1): C (2.1) 'NAME',X1,X2,X3,VALUE,/ C 'NAME'... Name of the light. Not considered. May be blank. C X1,X2,X3... Directional vector towards the light. C VALUE...Intensity of the light source, possibly supplemented by C the minus sign if the light should be initially switched C off. The colour of the light is assumed white. C Default: VALUE=0.80 (default for VRML materials) C (3) / or end of file. C C C Input file PLIGHT with the point lights: C (1) None to several strings terminated by / (a slash) C (2) For each light data (2.1): C (2.1) 'NAME',X1,X2,X3,VALUE,/ C 'NAME'... Name of the light. Not considered. May be blank. C X1,X2,X3... Coordinates of the light. C VALUE...Intensity of the light source, possibly supplemented by C the minus sign if the light should be initially switched C off. The colour of the light is assumed white. C Default: VALUE=0.80 (default for VRML materials) C (3) / or end of file. C C======================================================================= C C External functions and subroutines: EXTERNAL LENGTH,ERROR,RSEP1,RSEP3T,RSEP3R INTEGER LENGTH C C Filenames and parameters: CHARACTER*80 FILE1,FILE2 INTEGER LU1,LU2 REAL UNDEF PARAMETER (LU1=1,LU2=2,UNDEF=-999999.) C C Other variables: CHARACTER*5 VRML CHARACTER*255 TEXT INTEGER I,J REAL UP1,UP2,UP3,RED,GREEN,BLUE REAL X1,X2,X3,T1,T2,T3,R1,R2,R3,R4,W,H,C,S,DIST,AUX REAL R11,R21,R31,R12,R22,R32,R13,R23,R33 REAL S11,S21,S31,S12,S22,S32,S13,S23,S33 C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+INIWRL: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 IF(FILE1.EQ.' ') THEN C INIWRL-01 CALL ERROR('INIWRL-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF CALL RSEP1(LU1,FILE1) WRITE(*,'(A)') '+INIWRL: Working... ' C C Reading the form of the output file: CALL RSEP3T('VRML',VRML ,'vrml2' ) CALL LOWER(VRML) IF(VRML.NE.'vrml1'.AND. * VRML.NE.'vrml2'.AND. * VRML.NE.'pov' .AND. * VRML.NE.'gocad') THEN C INIWRL-02 CALL ERROR('INIWRL-02: No valid string in VRML') C Valid string specifying the form of the output file is: C VRML='VRML1' or 'VRML2' or 'POV' or 'GOCAD'. C Default and recommended value is 'VRML2'. END IF C C Opening the output file and writing its beginning: CALL RSEP3T('WRLINI',FILE1,' ') CALL RSEP3T('WRL' ,FILE2,'out.wrl') CALL WRL1(LU1,LU2,FILE1,FILE2,VRML,0) C C....................................................................... C C Cameras (viewpoints): C CALL RSEP3T('CAMERA',FILE1,' ') CALL RSEP3R('UP1',UP1,0.) CALL RSEP3R('UP2',UP2,0.) CALL RSEP3R('UP3',UP3,1.) IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) (TEXT,I=1,20) C C Loop over viewpoints 20 CONTINUE TEXT='$' X1=0. X2=0. X3=0. T1=0. T2=0. T3=0. W=UNDEF H=UNDEF READ(LU1,*,END=29) TEXT,X1,X2,X3,T1,T2,T3,W,H IF(TEXT.EQ.'$') THEN GO TO 29 END IF C C Camera back unit vector R13=X1-T1 R23=X2-T2 R33=X3-T3 DIST=SQRT(R13*R13+R23*R23+R33*R33) IF(DIST.EQ.0.) THEN C INIWRL-03 CALL ERROR('INIWRL-03: Zero distance from camera to model') END IF R13=R13/DIST R23=R23/DIST R33=R33/DIST C C Viewing frame IF(W.EQ.UNDEF.AND.H.EQ.UNDEF) THEN H=DIST*2.*(SQRT(2.)-1.) W=H*4./3. ELSE IF(W.EQ.UNDEF) THEN W=H*4./3. ELSE IF(H.EQ.UNDEF) THEN H=W*3./4. END IF C IF(VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN C Camera top unit vector AUX=UP1*R13+UP2*R23+UP3*R33 R12=UP1-R13*AUX R22=UP2-R23*AUX R32=UP3-R33*AUX AUX=SQRT(R12*R12+R22*R22+R32*R32) IF(AUX.GE.0.00025) THEN R12=R12/AUX R22=R22/AUX R32=R32/AUX ELSE IF(ABS(R13).LE.ABS(R23).AND.ABS(R13).LE.ABS(R33)) THEN AUX=SQRT(R23*R23+R33*R33) R12=0. R22= R33/AUX R32=-R23/AUX ELSE IF(ABS(R23).LE.ABS(R33)) THEN AUX=SQRT(R13*R13+R33*R33) R12= R33/AUX R22=0. R32=-R13/AUX ELSE AUX=SQRT(R13*R13+R23*R23) R12= R23/AUX R22=-R13/AUX R32=0. END IF C C Camera right unit vector R11=R22*R33-R32*R23 R21=R32*R13-R12*R33 R31=R12*R23-R22*R13 C C Rotation axis vector C=R11+R22+R33-1. R11=R11-1. R22=R22-1. R33=R33-1. S11=R22*R33-R32*R23 S21=R32*R13-R12*R33 S31=R12*R23-R22*R13 S12=R23*R31-R33*R21 S22=R33*R11-R13*R31 S32=R13*R21-R23*R11 S13=R21*R32-R31*R22 S23=R31*R12-R11*R32 S33=R11*R22-R21*R12 IF(S11.LE.0..AND.S22.LE.0..AND.S33.LE.0.) THEN R1=0. R2=0. R3=1. R4=0. ELSE IF(S33.GE.S22.AND.S33.GE.S11) THEN R1=S13+S31 R2=S23+S32 R3=S33+S33 ELSE IF(S22.GE.S11) THEN R1=S12+S21 R2=S22+S22 R3=S32+S23 ELSE R1=S11+S11 R2=S21+S12 R3=S31+S13 END IF AUX=SQRT(R1*R1+R2*R2+R3*R3) R1=R1/AUX R2=R2/AUX R3=R3/AUX S=R1*(R32-R23)+R2*(R13-R31)+R3*(R21-R12) R4=ATAN2(S,C) C IF(VRML.EQ.'vrml1') THEN AUX=2.*ATAN(H/DIST/2.) WRITE(LU2,'(A)') * 'PerspectiveCamera {' WRITE(LU2,'(A,F8.6)') * ' heightAngle ',AUX WRITE(LU2,'(A,G15.6)') * ' focalDistance ',DIST ELSE AUX=2.*ATAN(AMAX1(W*3./4.,H)/DIST/2.) WRITE(LU2,'(A)') * 'Viewpoint {' WRITE(LU2,'(3A)') * ' description "',TEXT(1:LENGTH(TEXT)),'"' WRITE(LU2,'(A,F8.6)') * ' fieldOfView ',AUX END IF WRITE(LU2,'(3(A,G15.6))') * ' position ',X1,' ',X2,' ',X3 WRITE(LU2,'(4(A,F9.6))') * ' orientation ',R1,' ',R2,' ',R3,' ',R4 WRITE(LU2,'(A)') * '}' C ELSE IF(VRML.EQ.'pov') THEN WRITE(LU2,'(A)') * 'camera {' * ,' perspective' WRITE(LU2,'(A,3(G15.6,A))') * ' right <',-W ,',', 0.,',', 0. ,'>' * ,' up <', 0.,',', H ,',', 0. ,'>' * ,' direction <', 0.,',', 0.,',',DIST,'>' * ,' sky <',UP1,',',UP2,',',UP3 ,'>' * ,' location <', X1,',', X2,',', X3 ,'>' * ,' look_at <', T1,',', T2,',', T3 ,'>' WRITE(LU2,'(A)') * '}' C END IF GO TO 20 C End of the loop over viewpoints C 29 CONTINUE CLOSE(LU1) END IF C C....................................................................... C C Ambient light: C CALL RSEP3R('AMBIENT',W,0.20) C VRML 1.0 has an implicit ambient light of intensity 1.00 IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'NavigationInfo {' * ,' headlight FALSE' * ,'}' * ,'DirectionalLight {' * ,' color 1.00 1.00 1.00' * ,' intensity 0.00' WRITE(LU2,'(A,F4.2)') * ' ambientIntensity ',W WRITE(LU2,'(A)') * ' on TRUE' * ,'}' ELSE IF(VRML.EQ.'pov') THEN WRITE(LU2,'(A,3(F4.2,A))') * 'global_settings { ambient_light rgb <',W,',',W,',',W,'> }' END IF C C....................................................................... C C Directional and point lights: C DO 39 J=1,2 IF(J.EQ.1) THEN C Directional lights CALL RSEP3T('DLIGHT',FILE1,' ') ELSE C Point lights CALL RSEP3T('PLIGHT',FILE1,' ') END IF IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) (TEXT,I=1,20) C C Loop over lights 30 CONTINUE TEXT='$' X1=0. X2=0. X3=0. W =0.80 READ(LU1,*,END=38) TEXT,X1,X2,X3,W IF(TEXT.EQ.'$') THEN GO TO 38 END IF C IF(VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN IF(J.EQ.1) THEN WRITE(LU2,'(A)') * 'DirectionalLight {' AUX=SQRT(X1*X1+X2*X2+X3*X3) X1=-X1/AUX X2=-X2/AUX X3=-X3/AUX WRITE(LU2,'(3(A,F9.6))') * ' direction ',X1,' ',X2,' ',X3 ELSE WRITE(LU2,'(A)') * 'PointLight {' WRITE(LU2,'(3(A,G15.6))') * ' location ',X1,' ',X2,' ',X3 WRITE(LU2,'(A)') * ' radius 999999' END IF WRITE(LU2,'(A)') * ' color 1.00 1.00 1.00' WRITE(LU2,'(A,F4.2)') * ' intensity ',ABS(W) IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * ' ambientIntensity 0.00' END IF IF(W.GT.0.) THEN WRITE(LU2,'(A)') * ' on TRUE' ELSE WRITE(LU2,'(A)') * ' on FALSE' END IF WRITE(LU2,'(A)') * '}' ELSE IF(VRML.EQ.'pov') THEN WRITE(LU2,'(A)') * 'light_source {' WRITE(LU2,'(A,3(G15.6,A))') * ' <',X1,',',X2,',',X3,'>' WRITE(LU2,'(A,3(F4.2,A))') * ' rgb <',W,',',W,',',W,'>' WRITE(LU2,'(A)') * '}' END IF GO TO 30 C End of the loop over directional lights C 38 CONTINUE CLOSE(LU1) END IF 39 CONTINUE C C....................................................................... C C Background colour: C CALL RSEP3R('R',RED ,0.) CALL RSEP3R('G',GREEN,0.) CALL RSEP3R('B',BLUE ,0.) C VRML 1.0 has no background node IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A,3(F4.2,A))') * 'Background { skyColor ',RED,' ',GREEN,' ',BLUE,' }' ELSE IF(VRML.EQ.'pov') THEN WRITE(LU2,'(A,3(F4.2,A))') * 'background { color rgb <',RED,',',GREEN,',',BLUE,'> }' END IF C C....................................................................... C C Separating the header by a blank line IF (VRML.NE.'gocad') THEN WRITE(LU2,'(A)') END IF C C....................................................................... C C Subroutine for surfaces: C IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'PROTO Surface [' * ,' exposedField SFNode appearance NULL' * ,' field MFVec3f point []' * ,' exposedField SFNode normalPos NULL' * ,' exposedField SFNode normalNeg NULL' * ,' exposedField SFNode colorPos NULL' * ,' exposedField SFNode colorNeg NULL' * ,' field MFInt32 coordIndex []' * ,']{' * ,' Transform {' * ,' children [' * ,' Shape {' * ,' appearance IS appearance' * ,' geometry IndexedFaceSet {' * ,' ccw TRUE # positive surface side' * ,' coord DEF SurfaceCoord Coordinate {' * ,' point IS point' * ,' }' * ,' normal IS normalPos' * ,' color IS colorPos' * ,' coordIndex IS coordIndex' * ,' }' * ,' }' * ,' Shape {' * ,' appearance IS appearance' * ,' geometry IndexedFaceSet {' * ,' ccw FALSE # negative surface side' * ,' coord USE SurfaceCoord' * ,' normal IS normalNeg' * ,' color IS colorNeg' * ,' coordIndex IS coordIndex' * ,' }' * ,' }' * ,' ]' * ,' }' * ,'}' END IF C C....................................................................... C C Subroutine for lines: C IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'PROTO Line [' * ,' exposedField SFNode appearance NULL' * ,' field MFVec3f point []' * ,' exposedField SFNode color NULL' * ,' field MFInt32 coordIndex []' * ,']{' * ,' Transform {' * ,' children [' * ,' Shape {' * ,' appearance IS appearance' * ,' geometry IndexedLineSet {' * ,' coord Coordinate {' * ,' point IS point' * ,' }' * ,' color IS color' * ,' coordIndex IS coordIndex' * ,' }' * ,' }' * ,' ]' * ,' }' * ,'}' ELSE IF (VRML.EQ.'pov') THEN WRITE(LU2,'(A)') * '#declare LINERADIUS = 0.1;' * ,' ' * ,'#macro LINE(X1,X2,X3,X4,Y1,Y2,Y3,Y4)' * ,' #local X=inv.cal 0100666 0000765 0000765 00000000010 06767357672 011726 0 ustar bulant bulant $2=1/$1 invsub.cal 0100666 0000765 0000765 00000000031 06770352142 012420 0 ustar bulant bulant A1=1/$1 A2=1/$2 $3=A1-A2 length.for 0100666 0000765 0000765 00000005021 06477703620 012433 0 ustar bulant bulant C;' * ,' #local Y= ;' * ,' #local VD=X4-Y4;' * ,' #local VY= Y4;' * ,' #if (VD=0)' * ,' #local VD=VPER/999999;' * ,' #end' * ,' #local G0=(X-Y)*VPER/VD;' * ,' cylinder {' * ,' X Y LINERADIUS' * ,' texture {' * ,' pigment {' * ,' gradient x' * ,' translate ((VREF-V3)/VPER-CREF-100)*x' * ,' matrix ' * ,' translate Y' * ,' }' * ,' }' * ,' }' * ,'#end' * ,' ' END IF C C....................................................................... C C Subroutine for points: C IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'PROTO Point [' * ,' exposedField SFNode appearance NULL' * ,' field MFVec3f point []' * ,' exposedField SFNode color NULL' * ,']{' * ,' Transform {' * ,' children [' * ,' Shape {' * ,' appearance IS appearance' * ,' geometry PointSet {' * ,' coord Coordinate {' * ,' point IS point' * ,' }' * ,' color IS color' * ,' }' * ,' }' * ,' ]' * ,' }' * ,'}' END IF C C....................................................................... C C Subroutine for texts: C IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'PROTO text [' * ,' exposedField SFNode appearance NULL' * ,' exposedField SFVec3f point 0 0 0' * ,' exposedField MFString string []' * ,' exposedField SFNode fontStyle NULL' * ,']{' * ,' Transform {' * ,' translation IS point' * ,' children [' * ,' Billboard {' AUX=SQRT(UP1*UP1+UP2*UP2+UP3*UP3) R1=UP1/AUX R2=UP2/AUX R3=UP3/AUX WRITE(LU2,'(3(A,F6.3))') * ' axisOfRotation ',R1,' ',R2,' ',R3 AUX=SQRT(UP2*UP2+UP3*UP3) WRITE(LU2,'(A)') * ' children [' * ,' Transform {' AUX=SQRT(UP1*UP1+UP3*UP3) IF(AUX.NE.0.) THEN R1=UP3/AUX R2=0. R3=-UP1/AUX R4=ATAN2(AUX,UP2) ELSE R1=1. R2=0. R3=0. IF(UP2.GE.0.) THEN R4=0. ELSE R4=3.141593 END IF END IF WRITE(LU2,'(3(A,F6.3),A,F9.6)') * ' rotation ',R1,' ',R2,' ',R3,' ',R4 WRITE(LU2,'(A)') * ' children [' * ,' Shape {' * ,' appearance IS appearance' * ,' geometry Text {' * ,' string IS string' * ,' fontStyle IS fontStyle' * ,' }' * ,' }' * ,' ]' * ,' }' * ,' ]' * ,' }' * ,' ]' * ,' }' * ,'}' END IF C C....................................................................... C CLOSE(LU2) WRITE(*,'(A)') '+INIWRL: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'forms.for' C forms.for INCLUDE 'wrl.for' C wrl.for C C======================================================================= C
C Subroutine file 'length.for' to facilitate string manipulation. C C Version: 5.20 C Date: 1998, March 6 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 LOWER...Subroutine changing a given character string to lowercase. C LOWER C LENGTH..Integer function to determine the length of a string C without trailing blanks. C LENGTH C C======================================================================= C C C SUBROUTINE LOWER(TEXT) CHARACTER*(*) TEXT C C Subroutine changing a given character string to lowercase. C C Input: C TEXT... A given string. C C Output: C TEXT... The given string converted to lowercase. C C----------------------------------------------------------------------- C EXTERNAL LENGTH INTEGER LENGTH C C----------------------------------------------------------------------- C CHARACTER*1 LETTER INTEGER ISHIFT,I C ISHIFT=ICHAR('a')-ICHAR('A') DO 10 I=1,LENGTH(TEXT) LETTER=TEXT(I:I) IF('A'.LE.LETTER.AND.LETTER.LE.'Z') THEN TEXT(I:I)=CHAR(ICHAR(LETTER)+ISHIFT) END IF 10 CONTINUE RETURN END C C======================================================================= C C C INTEGER FUNCTION LENGTH(TEXT) CHARACTER*(*) TEXT C C Subroutine to determine the length of a string without trailing C blanks. C C Input: C TEXT... Character string. C C Output: C LENGTH..Length of the string without trailing blanks. C LENGTH=1 for a blank string. C C No subroutines and external functions required. C C Date: 1995, August 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C INTEGER I C C....................................................................... C DO 1 I=LEN(TEXT),1,-1 IF(TEXT(I:I).NE.' ') THEN GO TO 2 END IF 1 CONTINUE I=1 2 CONTINUE LENGTH=I C RETURN END C C======================================================================= Clinden.for 0100666 0000765 0000765 00000021617 07054147730 012430 0 ustar bulant bulant C
C Program LINDEN to densify lines C C Version: 5.40 C Date: 2000, February 21 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C Program LINDEN reads the line(s) specified in the form C LIN, and divides each part of each C line into NLINDEN subparts (i.e. adds NLINDEN-1 new points in C between each two subsequent points of each line). The subparts of C each part are of the same length (the new points are added C equidistantly). C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of input and output files: C LIN='string'... Name of the input file with the input line(s). C Description of file LIN C Default: LIN='lin.dat' C LINOUT='string'... Name of the output file with the densified C line(s). Description of file LINOUT C Default: LINOUT='lin.out' C Data specifying the form of the output file: C NLINDEN=integer ... Number of subparts, to which each part of the C input line is to be divided. C Default: NLINDEN=1 (No new points added) C C Input file LIN with the lines: C (1) None to several strings terminated by / (a slash) C (2) For each line data (2.1), (2.2) and (2.3): C (2.1) 'NAME',X1,X2,X3,/ C 'NAME'... Name of the line. Not considered. May be blank but C must be different from '$'. C X1,X2,X3... Optional coordinates of the reference point of the C line. Not considered. Need not be defined, but must C must be different from the value of UNDEF C (the deffinition of the parameter UNDEF see below). C /... List of values must be terminated by a slash. C (2.2) For each point of the line data (2.2.1): C (2.2.1) X1,X2,X3,V1,...,VN,/ C X1,X2,X3... Coordinates of the point of the line. C X1 must be different from the value of UNDEF C (the deffinition of the parameter UNDEF see below). C Default for X2 and X3 is 0. C V1,...,VN...Other real values. Not considered. Up to 100 values C is allowed. C /... List of values must be terminated by a slash. C (2.3) / C (3) / or end of file. C C C Output file LINOUT with the densified lines: C (1) Strings as in file LIN terminated by / (a slash). Only the C first 20 strings from file LIN are written to file LINOUT. Each C line contains only one string or the final /. Spaces at the ends C of the strings are not written. C (2) For each line data (2.1), (2.2) and (2.3): C (2.1) 'NAME',X1,X2,X3,/ C Name of the line and the optional coordinates as in the file LIN. C (2.2) For each point of the line data (2.2.1): C (2.2.1) X1,X2,X3,/ C Coordinates of the point of the line. Points from file LIN are C repeated, NLINDEN-1 new points is added equidistantly in between C each pair of subsequent points from file LIN. C (2.3) / (a slash) C (3) / (a slash) at the end of file. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RSEP3I,FORM1,LENGTH INTEGER LENGTH C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3I ... C File sep.for. C FORM1 ... File forms.for. C LENGTH ... File length.for. C C C Filenames and parameters: CHARACTER*80 FSEP,FIN,FOUT INTEGER LU1,LU2,NDEN,NDEN1 REAL UNDEF PARAMETER (LU1=1,LU2=2,UNDEF=-999999.) C C Other variables: CHARACTER*(24) FORMAT INTEGER I1,I2,I REAL R1,R2,R3,X1,X2,X3,Y1,Y2,Y3,Z1,Z2,Z3,DX1,DX2,DX3,DEN,V(100) CHARACTER*255 TEXT(20) DATA TEXT/20*'$'/ C C....................................................................... C C Reading a name of the file with the input data: FSEP=' ' WRITE(*,'(A)') ' LINDEN: Enter input filename: ' READ(*,*) FSEP IF (FSEP.EQ.' ') THEN C LINDEN-01 CALL ERROR('LINDEN-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF WRITE(*,'(A)') '+LINDEN: Working ... ' C C Reading all the data from the SEP file into the memory: CALL RSEP1(LU1,FSEP) C C Reading input and output filenames: CALL RSEP3T('LIN' ,FIN ,'lin.dat') CALL RSEP3T('LINOUT',FOUT,'lin.out') CALL RSEP3I('NLINDEN',NDEN,1) NDEN=IABS(NDEN) DEN=FLOAT(NDEN) NDEN1=0 IF (NDEN.NE.0) NDEN1=NDEN-1 C C Beginning of the output file: OPEN(LU2,FILE=FOUT) C C Reading lines: OPEN(LU1,FILE=FIN,STATUS='OLD') READ(LU1,*) (TEXT(I),I=1,20) I2=0 DO 10, I1=20,1,-1 IF (TEXT(I1).NE.'$') THEN I2=I1 GOTO 11 ENDIF 10 CONTINUE 11 CONTINUE DO 20, I1=1,I2 WRITE(LU2,'(3A)') '''',TEXT(I1)(1:LENGTH(TEXT(I1))),'''' 20 CONTINUE WRITE(LU2,'(A)') '/' C Loop over lines: 60 CONTINUE TEXT(1)='$' R1=UNDEF R2=UNDEF R3=UNDEF READ(LU1,*,END=90) TEXT(1),R1,R2,R3 IF (TEXT(1).EQ.'$') GOTO 90 FORMAT(1:6)='(3A,0(' FORMAT(15:16)='))' IF (R1.EQ.UNDEF) THEN WRITE(LU2,'(3A)') * '''',TEXT(1)(1:LENGTH(TEXT(1))),''' /' ELSEIF (R2.EQ.UNDEF) THEN CALL FORM1(R1,R1,FORMAT(7:14)) FORMAT(5:5)='1' WRITE(LU2,FORMAT) * '''',TEXT(1)(1:LENGTH(TEXT(1))),''' ',R1,' /' ELSEIF (R3.EQ.UNDEF) THEN CALL FORM1(AMIN1(R1,R2),AMAX1(R1,R2),FORMAT(7:14)) FORMAT(5:5)='2' WRITE(LU2,FORMAT) * '''',TEXT(1)(1:LENGTH(TEXT(1))),''' ',R1,' ',R2,' /' ELSE CALL FORM1(AMIN1(R1,R2,R3),AMAX1(R1,R2,R3),FORMAT(7:14)) FORMAT(5:5)='3' WRITE(LU2,FORMAT) * '''',TEXT(1)(1:LENGTH(TEXT(1))),''' ',R1,' ',R2,' ',R3,' /' ENDIF C Reading the line points X1=UNDEF X2=0. X3=0. READ(LU1,*,END=80) X1,X2,X3,(V(I1),I1=1,100) IF (X1.EQ.UNDEF) GOTO 80 FORMAT(1:3)='(3(' FORMAT(12:13)='))' CALL FORM1(AMIN1(X1,X2,X3),AMAX1(X1,X2,X3),FORMAT(4:11)) WRITE(LU2,FORMAT) X1,' ',X2,' ',X3,' /' 70 CONTINUE Y1=UNDEF Y2=0. Y3=0. READ(LU1,*,END=80) Y1,Y2,Y3,(V(I1),I1=1,100) IF (Y1.EQ.UNDEF) GOTO 80 IF (NDEN1.NE.0) THEN DX1=(Y1-X1)/DEN DX2=(Y2-X2)/DEN DX3=(Y3-X3)/DEN DO 75, I1=1,NDEN1 Z1=X1+I1*DX1 Z2=X2+I1*DX2 Z3=X3+I1*DX3 CALL FORM1(AMIN1(Z1,Z2,Z3),AMAX1(Z1,Z2,Z3),FORMAT(4:11)) WRITE(LU2,FORMAT) Z1,' ',Z2,' ',Z3,' /' 75 CONTINUE ENDIF CALL FORM1(AMIN1(Y1,Y2,Y3),AMAX1(Y1,Y2,Y3),FORMAT(4:11)) WRITE(LU2,FORMAT) Y1,' ',Y2,' ',Y3,' /' X1=Y1 X2=Y2 X3=Y3 GOTO 70 80 CONTINUE C End of line. WRITE(LU2,'(A)') ' /' GOTO 60 90 CONTINUE C End of file. WRITE(LU2,'(A)') ' /' CLOSE(LU1) CLOSE(LU2) WRITE(*,'(A)') '+LINDEN: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'forms.for' C forms.for C C======================================================================= Clinwrl.for 0100666 0000765 0000765 00000055242 10052322274 012455 0 ustar bulant bulant C
C Program LINWRL to convert lines into the Virtual Reality Modeling C Language or GOCAD representation C C Version: 5.80 C Date: 2004, May 18 C C Coded by: Ludek Klimes & Vaclav Bucha C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mails: klimes@seis.karlov.mff.cuni.cz C bucha@seis.karlov.mff.cuni.cz C C References: C C VRML (Virtual Reality Modeling Language) version 1.0C C C VRML97 (Virtual Reality Modeling Language ISO/IEC 14772) C C GOCAD C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C LIN='string'... Name of the file with the polylines. C Description of file LIN C Default: LIN='lin.out' C COLORS='string'... Name of the file containing the data describing C the colour map. C Description of file COLORS C Default: COLORS='hsv.dat' C Input/output file: C WRL='string'... Name of the file to be supplemented with lines C or to be copied to the beginning of the output file. C If the filename is blank, output file starts from a C scratch (mostly not reasonable). C The default name of the output file is equal to WRL. C It is recommended to specify WRL rather than to use C the default name. C Default: WRL='out.wrl' C WRLOUT='string'... Name of the output file if different from WRL. C Default: WRLOUT=WRL C Data specifying the form of the output file: C VRML='string'... Virtual reality scene description language. C VRML='VRML1': VRML (Virtual Reality Modeling Language) C version 1.0. C VRML='VRML2': VRML97 according to ISO/IEC 14772 standard. C VRML='GOCAD': GOCAD description of curves (PLine). C Default: VRML='VRML2' (recommended) C NAME='string'... String containing the GOCAD name of the set of C lines. Be sure to select different names for all objects C within the GOCAD file. C The same name is used for the corresponding colour scale, C written if KOLLIN is positive. C Used only if VRML='GOCAD'. Obligatory parameter, must be C specified and cannot be blank if VRML='GOCAD'. C Optional data to shift the lines: C SHIFT1=real, SHIFT2=real, SHIFT3=real... All lines will be shifted C by vector (SHIFT1,SHIFT2,SHIFT3). The shift may be C applied to the lines situated at a surface to make them C visible. C SHIFT1=0., SHIFT2=0., SHIFT3=0. C Data specifying the values to be scaled in colours: C KOLLIN=integer... If zero, all lines will have the same colour C given by parameters R, G, B. If positive, the values in C KOLLIN-th column of input file LIN will be colour-coded C at each point on the lines. C Default: KOLLIN=0 C PROPERTIES='string'... String containing names of properties C corresponding to optional values V1,...,VN (see file C LIN) which may be used to control the C colour of the line. The names are separated by blanks. C If the number of names is smaller than the number of C values, the leftmost values are considered. PROPERTIES C must be specified if VRML='GOCAD' and KOLLIN is positive. C If KOLLIN is 1, 2 or 3, the last name is assumed to denote C the KOLLINth coordinate instead of the quantity in the C corresponding column. C If PROPERTIES=' ', no values are considered and GOCAD atom C VRTX is used for the vertices (otherwise, GOCAD atom PVRTX C is used). C Used only if VRML='GOCAD'. C Default: PROPERTIES=' ' C Data specifying the colour scale: C VADD=real, VMUL=real, VPER=real, VREF=real, CREF=real, CREF1=real, C CREF2=real, CREF3=real, etc... Refer to file C colors.for. C R=real, G=real, B=real... Float numbers between 0 and 1 specifying C the colour of the lines if KOLLIN=0. C Defaults: R=1, G=1, B=1 (white) C C C Input file LIN with the lines: C (1) None to several strings terminated by / (a slash) C (2) For each line data (2.1), (2.2) and (2.3): C (2.1) 'NAME',X1,X2,X3,/ C 'NAME'... Name of the line. Not considered. May be blank but C must be different from '$'. C X1,X2,X3... Optional coordinates of the reference point of the C line. Not considered. C /... List of values must be terminated by a slash. C (2.2) For each point of the line data (2.2.1): C (2.2.1) X1,X2,X3,V1,...,VN,/ C X1,X2,X3... Coordinates of the point of the line. C V1,...,VN...Optional values which may be used to control the C colour of the line. C /... List of values must be terminated by a slash. C (2.3) / C (3) / or end of file. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C C External functions and subroutines: EXTERNAL LENGTH,RSEP1,RSEP3T,RSEP3I,ERROR,FORM2,COLOR1,COLOR2 INTEGER LENGTH C C Filenames and parameters: CHARACTER*80 FSEP,FLIN,FCOLS,FIN,FOUT INTEGER LU1,LU2,LU3,IUNDEF,MQ REAL UNDEF PARAMETER (LU1=1,LU2=2,LU3=3,IUNDEF=-999999,UNDEF=-999999.,MQ=30) C C Other variables: CHARACTER*(8+8*MQ) FORMAT CHARACTER*5 VRML CHARACTER*255 NAME,TEXT INTEGER KOLLIN,KQ,NQ INTEGER MVRTX,NVRTX,IVRTX,I0,I1,I2,I REAL SHIFT1,SHIFT2,SHIFT3,RED,GREEN,BLUE,TRANSP REAL OUTMIN(MQ),OUTMAX(MQ),R,G,B,AUX,AUXA(1) C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+LINWRL: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C LINWRL-01 CALL ERROR('LINWRL-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF CALL RSEP1(LU1,FSEP) WRITE(*,'(A)') '+LINWRL: Working... ' C C Reading input and output filenames: CALL RSEP3T('LIN' ,FLIN ,'lin.out') CALL RSEP3T('COLORS',FCOLS,'hsv.dat') CALL RSEP3T('WRL' ,FIN ,'out.wrl' ) CALL RSEP3T('WRLOUT',FOUT ,FIN ) CALL RSEP3T('VRML' ,VRML ,'VRML2' ) CALL LOWER(VRML) C C Optional shift: CALL RSEP3R('SHIFT1',SHIFT1,0.00) CALL RSEP3R('SHIFT2',SHIFT2,0.00) CALL RSEP3R('SHIFT3',SHIFT3,0.00) C C Reading the data for colours: CALL RSEP3I('KOLLIN',KOLLIN,0) CALL RSEP3R('R' ,RED ,1.00) CALL RSEP3R('G' ,GREEN ,1.00) CALL RSEP3R('B' ,BLUE ,1.00) C C Opening the output file and writing its beginning: CALL WRL1(LU1,LU2,FIN,FOUT,VRML,1) C C Writing the prolog for the lines (part 1): IF (VRML.EQ.'vrml1') THEN IF(KOLLIN.LE.0) THEN WRITE(LU2,'(A)') * 'DEF LineMaterial Material {' WRITE(LU2,'(A,3(1X,F4.2))') * ' emissiveColor',RED,GREEN,BLUE WRITE(LU2,'(A)') * '}' * ,' ' END IF ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'Shape {' * ,' appearance DEF LineAppearance Appearance {' * ,' material Material {' IF(KOLLIN.LE.0) THEN WRITE(LU2,'(A,3(1X,F4.2))') * ' emissiveColor',RED,GREEN,BLUE END IF WRITE(LU2,'(A)') * ' }' * ,' }' * ,'}' ELSE IF (VRML.EQ.'gocad') THEN CALL RSEP3T('NAME',NAME,' ') C Subroutine WRL has already checked that NAME is not blank. WRITE(LU2,'(A)') * 'GOCAD PLine 1.0' WRITE(LU2,'(2A)') * 'HDR name:',NAME(1:LENGTH(NAME)) WRITE(LU2,'(A)') * 'HDR *atoms:false' * ,'HDR *visible:true' CALL RSEP3T('PROPERTIES',TEXT,' ') I0=1 KQ=3 DO 11 I=1,LEN(TEXT)-1 IF (TEXT(I:I).EQ.' '.AND.TEXT(I+1:I+1).NE.' ') THEN I0=I+1 END IF IF (TEXT(I:I).NE.' '.AND.TEXT(I+1:I+1).EQ.' ') THEN KQ=KQ+1 IF (KQ.EQ.KOLLIN.OR.(1.LE.KOLLIN.AND.KOLLIN.LE.3)) THEN I1=I0 I2=I END IF END IF 11 CONTINUE IF (KOLLIN.LE.0) THEN WRITE(LU2,'(3(A,F4.2))') * 'HDR *line*color: ',RED,' ',GREEN,' ',BLUE ELSE IF (KQ.LT.KOLLIN.OR.KQ.LT.4) THEN C SRFWRL-02 CALL ERROR('SRFWRL-02: GOCAD property name not specified') C If KOLLIN is not zero, list PROPERTIES of property names C must contain MAX(1,KOLLIN-3) names at the least, see the C description of the input data. END IF WRITE(LU2,'(A)') * 'HDR *painted:true' WRITE(LU2,'(2A)') * 'HDR *painted*variable:',TEXT(I1:I2) END IF IF (KQ.GT.3) THEN WRITE(LU2,'(2A)') * 'PROPERTIES ',TEXT(1:LENGTH(TEXT)) END IF IF (KOLLIN.NE.0) THEN WRITE(LU2,'(2A)') * 'PROPERTY_CLASSES ',TEXT(1:LENGTH(TEXT)) WRITE(LU2,'(3A)') * 'PROPERTY_CLASS_HEADER ',TEXT(I1:I2),' {' C The output file now waits for the colour scale. END IF C KQ is the number of coordinates and properties at each point. C ELSE IF (VRML.EQ.'pov') THEN C *** ELSE C LINWRL-03 CALL ERROR('LINWRL-03: No valid string in VRML') C Valid string specifying the form of the output file is: C VRML='VRML1' or 'VRML2' or 'GOCAD'. Default and recommended C value is 'VRML2'. END IF C C Determining number NQ of values stored at each point: IF(VRML.EQ.'gocad') THEN NQ=KQ ELSE KQ=MAX0(3,KOLLIN) IF(KOLLIN.EQ.0) THEN NQ=3 ELSE NQ=4 END IF C Values to be displayed will be shifted to the 4th column END IF IF(NQ.GT.MQ) THEN C LINWRL-04 CALL ERROR('LINWRL-04: Too small arrays OUTMIN and OUTMAX') END IF C C Determining the minima and maxima of quantities at line points: OPEN(LU1,FILE=FLIN,STATUS='OLD') READ(LU1,*) (TEXT,I=1,20) IVRTX=0 MVRTX=0 19 CONTINUE C Beginning of the line: NVRTX=0 TEXT='$' READ(LU1,*,END=39) TEXT,R,R,R IF(TEXT.EQ.'$') THEN C End of the file GO TO 39 END IF C Loop over the points of the line: 20 CONTINUE RAM(1)=UNDEF DO 21 I=2,KQ RAM(I)=0. 21 CONTINUE READ(LU1,*,END=29) (RAM(I),I=1,KQ) IF(RAM(1).EQ.UNDEF) THEN C End of the line GO TO 29 END IF C Relocating the values to be displayed IF(VRML.EQ.'gocad') THEN IF(1.LE.KOLLIN.AND.KOLLIN.LE.3) THEN RAM(KQ)=RAM(KOLLIN) END IF ELSE IF(KOLLIN.GT.0) THEN RAM(4)=RAM(KOLLIN) END IF END IF C Determining the minimum and maximum values IF(IVRTX.EQ.0) THEN DO 22 I=1,NQ OUTMIN(I)=RAM(I) OUTMAX(I)=RAM(I) 22 CONTINUE ELSE DO 23 I=1,NQ OUTMIN(I)=AMIN1(OUTMIN(I),RAM(I)) OUTMAX(I)=AMAX1(OUTMAX(I),RAM(I)) 23 CONTINUE END IF C Number of storage locations in RAM to be used for the points NVRTX=NVRTX+NQ MVRTX=MAX0(NVRTX+KQ,MVRTX+KQ) IF(MVRTX.GT.MRAM) THEN C LINWRL-05 CALL ERROR('LINWRL-05: Too small array RAM') END IF C Total number of points of all lines IVRTX=IVRTX+1 GO TO 20 29 CONTINUE GO TO 19 39 CONTINUE C C Determining the colour map: IF(KOLLIN.GT.0) THEN IF(VRML.EQ.'gocad') THEN CALL COLOR1(LU3,MRAM-MVRTX,IRAM(MVRTX+1),RAM(MVRTX+1), * 1,OUTMIN(KOLLIN),OUTMAX(KOLLIN)) WRITE(LU2,'(2A)') * ' *colormap:',NAME(1:LENGTH(NAME)) FORMAT='(A,' CALL FORM2(1,OUTMIN(KOLLIN),OUTMAX(KOLLIN),FORMAT(4:11)) FORMAT(9:11)=') ' IF(OUTMAX(KOLLIN).GT.OUTMIN(KOLLIN)) THEN WRITE(LU2,FORMAT) * ' *low_clip: ',OUTMIN(KOLLIN) * ,' *high_clip:',OUTMAX(KOLLIN) ELSE WRITE(LU2,FORMAT) * ' *low_clip: ',OUTMIN(KOLLIN) * ,' *high_clip:',OUTMIN(KOLLIN)+1. END IF WRITE(LU2,'(4A)') * ' *colormap*',NAME(1:LENGTH(NAME)),'*colors: ',CHAR(92) AUX=(OUTMAX(KOLLIN)-OUTMIN(KOLLIN))/255. DO 31 I=0,255 AUXA(1)=OUTMIN(KOLLIN)+FLOAT(I)*AUX CALL COLOR2(MRAM-MVRTX,IRAM(MVRTX+1),RAM(MVRTX+1), * 1,AUXA,R,G,B) IF (I.LT.255) THEN WRITE(LU2,'(I5,3(1X,F4.2),2A)') * I,R,G,B,' ',CHAR(92) ELSE WRITE(LU2,'(I5,3(1X,F4.2),2A)') * I,R,G,B END IF 31 CONTINUE WRITE(LU2,'(A)') * '}' ELSE IF (VRML.EQ.'pov') THEN CALL RSEP3R('TRANSP',TRANSP,0.) C WRITE(LU2,'(A)') C * '#default {' C * ,' pigment {' C * ,' color_map {' C CALL COLOR3(MRAM-MVRTX,IRAM(MVRTX+1),RAM(MVRTX+1),1,IREF,IRGB) C I=MVRTX+1+IRAM(MVRTX+1) C IREF=MVRTX+IREF C IRGB=MVRTX+IRGB C DO 57 I2=1,IRAM(MVRTX+2)-IRAM(MVRTX+1) C WRITE(LU2,'(A,F8.6,A,4(F4.2,A))') C * ' [',RAM(I+I2),' rgbt <', C * (RAM(IRGB+I1),',',I1=3*I2-2,3*I2),TRANSP,'>]' C 57 CONTINUE C WRITE(LU2,'(A)') C * ' }' C * ,' }' C * ,'}' C WRITE(LU2,'(A,G13.6,A)') C * '#declare CREF = ',RAM(IREF+1),';' C * ,'#declare VREF = ',RAM(IREF+2),';' C * ,'#declare VPER = ',RAM(IREF+3),';' ELSE CALL COLOR1(LU3,MRAM-MVRTX,IRAM(MVRTX+1),RAM(MVRTX+1), * 1,OUTMIN(4),OUTMAX(4)) END IF END IF C C Writing the prolog for the lines (part 2): IF (VRML.EQ.'vrml1') THEN CONTINUE ELSE IF (VRML.EQ.'vrml2') THEN CONTINUE END IF C C Loop over lines: REWIND(LU1) READ(LU1,*) (TEXT,I=1,20) IVRTX=0 60 CONTINUE C Beginning of the line: NVRTX=0 TEXT='$' READ(LU1,*,END=90) TEXT,R,R,R IF(TEXT.EQ.'$') THEN C End of the file GO TO 90 END IF C C Reading the line points: 70 CONTINUE IF(NVRTX+KQ.GT.MVRTX) THEN C LINWRL-06 CALL ERROR('LINWRL-06: Strange error') C This error should not appear. Contact the author. END IF RAM(NVRTX+1)=UNDEF DO 71 I=NVRTX+2,NVRTX+KQ RAM(I)=0. 71 CONTINUE READ(LU1,*,END=79) (RAM(I),I=NVRTX+1,NVRTX+KQ) IF(RAM(NVRTX+1).EQ.UNDEF) THEN C End of the line GO TO 79 END IF C Relocating the values to be displayed IF(VRML.EQ.'gocad') THEN IF(1.LE.KOLLIN.AND.KOLLIN.LE.3) THEN RAM(NVRTX+KQ)=RAM(NVRTX+KOLLIN) END IF ELSE IF(KOLLIN.GT.0) THEN RAM(NVRTX+4)=RAM(NVRTX+KOLLIN) END IF END IF C Shifting the point RAM(NVRTX+1)=RAM(NVRTX+1)+SHIFT1 RAM(NVRTX+2)=RAM(NVRTX+2)+SHIFT2 RAM(NVRTX+3)=RAM(NVRTX+3)+SHIFT3 C Determining the minimum and maximum values within the line IF(NVRTX.EQ.0) THEN DO 72 I=1,NQ OUTMIN(I)=RAM(NVRTX+I) OUTMAX(I)=RAM(NVRTX+I) 72 CONTINUE ELSE DO 73 I=1,NQ OUTMIN(I)=AMIN1(OUTMIN(I),RAM(NVRTX+I)) OUTMAX(I)=AMAX1(OUTMAX(I),RAM(NVRTX+I)) 73 CONTINUE END IF C Number of storage locations in RAM used for the points NVRTX=NVRTX+NQ C Total number of points of all lines IVRTX=IVRTX+1 GO TO 70 79 CONTINUE IF(NVRTX/NQ.LT.2) THEN GO TO 60 END IF C C Writing the prolog for the line: IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') * 'Separator {' IF(KOLLIN.GT.0) THEN WRITE(LU2,'(A)') * 'MaterialBinding { value PER_VERTEX }' ELSE WRITE(LU2,'(A)') * 'MaterialBinding { value OVERALL }' * ,'USE LineMaterial' END IF WRITE(LU2,'(A)') * 'Coordinate3 { point [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'Line {' * ,'appearance USE LineAppearance' * ,'point [' ELSE IF (VRML.EQ.'gocad') THEN WRITE(LU2,'(A)') * 'ILINE' C ELSE IF (VRML.EQ.'pov') THEN C *** END IF C C Writing the vertices: IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN FORMAT='(' CALL FORM2(3,OUTMIN(1),OUTMAX(1),FORMAT(2:25)) DO 81 I=1,NVRTX,NQ WRITE(LU2,FORMAT) RAM(I),' ',RAM(I+1),' ',RAM(I+2),',' 81 CONTINUE ELSE IF (VRML.EQ.'gocad') THEN FORMAT='(A,I0,A,' FORMAT(5:5)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(IVRTX)+0.5))) CALL FORM2(NQ,OUTMIN(1),OUTMAX(1),FORMAT(9:8+8*NQ)) IF (KOLLIN.EQ.0) THEN DO 82 I0=1,NVRTX,NQ WRITE(LU2,FORMAT) 'VRTX ',IVRTX-(NVRTX-I0)/NQ, * (' ',RAM(I),I=I0,I0+NQ-1) 82 CONTINUE ELSE DO 83 I0=1,NVRTX,NQ WRITE(LU2,FORMAT) 'PVRTX ',IVRTX-(NVRTX-I0)/NQ, * (' ',RAM(I),I=I0,I0+NQ-1) 83 CONTINUE END IF ELSE IF (VRML.EQ.'pov') THEN C Writing the vertices with values: FORMAT='(A,' CALL FORM2(NQ,OUTMIN,OUTMAX,FORMAT(4:27)) FORMAT(27:38)=',3(F5.3,A),' CALL FORM2(1,OUTMIN(7),OUTMAX(7),FORMAT(39:46)) DO 84 I=1,NVRTX-NQ,NQ WRITE(LU2,FORMAT) * 'VRTX(',(RAM(I1),',',I1=I,I+NQ-2),RAM(I+NQ-1),')' 84 CONTINUE END IF IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') ']' END IF C C Writing the colours of the points: IF(KOLLIN.GT.0) THEN IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'Material { emissiveColor [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'color Color { color [' END IF IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN DO 85 I=NQ,NVRTX,NQ CALL COLOR2(MRAM-MVRTX,IRAM(MVRTX+1),RAM(MVRTX+1), * 1,RAM(I),R,G,B) WRITE(LU2,'(3(F4.2,A))') R,' ',G,' ',B,',' 85 CONTINUE END IF IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '] }' END IF END IF C C Writing the indices of the points: IF(VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'IndexedLineSet { coordIndex [' ELSE IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'coordIndex [' END IF IF(VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN FORMAT='(10(I0,A))' I=INT(ALOG10(FLOAT(NVRTX/NQ)-0.5))+1 FORMAT(6:6)=CHAR(ICHAR('0')+I) WRITE(LU2,FORMAT) (I1,', ',I1=0,NVRTX/NQ-2),NVRTX/NQ-1 ELSE IF (VRML.EQ.'gocad') THEN FORMAT='(2(A,I0))' I=INT(ALOG10(FLOAT(IVRTX)+0.5))+1 FORMAT(7:7)=CHAR(ICHAR('0')+I) WRITE(LU2,FORMAT) * ('SEG ',I1,' ',I1+1,I1=IVRTX-NVRTX/NQ+1,IVRTX-1) END IF IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') ']' END IF C C Writing the trailor for the line: IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '}' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '}' END IF GO TO 60 C 90 CONTINUE C C Writing the trailor for the set of lines: IF (VRML.EQ.'gocad') THEN WRITE(LU2,'(A)') 'END' END IF CLOSE(LU1) CLOSE(LU2) WRITE(*,'(A)') '+LINWRL: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'forms.for' C forms.for INCLUDE 'colors.for' C colors.for INCLUDE 'wrl.for' C wrl.for C C======================================================================= Cloc0.cal 0100666 0000765 0000765 00000000374 07107706752 011766 0 ustar bulant bulant Initializing the location of hypocentre: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ No input. Output: $2,$3,$4... Temporary files to accumulate intermediate results. For example refer to wb2-loc.h. $2=0. $3=0. $4=0. loc1.cal 0100666 0000765 0000765 00000002117 07107706700 011755 0 ustar bulant bulant Including a new arrival time into the location of hypocentre: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Input: POWERN... Exponent describing the self-affine random medium. TTERR1... Travel-time error at travel time equal to 1 unit. T... Arrival time at the receiver. TERR... Standard deviation of the arrival time. TREF... Optional reference arrival time. Need not be specified. $1... Gridded travel time from the receiver. $2,$3,$4... Temporary files to accumulate intermediate results. Output: $2,$3,$4... Updated temporary files. Travel-time variances are calculated from POWERN and TTERR1. Travel-time covariances are not calculated and are deemed zero, which may result in underestimation of variances of hypocentral coordinates. For example refer to wb2-loc.h. TDIF=T-TREF TDIF=TDIF-$1 TTERR=$1**POWERN TTERR=$1*TTERR TTERR=TTERR1*TTERR A=TTERR*TTERR AA=TERR*TERR A=A+AA A=1./A B=A*TDIF C=$2*TDIF C=C-$3 CC=C*C C=0.000001*A C=MAX(C,$2) C=CC/C $2=$2+A $3=$3+B C=C/$2 C=A*C CC=$4*$4 C=C+CC $4=SQRT(C) loc2.cal 0100666 0000765 0000765 00000001070 07107706746 011765 0 ustar bulant bulant Finishing the location of hypocentre: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Input: TREF... Optional reference arrival time. Need not be specified. $2,$3,$4... Temporary files to accumulate intermediate results. Output: $5... Grid values of the relative probability. $6... Grid values of the mean hypocentral time. $7... Grid values of the standard deviation of hypocentral time. For example refer to wb2-loc.h. A=1./$2 THYPO=$3/$2 SIGMA=$4*$4 SIGMA=-0.5*SIGMA $5=EXP(SIGMA) $6=THYPO+TREF $7=SQRT(A) mfsd.for 0100666 0000765 0000765 00000007211 07040004124 012062 0 ustar bulant bulant C SUBROUTINE 'MFSD' OF THE IBM SCIENTIFIC SUBROUTINE PACKAGE. C C NOTE: TO CONFORM WITH THE FORTRAN77 STANDARD, DUMMY ARRAY DIMENSIONS C (1) HAVE BEEN CHANGED TO (*). C C .................................................................. C C SUBROUTINE MFSD C C PURPOSE C FACTOR A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX C C USAGE C CALL MFSD(A,N,EPS,IER) C C DESCRIPTION OF PARAMETERS C A - UPPER TRIANGULAR PART OF THE GIVEN SYMMETRIC C POSITIVE DEFINITE N BY N COEFFICIENT MATRIX. C ON RETURN A CONTAINS THE RESULTANT UPPER C TRIANGULAR MATRIX. C N - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX. C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME- C TER N OR BECAUSE SOME RADICAND IS NON- C POSITIVE (MATRIX A IS NOT POSITIVE C DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI- C FICANCE) C IER=K - WARNING WHICH INDICATES LOSS OF SIGNIFI- C CANCE. THE RADICAND FORMED AT FACTORIZA- C TION STEP K+1 WAS STILL POSITIVE BUT NO C LONGER GREATER THAN ABS(EPS*A(K+1,K+1)). C C REMARKS C THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE C STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS. C IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU- C LAR MATRIX IS STORED COLUMNWISE TOO. C THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL C CALCULATED RADICANDS ARE POSITIVE. C THE PRODUCT OF RETURNED DIAGONAL TERMS IS EQUAL TO THE C SQUARE-ROOT OF THE DETERMINANT OF THE GIVEN MATRIX. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE USING THE SQUARE-ROOT METHOD OF CHOLESKY. C THE GIVEN MATRIX IS REPRESENTED AS PRODUCT OF TWO TRIANGULAR C MATRICES, WHERE THE LEFT HAND FACTOR IS THE TRANSPOSE OF C THE RETURNED RIGHT HAND FACTOR. C C .................................................................. C SUBROUTINE MFSD(A,N,EPS,IER) C C DIMENSION A(*) DOUBLE PRECISION DPIV,DSUM C C TEST ON WRONG INPUT PARAMETER N IF(N-1) 12,1,1 1 IER=0 C C INITIALIZE DIAGONAL-LOOP KPIV=0 DO 11 K=1,N KPIV=KPIV+K IND=KPIV LEND=K-1 C C CALCULATE TOLERANCE TOL=ABS(EPS*A(KPIV)) C C START FACTORIZATION-LOOP OVER K-TH ROW DO 11 I=K,N DSUM=0.D0 IF(LEND) 2,4,2 C C START INNER LOOP 2 DO 3 L=1,LEND LANF=KPIV-L LIND=IND-L 3 DSUM=DSUM+DBLE(A(LANF)*A(LIND)) C END OF INNER LOOP C C TRANSFORM ELEMENT A(IND) 4 DSUM=DBLE(A(IND))-DSUM IF(I-K) 10,5,10 C C TEST FOR NEGATIVE PIVOT ELEMENT AND FOR LOSS OF SIGNIFICANCE 5 IF(SNGL(DSUM)-TOL) 6,6,9 6 IF(DSUM) 12,12,7 7 IF(IER) 8,8,9 8 IER=K-1 C C COMPUTE PIVOT ELEMENT 9 DPIV=DSQRT(DSUM) A(KPIV)=DPIV DPIV=1.D0/DPIV GO TO 11 C C CALCULATE TERMS IN ROW 10 A(IND)=DSUM*DPIV 11 IND=IND+I C C END OF DIAGONAL-LOOP RETURN 12 IER=-1 RETURN END C C======================================================================= C mgrd.for 0100666 0000765 0000765 00000021243 10062244274 012075 0 ustar bulant bulant C
C Program MGRD (Multivalued GRiD) to convert multivalued grid into C several singlevalued grids. C C Version: 5.80 C Date: 2004, June 11 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input/output data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data describing the grid: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C Names of input and output files: C NUM='string'...Name of the input ASCII file containing, for each C gridpoint, the integer number of given values in the C gridpoint. C For general description of files with gridded data refer C to file forms.htm. C Default: NUM='num.out' C MGRD='string'...Name of the input file containing, for each C gridpoint, all given values. C For general description of the files with multivalued C gridded data refer to file C forms.htm. C Default: MGRD='mgrd.out' C GRD='string'...String in apostrophes controling the name(s) of the C output ASCII files with data cubes: C For IMGRD=0: C The name of the output file with the generated C single-valued grids stored as several "snapshots". C The number of "snapshots" equals the maximum number of C values given at a point. C Otherwise: C The template name of the output files with the generated C single-valued grids. The number of output files equals C the maximum number of values given at a point. C Generation of names of output files: C All digits contained within the filename are assumed C to form an integer number. This number is increased C by 0 for the first output file, by 1 for the second C one, etc. The other characters of the filename remain C unchanged. C For general description of files with gridded data refer C to file forms.htm. C Default: GRD='grd00.out' C IMGRD=integer: C IMGRD=0: Output single-valued grids are stored as several C "snapshots" in a single output file. The number of C "snapshots" is appended to the end of the input SEP C file in the form of: N4=integer C Otherwise: Output single-valued grids are stored in C separate output files. C Default: IMGRD=0 C Output data appended at the end of SEP file (written just if IMGRD=0): C N4=positive integer... Number of single-valued grids ("snapshots") C in the output file GRD. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C CHARACTER*80 FGRD,FMUL,FVAL,FOUT CHARACTER*10 TEXT INTEGER LU1,LU2,MGRD,I,I4,N,N1,N2,N3,N4,N1N2N3 REAL UNDEF PARAMETER (LU1=1,LU2=2,UNDEF=-999999.) C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+MGRD: Enter input filename: ' FGRD=' ' READ(*,*) FGRD WRITE(*,'(A)') '+MGRD: Working ... ' C C Reading all data from the SEP file into the memory: IF (FGRD.NE.' ') THEN CALL WSEP1(LU1,FGRD) C File remains open for writing. ELSE C MGRD-04 CALL ERROR('MGRD-04: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('NUM',FMUL,'num.out') CALL RSEP3T('MGRD',FVAL,'mgrd.out') CALL RSEP3T('GRD',FOUT,'grd00.out') C C Recalling the data specifying grid dimensions C (arguments: Name of value in input data, Variable, Default): CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) N1N2N3=N1*N2*N3 CALL RSEP3I('IMGRD',MGRD,0) C IF(N1N2N3.GT.MRAM) THEN C MGRD-01 CALL ERROR('MGRD-01: Too small array RAM') C Dimension MRAM of array RAM in include file C ram.inc should probably be increased to C accommodate the input integer grid values. END IF CALL RARRAI(LU2,FMUL,'FORMATTED',.TRUE.,1,N1N2N3,IRAM) N4=0 N=0 DO 10 I=1,N1N2N3 N4=MAX0(IRAM(I),N4) N=N+IRAM(I) 10 CONTINUE IF(2*N1N2N3+N.GT.MRAM) THEN C MGRD-02 CALL ERROR('MGRD-02: Too small array RAM') C Dimension MRAM of array RAM in include file C ram.inc should probably be increased to C accommodate the input integer grid values, all input multivalued C grid values, and one output singlevalued grid. END IF CALL RARRAY(LU2,FVAL,'FORMATTED',.TRUE.,UNDEF,N,RAM(2*N1N2N3+1)) C C Loop over singlevalued grids: DO 50 I4=1,N4 N=2*N1N2N3+I4 DO 20 I=1,N1N2N3 IF(IRAM(I).GE.I4) THEN RAM(N1N2N3+I)=RAM(N) ELSE RAM(N1N2N3+I)=UNDEF END IF N=N+IRAM(I) 20 CONTINUE C IF(MGRD.EQ.0) THEN C Writing output file: IF(I4.EQ.1) THEN OPEN(LU2,FILE=FOUT,FORM='FORMATTED') END IF CALL WARRAY(LU2,' ','FORMATTED', * .TRUE.,UNDEF,.FALSE.,0.,N1N2N3,RAM(N1N2N3+1)) IF(I4.EQ.N4) THEN CLOSE(LU2) CALL WSEP3I(LU1,'N4',N4) END IF ELSE C Generating new output filename: IF(I4.GT.1) THEN N=LEN(FOUT) 30 CONTINUE DO 31 I=N,1,-1 IF(LLE('0',FOUT(I:I)).AND.LLE(FOUT(I:I),'8')) THEN FOUT(I:I)=CHAR(ICHAR(FOUT(I:I))+1) GO TO 32 ELSE IF(FOUT(I:I).EQ.'9') THEN FOUT(I:I)='0' N=I-1 GO TO 30 END IF 31 CONTINUE C MGRD-03 CALL ERROR('MGRD-03: Too many output grids') C The digits in the template name of the output files do not C allow for the generation of all singlevalued output grids. C The number of digits should be increased. 32 CONTINUE END IF C C Writing output file: CALL WARRAY(LU2,FOUT,'FORMATTED', * .TRUE.,UNDEF,.FALSE.,0.,N1N2N3,RAM(N1N2N3+1)) END IF 50 CONTINUE C CLOSE(LU1) WRITE(*,'(A)') '+MGRD: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cmul.cal 0100666 0000765 0000765 00000000011 06311435266 011705 0 ustar bulant bulant $3=$1*$2 neg.cal 0100666 0000765 0000765 00000000010 07231752610 011655 0 ustar bulant bulant $2=0-$1 norm2.cal 0100666 0000765 0000765 00000000053 06311435312 012143 0 ustar bulant bulant SQ1=$1*$1 SQ2=$2*$2 SQ=SQ1+SQ2 $3=SQRT(SQ) pallet.for 0100666 0000765 0000765 00000026165 07042762726 012450 0 ustar bulant bulant C
C Program PALLET to interpolate colour tables. C C Version: 5.40 C Date: 2000, January 24 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of input and output files: C KRGB='string'... Name of the input data file containing C the table assigning RGB colours to several integers. C Description of file KRGB C No default, KRGB must be specified and cannot be blank. C KRGBNEW='string'... Name of the output data file containing C the table assigning RGB colours to all integers within the C range corresponding to the input. C Description of file KRGBNEW C No default, KRGBNEW must be specified and cannot be blank. C Brightness factor: C FACTOR=real ... Brightness factor. Intensities of the input RGB C colours are multiplied by FACTOR. C Default: FACTOR=1. C C C Input file KRGB and output file KRGBNEW with the RGB colour tables: C Each line contains four numbers: C K,R,G,B C K... Index of the colour. Non-negative integer. C R... Content of the red colour. Real between 0 and 1. C G... Content of the green colour. Real between 0 and 1. C B... Content of the blue colour. Real between 0 and 1. C C....................................................................... C C This Fortran77 file consists of the following external procedures: C PALLET..Main program to interpolate colour tables. C PALLET C RGBHSV..Subroutine to convert the RGB colour representation into C the HSV colour representation. C RGBHSV C HSVRGB..Subroutine to convert the HSV colour representation into C the RGB colour representation. C HSVRGB C C======================================================================= C C C C Filenames: CHARACTER*80 FILE1,FILE2 CHARACTER*80 FILSEP INTEGER LU0 PARAMETER (LU0=1) C INTEGER K1,K2,K REAL FACTOR,A1,H1,S1,V1,A2,H2,S2,V2,R2,G2,B2,H,S,V,R,G,B C C....................................................................... C C Reading name of SEP file with input data: WRITE(*,'(A)') '+PALLET: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP WRITE(*,'(A)') '+PALLET: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU0,FILSEP) ELSE C PALLET-07 CALL ERROR('PALLET-07: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('KRGB',FILE1,' ') IF (FILE1.EQ.' ') THEN C PALLET-08 CALL ERROR('PALLET-08: Input file KRGB not given') C Input file KRGB must be specified. C There is no default filename. ENDIF CALL RSEP3T('KRGBNEW',FILE2,' ') IF (FILE2.EQ.' ') THEN C PALLET-09 CALL ERROR('PALLET-09: Output file KRGBNEW not given') C Output file KRGBNEW must be specified. C There is no default filename. ENDIF CALL RSEP3R('FACTOR',FACTOR,1.) C OPEN(1,FILE=FILE1,STATUS='OLD') OPEN(2,FILE=FILE2) READ(1,*,END=90) K2,R2,G2,B2 IF(K2.EQ.0) THEN WRITE(2,'(I3,3F5.2)') K2,R2,G2,B2 ELSE WRITE(2,'(I3,3F5.2)') K2,R2*FACTOR,G2*FACTOR,B2*FACTOR END IF CALL RGBHSV(R2,G2,B2,H2,S2,V2) 10 CONTINUE K1=K2 H1=H2 S1=S2 V1=V2 READ(1,*,END=90) K2,R2,G2,B2 CALL RGBHSV(R2,G2,B2,H2,S2,V2) DO 20 K=K1+1,K2 A2=FLOAT(K-K1)/FLOAT(K2-K1) A1=1.-A2 H=H1*A1+H2*A2 S=S1*A1+S2*A2 V=V1*A1+V2*A2 IF(ABS(H1-H2).GT.0.5) THEN IF(H1+H2.LT.1.) THEN IF(H1.LT.H2) THEN H=H+A1 ELSE H=H+A2 END IF ELSE IF(H1.GE.H2) THEN H=H-A1 ELSE H=H-A2 END IF END IF END IF S=S*FACTOR V=V*FACTOR CALL HSVRGB(H,S,V,R,G,B) WRITE(2,'(I3,3F5.2)') K,R,G,B 20 CONTINUE GO TO 10 C 90 CONTINUE CLOSE(1) CLOSE(2) WRITE(*,'(A)') '+PALLET: Done. ' STOP END C C======================================================================= C C C SUBROUTINE RGBHSV(R,G,B,H,S,V) REAL R,G,B,H,S,V C C Subroutine to convert the RGB colour representation into the HSV C colour representation. C C Input: C R... Red. C G... Green. C B... Blue. C C Output: C H... Hue: red=0., green=1/3, blue=2/3. C S... Saturation or chroma: saturation*value=chroma=pure colour. C V... Value = pure colour + white. C C No subroutines and external functions referred. C C Date: 1999, February 26 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C * REAL PI * PARAMETER (PI=3.141593) C C....................................................................... C H=0. IF(R.GE.G.AND.R.GE.B) THEN V=R IF(B.GE.G) THEN S=(V-G) IF(S.GT.0.) THEN * H=11./12.-ASIN((B-G)/S-0.5)/2./PI H=(6.-(B-G)/S)/6. END IF ELSE S=(V-B) IF(S.GT.0.) THEN * H= 1./12.+ASIN((G-B)/S-0.5)/2./PI H=(0.+(G-B)/S)/6. END IF END IF ELSE IF(G.GE.B) THEN V=G IF(R.GE.B) THEN S=(V-B) IF(S.GT.0.) THEN * H= 3./12.-ASIN((R-B)/S-0.5)/2./PI H=(2.-(R-B)/S)/6. END IF ELSE S=(V-R) IF(S.GT.0.) THEN * H= 5./12.+ASIN((B-R)/S-0.5)/2./PI H=(2.+(B-R)/S)/6. END IF END IF ELSE V=B IF(G.GE.R) THEN S=(V-R) IF(S.GT.0.) THEN * H= 7./12.-ASIN((G-R)/S-0.5)/2./PI H=(4.-(G-R)/S)/6. END IF ELSE S=(V-G) IF(S.GT.0.) THEN * H= 9./12.+ASIN((R-G)/S-0.5)/2./PI H=(4.+(R-G)/S)/6. END IF END IF END IF IF(H.LT.0.) THEN H=H+1. END IF IF(H.GT.1.) THEN H=H-1. END IF C If V is saturation (comment if V is chroma): * IF(V.GT.0.) THEN * S=S/V * END IF C RETURN END C C======================================================================= C C C SUBROUTINE HSVRGB(H,S,V,R,G,B) REAL H,S,V,R,G,B C C Subroutine to convert the HSV colour representation into the RGB C colour representation. C C Input: C H... Hue: red=0., green=1/3, blue=2/3. C S... Saturation or chroma: saturation*value=chroma=pure colour. C V... Value = pure colour + white. C C Output: C R... Red. C G... Green. C B... Blue. C C No subroutines and external functions referred. C C Date: 1999, February 26 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C * REAL PI * PARAMETER (PI=3.141593) C C....................................................................... C R=0. G=0. B=0. IF(H.LE.1./6.) THEN R=1. IF(H.LE.0.) THEN * B=-SIN(2.*PI*(H+1./12.))+0.5 B=-6.*H ELSE * G= SIN(2.*PI*(H-1./12.))+0.5 G= 6.*H END IF ELSE IF(H.LE.3./6.) THEN G=1. IF(H.LE.2./6.) THEN * R=-SIN(2.*PI*(H-3./12.))+0.5 R=-6.*H+2. ELSE * B= SIN(2.*PI*(H-5./12.))+0.5 B= 6.*H-2. END IF ELSE IF(H.LE.5./6.) THEN B=1. IF(H.LE.4./6.) THEN * G=-SIN(2.*PI*(H-7./12.))+0.5 G=-6.*H+4. ELSE * R= SIN(2.*PI*(H-9./12.))+0.5 R= 6.*H-4. END IF ELSE R=1. IF(H.LE.1.) THEN * B=-SIN(2.*PI*(H-11./12.))+0.5 B=-6.*H+6. ELSE * G= SIN(2.*PI*(H-13./12.))+0.5 G= 6.*H-6. END IF END IF C If V is saturation: * R=V*(1.-S*(1.-R)) * G=V*(1.-S*(1.-G)) * B=V*(1.-S*(1.-B)) C If V is chroma: R=V-S*(1.-R) G=V-S*(1.-G) B=V-S*(1.-B) C IF(R.LT.0.) THEN C PALLET-01 CALL ERROR('PALLET-01: Red colour component negative') END IF IF(R.GT.1.) THEN C PALLET-02 CALL ERROR('PALLET-02: Red colour component greater than 1') END IF IF(G.LT.0.) THEN C PALLET-03 CALL ERROR('PALLET-03: Green colour component negative') END IF IF(G.GT.1.) THEN C PALLET-04 CALL ERROR('PALLET-04: Green colour component greater than 1') END IF IF(B.LT.0.) THEN C PALLET-05 CALL ERROR('PALLET-05: Blue colour component negative') END IF IF(B.GT.1.) THEN C PALLET-06 CALL ERROR('PALLET-06: Blue colour component greater than 1') END IF C RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for C C======================================================================= Cpictures.for 0100666 0000765 0000765 00000111020 07571327400 012777 0 ustar bulant bulant C
C Program PICTURES to draw lines and points C C Program PICTURES is designed to draw texts and 2-D projections of C 3-D lines and points. The drawing is controled with control data. C The form of the file containing control data and the form of the C files containing the data to be drawn is described below. C C The program is coded in the ANSI X3.9-1978 Fortran77 standard language C employing the ANSI X3.124-1985 GKS (Graphical Kernel System) level 2b C subroutines. C C Version: 5.70 C Date: 2002, November 28 C C Coded by Jana Konopaskova, 1993, September 25 C Revised 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 Program PICTURES has originally been designed to be linked with the C CALCOMP-GKS interface 'calcomp.for' and with GKS graphics library for C a particular computer system. However, the program is recently used C with the CALCOMP-PostScript interface 'calcops.for' supplemented with C simple interface 'gksps.for' from GKS to PostScript. Note that C 'gksps.for' contains just GKS routines called by program PICTURES and C mostly exploits subroutines of 'calcops.for'. Moreover, the current C version of 'gksps.for' does not support most of GKS text attributes C used by program PICTURES and should be finished and debugged in the C future. C C calcomp.for C calcops.for C gksps.for C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C PICDAT='string'... Name of the input file to control plotting. C Description of file PICDAT C No default, obligatory parameter. C Data specifying the form of the output file: C PICTURE='string'... String containing the name of the output C PostScript file with the plotted picture. C Default: PICTURE='picture.ps' C C C Data to control plotting 2-D projections of 3-D lines and points, C including corresponding descriptive texts: C The control file is a sequence of four sets of formated records. C Each set can be repeated to change the projection or plotting C attributes for the subsequent lines or points. C The form of the sets is as follows: C (1) Projection matrix: C The set of two records (1.1) and (1.2) determining the projection C matrix: C (1.1) 'PROJECTION' C The above string identifies this section. C (1.2) PM(1) PM(2) PM(3) PM(4) PM(5) PM(6) PM(7) PM(8) / C here PM(1) to PM(8) are real numbers determining C projection matrix, which transforms coordinates X1,X2,X3 C to 2-D plot coordinates Y1,Y2: C Y1 = PM(1) + PM(3)*X1 + PM(5)*X2 + PM(7)*X3 C Y2 = PM(2) + PM(4)*X1 + PM(6)*X2 + PM(8)*X3 C Note: In future versions these line may be replaced by, e.g., C (1.1) 'PROJECTION' C (1.2) C10,C11,C12,C13 C (1.3) C20,C21,C22,C23 C Transformation matrix from model coordinates X1,X2,X3 to C 2-D plot coordinates C1,C2: C C1 = C10 + C11*X1 + C12*X2 + C13*X3 C C2 = C20 + C21*X1 + C22*X2 + C23*X3 C (2) Graphic attributes: C The set of records determining the attributes for drawing (see C also the GKS documentation). Only the first and the last records C are compulsory. C Each string represents the name of the attribute parameter. C The parameters not listed in the control data file take the C default values. C We use notation R1,R2,...for real constants and I1,I2,...for C integer constants: (attention: the slashes at the end of records C are important) C 'ATTRIBUTES' C The above string identifies this section. C 'INIT' / All attributes are inicialized to their defaults C (subroutine DFLTAT). C 'ILC' I1 / Determines whether the lines are to be drawn C (0-no, 1-yes). C Default: 1 C 'IPC' I1 / Determines whether the points are to be drawn C (0-no, 1-yes). C Default: 1 C 'ITC' I1 / Determines whether the texts are to be drawn: C 0: No texts are drawn. C 1: Texts describing points and texts describing C lines with specified reference points are C drawn. C 2: All texts except those describing empty lines C without specified reference points are drawn. C 3: All texts are drawn. C Default: 1 C 'LCOLI' I1 / Color index determining the color of lines . C Default: 1 C 'PCOLI' I1 / Color index determining the color of points. C Default: 1 C 'TCOLI' I1 / Color index determining the color of texts. C Default: 1 C 'LTYPE' I1 / Determines linetype: C 1: solid, C 2: dashed, C 3: dotted, C 4: dashed-dotted line. C Default: 1 C 'LWIDTH' R1 / Relative linewidth scale factor. C In PostScript (interface 'gksps.for'), thickness C of lines in points (1/72 in). C Default: 1.0 C 'MTYPE' I1 / Determines marker type: C 1: '.', C 2: '+', C 3: '*', C 4: 'o', C 5: 'x'. C Default: 3 C 'MSZSF' R1 / Marker size scale factor. C In PostScript (interface 'gksps.for'), marker C size in dekapoints (1dpt=10in/72=3.537777mm). C Default: 1.0 C 'CHH' R1 / Character height. C In PostScript (interface 'gksps.for'), character C height in dekapoints (1dpt=10in/72=3.537777mm). C Default: 1.0 C 'CHXP' R1 / Character expansion factor. C Default: 1.0 C 'CHSP' R1 / Character spacing. C Default: 0.0 C 'CHUP' R1 R2 / Character up vector. C Default: 0.0 1.0 C 'TXAL' I1 I2 / Text alignment. C Horizontal: I1=0 ... normal C I1=1 ... left C I1=2 ... center C I1=3 ... right C Vertical: I2=0 ... normal C I2=1 ... top C I2=3 ... half C I2=5 ... bottom C Default: 0 0 C 'FP' I1 I2 / Font and text precision: C Text precision: C 0: string, C 1: char, C 2: stroke. C Default font: 1 C Default text precision: 0 C 'TXP' I1 / Determines text path. C Default: 0 C / List of attributes must be terminated by a C slash. C (3) Instruction to plot lines: C According to the attributes currently set, whole lines, points of C lines or texts at the reference pints of lines may be drawn. C Records (3.1) and (3.2) determine the lines to be drawn: C (3.1) 'LINES' C The above string identifies this section. C (3.2) 'NFILE' C 'NFILE'... Name of the input data file containing 3-D C lines to be plotted according to the attributes currently C set. C If 'NFILE'=' ' or is replaced by a slash, the data C describing the lines are included immediately after line C (3.2). C The data representing lines should have form C LINES (or briefly LIN). C Default: 'NFILE'=' '. C (4) Instruction to plot points: C According to the attributes currently set, points or texts C describing the points may be drawn. C Records (4.1) and (4.2) determine the points to be drawn: C (4.1) 'POINTS' C The above string identifies this section. C (4.2) 'NFILE' C 'NFILE'... Name of the input data file containing 3-D C points to be plotted according to the attributes currently C set. C If 'NFILE'=' ' or is replaced by a slash, the data C describing the points are included immediately after line C (4.2). C The data representing points should have form C POINTS (or briefly PTS). C Default: 'NFILE'=' '. C C....................................................................... C C This file contains following routines: C Program PICTURES C Subroutine PAINT C Subroutine SCAN C Subroutine ATTRIB C Subroutine DFLTAT C Except above routines, program PICTURES requires CALCOMP plotting C routines and GKS (Graphical Kernel System) subroutines. C GKS must be installed before the program PICTURES can be C executed. C C======================================================================= C C Program PICTURES to draw texts and 2-D projection of 3-D points and C lines. C C----------------------------------------------------------------------- EXTERNAL ERROR,RSEP1,RSEP3T,PLOTN,PLOTS,PLOT,PAINT,SCAN C----------------------------------------------------------------------- C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C Allocation of working arrays: INTEGER LDIM,NDIM,MDIM PARAMETER (LDIM=MRAM/6,NDIM=MRAM/6,MDIM=MRAM/6) REAL LX(LDIM), LY(LDIM), PX(NDIM), PY(NDIM) INTEGER ICOL(MDIM) REAL WDTH(MDIM) EQUIVALENCE (LX ,RAM( 1)) EQUIVALENCE (LY ,RAM( LDIM+ 1)) EQUIVALENCE (PX ,RAM(2*LDIM+ 1)) EQUIVALENCE (PY ,RAM(2*LDIM+ NDIM+ 1)) EQUIVALENCE (ICOL,RAM(2*LDIM+2*NDIM+ 1)) EQUIVALENCE (WDTH,RAM(2*LDIM+2*NDIM+MDIM+1)) C CHARACTER INDATA*80,FSEP*80,FILPS*80 C C Auxiliary storage location: INTEGER LU1,NUM,IERR,I PARAMETER (LU1=1) C----------------------------------------------------------------------- C C Reading main input data: WRITE(*,'(A)') '+PICTURES: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C PICTURES-01 CALL ERROR('PICTURES-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF WRITE(*,'(A)') '+PICTURES: Working... ' C C Reading input and output filenames: CALL RSEP1(LU1,FSEP) CALL RSEP3T('PICDAT',INDATA,' ') IF(INDATA.EQ.' ') THEN C PICTURES-02 CALL ERROR('PICTURES-02: No input file specified') C Input file with the description of the picture must be specified C by parameter PICDAT. C There is no default filename. END IF CALL RSEP3T('PICTURE',FILPS,'picture.ps') C CALL SCAN (INDATA,ICOL,WDTH,MDIM,NUM,IERR) IF(IERR.NE.0) THEN IF(IERR.EQ.-1) THEN WRITE (*,240) INDATA GO TO 100 END IF IF (IERR.EQ.-2) WRITE (*,250) INDATA IF (IERR.EQ.-4) WRITE (*,260) IF (IERR.EQ.-5) WRITE (*,270) GO TO 100 END IF C Initializing the GKS to CALCOMP interface: CALL GOPKS(0,0) C Initializing the CALCOMP to PostScript interface: CALL PLOTN(FILPS,0) CALL PLOTS(0,0,0) DO 40 I=1,NUM CALL PAINT(INDATA,ICOL(I),WDTH(I),PX,PY,NDIM,LX,LY,LDIM,IERR) IF (IERR.NE.0) THEN IF (IERR.EQ.-1 .OR. IERR.EQ.-2) WRITE(*,275) IF (IERR.EQ.-3) WRITE(*,280) IF (IERR.EQ.-4) WRITE(*,260) IF (IERR.GT.0) WRITE (*,285) GO TO 100 END IF 40 CONTINUE CALL PLOT (0.,0.,999) WRITE(*,'(A)') '+PICTURES: Done. ' 100 STOP C 230 FORMAT(/' A reading error occurred, try again.') 240 FORMAT(/' *****************************************', + /' * The file ',A12, ' cannot be found.*' + /' *****************************************') 250 FORMAT(/' ******************************************************** +' /' * An error occurred when reading the file ', A12,'.* +' /' * Maybe the syntax of that file is wrong. * +' /' ********************************************************') 260 FORMAT(/' *****************************************************' + /' * An error occurred during reading the objects that *' + /' * should be drawn. Maybe the syntax of the file *' + /' * containing that objects is wrong. *' + /' *****************************************************') 270 FORMAT(/' *****************************************************' + /' * The dimension of some arrays in the program *' + /' * PICTURES is not sufficient. It is necessarry *' + /' * to increase the dimension of the arrays ICOL and *' + /' * WDTH to a certain value and to assign the same *' + /' * value to the variable MDIM (see the source code *' + /' * pictures.for) *' + /' *****************************************************') 275 FORMAT(/' A problem occurred while accessing the file containing' + /' control data. Maybe your disk is not all right.') 280 FORMAT(/' ***********************************************' + /' * The file containing the objects that should *' + /' * be drawn cannot be found. *' + /' ***********************************************') 285 FORMAT(/' ******************************************************** +' /' * Some objects or their partitions could not be drawn * +' /' * because of insufficient dimension of some arrays in * +' /' * the program PICTURES. It is necessarry to increase * +' /' * the dimension of the arrays LX,LY (resp. PX,PY) to * +' /' * a certain value and to assign the same value to the * +' /' * variable LDIM (resp. NDIM) (see the source code * +' /' * pictures.for * +' /' ********************************************************') C END C C======================================================================= C C C SUBROUTINE PAINT (INDATA,ICOLOR,WIDTH,PX,PY,NDIM,LX,LY,LDIM,IERR) C C Subroutine PAINT is designed to draw texts and 2-D projections of 3-D C points and lines. C C Input: C INDATA..The name of the file containing control data. C (character*12) C ICOLOR..Color index. Only objects with color index equal to C ICOLOR will be drawn. (integer) C WIDTH...Linewidth. Only lines with linewidth equal to WIDTH will C be drawn. (real) C NDIM... Dimension of auxiliary arrays PX, PY (integer) C LDIM... Dimension of auxiliary arrays LX, LY (integer) C C Output: C IERR... Error parameter (integer) C IERR=0: No errors occurred C IERR=-1: It was not possible to open the file indata C IERR=-2: An error occurred while reading the file C containing control data. C IERR=-3: It was not possible to open the file containing C data that should be drawn. C IERR=-4: An error occurred while reading the file C containing data that should be drawn. C IERR.GT.0: Insufficient either the dimension ndim or the C dimension LDIM. Some objects or their parts C cannot be drawn. C Auxiliary arrays: C PX,PY...Arrays used for the storage of the projection of points. C These arrays are used only when points are stored in the C file containing lines. (real) C LX,LY...Arrays used for the storage of the projection of points C determining a line or for the storage of the projection C of points. (real) C C Parameters in common block /DEFLT/: C These parameters are inicialized at the beginning of subroutine C paint through subroutine dfltat. All parameters in common block C except LUIN, LUDATA and EPS can be changed by the help of the file C containing control data. C PM... Array containing the projection matrix. (real) C LUIN... Logical unit specifier used for the access to control C data. (integer) C LUDAT...Logical unit specifier used for the access to the data to C be drawn. (integer) C ITC,IPC,ILC... Determine whether it is required to draw texts, C points and lines, respectively (0 - drawing is not C required, positive - drawing is required). (integer) C TCOLI,PCOLI,LCOLI...Color indices determining the color of texts, C points and lines, respectively (for details see the C documentation to the graphics system GKS). (integer) C LWIDTH..Relative linewidth (real) C EPS... A little real number. Lines will be drawn when C ABS(LWIDTH-WIDTH) is less than EPS. C C Subroutines required: DFLTAT, ATTRIB, GKS subroutines C C GKS requirements: C GKS must be installed and workstation(s) prepared C (see the documentation to GKS) so that immediate calling of GKS C output functions is possible. C C----------------------------------------------------------------------- C LOGICAL PR,AT,PO,LI CHARACTER INDATA*12,NFILE*12,CNTR*2,W,ST*80 INTEGER TCOLI,LCOLI,PCOLI,IERR,LUIN,LU,LUDAT,IT,IP,IL,ITC,IPC,ILC, * ICOLOR,IND,INDP,INDL,LDIM,NDIM,I,N REAL LWIDTH,PM(8),LX(*),LY(*),PX(*),PY(*),RMAX,RC,DIF,WIDTH,EPS, * X1,X2,X3,Y1,Y2,Y3,P1,P2 COMMON/DEFLT/ PM,LUIN,LUDAT,ITC,IPC,ILC,TCOLI,PCOLI,LCOLI,LWIDTH, + EPS C C----------------------------------------------------------------------- C IERR=0 RMAX=3.402823E+38 RC=3.40282E+38 CALL DFLTAT(-1) C ------------------------------------------------------------------ OPEN (LUIN,ERR=190,FILE=INDATA,STATUS='OLD') 1 CNTR='@@' READ (LUIN,*,END=200,ERR=180) CNTR IF (CNTR.EQ.'@@') GO TO 200 PR=CNTR.EQ.'PR' .OR. CNTR.EQ.'pr' AT=CNTR.EQ.'AT' .OR. CNTR.EQ.'at' PO=CNTR.EQ.'PO' .OR. CNTR.EQ.'po' LI=CNTR.EQ.'LI' .OR. CNTR.EQ.'li' IF(.NOT.PR .AND. .NOT.AT .AND. .NOT.PO .AND. .NOT.LI) GO TO 180 C ------------------------------------------------------------------ IF(PR) READ (LUIN,*,ERR=180)PM C ------------------------------------------------------------------ IF(AT) THEN CALL ATTRIB(1,IERR) IF (IERR.EQ.-1) GO TO 180 END IF C ------------------------------------------------------------------ IF (PO.OR.LI) THEN IT=0 IP=0 IL=0 IF(ITC.GE.1 .AND. TCOLI.EQ.ICOLOR) IT=ITC IF(IPC.GE.1 .AND. PCOLI.EQ.ICOLOR) IP=1 DIF=ABS(LWIDTH-WIDTH) IF(ILC.EQ.1 .AND. LCOLI.EQ.ICOLOR .AND. DIF.LT.EPS) IL=1 NFILE='EMPTY ' READ (LUIN,*,ERR=180) NFILE LU=LUIN IF (NFILE.NE.'EMPTY ')THEN IF(IT.EQ.0 .AND. IP.EQ.0 .AND. IL.EQ.0) GO TO 1 OPEN (LUDAT,ERR=170,FILE=NFILE,STATUS='OLD') LU=LUDAT END IF 10 W='@' READ(LU,*,ERR=195) W IF(W.NE.'@') GO TO 10 END IF C ------------------------------------------------------------------ IF (PO) THEN IND=0 20 CONTINUE X1=0. X2=0. X3=0. ST='$' READ(LU,*,END=50,ERR=195) ST,X1,X2,X3 IF (ST.EQ.'$') THEN GO TO 50 END IF IF (IND.EQ.LDIM) THEN IERR=IERR+1 25 CONTINUE ST='$' READ (LU,*,END=50,ERR=195) ST,X1,X2,X3 IF (ST.EQ.'$') THEN GO TO 50 END IF GO TO 25 END IF IND=IND+1 LX(IND)=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 LY(IND)=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 IF (IT.GE.1) THEN N=80 DO 30 I=80,2,-1 IF(ST(I:I).NE.' ') GO TO 40 N=N-1 30 CONTINUE 40 CALL GTX (LX(IND),LY(IND),ST(1:N)) END IF GO TO 20 50 IF (IP.EQ.1) CALL GPM(IND,LX,LY) IF (LU.NE.LUIN) REWIND(LU) END IF C ------------------------------------------------------------------ IF (LI) THEN INDP=0 70 INDL=2 Y1=RMAX Y2=0. Y3=0. ST='$' READ(LU,*,END=1,ERR=195) ST,Y1,Y2,Y3 IF (ST.EQ.'$')THEN IF (IP.EQ.1 .AND. INDP.GT.0) CALL GPM (INDP,PX,PY) IF (LU.NE.LUIN) REWIND(LU) GO TO 1 END IF C X1=RMAX X2=0. X3=0. READ (LU,*,END=70,ERR=195) X1,X2,X3 IF (IT.GE.1) THEN N=80 DO 75 I=80,2,-1 IF (ST(I:I).NE.' ') GO TO 78 N=N-1 75 CONTINUE 78 CONTINUE IF (Y1.LE.RC) THEN P1=PM(1)+PM(3)*Y1+PM(5)*Y2+PM(7)*Y3 P2=PM(2)+PM(4)*Y1+PM(6)*Y2+PM(8)*Y3 CALL GTX (P1,P2,ST(1:N)) ELSE IF (X1.LE.RC.AND.IT.GE.2) THEN P1=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 P2=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 CALL GTX (P1,P2,ST(1:N)) ELSE IF (IT.GE.3) THEN P1=PM(1) P2=PM(2) CALL GTX (P1,P2,ST(1:N)) END IF END IF IF (X1.GT.RC) GO TO 70 C Y1=RMAX Y2=0. Y3=0. READ (LU,*,END=70,ERR=195) Y1,Y2,Y3 IF (Y1.GT.RC) THEN IF (INDP.LT.NDIM) THEN INDP=INDP+1 PX(INDP)=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 PY(INDP)=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 ELSE IERR=IERR+1 END IF GO TO 70 END IF LX(1)=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 LY(1)=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 LX(2)=PM(1)+PM(3)*Y1+PM(5)*Y2+PM(7)*Y3 LY(2)=PM(2)+PM(4)*Y1+PM(6)*Y2+PM(8)*Y3 80 CONTINUE X1=RMAX X2=0. X3=0. READ(LU,*,END=70,ERR=195) X1,X2,X3 IF (X1.GT.RC) THEN IF(IL.EQ.1) CALL GPL(INDL,LX,LY) GO TO 70 END IF IF (INDL.EQ.LDIM) THEN IERR=IERR+1 90 X1=RMAX READ(LU,*,END=70,ERR=195) X1,X2,X3 IF (X1.LE.RC) GO TO 90 IF (IL.EQ.1) CALL GPL(INDL,LX,LY) GO TO 70 END IF INDL=INDL+1 LX(INDL)=PM(1)+PM(3)*X1+PM(5)*X2+PM(7)*X3 LY(INDL)=PM(2)+PM(4)*X1+PM(6)*X2+PM(8)*X3 GO TO 80 END IF C ------------------------------------------------------------------ GO TO 1 170 IERR=-3 GO TO 200 180 IERR=-2 GO TO 200 190 IERR=-1 RETURN 195 IERR=-4 200 REWIND(LUIN) RETURN C END C C======================================================================= C C C SUBROUTINE SCAN (INDATA,ICOL,WDTH,NDIM,NUM,IERR) C C Subroutine SCAN is designed to look over the file containing control C data for drawing 2-D projection of 3-D points and lines and to C determine which colors and linewidths are required for drawing the C data. C C Input: C INDATA..The name of the file containing control data C (character*12) C NDIM... Dimension of output arrays ICOL and WDTH (integer) C C Output: C ICOL... Array containing color indexes representing colors C required for drawing the data (integer) C WDTH... Array containing linewidths. A linewidth in any array C element WDTH(I) corresponds to color index ICOL(I). It is C possible to have WDTH(I) less than zero. In such case the C linewidth corresponding to color index ICOL(I) is C arbitrary. (real) C NUM... The number of color indexes (resp. linewidths) stored in C array ICOL (resp. WDTH) (integer) C IERR... Error indicator (integer) C IERR=0: No errors occurred C IERR=-1: It was not possible to open the file indata C IERR=-2: An error occurred while reading the file C containing control data. C IERR=-4: An error occurred while reading the file C containing data that should be drawn. C IERR=-5: The dimension NDIM of the arrays ICOL and WDTH is C not sufficiet. C C Parameters in common block /DEFLT/: C These parameters are inicialized at the beginning of subroutine C scan through subroutine DFLTAT. All parameters in common block C except LUIN, LUDATA and EPS can be changed by the help of the file C containing control data. C PM... Array containing the projection matrix. C LUIN... Logical unit specifier used for the access to control C data. (integer) C LUDAT.. Logical unit specifier used for the access to the data to C be drawn. (integer) C ITC,IPC,ILC... Determine whether it is required to draw texts, C points and lines, respectively (0 - drawing is not C required, positive - drawing is required). (integer) C TCOLI,PCOLI,LCOLI...Color indexes determining the color of texts, C points and lines respectively (for details see the C documentation to the graphics system GKS). (integer) C LWIDTH..Linewidth (real) C EPS... A little real number. Lines will be drawn when C ABS(LWIDTH-WIDTH) is less than EPS. C C Subroutines required: DFLTAT, ATTRIB C C----------------------------------------------------------------------- C INTEGER TCOLI,LCOLI,PCOLI,ICOL(*),IERR,NUM,LUIN,LUDAT,ILC,IPC,ITC, * I,NDIM REAL LWIDTH,PM(8),WDTH(*),RMAX,RC,X1,X2,X3,EPS CHARACTER INDATA*12,NFILE*12,CNTR*2,W LOGICAL PR,AT,PO,LI COMMON/DEFLT/ PM,LUIN,LUDAT,ITC,IPC,ILC,TCOLI,PCOLI,LCOLI,LWIDTH, + EPS C C----------------------------------------------------------------------- C IERR=0 RMAX=3.402823E+38 RC=3.40282E+38 CALL DFLTAT(-2) NUM=0 C ------------------------------------------------------------------ OPEN (LUIN,ERR=170,FILE=INDATA,STATUS='OLD') 10 CNTR='@@' READ (LUIN,*,END=200,ERR=180) CNTR IF (CNTR.EQ.'@@') GO TO 200 PR=CNTR.EQ.'PR' .OR. CNTR.EQ.'pr' AT=CNTR.EQ.'AT' .OR. CNTR.EQ.'at' PO=CNTR.EQ.'PO' .OR. CNTR.EQ.'po' LI=CNTR.EQ.'LI' .OR. CNTR.EQ.'li' IF (.NOT.PR .AND. .NOT.AT .AND. .NOT.PO .AND. .NOT.LI) GO TO 180 C ------------------------------------------------------------------ IF (PR) READ (LUIN,*,ERR=180) PM C ------------------------------------------------------------------ IF(AT) THEN CALL ATTRIB(0,IERR) IF (IERR.EQ.-1) GO TO 180 END IF C ------------------------------------------------------------------ IF (PO.OR.LI) THEN NFILE='EMPTY ' READ (LUIN,*,ERR=180) NFILE IF (NFILE.EQ.'EMPTY ') THEN 30 W='@' READ (LUIN,*,ERR=185) W IF (W.NE.'@') GO TO 30 END IF IF (ITC.EQ.0) GO TO 60 IF (NUM.EQ.0) GO TO 50 DO 40 I=1,NUM IF (ICOL(I).EQ.TCOLI) GO TO 60 40 CONTINUE 50 NUM=NUM+1 IF (NUM.GT.NDIM) GO TO 190 ICOL(NUM)=TCOLI WDTH(NUM)=-1.0 60 CONTINUE IF (IPC.EQ.0) GO TO 90 IF (NUM.EQ.0) GO TO 80 DO 70 I=1,NUM IF (ICOL(I).EQ.PCOLI) GO TO 90 70 CONTINUE 80 NUM=NUM+1 IF (NUM.GT.NDIM) GO TO 190 ICOL(NUM)=PCOLI WDTH(NUM)=-1.0 90 CONTINUE END IF C ------------------------------------------------------------------ IF (PO .AND. NFILE.EQ.'EMPTY ') THEN 100 X1=RMAX READ (LUIN,*,END=100,ERR=185) W,X1,X2,X3 IF (X1.LE.RC) GO TO 100 END IF C ------------------------------------------------------------------ IF (LI) THEN IF (ILC.EQ.0) GO TO 130 IF (NUM.EQ.0) GO TO 120 DO 110 I=1,NUM IF (ICOL(I).EQ.LCOLI) THEN IF (ABS(WDTH(I)-LWIDTH).LT.EPS)GO TO 130 IF (WDTH(I).GE.0.0) GO TO 110 WDTH(I)=LWIDTH GO TO 130 END IF 110 CONTINUE 120 NUM=NUM+1 IF (NUM.GT.NDIM) GO TO 190 ICOL(NUM)=LCOLI WDTH(NUM)=LWIDTH 130 CONTINUE IF (NFILE.EQ.'EMPTY ') THEN 140 X1=RMAX X2=0. X3=0. READ (LUIN,*,END=10,ERR=185) W,X1,X2,X3 IF (X1.GT.RC) GO TO 10 150 X1=RMAX READ (LUIN,*,END=140,ERR=185) X1,X2,X3 IF (X1.GT.RC) GO TO 140 GO TO 150 END IF END IF C ------------------------------------------------------------------ GO TO 10 170 IERR=-1 RETURN 180 IERR=-2 GO TO 200 185 IERR=-4 GO TO 200 190 IERR=-5 200 REWIND (LUIN) RETURN C END C C======================================================================= C C C SUBROUTINE ATTRIB (ICONTR,IERR) C C Subroutine ATTRIB is designed to read some attributes from the C file containing control data for drawing 2-D projections of 3-D C points and lines and to set up GKS according to the attributes. C C Input: C ICONTR..Control parameter (integer) C ICONTR=0: Attributes are red but GKS is not set up C according to them. C ICONTR=1: Attributes are read and GKS is set up. C C Output: C IERR... Error parameter (integer) C IERR=0: No errors occurred. C IERR=-1: Error occurred while reading the file containing C control data. C C Subroutines required: C subroutine DFLTAT C subroutines of GKS C C----------------------------------------------------------------------- C INTEGER TCOLI,PCOLI,IPAR1,IPAR2,ICONTR,IERR, * LUIN,LUDAT,ILC,IPC,ITC,LCOLI REAL LWIDTH,PM(8),PAR1,PAR2,EPS CHARACTER AT*6 COMMON/DEFLT/ PM,LUIN,LUDAT,ITC,IPC,ILC,TCOLI,PCOLI,LCOLI,LWIDTH, + EPS C C----------------------------------------------------------------------- C 10 AT='@@@@@@' PAR2=0.0 READ (LUIN,*,ERR=30)AT,PAR1,PAR2 IF(AT.EQ.'@@@@@@') GO TO 50 IPAR1=NINT(PAR1) IPAR2=NINT(PAR2) IF (ICONTR.EQ.0) GO TO 20 IF (AT.EQ.'CHH ' .OR. AT.EQ.'chh ') CALL GSCHH(PAR1) IF (AT.EQ.'CHXP ' .OR. AT.EQ.'chxp ') CALL GSCHXP(PAR1) IF (AT.EQ.'CHSP ' .OR. AT.EQ.'chsp ') CALL GSCHSP(PAR1) IF (AT.EQ.'CHUP ' .OR. AT.EQ.'chup ') CALL GSCHUP(PAR1,PAR2) IF (AT.EQ.'TXAL ' .OR. AT.EQ.'txal ') CALL GSTXAL(IPAR1,IPAR2) IF (AT.EQ.'FP ' .OR. AT.EQ.'fp ') CALL GSTXFP(IPAR1,IPAR2) IF (AT.EQ.'TXP ' .OR. AT.EQ.'txp ') CALL GSTXP(IPAR1) IF (AT.EQ.'LTYPE ' .OR. AT.EQ.'ltype ') CALL GSLN(IPAR1) IF (AT.EQ.'MTYPE ' .OR. AT.EQ.'mtype ') CALL GSMK(IPAR1) IF (AT.EQ.'MSZSF ' .OR. AT.EQ.'mszsf ') CALL GSMKSC(PAR1) 20 IF (AT.EQ.'ITC ' .OR. AT.EQ.'itc ') ITC=IPAR1 IF (AT.EQ.'IPC ' .OR. AT.EQ.'ipc ') IPC=IPAR1 IF (AT.EQ.'ILC ' .OR. AT.EQ.'ilc ') ILC=IPAR1 IF (AT.EQ.'INIT ' .OR. AT.EQ.'init ') CALL DFLTAT(ICONTR) IF (AT.EQ.'TCOLI ' .OR. AT.EQ.'tcoli ') THEN IF (ICONTR.NE.0) CALL GSTXCI(IPAR1) TCOLI=IPAR1 END IF IF (AT.EQ.'LWIDTH' .OR. AT.EQ.'lwidth') THEN IF (ICONTR.NE.0) CALL GSLWSC(PAR1) LWIDTH=PAR1 END IF IF (AT.EQ.'LCOLI ' .OR. AT.EQ.'lcoli ') THEN IF (ICONTR.NE.0) CALL GSPLCI(IPAR1) LCOLI=IPAR1 END IF IF (AT.EQ.'PCOLI ' .OR. AT.EQ.'pcoli ') THEN IF (ICONTR.NE.0) CALL GSPMCI(IPAR1) PCOLI=IPAR1 END IF GO TO 10 C ------------------------------------------------------------------ 30 IERR=-1 50 RETURN C END C C======================================================================= C C C SUBROUTINE DFLTAT(ICONTR) C C Subroutine DFLTAT is designed to initialize some parameters. C This subroutine serves to subroutines PAINT and SCAN. C C Input: C ICONTR...Control parameter (integer) C ICONTR=0: Only the parameters TCOLI,LWIDTH LCOLI,PCOLI, C ITC,IPC,ILC are initialized C ICONTR=-2: As ICONTR=0 but in addition LUIN,LUDAT,EPS C and projection matrix PM are initialized C ICONTR=-1: As ICONTR=-2 but in addition GKS is set up C according to initial attributes C ICONTR=1: As ICONTR=0 but in addition GKS is set up C according to initial attributes C C Subroutines required: Subroutines of system GKS C C----------------------------------------------------------------------- C INTEGER TXALH,TXALV,TCOLI,FONT,PREC,TXP,PCOLI,ICONTR,LTYPE,MTYPE, * LUIN,LUDAT,ILC,IPC,ITC,LCOLI REAL LWIDTH,MSZSF,PM(8),EPS,CHH,CHXP,CHSP,CHUX,CHUY COMMON/DEFLT/ PM,LUIN,LUDAT,ITC,IPC,ILC,TCOLI,PCOLI,LCOLI,LWIDTH, + EPS C C----------------------------------------------------------------------- C IF (ICONTR.NE.-1 .AND. ICONTR.NE.-2) GO TO 5 PM(1)=0.0 PM(2)=0.0 PM(3)=1.0 PM(4)=0.0 PM(5)=0.0 PM(6)=1.0 PM(7)=0.0 PM(8)=0.0 LUIN=1 LUDAT=2 EPS=0.001 5 TCOLI=1 LWIDTH=1.0 LCOLI=1 PCOLI=1 ITC=1 IPC=1 ILC=1 IF (ICONTR.EQ.0 .OR. ICONTR.EQ.-2) GO TO 10 CHH=1.0 CHXP=1.0 CHSP=0.0 CHUX=0.0 CHUY=1.0 TXALH=0 TXALV=0 FONT=1 PREC=0 TXP=0 LTYPE=1 MTYPE=3 MSZSF=1.0 CALL GSCHH(CHH) CALL GSCHXP(CHXP) CALL GSCHSP(CHSP) CALL GSCHUP(CHUX,CHUY) CALL GSTXAL(TXALH,TXALV) CALL GSTXCI(TCOLI) CALL GSTXFP(FONT,PREC) CALL GSTXP(TXP) CALL GSLN(LTYPE) CALL GSLWSC(LWIDTH) CALL GSPLCI(LCOLI) CALL GSMK(MTYPE) CALL GSMKSC(MSZSF) CALL GSPMCI(PCOLI) 10 RETURN C END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'calcops.for' C calcops.for INCLUDE 'gksps.for' C gksps.for C C======================================================================= Cplgn.for 0100666 0000765 0000765 00000017615 10062244274 012114 0 ustar bulant bulant C
C Program PLGN to convert polygons described by names of the vertices C into the same polygons described by indices of the vertices C C Version: 5.80 C Date: 2004, June 11 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C VRTX='string'... Name of the file with vertices of the polygons. C Description of file VRTX C Default: VRTX='vrtx.out' C PLGNS='string'... Name of the file describing the polygons in C terms of the names of the vertices. C Description of file PLGNS C Default: PLGNS='plgns.out' C Data specifying output file: C PLGN='string'... Name of the file describing the polygons in C terms of the indices of the vertices. C Description of file PLGN C Default: PLGN='plgn.out' C C C Input file VRTX with the vertices: C (1) None to several strings terminated by / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,Z1,Z2,Z3,/ C 'NAME'... Name of the vertex. Different vertices must have C different names. C X1,X2,X3... Coordinates of the vertex. C Z1,Z2,Z3... Normal to the surface at the vertex. C /... None to several values terminated by a slash. C (3) / or end of file. C C C Input file PLGNS with the polygons: C (1) For each polygon data (1.1): C (1.1) 'VRTX1','VRTX2',...,'VRTXN',/ C 'VRTX1','VRTX2',...,'VRTXN'... Strings containing the names of N C vertices of the polygon. The names must correspond to the C names in file VRTX. C /... List of vertices must be terminated by a slash. C (2) / or end of file. C C C Output file PLGN with the polygons: C (1) For each polygon data (1.1): C (1.1) I1,I2,...,IN,/ C I1,I2,...,IN... Integer indices of N vertices of the polygon. C The vertices in file VRTX are indexed by positive integers C according to their order. C /... List of vertices is terminated by a slash. C C======================================================================= C C String array for the vertex names: INTEGER MVRTX,MIVRTX PARAMETER (MVRTX=2048,MIVRTX=21) CHARACTER*12 VRTX(MVRTX) INTEGER IVRTX(MIVRTX) COMMON /VRTXC/ VRTX C C Filenames and parameters: CHARACTER*80 FSEP,FVRTX,FPLGNS,FPLGN INTEGER LU,LU2,IUNDEF PARAMETER (LU=1,LU2=2) C Input data: CHARACTER*10 FORMAT CHARACTER*1 TEXT C Other variables: INTEGER NVRTX,NIVRTX,N,I,I1 C C MVRTX...Maximum number of vertices in the list of points plus C the number of vertices of the largest polygon plus 1. C MIVRTX..Maximum number of vertices of a single polygon increased C by 1. C NVRTX...Number of vertices in the list of points. C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+PLGN: Enter input filename: ' FSEP=' ' READ (*,*) FSEP C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C PLGN-05 CALL ERROR('PLGN-05: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C WRITE(*,'(A)') '+PLGN: Working ... ' C C Reading input and output filenames: CALL RSEP3T('VRTX',FVRTX,'vrtx.out') CALL RSEP3T('PLGNS',FPLGNS,'plgns.out') CALL RSEP3T('PLGN',FPLGN,'plgn.out') C C Reading vertices: OPEN(LU,FILE=FVRTX) READ(LU,*) (TEXT,I=1,20) NVRTX=0 10 CONTINUE NVRTX=NVRTX+1 IF(NVRTX.GT.MVRTX) THEN C PLGN-01 CALL ERROR('PLGN-01: Too small array VRTX') C Dimension MVRTX of array VRTX should be C increased. END IF VRTX(NVRTX)='$' READ(LU,*,END=11) VRTX(NVRTX) IF(VRTX(NVRTX).EQ.'$') THEN GO TO 11 END IF GO TO 10 11 CONTINUE NVRTX=NVRTX-1 CLOSE(LU) C C Checking vertex names: DO 15 I=1,NVRTX DO 14 I1=I+1,NVRTX IF(VRTX(I).EQ.VRTX(I1)) THEN C PLGN-02 CALL ERROR('PLGN-02: Different vertices have the same name') C Strings identifying different vertices in the list of points C are equal within the considered length, see array C VRTX. END IF 14 CONTINUE 15 CONTINUE C C Output format FORMAT='(99(I0,A))' I=INT(ALOG10(FLOAT(NVRTX)))+1 FORMAT(6:6)=CHAR(ICHAR('0')+I) C C Reading polygons: OPEN(LU,FILE=FPLGNS) OPEN(LU2,FILE=FPLGN) NIVRTX=MIN0(MVRTX,NVRTX+MIVRTX) DO 21 I=NVRTX+1,NIVRTX VRTX(I)='$' 21 CONTINUE 22 CONTINUE READ(LU,*,END=29) (VRTX(I),I=NVRTX+1,NIVRTX) IF(VRTX(NVRTX+1).EQ.'$') THEN GO TO 29 END IF DO 25 I=NVRTX+1,NIVRTX IF(VRTX(I).EQ.'$') THEN N=I-NVRTX-1 GO TO 27 END IF DO 23 I1=1,NVRTX IF(VRTX(I).EQ.VRTX(I1)) THEN IVRTX(I-NVRTX)=I1 GO TO 24 END IF 23 CONTINUE C PLGN-03 CALL ERROR('PLGN-03: Vertex not found') C String identifying a vertex of a polygon does not match any C vertex in the list of points. 24 CONTINUE 25 CONTINUE C PLGN-04 CALL ERROR('PLGN-04: Too small array VRTX or IVRTX') C Dimension MVRTX of array VRTX or C dimension MIVRTX of array IVRTX should be increased. 27 CONTINUE WRITE(LU2,FORMAT) (IVRTX(I),' ',I=1,N-1),IVRTX(N),' /' DO 28 I=NVRTX+1,NVRTX+N VRTX(I)='$' 28 CONTINUE GO TO 22 29 CONTINUE C CLOSE(LU) CLOSE(LU2) WRITE(*,'(A)') '+PLGN: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for C C======================================================================= Cptsgrd.for 0100666 0000765 0000765 00000014650 07043504314 012452 0 ustar bulant bulant C
C Program PTSGRD to generate grid file containing undefined values C at the gridpoints closest to the given points and zeros at the other C gridpoints C C Version: 5.40 C Date: 2000, January 26 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Imput and output filenames: C PTS='string'... String in apostrophes containing the name of the C input file with the coordinates of the points. C If PTS=' ', zeros at all gridpoints are generated. C Description of the file PTS C Default: PTS=' ' C PTSGRD='string'... String in apostrophes containing the name of C the output file with the grid values. C For general description of files with gridded data refer C to file forms.htm. C No default, 'PTSGRD' must be specified and cannot be blank C Data specifying grid dimensions: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C O1=real... First coordinate of the grid origin (first point of the C grid). C Default: O1=0. C O2=real... Second coordinate of the grid origin. C Default: O2=0. C O3=real... Third coordinate of the grid origin. C Default: O3=0. C D1=real... Grid interval in the direction of the first coordinate C axis. C Default: D1=1. C D2=real... Grid interval in the direction of the second coordinate C axis. C Default: D2=1. C D3=real... Grid interval in the direction of the third coordinate C axis. C Default: D3=1. C C C Input file PTS with given points: C (1) None to several strings terminated by / (a slash) C (2) For each gridpoint data (2.1): C (2.1) 'NAME',X1,X2,X3,/ C 'NAME'... Name of the point. Any string different from '$'. C X1,X2,X3... Coordinates of the point. C (3) / or end of file C C----------------------------------------------------------------------- C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C C Filenames and parameters: CHARACTER*80 FSEP,FPTS,FGRD INTEGER LU REAL UNDEF PARAMETER (LU=1,UNDEF=-999999.) C C Data: CHARACTER*1 TEXT INTEGER I,I1,I2,I3,N1,N2,N3 REAL D1,D2,D3,O1,O2,O3,X1,X2,X3 C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+PTSGRD: Enter input filename: ' FSEP=' ' READ(*,*) FSEP C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C PTSGRD-01 CALL ERROR('PTSGRD-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C WRITE(*,'(A)') '+PTSGRD: Working... ' C C Recalling the data specifying grid dimensions CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) C C Input and output filenames: CALL RSEP3T('PTS' ,FPTS,' ') CALL RSEP3T('PTSGRD',FGRD,' ') IF (FGRD.EQ.' ') THEN C PTSGRD-02 CALL ERROR('PTSGRD-02: Output file PTSGRD not given') C Output file PTSGRD must be specified. C There is no default filename. ENDIF C DO 10 I=1,N1*N2*N3 RAM(I)=0. 10 CONTINUE C IF(FPTS.NE.' ') THEN C OPEN(LU,FILE=FPTS,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) 20 CONTINUE TEXT='$' X1=0. X2=0. X3=0. READ(LU,*,END=29) TEXT,X1,X2,X3 IF(TEXT.EQ.'$') THEN GO TO 29 END IF I1=NINT((X1-O1)/D1) I2=NINT((X2-O2)/D2) I3=NINT((X3-O3)/D3) IF(0.LE.I1.AND.I1.LT.N1.AND. * 0.LE.I2.AND.I2.LT.N2.AND. * 0.LE.I3.AND.I3.LT.N3) THEN RAM(1+I1+N1*(I2+N2*I3))=UNDEF END IF GO TO 20 29 CONTINUE CLOSE(LU) END IF C C Writing output grid values: CALL WARRAY(LU,FGRD,'FORMATTED',.TRUE.,UNDEF,.FALSE.,0., * N1*N2*N3,RAM) WRITE(*,'(A)') '+PTSGRD: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cptswrl.for 0100666 0000765 0000765 00000044700 10062244274 012502 0 ustar bulant bulant C
C Program PTSWRL to convert points into the Virtual Reality Modeling C Language or GOCAD representation C C Version: 5.80 C Date: 2004, June 11 C C Coded by: Ludek Klimes & Vaclav Bucha C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mails: klimes@seis.karlov.mff.cuni.cz C bucha@seis.karlov.mff.cuni.cz C C References: C C VRML (Virtual Reality Modeling Language) version 1.0C C C VRML97 (Virtual Reality Modeling Language ISO/IEC 14772) C C GOCAD C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C PTS='string'... Name of the file with the points. C Description of file PTS C Default: PTS='pts.out' C COLORS='string'... Name of the file containing the data describing C the colour map. C Description of file COLORS C Default: COLORS='hsv.dat' C Input/output file: C WRL='string'... Name of the file to be supplemented with surfaces C or to be copied to the beginning of the output file. C If the filename is blank, output file starts from a C scratch (mostly not reasonable). C The default name of the output file is equal to WRL. C It is recommended to specify WRL rather than to use C the default name. C Default: WRL='out.wrl' C WRLOUT='string'... Name of the output file if different from WRL. C Default: WRLOUT=WRL C Data specifying the form of the output file: C VRML='string'... Virtual reality scene description language. C VRML='VRML1': VRML (Virtual Reality Modeling Language) C version 1.0. C VRML='VRML2': VRML97 according to ISO/IEC 14772 standard. C VRML='GOCAD': GOCAD description of points (VSet). C Default: VRML='VRML2' (recommended) C NAME='string'... String containing the GOCAD name of the set of C points. Be sure to select different names for all objects C within the GOCAD file. C The same name is used for the corresponding colour scale, C written if KOLPTS is positive. C Used only if VRML='GOCAD'. Obligatory parameter, must be C specified and cannot be blank if VRML='GOCAD'. C Optional data to shift the points: C SHIFT1=real, SHIFT2=real, SHIFT3=real... All points will be C shifted by vector (SHIFT1,SHIFT2,SHIFT3). The shift may C be applied to the points situated at a surface to make C them visible. C Default: SHIFT1=0., SHIFT2=0., SHIFT3=0. C Optional data specifying the symbol and size of the points: C ASYMB='string'... String specifying the GOCAD symbol C used for plotting points. Possible values are: C 'point','cross','tetra','diamond','cube','ico','sphere'. C Used only if VRML='GOCAD'. C Default: ASYMB='point' C ASIZE=integer... Size of points (atoms) in GOCAD. C Used only if VRML='GOCAD'. C Default: ASIZE=3 C Data specifying the values to be scaled in colours: C KOLPTS=integer... If zero, all points will have the same colour C given by parameters R, G, B. If positive, the C values in KOLPTS-th column of input file PTS will be C colour coded at each point. C Default: KOLPTS=0 C PROPERTIES='string'... String containing names of properties C corresponding to optional values V1,...,VN (see file C PTS) which may be used to control the C colour of the point. The names are separated by blanks. C If the number of names is smaller than the number of C values, the leftmost values are considered. PROPERTIES C must be specified if VRML='GOCAD' and KOLPTS is positive. C If KOLPTS is 1, 2 or 3, the last name is assumed to denote C the KOLPTSth coordinate rather than the quantity in the C corresponding column, and the value of the coordinate C copied into that column. C If PROPERTIES=' ', no values are considered and GOCAD atom C VRTX is used for the vertices (otherwise, GOCAD atom PVRTX C is used). C Used only if VRML='GOCAD'. C Default: PROPERTIES=' ' C Data specifying the colour scale: C VADD=real, VMUL=real, VPER=real, VREF=real, CREF=real, CREF1=real, C CREF2=real, CREF3=real, etc... Refer to file C colors.for. C R=real, G=real, B=real... Float numbers between 0 and 1 specifying C the colour of the points if KOLPTS=0. C Defaults: R=1, G=1, B=1 (white) C C C Input file PTS with the points: C (1) None to several strings terminated by / (a slash) C (2) For each point data: C (2.1) 'NAME',X1,X2,X3,V1,...,VN,/ C 'NAME'... Name of the point. Not considered. May be blank. C X1,X2,X3... Coordinates of the point C V1,...,VN...Optional values which may be used to control the C colour of the point. C /... Values must be terminated by a slash. C (3) / or end of file. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C C External functions and subroutines: EXTERNAL LENGTH,RSEP1,RSEP3T,RSEP3I,ERROR,FORM2,COLOR1,COLOR2 INTEGER LENGTH C C Filenames and parameters: CHARACTER*80 FSEP,FPTS,FCOLS,FIN,FOUT,ASYMB INTEGER LU1,LU2,IUNDEF,MQ REAL UNDEF PARAMETER (LU1=1,LU2=2,IUNDEF=-999999,UNDEF=-999999.,MQ=30) C C Other variables: CHARACTER*46 FORMAT CHARACTER*5 VRML CHARACTER*255 NAME,TEXT INTEGER KOLPTS,KQ,NQ,ASIZE INTEGER NVRTX,I0,I1,I2,I REAL SHIFT1,SHIFT2,SHIFT3,RED,GREEN,BLUE REAL OUTMIN(MQ),OUTMAX(MQ),R,G,B,AUX,AUXA(1) C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+PTSWRL: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C PTSWRL-01 CALL ERROR('PTSWRL-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF CALL RSEP1(LU1,FSEP) WRITE(*,'(A)') '+PTSWRL: Working... ' C C Reading input and output filenames: CALL RSEP3T('PTS' ,FPTS ,'pts.out') CALL RSEP3T('COLORS',FCOLS,'hsv.dat') CALL RSEP3T('WRL' ,FIN ,'out.wrl' ) CALL RSEP3T('WRLOUT',FOUT ,FIN ) CALL RSEP3T('VRML' ,VRML ,'VRML2' ) CALL LOWER(VRML) C C Optional shift: CALL RSEP3R('SHIFT1',SHIFT1,0.00) CALL RSEP3R('SHIFT2',SHIFT2,0.00) CALL RSEP3R('SHIFT3',SHIFT3,0.00) C C Reading the data for colours: CALL RSEP3I('KOLPTS',KOLPTS,0) CALL RSEP3R('R' ,RED ,1.00) CALL RSEP3R('G' ,GREEN ,1.00) CALL RSEP3R('B' ,BLUE ,1.00) C C Opening the output file and writing its beginning: CALL WRL1(LU1,LU2,FIN,FOUT,VRML,1) C C Writing the prolog for the points (part 1): IF (VRML.EQ.'vrml1') THEN IF(KOLPTS.LE.0) THEN WRITE(LU2,'(A)') * 'DEF PointMaterial Material {' WRITE(LU2,'(A,3(1X,F4.2))') * ' emissiveColor',RED,GREEN,BLUE WRITE(LU2,'(A)') * '}' * ,' ' END IF ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'Shape {' * ,' appearance DEF PointAppearance Appearance {' * ,' material Material {' IF(KOLPTS.LE.0) THEN WRITE(LU2,'(A,3(1X,F4.2))') * ' emissiveColor',RED,GREEN,BLUE END IF WRITE(LU2,'(A)') * ' }' * ,' }' * ,'}' * ,' ' ELSE IF (VRML.EQ.'gocad') THEN CALL RSEP3T('NAME',NAME,' ') C Subroutine WRL has already checked that NAME is not blank. WRITE(LU2,'(A)') * 'GOCAD VSet 1.0' WRITE(LU2,'(2A)') * 'HDR name:',NAME(1:LENGTH(NAME)) WRITE(LU2,'(A)') * 'HDR *visible:true' C C Symbol of points: CALL RSEP3T('ASYMB',ASYMB,'point') WRITE(LU2,'(2A)') * 'HDR *atoms*symbol:',ASYMB(1:LENGTH(ASYMB)) C C Size of points: CALL RSEP3I('ASIZE',ASIZE,3) WRITE(LU2,'(A,I3)') * 'HDR *atoms*size:',ASIZE CALL RSEP3T('PROPERTIES',TEXT,' ') I0=1 KQ=3 DO 11 I=1,LEN(TEXT)-1 IF (TEXT(I:I).EQ.' '.AND.TEXT(I+1:I+1).NE.' ') THEN I0=I+1 END IF IF (TEXT(I:I).NE.' '.AND.TEXT(I+1:I+1).EQ.' ') THEN KQ=KQ+1 IF (KQ.EQ.KOLPTS.OR.(1.LE.KOLPTS.AND.KOLPTS.LE.3)) THEN I1=I0 I2=I END IF END IF 11 CONTINUE IF (KOLPTS.LE.0) THEN WRITE(LU2,'(3(A,F4.2))') * 'HDR *atoms*color: ',RED,' ',GREEN,' ',BLUE ELSE IF (KQ.LT.KOLPTS.OR.KQ.LT.4) THEN C PTSWRL-02 CALL ERROR('PTSWRL-02: GOCAD property name not specified') C If KOLPTS is not zero, list PROPERTIES of property names C must contain MAX(1,KOLPTS-3) names at the least, see the C description of the input data. END IF WRITE(LU2,'(A)') * 'HDR *painted:true' WRITE(LU2,'(2A)') * 'HDR *painted*variable:',TEXT(I1:I2) END IF IF (KQ.GT.3) THEN WRITE(LU2,'(2A)') * 'PROPERTIES ',TEXT(1:LENGTH(TEXT)) END IF IF (KOLPTS.NE.0) THEN WRITE(LU2,'(2A)') * 'PROPERTY_CLASSES ',TEXT(1:LENGTH(TEXT)) WRITE(LU2,'(3A)') * 'PROPERTY_CLASS_HEADER ',TEXT(I1:I2),' {' C The output file now waits for the colour scale. END IF C KQ is the number of coordinates and properties at each point. C ELSE IF (VRML.EQ.'pov') THEN C *** ELSE C PTSWRL-03 CALL ERROR('PTSWRL-03: No valid string in VRML') C Valid string specifying the form of the output file is: C VRML='VRML1' or 'VRML2' or 'GOCAD'. Default and recommended C value is 'VRML2'. END IF C C Determining number NQ of values stored at each point: IF(VRML.EQ.'gocad') THEN NQ=KQ ELSE KQ=MAX0(3,KOLPTS) IF(KOLPTS.EQ.0) THEN NQ=3 ELSE NQ=4 END IF C Values to be displayed will be shifted to the 4th column END IF IF(NQ.GT.MQ) THEN C PTSWRL-04 CALL ERROR('PTSWRL-04: Too small arrays OUTMIN and OUTMAX') END IF C C Reading points: OPEN(LU1,FILE=FPTS,STATUS='OLD') READ(LU1,*) (TEXT,I=1,20) NVRTX=0 20 CONTINUE IF(NVRTX+KQ.GT.MRAM) THEN C PTSWRL-05 CALL ERROR('PTSWRL-05: Too small array RAM') END IF TEXT='$' DO 21 I=NVRTX+1,NVRTX+KQ RAM(I)=0. 21 CONTINUE READ(LU1,*,END=29) TEXT,(RAM(I),I=NVRTX+1,NVRTX+KQ) IF(TEXT.EQ.'$') THEN GO TO 29 END IF C Relocating the values to be displayed IF(VRML.EQ.'gocad') THEN IF(1.LE.KOLPTS.AND.KOLPTS.LE.3) THEN RAM(NVRTX+KQ)=RAM(NVRTX+KOLPTS) END IF ELSE IF(KOLPTS.GT.0) THEN RAM(NVRTX+4)=RAM(NVRTX+KOLPTS) END IF END IF C Shifting the point RAM(NVRTX+1)=RAM(NVRTX+1)+SHIFT1 RAM(NVRTX+2)=RAM(NVRTX+2)+SHIFT2 RAM(NVRTX+3)=RAM(NVRTX+3)+SHIFT3 C Determining the minimum and maximum values IF(NVRTX.EQ.0) THEN DO 22 I=1,NQ OUTMIN(I)=RAM(NVRTX+I) OUTMAX(I)=RAM(NVRTX+I) 22 CONTINUE ELSE DO 23 I=1,NQ OUTMIN(I)=AMIN1(OUTMIN(I),RAM(NVRTX+I)) OUTMAX(I)=AMAX1(OUTMAX(I),RAM(NVRTX+I)) 23 CONTINUE END IF C Number of storage locations in RAM used for the points NVRTX=NVRTX+NQ GO TO 20 29 CONTINUE CLOSE(LU1) C NVRTX is the number of storage locations in RAM used for points C C Determining the colour map: IF(KOLPTS.GT.0) THEN IF(VRML.EQ.'gocad') THEN CALL COLOR1(LU1,MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,OUTMIN(KOLPTS),OUTMAX(KOLPTS)) WRITE(LU2,'(2A)') * ' *colormap:',NAME(1:LENGTH(NAME)) FORMAT='(A,' CALL FORM2(1,OUTMIN(KOLPTS),OUTMAX(KOLPTS),FORMAT(4:11)) FORMAT(9:11)=') ' IF(OUTMAX(KOLPTS).GT.OUTMIN(KOLPTS)) THEN WRITE(LU2,FORMAT) * ' *low_clip: ',OUTMIN(KOLPTS) * ,' *high_clip:',OUTMAX(KOLPTS) ELSE WRITE(LU2,FORMAT) * ' *low_clip: ',OUTMIN(KOLPTS) * ,' *high_clip:',OUTMIN(KOLPTS)+1. END IF WRITE(LU2,'(4A)') * ' *colormap*',NAME(1:LENGTH(NAME)),'*colors: ',CHAR(92) AUX=(OUTMAX(KOLPTS)-OUTMIN(KOLPTS))/255. DO 31 I=0,255 AUXA(1)=OUTMIN(KOLPTS)+FLOAT(I)*AUX CALL COLOR2(MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,AUXA,R,G,B) IF (I.LT.255) THEN WRITE(LU2,'(I5,3(1X,F4.2),2A)') * I,R,G,B,' ',CHAR(92) ELSE WRITE(LU2,'(I5,3(1X,F4.2),2A)') * I,R,G,B END IF 31 CONTINUE WRITE(LU2,'(A)') * '}' C ELSE IF (VRML.EQ.'pov') THEN C *** ELSE CALL COLOR1(LU1,MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,OUTMIN(4),OUTMAX(4)) END IF END IF C C Writing the prolog for the points (part 2): IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') * 'Separator {' IF(KOLPTS.GT.0) THEN WRITE(LU2,'(A)') * 'MaterialBinding { value PER_VERTEX }' ELSE WRITE(LU2,'(A)') * 'MaterialBinding { value OVERALL }' * ,'USE PointMaterial' END IF WRITE(LU2,'(A)') * 'Coordinate3 { point [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'Point {' * ,'appearance USE PointAppearance' * ,'point [' END IF C C Writing the points: IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN FORMAT='(' CALL FORM2(3,OUTMIN(1),OUTMAX(1),FORMAT(2:25)) DO 81 I=1,NVRTX,NQ WRITE(LU2,FORMAT) RAM(I),' ',RAM(I+1),' ',RAM(I+2),',' 81 CONTINUE ELSE IF (VRML.EQ.'gocad') THEN FORMAT='(A,I0,A,' FORMAT(5:5)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(NVRTX/NQ)+0.5))) CALL FORM2(NQ,OUTMIN(1),OUTMAX(1),FORMAT(9:8+8*NQ)) IF (KOLPTS.EQ.0) THEN DO 82 I0=1,NVRTX,NQ WRITE(LU2,FORMAT) 'VRTX ',I0/NQ+1,(' ',RAM(I),I=I0,I0+NQ-1) 82 CONTINUE ELSE DO 83 I0=1,NVRTX,NQ WRITE(LU2,FORMAT) 'PVRTX ',I0/NQ+1,(' ',RAM(I),I=I0,I0+NQ-1) 83 CONTINUE END IF ELSE IF (VRML.EQ.'pov') THEN C Writing the vertices with values: C *** END IF C Writing the trailor for the point: IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') ']' END IF C C Writing the colours of the points: IF(KOLPTS.GT.0) THEN IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'Material { emissiveColor [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'color Color { color [' END IF IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN DO 84 I=NQ,NVRTX,NQ CALL COLOR2(MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,RAM(I),R,G,B) WRITE(LU2,'(3(F4.2,A))') R,' ',G,' ',B,',' 84 CONTINUE END IF IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '] }' END IF END IF C C Writing the trailor for the point set: IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'PointSet { }' WRITE(LU2,'(A)') '}' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '}' ELSE IF (VRML.EQ.'gocad') THEN WRITE(LU2,'(A)') 'END' END IF CLOSE(LU2) WRITE(*,'(A)') '+PTSWRL: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'forms.for' C forms.for INCLUDE 'colors.for' C colors.for INCLUDE 'wrl.for' C wrl.for C C======================================================================= Cram.inc 0100666 0000765 0000765 00000003326 07216057610 011713 0 ustar bulant bulant C
C Common block /RAMC/ is designed to be included in all programs C demanding huge amounts of memory, e.g., in programs dealing with C dense rectangular grids of points. Assuming no other considerable C memory requirements of the respective programs, this include file C enables to approximately adjust the memory requirements of all C programs for a particular computer at one go. C C INCLUDE 'ram.inc' C ------------------------------------------------------------------ INTEGER MRAM,MINRAM,MAXRAM PARAMETER (MRAM=4000000) REAL RAM(MRAM) COMMON/RAMC/ MINRAM,MAXRAM,RAM SAVE /RAMC/ C ------------------------------------------------------------------ C C For example, MRAM=4000000 requires 15.259 MB of memory, which may C be suitable for 16 MB computer if the rest of program together C with the operating system does not require more than 759 kB. C C MINRAM, MAXRAM... Variables which are usually undefined and not C used. They are designed in case that the program calls C a subroutine which needs to use a part of array RAM. For C example, the subroutine may be called when program starts, C allocate subarray RAM(1:MINRAM-1) or RAM(MAXRAM+1:MRAM) or C both, and define MINRAM or MAXRAM or both. The program C may then use subarray RAM(MINRAM:MRAM) or RAM(1:MAXRAM) C or RAM(MINRAM:MAXRAM) instead of whole array RAM(1:MRAM). C C Date: 2000, December 14 C Coded by Ludek Klimes C C======================================================================= Creldev.cal 0100666 0000765 0000765 00000000024 06770622720 012377 0 ustar bulant bulant DIF=$1-$2 $3=DIF/$2 reldif.cal 0100666 0000765 0000765 00000000066 06311435340 012360 0 ustar bulant bulant DIF=$1-$2 SUM=$1+$2 DIF=DIF/SUM DIF=2*DIF $3=ABS(DIF) relerr.cal 0100666 0000765 0000765 00000000041 06311435302 012375 0 ustar bulant bulant DIF=$1-$2 DIF=DIF/$2 $3=ABS(DIF) rtcoef.for 0100666 0000765 0000765 00000013454 10062244274 012433 0 ustar bulant bulant C
C Auxiliary main program RTCOEF C (for testing of routine COEF52) C ******************************* C For testing purposes, a brief main program RTCOEF is included C to control the computation of R/T coefficients using the routine C COEF52. Main program first calls COEF52 to read the data for the C model, and, after this, it reads two records specifying the C required computations. The computations are performed either in an C angle loop, or in a frequency loop. For any required angle of C incidence and frequency, routine COEF52 is called to compute the C relevant R/T coefficient. C C The complete set of input data is as follows: C ******************************************** C 1) One record: NZ C NZ ... number of layers, including both halfspaces C 2) NZ records: VP,VS,RHO,QP,QS,D C Parameters of the layers; one record for one layer. The C first record corresponds to the halfspace with the incident C wave (first halfspace), the last record to the NZ-th layer, C that is to the second halfspace. C 3) One record: FREF C FREF ... reference frequency (in Hz). C 4) One record: NC,NH,NQ,NF,NA C NC ... type of R/T coefficient C NH ... NH=0...the second halfspace is solid or liquid C NH=1...the second halfspace is a vacuum C NQ ... NQ=0... model is non-dissipative C NQ=1... model is dissipative C NF ... number of frequencies in the frequency loop. C For NF=1, the frequency loop is not considered C NA ... number of angles of incidence in the angle loop. C For NA=1, the angle loop is not considered C 5) One record: FMIN,DF,AMIN,DA,GAMMA C FMIN,DF ... specify frequency loop, in Hz C AMIN,DA ... specify angle loop, in degrees C GAMMA ... attenuation angle, in degrees C The records 4 and 5 can be repeated any number of times. The C computation finishes if NC=0 is used in record 4. C If we wish to compute the R/T coefficients in an angle loop C (for one given frequency FMIN), we use NF=1. If we wish to C compute the R/T coefficients in a frequency loop (for one C given angle of incidence AMIN), we use NA=1. Use always NF=1 C or NA=1. C The input data are stored in the file input.dat. C The results of computations are stored in the file C output.dat. For convenience, all input data are first stored C in output.dat (even those for model). Then, after an empty C line, the results of computations are stored. Each line diplays: C ANGLE,FREQ,RMOD,RPHASE,RMOD0,RPH0. C C Test examples C ************* C Four test examples are included. See the description in the file C 'rtcoef.htm'. C C The test data are located in subdirectory C rtcoef C of package DATA. C The test examples may be executed by command C perl go.pl rtcoef.h C running the demonstration history file C rtcoef.h. C C References C ********** C Brokesova,J. (2000). Reflection/transmission coefficients at a C plane interface in dissipative and non-dissipative media: C A comparison. J.Comput.Acoustics, 9,623 -641. C Brokesova,J., and Cerveny,V. (1998). Inhomogeneous plane waves C in dissipative, isotropic and anisotropic media. Reflection/ C transmission coefficients. In Seismic waves in complex 3-D C structures, Report No. 7, pp. 57 - 146. Department of C Geophysics, Charles University, Prague. C Cerveny,V. (1989). Synthetic body wave seismograms for laterally C varying media containing thin transition layers. Geophys. J. C Int., 99, 331-349, C Cerveny,V. (2001). Seismic ray theory. Cambridge Univ. Press, C Cambridge. C Muller,G. (1985). The reflectivity method. A tutorial. J.Geophys., C 58, 153-174. C C C Consortium Project "Seismic Waves in Complex 3-D Structures" C Praha, April 2003 C J.Brokesova, V.Cerveny C ************************************************************************ c c program rtcoef c ************** c c Auxiliary program rtcoef is designed for computations c of R/T coefficients of inhomogeneous P, SV and SH plane wave c at stack of layers between two isotropic anelastic halfspaces. c It uses the routine coef52. c open(7,file='input.dat') open(9,file='output.dat') c c reading the model call coef52(0,0,0,0,7,9,0.,0.,0.,0.,0.,0.,0.) c c reading the data for coef52 1 read(7,100)nc,nh,nq,nf,na write(9,100)nc,nh,nq,nf,na if(nc.eq.0.or.nc.eq.11.or.nc.eq.12.or.nc.gt.14)go to 10 read(7,101)fmin,df,amin,da,gamma write(9,101)fmin,df,amin,da,gamma write(9,102) c c angle loop if(na.eq.1)go to 5 freq=fmin do 2 i=1,na angle=amin+(i-1)*da call coef52(nc,nh,nq,1,7,9,angle,gamma,freq,rmod,rphase, 1rmod0,rph0) write(9,101)angle,freq,rmod,rphase,rmod0,rph0 2 continue go to 10 c c frequency loop 5 angle=amin do 6 i=1,nf freq=fmin+(i-1)*df call coef52(nc,nh,nq,1,7,9,angle,gamma,freq,rmod,rphase, 1rmod0,rph0) write(9,101)angle,freq,rmod,rphase,rmod0,rph0 6 continue c 7 go to 1 100 format(6i5) 101 format(8f10.3) 102 format (/) 10 continue stop end c ************************************************************************ c INCLUDE 'coef52.for' c coef52.for c ************************************************************************ csep.for 0100666 0000765 0000765 00000071770 07440605504 011750 0 ustar bulant bulant C
C Subroutine file 'sep.for' to read data in the form of the SEP header C or parameter files. C C Version: 5.60 C Date: 2002, March 4 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 SEPB... Subprogram designed to initiate the number of parameters C stored in common blocks /SEPT/ and /SEPC/ (include file C 'sep.inc'). C SEPB C SSEP... Subroutine designed to Switch between different sets C of the SEP parameters. C SSEP C RSEP1...Subroutine designed to Read a SEP-like parameter or header C file and to store the parameter names and values for C future use. It does the same as WSEP1 and closes the C input file. C RSEP1 C WSEP1...Subroutine designed to read a SEP-like parameter or header C file and to store the parameter names and values for C future use. It does not close the input file and leaves C it open for Writing. C WSEP1 C RSEP2...Subroutine designed to take a line from a SEP-like C parameter or header file and to store the parameter names C and values for future use. C RSEP2 C RSEP3Q..Subroutine designed to decide whether a parameter is C a number or a string. C RSEP3Q C RSEP3R..Subroutine designed to read the value of a given C real-valued parameter from previously stored contents of C SEP-like parameter or header files. C RSEP3R C RSEP3I..Subroutine designed to read the value of a given integer C parameter from previously stored contents of SEP-like C parameter or header files. Note that integer value can C be read both by RSEP3R into real-valued variable or by C RSEP3I into integer variable. C RSEP3I C RSEP3T..Subroutine designed to read the value of a given C text-valued parameter from previously stored contents of C SEP-like parameter or header files. C RSEP3T C WSEPR...Subroutine designed to write the value of a given C real-valued parameter into the output string. C WSEPR C WSEPI...Subroutine designed to write the value of a given C integer parameter into the output string. C WSEPI C WSEPT...Subroutine designed to write the value of a given C text-valued parameter into the output string. C WSEPT C WSEP3R..Subroutine designed to write the value of a given C real-valued parameter into the output file. C WSEP3R C WSEP3I..Subroutine designed to write the value of a given C integer parameter into the output file. C WSEP3I C WSEP3T..Subroutine designed to write the value of a given C text-valued parameter into the output file. C WSEP3T C C Referred external functions: C LOWER...file 'length.for' C LENGTH..file 'length.for' C C....................................................................... C C C Form of the SEP (Stanford Exploration Project) parameter files: C C All the data are specified in the form of PARAMETER=VALUE, e.g. C N1=50, with PARAMETER directly preceding = without intervening C spaces and with VALUE directly following = without intervening C spaces. The PARAMETER=VALUE couple must be delimited by a space C or comma from both sides. PARAMETER= followed by a space resets C the default parameter value. C C All other text in the input files is ignored. The file thus may C contain unused data or comments without leading comment character. C Everything between comment character # and the end of the C respective line is ignored, too. C C The PARAMETER=VALUE couples may be specified in any order. C The last appearance takes precedence. C C PARAMETER is the string identifying the variable. It must not be C enclosed in apostrophes (if it were, the apostrophes would be C considered as the part of the identifier). It must immediately C precede '=', with no intervening spaces. From the left, PARAMETER C is delimited by a space ' ', or by comma ','. C The PARAMETER string is not case-sensitive. C C On input, all characters '=' are determined and each of them C is assumed to correspond to one PARAMETER=VALUE couple. C Only characters '=' within 'value' strings enclosed in apostrophes C or within comments (after #) do not create PARAMETER=VALUE C couples. C C The most common parameters: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C D1=real... Grid interval in the direction of the first coordinate C axis. C Default: D1=1. C D2=real... Grid interval in the direction of the second coordinate C axis. C Default: D2=1. C D3=real... Grid interval in the direction of the third coordinate C axis. C Default: D3=1. C O1=real... First coordinate of the grid origin (first point of the C grid). C Default: O1=0. C O2=real... Second coordinate of the grid origin. C Default: O2=0. C O3=real... Third coordinate of the grid origin. C Default: O3=0. C C Example of the SEP parameter file: C grd.h C C Each program may consider several sets of SEP-like specified C parameters, but most common is the use of a single parameter set. C The parameters of each parameter set may by step-by-step redefined. C A considerable attention should thus be paid to the order in which C the parameter files are read and in which subroutines RSEP1 and RSEP2 C are invoked with input files or lines. The order specifies the order C of preferences of redefined values. C C For example: C (a) Subroutine RSEP1 reads the parameters of the input file. C (b) Invocations of function RSEP3I define dimensions N1,N2,N3 of the C input file. C (c) Subroutine RSEP1 reads the parameters of the output file and C redefines the values of parameters N1,N2,N3. C (d) New invocations of function RSEP3I define dimensions N1,N2,N3 of C the output file. C C======================================================================= C C C BLOCK DATA SEPB C C Subprogram designed to initiate the numbers of parameters stored in C common blocks /SEPT/ and /SEPC/ (include file 'sep.inc'). C C----------------------------------------------------------------------- C INCLUDE 'sep.inc' C sep.inc C C----------------------------------------------------------------------- C C At the beginning, no parameters are defined, set 1 is to be used: DATA NPAR/0,MSET*0/ DATA ISET,NSET/1,1/ END C C======================================================================= C C C SUBROUTINE SSEP(I) INTEGER I C C Subroutine designed to switch between different sets of the SEP C parameters. C C Input: C I ... Index of the set to be used. C C No output. C C----------------------------------------------------------------------- C INCLUDE 'sep.inc' C sep.inc C C----------------------------------------------------------------------- INTEGER I1 C IF (I.GT.MSET) THEN C SEP-07 CALL ERROR('SEP-07: Too many sets of SEP parameters') C At most MSET parameter sets are available, see the file C sep.inc. END IF IF (I.GT.NSET) THEN DO 10, I1=NSET+1,I NSET=I1 NPAR(I1)=NPAR(I1-1) 10 CONTINUE ENDIF ISET=I RETURN END C C======================================================================= C C C SUBROUTINE RSEP1(LU,FILE) INTEGER LU CHARACTER*(*) FILE C C Subroutine designed to read a SEP-like parameter or header file and to C store the parameter names and values for future use. Unlike WSEP1, it C closes the input file. C C Input: C LU... Logical unit number of the input file. The file will be C opened, read and closed. C FILE... String containing the name of the input SEP parameter C file to be read. C If FILE=' ', no action is done. C C No output. C C----------------------------------------------------------------------- C EXTERNAL WSEP1 C C----------------------------------------------------------------------- C IF(FILE.NE.' ') THEN CALL WSEP1(LU,FILE) CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE WSEP1(LU,FILE) INTEGER LU CHARACTER*(*) FILE C C Subroutine designed to read a SEP-like parameter or header file and to C store the parameter names and values for future use. This subroutine, C unlike RSEP1, leaves the input file open in order to append new lines C using the WRITE statement. C C Input: C LU... Logical unit number of the input file. The file will be C opened and read, but not closed. C FILE... String containing the name of the input SEP parameter C file to be read. C If FILE=' ', no action is done. C C No output. C C----------------------------------------------------------------------- C EXTERNAL RSEP2 C C----------------------------------------------------------------------- C CHARACTER*255 LINE C IF(FILE.NE.' ') THEN OPEN(LU,FILE=FILE,STATUS='OLD') 1 CONTINUE READ(LU,'(A)',END=9) LINE CALL RSEP2(LINE) GO TO 1 9 CONTINUE END IF RETURN END C C======================================================================= C C C SUBROUTINE RSEP2(LINE) CHARACTER*(*) LINE C C Subroutine designed to take a line from a SEP-like parameter or header C file and to store the parameter names and values for future use. C C Input: C LINE... String containing a line from a SEP parameter file. C C No output. C C----------------------------------------------------------------------- C INCLUDE 'sep.inc' C sep.inc C C----------------------------------------------------------------------- C EXTERNAL LENGTH,LOWER INTEGER LENGTH C C----------------------------------------------------------------------- C INTEGER M,K,L,I,J,I1 C C M... Length of the line. C K... Position of the current '=' character in the line, later C of the next character. C L... Starting position of the line part being interpreted. C I,J... Temporary indices. C C....................................................................... C C Length of the input line up to the comment sign '#': M=LEN(LINE) I=INDEX(LINE,'#') IF(I.GT.0) THEN M=I-1 END IF C L=1 1 CONTINUE C Assessing part LINE(L:M) of the input line: IF(L.GT.M) THEN GO TO 9 END IF C C Searching for '=' in the line: K=INDEX(LINE(L:M),'=')+L-1 IF(K.LT.L) THEN GO TO 9 END IF C Preparing storage location for the new parameter: IF(NPAR(NSET)+1.GT.MPAR) THEN C SEP-01 CALL ERROR('SEP-01: Too many input parameters to store') END IF DO 10, I1=NPAR(NSET),NPAR(ISET)+1,-1 PAR(I1+1) =PAR(I1) VALUE(I1+1)=VALUE(I1) NCHAR(I1+1)=NCHAR(I1) 10 CONTINUE DO 11, I1=NSET,ISET,-1 NPAR(I1)=NPAR(I1)+1 11 CONTINUE C C Name of the parameter must precede '=': DO 2 I=K-1,L,-1 IF(LINE(I:I).EQ.' '.OR.LINE(I:I).EQ.',') THEN GO TO 3 END IF 2 CONTINUE 3 CONTINUE IF(I.GE.K-1) THEN PAR(NPAR(ISET))=' ' ELSE PAR(NPAR(ISET))=LINE(I+1:K-1) CALL LOWER(PAR(NPAR(ISET))) END IF C C Value of the parameter must follow '=': K=K+1 IF(K.GT.M) THEN C End of line just after '=': NCHAR(NPAR(ISET))=0 L=K ELSE IF(LINE(K:K).EQ.''''.OR.LINE(K:K).EQ.'"') THEN C String enclosed in apostrophes or quotes following '=': NCHAR(NPAR(ISET))=0 L=K C Loop for embedded apostrophes 5 CONTINUE L=L+1 C L is the position after the opening apostrophe I=INDEX(LINE(L:M),LINE(K:K)) IF(I.LE.0) THEN C SEP-02 CALL ERROR('SEP-02: String not terminated by apostrophe') END IF J=NCHAR(NPAR(ISET)) NCHAR(NPAR(ISET))=J+I-1 VALUE(NPAR(ISET))(J+1:J+I-1)=LINE(L:L+I-2) L=L+I C L is the position after the terminating apostrophe IF(LINE(L:L).EQ.LINE(K:K)) GO TO 5 ELSE C String without apostrophes or quotes following '=': I=INDEX(LINE(K:M),' ') J=INDEX(LINE(K:M),',') IF(I.LE.0) THEN IF(J.LE.0) THEN I=M-K+2 ELSE I=J END IF ELSE IF(J.GT.0) THEN I=MIN0(I,J) END IF END IF NCHAR(NPAR(ISET))=I-1 IF(I.GT.1) THEN VALUE(NPAR(ISET))=LINE(K:K+I-2) END IF L=K+I C L is the position after the terminating separator ' ' or ',' END IF C C Blank parameter: IF(PAR(NPAR(ISET)).EQ.' ') THEN DO 12, I1=NPAR(ISET),NPAR(NSET)-1 PAR(I1) =PAR(I1+1) VALUE(I1)=VALUE(I1+1) NCHAR(I1)=NCHAR(I1+1) 12 CONTINUE DO 13, I1=ISET,NSET NPAR(I1)=NPAR(I1)-1 13 CONTINUE END IF C C Removing duplicate registrations: DO 7 I=NPAR(ISET)-1,NPAR(ISET-1)+1,-1 IF(PAR(I).EQ.PAR(NPAR(ISET))) THEN NCHAR(I)=NCHAR(NPAR(ISET)) VALUE(I)=VALUE(NPAR(ISET)) DO 14, I1=NPAR(ISET),NPAR(NSET)-1 PAR(I1) =PAR(I1+1) VALUE(I1)=VALUE(I1+1) NCHAR(I1)=NCHAR(I1+1) 14 CONTINUE DO 15, I1=ISET,NSET NPAR(I1)=NPAR(I1)-1 15 CONTINUE GO TO 8 END IF 7 CONTINUE 8 CONTINUE GO TO 1 C 9 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE RSEP3Q(NAME,LNUM) CHARACTER*(*) NAME LOGICAL LNUM C C Subroutine designed to decide whether a given parameter is a number or C a string. C C Input: C NAME... String containing the name of the parameter. Except for C its case, it should match the parameter name in the input C SEP parameter file. C C Output: C LNUM... LNUM=.TRUE.: Parameter given by NAME is an integer or real C number. C LNUM=.FALSE.: Parameter given by NAME is a string or a C default. C C----------------------------------------------------------------------- C INCLUDE 'sep.inc' C sep.inc C C----------------------------------------------------------------------- C EXTERNAL LOWER C C----------------------------------------------------------------------- C CHARACTER*20 LOWNAM INTEGER I C C....................................................................... C LOWNAM=NAME CALL LOWER(LOWNAM) DO 10 I=NPAR(ISET-1)+1,NPAR(ISET) IF(PAR(I).EQ.LOWNAM) THEN IF(NCHAR(I).LE.0) THEN LNUM=.FALSE. ELSE IF(('0'.LE.VALUE(I)(1:1).AND.VALUE(I)(1:1).LE.'9').OR. * VALUE(I)(1:1).EQ.'+'.OR.VALUE(I)(1:1).EQ.'-'.OR. * VALUE(I)(1:1).EQ.'.') THEN LNUM=.TRUE. ELSE LNUM=.FALSE. END IF END IF 10 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE RSEP3R(NAME,ROUT,RDEF) CHARACTER*(*) NAME REAL ROUT,RDEF C C Subroutine designed to read the value of a given real-valued parameter C from previously stored contents of SEP-like parameter or header files. C Note that integer value can be read both by RSEP3R into real-valued C variable or by RSEP3I into integer variable. C C Input: C NAME... String containing the name of the parameter. Except for C its case, it should match the parameter name in the input C SEP parameter file. C RDEF... Default value of the parameter. C C Output: C ROUT... Value of the parameter. C C----------------------------------------------------------------------- C INCLUDE 'sep.inc' C sep.inc C C----------------------------------------------------------------------- C EXTERNAL LENGTH,LOWER INTEGER LENGTH C C----------------------------------------------------------------------- C CHARACTER*20 LOWNAM CHARACTER*7 FORMAT INTEGER I C LOWNAM=NAME CALL LOWER(LOWNAM) ROUT=RDEF DO 10 I=NPAR(ISET-1)+1,NPAR(ISET) IF(PAR(I).EQ.LOWNAM) THEN IF(NCHAR(I).LE.0) THEN ROUT=RDEF ELSE FORMAT='(F00.0)' FORMAT(3:3)=CHAR(ICHAR('0')+NCHAR(I)/10) FORMAT(4:4)=CHAR(ICHAR('0')+MOD(NCHAR(I),10)) READ(VALUE(I),FORMAT,ERR=20) ROUT END IF END IF 10 CONTINUE RETURN C 20 CONTINUE C SEP-03 WRITE(*,'(5A)') ' Parameter: ''',PAR(I)(1:LENGTH(PAR(I))), * ''', Value: ''',VALUE(I)(1:NCHAR(I)),'''' CALL ERROR('SEP-03 in RSEP3R when reading real value') RETURN END C C======================================================================= C C C SUBROUTINE RSEP3I(NAME,IOUT,IDEF) CHARACTER*(*) NAME INTEGER IOUT,IDEF C C Subroutine designed to read the value of a given integer parameter C from previously stored contents of SEP-like parameter or header files. C Note that integer value can be read both by RSEP3R into real-valued C variable or by RSEP3I into integer variable. C C Input: C NAME... String containing the name of the parameter. Except for C its case, it should match the parameter name in the input C SEP parameter file. C IDEF... Default value of the parameter. C C Output: C IOUT... Value of the parameter. C C----------------------------------------------------------------------- C INCLUDE 'sep.inc' C sep.inc C C----------------------------------------------------------------------- C EXTERNAL LENGTH,LOWER INTEGER LENGTH C C----------------------------------------------------------------------- C CHARACTER*20 LOWNAM CHARACTER*5 FORMAT INTEGER I C LOWNAM=NAME CALL LOWER(LOWNAM) IOUT=IDEF DO 10 I=NPAR(ISET-1)+1,NPAR(ISET) IF(PAR(I).EQ.LOWNAM) THEN IF(NCHAR(I).LE.0) THEN IOUT=IDEF ELSE FORMAT='(I00)' FORMAT(3:3)=CHAR(ICHAR('0')+NCHAR(I)/10) FORMAT(4:4)=CHAR(ICHAR('0')+MOD(NCHAR(I),10)) READ(VALUE(I),FORMAT,ERR=20) IOUT END IF END IF 10 CONTINUE RETURN C 20 CONTINUE C SEP-04 WRITE(*,'(5A)') ' Parameter: ''',PAR(I)(1:LENGTH(PAR(I))), * ''', Value: ''',VALUE(I)(1:NCHAR(I)),'''' CALL ERROR('SEP-04 in RSEP3I when reading integer value') RETURN END C C======================================================================= C C C SUBROUTINE RSEP3T(NAME,TOUT,TDEF) CHARACTER*(*) NAME,TOUT,TDEF C C Subroutine designed to read the value of a given text-valued parameter C from previously stored contents of SEP-like parameter or header files. C C Input: C NAME... String containing the name of the parameter. Except for C its case, it should match the parameter name in the input C SEP parameter file. C TDEF... Default value of the parameter. C C Output: C TOUT... Value of the parameter. C C----------------------------------------------------------------------- C INCLUDE 'sep.inc' C sep.inc C C----------------------------------------------------------------------- C EXTERNAL LOWER C C----------------------------------------------------------------------- C CHARACTER*20 LOWNAM INTEGER I C LOWNAM=NAME CALL LOWER(LOWNAM) TOUT=TDEF DO 10 I=NPAR(ISET-1)+1,NPAR(ISET) IF(PAR(I).EQ.LOWNAM) THEN IF(NCHAR(I).LE.0) THEN TOUT=TDEF ELSE TOUT=VALUE(I)(1:NCHAR(I)) END IF END IF 10 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE WSEPR(LINE,NAME,RVAL) CHARACTER*(*) LINE,NAME REAL RVAL C C Subroutine designed to write the value of a given real-valued C parameter into the output string. C C Input: C NAME... String containing the name of the parameter. C RVAL... Value of the parameter. C C Output: C LINE... String containing 2 spaces followed by the NAME=RVAL C couple. C C----------------------------------------------------------------------- C EXTERNAL LENGTH,WSEPI INTEGER LENGTH C C----------------------------------------------------------------------- C C NWIDTH is the maximum width of the output real number in C characters. The real number should be written with the accuracy C of NWIDTH-6 digits. C INTEGER NWIDTH,I,J PARAMETER (NWIDTH=12) CHARACTER*(NWIDTH) TEXT CHARACTER*7 FORMAT C C....................................................................... C C Decision whether RVAL can be written as integer not exceeding 9 C digits, with relative rounding error up to 0.0000005: IF(-999999999.LE.NINT(RVAL).AND.NINT(RVAL).LE.999999999.AND. * ABS(FLOAT(NINT(RVAL))-RVAL).LE.0.0000005*ABS(RVAL)) THEN C The real number will be written in integer format CALL WSEPI(LINE,NAME,NINT(RVAL)) ELSE C The real number will be written in floating-point format C C Output format: FORMAT='(G12.6)' FORMAT(3:3)=CHAR(ICHAR('0')+NWIDTH/10) FORMAT(4:4)=CHAR(ICHAR('0')+MOD(NWIDTH,10)) C WRITE(TEXT,FORMAT) RVAL DO 11 J=1,NWIDTH IF(TEXT(J:J).NE.' ') THEN GO TO 12 END IF 11 CONTINUE 12 CONTINUE I=LENGTH(NAME)+3 IF(I+LENGTH(TEXT(J:)).GT.LEN(LINE)) THEN C SEP-05 CALL ERROR('SEP-05 in WSEPR: Too small output string') END IF LINE(1:2)=' ' LINE(3:I-1)=NAME LINE(I:I)='=' LINE(I+1:)=TEXT(J:) END IF RETURN END C C======================================================================= C C C SUBROUTINE WSEPI(LINE,NAME,IVAL) CHARACTER*(*) LINE,NAME INTEGER IVAL C C Subroutine designed to write the value of a given integer C parameter into the output string. C C Input: C NAME... String containing the name of the parameter. C IVAL... Value of the parameter. C C Output: C LINE... String containing a space followed by the NAME=IVAL C couple. C C----------------------------------------------------------------------- C EXTERNAL LENGTH INTEGER LENGTH C C----------------------------------------------------------------------- C C NWIDTH is the maximum width of the output integer in characters. C INTEGER NWIDTH,I,J PARAMETER (NWIDTH=12) CHARACTER*(NWIDTH) TEXT CHARACTER*5 FORMAT C C Output format: FORMAT='(I00)' FORMAT(3:3)=CHAR(ICHAR('0')+NWIDTH/10) FORMAT(4:4)=CHAR(ICHAR('0')+MOD(NWIDTH,10)) C WRITE(TEXT,FORMAT) IVAL DO 11 J=1,NWIDTH IF(TEXT(J:J).NE.' ') THEN GO TO 12 END IF 11 CONTINUE 12 CONTINUE I=LENGTH(NAME)+3 IF(I+LENGTH(TEXT(J:)).GT.LEN(LINE)) THEN C SEP-06 CALL ERROR('SEP-06 in WSEPI: Too small output string') END IF LINE(1:2)=' ' LINE(3:I-1)=NAME LINE(I:I)='=' LINE(I+1:)=TEXT(J:) RETURN END C C======================================================================= C C C SUBROUTINE WSEPT(LINE,NAME,TVAL) CHARACTER*(*) LINE,NAME,TVAL C C Subroutine designed to write the value of a given text-valued C parameter into the output string. C C Input: C NAME... String containing the name of the parameter. C TVAL... Value of the parameter. C C Output: C LINE... String containing a space followed by the NAME=TVAL C couple. C C----------------------------------------------------------------------- C EXTERNAL LENGTH INTEGER LENGTH C C----------------------------------------------------------------------- C C NWIDTH is the maximum width of the output integer in characters. C INTEGER I,J C LINE=' ' I=LENGTH(NAME)+3 J=LENGTH(TVAL) IF(I+2+J.GT.LEN(LINE)) THEN C SEP-08 CALL ERROR('SEP-08 in WSEPT: Too small output string') END IF LINE(1:2)=' ' LINE(3:I-1)=NAME LINE(I:I+1)='=''' LINE(I+2:I+2+J-1)=TVAL(1:J) LINE(I+2+J:I+2+J)='''' RETURN END C C======================================================================= C C C SUBROUTINE WSEP3R(LU,NAME,RVAL) INTEGER LU CHARACTER*(*) NAME REAL RVAL C C Subroutine designed to write the value of a given real C parameter into the output file. C C Input: C LU... Logical unit number of the already open output file. C NAME... String containing the name of the parameter. C RVAL... Value of the parameter. C C No output. C C----------------------------------------------------------------------- C EXTERNAL LENGTH INTEGER LENGTH C C----------------------------------------------------------------------- C CHARACTER*80 LINE C CALL WSEPR(LINE,NAME,RVAL) WRITE(LU,'(A)') LINE(1:LENGTH(LINE)) RETURN END C C======================================================================= C C C SUBROUTINE WSEP3I(LU,NAME,IVAL) CHARACTER*(*) NAME INTEGER LU,IVAL C C Subroutine designed to write the value of a given integer C parameter into the output file. C C Input: C LU... Logical unit number of the already open output file. C NAME... String containing the name of the parameter. C IVAL... Value of the parameter. C C No output. C C----------------------------------------------------------------------- C EXTERNAL LENGTH INTEGER LENGTH C C----------------------------------------------------------------------- C CHARACTER*80 LINE C CALL WSEPI(LINE,NAME,IVAL) WRITE(LU,'(A)') LINE(1:LENGTH(LINE)) RETURN END C C======================================================================= C C C SUBROUTINE WSEP3T(LU,NAME,TVAL) CHARACTER*(*) NAME,TVAL INTEGER LU C C Subroutine designed to write the value of a given text-valued C parameter into the output file. C C Input: C LU... Logical unit number of the already open output file. C NAME... String containing the name of the parameter. C TVAL... Value of the parameter. C C No output. C C----------------------------------------------------------------------- C EXTERNAL LENGTH INTEGER LENGTH C C----------------------------------------------------------------------- C CHARACTER*80 LINE C CALL WSEPT(LINE,NAME,TVAL) WRITE(LU,'(A)') LINE(1:LENGTH(LINE)) RETURN END C C======================================================================= Csep.htm 0100666 0000765 0000765 00000013313 10061773474 011744 0 ustar bulant bulant
The history files are introduced according to the SEP (Stanford Exploration Project) history files, although there are some differences, especially in running the programs.
The history files are designed to contain both the data and the information how to execute the programs. The following items are recognized in the history files:
No other items are interpreted in this version. All text containing neither equals nor colons has thus the effect of comments.
If the DATA for a program (i.e., string right to the colon) contain a substring identical to the name of the history file, the program is assumed to read the history file. In such a case, only the PARAMETER=VALUE couples between the beginning of the history file and the "colon" instruction to execute the program are assumed to apply to the program. If there is more PARAMETER=VALUE couples for the same parameter in the history file, the last couple before the "colon" of the currently executed program takes preference. This convention enables to modify the data for the program by entering additional PARAMETER=VALUE couples and additional "colon" instructions to execute the programs within the same history file.
When executing the history file, it is copied line by line to the output history file. When a "colon" instruction to execute the program is encountered, the program is executed with the name of the output history file substituted for the name of the input history file in order to hide the PARAMETER=VALUE couples between the "colon" instruction and end of file to the program.
The history files may be executed by Perl script
go.pl. For example, history file
'file.h' may be executed by command
perl go.pl file.h
generating the output history file named 'file.out'.
If you wish to name the output history file, e.g., 'new.out',
the history file may be executed by command
perl go.pl file.h new.out
Perl interpreter should be available at www.perl.org
Example of the history file: corfun.h.
Examples of papers devoted to the description of history files (ordered chronologically):
Alphabetical list of input parameters of all programs.
sep.inc 0100666 0000765 0000765 00000003132 07401075504 011714 0 ustar bulant bulant CC INCLUDE 'sep.inc' C ------------------------------------------------------------------ INTEGER MPAR,MCHAR,MSET PARAMETER (MPAR=1000,MCHAR=80,MSET=10) CHARACTER*20 PAR(MPAR) CHARACTER*(MCHAR) VALUE(MPAR) INTEGER NPAR(0:MSET),NCHAR(MPAR),ISET,NSET COMMON /SEPT/ PAR,VALUE COMMON /SEPC/ NPAR,NCHAR,ISET,NSET SAVE /SEPT/,/SEPC/ C ------------------------------------------------------------------ C C MPAR... Maximum number of parameters to be specified. C If the parameter value is N-times redefined, the parameter C occupies N+1 storage locations. C MCHAR...Maximum length of the string describing the parameter C value. C MSET... Maximum number of parameter sets. C NSET... Number of currently specified parameter sets. C ISET... Index of the actual parameter set. C NPAR(I).Position of the last parameter of the set I in arrays PAR, C VALUE and NCHAR. (NPAR(I)-NPAR(I-1)) is the number C of currently specified parameters in the set I. C PAR... Names (identifiers) of currently specified parameters. C VALUE...Strings describing the values of currently specified C parameters. C NCHAR...Lengths of the strings describing the values of currently C specified parameters. C C Date: 2001, November 28 C Coded by Ludek Klimes C C======================================================================= Csep.pl 0100666 0000765 0000765 00000010363 06617240400 011557 0 ustar bulant bulant #!perl #
# # Subroutine file 'sep.pl' to read data in the form of the SEP header # or parameter files. # # Version: 5.20 # Date: 1998, November 2 # # Coded by: Ludek Klimes # Department of Geophysics, Charles University Prague, # Ke Karlovu 3, 121 16 Praha 2, Czech Republic, # E-mail: klimes@seis.karlov.mff.cuni.cz # #....................................................................... # # This file consists of the following PERL subroutines: # RSEP1...Subroutine designed to read a SEP-like parameter or header # file and to store the parameter names and values for # future use. # RSEP1 # RSEP3...Subroutine designed to read the value of a given text, # integer or real-valued parameter from a previously stored # contents of SEP-like parameter or header file. # RSEP3 # #....................................................................... # # # Form of the SEP (Stanford Exploration Project) parameter files: # Refer to Fortran file sep.for. # #======================================================================= # # # # Subroutine RSEP1($FILE) # ~~~~~~~~~~~~~~~~~~~~~~~ # Subroutine designed to read a SEP-like parameter or header file and to # store the parameter names and values for future use. # # Input: # $FILE...String containing the name of the input SEP parameter # file to be read. # If $FILE=' ', no action is done. # # No output. # #----------------------------------------------------------------------- # sub RSEP1 { package Sep; $FILE=$_[0]; # if ($FILE eq ' ') { @SEPSTR=(); } else { open(LU,"<$FILE"); # Reading the SEP file into string array @SEPSTR @SEPSTR=sinv.for 0100666 0000765 0000765 00000007236 07040004130 012114 0 ustar bulant bulant C SUBROUTINE 'SINV' OF THE IBM SCIENTIFIC SUBROUTINE PACKAGE. C C NOTE: TO CONFORM WITH THE FORTRAN77 STANDARD, DUMMY ARRAY DIMENSIONS C (1) HAVE BEEN CHANGED TO (*). C C .................................................................. C C SUBROUTINE SINV C C PURPOSE C INVERT A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX C C USAGE C CALL SINV(A,N,EPS,IER) C C DESCRIPTION OF PARAMETERS C A - UPPER TRIANGULAR PART OF THE GIVEN SYMMETRIC C POSITIVE DEFINITE N BY N COEFFICIENT MATRIX. C ON RETURN A CONTAINS THE RESULTANT UPPER C TRIANGULAR MATRIX. C N - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX. C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME- C TER N OR BECAUSE SOME RADICAND IS NON- C POSITIVE (MATRIX A IS NOT POSITIVE C DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI- C FICANCE) C IER=K - WARNING WHICH INDICATES LOSS OF SIGNIFI- C CANCE. THE RADICAND FORMED AT FACTORIZA- C TION STEP K+1 WAS STILL POSITIVE BUT NO C LONGER GREATER THAN ABS(EPS*A(K+1,K+1)). C C REMARKS C THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE C STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS. C IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU- C LAR MATRIX IS STORED COLUMNWISE TOO. C THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL C CALCULATED RADICANDS ARE POSITIVE. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C MFSD C C METHOD C SOLUTION IS DONE USING THE FACTORIZATION BY SUBROUTINE MFSD. C C .................................................................. C SUBROUTINE SINV(A,N,EPS,IER) C C DIMENSION A(*) DOUBLE PRECISION DIN,WORK C C FACTORIZE GIVEN MATRIX BY MEANS OF SUBROUTINE MFSD C A = TRANSPOSE(T) * T CALL MFSD(A,N,EPS,IER) IF(IER) 9,1,1 C C INVERT UPPER TRIANGULAR MATRIX T C PREPARE INVERSION-LOOP 1 IPIV=N*(N+1)/2 IND=IPIV C C INITIALIZE INVERSION-LOOP DO 6 I=1,N DIN=1.D0/DBLE(A(IPIV)) A(IPIV)=DIN MIN=N KEND=I-1 LANF=N-KEND IF(KEND) 5,5,2 2 J=IND C C INITIALIZE ROW-LOOP DO 4 K=1,KEND WORK=0.D0 MIN=MIN-1 LHOR=IPIV LVER=J C C START INNER LOOP DO 3 L=LANF,MIN LVER=LVER+1 LHOR=LHOR+L 3 WORK=WORK+DBLE(A(LVER)*A(LHOR)) C END OF INNER LOOP C A(J)=-WORK*DIN 4 J=J-MIN C END OF ROW-LOOP C 5 IPIV=IPIV-MIN 6 IND=IND-1 C END OF INVERSION-LOOP C C CALCULATE INVERSE(A) BY MEANS OF INVERSE(T) C INVERSE(A) = INVERSE(T) * TRANSPOSE(INVERSE(T)) C INITIALIZE MULTIPLICATION-LOOP DO 8 I=1,N IPIV=IPIV+I J=IPIV C C INITIALIZE ROW-LOOP DO 8 K=I,N WORK=0.D0 LHOR=J C C START INNER LOOP DO 7 L=K,N LVER=LHOR+K-I WORK=WORK+DBLE(A(LHOR)*A(LVER)) 7 LHOR=LHOR+L C END OF INNER LOOP C A(J)=WORK 8 J=J+K C END OF ROW- AND MULTIPLICATION-LOOP C 9 RETURN END C C======================================================================= C smeigen.for 0100666 0000765 0000765 00000024450 07472360104 012600 0 ustar bulant bulant C; close(LU) || die "Error when closing '$FILE'"; } } #======================================================================= # # # # Subroutine RSEP3($NAME,$OUT,$DEF) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Subroutine designed to read the value of a given text, integer or # real-valued parameter from a previously stored contents of SEP-like # parameter or header file. # # Input: # $NAME...String containing the name of the parameter. Except for # its case, it should match the parameter name in the input # SEP parameter file. # $DEF... Default value of the parameter. # # Output: # $OUT... Value of the parameter. # #----------------------------------------------------------------------- # sub RSEP3 { package Sep; $NAME=$_[0]; $DEF=$_[2]; #--------------------------------------------------------------------- # Converting the parameter name to the lowercase string to be searched $nameeq=' '."\L$NAME\E".'='; # # Setting the default value $OUT=$DEF; # # Loop over lines foreach $SEPSTR (@SEPSTR) { $i=index($SEPSTR,'#',0)-1; if ($i==-2) { $i=length($SEPSTR); } # Converting string $SEPSTR to lowercase $sepstr="\L$SEPSTR\E"; $i=rindex($sepstr,$nameeq,$i); if ($i>-1) { # Line contains string $nameeq $i=$i+length($nameeq); if (substr($SEPSTR,$i,1) eq "'") { # Parameter value is a string in apostrophes $i=$i+1; $j=index($SEPSTR,"'",$i); } elsif (substr($SEPSTR,$i,1) eq '"') { # Parameter value is a string in double quotes $i=$i+1; $j=index($SEPSTR,'"',$i); } else { # Parameter value is terminated by ' ' or ',' or end of line or '#' $j=index($SEPSTR,' ',$i); $k=index($SEPSTR,',',$i); if ($j<=-1 || ($k>-1 && $j>$k)) { $j=$k; } if ($j<=-1) { $j=length($SEPSTR)-1; } $k=index($SEPSTR,'#',0); if ($k>-1 && $j>$k) { $j=$k; } } $j=$j-$i; if ($j>0) { $OUT=substr($SEPSTR,$i,$j); } } } #--------------------------------------------------------------------- $_[1]=$OUT; } #======================================================================= 1; #
C Program SMEIGEN to read a symetric matrix SM1 and to compute general C matrix GM1 of its eigenvectors and diagonal matrix DM1 of its C eigenvalues. C C Version: 5.50 C Date: 2002, May 21 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows (and columns) of C matrices SM1, GM1, and DM1. C Default: M1=' ' means that the number is 1. C Filenames of the files with the matrices: C SM1='string' ... Name of the file containing the input matrix. C No default, 'SM1' must be specified and cannot be blank. C GM1='string' ... Name of the file containing general C matrix of eigenvectors of matrix SM1 (output). C Default: GM1=' ' (the matrix is not written). C DM1='string' ... Name of the file containing diagonal C matrix of eigenvalues of matrix SM1 (output). C Default: DM1=' ' (the matrix is not written). C If both GM1 and DM1 equal ' ', the program is stopped. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL SMEIG,SMBLO,EIGEN,ERROR,RSEP1,RSEP3T,RMAT,WMAT C SMEIG,SMBLO ... This file. C EIGEN ... File eigennr.for. C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C EXTERNAL IND,INDG INTEGER IND,INDG C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3 INTEGER M1,N,NN,NB,LU1,I1,I2,I3,I4,IBMI,IBMA,J2,J3 PARAMETER (LU1=1) C C----------------------------------------------------------------------- C C Reading the name of the file with the input data: WRITE(*,'(A)') '+SMEIGEN: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C SMEIGEN-01 CALL ERROR('SMEIGEN-01: SEP file not given') ENDIF C C Reading the dimension of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF N=M1 NN=M1*(M1+1)/2 MAXRAM=MRAM-2*N IF (2*NN+2*N*N+N+N+1+N+N.GT.MRAM) THEN C SMEIGEN-02 CALL ERROR('SMEIGEN-02: Small dimension MRAM of array RAM') C If possible, enlarge the dimension MRAM of array RAM in include C file ram.inc. END IF C C Reading the names of the files with the matrices: CALL RSEP3T('SM1',FILE1,' ') CALL RSEP3T('GM1',FILE2,' ') CALL RSEP3T('DM1',FILE3,' ') IF (FILE1.EQ.' ') THEN C SMEIGEN-03 CALL ERROR('SMEIGEN-03: Input file with matrix SM1 not given') ENDIF IF ((FILE2.EQ.' ').AND.(FILE3.EQ.' ')) THEN C SMEIGEN-04 CALL * ERROR('SMEIGEN-04: None of the output files GM1 or DM1 given') ENDIF C C Reading input matrix: CALL RMAT(LU1,FILE1,M1,0,RAM(MAXRAM-NN+1)) C WRITE(*,'(A)') '+SMEIGEN: Working... ' C C Identification of blocks: CALL SMBLO(RAM(MAXRAM-NN+1),N,NN,NB,IRAM(MAXRAM-NN-N)) C C Preparing array for results: DO 5, I1=MAXRAM-NN-N-1-N*N-N+1,MAXRAM-NN-N-1 RAM(I1)=0. 5 CONTINUE C C Computing the eigenvalues and the eigenvectors: DO 20, I1=1,NB C Current block: IBMI=IRAM(MAXRAM-NN-N+I1-1)+1 IBMA=IRAM(MAXRAM-NN-N+I1) C Moving the block to RAM(1): I4=0 DO 10, I2=IBMI,IBMA DO 8, I3=IBMI,I2 I4=I4+1 RAM(I4)=RAM(MAXRAM-NN+IND(I3,I2)) 8 CONTINUE 10 CONTINUE J2=IBMA-IBMI+1 J3=I2*(I2+1)/2 C Computing the eigenvalues and the eigenvectors: CALL SMEIG(RAM,J2,J3) C Moving the eigenvectors to RAM(MAXRAM-NN-N-1-N*N+1): I4=0 DO 14, I2=IBMI,IBMA DO 12, I3=IBMI,IBMA I4=I4+1 RAM(MAXRAM-NN-N-1-N*N+INDG(I3,I2,N))=RAM(J3+I4) 12 CONTINUE 14 CONTINUE C Moving the eigenvalues to RAM(MAXRAM-NN-N-1-N*N-N+1): DO 16, I4=1,J2 RAM(MAXRAM-NN-N-1-N*N-N+IBMI-1+I4)=RAM(J3+J2*J2+I4) 16 CONTINUE 20 CONTINUE C C Writing output matrix GM1: IF (FILE2.NE.' ') THEN CALL WMAT(LU1,FILE2,M1,M1,RAM(MAXRAM-NN-N-1-N*N+1)) ENDIF C Writing output matrix DM1: IF (FILE3.NE.' ') THEN CALL WMAT(LU1,FILE3,M1,1,RAM(MAXRAM-NN-N-1-N*N-N+1)) ENDIF WRITE(*,'(A)') '+SMEIGEN: Done. ' C STOP END C C======================================================================= C SUBROUTINE SMEIG(SM,N,NN) C C======================================================================= C Computes the eigenvectors and eigenvalues of symmetric matrix SM. INTEGER N,NN REAL SM(NN+N*N+N) C Input: SM ... input symmetric matrix C N ... number of rows (and columns) of the matrix C NN ... N*(N+1)/2 C Output: SM(NN+1) ... eigenvectors of the input matrix C SM(NN+N*N+1) ... eigenvalues of the input matrix INTEGER I C----------------------------------------------------------------------- CALL EIGEN(SM,SM(NN+1),N,0) DO 21 I=1,N SM(NN+N*N+I)=SM(I*(I+1)/2) 21 CONTINUE RETURN END C C======================================================================= C SUBROUTINE SMBLO(SM,N,NN,NB,IB) C C======================================================================= C Subroutine to find blocks of a symmetric matrix INTEGER N,NN,NB,IB(0:N) REAL SM(NN) C Input: SM ... symmetric matrix C N ... number of rows (and columns) of the matrix C NN ... N*(N+1)/2 C Output: NB ... number of blocks of the matrix C IB ... array with numbers of lines (and rows), at which C the blocks finish INTEGER I1,I2 EXTERNAL IND INTEGER IND C----------------------------------------------------------------------- C Initiating first block: NB=1 IB(0)=0 IB(1)=1 I1=0 10 CONTINUE C Loop for lines of the matrix: I1=I1+1 DO 20, I2=N,IB(NB)+1,-1 C Loop for rows of the line I1: IF (SM(IND(I1,I2)).NE.0.) THEN C The block is larger: IB(NB)=I2 GOTO 21 ENDIF 20 CONTINUE 21 CONTINUE IF (IB(NB).EQ.N) THEN C End of the search for blocks. RETURN ENDIF IF (IB(NB).EQ.I1) THEN C Block finished, continuing with the next block. NB=NB+1 IB(NB)=I1+1 ENDIF GOTO 10 END C======================================================================= INTEGER FUNCTION IND(I,J) INTEGER I,J C I ... Index of a line. C J ... Index of a row. IND=J*(J-1)/2+I RETURN END C======================================================================= INTEGER FUNCTION INDG(I,J,K) INTEGER I,J,K C I ... Index of a line. C J ... Index of a row. C K ... Number of lines. INDG=K*(J-1)+I RETURN END C C======================================================================= C INCLUDE 'forms.for' C forms.for INCLUDE 'error.for' C error.for INCLUDE 'length.for' C length.for INCLUDE 'sep.for' C sep.for INCLUDE 'eigennr.for' C eigennr.for INCLUDE 'indexx.for' C indexx.for of Numerical Recipes INCLUDE 'tred2.for' C tred2.for of Numerical Recipes INCLUDE 'tqli.for' C tqli.for of Numerical Recipes INCLUDE 'pythag.for' C pythag.for of Numerical Recipes C C======================================================================= Csmgm.for 0100666 0000765 0000765 00000015257 07277671010 012125 0 ustar bulant bulant C
C Program SMGM to compute product GM2=SM1*GM1 of symmetric matrix SM1 C and general matrix GM1. C C Version: 5.50 C Date: 2001, May 14 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows and columns of matrix SM1 C and rows of matrices GM1 and GM2. C Default: M1=' ' means that the number is 1. C M2='string'... Name of the file containing a single integer number C specifying the number of columns of matrices GM1 and GM2. C Default: M2=' ' means that the number is 1. C Filenames of the files with the matrices: C SM1='string' ... Name of the input file containing matrix SM1. C No default, 'SM1' must be specified and cannot be blank. C GM1='string' ... Name of the input file containing matrix GM1. C No default, 'GM1' must be specified and cannot be blank. C GM2='string' ... Name of the file containing matrix GM2 (output). C No default, 'GM2' must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3 INTEGER M1,M2,NA,NB,LU1,I1,I2,I3,J1,J2,J3 REAL CIJ PARAMETER (LU1=1) C----------------------------------------------------------------------- C C Reading a name of the file with the input data: WRITE(*,'(A)') '+SMGM: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C SMGM-01 CALL ERROR('SMGM-01: SEP file not given') ENDIF C C Reading the dimensions of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF CALL RSEP3T('M2',FILE1,' ') IF (FILE1.EQ.' ') THEN M2=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M2 CLOSE(LU1) ENDIF NA=M1*(M1+1)/2 NB=M1*M2 C IF (NA+NB+M1.GT.MRAM) THEN C SMGM-02 CALL ERROR('SMGM-02: Small dimension MRAM of array RAM') ENDIF C C Reading the names of the files with the matrices: CALL RSEP3T('SM1',FILE1,' ') CALL RSEP3T('GM1',FILE2,' ') CALL RSEP3T('GM2',FILE3,' ') IF (FILE1.EQ.' ') THEN C SMGM-03 CALL ERROR('SMGM-03: Input file with matrix SM1 not given.') ENDIF IF (FILE2.EQ.' ') THEN C SMGM-04 CALL ERROR('SMGM-04: Input file with matrix GM1 not given.') ENDIF IF (FILE3.EQ.' ') THEN C SMGM-05 CALL ERROR('SMGM-05: Output file with matrix GM2 not given.') ENDIF C C Reading input matrices: CALL RMAT(LU1,FILE1,M1,0,RAM) CALL RMAT(LU1,FILE2,M1,M2,RAM(NA+1)) C WRITE(*,'(A)') '+SMGM: Working... ' C C Multiplication: C Loop over columns: DO 10, I1=1,M2 J3=NA+NB C Loop over rows: DO 20, I2=1,M1 CIJ=0. J2=NA+M1*(I1-1) DO 30, I3=1,M1 C Element of the first matrix: IF (I3.LE.I2) THEN J1=I2*(I2-1)/2+I3 ELSE J1=I3*(I3-1)/2+I2 ENDIF C Element of the second matrix: J2=J2+1 CIJ=CIJ+RAM(J1)*RAM(J2) 30 CONTINUE J3=J3+1 RAM(J3)=CIJ 20 CONTINUE J2=NA+M1*(I1-1) J3=NA+NB C Loop over rows of the I1th column DO 21, I2=1,M1 J2=J2+1 J3=J3+1 RAM(J2)=RAM(J3) 21 CONTINUE 10 CONTINUE C C Writing output matrix: CALL WMAT(LU1,FILE3,M1,M2,RAM(NA+1)) WRITE(*,'(A)') '+SMGM: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Csminv.for 0100666 0000765 0000765 00000020471 07303642010 012274 0 ustar bulant bulant C
C Program SMINV to compute symmetric matrix SM2, which is inverse to C input symetric matrix SM1. C C Version: 5.50 C Date: 2000, October 20 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows (and columns) of symmetric C matrices SM1 and SM2. C Default: M1=' ' means that the number is 1. C Filenames of the files with the matrices: C SM1='string' ... Name of the input file containing matrix SM1. C No default, 'SM1' must be specified and cannot be blank. C SM2='string' ... Name of the output file containing symmetric C matrix SM2 which is inverse to matrix SM1. C No default, 'SM2' must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL SMBLO,IND,ERROR,RSEP1,RSEP3T,RMAT,WMAT,SINV INTEGER IND C SMBLO,IND ... This file. C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C SINV ... File sinv.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C CHARACTER*80 FILSEP,FILE1,FILE2 CHARACTER*49 TEXT INTEGER M1,N,NN,NB,LU1,I1,I2,I3,I4,IBMI,IBMA,IER PARAMETER (LU1=1) REAL EPS C C----------------------------------------------------------------------- EPS=0.000001 C C Reading a name of the file with the input data: WRITE(*,'(A)') '+SMINV: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C SMINV-01 CALL ERROR('SMINV-01: SEP file not given') ENDIF C C Reading the dimension of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF N=M1 NN=M1*(M1+1)/2 IF (3*NN+N+1.GT.MRAM) THEN C SMINV-02 CALL ERROR('SMINV-02: Small dimension MRAM of array RAM') END IF C C Reading the names of the files with the matrices: CALL RSEP3T('SM1',FILE1,' ') IF (FILE1.EQ.' ') THEN C SMINV-03 CALL ERROR('SMINV-03: Input file with matrix SM1 not given') ENDIF CALL RSEP3T('SM2',FILE2,' ') IF (FILE2.EQ.' ') THEN C SMINV-04 CALL ERROR('SMINV-04: Output file with matrix SM2 not given') ENDIF C C Reading input matrix: CALL RMAT(LU1,FILE1,M1,0,RAM(MRAM-NN+1)) C WRITE(*,'(A)') '+SMINV: Working... ' C C Identification of blocks: CALL SMBLO(RAM(MRAM-NN+1),N,NN,NB,IRAM(MRAM-NN-N)) C C Preparing array for results: DO 5, I1=MRAM-2*NN-N,MRAM-NN-N-1 RAM(I1)=0. 5 CONTINUE C C Computing the inverse matrix: DO 20, I1=1,NB C Current block: IBMI=IRAM(MRAM-NN-N+I1-1)+1 IBMA=IRAM(MRAM-NN-N+I1) C Moving the block to RAM(1): I4=0 DO 10, I2=IBMI,IBMA DO 8, I3=IBMI,I2 I4=I4+1 RAM(I4)=RAM(MRAM-NN+IND(I3,I2)) 8 CONTINUE 10 CONTINUE I2=IBMA-IBMI+1 I3=I2*(I2+1)/2 C Inverting matrix: CALL SINV(RAM,I2,EPS,IER) IF(IER.NE.0) THEN C SMINV-05 WRITE(TEXT,'(A,I5,A)') * 'SMINV-05: Error',IER,' in subroutine SINV' CALL ERROR(TEXT) ENDIF C Moving the block to RAM(MRAM-NN-N-1-NN+1): I4=0 DO 14, I2=IBMI,IBMA DO 12, I3=IBMI,I2 I4=I4+1 RAM(MRAM-2*NN-N-1+IND(I3,I2))=RAM(I4) 12 CONTINUE 14 CONTINUE 20 CONTINUE C C Writing output matrix R: IF (FILE2.NE.' ') THEN CALL WMAT(LU1,FILE2,M1,0,RAM(MRAM-2*NN-N)) ENDIF WRITE(*,'(A)') '+SMINV: Done. ' C STOP END C C======================================================================= C SUBROUTINE SMBLO(SM,N,NN,NB,IB) C C======================================================================= C Subroutine to find blocks of a symmetric matrix INTEGER N,NN,NB,IB(0:N) REAL SM(NN) C Input: SM ... symmetric matrix C N ... number of rows (and columns) of the matrix C NN ... N*(N+1)/2 C Output: NB ... number of blocks of the matrix C IB ... array with numbers of lines (and rows), at which C the blocks finish INTEGER I1,I2 EXTERNAL IND INTEGER IND C----------------------------------------------------------------------- C Initiating first block: NB=1 IB(0)=0 IB(1)=1 I1=0 10 CONTINUE C Loop for lines of the matrix: I1=I1+1 DO 20, I2=N,IB(NB)+1,-1 C Loop for rows of the line I1: IF (SM(IND(I1,I2)).NE.0.) THEN C The block is larger: IB(NB)=I2 GOTO 21 ENDIF 20 CONTINUE 21 CONTINUE IF (IB(NB).EQ.N) THEN C End of the search for blocks. RETURN ENDIF IF (IB(NB).EQ.I1) THEN C Block finished, continuing with the next block. NB=NB+1 IB(NB)=I1+1 ENDIF GOTO 10 END C======================================================================= INTEGER FUNCTION IND(I,J) INTEGER I,J C I ... Index of a line. C J ... Index of a row. IND=J*(J-1)/2+I RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for INCLUDE 'sinv.for' C sinv.for INCLUDE 'mfsd.for' C mfsd.for C C======================================================================= Csmpower.for 0100666 0000765 0000765 00000024434 07472107304 012650 0 ustar bulant bulant C
C Program SMPOWER to compute matrix SM2, which is POWER-th power of C input symetric matrix SM1. C C Version: 5.50 C Date: 2002, May 20 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows (and columns) of symmetric C matrices A and R. C Default: M1=' ' means that the number is 1. C Filenames of the files with the matrices: C SM1='string' ... Name of the input file containing symmetric C matrix SM1. C No default, 'SM1' must be specified and cannot be blank. C SM2='string' ... Name of the output file containing symmetric C matrix SM2=SM1**POWER. C No default, 'SM2' must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C Data specifying the power: C POWER=real ... Power of the matrix SM1. C Default: POWER=1. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL SMBLO,SMPOW,IND,ERROR,RSEP1,RSEP3T,RSEP3R,RMAT,WMAT,EIGEN INTEGER IND C SMBLO,SMPOW,IND ... This file. C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R ... C File sep.for. C RMAT,WMAT ... File forms.for. C EIGEN ... eigennr.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C CHARACTER*80 FILSEP,FILE1,FILE2 INTEGER M1,N,NN,NB,LU1,I1,I2,I3,I4,IBMI,IBMA PARAMETER (LU1=1) REAL POWER C C----------------------------------------------------------------------- C C Reading a name of the file with the input data: WRITE(*,'(A)') '+SMPOWER: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C SMPOWER-01 CALL ERROR('SMPOWER-01: SEP file not given') ENDIF C C Reading the dimension of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF N=M1 NN=M1*(M1+1)/2 MAXRAM=MRAM-2*N IF (3*NN+N*N+N+N+1+N+N.GT.MRAM) THEN C SMPOWER-02 CALL ERROR('SMPOWER-02: Small dimension MRAM of array RAM') C If possible, enlarge the dimension MRAM of array RAM in include C file ram.inc. ENDIF C C Reading the names of the files with the matrices: CALL RSEP3T('SM1',FILE1,' ') CALL RSEP3T('SM2',FILE2,' ') IF (FILE1.EQ.' ') THEN C SMPOWER-03 CALL ERROR('SMPOWER-03: Input file with matrix SM1 not given') ENDIF IF (FILE2.EQ.' ') THEN C SMPOWER-04 CALL ERROR('SMPOWER-04: Output file with matrix SM2 not given') ENDIF C C Reading input matrix: CALL RMAT(LU1,FILE1,M1,0,RAM(MAXRAM-NN+1)) C Reading the power: CALL RSEP3R('POWER',POWER,1.) C WRITE(*,'(A)') '+SMPOWER: Working... ' C C Identification of blocks: CALL SMBLO(RAM(MAXRAM-NN+1),N,NN,NB,IRAM(MAXRAM-NN-N)) C C Preparing array for results: DO 5, I1=MAXRAM-2*NN-N,MAXRAM-NN-N-1 RAM(I1)=0. 5 CONTINUE C C Computing the power: DO 20, I1=1,NB C Current block: IBMI=IRAM(MAXRAM-NN-N+I1-1)+1 IBMA=IRAM(MAXRAM-NN-N+I1) C Moving the block to RAM(1): I4=0 DO 10, I2=IBMI,IBMA DO 8, I3=IBMI,I2 I4=I4+1 RAM(I4)=RAM(MAXRAM-NN+IND(I3,I2)) 8 CONTINUE 10 CONTINUE I2=IBMA-IBMI+1 I3=I2*(I2+1)/2 C Computing the power: CALL SMPOW(RAM,I2,I3,POWER) C Moving the block to RAM(MAXRAM-NN-N-1-NN+1): I4=0 DO 14, I2=IBMI,IBMA DO 12, I3=IBMI,I2 I4=I4+1 RAM(MAXRAM-2*NN-N-1+IND(I3,I2))=RAM(I4) 12 CONTINUE 14 CONTINUE 20 CONTINUE C C Writing output matrix SM2: IF (FILE2.NE.' ') THEN CALL WMAT(LU1,FILE2,M1,0,RAM(MAXRAM-2*NN-N)) ENDIF WRITE(*,'(A)') '+SMPOWER: Done. ' C STOP END C C======================================================================= C SUBROUTINE SMPOW(SM,N,NN,POWER) C C======================================================================= C Computes the POWER-th power of symmetric matrix SM. INTEGER N,NN REAL SM(NN+N*N+N),POWER C Input: SM ... input symmetric matrix C N ... number of rows (and columns) of the matrix C NN ... N*(N+1)/2 C POWER ... the power C Output: SM ... the input matrix powered to POWER INTEGER I,J,I1,I2,I3 REAL AUX,SMMAX C----------------------------------------------------------------------- CALL EIGEN(SM,SM(NN+1),N,0) SMMAX=SM(1) DO 21 I=2,N SMMAX=AMAX1(SM(I*(I+1)/2),SMMAX) 21 CONTINUE DO 22 I=1,N AUX=SM(I*(I+1)/2) IF(AUX.LE.0.) THEN IF(ABS(AUX).GT.0.000001*SMMAX * .OR.(SMMAX.EQ.0..AND.POWER.LE.0.)) THEN C SMPOWER-05 CALL ERROR('SMPOWER-05: Eigenvalue not positive') ENDIF IF(POWER.LE.0.) THEN AUX=0.000001*SMMAX ELSE AUX=0. END IF END IF SM(NN+N*N+I)=AUX**POWER 22 CONTINUE DO 25 I=1,NN SM(I)=0. 25 CONTINUE DO 28 I3=1,N AUX=SM(NN+N*N+I3) J=NN+N*(I3-1) I=0 DO 27, I2=J+1,J+N DO 26, I1=J+1,I2 I=I+1 SM(I)=SM(I)+SM(I1)*SM(I2)*AUX 26 CONTINUE 27 CONTINUE 28 CONTINUE RETURN END C C======================================================================= C SUBROUTINE SMBLO(SM,N,NN,NB,IB) C C======================================================================= C Subroutine to find blocks of a symmetric matrix INTEGER N,NN,NB,IB(0:N) REAL SM(NN) C Input: SM ... symmetric matrix C N ... number of rows (and columns) of the matrix C NN ... N*(N+1)/2 C Output: NB ... number of blocks of the matrix C IB ... array with numbers of lines (and rows), at which C the blocks finish INTEGER I1,I2 EXTERNAL IND INTEGER IND C----------------------------------------------------------------------- C Initiating first block: NB=1 IB(0)=0 IB(1)=1 I1=0 10 CONTINUE C Loop for lines of the matrix: I1=I1+1 DO 20, I2=N,IB(NB)+1,-1 C Loop for rows of the line I1: IF (SM(IND(I1,I2)).NE.0.) THEN C The block is larger: IB(NB)=I2 GOTO 21 ENDIF 20 CONTINUE 21 CONTINUE IF (IB(NB).EQ.N) THEN C End of the search for blocks. RETURN ENDIF IF (IB(NB).EQ.I1) THEN C Block finished, continuing with the next block. NB=NB+1 IB(NB)=I1+1 ENDIF GOTO 10 END C======================================================================= INTEGER FUNCTION IND(I,J) INTEGER I,J C I ... Index of a line. C J ... Index of a row. IND=J*(J-1)/2+I RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for INCLUDE 'eigennr.for' C eigennr.for INCLUDE 'indexx.for' C indexx.for of Numerical Recipes INCLUDE 'tred2.for' C tred2.for of Numerical Recipes INCLUDE 'tqli.for' C tqli.for of Numerical Recipes INCLUDE 'pythag.for' C pythag.for of Numerical Recipes C C======================================================================= Csmsm.for 0100666 0000765 0000765 00000014410 07247110610 012116 0 ustar bulant bulant C
C Program SMSM to compute product GM1=SM1*SM2 of two symmetric matrices C SM1 and SM2 C C Version: 5.50 C Date: 2001, February 28 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows (and columns) of symmetric C matrices SM1, SM2 and general matrix GM1. C Default: M1=' ' means that the number is 1. C Filenames of the files with the matrices: C SM1='string' ... Name of the input file containing matrix SM1. C No default, 'SM1' must be specified and cannot be blank. C SM2='string' ... Name of the input file containing matrix SM2. C No default, 'SM2' must be specified and cannot be blank. C GM1='string' ... Name of the output file containing general C matrix GM1=SM1*SM2. C No default, 'GM1' must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3 INTEGER M1,NN,LU1,I1,I2,I3,J1,J2,J3 REAL CIJ PARAMETER (LU1=1) C C----------------------------------------------------------------------- C C Reading a name of the file with the input data: FILSEP=' ' WRITE(*,'(A)') '+SMSM: Enter input filename: ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C SMSM-01 CALL ERROR('SMSM-01: SEP file not given') ENDIF C C Reading the dimension of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF NN=M1*(M1+1)/2 C IF (2*NN+M1*M1.GT.MRAM) THEN C SMSM-02 CALL ERROR('SMSM-02: Small dimension MRAM of array RAM') END IF C C Reading the names of the files with the matrices: CALL RSEP3T('SM1',FILE1,' ') CALL RSEP3T('SM2',FILE2,' ') CALL RSEP3T('GM1',FILE3,' ') IF (FILE1.EQ.' ') THEN C SMSM-03 CALL ERROR('SMSM-03: Input file with matrix SM1 not given') ENDIF IF (FILE2.EQ.' ') THEN C SMSM-04 CALL ERROR('SMSM-04: Input file with matrix SM2 not given') ENDIF IF (FILE3.EQ.' ') THEN C SMSM-05 CALL ERROR('SMSM-05: Output file with matrix GM1 not given') ENDIF C C Reading input matrices: CALL RMAT(LU1,FILE1,M1,0,RAM) CALL RMAT(LU1,FILE2,M1,0,RAM(NN+1)) C WRITE(*,'(A)') '+SMSM: Working... ' C C Multiplication: J3=2*NN C Loop over columns: DO 10, I1=1,M1 C Loop over lines: DO 20, I2=1,M1 J3=J3+1 CIJ=0. DO 30, I3=1,M1 C Element of the first matrix: IF (I3.LE.I2) THEN J1=I2*(I2-1)/2+I3 ELSE J1=I3*(I3-1)/2+I2 ENDIF C Element of the second matrix: IF (I3.LE.I1) THEN J2=NN+I1*(I1-1)/2+I3 ELSE J2=NN+I3*(I3-1)/2+I1 ENDIF CIJ=CIJ+RAM(J1)*RAM(J2) 30 CONTINUE RAM(J3)=CIJ 20 CONTINUE 10 CONTINUE C C Writing output matrix GM1: IF (FILE3.NE.' ') THEN CALL WMAT(LU1,FILE3,M1,M1,RAM(2*NN+1)) ENDIF WRITE(*,'(A)') '+SMSM: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Csmsmsm.for 0100666 0000765 0000765 00000015772 07277147410 012505 0 ustar bulant bulant C
C Program SMSMSM to compute product SM3=SM1*SM2*SM1 of symmetric C matrices SM1 and SM2. C C Version: 5.50 C Date: 2001, May 12 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows (and columns) of symmetric C matrices SM1, SM2 and SM3. C Default: M1=' ' means that the number is 1. C Filenames of the files with the matrices: C SM1='string'... Name of the file containing matrix SM1 (input). C No default, SM1 must be specified and cannot be blank. C SM2='string'... Name of the file containing matrix SM2 (input). C No default, SM2 must be specified and cannot be blank. C SM3='string'... Name of the file containing symmetric C matrix SM3=SM1*SM2*SM1 (output). C No default, SM3 must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3 INTEGER LU1,M1,I0,I1,I2,J0,J1,J2 PARAMETER (LU1=1) REAL AUX C C----------------------------------------------------------------------- C C Reading a name of the file with the input data: WRITE(*,'(A)') '+SMSMSM: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C SMSMSM-01 CALL ERROR('SMSMSM-01: SEP file not given') ENDIF C C Reading the dimension of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF C C Memory for 3 general matrices GM1, GM2 and GM3: IF (3*M1*M1.GT.MRAM) THEN C SMSMSM-02 CALL ERROR('SMSMSM-02: Small dimension MRAM of array RAM') END IF C C Reading the names of the files with the matrices: CALL RSEP3T('SM1',FILE1,' ') CALL RSEP3T('SM2',FILE2,' ') CALL RSEP3T('SM3',FILE3,' ') IF (FILE1.EQ.' ') THEN C SMSMSM-03 CALL ERROR('SMSMSM-03: Input file with matrix SM1 not given.') ENDIF IF (FILE2.EQ.' ') THEN C SMSMSM-04 CALL ERROR('SMSMSM-04: Input file with matrix SM2 not given.') ENDIF IF (FILE3.EQ.' ') THEN C SMSMSM-05 CALL ERROR('SMSMSM-05: Output file with matrix SM3 not given.') ENDIF C C Reading input matrices: C Reading SM1 CALL RMAT(LU1,FILE1,M1,0,RAM(2*M1*M1+1)) C Storing SM1 (RAM index J0) as GM1 (RAM indices J1 and J2) J0=2*M1*M1 DO 12 I2=1,M1 J1=M1*(I2-1) J2=I2-M1 DO 11 I1=1,I2 J0=J0+1 J1=J1+1 J2=J2+M1 AUX=RAM(J0) RAM(J1)=AUX RAM(J2)=AUX 11 CONTINUE 12 CONTINUE C Reading SM2 CALL RMAT(LU1,FILE2,M1,0,RAM(2*M1*M1+1)) C Storing SM2 (RAM index J0) as GM2 (RAM indices J1 and J2) J0=2*M1*M1 DO 22 I2=1,M1 J1=M1*M1+M1*(I2-1) J2=M1*M1+I2-M1 DO 21 I1=1,I2 J0=J0+1 J1=J1+1 J2=J2+M1 AUX=RAM(J0) RAM(J1)=AUX RAM(J2)=AUX 21 CONTINUE 22 CONTINUE WRITE(*,'(A)') '+SMSMSM: Working... ' C C Multiplication: C Storing GM2*GM1 as GM3 DO 32 I2=1,M1 DO 31 I1=1,M1 J1=M1*M1+M1*(I1-1) J2= M1*(I2-1) AUX=0. DO 30 I0=1,M1 J1=J1+1 J2=J2+1 AUX=AUX+RAM(J1)*RAM(J2) 30 CONTINUE RAM(2*M1*M1+M1*(I2-1)+I1)=AUX 31 CONTINUE 32 CONTINUE C Storing SM3=GM1*GM3 in place of GM2 DO 42 I2=1,M1 DO 41 I1=1,I2 J1= M1*(I1-1) J2=2*M1*M1+M1*(I2-1) AUX=0. DO 40 I0=1,M1 J1=J1+1 J2=J2+1 AUX=AUX+RAM(J1)*RAM(J2) 40 CONTINUE RAM(M1*M1+I2*(I2-1)/2+I1)=AUX 41 CONTINUE 42 CONTINUE C C Writing output matrix SM3: CALL WMAT(LU1,FILE3,M1,0,RAM(M1*M1+1)) WRITE(*,'(A)') '+SMSMSM: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Csp.for 0100666 0000765 0000765 00000231541 10062244274 011572 0 ustar bulant bulant C
C Program SP (Seismogram Plotting) to plot seismograms previously stored C in the GSE data exchange format. C C Version: 5.80 C Date: 2004, June 11 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input files: C SS='string'... String with the name of the input data file in the C GSE data exchange format, containing the seismograms to be C plotted. C If the source names are specified in the comment lines C of the GSE file, the hypocentral coordinates of the C sources are taken, in the order of preference, from file C PTS (if the filename is specified), file SRC (if the C filename is specified), corresponding GSE file SS* (if C the coordinates are present), default to zeros. C If the source name is not specified in the comment lines C of the GSE file, the hypocentral coordinates of the C sources are taken, in the order of preference, from the C the first point in file SRC (if the filename is C specified), GSE file SS (if the coordinates are C present), default to zeros. C The coordinates of the receivers are taken, in the order C of preference, from file PTS (if the filename is C specified), file REC (if the filename is specified), C GSE file SS. C The source and receiver names cannot be longer than C 6 characters. C Description of GSE file SS C Default: SS='ss.gse' C SS1='string', SS2='string', ..., SS9='string'... Strings with the C additional, optional names of the input data files in the C GSE data exchange format, containing the seismograms to be C plotted simultaneously with seismograms given by parameter C SS into the same figures. The order of plottting is SS, C SS1, SS2, ..., SS9, considering just nonblank filenames. C The seismograms are plotted in colours given by parameters C KOLOR, KOLOR1, KOLOR2, ..., KOLOR9, respectively. Refer C to file calcops.rgb for the C definitions of the colours. The frame and description C remain in colour number 1, which is probably black. C Defaults: SS1=' ', SS2=' ', SS3=' ', ..., SS9=' ' C SRC='string'... String with the name of the input data file C with the name(s) and coordinates of the hypocentre(s). C If specified, this file serves (a) to select the sources C for plotting seismograms, (b) to update the hypocentre C coordinates if PTS=' ' or if the source name is not C specified in the comment lines of the GSE file and file C PTS thus cannot be used. C If SRC is not blank and the source names are specified C comment lines of the GSE file, only seismograms C corresponding to the sources listed in file SRC will be C plotted, otherwise no selection according to the source C names is performed. C If the source names are specified in the comment lines C of the GSE file, the hypocentral coordinates of the C sources are taken, in the order of preference, from file C PTS (if the filename is specified), file SRC (if the C filename is specified), corresponding GSE file SS* (if C the coordinates are present), default to zeros. C If the source name is not specified in the comment lines C of the GSE file, the hypocentral coordinates are taken, C in the order of preference, from the the first point in C file SRC (if the filename is specified), corresponding C GSE file SS* (if the coordinates are present), default C to zeros. C The source names cannot be longer than 6 characters. C The hypocentral coordinates are used only for optional C travel-time reduction on a given velocity, or for C amplitude power scaling. File SRC thus usually need not C be specified if the seismograms are generated by programs C 'greenss.for' or 'ss.for', because those programs enter C the hypocentral coordinates directly to the comments of C the data section in GSE data exchange file. C Description of file SRC C Default: SRC=' ' C REC='string'... String with the name of the input data file C containing the list of receivers. C If specified, this file serves (a) to select the receivers C for plotting seismograms, (b) to update the receiver C coordinates if PTS=' '. C If REC=' ' seismograms at all receivers will be plotted, C otherwise only seismograms at the receivers listed in C file REC will be plotted. C The coordinates of the receivers are taken, in the order C of preference, from file PTS (if the filename is C specified), file REC (if the filename is specified), C corresponding GSE file SS*. C File REC also enables to determine the number NREC of all C receivers, in which the seimograms may be plotted, for C scaling purposes. If REC=' ', NREC=999 for scaling. C Only the first 6 characters of receiver names are C significant. C The receiver names cannot be longer than 6 characters. C In most cases, file REC will be the same as for the C calculation of synthetic seismograms. C Parameter REC has to be specified and cannot be blank if C KODESP=0, see below. If KODESP=0, the horizontal position C of a plotted seismogram corresponds to the position of the C corresponding receiver in file REC. C Description of file REC C Default: REC=' ' C FTT='string'... String with the name of the input data file C with the list of travel times to be highlighted. C The travel times are specified in dependence on the C source and receiver names. The coordinates of the source C and receivers are taken from file PTS. If PTS=' ', the C coordinates of the source are taken from file SRC and the C coordinates of receivers are taken from file REC. C If PTS=' ' and SRC=' ', the source coordinates are assumed C zero. If FTT.NE.' ' and PTS=' ', REC cannot be blank. C If FTT=' ', no travel times are highlighted. C Description of file FTT C Default: FTT=' ' C PTS='string'... String with the name of the input data file C with the coordinates corresponding to the source and C receiver names. Since this file is given just to specify C the coordinates, the coordinates from this file have the C highest priority. This feature is especially useful when C changing the coordinate system. The seismogram files C need not be changed and may preserve the old coordinates. C The same advantage applies to files SRC, REC and SPHILI. C The point names cannot be longer than 6 characters. C Description of file PTS C Default: PTS=' ' C SPHILI='string'... String with the name of the input data file C with the list of times to be highlighted. C The times are specified in dependence on the names and C coordinates of receivers. C If REC is not blank and the receiver names are specified C in file SPHILI, only times corresponding to the C receivers listed in file REC will be plotted, otherwise C no selection according to the receiver names is C performed. C The coordinates of the receivers are taken, in the order C of preference, from file PTS (if filename PTS is C specified and the point names in file SPHILI are not C blank), from file SPHILI. C If SPHILI=' ', no times are highlighted. C Description of file SPHILI C Default: SPHILI=' ' C Names of output files: C SP1='string'... String with the name of the first output C PostScript file, usually contaning the plot of the first C component of the seismograms. C If blank, the file is not created. C Default: SP1='ss1.gse' C SP2='string'... String with the name of the second output C PostScript file, usually contaning the plot of the second C component of the seismograms. C If blank, the file is not created. C Default: SP2='ss2.gse' C SP3='string'... String with the name of the third output C PostScript file, usually contaning the plot of the third C component of the seismograms. C If blank, the file is not created. C Default: SP3='ss3.gse' C Component selection (mostly not needed): C KOMP1=integer... Component of the seismograms of file given by C parameter SS, plotted into the output file given by C parameter SP1. C Default: KOMP1=1 C KOMP11=integer, KOMP12=integer, KOMP13=integer, KOMP14=integer, C KOMP15=integer, KOMP16=integer, KOMP17=integer, KOMP18=integer, C KOMP19=integer... Components of the seismograms of files given by C parameters SS1, SS2, SS3, SS4, SS5, SS6, SS7, SS8, SS9, C respectively, plotted into the output file given by C parameter SP1. C Defaults: KOMP11=KOMP1, KOMP12=KOMP1, KOMP13=KOMP1, C KOMP14=KOMP1, KOMP15=KOMP1, KOMP16=KOMP1, C KOMP17=KOMP1, KOMP18=KOMP1, KOMP19=KOMP1 C KOMP2=integer... Component of the seismograms of file given by C parameter SS, plotted into the output file given by C parameter SP2. Analogous to KOMP1. C Default: KOMP2=2 C KOMP21=integer, KOMP22=integer, KOMP23=integer, KOMP24=integer, C KOMP25=integer, KOMP26=integer, KOMP27=integer, KOMP28=integer, C KOMP29=integer... Analogous to KOMP11 to KOMP19, but for file SP2. C Defaults equal the value of KOMP2. C KOMP3=integer... Component of the seismograms of file given by C parameter SS, plotted into the output file given by C parameter SP3. Analogous to KOMP1. C Default: KOMP3=3 C KOMP31=integer, KOMP32=integer, KOMP33=integer, KOMP34=integer, C KOMP35=integer, KOMP36=integer, KOMP37=integer, KOMP38=integer, C KOMP39=integer... Analogous to KOMP11 to KOMP19, but for file SP2. C Defaults equal the value of KOMP3. C Data to control plotting: C Colours: C KOLOR=positive integer, KOLOR1=positive integer, C KOLOR2=positive integer, ..., KOLOR9=positive integer... Colours C to plot seismograms of files SS,SS1, SS2, ..., SS9, C respectively. Colour indices correspond to dummy C parameter INP of CalComp subroutine C NEWPEN. C The colours corresponding to the indices may be defined C or changed in file calcops.rgb. C Default: KOLOR=1, KOLOR1=2, KOLOR2=3, ..., KOLOR9=10 C KOLORTT=positive integer... Colour to plot the travel times of C optional file FTT. It is also used as the default colour C for optional file SPHILI. C Travel times are not plotted if KOLORTT is not positive. C Default: KOLORTT=1 C KOLORTD=integer... Colour to plot the error bar of optional file C FTT. It is also used as the default colour for optional C file SPHILI. C The error bar is not plotted if KOLORTD is negative. C If KOLORTD=0 (white), the contour of the rectangle is C plotted in colour KOLORTT. C Default: KOLORTD=0 C Data for the time axis (vertical): C SPTMIN=real... Time (or reduced time) corresponding to the bottom C of the seismogram plot. C Default: SPTMIN=0. C SPTMAX=real... Time (or reduced time) corresponding to the top of C the seismogram plot. C SPTMAX may be chosen smaller than SPTMIN to point the time C axis downwards. C Default: SPTMAX=1. C SPTLEN=positive real... Length of the vertical time axis in cm. C Default: SPTLEN=10. C SPTDIV=real... ABS(SPTDIV) is the number of intervals along the C time axis, starting at the bottom. Must be SPTDIV.NE.0. C SPTDIV.GT.0.: the marks at the endpoints of intervals will C be supplemented with corresponding times (or reduced C times). C SPTDIV.LT.0.: the time axis will have no description. C Default: SPTDIV=1. C SPTSUB=positive real... Number of subintervals to be marked in C each interval. Must be SPTSUB.GT.0. C Default: SPTSUB=1. C SPVRED=real... Reduction velocity. If non-zero, the time at each C receiver is reduced by the value of RR/SPVRED, where RR is C the hypocentral distance. C No time reduction is applied if SPVRED=0. C Default: SPVRED=0. C Data for the distance axis (horizontal): C KODESP=integer... Specifies the distribution and description of C seismograms in the plot. See the description of SPXMIN, C SPXMAX,SPYMIN,SPYMAX below. C Default: KODESP=0 C SPXMIN=real, SPXMAX=real, SPYMIN=real, SPYMAX=real: C For KODESP=0: Horizontal axis represents the index of the C receiver, corresponding to the receiver position in C the file given by parameter REC. C SPXMIN and SPXMAX are the receiver indices corresponding C to the lef-hand and right-hand sides of the frame. C Example: For default values SPXMIN=0 and SPXMAX=NREC+1, C where NREC is the number of receivers in file REC, the C horizontal axis is divided into NREC+1 intervals. C The seismogram at the Ith receiver is then plotted at C the endpoint of the Ith interval. C SPYMIN and SPYMAX have no meaning. C If SPXDIV.GT.0., the horizontal axis is denoted by the C names of the receivers corresponding to the plotted C seismograms, otherwise it has no description. C Parameter REC has to be specified and cannot be blank in C this case. C For KODESP=1: Horizontal axis represents the profile with C endpoints (X1,X2)=(SPXMIN,SPYMIN) and C (X1,X2)=(SPXMAX,SPYMAX), C situated in a horizontal plane. The seismograms are C located at the orthogonal projections of the receivers C onto the profile. If SPXDIV.GT.0., the horizontal axis C is supplemented with the values of the X1 coordinates. C For KODESP=2: Horizontal axis represents the profile with C endpoints (X1,X2)=(SPXMIN,SPYMIN) and C (X1,X2)=(SPXMAX,SPYMAX), C situated in a horizontal plane. The seismograms are C located at the orthogonal projections of the receivers C onto the profile. If SPXDIV.GT.0., the horizontal axis C is supplemented with the values of both X1 and X2 C coordinates. C For KODESP=3: Horizontal axis represents the vertical C profile with endpoints X3=SPXMIN and X3=SPXMAX. C The seismograms are located at the horizontal C projections of the receivers onto the profile. C If SPXDIV.GT.0., the horizontal axis is supplemented C with the values of X3 coordinate. C SPYMIN and SPYMAX have no meaning. C For KODESP=4: Horizontal axis represents the hypocentral C distance with endpoints RR=SPXMIN and RR=SPXMAX. C The seismograms are located according to the hypocentral C distances the receivers. C If SPXDIV.GT.0., the horizontal axis is supplemented C with the values of the hypocentral distance. C SPYMIN and SPYMAX have no meaning. C Default: SPXMIN=0., SPXMAX=NREC+1, SPYMIN=0., SPYMAX=0., C where NREC is the number of receivers in file REC. C SPXMIN1=real, SPXMIN2=real, SPXMIN3=real, SPXMIN4=real, C SPXMIN5=real, SPXMIN6=real, SPXMIN7=real, SPXMIN8=real, C SPXMIN9=real... Analogous to SPXMIN, but for files SS1 to SS9. C Do not influence the description of the horizontal axis C nor highlighting of times. C Usually need not be specified. C Defaults equal the value of SPXMIN. C SPXMAX1=real, SPXMAX2=real, SPXMAX3=real, SPXMAX4=real, C SPXMAX5=real, SPXMAX6=real, SPXMAX7=real, SPXMAX8=real, C SPXMAX9=real... Analogous to SPXMAX, but for files SS1 to SS9. C Do not influence the description of the horizontal axis C nor highlighting of times. C Usually need not be specified. C Defaults equal the value of SPXMAX. C SPYMIN1=real, SPYMIN2=real, SPYMIN3=real, SPYMIN4=real, C SPYMIN5=real, SPYMIN6=real, SPYMIN7=real, SPYMIN8=real, C SPYMIN9=real... Analogous to SPYMIN, but for files SS1 to SS9. C Do not influence the description of the horizontal axis C nor highlighting of times. C Usually need not be specified. C Defaults equal the value of SPYMIN. C SPYMAX1=real, SPYMAX2=real, SPYMAX3=real, SPYMAX4=real, C SPYMAX5=real, SPYMAX6=real, SPYMAX7=real, SPYMAX8=real, C SPYMAX9=real... Analogous to SPYMAX, but for files SS1 to SS9. C Do not influence the description of the horizontal axis C nor highlighting of times. C Usually need not be specified. C Defaults equal the value of SPYMAX. C SPXLEN=positive real... Length of the horizontal axis in cm. C Default: SPXLEN=FLOAT(NREC+1), where NREC is the number of C receivers in file REC. C SPXDIV=real... ABS(SPXDIV) is the number of intervals along the C horizontal axis, starting at the left. C Must be SPXDIV.NE.0. C SPXDIV.GT.0.: The marks at the endpoints of intervals will C be supplemented with the corresponding values. C SPXDIV.LT.0.: Horizontal axis will have no description. C Default: SPXDIV=1. C SPXSUB=positive real... Number of subintervals to be marked in C each interval. Must be SPXSUB.GT.0. C Default: SPXSUB=1. C Amplitude scaling: C NORMSP=integer... Type of amplitude scaling: C NORMSP.LT.0: Like NORMSP=0, but the maximum amplitude is C calculated only over the plotted part of seismogram. C NORMSP.EQ.0: Maximum amplitude at each trace normalized to C the given value. C Simple and universal option. No other amplitude scaling C parameter usually needs to be specified for this option, C although the input parameters SPAMP and SPAMPi enable C for possible amplitude scaling. C Amplitude scale AA is C AA=SPAMPi*XD/AMAX C where AMAX is the maximum amplitude in each seismogram C and XD is the average distance between seismograms, i.e. C XD=SPXLEN/(NREC+1), where NREC is the number of C receivers in file REC. The receiver file given by input C parameter REC is thus required to determine NREC. C NORMSP.GT.0: All seismograms have the same scaling or C power scaling. C Amplitude scale AA is C AA=SPAMPi*(RR/SPDIST)**SPOWER C where SPDIST is the hypocentral distance of the receiver C under consideration. C Default: NORMSP=0 C SPAMP=real... Amplitude scale for all 3 components. C Default: SPAMP=1. C SPAMP1=real, SPAMP2=real, ..., SPAMP9=real... Amplitude scales C SPAMP individually set for optional input GSE files C given by parameters SS1, SS2, ..., SS9, respectively. C Defaults: SPAMP1=SPAMP, SPAMP2=SPAMP, ..., SPAMP9=SPAMP C SPAMPX1=real, SPAMPX2=real, SPAMPX3=real... Amplitude scale C multiplicative factors for individual output files SP1, C SP2 and SP3, usually corresponding to different C components. C SPAMP will be multiplied by SPAMPX1 for file SP1 (usually C component 1), by SPAMPX2 for file SP1 (usually component C 2), by SPAMPX3 for file SP1 (usually component 3). C Default: SPAMPX1=1, SPAMPX2=1, SPAMPX3=1 C SPOWER=real... Exponent of the amplitude power scaling. C Need not be specified if power scaling is not required. C Has no meaning if NORMSP.LE.0. C Default: SPOWER=0. C SPOWER1=real, SPOWER2=real, ..., SPOWER9=real... Exponents of the C amplitude power scaling for optional input GSE files C given by parameters SS1, SS2, ..., SS9, respectively. C Defaults: SPOWER1=SPOWER, SPOWER2=SPOWER, ..., C SPOWER9=SPOWER C SPDIST=real... Reference hypocentral distance for the amplitude C power scaling. C Need not be specified if power scaling is not required. C Has no meaning if NORMSP.LE.0 or SPOWER=0. C Default: SPDIST=1. C SPEXP=real, SPEXPT=real... Exponential scaling of seismograms with C respect to time. The amplitude scale is multiplied by the C factor of EXP(SPEXP*(t-SPEXPT)). C Example 1: Exponential scaling with SPEXP=pi*F/Q, where C F is the dominant frequency and Q is the quality factor, C may roughly compensate for attenuation when plotting C late arrivals. C Example 2: Exponential scaling with SPEXP equal to half C the sum of the positive Lyapunov exponents may C compensate for large geometrical spreading when plotting C late arrivals. C Default: SPEXP=0., SPEXPT=0. C SPEXP1=real, SPEXP2=real, ..., SPEXP9=real... Exponential scaling C set individually for optional input GSE files given by C parameters SS1, SS2, ..., SS9, respectively. C Defaults: SPEXP1=SPEXP, SPEXP2=SPEXP, ..., SPEXP9=SPEXP C Other data to control plotting: C SPTEXT1='string'... Text to be written above the left-hand top C corner of the frame. C Default: SPTEXT1=' ' C SPTEXT2='string'... Text to be written above the right-hand top C corner of the frame. C Default: SPTEXT2=' ' C SPTEXT3='string'... Text to be written below the frame. C Default: SPTEXT3=' ' C SPTEXT4='string'... Text to be written below text SPTEXT3. C Default: SPTEXT4=' ' C SPCHRH=real... Character height in cm. C Default: SPCHRH=0.4 C SPHIWI=real... Width of the highlighted area when plotting travel C times. C Default: SPHIWI=XD, C where XD is the average distance between seismograms, C i.e. XD=SPXLEN/(NREC+1), where NREC is the number of C receivers in file REC, see the amplitude scaling. C C C Input GSE files SS* with the seismograms to plot: C File in the GSE data exchange format, see the description in file C 'gse.for'. C The 'sp.for' program is looking in the comment lines of the C waveform identification section for the source name identified by C string 'NAMESRC', and for the hypocentral coordinates identified C by strings 'X1SRC', 'X2SRC' and 'X3SRC'. C Description of format GSE C C C Input file SRC with the hypocentral coordinates: C (1) / C None to 20 character strings terminated by a slash. C (2) 'SRCNAME',X1SRC,X2SRC,X3SRC,/ C 'SRCNAME'... Name of the source. Used only if the comment lines C of the GSE file contain the source name. C The source names cannot be longer than 6 characters. C X1SRC,X2SRC,X3SRC... Coordinates of the hypocentre. C Default: X1SRC=0., X2SRC=0., X3SRC=0. C C C Input file REC containing receiver coordinates: C (1) Several strings terminated by / (a slash). C The simplest way is to submit just the /. C (2) Several times (2.1): C (2.1) 'NAMER(IR)',X1REC(IR),X2REC(IR),X3REC(IR),/ C 'NAMER(IR)'... String containing the name of the receiver. C The receiver names cannot be longer than 6 characters. C The limitation of the receiver names to 6 characters is C imposed by the GSE standard. C X1REC(IR),X2REC(IR),X3REC(IR)... Coordinates of the receiver. C The coordinates need not be present in the file. It may C thus be comfortable to omit them if preparing the list for C the selection of particular receivers for seismogram C plotting. C Default: X1REC(IR)=0, X2REC(IR)=0, X3REC(IR)=0. C (3) / (a slash). C C C Input file SPHILI containing travel times to highlight: C (1) Several strings terminated by / (a slash). C The simplest way is to submit just the /. C (2) Several times (2.1): C (2.1) 'NAMER(IR)',X1REC(IR),X2REC(IR),X3REC(IR),TT,TTERR,K1,K2,/ C 'NAMER(IR)',X1REC(IR),X2REC(IR),X3REC(IR)... Same meaning as in C the receiver file above. C TT... Travel time. If given, it will be plotted as horizontal C line of width SPHIWI and colour K1. It is plotted after C the frame and the corresponding error bar, but before C seismograms. C TTERR...Travel time error. If given, it will be plotted as C a solid rectangle of width SPHIWI and colour K2. It is C plotted after the frame but before the corresponding C travel time and before seismograms. C K1... Colour to plot the travel time. The travel time is not C plotted if K1 is not positive. C K2... Colour to plot the error bar. The error bar is not C plotted if K2 is negative. If K2=0 (white), the contour C of the rectangle is plotted in colour K1. C Default: X1REC(IR)=0, X2REC(IR)=0, X3REC(IR)=0., K1=KOLORTD, C K2=KOLORTD C (3) / (a slash). C C....................................................................... C C This Fortran77 file consists of the following external procedures: C SP... Main program to read and plot the seismograms. C SP C FRAME...Subroutine called by the main to plot the rectangular C frame around the seismograms and supplement it with simple C descriptions. C FRAME C C Other external procedures required: C RGSE1,RGSE2... Subroutines of the Fortran 77 file 'gse.for' C (package MODEL), designed to read seismograms in the GSE C data exchange format. C PLOTS,PLOT,SYMBOL,NUMBER... CALCOMP plotting subroutines. For C example, Fortran 77 routines of file 'calcops.for' C (package MODEL) may be used to generate seismogram plots C in the PostScript files. C C======================================================================= C C C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (RAM,IRAM) C C Allocation of working arrays: INTEGER MPTS,MSS PARAMETER (MPTS=3000,MSS=MRAM-3*MPTS) CHARACTER*6 PTS(MPTS) COMMON/PTSC/PTS C C----------------------------------------------------------------------- C C External functions and subroutines: EXTERNAL LENGTH INTEGER LENGTH C C Input and output data filenames and logical unit numbers: INTEGER LU,LUPAR PARAMETER (LU=1,LUPAR=2) CHARACTER*80 FILSEP,FILPAR,FILPTS,FILSRC,FILREC,FILFTT,FILHIL CHARACTER*80 FILOLD(0:9),FILESS(0:9),FILEPS(3) C C Storing seismograms in memory INTEGER IFILO(0:9),IFILE(0:9),ISSRAM(0:10) C IFILO(I:I)... Index of the data corresponding to file FILOLD(I:I). C IFILE(I:I)... Index of the data corresponding to file FILESS(I:I). C ISSRAM(IFILE:IFILE)... End of IFILEth data stored in RAM. C C Parameters and small working arrays: REAL UNDEF PARAMETER (UNDEF=-999999.) INTEGER KOLOR(0:9),KOMP(0:9,3) INTEGER ISS,ISP REAL SPXMIN(0:9),SPXMAX(0:9),SPYMIN(0:9),SPYMAX(0:9) REAL SPAMP(0:9,3),SPOWER(0:9),SPEXP(0:9) REAL SPAMPX(3),XPTS(4),YPTS(4) C CHARACTER*1 CHAN,TEXT CHARACTER*6 NAMSRC,NAMREC CHARACTER*80 NAMPTS C C Line of optional SEP parameter file or comments in the GSE file CHARACTER*80 LINE C C Data specifying labels in the plot: CHARACTER*80 TEXT1,TEXT2,TEXT3,TEXT4 CHARACTER*20 KXTEXT(5) C C Lists of point coordinates, sources and receivers: C INTEGER NPTS,NSRC,NREC C DATA FILESS/10*' '/ DATA KXTEXT/' ','X1','X1','X3','HYPOCENTRAL DISTANCE'/ C C....................................................................... C C Reading name of SEP file with input data: FILSEP=' ' WRITE(*,'(A)') '+SP: Enter input filename: ' READ(*,*) FILSEP IF (FILSEP.EQ.' ') THEN C SP-01 CALL ERROR('SP-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading all data from the SEP file into the memory: CALL RSEP1(LU,FILSEP) WRITE(*,'(A)') '+SP: Working... ' C C Loop over SP executions in optional SP parameter file: CALL RSEP3T('SPPAR',FILPAR,' ') IF(FILPAR.NE.' ') THEN OPEN(LUPAR,FILE=FILPAR,STATUS='OLD') NSSRAM=0 ISSRAM(0)=0 END IF 100 CONTINUE IF(FILPAR.NE.' ') THEN C Loop over lines the SP parameter file 110 CONTINUE READ(LUPAR,'(A)',END=999) LINE CALL RSEP2(LINE) I=INDEX(LINE,'#') IF(I.EQ.0) THEN I=LENGTH(LINE) END IF I=INDEX(LINE(1:I),'sp:') IF(I.GT.1) THEN IF(LINE(I-1:I-1).NE.' ') THEN I=0 END IF END IF IF(I.EQ.0) GO TO 110 C SP execution is prescribed at the current positions in the SP C parameter file. C Copying filenames corresponding to the data stored in RAM: DO 111 I2=0,9 FILOLD(I2)=FILESS(I2) IFILO (I2)=IFILE (I2) 111 CONTINUE END IF C C Input and output filenames: CALL RSEP3T('SS' ,FILESS(0),'ss.gse') CALL RSEP3T('SS1',FILESS(1),' ') CALL RSEP3T('SS2',FILESS(2),' ') CALL RSEP3T('SS3',FILESS(3),' ') CALL RSEP3T('SS4',FILESS(4),' ') CALL RSEP3T('SS5',FILESS(5),' ') CALL RSEP3T('SS6',FILESS(6),' ') CALL RSEP3T('SS7',FILESS(7),' ') CALL RSEP3T('SS8',FILESS(8),' ') CALL RSEP3T('SS9',FILESS(9),' ') CALL RSEP3T('SP1',FILEPS(1),'ss1.ps') CALL RSEP3T('SP2',FILEPS(2),'ss2.ps') CALL RSEP3T('SP3',FILEPS(3),'ss3.ps') C### IF(FILPAR.EQ.' ') THEN ISS0=0 ELSE DO 129 I2=0,9 IF(FILOLD(I2).NE.' ') THEN DO 121 I1=0,9 IF(FILESS(I1).EQ.FILOLD(I2)) THEN GO TO 128 END IF 121 CONTINUE C Removing seismograms from the memory I=ISSRAM(IFILE(I2))-ISSRAM(IFILE(I2)-1) DO 122 I1=ISSRAM(IFILE(I2))+1,ISSRAM(NSSRAM) RAM(I1-I)=RAM(I1) 122 CONTINUE DO 123 I1=IFILE(I2),NSSRAM ISSRAM(I1-1)=ISSRAM(I1)-I 123 CONTINUE NSSRAM=NSSRAM-1 DO 124 I1=I2+1,9 IF(FILOLD(I1).EQ.FILOLD(I2)) THEN FILOLD(I1)=' ' END IF 124 CONTINUE FILOLD(I2)=' ' 128 CONTINUE END IF 129 CONTINUE DO 139 I2=0,9 IF(FILESS(I2).NE.' ') THEN DO 131 I1=0,9 IF(FILESS(I2).EQ.FILOLD(I1)) THEN IFILE(I2)=IFILO(I1) GO TO 138 END IF 131 CONTINUE DO 132 I1=0,I2-1 IF(FILESS(I2).EQ.FILESS(I1)) THEN IFILE(I2)=IFILE(I1) GO TO 138 END IF 132 CONTINUE C Reading seismograms into the memory WRITE(*,'(2A)') '+SP: Reading ',FILESS(I2)(1:66) OPEN(LU,FILE=FILESS(I2),STATUS='OLD') CALL RGSE1(LU,TEXT) ISS0=ISSRAM(NSSRAM)+1 133 CONTINUE CALL RGSE2(LU,NAMREC,CHAN,I,X1R,X2R,X3R,T0,TD, * NSS,MSS-ISS0-22,RAM(ISS0+1)) IF(NSS.LE.-1) THEN C End of the GSE file GO TO 137 END IF 134 CONTINUE CALL RGSE2C(LINE,*135) CALL RSEP2(LINE) GO TO 134 135 CONTINUE CALL RSEP3T('NAMESRC',NAMSRC,' ') CALL RSEP3R('X1SRC',X1S,0.) CALL RSEP3R('X2SRC',X2S,0.) CALL RSEP3R('X3SRC',X3S,0.) CALL WRAM2(ISS0,NAMSRC,X1S,X2S,X3S, * NAMREC,X1R,X2R,X3R,I,T0,TD,NSS,IRAM,RAM) GO TO 133 137 CONTINUE NSSRAM=NSSRAM+1 ISSRAM(NSSRAM)=ISS0 IFILE(I2)=NSSRAM CLOSE(LU) 138 CONTINUE END IF 139 CONTINUE END IF C^^^ C Reading lists of point coordinates, sources and receivers: C Point coordinates NPTS=0 CALL RSEP3T('PTS',FILPTS,' ') IF(FILPTS.NE.' ') THEN OPEN(LU,FILE=FILPTS,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) DO 11 I=1,MPTS I0=MSS+3*I NAMPTS='$$$$$$$' RAM(I0-2)=0. RAM(I0-1)=0. RAM(I0 )=0. READ(LU,*,END=12) NAMPTS,RAM(I0-2),RAM(I0-1),RAM(I0) IF(NAMPTS(1:7).EQ.'$$$$$$$') THEN GO TO 12 END IF IF(NAMPTS(7:).NE.' ') THEN C SP-13 CALL ERROR('SP-13: Point name exceeds 6 characters') C Names of points in file given by input parameter PTS cannot C be longer than 6 characters. This limitation is imposed by C the GSE standard. END IF PTS(I)=NAMPTS(1:6) 11 CONTINUE C SP-02 CALL ERROR('SP-02: Array dimension MPTS small for points') 12 CONTINUE NPTS=I-1 CLOSE(LU) END IF C Sources NSRC=0 CALL RSEP3T('SRC',FILSRC,' ') IF(FILSRC.NE.' ') THEN OPEN(LU,FILE=FILSRC,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) DO 13 I=NPTS+1,MPTS I0=MSS+3*I NAMPTS='$$$$$$$' RAM(I0-2)=0. RAM(I0-1)=0. RAM(I0 )=0. READ(LU,*,END=14) NAMPTS,RAM(I0-2),RAM(I0-1),RAM(I0) IF(NAMPTS(1:7).EQ.'$$$$$$$') THEN GO TO 14 END IF IF(NAMPTS(7:).NE.' ') THEN C SP-14 CALL ERROR('SP-14: Source name exceeds 6 characters') C Names of sources in file given by input parameter SRC cannot C be longer than 6 characters. This is the limitation imposed C by the GSE standard on the receiver names and applied here C also to the source names. END IF PTS(I)=NAMPTS(1:6) 13 CONTINUE C SP-03 CALL ERROR('SP-03: Array dimension MPTS small for sources') 14 CONTINUE NSRC=I-NPTS-1 CLOSE(LU) END IF C Receivers NREC=0 RECNUM=999. CALL RSEP3T('REC',FILREC,' ') IF(FILREC.NE.' ') THEN OPEN(LU,FILE=FILREC,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) DO 15 I=NPTS+NSRC+1,MPTS I0=MSS+3*I NAMPTS='$$$$$$$' RAM(I0-2)=0. RAM(I0-1)=0. RAM(I0 )=0. READ(LU,*,END=16) NAMPTS,RAM(I0-2),RAM(I0-1),RAM(I0) IF(NAMPTS(1:7).EQ.'$$$$$$$') THEN GO TO 16 END IF IF(NAMPTS(7:).NE.' ') THEN C SP-15 CALL ERROR('SP-15: Receiver name exceeds 6 characters') C Names of receivers in file given by input parameter REC C cannot be longer than 6 characters. This limitation is C imposed by the GSE standard. END IF PTS(I)=NAMPTS(1:6) 15 CONTINUE C SP-04 CALL ERROR('SP-04: Array dimension MPTS small for points') 16 CONTINUE NREC=I-NPTS-NSRC-1 RECNUM=FLOAT(NREC) CLOSE(LU) END IF C C Components: CALL RSEP3I('KOMP1 ',KOMP(0,1),1) CALL RSEP3I('KOMP11',KOMP(1,1),KOMP(0,1)) CALL RSEP3I('KOMP12',KOMP(2,1),KOMP(0,1)) CALL RSEP3I('KOMP13',KOMP(3,1),KOMP(0,1)) CALL RSEP3I('KOMP14',KOMP(4,1),KOMP(0,1)) CALL RSEP3I('KOMP15',KOMP(5,1),KOMP(0,1)) CALL RSEP3I('KOMP16',KOMP(6,1),KOMP(0,1)) CALL RSEP3I('KOMP17',KOMP(7,1),KOMP(0,1)) CALL RSEP3I('KOMP18',KOMP(8,1),KOMP(0,1)) CALL RSEP3I('KOMP19',KOMP(9,1),KOMP(0,1)) CALL RSEP3I('KOMP2 ',KOMP(0,2),2) CALL RSEP3I('KOMP21',KOMP(1,2),KOMP(0,2)) CALL RSEP3I('KOMP22',KOMP(2,2),KOMP(0,2)) CALL RSEP3I('KOMP23',KOMP(3,2),KOMP(0,2)) CALL RSEP3I('KOMP24',KOMP(4,2),KOMP(0,2)) CALL RSEP3I('KOMP25',KOMP(5,2),KOMP(0,2)) CALL RSEP3I('KOMP26',KOMP(6,2),KOMP(0,2)) CALL RSEP3I('KOMP27',KOMP(7,2),KOMP(0,2)) CALL RSEP3I('KOMP28',KOMP(8,2),KOMP(0,2)) CALL RSEP3I('KOMP29',KOMP(9,2),KOMP(0,2)) CALL RSEP3I('KOMP3 ',KOMP(0,3),3) CALL RSEP3I('KOMP31',KOMP(1,3),KOMP(0,3)) CALL RSEP3I('KOMP32',KOMP(2,3),KOMP(0,3)) CALL RSEP3I('KOMP33',KOMP(3,3),KOMP(0,3)) CALL RSEP3I('KOMP34',KOMP(4,3),KOMP(0,3)) CALL RSEP3I('KOMP35',KOMP(5,3),KOMP(0,3)) CALL RSEP3I('KOMP36',KOMP(6,3),KOMP(0,3)) CALL RSEP3I('KOMP37',KOMP(7,3),KOMP(0,3)) CALL RSEP3I('KOMP38',KOMP(8,3),KOMP(0,3)) CALL RSEP3I('KOMP39',KOMP(9,3),KOMP(0,3)) C C Colours: CALL RSEP3I('KOLOR ',KOLOR(0),1) CALL RSEP3I('KOLOR1',KOLOR(1),2) CALL RSEP3I('KOLOR2',KOLOR(2),3) CALL RSEP3I('KOLOR3',KOLOR(3),4) CALL RSEP3I('KOLOR4',KOLOR(4),5) CALL RSEP3I('KOLOR5',KOLOR(5),6) CALL RSEP3I('KOLOR6',KOLOR(6),7) CALL RSEP3I('KOLOR7',KOLOR(7),8) CALL RSEP3I('KOLOR8',KOLOR(8),9) CALL RSEP3I('KOLOR9',KOLOR(9),10) CALL RSEP3I('KOLORTT',KOLORT,1) CALL RSEP3I('KOLORTD',KOLORD,0) C C Initial values for plotting frame: C Time axis: CALL RSEP3R('SPTMIN',SPTMIN, 0.) CALL RSEP3R('SPTMAX',SPTMAX, 1.) CALL RSEP3R('SPTLEN',SPTLEN,10.) CALL RSEP3R('SPTDIV',SPTDIV, 1.) CALL RSEP3R('SPTSUB',SPTSUB, 1.) CALL RSEP3R('SPVRED',SPVRED, 0.) C Distance axis: CALL RSEP3I('KODESP',KODESP, 0 ) CALL RSEP3R('SPXLEN',SPXLEN,RECNUM+1.) CALL RSEP3R('SPXDIV',SPXDIV, 1.) CALL RSEP3R('SPXSUB',SPXSUB, 1.) CALL RSEP3R('SPXMIN ',SPXMIN(0), 0.) CALL RSEP3R('SPXMIN1',SPXMIN(1),SPXMIN(0)) CALL RSEP3R('SPXMIN2',SPXMIN(2),SPXMIN(0)) CALL RSEP3R('SPXMIN3',SPXMIN(3),SPXMIN(0)) CALL RSEP3R('SPXMIN4',SPXMIN(4),SPXMIN(0)) CALL RSEP3R('SPXMIN5',SPXMIN(5),SPXMIN(0)) CALL RSEP3R('SPXMIN6',SPXMIN(6),SPXMIN(0)) CALL RSEP3R('SPXMIN7',SPXMIN(7),SPXMIN(0)) CALL RSEP3R('SPXMIN8',SPXMIN(8),SPXMIN(0)) CALL RSEP3R('SPXMIN9',SPXMIN(9),SPXMIN(0)) CALL RSEP3R('SPXMAX ',SPXMAX(0),RECNUM+1.) CALL RSEP3R('SPXMAX1',SPXMAX(1),SPXMAX(0)) CALL RSEP3R('SPXMAX2',SPXMAX(2),SPXMAX(0)) CALL RSEP3R('SPXMAX3',SPXMAX(3),SPXMAX(0)) CALL RSEP3R('SPXMAX4',SPXMAX(4),SPXMAX(0)) CALL RSEP3R('SPXMAX5',SPXMAX(5),SPXMAX(0)) CALL RSEP3R('SPXMAX6',SPXMAX(6),SPXMAX(0)) CALL RSEP3R('SPXMAX7',SPXMAX(7),SPXMAX(0)) CALL RSEP3R('SPXMAX8',SPXMAX(8),SPXMAX(0)) CALL RSEP3R('SPXMAX9',SPXMAX(9),SPXMAX(0)) CALL RSEP3R('SPYMIN ',SPYMIN(0), 0.) CALL RSEP3R('SPYMIN1',SPYMIN(1),SPYMIN(0)) CALL RSEP3R('SPYMIN2',SPYMIN(2),SPYMIN(0)) CALL RSEP3R('SPYMIN3',SPYMIN(3),SPYMIN(0)) CALL RSEP3R('SPYMIN4',SPYMIN(4),SPYMIN(0)) CALL RSEP3R('SPYMIN5',SPYMIN(5),SPYMIN(0)) CALL RSEP3R('SPYMIN6',SPYMIN(6),SPYMIN(0)) CALL RSEP3R('SPYMIN7',SPYMIN(7),SPYMIN(0)) CALL RSEP3R('SPYMIN8',SPYMIN(8),SPYMIN(0)) CALL RSEP3R('SPYMIN9',SPYMIN(9),SPYMIN(0)) CALL RSEP3R('SPYMAX ',SPYMAX(0), 0.) CALL RSEP3R('SPYMAX1',SPYMAX(1),SPYMAX(0)) CALL RSEP3R('SPYMAX2',SPYMAX(2),SPYMAX(0)) CALL RSEP3R('SPYMAX3',SPYMAX(3),SPYMAX(0)) CALL RSEP3R('SPYMAX4',SPYMAX(4),SPYMAX(0)) CALL RSEP3R('SPYMAX5',SPYMAX(5),SPYMAX(0)) CALL RSEP3R('SPYMAX6',SPYMAX(6),SPYMAX(0)) CALL RSEP3R('SPYMAX7',SPYMAX(7),SPYMAX(0)) CALL RSEP3R('SPYMAX8',SPYMAX(8),SPYMAX(0)) CALL RSEP3R('SPYMAX9',SPYMAX(9),SPYMAX(0)) C Characters: CALL RSEP3T('SPTEXT1',TEXT1,' ') CALL RSEP3T('SPTEXT2',TEXT2,' ') CALL RSEP3T('SPTEXT3',TEXT3,' ') CALL RSEP3T('SPTEXT4',TEXT4,' ') CALL RSEP3R('SPCHRH',SPCHRH, 0.4) C C Amplitude scaling: CALL RSEP3I('NORMSP',NORMSP,0) CALL RSEP3R('SPAMP ',SPAMP(0,1),1.) CALL RSEP3R('SPAMP1',SPAMP(1,1),SPAMP(0,1)) CALL RSEP3R('SPAMP2',SPAMP(2,1),SPAMP(0,1)) CALL RSEP3R('SPAMP3',SPAMP(3,1),SPAMP(0,1)) CALL RSEP3R('SPAMP4',SPAMP(4,1),SPAMP(0,1)) CALL RSEP3R('SPAMP5',SPAMP(5,1),SPAMP(0,1)) CALL RSEP3R('SPAMP6',SPAMP(6,1),SPAMP(0,1)) CALL RSEP3R('SPAMP7',SPAMP(7,1),SPAMP(0,1)) CALL RSEP3R('SPAMP8',SPAMP(8,1),SPAMP(0,1)) CALL RSEP3R('SPAMP9',SPAMP(9,1),SPAMP(0,1)) CALL RSEP3R('SPAMPX1',SPAMPX(1),1.) CALL RSEP3R('SPAMPX2',SPAMPX(2),1.) CALL RSEP3R('SPAMPX3',SPAMPX(3),1.) DO 18 I2=3,1,-1 DO 17 I1=0,9 SPAMP(I1,I2)=SPAMP(I1,1)*SPAMPX(I2) 17 CONTINUE 18 CONTINUE CALL RSEP3R('SPDIST' ,SPDIST,1.) CALL RSEP3R('SPOWER' ,SPOWER(0),0.) CALL RSEP3R('SPOWER1',SPOWER(1),SPOWER(0)) CALL RSEP3R('SPOWER2',SPOWER(2),SPOWER(0)) CALL RSEP3R('SPOWER3',SPOWER(3),SPOWER(0)) CALL RSEP3R('SPOWER4',SPOWER(4),SPOWER(0)) CALL RSEP3R('SPOWER5',SPOWER(5),SPOWER(0)) CALL RSEP3R('SPOWER6',SPOWER(6),SPOWER(0)) CALL RSEP3R('SPOWER7',SPOWER(7),SPOWER(0)) CALL RSEP3R('SPOWER8',SPOWER(8),SPOWER(0)) CALL RSEP3R('SPOWER9',SPOWER(9),SPOWER(0)) CALL RSEP3R('SPEXP ',SPEXP(0),0.) CALL RSEP3R('SPEXP1',SPEXP(1),SPEXP(0)) CALL RSEP3R('SPEXP2',SPEXP(2),SPEXP(0)) CALL RSEP3R('SPEXP3',SPEXP(3),SPEXP(0)) CALL RSEP3R('SPEXP4',SPEXP(4),SPEXP(0)) CALL RSEP3R('SPEXP5',SPEXP(5),SPEXP(0)) CALL RSEP3R('SPEXP6',SPEXP(6),SPEXP(0)) CALL RSEP3R('SPEXP7',SPEXP(7),SPEXP(0)) CALL RSEP3R('SPEXP8',SPEXP(8),SPEXP(0)) CALL RSEP3R('SPEXP9',SPEXP(9),SPEXP(0)) CALL RSEP3R('SPEXPT',SPEXPT,0.) C SSTMIN=AMIN1(SPTMIN,SPTMAX) SSTMAX=AMAX1(SPTMIN,SPTMAX) SCY= SPTLEN/(SPTMAX-SPTMIN) XA = SPXMAX(0)-SPXMIN(0) YA = SPYMAX(0)-SPYMIN(0) C C Higlighting given areas (e.g., travel times with error bars): CALL RSEP3T('FTT' ,FILFTT,' ') CALL RSEP3T('SPHILI',FILHIL,' ') CALL RSEP3R('SPHIWI',SPHIWI,SPXLEN/(RECNUM+1.)) C C....................................................................... C C Loop over 3 seismogram files: DO 99 ISP=1,3 IF(FILEPS(ISP).NE.' ') THEN WRITE(*,'(2A)') '+SP: Plotting ',FILEPS(ISP)(1:65) C C Initialization of CALCOMP: CALL PLOTN(FILEPS(ISP),0) CALL PLOTS(0,0,0) C C Plotting frame: CALL NEWPEN(1) IX = KODESP IT = -1 IF(KODESP.GE.3) IX=1 IF(SPXDIV.LT.0.) IX=0 IF(SPTDIV.LT.0.) IT=0 CALL FRAME(SPXLEN,SPTLEN,ABS(SPXDIV),SPXSUB, * ABS(SPTDIV),SPTSUB,0,IX,IT,SPCHRH, * SPXMIN(0),SPXMAX(0),KXTEXT(KODESP+1), * SPYMIN(0),SPYMAX(0),'X2', * SPTMIN,SPTMAX,'TIME', * TEXT1,0,0.,0,TEXT2,0,0.,0,TEXT3,TEXT4) C C Higlighting travel times of file FTT: IF(FILFTT.NE.' ') THEN OPEN(LU,FILE=FILFTT,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) C Loop for areas to highlight: 20 CONTINUE NAMSRC='$$$$$$' T0=0. TD=0. READ(LU,*,END=29) NAMSRC,NAMREC,T0,TD IF(NAMSRC.EQ.'$$$$$$') THEN C End of travel-time file GO TO 29 END IF C Selecting the receiver: IF(FILREC.NE.' ') THEN C Loop for receivers DO 21 I=NPTS+NSRC+1,NPTS+NSRC+NREC IF(PTS(I).EQ.NAMREC) THEN IREC=I-NPTS-NSRC GO TO 22 END IF 21 CONTINUE GO TO 20 END IF 22 CONTINUE C Selecting the source: IF(FILSRC.NE.' ') THEN C Loop for sources DO 23 I=NPTS+1,NPTS+NSRC IF(PTS(I).EQ.NAMSRC) GO TO 24 23 CONTINUE GO TO 20 END IF 24 CONTINUE C Finding the receiver coordinates: DO 25 I=1,NPTS IF(PTS(I).EQ.NAMREC) THEN I0=MSS+3*I X1R=RAM(I0-2) X2R=RAM(I0-1) X3R=RAM(I0) GO TO 26 END IF 25 CONTINUE C SP-05 LINE='SP-05: Receiver '//NAMREC(1:LENGTH(NAMREC)) * //' not found in file PTS' CALL ERROR(LINE) C If file FTT with travel times is given, file PTS has C to contain all receiver names of file REC (if REC is C specified) or all receiver names of file FTT (if C REC=' '). 26 CONTINUE C Finding the source coordinates: DO 27 I=1,NPTS IF(PTS(I).EQ.NAMSRC) THEN I0=MSS+3*I X1S=RAM(I0-2) X2S=RAM(I0-1) X3S=RAM(I0) GO TO 28 END IF 27 CONTINUE C SP-06 LINE='SP-06: Source '//NAMSRC(1:LENGTH(NAMSRC)) * //' not found in file PTS' CALL ERROR(LINE) C If file FTT with travel times is given, file PTS has C to contain all receiver names of file REC (if REC is C specified) or all receiver names of file FTT (if C REC=' '). 28 CONTINUE C Reduction of the travel time IF(SPVRED.NE.0.) THEN RR=SQRT((X1R-X1S)**2+(X2R-X2S)**2+(X3R-X3S)**2) T0=T0-RR/SPVRED END IF IF(KODESP.EQ.0) THEN IF(FILREC.EQ.' ') THEN C SP-07 CALL ERROR('SP-07: No receiver file specified') C For KODESP=0, filename REC must be specified in the C input data. END IF X=SPXLEN*(FLOAT(IREC)-SPXMIN(0)) * /(SPXMAX(0)-SPXMIN(0)) ELSE IF(KODESP.EQ.1.OR.KODESP.EQ.2) THEN X=SPXLEN*((X1R-SPXMIN(0))*XA+(X2R-SPYMIN(0))*YA) * /(XA*XA+YA*YA) ELSE IF(KODESP.EQ.3) THEN X=SPXLEN*(X3R-SPXMIN(0))/XA ELSE X=SPXLEN*(RR-SPXMIN(0))/XA END IF C Plotting the highlight: IF(KOLORD.GE.0) THEN XPTS(1)=X-0.5*SPHIWI XPTS(2)=X+0.5*SPHIWI XPTS(3)=X+0.5*SPHIWI XPTS(4)=X-0.5*SPHIWI YPTS(1)=SCY*(T0-TD-SPTMIN) YPTS(2)=SCY*(T0-TD-SPTMIN) YPTS(3)=SCY*(T0+TD-SPTMIN) YPTS(4)=SCY*(T0+TD-SPTMIN) IF(KOLORD.GT.0) THEN CALL NEWPEN(KOLORD) CALL FILL(XPTS,YPTS,4) ELSE CALL NEWPEN(KOLORT) CALL PLOT(XPTS(1),YPTS(1),3) CALL PLOT(XPTS(2),YPTS(2),2) CALL PLOT(XPTS(3),YPTS(3),2) CALL PLOT(XPTS(4),YPTS(4),2) CALL PLOT(XPTS(1),YPTS(1),2) END IF END IF IF(KOLORT.GT.0) THEN CALL NEWPEN(KOLORT) CALL PLOT(X-0.5*SPHIWI,SCY*(T0-SPTMIN),3) CALL PLOT(X+0.5*SPHIWI,SCY*(T0-SPTMIN),2) END IF GO TO 20 29 CONTINUE C Closing highlighting file CLOSE(LU) END IF C C Higlighting times given in file SPHILI: IF(FILHIL.NE.' ') THEN OPEN(LU,FILE=FILHIL,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) C Loop for areas to highlight: 30 CONTINUE NAMREC='$$$$$$' T0=UNDEF TD=UNDEF K1=KOLORT K2=KOLORD READ(LU,*,END=39) NAMREC,X1R,X2R,X3R,T0,TD,K1,K2 IF(NAMREC.EQ.'$$$$$$') THEN GO TO 39 END IF C Selecting the receiver: IF(FILREC.NE.' ') THEN C Loop for receivers DO 31 I=NPTS+NSRC+1,NPTS+NSRC+NREC IF(PTS(I).EQ.NAMREC) THEN IREC=I-NPTS-NSRC GO TO 32 END IF 31 CONTINUE GO TO 30 END IF 32 CONTINUE C Updating the coordinates: IF(FILPTS.NE.' '.AND.NAMREC.NE.' ') THEN C Receiver coordinates DO 33 I=1,NPTS IF(PTS(I).EQ.NAMREC) THEN I0=MSS+3*I X1R=RAM(I0-2) X2R=RAM(I0-1) X3R=RAM(I0) GO TO 34 END IF 33 CONTINUE C SP-08 LINE='SP-08: Receiver '//NAMREC(1:LENGTH(NAMREC)) * //' not found in file PTS' CALL ERROR(LINE) C If file PTS with the coordinates of points is given C and file SPHILI contains receiver names, file PTS has C to contain all receiver names of file REC (if REC is C specified) or all receiver names of file SPHILI (if C REC=' '). 34 CONTINUE END IF IF(SPVRED.NE.0.) THEN IF(FILSRC.EQ.' ') THEN X1S=0. X2S=0. X3S=0. ELSE I0=MSS+3*NPTS X1S=RAM(I0+1) X2S=RAM(I0+2) X3S=RAM(I0+3) END IF RR=SQRT((X1R-X1S)**2+(X2R-X2S)**2+(X3R-X3S)**2) T0=T0-RR/SPVRED END IF IF(KODESP.EQ.0) THEN IF(FILREC.EQ.' ') THEN C SP-09 CALL ERROR('SP-09: No receiver file specified') C For KODESP=0, filename REC must be specified in the C input data. END IF X=SPXLEN*(FLOAT(IREC)-SPXMIN(0)) * /(SPXMAX(0)-SPXMIN(0)) ELSE IF(KODESP.EQ.1.OR.KODESP.EQ.2) THEN X=SPXLEN*((X1R-SPXMIN(0))*XA+(X2R-SPYMIN(0))*YA) * /(XA*XA+YA*YA) ELSE IF(KODESP.EQ.3) THEN X=SPXLEN*(X3R-SPXMIN(0))/XA ELSE X=SPXLEN*(RR-SPXMIN(0))/XA END IF C Plotting the highlight: IF(T0.EQ.UNDEF) THEN K1=-1 K2=-1 END IF IF(TD.EQ.UNDEF) THEN K2=-1 END IF IF(K2.GE.0) THEN XPTS(1)=X-0.5*SPHIWI XPTS(2)=X+0.5*SPHIWI XPTS(3)=X+0.5*SPHIWI XPTS(4)=X-0.5*SPHIWI YPTS(1)=SCY*(T0-TD-SPTMIN) YPTS(2)=SCY*(T0-TD-SPTMIN) YPTS(3)=SCY*(T0+TD-SPTMIN) YPTS(4)=SCY*(T0+TD-SPTMIN) IF(K2.GT.0) THEN CALL NEWPEN(K2) CALL FILL(XPTS,YPTS,4) ELSE CALL NEWPEN(K1) CALL PLOT(XPTS(1),YPTS(1),3) CALL PLOT(XPTS(2),YPTS(2),2) CALL PLOT(XPTS(3),YPTS(3),2) CALL PLOT(XPTS(4),YPTS(4),2) END IF END IF IF(K1.GT.0) THEN CALL NEWPEN(K1) CALL PLOT(X-0.5*SPHIWI,SCY*(T0-SPTMIN),3) CALL PLOT(X+0.5*SPHIWI,SCY*(T0-SPTMIN),2) END IF GO TO 30 39 CONTINUE C Closing highlighting file CLOSE(LU) END IF C C Plotting seismograms: C Loop for GSE files DO 90 ISS=0,9 IF(FILESS(ISS).NE.' ') THEN CALL NEWPEN(KOLOR(ISS)) XA=SPXMAX(ISS)-SPXMIN(ISS) YA=SPYMAX(ISS)-SPYMIN(ISS) C### C Opening input GSE file with the seismograms: IF(FILPAR.EQ.' ') THEN OPEN(LU,FILE=FILESS(ISS),STATUS='OLD') CALL RGSE1(LU,TEXT) ELSE ISS0=ISSRAM(IFILE(ISS)-1)+1 END IF C^^^ C Loop for seismograms IREC=0 40 CONTINUE 41 CONTINUE C### C Selecting the component: 42 CONTINUE ISS1=ISS0 IF(FILPAR.EQ.' ') THEN CALL RGSE2 * (LU,NAMREC,CHAN,I,X1R,X2R,X3R,T0,TD,NSS,MSS,RAM) ELSE CALL RRAM2(ISS0,NAMSRC,X1S,X2S,X3S, * NAMREC,X1R,X2R,X3R,I,T0,TD,NSS,IRAM,RAM) END IF IF(NSS.LE.-1) THEN C End of the GSE file GO TO 80 END IF IF(I.NE.KOMP(ISS,ISP)) GO TO 42 C^^^ C Selecting the receiver: IF(FILREC.EQ.' ') THEN IREC=IREC+1 ELSE C Loop for receivers DO 51 I=NPTS+NSRC+1,NPTS+NSRC+NREC IF(PTS(I).EQ.NAMREC) THEN I0=MSS+3*I X1R=RAM(I0-2) X2R=RAM(I0-1) X3R=RAM(I0) IREC=I-NPTS-NSRC GO TO 52 END IF 51 CONTINUE GO TO 41 END IF 52 CONTINUE C### C Reading the source information: IF(FILPAR.EQ.' ') THEN 53 CONTINUE CALL RGSE2C(LINE,*54) CALL RSEP2(LINE) GO TO 53 54 CONTINUE CALL RSEP3T('NAMESRC',NAMSRC,' ') CALL RSEP3R('X1SRC',X1S,0.) CALL RSEP3R('X2SRC',X2S,0.) CALL RSEP3R('X3SRC',X3S,0.) END IF C^^^ C Selecting the source: IF(FILSRC.NE.' ') THEN IF(NAMSRC.EQ.' ') THEN I0=MSS+3*NPTS X1S=RAM(I0+1) X2S=RAM(I0+2) X3S=RAM(I0+3) ELSE C Loop for sources DO 55 I=NPTS+1,NPTS+NSRC IF(PTS(I).EQ.NAMSRC) THEN I0=MSS+3*I X1S=RAM(I0-2) X2S=RAM(I0-1) X3S=RAM(I0) GO TO 56 END IF 55 CONTINUE GO TO 41 END IF END IF 56 CONTINUE C C Updating the coordinates: IF(FILPTS.NE.' ') THEN C Receiver coordinates DO 61 I=1,NPTS IF(PTS(I).EQ.NAMREC) THEN I0=MSS+3*I X1R=RAM(I0-2) X2R=RAM(I0-1) X3R=RAM(I0) GO TO 62 END IF 61 CONTINUE C SP-10 LINE='SP-10: Receiver '//NAMREC(1:LENGTH(NAMREC)) * //' not found in file PTS' CALL ERROR(LINE) C If file PTS with the coordinates of points is given, C it has to contain all receiver names of file REC C (if REC is specified) or all receiver names of the C GSE file (if REC=' '). 62 CONTINUE C Source coordinates IF(NAMSRC.NE.' ') THEN DO 63 I=1,NPTS IF(PTS(I).EQ.NAMSRC) THEN I0=MSS+3*I X1S=RAM(I0-2) X2S=RAM(I0-1) X3S=RAM(I0) GO TO 64 END IF 63 CONTINUE C SP-11 CALL ERROR('SP-11: Source not found in file PTS') C If file PTS with the coordinates of points is given C and the GSE file contains source names, file PTS has C to contain all source names of file SRC (if SRC is C specified) or all source names of the GSE file (if C SRC=' '). 64 CONTINUE END IF END IF C C Plotting the seismogram: RR=SQRT((X1R-X1S)**2+(X2R-X2S)**2+(X3R-X3S)**2) IF(SPEXP(ISS).NE.0.) THEN DO 76 I=1,NSS RAM(ISS1+I)=RAM(ISS1+I) * *EXP(SPEXP(ISS)*(T0+TD*FLOAT(I-1)-SPEXPT)) 76 CONTINUE END IF IF(SPVRED.NE.0.) THEN T0=T0-RR/SPVRED END IF C IF(NORMSP.LE.0) THEN IF(NORMSP.LT.0) THEN I1=MAX0(INT((SSTMIN-T0)/TD+2.),1) I2=MIN0(INT((SSTMAX-T0)/TD+1.),NSS) ELSE I1=1 I2=NSS END IF AA=0. DO 77 I=I1,I2 AA=AMAX1(ABS(RAM(ISS1+I)),AA) 77 CONTINUE IF(AA.NE.0.) THEN AA=SPAMP(ISS,ISP)*SPXLEN/(RECNUM+1.)/AA END IF ELSE IF(SPOWER(ISS).EQ.0.) THEN AA=SPAMP(ISS,ISP) ELSE AA=SPAMP(ISS,ISP)*((RR/SPDIST)**SPOWER(ISS)) END IF END IF C IF(KODESP.LE.0) THEN IF(FILREC.EQ.' ') THEN C SP-12 CALL ERROR('SP-12: No receiver file specified') C For KODESP=0, filename REC must be specified in the C input data. END IF X=SPXLEN*(FLOAT(IREC)-SPXMIN(ISS)) * /(SPXMAX(ISS)-SPXMIN(ISS)) ELSE IF(KODESP.EQ.1.OR.KODESP.EQ.2) THEN X=SPXLEN*((X1R-SPXMIN(ISS))*XA+(X2R-SPYMIN(ISS))*YA) * /(XA*XA+YA*YA) ELSE IF(KODESP.EQ.3) THEN X=SPXLEN*(X3R-SPXMIN(ISS))/XA ELSE X=SPXLEN*(RR-SPXMIN(ISS))/XA END IF Y=SCY*(SSTMIN-SPTMIN) C C Denoting the horizontal axis by the receiver name: C IF(ISS.EQ.0) THEN IF(KODESP.LE.0.AND.SPXDIV.GT.0.) THEN CALL SYMBOL(X-0.5*(LENGTH(NAMREC)-0.43)*SPCHRH, * Y-1.8*SPCHRH,SPCHRH,NAMREC,0.,LENGTH(NAMREC)) END IF C END IF C CALL PLOT(X,Y,3) DO 78 I=1,NSS T = T0+TD*FLOAT(I-1) IF (SSTMIN.LE.T.AND.T.LE.SSTMAX) THEN IF (T.LT.SSTMIN+TD) THEN C Bottom intersection point of the seismogram A=(T-SSTMIN)/TD IF(I.GT.1) THEN A=(1.-A)*RAM(ISS1+I)+A*RAM(ISS1+I-1) ELSE A=(1.-A)*RAM(ISS1+I) END IF A=X-AA*A Y=SCY*(SSTMIN-SPTMIN) CALL PLOT(A,Y,2) ELSE IF (I.EQ.1) THEN C Straight line before the seismogram Y = SCY*(T-TD-SPTMIN) CALL PLOT(X,Y,2) END IF A = X-AA*RAM(ISS1+I) Y = SCY*(T-SPTMIN) CALL PLOT(A,Y,2) IF (T.GT.SSTMAX-TD) THEN C Top intersection point of the seismogram A=(SSTMAX-T)/TD IF(I.LT.NSS) THEN A=(1.-A)*RAM(ISS1+I)+A*RAM(ISS1+I+1) ELSE A=(1.-A)*RAM(ISS1+I) END IF A=X-AA*A Y=SCY*(SSTMAX-SPTMIN) CALL PLOT(A,Y,2) ELSE IF (I.EQ.NSS) THEN C Straight line after the seismogram Y = SCY*(T+TD-SPTMIN) CALL PLOT(X,Y,2) END IF END IF 78 CONTINUE Y=SCY*(SSTMAX-SPTMIN) CALL PLOT(X,Y,2) C GO TO 40 80 CONTINUE C End of loop for receivers C### C Closing GSE file IF(FILPAR.EQ.' ') THEN CLOSE(LU) END IF END IF 90 CONTINUE C End of loop for GSE files C^^^ CALL PLOT(0.,0.,999) END IF 99 CONTINUE C C End of loop over SP executions in optional SP parameter file: IF(FILPAR.NE.' ') THEN GO TO 100 END IF 999 CONTINUE IF(FILPAR.NE.' ') THEN CLOSE(LUPAR) END IF C WRITE(*,'(A)') '+SP: Done. ' STOP END C C======================================================================= C C C SUBROUTINE FRAME(XX,YY,XM,XN,YM,YN,MM,IX,IY,HEIGHT, * XL1,XR1,KX1,XL2,XR2,KX2,YL,YR,KY, * K1,M1,A1,N1,K2,M2,A2,N2,K3,K4) C CHARACTER*(*) KX1,KX2,KY,K1,K2,K3,K4 REAL XX,YY,XM,XN,YM,YN,HEIGHT,XL1,XR1,XL2,XR2,YL,YR,A1,A2 INTEGER MM,IX,IY,M1,N1,M2,N2 C C Input: C XX... Length of the horizontal axis in cm. C YY... Length of the vertical axis in cm. C XM... The number of intervals along the horizontal axis, C starting at the left. The intervals are marked with C long ticks and are supplemented with the numerical C values if IX is positive. XM must be positive. C XN... Number of subintervals to be marked in each interval C with short ticks. XN must be positive. C YM... The number of intervals along the vertical axis, C starting at the bottom. The intervals are marked with C long ticks and are supplemented with the numerical C values if IY is positive. YM must be positive. C YN... Number of subintervals to be marked in each interval C with short ticks. YN must be positive. C MM... If negative, the top line of the frame is not plotted. C IX... IX=0: No labeling of the horizontal axis. C IX=1: Labeling of the horizontal axis with the first C variable only. C IX=2: Labeling of the horizontal axis with both variables. C IY... IY=0: No labeling of the vertical axis. C IY=1: Labeling of the vertical axis. C HEIGHT... Height of the characters in cm. C XL1,XR1... Values of the first variable along the horizontal axis, C corresponding to left-hand and right-hand corners. C KX1... First label of the horizontal axis. String to be written C below the horizontal axis. C XL2,XR2... Values of the second variable along the horizontal C axis, corresponding to left-hand and right-hand corners. C KX2... Second label of the horizontal axis. String to be written C below the horizontal axis. C YL,YR...Values of the variable along the vertical axis, C corresponding to left-hand and right-hand corners. C KY... Label of the vertical axis. String to be written to the C left of the vertical axis. C K1,A1...String and the number to be written above the frame, C starting 0.5*HEIGHT above the left top corner. C M1... Number A1 is written only if M2 is positive. C N1... Number of decimal places of A1. C K2,A2...String and the number to be written above the frame, C ending 0.5*HEIGHT above the right top corner. C M2... Width of A2 in characters. A2 is written only if M2 is C positive. C N2... Number of decimal places of A2. C K3... String to be written below the frame, starting 5.3*HEIGHT C below the left bottom corner. C K4... String to be written below the frame, starting 7.0*HEIGHT C below the left bottom corner. C C----------------------------------------------------------------------- C EXTERNAL LENGTH INTEGER LENGTH C INTEGER LX1,LX2,LY,L1,L2,L3,L4 C C Lengths of input strings LX1=LENGTH(KX1) LX2=LENGTH(KX2) LY =LENGTH(KY) L1 =LENGTH(K1) L2 =LENGTH(K2) L3 =LENGTH(K3) L4 =LENGTH(K4) C HEIGH0=.215*HEIGHT HEIGH2=.500*HEIGHT C C Initial values for plotting frame: I0= 0 JX= IABS(IX)-1 MX= INT(XM*XN+0.001) NX= INT(XN+0.5) MY= INT(YM*YN+0.001) NY= INT(YN+0.5) XD= XX/XM/XN YD= YY/YM/YN XH1= (XR1-XL1)/XM XH2= (XR2-XL2)/XM YH = (YR -YL )/YM C C Plotting border 29.7*21.0 cm (landscape): C CALL PLOT( 0. , 0. ,3) C CALL PLOT(29.7, 0. ,2) C CALL PLOT(29.7,21.0,2) C CALL PLOT( 0. ,21.0,2) C CALL PLOT( 0. , 0. ,2) C C Plotting frame XX*YY cm centred on the A4 sheet: C Landscape * X = (29.7-XX)/2. * Y = (21.0-YY)/2. C Portrait X = (21.0-XX)/2. Y = (29.7-YY)/2. C Leaving 2 cm belts for description of axes IF(IX.GE.0) THEN X=X+2.5*HEIGHT END IF IF (IY.NE.0) THEN Y=Y+2.5*HEIGHT END IF C Shifting the origin and plotting the frame CALL PLOT(X,Y,-3) CALL PLOT(XX,0.,2) CALL PLOT(XX,YY,2) IF(MM.GE.0) THEN I = 2 ELSE I = 3 END IF CALL PLOT(0.,YY,I) CALL PLOT(0.,0.,2) C C Description of axes: C C Bottom horizontal axis: X = 0. X1= XL1-XH1 X2= XL2-XH2 DO 16 I=I0,MX IF (MOD(I,NX).NE.0) THEN A = 0.1 ELSE A = 0.2 IF (JX.GE.0) THEN X1= X1+XH1 X2= X2+XH2 IF(IX.GE.0.OR.MOD(I,MX).NE.0) THEN C Determination of the number of decimal places: ccc J = INT(.99-ALOG10(AMAX1(ABS(XH1),ABS(XH2),0.001))) DO 11 J=0,5 IF(AMOD(ABS(XH1)+0.000001,0.1**J).LT.0.000002) THEN GO TO 12 END IF 11 CONTINUE 12 CONTINUE C J is the preferable number of decimal places. JMAX=MAX0(INT(ALOG10(ABS(X1)+0.5*0.1**J))+1,1) IF(X1.LT.0.) JMAX=JMAX+1 C JMAX is the number of digits left to the decimal point. IF (JX.GT.0) THEN DO 13 J=J,5 IF(AMOD(ABS(XH2)+0.000001,0.1**J).LT.0.000002) THEN GO TO 14 END IF 13 CONTINUE 14 CONTINUE C J is the preferable number of decimal places. JMAX=MAX0(INT(ALOG10(ABS(X2)+0.5*0.1**J))+1,JMAX) IF(X1.GE.0..AND.X2.LT.0.) JMAX=JMAX+1 C JMAX is the number of digits left to the decimal point. END IF JMAX=INT(XX/XM/HEIGHT)-JMAX-1 C JMAX is the maximum number of decimal places. J=MIN0(J,JMAX) IF(J.LE.0) THEN J=-1 END IF C J is the number of decimal places. C B = X-( .5*FLOAT(1+JX)*AINT(ALOG10(ABS(X1)+.5))+0.285 * -FLOAT(JX)+.5*FLOAT(J+1) )*HEIGHT IF(X1.LT.0.) THEN B=B-HEIGHT END IF CALL NUMBER(B,-1.8*HEIGHT,HEIGHT,X1,0.,J) IF (JX.GT.0) THEN B = X-HEIGHT*AINT(ALOG10(ABS(X2)+.5))+.715*HEIGHT IF(X2.LT.0.) B=B-HEIGHT CALL NUMBER(B,-3.3*HEIGHT,HEIGHT,X2,0.,J) END IF END IF END IF END IF IF (MOD(I,MX).NE.0) THEN CALL PLOT(X,0.,3) CALL PLOT(X,A ,2) END IF X = X+XD 16 CONTINUE IF (JX.EQ.0) THEN B = XX-XX/XM/2.-HEIGH2*FLOAT(LX1)+HEIGH0 CALL SYMBOL(B,-3.3*HEIGHT,HEIGHT,KX1,0.,LX1) ELSE IF (JX.GT.0) THEN CALL SYMBOL(XX+2.715*HEIGHT,-1.8*HEIGHT,HEIGHT,KX1,0.,LX1) CALL SYMBOL(XX+2.715*HEIGHT,-3.3*HEIGHT,HEIGHT,KX2,0.,LX2) END IF C C Right-hand vertical axis: Y = 0. M = MY DO 23 I=1,M Y = Y+YD A = 0.1 IF (MOD(I,NY).EQ.0) THEN A = 0.2 END IF CALL PLOT(XX,Y,3) CALL PLOT(XX-A,Y,2) 23 CONTINUE C C Top horizontal axis: IF (MM.GE.0) THEN X = XX M = MX-1 DO 33 I=1,M X = X-XD IF (MOD(I,NX).NE.0) THEN A = 0.1 ELSE A = 0.2 END IF CALL PLOT(X,YY,3) CALL PLOT(X,YY-A,2) 33 CONTINUE END IF C C Left-hand vertical axis: Y = 0. Y1= YL-YH DO 45 I=I0,MY IF (MOD(I,NY).NE.0) THEN A = 0.1 ELSE A = 0.2 IF (IY.NE.0) THEN Y1= Y1+YH C C Determination of the number of decimal places: ccc J = INT(.99-ALOG10(AMAX1(ABS(YH),0.001))) DO 41 J=0,5 IF(AMOD(ABS(YH)+0.000001,0.1**J).LT.0.000002) THEN GO TO 42 END IF 41 CONTINUE 42 CONTINUE IF(J.LE.0) THEN J=-1 END IF ccc IF(J.LE.0.OR.IY.GT.0) THEN ccc J=IY ccc END IF C J is the number of decimal places. C B = -( AINT(ALOG10(ABS(Y1)+.5))+2.785+FLOAT(J) )*HEIGHT IF(Y1.LT.0.) THEN B=B-HEIGHT END IF CALL NUMBER(B,Y-HEIGH2,HEIGHT,Y1,0.,J) END IF END IF IF (I.NE.0) THEN CALL PLOT(0.,Y,3) CALL PLOT(A,Y ,2) END IF Y = Y+YD 45 CONTINUE IF (IY.NE.0) THEN A = -HEIGHT*FLOAT(LY)-1.285*HEIGHT IF (YM-FLOAT(MY/NY).GE.0.25) THEN B = YY-HEIGHT ELSE B = YY-YY/YM/2.-HEIGH2 END IF CALL SYMBOL(A,B,HEIGHT,KY,0.,LY) END IF C C Writing texts: CALL SYMBOL(HEIGH0,YY+HEIGH2,HEIGHT,K1,0.,L1) B = HEIGHT*FLOAT(L1)+1.215*HEIGHT IF(M1.GT.0) THEN CALL NUMBER(B,YY+HEIGH2,HEIGHT,A1,0.,N1) END IF B = XX-HEIGHT*FLOAT(L2+M2)-.785*HEIGHT CALL SYMBOL( B,YY+HEIGH2,HEIGHT,K2,0.,L2) B = XX-HEIGHT*FLOAT(M2) +.215*HEIGHT IF(M2.GT.0) THEN CALL NUMBER(B,YY+HEIGH2,HEIGHT,A2,0.,N2) END IF CALL SYMBOL(HEIGH0,-5.3*HEIGHT,HEIGHT,K3,0.,L3) CALL SYMBOL(HEIGH0,-7.0*HEIGHT,HEIGHT,K4,0.,L4) C RETURN END C C======================================================================= C### SUBROUTINE WRAM2(ISS0,NAMSRC,X1S,X2S,X3S, * NAMREC,X1R,X2R,X3R,KOMP,T0,TD,NSS,IRAM,RAM) CHARACTER*(*) NAMSRC,NAMREC INTEGER IRAM(*) REAL RAM(*) C CHARACTER*6 NAME IRAM(ISS0)=22+NSS I=ISS0+IRAM(ISS0) NAME=NAMSRC IRAM(I-21)=ICHAR(NAME(1:1)) IRAM(I-20)=ICHAR(NAME(2:2)) IRAM(I-19)=ICHAR(NAME(3:3)) IRAM(I-18)=ICHAR(NAME(4:4)) IRAM(I-17)=ICHAR(NAME(5:5)) IRAM(I-16)=ICHAR(NAME(6:6)) NAME=NAMREC IRAM(I-15)=ICHAR(NAME(1:1)) IRAM(I-14)=ICHAR(NAME(2:2)) IRAM(I-13)=ICHAR(NAME(3:3)) IRAM(I-12)=ICHAR(NAME(4:4)) IRAM(I-11)=ICHAR(NAME(5:5)) IRAM(I-10)=ICHAR(NAME(6:6)) RAM(I-9)=X1S RAM(I-8)=X2S RAM(I-7)=X3S RAM(I-6)=X1R RAM(I-5)=X2R RAM(I-4)=X3R IRAM(I-3)=KOMP RAM(I-2)=T0 RAM(I-1)=TD ISS0=I IRAM(ISS0)=0 RETURN END C C======================================================================= C SUBROUTINE RRAM2(ISS0,NAMSRC,X1S,X2S,X3S, * NAMREC,X1R,X2R,X3R,KOMP,T0,TD,NSS,IRAM,RAM) CHARACTER*(*) NAMSRC,NAMREC INTEGER IRAM(*) REAL RAM(*) C CHARACTER*6 NAME NSS=IRAM(ISS0)-22 I=ISS0+IRAM(ISS0) IF(NSS.GT.-1) THEN NAME(1:1)=CHAR(IRAM(I-21)) NAME(2:2)=CHAR(IRAM(I-20)) NAME(3:3)=CHAR(IRAM(I-19)) NAME(4:4)=CHAR(IRAM(I-18)) NAME(5:5)=CHAR(IRAM(I-17)) NAME(6:6)=CHAR(IRAM(I-16)) NAMSRC=NAME NAME(1:1)=CHAR(IRAM(I-15)) NAME(2:2)=CHAR(IRAM(I-14)) NAME(3:3)=CHAR(IRAM(I-13)) NAME(4:4)=CHAR(IRAM(I-12)) NAME(5:5)=CHAR(IRAM(I-11)) NAME(6:6)=CHAR(IRAM(I-10)) NAMREC=NAME X1S=RAM(I-9) X2S=RAM(I-8) X3S=RAM(I-7) X1R=RAM(I-6) X2R=RAM(I-5) X3R=RAM(I-4) KOMP=IRAM(I-3) T0=RAM(I-2) TD=RAM(I-1) END IF ISS0=I RETURN END C^^^ C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'gse.for' C gse.for INCLUDE 'length.for' C length.for INCLUDE 'calcops.for' C calcops.for C C======================================================================= Csqrt.cal 0100666 0000765 0000765 00000000014 07040525546 012105 0 ustar bulant bulant $2=SQRT($1) srfwrl.for 0100666 0000765 0000765 00000107135 07471115104 012467 0 ustar bulant bulant C
C Program SRFWRL to convert triangulated or polygonated surfaces into C the Virtual Reality Modeling Language or GOCAD representation C C Version: 5.60 C Date: 2002, May 17 C C Coded by: Ludek Klimes & Vaclav Bucha C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mails: klimes@seis.karlov.mff.cuni.cz C bucha@seis.karlov.mff.cuni.cz C C References: C C VRML (Virtual Reality Modeling Language) version 1.0C C C VRML97 (Virtual Reality Modeling Language ISO/IEC 14772) C C GOCAD C C Persistence of Vision scene description language, version 3.1 C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C VRTX='string'... Name of the file with vertices of the polygons. C Description of file VRTX C Default: VRTX='vrtx.out' C TRGL='string'... Name of the file describing the triangles or C polygons. Triangles are recommended (and obligatory if C VRML='GOCAD'). C Description of file TRGL C Default: TRGL='trgl.out' C COLORS='string'... Name of the file containing the data describing C the colour map. C Description of file COLORS C Default: COLORS='hsv.dat' C Input/output file: C WRL='string'... Name of the file to be supplemented with surfaces C or to be copied to the beginning of the output file. C If the filename is blank, output file starts from a C scratch (mostly not reasonable). C The default name of the output file is equal to WRL. C It is recommended to specify WRL rather than to use C the default name. C Default: WRL='out.wrl' C WRLOUT='string'... Name of the output file if different from WRL. C Default: WRLOUT=WRL C Data specifying the form of the output file: C VRML='string'... Virtual reality scene description language. C VRML='VRML1': VRML (Virtual Reality Modeling Language) C version 1.0. C VRML='VRML2': VRML97 according to ISO/IEC 14772 standard. C VRML='GOCAD': GOCAD description of surfaces (TSurf). C VRML='POV': POV (Persistence Of Vision) scene C description language, version 3.1. C This option has not been used and is thus C poorly debugged. C Default: VRML='VRML2' (recommended if not using GOCAD) C NAME='string'... String containing the GOCAD name of the surface. C Be sure to select different names for all objects within C the GOCAD file. C The same name is used for the corresponding colour scale, C written if KOLSRF is positive. C Used only if VRML='GOCAD'. Obligatory parameter, must be C specified and cannot be blank if VRML='GOCAD'. C Data specifying the values to be scaled in colours: C KOLSRF=integer... If zero, all surfaces will have the same colour C given by parameters R, G, B. If positive, the values in C KOLSRF-th column of input file VRTX will be colour-coded C at each vertex of each triangle or polygon of the surface. C If VRML.NE.'GOCAD', this setting may be modified by C parameters KOLPOS and KOLNEG. C If both KOLPOS and KOLNEG are specified, KOLSRF is used C only if VRML='GOCAD'. C Default: KOLSRF=7 C KOLPOS=integer... Analogous to KOLSRF, but applies just to the C positive side of the the surface. C Not used if VRML='GOCAD'. C Default: KOLPOS=KOLSRF C KOLNEG=integer... Analogous to KOLSRF, but applies just to the C negative side of the the surface. C Not used if VRML='GOCAD'. C Default: KOLNEG=KOLSRF C PROPERTIES='string'... String containing names of properties C corresponding to values Z1,Z2,Z3,V1,...,VN (see file C VRTX) which may be used to control the C colour of the surface. The names are separated by blanks. C If the number of names is smaller than the number of C values, the leftmost values are considered. PROPERTIES C must be specified if VRML='GOCAD' and KOLSRF is positive. C If KOLSRF is 1, 2 or 3, the last name is assumed to denote C the KOLSRFth coordinate rather than the quantity in the C corresponding column, and the value of the coordinate C copied into that column. C If PROPERTIES=' ', no values are considered and GOCAD atom C VRTX is used for the vertices (otherwise, GOCAD atom PVRTX C is used). C Used only if VRML='GOCAD'. C Default: PROPERTIES=' ' C Data specifying the colour scale: C VADD=real, VMUL=real, VPER=real, VREF=real, CREF=real, CREF1=real, C CREF2=real, CREF3=real, etc... Refer to file C colors.for. C R=real, G=real, B=real... Float numbers between 0 and 1 specifying C the colour of the surfaces if KOLSRF=0 or KOLPOS=0 or C KOLNEG=0. C Defaults: R=1, G=1, B=1 (white) C TRANSP=real... Transparency of the surfaces (sometimes called C transmit). Values from 0 to 1. C Default: TRANSP=0. C AMBIENT=real... Float number between 0 and 1 specifying the C intensity of the ambient light. The colour of the ambient C light is assumed white. Applied to the surfaces only if C VRML='vrml1'. Otherwise, the ambient light source of C intensity AMBIENT is prescribed by program C iniwrl.for. C Not used if VRML='GOCAD'. C Default: AMBIENT=0.20 (default for VRML materials) C SPECULAR=real... Intensity of the specular reflections from C glossy surfaces. Values from 0 to 1. C Not used if VRML='GOCAD'. C Default: SPECULAR=0 (default for VRML materials) C SHININESS=real... Shininess of the surfaces (sometimes called C transmit). Values from 0 to 1. C Not used if VRML='GOCAD'. C Default: SHININESS=0.20 (default for VRML materials) C C C Input file VRTX with the vertices: C (1) None to several strings terminated by / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,Z1,Z2,Z3,V1,...,VN/ C 'NAME'... Name of the vertex. Not considered. May be blank. C X1,X2,X3... Coordinates of the vertex. C Z1,Z2,Z3... Normal to the surface at the vertex. The normals are C used for shading of the surface if VRML='VRML1' or C VRML='VRML2'. If at least one normal is zero, shading C corresponds to flat triangles or polygons. C Normals are transmitted to the GOCAD file if VRML='GOCAD' C and parameter PROPERTIES is specified, but do not C influence the surface appearance. C V1,...,VN...Optional values which may be used to control the C colour of the surface. C /... None to several values terminated by a slash. C (3) / or end of file. C C C Input file TRGL with the triangles or polygons: C (1) For each triangle data (1.1), or for each polygon data (1.2): C (1.1) I1,I2,I3,/ C I1,I2,I3... Indices of 3 vertices of the triangle, right-handed C with respect to the given surface normals. C The vertices in file VRTX are indexed by positive integers C according to their order. C For polygon, three indices I1,I2,I3 are replaced with more C ones. C /... List of vertices is terminated by a slash. C (1.2) I1,I2,...,IN,/ C I1,I2,...,IN... Indices of N vertices of the polygon. C The vertices in file VRTX are indexed by positive integers C according to their order. C /... List of vertices must be terminated by a slash. C (2) / or end of file. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C C External functions and subroutines: EXTERNAL LENGTH,RSEP1,RSEP3T,RSEP3I,ERROR,FORM2,COLOR1,COLOR2 INTEGER LENGTH C C Filenames and parameters: CHARACTER*80 FSEP,FVRTX,FTRGL,FCOLS,FIN,FOUT INTEGER LU1,LU2,IUNDEF,MVRTX,MQ PARAMETER (LU1=1,LU2=2,IUNDEF=-999999,MVRTX=99,MQ=30) C MVRTX... Maximum number of vertices of a single polygon. C C Other variables: CHARACTER*(8+8*MQ) FORMAT CHARACTER*5 VRML CHARACTER*255 NAME,PROP,TEXT LOGICAL LNORM INTEGER KOLSRF,KOLPOS,KOLNEG,KQ,NQ INTEGER NVRTX,NPLGN,IREF,IRGB,I0,I1,I2,I,N REAL AMBI,TRANSP,SPEC,SHIN,RED,GREEN,BLUE REAL OUTMIN(MQ),OUTMAX(MQ),R,G,B,AUX,AUXA(1) C LNORM.. Says whether the surface normals are specified. C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+SRFWRL: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C SRFWRL-08 CALL ERROR('SRFWRL-08: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF CALL RSEP1(LU1,FSEP) WRITE(*,'(A)') '+SRFWRL: Working... ' C C Reading input and output filenames: CALL RSEP3T('VRTX' ,FVRTX,'vrtx.out') CALL RSEP3T('TRGL' ,FTRGL,'trgl.out') CALL RSEP3T('COLORS',FCOLS,'hsv.dat' ) CALL RSEP3T('WRL' ,FIN ,'out.wrl' ) CALL RSEP3T('WRLOUT',FOUT ,FIN ) CALL RSEP3T('VRML' ,VRML ,'VRML2' ) CALL LOWER(VRML) C C Reading input parameters for surface appearance: CALL RSEP3I('KOLSRF',KOLSRF,7) CALL RSEP3I('KOLPOS',KOLPOS,KOLSRF) CALL RSEP3I('KOLNEG',KOLNEG,KOLSRF) CALL RSEP3R('AMBIENT' ,AMBI ,0.20) CALL RSEP3R('TRANSP' ,TRANSP,0.00) CALL RSEP3R('SPECULAR' ,SPEC ,0.00) CALL RSEP3R('SHININESS',SHIN ,0.20) CALL RSEP3R('R' ,RED ,1.) CALL RSEP3R('G' ,GREEN ,1.) CALL RSEP3R('B' ,BLUE ,1.) C C Opening the output file and writing its beginning: CALL WRL1(LU1,LU2,FIN,FOUT,VRML,1) C C Writing the prolog for the surface (part 1): IF (VRML.EQ.'vrml1') THEN CONTINUE ELSE IF (VRML.EQ.'vrml2') THEN CONTINUE ELSE IF (VRML.EQ.'gocad') THEN KOLPOS=KOLSRF KOLNEG=KOLSRF CALL RSEP3T('NAME',NAME,' ') C Subroutine WRL has already checked that NAME is not blank. WRITE(LU2,'(A)') * 'GOCAD TSurf 1.0' WRITE(LU2,'(2A)') * 'HDR name:',NAME(1:LENGTH(NAME)) WRITE(LU2,'(A)') * 'HDR *visible:true' CALL RSEP3T('PROPERTIES',PROP,' ') I0=1 KQ=3 DO 11 I=1,LEN(PROP)-1 IF (PROP(I:I).EQ.' '.AND.PROP(I+1:I+1).NE.' ') THEN I0=I+1 END IF IF (PROP(I:I).NE.' '.AND.PROP(I+1:I+1).EQ.' ') THEN KQ=KQ+1 IF (KQ.EQ.KOLSRF.OR.(1.LE.KOLSRF.AND.KOLSRF.LE.3)) THEN I1=I0 I2=I END IF END IF 11 CONTINUE IF (KOLSRF.LE.0) THEN WRITE(LU2,'(3(A,F4.2))') * 'HDR color: ',RED,' ',GREEN,' ',BLUE WRITE(LU2,'(A,F4.2)') * 'HDR *solid*transparency:',TRANSP ELSE IF (KQ.LT.KOLSRF.OR.KQ.LT.4) THEN C SRFWRL-09 CALL ERROR('SRFWRL-09: GOCAD property name not specified') C If KOLSRF is not zero, list PROPERTIES of property names C must contain MAX(1,KOLSRF-3) names at the least, see the C description of the input data. END IF WRITE(LU2,'(A)') * 'HDR *painted:true' * ,'HDR *shaded_painted:true' * ,'HDR *precise_painted:true' WRITE(LU2,'(2A)') * 'HDR *painted*variable:',PROP(I1:I2) END IF IF (KQ.GT.3) THEN WRITE(LU2,'(2A)') * 'PROPERTIES ',PROP(1:LENGTH(PROP)) END IF IF (KOLSRF.NE.0) THEN IF (LENGTH(PROP)+(KQ-3)*LENGTH(NAME).GT.LEN(TEXT)) THEN C SRFWRL-10 CALL ERROR('SRFWRL-10: Too long property class names') C Each property class name is composed of the object name C given by input parameter NAME and the property name. C The property names are given by input parameter PROPERTIES. C All property class names should fit into character variable C TEXT. The length of TEXT thus should not be smaller than C the length of the value of PROPERTIES, plus the number of C properties times the length of the value of NAME. END IF I0=0 DO 12 I=1,LENGTH(PROP) IF (I.EQ.1.AND.PROP(1:1).NE.' ') THEN TEXT(I0+1:I0+LENGTH(NAME))=NAME(1:LENGTH(NAME)) I0=I0+LENGTH(NAME) END IF I0=I0+1 TEXT(I0:I0)=PROP(I:I) IF (PROP(I:I).EQ.' '.AND.PROP(I+1:I+1).NE.' ') THEN TEXT(I0+1:I0+LENGTH(NAME))=NAME(1:LENGTH(NAME)) I0=I0+LENGTH(NAME) END IF 12 CONTINUE WRITE(LU2,'(2A)') * 'PROPERTY_CLASSES ',TEXT(1:I0) WRITE(LU2,'(4A)') * 'PROPERTY_CLASS_HEADER ',NAME(1:LENGTH(NAME)),PROP(I1:I2),' {' C The output file now waits for the colour scale. END IF C KQ is the number of coordinates and properties at each point. ELSE C SRFWRL-11 CALL ERROR('SRFWRL-11: No valid string in VRML') C Valid string specifying the form of the output file is: C VRML='VRML1' or 'VRML2' or 'GOCAD' or 'POV'. Default and C recommended value is 'VRML2'. END IF C C Reading vertices: LNORM=.TRUE. IF(VRML.EQ.'gocad') THEN NQ=KQ ELSE KQ=MAX0(6,KOLPOS,KOLNEG) IF(KOLPOS.EQ.0.AND.KOLNEG.EQ.0) THEN NQ=6 ELSE IF(KOLPOS.EQ.KOLNEG) THEN NQ=7 ELSE NQ=8 END IF C Values to be displayed will be shifted to the 7th and 8th column END IF IF(NQ.GT.MQ) THEN C SRFWRL-12 CALL ERROR('SRFWRL-12: Too small arrays OUTMIN and OUTMAX') END IF OPEN(LU1,FILE=FVRTX,STATUS='OLD') READ(LU1,*) (TEXT,I=1,20) NVRTX=0 20 CONTINUE IF(NVRTX+KQ.GT.MRAM) THEN C SRFWRL-01 CALL ERROR('SRFWRL-01: Too small array RAM') END IF TEXT='$' DO 21 I=NVRTX+2,NVRTX+KQ RAM(I)=0. 21 CONTINUE READ(LU1,*,END=29) TEXT,(RAM(I),I=NVRTX+1,NVRTX+KQ) IF(TEXT.EQ.'$') THEN GO TO 29 END IF C Relocating the values to be displayed to the 7th and 8th columns IF(VRML.EQ.'gocad') THEN IF(1.LE.KOLSRF.AND.KOLSRF.LE.3) THEN RAM(NVRTX+KQ)=RAM(NVRTX+KOLSRF) END IF ELSE IF(KOLNEG.GT.0) THEN AUX=RAM(NVRTX+KOLNEG) END IF IF(KOLPOS.GT.0) THEN RAM(NVRTX+7)=RAM(NVRTX+KOLPOS) END IF IF(KOLNEG.GT.0.AND.KOLPOS.NE.KOLNEG) THEN RAM(NVRTX+8)=AUX END IF END IF C Normalizing the normal AUX=SQRT(RAM(NVRTX+4)**2+RAM(NVRTX+5)**2+RAM(NVRTX+6)**2) IF(AUX.GT.0.) THEN AUX=0.999/AUX RAM(NVRTX+4)=RAM(NVRTX+4)*AUX RAM(NVRTX+5)=RAM(NVRTX+5)*AUX RAM(NVRTX+6)=RAM(NVRTX+6)*AUX ELSE LNORM=.FALSE. END IF C Determining the minimum and maximum values IF(NVRTX.EQ.0) THEN DO 22 I=1,NQ OUTMIN(I)=RAM(NVRTX+I) OUTMAX(I)=RAM(NVRTX+I) 22 CONTINUE ELSE DO 23 I=1,NQ OUTMIN(I)=AMIN1(OUTMIN(I),RAM(NVRTX+I)) OUTMAX(I)=AMAX1(OUTMAX(I),RAM(NVRTX+I)) 23 CONTINUE END IF C Number of storage locations in RAM used for the vertices NVRTX=NVRTX+NQ GO TO 20 29 CONTINUE CLOSE(LU1) C NVRTX is the number of storage locations in RAM used for vertices IF(VRML.NE.'gocad') THEN IF(KOLNEG.NE.0) THEN IF(KOLPOS.EQ.KOLNEG) THEN KOLNEG=7 ELSE KOLNEG=8 END IF END IF IF(KOLPOS.NE.0) THEN KOLPOS=7 END IF IF(NQ.GE.8) THEN OUTMIN(7)=AMIN1(OUTMIN(7),OUTMIN(8)) OUTMAX(7)=AMAX1(OUTMAX(7),OUTMAX(8)) END IF END IF C Values to be displayed have been shifted to the 7th or 8th columns C C Determining the colour map: IF(KOLPOS.GT.0.OR.KOLNEG.GT.0) THEN IF(VRML.EQ.'gocad') THEN CALL COLOR1(LU1,MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,OUTMIN(KOLSRF),OUTMAX(KOLSRF)) WRITE(LU2,'(2A)') * ' *colormap:',NAME(1:LENGTH(NAME)) FORMAT='(A,' CALL FORM2(1,OUTMIN(KOLSRF),OUTMAX(KOLSRF),FORMAT(4:11)) FORMAT(9:11)=') ' IF(OUTMAX(KOLSRF).GT.OUTMIN(KOLSRF)) THEN WRITE(LU2,FORMAT) * ' *low_clip: ',OUTMIN(KOLSRF) * ,' *high_clip:',OUTMAX(KOLSRF) ELSE WRITE(LU2,FORMAT) * ' *low_clip: ',OUTMIN(KOLSRF) * ,' *high_clip:',OUTMIN(KOLSRF)+1. END IF WRITE(LU2,'(4A)') * ' *colormap*',NAME(1:LENGTH(NAME)),'*colors: ',CHAR(92) AUX=(OUTMAX(KOLSRF)-OUTMIN(KOLSRF))/255. DO 31 I=0,255 AUXA(1)=OUTMIN(KOLSRF)+FLOAT(I)*AUX CALL COLOR2(MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,AUXA,R,G,B) IF (I.LT.255) THEN WRITE(LU2,'(I5,3(1X,F4.2),2A)') * I,R,G,B,' ',CHAR(92) ELSE WRITE(LU2,'(I5,3(1X,F4.2),2A)') * I,R,G,B END IF 31 CONTINUE IF(TRANSP.GT.0.) THEN WRITE(LU2,'(2A)') * ' *colormap*alphas: ',CHAR(92) DO 32 I=0,255 IF (I.LT.255) THEN WRITE(LU2,'(I5,1X,F4.2,2A)') * I,TRANSP,' ',CHAR(92) ELSE WRITE(LU2,'(I5,1X,F4.2,2A)') * I,TRANSP END IF 32 CONTINUE END IF WRITE(LU2,'(A)') * '}' ELSE IF (VRML.EQ.'pov') THEN AUX=0.01/SHIN WRITE(LU2,'(A)') * '#default {' WRITE(LU2,'(A,2(F4.2,A))') * ' finish { ambient 1.00 specular ',SPEC, * ' roughness ',AUX,' }' WRITE(LU2,'(A)') * ' pigment {' * ,' color_map {' CALL COLOR3(MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1),1,IREF,IRGB) I=NVRTX+1+IRAM(NVRTX+1) IREF=NVRTX+IREF IRGB=NVRTX+IRGB DO 57 I2=1,IRAM(NVRTX+2)-IRAM(NVRTX+1) WRITE(LU2,'(A,F8.6,A,4(F4.2,A))') * ' [',RAM(I+I2),' rgbt <', * (RAM(IRGB+I1),',',I1=3*I2-2,3*I2),TRANSP,'>]' 57 CONTINUE WRITE(LU2,'(A)') * ' }' * ,' }' * ,'}' WRITE(LU2,'(A,G13.6,A)') * '#declare CREF = ',RAM(IREF+1),';' * ,'#declare VREF = ',RAM(IREF+2),';' * ,'#declare VPER = ',RAM(IREF+3),';' ELSE CALL COLOR1(LU1,MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,OUTMIN(7),OUTMAX(7)) END IF END IF C C Writing the prolog for the surface (part 2): IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') * 'DEF SurfaceMaterial Material {' WRITE(LU2,'(3(A,F4.2))') * ' diffuseColor ',RED,' ',GREEN,' ',BLUE * ,' ambientColor ',RED*AMBI,' ',GREEN*AMBI,' ',BLUE*AMBI * ,' specularColor ',SPEC,' ',SPEC,' ',SPEC WRITE(LU2,'(A,F4.2)') * ' shininess ',SHIN * ,' transparency ',TRANSP WRITE(LU2,'(A)') * ' emissiveColor 0.00 0.00 0.00' * ,'}' WRITE(LU2,'(A)') * 'Separator {' * ,'USE SurfaceMaterial' IF(LNORM) THEN WRITE(LU2,'(A)') 'NormalBinding { value PER_VERTEX }' ELSE WRITE(LU2,'(A)') 'NormalBinding { value PER_FACE }' END IF ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') * 'Shape {' * ,' appearance DEF SurfaceAppearance Appearance {' * ,' material Material {' WRITE(LU2,'(3(A,F4.2))') * ' diffuseColor ',RED,' ',GREEN,' ',BLUE * ,' specularColor ',SPEC,' ',SPEC,' ',SPEC WRITE(LU2,'(A,F4.2)') * ' shininess ',SHIN * ,' transparency ',TRANSP WRITE(LU2,'(A)') * ' ambientIntensity 1.00' * ,' emissiveColor 0.00 0.00 0.00' * ,' }' * ,' }' * ,'}' * ,'Surface {' * ,'appearance USE SurfaceAppearance' ELSE IF (VRML.EQ.'pov') THEN WRITE(LU2,'(A,I6,A)') * '#declare NVRTX =',NVRTX/NQ,';' WRITE(LU2,'(A)') * '#declare PTS = array[NVRTX][7]' * ,'#declare IVRTX = 0;' * ,'#macro VRTX(X1,X2,X3,Z1,Z2,Z3,V1)' * ,' #declare PTS[IVRTX][0] = X1;' * ,' #declare PTS[IVRTX][1] = X2;' * ,' #declare PTS[IVRTX][2] = X3;' * ,' #declare PTS[IVRTX][3] = Z1;' * ,' #declare PTS[IVRTX][4] = Z2;' * ,' #declare PTS[IVRTX][5] = Z3;' * ,' #declare PTS[IVRTX][6] = V1;' * ,' #declare IVRTX = IVRTX + 1;' * ,'#end' * ,'#macro TRGL(I1,I2,I3)' * ,' #local X1=srp.for 0100666 0000765 0000765 00000020030 07276426010 011744 0 ustar bulant bulant C;' * ,' #local X2= ;' * ,' #local X3= ;' * ,' #local Z1= ;' * ,' #local Z2= ;' * ,' #local Z3= ;' * ,' #local V1=PTS[I1][6]-PTS[I3][6];' * ,' #local V2=PTS[I2][6]-PTS[I3][6];' * ,' #local V3= PTS[I3][6];' * ,' #if (V1=0 & V2=0)' * ,' #local V1=VPER/999999;' * ,' #end' * ,' #local D1=X1-X3;' * ,' #local D2=X2-X3;' * ,' #local D11=vdot(D1,D1);' * ,' #local D12=vdot(D1,D2);' * ,' #local D22=vdot(D2,D2);' * ,' #local D =D11*D22-D12*D12;' * ,' #local G =(D1*(D22*V1-D12*V2)+D2*(-D12*V1+D11*V2))/D;' * ,' #local GN= vlength(G);' * ,' #local G0= G*VPER/GN/GN;' * ,' #local G1= V2*D1-V1*D2;' * ,' #local G2= vcross(G0,G1);' * ,' smooth_triangle {' * ,' X1,Z1,X2,Z2,X3,Z3' * ,' texture {' * ,' pigment {' * ,' gradient x' * ,' translate ((VREF-V3)/VPER-CREF-100)*x' * ,' matrix ' * ,' translate X3' * ,' }' * ,' }' * ,' }' * ,'#end' END IF C C Writing the vertices: IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'Coordinate3 { point [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'point [' END IF C ------ IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN FORMAT='(' CALL FORM2(3,OUTMIN(1),OUTMAX(1),FORMAT(2:25)) DO 60 I=1,NVRTX,NQ WRITE(LU2,FORMAT) RAM(I),' ',RAM(I+1),' ',RAM(I+2),',' 60 CONTINUE ELSE IF (VRML.EQ.'gocad') THEN C Writing the vertices with normals and values: FORMAT='(A,I0,A,' FORMAT(5:5)=CHAR(ICHAR('1')+INT(ALOG10(FLOAT(NVRTX/NQ)+0.5))) IF (NQ.EQ.3) THEN CALL FORM2(3,OUTMIN(1),OUTMAX(1),FORMAT(9:8+8*3)) DO 62 I0=1,NVRTX,NQ WRITE(LU2,FORMAT) 'VRTX ',I0/NQ+1,(' ',RAM(I),I=I0,I0+2) 62 CONTINUE ELSE CALL FORM2(NQ,OUTMIN(1),OUTMAX(1),FORMAT(9:8+8*NQ)) DO 63 I0=1,NVRTX,NQ WRITE(LU2,FORMAT) 'PVRTX ',I0/NQ+1,(' ',RAM(I),I=I0,I0+NQ-1) 63 CONTINUE END IF ELSE IF (VRML.EQ.'pov') THEN C Writing the vertices with normals and values: IF(KOLNEG.NE.KOLPOS) THEN C SRFWRL-51 CALL WARN('SRFWRL-51: POV surface sides differently coloured') C POV scene description language does not allow for different C colours at the positive and negative side of a surface. END IF FORMAT='(A,' CALL FORM2(3,OUTMIN(1),OUTMAX(1),FORMAT(4:27)) FORMAT(27:38)=',3(F5.3,A),' CALL FORM2(1,OUTMIN(7),OUTMAX(7),FORMAT(39:46)) DO 65 I=1,NVRTX,NQ WRITE(LU2,FORMAT) 'VRTX(',(RAM(I1),',',I1=I,I+5),RAM(I+6),')' 65 CONTINUE END IF C ------ IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') ']' END IF C C Writing the right-handed normals (positive surface side): IF(LNORM) THEN IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'DEF SurfaceNormal Normal { vector [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'normalPos Normal { vector [' END IF C ------ IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN FORMAT='(3(F5.3,A))' DO 66 I=4,NVRTX,NQ WRITE(LU2,FORMAT) RAM(I),' ',RAM(I+1),' ',RAM(I+2),',' 66 CONTINUE END IF C ------ IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '] }' END IF END IF C C Writing the left-handed normals (negative surface side): IF(LNORM) THEN IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'Normal { vector [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'normalNeg Normal { vector [' END IF C ------ IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN DO 67 I=4,NVRTX,NQ WRITE(LU2,FORMAT) -RAM(I),' ',-RAM(I+1),' ',-RAM(I+2),',' 67 CONTINUE END IF C ------ IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '] }' END IF END IF C C Writing the colours of the positive surface side: IF(KOLPOS.GT.0) THEN IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'DEF SurfaceColor Material { diffuseColor [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'colorPos DEF SurfaceColor Color { color [' END IF C ------ IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN DO 71 I=KOLPOS,NVRTX,NQ CALL COLOR2(MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,RAM(I),R,G,B) WRITE(LU2,'(3(F4.2,A))') R,' ',G,' ',B,',' 71 CONTINUE END IF C ------ IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '] }' END IF END IF C C Writing the colours of the negative surface side: IF(KOLNEG.GT.0) THEN IF(KOLNEG.EQ.KOLPOS) THEN IF (VRML.EQ.'vrml1') THEN CONTINUE ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'colorNeg USE SurfaceColor' END IF ELSE IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') 'Material { diffuseColor [' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'colorNeg Color { color [' ELSE IF (VRML.EQ.'pov') THEN END IF C ------ IF (VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN DO 72 I=KOLNEG,NVRTX,NQ CALL COLOR2(MRAM-NVRTX,IRAM(NVRTX+1),RAM(NVRTX+1), * 1,RAM(I),R,G,B) WRITE(LU2,'(3(F4.2,A))') R,' ',G,' ',B,',' 72 CONTINUE END IF C ------ IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '] }' END IF END IF END IF C C Reading the polygons (usually triangles): DO 81 I=1,MRAM IRAM(I)=0 81 CONTINUE OPEN(LU1,FILE=FTRGL) NPLGN=0 82 CONTINUE IF(NPLGN+MVRTX+1.GT.MRAM) THEN C SRFWRL-02 CALL ERROR('SRFWRL-02: Too small array RAM') END IF IRAM(NPLGN+1)=IUNDEF READ(LU1,*,END=89) (IRAM(I),I=NPLGN+1,NPLGN+MVRTX+1) IF(IRAM(NPLGN+1).EQ.IUNDEF) THEN GO TO 89 END IF DO 83 I=NPLGN+1,NPLGN+MVRTX+1 IF(IRAM(I).LE.0) THEN C Number of polygon vertices N=I-1-NPLGN GO TO 84 ELSE IF(IRAM(I).GT.NVRTX/NQ) THEN C SRFWRL-03 WRITE(TEXT,'(A,I6)')'SRFWRL-03: Wrong vertex index:',IRAM(I) CALL ERROR(TEXT(1:LENGTH(TEXT))) END IF 83 CONTINUE C SRFWRL-04 CALL ERROR('SRFWRL-04: Too many vertices in polygons') 84 CONTINUE IF(N.LT.3) THEN C SRFWRL-52 CALL WARN('SRFWRL-52: Polygon of less than 3 vertices') END IF C Checking vertex indices: DO 86 I2=NPLGN+1,NPLGN+N DO 85 I1=I2+1,NPLGN+N IF(IRAM(I2).EQ.IRAM(I1)) THEN C SRFWRL-05 WRITE(TEXT,'(A,I6)') * 'SRFWRL-05: The same vertex twice in a polygon:',IRAM(I2) CALL ERROR(TEXT(1:LENGTH(TEXT))) C All vertices of a polygon must be different. END IF 85 CONTINUE 86 CONTINUE C Terminating polygon by zero IF(N.GE.3) THEN NPLGN=NPLGN+N+1 IRAM(NPLGN)=0 END IF GO TO 82 89 CONTINUE CLOSE(LU1) C C Writing the polygons (usually triangles): IF(VRML.EQ.'vrml1') THEN IF(KOLNEG.GT.0) THEN WRITE(LU2,'(A)') 'MaterialBinding { value PER_VERTEX }' ELSE WRITE(LU2,'(A)') 'MaterialBinding { value OVERALL }' END IF WRITE(LU2,'(A)') 'ShapeHints {' WRITE(LU2,'(A)') ' vertexOrdering CLOCKWISE' WRITE(LU2,'(A)') ' shapeType SOLID' WRITE(LU2,'(A)') '}' WRITE(LU2,'(A)') 'DEF Surface IndexedFaceSet { coordIndex [' ELSE IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') 'coordIndex [' END IF C ------ N=0 IF(VRML.EQ.'vrml1'.OR.VRML.EQ.'vrml2') THEN FORMAT='(99(I0,A))' I=INT(ALOG10(FLOAT(NVRTX/NQ)-0.5))+1 FORMAT(6:6)=CHAR(ICHAR('0')+I) DO 91 I2=1,NPLGN IF(IRAM(I2).LE.0) THEN WRITE(LU2,FORMAT) * (IRAM(I1)-1,', ',I1=N+1,I2-2),IRAM(I2-1)-1,', -1,' N=I2 END IF 91 CONTINUE ELSE IF (VRML.EQ.'gocad') THEN FORMAT='(A,3(A,I0))' I=INT(ALOG10(FLOAT(NVRTX/NQ)+0.5))+1 FORMAT(9:9)=CHAR(ICHAR('0')+I) DO 92 I2=1,NPLGN IF(IRAM(I2).LE.0) THEN IF(I2-N.GT.4) THEN C SRFWRL-06 CALL ERROR('SRFWRL-06: More than 3 vertices in polygon') C In this version of the SRFWRL program, only triangles are C allowed for GOCAD. Polygons should be divided into C triangles using program 'trgl.for'. END IF WRITE(LU2,FORMAT) 'TRGL',(' ',IRAM(I1),I1=N+1,I2-1) N=I2 END IF 92 CONTINUE ELSE IF(VRML.EQ.'pov') THEN FORMAT='(99(A,I0))' I=INT(ALOG10(FLOAT(NVRTX/NQ)-0.5))+1 FORMAT(8:8)=CHAR(ICHAR('0')+I) DO 93 I2=1,NPLGN IF(IRAM(I2).LE.0) THEN IF(I2-N.GT.4) THEN C SRFWRL-07 CALL ERROR('SRFWRL-07: More than 3 vertices in polygon') C In this version of the SRFWRL program, only triangles are C allowed for the POV scene description language. Polygons C should be divided into triangles using program 'trgl.for'. END IF WRITE(LU2,FORMAT) * 'TRGL(',(IRAM(I1)-1,',',I1=N+1,I2-2),IRAM(I2-1)-1,')' N=I2 END IF 93 CONTINUE END IF C ------ IF(VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '] }' IF(LNORM) THEN WRITE(LU2,'(A)') 'USE SurfaceNormal' END IF IF(KOLPOS.GT.0) THEN WRITE(LU2,'(A)') 'USE SurfaceColor' WRITE(LU2,'(A)') 'MaterialBinding { value PER_VERTEX }' ELSE WRITE(LU2,'(A)') 'MaterialBinding { value OVERALL }' END IF WRITE(LU2,'(A)') 'ShapeHints {' WRITE(LU2,'(A)') ' vertexOrdering COUNTERCLOCKWISE' WRITE(LU2,'(A)') ' shapeType SOLID' WRITE(LU2,'(A)') '}' WRITE(LU2,'(A)') 'USE Surface' ELSE IF(VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') ']' END IF C C Writing the trailor for the surface: IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '}' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '}' ELSE IF (VRML.EQ.'gocad') THEN WRITE(LU2,'(A)') 'END' END IF CLOSE(LU2) WRITE(*,'(A)') '+SRFWRL: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'forms.for' C forms.for INCLUDE 'colors.for' C colors.for INCLUDE 'wrl.for' C wrl.for C C======================================================================= C
C Program SRP (Source and Receiver Points, or SuRface Points) to C generate files containing source and/or receiver points corresponding C to given configuration parameter(s). C C The dependence of the source and receiver coordinates on the C configuration parameters is assumed to be linear. C C Version: 5.50 C Date: 2001, May 10 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Name of the input file, configuration parameters: C SRP='string'...Name of the input file specifying the unshifted C points corresponding to zero configuration parameters, C and the derivatives of their positions with respect to the C configuration parameters. C Description of the file SRP C Default: 'SRP'='srp.dat' C CNAME='string'... Character string which is, without trailing C blanks, prefixed to the name of each unshifted point in C order to create the name of the corresponding point C shifted according to the configuration parameters CPAR1, C CPAR2. C Default: 'CNAME'=' ' C CPAR1=real, CPAR2=real...Configuration parameters describing new, C shifted positions of the given surface points. C Default: CPAR1=0., CPAR2=0. C C C Input file 'SRP' with the unshifted points: C (1) 'PTS1','PTS2','PTS3',...,/ C One to MFILE=1024 filenames terminated by a slash. Names of the C output files with the shifted surface points, corresponding to C given configuration parameters CPAR1, CPAR2. It is thus assumed, C that the shifted points are written to the same files for all C values of the configuration parameters. A filename should not C exceed 12 characters. C (2) For each filename, data (2.1) and (2.2): C (2.1) For each point to be written to the output file data (2.1.1): C (2.1.1) 'NAME',X10,X20,X30,X11,X21,X31,X12,X22,X32,/ C 'NAME'..Name of the unshifted point. It will be appended to given C string 'CNAME' (with trailing blanks removed from both C 'CNAME' and 'NAME') to form the name of the corresponding C shifted point. The resulting composed name 'CNAMENAME' is C truncated to 80 characters. However, some other C applications may truncate the names of points to 12, 11, C 8, or even 6 characters. C X10,X20,X30... Coordinates of the unshifted points. C X11,X21,X31... Derivatives of the coordinates with respect to the C first configuration parameter CPAR1. C X12,X22,X32... Derivatives of the coordinates with respect to the C second configuration parameter CPAR2. C Default: X10=0., X20=0., X30=0., X11=0., X21=0., X31=0., X12=0., C X22=0., X32=0. C (2.2) / C C C Output files PTS with the shifted surface points: C (1) / C (2) For each shifted point data (2.1): C (2.1) 'CNAMENAME',X1,X2,X3,/ C 'CNAMENAME'..Name of the shifted point. C X1,X2,X3... Coordinates of the shifted point, C X1=X10+X11*CPAR1+X12*CPAR2, C X2=X20+X21*CPAR1+X22*CPAR2, C X3=X30+X31*CPAR1+X32*CPAR2. C (3) / C C----------------------------------------------------------------------- C CHARACTER*80 FILSEP INTEGER LU PARAMETER (LU=1) C C Filenames: INTEGER MFILE PARAMETER (MFILE=1024) CHARACTER*12 FILE1(MFILE) CHARACTER*80 FILE0 C C Logical unit numbers: INTEGER LU0,LU1 PARAMETER (LU0=10) PARAMETER (LU1=11) C C Data: CHARACTER*80 NAME CHARACTER*8 CNAME CHARACTER*28 FORMAT INTEGER I,J,L REAL X(3),X1,X2,X3,X10,X20,X30,X11,X21,X31,X12,X22,X32,C1,C2 EQUIVALENCE (X(1),X1),(X(2),X2),(X(3),X3) C C I,J... Loop variables. C X1,X2,X3... Coordinates of a point. C X00,X10,X20,X01,X11,X21,X02,X12,X22... Projection matrix from C configuration parameters to coordinates of a point. C C1,C2.. Configuration parameters of a point. C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+SRP: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP WRITE(*,'(A)') '+SRP: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU,FILSEP) ELSE C SRP-01 CALL ERROR('SRP-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input parameters from the SEP file: CALL RSEP3T('SRP',FILE0,'srp.dat') CALL RSEP3T('CNAME',CNAME,' ') CALL RSEP3R('CPAR1',C1,0.) CALL RSEP3R('CPAR2',C2,0.) C OPEN(LU0,FILE=FILE0,STATUS='OLD') DO 10 I=1,MFILE FILE1(I)='$' 10 CONTINUE READ(LU0,*) (FILE1(I),I=1,MFILE) C DO 11 L=LEN(CNAME),1,-1 IF(CNAME(L:L).NE.' ') THEN GO TO 12 END IF 11 CONTINUE 12 CONTINUE L=L+1 C C Loop over output surface-point files: DO 30 I=1,MFILE IF(FILE1(I).EQ.'$') THEN GO TO 90 END IF OPEN(LU1,FILE=FILE1(I)) WRITE(LU1,'(A)') '/' 20 CONTINUE NAME=CNAME NAME(L:L)='$' X10=0. X20=0. X30=0. X11=0. X21=0. X31=0. X12=0. X22=0. X32=0. READ(LU0,*) NAME(L:80),X10,X20,X30,X11,X21,X31,X12,X22,X32 IF(NAME(L:80).EQ.'$' * .AND.X10.EQ.0..AND.X20.EQ.0..AND.X30.EQ.0. * .AND.X11.EQ.0..AND.X21.EQ.0..AND.X31.EQ.0. * .AND.X12.EQ.0..AND.X22.EQ.0..AND.X32.EQ.0.) THEN GO TO 29 END IF DO 21 J=LEN(NAME),2,-1 IF(NAME(J:J).NE.' ') THEN GO TO 22 END IF 21 CONTINUE 22 CONTINUE X1=X10+X11*C1+X12*C2 X2=X20+X21*C1+X22*C2 X3=X30+X31*C1+X32*C2 FORMAT(1:4)='(3A,' CALL FORM2(3,X,X,FORMAT(5:28)) WRITE(LU1,FORMAT) '''',NAME(1:J),''' ',X1,' ',X2,' ',X3,' /' GO TO 20 29 CONTINUE WRITE(LU1,'(A)') '/' CLOSE(LU1) 30 CONTINUE C 90 CONTINUE CLOSE(LU0) WRITE(*,'(A)') '+SRP: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Css.for 0100666 0000765 0000765 00000130343 10062244274 011573 0 ustar bulant bulant C
C Program SS (Synthetic Seismograms) to read or generate and filter the C source time function. It may store the filtered source time function C and its Hilbert transform in the GSE data exchange format, or read the C frequency-domain response function and generate synthetic seismograms C in the GSE data exchange format. C C Version: 5.80 C Date: 2004, June 11 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Name of the input file: C RF='string'... String with the name of the input data file with C the frequency-domain response functions at individual C receivers. Is not taken into account if SS=' '. C The file is generated by program 'greenss.for'. C Description of file RF C Default: RF='rf.out' (mostly sufficient) C Names of output files: C SIGGSE='string'... String with the name of the output data file in C the GSE data exchange format, containing the filtered C source time function and its Hilbert transform. C Generated just if SIGGSE.NE.' '. C For the GSE data exchange format, refer to the description C in file 'gse.for'. C Default: SIGGSE=' ' C SS='string'... String with the name of the output data file in the C GSE data exchange format, containing the seismograms at C the receivers. C Generated just if SS.NE.' '. C For the GSE data exchange format, refer to the description C in file 'gse.for'. C Default: SS='ss.gse' C SSLOG='string'... String with the name of the output log file of C program SS. C Do not specify blank name. C Description of file SSLOG C Default: SSLOG='sslog.out' (mostly sufficient) C SIGPLOT='string'... String with the name of the output PostScript C file with the sketches of C 1 Input signal, C 2 Spectrum of the input signal, C 3 Spectrum of the filter, C 4 Spectrum of the filtered signal, C 5 Filtered signal, C 6 Hilbert transform of the filtered signal. C Generated just if SIGPLOT is not blank and MPTS is C positive. C Description of check plots C Default: SIGPLOT=' ' C SSPLOT='string'... String with the name of the output PostScript C file with the sketches of the synthetic seismograms at the C receivers. C Generated just if both SSPLOT and SS are not blank. C Description of check plots C Default: SSPLOT=' ' C Time step and time interval for the Fast Fourier Transform: C DT=real... Time interval to digitize the source time function and C seismograms. C Default: DT=1. C NFFT=integer... Number of the time samples for the fast Fourier C transform. C NFFT must be an integer power of 2 (NFFT is rounded up to C the nearest power of 2 in this program but not in other C programs which may work with it). C Default: NFFT=MSS, where MSS is the array dimension C declared in the code. C TRED=real, SSVRED=real... Specification of the time window for C the calculation of synthetic seismograms. Usually need C not be specified. C SSVRED.EQ.0: Seismogram is centred in the time interval of C length (NFFT-1)*DT according to the travel times of the C first and last arrivals at the receiver (default). C SSVRED.NE.0: Time of the first sample of the time window C is T=TRED+R/SSVRED, where R is the hypocentral distance. C Default: TRED=0., SSVRED=0. (mostly sufficient) C Data describing the filtration of the source time function: C DER=real, HILB=real... The source time function is DER-th C derivative and HILB-th Hilbert transform of the given C signal. C Default: DER=0. C Default: HILB=0. C FMIN=real, FLOW=real, FHIGH=real, FMAX=real... Parameters of the C frequency filter to be applied to the source time C function. The filter is zero C for frequencies F smaller than FMIN or greater than FMAX. C The filter is 1 between FLOW and FHIGH. C Between FMIN and FLOW, cosine tapering C ( 0.5-0.5*cos(pi*(F-FMIN)/(FLOW-FMIN)) )**KEXP C is used. C Between FMIN and FLOW, cosine tapering C ( 0.5-0.5*cos(pi*(F-FMAX)/(FHIGH-FMAX)) )**KEXP C is used. C Default: FMIN=0. C Default: FLOW=0. C Default: FMAX=0.5/DT C Default: FHIGH=FMAX C KEXP=real... Exponent controlling the cosine frequency-domain C filter. Usually need not be specified because the default C is the most common option. C Default: KEXP=1 (mostly sufficient) C Input data to control optional plotting: C MPTS=integer... Number of points of the time functions at the C output check plot. The corresponding MPTS-1 time C intervals are all together scaled to 10.23cm. The signal C is approximately centred. MPTS does not apply to the C spectra at the output check plot, NFFT/2 points of each C spectrum is plotted. C MPTS=0: No output check plot of the source time function C is generated. C MPTS.LT.0: No output plot is generated, including the C seismograms. C Default: MPTS=0 C SMALL=positive real... Amplitudes in absolute value not exceeding C SMALL times the maximum absolute amplitude of the C seismogram are assumed zero. C Default: SMALL=0.002 C Data describing the source time function: C KSIG=integer... Type of the source time function: C KSIG=0: Digitized time function specified point by point. C KSIG=1: Gabor signal. C * KSIG=2: Hermite-Gaussian (Ricker) signal. C KSIG=3: Kuepper (Mueller) signal. C * KSIG=4: Rayleigh signal. C * KSIG=5: Generalized Berlage signal. C * KSIG=6: ? C * Only KSIG=0,1,3 is implemented in this version. C Default: KSIG=0 C SIGDIG='string'... Name of the file containing the digitized time C function specified point by point and terminated by a C slash. The file is read by the list-directed input. C Required just for KSIG=0 C Default: SIGDIG=' '. C SIGT=real... Reference time of the given signal. C Used for all signals. C Default: SIGT=0. (mostly sufficient) C SIGF=positive real... Reference frequency. C Required for all analytical signals (KSIG=1,2,3,4,5,6). C Default: SIGF=1. C SIGW=positive real... Relative width of the signal. C Often the width of the signal envelope expressed in the C reference half-periods 1/(2*SIGF). C Very roughly defined for non-causal functions. C Required for all analytical signals (KSIG=1,2,3,4,5,6). C Default: SIGW=4. C SIGA=real... Amplitude of the maximum of the signal or its C envelope. C Used for all analytical signals (KSIG=1,2,3,4,5,6). C Default: SIGA=1. (mostly sufficient) C SIGPH=real... Phase in radians. C Used for KSIG=1,3,4,5,6. C Default: SIGPH=0. C PAR5=real... C Used for KSIG=5,6. C PAR6=real... C Used for KSIG=5. C Detailed description of the source time functions: C KSIG=0: Time function digitized with step DT, specified point by C point and terminated by a slash is read from the file C given by input parameter SIGDIG. The first sample C corresponds to time SIGT. C KSIG=1: Gabor signal: C S(t)=SIGA*exp(-(2*pi*SIGF*(t-SIGT)/SIGW)**2) C *cos(2*pi*SIGF*(t-SIGT)+SIGPH) C Gabor signal is not causal but has all derivatives C continuous. C SIGF... Prevailing frequency. C SIGW... Relative width of the signal. In the interval of C SIGW half-periods 1/(2*SIGF) the signal envelope C exceeds 8.48 per cent of its maximum. C SIGA... Amplitude of the envelope. C SIGPH...Phase. C KSIG=2: Hermite-Gaussian (Ricker) signal: C * for future extension, not implemented in this version * C S(t)=A*(-1)**n*Hn(SIGF*(t-SIGT))*exp(-(SIGF*(t-SIGT))**2) C where Hn(x) is the Hermite polynomial of order n=SIGW, C (-1)**n*Hn(x)*exp(-x**2)=(d/dx)**n[exp(-x**2)] C and the scaling factor is C A=SIGA*(n/2)!/n! C Then C S(t)=A*(1/SIGF*d/dt)**n[exp(-(SIGF*(t-SIGT))**2)] C Note that Ricker suggested the Hermite-Gaussian signal C with n=1, 2 and 3 for the approximation of particle C diplacement, velocity and acceleration, respectively, C at the receivers very distant from a point source. C Most widely used is the special case for SIGW=2, C originally suggested by Ricker for particle velocity, C S(t)=SIGA*(2*(SIGF*(t-SIGT))**2-1) C *exp(-(SIGF*(t-SIGT))**2) C Hermite-Gaussian signal is not causal but has all C derivatives continuous. C SIGF... Reference frequency. The mean frequency is C F0=SIGF*(SIGW/2)!/(((SIGW-1)/2))!/pi and the C spectrum has maximum at FM=SIGF*SQRT(SIGW/2)/pi. C Note that for even SIGW C (SIGW/2)!/(((SIGW-1)/2))! C =2*4*...*SIGW/(1*3*...*(SIGW-1))/SQRT(pi) C and for odd SIGW C (SIGW/2)!/(((SIGW-1)/2))! C =3*5*...*SIGW/(2*4*...*(SIGW-1))*SQRT(pi)/2 C SIGW... Order n of the Hermite-Gaussian signal. The best C known option is SIGW=2 (Ricker signal for C far-field particle velocity). C SIGW is rounded to the nearest integer. C KSIG=3: Kuepper (Mueller) signal: C For 0.LE.(t-SIGT).LE.SIGW/(2*SIGF): C S(t)=SIGA*A*(sin(2*pi*SIGF*(t-SIGT)) C -sin(2*pi*SIGF*(t-SIGT)*(SIGW+2)/SIGW) C * SIGW / (SIGW+2) C -(1-cos(2*pi*SIGF*(t-SIGT)/SIGW)) C * sin(pi*SIGW) / (SIGW+2) ) C with A=1/SMAX, where SMAX is the maximum absolute value C of the signal without multiplication factors SIGA*A. C Outside the interval: C S(t)=0 C Note that the standard Kuepper signal is defined just for C integer SIGW and consists only of the two sine terms. C The last term (with cosine) has been added to make the C signal continuous also for non-integer SIGW. C Kuepper signal is causal, has continuous the first C derivative, and for integer SIGW also the second C derivative. C SIGF... Reference frequency. C SIGW... Relative width of the signal, i.e. the duration of C the signal in half-periods 1/(2*SIGF). C SIGW rounded to the next greater integer is the C number of local extrema of the signal. C SIGA... Maximum amplitude of the signal. Determines A. C SIGPH...Not applicable. C KSIG=4: Rayleigh signal: C * for future extension, not implemented in this version * C S(t)=SIGA*(COS(SIGPH)-SIN(SIGPH)*SIGF*(t-SIGT)) C /(1+(SIGF*(t-SIGT))**2) C Note that the Rayleigh signal is the Dirac distribution C D(t-SIGT) shifted by i/SIGF in the complex plane, C S(t)=Re(exp(i*SIGPH)*D(t-SIGT+i/SIGF)) C Rayleigh signal is not causal but has all derivatives C continuous. C SIGF... Reference frequency. C SIGW... Not applicable. C SIGA... Amplitude of the envelope. C SIGPH...Phase. C KSIG=5: Generalized Berlage signal: C * for future extension, not implemented in this version * C For t.LE.SIGT: C S(t)=0 C For t.GT.SIGT: C S(t)=SIGA*A(t)*(t-SIGT)**SIGW*exp(-PAR5*(t-SIGT)) C *sin(2*pi*SIGF*(t-SIGT)+SIGPH) C where A(t) normalizes the maximum of the envelope to 1 C and also enables to generalize the Berlage signal by C means of choosing PAR6 positive, C A(t)=(SIGW/(PAR5*(1+SIGW*PAR6*(t-SIGT))*TMAX**2) C *exp(PAR5*TMAX) C where time t=SIGT+TMAX corresponds to the maximum of the C envelope, C TMAX=(SQRT(1+4*SIGW*SIGW*PAR6/PAR5)-1)/(2*SIGW*PAR6) C Note that the limiting case for PAR6=0 is the standard C Berlage signal, with A(t) constant, C A(t)=PAR5/SIGW*exp(SIGW) C TMAX=SIGW/PAR5 C Note that the limiting case for SIGW=+infinity is given by C S(t)=SIGA C *exp(-1/PAR6/(t-SIGT)+2*SQRT(PAR5/PAR6)-PAR5*(t-SIGT)) C *sin(2*pi*SIGF*(t-SIGT)+SIGPH) C with maximum of the envelope in time t=SIGT+TMAX, C TMAX=1/SQRT(PAR5*PAR6) C The generalized Berlage signal is causal, has continuous C derivatives of orders less than INT(SIGW), C and for SIGPH=0 or SIGPH=pi even of orders less than C INT(SIGW)+1. C SIGF... Prevailing frequency. C SIGW... Controls the onset of the signal. Derivatives of C of orders less than INT(SIGW), and for SIGPH=0 or C SIGPH=pi even of orders less than INT(SIGW)+1, are C continuous. For PAR6=0 (standard Berlage), C distance TMAX beetween the begining of the signal C and the maximum of the envelope is SIGW/PAR5. C SIGW=999 or greater is understood as infinity. C SIGA... Amplitude of the envelope. C SIGPH...Phase. C PAR5... Controls the effective duration of the signal. C PAR6... Zero for standard Berlage signal. Positive values C enable to decrease distance TMAX beetween the C begining of the signal and the maximum of the C envelope. To decrease TMAX from SIGW/PAR5 to C K/PAR5, select PAR6=PAR5*(1/K-1/SIGW)/K. C KSIG=6: ? C * for future extension, not implemented in this version * C For 0.LE.(t-SIGT): C S(t)=SIGA*exp(-(1/TRED-2+TRED)*pi*PAR5/SIGW) C *sin(2*pi*SIGF*(t-SIGT)+SIGPH) C Where: C TRED=4*SIGF*(t-SIGT)/PAR5 C Otherwise: C S(t)=0 C SIGF... Prevailing frequency. C SIGW... Controls the relative width of the signal. C SIGA... Amplitude of the envelope. C SIGPH...Phase. C PAR5... Distance beetween the begining of the signal and C the maximum of the envelope is SIGW/4 prevailing C periods 1/SIGF. C Reasonable value for SIGPH=0 is PAR5=3. C C C Input file 'RF' with the response functions: C (1) 'TEXT1',/ C 'TEXT1'... Text string in apostrophes. The first 34 characters C will be passed to the header of the output GSE file. C (2) X1SRC,X2SRC,X3SRC,/ C X1SRC,X2SRC,X3SRC... Coordinates of the hypocentre. C (3) FMINIM,FD,NF,/ C FMINIM..The lowest frequency at the digitized response function. C FD... The frequency step. C NF... The number of discrete frequencies. C (4) For each receiver (4.1) and (4.2): C (4.1) 'REC',X1,X2,X3,TMIN,TMAX,AMAX,/ C 'REC'...Name of the receiver (6 characters). C X1,X2,X3... Coordinates of the receiver. C TMIN,TMAX...Travel times of the first and last arrivals at the C receiver. C AMAX... Maximum absolute value over the real and imaginary part of C all 3 components of the response function. C (4.2) Written only if TMIN.LE.TMAX (Attention: Formatted input!): C 6*NF integer numbers, FORMAT(12I6): C (IPR(I,IF),I=1,6,IF=1,NF) C IPR... IPR(I,IF)=IFIX(99999.1*SPR(I,IF)/AMAX), where C SPR(*,IF) is the response function at the frequency C F=FMIN+(IF-1)*FD. C SPR(1,IF) is the real part of the X1 component. C SPR(2,IF) is the imaginary part of the X1 component. C SPR(3,IF) is the real part of the X2 component. C SPR(4,IF) is the imaginary part of the X2 component. C SPR(5,IF) is the real part of the X3 component. C SPR(6,IF) is the imaginary part of the X3 component. C (5) / or end of file. C C C Output file 'SSGSE' with the seismograms or source time function: C File in the GSE data exchange format, see the description in file C 'gse.for'. C Description of format GSE C C C Output log file 'SSLOG': C Contains information on the input data, source time function, C synthetic seismograms. Often may be discarded. C C C Output check plots: C File SIGPLOT (if MPTS.GT.0) contains plots of: C 1 Input signal, C 2 Spectrum of the input signal, C 3 Spectrum of the filter, C 4 Spectrum of the filtered signal, C 5 Filtered signal, C 6 Hilbert transform of the filtered signal. C File SSPLOT (if SS.NE.' ') contains plots of the synthetic C seismograms at the receivers. C Horizontal size of each function is 10.23cm, vertical scaling is C 1cm per the maximum absolute amplitude of the function. C Endpoints of the time (or frequency) interval plotted and the C leftmost and rightmost samples of amplitudes in absolute C value grater than SMALL times the maximum absolute C amplitude of the seismogram are labelled with the C corresponding time (or frequency) values. C MPTS points are plotted for input signal, filtered signal and its C Hilbert transform. C NFFT/2 points are plotted for the spectra. C NFFT points are plotted for the synthetic seismograms. C C....................................................................... C C This Fortran77 file consists of the following external procedures: C SS... Main program. C SS C SIGNAL..Subroutine to generate Gabor or Mueller signal of C given parameters. C SIGNAL C PLSIG...Subroutine to determine the maximum amplitude of the given C function, detect zeros beyond and behind the signal, write C the parameters of the signal to the output log file, and C eventually plot the signal. C PLSIG C PLOPN...Simple subroutine to initiate plotting. C PLOPN C PLTIM...Simple subroutine to supplement the signal plots with the C time labels. C PLTIM C FCOOLR..Subroutine for the fast Fourier transform of N=2**K C complex data points. C FCOOLR C C Other external procedures required: C WGSE1,WGSE2,WGSE3... Subroutines of the Fortran 77 file 'gse.for' C (package FORMS), designed to write seismograms in the GSE C data exchange format. C PLOTS,PLOT,SYMBOL,NUMBER... CALCOMP plotting subroutines. For C example, Fortran 77 routines of file 'calcops.for' C (package FORMS) may be used to generate seismogram plots C in the PostScript files. C C======================================================================= C C C EXTERNAL RSEP1,RSEP3T,RSEP3I,RSEP3R,WSEPR,WGSE1,WGSE2,WGSE2C,WGSE3 EXTERNAL ERROR,SIGNAL,PLSIG,SYMBOL,FCOOLR C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C Allocation of working arrays: INTEGER MSS PARAMETER (MSS=MRAM/9) REAL S1(2,MSS),S2(2,MSS),S3(2,MSS),S4(2,MSS),SS(MSS) EQUIVALENCE (S1,RAM ) EQUIVALENCE (S2,RAM(2*MSS+1)) EQUIVALENCE (S3,RAM(4*MSS+1)) EQUIVALENCE (S4,RAM(6*MSS+1)) EQUIVALENCE (SS,RAM(8*MSS+1)) C C----------------------------------------------------------------------- C C Filenames: CHARACTER*80 FILDAT,FILLOG,FILRF,FILGSE,FILSIG,FILPS PARAMETER (LU4=1,LU5=2,LU6=3,LU7=4) C PARAMETER (UNDEF=-999999.) CHARACTER*80 TEXT1 REAL PSGNL(10) C C Receiver name: CHARACTER*6 REC C C Source coordinates transferred through the GSE file: INTEGER NCOM PARAMETER (NCOM=3) CHARACTER*80 LINE CHARACTER*5 TCOM(NCOM) REAL VCOM(NCOM),KEXP DATA TCOM/'X1SRC','X2SRC','X3SRC'/ C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+SS: Enter input filename: ' FILDAT=' ' READ(*,*) FILDAT C C Reading all data from the SEP file into the memory: IF (FILDAT.NE.' ') THEN CALL RSEP1(LU5,FILDAT) ELSE C SS-12 CALL ERROR('SS-12: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C WRITE(*,'(A)') '+SS: Working... ' C CALL RSEP3T('SSLOG',FILLOG,'sslog.out') OPEN(LU6,FILE=FILLOG) C C Input data for the source signal CALL RSEP3I('KSIG ',KSGNL ,0) CALL RSEP3I('MPTS ',MPTS ,0) CALL RSEP3I('NFFT ',NPTS ,MSS) CALL RSEP3R('DER ',DER ,0.) CALL RSEP3R('HILB ',HILB ,0.) CALL RSEP3R('DT ' ,DT ,1.) CALL RSEP3R('FMIN ' ,FMIN ,0.) CALL RSEP3R('FLOW ' ,FL ,0.) CALL RSEP3R('FMAX ' ,FMAX ,0.5/DT) CALL RSEP3R('FHIGH' ,FR ,FMAX) CALL RSEP3R('KEXP ' ,KEXP ,1.0) CALL RSEP3R('SIGT ' ,SIGT ,0.) CALL RSEP3R('TRED ' ,TRED ,0.) CALL RSEP3R('SSVRED',VRED ,0.) N = NPTS-1 NPTS= 1 DO 1 KPTS=1,15 NPTS= NPTS+NPTS IF (N-1.LE.0) GO TO 10 N= N/2 1 CONTINUE C SS-05 CALL ERROR * ('SS-05: Too large number NFFT of time samples for FFT') C NFFT should not exceed 2**15. Check the input data. C To use greater NFFT, edit subroutine FCOOLR at the end of this C file. 10 CONTINUE IF (NPTS.GT.MSS) THEN C SS-01 CALL ERROR('SS-01: Array dimension MSS less than NPTS.') END IF IF (KSGNL.LE.0) THEN CALL RSEP3T('SIGDIG',FILSIG,' ') IF (FILSIG.EQ.' ') THEN C SS-02 CALL ERROR('SS-02: No filename with source time function') C For input parameter KSIG=0 (default value), input parameter C SIGDIG must contain the name of the file with the digitized C source time function. Refer to the description of the C input data. END IF OPEN(LU5,FILE=FILSIG,STATUS='OLD') DO 12 I=1,NPTS S1(1,I)=0. 12 CONTINUE READ (LU5,*) (S1(1,I),I=1,NPTS) CLOSE(LU5) DO 13 I=NPTS,1,-1 IF(S1(1,I).NE.0.) GO TO 14 S1(1,I)=0. 13 CONTINUE 14 CONTINUE N = I N1= (NPTS-N)/2 N2= NPTS-N-N1 J = NPTS DO 15 I=1,N2 S1(1,J)= 0. J = J-1 15 CONTINUE DO 16 I=1,N K = J-N1 S1(1,J)= S1(1,K) J = J-1 16 CONTINUE DO 17 I=1,N1 S1(1,I)= 0. 17 CONTINUE SIGT= SIGT-DT*FLOAT(N1) ELSE CALL RSEP3R('SIGF' ,PSGNL(1),1.) CALL RSEP3R('SIGW' ,PSGNL(2),4.) CALL RSEP3R('SIGPH',PSGNL(3),0.) CALL RSEP3R('SIGA' ,PSGNL(4),1.) CALL RSEP3R('SIG5' ,PSGNL(5),0.) CALL RSEP3R('SIG6' ,PSGNL(6),0.) CALL SIGNAL(KSGNL,NPTS,SIGT,DT,S1,PSGNL) END IF DO 20 I=1,NPTS S1(2,I)= 0. 20 CONTINUE C C Plotting the input signal: CALL RSEP3T('SIGPLOT',FILPS,' ') WRITE(LU6,'(/A,I2)') ' Source signal No.',KSGNL WRITE(LU6,'(2A/2A)') ' * Left-hand Left-hand Right-hand', * ' Right-hand Non-zero Maximum ', * ' tip hill-side hill-side', * ' tip range amplitude' CALL PLSIG(MPTS,1,1,MPTS,NPTS,SIGT,DT,S1,A,I,J,FILPS) C C Spectrum of the input signal: CALL FCOOLR(KPTS,S1,1.) FD= 1./DT/FLOAT(NPTS) C C Amplitude spectrum, frequency window: A = 2./FLOAT(NPTS) DO 38 I=1,NPTS/2 S2(1,I)= SQRT(S1(1,I)*S1(1,I)+S1(2,I)*S1(2,I)) F = FD*FLOAT(I-1) IF (F-FMIN) 31,31,32 31 S2(2,I)= 0. GO TO 38 32 IF (F-FL) 33,34,34 33 S2(2,I)= A*(.5+.5*COS(3.14159*(F-FL)/(FMIN-FL)))**KEXP GO TO 38 34 IF (F-FR) 35,35,36 35 S2(2,I)= A GO TO 38 36 IF (F-FMAX) 37,31,31 37 S2(2,I)= A*(.5+.5*COS(3.14159*(F-FR)/(FMAX-FR)))**KEXP 38 CONTINUE IF (DER) 39,41,39 39 FDA= 6.283185*FD F = 0. DO 40 I=2,NPTS/2 F = F+FDA 40 S2(2,I)= S2(2,I)*F**DER 41 CONTINUE DO 42 I=NPTS/2+1,NPTS S2(1,I)= 0. 42 S2(2,I)= 0. CALL PLSIG(MPTS,2,2,NPTS/2,NPTS/2,0.,FD,S2,A,I,J,FILPS) CALL PLSIG(MPTS,3,3,NPTS/2,NPTS/2,0.,FD,S2(2,1),A,I,J,FILPS) C C Filtration of the input signal: A = 1.570796*(DER+HILB) C = COS(A) S = -SIN(A) DO 47 I=1,NPTS A = S1(1,I)*C-S1(2,I)*S S1(2,I)= S1(1,I)*S+S1(2,I)*C 47 S1(1,I)= A 48 DO 49 I=1,NPTS S1(1,I)= S1(1,I)*S2(2,I) S1(2,I)= S1(2,I)*S2(2,I) 49 S2(1,I)= S2(1,I)*S2(2,I) CALL PLSIG(MPTS,4,4,NPTS/2,NPTS/2,0.,FD,S2,A,NF1,NF2,FILPS) DO 50 I=1,NPTS S2(1,I)= S1(1,I) 50 S2(2,I)= S1(2,I) CALL FCOOLR(KPTS,S2,-1.) CALL PLSIG(MPTS,5,5,MPTS,NPTS,SIGT,DT,S2,A,N1,N2,FILPS) CALL PLSIG(MPTS,6,6,MPTS,NPTS,SIGT,DT,S2(2,1),A,N,J,FILPS) C Legend: IF(FILPS.NE.' '.AND.MPTS.GT.0) THEN CALL SYMBOL(-1.4,-3.,0.8,'1',0.,1) CALL SYMBOL( 0.0,-3.,0.3,'INPUT SIGNAL',0.,12) CALL SYMBOL( 5.6,-3.,0.3,'RIGHT:',0.,6) CALL SYMBOL( 7.6,-3.,0.4,'MAXIMUM AMPLITUDE',0.,17) CALL SYMBOL(-1.4,-4.,0.8,'2',0.,1) CALL SYMBOL( 0.0,-4.,0.3,'SPECTRUM OF THE INPUT SIGNAL',0.,28) CALL SYMBOL(-1.4,-5.,0.8,'3',0.,1) CALL SYMBOL( 0.0,-5.,0.3,'SPECTRUM OF THE FILTER',0.,22) CALL SYMBOL(-1.4,-6.,0.8,'4',0.,1) CALL SYMBOL( 0.0,-6.,0.3, * 'SPECTRUM OF THE FILTERED SIGNAL',0.,31) CALL SYMBOL(-1.4,-7.,0.8,'5',0.,1) CALL SYMBOL( 0.0,-7.,0.3,'FILTERED SIGNAL',0.,16) CALL SYMBOL(-1.4,-8.,0.8,'6',0.,1) CALL SYMBOL( 0.0,-8.,0.3, * 'HILBERT TRANSFORM OF THE FILTERED SIGNAL',0.,40) END IF CALL RSEP3T('SIGGSE',FILSIG,' ') IF(FILSIG.NE.' ') THEN C Writing the source time function and its Hilbert transform: OPEN(LU7,FILE=FILSIG) CALL WGSE1(LU7,' ') DO 51 I=1,NPTS SS(I)=S2(1,I) 51 CONTINUE CALL WGSE2(LU7,' ',' ',0,0.,0.,0.,SIGT,DT,NPTS,SS) DO 52 I=1,NPTS SS(I)=S2(2,I) 52 CONTINUE CALL WGSE2(LU7,' ',' ',0,0.,0.,0.,SIGT,DT,NPTS,SS) CALL WGSE3(LU7) CLOSE(LU7) WRITE(*,'(A)') '+SS: Source time function generated.' STOP END IF IF(FILPS.NE.' '.AND.MPTS.GT.0) CALL PLOT(0.,0.,999) IF (N1.GE.NPTS.OR.N.GE.NPTS) THEN C SS-04 CALL ERROR * ('SS-04: Too small number NFFT of time samples for FFT') END IF N1= MIN0(N1,I) N2= MIN0(N2,J) C C....................................................................... C C Opening output file with seismograms: CALL RSEP3T('SS',FILGSE,'ss.gse') IF (FILGSE.EQ.' ') THEN IF(FILSIG.EQ.' ') THEN IF(FILPS.EQ.' ') THEN WRITE(*,'(A)') '+SS: Nothing to do. ' ELSE WRITE(*,'(A)') '+SS: Signal plotted. ' END IF ELSE WRITE(*,'(A)') '+SS: Signal generated. ' END IF STOP END IF OPEN(LU7,FILE=FILGSE) CALL RSEP3T('SSPLOT',FILPS,' ') C C Opening input files with the response function: CALL RSEP3T('RF',FILRF,'rf.out') IF (FILRF.EQ.' ') THEN C SS-03 CALL ERROR('SS-03: No file with response function specified') END IF OPEN(LU4,FILE=FILRF,STATUS='OLD') C C Headlines of files: WRITE(LU6,'(/A)') * ' Beginning of the input file with frequency response' TEXT1=' ' READ (LU4,*) TEXT1 WRITE(LU6,'(2A)') ' ***',TEXT1 READ (LU4,*) (VCOM(I),I=1,3) WRITE(LU6,'(A,10F8.3)') ' ***',(VCOM(I),I=1,3) READ (LU4,*) FMINIM,A,NF WRITE(LU6,'(A,2E12.5,I4)') ' ***',FMINIM,A,NF IF (NPTS.NE.INT(1./A/DT+.5)) THEN C SS-06 CALL ERROR('SS-06: Inconsistent time and frequency steps.') END IF MINIM= INT(FMINIM/FD+1.5) MAXIM= MINIM+NF-1 IF (NF1+1.LT.MINIM) THEN C SS-07 CALL ERROR * ('SS-07: Missing low frequencies in response function.') END IF IF (MAXIM+NF2.LT.NPTS/2) THEN C SS-08 CALL ERROR * ('SS-08: Missing high frequencies in response function.') END IF CALL WGSE1(LU7,TEXT1) WRITE(LU6,'(/A)') ' Synthetic sections at receivers' WRITE(LU6,'(2A/2A)') ' * Coordinates of the receiver ', * ' First Last Upper ', * ' X Y Z ', * ' arrival arrival amplitude' WRITE(LU6,'(2A/2A)') ' * Left-hand Left-hand Right-han', * 'd Right-hand Non-zero Maximum ', * ' tip hill-side hill-sid', * 'e tip range amplitude' C C Preparing source coordinates for output in the GSE file: DO 55 I=1,NCOM CALL WSEPR(LINE,TCOM(I),VCOM(I)) CALL WGSE2C(LINE) 55 CONTINUE C C Loop for the receivers: NUMS= 1 DO 79 IREC=1,999999 X=UNDEF TMIN= 999999. TMAX=-999999. AMAX=0. READ (LU4,*,END=90) REC,X,Y,Z,TMIN,TMAX,AMAX IF(X.EQ.UNDEF) THEN GO TO 90 END IF WRITE(LU6,'(I4,5F11.3,E11.3)') IREC,X,Y,Z,TMIN,TMAX,AMAX IF(TMIN.LE.TMAX) THEN C Zero range in frequency domain: N = MINIM-1 DO 58 I=1,N S2(1,I)= 0. S2(2,I)= 0. S3(1,I)= 0. S3(2,I)= 0. S4(1,I)= 0. S4(2,I)= 0. 58 CONTINUE N = MIN0(NPTS,MAXIM+1) DO 59 I=N,NPTS S2(1,I)= 0. S2(2,I)= 0. S3(1,I)= 0. S3(2,I)= 0. S4(1,I)= 0. S4(2,I)= 0. 59 CONTINUE C READ(LU4,'(12F6.0)') (S2(1,I),S2(2,I),S3(1,I),S3(2,I), * S4(1,I),S4(2,I),I=MINIM,MAXIM) A = AMAX/99999. DO 65 I=MINIM,MAXIM B = A*(S1(1,I)*S2(1,I)-S1(2,I)*S2(2,I)) S2(2,I)= A*(S1(1,I)*S2(2,I)+S1(2,I)*S2(1,I)) S2(1,I)= B B = A*(S1(1,I)*S3(1,I)-S1(2,I)*S3(2,I)) S3(2,I)= A*(S1(1,I)*S3(2,I)+S1(2,I)*S3(1,I)) S3(1,I)= B B = A*(S1(1,I)*S4(1,I)-S1(2,I)*S4(2,I)) S4(2,I)= A*(S1(1,I)*S4(2,I)+S1(2,I)*S4(1,I)) S4(1,I)= B 65 CONTINUE CALL FCOOLR(KPTS,S2,-1.) CALL FCOOLR(KPTS,S3,-1.) CALL FCOOLR(KPTS,S4,-1.) N = INT((TMAX+TMIN)/(DT+DT)) IF(VRED.GT.0) N=NPTS/2+ * INT((TRED+SQRT((VCOM(1)-X)**2+(VCOM(2)-Y)**2 * +(VCOM(3)-Z)**2)/VRED)/DT) TMIN= SIGT+DT*FLOAT(N) N = MOD(N,NPTS) IF(N.LT.0) THEN N=N+NPTS END IF DO 66 I=1,N J = NPTS-N+I S2(2,J)= S2(1,I) S3(2,J)= S3(1,I) S4(2,J)= S4(1,I) 66 CONTINUE K = NPTS-N DO 68 I=1,K J = N+I S2(2,I)= S2(1,J) S3(2,I)= S3(1,J) S4(2,I)= S4(1,J) 68 CONTINUE CALL PLSIG * (MPTS+1,NUMS,IREC,NPTS,NPTS,TMIN,DT,S2(2,1),AMAX,N1,N2,FILPS) IF(N1.LT.NPTS) THEN C Non-zero signal NUMS= NUMS+1 T0= TMIN+DT*FLOAT(N1) N2= NPTS-N2 N = N2-N1 DO 71 I=1,N N1= N1+1 SS(I)=S2(2,N1) 71 CONTINUE CALL WGSE2(LU7,REC,' ',1,X,Y,Z,T0,DT,N,SS) ELSE C Zero signal CALL WGSE2(LU7,REC,' ',1,X,Y,Z,0.,DT,0,SS) END IF CALL PLSIG * (MPTS+1,NUMS,IREC,NPTS,NPTS,TMIN,DT,S3(2,1),AMAX,N1,N2,FILPS) IF(N1.LT.NPTS) THEN C Non-zero signal NUMS= NUMS+1 T0= TMIN+DT*FLOAT(N1) N2= NPTS-N2 N = N2-N1 DO 72 I=1,N N1= N1+1 SS(I)=S3(2,N1) 72 CONTINUE CALL WGSE2(LU7,REC,' ',2,X,Y,Z,T0,DT,N,SS) ELSE C Zero signal CALL WGSE2(LU7,REC,' ',2,X,Y,Z,0.,DT,0,SS) END IF CALL PLSIG * (MPTS+1,NUMS,IREC,NPTS,NPTS,TMIN,DT,S4(2,1),AMAX,N1,N2,FILPS) IF(N1.LT.NPTS) THEN C Non-zero signal NUMS= NUMS+1 T0= TMIN+DT*FLOAT(N1) N2= NPTS-N2 N = N2-N1 DO 73 I=1,N N1= N1+1 SS(I)=S4(2,N1) 73 CONTINUE CALL WGSE2(LU7,REC,' ',3,X,Y,Z,T0,DT,N,SS) ELSE C Zero signal CALL WGSE2(LU7,REC,' ',3,X,Y,Z,0.,DT,0,SS) END IF ELSE CALL WGSE2(LU7,REC,' ',1,X,Y,Z,0.,DT,0,SS) CALL WGSE2(LU7,REC,' ',2,X,Y,Z,0.,DT,0,SS) CALL WGSE2(LU7,REC,' ',3,X,Y,Z,0.,DT,0,SS) END IF 79 CONTINUE C C End of computation: 90 IF(FILPS.NE.' '.AND.MPTS.GT.-1.AND.NUMS.GT.1) CALL PLOT(0.,0.,999) CALL WGSE3(LU7) CLOSE(LU7) CLOSE(LU6) CLOSE(LU4) WRITE(*,'(A)') '+SS: Done. ' STOP END C C======================================================================= C C C SUBROUTINE SIGNAL(KSGNL,NPTS,SIGT,DT,S,PAR) REAL S(2,NPTS),PAR(*) C EXTERNAL ERROR C GO TO (10,1,30,1,1,1) KSGNL 1 CONTINUE C SS-09 CALL ERROR('SS-09: Only signals KSIG=1,3 allowed') C C Gabor signal 10 CONTINUE T = -DT*FLOAT(NPTS/2) SIGT= SIGT+T A = 6.283185*PAR(1) B = A*A/PAR(2)/PAR(2) DO 11 I=1,NPTS S(1,I)=0. IF(B*T*T.LT.70.) S(1,I)= COS(A*T+PAR(3))*EXP(-B*T*T) IF(PAR(4).NE.0.) S(1,I)=S(1,I)*PAR(4) T = T+DT 11 CONTINUE RETURN C C Kuepper (Mueller) signal: 30 CONTINUE N2= IFIX(PAR(2)/PAR(1)/DT/2.)+1 N1= (NPTS-N2)/2 SIGT= SIGT-DT*FLOAT(N1) A = 6.283185*PAR(1) B = PAR(2)/(2.+PAR(2)) C = A/B D = SIN(3.141593*PAR(2))/(2.+PAR(2)) E = A/PAR(2) DO 31 I=1,N1 S(1,I)= 0. 31 CONTINUE T = 0. F = 0. N2= N1+N2 N1= N1+1 DO 32 I=N1,N2 S(1,I)= SIN(A*T)-B*SIN(C*T)+D*COS(E*T)-D F = AMAX1(F,ABS(S(1,I))) T = T+DT 32 CONTINUE IF(PAR(4).NE.0.) F=F/PAR(4) DO 33 I=N1,N2 S(1,I)= S(1,I)/F 33 CONTINUE N2= N2+1 DO 34 I=N2,NPTS S(1,I)= 0. 34 CONTINUE RETURN C C Generalized Berlage signal: 50 CONTINUE N2= IFIX(ALOG(1000.)/PAR(5)/DT)+1 N1= (NPTS-N2)/2 SIGT= SIGT-DT*FLOAT(N1) A = 6.283185*PAR(1) B=2.*SQRT(PAR(5)/PAR(6)) TMAX = 2.*PAR(2)*PAR(2)*PAR(6)/PAR(5) IF(TMAX.LT.0.000001) THEN TMAX=1. ELSE TMAX=(SQRT(1.+2.*B)-1.)/B ENDIF TMAX=TMAX*PAR(2)/PAR(5) DO 51 I=1,N1+1 S(1,I)= 0. 51 CONTINUE T = 0. F = 0. N1= N1+1 DO 52 I=N1+1,NPTS T=T+DT S(1,I)=0. IF(PAR(2).LE.998.) THEN TRED=1.+PAR(2)*PAR(6)*T*TMAX*TMAX TRED=PAR(2)*T/(PAR(5)*TRED) C=PAR(5)*T IF(C.LT.70.) S(1,I)= SIN(A*T+PAR(3))*EXP(-C)*TRED**PAR(2) ELSE IF(PAR(6).LE.0.) THEN C SS-10 CALL ERROR('SS-10: Signal parameter PAR6 not positive') ENDIF B=2.*SQRT(PAR(5)/PAR(6)) C=1./(PAR(6)*T)-B+PAR(5)*T IF(C.LT.70.) S(1,I)= SIN(A*T+PAR(3))*EXP(-C) ENDIF IF(PAR(4).NE.0.) S(1,I)=S(1,I)*PAR(4) 52 CONTINUE RETURN C C Signal No.6: 60 CONTINUE N2= IFIX(PAR(2)/PAR(1)/DT/2.)+1 N1= (NPTS-N2)/2 SIGT= SIGT-DT*FLOAT(N1) A = 6.283185*PAR(1) B = 4.*PAR(1)/PAR(5) DO 61 I=1,N1+1 S(1,I)= 0. 61 CONTINUE T = 0. F = 0. N1= N1+1 DO 62 I=N1+1,NPTS T=T+DT S(1,I)=0. TRED=B*T C=1./TRED-2.+TRED C=C*3.141593*PAR(5)/PAR(2) IF(C.LT.70.) S(1,I)= SIN(A*T+PAR(3))*EXP(-C) IF(PAR(4).NE.0.) S(1,I)=S(1,I)*PAR(4) 62 CONTINUE RETURN C END C C======================================================================= C C C SUBROUTINE PLSIG(KPLOT,NUMS,NUM,MPTS,NPTS,TL,DT,S,AMP,N1,N2,FILPS) REAL S(2,NPTS) CHARACTER*(*) FILPS C EXTERNAL ERROR,PLTIM,PLOTN,PLOT,NUMBER PARAMETER (LU6=3) C IF(MPTS.GT.NPTS) THEN C SS-11 WRITE(*,'(2(A,I6))') ' MPTS=',MPTS,' NPTS=',NPTS CALL ERROR('SS-11: MPTS greater than NPTS') END IF C C Maximum amplitude: AMP= 0. DO 1 I=1,NPTS 1 AMP= AMAX1(AMP,ABS(S(1,I))) CALL RSEP3R('SMALL',SMALL,0.002) EPS= SMALL*AMP C C Zeros beyond and behind the signal: DO 2 N1=1,NPTS IF(ABS(S(1,N1)).GT.EPS) GO TO 3 2 CONTINUE N1= NPTS RETURN 3 N1= N1-1 DO 4 N2=1,NPTS I = NPTS-N2+1 IF(ABS(S(1,I)).GT.EPS) GO TO 5 4 CONTINUE 5 N2= N2-1 C C Writing the parameters of the signal: N3= (NPTS-MPTS)/2+1 N4= N3+MPTS-1 T1= TL+DT*FLOAT(N1) T2= TL+DT*FLOAT(NPTS-N2-1) T3= TL+DT*FLOAT(N3-1) T4= TL+DT*FLOAT(N4-1) A = T2-T1 WRITE(LU6,'(I4,5F11.3,E11.3)') NUM,T3,T1,T2,T4,A,AMP IF(FILPS.EQ.' '.OR.KPLOT.LE.0.) RETURN C C Plotting the signal: NUM1= MOD(NUMS-1,14)+1 CALL PLOTN(FILPS,(NUMS-1)/14) IF(NUM1.EQ.1.AND.NUMS.NE.1) CALL PLOT(0.,0.,999) IF(NUM1.EQ.1) CALL PLOPN CALL PLOT(0.,-2.,-3) ccc A = -0.8*FLOAT(NUM/10)-1.428 A = -0.8*AINT(ALOG10(FLOAT(NUM)+.5)+1.)-1.428 CALL NUMBER(A,-0.4,0.8,FLOAT(NUM),0.,-1) CALL PLTIM(T3,T4,T3,-.3) CALL PLTIM(T3,T4,T1,-.5) CALL PLTIM(T3,T4,T2,-.5) CALL PLTIM(T3,T4,T4,-.3) CALL NUMBER(11.016,-0.200,0.4,AMP,0.,6) CALL PLOT(10.23,0.00,3) CALL PLOT( 0.00,0.00,2) A = 10.23/FLOAT(MPTS-1) X = 0. DO 11 I=N3,N4 IF(AMP.EQ.0.) THEN Y = 0. ELSE Y = S(1,I)/AMP END IF CALL PLOT(X,Y,2) 11 X = X+A RETURN END C C======================================================================= C C C SUBROUTINE PLOPN C EXTERNAL PLOTS,PLOT C CALL PLOTS(0,0,0) * CALL PLOT( 0. , 0. ,3) * CALL PLOT(21.0, 0. ,2) * CALL PLOT(21.0,29.7,2) * CALL PLOT( 0. ,29.7,2) * CALL PLOT( 0. , 0. ,2) CALL PLOT(5.38,29.7,-3) RETURN END C C======================================================================= C C C SUBROUTINE PLTIM(T3,T4,T,B) C EXTERNAL PLOT,NUMBER C A = (T-T3)/(T4-T3) IF(A.LT.-0.01) RETURN IF(A.GT. 1.01) RETURN A = 10.23*A CALL PLOT(A, 0.2,3) CALL PLOT(A,-0.2,2) A = A-0.457 CALL NUMBER(A,B-0.1,0.2,T,0.,2) RETURN END C C======================================================================= C C C C Fast Fourier transform of N = 2**K complex data points C SUBROUTINE FCOOLR(K,D,SN) C DIMENSION INU(15),D(*) C LX=2**K Q1=LX IL=LX SH=SN*6.28318530718/Q1 DO 10 I=1,K IL=IL/2 10 INU(I)=IL NKK=1 DO 40 LA=1,K NCK=NKK NKK=NKK+NKK LCK=LX/NCK L2K=LCK+LCK NW=0 DO 40 ICK=1,NCK FNW=NW AA=SH*FNW W1=COS(AA) W2=SIN(AA) LS=L2K*(ICK-1) DO 20 I=2,LCK,2 J1=I+LS J=J1-1 JH=J+LCK JH1=JH+1 Q1=D(JH)*W1-D(JH1)*W2 Q2=D(JH)*W2+D(JH1)*W1 D(JH)=D(J)-Q1 D(JH1)=D(J1)-Q2 D(J)=D(J)+Q1 20 D(J1)=D(J1)+Q2 DO 29 I=2,K ID=INU(I) IL=ID+ID IF(NW-ID-IL*(NW/IL)) 40,30,30 30 NW=NW-ID 29 CONTINUE 40 NW=NW+ID NW=0 DO 6 J=1,LX IF(NW-J) 8,7,7 7 JJ=NW+NW+1 J1=JJ+1 JH1=J+J JH=JH1-1 Q1=D(JJ) D(JJ)=D(JH) D(JH)=Q1 Q1=D(J1) D(J1)=D(JH1) D(JH1)=Q1 8 DO 9 I=1,K ID=INU(I) IL=ID+ID IF(NW-ID-IL*(NW/IL)) 6,5,5 5 NW=NW-ID 9 CONTINUE 6 NW=NW+ID RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'gse.for' C gse.for INCLUDE 'length.for' C length.for INCLUDE 'calcops.for' C calcops.for C C======================================================================= Csub.cal 0100666 0000765 0000765 00000000011 06311435304 011672 0 ustar bulant bulant $3=$1-$2 subsob.cal 0100666 0000765 0000765 00000000072 10033450474 012406 0 ustar bulant bulant ABSSOB=ABS(SOBMUL) SOB=ABSSOB*$2 SOB=SOBMUL*SOB $3=$1-SOB swap.for 0100666 0000765 0000765 00000011455 07207651410 012123 0 ustar bulant bulant C
C Program SWAP to swap the bytes, i.e., to convert binary gridded data C (data cubes) between little-endian (PC's) and big-endian (VAX, Alpha, C RISC workstations) hardware C C Version: 5.50 C Date: 2000, November 25 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 Attention: Functionality of program SWAP is strongly affected by C the Fortran compiler and by the options of the compiler. C Program SWAP can work only if the compiler supports unformatted C direct-access files "without headers". C Program SWAP uses INTEGER*1 statement, which violates Fotran 77 C standard. C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the input grid: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C N2=positive integer... Number of gridpoints along the X2 axis. C Default: N2=1 C N3=positive integer... Number of gridpoints along the X3 axis. C Default: N3=1 C Names of the grid file being swapped: C IN='string'... String with the name of the input unformatted file C containing the gridded values. The file should contain C just the 4 byte IEEE reals. The length of the file is C thus exactly 4*N1*N2*N3 bytes. C No default, IN must be specified and cannot be blank. C Data specifying input/output format: C ESIZE=integer... Number of bytes per a real in the input binary C file. Must be ESIZE=4. C Default: ESIZE=4 C C======================================================================= C CHARACTER*80 FILE1 INTEGER LU1 PARAMETER (LU1=1) C INTEGER N1,N2,N3,I INTEGER*1 I1(4),I2(4) REAL AUX1,AUX2 EQUIVALENCE (I1,AUX1),(I2,AUX2) C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+SWAP: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 IF (FILE1.EQ.' ') THEN C SWAP-01 CALL ERROR('SWAP-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF CALL RSEP1(LU1,FILE1) C C Input/output file with gridded data: CALL RSEP3T('IN',FILE1,' ') IF (FILE1.EQ.' ') THEN C SWAP-02 CALL ERROR('SWAP-02: Input file not specified') END IF CALL RSEP3I('ESIZE',I,4) IF (I.NE.4) THEN C SWAP-04 CALL ERROR('SWAP-04: Binary reals not 4-byte long') END IF C C Reading grid dimensions: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) C C Swapping: WRITE(*,'(A)') '+SWAP: Swapping... ' OPEN(LU1,FILE=FILE1,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4, * STATUS='OLD') C C Any Fortran 77 compiler (option "direct files without headers"): DO 10 I=1,N1*N2*N3 READ(LU1,REC=I) AUX1 I2(1)=I1(4) I2(2)=I1(3) I2(3)=I1(2) I2(4)=I1(1) WRITE(LU1,REC=I) AUX2 10 CONTINUE C CLOSE(LU1) WRITE(*,'(A)') '+SWAP: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for C C======================================================================= Ctrgl.for 0100666 0000765 0000765 00000050112 07226523210 012107 0 ustar bulant bulant C
C Program TRGL to divide polygons on a curved surface into triangles, C right-handed with respect to the surface normals C C Version: 5.50 C Date: 2001, January 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C VRTX='string'... Name of the file with vertices of the polygons. C Description of file VRTX C Default: VRTX='vrtx.out' C PLGN='string'... Name of the file describing the polygons. C Description of file PLGN C Default: PLGN='plgn.out' C Data specifying output file: C TRGL='string'... Name of the file describing the triangles. C Description of file TRGL C Default: TRGL='trgl.out' C C C Input file VRTX with the vertices: C (1) None to several strings terminated by / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,Z1,Z2,Z3,/ C 'NAME'... Name of the vertex. Not considered. May be blank. C X1,X2,X3... Coordinates of the vertex. C Z1,Z2,Z3... Normal to the surface at the vertex. C /... None to several values terminated by a slash. C (3) / or end of file. C C C Input file PLGN with the polygons: C (1) For each polygon data (1.1): C (1.1) I1,I2,...,IN,/ C I1,I2,...,IN... Indices of N vertices of the polygon. C The vertices in file VRTX are indexed by positive integers C according to their order. C /... List of vertices must be terminated by a slash. C (2) / or end of file. C C C Output file TRGL with the triangles: C (1) For each triangle data (1.1): C (1.1) I1,I2,I3,/ C I1,I2,I3... Indices of 3 vertices of the triangle, right-handed C with respect to the given surface normals. C The vertices in file VRTX are indexed by positive integers C according to their order. C /... List of vertices is terminated by a slash. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C EXTERNAL LENGTH,ERROR,WARN,RSEP1,RSEP3T INTEGER LENGTH C C....................................................................... C C Filenames and parameters: CHARACTER*80 FSEP,FVRTX,FPLGN,FTRGL INTEGER LU,IUNDEF,MVRTX PARAMETER (LU=1,IUNDEF=-999999,MVRTX=1000) C Input data: CHARACTER*9 FORMAT CHARACTER*80 TEXT C Other variables: INTEGER NVRTX,NPLGN,NTRGL,NBIGON,N,I,I1,I2,I3,J1,J2,J3,K1,K2,N1,N2 REAL X1,X2,X3,Y1,Y2,Y3,Z1,Z2,Z3,A1,A2,A3,D,DMAX,DMIN,HAND,S,C,AUX C C MVRTX...Maximum number of vertices of one polygon. C NVRTX...Number of storage locations for the vertices, i.e. 6 times C the number of vertices. C NPLGN...Last storage location for polygons, i.e. NVRTX + 4 times C the number of future triangles. Each polygon with N C vertices occupies 4*(N-2) locations because it will be C split into N-2 triangles. 4*(N-2)-N locations following C N vertex indices are filled wth zeros. C NTRGL...Last storage location with triangles, i.e. NVRTX + 4 times C the number of created triangles. C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+TRGL: Enter input filename: ' FSEP=' ' READ (*,*) FSEP WRITE(*,'(A)') '+TRGL: Working... ' C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C TRGL-11 CALL ERROR('TRGL-11: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input and output filenames: CALL RSEP3T('VRTX',FVRTX,'vrtx.out') CALL RSEP3T('PLGN',FPLGN,'plgn.out') CALL RSEP3T('TRGL',FTRGL,'trgl.out') C C Reading vertices: OPEN(LU,FILE=FVRTX) READ(LU,*) (TEXT,I=1,20) NVRTX=0 10 CONTINUE IF(NVRTX+6.GT.MRAM) THEN C TRGL-01 CALL ERROR('TRGL-01: Too small array RAM') END IF TEXT='$' READ(LU,*,END=18) TEXT,(RAM(I),I=NVRTX+1,NVRTX+6) IF(TEXT.EQ.'$') THEN GO TO 18 END IF C Normalizing the normal AUX=SQRT(RAM(NVRTX+4)**2+RAM(NVRTX+5)**2+RAM(NVRTX+6)**2) RAM(NVRTX+4)=RAM(NVRTX+4)/AUX RAM(NVRTX+5)=RAM(NVRTX+5)/AUX RAM(NVRTX+6)=RAM(NVRTX+6)/AUX NVRTX=NVRTX+6 GO TO 10 18 CONTINUE CLOSE(LU) C C Reading polygons: DO 19 I=NVRTX+1,MRAM IRAM(I)=0 19 CONTINUE OPEN(LU,FILE=FPLGN) NPLGN=NVRTX NBIGON=0 20 CONTINUE IRAM(NPLGN+1)=IUNDEF READ(LU,*,END=29) (IRAM(I),I=NPLGN+1,MIN0(NPLGN+MVRTX+1,MRAM)) IF(IRAM(NPLGN+1).EQ.IUNDEF) THEN GO TO 29 END IF DO 21 I=NPLGN+1,MIN0(NPLGN+MVRTX+1,MRAM) IF(IRAM(I).LE.0) THEN C Number of polygon vertices N=I-1-NPLGN GO TO 22 ELSE IF(IRAM(I).GT.NVRTX/6) THEN C TRGL-02 WRITE(TEXT,'(A,I6)') 'TRGL-02: Wrong vertex index:',IRAM(I) CALL ERROR(TEXT(1:LENGTH(TEXT))) END IF 21 CONTINUE C TRGL-03 CALL ERROR('TRGL-03: Too many vertices in polygons') 22 CONTINUE IF(N.LT.3) THEN C TRGL-04 CALL ERROR('TRGL-04: Polygon of less than 3 vertices') END IF IF(NPLGN+4*(N-2).GT.MRAM) THEN C TRGL-05 CALL ERROR('TRGL-05: Too small array RAM') END IF C Checking vertex indices: DO 24 I2=NPLGN+1,NPLGN+N DO 23 I1=I2+1,NPLGN+N IF(IRAM(I2).EQ.IRAM(I1)) THEN C TRGL-06 WRITE(TEXT,'(A,I6)') * 'TRGL-06: The same vertex twice in a polygon:',IRAM(I2) CALL ERROR(TEXT(1:LENGTH(TEXT))) C All vertices of a polygon must have different indices. END IF 23 CONTINUE 24 CONTINUE C Check for identical indices: 25 CONTINUE DO 27 I2=NPLGN+1,NPLGN+N J1=6*(IRAM(I2)-1) IF(I2.LT.NPLGN+N) THEN J2=6*(IRAM(I2+1)-1) ELSE J2=6*(IRAM(NPLGN+1)-1) END IF IF(RAM(J1+1).EQ.RAM(J2+1).AND. * RAM(J1+2).EQ.RAM(J2+2).AND. * RAM(J1+3).EQ.RAM(J2+3)) THEN IF(RAM(J1+4).NE.RAM(J2+4).OR. * RAM(J1+5).NE.RAM(J2+5).OR. * RAM(J1+6).NE.RAM(J2+6)) THEN C TRGL-10 WRITE(TEXT,'(A,3I6)') * 'TRGL-10: Different normals at identical points:', * IRAM(I2),IRAM(I2+1) CALL ERROR(TEXT(1:LENGTH(TEXT))) C Two subsequent points of a polygon have the same C coordinates but different normals. END IF DO 26 I1=I2+1,NPLGN+N-1 IRAM(I1)=IRAM(I1+1) 26 CONTINUE IRAM(NPLGN+N)=0 N=N-1 GO TO 25 END IF 27 CONTINUE IF(N.LT.3) THEN NBIGON=NBIGON+1 GO TO 20 END IF C Leaving the space for N-2 triangles, each terminated by zero: DO 28 I=NPLGN+N+1,NPLGN+4*(N-2) IRAM(I)=0 28 CONTINUE NPLGN=NPLGN+4*(N-2) GO TO 20 29 CONTINUE IF(NBIGON.GT.0) THEN C TRGL-53 WRITE(TEXT,'(A,3I6)') * 'TRGL-53: Number of polygons with less than 3 vertices:', * NBIGON CALL WARN(TEXT(1:LENGTH(TEXT))) C Polygons with less than 3 vertices are created from polygons C with subsequent vertices of identical coordinates. END IF CLOSE(LU) C C Dividing polygons into triangles: IF(NVRTX.EQ.NPLGN) THEN C There are no polygons GO TO 49 END IF NTRGL=NVRTX C Loop over polygons 30 CONTINUE C Determining number N of polygon vertices DO 31 I=NTRGL+1,NPLGN IF(IRAM(I).LE.0) THEN N=I-1-NTRGL GO TO 32 END IF 31 CONTINUE 32 CONTINUE IF(N.EQ.3) THEN C Current polygon is a triangle, proceeding to the next polygon NTRGL=NTRGL+4 IF(NTRGL.LT.NPLGN) THEN GO TO 30 ELSE C All polygons are divided into triangles GO TO 49 END IF END IF C C Dividing the polygon into 2 polygons: K1=0 DMIN=1.0E20 C Loop over polygon vertices C (a) Determination of the handedness of the polygon HAND=0. DO 35 I2=1,N I3=MOD(I2,N)+1 IF(I2.GT.1) THEN I1=I2-1 ELSE I1=N END IF J1=6*(IRAM(NTRGL+I1)-1) J2=6*(IRAM(NTRGL+I2)-1) J3=6*(IRAM(NTRGL+I3)-1) X1=RAM(J2+1)-RAM(J1+1) X2=RAM(J2+2)-RAM(J1+2) X3=RAM(J2+3)-RAM(J1+3) Y1=RAM(J3+1)-RAM(J2+1) Y2=RAM(J3+2)-RAM(J2+2) Y3=RAM(J3+3)-RAM(J2+3) Z1=X2*Y3-X3*Y2 Z2=X3*Y1-X1*Y3 Z3=X1*Y2-X2*Y1 S=Z1*RAM(J2+4)+Z2*RAM(J2+5)+Z3*RAM(J2+6) C=X1*Y1+X2*Y2+X3*Y3 HAND=HAND+ATAN2(S,C) 35 CONTINUE C (b) Selection of the triangle to be separated DO 37 I2=1,N I3=MOD(I2,N)+1 IF(I2.GT.1) THEN I1=I2-1 ELSE I1=N END IF J1=6*(IRAM(NTRGL+I1)-1) J2=6*(IRAM(NTRGL+I2)-1) J3=6*(IRAM(NTRGL+I3)-1) X1=RAM(J2+1)-RAM(J1+1) X2=RAM(J2+2)-RAM(J1+2) X3=RAM(J2+3)-RAM(J1+3) Y1=RAM(J3+1)-RAM(J2+1) Y2=RAM(J3+2)-RAM(J2+2) Y3=RAM(J3+3)-RAM(J2+3) Z1=X2*Y3-X3*Y2 Z2=X3*Y1-X1*Y3 Z3=X1*Y2-X2*Y1 S=Z1*RAM(J2+4)+Z2*RAM(J2+5)+Z3*RAM(J2+6) IF(S*HAND.GT.0.) THEN C Normal Z to the separation plane X1=RAM(J3+1)-RAM(J1+1) X2=RAM(J3+2)-RAM(J1+2) X3=RAM(J3+3)-RAM(J1+3) Y1=RAM(J3+4)+RAM(J1+4) Y2=RAM(J3+5)+RAM(J1+5) Y3=RAM(J3+6)+RAM(J1+6) Z1=X2*Y3-X3*Y2 Z2=X3*Y1-X1*Y3 Z3=X1*Y2-X2*Y1 C Point on the diagonal Y1=RAM(J1+1) Y2=RAM(J1+2) Y3=RAM(J1+3) C Vertex to be separated D=Z1*(RAM(J2+1)-Y1)+Z2*(RAM(J2+2)-Y2)+Z3*(RAM(J2+3)-Y3) DMAX=0. IF(D*HAND.GT.0) THEN C Loop over opposite vertices DO 36 I=1,N IF(I.NE.I1.AND.I.NE.I2.AND.I.NE.I3) THEN J2=6*(IRAM(NTRGL+I)-1) AUX=Z1*(RAM(J2+1)-Y1)+Z2*(RAM(J2+2)-Y2) * +Z3*(RAM(J2+3)-Y3) DMAX=AMAX1(-AUX*SIGN(1.,HAND),DMAX) END IF 36 CONTINUE AUX=AMIN1(ABS(D),DMAX) IF(AUX.GT.0.) THEN AUX=ABS((RAM(J3+4)-RAM(J1+4))*X1 * +(RAM(J3+5)-RAM(J1+5))*X2 * +(RAM(J3+6)-RAM(J1+6))*X3) * *SQRT(X1*X1+X2*X2+X3*X3)/AUX IF(K1.EQ.0.OR.AUX.LT.DMIN) THEN K1=MIN0(I1,I3) K2=MAX0(I1,I3) DMIN=AUX END IF END IF END IF END IF 37 CONTINUE C ^^^^^^^^ C Loop over polygon diagonals to find the best one for division *521 DO 42 I1=1,N-2 * DO 42 I1=1,N * J1=6*(IRAM(NTRGL+I1)-1) C521 Loop over all polygon diagonals *521 DO 41 I2=I1+2,N+MIN0(I1-2,0) C-NEW *** C Limiting the loop to a single diagonal per vertex * I2=MOD(I1+1,N)+1 * J2=6*(IRAM(NTRGL+I2)-1) C Normal Z to the separation plane * X1=RAM(J2+1)-RAM(J1+1) * X2=RAM(J2+2)-RAM(J1+2) * X3=RAM(J2+3)-RAM(J1+3) * Y1=RAM(J2+4)+RAM(J1+4) * Y2=RAM(J2+5)+RAM(J1+5) * Y3=RAM(J2+6)+RAM(J1+6) * Z1=X2*Y3-X3*Y2 * Z2=X3*Y1-X1*Y3 * Z3=X1*Y2-X2*Y1 C Point on the diagonal * Y1=RAM(J1+1) * Y2=RAM(J1+2) * Y3=RAM(J1+3) C Vertex to be separated * I3=MOD(I1,N)+1 * J3=6*(IRAM(NTRGL+I3)-1) * D=Z1*(RAM(J3+1)-Y1)+Z2*(RAM(J3+2)-Y2)+Z3*(RAM(J3+3)-Y3) * DMAX=0. * IF(D.NE.0) THEN C Loop over opposite vertices * DO 35 I=1,N * IF(I.NE.I1.AND.I.NE.I2.AND.I.NE.I3) THEN * J3=6*(IRAM(NTRGL+I)-1) * AUX=Z1*(RAM(J3+1)-Y1)+Z2*(RAM(J3+2)-Y2) * * +Z3*(RAM(J3+3)-Y3) * IF(AUX*D.GE.0.) THEN C Vertex I3 is not separated from opposite vertices * GO TO 41 * END IF * DMAX=AMAX1(ABS(AUX),DMAX) * END IF * 35 CONTINUE * AUX=SQRT((RAM(J2+4)-RAM(J1+4))**2 * * +(RAM(J2+5)-RAM(J1+5))**2 * * +(RAM(J2+6)-RAM(J1+6))**2) * * *(X1*X1+X2*X2+X3*X3)/AMIN1(ABS(D),DMAX) * IF(K1.EQ.0.OR.AUX.LT.DMIN) THEN * K1=MIN0(I1,I2) * K2=MAX0(I1,I2) * DMIN=AUX * END IF * END IF * 41 CONTINUE * 42 CONTINUE C ^^^^^^^^ IF(K1.EQ.0) THEN C TRGL-09 WRITE(TEXT,'(A,7I6)') * 'TRGL-09: Polygon cannot be divided:', * (IRAM(I),I=NTRGL+1,NTRGL+MIN0(7,N)) IF(N.GT.7) THEN TEXT(78:80)='...' END IF CALL ERROR(TEXT(1:LENGTH(TEXT))) C No polygon vertex can be separated from all opposite polygon C vertices by the plane determined by the diagonal connecting C the two adjacent vertices and the sum of the normals in the C adjacent vertices. END IF C v---521---v C Dividing polygon along diagonal between K1-th and K2-th vertices N1=K1+N-K2+1 N2=K2-K1+1 C Doubling K2-th and K1-th vertices DO 43 I=NTRGL+N,NTRGL+K2,-1 IRAM(I+1)=IRAM(I) 43 CONTINUE DO 44 I=NTRGL+N+1,NTRGL+K1,-1 IRAM(I+1)=IRAM(I) 44 CONTINUE C Moving vertices K2,K2+1,...,N C between vertices 1,2,...,K1 and K1,K1+1,...,K2 DO 46 I2=K2,N I=IRAM(NTRGL+N+2) DO 45 I1=NTRGL+N+1,NTRGL+K1+1,-1 IRAM(I1+1)=IRAM(I1) 45 CONTINUE IRAM(NTRGL+K1+1)=I 46 CONTINUE C Moving the second polygon to the proper location DO 47 I=NTRGL+N2,NTRGL+1,-1 IRAM(I+4*(N1-2))=IRAM(I+N1) 47 CONTINUE C Storing zeros between the polygons DO 48 I=NTRGL+4*(N1-2),NTRGL+N1+1,-1 IRAM(I)=0 48 CONTINUE GO TO 30 49 CONTINUE C C Making triangles right-handed with respect to the normals: DO 51 I=NVRTX+1,NPLGN,4 IF(IRAM(I+3).NE.0) THEN C TRGL-07 CALL ERROR('TRGL-07: Triangle not terminated by 0') C This errror should not appear. Contact the author. END IF J1=6*(IRAM(I )-1) J2=6*(IRAM(I+1)-1) J3=6*(IRAM(I+2)-1) X1=RAM(J2+1)-RAM(J1+1) X2=RAM(J2+2)-RAM(J1+2) X3=RAM(J2+3)-RAM(J1+3) Y1=RAM(J3+1)-RAM(J2+1) Y2=RAM(J3+2)-RAM(J2+2) Y3=RAM(J3+3)-RAM(J2+3) Z1=X2*Y3-X3*Y2 Z2=X3*Y1-X1*Y3 Z3=X1*Y2-X2*Y1 IF(Z1.EQ.0..AND.Z2.EQ.0..AND.Z3.EQ.0.) THEN C TRGL-51 WRITE(TEXT,'(A,3I6)') * 'TRGL-51: Triangle has shrunk into a line:', * IRAM(I),IRAM(I+1),IRAM(I+2) CALL WARN(TEXT(1:LENGTH(TEXT))) C The sides of a triangle are parallel. C Marking the triangle linear in order not to write it into the C output file: IRAM(I+3)=-1 ELSE A1=Z1*RAM(J1+4)+Z2*RAM(J1+5)+Z3*RAM(J1+6) A2=Z1*RAM(J2+4)+Z2*RAM(J2+5)+Z3*RAM(J2+6) A3=Z1*RAM(J3+4)+Z2*RAM(J3+5)+Z3*RAM(J3+6) IF(A1.LT.0..AND.A2.LT.0..AND.A3.LT.0.) THEN C Changing left-handed triangle into right-handed one J2=IRAM(I+1) J3=IRAM(I+2) IRAM(I+1)=J3 IRAM(I+2)=J2 ELSE IF(A1.LE.0..OR.A2.LE.0..OR.A3.LE.0.) THEN AUX=X1*(X1+Y1)+Y1*Y1+X2*(X2+Y2)+Y2*Y2+X3*(X3+Y3)+Y3*Y3 AUX=SQRT(Z1*Z1+Z2*Z2+Z3*Z3)/AUX IF(AUX.LE.0.000010) THEN C TRGL-52 WRITE(TEXT,'(A,3I6)') * 'TRGL-52: Triangle is too narrow:', * IRAM(I),IRAM(I+1),IRAM(I+2) CALL WARN(TEXT(1:LENGTH(TEXT))) C Triangle is too narrow, i.e., the area of the triangle C is too small compared with the sum of the squares of its C sides. C Marking the triangle linear in order not to write it into C the output file: IRAM(I+3)=-1 ELSE C TRGL-08 WRITE(TEXT,'(A,3I6)') * 'TRGL-08: Wrong normals at the triangle vertices:', * IRAM(I),IRAM(I+1),IRAM(I+2) CALL ERROR(TEXT(1:LENGTH(TEXT))) C Normals at the triangle vertices do not point at the same C side of the triangle. END IF END IF END IF 51 CONTINUE C C Writing triangles: OPEN(LU,FILE=FTRGL) FORMAT='(3(I0,A))' I=INT(ALOG10(FLOAT(NVRTX)+0.5))+1 FORMAT(5:5)=CHAR(ICHAR('0')+I) DO 61 I=NVRTX+1,NPLGN,4 IF(IRAM(I+3).EQ.0) THEN WRITE(LU,FORMAT) IRAM(I),' ',IRAM(I+1),' ',IRAM(I+2),' /' END IF 61 CONTINUE CLOSE(LU) C IF(NVRTX.EQ.NPLGN) THEN C There are no polygons WRITE(*,'(A)') '+TRGL: No triangles. ' ELSE WRITE(*,'(A)') '+TRGL: Done. ' END IF STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for C C======================================================================= Ctrglnorm.for 0100666 0000765 0000765 00000034061 07304363410 013011 0 ustar bulant bulant C
C Program TRGLNORM to compute normals to given triangles C C Version: 5.50 C Date: 2000, September 4 C C Coded by: Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C This program reads file TRGL with triangles (or polygons) and the C corresponding file VRTX with coordinates of the vertices of the C triangles (polygons). Then it computes vector product W of the vector C [first vertex , second vertex] with the vector C [second vertex , third vertex]. If the scalar product of vector W C with the input vector given by VECT1, VECT2 and VECT3 is nonnegative, C the program writes the triangle (polygon) to the output file TRGLN, C and the coordinates of vertices together with the vector W to the C output file VRTXN. The vertex being used in several triangles C in file TRGL is thus written to file VRTXN several times with C different normals W. C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C VRTX='string'... Name of the file with vertices of the triangles. C Description of file VRTX C Default: VRTX='vrtx.out' C TRGL='string'... Name of the file with the triangles or polygons. C Description of file TRGL C Default: TRGL='trgl.out' C Selection vector: C VECT1=real,VECT2=real,VECT3=real ... Three components of the C selection vector. The triangles (polygons) and the C corresponding vertices are written to the output files C only if the scalar product of the selection vector with C the normal to the triangle is nonnegative. C Default: VECT1=0.,VECT2=0.,VECT3=0. means that all the C triangles are written to the output files. C Data specifying output files: C VRTXN='string'... Name of the file with vertices of the triangles. C Description of file VRTXN C Default: VRTXN='vrtxn.out' C TRGLN='string'... Name of the file with the triangles or polygons. C Description of file TRGLN C Default: TRGLN='trgln.out' C Data specifying form of output files: C KOLUM1=integer,KOLUM2=integer,KOLUM3=integer ... Indices of the C columns, where to write the components of the computed C normal vector. C Default: KOLUM1=4,KOLUM2=5,KOLUM3=6 C C C Input file VRTX with the vertices: C (1) None to several strings terminated by / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,/ C 'NAME'... Name of the vertex. Not considered. May be blank. C X1,X2,X3... Coordinates of the vertex. C /... None to several values terminated by a slash. C (3) / or end of file. C C C Input file TRGL with the triangles: C (1) For each triangle data (1.1): C (1.1) I1,I2,I3,/ C I1,I2,I3... Indices of 3 (or more in case of polygon) vertices C of the triangle. C The vertices in file VRTX are indexed by positive integers C according to their order. C /... List of vertices of the triangle is terminated by a slash. C C C Output file VRTXN with the vertices: C (1) / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,W1,W2,W3,/ C 'NAME'..Name of the vertex. String in apostrophes containing C the index of the vertex corresponding to file TRGLN. C X1,X2,X3,W1,W2,W3... KOLUMi-th column of the input file is C replaced by the value of i-th component of the normal C to the corresponding triangle in file TRGLN. C If the input file VRTX contains less than C MAX(KOLUM1,KOLUM2,KOLUM3) values, the missing values C are replaced by the value of parameter UNDEF, see below. C / ... A slash. C (3) / (a slash) C C C Output file TRGLN with the triangles: C (1) For each triangle data (1.1): C (1.1) I1,I2,I3,/ C I1,I2,I3... Indices of 3 (or more in case of polygon) vertices C of the triangle. C The vertices in file VRTXN are indexed by positive C integers according to their order. C /... List of vertices of the triangle is terminated by a slash. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C EXTERNAL LENGTH,ERROR,FORM1,WARN,RSEP1,RSEP3T,RSEP3R,RSEP3I INTEGER LENGTH C C....................................................................... C C Filenames and parameters: CHARACTER*80 FSEP,FVRTX,FTRGL,FVRTXN,FTRGLN INTEGER LU,LU1,LU2,IUNDEF,MVRTX PARAMETER (LU=1,LU1=2,LU2=3,IUNDEF=-999999,MVRTX=1000) REAL UNDEF PARAMETER (UNDEF=9.9E9) C Input data: REAL VECT1,VECT2,VECT3 CHARACTER*10 FORMA1 CHARACTER*26 FORMA2 CHARACTER*80 TEXT C Other variables: INTEGER NVRTX,NBIGON,N,I,I1,I2,J1,J2,J3,NQ INTEGER NPTS,KOLUM1,KOLUM2,KOLUM3 REAL A1,A2,A3,B1,B2,B3,W1,W2,W3,AUX,OUTMIN,OUTMAX C C MVRTX...Maximum number of vertices of one polygon. C NVRTX...Number of storage locations for the vertices, i.e. 6 times C the number of vertices. C NTRGL...Last storage location with triangles, i.e. NVRTX + 4 times C the number of created triangles. C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+TRGLNORM: Enter input filename: ' FSEP=' ' READ (*,*) FSEP WRITE(*,'(A)') '+TRGLNORM: Working... ' C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C TRGLNORM-01 CALL ERROR('TRGLNORM-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input and output filenames: CALL RSEP3T('VRTX',FVRTX,'vrtx.out') CALL RSEP3T('TRGL',FTRGL,'trgl.out') CALL RSEP3T('VRTXN',FVRTXN,'vrtxn.out') CALL RSEP3T('TRGLN',FTRGLN,'trgln.out') C C Reading the selection vector: CALL RSEP3R('VECT1',VECT1,0.) CALL RSEP3R('VECT2',VECT2,0.) CALL RSEP3R('VECT3',VECT3,0.) C C Reading the columns where to write the normal: CALL RSEP3I('KOLUM1',KOLUM1,4) CALL RSEP3I('KOLUM2',KOLUM2,5) CALL RSEP3I('KOLUM3',KOLUM3,6) C C Reading vertices: OPEN(LU,FILE=FVRTX,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) NVRTX=0 NQ=MAX0(3,KOLUM1,KOLUM2,KOLUM3) 10 CONTINUE IF(NVRTX+NQ.GT.MRAM) THEN C TRGLNORM-02 CALL ERROR('TRGLNORM-02: Too small array RAM') END IF DO 12, I=1,NQ RAM(NVRTX+I)=UNDEF 12 CONTINUE TEXT='$' READ(LU,*,END=18) TEXT,(RAM(I),I=NVRTX+1,NVRTX+NQ) IF(TEXT.EQ.'$') THEN GO TO 18 END IF NVRTX=NVRTX+NQ GO TO 10 18 CONTINUE CLOSE(LU) C C Output format for the file with polygons FORMA1='(99(I0,A))' FORMA2='(A,1I0.0,A,00(F00.0,1X),A)' I=INT(ALOG10(FLOAT(NVRTX/NQ)))+1 IF (I.GT.9) THEN C TRGLNORM-03 CALL ERROR('TRGLNORM-03: Too many vertices in file VRTX') C This format specification allows for maximum of 100 000 000 C of vertices in file VRTX ENDIF FORMA1(6:6)=CHAR(ICHAR('0')+I) FORMA2(6:6)=FORMA1(6:6) FORMA2(8:8)=FORMA1(6:6) FORMA2(13:13)=CHAR(ICHAR('0')+MOD(NQ/1,10)) FORMA2(12:12)=CHAR(ICHAR('0')+MOD(NQ/10,10)) C C Reading polygons: DO 19 I=NVRTX+1,MRAM IRAM(I)=0 19 CONTINUE OPEN(LU,FILE=FTRGL,STATUS='OLD') IF (FVRTXN.NE.' ') OPEN(LU1,FILE=FVRTXN) IF (FTRGLN.NE.' ') OPEN(LU2,FILE=FTRGLN) IF (FVRTXN.NE.' ') WRITE(LU1,'(A)') '/' NPTS=0 NBIGON=0 C Loop over the polygons: 20 CONTINUE IRAM(NVRTX+1)=IUNDEF READ(LU,*,END=29) (IRAM(I),I=NVRTX+1,MIN0(NVRTX+MVRTX+1,MRAM)) IF(IRAM(NVRTX+1).EQ.IUNDEF) THEN GO TO 29 END IF DO 21 I=NVRTX+1,MIN0(NVRTX+MVRTX+1,MRAM) IF(IRAM(I).LE.0) THEN C Number of polygon vertices N=I-1-NVRTX GO TO 22 ELSE IF(IRAM(I).GT.NVRTX/NQ) THEN C TRGLNORM-04 WRITE(TEXT,'(A,I6)') * 'TRGLNORM-04: Wrong vertex index:',IRAM(I) CALL ERROR(TEXT(1:LENGTH(TEXT))) END IF 21 CONTINUE C TRGLNORM-05 CALL ERROR('TRGLNORM-05: Too many vertices in polygons') 22 CONTINUE IF(N.LT.3) THEN C TRGLNORM-06 CALL ERROR('TRGLNORM-06: Polygon of less than 3 vertices') END IF C Check for identical indices of vertices: DO 24 I2=NVRTX+1,NVRTX+N DO 23 I1=I2+1,NVRTX+N IF(IRAM(I2).EQ.IRAM(I1)) THEN C TRGLNORM-07 WRITE(TEXT,'(A,I6)') * 'TRGLNORM-07: The same vertex twice in a polygon:',IRAM(I2) CALL ERROR(TEXT(1:LENGTH(TEXT))) C All vertices of a polygon must have different indices. END IF 23 CONTINUE 24 CONTINUE C Check for identical coordinates of vertices: 25 CONTINUE DO 27 I2=NVRTX+1,NVRTX+N J1=NQ*(IRAM(I2)-1) IF(I2.LT.NVRTX+N) THEN J2=NQ*(IRAM(I2+1)-1) ELSE J2=NQ*(IRAM(NVRTX+1)-1) END IF IF(RAM(J1+1).EQ.RAM(J2+1).AND. * RAM(J1+2).EQ.RAM(J2+2).AND. * RAM(J1+3).EQ.RAM(J2+3)) THEN C Two subsequent points of a polygon have the same coordinates DO 26 I1=I2+1,NVRTX+N-1 IRAM(I1)=IRAM(I1+1) 26 CONTINUE IRAM(NVRTX+N)=0 N=N-1 GO TO 25 END IF 27 CONTINUE IF(N.LT.3) THEN NBIGON=NBIGON+1 GO TO 20 END IF J1=NQ*(IRAM(NVRTX+1)-1) J2=NQ*(IRAM(NVRTX+2)-1) J3=NQ*(IRAM(NVRTX+3)-1) A1=RAM(J2+1)-RAM(J1+1) A2=RAM(J2+2)-RAM(J1+2) A3=RAM(J2+3)-RAM(J1+3) B1=RAM(J3+1)-RAM(J1+1) B2=RAM(J3+2)-RAM(J1+2) B3=RAM(J3+3)-RAM(J1+3) W1=A2*B3-B2*A3 W2=A3*B1-B3*A1 W3=A1*B2-B1*A2 C Normalizing the normal: AUX=SQRT(W1**2+W2**2+W3**2) W1=W1/AUX W2=W2/AUX W3=W3/AUX C Scalar product with selection vector: AUX=VECT1*W1+VECT2*W2+VECT3*W3 IF (AUX.GE.0.) THEN IF (FTRGLN.NE.' ') THEN C Writing the polygon: WRITE(LU2,FORMA1) (NPTS+I,' ',I=1,N-1),NPTS+N,' /' ENDIF IF (FVRTXN.NE.' ') THEN C Writing the vertices: DO 28, I1=NVRTX+1,NVRTX+N J1=NQ*(IRAM(I1)-1) RAM(J1+KOLUM1)=W1 RAM(J1+KOLUM2)=W2 RAM(J1+KOLUM3)=W3 OUTMIN=0. OUTMAX=0. DO 16, I=J1+1,J1+NQ IF(RAM(I).LT.OUTMIN) OUTMIN=RAM(I) IF(RAM(I).GT.OUTMAX) OUTMAX=RAM(I) 16 CONTINUE CALL FORM1(OUTMIN,OUTMAX,FORMA2(15:22)) FORMA2(21:24)= '1X),' NPTS=NPTS+1 WRITE(LU1,FORMA2) * ' ''',NPTS,''' ',(RAM(J1+I),I=1,NQ),'/' 28 CONTINUE ENDIF ENDIF GO TO 20 C End of the loop over the polygons. 29 CONTINUE IF(NBIGON.GT.0) THEN C TRGLNORM-08 WRITE(TEXT,'(A,3I6)') * 'TRGLNORM-08: Number of polygons with less than 3 vertices:', * NBIGON CALL WARN(TEXT(1:LENGTH(TEXT))) C Polygons with less than 3 vertices are created from polygons C with subsequent vertices of identical coordinates. END IF CLOSE(LU) IF (FVRTXN.NE.' ') WRITE(LU1,'(A)') '/' IF (FVRTXN.NE.' ') CLOSE(LU1) IF (FTRGLN.NE.' ') CLOSE(LU2) WRITE(*,'(A)') '+TRGLNORM: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Ctrglps.for 0100666 0000765 0000765 00000065032 07311326664 012472 0 ustar bulant bulant C
C Program TRGLPS to display values defined in vertices of triangulated C 2-D sections in PostScript. C C Version: 5.50 C Date: 2001, June 12 C C Coded by Petr Bulant C Department of Geophysics, Charles University Prague C Ke Karlovu 3, 121 16 Praha 2, Czech Republic C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C VRTX='string'... Name of the file with vertices of the polygons. C Description of file VRTX C Default: VRTX='vrtx.out' C TRGL='string'... Name of the file describing the triangles C of the 2-D section. C Description of file TRGL C Default: TRGL='trgl.out' C Output PostScript file: C TRGLPS='string'... Name of the output PostScript file. C It is recommended to specify TRGLPS rather than to use the C default name. C Default: TRGLPS='trglps.ps' C Data describing dimensions and layout of the picture: C UNIT='string'... All lengths controlling the size and position of C the plot are assumed to be expressed in the units given C by the string. The units also influence the default C paper size, plot size and margins. Allowed values: C UNIT='cm': centimetres (default), C UNIT='in': inches (1in=2.54cm). C XSIGN=real... Determines the sign of the default value of HSIZE. C Default: XSIGN=1. C HSIZE=real... Size (in UNITs) of the image, corresponding to the C X1 plot axis (horizontal before a possible rotation). C If negative, the values will be displayed from the right C to the left. C Default: HSIZE=SIGN( 16.0,XSIGN) for UNIT='cm', C HSIZE=SIGN( 6.5,XSIGN) for UNIT='in', C YSIGN=real... Determines the sign of the default value of VSIZE. C Default: YSIGN=1. C VSIZE=real... Size (in UNITs) of the image, corresponding to the C X2 plot axis (vertical before a possible rotation). C If negative, the values will be displayed from the top to C the bottom. C Default (proportional display): C VSIZE=SIGN(HSIZE*DY/DX,YSIGN) where DY=YMAX-YMIN is the C extent of the coordinates of vertices corresponding to C X2 plot axis, DX is the extent corresponding to X1 axis. C HOFFSET=real... Distance (in UNITs) of the image from the leftmost C paper edge (before a possible rotation). Controls the C horizontal position of the figure. C Default: HOFFSET=2.5 for UNIT='cm', C HOFFSET=1.0 for UNIT='in', C VOFFSET=real... Distance (in UNITs) of the image from the bottom C paper edge (before a possible rotation). Controls the C vertical position of the figure. C Default: C if VSIZE.LE.HEIGHT-2*2.5: VOFFSET=HEIGHT-2.5-VSIZE C otherwise if VSIZE.LE.HEIGHT: VOFFSET=(HEIGHT-VSIZE)/2. C otherwise: VOFFSET=2.5 C HEIGHT=real... Height of the paper in a portrait position. C Default: HEIGHT=29.7 for UNIT='cm', C HEIGHT=11.0 for UNIT='in', C ROTATE=real... Enables to rotate the image by angle specified in C degrees (positive counterclockwise). The image is rotated C around the centre of the square paper of size HEIGHT. C If applied, the user will probably wish to specify the C value of ROTATE=90. C Parameters HSIZE,VSIZE,HOFFSET,VOFFSET apply to the image C before rotation. C Attention: BoundingBox is incorrect if ROTATE is not C multiple of 90 degrees. C Default: ROTATE=0. C LEFT=integer... Determines, whether the 2-D section is to be C displayed in right-handed coordinate system with the C X1 plot axis corresponding to x1 (x2, x3 respectively) C section axis and X2 plot axis corresponding to C x2 (x3, x1 respectively) section axis, C or rather in left-handed system with X1 plot axis C corresponding to x2 (x3, x1) and X2 to x1 (x2, x3). C LEFT=0 ... Right-handed system C otherwise ... Left-handed system C Default: LEFT=0 C Data specifying the values to be scaled in colours: C KOLSRF=integer ... number of a column in file VRTX. The triangles C will be filled by colours according to the values written C in the KOLSRFth column of file VRTX. C Default: KOLSRF=7 C Data specifying the colour scale: C COLORS='string'... Name of the file containing the data describing C the colour map. C Description of file COLORS C Default: COLORS='hsv.dat' (mostly sufficient) C VADD=real, VMUL=real, VPER=real, VREF=real, CREF=real, CREF1=real, C CREF2=real, CREF3=real, etc... Refer to file C colors.for. C VDIV=real... Period of values corresponding to one colour. The C triangles are divided into smaller polygons, in such way, C that the extent of values in the vertices of the polygons C is less than VDIV. C Default: VDIV=VPER/256. C R=real, G=real, B=real... Colour of the undefined C values. C Defaults: R=0.80, G=0.80, B=0.80 (light grey) C C C Input file VRTX with the vertices of the triangles: C (1) None to several strings terminated by / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,Z1,Z2,Z3,/ C 'NAME'... Name of the vertex. Not considered. May be blank. C X1,X2,X3... Coordinates of the vertex. C Z1,Z2,Z3... Normal to the triangle at the vertex. Must be either C [1.,0.,0.], or [0.,1.,0.], or [0.,0.,1.]. C /... None to several values terminated by a slash. C (3) / (a slash) or end of file. C C C Input file TRGL with the triangles: C (1) For each triangle data (1.1): C (1.1) I1,I2,I3,/ C I1,I2,I3... Indices of 3 vertices of the triangle, right-handed C with respect to the given surface normals. C The vertices in file VRTX are indexed by positive integers C according to their order. C /... List of vertices of the triangle is terminated by a slash. C C======================================================================= C Subroutines and external functions required: EXTERNAL CHANGE,ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I,FORM1,LOWER, *LENGTH,COLOR1,COLOR2,COLOR3 INTEGER LENGTH C CHANGE ... This file. C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... C File sep.for. C FORM1,LOWER ... File forms.for. C LENGTH ... File length.for. C COLOR1,COLOR2,COLOR3 ... File colors.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) INTEGER NVRTX,NPLGN C....................................................................... C INTEGER LU PARAMETER (LU=1) CHARACTER*80 FSEP,FOUT,FVRTX,FTRGL,FCOLS CHARACTER*255 TEXT,FORMAT INTEGER LEFT LOGICAL LRIGHT INTEGER KOLSRF,KQ,NQ REAL ROTATE,R,G,B,COLOR,DC CHARACTER*2 UNIT REAL UNITPT,HEIGHT,OFFSET,WIDTH REAL XSIGN,YSIGN REAL XMIN,XMAX,YMIN,YMAX,CMIN,CMAX,DX,DY REAL BBOX1,BBOX2,BBOX3,BBOX4,BB1,BB2,BB3,BB4 REAL BB1P,BB2P,BB3P,BB4P,BB2DEF,BB4DEF,AUX,C,S INTEGER I1,I2 INTEGER JX1,JY1,JC1,JX2,JY2,JC2,JX3,JY3,JC3 REAL X2A,Y2A,X2B,Y2B,X3A,Y3A,X3B,Y3B REAL DC2,DC3,DC4,DX2,DY2,DX3,DY3,DX4,DY4 REAL B1,B2,B3,B4 C C UNIT... One of: 'cm', 'in'. C UNITPT...Size of the length unit, in which input data controlling C the size and position of the plot are expressed, in big C points (pt). E.g., UNITPT=72./2.54 corresponds to C plotting in cm. C HEIGHT..Anticipated height of the paper sheet. C OFFSET..Left margin, and top or bottom margin for low or high C plots, respectively. C WIDTH...Default width of the plot. C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: FSEP=' ' WRITE(*,'(A)') '+TRGLPS: Enter input filename:' READ(*,*) FSEP WRITE(*,'(A)') '+TRGLPS: Working... ' C C Reading all the data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C TRGLPS-01 CALL ERROR('TRGLPS-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input and output filenames: CALL RSEP3T('VRTX' ,FVRTX,'vrtx.out') CALL RSEP3T('TRGL' ,FTRGL,'trgl.out') CALL RSEP3T('COLORS',FCOLS,'hsv.dat' ) CALL RSEP3T('TRGLPS',FOUT ,'trglps.ps') C C C Reading vertices: CALL RSEP3I('LEFT',LEFT,0) LRIGHT=.TRUE. IF (LEFT.NE.0) LRIGHT=.FALSE. CALL RSEP3I('KOLSRF',KOLSRF,7) KQ=MAX0(6,KOLSRF) IF (KOLSRF.LE.0) THEN C NQ=2 C TRGLPS-02 CALL ERROR('TRGLPS-02: Wrong value of KOLSRF') C KOLSRF must be positive integer. ELSE NQ=3 ENDIF OPEN(LU,FILE=FVRTX,FORM='FORMATTED',STATUS='OLD') READ(LU,*) (TEXT,I1=1,20) NVRTX=0 10 CONTINUE IF (NVRTX+KQ.GT.MRAM) THEN C TRGLPS-03 CALL ERROR('TRGLPS-03: Too small array RAM') ENDIF TEXT='$' RAM(NVRTX+4)=0. RAM(NVRTX+5)=0. RAM(NVRTX+6)=0. IF (KOLSRF.GT.0) THEN RAM(NVRTX+KOLSRF)=0. ENDIF READ(LU,*,END=19) TEXT,(RAM(I1),I1=NVRTX+1,NVRTX+KQ) IF (TEXT.EQ.'$') GOTO 19 C Shifting the coordinates to columns 1 to 2: IF (RAM(NVRTX+4).EQ.1.) THEN RAM(NVRTX+1)=RAM(NVRTX+2) RAM(NVRTX+2)=RAM(NVRTX+3) ELSEIF (RAM(NVRTX+5).EQ.1.) THEN RAM(NVRTX+2)=RAM(NVRTX+1) RAM(NVRTX+1)=RAM(NVRTX+3) ELSEIF (RAM(NVRTX+6).EQ.1.) THEN C RAM(NVRTX+1)=RAM(NVRTX+1) C RAM(NVRTX+2)=RAM(NVRTX+2) CONTINUE ELSE C TRGLPS-04 CALL ERROR('TRGLPS-04: Wrong normal') C Input grid must be 2-D, one of the components of the normal C must equal 1, and the other two must equal zero. ENDIF IF (.NOT.LRIGHT) THEN AUX=RAM(NVRTX+1) RAM(NVRTX+1)=RAM(NVRTX+2) RAM(NVRTX+2)=AUX ENDIF C Shifting the value of color to column 3: IF (KOLSRF.GT.0) THEN RAM(NVRTX+3)=RAM(NVRTX+KOLSRF) ENDIF C Recording the minima and maxima of the coordinates: IF (NVRTX.EQ.0) THEN XMIN=RAM(NVRTX+1) XMAX=RAM(NVRTX+1) YMIN=RAM(NVRTX+2) YMAX=RAM(NVRTX+2) CMIN=RAM(NVRTX+3) CMAX=RAM(NVRTX+3) ELSE XMIN=AMIN1(XMIN,RAM(NVRTX+1)) XMAX=AMAX1(XMAX,RAM(NVRTX+1)) YMIN=AMIN1(YMIN,RAM(NVRTX+2)) YMAX=AMAX1(YMAX,RAM(NVRTX+2)) CMIN=AMIN1(CMIN,RAM(NVRTX+3)) CMAX=AMAX1(CMAX,RAM(NVRTX+3)) ENDIF NVRTX=NVRTX+NQ GOTO 10 19 CONTINUE CLOSE(LU) DX=XMAX-XMIN DY=YMAX-YMIN IF (DX.LE.0..OR.DY.LE.0.) THEN C TRGLPS-05 CALL ERROR('TRGLPS-05: Infinitely thin section') C The section should be two-dimensional. ENDIF C C C Recalling the plotting unit and setting default dimensions: CALL RSEP3T('UNIT',UNIT,'cm') CALL LOWER(UNIT) IF (UNIT.EQ.'cm') THEN UNITPT=72./2.54 HEIGHT=29.7 OFFSET=2.5 WIDTH=16.0 ELSEIF (UNIT.EQ.'in') THEN UNITPT=72. HEIGHT=11.0 OFFSET=1.0 WIDTH=6.5 * ELSEIF (UNIT.EQ.'pt') THEN * UNITPT=1. * HEIGHT=FLOAT(N32*N2) * OFFSET=0.0 * WIDTH=FLOAT(N31*N1) ELSE C TRGLPS-06 CALL ERROR('TRGLPS-06: Unrecognized plotting units') C Allocated plotting units are UNIT='cm', UNIT='in' or UNIT='pt'. ENDIF C C C Recalling the data for the plotting area: CALL RSEP3R('XSIGN' ,XSIGN,1.) CALL RSEP3R('YSIGN' ,YSIGN,1.) AUX=HEIGHT CALL RSEP3R('HEIGHT' ,HEIGHT,AUX) CALL RSEP3R('HSIZE' ,BB3,SIGN(WIDTH,XSIGN)) CALL RSEP3R('HOFFSET',BB1,OFFSET) C Default height of the figure (proportional image): BB4DEF=ABS(BB3)*DY/DX CALL RSEP3R('VSIZE' ,BB4,SIGN(BB4DEF,YSIGN)) C Default vertical position of the figure: IF (ABS(BB4).LE.HEIGHT-2.*OFFSET) THEN BB2DEF=HEIGHT-OFFSET-ABS(BB4) ELSEIF(ABS(BB4).LE.HEIGHT) THEN BB2DEF=(HEIGHT-ABS(BB4))/2. ELSE BB2DEF=OFFSET ENDIF CALL RSEP3R('VOFFSET',BB2,BB2DEF) IF (BB3.LT.0.) BB1=BB1-BB3 IF (BB4.LT.0.) BB2=BB2-BB4 CALL RSEP3R('ROTATE',ROTATE,0.) C C Transformation from plotting units (e.g. centimetres) to points: BB1P=BB1*UNITPT BB2P=BB2*UNITPT BB3P=BB3*UNITPT BB4P=BB4*UNITPT C C Bounding box: BBOX1=AMIN1(BB1P,BB1P+BB3P) BBOX2=AMIN1(BB2P,BB2P+BB4P) BBOX3=AMAX1(BB1P,BB1P+BB3P) BBOX4=AMAX1(BB2P,BB2P+BB4P) B1=BBOX1 B2=BBOX2 B3=BBOX3 B4=BBOX4 IF(ROTATE.NE.0.) THEN C=COS(ROTATE*3.14159/180.) S=SIN(ROTATE*3.14159/180.) BBOX1=BBOX1-HEIGHT*UNITPT/2. BBOX2=BBOX2-HEIGHT*UNITPT/2. BBOX3=BBOX3-HEIGHT*UNITPT/2. BBOX4=BBOX4-HEIGHT*UNITPT/2. AUX =C*BBOX1-S*BBOX2 BBOX2=S*BBOX1+C*BBOX2 BBOX1=AUX AUX =C*BBOX3-S*BBOX4 BBOX4=S*BBOX3+C*BBOX4 BBOX3=AUX BBOX1=BBOX1+HEIGHT*UNITPT/2. BBOX2=BBOX2+HEIGHT*UNITPT/2. BBOX3=BBOX3+HEIGHT*UNITPT/2. BBOX4=BBOX4+HEIGHT*UNITPT/2. AUX =AMIN1(BBOX1,BBOX3) BBOX3=AMAX1(BBOX1,BBOX3) BBOX1=AUX AUX =AMIN1(BBOX2,BBOX4) BBOX4=AMAX1(BBOX2,BBOX4) BBOX2=AUX ENDIF C C C Recomputing true coordinates of the vertices into page coordinates DO 20, I1=1,NVRTX,NQ RAM(I1)=(RAM(I1)-XMIN)/DX*BB3P+BB1P RAM(I1+1)=(RAM(I1+1)-YMIN)/DY*BB4P+BB2P 20 CONTINUE C C C Reading the triangles: DO 81 I1=NVRTX+1,MRAM IRAM(I1)=0 81 CONTINUE OPEN(LU,FILE=FTRGL,FORM='FORMATTED',STATUS='OLD') NPLGN=NVRTX 82 CONTINUE IF (NPLGN.GT.MRAM) THEN C TRGLPS-07 CALL ERROR('TRGLPS-07: Too small array RAM') ENDIF READ(LU,*,END=89) (IRAM(I1),I1=NPLGN+1,NPLGN+3) DO 83 I1=NPLGN+1,NPLGN+3 IF ((IRAM(I1).LE.0).OR.(IRAM(I1).GT.NVRTX/NQ)) THEN C TRGLPS-08 WRITE(TEXT,'(A,I6)')'TRGLPS-08: Wrong vertex index',IRAM(I1) CALL ERROR(TEXT(1:LENGTH(TEXT))) ENDIF 83 CONTINUE NPLGN=NPLGN+3 GOTO 82 89 CONTINUE CLOSE(LU) C C C Reading colours of undefined values: CALL RSEP3R('R',R,0.8) CALL RSEP3R('G',G,0.8) CALL RSEP3R('B',B,0.8) C Determining the colour map: IF (KOLSRF.GT.0) THEN CALL COLOR1(LU,MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,CMIN,CMAX) ENDIF C C Writing PostScript prolog: WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+TRGLPS: Writing ',FOUT(1:MIN0(LEN(FOUT),63)) OPEN(LU,FILE=FOUT) WRITE(LU,'(A/A,4I6,/(A))') *'%!PS-Adobe-3.0', *'%%BoundingBox:',INT(BBOX1+.5),INT(BBOX2+.5), * INT(BBOX3+.5),INT(BBOX4+.5), *'%%EndComments', *'%%BeginProlog', *'%%BeginProcSet: (trglps)', *'%%Creator: trglps', *'%-----------------------------------------------------------', *'/C {setrgbcolor} bind def', *'/M {moveto} bind def', *'/L {lineto} bind def', *'/F {lineto closepath fill} bind def', *'%-----------------------------------------------------------', *'%%EndProcSet', *'%%EndProlog', *'%-----------------------------------------------------------', *'%%BeginSetup', *'% Numerical values describing the image size and position:' cc WRITE(LU,'(A,F8.1,A,F8.3,A)') '/BB1',BB1P,' def %',BB1,'cm' cc WRITE(LU,'(A,F8.1,A,F8.3,A)') '/BB2',BB2P,' def %',BB2,'cm' cc WRITE(LU,'(A,F8.1,A,F8.3,A)') '/BB3',BB3P,' def %',BB3,'cm' cc WRITE(LU,'(A,F8.1,A,F8.3,A)') '/BB4',BB4P,' def %',BB4,'cm' WRITE(LU,'(A,F8.1,A)') '/PAPERSIZE',HEIGHT*UNITPT,' def' WRITE(LU,'(A,F8.1,A)') '/ROTATE',ROTATE,' def' WRITE(LU,'(A)') *'%%EndSetup', *'%-----------------------------------------------------------', *'%%BeginObject: (trglps)', *'PAPERSIZE 2 div dup translate ROTATE rotate', *'PAPERSIZE -2 div dup translate', *'%-----------------------------------------------------------' C Setting colour of undefined values: WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' C C C Writing the triangles: CALL COLOR3(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1),1,I1,I2) I1=I1+NPLGN+2 CALL RSEP3R('VDIV',DC,RAM(I1)/256.) DC=ABS(DC) IF (DC.EQ.0.) THEN C TRGLPS-09 CALL ERROR('TRGLPS-09: Wrong value of VDIV') C VDIV must be nonzero. ENDIF FORMAT='(F00.0,A,F00.0,A,F00.0,A,F00.0,A,F00.0,A,F00.0,A:F00.0,A,F *00.0,A)' CALL FORM1(AMIN1(AINT(BBOX1+.5),AINT(BBOX2+.5)), * AMAX1(AINT(BBOX3+.5),AINT(BBOX4+.5)),FORMAT(2:9)) FORMAT(11:14)=FORMAT(3:6) FORMAT(19:22)=FORMAT(3:6) FORMAT(27:30)=FORMAT(3:6) FORMAT(35:38)=FORMAT(3:6) FORMAT(43:46)=FORMAT(3:6) FORMAT(51:54)=FORMAT(3:6) FORMAT(59:62)=FORMAT(3:6) C Plotting undefined values: WRITE(LU,FORMAT) B1,' ',B2,' M ',B1,' ',B4,' L ', * B3,' ',B4,' L ',B3,' ',B2,' F' DO 99, I2=NVRTX+1,NPLGN,3 JX1=(IRAM(I2)-1)*3+1 JY1=JX1+1 JC1=JY1+1 JX2=(IRAM(I2+1)-1)*3+1 JY2=JX2+1 JC2=JY2+1 JX3=(IRAM(I2+2)-1)*3+1 JY3=JX3+1 JC3=JY3+1 IF (KOLSRF.GT.0) THEN C Ordering the vertices according to the colour: IF (RAM(JC1).GT.RAM(JC2)) CALL CHANGE(JX1,JY1,JC1,JX2,JY2,JC2) IF (RAM(JC2).GT.RAM(JC3)) CALL CHANGE(JX2,JY2,JC2,JX3,JY3,JC3) IF (RAM(JC1).GT.RAM(JC2)) CALL CHANGE(JX1,JY1,JC1,JX2,JY2,JC2) DC2=RAM(JC2)-RAM(JC1) DC3=RAM(JC3)-RAM(JC1) DC4=RAM(JC3)-RAM(JC2) IF (DC3.LE.DC) THEN C Writing the whole triangle: COLOR=(RAM(JC3)+RAM(JC1))/2. CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' WRITE(LU,FORMAT) RAM(JX1),' ',RAM(JY1),' M ', * RAM(JX2),' ',RAM(JY2),' L ',RAM(JX3),' ',RAM(JY3),' F' ELSE DX2=RAM(JX2)-RAM(JX1) DY2=RAM(JY2)-RAM(JY1) DX3=RAM(JX3)-RAM(JX1) DY3=RAM(JY3)-RAM(JY1) DX4=RAM(JX3)-RAM(JX2) DY4=RAM(JY3)-RAM(JY2) IF (DC2.LE.DC) THEN C Writing the whole first part of the triangle: COLOR=(RAM(JC2)+RAM(JC1))/2. CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' X2B=RAM(JX2) Y2B=RAM(JY2) X3B=RAM(JX1)+DC2/DC3*DX3 Y3B=RAM(JY1)+DC2/DC3*DY3 WRITE(LU,FORMAT) RAM(JX1),' ',RAM(JY1),' M ', * X2B,' ',Y2B,' L ',X3B,' ',Y3B,' F' ELSE C Writing the first part of the triangle by parts: COLOR=RAM(JC1)+DC/2. CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' X2B=RAM(JX1)+DC/DC2*DX2 Y2B=RAM(JY1)+DC/DC2*DY2 X3B=RAM(JX1)+DC/DC3*DX3 Y3B=RAM(JY1)+DC/DC3*DY3 WRITE(LU,FORMAT) RAM(JX1),' ',RAM(JY1),' M ', * X2B,' ',Y2B,' L ',X3B,' ',Y3B,' F' DO 92, I1=1,INT(DC2/DC)-1 COLOR=COLOR+DC CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' X2A=X2B Y2A=Y2B X3A=X3B Y3A=Y3B X2B=X2B+DC/DC2*DX2 Y2B=Y2B+DC/DC2*DY2 X3B=X3B+DC/DC3*DX3 Y3B=Y3B+DC/DC3*DY3 WRITE(LU,FORMAT) X3A,' ',Y3A,' M ',X2A,' ',Y2A,' L ', * X2B,' ',Y2B,' L ',X3B,' ',Y3B,' F' 92 CONTINUE COLOR=(COLOR+DC/2. + RAM(JC2))/2. CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' X2A=X2B Y2A=Y2B X3A=X3B Y3A=Y3B X2B=RAM(JX2) Y2B=RAM(JY2) X3B=RAM(JX1)+DC2/DC3*DX3 Y3B=RAM(JY1)+DC2/DC3*DY3 WRITE(LU,FORMAT) X3A,' ',Y3A,' M ',X2A,' ',Y2A,' L ', * X2B,' ',Y2B,' L ',X3B,' ',Y3B,' F' ENDIF IF (DC4.LE.DC) THEN C Writing the whole second part of the triangle: COLOR=(RAM(JC3)+RAM(JC2))/2. CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' WRITE(LU,FORMAT) RAM(JX3),' ',RAM(JY3),' M ', * X2B,' ',Y2B,' L ',X3B,' ',Y3B,' F' ELSE C Writing the second part of the triangle by parts: COLOR=RAM(JC2)+DC/2. CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' X2A=X2B Y2A=Y2B X3A=X3B Y3A=Y3B X2B=X2B+DC/DC4*DX4 Y2B=Y2B+DC/DC4*DY4 X3B=X3B+DC/DC3*DX3 Y3B=Y3B+DC/DC3*DY3 WRITE(LU,FORMAT) X3A,' ',Y3A,' M ',X2A,' ',Y2A,' L ', * X2B,' ',Y2B,' L ',X3B,' ',Y3B,' F' DO 94, I1=1,INT(DC4/DC)-1 COLOR=COLOR+DC CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' X2A=X2B Y2A=Y2B X3A=X3B Y3A=Y3B X2B=X2B+DC/DC4*DX4 Y2B=Y2B+DC/DC4*DY4 X3B=X3B+DC/DC3*DX3 Y3B=Y3B+DC/DC3*DY3 WRITE(LU,FORMAT) X3A,' ',Y3A,' M ',X2A,' ',Y2A,' L ', * X2B,' ',Y2B,' L ',X3B,' ',Y3B,' F' 94 CONTINUE COLOR=(COLOR+DC/2. + RAM(JC3))/2. CALL COLOR2(MRAM-NPLGN,IRAM(NPLGN+1),RAM(NPLGN+1), * 1,COLOR,R,G,B) WRITE(LU,'(3(F4.2,A))') R,' ',G,' ',B,' C ' X2A=X2B Y2A=Y2B X3A=X3B Y3A=Y3B X2B=RAM(JX3) Y2B=RAM(JY3) WRITE(LU,FORMAT) X3A,' ',Y3A,' M ',X2A,' ',Y2A,' L ', * X2B,' ',Y2B,' F ' ENDIF ENDIF ELSE C Writing the vertices of the triangle: WRITE(LU,FORMAT) RAM(JX1),' ',RAM(JY1),' M ', * RAM(JX2),' ',RAM(JY2),' L ',RAM(JX3),' ',RAM(JY3),' F' ENDIF 99 CONTINUE C C C Writing PostScript trailer: WRITE(LU,'(A)') *'PAPERSIZE 2 div dup translate ROTATE neg rotate', *'PAPERSIZE -2 div dup translate', *'%%EndObject', *'showpage', *'%%EOF' CLOSE(LU) C WRITE(*,'(''+'',79('' ''))') WRITE(*,'(A)') '+TRGLPS: Done.' C STOP END C----------------------------------------------------------------------- SUBROUTINE CHANGE(I,J,K,L,M,N) INTEGER I,J,K,L,M,N,IA,JA,KA IA=I JA=J KA=K I=L J=M K=N L=IA M=JA N=KA RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'colors.for' C colors.for INCLUDE 'length.for' C length.for C C======================================================================= Ctrglsort.for 0100666 0000765 0000765 00000035327 10062244274 013034 0 ustar bulant bulant C
C Program TRGLSORT to sort triangles according to values at its vertices C C Version: 5.80 C Date: 2004, June 11 C C Coded by: Petr Bulant C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bulant@seis.karlov.mff.cuni.cz C C....................................................................... C This program reads file TRGL with triangles and the corresponding C file VRTX with coordinates of the vertices of the triangles. C The triangles are sorted into three output files TRGLN, TRGLN1 and C TRGLN2 according one of the following criteria: C C If KOLUMN and VALUE are given: C The program compares the values in KOLUMN-th column of file VRTX C with the value VALUE. The triangles with the values in all their C vertices equal to VALUE are written to files TRGLN and VRTXN. C The triangles with the values in all their vertices less than VALUE C are written to files TRGLN1 and VRTXN1. C Remaining triangles are written to files TRGLN2 and VRTXN2. C This option may be used, e.g., to separate triangles corresponding C to given interface, or to separate triangles according to the C coordinates of their vertices. C C If KOLUM1 and KOLUM2 are given: C The program computes for each triangle the absolute value of C the sum of values in column KOLUM1 and absolute value of the sum C of values in column KOLUM2 of file VRTX. Triangles with C sum corresponding to column KOLUM1 equal the sum corresponding C to column KOLUM2 are written to file TRGLN and their vertices to C file VRTXN. Triangles with sum corresponding to column KOLUM1 less C then sum corresponding to column KOLUM2 are written to file TRGLN1 C and their vertices to file VRTXN1. Remaining triangles and their C vertices are written to files TRGLN2 and VRTXN2. C This option may be used, e.g., to sort the triangles according C to their distances from two interfaces. The distances must be C calculated in advance by program 'intf.for', and written to columns C KOLUM1 and KOLUM2 of the corresponding files. C C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C VRTX='string'... Name of the file with vertices of the triangles. C Description of file VRTX C Default: VRTX='vrtx.out' C TRGL='string'... Name of the file with the triangles. C Description of file TRGL C Default: TRGL='trgl.out' C Data for sorting of the triangles: C KOLUMN=integer, KOLUM1=integer, KOLUM2=integer... Indices C of columns in input file VRTX, which contain the values, C according which the triangles are to be sorted. C Default: KOLUMN=0, KOLUM1=0, KOLUM2=0 C VALUE=real ... Value according which the triangles are C to be sorted. C Default: VALUE=UNDEF C For the value of UNDEF see below. C Either KOLUMN and VALUE, or KOLUM1 and KOLUM2 must be specified, C (i.e. one pair of parameters must be specified, specification of C both pairs of parameters results in error). C Data specifying output files: C VRTXN='string',VRTXN1='string',VRTXN2='string' ... C Names of the output files with vertices of triangles. C If blank, files are not generated. C Description of files VRTXNi C Default: VRTXN=' ', VRTXN1=' ', VRTXN2=' ' C TRGLN='string',TRGLN1='string',TRGLN2='string' ... C Names of the output files with the triangles. C If blank, files are not generated. C Description of files TRGLNi C Default: TRGLN=' ', TRGLN1=' ', TRGLN2=' ' C C C Input file VRTX with the vertices: C (1) None to several strings terminated by / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,R1,R2,/ C 'NAME'... Name of the vertex. Not considered. May be blank. C X1,X2,X3... Coordinates of the vertex. C R1,R2,/ ... None to several values terminated by a slash. C Number of values should be the same for all the vertices. C (3) / or end of file. C C C Input file TRGL with the triangles: C (1) For each triangle data (1.1): C (1.1) I1,I2,I3,/ C I1,I2,I3... Indices of 3 vertices of the triangle. C The vertices in file VRTX are indexed by positive integers C according to their order. C /... List of vertices of the triangle is terminated by a slash. C C C Output files VRTXN, VRTXN1 and VRTXN2 with the vertices: C (1) / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,R1,R2,/ C 'NAME'..Name of the vertex. String in apostrophes containing C the index of the vertex corresponding to file TRGLN, C TRGLN1 or TRGLN2. C X1,X2,X3,R1,R2,/ ... Unchanged values from the file VRTX. C (3) / (a slash) C C C Output files TRGLN, TRGLN1 and TRGLN2 with the triangles: C (1) For each triangle data (1.1): C (1.1) I1,I2,I3,/ C I1,I2,I3... Indices of 3 vertices of the triangle. C The vertices in corresponding file VRTXN, VRTXN1 or VRTXN2 C are indexed by positive integers according to their order. C /... List of vertices of the triangle is terminated by a slash. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C EXTERNAL LENGTH,ERROR,FORM1,WARN,RSEP1,RSEP3T,RSEP3R,RSEP3I INTEGER LENGTH C C....................................................................... C C Auxiliary storage locations: INTEGER LU,IUNDEF,NOUT PARAMETER (LU=1,IUNDEF=-999999,NOUT=3) REAL UNDEF PARAMETER (UNDEF=9.9E9) CHARACTER*80 FSEP,FVRTXO,FTRGLO,FVRTXN(NOUT),FTRGLN(NOUT) CHARACTER*10 FORMA1 CHARACTER*26 FORMA2 CHARACTER*80 TEXT INTEGER NVRTX,NTRGL,I,I1,I2,I3,J1,J2,J3,NQ INTEGER KOLUMN,KOLUM1,KOLUM2 REAL A1,A2,A3,B1,B2,B3,W1,W2,OUTMIN,OUTMAX,VALUE C C NVRTX...Last storage location with the vertices, C i.e. NQ+NOUT times the number of vertices. C NTRGL...Last storage location with triangles, C i.e. NVRTX + 3+NOUT times the number of triangles. C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+TRGLSORT: Enter input filename: ' FSEP=' ' READ (*,*) FSEP WRITE(*,'(A)') '+TRGLSORT: Working... ' C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C TRGLSORT-01 CALL ERROR('TRGLSORT-01: SEP file not given') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. ENDIF C C Reading input and output filenames: CALL RSEP3T('VRTX',FVRTXO,'vrtx.out') CALL RSEP3T('TRGL',FTRGLO,'trgl.out') CALL RSEP3T('VRTXN', FVRTXN(1),' ') CALL RSEP3T('VRTXN1',FVRTXN(2),' ') CALL RSEP3T('VRTXN2',FVRTXN(3),' ') CALL RSEP3T('TRGLN', FTRGLN(1),' ') CALL RSEP3T('TRGLN1',FTRGLN(2),' ') CALL RSEP3T('TRGLN2',FTRGLN(3),' ') C C Reading the columns with the values and the limits of coordinates: CALL RSEP3I('KOLUMN',KOLUMN,0) CALL RSEP3R('VALUE',VALUE,UNDEF) CALL RSEP3I('KOLUM1',KOLUM1,0) CALL RSEP3I('KOLUM2',KOLUM2,0) IF ((.NOT.(((KOLUMN.NE.0).AND.(VALUE.NE.UNDEF)).OR. * ((KOLUM1.NE.0).AND.(KOLUM2.NE.0 )))) .OR. * ( (((KOLUMN.NE.0).AND.(VALUE.NE.UNDEF)).AND. * ((KOLUM1.NE.0).AND.(KOLUM2.NE.0 ))))) THEN C TRGLSORT-02 CALL ERROR('TRGLSORT-02: Wrong sorting criterion.') C Either KOLUMN and VALUE, or KOLUM1 and KOLUM2 must be specified, C see input data. ENDIF C C Reading vertices: OPEN(LU,FILE=FVRTXO,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) DO 2, I=1,MRAM RAM(I)=UNDEF 2 CONTINUE TEXT='$' READ(LU,*,END=18) TEXT,(RAM(I),I=1,MRAM) IF(TEXT.EQ.'$') GO TO 18 NQ=0 DO 4, I=MRAM,1,-1 IF (RAM(I).NE.UNDEF) THEN NQ=I GOTO 5 ENDIF 4 CONTINUE 5 CONTINUE IF (NQ.LT.MAX0(KOLUM1,KOLUM2)) THEN C TRGLSORT-03 CALL ERROR('TRGLSORT-03: Missing values in file VRTX') C Each line of file VRTX must contain at least MAX(KOLUM1,KOLUM2) C quantities. ENDIF CLOSE(LU) OPEN(LU,FILE=FVRTXO,STATUS='OLD') READ(LU,*) (TEXT,I=1,20) NVRTX=0 10 CONTINUE IF(NVRTX+NQ+NOUT.GT.MRAM) THEN C TRGLSORT-04 CALL ERROR('TRGLSORT-04: Too small array RAM') END IF TEXT='$' READ(LU,*,END=18) TEXT,(RAM(I),I=NVRTX+1,NVRTX+NQ) IF(TEXT.EQ.'$') THEN GO TO 18 END IF DO 16, I=1,NOUT IRAM(NVRTX+NQ+I)=IUNDEF 16 CONTINUE NVRTX=NVRTX+NQ+NOUT GO TO 10 18 CONTINUE CLOSE(LU) C C Reading triangles: DO 19 I=NVRTX+1,MRAM IRAM(I)=IUNDEF 19 CONTINUE OPEN(LU,FILE=FTRGLO,STATUS='OLD') NTRGL=NVRTX 20 CONTINUE IF (NTRGL+3+NOUT.GT.MRAM) THEN C TRGLSORT-05 CALL ERROR('TRGLSORT-05: Too small array RAM') ENDIF READ(LU,*,END=22) (IRAM(I),I=NTRGL+1,NTRGL+3) NTRGL=NTRGL+3+NOUT GOTO 20 22 CONTINUE CLOSE(LU) C C Sorting the triangles: DO 30, I1=NVRTX,NTRGL-3-NOUT,3+NOUT J1=(NQ+NOUT)*(IRAM(I1+1)-1) J2=(NQ+NOUT)*(IRAM(I1+2)-1) J3=(NQ+NOUT)*(IRAM(I1+3)-1) W1=0. W2=0. IF ((KOLUM1.NE.0).AND.(KOLUM2.NE.0)) THEN A1=RAM(J1+KOLUM1) A2=RAM(J2+KOLUM1) A3=RAM(J3+KOLUM1) B1=RAM(J1+KOLUM2) B2=RAM(J2+KOLUM2) B3=RAM(J3+KOLUM2) W1=ABS(A1+A2+A3) W2=ABS(B1+B2+B3) ELSE A1=RAM(J1+KOLUMN) A2=RAM(J2+KOLUMN) A3=RAM(J3+KOLUMN) IF ((A1.EQ.VALUE).AND.(A2.EQ.VALUE).AND.(A3.EQ.VALUE)) THEN CONTINUE ELSEIF((A1.LT.VALUE).AND.(A2.LT.VALUE).AND.(A3.LT.VALUE)) THEN W2=1. ELSE W1=1. ENDIF ENDIF IF (W1.EQ.W2) THEN IRAM(I1+3+1)=1 IRAM(J1+NQ+1)=1 IRAM(J2+NQ+1)=1 IRAM(J3+NQ+1)=1 ELSEIF (W1.LT.W2) THEN IRAM(I1+3+2)=1 IRAM(J1+NQ+2)=1 IRAM(J2+NQ+2)=1 IRAM(J3+NQ+2)=1 ELSE IRAM(I1+3+3)=1 IRAM(J1+NQ+3)=1 IRAM(J2+NQ+3)=1 IRAM(J3+NQ+3)=1 ENDIF 30 CONTINUE C C Output format for the output files: FORMA1='(99(I0,A))' FORMA2='(A,1I0.0,A,00(F00.0,1X),A)' I=INT(ALOG10(FLOAT(NVRTX/(NQ+NOUT))))+1 IF (I.GT.9) THEN C TRGLSORT-06 CALL ERROR('TRGLSORT-06: Too many vertices in file VRTX') C This format specification allows for maximum of 100 000 000 C of vertices in file VRTX ENDIF FORMA1(6:6)=CHAR(ICHAR('0')+I) FORMA2(6:6)=FORMA1(6:6) FORMA2(8:8)=FORMA1(6:6) FORMA2(13:13)=CHAR(ICHAR('0')+MOD(NQ/1,10)) FORMA2(12:12)=CHAR(ICHAR('0')+MOD(NQ/10,10)) C C Indices of the vertices in the output files: DO 40, I1=1,NOUT I3=0 DO 39, I2=NQ,NVRTX-NOUT,NQ+NOUT IF (IRAM(I2+I1).EQ.1) THEN I3=I3+1 IRAM(I2+I1)=I3 ENDIF 39 CONTINUE 40 CONTINUE C C Writing the output files: DO 60, I1=1,3 C Writing the vertices: IF (FVRTXN(I1).NE.' ') THEN OPEN(LU,FILE=FVRTXN(I1)) WRITE(LU,'(A)') '/' DO 44, I2=0,NVRTX-NQ-NOUT,NQ+NOUT I3=IRAM(I2+NQ+I1) IF (I3.NE.IUNDEF) THEN OUTMIN=0. OUTMAX=0. DO 42, I=I2+1,I2+NQ IF(RAM(I).LT.OUTMIN) OUTMIN=RAM(I) IF(RAM(I).GT.OUTMAX) OUTMAX=RAM(I) 42 CONTINUE CALL FORM1(OUTMIN,OUTMAX,FORMA2(15:22)) FORMA2(21:24)= '1X),' WRITE(LU,FORMA2) * ' ''',I3,''' ',(RAM(I2+I),I=1,NQ),'/' ENDIF 44 CONTINUE WRITE(LU,'(A)') '/' CLOSE(LU) ENDIF C Writing the triangles: IF (FTRGLN(I1).NE.' ') THEN OPEN(LU,FILE=FTRGLN(I1)) DO 52, I2=NVRTX,NTRGL-3-NOUT,3+NOUT I3=IRAM(I2+3+I1) IF (I3.NE.IUNDEF) THEN WRITE(LU,FORMA1) IRAM((NQ+NOUT)*(IRAM(I2+1)-1)+NQ+I1),' ', * IRAM((NQ+NOUT)*(IRAM(I2+2)-1)+NQ+I1),' ', * IRAM((NQ+NOUT)*(IRAM(I2+3)-1)+NQ+I1),' /' ENDIF 52 CONTINUE CLOSE(LU) ENDIF 60 CONTINUE C WRITE(*,'(A)') '+TRGLSORT: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Ctrsmsm.for 0100666 0000765 0000765 00000014061 07277147410 012501 0 ustar bulant bulant C
C Program TRSMSM to compute trace tr(SM1*SM2) of the product of two C symmetric matrices SM1 and SM2 C C Version: 5.50 C Date: 2001, May 12 C C Coded by Petr Bulant and Ludek Klimes C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mails: bulant@seis.karlov.mff.cuni.cz C klimes@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying dimensions of the matrices: C M1='string'... Name of the file containing a single integer number C specifying the number of rows (and columns) of symmetric C matrices SM1 and SM2. C Default: M1=' ' means that the number is 1. C Filenames of the files with the matrices: C SM1='string'... Name of the input file containing matrix SM1. C No default, SM1 must be specified and cannot be blank. C SM2='string'... Name of the input file containing matrix SM2. C No default, SM2 must be specified and cannot be blank. C TRACE='string'... Name of the output file containing a single C value, trace tr(SM1*SM2) of the product of two symmetric C matrices SM1 and SM2. C No default, TRACE must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string'... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string'... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string'... Form of the files with matrices to be written. C Default: FORMMW=FORMM C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File sep.for. C RMAT,WMAT ... File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3 INTEGER LU1,M1,NN,I1,I2,I PARAMETER (LU1=1) REAL TRACE C C----------------------------------------------------------------------- C C Reading a name of the file with the input data: FILSEP=' ' WRITE(*,'(A)') '+TRSMSM: Enter input filename: ' READ(*,*) FILSEP C C Reading all the data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU1,FILSEP) ELSE C TRSMSM-01 CALL ERROR('TRSMSM-01: SEP file not given') ENDIF C C Reading the dimension of the matrices: CALL RSEP3T('M1',FILE1,' ') IF (FILE1.EQ.' ') THEN M1=1 ELSE OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) ENDIF NN=M1*(M1+1)/2 C IF (2*NN.GT.MRAM) THEN C TRSMSM-02 CALL ERROR('TRSMSM-02: Small dimension MRAM of array RAM') END IF C C Reading the names of the files with the matrices: CALL RSEP3T('SM1',FILE1,' ') CALL RSEP3T('SM2',FILE2,' ') CALL RSEP3T('TRACE',FILE3,' ') IF (FILE1.EQ.' ') THEN C TRSMSM-03 CALL ERROR('TRSMSM-03: Input file with matrix SM1 not given') ENDIF IF (FILE2.EQ.' ') THEN C TRSMSM-04 CALL ERROR('TRSMSM-04: Input file with matrix SM2 not given') ENDIF IF (FILE3.EQ.' ') THEN C TRSMSM-05 CALL ERROR('TRSMSM-05: Output filename TRACE not specified') ENDIF C C Reading input matrices: CALL RMAT(LU1,FILE1,M1,0,RAM) CALL RMAT(LU1,FILE2,M1,0,RAM(NN+1)) C WRITE(*,'(A)') '+TRSMSM: Working... ' C C Calculating the trace: TRACE=0. I=0 C Loop over columns: DO 12, I2=1,M1 C Loop over rows: DO 11, I1=1,I2-1 I=I+1 TRACE=TRACE+2.*RAM(I)*RAM(NN+I) 11 CONTINUE I=I+1 TRACE=TRACE+RAM(I)*RAM(NN+I) 12 CONTINUE C C Writing output file TRACE: RAM(1)=TRACE IF (FILE3.NE.' ') THEN CALL WMAT(LU1,FILE3,1,1,RAM) ENDIF WRITE(*,'(A)') '+TRSMSM: Done. ' C STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Ctsurf.for 0100666 0000765 0000765 00000017634 10062244274 012320 0 ustar bulant bulant C
C Program to convert GOCAD triangulated surfaces into a file with points C and a file with triangles C C Version: 5.80 C Date: 2004, June 11 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 Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying input files: C TSURF='string'... Name of the file with GOCAD triangulated C surfaces. C Description of file TSURF C No default, TSURF must be specified. C Data specifying output files: C VRTX='string'... Name of the file with vertices of the polygons. C If the filename is blank, the file is not generated. C Description of file VRTX C Default: VRTX='vrtx.out' C PLGNS='string'... Name of the file describing the triangles. C If the filename is blank, the file is not generated. C Description of file PLGNS C Default: PLGNS='trgl.out' C Optional data to shift the triangles: C SHIFT1=real, SHIFT2=real, SHIFT3=real... All triangle vertices C will be shifted by vector (SHIFT1,SHIFT2,SHIFT3). C SHIFT1=0., SHIFT2=0., SHIFT3=0. C C C Input file TSURF with the GOCAD triangulated surfaces: C The file consists of lines (1) and lines (2): C For each vertex: C (1) VRTX,NAME,X1,X2,X3 C VRTX... String VRTX without apostrophes. C NAME... Index of the vertex (integer). C X1,X2,X3... Coordinates of the vertex. C For each triangle: C (2) TRGL,NAME1,NAME2,NAME3 C TRGL... String TRGL without apostrophes. C NAME1,NAME2,NAME3... Indices of the vertices of the triangle C (integers). C C C Output file VRTX with the vertices: C (1) / (a slash) C (2) For each vertex data (2.1): C (2.1) 'NAME',X1,X2,X3,/ C 'NAME'..Name of the vertex. String in apostrophes containing C the index of the vertex. C X1,X2,X3... Coordinates of the vertex. C /... A slash. C (3) / (a slash followed by a comment) C (4) / (a slash followed by a comment) C C C Output file PLGNS with the triangles: C For each triangle data (1): C (1) 'NAME1','NAME2','NAME3',/ C 'NAME1','NAME2','NAME3'... Names of the vertices. Strings in C apostrophes containing the indices of the vertices. C /... List of vertices is terminated by a slash. C C======================================================================= C CHARACTER*80 FILE,FVRTX,FTRGL INTEGER LU1,LU2,LU3,LU4 PARAMETER (LU1=1,LU2=2,LU3=3,LU4=4) CHARACTER*4 KEY CHARACTER*76 LINE CHARACTER*34 FORMAT INTEGER I0,I1,I2,I3 REAL SHIFT1,SHIFT2,SHIFT3 REAL X(3),X1,X2,X3,X1MIN,X1MAX,X2MIN,X2MAX,X3MIN,X3MAX EQUIVALENCE (X(1),X1),(X(2),X2),(X(3),X3) C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+TSURF: Enter input filename: ' FILE=' ' READ (*,*) FILE IF(FILE.EQ.' ') THEN C TSURF-01 CALL ERROR('TSURF-01: No input file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF WRITE(*,'(A)') '+TSURF: Working... ' C C Opening input and output files: CALL RSEP1(LU1,FILE) CALL RSEP3T('TSURF',FILE ,' ') IF(FILE.EQ.' ') THEN C TSURF-02 CALL ERROR('TSURF-02: No GOCAD file specified') C Input file TSURF with the GOCAD triangulated surfaces must be C specified. C There is no default filename. END IF CALL RSEP3T('VRTX' ,FVRTX,'vrtx.out') CALL RSEP3T('PLGNS',FTRGL,'trgl.out') OPEN(LU1,FILE=FILE,STATUS='OLD') IF(FVRTX.NE.' ') THEN OPEN(LU2,FILE=FVRTX) WRITE(LU2,'(A)') '/' END IF IF(FTRGL.NE.' ') THEN OPEN(LU3,FILE=FTRGL) END IF C C Optional shift: CALL RSEP3R('SHIFT1',SHIFT1,0.) CALL RSEP3R('SHIFT2',SHIFT2,0.) CALL RSEP3R('SHIFT3',SHIFT3,0.) C C Preparation for the loop over lines of the input GOCAD file OPEN(LU4,STATUS='SCRATCH') FORMAT(1:10)='(A,I6.6,A,' NPTS=0 C C Loop over lines of the input GOCAD file with the TSURF object 10 CONTINUE READ(LU1,'(2A)',END=90) KEY,LINE WRITE(LU4,'(A)') LINE BACKSPACE(LU4) IF(KEY.EQ.'VRTX') THEN C Writing the vertex IF(FVRTX.NE.' ') THEN READ(LU4,*) I0,X1,X2,X3 X1=X1+SHIFT1 X2=X2+SHIFT2 X3=X3+SHIFT3 IF(NPTS.EQ.0) THEN X1MIN=X1 X2MIN=X2 X3MIN=X3 X1MAX=X1 X2MAX=X2 X3MAX=X3 ELSE X1MIN=AMIN1(X1,X1MIN) X2MIN=AMIN1(X2,X2MIN) X3MIN=AMIN1(X3,X3MIN) X1MAX=AMAX1(X1,X1MAX) X2MAX=AMAX1(X2,X2MAX) X3MAX=AMAX1(X3,X3MAX) END IF NPTS=NPTS+1 CALL FORM2(3,X,X,FORMAT(11:34)) WRITE(LU2,FORMAT) '''',I0,''' ',X1,' ',X2,' ',X3,' /' END IF ELSE IF(KEY.EQ.'TRGL') THEN C Writing the triangle IF(FTRGL.NE.' ') THEN READ(LU4,*) I1,I2,I3 WRITE(LU3,'(4(A,I6.6))')'''',I1,''' ''',I2,''' ''',I3,''' /' END IF ELSE C TSURF-03 CALL ERROR('TSURF-03: Unexpected key string') C Only key strings VRTX and TRGL may be used in the input GOCAD C file. END IF GO TO 10 C C Closing input and output files: 90 CONTINUE CLOSE(LU1) IF(FVRTX.NE.' ') THEN FORMAT(1:10)='(A, ' X1=X1MIN X2=X2MIN X3=X3MIN CALL FORM2(3,X,X,FORMAT(11:34)) WRITE(LU2,FORMAT) '/ Minimum coordinates: ',X1,' ',X2,' ',X3 X1=X1MAX X2=X2MAX X3=X3MAX CALL FORM2(3,X,X,FORMAT(11:34)) WRITE(LU2,FORMAT) '/ Maximum coordinates: ',X1,' ',X2,' ',X3 CLOSE(LU2) END IF IF(FTRGL.NE.' ') THEN CLOSE(LU3) END IF CLOSE(LU4) WRITE(*,'(A)') '+TSURF: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for C C======================================================================= Cwrl.for 0100666 0000765 0000765 00000015357 07216057610 011764 0 ustar bulant bulant C
C Subroutine file 'wrl.for' to facilitate writing VRML, GOCAD or POV C files C C Version: 5.50 C Date: 2000, December 14 C C....................................................................... C C This file consists of the following external procedures: C WRL1... Subroutine designed to write the beginning of the output C VRML, GOCAD or POV file. C WRL1 C C======================================================================= C C C SUBROUTINE WRL1(LU1,LU2,FILE1,FILE2,VRML,ICHECK) INTEGER LU1,LU2,ICHECK CHARACTER*(*) FILE1,FILE2,VRML C C Subroutine designed to write the beginning of the output VRML, GOCAD C or POV file. C C Input: C LU1... Logical unit number to be used for a possible input. C LU2... Logical unit number connected to output file FILE2. C FILE1...Possible input filename. If FILE1 is blank, the header C will be written to FILE2. If FILE1 is equal to FILE2, C FILE2 will be positioned at its end. Otherwise, file C FILE1 will be opened, the content of file FILE1 will be C copied to the output file, and file FILE1 will be closed. C FILE2...Output filename. The file has to be open. C VRML... Form of the output file: either 'vrml1', 'vrml2', 'gocad' C or 'pov'. C ICHECK..ICHECK.EQ.0: No check of the GOCAD object name. C ICHECK.NE.0: Check of the GOCAD object name. C Used only if VRML='gocad'. C C No output. C C Date: 2000, December 14 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C External function: EXTERNAL LENGTH INTEGER LENGTH C C Other variables: CHARACTER*255 TEXT,NAME LOGICAL LNAME INTEGER I,J C TEXT... Used to copy lines from input WRL to output WRL file. C C....................................................................... C C Opening the output file: IF (FILE2.EQ.' ') THEN C WRL-01 CALL ERROR('WRL-01: No output virtual reality file') C Name of the output file of program C 'iniwrl.for', C 'ptswrl.for', C 'linwrl.for', C 'srfwrl.for' or C 'grdwrl.for' has not been specified C in the input SEP parameter file. END IF OPEN(LU2,FILE=FILE2) C C Checking the GOCAD object name: IF (VRML.EQ.'gocad'.AND.ICHECK.NE.0) THEN LNAME=.TRUE. ELSE LNAME=.FALSE. END IF IF (LNAME) THEN CALL RSEP3T('NAME',NAME,' ') IF (NAME.EQ.' ') THEN C WRL-02 CALL ERROR('WRL-02: No name of GOCAD object') C Name of each GOCAD object must be specified by input SEP C parameter NAME. C All objects within the GOCAD file must have different names, C specified by input SEP parameter NAME. C Please, check the values of parameter NAME for each execution C of programs C 'ptswrl.for', C 'linwrl.for', C 'srfwrl.for' or C 'grdwrl.for' in the history file. END IF END IF C C Writing the output file: IF (FILE1.EQ.' ') THEN C Writing the beginning a new file: IF (VRML.EQ.'vrml1') THEN WRITE(LU2,'(A)') '#VRML V1.0 ascii' ELSE IF (VRML.EQ.'vrml2') THEN WRITE(LU2,'(A)') '#VRML V2.0 utf8' ELSE IF (VRML.EQ.'gocad') THEN WRITE(LU2,'(A)') * '#GOCAD format (generated by SW3D package FORMS)' ELSE IF (VRML.EQ.'pov') THEN WRITE(LU2,'(A)') '//POV 3.1' END IF ELSE IF (FILE1.EQ.FILE2) THEN C Output is appended to the input file: 11 CONTINUE READ(LU2,'(A)',END=12) TEXT IF (LNAME) THEN C Check for the uniqueness of the GOCAD object name I=INDEX(TEXT,'HDR name:') IF (I.GT.0) THEN J=INDEX(TEXT(I+9:),NAME(1:LENGTH(NAME))) IF (J.GT.0) THEN J=I+9+J+LENGTH(NAME) IF (TEXT(J:J).EQ.' ') THEN C WRL-03 CALL ERROR('WRL-03: Repeated GOCAD object name') C All objects within the GOCAD file must have different C names, specified by input SEP parameter NAME. C Please, check the values of parameter NAME for each C execution of programs C 'ptswrl.for', C 'linwrl.for', C 'srfwrl.for' or C 'grdwrl.for' in the C history file. END IF END IF END IF END IF GO TO 11 12 CONTINUE ELSE C Copying input file to the output file: OPEN(LU1,FILE=FILE1,STATUS='OLD') 13 CONTINUE READ(LU1,'(A)',END=14) TEXT WRITE(LU2,'(A)') TEXT(1:LENGTH(TEXT)) IF (LNAME) THEN C Check for the uniqueness of the GOCAD object name I=INDEX(TEXT,'HDR name:') IF (I.GT.0) THEN J=INDEX(TEXT(I+9:),NAME(1:LENGTH(NAME))) IF (J.GT.0) THEN J=I+9+J+LENGTH(NAME) IF (TEXT(J:J).EQ.' ') THEN C WRL-04 CALL ERROR('WRL-04: Repeated GOCAD object name') C All objects within the GOCAD file must have different C names, specified by input SEP parameter NAME. C Please, check the values of parameter NAME for each C execution of programs C 'ptswrl.for', C 'linwrl.for', C 'srfwrl.for' or C 'grdwrl.for' in the C history file. END IF END IF END IF END IF GO TO 13 14 CONTINUE CLOSE(LU1) END IF IF (FILE1.NE.' '.OR.VRML.NE.'gocad') THEN WRITE(LU2,'(A)') END IF RETURN END C C======================================================================= C